-- Let's first prove some simple example lemmas with the logical connectives we learned in the lecture.
section
-- Variables in sections determine the type of certain variables for the remainder of the section, saving us a bit of space.
variable (p q r : Prop)

example : p → p :=
  fun h => h

example : p → (q → p) :=
  fun hp => fun hq => hp -- similarly to the note below, we can elide parentheses around the inner `fun`

-- Note: `→` associates to the right, so the above proposition is equivalent to
-- `p → q → p`

example : (p → False) → (p → q) :=
  fun hnp hp => nomatch hnp hp  -- we can also combine nested `fun`s

example : (p ∨ p) → p :=
  fun hpp => match hpp with
    | Or.inl hp => hp
    | Or.inr hp => hp

example : (p → q → r) → (p ∧ q → r) :=
  fun h hpq => match hpq with
    | And.intro hp hq => h hp hq

example : (p ∧ q → r) → (p → q → r) :=
  fun h hp hq => h (And.intro hp hq)

example : p → (p → q) → p ∧ q :=
  -- For inductive types with a single constructor `I.c`, we can also use the
  -- *anonymous constructor* notation `⟨e, ...⟩` instead of `I.c e...`.
  -- Input `⟨` and `⟩` as `\<` and `\>`.
  fun hp h => ⟨hp, h hp⟩

theorem imp_and : (p → q ∧ r) → (p → q) ∧ (p → r) :=
  fun h => ⟨fun hp => match h hp with | And.intro hq hr => hq,
            fun hp => match h hp with | And.intro hq hr => hr⟩

-- Matching on `And.intro` can quickly become tedious, so you can use the following helper functions from now on:
#check And.left
#check And.right

/- BIIMPLICATION -/

-- Biimplication ("if and only if") is written \iff.
-- It is defined as a data type on the constructor
-- Iff.intro : (A → B) → (B → A) → (A ↔ B)
-- Can you recover the proof for A → B by a match expression?

example (hpq : p ↔ q) : (p → q) :=
  match hpq with
  | ⟨hmp, _⟩ => hmp
-- Note that we didn't have to give the second argument on the left side of `=>` since we do not use it.

-- Like for `And`, we have names for both directions of the biimplication:
#check Iff.mp
#check Iff.mpr

-- Prove the following biimplications using the threorem from above!
-- Note: `↔` is defined to bind less tightly than other connectives such as `∧` or `∨`.

theorem iff_and : (p → q ∧ r) ↔ (p → q) ∧ (p → r) :=
  -- If `h : p ∧ q`, we can also write `h.left` as a shorthand for `And.left h`.
  -- In general, if a term `e` has some type `A` and `A.f : A → ...` is a function,
  -- then `e.f` is a shorthand for `A.f e`.
  ⟨fun hpqr => ⟨fun hp => (hpqr hp).left, fun hp => (hpqr hp).right⟩,
   -- We can use "infallible" patterns such as anonymous constructors directly in place of a `fun` binder name
   -- This feature is a good way to make proofs shorter.
   fun ⟨hpq, hpr⟩ hp => ⟨hpq hp, hpr hp⟩⟩

theorem or_and : (p ∨ q → r) ↔ (p → r) ∧ (q → r) :=
  ⟨fun hpqr => ⟨fun hp => hpqr (Or.inl hp), fun hq => hpqr (Or.inr hq)⟩,
   fun hprqr =>
     -- `fun | ...` is short for `fun x => match x with | ...`
     fun
     | Or.inl hp => hprqr.left hp
     | Or.inr hq => hprqr.right hq⟩

theorem iff_and_false : False ↔ p ∧ False :=
  ⟨fun fa => nomatch fa, fun h => h.right⟩

/- NEGATION -/

-- Negation is defined by ¬ A := (A → False).
-- How is that a good choice? Let us check some basic properties of negation:
theorem imp_not_not : p → ¬¬p :=
  fun hp hnp => hnp hp

example : ¬(p ∧ ¬p) :=
  fun h => h.right h.left

theorem not_or_not : (¬p ∨ ¬q) → ¬(p ∧ q) :=
  fun hor ⟨hp, hq⟩ =>
    match hor with
    | Or.inl hnp => hnp hp
    | Or.inr hnq => hnq hq

-- The following ones are a harder to prove. Don't hesitate to skip them or ask your
-- tutors if you get stuck

example : ¬(p ↔ ¬p) :=
  fun h =>
    -- We can use `have` for a sub-proof so we don't have to repeat ourselves.
    -- `have` is generally nicer to use than `let` in the case of propositions.
    -- We have updated the slides to reflect this.
    have hp : p := h.2 (fun hp => h.1 hp hp)
    h.1 hp hp
-- Did you see that we used `.1` and `.2` instead of `.mp` and `.mpr`?
-- For single-constructor inductive types we can also use numbers to refer to their "fields", i.e. to
-- the arguments of the constructor.

example : ¬¬(¬¬p → p) :=
  fun nnnpp => nnnpp fun nnp => False.elim (nnp (fun hp => nnnpp fun _ => hp))
-- Using `False.elim` instead of `nomatch` makes for better output during the construction of the proof.
-- We have updated the slides to reflect this.

/- CLASSICAL AXIOMS -/

-- Some tautologies about negation cannot be proven by just assuming the logical
-- connectives as algebraic propositions. Instead, we need to assume these facts
-- as axioms. To have access to these, we need to open a namespace called "Classical".
-- We will learn more about constructive versus classical logic in week 5.
open Classical

-- The following statement is called the _law of excluded middle_.
-- It is assumed as an axiom, which means that it doesn't have to be proved.

#check em p

-- Now use the law of excluded middle to show that the theorem not_or_not is reversible:

theorem not_and : ¬(p ∧ q) → (¬ p ∨ ¬ q) :=
  fun hn =>
  match em p with
  | Or.inl hp  =>
    match em q with
    | Or.inl hq  => False.elim (hn ⟨hp, hq⟩)
    | Or.inr hnq => Or.inr hnq
  | Or.inr hnp => Or.inl hnp
-- You can see in the structure of this proof that what we are doing is just making
-- iterated case distinctions on the truth value of propositions.
-- As such, the above proof is the equivalent of a proof "by truth" table, where we are listing all the possible
-- combinations.

-- Also, we can now deal better with double negations:

example : ¬¬p ↔ p :=
  ⟨fun hnnp =>
   match em p with
   | Or.inl hp => hp
   | Or.inr hnp => False.elim (hnnp hnp),
   imp_not_not p⟩
-- The proof of the first direction is what you know as "proof by contradiction":
-- To prove a proposition `p`, we match on `em p`. Then, the first case is always trivial,
-- and in the second case we will have to use `False.elim` to show that now we have contradicting
-- premises.
-- You will need this principle in the second exercise sheet as well.

end


import data.set
import data.int.basic
import data.nat.basic
open function int set nat

section
  def f (x : ℤ) : ℤ := x + 3
  def g (x : ℤ) : ℤ := -x
  def h (x : ℤ) : ℤ := 2 * x + 3

  -- 1
  example : injective h :=

  assume x,
  assume y,

  assume h1: 2 * x + 3 = 2 * y + 3,

  have h2: 2 * x = 2 * y, from add_right_cancel h1,

  show x = y, from mul_left_cancel₀ dec_trivial h2

  -- 2
  example : surjective g :=

  assume f,

  have h1: g (-f) = -(-f), from rfl,
  have h2: g (-f) = f, from neg_neg f,
  show ∃ (a : ℤ), g a = f, from exists.intro (-f) h2

  -- 3
  example (A B : Type) (u : A → B) (v1 : B → A) (v2 : B → A)
    (h1 : left_inverse v1 u) (h2 : right_inverse v2 u) : v1 = v2 :=
  funext
    (assume x,
      calc
        v1 x = v1 (u (v2 x)) : by rw h2
         ... = v2 x          : by rw h1)
end

-- 4
section
  variables {X Y : Type}
  variable f : X → Y
  variables A B : set X

  example : f '' (A ∩ B) ⊆ f '' A ∩ f '' B :=
  assume y,
  assume h1 : y ∈ f '' (A ∩ B),
  show y ∈ f '' A ∩ f '' B, from exists.elim h1
  (
    assume a,
    assume b,

    have e1: f a = y, from and.right b,

    have e2: a ∈ A, from and.left (and.left b),
    have e3: a ∈ A ∧ f a = y, from and.intro e2 e1,
    have e4: y ∈ f '' A, from exists.intro a e3,

    have e5: a ∈ B, from and.right (and.left b),
    have e6: a ∈ B ∧ f a = y, from and.intro e5 e1,
    have e7: y ∈ f '' B, from exists.intro a e6,

    show y ∈ f '' A ∩ f '' B, from and.intro e4 e7
  )
end

-- 5
example : ∀ m n k : nat, m * (n + k) = m * n + m * k :=
  begin
    intros m n k,
    induction m,

    rw zero_mul,
    rw zero_mul,
    rw zero_mul,

    rw succ_mul,
    rw succ_mul,
    rw succ_mul,

    rw ← add_assoc,
    rw ← add_assoc,

    rw add_right_comm,

    rw m_ih,

    rw add_comm,

    rw add_assoc,
    rw add_assoc,
    rw add_assoc,

    rw add_left_comm
  end

-- 6
example : ∀ n : nat, 0 * n = 0 :=
  begin
    intro n,
    induction n,

    refl,

    rw mul_succ,

    rw n_ih
  end

-- 7
example : ∀ n : nat, 1 * n = n :=
  begin
    intro n,
    induction n,

    rw mul_zero,

    rw mul_succ,

    rw n_ih
  end

-- 8
example : ∀ m n k : nat, (m * n) * k = m * (n * k) :=
  begin
    intros m n k,
    induction k,

    rw mul_zero,
    rw mul_zero,
    rw mul_zero,

    rw mul_succ,
    rw mul_succ,

    rw left_distrib,

    rw k_ih
  end

-- 9
example : ∀ m n : nat, m * n = n * m :=
  begin
  intros m n,
  induction m,

  rw mul_zero,

  rw zero_mul,

  rw mul_succ,

  rw succ_mul,

  rw m_ih
  end


variable (α : Type)
variable (f : α → α)
variable (A B C : α → Prop)
variable (D : Prop)

theorem problem1 (h₁ : ∀ x, A x → B x) (h₂ : ∃ y, A y) : ∃ z, B z := sorry

theorem problem2 (h : ∃ x, A x) : ∃ y, A y ∨ B y := sorry

theorem problem3 (h : ∀ x, A x → A (f x)) : ∀ y, A y → A (f (f y)) := sorry

theorem problem4 (h₁ : ∀ x, A x ∨ B x) (h₂ : ∀ x, A x → C x) (h₃ : ∀ x, B x → C x) : ∀ x, C x := sorry

theorem problem5 (a : α) : (∀ (x:α), D) ↔ D := sorry


/-
Copyright (c) 2020 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca
-/

import ring_theory.polynomial.cyclotomic
import topology.algebra.polynomial
import field_theory.finite.basic

/-!
# Primes congruent to one

We prove that, for any positive `k : ℕ`, there are infinitely many primes `p` such that
`p ≡ 1 [MOD k]`.
-/

namespace nat

open polynomial nat filter

/-- For any positive `k : ℕ` there are infinitely many primes `p` such that `p ≡ 1 [MOD k]`. -/
lemma exists_prime_ge_modeq_one (k n : ℕ) (hpos : 0 < k) :
  ∃ (p : ℕ), nat.prime p ∧ n ≤ p ∧ p ≡ 1 [MOD k] :=
begin
  have hli : tendsto (abs ∘ (λ (a : ℕ), abs(a : ℚ))) at_top at_top,
  { simp only [(∘), abs_cast],
    exact nat.strict_mono_cast.monotone.tendsto_at_top_at_top exists_nat_ge },
  have hcff : int.cast_ring_hom ℚ (cyclotomic k ℤ).leading_coeff ≠ 0,
  { simp only [cyclotomic.monic, ring_hom.eq_int_cast, monic.leading_coeff, int.cast_one, ne.def,
     not_false_iff, one_ne_zero] },
  obtain ⟨a, ha⟩ := tendsto_at_top_at_top.1 (tendsto_abv_eval₂_at_top (int.cast_ring_hom ℚ) abs
    (cyclotomic k ℤ) (degree_cyclotomic_pos k ℤ hpos) hcff hli) 2,
  let b := a * (k * n.factorial),
  have hgt : 1 < (eval ↑(a * (k * n.factorial)) (cyclotomic k ℤ)).nat_abs,
  { suffices hgtabs : 1 < abs (eval ↑b (cyclotomic k ℤ)),
    { rw [int.abs_eq_nat_abs] at hgtabs,
      exact_mod_cast hgtabs },
    suffices hgtrat : 1 < abs (eval ↑b (cyclotomic k ℚ)),
    { rw [← map_cyclotomic_int k ℚ, ← int.cast_coe_nat, ← int.coe_cast_ring_hom, eval_map,
        eval₂_hom, int.coe_cast_ring_hom] at hgtrat,
      assumption_mod_cast },
    suffices hleab : a ≤ b,
    { replace ha := lt_of_lt_of_le one_lt_two (ha b hleab),
      rwa [← eval_map, map_cyclotomic_int k ℚ, abs_cast] at ha },
    exact le_mul_of_pos_right (mul_pos hpos (factorial_pos n)) },
  let p := min_fac (eval ↑b (cyclotomic k ℤ)).nat_abs,
  haveI hprime : fact p.prime := ⟨min_fac_prime (ne_of_lt hgt).symm⟩,
  have hroot : is_root (cyclotomic k (zmod p)) (cast_ring_hom (zmod p) b),
  { rw [is_root.def, ← map_cyclotomic_int k (zmod p), eval_map, coe_cast_ring_hom,
    ← int.cast_coe_nat, ← int.coe_cast_ring_hom, eval₂_hom, int.coe_cast_ring_hom,
      zmod.int_coe_zmod_eq_zero_iff_dvd _ _],
    apply int.dvd_nat_abs.1,
    exact_mod_cast min_fac_dvd (eval ↑b (cyclotomic k ℤ)).nat_abs },
  refine ⟨p, hprime.1, _, _⟩,
  { by_contra habs,
    exact (prime.dvd_iff_not_coprime hprime.1).1
      (dvd_factorial (min_fac_pos _) (le_of_not_ge habs))
      (coprime_of_root_cyclotomic hpos hroot).symm.coprime_mul_left_right.coprime_mul_left_right },
  { have hdiv := order_of_dvd_of_pow_eq_one (zmod.units_pow_card_sub_one_eq_one p
      (zmod.unit_of_coprime b (coprime_of_root_cyclotomic hpos hroot))),
    have : ¬p ∣ k := hprime.1.coprime_iff_not_dvd.1
      (coprime_of_root_cyclotomic hpos hroot).symm.coprime_mul_left_right.coprime_mul_right_right,
    rw [order_of_root_cyclotomic hpos this hroot] at hdiv,
    exact ((modeq.modeq_iff_dvd' hprime.1.pos).2 hdiv).symm }
end

lemma frequently_at_top_modeq_one (k : ℕ) (hpos : 0 < k) :
  ∃ᶠ p in at_top, nat.prime p ∧ p ≡ 1 [MOD k] :=
begin
  refine frequently_at_top.2 (λ n, _),
  obtain ⟨p, hp⟩ := exists_prime_ge_modeq_one k n hpos,
  exact ⟨p, ⟨hp.2.1, hp.1, hp.2.2⟩⟩
end

lemma infinite_set_of_prime_modeq_one (k : ℕ) (hpos : 0 < k) :
  set.infinite {p : ℕ | nat.prime p ∧ p ≡ 1 [MOD k]} :=
frequently_at_top_iff_infinite.1 (frequently_at_top_modeq_one k hpos)

end nat


/-
Copyright (c) 2022 Justin Thomas. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Justin Thomas
-/
import field_theory.minpoly.field
import ring_theory.principal_ideal_domain

/-!
# Annihilating Ideal

Given a commutative ring `R` and an `R`-algebra `A`
Every element `a : A` defines
an ideal `polynomial.ann_ideal a ⊆ R[X]`.
Simply put, this is the set of polynomials `p` where
the polynomial evaluation `p(a)` is 0.

## Special case where the ground ring is a field

In the special case that `R` is a field, we use the notation `R = 𝕜`.
Here `𝕜[X]` is a PID, so there is a polynomial `g ∈ polynomial.ann_ideal a`
which generates the ideal. We show that if this generator is
chosen to be monic, then it is the minimal polynomial of `a`,
as defined in `field_theory.minpoly`.

## Special case: endomorphism algebra

Given an `R`-module `M` (`[add_comm_group M] [module R M]`)
there are some common specializations which may be more familiar.
* Example 1: `A = M →ₗ[R] M`, the endomorphism algebra of an `R`-module M.
* Example 2: `A = n × n` matrices with entries in `R`.
-/

open_locale polynomial

namespace polynomial

section semiring

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]

variables (R)

/-- `ann_ideal R a` is the *annihilating ideal* of all `p : R[X]` such that `p(a) = 0`.

The informal notation `p(a)` stand for `polynomial.aeval a p`.
Again informally, the annihilating ideal of `a` is
`{ p ∈ R[X] | p(a) = 0 }`. This is an ideal in `R[X]`.
The formal definition uses the kernel of the aeval map. -/
noncomputable def ann_ideal (a : A) : ideal R[X] :=
((aeval a).to_ring_hom : R[X] →+* A).ker

variables {R}

/-- It is useful to refer to ideal membership sometimes
 and the annihilation condition other times. -/
lemma mem_ann_ideal_iff_aeval_eq_zero {a : A} {p : R[X]} :
  p ∈ ann_ideal R a ↔ aeval a p = 0 :=
iff.rfl

end semiring

section field

variables {𝕜 A : Type*} [field 𝕜] [ring A] [algebra 𝕜 A]
variable (𝕜)

open submodule

/-- `ann_ideal_generator 𝕜 a` is the monic generator of `ann_ideal 𝕜 a`
if one exists, otherwise `0`.

Since `𝕜[X]` is a principal ideal domain there is a polynomial `g` such that
 `span 𝕜 {g} = ann_ideal a`. This picks some generator.
 We prefer the monic generator of the ideal. -/
noncomputable def ann_ideal_generator (a : A) : 𝕜[X] :=
let g := is_principal.generator $ ann_ideal 𝕜 a
  in g * (C g.leading_coeff⁻¹)

section

variables {𝕜}

@[simp] lemma ann_ideal_generator_eq_zero_iff {a : A} :
  ann_ideal_generator 𝕜 a = 0 ↔ ann_ideal 𝕜 a = ⊥ :=
by simp only [ann_ideal_generator, mul_eq_zero, is_principal.eq_bot_iff_generator_eq_zero,
  polynomial.C_eq_zero, inv_eq_zero, polynomial.leading_coeff_eq_zero, or_self]
end

/-- `ann_ideal_generator 𝕜 a` is indeed a generator. -/
@[simp] lemma span_singleton_ann_ideal_generator (a : A) :
  ideal.span {ann_ideal_generator 𝕜 a} = ann_ideal 𝕜 a :=
begin
  by_cases h : ann_ideal_generator 𝕜 a = 0,
  { rw [h, ann_ideal_generator_eq_zero_iff.mp h, set.singleton_zero, ideal.span_zero] },
  { rw [ann_ideal_generator, ideal.span_singleton_mul_right_unit, ideal.span_singleton_generator],
    apply polynomial.is_unit_C.mpr,
    apply is_unit.mk0,
    apply inv_eq_zero.not.mpr,
    apply polynomial.leading_coeff_eq_zero.not.mpr,
    apply (mul_ne_zero_iff.mp h).1 }
end

/-- The annihilating ideal generator is a member of the annihilating ideal. -/
lemma ann_ideal_generator_mem (a : A) : ann_ideal_generator 𝕜 a ∈ ann_ideal 𝕜 a :=
ideal.mul_mem_right _ _ (submodule.is_principal.generator_mem _)

lemma mem_iff_eq_smul_ann_ideal_generator {p : 𝕜[X]} (a : A) :
  p ∈ ann_ideal 𝕜 a ↔ ∃ s : 𝕜[X], p = s • ann_ideal_generator 𝕜 a :=
by simp_rw [@eq_comm _ p, ← mem_span_singleton, ← span_singleton_ann_ideal_generator 𝕜 a,
 ideal.span]

/-- The generator we chose for the annihilating ideal is monic when the ideal is non-zero. -/
lemma monic_ann_ideal_generator (a : A) (hg : ann_ideal_generator 𝕜 a ≠ 0) :
  monic (ann_ideal_generator 𝕜 a) :=
monic_mul_leading_coeff_inv (mul_ne_zero_iff.mp hg).1

/-! We are working toward showing the generator of the annihilating ideal
in the field case is the minimal polynomial. We are going to use a uniqueness
theorem of the minimal polynomial.

This is the first condition: it must annihilate the original element `a : A`. -/
lemma ann_ideal_generator_aeval_eq_zero (a : A) :
  aeval a (ann_ideal_generator 𝕜 a) = 0 :=
mem_ann_ideal_iff_aeval_eq_zero.mp (ann_ideal_generator_mem 𝕜 a)

variables {𝕜}

lemma mem_iff_ann_ideal_generator_dvd {p : 𝕜[X]} {a : A} :
  p ∈ ann_ideal 𝕜 a ↔ ann_ideal_generator 𝕜 a ∣ p :=
by rw [← ideal.mem_span_singleton, span_singleton_ann_ideal_generator]

/-- The generator of the annihilating ideal has minimal degree among
 the non-zero members of the annihilating ideal -/
lemma degree_ann_ideal_generator_le_of_mem (a : A) (p : 𝕜[X])
  (hp : p ∈ ann_ideal 𝕜 a) (hpn0 : p ≠ 0) :
  degree (ann_ideal_generator 𝕜 a) ≤ degree p :=
degree_le_of_dvd (mem_iff_ann_ideal_generator_dvd.1 hp) hpn0

variables (𝕜)

/-- The generator of the annihilating ideal is the minimal polynomial. -/
lemma ann_ideal_generator_eq_minpoly (a : A) :
  ann_ideal_generator 𝕜 a = minpoly 𝕜 a :=
begin
  by_cases h : ann_ideal_generator 𝕜 a = 0,
  { rw [h, minpoly.eq_zero],
    rintro ⟨p, p_monic, (hp : aeval a p = 0)⟩,
    refine p_monic.ne_zero (ideal.mem_bot.mp _),
    simpa only [ann_ideal_generator_eq_zero_iff.mp h]
      using mem_ann_ideal_iff_aeval_eq_zero.mpr hp },
  { exact minpoly.unique _ _
      (monic_ann_ideal_generator _ _ h)
      (ann_ideal_generator_aeval_eq_zero _ _)
      (λ q q_monic hq, (degree_ann_ideal_generator_le_of_mem a q
        (mem_ann_ideal_iff_aeval_eq_zero.mpr hq)
        q_monic.ne_zero)) }
end

/-- If a monic generates the annihilating ideal, it must match our choice
 of the annihilating ideal generator. -/
lemma monic_generator_eq_minpoly (a : A) (p : 𝕜[X])
  (p_monic : p.monic) (p_gen : ideal.span {p} = ann_ideal 𝕜 a) :
  ann_ideal_generator 𝕜 a = p :=
begin
  by_cases h : p = 0,
  { rwa [h, ann_ideal_generator_eq_zero_iff, ← p_gen, ideal.span_singleton_eq_bot.mpr], },
  { rw [← span_singleton_ann_ideal_generator, ideal.span_singleton_eq_span_singleton] at p_gen,
    rw eq_comm,
    apply eq_of_monic_of_associated p_monic _ p_gen,
    { apply monic_ann_ideal_generator _ _ ((associated.ne_zero_iff p_gen).mp h), }, },
end

end field

end polynomial


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

This file formalises the fact that any finite, linearly ordered
set of size n has a unique order-isomorphism with the set
fin n =  {0,...,n-1}.
-/

import data.finset data.fintype
import fin_extra
open list

variables {α : Type*}

namespace list

/-
 If we have a list l (of length n) and a natural number i, we might
 want to refer to the i'th entry in the list, but then we have to
 decide what to do about the possibility that i is too large so that
 there is no i'th entry.  We always use 0-based indexing so the
 i'th entry is defined for i < n but not for i ≥ n.

 The standard library defines (l.nth i) to be of type (option α),
 and to have value (some x) if i < n and x is the i'th entry, but to
 have value (none) if i ≥ n.  The standard library also defines
 (l.nth_le i h) to be x if h is a proof of i < n.  Here we just
 repackage this slightly: the pair ⟨i,h⟩ gives a term of type
 (fin n), and we define l.fin_nth ⟨i,h⟩ to be x again.
-/
def fin_nth (l : list α) (i : fin l.length) : α :=
 l.nth_le i.val i.is_lt

/- An obvious lemma about the behaviour of fin_nth. -/
lemma fin_nth_cons (a : α) (l : list α) (i : fin l.length) :
 (list.cons a l).fin_nth i.succ = l.fin_nth i :=
begin
 cases i,dsimp[fin.succ,fin_nth],refl,
end

/-
 If R is a relation on α and l is a list, we define
 (pairwise_nth R l) to be true if all entries in l are R-related
 to all strictly later entries.  For example, if R is an order
 relation then this just means that the list is sorted, and if
 R is the relation x ≠ y then this just means that l has no
 duplicates.  Here we define pairwise_nth in the obvious way
 using indices.  We then prove that our pairwise_nth is
 equivalent to the definition of pairwise in the standard
 library, which is formulated by structural induction rather
 than using indices.
-/

def pairwise_nth₀ (R : α → α → Prop) (l : list α) :=
 ∀ (i j : fin l.length), i < j → R (l.fin_nth i) (l.fin_nth j)

def pairwise_nth (R : α → α → Prop) (l : list α) :=
 ∀ {i j : ℕ} (hi : i < j) (hj : j < l.length),
   R (l.nth_le i (lt_trans hi hj)) (l.nth_le j hj)

lemma pairwise_nth_mp {R : α → α → Prop} {l : list α}
 (p : pairwise R l) : pairwise_nth R l :=
begin
  induction p with a l0 R_a_l0 p0 ih,
  { intros i j hi hj, cases hj },
  { intros i j hi hj,
    rcases j with j, { cases hi },
    have hj0 : j < l0.length := nat.lt_of_succ_lt_succ hj,
    cases i with i,
    { exact R_a_l0 _ (l0.nth_le_mem j hj0) },
    { exact ih (nat.lt_of_succ_lt_succ hi) hj0 } }
end

lemma pairwise_nth_mpr {R : α → α → Prop} {l : list α}
 (hl : pairwise_nth R l) : (pairwise R l) :=
begin
  induction l with a l ih,
  { exact @pairwise.nil _ R },
  { have R_a_l : ∀ (b ∈ l), (R a b) :=
    begin
      intros b b_in_l,
      rcases nth_le_of_mem b_in_l with ⟨j,⟨hj,eq_b⟩⟩,
      rw [← eq_b],
      exact hl (nat.zero_lt_succ j) (nat.succ_lt_succ hj)
    end,
    have : l.pairwise R :=
    begin
      apply ih,
      intros i j hi hj,
      exact hl (nat.succ_lt_succ hi) (nat.succ_lt_succ hj),
    end,
    exact pairwise.cons R_a_l this }
end

lemma pairwise_nth_iff {R : α → α → Prop} {l : list α} :
 (pairwise R l) ↔ (pairwise_nth R l) :=
  iff.intro (@pairwise_nth_mp _ R l) (@pairwise_nth_mpr _ R l)

/-
 The standard library defines a list to be sorted if all entries are
 less than or equal to all strictly later entries.  Here we define
 a list to be strongly sorted if the relevant inequalities hold
 strictly.  This is clearly equivalent to saying that the list is
 sorted and has distinct entries; we also formalise this equivalence.
-/

variables [linear_order α] [decidable_rel (@has_le.le α _)]

def strongly_sorted (l : list α) : Prop :=
 list.pairwise has_lt.lt l

lemma strongly_sorted_of_sorted_nodup (l : list α) :
 l.sorted has_le.le → l.nodup → l.strongly_sorted :=
begin
 intro l_sorted,
 induction l_sorted with a l0 a_le_l0 l0_sorted ih,
 {intro,exact pairwise.nil},
 {intro l_nodup,
  cases l_nodup with _ _ a_ne_l0 l0_nodup,
  have l0_strongly_sorted := ih l0_nodup,
  have a_lt_l0 : ∀ (x : α) (x_in_l0 : x ∈ l0), (a < x) :=
  begin
   intros x x_in_l0,
   exact lt_of_le_of_ne (a_le_l0 x x_in_l0) (a_ne_l0 x x_in_l0),
  end,
  exact pairwise.cons a_lt_l0 l0_strongly_sorted,
 }
end

lemma sorted_of_strongly_sorted (l : list α) :
 l.strongly_sorted → l.sorted has_le.le :=
begin
 intro l_strongly_sorted,
 induction l_strongly_sorted with a l0 a_lt_l0 l0_strongly_sorted ih,
 {exact pairwise.nil},
 {have a_le_l0 : ∀ x ∈ l0, a ≤ x :=
   λ x x_in_l0,le_of_lt (a_lt_l0 x x_in_l0),
  have l0_sorted := ih,
  exact pairwise.cons a_le_l0 l0_sorted
 }
end

lemma nodup_of_strongly_sorted (l : list α) :
 l.strongly_sorted → l.nodup :=
begin
 intro l_strongly_sorted,
 induction l_strongly_sorted with a l0 a_ne_l0 l0_strongly_sorted ih,
 {exact pairwise.nil},
 {have a_ne_l0 : ∀ x ∈ l0, a ≠ x :=
   λ x x_in_l0,ne_of_lt (a_ne_l0 x x_in_l0),
  have l0_nodup := ih,
  exact pairwise.cons a_ne_l0 l0_nodup
 }
end

/-
 Sortedness is defined in the standard library by structural
 induction. Here we reformulate it in terms of indices.
-/

lemma sorted_nth_lt_mp {l : list α}
 (l_nodup : list.nodup l)
 (l_sorted : list.sorted has_le.le l)
 {i j : ℕ} (hi : i < j) (hj : j < l.length) :
 (l.nth_le i (lt_trans hi hj) < l.nth_le j hj) :=
begin
  let x := l.nth_le i (lt_trans hi hj),
  let y := l.nth_le j hj,
  have x_ne_y : x ≠ y := pairwise_nth_mp l_nodup hi hj,
  have x_le_y : x ≤ y := pairwise_nth_mp l_sorted hi hj,
  exact lt_of_le_of_ne x_le_y x_ne_y,
end

lemma sorted_nth_le_mp {l : list α}
 (l_nodup : list.nodup l)
 (l_sorted : list.sorted has_le.le l)
 {i j : ℕ} (hi : i ≤ j) (hj : j < l.length) :
 (l.nth_le i (lt_of_le_of_lt hi hj) ≤ l.nth_le j hj) :=
begin
 by_cases h : i = j,
 { cases h, refl },
 { have hi' : i < j := lt_of_le_of_ne hi h,
   exact (le_of_lt $ sorted_nth_lt_mp l_nodup l_sorted hi' hj) }
end

lemma sorted_nth_lt {l : list α}
 (l_nodup : list.nodup l)
 (l_sorted : list.sorted has_le.le l)
 { i j : ℕ } (hi : i < l.length) (hj : j < l.length) :
  (i < j) ↔ (l.nth_le i hi < l.nth_le j hj) :=
begin
 split,
 { intro hi',
   exact sorted_nth_lt_mp l_nodup l_sorted hi' hj },
 { intro x_lt_y,
   rcases lt_or_ge i j with i_lt_j | j_le_i,
   { assumption },
   { exfalso,
     let y_le_x := sorted_nth_le_mp l_nodup l_sorted j_le_i hi,
     exact not_lt_of_ge y_le_x x_lt_y } }
end

lemma sorted_nth_le {l : list α}
 (l_nodup : list.nodup l)
 (l_sorted : list.sorted has_le.le l)
 { i j : ℕ } (hi : i < l.length) (hj : j < l.length) :
  (i ≤ j) ↔ (l.nth_le i hi ≤ l.nth_le j hj) :=
begin
 split,
 { intro hi',
   exact sorted_nth_le_mp l_nodup l_sorted hi' hj },
 { intro x_le_y,
   rcases le_or_gt i j with i_le_j | j_lt_i,
   { assumption },
   { exfalso,
     let y_lt_x := sorted_nth_lt_mp l_nodup l_sorted j_lt_i hi,
     exact not_le_of_gt y_lt_x x_le_y } }
end

end list

namespace finset

variables [linear_order α] [decidable_rel (@has_le.le α _)]

/-
 The standard library defines a function that accepts a finite set s
 and returns the list of elements in sorted order.  The next lemma
 tells us how we can recognise that list if we have obtained it by
 other means.
-/

theorem list.perm.eqv' (α : Type*) : equivalence (@perm α) :=
mk_equivalence (@perm α) (@perm.refl α) (@perm.symm α) (@perm.trans α)

instance list.is_setoid' (α : Type*) : setoid (list α) :=
setoid.mk (@perm α) (list.perm.eqv' α)

lemma sort_spec (s : finset α) (l : list α)
 (l_nodup : l.nodup) (l_sorted : l.sorted has_le.le)
  (s_eq_l : s = l.to_finset) : s.sort has_le.le = l :=
begin
 let h0 := (congr_arg val
            (eq.trans (eq.trans (to_finset_eq (sort_nodup has_le.le s)) (eq.trans (sort_to_finset has_le.le s) s_eq_l))
                      (eq.symm (to_finset_eq l_nodup)))),
 let h1 := list.eq_of_sorted_of_perm (@quotient.exact (list α) (list.is_setoid' α) _ _ h0) (sort_sorted has_le.le s) l_sorted,
 let ll : multiset α := quot.mk _ l,
 have ll_nodup : ll.nodup := multiset.coe_nodup.mpr l_nodup,
 have ll_eq : (⟨ll,ll_nodup⟩ : finset α) = l.to_finset := list.to_finset_eq l_nodup,
 let m := s.sort has_le.le,
 have m_nodup : m.nodup := s.sort_nodup has_le.le,
 have m_sorted : m.sorted has_le.le := s.sort_sorted has_le.le,
 let mm : multiset α := quot.mk _ m,
 have mm_nodup : mm.nodup := multiset.coe_nodup.mpr m_nodup,
 have mm_eq : (⟨mm,mm_nodup⟩ : finset α) = m.to_finset := list.to_finset_eq m_nodup,
 have m_to_finset : m.to_finset = s :=
  s.sort_to_finset has_le.le,
 let mm_eq_ll :=
  congr_arg finset.val ((mm_eq.trans (m_to_finset.trans s_eq_l)).trans ll_eq.symm),
 dsimp[finset.val] at mm_eq_ll,
 have perm_m_l : perm m l := quotient.exact mm_eq_ll,
 exact list.eq_of_sorted_of_perm perm_m_l m_sorted l_sorted,
end

/-
 The next lemma is equivalent to the previous one.  However, as an
 experiment we have written it as a single term rather than using
 tactics.  We used the command "#print sort_spec" to print the
 proof term generated automatically be Lean from the tactic proof,
 and then reorganised it a bit to eliminate some inefficiencies.
-/

lemma sort_spec_alt (s : finset α) (l : list α)
 (l_nodup : l.nodup) (l_sorted : l.sorted has_le.le)
  (s_eq_l : s = l.to_finset) : s.sort has_le.le = l :=
    list.eq_of_sorted_of_perm
     (@quotient.exact
      (list α)
      (list.is_setoid' α)
      _
      _
      (@congr_arg
       (finset α)
       (multiset α)
       _
       _
       finset.val
       (eq.trans
        (eq.trans (to_finset_eq (sort_nodup has_le.le s)) (eq.trans (sort_to_finset has_le.le s) s_eq_l))
        (eq.symm (to_finset_eq l_nodup))
       )
      )
     )
     (sort_sorted has_le.le s)
     l_sorted

section rank_equiv

/-
 We now give our first version of the fact that any finite, linearly ordered
 set of size n is order-isomorphic to (fin n). In this version, the type α has
 a decidable linear order and s is a finite subset of α that need not contain
 all elements of α.  In order to talk about an order-equivalence we need to
 convert s into a separate type by considering {a // a ∈ s}. The definition
 (rank_equiv s) gives an equivalence from this type to (fin n), but it is not
 initially packaged with any information about order-preserving properties.
 Instead, we prove those properties as four separate lemmas after the
 definition of rank_equiv.

 Note that we have arguments n and s_card : s.card = n, and we produce an
 equivalence with (fin n).  One might think that it would be more natural to
 just produce an equivalence with (fin s.card), and then use eq.mp to convert
 this to (fin n) if necessary.  Unfortunately, this leads to a lot of tedious
 troubles with heterogenous equality.  As far as I can tell, the present
 approach is the simplest way to avoid that.
-/

variables {s : finset α} {n : ℕ} (s_card : s.card = n)
include s_card

def rank_equiv : { a // a ∈ s } ≃ fin n :=
begin
 let l := s.sort has_le.le,
 have l_nodup : list.nodup l := finset.sort_nodup has_le.le s,
 have l_eq_s : l.to_finset = s := by simp[finset.sort_eq],
 have l_len : l.length = n :=
  ((@eq.subst (finset α) (λ t, t.card = l.length) _ _ l_eq_s
             (list.to_finset_card_of_nodup l_nodup)).symm).trans s_card,
 let mem_equiv : ∀ a : α, a ∈ s ↔ a ∈ l :=
  λ a, @eq.subst (finset α) (λ t, a ∈ t ↔ a ∈ l) _ _ l_eq_s
         (@list.mem_to_finset α _ a l),
 let to_fun : { a // a ∈ s } → fin n :=
 begin
  intro a,
  have a_in_l : a.val ∈ l := (mem_equiv a.val).mp a.property,
  let i : ℕ := list.index_of a.val l,
  have i_lt_n : i < n :=
   l_len.subst (list.index_of_lt_length.mpr a_in_l),
  exact ⟨i,i_lt_n⟩
 end,
 let inv_fun : fin n → { a // a ∈ s } :=
 begin
  intro i,
  have i_is_lt : i.val < l.length := @eq.subst ℕ (λ m, i.val < m) _ _ l_len.symm i.is_lt,
  let a := l.nth_le i.val i_is_lt,
  have a_in_s : a ∈ s := (mem_equiv a).mpr (l.nth_le_mem i.val i_is_lt),
  exact ⟨a,a_in_s⟩
 end,
 have left_inv : ∀ a, inv_fun (to_fun a) = a :=
 begin
  intro a,
  rcases a with ⟨a_val,a_in_s⟩,
  have a_in_l : a_val ∈ l := (mem_equiv a_val).mp a_in_s,
  let i := list.index_of a_val l,
  have i_lt_len : i < l.length := list.index_of_lt_length.mpr a_in_l,
  have i_lt_n : i < n := l_len.subst i_lt_len,
  dsimp[inv_fun,to_fun],
  apply subtype.eq,dsimp[subtype.val],
  exact list.index_of_nth_le i_lt_len,
 end,
 have right_inv : ∀ i, to_fun (inv_fun i) = i :=
 begin
  intro i,
  rcases i with ⟨i_val,i_lt_n⟩,
  have i_lt_len : i_val < l.length := l_len.symm.subst i_lt_n,
  dsimp[inv_fun,to_fun],
  apply fin.eq_of_veq,dsimp[fin.val],
  exact list.nth_le_index_of l_nodup i_val i_lt_len,
 end,
 exact ⟨to_fun,inv_fun,left_inv,right_inv⟩,
end

lemma seq_le (i1 i2 : fin n) :
 i1 ≤ i2 ↔ (((rank_equiv s_card).inv_fun i1).val ≤ ((rank_equiv s_card).inv_fun i2).val) :=
begin
 dsimp [rank_equiv, nth_le, has_le.le, fin.le],
 let l := s.sort has_le.le,
 have l_nodup : list.nodup l := finset.sort_nodup has_le.le s,
 have l_sorted : l.sorted has_le.le := sort_sorted has_le.le s,
 have l_eq_s : l.to_finset = s := by simp[finset.sort_eq],
 have l_len : l.length = n :=
  ((@eq.subst (finset α) (λ t, t.card = l.length) _ _ l_eq_s
             (list.to_finset_card_of_nodup l_nodup)).symm).trans s_card,
 have i1p : i1.val < l.length := by { rw[l_len], exact i1.is_lt },
 have i2p : i2.val < l.length := by { rw[l_len], exact i2.is_lt },
 exact list.sorted_nth_le l_nodup l_sorted i1p i2p
end

lemma seq_lt (i1 i2 : fin n) :
 i1 < i2 ↔ (((rank_equiv s_card).inv_fun i1).val < ((rank_equiv s_card).inv_fun i2).val) :=
begin
 dsimp [rank_equiv, nth_le, has_le.le, fin.le],
 let l := s.sort has_le.le,
 have l_nodup : list.nodup l := finset.sort_nodup has_le.le s,
 have l_sorted : l.sorted has_le.le := sort_sorted has_le.le s,
 have l_eq_s : l.to_finset = s := by simp[finset.sort_eq],
 have l_len : l.length = n :=
  ((@eq.subst (finset α) (λ t, t.card = l.length) _ _ l_eq_s
             (list.to_finset_card_of_nodup l_nodup)).symm).trans s_card,
 have i1p : i1.val < l.length := by { rw[l_len], exact i1.is_lt },
 have i2p : i2.val < l.length := by { rw[l_len], exact i2.is_lt },
 exact list.sorted_nth_lt l_nodup l_sorted i1p i2p
end

lemma rank_le (a1 a2 : {a // a ∈ s }) :
 a1.val ≤ a2.val ↔ (rank_equiv s_card).to_fun a1 ≤ (rank_equiv s_card).to_fun a2 :=
begin
 let f := rank_equiv s_card,
 let i1 := f.to_fun a1,
 let i2 := f.to_fun a2,
 let a1a := f.inv_fun i1,
 let a2a := f.inv_fun i2,
 let h := ((seq_le s_card) (f.to_fun a1) (f.to_fun a2)).symm,
 let e1 : (f.inv_fun i1).val = a1.val := congr_arg subtype.val (f.left_inv a1),
 let e2 : (f.inv_fun i2).val = a2.val := congr_arg subtype.val (f.left_inv a2),
 split,
 {intro h1,rw[← e1,← e2] at h1,exact h.mp h1,},
 {intro h2,let h3 := h.mpr h2,rw[e1,e2] at h3,exact h3}
end

lemma rank_lt (a1 a2 : {a // a ∈ s }) :
 a1.val < a2.val ↔ ((rank_equiv s_card).to_fun a1) < ((rank_equiv s_card).to_fun a2) :=
begin
 let f := rank_equiv s_card,
 let i1 := f.to_fun a1,
 let i2 := f.to_fun a2,
 let a1a := f.inv_fun i1,
 let a2a := f.inv_fun i2,
 let h := ((seq_lt s_card) (f.to_fun a1) (f.to_fun a2)).symm,
 let e1 : (f.inv_fun i1).val = a1.val := congr_arg subtype.val (f.left_inv a1),
 let e2 : (f.inv_fun i2).val = a2.val := congr_arg subtype.val (f.left_inv a2),
 split,
 {intro h1,rw[← e1,← e2] at h1,exact h.mp h1,},
 {intro h2,let h3 := h.mpr h2,rw[e1,e2] at h3,exact h3}
end

lemma rank_as_card (a : { x // x ∈ s}) :
 ((rank_equiv s_card).to_fun a).val = card (s.filter (λ x, x < a.val)) :=
begin
 let f := rank_equiv s_card,
 let u := s.filter (λ x, x < a.val),
 let ut := {x // x ∈ u},
 let k := f.to_fun a,
 have fi_k : f.inv_fun k = a := f.left_inv a,
 let g_to_fun : ut → fin k.val :=
 begin
  intro x,
  let x0 : { x // x ∈ s } := ⟨x.val,(mem_filter.mp x.property).left⟩,
  let x_lt_a : x0.val < a.val := (mem_filter.mp x.property).right,
  let i := f.to_fun x0,
  let i_lt_k : i < k := ((rank_lt s_card) x0 a).mp x_lt_a,
  let i_lt_k_val : i.val < k.val :=
  begin
   let h := i_lt_k,
   dsimp[has_lt.lt,fin.lt] at h,
   exact h,
  end,
  exact ⟨i.val,i_lt_k_val⟩,
 end,
 let g_inv_fun : fin k.val → ut :=
 begin
  intro i,
  let i0 : fin n := ⟨i.val,lt_trans i.is_lt k.is_lt⟩,
  have i0_lt_k : i0 < k := by { simp[has_lt.lt,fin.lt], exact i.is_lt,},
  let x0 := f.inv_fun i0,
  let x_lt_a := ((seq_lt s_card) i0 k).mp i0_lt_k,
  rw[fi_k] at x_lt_a,
  have x_in_u : x0.val ∈ u :=
  begin
   apply mem_filter.mpr,
   exact ⟨x0.property,x_lt_a⟩,
  end,
  exact ⟨x0.val,x_in_u⟩,
 end,
 have g_left_inv : ∀ x, g_inv_fun (g_to_fun x) = x :=
 begin
  intro x,
  dsimp[g_to_fun,g_inv_fun],
  apply subtype.eq; simp[subtype.val],
  exact congr_arg subtype.val (f.left_inv _),
 end,
 have g_right_inv : ∀ i, g_to_fun (g_inv_fun i) = i :=
 begin
  intro i,
  dsimp[g_to_fun,g_inv_fun],
  apply fin.eq_of_veq; simp[fin.val],
  exact congr_arg fin.val (f.right_inv _),
 end,
 let g : ut ≃ fin k.val := ⟨g_to_fun,g_inv_fun,g_left_inv,g_right_inv⟩,
 let h0 := fintype.card_congr g,
 let h1 := @finset.card_attach α u,
 let h2 := fintype.card_fin k.val,
 exact (h1.symm.trans (h0.trans h2)).symm,
end

end rank_equiv

end finset

namespace fintype
open finset fintype

variables [linear_order α] [decidable_rel (@has_le.le α _)]
variables [fintype α] {n : ℕ} (α_card : card α = n)
include α_card

/-
 We now give our second version of the fact that any finite, linearly ordered
 set of size n is order-isomorphic to (fin n). In this version we assume given
 an instance of (fintype α), which is essentially a proof that the whole type
 α is finite. From this we build an equivalence from α to (fin n), and again
 we prove the order properties as separate lemmas.
-/

def rank_equiv : α ≃ fin n :=
begin
 have h0 : finset.card (@elems α _) = n := α_card,
 let f := finset.rank_equiv h0,
 let to_fun : α → fin n := λ a, f.to_fun ⟨a,mem_univ a⟩,
 let inv_fun : fin n → α := λ i, (f.inv_fun i).val,
 have left_inv : ∀ a : α, inv_fun (to_fun a) = a :=
  λ a, congr_arg subtype.val (f.left_inv ⟨a,mem_univ a⟩),
 have right_inv : ∀ i : fin n, to_fun (inv_fun i) = i :=
 begin
  intro i,
  have e : f.inv_fun i = ⟨inv_fun i,mem_univ _⟩ :=
   by {apply subtype.eq,simp[inv_fun]},
  dsimp[inv_fun,to_fun],rw[← e],exact f.right_inv i,
 end,
 exact ⟨to_fun,inv_fun,left_inv,right_inv⟩,
end

lemma seq_le (i1 i2 : fin n) :
 i1 ≤ i2 ↔ (rank_equiv α_card).inv_fun i1 ≤ (rank_equiv α_card).inv_fun i2 :=
  (seq_le α_card) i1 i2

lemma seq_lt (i1 i2 : fin n) :
 i1 < i2 ↔ (rank_equiv α_card).inv_fun i1 < (rank_equiv α_card).inv_fun i2 :=
  (seq_lt α_card) i1 i2

lemma rank_le (a1 a2 : α) :
 a1 ≤ a2 ↔ (rank_equiv α_card).to_fun a1 ≤ (rank_equiv α_card).to_fun a2 :=
  (rank_le α_card) ⟨a1,mem_univ a1⟩ ⟨a2,mem_univ a2⟩

lemma rank_lt (a1 a2 : α) :
 a1 < a2 ↔ (rank_equiv α_card).to_fun a1 < (rank_equiv α_card).to_fun a2 :=
  (rank_lt α_card) ⟨a1,mem_univ a1⟩ ⟨a2,mem_univ a2⟩

end fintype

namespace fin
/-
 The only strictly increasing self-map of (fin n) is the identity
-/
lemma rigid {n : ℕ} {f : fin n → fin n}
 (f_mono : ∀ {i1 i2 : fin n}, i1 < i2 → (f i1) < (f i2)) :
  ∀ (i : fin n), f i = i :=
begin
 induction n with n0 ih,
 {intro i,exact fin.elim0 i},
 {
  let f0 : fin n0 → fin n0 :=
  begin
   intro i0,
   let h0 := ne_of_lt (lt_of_le_of_lt (fin.zero_le (f 0)) (f_mono (@fin.zero_lt_succ n0 i0))),
   exact fin.pred (f i0.succ) h0.symm,
  end,
  have succ_f0 : ∀ (i0 : fin n0), (f0 i0).succ = f i0.succ :=
  begin
   intro i0,
   let h0 := ne_of_lt (lt_of_le_of_lt (fin.zero_le (f 0)) (f_mono (@fin.zero_lt_succ n0 i0))),
   exact fin.succ_pred (f i0.succ) h0.symm,
  end,
  have f0_mono : ∀ {i1 i2 : fin n0}, i1 < i2 → (f0 i1) < (f0 i2) :=
  begin
   intros i1 i2 i1_lt_i2,
   let h0 := f_mono (fin.succ_lt_succ i1_lt_i2),
   rw[← (succ_f0 i1)] at h0,
   rw[← (succ_f0 i2)] at h0,
   exact fin.lt_of_succ_lt_succ h0,
  end,
  let f0_id := ih @f0_mono,
  have f_zero_a : ∀ (j : fin n0.succ), f 0 = j → j = 0 :=
  begin
   intros j e, cases j, cases j_val with j0_val,
   {refl},
   {
     exfalso,
     have j0_is_lt : j0_val < n0 := nat.lt_of_succ_lt_succ j_is_lt,
     let j0 : fin n0 := ⟨j0_val,j0_is_lt⟩,
     let j := j0.succ,
     have h0 : f j = j := (succ_f0 j0).symm.trans (congr_arg fin.succ (f0_id j0)),
     have h1 : f 0 < f j := f_mono (@fin.zero_lt_succ n0 j0),
     have h2 : j < f j := @eq.subst (fin n0.succ) (λ k, k < f j) _ _ e h1,
     exact (ne_of_lt h2) h0.symm,
   }
  end,
  have f_zero : f 0 = 0 := f_zero_a (f 0) rfl,
  intro i, cases i, cases i_val with i0_val,
  {exact f_zero,},
  {
   have i0_is_lt : i0_val < n0 := nat.lt_of_succ_lt_succ i_is_lt,
   let h0 := congr_arg fin.succ (f0_id ⟨i0_val,i0_is_lt⟩),
   let h1 := succ_f0 ⟨i0_val,i0_is_lt⟩,
   let h2 := h1.symm.trans h0,
   exact h2,
  }
 }
end

end fin


-- Level 1
example (P Q : Type) (p : P) (h : P → Q) : Q :=

begin

exact h p

end
-- * Level 2

import mynat.add -- + on mynat
import mynat.mul -- * on mynat

example : mynat → mynat :=

begin

intro n,
exact 3*n+2

end

-- *  Level 3

example (P Q R S T U: Type)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=

begin

have q : Q := h(p),
have t : T := j(q),
have u : U := l(t),
exact u

end
-- Level 4
example (P Q R S T U: Type)
(p : P)
(h : P → Q)
(i : Q → R)
(j : Q → T)
(k : S → T)
(l : T → U)
: U :=

begin
have q : Q := h(p),
have t : T := j(q),
have u : U := l(t),
exact u

end

-- Level 5

example (P Q : Type) : P → (Q → P) :=

begin

intro p,
intro q,
exact p

end

-- Level 6
example (P Q R : Type) : (P → (Q → R)) → ((P → Q) → (P → R)) :=

begin

intro f,
intro g,
intro h,

have j := f h,

apply j,
apply g,
exact h

end
-- Level 7
example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) :=

begin
intros f h p,
exact h(f(p))
end
-- Level 8

example (P Q : Type) : (P → Q) → ((Q → empty) → (P → empty)) :=

begin

intros f h p,
apply h,
apply f,
exact p

end


-- propositions
-- proofs
-- predicates
    -- sets
    -- relations
    -- equality
-- connectives
    -- not
    -- and
    -- or

-- proposition
inductive nifty_was_a_cat : Prop
-- proof
| there_are_pictures_of_nifty
| we_remember_nifty_fondly

inductive pet : Type
| nifty
| tom
| cheese
| kevin

open pet

inductive was_a_cat : pet → Prop
| nifty_proof : was_a_cat nifty
| tom_proof : was_a_cat tom

open was_a_cat

theorem nifty_cat : was_a_cat nifty := nifty_proof

-- Predicates with single arguments, in essence, define a *set*
-- The elements of this set all satisfy the predicate
-- (elements that do not satisfy the predicate are not members)
-- A kind of "membership test" for being in a set

inductive and'' (α β : Prop) : Prop
| intro : α → β → and''

def nwac_and_cwac : Prop := and'' (was_a_cat nifty) (was_a_cat cheese)

theorem pf : (and'' (was_a_cat nifty) (was_a_cat tom)) := and''.intro (nifty_proof) (tom_proof)

def and''_intro (α β : Prop) : α → β → (and'' α β) := and''.intro

def and''_elim_left {α β : Prop} : (and'' α β) → α
| (and''.intro a b) := a

def and''_elim_right {α β : Prop} : (and'' α β) → β
| (and''.intro a b) := b

theorem twac : (was_a_cat tom) := (and''_elim_right pf)

-- if you have a data type of one constructor, you can use the "structure" keyword to declare it

inductive and''' (α β : Prop) : Prop
| intro (left : α) (right : β) : and'''

structure and' (a b : Prop) : Prop := intro :: (left : a) (right : b)


import data.nat.prime
import tactic.norm_num
import data.list.basic
open nat
open list

theorem exists_prime_prod: ∀x:ℕ,1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧prod L=x:=begin
    have Hstrong:∀ y x:ℕ,x≤y→1≤x→∃L:list ℕ,(∀p:ℕ,p ∈ L→prime p)∧prod L=x:=begin
        intro,induction y with y1 Hiy,
        intros,rw eq_zero_of_le_zero a at a_1,revert a_1,norm_num,intros,
        cases x with x1,revert a_1,norm_num,
        cases x1 with x2,existsi nil,norm_num,
        cases classical.em (prime (succ(succ x2))) with A A,
        existsi ([succ (succ x2)]),norm_num,exact A,
        have H:=exists_dvd_of_not_prime2 (dec_trivial:2≤succ(succ x2)) A,
        cases H with b Hb,cases Hb with Hbd Hb,cases Hb with Hb2 Hbx,
        have H:=exists_eq_mul_right_of_dvd Hbd,cases H with c Hbc,rw eq_comm at Hbc,
        have H3:=succ_ne_zero (succ x2),rw ←Hbc at H3,
        have H2:= iff.elim_right pos_iff_ne_zero (ne_zero_of_mul_ne_zero_left H3),
        have H1:=iff.elim_right (lt_mul_iff_one_lt_left (iff.elim_right pos_iff_ne_zero (ne_zero_of_mul_ne_zero_left H3))) (lt_of_lt_of_le (dec_trivial:1<2) Hb2),rw Hbc at H1,
        cases Hiy b (le_of_succ_le_succ (le_trans (succ_le_of_lt Hbx) a)) (le_trans (dec_trivial:1≤2) Hb2) with B HB,
        cases Hiy c (le_of_succ_le_succ (le_trans (succ_le_of_lt H1) a)) (succ_le_of_lt H2) with C HC,existsi B++C,norm_num,intros,apply and.intro,
        rwa [and.right HB,and.right HC],intros,cases a_2,exact and.left HB p a_2,exact and.left HC p a_2,
    end,exact λ x,Hstrong x x (le_refl x),
end
theorem bezout: ∀ b c:ℕ,∃x y:ℤ, ↑b*x+↑c*y = ↑(gcd b c):=begin
    assume b c,apply gcd.induction b c,
    simp [gcd],intro,existsi (1:ℤ),simp,
    assume m n Hm,assume Hmn,cases Hmn with x1 Hx,cases Hx with y1 Hxy,
    cases m with m,simp [lt_irrefl] at Hm,revert Hm,trivial,
    unfold gcd,rw ←Hxy,existsi -↑(n/succ m)*x1+y1,existsi x1,
    have H: n%succ m=n-(succ m)*(n/(succ m)):=begin rw [eq_comm,nat.sub_eq_iff_eq_add,mod_add_div n (succ m)],rw mul_comm,exact div_mul_le_self n (succ m) end,rw H,
    rw [int.coe_nat_sub,mul_add,add_assoc,add_comm (↑(succ m) * y1) (↑n * x1),←add_assoc,add_right_cancel_iff,mul_sub_right_distrib,int.coe_nat_mul],norm_num,
    rw mul_comm,exact div_mul_le_self n (succ m),
end
theorem euclid: ∀b c p:ℕ, prime p → p ∣ (b*c) → p ∣ b ∨ p ∣ c:=begin
    assume b c p Hp Hpbc,unfold prime at Hp,
    cases(and.right Hp (gcd c p) (and.right (gcd_dvd c p))) with A A,
    cases (bezout c p)with x H,cases H with y H,rw A at H,
    have H1:↑(b*c)*x+↑(p*b)*y=↑b:=by{have H:↑b*↑c*x+↑b*↑p*y=↑b*↑1:=by{rw[←H,mul_add],norm_num},simp at H,rw←H,norm_num},left,
    have H2:=dvd_mul_of_dvd_left (iff.elim_right int.coe_nat_dvd Hpbc) x,
    have H3:=dvd_mul_of_dvd_left (iff.elim_right int.coe_nat_dvd (dvd_mul_of_dvd_left (dvd_refl p) b)) y,
    have H4:=dvd_add H2 H3,rw H1 at H4,rwa ←int.coe_nat_dvd,right,rw ←A,
    exact and.left (gcd_dvd c p),
end
theorem dvd_prod_of_mem: ∀ (p:ℕ) (L:list ℕ),p∈L→ p ∣ prod L:=begin
    assume p L,revert p,
    induction L with p1 L1 HiL,
        norm_num,
        exact λ p2 Hp, dvd_mul_of_dvd_right (HiL p2 Hp) p1,
end
theorem mem_of_prime_dvd_prod: ∀ (B:list ℕ)(p:ℕ),prime p→(∀pB, pB ∈ B → prime pB)→p ∣ prod B → p ∈ B:=begin
    assume B,
    induction B with p1 B1 Hi,
    rw prod_nil,assume p Hp H H2,exfalso,revert H2,
    exact prime.not_dvd_one Hp,
    assume p2 Hp2 H H1,
    norm_num,rw prod_cons at H1,
    have H2:=euclid p1 (prod B1) p2 Hp2 H1,
    cases H2 with A A,left,
    have H3:=H p1,
    revert H3,norm_num,assume H4,
    unfold prime at H4,
    have H5:=and.right H4 p2 A,
    have H6:¬p2=1:=begin unfold prime at Hp2,intro,rw a at Hp2,simp at Hp2,revert Hp2,exact dec_trivial,end,
    simp [H6] at H5,assumption,right,
    have H3:(∀ (pB : ℕ), pB ∈ B1 → prime pB):=begin revert H, norm_num,end,have H2:= Hi p2 Hp2 H3 A,assumption,
end
theorem  unique_prime_factorization: ∀ A B:list ℕ,prod A=prod B→(∀p:ℕ, p∈A→prime p)→(∀ p:ℕ,p∈ B→ prime p)→A~B:=begin
    assume A,
    induction A with pA A Hi,
    rw prod_nil,norm_num,
    assume B HP HA,
    have H:∀ p,p∈ B→ ¬p∈ B:=begin intros p HpB,
        have H1:=dvd_prod_of_mem p B HpB,
        rw ←HP at H1,exfalso,
        exact prime.not_dvd_one (HA p HpB) H1,
    end,apply perm.symm,rw perm_nil, cases B,trivial,exfalso,
    exact H a (mem_cons_self a a_1) (mem_cons_self a a_1),
    assume B HP HA HB,
    rw prod_cons at HP,
    have H8:pA ∣ prod B:=begin
        have H1:=dvd_mul_of_dvd_left (dvd_refl pA) (prod A),
        rwa HP at H1,
    end,
    have HppA: prime pA:=begin apply HA,norm_num,  end,
    have H9:=mem_of_prime_dvd_prod B pA HppA HB H8,
    have H11:=prod_eq_of_perm (perm_erase H9),rw [H11,prod_cons] at HP,
    rw nat.mul_left_inj (gt_of_ge_of_gt (and.left HppA) (dec_trivial:2>0)) at HP,
    have HA1:∀ (p : ℕ), p ∈ A → prime p:=begin revert HA,norm_num,end,
    have HB1:∀ (p : ℕ), p ∈(list.erase B pA) → prime p:=λ p Hp,HB p (mem_of_mem_erase Hp),
    have Hi2:= iff.elim_right (perm_cons pA) (Hi (list.erase B pA) HP HA1 HB1),
    exact perm.trans Hi2 (perm.symm (perm_erase H9)),
end
theorem fundamental_theorem_of_arithmetic: ∀n:ℕ,1≤n→∃L:list ℕ,(∀p:ℕ,p∈L→prime p)∧prod L=n∧∀M:list ℕ,((∀p:ℕ,p∈M→prime p)→prod M=n→L~M):=begin
    assume n Hn,
    cases (exists_prime_prod n Hn) with L HL, existsi L,
    apply and.intro (and.left HL),
    apply and.intro (and.right HL),
    intros M H1 H2,
    rw[eq_comm,←and.right HL] at H2,
    exact (unique_prime_factorization L) M H2 (and.left HL) H1,
end


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/
import analysis.convex.function
import topology.algebra.affine
import topology.local_extr
import topology.metric_space.basic

/-!
# Minima and maxima of convex functions

We show that if a function `f : E → β` is convex, then a local minimum is also
a global minimum, and likewise for concave functions.
-/

variables {E β : Type*} [add_comm_group E] [topological_space E]
  [module ℝ E] [topological_add_group E] [has_continuous_smul ℝ E]
  [ordered_add_comm_group β] [module ℝ β] [ordered_smul ℝ β]
  {s : set E}

open set filter function
open_locale classical topology

/--
Helper lemma for the more general case: `is_min_on.of_is_local_min_on_of_convex_on`.
-/
lemma is_min_on.of_is_local_min_on_of_convex_on_Icc {f : ℝ → β} {a b : ℝ} (a_lt_b : a < b)
  (h_local_min : is_local_min_on f (Icc a b) a) (h_conv : convex_on ℝ (Icc a b) f) :
  is_min_on f (Icc a b) a :=
begin
  rintro c hc, dsimp only [mem_set_of_eq],
  rw [is_local_min_on, nhds_within_Icc_eq_nhds_within_Ici a_lt_b] at h_local_min,
  rcases hc.1.eq_or_lt with rfl|a_lt_c, { exact le_rfl },
  have H₁ : ∀ᶠ y in 𝓝[>] a, f a ≤ f y,
    from h_local_min.filter_mono (nhds_within_mono _ Ioi_subset_Ici_self),
  have H₂ : ∀ᶠ y in 𝓝[>] a, y ∈ Ioc a c,
    from Ioc_mem_nhds_within_Ioi (left_mem_Ico.2 a_lt_c),
  rcases (H₁.and H₂).exists with ⟨y, hfy, hy_ac⟩,
  rcases (convex.mem_Ioc a_lt_c).mp hy_ac with ⟨ya, yc, ya₀, yc₀, yac, rfl⟩,
  suffices : ya • f a + yc • f a ≤ ya • f a + yc • f c,
    from (smul_le_smul_iff_of_pos yc₀).1 (le_of_add_le_add_left this),
  calc ya • f a + yc • f a = f a : by rw [← add_smul, yac, one_smul]
  ... ≤ f (ya * a + yc * c)      : hfy
  ... ≤ ya • f a + yc • f c      : h_conv.2 (left_mem_Icc.2 a_lt_b.le) hc ya₀ yc₀.le yac
end

/--
A local minimum of a convex function is a global minimum, restricted to a set `s`.
-/
lemma is_min_on.of_is_local_min_on_of_convex_on {f : E → β} {a : E}
  (a_in_s : a ∈ s) (h_localmin : is_local_min_on f s a) (h_conv : convex_on ℝ s f) :
  is_min_on f s a :=
begin
  intros x x_in_s,
  let g : ℝ →ᵃ[ℝ] E := affine_map.line_map a x,
  have hg0 : g 0 = a := affine_map.line_map_apply_zero a x,
  have hg1 : g 1 = x := affine_map.line_map_apply_one a x,
  have hgc : continuous g, from affine_map.line_map_continuous,
  have h_maps : maps_to g (Icc 0 1) s,
  { simpa only [maps_to', ← segment_eq_image_line_map]
      using h_conv.1.segment_subset a_in_s x_in_s },
  have fg_local_min_on : is_local_min_on (f ∘ g) (Icc 0 1) 0,
  { rw ← hg0 at h_localmin,
    exact h_localmin.comp_continuous_on h_maps hgc.continuous_on (left_mem_Icc.2 zero_le_one) },
  have fg_min_on : is_min_on (f ∘ g) (Icc 0 1 : set ℝ) 0,
  { refine is_min_on.of_is_local_min_on_of_convex_on_Icc one_pos fg_local_min_on _,
    exact (h_conv.comp_affine_map g).subset h_maps (convex_Icc 0 1) },
  simpa only [hg0, hg1, comp_app, mem_set_of_eq] using fg_min_on (right_mem_Icc.2 zero_le_one)
end

/-- A local maximum of a concave function is a global maximum, restricted to a set `s`. -/
lemma is_max_on.of_is_local_max_on_of_concave_on {f : E → β} {a : E}
  (a_in_s : a ∈ s) (h_localmax: is_local_max_on f s a) (h_conc : concave_on ℝ s f) :
  is_max_on f s a :=
@is_min_on.of_is_local_min_on_of_convex_on _ βᵒᵈ _ _ _ _ _ _ _ _ s f a a_in_s h_localmax h_conc

/-- A local minimum of a convex function is a global minimum. -/
lemma is_min_on.of_is_local_min_of_convex_univ {f : E → β} {a : E}
  (h_local_min : is_local_min f a) (h_conv : convex_on ℝ univ f) : ∀ x, f a ≤ f x :=
λ x, (is_min_on.of_is_local_min_on_of_convex_on (mem_univ a)
        (h_local_min.on univ) h_conv) (mem_univ x)

/-- A local maximum of a concave function is a global maximum. -/
lemma is_max_on.of_is_local_max_of_convex_univ {f : E → β} {a : E}
  (h_local_max : is_local_max f a) (h_conc : concave_on ℝ univ f) : ∀ x, f x ≤ f a :=
@is_min_on.of_is_local_min_of_convex_univ _ βᵒᵈ _ _ _ _ _ _ _ _ f a h_local_max h_conc


/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux
-/
import analysis.normed_space.star.basic
import analysis.normed_space.spectrum
import algebra.star.module
import analysis.normed_space.star.exponential

/-! # Spectral properties in C⋆-algebras
In this file, we establish various propreties related to the spectrum of elements in C⋆-algebras.
-/

local postfix `⋆`:std.prec.max_plus := star

open_locale topological_space ennreal
open filter ennreal spectrum cstar_ring

section unitary_spectrum

variables
{𝕜 : Type*} [normed_field 𝕜]
{E : Type*} [normed_ring E] [star_ring E] [cstar_ring E]
[normed_algebra 𝕜 E] [complete_space E] [nontrivial E]

lemma unitary.spectrum_subset_circle (u : unitary E) :
  spectrum 𝕜 (u : E) ⊆ metric.sphere 0 1 :=
begin
  refine λ k hk, mem_sphere_zero_iff_norm.mpr (le_antisymm _ _),
  { simpa only [cstar_ring.norm_coe_unitary u] using norm_le_norm_of_mem hk },
  { rw ←unitary.coe_to_units_apply u at hk,
    have hnk := ne_zero_of_mem_of_unit hk,
    rw [←inv_inv (unitary.to_units u), ←spectrum.map_inv, set.mem_inv] at hk,
    have : ∥k∥⁻¹ ≤ ∥↑((unitary.to_units u)⁻¹)∥, simpa only [norm_inv] using norm_le_norm_of_mem hk,
    simpa using inv_le_of_inv_le (norm_pos_iff.mpr hnk) this }
end

lemma spectrum.subset_circle_of_unitary {u : E} (h : u ∈ unitary E) :
  spectrum 𝕜 u ⊆ metric.sphere 0 1 :=
unitary.spectrum_subset_circle ⟨u, h⟩

end unitary_spectrum

section complex_scalars

open complex

variables {A : Type*}
[normed_ring A] [normed_algebra ℂ A] [complete_space A] [star_ring A] [cstar_ring A]

local notation `↑ₐ` := algebra_map ℂ A

lemma spectral_radius_eq_nnnorm_of_self_adjoint [norm_one_class A] {a : A}
  (ha : a ∈ self_adjoint A) :
  spectral_radius ℂ a = ∥a∥₊ :=
begin
  have hconst : tendsto (λ n : ℕ, (∥a∥₊ : ℝ≥0∞)) at_top _ := tendsto_const_nhds,
  refine tendsto_nhds_unique _ hconst,
  convert (spectrum.pow_nnnorm_pow_one_div_tendsto_nhds_spectral_radius (a : A)).comp
      (nat.tendsto_pow_at_top_at_top_of_one_lt (by linarith : 1 < 2)),
  refine funext (λ n, _),
  rw [function.comp_app, nnnorm_pow_two_pow_of_self_adjoint ha, ennreal.coe_pow, ←rpow_nat_cast,
    ←rpow_mul],
  simp,
end

lemma spectral_radius_eq_nnnorm_of_star_normal [norm_one_class A] (a : A) [is_star_normal a] :
  spectral_radius ℂ a = ∥a∥₊ :=
begin
  refine (ennreal.pow_strict_mono two_ne_zero).injective _,
  have ha : a⋆ * a ∈ self_adjoint A,
    from self_adjoint.mem_iff.mpr (by simpa only [star_star] using (star_mul a⋆ a)),
  have heq : (λ n : ℕ, ((∥(a⋆ * a) ^ n∥₊ ^ (1 / n : ℝ)) : ℝ≥0∞))
    = (λ x, x ^ 2) ∘ (λ n : ℕ, ((∥a ^ n∥₊ ^ (1 / n : ℝ)) : ℝ≥0∞)),
  { funext,
    rw [function.comp_apply, ←rpow_nat_cast, ←rpow_mul, mul_comm, rpow_mul, rpow_nat_cast,
      ←coe_pow, sq, ←nnnorm_star_mul_self, commute.mul_pow (star_comm_self' a), star_pow], },
  have h₂ := ((ennreal.continuous_pow 2).tendsto (spectral_radius ℂ a)).comp
    (spectrum.pow_nnnorm_pow_one_div_tendsto_nhds_spectral_radius a),
  rw ←heq at h₂,
  convert tendsto_nhds_unique h₂ (pow_nnnorm_pow_one_div_tendsto_nhds_spectral_radius (a⋆ * a)),
  rw [spectral_radius_eq_nnnorm_of_self_adjoint ha, sq, nnnorm_star_mul_self, coe_mul],
end

/-- Any element of the spectrum of a selfadjoint is real. -/
theorem self_adjoint.mem_spectrum_eq_re [star_module ℂ A] [nontrivial A] {a : A}
  (ha : a ∈ self_adjoint A) {z : ℂ} (hz : z ∈ spectrum ℂ a) : z = z.re :=
begin
  let Iu := units.mk0 I I_ne_zero,
  have : exp ℂ (I • z) ∈ spectrum ℂ (exp ℂ (I • a)),
    by simpa only [units.smul_def, units.coe_mk0]
      using spectrum.exp_mem_exp (Iu • a) (smul_mem_smul_iff.mpr hz),
  exact complex.ext (of_real_re _)
    (by simpa only [←complex.exp_eq_exp_ℂ, mem_sphere_zero_iff_norm, norm_eq_abs, abs_exp,
      real.exp_eq_one_iff, smul_eq_mul, I_mul, neg_eq_zero]
      using spectrum.subset_circle_of_unitary (self_adjoint.exp_i_smul_unitary ha) this),
end

/-- Any element of the spectrum of a selfadjoint is real. -/
theorem self_adjoint.mem_spectrum_eq_re' [star_module ℂ A] [nontrivial A]
  (a : self_adjoint A) {z : ℂ} (hz : z ∈ spectrum ℂ (a : A)) : z = z.re :=
self_adjoint.mem_spectrum_eq_re a.property hz

/-- The spectrum of a selfadjoint is real -/
theorem self_adjoint.coe_re_map_spectrum [star_module ℂ A] [nontrivial A] {a : A}
  (ha : a ∈ self_adjoint A) : spectrum ℂ a = (coe ∘ re '' (spectrum ℂ a) : set ℂ) :=
le_antisymm (λ z hz, ⟨z, hz, (self_adjoint.mem_spectrum_eq_re ha hz).symm⟩) (λ z, by
  { rintros ⟨z, hz, rfl⟩,
    simpa only [(self_adjoint.mem_spectrum_eq_re ha hz).symm, function.comp_app] using hz })

/-- The spectrum of a selfadjoint is real -/
theorem self_adjoint.coe_re_map_spectrum' [star_module ℂ A] [nontrivial A] (a : self_adjoint A) :
  spectrum ℂ (a : A) = (coe ∘ re '' (spectrum ℂ (a : A)) : set ℂ) :=
self_adjoint.coe_re_map_spectrum a.property

end complex_scalars


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import order.lattice
import data.set.basic

universes u v w

variables {α : Type u} {β : Type v} {ι : Sort w} (r : α → α → Prop)
local infix ` ≼ ` : 50 := r

/-- A family of elements of α is directed (with respect to a relation `≼` on α)
  if there is a member of the family `≼`-above any pair in the family.  -/
def directed (f : ι → α) := ∀x y, ∃z, f x ≼ f z ∧ f y ≼ f z

/-- A subset of α is directed if there is an element of the set `≼`-above any
  pair of elements in the set. -/
def directed_on (s : set α) := ∀ (x ∈ s) (y ∈ s), ∃z ∈ s, x ≼ z ∧ y ≼ z

variables {r}

theorem directed_on_iff_directed {s} : @directed_on α r s ↔ directed r (coe : s → α) :=
by simp [directed, directed_on]; refine ball_congr (λ x hx, by simp; refl)

alias directed_on_iff_directed ↔ directed_on.directed_coe _

theorem directed_on_image {s} {f : β → α} :
  directed_on r (f '' s) ↔ directed_on (f ⁻¹'o r) s :=
by simp only [directed_on, set.ball_image_iff, set.bex_image_iff, order.preimage]

theorem directed_on.mono {s : set α} (h : directed_on r s)
  {r' : α → α → Prop} (H : ∀ {a b}, r a b → r' a b) :
  directed_on r' s :=
λ x hx y hy, let ⟨z, zs, xz, yz⟩ := h x hx y hy in ⟨z, zs, H xz, H yz⟩

theorem directed_comp {ι} {f : ι → β} {g : β → α} :
  directed r (g ∘ f) ↔ directed (g ⁻¹'o r) f := iff.rfl

theorem directed.mono {s : α → α → Prop} {ι} {f : ι → α}
  (H : ∀ a b, r a b → s a b) (h : directed r f) : directed s f :=
λ a b, let ⟨c, h₁, h₂⟩ := h a b in ⟨c, H _ _ h₁, H _ _ h₂⟩

theorem directed.mono_comp {ι} {rb : β → β → Prop} {g : α → β} {f : ι → α}
  (hg : ∀ ⦃x y⦄, x ≼ y → rb (g x) (g y)) (hf : directed r f) :
  directed rb (g ∘ f) :=
directed_comp.2 $ hf.mono hg

/-- A monotone function on a sup-semilattice is directed. -/
lemma directed_of_sup [semilattice_sup α] {f : α → β} {r : β → β → Prop}
  (H : ∀ ⦃i j⦄, i ≤ j → r (f i) (f j)) : directed r f :=
λ a b, ⟨a ⊔ b, H le_sup_left, H le_sup_right⟩

lemma monotone.directed_le [semilattice_sup α] [preorder β] {f : α → β} :
  monotone f → directed (≤) f :=
directed_of_sup

/-- An antimonotone function on an inf-semilattice is directed. -/
lemma directed_of_inf [semilattice_inf α] {r : β → β → Prop} {f : α → β}
  (hf : ∀a₁ a₂, a₁ ≤ a₂ → r (f a₂) (f a₁)) : directed r f :=
assume x y, ⟨x ⊓ y, hf _ _ inf_le_left, hf _ _ inf_le_right⟩

/-- A `preorder` is a `directed_order` if for any two elements `i`, `j`
there is an element `k` such that `i ≤ k` and `j ≤ k`. -/
class directed_order (α : Type u) extends preorder α :=
(directed : ∀ i j : α, ∃ k, i ≤ k ∧ j ≤ k)

@[priority 100]  -- see Note [lower instance priority]
instance linear_order.to_directed_order (α) [linear_order α] : directed_order α :=
⟨λ i j, or.cases_on (le_total i j) (λ hij, ⟨j, hij, le_refl j⟩) (λ hji, ⟨i, le_refl i, hji⟩)⟩


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.category.Module.epi_mono

/-!
# The concrete (co)kernels in the category of modules are (co)kernels in the categorical sense.
-/

open category_theory
open category_theory.limits
open category_theory.limits.walking_parallel_pair

universes u v

namespace Module
variables {R : Type u} [ring R]

section
variables {M N : Module.{v} R} (f : M ⟶ N)

/-- The kernel cone induced by the concrete kernel. -/
def kernel_cone : kernel_fork f :=
kernel_fork.of_ι (as_hom f.ker.subtype) $ by tidy

/-- The kernel of a linear map is a kernel in the categorical sense. -/
def kernel_is_limit : is_limit (kernel_cone f) :=
fork.is_limit.mk _
  (λ s, linear_map.cod_restrict f.ker (fork.ι s) (λ c, linear_map.mem_ker.2 $
    by { rw [←@function.comp_apply _ _ _ f (fork.ι s) c, ←coe_comp, fork.condition,
      has_zero_morphisms.comp_zero (fork.ι s) N], refl }))
  (λ s, linear_map.subtype_comp_cod_restrict _ _ _)
  (λ s m h, linear_map.ext $ λ x, subtype.ext_iff_val.2 $
    have h₁ : (m ≫ (kernel_cone f).π.app zero).to_fun = (s.π.app zero).to_fun,
      by { congr, exact h zero },
    by convert @congr_fun _ _ _ _ h₁ x )

/-- The cokernel cocone induced by the projection onto the quotient. -/
def cokernel_cocone : cokernel_cofork f :=
cokernel_cofork.of_π (as_hom f.range.mkq) $ linear_map.range_mkq_comp _

/-- The projection onto the quotient is a cokernel in the categorical sense. -/
def cokernel_is_colimit : is_colimit (cokernel_cocone f) :=
cofork.is_colimit.mk _
  (λ s, f.range.liftq (cofork.π s) $ linear_map.range_le_ker_iff.2 $ cokernel_cofork.condition s)
  (λ s, f.range.liftq_mkq (cofork.π s) _)
  (λ s m h,
  begin
    haveI : epi (as_hom f.range.mkq) := (epi_iff_range_eq_top _).mpr (submodule.range_mkq _),
    apply (cancel_epi (as_hom f.range.mkq)).1,
    convert h walking_parallel_pair.one,
    exact submodule.liftq_mkq _ _ _
  end)
end

/-- The category of R-modules has kernels, given by the inclusion of the kernel submodule. -/
lemma has_kernels_Module : has_kernels (Module R) :=
⟨λ X Y f, has_limit.mk ⟨_, kernel_is_limit f⟩⟩

/-- The category or R-modules has cokernels, given by the projection onto the quotient. -/
lemma has_cokernels_Module : has_cokernels (Module R) :=
⟨λ X Y f, has_colimit.mk ⟨_, cokernel_is_colimit f⟩⟩

open_locale Module

local attribute [instance] has_kernels_Module
local attribute [instance] has_cokernels_Module

variables {G H : Module.{v} R} (f : G ⟶ H)

/--
The categorical kernel of a morphism in `Module`
agrees with the usual module-theoretical kernel.
-/
noncomputable def kernel_iso_ker {G H : Module.{v} R} (f : G ⟶ H) :
  kernel f ≅ Module.of R (f.ker) :=
limit.iso_limit_cone ⟨_, kernel_is_limit f⟩

-- We now show this isomorphism commutes with the inclusion of the kernel into the source.

@[simp, elementwise] lemma kernel_iso_ker_inv_kernel_ι :
  (kernel_iso_ker f).inv ≫ kernel.ι f = f.ker.subtype :=
limit.iso_limit_cone_inv_π _ _

@[simp, elementwise] lemma kernel_iso_ker_hom_ker_subtype :
  (kernel_iso_ker f).hom ≫ f.ker.subtype = kernel.ι f :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ (limit.is_limit _) zero

/--
The categorical cokernel of a morphism in `Module`
agrees with the usual module-theoretical quotient.
-/
noncomputable def cokernel_iso_range_quotient {G H : Module.{v} R} (f : G ⟶ H) :
  cokernel f ≅ Module.of R (f.range.quotient) :=
colimit.iso_colimit_cocone ⟨_, cokernel_is_colimit f⟩

-- We now show this isomorphism commutes with the projection of target to the cokernel.

@[simp, elementwise] lemma cokernel_π_cokernel_iso_range_quotient_hom :
  cokernel.π f ≫ (cokernel_iso_range_quotient f).hom = f.range.mkq :=
by { convert colimit.iso_colimit_cocone_ι_hom _ _; refl, }

@[simp, elementwise] lemma range_mkq_cokernel_iso_range_quotient_inv :
  ↿f.range.mkq ≫ (cokernel_iso_range_quotient f).inv = cokernel.π f :=
by { convert colimit.iso_colimit_cocone_ι_inv ⟨_, cokernel_is_colimit f⟩ _; refl, }

end Module


import Lean4Axiomatic.AbstractAlgebra.Substitutive

namespace Lean4Axiomatic.AA

open Relation.Equivalence (EqvOp)

/--
Class for types and operations that satisfy the associative property.

For more information see `Associative.assoc` or
[consult Wikipedia](https://en.wikipedia.org/wiki/Associative_property).

**Named parameters**
- `α`: the type that the binary operation `f` is defined over.
- `f`: the binary operation that obeys the associative property.

**Class parameters**
- `EqvOp α`: necessary because the property expresses an equality on `α`.
-/
class Associative {α : Sort u} [EqvOp α] (f : α → α → α) where
  /--
  The associative property of a binary operation `f` defined over a type `α`.

  Some well-known examples from arithmetic are that addition and multiplication
  are associative; we have `(a + b) + c ≃ a + (b + c)` and
  `(a * b) * c ≃ a * (b * c)` for all natural numbers `a`, `b`, and `c`.

  **Named parameters**
  - see `Associative` for the class parameters.
  - `x`: the first operand (when reading from left to right).
  - `y`: the second operand.
  - `z`: the third operand.
  -/
  assoc {x y z : α} : f (f x y) z ≃ f x (f y z)

export Associative (assoc)

/--
Class for types and operations that have either a left or right absorbing
element.

For more information see `AbsorbingOn.absorb` or
[consult Wikipedia](https://en.wikipedia.org/wiki/Absorbing_element).

**Named parameters**
- `hand`:
  Indicates whether the absorbing element is the left or right argument to the
  binary operation `f`.
- `α`:
  The `Sort` of the absorbing element and the parameters of the operation `f`.
- `z`:
  The absorbing element, named `z` to suggest zero (the canonical example).
- `f`:
  The binary operation that has `z` as absorbing element.

**Class parameters**
- `EqvOp α`: Necessary because the property expresses an equivalence on `α`.
-/
class AbsorbingOn
    (hand : Hand) {α : Sort u} [EqvOp α] (z : α) (f : α → α → α)
    :=
  /--
  The left- or right-handed absorption property of a distinguished element `z`
  and a binary operation `f` defined over a sort `α`.

  The most well-known example of an absorbing element is zero, when paired with
  multiplication. In all standard number systems, `0 * x ≃ 0 ≃ x * 0` for all
  numbers `x`.

  **Named parameters**
  - See `AbsorbingOn` for the class parameters.
  - `x`:
    The argument to `f` that is not the absorbing element; it will be in the
    position that is the opposite of `hand`.
  -/
  absorb {x : α} : hand.align f z x ≃ z

export AbsorbingOn (absorb)

/--
Convenience function for the left-handed absorption property.

Can often resolve cases where type inference gets stuck when using the more
general `AbsorbingOn.absorb` function; see its documentation for details.
-/
abbrev absorbL := @absorb Hand.L

/--
Convenience function for the right-handed absorption property.

Can often resolve cases where type inference gets stuck when using the more
general `AbsorbingOn.absorb` function; see its documentation for details.
-/
abbrev absorbR := @absorb Hand.R

/--
Convenience class for types and operations that have left **and** right
absorbing element.

See `AbsorbingOn` for detailed documentation.
-/
class Absorbing {α : Sort u} [EqvOp α] (z : α) (f : α → α → α) :=
  absorbingL : AbsorbingOn Hand.L z f
  absorbingR : AbsorbingOn Hand.R z f

attribute [instance] Absorbing.absorbingL
attribute [instance] Absorbing.absorbingR

/--
Derive right-handed absorption from left-handed absorption for operations `f`
meeting certain conditions.

**Intuition**: Both left and right absorbing elements produce the same result
(themselves) from their associated binary operation. Thus, if the arguments to
`f` can be swapped, one hand can be shown to imply the other.

**Named parameters**
- `α`: The `Sort` of the absorbing element `z`, and `f`'s parameters.
- `z`: The absorbing element.
- `f`: The binary operation that has `z` as absorbing element.

**Class parameters**
- `EqvOp α`: Necessary because `AbsorbingOn.absorb` requires it.
- `Commutative f`: Restriction on `f` that's required for the derivation.
-/
def absorbingR_from_absorbingL
    {α : Sort u} {z : α} {f : α → α → α} [EqvOp α] [Commutative f]
    : AbsorbingOn Hand.L z f → AbsorbingOn Hand.R z f
    := by
  intro _ -- Make left absorbing available to instance search
  apply AbsorbingOn.mk
  intro (x : α)
  show f x z ≃ z
  exact Rel.trans AA.comm AA.absorbL

/--
Class for types, values, and operations that satisfy either the left- or
right-handed identity property.

For more information see `IdentityOn.ident` or
[consult Wikipedia](https://en.wikipedia.org/wiki/Identity_element).

**Named parameters**
- `hand`:
  Indicates whether the property is left- or right-handed.
- `α`:
  The `Sort` of the identity element and the parameters of the operation.
- `e`:
  The identity element. It's labeled as an `outParam` because it's useful to
  have it be inferred in some contexts; see `InverseOn` for an example.
- `f`:
  The binary operation that obeys the identity property with `e`.

**Class parameters**
- `EqvOp α`: Necessary because the property expresses an equality on `α`.
-/
class IdentityOn
    (hand : Hand) {α : Sort u} [EqvOp α] (e : outParam α) (f : α → α → α)
    :=
  /--
  The left- or right-handed identity property of a distinguished element `e`
  and a binary operation `f` defined over a sort `α`.

  The most well-known examples are the additive and multiplicative identities
  from arithmetic. Zero is the identity element for addition (because
  `0 + n ≃ n + 0 ≃ n` for all `n`), while one is the identity for
  multiplication (because `1 * m ≃ m * 1 ≃ m` for all `m`).

  **Named parameters**
  - See `IdentityOn` for the class parameters.
  - `x`:
    The argument to `f` that is not the identity element; it will be in the
    position that is the opposite of `hand`.
  -/
  ident {x : α} : hand.align f e x ≃ x

export IdentityOn (ident)

/--
Convenience function for the left-handed identity property.

Can often resolve cases where type inference gets stuck when using the more
general `ident` function.

See `IdentityOn.ident` for detailed documentation.
-/
abbrev identL := @ident Hand.L

/--
Convenience function for the right-handed identity property.

Can often resolve cases where type inference gets stuck when using the more
general `ident` function.

See `IdentityOn.ident` for detailed documentation.
-/
abbrev identR := @ident Hand.R

/--
Convenience class for types, values, and operations that satisfy the full
(left- **and** right-handed) identity property.

See `IdentityOn` for detailed documentation.
-/
class Identity {α : Sort u} [EqvOp α] (e : outParam α) (f : α → α → α) :=
  identityL : IdentityOn Hand.L e f
  identityR : IdentityOn Hand.R e f

attribute [instance] Identity.identityL
attribute [instance] Identity.identityR

/--
Derive the right-identity property from left-identity for operations `f`
meeting certain conditions.

**Intuition**: Both the left-handed and right-handed versions of the property
equate an application of `f` to the same value. Thus if `f` is commutative, one
version implies the other.

**Named parameters**
- `α`: The `Sort` of the identity element and the parameters of the operation.
- `e`: The identity element.
- `f`: The binary operation that obeys the identity property with `e`.

**Class parameters**
- `EqvOp α`: Necessary because `IdentityOn.ident` expresses an equality on `α`.
- `Commutative f`: Restriction on `f` that's required for the derivation.
-/
def identityR_from_identityL
    {α : Sort u} [EqvOp α] {e : α} {f : α → α → α} [Commutative f]
    : IdentityOn Hand.L e f → IdentityOn Hand.R e f
    := by
  intro _ -- Make left identity available to instance search
  apply IdentityOn.mk
  intro (x : α)
  show f x e ≃ x
  exact Rel.trans AA.comm AA.identL

/--
Class for types and operations that satisfy either the left- or right-handed
inverse property.

For more information see `InverseOn.inverse` or
[consult Wikipedia](https://en.wikipedia.org/wiki/Inverse_element).

**Named parameters**
- `hand`: Indicates whether the property is left- or right-handed.
- `α`: The `Sort` of the operations' parameters.
- `e`: An identity element under the operation `f`.
- `inv`: An operation that turns any `α` value into its inverse.
- `f`: The binary operation that, with `inv`, obeys the inverse property.

**Class parameters**
- `EqvOp α`: Necessary because the property expresses an equality on `α`.
- `IdentityOn hand e f`: Evidence that `e` is an identity element.
-/
class InverseOn
    (hand : Hand) {α : Sort u} {e : α} (inv : outParam (α → α)) (f : α → α → α)
    [EqvOp α] [IdentityOn hand e f]
    :=
  /--
  The left- or right-handed inverse property of an inverse operation `inv` and
  a binary operation `f` defined over a sort `α`.

  The most well-known examples are additive and multiplicative inverses from
  arithmetic. Integers are the simplest numbers to have additive inverses, via
  negation; `a + (-a) ≃ (-a) + a ≃ 0` for all `a`. Similarly, rational numbers
  are the simplest ones with multiplicative inverses, via reciprocation;
  `q * q⁻¹ ≃ q⁻¹ * q ≃ 1` for all nonzero `q`.

  **Named parameters**
  - See `InverseOn` for the class parameters.
  - `x`: The value that is combined (via `f`) with its own inverse.
  -/
  inverse {x : α} : hand.align f (inv x) x ≃ e

export InverseOn (inverse)

/--
Convenience function for the left-handed inverse property.

Can often resolve cases where type inference gets stuck when using the more
general `inverse` function.

See `InverseOn.inverse` for detailed documentation.
-/
abbrev inverseL := @inverse Hand.L

/--
Convenience function for the right-handed inverse property.

Can often resolve cases where type inference gets stuck when using the more
general `inverse` function.

See `InverseOn.inverse` for detailed documentation.
-/
abbrev inverseR := @inverse Hand.R

/--
Convenience class for types and operations that satisfy the full (left- **and**
right-handed) inverse property.

See `InverseOn` for detailed documentation.
-/
class Inverse
    {α : Sort u} {e : α} (inv : outParam (α → α)) (f : α → α → α)
    [EqvOp α] [Identity e f] :=
  inverseL : InverseOn Hand.L inv f
  inverseR : InverseOn Hand.R inv f

attribute [instance] Inverse.inverseL
attribute [instance] Inverse.inverseR

/--
Derive the right-inverse property from left-inverse for operations `f`
meeting certain conditions.

**Intuition**: Both the left-handed and right-handed versions of the property
equate an application of `f` to the same value. Thus if `f` is commutative, one
version implies the other.

**Named parameters**
- `α`: The `Sort` of the operations' parameters.
- `e`: An identity element under the operation `f`.
- `inv`: An operation that turns any `α` value into its inverse.
- `f`: The binary operation that, with `inv`, obeys the inverse property.

**Class parameters**
- `EqvOp α`: Necessary because the property expresses an equality on `α`.
- `IdentityOn hand e f`: Evidence that `e` is an identity element.
- `Commutative f`: Restriction on `f` that's required for the derivation.
-/
def inverseR_from_inverseL
    {α : Sort u} {e : α} {inv : α → α} {f : α → α → α}
    [EqvOp α] [Identity e f] [Commutative f]
    : InverseOn Hand.L inv f → InverseOn Hand.R inv f
    := by
  intro _ -- Make left inverse available to instance search
  apply InverseOn.mk
  intro (x : α)
  show f x (inv x) ≃ e
  exact Rel.trans AA.comm AA.inverseL

/--
Class for types and operations that satisfy either the left- or right-handed
semicompatibility property.

This property doesn't seem to have a standard name. For more information see
`SemicompatibleOn.scompat`

**Named parameters**
- `hand`: Indicates whether the property is left- or right-handed.
- `α`: The `Sort` that the operations `f` and `g` are defined over.
- `f`: An unary operation on `α`.
- `g`: A binary operation on `α`.

**Class parameters**
- `EqvOp α`: Necessary because the property expresses an equivalence on `α`.
-/
class SemicompatibleOn
    (hand : Hand) {α : Sort u} [EqvOp α] (f : α → α) (g : α → α → α)
    :=
  /--
  The left- or right-handed semicompatibility property of two operations `f`
  and `g` defined over a sort `α`.

  The property is called _semi_-compatible because when `f` is exchanged with
  `g`, it only operates on one of `g`'s arguments, rather than both. An example
  of operations that are semicompatible are _successor_ (i.e., `step`) and
  _addition_ on natural numbers: `step n + m ≃ step (n + m) ≃ n + step m`.
  Another example is negation and multiplication on integers:
  `(-a) * b ≃ -(a * b) ≃ a * (-b)`.

  **Named parameters**
  - See `SemicompatibleOn` for the class parameters.
  - `x`: The left-hand argument to `g`.
  - `y`: The right-hand argument to `g`.
  -/
  scompat {x y : α} : f (g x y) ≃ hand.pick (g (f x) y) (g x (f y))

export SemicompatibleOn (scompat)

/--
Convenience function for the left-handed semicompatibility property.

Can often resolve cases where type inference gets stuck when using the more
general `scompat` function.

See `SemicompatibleOn.scompat` for detailed documentation.
-/
abbrev scompatL := @scompat Hand.L

/--
Convenience function for the right-handed semicompatibility property.

Can often resolve cases where type inference gets stuck when using the more
general `scompat` function.

See `SemicompatibleOn.scompat` for detailed documentation.
-/
abbrev scompatR := @scompat Hand.R

/--
Convenience class for types and operations that satisfy the full (left- **and**
right-handed) semicompatibility property.

See `SemicompatibleOn` for detailed documentation.
-/
class Semicompatible {α : Sort u} [EqvOp α] (f : α → α) (g : α → α → α) :=
  semicompatibleL : SemicompatibleOn Hand.L f g
  semicompatibleR : SemicompatibleOn Hand.R f g

attribute [instance] Semicompatible.semicompatibleL
attribute [instance] Semicompatible.semicompatibleR

/--
Derive the right-semicompatibility property from left-semicompatibility for
operations `f` and `g` meeting certain conditions.

**Intuition**: Both the left-handed and right-handed versions of the property
have one side of their equivalences in common. Thus if `g` is commutative, one
version implies the other.

**Named parameters**
- `α`: The `Sort` of the operations' parameters.
- `f`: An unary operation on `α`.
- `g`: A binary operation on `α`.

**Class parameters**
- `EqvOp α`:
    Necessary because the property expresses an equivalence on `α`.
- `Substitutive₁ f (· ≃ ·) (· ≃ ·)`:
    Needed to transform an expression passed to `f`. Nearly every useful `f`
    will satisfy this property.
- `Commutative g`:
    Restriction on `g` that's required for the derivation.
-/
def semicompatibleR_from_semicompatibleL
    {α : Sort u} {f : α → α} {g : α → α → α}
    [EqvOp α] [Substitutive₁ f (· ≃ ·) (· ≃ ·)] [Commutative g]
    : SemicompatibleOn Hand.L f g → SemicompatibleOn Hand.R f g
    := by
  intro _ -- Make the left-hand property available to instance search
  apply SemicompatibleOn.mk
  intro x y
  show f (g x y) ≃ g x (f y)
  calc
    f (g x y) ≃ _ := AA.subst₁ AA.comm
    f (g y x) ≃ _ := AA.scompatL
    g (f y) x ≃ _ := AA.comm
    g x (f y) ≃ _ := Rel.refl

/--
Class for types and operations that satisfy the binary compatibility property.

This property does not have a standard name in abstract algebra. However, it is
a key part of what it means to have a
[homomorphism](https://en.wikipedia.org/wiki/Homomorphism) between algebraic
structures.

**Named parameters**
- `α`:
    The `Sort` that is the input of `f` and that the operation `g` is defined
    over.
- `β`:
    The `Sort` that is the output of `f` and that the operation `h` is defined
    over.
- `f`:
    An unary operation mapping `α` to `β`, that is "compatible" with operations
    `g` and `h`.
- `g`:
    A binary operation on `α`.
- `h`:
    A binary operation on `β`.

**Class parameters**
- `EqvOp β`: Necessary because the property expresses an equivalence on `β`.
-/
class Compatible₂
    {α β : Sort u} [EqvOp β]
    (f : α → β) (g : α → α → α) (h : outParam (β → β → β))
    :=
  /--
  The compatibility property of an unary operation `f` with two binary
  operations `g` and `h` that are defined over sorts `α` and `β`, respectively.

  Typically, `g` and `h` represent a similar operation on each of their sorts,
  and we say that `f` _is compatible with_ that operation, or that `f`
  _preserves_ the operation. In particular, `α` and `β` are often the same
  sort, and `g` and `h` are often the same operation.

  An example instance of the property is that negation is compatible with
  addition on the integers: `-(a + b) ≃ (-a) + (-b)` for all integers `a` and
  `b`.

  **Named parameters**
  - See `Compatible` for the class parameters.
  - `x`: The left-hand argument to `g`.
  - `y`: The right-hand argument to `g`.
  -/
  compat₂ {x y : α} : f (g x y) ≃ h (f x) (f y)

export Compatible₂ (compat₂)

/--
Class for types and operations that satisfy either the left- or right-handed
distributive property.

For more information see `DistributiveOn.distrib` or
[consult Wikipedia](https://en.wikipedia.org/wiki/Distributive_property).

**Named parameters**
- `hand`: indicates whether the property is left- or right-handed.
- `α`: the type that the binary operations `f` and `g` are defined over.
- `f`: the binary operation that distributes over `g`.
- `g`: the binary operation that `f` distributes over.

**Class parameters**
- `EqvOp α`: necessary because the property expresses an equality on `α`.
-/
class DistributiveOn
    (hand : Hand) {α : Sort u} [EqvOp α] (f g : α → α → α) where
  /--
  The left- or right-handed distributive property of two binary operations `f`
  and `g` defined over a type `α`.

  If this property is satisfied, one says that `f` _distributes_ over `g`. A
  well-known example from arithmetic is that multiplication distributes over
  addition; `a * (b + c) ≃ a * b + a * c` for the left-handed case and
  `(b + c) * a ≃ b * a + c * a` for the right-handed case.

  **Named parameters**
  - see `DistributiveOn` for the class parameters.
  - `x`: the argument to `f` that gets distributed; the `hand` parameter
    indicates which side of `f` it is on.
  - `y`: the left argument to `g`.
  - `z`: the right argument to `g`.
  -/
  distrib {x y z : α} :
    hand.align f x (g y z) ≃ g (hand.align f x y) (hand.align f x z)

export DistributiveOn (distrib)

/--
Convenience function for the left-handed distributive property.

Can often resolve cases where type inference gets stuck when using the more
general `distrib` function.

See `DistributiveOn.distrib` for detailed documentation.
-/
abbrev distribL := @distrib Hand.L

/--
Convenience function for the right-handed distributive property.

Can often resolve cases where type inference gets stuck when using the more
general `distrib` function.

See `DistributiveOn.distrib` for detailed documentation.
-/
abbrev distribR := @distrib Hand.R

/--
Convenience class for types and operations that satisfy the full (left- **and**
right-handed) distributive property.

See `DistributiveOn` for detailed documentation.
-/
class Distributive {α : Sort u} [EqvOp α] (f g : α → α → α) where
  distributiveL : DistributiveOn Hand.L f g
  distributiveR : DistributiveOn Hand.R f g

attribute [instance] Distributive.distributiveL
attribute [instance] Distributive.distributiveR

/--
Derive right-distributivity from left-distributivity for operations `f` and `g`
meeting certain conditions.
-/
def distributiveR_from_distributiveL
    {α : Sort u} {f g : α → α → α}
    [EqvOp α] [Commutative f] [Substitutive₂ g AA.tc (· ≃ ·) (· ≃ ·)]
    : DistributiveOn Hand.L f g → DistributiveOn Hand.R f g := by
  intro
  constructor
  intro x y z
  show f (g y z) x ≃ g (f y x) (f z x)
  calc
    f (g y z) x       ≃ _ := AA.comm
    f x (g y z)       ≃ _ := AA.distribL
    g (f x y) (f x z) ≃ _ := AA.substL AA.comm
    g (f y x) (f x z) ≃ _ := AA.substR AA.comm
    g (f y x) (f z x) ≃ _ := Rel.refl

/-- Expresses that one of two propositions is true, but not both. -/
def ExactlyOneOfTwo (α β : Prop) : Prop := (α ∨ β) ∧ ¬ (α ∧ β)

/--
Inhabited when at least one of its three propositions is true; a three-way
logical OR.
-/
inductive OneOfThree (α β γ : Prop) : Prop
| first  (a : α)
| second (b : β)
| third  (c : γ)

/--
Converts each proposition in `OneOfThree` to a different one while preserving
which one is inhabited.

Intended to be used in contexts where the mapping functions are previously
defined, to keep the code compact.
-/
def OneOfThree.map
    {α₁ α₂ β₁ β₂ γ₁ γ₂ : Prop}
    : OneOfThree α₁ β₁ γ₁ → (α₁ → α₂) → (β₁ → β₂) → (γ₁ → γ₂)
    → OneOfThree α₂ β₂ γ₂
| first a, f, _, _ => first (f a)
| second b, _, g, _ => second (g b)
| third c, _, _, h => third (h c)

/--
"Rotates" `OneOfThree`'s propositions one place to the left: the leftmost one
becomes the rightmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `OneOfThree.map` to translate between arbitrary
`OneOfThree` types.
-/
def OneOfThree.rotL {α β γ : Prop} : OneOfThree α β γ → OneOfThree β γ α
| first a => third a
| second b => first b
| third c => second c

/--
"Rotates" `OneOfThree`'s propositions one place to the right: the rightmost one
becomes the leftmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `OneOfThree.map` to translate between arbitrary
`OneOfThree` types.
-/
def OneOfThree.rotR {α β γ : Prop} : OneOfThree α β γ → OneOfThree γ α β
| first a => second a
| second b => third b
| third c => first c

/-- Inhabited when at least two of its three propositions are true. -/
inductive TwoOfThree (α β γ : Prop) : Prop
| oneAndTwo   (a : α) (b : β)
| oneAndThree (a : α) (c : γ)
| twoAndThree (b : β) (c : γ)

/--
Converts each proposition in `TwoOfThree` to a different one while preserving
which ones are inhabited.

Intended to be used in contexts where the mapping functions are previously
defined, to keep the code compact.
-/
def TwoOfThree.map
    {α₁ α₂ β₁ β₂ γ₁ γ₂ : Prop} (f : α₁ → α₂) (g : β₁ → β₂) (h : γ₁ → γ₂)
    : TwoOfThree α₁ β₁ γ₁ → TwoOfThree α₂ β₂ γ₂
| oneAndTwo a b => oneAndTwo (f a) (g b)
| oneAndThree a c => oneAndThree (f a) (h c)
| twoAndThree b c => twoAndThree (g b) (h c)

/--
"Rotates" `TwoOfThree`'s propositions one place to the left: the leftmost one
becomes the rightmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `TwoOfThree.map` to translate between arbitrary
`TwoOfThree` types.
-/
def TwoOfThree.rotL {α β γ : Prop} : TwoOfThree α β γ → TwoOfThree β γ α
| oneAndTwo a b => oneAndThree b a
| oneAndThree a c => twoAndThree c a
| twoAndThree b c => oneAndTwo b c

/--
"Rotates" `TwoOfThree`'s propositions one place to the right: the rightmost one
becomes the leftmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `TwoOfThree.map` to translate between arbitrary
`TwoOfThree` types.
-/
def TwoOfThree.rotR {α β γ : Prop} : TwoOfThree α β γ → TwoOfThree γ α β
| oneAndTwo a b => twoAndThree a b
| oneAndThree a c => oneAndTwo c a
| twoAndThree b c => oneAndThree c b

/--
Inhabited when exactly one of its three propositions is true.

Can be used to express the various "trichotomy" properties in algebra.
-/
structure ExactlyOneOfThree (α β γ : Prop) : Prop :=
  atLeastOne :   OneOfThree α β γ
  atMostOne  : ¬ TwoOfThree α β γ

/--
Converts all propositions in `ExactlyOneOfThree` to equivalents while
preserving the one that's inhabited.

Intended to be used in contexts where the mapping functions are previously
defined, to keep the code compact.
-/
def ExactlyOneOfThree.map
    {α₁ α₂ β₁ β₂ γ₁ γ₂ : Prop}
    : ExactlyOneOfThree α₁ β₁ γ₁ → (α₁ ↔ α₂) → (β₁ ↔ β₂) → (γ₁ ↔ γ₂)
    → ExactlyOneOfThree α₂ β₂ γ₂
    := by
  intro (x : ExactlyOneOfThree α₁ β₁ γ₁)
  intro (f : α₁ ↔ α₂) (g : β₁ ↔ β₂) (h : γ₁ ↔ γ₂)
  have atLeastOne : OneOfThree α₂ β₂ γ₂ := x.atLeastOne.map f.mp g.mp h.mp
  have atMostOne : ¬TwoOfThree α₂ β₂ γ₂ :=
    mt (TwoOfThree.map f.mpr g.mpr h.mpr) x.atMostOne
  exact ExactlyOneOfThree.mk atLeastOne atMostOne

/--
"Rotates" `ExactlyOneOfThree`'s propositions one place to the left: the
leftmost one becomes the rightmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `ExactlyOneOfThree.map` to translate between arbitrary
`ExactlyOneOfThree` types.
-/
def ExactlyOneOfThree.rotL
    {α β γ : Prop} : ExactlyOneOfThree α β γ → ExactlyOneOfThree β γ α
    := by
  intro (x : ExactlyOneOfThree α β γ)
  have atLeastOne : OneOfThree β γ α := x.atLeastOne.rotL
  have atMostOne : ¬TwoOfThree β γ α := mt TwoOfThree.rotR x.atMostOne
  exact ExactlyOneOfThree.mk atLeastOne atMostOne

/--
"Rotates" `ExactlyOneOfThree`'s propositions one place to the right: the
rightmost one becomes the leftmost.

This merely changes how the type is written; the value is preserved. Useful
in conjunction with `ExactlyOneOfThree.map` to translate between arbitrary
`ExactlyOneOfThree` types.
-/
def ExactlyOneOfThree.rotR
    {α β γ : Prop} : ExactlyOneOfThree α β γ → ExactlyOneOfThree γ α β
    := by
  intro (x : ExactlyOneOfThree α β γ)
  have atLeastOne : OneOfThree γ α β := x.atLeastOne.rotR
  have atMostOne : ¬TwoOfThree γ α β := mt TwoOfThree.rotL x.atMostOne
  exact ExactlyOneOfThree.mk atLeastOne atMostOne

/--
Swaps the middle two elements of a balanced four-element expression involving a
single binary operation.

The sort `α` and its binary operation `f` must form a commutative semigroup.

**Named parameters**
- `α`: the sort over which `f` operates.
- `f`: the binary operation used in the expression.
- `a`, `b`, `c`, `d`: the operands to `f` in the expression.

**Class parameters**
- `EqvOp α`: needed to express the identity between expressions.
- `Associative f`, `Commutative f`: needed to rearrange the operands freely.
- `Substitutive₂ f tc (· ≃ ·) (· ≃ ·)`: needed to rearrange subexpressions.
-/
theorem expr_xxfxxff_lr_swap_rl
    {α : Sort u} {f : α → α → α} {a b c d : α} [EqvOp α]
    [Associative f] [Commutative f] [Substitutive₂ f tc (· ≃ ·) (· ≃ ·)]
    : f (f a b) (f c d) ≃ f (f a c) (f b d)
    := calc
  f (f a b) (f c d) ≃ _ := AA.assoc
  f a (f b (f c d)) ≃ _ := AA.substR (Rel.symm AA.assoc)
  f a (f (f b c) d) ≃ _ := AA.substR (AA.substL AA.comm)
  f a (f (f c b) d) ≃ _ := AA.substR AA.assoc
  f a (f c (f b d)) ≃ _ := Rel.symm AA.assoc
  f (f a c) (f b d) ≃ _ := Rel.refl

/--
Swaps the second and fourth elements of a balanced four-element expression
involving a single binary operation.

The sort `α` and its binary operation `f` must form a commutative semigroup.

**Named parameters**
- `α`: the sort over which `f` operates.
- `f`: the binary operation used in the expression.
- `a`, `b`, `c`, `d`: the operands to `f` in the expression.

**Class parameters**
- `EqvOp α`: needed to express the identity between expressions.
- `Associative f`, `Commutative f`: needed to rearrange the operands freely.
- `Substitutive₂ f tc (· ≃ ·) (· ≃ ·)`: needed to rearrange subexpressions.
-/
theorem expr_xxfxxff_lr_swap_rr
    {α : Sort u} {f : α → α → α} {a b c d : α} [EqvOp α]
    [Associative f] [Commutative f] [Substitutive₂ f tc (· ≃ ·) (· ≃ ·)]
    : f (f a b) (f c d) ≃ f (f a d) (f c b)
    := calc
  f (f a b) (f c d) ≃ _ := AA.substR AA.comm
  f (f a b) (f d c) ≃ _ := expr_xxfxxff_lr_swap_rl
  f (f a d) (f b c) ≃ _ := AA.substR AA.comm
  f (f a d) (f c b) ≃ _ := Rel.refl

end Lean4Axiomatic.AA


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module combinatorics.partition
! leanprover-community/mathlib commit dc6c365e751e34d100e80fe6e314c3c3e0fd2988
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.Composition
import Mathlib.Data.Nat.Parity
import Mathlib.Tactic.ApplyFun

/-!
# Partitions

A partition of a natural number `n` is a way of writing `n` as a sum of positive integers, where the
order does not matter: two sums that differ only in the order of their summands are considered the
same partition. This notion is closely related to that of a composition of `n`, but in a composition
of `n` the order does matter.
A summand of the partition is called a part.

## Main functions

* `p : Partition n` is a structure, made of a multiset of integers which are all positive and
  add up to `n`.

## Implementation details

The main motivation for this structure and its API is to show Euler's partition theorem, and
related results.

The representation of a partition as a multiset is very handy as multisets are very flexible and
already have a well-developed API.

## Tags

Partition

## References

<https://en.wikipedia.org/wiki/Partition_(number_theory)>
-/

variable {α : Type _}

open Multiset

open BigOperators

namespace Nat

/-- A partition of `n` is a multiset of positive integers summing to `n`. -/
@[ext]
structure Partition (n : ℕ) where
  /-- positive integers summing to `n`-/
  parts : Multiset ℕ
  /-- proof that the `parts` are positive-/
  parts_pos : ∀ {i}, i ∈ parts → 0 < i
  /-- proof that the `parts` sum to `n`-/
  parts_sum : parts.sum = n
  -- porting notes: chokes on `parts_pos`
  --deriving DecidableEq
#align nat.partition Nat.Partition

namespace Partition

instance decidableEqParition: DecidableEq (Partition n)
  | p, q => by simp [Partition.ext_iff]; exact decidableEq p.parts q.parts

/-- A composition induces a partition (just convert the list to a multiset). -/
def ofComposition (n : ℕ) (c : Composition n) : Partition n
    where
  parts := c.blocks
  parts_pos {i} hi := c.blocks_pos hi
  parts_sum := by rw [Multiset.coe_sum, c.blocks_sum]
#align nat.partition.of_composition Nat.Partition.ofComposition

theorem ofComposition_surj {n : ℕ} : Function.Surjective (ofComposition n) := by
  rintro ⟨b, hb₁, hb₂⟩
  rcases Quotient.exists_rep b with ⟨b, rfl⟩
  refine' ⟨⟨b, fun {i} hi => hb₁ hi, _⟩, Partition.ext _ _ rfl⟩
  simpa using hb₂
#align nat.partition.of_composition_surj Nat.Partition.ofComposition_surj

-- The argument `n` is kept explicit here since it is useful in tactic mode proofs to generate the
-- proof obligation `l.sum = n`.
/-- Given a multiset which sums to `n`, construct a partition of `n` with the same multiset, but
without the zeros.
-/
def ofSums (n : ℕ) (l : Multiset ℕ) (hl : l.sum = n) : Partition n
    where
  parts := l.filter (· ≠ 0)
  parts_pos {i} hi := Nat.pos_of_ne_zero <| by apply of_mem_filter hi
  parts_sum := by
    have lt : l.filter (· = 0) + l.filter (· ≠ 0) = l := filter_add_not _ l
    apply_fun Multiset.sum  at lt
    have lz : (l.filter (· = 0)).sum = 0 :=
      by
      rw [Multiset.sum_eq_zero_iff]
      simp
    rwa [sum_add (filter (fun x => x = 0) l) (filter (fun x => ¬x = 0) l),lz,hl, zero_add] at lt
#align nat.partition.of_sums Nat.Partition.ofSums

/-- A `Multiset ℕ` induces a partition on its sum. -/
def ofMultiset (l : Multiset ℕ) : Partition l.sum :=
  ofSums _ l rfl
#align nat.partition.of_multiset Nat.Partition.ofMultiset

/-- The partition of exactly one part. -/
def indiscretePartition (n : ℕ) : Partition n :=
  ofSums n {n} rfl
#align nat.partition.indiscrete_partition Nat.Partition.indiscretePartition

instance {n : ℕ} : Inhabited (Partition n) :=
  ⟨indiscretePartition n⟩

/-- The number of times a positive integer `i` appears in the partition `ofSums n l hl` is the same
as the number of times it appears in the multiset `l`.
(For `i = 0`, `Partition.non_zero` combined with `Multiset.count_eq_zero_of_not_mem` gives that
this is `0` instead.)
-/
theorem count_ofSums_of_ne_zero {n : ℕ} {l : Multiset ℕ} (hl : l.sum = n) {i : ℕ} (hi : i ≠ 0) :
    (ofSums n l hl).parts.count i = l.count i :=
  count_filter_of_pos hi
#align nat.partition.count_of_sums_of_ne_zero Nat.Partition.count_ofSums_of_ne_zero

theorem count_ofSums_zero {n : ℕ} {l : Multiset ℕ} (hl : l.sum = n) :
    (ofSums n l hl).parts.count 0 = 0 :=
  count_filter_of_neg fun h => h rfl
#align nat.partition.count_of_sums_zero Nat.Partition.count_ofSums_zero

/-- Show there are finitely many partitions by considering the surjection from compositions to
partitions.
-/
instance (n : ℕ) : Fintype (Partition n) :=
  Fintype.ofSurjective (ofComposition n) ofComposition_surj

/-- The finset of those partitions in which every part is odd. -/
def odds (n : ℕ) : Finset (Partition n) :=
  Finset.univ.filter fun c => ∀ i ∈ c.parts, ¬Even i
#align nat.partition.odds Nat.Partition.odds

/-- The finset of those partitions in which each part is used at most once. -/
def distincts (n : ℕ) : Finset (Partition n) :=
  Finset.univ.filter fun c => c.parts.Nodup
#align nat.partition.distincts Nat.Partition.distincts

/-- The finset of those partitions in which every part is odd and used at most once. -/
def oddDistincts (n : ℕ) : Finset (Partition n) :=
  odds n ∩ distincts n
#align nat.partition.odd_distincts Nat.Partition.oddDistincts

end Partition

end Nat