/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Neil Strickland
-/
import order.basic
import algebra.ne_zero

/-!
# The positive natural numbers

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

This file contains the definitions, and basic results.
Most algebraic facts are deferred to `data.pnat.basic`, as they need more imports.
-/

/-- `ℕ+` is the type of positive natural numbers. It is defined as a subtype,
  and the VM representation of `ℕ+` is the same as `ℕ` because the proof
  is not stored. -/
@[derive [decidable_eq, linear_order]]
def pnat := {n : ℕ // 0 < n}
notation `ℕ+` := pnat

instance : has_one ℕ+ := ⟨⟨1, nat.zero_lt_one⟩⟩

instance coe_pnat_nat : has_coe ℕ+ ℕ := ⟨subtype.val⟩
instance : has_repr ℕ+ := ⟨λ n, repr n.1⟩

namespace pnat

@[simp] theorem mk_coe (n h) : ((⟨n, h⟩ : ℕ+) : ℕ) = n := rfl

/-- Predecessor of a `ℕ+`, as a `ℕ`. -/
def nat_pred (i : ℕ+) : ℕ := i - 1

@[simp]

end pnat

namespace nat

/-- Convert a natural number to a positive natural number. The
  positivity assumption is inferred by `dec_trivial`. -/
def to_pnat (n : ℕ) (h : 0 < n . tactic.exact_dec_trivial) : ℕ+ := ⟨n, h⟩

/-- Write a successor as an element of `ℕ+`. -/
def succ_pnat (n : ℕ) : ℕ+ := ⟨succ n, succ_pos n⟩

@[simp] theorem succ_pnat_coe (n : ℕ) : (succ_pnat n : ℕ) = succ n := rfl

@[simp] theorem nat_pred_succ_pnat (n : ℕ) : n.succ_pnat.nat_pred = n := rfl

@[simp] theorem _root_.pnat.succ_pnat_nat_pred (n : ℕ+) : n.nat_pred.succ_pnat = n :=
subtype.eq $ succ_pred_eq_of_pos n.2

/-- Convert a natural number to a pnat. `n+1` is mapped to itself,
  and `0` becomes `1`. -/
def to_pnat' (n : ℕ) : ℕ+ := succ_pnat (pred n)

@[simp] theorem to_pnat'_coe : ∀ (n : ℕ),
 ((to_pnat' n) : ℕ) = ite (0 < n) n 1
| 0 := rfl
| (m + 1) := by {rw [if_pos (succ_pos m)], refl}

end nat

namespace pnat

open nat

/-- We now define a long list of structures on ℕ+ induced by
 similar structures on ℕ. Most of these behave in a completely
 obvious way, but there are a few things to be said about
 subtraction, division and powers.
-/

@[simp] lemma mk_le_mk (n k : ℕ) (hn : 0 < n) (hk : 0 < k) :
  (⟨n, hn⟩ : ℕ+) ≤ ⟨k, hk⟩ ↔ n ≤ k := iff.rfl

@[simp] lemma mk_lt_mk (n k : ℕ) (hn : 0 < n) (hk : 0 < k) :
  (⟨n, hn⟩ : ℕ+) < ⟨k, hk⟩ ↔ n < k := iff.rfl

@[simp, norm_cast] lemma coe_le_coe (n k : ℕ+) : (n : ℕ) ≤ k ↔ n ≤ k := iff.rfl

@[simp, norm_cast] lemma coe_lt_coe (n k : ℕ+) : (n : ℕ) < k ↔ n < k := iff.rfl

@[simp] theorem pos (n : ℕ+) : 0 < (n : ℕ) := n.2

theorem eq {m n : ℕ+} : (m : ℕ) = n → m = n := subtype.eq

lemma coe_injective : function.injective (coe : ℕ+ → ℕ) := subtype.coe_injective

@[simp] theorem ne_zero (n : ℕ+) : (n : ℕ) ≠ 0 := n.2.ne'

instance _root_.ne_zero.pnat {a : ℕ+} : _root_.ne_zero (a : ℕ) := ⟨a.ne_zero⟩

theorem to_pnat'_coe {n : ℕ} : 0 < n → (n.to_pnat' : ℕ) = n := succ_pred_eq_of_pos

@[simp] theorem coe_to_pnat' (n : ℕ+) : (n : ℕ).to_pnat' = n := eq (to_pnat'_coe n.pos)

@[simp] lemma one_le (n : ℕ+) : (1 : ℕ+) ≤ n := n.2

@[simp] lemma not_lt_one (n : ℕ+) : ¬ n < 1 := not_lt_of_le n.one_le

instance : inhabited ℕ+ := ⟨1⟩

-- Some lemmas that rewrite `pnat.mk n h`, for `n` an explicit numeral, into explicit numerals.
@[simp] lemma mk_one {h} : (⟨1, h⟩ : ℕ+) = (1 : ℕ+) := rfl

@[norm_cast] theorem one_coe : ((1 : ℕ+) : ℕ) = 1 := rfl

@[simp, norm_cast] lemma coe_eq_one_iff {m : ℕ+} : (m : ℕ) = 1 ↔ m = 1 :=
subtype.coe_injective.eq_iff' one_coe

instance : has_well_founded ℕ+ := ⟨(<), measure_wf coe⟩

/-- Strong induction on `ℕ+`. -/
def strong_induction_on {p : ℕ+ → Sort*} : ∀ (n : ℕ+) (h : ∀ k, (∀ m, m < k → p m) → p k), p n
| n := λ IH, IH _ (λ a h, strong_induction_on a IH)
using_well_founded { dec_tac := `[assumption] }

/-- We define `m % k` and `m / k` in the same way as for `ℕ`
  except that when `m = n * k` we take `m % k = k` and
  `m / k = n - 1`.  This ensures that `m % k` is always positive
  and `m = (m % k) + k * (m / k)` in all cases.  Later we
  define a function `div_exact` which gives the usual `m / k`
  in the case where `k` divides `m`.
-/
def mod_div_aux : ℕ+ → ℕ → ℕ → ℕ+ × ℕ
| k 0 q := ⟨k, q.pred⟩
| k (r + 1) q := ⟨⟨r + 1, nat.succ_pos r⟩, q⟩

/-- `mod_div m k = (m % k, m / k)`.
  We define `m % k` and `m / k` in the same way as for `ℕ`
  except that when `m = n * k` we take `m % k = k` and
  `m / k = n - 1`.  This ensures that `m % k` is always positive
  and `m = (m % k) + k * (m / k)` in all cases.  Later we
  define a function `div_exact` which gives the usual `m / k`
  in the case where `k` divides `m`.
-/
def mod_div (m k : ℕ+) : ℕ+ × ℕ := mod_div_aux k ((m : ℕ) % (k : ℕ)) ((m : ℕ) / (k : ℕ))

/-- We define `m % k` in the same way as for `ℕ`
  except that when `m = n * k` we take `m % k = k` This ensures that `m % k` is always positive.
-/
def mod (m k : ℕ+) : ℕ+ := (mod_div m k).1

/-- We define `m / k` in the same way as for `ℕ` except that when `m = n * k` we take
  `m / k = n - 1`. This ensures that `m = (m % k) + k * (m / k)` in all cases. Later we
  define a function `div_exact` which gives the usual `m / k` in the case where `k` divides `m`.
-/
def div (m k : ℕ+) : ℕ  := (mod_div m k).2

theorem mod_coe (m k : ℕ+) :
 ((mod m k) : ℕ) = ite ((m : ℕ) % (k : ℕ) = 0) (k : ℕ) ((m : ℕ) % (k : ℕ)) :=
begin
  dsimp [mod, mod_div],
  cases (m : ℕ) % (k : ℕ),
  { rw [if_pos rfl], refl },
  { rw [if_neg n.succ_ne_zero], refl }
end

theorem div_coe (m k : ℕ+) :
 ((div m k) : ℕ) = ite ((m : ℕ) % (k : ℕ) = 0) ((m : ℕ) / (k : ℕ)).pred ((m : ℕ) / (k : ℕ)) :=
begin
  dsimp [div, mod_div],
  cases (m : ℕ) % (k : ℕ),
  { rw [if_pos rfl], refl },
  { rw [if_neg n.succ_ne_zero], refl }
end

/-- If `h : k | m`, then `k * (div_exact m k) = m`. Note that this is not equal to `m / k`. -/
def div_exact (m k : ℕ+) : ℕ+ :=
 ⟨(div m k).succ, nat.succ_pos _⟩

end pnat

section can_lift

instance nat.can_lift_pnat : can_lift ℕ ℕ+ coe ((<) 0) :=
⟨λ n hn, ⟨nat.to_pnat' n, pnat.to_pnat'_coe hn⟩⟩

instance int.can_lift_pnat : can_lift ℤ ℕ+ coe ((<) 0) :=
⟨λ n hn, ⟨nat.to_pnat' (int.nat_abs n),
  by rw [coe_coe, nat.to_pnat'_coe, if_pos (int.nat_abs_pos_of_ne_zero hn.ne'),
    int.nat_abs_of_nonneg hn.le]⟩⟩

end can_lift


import .lovelib

/-! # LoVe Exercise 3: Forward Proofs -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: Connectives and Quantifiers

1.1. Supply structured proofs of the following lemmas. -/

lemma I (a : Prop) :
  a → a :=
assume ha : a,
show a, from
  ha

lemma K (a b : Prop) :
  a → b → b :=
assume ha : a,
assume hb : b,
show b, from
  hb

lemma C (a b c : Prop) :
  (a → b → c) → b → a → c :=
assume hg : a → b → c,
assume hb : b,
assume ha : a,
show c, from
  hg ha hb

lemma proj_1st (a : Prop) :
  a → a → a :=
assume ha ha' : a,
show a, from
  ha

/-! Please give a different answer than for `proj_1st`. -/

lemma proj_2nd (a : Prop) :
  a → a → a :=
assume ha ha' : a,
show a, from
  ha'

lemma some_nonsense (a b c : Prop) :
  (a → b → c) → a → (a → c) → b → c :=
assume hg : a → b → c,
assume ha : a,
assume hf : a → c,
assume hb : b,
have hc : c :=
  hf ha,
show c, from
  hc

/-! 1.2. Supply a structured proof of the contraposition rule. -/

lemma contrapositive (a b : Prop) :
  (a → b) → ¬ b → ¬ a :=
assume hab : a → b,
assume hnb : ¬ b,
assume ha : a,
have hb : b :=
  hab ha,
show false, from
  hnb hb

/-! 1.3. Supply a structured proof of the distributivity of `∀` over `∧`. -/

lemma forall_and {α : Type} (p q : α → Prop) :
  (∀x, p x ∧ q x) ↔ (∀x, p x) ∧ (∀x, q x) :=
iff.intro
  (assume hpq : ∀x, p x ∧ q x,
   have hp : ∀x, p x :=
     fix x,
     and.elim_left (hpq x),
   have hq : ∀x, q x :=
     fix x,
     and.elim_right (hpq x),
   show (∀x, p x) ∧ (∀x, q x), from
     and.intro hp hq)
  (assume hpq : (∀x, p x) ∧ (∀x, q x),
   have hp : ∀x, p x :=
     and.elim_left hpq,
   have hq : ∀x, q x :=
     and.elim_right hpq,
   assume x : α,
   show p x ∧ q x, from
     and.intro (hp x) (hq x))

/-! 1.4 (**optional**). Reuse, if possible, the lemma `forall_and` from question
1.3 to prove the following instance of the lemma. -/

lemma forall_and_inst {α : Type} (r s : α → α → Prop) :
  (∀x, r x x ∧ s x x) ↔ (∀x, r x x) ∧ (∀x, s x x) :=
forall_and (λx, r x x) (λx, s x x)

/-! 1.5. Supply a structured proof of the following property, which can be used
pull a `∀`-quantifier past an `∃`-quantifier. -/

lemma forall_exists_of_exists_forall {α : Type} (p : α → α → Prop) :
  (∃x, ∀y, p x y) → (∀y, ∃x, p x y) :=
assume hpxy : ∃x, ∀y, p x y,
fix b,
show ∃x, p x b, from
  exists.elim hpxy
    (fix a,
     assume hpay : ∀y, p a y,
     show ∃x, p x b, from
       exists.intro a (hpay b))

/-! ## Question 2: Chain of Equalities

2.1. Write the following proof using `calc`.

      (a + b) * (a + b)
    = a * (a + b) + b * (a + b)
    = a * a + a * b + b * a + b * b
    = a * a + a * b + a * b + b * b
    = a * a + 2 * a * b + b * b

Hint: You might need the tactics `simp` and `cc` and the lemmas `mul_add`,
`add_mul`, and `two_mul`. -/

lemma binomial_square (a b : ℕ) :
  (a + b) * (a + b) = a * a + 2 * a * b + b * b :=
calc  (a + b) * (a + b)
    = a * (a + b) + b * (a + b) :
  begin
    simp [add_mul, mul_add],
    cc
  end
... = a * a + a * b + b * a + b * b :
  begin
    simp [add_mul, mul_add],
    cc
  end
... = a * a + a * b + a * b + b * b :
  by cc
... = a * a + 2 * a * b + b * b :
  begin
    simp [two_mul, mul_add, add_mul],
    cc
  end

/-! 2.2 (**optional**). Prove the same argument again, this time as a structured
proof, with `have` steps corresponding to the `calc` equations. Try to reuse as
much of the above proof idea as possible, proceeding mechanically. -/

lemma binomial_square₂ (a b : ℕ) :
  (a + b) * (a + b) = a * a + 2 * a * b + b * b :=
have h1 : (a + b) * (a + b) = a * (a + b) + b * (a + b) :=
  begin
    simp [add_mul, mul_add],
    cc
  end,
have h2 : a * (a + b) + b * (a + b) = a * a + a * b + b * a + b * b :=
  begin
    simp [add_mul, mul_add],
    cc
  end,
have h3 : a * a + a * b + b * a + b * b = a * a + a * b + a * b + b * b :=
  begin
    simp,
    cc
  end,
have h4 : a * a + a * b + a * b + b * b = a * a + 2 * a * b + b * b :=
  begin
    simp [two_mul, add_mul, mul_add],
    cc
  end,
show _, from
  begin
    rw h1,
    rw h2,
    rw h3,
    rw h4
  end

/-! 2.3. Prove the same lemma again, this time using tactics. -/

lemma binomial_square₃ (a b : ℕ) :
  (a + b) * (a + b) = a * a + 2 * a * b + b * b :=
begin
  simp [two_mul, add_mul, mul_add],
  cc
end

/-! ## Question 3 (**optional**): One-Point Rules

3.1 (**optional**). Prove that the following wrong formulation of the one-point
rule for `∀` is inconsistent, using a structured proof. -/

axiom forall.one_point_wrong {α : Type} {t : α} {p : α → Prop} :
  (∀x : α, x = t ∧ p x) ↔ p t

lemma proof_of_false :
  false :=
begin
  have wrong : (∀x, x = 0 ∧ true) ↔ true :=
    @forall.one_point_wrong ℕ 0 (λ_, true),
  simp at wrong,
  have one_eq_zero : 1 = 0 :=
    wrong 1,
  cc
end

/-! 3.2 (**optional**). Prove that the following wrong formulation of the
one-point rule for `∃` is inconsistent, using a tactical or structured proof. -/

axiom exists.one_point_wrong {α : Type} {t : α} {p : α → Prop} :
  (∃x : α, x = t → p x) ↔ p t

lemma proof_of_false₂ :
  false :=
begin
  have wrong : (∃x, x ≠ 0) ↔ false :=
    @exists.one_point_wrong ℕ 0 (λ_, false),
  simp at wrong,
  have one_eq_zero : 1 = 0 :=
    wrong 1,
  cc
end

end LoVe


constants p q : Prop

theorem t1 : p → q → p := λ hp : p, λ hq : q, hp

theorem t1' : p→ q → p :=
begin
    intros hp hq,
    exact hp,
end

theorem t1'' (hp : p) (hq : q) : p := hp

axiom hp : p
theorem t2 : q → p := t1' hp

-- Quantify over all propositions
theorem t1''' (p q : Prop) (hp : p) (hq : q): p := hp

#check t1'''
#check t1''

variables r s : Prop
#check t1''' r
#check t1''' r s

#check assume (hp : p) (hq : q), and.intro hp hq
example (hp : p) (hq :q) : p ∧ q := ⟨hp, hq⟩

-- SYNTACTIC SUGAR
variable l : list ℕ
#check l.head
#check list.head l
--chef's kiss

-- OR
example (h : p ∨ q) : q ∨ p :=
or.elim
h                 -- proof of p ∨ q
(λ hp, or.inr hp) -- proof of p → q ∨ p
(λ hq, or.inl hq) -- proof of q → q ∨ p

-- True and False
-- Neat lingo!
example (hnp : ¬p) (hq : q) (hqp : q → p) : r :=
absurd -- You are
(hqp hq) -- (proof of q → p)(proof of q) = proof of p
hnp -- proof of ¬p

example (hp : p) : true := trivial -- Nice

-- IFF
theorem and_swap : p ∧ q ↔ q ∧ p :=
iff.intro
(λ h : p ∧ q, and.intro h.right h.left)
(λ h : q ∧ p, and.intro h.right h.left)

---------------------
---------------------
---------------------

-- Ex 1
variables p q  : Prop

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := iff.intro
(λ h : p ∧ q, and.intro h.right h.left)
(λ h : q ∧ p, and.intro h.right h.left)

example : p ∨ q ↔ q ∨ p := iff.intro
(λ h: p ∨ q, or.elim h or.inr or.inl)
(λ h: q ∨ p, or.elim h or.inr or.inl)

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := iff.intro
(λ x : (p ∧ q) ∧ r, and.intro x.1.1 (and.intro x.1.2 x.2))
(λ x : p ∧ (q ∧ r), and.intro (and.intro x.1 x.2.1) x.2.2)

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := iff.intro
(λ x : (p ∨ q) ∨ r, or.elim x
  (λ y : p ∨ q, or.elim y or.inl (λ z : q, or.inr (or.inl z)))
  (λ y : r, or.intro_right p (or.intro_right q y))
)
(λ x : p ∨ (q ∨ r), or.elim x
  (λ y : p, or.intro_left r (or.intro_left q y))
  (λ y : q ∨ r, or.elim y (λ z : q, or.inl (or.inr z)) or.inr)
)

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := iff.intro
(λ x, and.elim x
  (λ a b, or.elim b
    (λ z, or.inl (and.intro a z))
    (λ z, or.inr (and.intro a z))
  )
)
(λ x, or.elim x
  (λ y, have q ∨ r, from or.inl y.right, and.intro y.left this)
  (λ y, have q ∨ r, from or.inr y.right, and.intro y.left this)
)

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := iff.intro
(λ x, or.elim x
  (λ z, and.intro (or.inl z) (or.inl z))
  (λ z, z.elim
    (λ a b, and.intro (or.inr z.1) (or.inr z.2))
  )
)
(λ x, and.elim x
  (λ y z, or.elim y
    (λ a, or.inl a)
    (λ b, or.elim z
      (λ a, or.inl a)
      (λ c, or.inr (and.intro b c))
    )
  )
)

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := iff.intro
(λ a b, a (b.1) (b.2))
(λ a b c, a (and.intro b c))

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) := iff.intro
(λ x, and.intro
  (λ y, x (or.inl y))
  (λ y, x (or.inr y))
)
(λ x y, or.elim y
  (λ z, x.1 z)
  (λ z, x.2 z)
)

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := iff.intro
(λ x, and.intro
  (λ y, x (or.inl y))
  (λ y, x (or.inr y))
)
(λ x y, or.elim y
  (have z:p, from or.elim y (λ x,x) (λ z, absurd z x.2 ), absurd z x.1)
  (λ z, absurd z x.2)
)

example : ¬p ∨ ¬q → ¬(p ∧ q) := λ x y, or.elim x (absurd y.1) (absurd y.2)

example : ¬(p ∧ ¬p) := λ x, absurd x.1 x.2

example : p ∧ ¬q → ¬(p → q) := λ x y, absurd (y x.1) x.2

example : ¬p → (p → q) := λ x y, absurd y x

example : (¬p ∨ q) → (p → q) := λ x y, or.elim x (λ z, absurd y z) (λ x, x)

example : p ∨ false ↔ p := iff.intro
(λ x, x.elim (λ y, y) (λ y, have ¬ false, from (λ z, z), (absurd y this)))
(λ x, or.inl x)

example : p ∧ false ↔ false := iff.intro
(λ x, x.2)
(λ x, have s :p, from (have s: ¬false, from (λ z, z), (absurd x s)), and.intro s x)

example : (p → q) → (¬q → ¬p) := λ x y z, absurd (x z) y

-- Ex 3
-- Not supposed to have classical open, so I am doing it first. :)
example : ¬(p ↔ ¬p) := (λ x,
  have h : p → ¬p, from (iff.elim_left x),
  have h' : ¬p → p, from (iff.elim_right x),
  have k : p → false, from (assume h'' : p, absurd h'' (h h'')),
  have k': p, from (h' k),
  absurd k' k
)

-- Ex 2
open classical

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) := λ x, by_cases
  (assume h : r, have h1: p → r, from (λ x, h), or.inl h1)
  (assume h : ¬r, have h1: p → s, from
    (λ z, or.elim (x z)
      (λ w, (absurd w h))
      (have h2 : p → s, from or.elim (x z) (λ t, absurd t h) (λ a b, a), λ a, a)
    ),
    or.inr h1
  )

example : ¬(p ∧ q) → ¬p ∨ ¬q := λ x, by_cases
  (assume h : p, (by_cases
    (assume h': q, absurd (and.intro h h') x)
    (assume h': ¬q, or.inr h')
  ))
  (assume h : ¬p, or.inl h)

example : ¬(p → q) → p ∧ ¬q := λ x, by_cases
(assume h : q, have h1 : p → q, from (λ _, h), absurd h1 x)
(assume h: ¬q, by_cases
  (assume s : p, and.intro s h)
  (assume s : ¬p, have h1: p → q, from (λ a, absurd a s), absurd h1 x)
)

example : (p → q) → (¬p ∨ q) := λ x, by_cases
(assume h : p, or.inr (x h))
(assume h : ¬p, or.inl h)

example : (¬q → ¬p) → (p → q) := λ x y, by_cases
(assume h : q, h)
(assume h : ¬q, absurd y (x h))

example : p ∨ ¬p := em p

example : (((p → q) → p) → p) := by_cases
(assume h : p, λ _, h)
(assume h : ¬p, λ x, have h1 : p → q, from (λ y, absurd y h), x h1)


/-
Copyright (c) 2022 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import linear_algebra.multilinear.basic
import linear_algebra.free_module.finite.matrix

/-! # Multilinear maps over finite dimensional spaces

The main results are that multilinear maps over finitely-generated, free modules are
finitely-generated and free.

* `module.finite.multilinear_map`
* `module.free.multilinear_map`

We do not put this in `linear_algebra/multilinear_map/basic` to avoid making the imports too large
there.
-/

namespace multilinear_map

variables {ι R M₂ : Type*} {M₁ : ι → Type*}
variables [finite ι]
variables [comm_ring R] [add_comm_group M₂] [module R M₂]
variables [Π i, add_comm_group (M₁ i)] [Π i, module R (M₁ i)]
variables [module.finite R M₂] [module.free R M₂]
variables [∀ i, module.finite R (M₁ i)] [∀ i, module.free R (M₁ i)]

-- the induction requires us to show both at once
private lemma free_and_finite :
  module.free R (multilinear_map R M₁ M₂) ∧ module.finite R (multilinear_map R M₁ M₂) :=
begin
  -- the `fin n` case is sufficient
  suffices : ∀ n (N : fin n → Type*) [Π i, add_comm_group (N i)],
    by exactI ∀ [Π i, module R (N i)],
    by exactI ∀ [∀ i, module.finite R (N i)] [∀ i, module.free R (N i)],
      module.free R (multilinear_map R N M₂) ∧ module.finite R (multilinear_map R N M₂),
  { casesI nonempty_fintype ι,
    casesI this _ (M₁ ∘ (fintype.equiv_fin ι).symm),
    have e := dom_dom_congr_linear_equiv' R M₁ M₂ (fintype.equiv_fin ι),
    exact ⟨module.free.of_equiv e.symm, module.finite.equiv e.symm⟩, },
  introsI n N _ _ _ _,
  unfreezingI { induction n with n ih },
  { exact ⟨module.free.of_equiv (const_linear_equiv_of_is_empty R N M₂),
           module.finite.equiv (const_linear_equiv_of_is_empty R N M₂)⟩ },
  { suffices :
      module.free R (N 0 →ₗ[R] multilinear_map R (λ (i : fin n), N i.succ) M₂) ∧
      module.finite R (N 0 →ₗ[R] multilinear_map R (λ (i : fin n), N i.succ) M₂),
    { casesI this,
      exact ⟨module.free.of_equiv (multilinear_curry_left_equiv R N M₂),
            module.finite.equiv (multilinear_curry_left_equiv R N M₂)⟩ },
    casesI ih (λ i, N i.succ),
    exact ⟨module.free.linear_map _ _ _, module.finite.linear_map _ _⟩ },
end

instance _root_.module.finite.multilinear_map : module.finite R (multilinear_map R M₁ M₂) :=
free_and_finite.2

instance _root_.module.free.multilinear_map : module.free R (multilinear_map R M₁ M₂) :=
free_and_finite.1

end multilinear_map


theorem succ_eq_add_one (n : mynat) : succ n = n + 1 :=
begin
rw one_eq_succ_zero,
rw add_succ,
rw add_zero,
refl,
end


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro
-/
import data.subtype
import data.prod

/-!
# Basic definitions about `≤` and `<`

## Definitions

### Predicates on functions

- `monotone f`: a function between two types equipped with `≤` is monotone
  if `a ≤ b` implies `f a ≤ f b`.
- `strict_mono f` : a function between two types equipped with `<` is strictly monotone
  if `a < b` implies `f a < f b`.
- `order_dual α` : a type tag reversing the meaning of all inequalities.

### Transfering orders

- `order.preimage`, `preorder.lift`: transfer a (pre)order on `β` to an order on `α`
  using a function `f : α → β`.
- `partial_order.lift`, `linear_order.lift`: transfer a partial (resp., linear) order on `β` to a
  partial (resp., linear) order on `α` using an injective function `f`.

### Extra classes

- `no_top_order`, `no_bot_order`: an order without a maximal/minimal element.
- `densely_ordered`: an order with no gaps, i.e. for any two elements `a<b` there exists
  `c`, `a<c<b`.

## Main theorems

- `monotone_of_monotone_nat`: if `f : ℕ → α` and `f n ≤ f (n + 1)` for all `n`, then
  `f` is monotone;
- `strict_mono.nat`: if `f : ℕ → α` and `f n < f (n + 1)` for all `n`, then f is strictly monotone.

## TODO

- expand module docs
- automatic construction of dual definitions / theorems

## See also
- `algebra.order` for basic lemmas about orders, and projection notation for orders

## Tags

preorder, order, partial order, linear order, monotone, strictly monotone
-/

open function

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w} {r : α → α → Prop}

@[simp] lemma lt_self_iff_false [preorder α] (a : α) : a < a ↔ false :=
by simp [lt_irrefl a]

attribute [ext] has_le

@[ext]
lemma preorder.to_has_le_injective {α : Type*} :
  function.injective (@preorder.to_has_le α) :=
λ A B h, begin
  cases A, cases B,
  injection h with h_le,
  have : A_lt = B_lt,
  { funext a b,
    dsimp [(≤)] at A_lt_iff_le_not_le B_lt_iff_le_not_le h_le,
    simp [A_lt_iff_le_not_le, B_lt_iff_le_not_le, h_le], },
  congr',
end

@[ext]
lemma partial_order.to_preorder_injective {α : Type*} :
  function.injective (@partial_order.to_preorder α) :=
λ A B h, by { cases A, cases B, injection h, congr' }

@[ext]
lemma linear_order.to_partial_order_injective {α : Type*} :
  function.injective (@linear_order.to_partial_order α) :=
λ A B h, by { cases A, cases B, injection h, congr' }

theorem preorder.ext {α} {A B : preorder α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

theorem partial_order.ext {α} {A B : partial_order α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

theorem linear_order.ext {α} {A B : linear_order α}
  (H : ∀ x y : α, (by haveI := A; exact x ≤ y) ↔ x ≤ y) : A = B :=
by { ext x y, exact H x y }

/-- Given a relation `R` on `β` and a function `f : α → β`,
  the preimage relation on `α` is defined by `x ≤ y ↔ f x ≤ f y`.
  It is the unique relation on `α` making `f` a `rel_embedding`
  (assuming `f` is injective). -/
@[simp] def order.preimage {α β} (f : α → β) (s : β → β → Prop) (x y : α) := s (f x) (f y)

infix ` ⁻¹'o `:80 := order.preimage

/-- The preimage of a decidable order is decidable. -/
instance order.preimage.decidable {α β} (f : α → β) (s : β → β → Prop) [H : decidable_rel s] :
  decidable_rel (f ⁻¹'o s) :=
λ x y, H _ _

section monotone
variables [preorder α] [preorder β] [preorder γ]

/-- A function between preorders is monotone if
  `a ≤ b` implies `f a ≤ f b`. -/
def monotone (f : α → β) := ∀⦃a b⦄, a ≤ b → f a ≤ f b

theorem monotone_id : @monotone α α _ _ id := assume x y h, h

theorem monotone_const {b : β} : monotone (λ(a:α), b) := assume x y h, le_refl b

protected theorem monotone.comp {g : β → γ} {f : α → β} (m_g : monotone g) (m_f : monotone f) :
  monotone (g ∘ f) :=
assume a b h, m_g (m_f h)

protected theorem monotone.iterate {f : α → α} (hf : monotone f) (n : ℕ) : monotone (f^[n]) :=
nat.rec_on n monotone_id (λ n ihn, ihn.comp hf)

lemma monotone_of_monotone_nat {f : ℕ → α} (hf : ∀n, f n ≤ f (n + 1)) :
  monotone f | n m h :=
begin
  induction h,
  { refl },
  { transitivity, assumption, exact hf _ }
end

lemma monotone.reflect_lt {α β} [linear_order α] [preorder β] {f : α → β} (hf : monotone f)
  {x x' : α} (h : f x < f x') : x < x' :=
by { rw [← not_le], intro h', apply not_le_of_lt h, exact hf h' }

/-- If `f` is a monotone function from `ℕ` to a preorder such that `y` lies between `f x` and
  `f (x + 1)`, then `y` doesn't lie in the range of `f`. -/
lemma monotone.ne_of_lt_of_lt_nat {α} [preorder α] {f : ℕ → α} (hf : monotone f)
  (x x' : ℕ) {y : α} (h1 : f x < y) (h2 : y < f (x + 1)) : f x' ≠ y :=
by { rintro rfl, apply (hf.reflect_lt h1).not_le, exact nat.le_of_lt_succ (hf.reflect_lt h2) }

/-- If `f` is a monotone function from `ℤ` to a preorder such that `y` lies between `f x` and
  `f (x + 1)`, then `y` doesn't lie in the range of `f`. -/
lemma monotone.ne_of_lt_of_lt_int {α} [preorder α] {f : ℤ → α} (hf : monotone f)
  (x x' : ℤ) {y : α} (h1 : f x < y) (h2 : y < f (x + 1)) : f x' ≠ y :=
by { rintro rfl, apply (hf.reflect_lt h1).not_le, exact int.le_of_lt_add_one (hf.reflect_lt h2) }

end monotone

/-- A function `f` is strictly monotone if `a < b` implies `f a < f b`. -/
def strict_mono [has_lt α] [has_lt β] (f : α → β) : Prop :=
∀ ⦃a b⦄, a < b → f a < f b

lemma strict_mono_id [has_lt α] : strict_mono (id : α → α) := λ a b, id

/-- A function `f` is strictly monotone increasing on `t` if `x < y` for `x,y ∈ t` implies
`f x < f y`. -/
def strict_mono_incr_on [has_lt α] [has_lt β] (f : α → β) (t : set α) : Prop :=
∀ ⦃x⦄ (hx : x ∈ t) ⦃y⦄ (hy : y ∈ t), x < y → f x < f y

/-- A function `f` is strictly monotone decreasing on `t` if `x < y` for `x,y ∈ t` implies
`f y < f x`. -/
def strict_mono_decr_on [has_lt α] [has_lt β] (f : α → β) (t : set α) : Prop :=
∀ ⦃x⦄ (hx : x ∈ t) ⦃y⦄ (hy : y ∈ t), x < y → f y < f x

/-- Type tag for a set with dual order: `≤` means `≥` and `<` means `>`. -/
def order_dual (α : Type*) := α

namespace order_dual
instance (α : Type*) [h : nonempty α] : nonempty (order_dual α) := h
instance (α : Type*) [h : subsingleton α] : subsingleton (order_dual α) := h
instance (α : Type*) [has_le α] : has_le (order_dual α) := ⟨λx y:α, y ≤ x⟩
instance (α : Type*) [has_lt α] : has_lt (order_dual α) := ⟨λx y:α, y < x⟩

-- `dual_le` and `dual_lt` should not be simp lemmas:
-- they cause a loop since `α` and `order_dual α` are definitionally equal

lemma dual_le [has_le α] {a b : α} :
  @has_le.le (order_dual α) _ a b ↔ @has_le.le α _ b a := iff.rfl

lemma dual_lt [has_lt α] {a b : α} :
  @has_lt.lt (order_dual α) _ a b ↔ @has_lt.lt α _ b a := iff.rfl

lemma dual_compares [has_lt α] {a b : α} {o : ordering} :
  @ordering.compares (order_dual α) _ o a b ↔ @ordering.compares α _ o b a :=
by { cases o, exacts [iff.rfl, eq_comm, iff.rfl] }

instance (α : Type*) [preorder α] : preorder (order_dual α) :=
{ le_refl  := le_refl,
  le_trans := assume a b c hab hbc, hbc.trans hab,
  lt_iff_le_not_le := λ _ _, lt_iff_le_not_le,
  .. order_dual.has_le α,
  .. order_dual.has_lt α }

instance (α : Type*) [partial_order α] : partial_order (order_dual α) :=
{ le_antisymm := assume a b hab hba, @le_antisymm α _ a b hba hab, .. order_dual.preorder α }

instance (α : Type*) [linear_order α] : linear_order (order_dual α) :=
{ le_total := assume a b:α, le_total b a,
  decidable_le := show decidable_rel (λa b:α, b ≤ a), by apply_instance,
  decidable_lt := show decidable_rel (λa b:α, b < a), by apply_instance,
  .. order_dual.partial_order α }

instance : Π [inhabited α], inhabited (order_dual α) := id

theorem preorder.dual_dual (α : Type*) [H : preorder α] :
  order_dual.preorder (order_dual α) = H :=
preorder.ext $ λ _ _, iff.rfl

theorem partial_order.dual_dual (α : Type*) [H : partial_order α] :
  order_dual.partial_order (order_dual α) = H :=
partial_order.ext $ λ _ _, iff.rfl

theorem linear_order.dual_dual (α : Type*) [H : linear_order α] :
  order_dual.linear_order (order_dual α) = H :=
linear_order.ext $ λ _ _, iff.rfl

theorem cmp_le_flip {α} [has_le α] [@decidable_rel α (≤)] (x y : α) :
  @cmp_le (order_dual α) _ _ x y = cmp_le y x := rfl

end order_dual

namespace strict_mono_incr_on

section dual

variables [preorder α] [preorder β] {f : α → β} {s : set α}

protected lemma dual (H : strict_mono_incr_on f s) :
  @strict_mono_incr_on (order_dual α) (order_dual β) _ _ f s :=
λ x hx y hy, H hy hx

protected lemma dual_right (H : strict_mono_incr_on f s) :
  @strict_mono_decr_on α (order_dual β) _ _ f s :=
H

end dual

variables [linear_order α] [preorder β] {f : α → β} {s : set α} {x y : α}

lemma le_iff_le (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  f x ≤ f y ↔ x ≤ y :=
⟨λ h, le_of_not_gt $ λ h', not_le_of_lt (H hy hx h') h,
 λ h, (lt_or_eq_of_le h).elim (λ h', le_of_lt (H hx hy h')) (λ h', h' ▸ le_refl _)⟩

lemma lt_iff_lt (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  f x < f y ↔ x < y :=
by simp only [H.le_iff_le, hx, hy, lt_iff_le_not_le]

protected theorem compares (H : strict_mono_incr_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  ∀ {o}, ordering.compares o (f x) (f y) ↔ ordering.compares o x y
| ordering.lt := H.lt_iff_lt hx hy
| ordering.eq := ⟨λ h, le_antisymm ((H.le_iff_le hx hy).1 h.le) ((H.le_iff_le hy hx).1 h.symm.le),
                   congr_arg _⟩
| ordering.gt := H.lt_iff_lt hy hx

end strict_mono_incr_on

namespace strict_mono_decr_on

section dual

variables [preorder α] [preorder β] {f : α → β} {s : set α}

protected lemma dual (H : strict_mono_decr_on f s) :
  @strict_mono_decr_on (order_dual α) (order_dual β) _ _ f s :=
λ x hx y hy, H hy hx

protected lemma dual_right (H : strict_mono_decr_on f s) :
  @strict_mono_incr_on α (order_dual β) _ _ f s :=
H

end dual

variables [linear_order α] [preorder β] {f : α → β} {s : set α} {x y : α}

lemma le_iff_le (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  f x ≤ f y ↔ y ≤ x :=
H.dual_right.le_iff_le hy hx

lemma lt_iff_lt (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) :
  f x < f y ↔ y < x :=
H.dual_right.lt_iff_lt hy hx

protected theorem compares (H : strict_mono_decr_on f s) (hx : x ∈ s) (hy : y ∈ s) {o : ordering} :
  ordering.compares o (f x) (f y) ↔ ordering.compares o y x :=
order_dual.dual_compares.trans $ H.dual_right.compares hy hx

end strict_mono_decr_on

namespace strict_mono
open ordering function

protected lemma strict_mono_incr_on [has_lt α] [has_lt β] {f : α → β} (hf : strict_mono f)
  (s : set α) :
  strict_mono_incr_on f s :=
λ x hx y hy hxy, hf hxy

lemma comp [has_lt α] [has_lt β] [has_lt γ] {g : β → γ} {f : α → β}
  (hg : strict_mono g) (hf : strict_mono f) :
  strict_mono (g ∘ f) :=
λ a b h, hg (hf h)

protected theorem iterate [has_lt α] {f : α → α} (hf : strict_mono f) (n : ℕ) :
  strict_mono (f^[n]) :=
nat.rec_on n strict_mono_id (λ n ihn, ihn.comp hf)

lemma id_le {φ : ℕ → ℕ} (h : strict_mono φ) : ∀ n, n ≤ φ n :=
λ n, nat.rec_on n (nat.zero_le _)
  (λ n hn, nat.succ_le_of_lt (lt_of_le_of_lt hn $ h $ nat.lt_succ_self n))

protected lemma ite' [preorder α] [has_lt β] {f g : α → β} (hf : strict_mono f) (hg : strict_mono g)
  {p : α → Prop} [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x)
  (hfg : ∀ ⦃x y⦄, p x → ¬p y → x < y → f x < g y) :
  strict_mono (λ x, if p x then f x else g x) :=
begin
  intros x y h,
  by_cases hy : p y,
  { have hx : p x := hp h hy,
    simpa [hx, hy] using hf h },
  { by_cases hx : p x,
    { simpa [hx, hy] using hfg hx hy h },
    { simpa [hx, hy] using hg h} }
end

protected lemma ite [preorder α] [preorder β] {f g : α → β} (hf : strict_mono f)
  (hg : strict_mono g) {p : α → Prop} [decidable_pred p] (hp : ∀ ⦃x y⦄, x < y → p y → p x)
  (hfg : ∀ x, f x ≤ g x) :
  strict_mono (λ x, if p x then f x else g x) :=
hf.ite' hg hp $ λ x y hx hy h, (hf h).trans_le (hfg y)

section
variables [linear_order α] [preorder β] {f : α → β}

lemma lt_iff_lt (H : strict_mono f) {a b} : f a < f b ↔ a < b :=
(H.strict_mono_incr_on set.univ).lt_iff_lt trivial trivial

protected theorem compares (H : strict_mono f) {a b} {o} :
  compares o (f a) (f b) ↔ compares o a b :=
(H.strict_mono_incr_on set.univ).compares trivial trivial

lemma injective (H : strict_mono f) : injective f :=
λ x y h, show compares eq x y, from H.compares.1 h

lemma le_iff_le (H : strict_mono f) {a b} : f a ≤ f b ↔ a ≤ b :=
(H.strict_mono_incr_on set.univ).le_iff_le trivial trivial

lemma top_preimage_top (H : strict_mono f) {a} (h_top : ∀ p, p ≤ f a) (x : α) : x ≤ a :=
H.le_iff_le.mp (h_top (f x))

lemma bot_preimage_bot (H : strict_mono f) {a} (h_bot : ∀ p, f a ≤ p) (x : α) : a ≤ x :=
H.le_iff_le.mp (h_bot (f x))

end

protected lemma nat {β} [preorder β] {f : ℕ → β} (h : ∀n, f n < f (n+1)) : strict_mono f :=
by { intros n m hnm, induction hnm with m' hnm' ih, apply h, exact ih.trans (h _) }

-- `preorder α` isn't strong enough: if the preorder on α is an equivalence relation,
-- then `strict_mono f` is vacuously true.
lemma monotone [partial_order α] [preorder β] {f : α → β} (H : strict_mono f) : monotone f :=
λ a b h, (lt_or_eq_of_le h).rec (le_of_lt ∘ (@H _ _)) (by rintro rfl; refl)

end strict_mono

section
open function

lemma injective_of_lt_imp_ne [linear_order α] {f : α → β} (h : ∀ x y, x < y → f x ≠ f y) :
  injective f :=
begin
  intros x y k,
  contrapose k,
  rw [←ne.def, ne_iff_lt_or_gt] at k,
  cases k,
  { apply h _ _ k },
  { rw eq_comm,
    apply h _ _ k }
end

lemma strict_mono_of_monotone_of_injective [partial_order α] [partial_order β] {f : α → β}
  (h₁ : monotone f) (h₂ : injective f) : strict_mono f :=
λ a b h,
begin
  rw lt_iff_le_and_ne at ⊢ h,
  exact ⟨h₁ h.1, λ e, h.2 (h₂ e)⟩
end

lemma monotone.strict_mono_iff_injective [linear_order α] [partial_order β] {f : α → β}
  (h : monotone f) : strict_mono f ↔ injective f :=
⟨λ h, h.injective, strict_mono_of_monotone_of_injective h⟩

lemma strict_mono_of_le_iff_le [preorder α] [preorder β] {f : α → β}
  (h : ∀ x y, x ≤ y ↔ f x ≤ f y) : strict_mono f :=
λ a b, by simp [lt_iff_le_not_le, h] {contextual := tt}

end

/-! ### Order instances on the function space -/

instance pi.preorder {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] : preorder (Πi, α i) :=
{ le       := λx y, ∀i, x i ≤ y i,
  le_refl  := assume a i, le_refl (a i),
  le_trans := assume a b c h₁ h₂ i, le_trans (h₁ i) (h₂ i) }

lemma pi.le_def {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] {x y : Π i, α i} :
  x ≤ y ↔ ∀ i, x i ≤ y i :=
iff.rfl

lemma pi.lt_def {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] {x y : Π i, α i} :
  x < y ↔ x ≤ y ∧ ∃ i, x i < y i :=
by simp [lt_iff_le_not_le, pi.le_def] {contextual := tt}

lemma le_update_iff {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] [decidable_eq ι]
  {x y : Π i, α i} {i : ι} {a : α i} :
  x ≤ function.update y i a ↔ x i ≤ a ∧ ∀ j ≠ i, x j ≤ y j :=
function.forall_update_iff _ (λ j z, x j ≤ z)

lemma update_le_iff {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] [decidable_eq ι]
  {x y : Π i, α i} {i : ι} {a : α i} :
  function.update x i a ≤ y ↔ a ≤ y i ∧ ∀ j ≠ i, x j ≤ y j :=
function.forall_update_iff _ (λ j z, z ≤ y j)

lemma update_le_update_iff {ι : Type u} {α : ι → Type v} [∀i, preorder (α i)] [decidable_eq ι]
  {x y : Π i, α i} {i : ι} {a b : α i} :
  function.update x i a ≤ function.update y i b ↔ a ≤ b ∧ ∀ j ≠ i, x j ≤ y j :=
by simp [update_le_iff] {contextual := tt}

instance pi.partial_order {ι : Type u} {α : ι → Type v} [∀i, partial_order (α i)] :
  partial_order (Πi, α i) :=
{ le_antisymm := λf g h1 h2, funext (λb, le_antisymm (h1 b) (h2 b)),
  ..pi.preorder }

theorem comp_le_comp_left_of_monotone [preorder α] [preorder β]
  {f : β → α} {g h : γ → β} (m_f : monotone f) (le_gh : g ≤ h) :
  has_le.le.{max w u} (f ∘ g) (f ∘ h) :=
assume x, m_f (le_gh x)

section monotone
variables [preorder α] [preorder γ]

protected theorem monotone.order_dual {f : α → γ} (hf : monotone f) :
  @monotone (order_dual α) (order_dual γ) _ _ f :=
λ x y hxy, hf hxy

theorem monotone_lam {f : α → β → γ} (m : ∀b, monotone (λa, f a b)) : monotone f :=
assume a a' h b, m b h

theorem monotone_app (f : β → α → γ) (b : β) (m : monotone (λa b, f b a)) : monotone (f b) :=
assume a a' h, m h b

end monotone

theorem strict_mono.order_dual [has_lt α] [has_lt β] {f : α → β} (hf : strict_mono f) :
  @strict_mono (order_dual α) (order_dual β) _ _ f :=
λ x y hxy, hf hxy

/-- Transfer a `preorder` on `β` to a `preorder` on `α` using a function `f : α → β`. -/
def preorder.lift {α β} [preorder β] (f : α → β) : preorder α :=
{ le := λx y, f x ≤ f y,
  le_refl := λ a, le_refl _,
  le_trans := λ a b c, le_trans,
  lt := λx y, f x < f y,
  lt_iff_le_not_le := λ a b, lt_iff_le_not_le }

/-- Transfer a `partial_order` on `β` to a `partial_order` on `α` using an injective
function `f : α → β`. -/
def partial_order.lift {α β} [partial_order β] (f : α → β) (inj : injective f) :
  partial_order α :=
{ le_antisymm := λ a b h₁ h₂, inj (le_antisymm h₁ h₂), .. preorder.lift f }

/-- Transfer a `linear_order` on `β` to a `linear_order` on `α` using an injective
function `f : α → β`. -/
def linear_order.lift {α β} [linear_order β] (f : α → β) (inj : injective f) :
  linear_order α :=
{ le_total := λx y, le_total (f x) (f y),
  decidable_le := λ x y, (infer_instance : decidable (f x ≤ f y)),
  decidable_lt := λ x y, (infer_instance : decidable (f x < f y)),
  decidable_eq := λ x y, decidable_of_iff _ inj.eq_iff,
  .. partial_order.lift f inj }

instance subtype.preorder {α} [preorder α] (p : α → Prop) : preorder (subtype p) :=
preorder.lift subtype.val

@[simp] lemma subtype.mk_le_mk {α} [preorder α] {p : α → Prop} {x y : α} {hx : p x} {hy : p y} :
  (⟨x, hx⟩ : subtype p) ≤ ⟨y, hy⟩ ↔ x ≤ y :=
iff.rfl

@[simp] lemma subtype.mk_lt_mk {α} [preorder α] {p : α → Prop} {x y : α} {hx : p x} {hy : p y} :
  (⟨x, hx⟩ : subtype p) < ⟨y, hy⟩ ↔ x < y :=
iff.rfl

@[simp, norm_cast] lemma subtype.coe_le_coe {α} [preorder α] {p : α → Prop} {x y : subtype p} :
  (x : α) ≤ y ↔ x ≤ y :=
iff.rfl

@[simp, norm_cast] lemma subtype.coe_lt_coe {α} [preorder α] {p : α → Prop} {x y : subtype p} :
  (x : α) < y ↔ x < y :=
iff.rfl

instance subtype.partial_order {α} [partial_order α] (p : α → Prop) :
  partial_order (subtype p) :=
partial_order.lift subtype.val subtype.val_injective

instance subtype.linear_order {α} [linear_order α] (p : α → Prop) : linear_order (subtype p) :=
linear_order.lift subtype.val subtype.val_injective

lemma subtype.mono_coe [preorder α] (t : set α) : monotone (coe : (subtype t) → α) :=
λ x y, id

lemma subtype.strict_mono_coe [preorder α] (t : set α) : strict_mono (coe : (subtype t) → α) :=
λ x y, id

instance prod.has_le (α : Type u) (β : Type v) [has_le α] [has_le β] : has_le (α × β) :=
⟨λp q, p.1 ≤ q.1 ∧ p.2 ≤ q.2⟩

instance prod.preorder (α : Type u) (β : Type v) [preorder α] [preorder β] : preorder (α × β) :=
{ le_refl  := assume ⟨a, b⟩, ⟨le_refl a, le_refl b⟩,
  le_trans := assume ⟨a, b⟩ ⟨c, d⟩ ⟨e, f⟩ ⟨hac, hbd⟩ ⟨hce, hdf⟩,
    ⟨le_trans hac hce, le_trans hbd hdf⟩,
  .. prod.has_le α β }

/-- The pointwise partial order on a product.
    (The lexicographic ordering is defined in order/lexicographic.lean, and the instances are
    available via the type synonym `lex α β = α × β`.) -/
instance prod.partial_order (α : Type u) (β : Type v) [partial_order α] [partial_order β] :
  partial_order (α × β) :=
{ le_antisymm := assume ⟨a, b⟩ ⟨c, d⟩ ⟨hac, hbd⟩ ⟨hca, hdb⟩,
    prod.ext (le_antisymm hac hca) (le_antisymm hbd hdb),
  .. prod.preorder α β }

/-!
### Additional order classes
-/

/-- order without a top element; somtimes called cofinal -/
class no_top_order (α : Type u) [preorder α] : Prop :=
(no_top : ∀a:α, ∃a', a < a')

lemma no_top [preorder α] [no_top_order α] : ∀a:α, ∃a', a < a' :=
no_top_order.no_top

instance nonempty_gt {α : Type u} [preorder α] [no_top_order α] (a : α) :
  nonempty {x // a < x} :=
nonempty_subtype.2 (no_top a)

/-- order without a bottom element; somtimes called coinitial or dense -/
class no_bot_order (α : Type u) [preorder α] : Prop :=
(no_bot : ∀a:α, ∃a', a' < a)

lemma no_bot [preorder α] [no_bot_order α] : ∀a:α, ∃a', a' < a :=
no_bot_order.no_bot

instance order_dual.no_top_order (α : Type u) [preorder α] [no_bot_order α] :
  no_top_order (order_dual α) :=
⟨λ a, @no_bot α _ _ a⟩

instance order_dual.no_bot_order (α : Type u) [preorder α] [no_top_order α] :
  no_bot_order (order_dual α) :=
⟨λ a, @no_top α _ _ a⟩

instance nonempty_lt {α : Type u} [preorder α] [no_bot_order α] (a : α) :
  nonempty {x // x < a} :=
nonempty_subtype.2 (no_bot a)

/-- An order is dense if there is an element between any pair of distinct elements. -/
class densely_ordered (α : Type u) [preorder α] : Prop :=
(dense : ∀a₁ a₂:α, a₁ < a₂ → ∃a, a₁ < a ∧ a < a₂)

lemma exists_between [preorder α] [densely_ordered α] : ∀{a₁ a₂:α}, a₁ < a₂ → ∃a, a₁ < a ∧ a < a₂ :=
densely_ordered.dense

instance order_dual.densely_ordered (α : Type u) [preorder α] [densely_ordered α] :
  densely_ordered (order_dual α) :=
⟨λ a₁ a₂ ha, (@exists_between α _ _ _ _ ha).imp $ λ a, and.symm⟩

lemma le_of_forall_le_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h : ∀a₃>a₂, a₁ ≤ a₃) :
  a₁ ≤ a₂ :=
le_of_not_gt $ assume ha,
  let ⟨a, ha₁, ha₂⟩ := exists_between ha in
  lt_irrefl a $ lt_of_lt_of_le ‹a < a₁› (h _ ‹a₂ < a›)

lemma eq_of_le_of_forall_le_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h₁ : a₂ ≤ a₁) (h₂ : ∀a₃>a₂, a₁ ≤ a₃) : a₁ = a₂ :=
le_antisymm (le_of_forall_le_of_dense h₂) h₁

lemma le_of_forall_ge_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h : ∀a₃<a₁, a₃ ≤ a₂) :
  a₁ ≤ a₂ :=
le_of_not_gt $ assume ha,
  let ⟨a, ha₁, ha₂⟩ := exists_between ha in
  lt_irrefl a $ lt_of_le_of_lt (h _ ‹a < a₁›) ‹a₂ < a›

lemma eq_of_le_of_forall_ge_of_dense [linear_order α] [densely_ordered α] {a₁ a₂ : α}
  (h₁ : a₂ ≤ a₁) (h₂ : ∀a₃<a₁, a₃ ≤ a₂) : a₁ = a₂ :=
le_antisymm (le_of_forall_ge_of_dense h₂) h₁

lemma dense_or_discrete [linear_order α] (a₁ a₂ : α) :
  (∃a, a₁ < a ∧ a < a₂) ∨ ((∀a>a₁, a₂ ≤ a) ∧ (∀a<a₂, a ≤ a₁)) :=
or_iff_not_imp_left.2 $ assume h,
  ⟨assume a ha₁, le_of_not_gt $ assume ha₂, h ⟨a, ha₁, ha₂⟩,
    assume a ha₂, le_of_not_gt $ assume ha₁, h ⟨a, ha₁, ha₂⟩⟩

variables {s : β → β → Prop} {t : γ → γ → Prop}

/-- Type synonym to create an instance of `linear_order` from a
`partial_order` and `[is_total α (≤)]` -/
def as_linear_order (α : Type u) := α

instance {α} [inhabited α] : inhabited (as_linear_order α) :=
⟨ (default α : α) ⟩

noncomputable instance as_linear_order.linear_order {α} [partial_order α] [is_total α (≤)] :
  linear_order (as_linear_order α) :=
{ le_total := @total_of α (≤) _,
  decidable_le := classical.dec_rel _,
  .. (_ : partial_order α) }


/-
Copyright (c) 2020 Thomas Browning and Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import group_theory.solvable
import field_theory.polynomial_galois_group
import ring_theory.roots_of_unity

/-!
# The Abel-Ruffini Theorem

This file proves one direction of the Abel-Ruffini theorem, namely that if an element is solvable
by radicals, then its minimal polynomial has solvable Galois group.

## Main definitions

* `SBF F E` : the intermediate field of solvable-by-radicals elements

## Main results

* `solvable_gal_of_solvable_by_rad` : the minimal polynomial of an element of `SBF F E` has
solvable Galois group
-/

noncomputable theory
open_locale classical

open polynomial intermediate_field

section abel_ruffini

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]

lemma gal_zero_is_solvable : is_solvable (0 : polynomial F).gal :=
by apply_instance

lemma gal_one_is_solvable : is_solvable (1 : polynomial F).gal :=
by apply_instance

lemma gal_C_is_solvable (x : F) : is_solvable (C x).gal :=
by apply_instance

lemma gal_X_is_solvable : is_solvable (X : polynomial F).gal :=
by apply_instance

lemma gal_X_sub_C_is_solvable (x : F) : is_solvable (X - C x).gal :=
by apply_instance

lemma gal_X_pow_is_solvable (n : ℕ) : is_solvable (X ^ n : polynomial F).gal :=
by apply_instance

lemma gal_mul_is_solvable {p q : polynomial F}
  (hp : is_solvable p.gal) (hq : is_solvable q.gal) : is_solvable (p * q).gal :=
solvable_of_solvable_injective (gal.restrict_prod_injective p q)

lemma gal_prod_is_solvable {s : multiset (polynomial F)}
  (hs : ∀ p ∈ s, is_solvable (gal p)) : is_solvable s.prod.gal :=
begin
  apply multiset.induction_on' s,
  { exact gal_one_is_solvable },
  { intros p t hps hts ht,
    rw [multiset.insert_eq_cons, multiset.prod_cons],
    exact gal_mul_is_solvable (hs p hps) ht },
end

lemma gal_is_solvable_of_splits {p q : polynomial F}
  (hpq : fact (p.splits (algebra_map F q.splitting_field))) (hq : is_solvable q.gal) :
  is_solvable p.gal :=
begin
  haveI : is_solvable (q.splitting_field ≃ₐ[F] q.splitting_field) := hq,
  exact solvable_of_surjective (alg_equiv.restrict_normal_hom_surjective q.splitting_field),
end

lemma gal_is_solvable_tower (p q : polynomial F)
  (hpq : p.splits (algebra_map F q.splitting_field))
  (hp : is_solvable p.gal)
  (hq : is_solvable (q.map (algebra_map F p.splitting_field)).gal) :
  is_solvable q.gal :=
begin
  let K := p.splitting_field,
  let L := q.splitting_field,
  haveI : fact (p.splits (algebra_map F L)) := ⟨hpq⟩,
  let ϕ : (L ≃ₐ[K] L) ≃* (q.map (algebra_map F K)).gal :=
    (is_splitting_field.alg_equiv L (q.map (algebra_map F K))).aut_congr,
  have ϕ_inj : function.injective ϕ.to_monoid_hom := ϕ.injective,
  haveI : is_solvable (K ≃ₐ[F] K) := hp,
  haveI : is_solvable (L ≃ₐ[K] L) := solvable_of_solvable_injective ϕ_inj,
  exact is_solvable_of_is_scalar_tower F p.splitting_field q.splitting_field,
end

section gal_X_pow_sub_C

lemma gal_X_pow_sub_one_is_solvable (n : ℕ) : is_solvable (X ^ n - 1 : polynomial F).gal :=
begin
  by_cases hn : n = 0,
  { rw [hn, pow_zero, sub_self],
    exact gal_zero_is_solvable },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : (X ^ n - 1 : polynomial F) ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_one hn').symm.trans (congr_arg leading_coeff h)),
  apply is_solvable_of_comm,
  intros σ τ,
  ext a ha,
  rw [mem_root_set hn'', alg_hom.map_sub, aeval_X_pow, aeval_one, sub_eq_zero] at ha,
  have key : ∀ σ : (X ^ n - 1 : polynomial F).gal, ∃ m : ℕ, σ a = a ^ m,
  { intro σ,
    obtain ⟨m, hm⟩ := σ.to_alg_hom.to_ring_hom.map_root_of_unity_eq_pow_self
      ⟨is_unit.unit (is_unit_of_pow_eq_one a n ha hn'),
      by { ext, rwa [units.coe_pow, is_unit.unit_spec, subtype.coe_mk n hn'] }⟩,
    use m,
    convert hm,
    all_goals { exact (is_unit.unit_spec _).symm } },
  obtain ⟨c, hc⟩ := key σ,
  obtain ⟨d, hd⟩ := key τ,
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_pow, hd, σ.map_pow, hc, ←pow_mul, pow_mul'],
end

lemma gal_X_pow_sub_C_is_solvable_aux (n : ℕ) (a : F)
  (h : (X ^ n - 1 : polynomial F).splits (ring_hom.id F)) : is_solvable (X ^ n - C a).gal :=
begin
  by_cases ha : a = 0,
  { rw [ha, C_0, sub_zero],
    exact gal_X_pow_is_solvable n },
  have ha' : algebra_map F (X ^ n - C a).splitting_field a ≠ 0 :=
    mt ((ring_hom.injective_iff _).mp (ring_hom.injective _) a) ha,
  by_cases hn : n = 0,
  { rw [hn, pow_zero, ←C_1, ←C_sub],
    exact gal_C_is_solvable (1 - a) },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : X ^ n - C a ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_C hn').symm.trans (congr_arg leading_coeff h)),
  have hn''' : (X ^ n - 1 : polynomial F) ≠ 0 :=
    λ h, one_ne_zero ((leading_coeff_X_pow_sub_one hn').symm.trans (congr_arg leading_coeff h)),
  have mem_range : ∀ {c}, c ^ n = 1 → ∃ d, algebra_map F (X ^ n - C a).splitting_field d = c :=
    λ c hc, ring_hom.mem_range.mp (minpoly.mem_range_of_degree_eq_one F c (or.resolve_left h hn'''
      (minpoly.irreducible ((splitting_field.normal (X ^ n - C a)).is_integral c)) (minpoly.dvd F c
      (by rwa [map_id, alg_hom.map_sub, sub_eq_zero, aeval_X_pow, aeval_one])))),
  apply is_solvable_of_comm,
  intros σ τ,
  ext b hb,
  rw [mem_root_set hn'', alg_hom.map_sub, aeval_X_pow, aeval_C, sub_eq_zero] at hb,
  have hb' : b ≠ 0,
  { intro hb',
    rw [hb', zero_pow hn'] at hb,
    exact ha' hb.symm },
  have key : ∀ σ : (X ^ n - C a).gal, ∃ c, σ b = b * algebra_map F _ c,
  { intro σ,
    have key : (σ b / b) ^ n = 1 := by rw [div_pow, ←σ.map_pow, hb, σ.commutes, div_self ha'],
    obtain ⟨c, hc⟩ := mem_range key,
    use c,
    rw [hc, mul_div_cancel' (σ b) hb'] },
  obtain ⟨c, hc⟩ := key σ,
  obtain ⟨d, hd⟩ := key τ,
  rw [σ.mul_apply, τ.mul_apply, hc, τ.map_mul, τ.commutes, hd, σ.map_mul, σ.commutes, hc],
  rw [mul_assoc, mul_assoc, mul_right_inj' hb', mul_comm],
end

lemma splits_X_pow_sub_one_of_X_pow_sub_C {F : Type*} [field F] {E : Type*} [field E]
  (i : F →+* E) (n : ℕ) {a : F} (ha : a ≠ 0) (h : (X ^ n - C a).splits i) : (X ^ n - 1).splits i :=
begin
  have ha' : i a ≠ 0 := mt (i.injective_iff.mp (i.injective) a) ha,
  by_cases hn : n = 0,
  { rw [hn, pow_zero, sub_self],
    exact splits_zero i },
  have hn' : 0 < n := pos_iff_ne_zero.mpr hn,
  have hn'' : (X ^ n - C a).degree ≠ 0 :=
    ne_of_eq_of_ne (degree_X_pow_sub_C hn' a) (mt with_bot.coe_eq_coe.mp hn),
  obtain ⟨b, hb⟩ := exists_root_of_splits i h hn'',
  rw [eval₂_sub, eval₂_X_pow, eval₂_C, sub_eq_zero] at hb,
  have hb' : b ≠ 0,
  { intro hb',
    rw [hb', zero_pow hn'] at hb,
    exact ha' hb.symm },
  let s := ((X ^ n - C a).map i).roots,
  have hs : _ = _ * (s.map _).prod := eq_prod_roots_of_splits h,
  rw [leading_coeff_X_pow_sub_C hn', ring_hom.map_one, C_1, one_mul] at hs,
  have hs' : s.card = n := (nat_degree_eq_card_roots h).symm.trans nat_degree_X_pow_sub_C,
  apply @splits_of_exists_multiset F E _ _ i (X ^ n - 1) (s.map (λ c : E, c / b)),
  rw [leading_coeff_X_pow_sub_one hn', ring_hom.map_one, C_1, one_mul, multiset.map_map],
  have C_mul_C : (C (i a⁻¹)) * (C (i a)) = 1,
  { rw [←C_mul, ←i.map_mul, inv_mul_cancel ha, i.map_one, C_1] },
  have key1 : (X ^ n - 1).map i = C (i a⁻¹) * ((X ^ n - C a).map i).comp (C b * X),
  { rw [map_sub, map_sub, map_pow, map_X, map_C, map_one, sub_comp, pow_comp, X_comp, C_comp,
        mul_pow, ←C_pow, hb, mul_sub, ←mul_assoc, C_mul_C, one_mul] },
  have key2 : (λ q : polynomial E, q.comp (C b * X)) ∘ (λ c : E, X - C c) =
    (λ c : E, C b * (X - C (c / b))),
  { ext1 c,
    change (X - C c).comp (C b * X) = C b * (X - C (c / b)),
    rw [sub_comp, X_comp, C_comp, mul_sub, ←C_mul, mul_div_cancel' c hb'] },
  rw [key1, hs, prod_comp, multiset.map_map, key2, multiset.prod_map_mul, multiset.map_const,
      multiset.prod_repeat, hs', ←C_pow, hb, ←mul_assoc, C_mul_C, one_mul],
  all_goals { exact field.to_nontrivial F },
end

lemma gal_X_pow_sub_C_is_solvable (n : ℕ) (x : F) : is_solvable (X ^ n - C x).gal :=
begin
  by_cases hx : x = 0,
  { rw [hx, C_0, sub_zero],
    exact gal_X_pow_is_solvable n },
  apply gal_is_solvable_tower (X ^ n - 1) (X ^ n - C x),
  { exact splits_X_pow_sub_one_of_X_pow_sub_C _ n hx (splitting_field.splits _) },
  { exact gal_X_pow_sub_one_is_solvable n },
  { rw [map_sub, map_pow, map_X, map_C],
    apply gal_X_pow_sub_C_is_solvable_aux,
    have key := splitting_field.splits (X ^ n - 1 : polynomial F),
    rwa [←splits_id_iff_splits, map_sub, map_pow, map_X, map_one] at key },
end

end gal_X_pow_sub_C

variables (F)

/-- Inductive definition of solvable by radicals -/
inductive is_solvable_by_rad : E → Prop
| base (a : F) : is_solvable_by_rad (algebra_map F E a)
| add (a b : E) : is_solvable_by_rad a → is_solvable_by_rad b → is_solvable_by_rad (a + b)
| neg (α : E) : is_solvable_by_rad α → is_solvable_by_rad (-α)
| mul (α β : E) : is_solvable_by_rad α → is_solvable_by_rad β → is_solvable_by_rad (α * β)
| inv (α : E) : is_solvable_by_rad α → is_solvable_by_rad α⁻¹
| rad (α : E) (n : ℕ) (hn : n ≠ 0) : is_solvable_by_rad (α^n) → is_solvable_by_rad α

variables (E)

/-- The intermediate field of solvable-by-radicals elements -/
def solvable_by_rad : intermediate_field F E :=
{ carrier := is_solvable_by_rad F,
  zero_mem' := by { convert is_solvable_by_rad.base (0 : F), rw ring_hom.map_zero },
  add_mem' := is_solvable_by_rad.add,
  neg_mem' := is_solvable_by_rad.neg,
  one_mem' := by { convert is_solvable_by_rad.base (1 : F), rw ring_hom.map_one },
  mul_mem' := is_solvable_by_rad.mul,
  inv_mem' := is_solvable_by_rad.inv,
  algebra_map_mem' := is_solvable_by_rad.base }

namespace solvable_by_rad

variables {F} {E} {α : E}

lemma induction (P : solvable_by_rad F E → Prop)
(base : ∀ α : F, P (algebra_map F (solvable_by_rad F E) α))
(add : ∀ α β : solvable_by_rad F E, P α → P β → P (α + β))
(neg : ∀ α : solvable_by_rad F E, P α → P (-α))
(mul : ∀ α β : solvable_by_rad F E, P α → P β → P (α * β))
(inv : ∀ α : solvable_by_rad F E, P α → P α⁻¹)
(rad : ∀ α : solvable_by_rad F E, ∀ n : ℕ, n ≠ 0 → P (α^n) → P α)
(α : solvable_by_rad F E) : P α :=
begin
  revert α,
  suffices : ∀ (α : E), is_solvable_by_rad F α → (∃ β : solvable_by_rad F E, ↑β = α ∧ P β),
  { intro α,
    obtain ⟨α₀, hα₀, Pα⟩ := this α (subtype.mem α),
    convert Pα,
    exact subtype.ext hα₀.symm },
  apply is_solvable_by_rad.rec,
  { exact λ α, ⟨algebra_map F (solvable_by_rad F E) α, rfl, base α⟩ },
  { intros α β hα hβ Pα Pβ,
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := ⟨Pα, Pβ⟩,
    exact ⟨α₀ + β₀, by {rw [←hα₀, ←hβ₀], refl }, add α₀ β₀ Pα Pβ⟩ },
  { intros α hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    exact ⟨-α₀, by {rw ←hα₀, refl }, neg α₀ Pα⟩ },
  { intros α β hα hβ Pα Pβ,
    obtain ⟨⟨α₀, hα₀, Pα⟩, β₀, hβ₀, Pβ⟩ := ⟨Pα, Pβ⟩,
    exact ⟨α₀ * β₀, by {rw [←hα₀, ←hβ₀], refl }, mul α₀ β₀ Pα Pβ⟩ },
  { intros α hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    exact ⟨α₀⁻¹, by {rw ←hα₀, refl }, inv α₀ Pα⟩ },
  { intros α n hn hα Pα,
    obtain ⟨α₀, hα₀, Pα⟩ := Pα,
    refine ⟨⟨α, is_solvable_by_rad.rad α n hn hα⟩, rfl, rad _ n hn _⟩,
    convert Pα,
    exact subtype.ext (eq.trans ((solvable_by_rad F E).coe_pow _ n) hα₀.symm) }
end

theorem is_integral (α : solvable_by_rad F E) : is_integral F α :=
begin
  revert α,
  apply solvable_by_rad.induction,
  { exact λ _, is_integral_algebra_map },
  { exact λ _ _, is_integral_add },
  { exact λ _, is_integral_neg },
  { exact λ _ _, is_integral_mul },
  { exact λ α hα, subalgebra.inv_mem_of_algebraic (integral_closure F (solvable_by_rad F E))
      (show is_algebraic F ↑(⟨α, hα⟩ : integral_closure F (solvable_by_rad F E)),
        by exact (is_algebraic_iff_is_integral F).mpr hα) },
  { intros α n hn hα,
    obtain ⟨p, h1, h2⟩ := (is_algebraic_iff_is_integral F).mpr hα,
    refine (is_algebraic_iff_is_integral F).mp ⟨p.comp (X ^ n),
      ⟨λ h, h1 (leading_coeff_eq_zero.mp _), by rw [aeval_comp, aeval_X_pow, h2]⟩⟩,
    rwa [←leading_coeff_eq_zero, leading_coeff_comp, leading_coeff_X_pow, one_pow, mul_one] at h,
    rwa nat_degree_X_pow }
end

/-- The statement to be proved inductively -/
def P (α : solvable_by_rad F E) : Prop := is_solvable (minpoly F α).gal

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
lemma induction3 {α : solvable_by_rad F E} {n : ℕ} (hn : n ≠ 0) (hα : P (α ^ n)) : P α :=
begin
  let p := minpoly F (α ^ n),
  have hp : p.comp (X ^ n) ≠ 0,
  { intro h,
    cases (comp_eq_zero_iff.mp h) with h' h',
    { exact minpoly.ne_zero (is_integral (α ^ n)) h' },
    { exact hn (by rw [←nat_degree_C _, ←h'.2, nat_degree_X_pow]) } },
  apply gal_is_solvable_of_splits,
  { exact ⟨splits_of_splits_of_dvd _ hp (splitting_field.splits (p.comp (X ^ n)))
      (minpoly.dvd F α (by rw [aeval_comp, aeval_X_pow, minpoly.aeval]))⟩ },
  { refine gal_is_solvable_tower p (p.comp (X ^ n)) _ hα _,
    { exact gal.splits_in_splitting_field_of_comp _ _ (by rwa [nat_degree_X_pow]) },
    { obtain ⟨s, hs⟩ := exists_multiset_of_splits _ (splitting_field.splits p),
      rw [map_comp, map_pow, map_X, hs, mul_comp, C_comp],
      apply gal_mul_is_solvable (gal_C_is_solvable _),
      rw prod_comp,
      apply gal_prod_is_solvable,
      intros q hq,
      rw multiset.mem_map at hq,
      obtain ⟨q, hq, rfl⟩ := hq,
      rw multiset.mem_map at hq,
      obtain ⟨q, hq, rfl⟩ := hq,
      rw [sub_comp, X_comp, C_comp],
      exact gal_X_pow_sub_C_is_solvable n q } },
end

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/
lemma induction2 {α β γ : solvable_by_rad F E} (hγ : γ ∈ F⟮α, β⟯) (hα : P α) (hβ : P β) : P γ :=
begin
  let p := (minpoly F α),
  let q := (minpoly F β),
  have hpq := polynomial.splits_of_splits_mul _ (mul_ne_zero (minpoly.ne_zero (is_integral α))
    (minpoly.ne_zero (is_integral β))) (splitting_field.splits (p * q)),
  let f : F⟮α, β⟯ →ₐ[F] (p * q).splitting_field := classical.choice (alg_hom_mk_adjoin_splits
  begin
    intros x hx,
    cases hx,
    rw hx,
    exact ⟨is_integral α, hpq.1⟩,
    cases hx,
    exact ⟨is_integral β, hpq.2⟩,
  end),
  have key : minpoly F γ = minpoly F (f ⟨γ, hγ⟩) := minpoly.unique'
    (minpoly.irreducible (is_integral γ)) begin
      suffices : aeval (⟨γ, hγ⟩ : F ⟮α, β⟯) (minpoly F γ) = 0,
      { rw [aeval_alg_hom_apply, this, alg_hom.map_zero] },
      apply (algebra_map F⟮α, β⟯ (solvable_by_rad F E)).injective,
      rw [ring_hom.map_zero, is_scalar_tower.algebra_map_aeval],
      exact minpoly.aeval F γ,
    end (minpoly.monic (is_integral γ)),
  rw [P, key],
  exact gal_is_solvable_of_splits ⟨normal.splits (splitting_field.normal _) _⟩
    (gal_mul_is_solvable hα hβ),
end

/-- An auxiliary induction lemma, which is generalized by `solvable_by_rad.is_solvable`. -/

theorem is_solvable (α : solvable_by_rad F E) :
  is_solvable (minpoly F α).gal :=
begin
  revert α,
  apply solvable_by_rad.induction,
  { exact λ α, by { rw minpoly.eq_X_sub_C, exact gal_X_sub_C_is_solvable α } },
  { exact λ α β, induction2 (add_mem _ (subset_adjoin F _ (set.mem_insert α _))
      (subset_adjoin F _ (set.mem_insert_of_mem α (set.mem_singleton β)))) },
  { exact λ α, induction1 (neg_mem _ (mem_adjoin_simple_self F α)) },
  { exact λ α β, induction2 (mul_mem _ (subset_adjoin F _ (set.mem_insert α _))
      (subset_adjoin F _ (set.mem_insert_of_mem α (set.mem_singleton β)))) },
  { exact λ α, induction1 (inv_mem _ (mem_adjoin_simple_self F α)) },
  { exact λ α n, induction3 },
end

end solvable_by_rad

end abel_ruffini


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.W.cardinal
import data.mv_polynomial.basic
/-!
# Cardinality of Polynomial Ring

The main result in this file is `mv_polynomial.cardinal_mk_le_max`, which says that
the cardinality of `mv_polynomial σ R` is bounded above by the maximum of `#R`, `#σ`
and `ℵ₀`.

-/
universes u
/-
The definitions `mv_polynomial_fun` and `arity` are motivated by defining the following
inductive type as a `W_type` in order to be able to use theorems about the cardinality
of `W_type`.

inductive mv_polynomial_term (σ R : Type u) : Type u
| of_ring : R → mv_polynomial_term
| X : σ → mv_polynomial_term
| add : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term
| mul : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term

`W_type (arity σ R)` is isomorphic to the above type.
-/
open cardinal
open_locale cardinal

/-- A type used to prove theorems about the cardinality of `mv_polynomial σ R`. The
`W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary functions. -/
private def mv_polynomial_fun (σ R : Type u) : Type u :=
R ⊕ σ ⊕ ulift.{u} bool

variables (σ R : Type u)
/-- A function used to prove theorems about the cardinality of `mv_polynomial σ R`.
  The type ``W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary
  functions. -/
private def arity : mv_polynomial_fun σ R → Type u
| (sum.inl _)              := pempty
| (sum.inr (sum.inl _))    := pempty
| (sum.inr (sum.inr ⟨ff⟩)) := ulift bool
| (sum.inr (sum.inr ⟨tt⟩)) := ulift bool

private def arity_fintype (x : mv_polynomial_fun σ R) : fintype (arity σ R x) :=
by rcases x with x | x | ⟨_ | _⟩; dsimp [arity]; apply_instance

local attribute [instance] arity_fintype

variables {σ R}

variables [comm_semiring R]

/-- The surjection from `W_type (arity σ R)` into `mv_polynomial σ R`. -/
private noncomputable def to_mv_polynomial :
  W_type (arity σ R) → mv_polynomial σ R
| ⟨sum.inl r, _⟩              := mv_polynomial.C r
| ⟨sum.inr (sum.inl i), _⟩    := mv_polynomial.X i
| ⟨sum.inr (sum.inr ⟨ff⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) * to_mv_polynomial (f (ulift.up ff))
| ⟨sum.inr (sum.inr ⟨tt⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) + to_mv_polynomial (f (ulift.up ff))

private lemma to_mv_polynomial_surjective : function.surjective (@to_mv_polynomial σ R _) :=
begin
  intro p,
  induction p using mv_polynomial.induction_on with x p₁ p₂ ih₁ ih₂ p i ih,
  { exact ⟨W_type.mk (sum.inl x) pempty.elim, rfl⟩ },
  { rcases ih₁ with ⟨w₁, rfl⟩,
    rcases ih₂ with ⟨w₂, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨tt⟩)) (λ x, cond x.down w₁ w₂),
      by simp [to_mv_polynomial]⟩ },
  { rcases ih with ⟨w, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨ff⟩)) (λ x, cond x.down w (W_type.mk
      (sum.inr (sum.inl i)) pempty.elim)), by simp [to_mv_polynomial]⟩ }
end

private lemma cardinal_mv_polynomial_fun_le : #(mv_polynomial_fun σ R) ≤ max (max (#R) (#σ)) ℵ₀ :=
calc #(mv_polynomial_fun σ R) = #R + #σ + #(ulift bool) :
  by dsimp [mv_polynomial_fun]; simp only [← add_def, add_assoc, cardinal.mk_ulift]
... ≤ max (max (#R + #σ) (#(ulift bool))) ℵ₀ : add_le_max _ _
... ≤ max (max (max (max (#R) (#σ)) ℵ₀) (#(ulift bool))) ℵ₀ :
  max_le_max (max_le_max (add_le_max _ _) le_rfl) le_rfl
... ≤ _ : by simp only [max_comm ℵ₀, max_assoc, max_left_comm ℵ₀, max_self,
            max_eq_left (lt_aleph_0_of_fintype (ulift.{u} bool)).le]

namespace mv_polynomial

/-- The cardinality of the multivariate polynomial ring, `mv_polynomial σ R` is at most the maximum
of `#R`, `#σ` and `ℵ₀` -/
lemma cardinal_mk_le_max {σ R : Type u} [comm_semiring R] :
  #(mv_polynomial σ R) ≤ max (max (#R) (#σ)) ℵ₀ :=
calc #(mv_polynomial σ R) ≤ #(W_type (arity σ R)) :
  cardinal.mk_le_of_surjective to_mv_polynomial_surjective
... ≤ max (#(mv_polynomial_fun σ R)) ℵ₀ : W_type.cardinal_mk_le_max_aleph_0_of_fintype
... ≤ _ : max_le_max cardinal_mv_polynomial_fun_le le_rfl
... ≤ _ : by simp only [max_assoc, max_self]

end mv_polynomial


import tactic .num_lemmas
import data.set.intervals data.real.nnreal

universe u

open set

section nat

open nat

lemma Ioo_ℕ_eq_Ioc (a b : ℕ) :
  Ioo a b = Ioc a (b-1) :=
by {cases b; {ext, simp [lt_succ_iff]}}

lemma Ioo_ℕ_eq_Ico (a b : ℕ) :
  Ioo a b = Ico (a+1) b :=
by {ext, simp [succ_le_iff]}

lemma Ioc_ℕ_eq_Ioo (a b : ℕ) :
  Ioc a b = Ioo a (b+1) :=
by simp [Ioo_ℕ_eq_Ioc]

lemma Ioc_ℕ_eq_Icc (a b : ℕ) :
  Ioc a b = Icc (a+1) b :=
by {ext, simp [succ_le_iff]}

lemma Ioo_ℕ_eq_Icc (a b : ℕ) :
  Ioo a b = Icc (a+1) (b-1) :=
by rw [Ioo_ℕ_eq_Ioc, Ioc_ℕ_eq_Icc]

lemma Ico_ℕ_eq_Ioo (a b : ℕ) (h : 0 < a) :
  Ico a b = Ioo (a-1) b :=
begin
  ext,
  cases a,
  { exfalso, exact lt_irrefl 0 h},
  simp only [mem_Ioo, and.congr_left_iff, sub_zero, succ_sub_succ_eq_sub, mem_Ico, nat.lt_iff_succ_le],
  tauto,
end

lemma Ico_ℕ_eq_Icc (a b : ℕ) (h : a < b) :
  Ico a b = Icc a (b-1) :=
by {cases b, {ext, simp, rintros - rfl, exact not_lt_zero a h,  },
    ext, simp [nat.lt_succ_iff],  }

lemma set.Icc_ℕ_bij_Icc_ℤ (a b : ℕ) :
  bij_on coe (Icc a b) (Icc (a : ℤ) (b : ℤ)) :=
begin
  refine ⟨λ _ h, by {simpa using h}, λ _ _ _ _ h, by {simpa using h}, λ x h, _⟩,
  rw mem_Icc at h,
  simp_rw [mem_image, mem_Icc, ← int.coe_nat_le],
  use int.to_nat x,
  simp_rw int.to_nat_of_nonneg (le_trans (int.coe_nat_nonneg a) h.1),
  exact ⟨h,rfl⟩,
end

theorem set.Icc_ℕ_finite (l u : ℕ) :
  (Icc l u).finite :=
begin
  convert (set.finite_image_iff
            (inj_on_of_injective (λ n m h, int.coe_nat_inj h)
            (Icc l u))).mp _,
  convert set.Icc_ℤ_finite l u,
  ext,
  simp_rw [mem_image, mem_Icc, ← int.coe_nat_le],
  split,
  { rintros ⟨y, h, rfl⟩, assumption, },
  rintros ⟨hl, hu⟩,
  refine ⟨int.to_nat x, _⟩,
  simp_rw int.to_nat_of_nonneg (le_trans (int.coe_nat_nonneg l) hl),
  tauto,
end

theorem set.Ico_ℕ_finite (l u : ℕ) :
  (Ico l u).finite :=
begin
  by_cases h: l < u,
  { rw Ico_ℕ_eq_Icc _ _ h, apply set.Icc_ℕ_finite _ _},
  rw Ico_eq_empty, simp, simpa using h,
end

theorem set.Ioc_ℕ_finite (l u : ℕ) :
  (Ioc l u).finite :=
by {rw Ioc_ℕ_eq_Icc, apply set.Icc_ℕ_finite}

theorem set.Ioo_ℕ_finite (l u : ℕ) :
  (Ioo l u).finite :=
by {rw Ioo_ℕ_eq_Icc, apply set.Icc_ℕ_finite}

end nat

section int
open int

lemma Ioo_ℤ_eq_Ioc (a b : ℤ) :
  Ioo a b = Ioc a (b-1) :=
ext_iff.mpr (λ x, ⟨λ h, ⟨h.1, le_sub_one_iff.mpr h.2⟩ , λ h, ⟨h.1, le_sub_one_iff.mp h.2⟩⟩)

lemma Ioo_ℤ_eq_Ico (a b : ℤ) :
  Ioo a b = Ico (a+1) b :=
rfl

lemma Ioo_ℤ_eq_Icc (a b : ℤ) :
  Ioo a b = Icc (a+1) (b-1) :=
eq.trans (Ioo_ℤ_eq_Ioc a b) rfl

lemma Ioc_ℤ_eq_Ioo (a b : ℤ) :
  Ioc a b = Ioo a (b+1) :=
ext_iff.mpr (λ x, ⟨λ h, ⟨h.1, lt_add_one_iff.mpr h.2⟩ , λ h, ⟨h.1, lt_add_one_iff.mp h.2⟩⟩)

lemma Ioc_ℤ_eq_Icc (a b : ℤ) :
  Ioc a b = Icc (a+1) b :=
rfl

end int

section insert

variables {α : Type*} [partial_order α] {l u : α}

@[simp] lemma Ioc_insert_left_eq_Icc (hle : l ≤ u) :
  insert l (Ioc l u) = Icc l u :=
begin
  ext x,
  rcases em (x = l) with (rfl | hl),
    simp [hle],
  simp [eq_false_intro hl, ne.le_iff_lt (ne.symm hl)],
end

@[simp] lemma Ioo_insert_right_eq_Ioc (hlt : l < u) :
  insert u (Ioo l u) = Ioc l u :=
begin
  ext x,
  rcases em (x = u) with (rfl | hu),
  { simp [le_refl x, hlt], },
  simp [eq_false_intro hu, false_or, ne.le_iff_lt hu],
end

@[simp] lemma Ioo_insert_left_eq_Ico (hab : l < u) :
  insert l (Ioo l u) = Ico l u :=
begin
  ext x,
  rcases em (x = l) with (rfl | hl),
    simpa [lt_irrefl, le_refl],
  simp [eq_false_intro hl, ne.le_iff_lt (ne.symm hl)],
end

@[simp] lemma Ico_insert_right_eq_Icc (hab : l ≤ u) :
  insert u (Ico l u) = Icc l u :=
begin
  ext x,
  rcases em (x = u) with (rfl | hu),
    simp [hab],
  simp [eq_false_intro hu, ne.le_iff_lt hu],
end

end insert


-- 4.1 The Universal Quantifier

variables (α : Type*) (p q : α → Prop)

example : (∀ x : α, p x ∧ q x) → ∀ y : α, p y :=
assume h : ∀ x : α, p x ∧ q x,
assume y : α,
show p y,
from (h y).left

example : (∀ x : α, p x ∧ q x) → ∀ x : α, p x :=
assume h : ∀ x : α, p x ∧ q x,
assume z : α,
show p z,
from and.elim_left (h z)

variable r : α → α → Prop
variable trans_r : ∀ x y z, r x y → r y z → r x z

variables a b c : α
variables (hab : r a b) (hbc : r b c)

#check trans_r
#check trans_r a b c
#check trans_r a b c hab
#check trans_r a b c hab hbc


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

import linear_algebra.matrix.bilinear_form
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.determinant
import linear_algebra.vandermonde
import linear_algebra.trace
import field_theory.is_alg_closed.algebraic_closure
import field_theory.primitive_element
import ring_theory.power_basis

/-!
# Trace for (finite) ring extensions.

Suppose we have an `R`-algebra `S` with a finite basis. For each `s : S`,
the trace of the linear map given by multiplying by `s` gives information about
the roots of the minimal polynomial of `s` over `R`.

## Main definitions

 * `algebra.trace R S x`: the trace of an element `s` of an `R`-algebra `S`
 * `algebra.trace_form R S`: bilinear form sending `x`, `y` to the trace of `x * y`
 * `algebra.trace_matrix R b`: the matrix whose `(i j)`-th element is the trace of `b i * b j`.
 * `algebra.embeddings_matrix A C b : matrix κ (B →ₐ[A] C) C` is the matrix whose
   `(i, σ)` coefficient is `σ (b i)`.
 * `algebra.embeddings_matrix_reindex A C b e : matrix κ κ C` is the matrix whose `(i, j)`
   coefficient is `σⱼ (b i)`, where `σⱼ : B →ₐ[A] C` is the embedding corresponding to `j : κ`
   given by a bijection `e : κ ≃ (B →ₐ[A] C)`.

## Main results

 * `trace_algebra_map_of_basis`, `trace_algebra_map`: if `x : K`, then `Tr_{L/K} x = [L : K] x`
 * `trace_trace_of_basis`, `trace_trace`: `Tr_{L/K} (Tr_{F/L} x) = Tr_{F/K} x`
 * `trace_eq_sum_roots`: the trace of `x : K(x)` is the sum of all conjugate roots of `x`
 * `trace_eq_sum_embeddings`: the trace of `x : K(x)` is the sum of all embeddings of `x` into an
   algebraically closed field
 * `trace_form_nondegenerate`: the trace form over a separable extension is a nondegenerate
   bilinear form

## Implementation notes

Typically, the trace is defined specifically for finite field extensions.
The definition is as general as possible and the assumption that we have
fields or that the extension is finite is added to the lemmas as needed.

We only define the trace for left multiplication (`algebra.left_mul_matrix`,
i.e. `algebra.lmul_left`).
For now, the definitions assume `S` is commutative, so the choice doesn't matter anyway.

## References

 * https://en.wikipedia.org/wiki/Field_trace

-/

universes u v w z

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra R T]
variables {K L : Type*} [field K] [field L] [algebra K L]
variables {ι κ : Type w} [fintype ι]

open finite_dimensional
open linear_map
open matrix

open_locale big_operators
open_locale matrix

namespace algebra

variables (b : basis ι R S)

variables (R S)

/-- The trace of an element `s` of an `R`-algebra is the trace of `(*) s`,
as an `R`-linear map. -/
noncomputable def trace : S →ₗ[R] R :=
(linear_map.trace R S).comp (lmul R S).to_linear_map

variables {S}

-- Not a `simp` lemma since there are more interesting ways to rewrite `trace R S x`,
-- for example `trace_trace`
lemma trace_apply (x) : trace R S x = linear_map.trace R S (lmul R S x) := rfl

lemma trace_eq_zero_of_not_exists_basis
  (h : ¬ ∃ (s : finset S), nonempty (basis s R S)) : trace R S = 0 :=
by { ext s, simp [trace_apply, linear_map.trace, h] }

include b

variables {R}

-- Can't be a `simp` lemma because it depends on a choice of basis
lemma trace_eq_matrix_trace [decidable_eq ι] (b : basis ι R S) (s : S) :
  trace R S s = matrix.trace _ R _ (algebra.left_mul_matrix b s) :=
by rw [trace_apply, linear_map.trace_eq_matrix_trace _ b, to_matrix_lmul_eq]

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`. -/
lemma trace_algebra_map_of_basis (x : R) :
  trace R S (algebra_map R S x) = fintype.card ι • x :=
begin
  haveI := classical.dec_eq ι,
  rw [trace_apply, linear_map.trace_eq_matrix_trace R b, trace_diag],
  convert finset.sum_const _,
  ext i,
  simp,
end
omit b

/-- If `x` is in the base field `K`, then the trace is `[L : K] * x`.

(If `L` is not finite-dimensional over `K`, then `trace` and `finrank` return `0`.)
-/
@[simp]
lemma trace_algebra_map (x : K) : trace K L (algebra_map K L x) = finrank K L • x :=
begin
  by_cases H : ∃ (s : finset L), nonempty (basis s K L),
  { rw [trace_algebra_map_of_basis H.some_spec.some, finrank_eq_card_basis H.some_spec.some] },
  { simp [trace_eq_zero_of_not_exists_basis K H, finrank_eq_zero_of_not_exists_basis_finset H] }
end

lemma trace_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) (x : T) :
  trace R S (trace S T x) = trace R T x :=
begin
  haveI := classical.dec_eq ι,
  haveI := classical.dec_eq κ,
  rw [trace_eq_matrix_trace (b.smul c), trace_eq_matrix_trace b, trace_eq_matrix_trace c,
      matrix.trace_apply, matrix.trace_apply, matrix.trace_apply,
      ← finset.univ_product_univ, finset.sum_product],
  refine finset.sum_congr rfl (λ i _, _),
  simp only [alg_hom.map_sum, smul_left_mul_matrix, finset.sum_apply,
      -- The unifier is not smart enough to apply this one by itself:
      finset.sum_apply i _ (λ y, left_mul_matrix b (left_mul_matrix c x y y))]
end

lemma trace_comp_trace_of_basis [algebra S T] [is_scalar_tower R S T]
  {ι κ : Type*} [fintype ι] [fintype κ]
  (b : basis ι R S) (c : basis κ S T) :
  (trace R S).comp ((trace S T).restrict_scalars R) = trace R T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace_of_basis b c] }

@[simp]
lemma trace_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] (x : T) :
  trace K L (trace L T x) = trace K T x :=
trace_trace_of_basis (basis.of_vector_space K L) (basis.of_vector_space L T) x

@[simp]
lemma trace_comp_trace [algebra K T] [algebra L T] [is_scalar_tower K L T]
  [finite_dimensional K L] [finite_dimensional L T] :
  (trace K L).comp ((trace L T).restrict_scalars K) = trace K T :=
by { ext, rw [linear_map.comp_apply, linear_map.restrict_scalars_apply, trace_trace] }

section trace_form

variables (R S)

/-- The `trace_form` maps `x y : S` to the trace of `x * y`.
It is a symmetric bilinear form and is nondegenerate if the extension is separable. -/
noncomputable def trace_form : bilin_form R S :=
(linear_map.compr₂ (lmul R S).to_linear_map (trace R S)).to_bilin

variables {S}

-- This is a nicer lemma than the one produced by `@[simps] def trace_form`.
@[simp] lemma trace_form_apply (x y : S) : trace_form R S x y = trace R S (x * y) := rfl

lemma trace_form_is_symm : (trace_form R S).is_symm :=
λ x y, congr_arg (trace R S) (mul_comm _ _)

lemma trace_form_to_matrix_power_basis (h : power_basis R S) :
  bilin_form.to_matrix h.basis (trace_form R S) = λ i j, (trace R S (h.gen ^ (i + j : ℕ))) :=
by { ext, rw [trace_form_to_matrix, pow_add, h.basis_eq_pow, h.basis_eq_pow] }

end trace_form

end algebra

section eq_sum_roots

open algebra polynomial

variables {F : Type*} [field F]
variables [algebra K S] [algebra K F]

/-- Given `pb : power_basis K S`, the trace of `pb.gen` is `-(minpoly K pb.gen).next_coeff`. -/
lemma power_basis.trace_gen_eq_next_coeff_minpoly [nontrivial S] (pb : power_basis K S) :
  algebra.trace K S pb.gen = -(minpoly K pb.gen).next_coeff :=
begin
  have d_pos : 0 < pb.dim := power_basis.dim_pos pb,
  have d_pos' : 0 < (minpoly K pb.gen).nat_degree, { simpa },
  haveI : nonempty (fin pb.dim) := ⟨⟨0, d_pos⟩⟩,
  rw [trace_eq_matrix_trace pb.basis, trace_eq_neg_charpoly_coeff, charpoly_left_mul_matrix,
      ← pb.nat_degree_minpoly, fintype.card_fin, ← next_coeff_of_pos_nat_degree _ d_pos']
end

/-- Given `pb : power_basis K S`, then the trace of `pb.gen` is
`((minpoly K pb.gen).map (algebra_map K F)).roots.sum`. -/
lemma power_basis.trace_gen_eq_sum_roots [nontrivial S] (pb : power_basis K S)
  (hf : (minpoly K pb.gen).splits (algebra_map K F)) :
  algebra_map K F (trace K S pb.gen) =
    ((minpoly K pb.gen).map (algebra_map K F)).roots.sum :=
begin
  rw [power_basis.trace_gen_eq_next_coeff_minpoly, ring_hom.map_neg, ← next_coeff_map
    (algebra_map K F).injective, sum_roots_eq_next_coeff_of_monic_of_split
      ((minpoly.monic (power_basis.is_integral_gen _)).map _)
      ((splits_id_iff_splits _).2 hf), neg_neg]
end

namespace intermediate_field.adjoin_simple

open intermediate_field

lemma trace_gen_eq_zero {x : L} (hx : ¬ is_integral K x) :
  algebra.trace K K⟮x⟯ (adjoin_simple.gen K x) = 0 :=
begin
  rw [trace_eq_zero_of_not_exists_basis, linear_map.zero_apply],
  contrapose! hx,
  obtain ⟨s, ⟨b⟩⟩ := hx,
  refine is_integral_of_mem_of_fg (K⟮x⟯).to_subalgebra _ x _,
  { exact (submodule.fg_iff_finite_dimensional _).mpr (finite_dimensional.of_finset_basis b) },
  { exact subset_adjoin K _ (set.mem_singleton x) }
end

lemma trace_gen_eq_sum_roots (x : L)
  (hf : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (trace K K⟮x⟯ (adjoin_simple.gen K x)) =
    ((minpoly K x).map (algebra_map K F)).roots.sum :=
begin
  have injKxL := (algebra_map K⟮x⟯ L).injective,
  by_cases hx : is_integral K x, swap,
  { simp [minpoly.eq_zero hx, trace_gen_eq_zero hx], },
  have hx' : is_integral K (adjoin_simple.gen K x),
  { rwa [← is_integral_algebra_map_iff injKxL, adjoin_simple.algebra_map_gen],
    apply_instance },
  rw [← adjoin.power_basis_gen hx, (adjoin.power_basis hx).trace_gen_eq_sum_roots];
    rw [adjoin.power_basis_gen hx, minpoly.eq_of_algebra_map_eq injKxL hx'];
    try { simp only [adjoin_simple.algebra_map_gen _ _] },
  exact hf
end

end intermediate_field.adjoin_simple

open intermediate_field

variables (K)

lemma trace_eq_trace_adjoin [finite_dimensional K L] (x : L) :
  algebra.trace K L x = finrank K⟮x⟯ L • trace K K⟮x⟯ (adjoin_simple.gen K x) :=
begin
  rw ← @trace_trace _ _ K K⟮x⟯ _ _ _ _ _ _ _ _ x,
  conv in x { rw ← intermediate_field.adjoin_simple.algebra_map_gen K x },
  rw [trace_algebra_map, linear_map.map_smul_of_tower],
end

variables {K}

lemma trace_eq_sum_roots [finite_dimensional K L]
  {x : L} (hF : (minpoly K x).splits (algebra_map K F)) :
  algebra_map K F (algebra.trace K L x) =
    finrank K⟮x⟯ L • ((minpoly K x).map (algebra_map K _)).roots.sum :=
by rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← algebra.smul_def,
    intermediate_field.adjoin_simple.trace_gen_eq_sum_roots _ hF, is_scalar_tower.algebra_map_smul]

end eq_sum_roots

variables {F : Type*} [field F]
variables [algebra R L] [algebra L F] [algebra R F] [is_scalar_tower R L F]

open polynomial

lemma algebra.is_integral_trace [finite_dimensional L F] {x : F} (hx : _root_.is_integral R x) :
  _root_.is_integral R (algebra.trace L F x) :=
begin
  have hx' : _root_.is_integral L x := is_integral_of_is_scalar_tower _ hx,
  rw [← is_integral_algebra_map_iff (algebra_map L (algebraic_closure F)).injective,
      trace_eq_sum_roots],
  { refine (is_integral.multiset_sum _).nsmul _,
    intros y hy,
    rw mem_roots_map (minpoly.ne_zero hx') at hy,
    use [minpoly R x, minpoly.monic hx],
    rw ← aeval_def at ⊢ hy,
    exact minpoly.aeval_of_is_scalar_tower R x y hy },
  { apply is_alg_closed.splits_codomain },
  { apply_instance }
end

section eq_sum_embeddings

variables [algebra K F] [is_scalar_tower K L F]

open algebra intermediate_field

variables (F) (E : Type*) [field E] [algebra K E]

lemma trace_eq_sum_embeddings_gen
  (pb : power_basis K L)
  (hE : (minpoly K pb.gen).splits (algebra_map K E)) (hfx : (minpoly K pb.gen).separable) :
  algebra_map K E (algebra.trace K L pb.gen) =
    (@@finset.univ (power_basis.alg_hom.fintype pb)).sum (λ σ, σ pb.gen) :=
begin
  letI := classical.dec_eq E,
  rw [pb.trace_gen_eq_sum_roots hE, fintype.sum_equiv pb.lift_equiv', finset.sum_mem_multiset,
      finset.sum_eq_multiset_sum, multiset.to_finset_val,
      multiset.dedup_eq_self.mpr _, multiset.map_id],
  { exact nodup_roots ((separable_map _).mpr hfx) },
  { intro x, refl },
  { intro σ, rw [power_basis.lift_equiv'_apply_coe, id.def] }
end

variables [is_alg_closed E]

lemma sum_embeddings_eq_finrank_mul [finite_dimensional K F] [is_separable K F]
  (pb : power_basis K L) :
  ∑ σ : F →ₐ[K] E, σ (algebra_map L F pb.gen) =
    finrank L F • (@@finset.univ (power_basis.alg_hom.fintype pb)).sum
      (λ σ : L →ₐ[K] E, σ pb.gen) :=
begin
  haveI : finite_dimensional L F := finite_dimensional.right K L F,
  haveI : is_separable L F := is_separable_tower_top_of_is_separable K L F,
  letI : fintype (L →ₐ[K] E) := power_basis.alg_hom.fintype pb,
  letI : ∀ (f : L →ₐ[K] E), fintype (@@alg_hom L F E _ _ _ _ f.to_ring_hom.to_algebra) :=
    _, -- will be solved by unification
  rw [fintype.sum_equiv alg_hom_equiv_sigma (λ (σ : F →ₐ[K] E), _) (λ σ, σ.1 pb.gen),
      ← finset.univ_sigma_univ, finset.sum_sigma, ← finset.sum_nsmul],
  refine finset.sum_congr rfl (λ σ _, _),
  { letI : algebra L E := σ.to_ring_hom.to_algebra,
    simp only [finset.sum_const, finset.card_univ],
    rw alg_hom.card L F E },
  { intros σ,
    simp only [alg_hom_equiv_sigma, equiv.coe_fn_mk, alg_hom.restrict_domain, alg_hom.comp_apply,
         is_scalar_tower.coe_to_alg_hom'] }
end

lemma trace_eq_sum_embeddings [finite_dimensional K L] [is_separable K L]
  {x : L} : algebra_map K E (algebra.trace K L x) = ∑ σ : L →ₐ[K] E, σ x :=
begin
  have hx := is_separable.is_integral K x,
  rw [trace_eq_trace_adjoin K x, algebra.smul_def, ring_hom.map_mul, ← adjoin.power_basis_gen hx,
      trace_eq_sum_embeddings_gen E (adjoin.power_basis hx) (is_alg_closed.splits_codomain _),
      ← algebra.smul_def, algebra_map_smul],
  { exact (sum_embeddings_eq_finrank_mul L E (adjoin.power_basis hx)).symm },
  { haveI := is_separable_tower_bot_of_is_separable K K⟮x⟯ L,
    exact is_separable.separable K _ }
end

end eq_sum_embeddings

section det_ne_zero

namespace algebra

variables (A : Type u) {B : Type v} (C : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B] [comm_ring C] [algebra A C]

open finset

/-- Given an `A`-algebra `B` and `b`, an `κ`-indexed family of elements of `B`, we define
`trace_matrix A b` as the matrix whose `(i j)`-th element is the trace of `b i * b j`. -/
@[simp] noncomputable
def trace_matrix (b : κ → B) : matrix κ κ A
| i j := trace_form A B (b i) (b j)

lemma trace_matrix_def (b : κ → B) : trace_matrix A b = λ i j, trace_form A B (b i) (b j) := rfl

lemma trace_matrix_reindex {κ' : Type*} (b : basis κ A B) (f : κ ≃ κ') :
  trace_matrix A (b.reindex f) = reindex f f (trace_matrix A b) :=
by {ext x y, simp}

variables {A}

lemma trace_matrix_of_matrix_vec_mul [fintype κ] (b : κ → B) (P : matrix κ κ A) :
  trace_matrix A ((P.map (algebra_map A B)).vec_mul b) = Pᵀ ⬝ (trace_matrix A b) ⬝ P :=
begin
  ext α β,
  rw [trace_matrix, vec_mul, dot_product, vec_mul, dot_product, matrix.mul_apply,
    bilin_form.sum_left, fintype.sum_congr _ _ (λ (i : κ), @bilin_form.sum_right _ _ _ _ _ _ _ _
    (b i * P.map (algebra_map A B) i α) (λ (y : κ), b y * P.map (algebra_map A B) y β)), sum_comm],
  congr, ext x,
  rw [matrix.mul_apply, sum_mul],
  congr, ext y,
  rw [map_apply, trace_form_apply, mul_comm (b y), ← smul_def],
  simp only [id.smul_eq_mul, ring_hom.id_apply, map_apply, transpose_apply, linear_map.map_smulₛₗ,
    trace_form_apply, algebra.smul_mul_assoc],
  rw [mul_comm (b x), ← smul_def],
  ring_nf,
  simp,
end

lemma trace_matrix_of_matrix_mul_vec [fintype κ] (b : κ → B) (P : matrix κ κ A) :
  trace_matrix A ((P.map (algebra_map A B)).mul_vec b) = P ⬝ (trace_matrix A b) ⬝ Pᵀ :=
begin
  refine add_equiv.injective transpose_add_equiv _,
  rw [transpose_add_equiv_apply, transpose_add_equiv_apply, ← vec_mul_transpose,
    ← transpose_map, trace_matrix_of_matrix_vec_mul, transpose_transpose, transpose_mul,
    transpose_transpose, transpose_mul]
end

lemma trace_matrix_of_basis [fintype κ] [decidable_eq κ] (b : basis κ A B) :
  trace_matrix A b = bilin_form.to_matrix b (trace_form A B) :=
begin
  ext i j,
  rw [trace_matrix, trace_form_apply, trace_form_to_matrix]
end

lemma trace_matrix_of_basis_mul_vec (b : basis ι A B) (z : B) :
  (trace_matrix A b).mul_vec (b.equiv_fun z) = (λ i, trace A B (z * (b i))) :=
begin
  ext i,
  rw [← col_apply ((trace_matrix A b).mul_vec (b.equiv_fun z)) i unit.star, col_mul_vec,
    matrix.mul_apply, trace_matrix_def],
  simp only [col_apply, trace_form_apply],
  conv_lhs
  { congr, skip, funext,
    rw [mul_comm _ (b.equiv_fun z _), ← smul_eq_mul, ← linear_map.map_smul] },
    rw [← linear_map.map_sum],
    congr,
    conv_lhs
    { congr, skip, funext,
      rw [← mul_smul_comm] },
    rw [← finset.mul_sum, mul_comm z],
    congr,
    rw [b.sum_equiv_fun ]
end

variable (A)
/-- `embeddings_matrix A C b : matrix κ (B →ₐ[A] C) C` is the matrix whose `(i, σ)` coefficient is
  `σ (b i)`. It is mostly useful for fields when `fintype.card κ = finrank A B` and `C` is
  algebraically closed. -/
@[simp] def embeddings_matrix (b : κ → B) : matrix κ (B →ₐ[A] C) C
| i σ := σ (b i)

/-- `embeddings_matrix_reindex A C b e : matrix κ κ C` is the matrix whose `(i, j)` coefficient
  is `σⱼ (b i)`, where `σⱼ : B →ₐ[A] C` is the embedding corresponding to `j : κ` given by a
  bijection `e : κ ≃ (B →ₐ[A] C)`. It is mostly useful for fields and `C` is algebraically closed.
  In this case, in presence of `h : fintype.card κ = finrank A B`, one can take
  `e := equiv_of_card_eq ((alg_hom.card A B C).trans h.symm)`. -/
def embeddings_matrix_reindex (b : κ → B) (e : κ ≃ (B →ₐ[A] C)) :=
reindex (equiv.refl κ) e.symm (embeddings_matrix A C b)

variable {A}

lemma embeddings_matrix_reindex_eq_vandermonde (pb : power_basis A B)
  (e : fin pb.dim ≃ (B →ₐ[A] C)) :
  embeddings_matrix_reindex A C pb.basis e = (vandermonde (λ i, e i pb.gen))ᵀ :=
by { ext i j, simp [embeddings_matrix_reindex, embeddings_matrix] }

section field

variables (K) {L} (E : Type z) [field E]
variables [algebra K E]
variables [module.finite K L] [is_separable K L] [is_alg_closed E]
variables (b : κ → L) (pb : power_basis K L)

lemma trace_matrix_eq_embeddings_matrix_mul_trans :
  (trace_matrix K b).map (algebra_map K E) =
  (embeddings_matrix K E b) ⬝ (embeddings_matrix K E b)ᵀ :=
by { ext i j, simp [trace_eq_sum_embeddings, embeddings_matrix, matrix.mul_apply] }

lemma trace_matrix_eq_embeddings_matrix_reindex_mul_trans [fintype κ]
  (e : κ ≃ (L →ₐ[K] E)) : (trace_matrix K b).map (algebra_map K E) =
  (embeddings_matrix_reindex K E b e) ⬝ (embeddings_matrix_reindex K E b e)ᵀ :=
by rw [trace_matrix_eq_embeddings_matrix_mul_trans, embeddings_matrix_reindex, reindex_apply,
  transpose_minor, ← minor_mul_transpose_minor, ← equiv.coe_refl, equiv.refl_symm]

end field

end algebra

open algebra

variables (pb : power_basis K L)

lemma det_trace_matrix_ne_zero' [is_separable K L] :
  det (trace_matrix K pb.basis) ≠ 0 :=
begin
  suffices : algebra_map K (algebraic_closure L) (det (trace_matrix K pb.basis)) ≠ 0,
  { refine mt (λ ht, _) this,
    rw [ht, ring_hom.map_zero] },
  haveI : finite_dimensional K L := pb.finite_dimensional,
  let e : fin pb.dim ≃ (L →ₐ[K] algebraic_closure L) := (fintype.equiv_fin_of_card_eq _).symm,
  rw [ring_hom.map_det, ring_hom.map_matrix_apply,
      trace_matrix_eq_embeddings_matrix_reindex_mul_trans K _ _ e,
      embeddings_matrix_reindex_eq_vandermonde, det_mul, det_transpose],
  refine mt mul_self_eq_zero.mp _,
  { simp only [det_vandermonde, finset.prod_eq_zero_iff, not_exists, sub_eq_zero],
    intros i _ j hij h,
    exact (finset.mem_filter.mp hij).2.ne' (e.injective $ pb.alg_hom_ext h) },
  { rw [alg_hom.card, pb.finrank] }
end

lemma det_trace_form_ne_zero [is_separable K L] [decidable_eq ι] (b : basis ι K L) :
  det (bilin_form.to_matrix b (trace_form K L)) ≠ 0 :=
begin
  haveI : finite_dimensional K L := finite_dimensional.of_fintype_basis b,
  let pb : power_basis K L := field.power_basis_of_finite_of_separable _ _,
  rw [← bilin_form.to_matrix_mul_basis_to_matrix pb.basis b,
      ← det_comm' (pb.basis.to_matrix_mul_to_matrix_flip b) _,
      ← matrix.mul_assoc, det_mul],
  swap, { apply basis.to_matrix_mul_to_matrix_flip },
  refine mul_ne_zero
    (is_unit_of_mul_eq_one _ ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det _).ne_zero
    _,
  { calc (pb.basis.to_matrix b ⬝ (pb.basis.to_matrix b)ᵀ).det *
        ((b.to_matrix pb.basis)ᵀ ⬝ b.to_matrix pb.basis).det
        = (pb.basis.to_matrix b ⬝ (b.to_matrix pb.basis ⬝ pb.basis.to_matrix b)ᵀ ⬝
          b.to_matrix pb.basis).det
        : by simp only [← det_mul, matrix.mul_assoc, matrix.transpose_mul]
    ... = 1 : by simp only [basis.to_matrix_mul_to_matrix_flip, matrix.transpose_one,
                            matrix.mul_one, matrix.det_one] },
  simpa only [trace_matrix_of_basis] using det_trace_matrix_ne_zero' pb
end

variables (K L)

theorem trace_form_nondegenerate [finite_dimensional K L] [is_separable K L] :
  (trace_form K L).nondegenerate :=
bilin_form.nondegenerate_of_det_ne_zero (trace_form K L) _
  (det_trace_form_ne_zero (finite_dimensional.fin_basis K L))

end det_ne_zero


import data.nat.factorization.basic

/-!
# Divisor-closed proposition

We say that a predicate `P : ℕ → Prop` is divisor-closed if for any positive
  integer `n` for which `P(n)` holds, we also have `P(d)` for any factor `d` of `n`.
We also define the following terminologies; most of their purposes are in number theory problems.
* We say that `P` is *wide* if `P(p)` holds for infinitely many primes `p`.
* We say that `P` is *`p`-strong* for some `p : ℕ` if `P(p^k)` holds for any `k ≥ 0`.
We defined `p`-strong generally to avoid complications.
However, its main usage comes when `p` is prime.

For convenience, we say that `P` is infinite if `P(n)` holds for infinitely many `n : ℕ`.
The main result we will prove is that a divisor-closed predicate `P` is
  infinite if and only if  `P` is either wide or `p`-strong for some prime `p`.
Note that we need axiom of choice to prove this result.

**Proof**

Clearly wide and `p`-strong predicates for any `p ≥ 2` are infinite.
Thus, it remains to prove the converse.
Let `P` be a divisor-closed predicate.
Suppose that `P` is neither wide or `p`-strong for any `p` prime.
Note that, if `P(n)` holds for some `n`, then `P(1)` must hold since `P` is divisor-closed.
Thus it is clear that `P` is not infinite if `P(1)` does not hold.
For the rest of the proof, we assume that `P(1)` holds.

For each `p` prime, since `P` is divisor-closed but not `p`-strong, there exists
  `x_p : ℕ` such that `P(p^k) ↔ k ≤ x_p` for any `k : ℕ`.
Indeed, we just take the maximum `k` such that `P(p^k)` holds.
Axiom of choice gives us a map `x : p ↦ x_p` with the domain being the set of primes.
Now, since `P` is not wide, `P(p)`, equivalently `x_p ≥ 1`, holds for finitely many primes `p`.

Finally, let `N = ∏ p, p^{x_p}`; the product is taken over primes `p` for which `x_p ≥ 1`.
If a positive integer `n` does not divide `N`, then `x_p < ν_p(n)` for some `p` prime.
Then `P(p^{ν_p(n)})` does not hold, so `P(n)` does not hold either.
Thus, for any `n` such that `P(n)` holds, we necessarily have `n ∣ N`.
There are finitely many such `n`, so `P` is not infinite, as desired.
-/

namespace IMOSL
namespace extra

/-- Divisor-closed maps -/
def divisor_closed (P : ℕ → Prop) := ∀ n : ℕ, n ≠ 0 → P n → ∀ d : ℕ, d ∣ n → P d

/-- Wide maps -/
def wide (P : ℕ → Prop) := {p : ℕ | p.prime ∧ P p}.infinite

/-- `p`-strong maps -/
def strong (p : ℕ) (P : ℕ → Prop) := ∀ k : ℕ, P (p ^ k)

section results

/-- If `P` is wide, then `P(n)` holds for infinitely many `n`,
  even if `P` is not divisor-closed. -/
theorem infinite_pred_of_wide {P : ℕ → Prop} (h0 : wide P) : (set_of P).infinite :=
  h0.mono (λ x h1, h1.2)

/-- If `P` is `p`-strong for some `p ≥ 2`, not necessarily prime, then
  `P(n)` holds for infinitely many `n`, even if `P` is not divisor-closed. -/
theorem infinite_pred_of_strong {P : ℕ → Prop} {p : ℕ} (h0 : 2 ≤ p) (h1 : strong p P) :
  (set_of P).infinite :=
  set.infinite_of_injective_forall_mem (nat.pow_right_injective h0) h1

variables {P : ℕ → Prop} [decidable_pred P] (h : divisor_closed P)
include h

/-- If `P(n)` holds for some `n ≠ 0`, then `P(1)` holds; this is obvious. -/
lemma dc_at_one {n : ℕ} (h0 : n ≠ 0) (h1 : P n) : P 1 :=
  h n h0 h1 1 (one_dvd n)

/-- An if-and-only-if criterion for a divisor-closed predicate to be `p`-strong; `p ≠ 0`. -/
theorem dc_not_strong_iff {p : ℕ} (h0 : p ≠ 0) :
  ¬strong p P ↔ (∃ c : ℕ, ∀ k : ℕ, P (p ^ k) ↔ k < c) :=
begin
  rw [strong, not_forall],
  refine ⟨λ h1, ⟨nat.find h1, (λ k, ⟨λ h2, _, λ h2, not_not.mp (nat.find_min h1 h2)⟩)⟩, λ h1, _⟩,
  rw ← not_le; intros h3,
  exact nat.find_spec h1 (h _ (pow_ne_zero k h0) h2 _ (pow_dvd_pow _ h3)),
  cases h1 with c h1,
  refine ⟨c, _⟩; rw h1,
  exact lt_irrefl c
end

/-- Using choice, given a predicate `P` that is not `p`-strong for any `p` prime, construct a
  map `x : nat.primes → ℕ` such that `P(p^k) → k < x_p` for any `k : ℕ` and `p` prime. -/
theorem dc_not_strong_aoc_map_iff (h0 : ∀ p : ℕ, p.prime → ¬strong p P) :
  ∃ x : ℕ → ℕ, (∀ p : ℕ, x p ≠ 0 → p.prime) ∧
    ∀ (p : ℕ) (hp : p.prime) (k : ℕ), P (p ^ k) ↔ k < x p :=
begin
  have h1 : ∀ p : nat.primes, ∃ kp : ℕ, (∀ k : ℕ, P (p ^ k) ↔ k < kp) :=
    λ ⟨p, hp⟩, by rw [subtype.coe_mk, ← dc_not_strong_iff h hp.ne_zero]; exact h0 p hp,
  replace h1 := classical.axiom_of_choice h1,
  cases h1 with x h1,
  refine ⟨(λ p, dite p.prime (λ hp : p.prime, x ⟨p, hp⟩) (λ _, 0)), (λ p h2, _), (λ p hp k, _)⟩,
  rw [ne.def, dite_eq_right_iff, not_forall] at h2,
  cases h2 with h2 h3; exact h2,
  rw [dif_pos hp, ← h1, subtype.coe_mk]
end

/-- Using choice, given a predicate `P` that is not `p`-strong for any `p` prime, construct a
  map `x : nat.primes → ℕ` such that `P(p^k) → k ≤ x_p` for any `k : ℕ` and `p` prime.
This is just a weak version of `dc_not_strong_aoc_map_iff`. -/
theorem dc_not_strong_aoc_map (h0 : ∀ p : ℕ, p.prime → ¬strong p P) :
  ∃ x : ℕ → ℕ, (∀ p : ℕ, x p ≠ 0 → p.prime) ∧
    ∀ (p : ℕ) (hp : p.prime) (k : ℕ), P (p ^ k) → k ≤ x p :=
  by rcases dc_not_strong_aoc_map_iff h h0 with ⟨x, h1, h2⟩;
    exact ⟨x, h1, λ p hp k h3, le_of_lt ((h2 p hp k).mp h3)⟩

/-- Using choice, given a predicate `P` that is not `p`-strong for any `p` prime, under the
  condition `P(1)`, construct a map `x : nat.primes → ℕ` such that `P(p^k) ↔ k ≤ x_p` for any
  `k : ℕ` and `p` prime. -/
theorem dc_not_strong_aoc_map_iff' (h0 : ∀ p : ℕ, p.prime → ¬strong p P) (h1 : P 1) :
  ∃ x : ℕ → ℕ, (∀ p : ℕ, x p ≠ 0 → p.prime) ∧
    ∀ (p : ℕ) (hp : p.prime) (k : ℕ), P (p ^ k) ↔ k ≤ x p :=
begin
  rcases dc_not_strong_aoc_map_iff h h0 with ⟨x, h2, h3⟩,
  refine ⟨λ p, x p - 1, λ p h4, h2 p (λ h5, _), λ p hp k, _⟩,
  rw [h5, zero_tsub] at h4; exact h4 rfl,
  rw [h3 p hp, ← nat.lt_succ_iff, nat.succ_eq_add_one, nat.sub_add_cancel],
  rwa [nat.succ_le_iff, ← h3 p hp, pow_zero]
end

/-- Using choice, given a predicate `P` that is neither wide nor `p`-strong for any `p` prime,
  under the condition `P(1)`, construct a finitely-supported map `x : nat.primes → ℕ` such that
  `P(p^k) ↔ k ≤ x_p` for any `k : ℕ` and `p` prime. -/
theorem dc_not_wide_strong_aoc_finsupp
    (h0 : ¬wide P) (h1 : ∀ p : ℕ, p.prime → ¬strong p P) (h2 : P 1) :
  ∃ x : ℕ →₀ ℕ, (∀ p : ℕ, x p ≠ 0 → p.prime) ∧
    ∀ (p : ℕ) (hp : p.prime) (k : ℕ), P (p ^ k) ↔ k ≤ x p :=
begin
  rw [wide, set.not_infinite] at h0,
  replace h2 := dc_not_strong_aoc_map_iff' h h1 h2,
  clear h h1; rcases h2 with ⟨x, h, h1⟩,
  refine ⟨⟨h0.to_finset, x, (λ p, _)⟩, ⟨h, h1⟩⟩,
  rw [set.finite.mem_to_finset, set.mem_set_of_eq, iff.comm],
  refine ⟨λ h2, ⟨h p h2, _⟩, λ h2, _⟩,
  rwa [← pow_one p, h1 p (h p h2), nat.succ_le_iff, zero_lt_iff],
  rw [← zero_lt_iff, ← nat.succ_le_iff, ← h1 p h2.1, pow_one],
  exact h2.2
end

/-- Assuming choice, if `P(n)` holds for infinitely many `n`, then
  `P` is either wide or `p`-strong for some `p` prime. -/
theorem dc_wide_or_strong_of_infinite (h0 : (set_of P).infinite) :
  wide P ∨ ∃ p : ℕ, p.prime ∧ strong p P :=
begin
  ---- First find `x : primes →₀ ℕ` such that `P(n) → ∀ p, v_p(n) ≤ x_p`
  have h1 : P 1 := by rcases h0.exists_nat_lt 0 with ⟨n, h1, h2⟩;
    exact dc_at_one h (ne_of_gt h2) h1,
  by_contra' h2; replace h2 := dc_not_wide_strong_aoc_finsupp h h2.1 h2.2 h1,
  clear h1; rcases h2 with ⟨x, h1, h2⟩,

  ---- Now take any `m > ∏_p p^{x_p}` and get a contradiction
  replace h0 := h0.exists_nat_lt (x.prod has_pow.pow),
  rcases h0 with ⟨m, h0, h3⟩,
  revert h3; rw [imp_false, not_lt],
  cases eq_or_ne m 0 with h3 h3,
  rw h3; exact (x.prod pow).zero_le,
  have h4 : 0 < x.prod pow := nat.prod_pow_pos_of_zero_not_mem_support
    (λ h4, nat.not_prime_zero (h1 0 $ finsupp.mem_support_iff.mp h4)),
  refine nat.le_of_dvd h4 _,
  rw [← nat.factorization_le_iff_dvd h3 (ne_of_gt h4),
      nat.prod_pow_factorization_eq_self _, finsupp.le_iff],
  intros p h5; replace h5 : p.prime := nat.prime_of_mem_factorization h5,
  rw [nat.factorization_def m h5, ← h2 p h5],
  exact h m h3 h0 _ pow_padic_val_nat_dvd,
  intros p h5; exact h1 p (finsupp.mem_support_iff.mp h5)
end

/-- Assuming choice, `P(n)` holds for infinitely many `n` iff
  `P` is either wide or `p`-strong for some `p` prime. -/
theorem dc_infinite_iff_wide_or_strong :
  (set_of P).infinite ↔ wide P ∨ ∃ p : ℕ, p.prime ∧ strong p P :=
begin
  refine ⟨dc_wide_or_strong_of_infinite h, λ h0, _⟩,
  rcases h0 with h0 | ⟨p, hp, h0⟩,
  exacts [infinite_pred_of_wide h0, infinite_pred_of_strong hp.two_le h0]
end

end results

end extra
end IMOSL