/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Leonardo de Moura
-/
prelude
import Init.SimpLemmas
universe u

namespace Nat

@[specialize] def foldAux {α : Type u} (f : Nat → α → α) (s : Nat) : Nat → α → α
  | 0,      a => a
  | succ n, a => foldAux f s n (f (s - (succ n)) a)

@[inline] def fold {α : Type u} (f : Nat → α → α) (n : Nat) (init : α) : α :=
  foldAux f n n init

@[inline] def foldRev {α : Type u} (f : Nat → α → α) (n : Nat) (init : α) : α :=
  let rec @[specialize] loop
    | 0,      a => a
    | succ n, a => loop n (f n a)
  loop n init

@[specialize] def anyAux (f : Nat → Bool) (s : Nat) : Nat → Bool
  | 0      => false
  | succ n => f (s - (succ n)) || anyAux f s n

/- `any f n = true` iff there is `i in [0, n-1]` s.t. `f i = true` -/
@[inline] def any (f : Nat → Bool) (n : Nat) : Bool :=
  anyAux f n n

@[inline] def all (f : Nat → Bool) (n : Nat) : Bool :=
  !any (fun i => !f i) n

@[inline] def repeat {α : Type u} (f : α → α) (n : Nat) (a : α) : α :=
  let rec @[specialize] loop
    | 0,      a => a
    | succ n, a => loop n (f a)
  loop n a

/- Nat.add theorems -/

@[simp] theorem zero_eq : Nat.zero = 0 :=
  rfl

@[simp] theorem add_eq : Nat.add x y = x + y :=
  rfl

@[simp] protected theorem zero_add : ∀ (n : Nat), 0 + n = n
  | 0   => rfl
  | n+1 => congrArg succ (Nat.zero_add n)

theorem succ_add : ∀ (n m : Nat), (succ n) + m = succ (n + m)
  | n, 0   => rfl
  | n, m+1 => congrArg succ (succ_add n m)

theorem add_succ (n m : Nat) : n + succ m = succ (n + m) :=
  rfl

theorem add_one (n : Nat) : n + 1 = succ n :=
  rfl

theorem succ_eq_add_one (n : Nat) : succ n = n + 1 :=
  rfl

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

protected theorem add_assoc : ∀ (n m k : Nat), (n + m) + k = n + (m + k)
  | n, m, 0      => rfl
  | n, m, succ k => congrArg succ (Nat.add_assoc n m k)

protected theorem add_left_comm (n m k : Nat) : n + (m + k) = m + (n + k) := by
  rw [← Nat.add_assoc, Nat.add_comm n m, Nat.add_assoc]

protected theorem add_right_comm (n m k : Nat) : (n + m) + k = (n + k) + m := by
  rw [Nat.add_assoc, Nat.add_comm m k, ← Nat.add_assoc]

protected theorem add_left_cancel {n m k : Nat} : n + m = n + k → m = k := by
  induction n with
  | zero => simp; intros; assumption
  | succ n ih => simp [succ_add]; intro h; apply ih h

protected theorem add_right_cancel {n m k : Nat} (h : n + m = k + m) : n = k := by
  rw [Nat.add_comm n m, Nat.add_comm k m] at h
  apply Nat.add_left_cancel h

/- Nat.mul theorems -/

@[simp] protected theorem mul_zero (n : Nat) : n * 0 = 0 :=
  rfl

theorem mul_succ (n m : Nat) : n * succ m = n * m + n :=
  rfl

@[simp] protected theorem zero_mul : ∀ (n : Nat), 0 * n = 0
  | 0      => rfl
  | succ n => mul_succ 0 n ▸ (Nat.zero_mul n).symm ▸ rfl

theorem succ_mul (n m : Nat) : (succ n) * m = (n * m) + m := by
  induction m with
  | zero => rfl
  | succ m ih => rw [mul_succ, add_succ, ih, mul_succ, add_succ, Nat.add_right_comm]

protected theorem mul_comm : ∀ (n m : Nat), n * m = m * n
  | n, 0      => (Nat.zero_mul n).symm ▸ (Nat.mul_zero n).symm ▸ rfl
  | n, succ m => (mul_succ n m).symm ▸ (succ_mul m n).symm ▸ (Nat.mul_comm n m).symm ▸ rfl

@[simp] protected theorem mul_one : ∀ (n : Nat), n * 1 = n :=
  Nat.zero_add

@[simp] protected theorem one_mul (n : Nat) : 1 * n = n :=
  Nat.mul_comm n 1 ▸ Nat.mul_one n

protected theorem left_distrib (n m k : Nat) : n * (m + k) = n * m + n * k := by
  induction n generalizing m k with
  | zero      => repeat rw [Nat.zero_mul]
  | succ n ih => simp [succ_mul, ih]; rw [Nat.add_assoc, Nat.add_assoc (n*m)]; apply congrArg; apply Nat.add_left_comm

protected theorem right_distrib (n m k : Nat) : (n + m) * k = n * k + m * k :=
  have h₁ : (n + m) * k = k * (n + m)     := Nat.mul_comm ..
  have h₂ : k * (n + m) = k * n + k * m   := Nat.left_distrib ..
  have h₃ : k * n + k * m = n * k + k * m := Nat.mul_comm n k ▸ rfl
  have h₄ : n * k + k * m = n * k + m * k := Nat.mul_comm m k ▸ rfl
  ((h₁.trans h₂).trans h₃).trans h₄

protected theorem mul_add (n m k : Nat) : n * (m + k) = n * m + n * k :=
  Nat.left_distrib n m k

protected theorem add_mul (n m k : Nat) : (n + m) * k = n * k + m * k :=
  Nat.right_distrib n m k

protected theorem mul_assoc : ∀ (n m k : Nat), (n * m) * k = n * (m * k)
  | n, m, 0      => rfl
  | n, m, succ k =>
    have h₁ : n * m * succ k = n * m * (k + 1)              := rfl
    have h₂ : n * m * (k + 1) = (n * m * k) + n * m * 1     := Nat.left_distrib ..
    have h₃ : (n * m * k) + n * m * 1 = (n * m * k) + n * m := by rw [Nat.mul_one (n*m)]
    have h₄ : (n * m * k) + n * m = (n * (m * k)) + n * m   := by rw [Nat.mul_assoc n m k]
    have h₅ : (n * (m * k)) + n * m = n * (m * k + m)       := (Nat.left_distrib n (m*k) m).symm
    have h₆ : n * (m * k + m) = n * (m * succ k)            := Nat.mul_succ m k ▸ rfl
    ((((h₁.trans h₂).trans h₃).trans h₄).trans h₅).trans h₆

protected theorem mul_left_comm (n m k : Nat) : n * (m * k) = m * (n * k) := by
  rw [← Nat.mul_assoc, Nat.mul_comm n m, Nat.mul_assoc]

/- Inequalities -/

theorem succ_lt_succ {n m : Nat} : n < m → succ n < succ m :=
  succ_le_succ

theorem lt_succ_of_le {n m : Nat} : n ≤ m → n < succ m :=
  succ_le_succ

@[simp] protected theorem sub_zero (n : Nat) : n - 0 = n :=
  rfl

theorem succ_sub_succ_eq_sub (n m : Nat) : succ n - succ m = n - m := by
  induction m with
  | zero      => exact rfl
  | succ m ih => apply congrArg pred ih

theorem pred_le : ∀ (n : Nat), pred n ≤ n
  | zero   => Nat.le.refl
  | succ n => le_succ _

theorem pred_lt : ∀ {n : Nat}, n ≠ 0 → pred n < n
  | zero,   h => absurd rfl h
  | succ n, h => lt_succ_of_le (Nat.le_refl _)

theorem sub_le (n m : Nat) : n - m ≤ n := by
  induction m with
  | zero      => exact Nat.le_refl (n - 0)
  | succ m ih => apply Nat.le_trans (pred_le (n - m)) ih

theorem sub_lt : ∀ {n m : Nat}, 0 < n → 0 < m → n - m < n
  | 0,   m,   h1, h2 => absurd h1 (Nat.lt_irrefl 0)
  | n+1, 0,   h1, h2 => absurd h2 (Nat.lt_irrefl 0)
  | n+1, m+1, h1, h2 =>
    Eq.symm (succ_sub_succ_eq_sub n m) ▸
      show n - m < succ n from
      lt_succ_of_le (sub_le n m)

theorem sub_succ (n m : Nat) : n - succ m = pred (n - m) :=
  rfl

theorem succ_sub_succ (n m : Nat) : succ n - succ m = n - m :=
  succ_sub_succ_eq_sub n m

protected theorem sub_self : ∀ (n : Nat), n - n = 0
  | 0        => by rw [Nat.sub_zero]
  | (succ n) => by rw [succ_sub_succ, Nat.sub_self n]

protected theorem lt_of_lt_of_le {n m k : Nat} : n < m → m ≤ k → n < k :=
  Nat.le_trans

protected theorem lt_of_lt_of_eq {n m k : Nat} : n < m → m = k → n < k :=
  fun h₁ h₂ => h₂ ▸ h₁

instance : Trans (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_trans

instance : Trans (. ≤ . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) where
  trans := Nat.le_trans

instance : Trans (. < . : Nat → Nat → Prop) (. ≤ . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_of_lt_of_le

instance : Trans (. ≤ . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) (. < . : Nat → Nat → Prop) where
  trans := Nat.lt_of_le_of_lt

protected theorem le_of_eq {n m : Nat} (p : n = m) : n ≤ m :=
  p ▸ Nat.le_refl n

theorem le_of_succ_le {n m : Nat} (h : succ n ≤ m) : n ≤ m :=
  Nat.le_trans (le_succ n) h

protected theorem le_of_lt {n m : Nat} (h : n < m) : n ≤ m :=
  le_of_succ_le h

def lt.step {n m : Nat} : n < m → n < succ m := le_step

theorem eq_zero_or_pos : ∀ (n : Nat), n = 0 ∨ n > 0
  | 0   => Or.inl rfl
  | n+1 => Or.inr (succ_pos _)

def lt.base (n : Nat) : n < succ n := Nat.le_refl (succ n)

theorem lt_succ_self (n : Nat) : n < succ n := lt.base n

protected theorem le_total (m n : Nat) : m ≤ n ∨ n ≤ m :=
  match Nat.lt_or_ge m n with
  | Or.inl h => Or.inl (Nat.le_of_lt h)
  | Or.inr h => Or.inr h

protected theorem lt_of_le_and_ne {m n : Nat} (h₁ : m ≤ n) (h₂ : m ≠ n) : m < n :=
  match Nat.eq_or_lt_of_le h₁ with
  | Or.inl h => absurd h h₂
  | Or.inr h => h

theorem eq_zero_of_le_zero {n : Nat} (h : n ≤ 0) : n = 0 :=
  Nat.le_antisymm h (zero_le _)

theorem lt_of_succ_lt {n m : Nat} : succ n < m → n < m :=
  le_of_succ_le

theorem lt_of_succ_lt_succ {n m : Nat} : succ n < succ m → n < m :=
  le_of_succ_le_succ

theorem lt_of_succ_le {n m : Nat} (h : succ n ≤ m) : n < m :=
  h

theorem succ_le_of_lt {n m : Nat} (h : n < m) : succ n ≤ m :=
  h

theorem lt_or_eq_or_le_succ {m n : Nat} (h : m ≤ succ n) : m ≤ n ∨ m = succ n :=
  Decidable.byCases
    (fun (h' : m = succ n) => Or.inr h')
    (fun (h' : m ≠ succ n) =>
       have : m < succ n := Nat.lt_of_le_and_ne h h'
       have : succ m ≤ succ n := succ_le_of_lt this
       Or.inl (le_of_succ_le_succ this))

theorem le_add_right : ∀ (n k : Nat), n ≤ n + k
  | n, 0   => Nat.le_refl n
  | n, k+1 => le_succ_of_le (le_add_right n k)

theorem le_add_left (n m : Nat): n ≤ m + n :=
  Nat.add_comm n m ▸ le_add_right n m

theorem le.dest : ∀ {n m : Nat}, n ≤ m → Exists (fun k => n + k = m)
  | zero,   zero,   h => ⟨0, rfl⟩
  | zero,   succ n, h => ⟨succ n, Nat.add_comm 0 (succ n) ▸ rfl⟩
  | succ n, zero,   h => absurd h (not_succ_le_zero _)
  | succ n, succ m, h =>
    have : n ≤ m := Nat.le_of_succ_le_succ h
    have : Exists (fun k => n + k = m) := dest this
    match this with
    | ⟨k, h⟩ => ⟨k, show succ n + k = succ m from ((succ_add n k).symm ▸ h ▸ rfl)⟩

theorem le.intro {n m k : Nat} (h : n + k = m) : n ≤ m :=
  h ▸ le_add_right n k

protected theorem not_le_of_gt {n m : Nat} (h : n > m) : ¬ n ≤ m := fun h₁ =>
  match Nat.lt_or_ge n m with
  | Or.inl h₂ => absurd (Nat.lt_trans h h₂) (Nat.lt_irrefl _)
  | Or.inr h₂ =>
    have Heq : n = m := Nat.le_antisymm h₁ h₂
    absurd (@Eq.subst _ _ _ _ Heq h) (Nat.lt_irrefl m)

theorem gt_of_not_le {n m : Nat} (h : ¬ n ≤ m) : n > m :=
  match Nat.lt_or_ge m n with
  | Or.inl h₁ => h₁
  | Or.inr h₁ => absurd h₁ h

protected theorem add_le_add_left {n m : Nat} (h : n ≤ m) (k : Nat) : k + n ≤ k + m :=
  match le.dest h with
  | ⟨w, hw⟩ =>
    have h₁ : k + n + w = k + (n + w) := Nat.add_assoc ..
    have h₂ : k + (n + w) = k + m     := congrArg _ hw
    le.intro <| h₁.trans h₂

protected theorem add_le_add_right {n m : Nat} (h : n ≤ m) (k : Nat) : n + k ≤ m + k := by
  rw [Nat.add_comm n k, Nat.add_comm m k]
  apply Nat.add_le_add_left
  assumption

protected theorem add_lt_add_left {n m : Nat} (h : n < m) (k : Nat) : k + n < k + m :=
  lt_of_succ_le (add_succ k n ▸ Nat.add_le_add_left (succ_le_of_lt h) k)

protected theorem add_lt_add_right {n m : Nat} (h : n < m) (k : Nat) : n + k < m + k :=
  Nat.add_comm k m ▸ Nat.add_comm k n ▸ Nat.add_lt_add_left h k

protected theorem zero_lt_one : 0 < (1:Nat) :=
  zero_lt_succ 0

theorem add_le_add {a b c d : Nat} (h₁ : a ≤ b) (h₂ : c ≤ d) : a + c ≤ b + d :=
  Nat.le_trans (Nat.add_le_add_right h₁ c) (Nat.add_le_add_left h₂ b)

theorem add_lt_add {a b c d : Nat} (h₁ : a < b) (h₂ : c < d) : a + c < b + d :=
  Nat.lt_trans (Nat.add_lt_add_right h₁ c) (Nat.add_lt_add_left h₂ b)

/- Basic theorems for comparing numerals -/

theorem ctor_eq_zero : Nat.zero = 0 :=
  rfl

protected theorem one_ne_zero : 1 ≠ (0 : Nat) :=
  fun h => Nat.noConfusion h

protected theorem zero_ne_one : 0 ≠ (1 : Nat) :=
  fun h => Nat.noConfusion h

theorem succ_ne_zero (n : Nat) : succ n ≠ 0 :=
  fun h => Nat.noConfusion h

/- mul + order -/

theorem mul_le_mul_left {n m : Nat} (k : Nat) (h : n ≤ m) : k * n ≤ k * m :=
  match le.dest h with
  | ⟨l, hl⟩ =>
    have : k * n + k * l = k * m := Nat.left_distrib k n l ▸ hl.symm ▸ rfl
    le.intro this

theorem mul_le_mul_right {n m : Nat} (k : Nat) (h : n ≤ m) : n * k ≤ m * k :=
  Nat.mul_comm k m ▸ Nat.mul_comm k n ▸ mul_le_mul_left k h

protected theorem mul_le_mul {n₁ m₁ n₂ m₂ : Nat} (h₁ : n₁ ≤ n₂) (h₂ : m₁ ≤ m₂) : n₁ * m₁ ≤ n₂ * m₂ :=
  Nat.le_trans (mul_le_mul_right _ h₁) (mul_le_mul_left _ h₂)

protected theorem mul_lt_mul_of_pos_left {n m k : Nat} (h : n < m) (hk : k > 0) : k * n < k * m :=
  Nat.lt_of_lt_of_le (Nat.add_lt_add_left hk _) (Nat.mul_succ k n ▸ Nat.mul_le_mul_left k (succ_le_of_lt h))

protected theorem mul_lt_mul_of_pos_right {n m k : Nat} (h : n < m) (hk : k > 0) : n * k < m * k :=
  Nat.mul_comm k m ▸ Nat.mul_comm k n ▸ Nat.mul_lt_mul_of_pos_left h hk

protected theorem mul_pos {n m : Nat} (ha : n > 0) (hb : m > 0) : n * m > 0 :=
  have h : 0 * m < n * m := Nat.mul_lt_mul_of_pos_right ha hb
  Nat.zero_mul m ▸ h

/- power -/

theorem pow_succ (n m : Nat) : n^(succ m) = n^m * n :=
  rfl

theorem pow_zero (n : Nat) : n^0 = 1 := rfl

theorem pow_le_pow_of_le_left {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i
  | 0      => Nat.le_refl _
  | succ i => Nat.mul_le_mul (pow_le_pow_of_le_left h i) h

theorem pow_le_pow_of_le_right {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j
  | 0,      h =>
    have : i = 0 := eq_zero_of_le_zero h
    this.symm ▸ Nat.le_refl _
  | succ j, h =>
    match lt_or_eq_or_le_succ h with
    | Or.inl h => show n^i ≤ n^j * n from
      have : n^i * 1 ≤ n^j * n := Nat.mul_le_mul (pow_le_pow_of_le_right hx h) hx
      Nat.mul_one (n^i) ▸ this
    | Or.inr h =>
      h.symm ▸ Nat.le_refl _

theorem pos_pow_of_pos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m :=
  pow_le_pow_of_le_right h (Nat.zero_le _)

/- min/max -/

protected def min (n m : Nat) : Nat :=
  if n ≤ m then n else m

protected def max (n m : Nat) : Nat :=
  if n ≤ m then m else n

end Nat

namespace Prod

@[inline] def foldI {α : Type u} (f : Nat → α → α) (i : Nat × Nat) (a : α) : α :=
  Nat.foldAux f i.2 (i.2 - i.1) a

@[inline] def anyI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
  Nat.anyAux f i.2 (i.2 - i.1)

@[inline] def allI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
  Nat.anyAux (fun a => !f a) i.2 (i.2 - i.1)

end Prod


import .incidenceplane

noncomputable theory
open_locale classical
open set function

open IncidencePlane

class NeutralPlane (Point : Type*) extends IncidencePlane Point :=
	-- Ruler postulate, divided into 3 statements
	(ruler (ℓ : Line) : Point → ℝ)
	(ruler_dist (P Q : Point) : distance P Q = abs (ruler (line_through P Q) P - ruler (line_through P Q) Q))
	(ruler_bij (ℓ : Line) : set.bij_on (ruler ℓ) (ℓ : set Point) univ)

	-- Plane separation postulate
	(half_planes (ℓ : Line) : set Point × set Point)
	(half_planes_def_1 (ℓ : Line) (Q : Point) : (half_planes ℓ).1 = half_plane ℓ Q ↔ Q ∈ (half_planes ℓ).1)
	(half_planes_def_2 (ℓ : Line) (Q : Point) : (half_planes ℓ).2 = half_plane ℓ Q ↔ Q ∈ (half_planes ℓ).2)
	(convex_half_plane (ℓ : Line) : is_convex (half_planes ℓ).1 ∧ is_convex (half_planes ℓ).2)
	(partition (ℓ : Line) : (half_planes ℓ).1 ∪ (half_planes ℓ).2 ∪ ℓ = univ)
	(disjoint (ℓ : Line): (half_planes ℓ).1 ∩ (half_planes ℓ).2 = ∅)
	(disjoint' (ℓ : Line) : (half_planes ℓ).1 ∩ ℓ = ∅ ∧ (half_planes ℓ).2 ∩ ℓ = ∅)
	(plane_separation (ℓ : Line) (P Q : Point) : P ∈ (half_planes ℓ).1 → Q ∈ (half_planes ℓ).2 →
	pts(P⬝Q) ∩ ℓ ≠ ∅)

	(angle_measure : Angle Point → ℝ) -- angle measure

  -- Protractor postulate
	(angle_nonneg (α : Angle Point) : 0 ≤ angle_measure α)
	(angle_bounded (α : Angle Point) : angle_measure α < 180)
	(angle_well_def (α β: Angle Point) : α ≈ β → angle_measure α = angle_measure β)
	(angle_nondegenerate (α : Angle Point) : α.O => α.A ≈ α.O => α.B ↔ angle_measure α = 0)

	-- Angle construction
	(angle_construction {t : ℝ} (h₀ : 0 < t) (h : t < 180) (r : Ray Point) {E : Point}
	(hE : E ∉ (r.line))	: Point)
	(angle_construction_def' {t : ℝ} (h₀ : 0 < t) (h : t < 180) (r : Ray Point) {E : Point}
	(hE : E ∉ (r.line)) : angle_construction h₀ h r hE ∈ half_plane (r.line) E)
	(angle_construction_def {t : ℝ} (h₀ : 0 < t) (h : t < 180) (r : Ray Point) {E : Point}
	(hE : E ∉ (r.line)) : angle_measure (∟ r.target r.origin (angle_construction h₀ h r hE)) = t)
	(angle_construction_unique {t : ℝ} (h₀ : 0 < t) (h : t < 180) (r : Ray Point) {E : Point}
	(hE : E ∉ (r.line))	(B : Point) (hB : B ∈ half_plane (r.line) E):
	angle_measure (∟ r.target r.origin B) = t → r.origin => B ≈ r.origin => angle_construction h₀ h r hE)

	-- Angle addition
	(angle_addition (A B C D : Point) (h : Ray.between (A=>B) (A=>D) (A=>C)) :
	angle_measure (∟B A D) + angle_measure (∟ D A C) = angle_measure (∟ B A C) )

	-- SAS
	(SAS (S T : Triangle Point) (hAB : (S.A⬝S.B) ≅ (T.A⬝T.B)) (hBC : (S.B⬝S.C) ≅ (T.B⬝T.C))
	(hABC : angle_measure (∟ T.A T.B T.C) =  angle_measure (∟ S.A S.B S.C)) :
	(S.A⬝S.C) ≅ (T.A⬝T.C) ∧ angle_measure (∟ T.B T.C T.A) = angle_measure (∟ S.B S.C S.A)
	∧ angle_measure (∟ T.C T.A T.B) =  angle_measure (∟ S.C S.A S.B))

namespace IncidencePlane
variables {Ω : Type*} [NeutralPlane Ω]

namespace Angle

def m (α : Angle Ω) := NeutralPlane.angle_measure α
@[simp] def congruent (α β : Angle Ω) := α.m = β.m
infix `≅`:100 := congruent

def is_acute (α : Angle Ω) := α.m < 90
def is_obtuse (α : Angle Ω) := 90 < α.m
def is_right (α : Angle Ω) := α.m = 90

@[simp] def linear_pair (α β : Angle Ω) := α.O = β.O ∧ (α.O=>α.B) ≈ (α.O=>β.A) ∧ α.A * α.O * β.B
@[simp] def supplementary (α β : Angle Ω) := α.m + β.m = 180

end Angle

def perpendicular (r s : Line Ω) := ∃ A B C, A ∈ r ∧ A ∈ s ∧ B ∈ r ∧ C ∈ s ∧ (∟ B A C).is_right
infix `⊥`:100 := perpendicular

namespace Triangle

def angles (T : Triangle Ω) := [(∟ T.A T.B T.C).m, (∟ T.B T.C T.A).m, (∟ T.C T.A T.B).m]
@[simp] def congruent (T S : Triangle Ω) := T.sides = S.sides ∧ T.angles = S.angles
infix `≅`:100 := congruent
end Triangle

end IncidencePlane

namespace NeutralPlane
variables {Ω : Type*} [NeutralPlane Ω]

lemma ruler_inj {P Q : Ω} {ℓ : Line Ω} : P ∈ ℓ → Q ∈ ℓ → ruler ℓ P = ruler ℓ Q → P = Q :=
λ hP hQ H, (NeutralPlane.ruler_bij ℓ).inj_on hP hQ H

def ruler_inv (ℓ : Line Ω) : ℝ → Ω := inv_fun_on (ruler ℓ) (ℓ : set Ω)

lemma ruler_compat {ℓ : Line Ω} {P : Ω} (hP : P ∈ ℓ) : ruler_inv ℓ (ruler ℓ P) = P :=
(NeutralPlane.ruler_bij ℓ).inv_on_inv_fun_on.1 hP

lemma ruler_compat' (ℓ : Line Ω) (x : ℝ) : ruler ℓ (ruler_inv ℓ x) = x :=
(surj_on.inv_on_inv_fun_on (NeutralPlane.ruler_bij ℓ).2.2).2 (mem_univ x)

end NeutralPlane


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module data.finset.pi_induction
! leanprover-community/mathlib commit f93c11933efbc3c2f0299e47b8ff83e9b539cbf6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Lattice
import Mathlib.Data.Finset.Sigma

/-!
# Induction principles for `∀ i, Finset (α i)`

In this file we prove a few induction principles for functions `Π i : ι, Finset (α i)` defined on a
finite type.

* `Finset.induction_on_pi` is a generic lemma that requires only `[Finite ι]`, `[DecidableEq ι]`,
  and `[∀ i, DecidableEq (α i)]`; this version can be seen as a direct generalization of
  `Finset.induction_on`.

* `Finset.induction_on_pi_max` and `Finset.induction_on_pi_min`: generalizations of
  `Finset.induction_on_max`; these versions require `∀ i, LinearOrder (α i)` but assume
  `∀ y ∈ g i, y < x` and `∀ y ∈ g i, x < y` respectively in the induction step.

## Tags
finite set, finite type, induction, function
-/

open Function

variable {ι : Type _} {α : ι → Type _} [Finite ι] [DecidableEq ι] [∀ i, DecidableEq (α i)]

namespace Finset

/-- General theorem for `Finset.induction_on_pi`-style induction principles. -/
theorem induction_on_pi_of_choice (r : ∀ i, α i → Finset (α i) → Prop)
    (H_ex : ∀ (i) (s : Finset (α i)) (_ : s.Nonempty), ∃ x ∈ s, r i x (s.erase x))
    {p : (∀ i, Finset (α i)) → Prop} (f : ∀ i, Finset (α i)) (h0 : p fun _ ↦ ∅)
    (step :
      ∀ (g : ∀ i, Finset (α i)) (i : ι) (x : α i),
        r i x (g i) → p g → p (update g i (insert x (g i)))) :
    p f := by
  cases nonempty_fintype ι
  induction' hs : univ.sigma f using Finset.strongInductionOn with s ihs generalizing f; subst s
  cases' eq_empty_or_nonempty (univ.sigma f) with he hne
  · convert h0 using 1
    simpa [funext_iff] using he
  · rcases sigma_nonempty.1 hne with ⟨i, -, hi⟩
    rcases H_ex i (f i) hi with ⟨x, x_mem, hr⟩
    set g := update f i ((f i).erase x) with hg
-- Porting note: this tactic does not exist yet
--  clear_value g
    have hx' : x ∉ g i := by
      rw [hg, update_same]
      apply not_mem_erase
    rw [show f = update g i (insert x (g i)) by
      rw [hg, update_idem, update_same, insert_erase x_mem, update_eq_self]] at hr ihs ⊢
    clear hg
    rw [update_same, erase_insert hx'] at hr
    refine step _ _ _ hr (ihs (univ.sigma g) ?_ _ rfl)
    rw [ssubset_iff_of_subset (sigma_mono (Subset.refl _) _)]
    exacts [⟨⟨i, x⟩, mem_sigma.2 ⟨mem_univ _, by simp⟩, by simp [hx']⟩,
      (@le_update_iff _ _ _ _ g g i _).2 ⟨subset_insert _ _, fun _ _ ↦ le_rfl⟩]
#align finset.induction_on_pi_of_choice Finset.induction_on_pi_of_choice

/-- Given a predicate on functions `∀ i, Finset (α i)` defined on a finite type, it is true on all
maps provided that it is true on `fun _ ↦ ∅` and for any function `g : ∀ i, Finset (α i)`, an index
`i : ι`, and `x ∉ g i`, `p g` implies `p (update g i (insert x (g i)))`.

See also `Finset.induction_on_pi_max` and `Finset.induction_on_pi_min` for specialized versions
that require `∀ i, LinearOrder (α i)`.  -/
theorem induction_on_pi {p : (∀ i, Finset (α i)) → Prop} (f : ∀ i, Finset (α i)) (h0 : p fun _ ↦ ∅)
    (step :
      ∀ (g : ∀ i, Finset (α i)) (i : ι) (x : α i) (_ : x ∉ g i),
        p g → p (update g i (insert x (g i)))) :
    p f :=
  induction_on_pi_of_choice (fun _ x s ↦ x ∉ s) (fun _ s ⟨x, hx⟩ ↦ ⟨x, hx, not_mem_erase x s⟩) f
    h0 step
#align finset.induction_on_pi Finset.induction_on_pi

-- Porting note: this docstring is the exact translation of the one from mathlib3 but
-- the last sentence (here and in the next lemma) does make much sense to me...
/-- Given a predicate on functions `∀ i, Finset (α i)` defined on a finite type, it is true on all
maps provided that it is true on `fun _ ↦ ∅` and for any function `g : ∀ i, Finset (α i)`, an index
`i : ι`, and an element`x : α i` that is strictly greater than all elements of `g i`, `p g` implies
`p (update g i (insert x (g i)))`.

This lemma requires `LinearOrder` instances on all `α i`. See also `Finset.induction_on_pi` for a
version that `x ∉ g i` instead of ` does not need `∀ i, LinearOrder (α i)`. -/
theorem induction_on_pi_max [∀ i, LinearOrder (α i)] {p : (∀ i, Finset (α i)) → Prop}
    (f : ∀ i, Finset (α i)) (h0 : p fun _ ↦ ∅)
    (step :
      ∀ (g : ∀ i, Finset (α i)) (i : ι) (x : α i),
        (∀ y ∈ g i, y < x) → p g → p (update g i (insert x (g i)))) :
    p f :=
  induction_on_pi_of_choice (fun _ x s ↦ ∀ y ∈ s, y < x)
    (fun _ s hs ↦ ⟨s.max' hs, s.max'_mem hs, fun _ ↦ s.lt_max'_of_mem_erase_max' _⟩) f h0 step
#align finset.induction_on_pi_max Finset.induction_on_pi_max

/-- Given a predicate on functions `∀ i, Finset (α i)` defined on a finite type, it is true on all
maps provided that it is true on `fun _ ↦ ∅` and for any function `g : ∀ i, Finset (α i)`, an index
`i : ι`, and an element`x : α i` that is strictly less than all elements of `g i`, `p g` implies
`p (update g i (insert x (g i)))`.

This lemma requires `LinearOrder` instances on all `α i`. See also `Finset.induction_on_pi` for a
version that `x ∉ g i` instead of ` does not need `∀ i, LinearOrder (α i)`. -/
theorem induction_on_pi_min [∀ i, LinearOrder (α i)] {p : (∀ i, Finset (α i)) → Prop}
    (f : ∀ i, Finset (α i)) (h0 : p fun _ ↦ ∅)
    (step :
      ∀ (g : ∀ i, Finset (α i)) (i : ι) (x : α i),
        (∀ y ∈ g i, x < y) → p g → p (update g i (insert x (g i)))) :
    p f :=
  @induction_on_pi_max ι (fun i ↦ (α i)ᵒᵈ) _ _ _ _ _ _ h0 step
#align finset.induction_on_pi_min Finset.induction_on_pi_min

end Finset


import analysis.special_functions.integrals
import data.nat.basic
import data.real.basic
import data.list.intervals
import measure_theory.integral.interval_integral
import number_theory.von_mangoldt
import tactic

open finset measure_theory interval_integral nat.arithmetic_function
open_locale nat big_operators arithmetic_function

/-
Exercise 1.1.25
Author: Gareth
-/

lemma aux_div {m n : ℕ} (h : m ∣ n) (hn : n ≠ 0) (hm : 1 < m): n / m < n :=
begin
  cases h with k hk,
  have hk' : k ≠ 0,
  { by_contradiction, simp [h] at hk, exact hn hk, },
  have hm' : m ≠ 0,
  { by_contradiction, simp only [h, zero_mul] at hk, exact hn hk, },
  rw [hk, nat.mul_div_cancel_left k (zero_lt_iff.2 hm')],
  conv_lhs { rw ← one_mul k, },
  exact nat.mul_lt_mul_of_pos_right hm (zero_lt_iff.2 hk'),
end

/- Induction on prime powers -/
lemma exists_prime_power_factor {n : ℕ} (h : 2 ≤ n) :
  ∃ p k : ℕ, p.prime ∧ 0 < k ∧ p ^ k ∣ n ∧ ¬p ∣ (n / p ^ k) :=
begin
  have h₀ : n ≠ 0, by linarith,
  have h₁ : n ≠ 1, by linarith,
  use n.min_fac,
  use (n.factorization n.min_fac),
  exact ⟨nat.min_fac_prime h₁,
         nat.prime.factorization_pos_of_dvd (nat.min_fac_prime h₁) h₀ (nat.min_fac_dvd n),
         nat.ord_proj_dvd n _,
         nat.not_dvd_ord_compl (nat.min_fac_prime h₁) h₀⟩,
end

lemma induction_on_prime_powers {P : ℕ → Prop} (p₀ : P 0) (p₁ : P 1)
  (h : ∀ p k a : ℕ, p.prime → ¬p ∣ a → P a → P (p ^ k * a)) (n : ℕ) : P n :=
begin
  induction n using nat.strong_induction_on with n h',
  by_cases h₀ : n = 0, { simp only [h₀, p₀], },
  by_cases h₁ : n = 1, { simp only [h₁, p₁], },
  rcases exists_prime_power_factor (show 2 ≤ n, by omega) with ⟨p, ⟨k, hp, hk, hn, ha⟩⟩,
  specialize h p k (n / p ^ k) hp ha,
  rw [← nat.mul_div_assoc _ hn, nat.mul_div_cancel_left _ (pow_pos (nat.prime.pos hp) k)] at h,
  apply h,
  apply h',
  refine nat.div_lt_self (by omega) _,
  rw ← one_pow k, apply nat.pow_lt_pow_of_lt_left (nat.prime.one_lt hp) hk,
end

/- Auxillary bounds on polynomials and integrals -/
lemma aux_bound1 {x : ℝ} (h : 0 ≤ x) (h' : x ≤ 1) : 0 ≤ x * (1 - x) := mul_nonneg h (by linarith)

lemma aux_bound2 {x : ℝ} (h : 0 ≤ x) (h' : x ≤ 1) : x * (1 - x) ≤ 1 / 4 :=
begin
  calc  x * (1 - x)
      = -(x - 1 / 2) ^ 2 + (1 / 2) ^ 2 : by ring
  ... ≤ 1 / 4                          : by norm_num [sq_nonneg (x - 1 / 2)]
end

lemma aux_bound {x : ℝ} (h : 0 ≤ x) (h' : x ≤ 1) {n : ℕ} : x ^ n * (1 - x) ^ n ≤ 1 / 4 ^ n :=
begin
  rw [← one_pow n]  { occs := occurrences.pos [2] },
  rw [← div_pow, ← mul_pow],
  exact pow_le_pow_of_le_left (aux_bound1 h h') (aux_bound2 h h') n,
end

lemma aux_integral_bound {n : ℕ} : ∫ x : ℝ in 0..1, x ^ n * (1 - x) ^ n ≤ 1 / 4 ^ n :=
begin
  rw [show 1 / 4 ^ n = ∫ x : ℝ in 0..1, (1 : ℝ) / 4 ^ n, by simp],
  apply integral_mono_on zero_le_one _ _,
  { intros x hx, cases hx with h h', exact aux_bound h h', },
  apply continuous.interval_integrable,
  continuity,
  simp,
end

lemma multiset.map_ite {P : Prop} [decidable P] {f : ℕ → ℝ} {s s₁ s₂ : multiset ℕ} :
multiset.map f (ite P s₁ s₂) = ite P (multiset.map f s₁) (multiset.map f s₂) :=
by { by_cases P ; simp [h] }

lemma multiset.sum_add_sub_map {s : multiset ℕ} (f g : ℕ → ℝ) :
(multiset.map f s).sum = (multiset.map g s).sum + (multiset.map (f - g) s).sum :=
begin
  simp only [pi.sub_apply, multiset.sum_map_sub], ring,
end

lemma nat.Icc_succ_right {n : ℕ} : Icc 1 n.succ = has_insert.insert n.succ (Icc 1 n) :=
begin
  ext,
  simp_rw [mem_insert, mem_Icc],
  rw [show a ≤ n.succ = (a ≤ n ∨ a = n.succ), by rw nat.le_add_one_iff, and_or_distrib_left],
  have : (1 ≤ a ∧ a = n.succ) = (a = n.succ),
  { rw [eq_iff_iff],
    split,
    rintros ⟨h₁, h₂⟩, exact h₂,
    intro h₁,
    simp only [h₁, nat.succ_eq_add_one, le_add_iff_nonneg_left, zero_le',
               eq_self_iff_true, and_self], },
  rw [this, or_comm],
end

lemma nat.succ_not_mem_Icc (m n : ℕ) : n.succ ∉ Icc m n := by { rw [mem_Icc, not_and, not_le], intro h, exact nat.lt_succ_self n }

lemma nat.pow_max {b m n: ℕ} (hb : 0 < b) : b ^ max m n = max (b ^ m) (b ^ n) :=
begin
  by_cases h : m ≤ n,
  { rw [max_eq_right h, max_eq_right (nat.pow_le_pow_of_le_right hb h)], },
  { push_neg at h,
    rw [max_eq_left_of_lt h,
        max_eq_left (nat.pow_le_pow_of_le_right hb (show n ≤ m, by linarith [h]))], },
end

-- lower bound: `nat.lt_pow_succ_log_self`
lemma nat.pow_log_self_le_self {b n : ℕ} (h : 1 < b ∧ n ≠ 0) : b ^ (nat.log b n) ≤ n :=
and.left ((nat.log_eq_iff (show _, by { right, exact h })).1 $ refl _)

lemma nat.pow_log_power_sub_one {p k n : ℕ} (hp : nat.prime p) (hk : k ≠ 0) (hn : n.succ = p ^ k):
nat.log p n = k - 1 :=
begin
  rw nat.log_eq_iff,
  split,
  { apply nat.le_of_lt_succ,
    rw hn,
    apply nat.pow_right_strict_mono (nat.prime.two_le hp),
    exact nat.sub_lt (zero_lt_iff.2 hk) zero_lt_one, },
  { rw [nat.sub_add_cancel (nat.one_le_iff_ne_zero.2 hk), ← hn], exact nat.lt_succ_self n, },
  { right,
    refine ⟨nat.prime.two_le hp, _⟩,
    rw [← nat.succ_ne_succ, hn],
    apply ne_of_gt,
    apply nat.one_lt_pow,
    exact zero_lt_iff.2 hk,
    exact nat.prime.two_le hp, }
end

-- TODO: Generalise these for non-primes
lemma nat.log_succ {p n : ℕ} (hp : nat.prime p) (hn : 0 < n) :
nat.log p n.succ = max (nat.log p n) (n.succ.factorization p) :=
begin
  rw nat.log_eq_iff,
  { split,
    { rw [nat.pow_max, max_le_iff],
      split,
      exact nat.pow_log_le_add_one _ _,
      exact nat.ord_proj_le _ (nat.succ_ne_zero _),
      exact nat.prime.pos hp, },
    { rw [pow_add, pow_one],
      by_cases h : nat.log p n < n.succ.factorization p,
      -- case 1, hard case
      { rw max_eq_right_of_lt h,
        rw [← pow_one p] { occs := occurrences.pos [3] },
        rw [← pow_add],
        -- lemmas
        let h' := nat.lt_pow_succ_log_self (nat.prime.two_le hp) n,
        replace h' := lt_of_lt_of_le h' ((nat.pow_le_iff_le_right $ nat.prime.two_le hp).2 h),
        let h'' := nat.ord_proj_le p (nat.succ_ne_zero n),
        have hn' : n.succ = p ^ (n.succ.factorization p),
        { apply eq.symm,
          by_contradiction hn,
          replace hn := lt_of_lt_of_le h' (nat.lt_succ_iff.1 (lt_iff_le_and_ne.2 ⟨h'', hn⟩)),
          linarith, },
        have hp': n.succ.factorization p ≠ 0,
        { by_contradiction, rw [← nat.succ_sub_one n, hn'] at hn, linarith, },
        -- not important lemma
        have h''' : n.succ ≤ n * p,
        { calc n.succ = n + 1 : by refl
                  ... ≤ n * 2 : by linarith
                  ... ≤ n * p : nat.mul_le_mul_of_nonneg_left (nat.prime.two_le hp) },
        -- important lemma 1
        have lemma1 : nat.log p n + 1 = n.succ.factorization p,
        { replace h := nat.succ_le_iff.2 h,
          rw nat.succ_eq_add_one at h,
          suffices : p ^ (nat.log p n + 1) = p ^ (n.succ.factorization p),
          { apply nat.pow_right_injective (nat.prime.two_le hp), simp only [this], },
          rw [← hn', nat.pow_log_power_sub_one hp hp' hn',
              nat.sub_add_cancel (nat.one_le_iff_ne_zero.2 hp'), ← hn'], },
        -- clean up
        rw [← lemma1, pow_add, pow_one],
        apply lt_of_le_of_lt h''',
        apply nat.mul_lt_mul_of_pos_right _ (nat.prime.pos hp),
        apply nat.lt_pow_succ_log_self (nat.prime.two_le hp) n, },
      -- case 2, easy case
      { push_neg at h,
        rw max_eq_left h,
        rw [← pow_one p] { occs := occurrences.pos [3] },
        rw [← pow_add],
        let h' := nat.lt_pow_succ_log_self (nat.prime.two_le hp) n,
        rw [← nat.succ_le_iff, le_iff_lt_or_eq] at h',
        cases h',
        { exact h' },
        -- somehow i broke this
        { sorry }, } }, },
  { right, exact ⟨nat.prime.two_le hp, nat.succ_ne_zero n⟩, }
end

lemma nat.log_succ_ne_log_self {p n : ℕ} (hp : nat.prime p) (hn : 0 < n) :
nat.log p n.succ ≠ nat.log p n ↔ n.succ = p ^ (n.succ.factorization p) :=
begin
  split,
  { rw nat.log_succ hp hn,
    intro h,
    simp only [ne.def, max_eq_left_iff, not_le, nat.lt_iff_add_one_le] at h,
    let h₁ := nat.pow_le_pow_of_le_right (nat.prime.pos hp) h,
    let h₃ := nat.ord_proj_le p (nat.succ_ne_zero n),
    let h₄ := nat.lt_iff_add_one_le.1 (nat.lt_pow_succ_log_self (nat.prime.two_le hp) n),
    let h₅ := le_trans h₄ h₁,
    exact omega.nat.le_and_le_iff_eq.1 ⟨h₅, h₃⟩, },
  { intro h,
    by_contradiction h',
    rw [h, nat.log_pow (nat.prime.two_le hp)] at h',
    let h'' := nat.pow_log_le_self p (ne_of_gt hn),
    rw [← h', ← h] at h'',
    exact (nat.not_succ_le_self n) h'', }
end

lemma nat.lcm_Icc_ne_zero {n : ℕ} : (Icc 1 n).lcm id ≠ 0 :=
begin
  induction n with k hk,
  { rw Icc_eq_empty, simp only [lcm_empty], exact one_ne_zero, linarith, },
  { simp only [hk, id.def, nat.Icc_succ_right, lcm_insert, ne.def, _root_.lcm_eq_zero_iff,
               nat.succ_ne_zero, or_self, not_false_iff], }
end

lemma nat.prime_dvd_lcm_Icc {p n : ℕ} (hp : nat.prime p) (hn : 0 < n) :
p ∣ (Icc 1 n).lcm id ↔ p ≤ n :=
begin
  rw [nat.prime.dvd_iff_one_le_factorization hp nat.lcm_Icc_ne_zero,
      nat.factorization_lcm_Icc_prime hp hn,
      ← nat.pow_le_iff_le_log (nat.prime.two_le hp) (ne_of_gt hn), pow_one],
end

lemma nat.lcm_Icc_factorization_support_eq_primes_le {n : ℕ} (hn : 0 < n) :
((Icc 1 n).lcm id).factorization.support = (filter nat.prime (Icc 1 n)) :=
begin
  ext,
  rw [nat.factor_iff_mem_factorization, nat.mem_factors nat.lcm_Icc_ne_zero, mem_filter],
  split ; rintros ⟨ha, ha'⟩,
  { simp only [mem_Icc],
    exact ⟨⟨by linarith [nat.prime.two_le ha], (nat.prime_dvd_lcm_Icc ha hn).1 ha'⟩, ha⟩, },
  { exact ⟨ha', (nat.prime_dvd_lcm_Icc ha' hn).2 (mem_Icc.1 ha).2⟩, },
end

lemma nat.factorization_lcm_Icc_prime {p n : ℕ} (hp : nat.prime p) (hn : 0 < n) :
nat.factorization ((Icc 1 n).lcm id) p = nat.log p n :=
begin
  let P := λ n, nat.factorization ((Icc 1 n).lcm id) p = nat.log p n,
  have hP₁ : P 1,
  { norm_num [P, Icc_self 1, lcm_singleton], },
  apply nat.le_induction hP₁ _ n,
  { apply hn, },
  { dsimp [P],
    intros n hn hP,
    rw nat.Icc_succ_right,
    simp only [nat.succ_eq_add_one, add_assoc, one_add_one_eq_two] at *,
    rw [lcm_insert, id.def, lcm_eq_nat_lcm, nat.factorization_lcm (nat.succ_ne_zero n)
        nat.lcm_Icc_ne_zero, finsupp.sup_apply, hP, sup_eq_max, nat.log_succ hp hn, max_comm], },
end

lemma nat.factorization_lcm_Icc_sum {n : ℕ} {f : ℕ → ℕ → ℝ} (hn : 0 < n):
(nat.factorization ((Icc 1 n).lcm id)).sum f
  = (filter nat.prime (Icc 1 n)).sum (λ p, f p (nat.log p n)) :=
begin
  rwa [finsupp.sum, nat.lcm_Icc_factorization_support_eq_primes_le hn, finset.sum_congr],
  refl,
  intros a ha,
  rw mem_filter at ha,
  congr,
  exact nat.factorization_lcm_Icc_prime ha.right hn,
end

-- Thank you Eric Wieser for helping!
lemma aux_prime_pow_partition {n : ℕ} : (Icc 1 n).filter is_prime_pow =
((Icc 1 n).filter nat.prime).bUnion (λ p, (Icc 1 (nat.log p n)).image (λ k, p ^ k)) :=
begin
  ext,
  simp only [mem_filter],
  split,
  { rintros ⟨ha, h⟩,
    rcases h with ⟨p, ⟨k, ⟨hp, hk, hpk⟩⟩⟩,
    replace hp := prime.nat_prime hp,
    rw [← hpk, mem_bUnion],
    use p,
    split,
    { simp only [mem_filter, mem_Icc, hp, and_true, nat.add_one_le_iff, nat.prime.pos hp, true_and],
      apply le_trans _ (mem_Icc.1 ha).right,
      simp only [← hpk, nat.le_self_pow (ne_of_gt hk) p], },
    rw mem_image,
    use k,
    simp only [and_true, eq_self_iff_true, mem_Icc, nat.add_one_le_iff, hk, true_and],
    apply nat.le_log_of_pow_le (nat.prime.two_le hp),
    rw hpk,
    exact (mem_Icc.1 ha).right, },
  { intros h,
    simp only [mem_bUnion, mem_filter, mem_image, mem_Icc] at h,
    rcases h with ⟨p, ⟨⟨hp₁, hp₂⟩, hp⟩, ⟨k, ⟨hk₁, hk₂⟩, hk⟩⟩,
    simp only [mem_Icc, is_prime_pow, prime.nat_prime],
    split,
    rw ← hk,
    split,
    exact pow_pos (nat.prime.pos hp) k,
    exact nat.pow_le_of_le_log (show n ≠ 0, by linarith [hp₂, nat.prime.pos hp]) hk₂,
    use [p, k],
    exact ⟨nat.prime_iff.1 hp, hk₁, hk⟩, }
end

lemma aux_log_lcm_eq_sum_von {n : ℕ} (hn : 0 < n) :
real.log ↑((Icc 1 n).lcm id) = (Icc 1 n).sum Λ :=
begin
  -- framework by Eric
  rw [real.log_nat_eq_sum_factorization, nat.factorization_lcm_Icc_sum hn],
  dsimp [von_mangoldt],
  simp_rw [← sum_filter, ← real.log_pow, ← nat.cast_pow],
  rw [← real.log_prod _ _ (λ i hi, _), ← real.log_prod _ _ (λ i hi, _)],
  { congr' 1,
    simp_rw [← nat.cast_prod, nat.cast_inj],
    rw [aux_prime_pow_partition, prod_bUnion],
    { rw prod_congr ((true_implies_iff _).1 (eq_self_iff_true _).2),
      intros p hp,
      rw [mem_filter, mem_Icc] at hp,
      rw prod_image,
      { transitivity (∏ x in Icc 1 (nat.log p n), p),
        { rw [prod_const, nat.card_Icc, nat.add_sub_cancel], },
        { apply prod_congr ((true_implies_iff _).1 (eq_self_iff_true _).2),
          intros x hx,
          rw nat.prime.pow_min_fac hp.right (ne_of_gt (mem_Icc.1 hx).1), }, },
      { intros x hx y hy h,
        exact nat.pow_right_injective (nat.prime.two_le hp.2) h, }, },
    { intros i hi j hj hij,
      simp_rw [mem_coe, mem_filter] at hi hj,
      rw [function.on_fun, disjoint_left],
      -- prove the families are disjoint
      intro a,
      simp only [mem_image],
      push_neg,
      rintros ⟨k₁, hk₁, hk₁'⟩,
      intros k₂ hk₂,
      rw ← hk₁',
      by_contradiction,
      have : nat.factorization (j ^ k₂) i = nat.factorization (i ^ k₁) i,
      { rw h, },
      simp only [nat.prime.factorization_pow, hi.2, hj.2, finsupp.single_eq_same,
                 finsupp.single_eq_of_ne (hij.symm)] at this,
      linarith [this, (mem_Icc.1 hk₁).1], }, },
  { norm_cast,
    exact (nat.min_fac_pos _).ne' },
  { norm_cast,
    -- easy :)
    rw [mem_filter, mem_Icc] at hi,
    rw pow_eq_zero_iff,
    linarith [hi.1.1],
    apply nat.log_pos (nat.prime.two_le hi.2) hi.1.2, },
end

lemma eval_integral_thing_idk {N : ℕ} {a : ℕ → ℝ} :
∫ x : ℝ in 0..1, ∑ n in range N, (a n) * x ^ n = ∑ n in range N, a n / ↑(n + 1) :=
begin
  rw interval_integral.integral_finset_sum,
  -- swap signs since it's finite sum
  simp_rw [integral_const_mul, nat.cast_add, algebra_map.coe_one, integral_pow],
  norm_num [mul_div],
  -- prove integrable
  { intros k hk,
    simp only [interval_integral.interval_integrable.const_mul, interval_integrable_pow], },
end

lemma aux_exp_mul_int {n : ℕ} :
∃ N : ℤ, ↑N = ↑((Icc 1 (2 * n + 1)).lcm id) * (∫ x : ℝ in 0..1, x ^ n * (1 - x) ^ n) :=
begin
  -- plan: directly evaluate the integral
  simp_rw [show ∀ x : ℝ, 1 - x = 1 + (-x), by { intro x, ring }, add_pow, mul_sum],
  rw interval_integral.integral_finset_sum,
  { -- evaluating the integral
    -- simp only [neg_pow, one_pow] { single_pass := tt },
    -- simp_rw [← mul_assoc, mul_comm, integral_const_mul],
    -- simp only [one_pow, one_mul, ← mul_assoc, ← pow_add],
    -- simp_rw [mul_comm _ ((-(1 : ℝ)) ^ _), integral_const_mul, ← mul_assoc, integral_pow],
    -- norm_num [mul_div],
    suffices : ∃ (N : ℤ), (N : ℝ) = ↑((Icc 1 (n * 2 + 1)).lcm id) * ∑ (x : ℕ) in range (n + 1), (n.choose x) * (-1) ^ (n - x) / (↑(n - x) + ↑n + 1),
    sorry,
    rw mul_comm,
    rw sum_mul,
    conv in (finset.sum _ _) {
      apply_congr,
      skip,
      rw nat.cast_sub (mem_range_succ_iff.1 H),
      rw div_mul_comm,
    },
    -- abstract fraction part into single coefficient
    let f : ℕ → ℤ := λ x, (Icc 1 (n * 2 + 1)).lcm (coe : ℕ → ℤ) / (↑n - x + ↑n + 1),
    have : ∀ x ∈ range (n + 1), ((f x) : ℝ) = ↑((Icc 1 (n * 2 + 1)).lcm id) / (↑n - ↑x + ↑n + 1),
    { intros x hx, simp [f], rw int.cast_div _ _, simp, },
    conv in (_ / _) {

    }
  },
end

#eval (int.lcm 4 6)
#eval (int.lcm 4 (-6))
#eval (int.lcm (-4) 6)
#eval (int.lcm (-4) (-6))

example {n : ℕ} {a : ℕ → ℤ} :
∃ (N : ℤ), (N : ℝ) = ∑ (x : ℕ) in range (n + 1), ↑(n.choose x) * (-1) ^ (n - x) * (a n : ℝ) :=
begin
  simp_rw [show (-1 : ℝ) = ↑(-1 : ℤ), by rw [int.cast_neg, algebra_map.coe_one], ← int.cast_pow],
  conv in (↑(nat.choose _ _)) { rw [← int.cast_coe_nat], },
  simp only [← int.cast_mul, ← int.cast_sum, exists_apply_eq_apply],
end

lemma asdf (i j : ℕ) : ↑(nat.lcm i j) = gcd_monoid.lcm i j := rfl

example {f : ℕ → ℕ} {n : ℕ} : (range (n + 1)).sum f = (range n).sum f + f n :=
begin
  simp,
end

-- lemma aux_lemma3 {n : ℕ} :


-- TODO: Rewrite things using paritions / setoids?
--       The relation would then be "are the same color".
--       see `data.setoid.partition`.
import topology.metric_space.basic
import data.fintype.basic
import data.real.basic
import mod_two
import analysis.normed_space.inner_product
import data.setoid.partition
import data.int.sqrt

universe u

/-- Whether a space can be colored using n colors while avoiding monochrome
    pairs with distances in `D`. -/
def space_colorable
(X : Type u) [has_dist X]
(D : finset ℝ)
(n : ℕ)
: Prop
:= ∃ (f : X → ℕ), (∀ a, f a < n) ∧ ∀ a b, (dist a b) ∈ D → f a ≠ f b

-- In our application `r_in` is a more "fine-grained" equivalence relation than `r_out` but that
-- isn't needed for this theorem.
-- It is a little annoying to have to write out `r_in.rel` instead of `≈` but that is necessary when working with two setoids.
theorem separation
{X : Type u} [has_dist X]
(d : ℝ)
(r_in : setoid X)
(r_out : setoid X)
(h1 : ∀ (a b : X), r_in.rel a b → dist a b < d)
(h2 : ∀ (a b : X), (¬r_in.rel a b) → r_out.rel a b → dist a b > d)
(x y : X)
(h3 : r_out.rel x y)
: dist x y ≠ d
:= begin
  by_contradiction hhh,
  rw not_not at hhh,
  have eq_imp_not_less : dist x y = d → ¬(dist x y) < d := by { intros bb, linarith, },
  have := (h2 x y ((mt (h1 x y)) (eq_imp_not_less hhh))) h3,
  linarith,
end

def hex_open_f (r : ℝ) (x y : ℝ) : Prop := (real.sqrt 3)⁻¹ + y - r < 0
                                        ∧  (real.sqrt 3)⁻¹ - y - r < 0
                                        ∧ -(real.sqrt 3)⁻¹ + y - r < 0
                                        ∧ -(real.sqrt 3)⁻¹ - y - r < 0
                                        ∧  x - (real.sqrt 3)*2⁻¹*r < 0
                                        ∧ -x - (real.sqrt 3)*2⁻¹*r < 0

def hex_left_up_ioo     (r : ℝ) (x y : ℝ) : Prop := -(real.sqrt 3)*2⁻¹*r < x ∧ x < 0      ∧ y =  x * (real.sqrt 3)⁻¹ + r
def hex_left_side_icc   (r : ℝ) (x y : ℝ) : Prop := -(r / 2) <= y      ∧ y <= r / 2 ∧ x = -(r * (real.sqrt 3)⁻¹)
def hex_left_down_ioc   (r : ℝ) (x y : ℝ) : Prop := -(real.sqrt 3)*2⁻¹*r < x ∧ x <= 0     ∧ y = -(x * (real.sqrt 3)⁻¹ + r)

-- A `hex_tile` is the open hexagon together with the three sides on the left
def hex_tile (r : ℝ) : set (ℝ×ℝ) := set_of (λ p, hex_open_f        r p.1 p.2
                                               ∨ hex_left_up_ioo   r p.1 p.2
                                               ∨ hex_left_side_icc r p.1 p.2
                                               ∨ hex_left_down_ioc r p.1 p.2)

def shift (k : (ℝ×ℝ)) (s : set (ℝ×ℝ)) : set (ℝ×ℝ) := set_of (λ p, s (p - k))

-- theorem hex_inter_hex_shift_right_eq_empty
-- : set.inter (hex_tile 1) (shift (⟨real.sqrt 3, 0⟩) (hex_tile 1)) = ∅
-- := begin
--   by_contradiction,
--   let hhh : ∃(x : ℝ×ℝ), (x : hex_tile 1) ∧ (x : (shift (⟨real.sqrt 3, 0⟩) (hex_tile 1))) := begin

--   end,
-- end

theorem inv_eq_2
(a b : ℝ)
(h : b ≠ 0)
: (1 / a) = b / (b*a)
:= begin
  exact (div_mul_right a h).symm,
end

theorem inv_eq_3
(a b c: ℝ)
(h : c ≠ 0)
: a / b = (a*c) / (b*c)
:= begin
  exact (mul_div_mul_right a b h).symm,
end

theorem inv_eq_4
(a : ℝ)
(h : a > 0)
: real.sqrt a ≠ 0
:= begin
  exact real.sqrt_ne_zero'.mpr h,
end

theorem inv_eq_5
(a : ℝ)
(h : 0 ≤ a)
: (real.sqrt a) * (real.sqrt a) = a
:= begin
  exact real.mul_self_sqrt h,
end

theorem zero_le_three
: 0 ≤ (3 : ℝ)
:= begin
  linarith,
end

theorem sub_div_add_div_eq_thing
(a b c : ℝ)
: -(a/b) + (c/b) = (-a + c) / b
:= begin
  ring,
end

theorem div_lt_zero_imp_numerator_lt_zero
(a : ℝ)
{b : ℝ}
(h : b > 0)
: (a / b) < 0 -> a < 0
:= begin
  intro k,
  have ggg : b * (a/b) < b * 0 := (mul_lt_mul_left h).mpr k,
  rw [mul_zero b, (mul_div_cancel' a (ne_of_gt h))] at ggg,
  exact ggg,
end

theorem gfgfgdfgdsf
(a b: ℝ)
(h1 : a > 0)
(h2 : b > 0)
: a * real.sqrt b > 0
:= begin
  exact mul_pos h1 (real.sqrt_pos.mpr h2),
end

theorem sqrt_three_gt_zero
: real.sqrt 3 > 0
:= begin
  norm_num,
end

#check real.sqrt_one

theorem one_le_sqrt_three
: 1 ≤ real.sqrt 3
:= begin
  nth_rewrite 0 ←real.sqrt_one,
  refine real.sqrt_le_sqrt _,
  linarith,
end

theorem one_lt_sqrt_three
: 1 < real.sqrt 3
:= begin
  nth_rewrite 0 ←real.sqrt_one,
  refine (real.sqrt_lt zero_le_one).mpr _,
  linarith,
end

theorem sqrt_three_equat_pos
: real.sqrt 3 + (1 / real.sqrt 3) - real.sqrt 3 * (1 / 2) ≥ 0
:= begin
  calc real.sqrt 3 + (1 / real.sqrt 3) - real.sqrt 3 * (1 / 2)
      = real.sqrt 3 + (1 / real.sqrt 3) - (real.sqrt 3 / 2) : by rw mul_one_div (real.sqrt 3) 2
  ... = (real.sqrt 3) / 2 + (1 / real.sqrt 3) : by linarith
  ... ≥ 0 : by {
    refine add_nonneg _ _,
    exact div_nonneg (le_of_lt sqrt_three_gt_zero) zero_le_two,
    exact div_nonneg zero_le_one (le_of_lt sqrt_three_gt_zero),
  }
end

theorem sqrt_three_equat_neg
: -(1 / real.sqrt 3) + real.sqrt 3 * (1 / 2) - real.sqrt 3 < 0
:= begin
  calc -(1 / real.sqrt 3) + real.sqrt 3 * (1 / 2) - real.sqrt 3
      = -(1 / real.sqrt 3) + -(real.sqrt 3) / 2 : begin
        linarith,
      end
  ... < 0 : by {
    refine add_neg _ _,
    exact neg_neg_of_pos (div_pos zero_lt_one (gt.lt sqrt_three_gt_zero)),
    rw neg_div 2 (real.sqrt 3),
    exact neg_neg_of_pos (div_pos (gt.lt sqrt_three_gt_zero) zero_lt_two),
  }
end

theorem hfhfhf
(a b: ℝ)
: (-a) / b = - (a/b)
:= begin
  exact neg_div b a
end

theorem inv_leq_one
{a : ℝ}
(h2 : 1 ≤ a)
: (1 / a) ≤ 1
:= begin
  refine (div_le_one _).mpr h2,
  linarith,
end

theorem ge_one_imp_sub_inv_ge_zero
(x: ℝ)
(h : 1 ≤ x)
: x - (1/x) ≥ 0
:= begin
  have jdjdj : ∀ (x1 : ℝ), 1 ≤ x1 -> 1/x1 ≤ x1 := by {
    intros xxx leee,
    calc (1 / xxx)
        ≤ 1 : inv_leq_one leee
    ... ≤ xxx : leee
  },
  exact sub_nonneg.mpr (jdjdj x h),
end

/- Not actually used -/
theorem sub_lt_zero_iff
{X : Type*} [ordered_add_comm_group X]
{a b : X}
: a - b < 0 ↔ b - a > 0
:= begin
  refine (iff.intro _ _),
  intro h,
  have hue := neg_lt_neg h,
  rw [neg_zero, neg_sub a b] at hue,
  exact hue,

  intro h,
  have hue := neg_lt_neg h,
  rw [neg_zero, neg_sub b a] at hue,
  exact hue,
end

theorem ge_one_imp_sub_inv_gt_zero
(x: ℝ)
(h : 1 < x)
: x - (1/x) > 0
:= begin
  have jdjdj : ∀ (x1 : ℝ), 1 < x1 -> 1/x1 < x1 := by {
    intros xxx leee,
    calc (1 / xxx)
        = xxx⁻¹ : one_div xxx
    ... < 1 : inv_lt_one leee
    ... < xxx : leee
  },
  exact sub_pos.mpr (jdjdj x h),
end

theorem another_case
{x : ℝ}
(hh7: x = -(1 / real.sqrt 3))
(hh13: x - real.sqrt 3 = -(1 / real.sqrt 3))
: false
:= begin
  rw hh7 at hh13,
  have sqrt_three_eq_zero : real.sqrt 3 = 0 := by linarith,
  rw ←real.sqrt_zero at sqrt_three_eq_zero,
  have yepp : (3 : ℝ) = 0 := by {
    refine (real.sqrt_inj _ _).mp (sqrt_three_eq_zero),
    exact zero_le_three,
    exact rfl.ge,
  },
  linarith,
end

-- How can I avoid the annoying case analysis? I should probably use rcases.
theorem in_the_middle
(x : ℝ×ℝ)
(h : (x ∈ hex_tile 1))
(h2 : (x ∈ shift (⟨real.sqrt 3, 0⟩) (hex_tile 1)))
: false
:= begin
  rw [hex_tile] at h,
  simp at *,
  rw [shift] at h2,
  rw [hex_tile] at h2,
  simp at h2,
  rw set.set_of_app_iff at h2,
  unfold hex_open_f hex_left_up_ioo hex_left_side_icc hex_left_down_ioc at h,
  unfold hex_open_f hex_left_up_ioo hex_left_side_icc hex_left_down_ioc at h2,
  simp at h,
  simp at h2,
  set xx : ℝ := x.fst,
  set yy : ℝ := x.snd,
  cases h,
  cases h2,
  have huehue21 : xx < real.sqrt 3 / 2 := by tauto,
  have huehue22 : real.sqrt 3 - xx < real.sqrt 3 / 2 := by tauto,
  linarith only [huehue21, huehue22],

  cases h2,
  have hh5 := h.2.2.2.2.1,
  have hh7 := h2.1,
  have huehue21 : xx          < real.sqrt 3 / 2      := by tauto,
  have huehue22 : real.sqrt 3 < xx + real.sqrt 3 / 2 := by tauto,
  linarith only [huehue21, huehue22],
  rw [inv_eq_one_div (real.sqrt 3), inv_eq_one_div (2 : ℝ)] at h,
  rw [inv_eq_one_div (real.sqrt 3), inv_eq_one_div (2 : ℝ)] at h2,
  cases h2,
  have hh9 := h.2.2.2.2.1,
  have hh13 := h2.2.2,
  have xxx3 : -(1 / real.sqrt 3) + (real.sqrt 3) / 2 < 0 := by linarith,
  rw (div_mul_right (real.sqrt 3) two_ne_zero).symm at xxx3,
  rw ((mul_div_mul_right (real.sqrt 3) 2 (real.sqrt_ne_zero'.mpr zero_lt_three)).symm  ) at xxx3,
  rw (real.mul_self_sqrt (zero_le_three)) at xxx3,
  rw (sub_div_add_div_eq_thing 2 (2 * real.sqrt 3) 3) at xxx3,
  let kkkkk := div_lt_zero_imp_numerator_lt_zero (-2 + 3) (mul_pos (zero_lt_two) sqrt_three_gt_zero) xxx3,
  linarith only [kkkkk],
  linarith,
  rw [inv_eq_one_div (real.sqrt 3), inv_eq_one_div (2 : ℝ)] at h,
  rw [inv_eq_one_div (real.sqrt 3), inv_eq_one_div (2 : ℝ)] at h2,
  cases h2,
  cases h,
  linarith,
  cases h,
  have hh10 := h2.2.2.2.2.2,
  have hh13 := h.2.2,
  rw hh13 at hh10,
  norm_num at hh10,
  have huehue : real.sqrt 3 + (1 / real.sqrt 3) - real.sqrt 3 * (1 / 2) < 0 := sub_lt_zero.mpr hh10,
  let llll := sqrt_three_equat_pos,
  linarith,
  linarith,
  cases h2,
  cases h,
  linarith,
  cases h,
  have hh7 := h.2.2,
  have hh11 := h2.1,
  rw hh7 at hh11,
  have huehue : 0 < -(1 / real.sqrt 3) + real.sqrt 3 * (1 / 2) - real.sqrt 3 := sub_pos.mpr hh11,
  let llll := sqrt_three_equat_neg,
  linarith,
  linarith,
  cases h2,
  cases h,

  have hh6 := h.2.1,
  have hh13 := h2.2.2,
  have djdjdjdj : xx = -(1 / real.sqrt 3) + real.sqrt 3 := begin
    linarith,
  end,
  rw djdjdjdj at hh6,
  have hh99 : (real.sqrt 3) - (1/ (real.sqrt 3)) ≥ 0 := begin
    exact ge_one_imp_sub_inv_ge_zero (real.sqrt 3) one_le_sqrt_three,
  end,
  linarith,
  cases h,
  exact another_case h.2.2 h2.2.2,

  have hh6 := h.2.1,
  have hh13 := h2.2.2,
  have djdjdjdj : xx = -(1 / real.sqrt 3) + real.sqrt 3 := begin
    linarith,
  end,
  rw djdjdjdj at hh6,
  have hh99 : (real.sqrt 3) - (1/ (real.sqrt 3)) > 0 := begin
    exact ge_one_imp_sub_inv_gt_zero (real.sqrt 3) one_lt_sqrt_three,
  end,
  linarith,
  cases h,
  linarith,
  cases h,
  sorry,
  sorry,
end

theorem simple_hfhfhf
: ((1*1) - 1)/1 = 0
:= by simp

-- theorem step_simple_hfhfhf
-- (h1: xx = -(1 / real.sqrt 3))
-- hh11: -(1 / 2) ≤ yy
-- hh12: yy ≤ 1 / 2
-- hh13: xx - real.sqrt 3 = -(1 / real.sqrt 3)
-- := begin
--   ring,
--   finish,
-- end

/-

  have hh5 := h.1,
  have hh6 := h.2.1,
  have hh7 := h.2.2.1,
  have hh8 := h.2.2.2.1,
  have hh9 := h.2.2.2.2.1,
  have hh10 := h.2.2.2.2.2,
  have hh11 := h2.1,
  have hh12 := h2.2.1,
  have hh13 := h2.2.2,
-/

/-
-(Sqrt[3] * (1 / 2)) < x
&& x ≤ 0
&& y = -1 + -(x * (1 / Sqrt[3]))
&& -(1 / 2) ≤ y
&& y ≤ 1 / 2
&& x - Sqrt[3] = -(1 / Sqrt[3])
-/

theorem hex_inter_hex_shift_right_eq_empty_imp_shift_le_sqrt_three
(x : ℝ)
: set.inter (hex_tile 1) (shift (⟨x, 0⟩) (hex_tile 1)) = ∅ → real.sqrt 3 ≤ x
:= sorry

theorem hex_inter_hex_shift_right_eq_empty_imp_shift_le_scale_mul_sqrt_three
(x : ℝ)
(s : ℝ)
: set.inter (hex_tile s) (shift (⟨x, 0⟩) (hex_tile s)) = ∅ → s * real.sqrt 3 ≤ x
:= sorry

/-- An inhabitated space cannot be colored with 0 colors -/
theorem chrom_absurd
(X : Type u) [has_dist X] [inhabited X]
(D : finset ℝ)
(n : ℕ)
: ¬space_colorable X D 0
:= begin
  rw space_colorable,
  simp,
end

theorem chrom_larger
(X : Type u) [has_dist X]
(D : finset ℝ)
(n : ℕ)
: space_colorable X D n → space_colorable X D (n+1)
:= begin
  rw [space_colorable, space_colorable],
  intro f1,
  refine exists.elim f1 _,
  intros k1 k2,
  have : ∀(a : X), k1 a < n+1 := begin
    intro a,
    exact nat.lt.step (k2.left a),
  end,
  tidy,
end

theorem chrom_smaller
(X : Type u) [has_dist X]
(D : finset ℝ)
(n : ℕ)
: ¬space_colorable X D n → ¬space_colorable X D (n-1)
:= begin
  refine not_imp_not.mpr _,
  induction n,
  exact id,
  intro k,
  exact chrom_larger X D _ k,
end

theorem if_eq_else_imp_false
{c : Prop} [decidable c] {α : Type*} {t e : α}
(h_eq : ite c t e = e) (h_ne : t ≠ e)
: ¬c
:= begin
  by_contradiction p_pos,
  exact h_ne ((rfl.congr (if_pos p_pos)).mp (h_eq.symm)).symm,
end

theorem if_eq_then_imp_true
{c : Prop} [decidable c] {α : Type*} {t e : α}
(h_eq : ite c t e = t) (h_ne : t ≠ e)
: c
:= begin
  by_contradiction p_neg,
  exact h_ne ((rfl.congr (if_neg p_neg)).mp (h_eq.symm)),
end

theorem chrom_of_real_line_bounded_contradiction
{a b: ℝ}
(ᾰ: dist a b = 1)
(ᾰ_1: ite (mod_two a < 1) 0 1 = ite (mod_two b < 1) 0 1)
(al : 0 ≤ a)
(au : a < 2)
(bl : 0 ≤ b)
(bu : b < 2)
: false
:= begin
  cases decidable.em (mod_two a < 1) with hat haf,
  rw (if_pos hat) at ᾰ_1,
  cases decidable.em (mod_two b < 1) with hbt hbf,
  rw (if_pos hbt) at ᾰ_1,
  rw real.dist_eq at ᾰ,
  have hhha : a < 1 := bounding_mod_two a au al hat,
  have hhhb : b < 1 := bounding_mod_two b bu bl hbt,
  have hpos : a - b < 1,            by linarith,
  have hpos_neg : -(a - b) < 1,     by linarith,
  have abs_bound : abs (a - b) < 1, by { exact max_lt hpos hpos_neg },
  linarith,

  have hmtb : ite (mod_two b < 1) 0 1 = 1, { exact if_neg hbf },
  linarith,

  have hmta : ite (mod_two a < 1) 0 1 = 1, { exact if_neg haf },
  rw hmta at ᾰ_1,
  have hbf : ¬(mod_two b < 1) := if_eq_else_imp_false ᾰ_1.symm zero_ne_one,
  rw (bounding_id b bu bl) at hbf,
  have haf_expand : ¬mod_two a < 1 := haf,
  rw (bounding_id a au al) at haf_expand,
  have hpos : a - b < 1,            by linarith,
  have hpos_neg : -(a - b) < 1,     by linarith,
  have abs_bound : abs (a - b) < 1, by { exact max_lt hpos hpos_neg },
  rw real.dist_eq at ᾰ,
  exact ne_of_lt abs_bound ᾰ,
end

theorem dist_mod_two_eq_dist
(x y : ℝ)
(h : dist x y = 1)
: dist (mod_two x) (mod_two y) = 1
:= begin
  rw real.dist_eq at h,
  rw real.dist_eq,

  cases decidable.em (x > y) with x_ge_y ne_x_ge_y, by
  {
    rw (abs_of_pos (sub_pos.mpr x_ge_y)) at h,
    have y_simp : y = x-1, by linarith,
    rw y_simp,
    exact (abs_of_mod_two_sub_mod_two_of_sub_one_eq_one x),
  },
  {
    have abs_simp : abs (x - y) = y - x, by { have := abs_sub x y, finish, },
    rw abs_simp at h,
    have y_simp : x = y-1, by linarith,
    rw y_simp,
    rw abs_sub (mod_two (y - 1)) (mod_two y),
    exact (abs_of_mod_two_sub_mod_two_of_sub_one_eq_one y),
  }
end

/-- A coloring of the real line used in `real_line_colorable_avoiding_one_with_two`. -/
private noncomputable def line_color (x : ℝ) : ℕ := ite (mod_two x < 1) 0 1

/-- The real number line can be colored with two colors
    while avoiding monochrome unit distances. --/
theorem colorable_real_line_avoiding_one_with_two
: space_colorable ℝ {1} 2
:= begin
  tidy,
  exact (line_color ᾰ),
  rw line_color,
  cases decidable.em (mod_two a < 1) with H1 H2,
  rw (if_pos H1),
  exact zero_lt_two,
  rw (if_neg H2),
  exact one_lt_two,
  rw [line_color, line_color] at ᾰ_1,
  rw ←mod_two_idempotent a at ᾰ_1,
  rw ←mod_two_idempotent b at ᾰ_1,
  exact (chrom_of_real_line_bounded_contradiction
    (dist_mod_two_eq_dist a b ᾰ)
    ᾰ_1
    (ge_iff_le.mp (mod_two_geq_0 a))
    (mod_two_le_2 a)
    (ge_iff_le.mp (mod_two_geq_0 b))
    (mod_two_le_2 b)
  ),
end


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis, Yaël Dillies
-/

import algebra.module.pi
import algebra.module.prod
import algebra.order.field
import algebra.order.pi
import algebra.order.smul
import algebra.pointwise

/-!
# Ordered module

In this file we provide lemmas about `ordered_smul` that hold once a module structure is present.

## References

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

## Tags

ordered module, ordered scalar, ordered smul, ordered action, ordered vector space
-/

open_locale pointwise

variables {k M N : Type*}

namespace order_dual

instance [semiring k] [ordered_add_comm_monoid M] [module k M] : module k (order_dual M) :=
{ add_smul := λ r s x, order_dual.rec (add_smul _ _) x,
  zero_smul := λ m, order_dual.rec (zero_smul _) m }

end order_dual

section semiring
variables [ordered_semiring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

/- can be generalized from `module k M` to `distrib_mul_action_with_zero k M` once it exists.
where `distrib_mul_action_with_zero k M`is the conjunction of `distrib_mul_action k M` and
`smul_with_zero k M`.-/
lemma smul_neg_iff_of_pos (hc : 0 < c) :
  c • a < 0 ↔ a < 0 :=
begin
  rw [←neg_neg a, smul_neg, neg_neg_iff_pos, neg_neg_iff_pos],
  exact smul_pos_iff_of_pos hc,
end

end semiring

section ring
variables [ordered_ring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

lemma smul_lt_smul_of_neg (h : a < b) (hc : c < 0) :
  c • b < c • a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff],
  exact smul_lt_smul_of_pos h (neg_pos_of_neg hc),
end

lemma smul_le_smul_of_nonpos (h : a ≤ b) (hc : c ≤ 0) :
  c • b ≤ c • a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_le_neg_iff],
  exact smul_le_smul_of_nonneg h (neg_nonneg_of_nonpos hc),
end

lemma eq_of_smul_eq_smul_of_neg_of_le (hab : c • a = c • b) (hc : c < 0) (h : a ≤ b) :
  a = b :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_inj] at hab,
  exact eq_of_smul_eq_smul_of_pos_of_le hab (neg_pos_of_neg hc) h,
end

lemma lt_of_smul_lt_smul_of_nonpos (h : c • a < c • b) (hc : c ≤ 0) :
  b < a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff] at h,
  exact lt_of_smul_lt_smul_of_nonneg h (neg_nonneg_of_nonpos hc),
end

lemma smul_lt_smul_iff_of_neg (hc : c < 0) :
  c • a < c • b ↔ b < a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff],
  exact smul_lt_smul_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_neg_iff_of_neg (hc : c < 0) :
  c • a < 0 ↔ 0 < a :=
begin
  rw [←neg_neg c, neg_smul, neg_neg_iff_pos],
  exact smul_pos_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_pos_iff_of_neg (hc : c < 0) :
  0 < c • a ↔ a < 0 :=
begin
  rw [←neg_neg c, neg_smul, neg_pos],
  exact smul_neg_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_nonpos_of_nonpos_of_nonneg (hc : c ≤ 0) (ha : 0 ≤ a) : c • a ≤ 0 :=
calc
  c • a ≤ c • 0 : smul_le_smul_of_nonpos ha hc
  ... = 0 : smul_zero' M c

lemma smul_nonneg_of_nonpos_of_nonpos (hc : c ≤ 0) (ha : a ≤ 0) : 0 ≤ c • a :=
@smul_nonpos_of_nonpos_of_nonneg k (order_dual M) _ _ _ _ _ _ hc ha

alias smul_pos_iff_of_neg ↔ _ smul_pos_of_neg_of_neg
alias smul_neg_iff_of_pos ↔ _ smul_neg_of_pos_of_neg
alias smul_neg_iff_of_neg ↔ _ smul_neg_of_neg_of_pos

lemma antitone_smul_left (hc : c ≤ 0) : antitone (has_scalar.smul c : M → M) :=
λ a b h, smul_le_smul_of_nonpos h hc

lemma strict_anti_smul_left (hc : c < 0) : strict_anti (has_scalar.smul c : M → M) :=
λ a b h, smul_lt_smul_of_neg h hc

end ring

section field
variables [linear_ordered_field k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

lemma smul_le_smul_iff_of_neg (hc : c < 0) : c • a ≤ c • b ↔ b ≤ a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_le_neg_iff],
  exact smul_le_smul_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_lt_iff_of_neg (hc : c < 0) : c • a < b ↔ c⁻¹ • b < a :=
begin
  rw [←neg_neg c, ←neg_neg a, neg_smul_neg, inv_neg, neg_smul _ b, neg_lt_neg_iff],
  exact smul_lt_iff_of_pos (neg_pos_of_neg hc),
end

lemma lt_smul_iff_of_neg (hc : c < 0) : a < c • b ↔ b < c⁻¹ • a :=
begin
  rw [←neg_neg c, ←neg_neg b, neg_smul_neg, inv_neg, neg_smul _ a, neg_lt_neg_iff],
  exact lt_smul_iff_of_pos (neg_pos_of_neg hc),
end

variables (M)

/-- Left scalar multiplication as an order isomorphism. -/
@[simps] def order_iso.smul_left_dual {c : k} (hc : c < 0) : M ≃o order_dual M :=
{ to_fun := λ b, order_dual.to_dual (c • b),
  inv_fun := λ b, c⁻¹ • (order_dual.of_dual b),
  left_inv := inv_smul_smul₀ hc.ne,
  right_inv := smul_inv_smul₀ hc.ne,
  map_rel_iff' := λ b₁ b₂, smul_le_smul_iff_of_neg hc }

variables {M} [ordered_add_comm_group N] [module k N] [ordered_smul k N]

-- TODO: solve `prod.has_lt` and `prod.has_le` misalignment issue
instance prod.ordered_smul : ordered_smul k (M × N) :=
ordered_smul.mk' $ λ (v u : M × N) (c : k) h hc,
  ⟨smul_le_smul_of_nonneg h.1.1 hc.le, smul_le_smul_of_nonneg h.1.2 hc.le⟩

instance pi.ordered_smul {ι : Type*} {M : ι → Type*} [Π i, ordered_add_comm_group (M i)]
  [Π i, mul_action_with_zero k (M i)] [∀ i, ordered_smul k (M i)] :
  ordered_smul k (Π i : ι, M i) :=
begin
  refine (ordered_smul.mk' $ λ v u c h hc i, _),
  change c • v i ≤ c • u i,
  exact smul_le_smul_of_nonneg (h.le i) hc.le,
end

-- Sometimes Lean fails to apply the dependent version to non-dependent functions,
-- so we define another instance
instance pi.ordered_smul' {ι : Type*} {M : Type*} [ordered_add_comm_group M]
  [mul_action_with_zero k M] [ordered_smul k M] :
  ordered_smul k (ι → M) :=
pi.ordered_smul

end field

/-! ### Upper/lower bounds -/

section ordered_semiring
variables [ordered_semiring k] [ordered_add_comm_monoid M] [smul_with_zero k M] [ordered_smul k M]
  {s : set M} {c : k}

lemma smul_lower_bounds_subset_lower_bounds_smul (hc : 0 ≤ c) :
  c • lower_bounds s ⊆ lower_bounds (c • s) :=
(monotone_smul_left hc).image_lower_bounds_subset_lower_bounds_image

lemma smul_upper_bounds_subset_upper_bounds_smul (hc : 0 ≤ c) :
  c • upper_bounds s ⊆ upper_bounds (c • s) :=
(monotone_smul_left hc).image_upper_bounds_subset_upper_bounds_image

lemma bdd_below.smul_of_nonneg (hs : bdd_below s) (hc : 0 ≤ c) : bdd_below (c • s) :=
(monotone_smul_left hc).map_bdd_below hs

lemma bdd_above.smul_of_nonneg (hs : bdd_above s) (hc : 0 ≤ c) : bdd_above (c • s) :=
(monotone_smul_left hc).map_bdd_above hs

end ordered_semiring

section ordered_ring
variables [ordered_ring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {s : set M} {c : k}

lemma smul_lower_bounds_subset_upper_bounds_smul (hc : c ≤ 0) :
  c • lower_bounds s ⊆ upper_bounds (c • s) :=
(antitone_smul_left hc).image_lower_bounds_subset_upper_bounds_image

lemma smul_upper_bounds_subset_lower_bounds_smul (hc : c ≤ 0) :
  c • upper_bounds s ⊆ lower_bounds (c • s) :=
(antitone_smul_left hc).image_upper_bounds_subset_lower_bounds_image

lemma bdd_below.smul_of_nonpos (hc : c ≤ 0) (hs : bdd_below s) : bdd_above (c • s) :=
(antitone_smul_left hc).map_bdd_below hs

lemma bdd_above.smul_of_nonpos (hc : c ≤ 0) (hs : bdd_above s) : bdd_below (c • s) :=
(antitone_smul_left hc).map_bdd_above hs

end ordered_ring

section linear_ordered_field
variables [linear_ordered_field k] [ordered_add_comm_group M]

section mul_action_with_zero
variables [mul_action_with_zero k M] [ordered_smul k M] {s t : set M} {c : k}

@[simp] lemma lower_bounds_smul_of_pos (hc : 0 < c) : lower_bounds (c • s) = c • lower_bounds s :=
(order_iso.smul_left _ hc).lower_bounds_image

@[simp] lemma upper_bounds_smul_of_pos (hc : 0 < c) : upper_bounds (c • s) = c • upper_bounds s :=
(order_iso.smul_left _ hc).upper_bounds_image

@[simp] lemma bdd_below_smul_iff_of_pos (hc : 0 < c) : bdd_below (c • s) ↔ bdd_below s :=
(order_iso.smul_left _ hc).bdd_below_image

@[simp] lemma bdd_above_smul_iff_of_pos (hc : 0 < c) : bdd_above (c • s) ↔ bdd_above s :=
(order_iso.smul_left _ hc).bdd_above_image

end mul_action_with_zero

section module
variables [module k M] [ordered_smul k M] {s t : set M} {c : k}

@[simp] lemma lower_bounds_smul_of_neg (hc : c < 0) : lower_bounds (c • s) = c • upper_bounds s :=
(order_iso.smul_left_dual M hc).upper_bounds_image

@[simp] lemma upper_bounds_smul_of_neg (hc : c < 0) : upper_bounds (c • s) = c • lower_bounds s :=
(order_iso.smul_left_dual M hc).lower_bounds_image

@[simp] lemma bdd_below_smul_iff_of_neg (hc : c < 0) : bdd_below (c • s) ↔ bdd_above s :=
(order_iso.smul_left_dual M hc).bdd_above_image

@[simp] lemma bdd_above_smul_iff_of_neg (hc : c < 0) : bdd_above (c • s) ↔ bdd_below s :=
(order_iso.smul_left_dual M hc).bdd_below_image

end module
end linear_ordered_field


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

! This file was ported from Lean 3 source module set_theory.game.short
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Basic
import Mathbin.SetTheory.Cardinal.Cofinality
import Mathbin.SetTheory.Game.Birthday

/-!
# Short games

A combinatorial game is `short` [Conway, ch.9][conway2001] if it has only finitely many positions.
In particular, this means there is a finite set of moves at every point.

We prove that the order relations `≤` and `<`, and the equivalence relation `≈`, are decidable on
short games, although unfortunately in practice `dec_trivial` doesn't seem to be able to
prove anything using these instances.
-/

universe u

open Pgame

namespace Pgame

/-- A short game is a game with a finite set of moves at every turn. -/
inductive Short : Pgame.{u} → Type (u + 1)
  |
  mk :
    ∀ {α β : Type u} {L : α → Pgame.{u}} {R : β → Pgame.{u}} (sL : ∀ i : α, short (L i))
      (sR : ∀ j : β, short (R j)) [Fintype α] [Fintype β], short ⟨α, β, L, R⟩
#align pgame.short Pgame.Short

instance subsingleton_short : ∀ x : Pgame, Subsingleton (Short x)
  | mk xl xr xL xR =>
    ⟨fun a b => by
      cases a; cases b
      congr
      · funext
        apply @Subsingleton.elim _ (subsingleton_short (xL x))
      · funext
        apply @Subsingleton.elim _ (subsingleton_short (xR x))⟩decreasing_by
  pgame_wf_tac
#align pgame.subsingleton_short Pgame.subsingleton_short

/-- A synonym for `short.mk` that specifies the pgame in an implicit argument. -/
def Short.mk' {x : Pgame} [Fintype x.LeftMoves] [Fintype x.RightMoves]
    (sL : ∀ i : x.LeftMoves, Short (x.moveLeft i))
    (sR : ∀ j : x.RightMoves, Short (x.moveRight j)) : Short x := by
  (cases x; dsimp at *) <;> exact short.mk sL sR
#align pgame.short.mk' Pgame.Short.mk'

attribute [class] short

/-- Extracting the `fintype` instance for the indexing type for Left's moves in a short game.
This is an unindexed typeclass, so it can't be made a global instance.
-/
def fintypeLeft {α β : Type u} {L : α → Pgame.{u}} {R : β → Pgame.{u}} [S : Short ⟨α, β, L, R⟩] :
    Fintype α := by
  cases' S with _ _ _ _ _ _ F _
  exact F
#align pgame.fintype_left Pgame.fintypeLeft

attribute [local instance] fintype_left

instance fintypeLeftMoves (x : Pgame) [S : Short x] : Fintype x.LeftMoves :=
  by
  cases x
  dsimp
  infer_instance
#align pgame.fintype_left_moves Pgame.fintypeLeftMoves

/-- Extracting the `fintype` instance for the indexing type for Right's moves in a short game.
This is an unindexed typeclass, so it can't be made a global instance.
-/
def fintypeRight {α β : Type u} {L : α → Pgame.{u}} {R : β → Pgame.{u}} [S : Short ⟨α, β, L, R⟩] :
    Fintype β := by
  cases' S with _ _ _ _ _ _ _ F
  exact F
#align pgame.fintype_right Pgame.fintypeRight

attribute [local instance] fintype_right

instance fintypeRightMoves (x : Pgame) [S : Short x] : Fintype x.RightMoves :=
  by
  cases x
  dsimp
  infer_instance
#align pgame.fintype_right_moves Pgame.fintypeRightMoves

instance moveLeftShort (x : Pgame) [S : Short x] (i : x.LeftMoves) : Short (x.moveLeft i) :=
  by
  cases' S with _ _ _ _ L _ _ _
  apply L
#align pgame.move_left_short Pgame.moveLeftShort

/-- Extracting the `short` instance for a move by Left.
This would be a dangerous instance potentially introducing new metavariables
in typeclass search, so we only make it an instance locally.
-/
def moveLeftShort' {xl xr} (xL xR) [S : Short (mk xl xr xL xR)] (i : xl) : Short (xL i) :=
  by
  cases' S with _ _ _ _ L _ _ _
  apply L
#align pgame.move_left_short' Pgame.moveLeftShort'

attribute [local instance] move_left_short'

instance moveRightShort (x : Pgame) [S : Short x] (j : x.RightMoves) : Short (x.moveRight j) :=
  by
  cases' S with _ _ _ _ _ R _ _
  apply R
#align pgame.move_right_short Pgame.moveRightShort

/-- Extracting the `short` instance for a move by Right.
This would be a dangerous instance potentially introducing new metavariables
in typeclass search, so we only make it an instance locally.
-/
def moveRightShort' {xl xr} (xL xR) [S : Short (mk xl xr xL xR)] (j : xr) : Short (xR j) :=
  by
  cases' S with _ _ _ _ _ R _ _
  apply R
#align pgame.move_right_short' Pgame.moveRightShort'

attribute [local instance] move_right_short'

theorem short_birthday : ∀ (x : Pgame.{u}) [Short x], x.birthday < Ordinal.omega
  | ⟨xl, xr, xL, xR⟩, hs => by
    haveI := hs
    rcases hs with ⟨sL, sR⟩
    rw [birthday, max_lt_iff]
    constructor;
    all_goals
      rw [← Cardinal.ord_aleph0]
      refine'
        Cardinal.lsub_lt_ord_of_isRegular.{u, u} Cardinal.isRegular_aleph0
          (Cardinal.lt_aleph0_of_finite _) fun i => _
      rw [Cardinal.ord_aleph0]
      apply short_birthday _
    · exact move_left_short' xL xR i
    · exact move_right_short' xL xR i
#align pgame.short_birthday Pgame.short_birthday

/-- This leads to infinite loops if made into an instance. -/
def Short.ofIsEmpty {l r xL xR} [IsEmpty l] [IsEmpty r] : Short (mk l r xL xR) :=
  Short.mk isEmptyElim isEmptyElim
#align pgame.short.of_is_empty Pgame.Short.ofIsEmpty

instance short0 : Short 0 :=
  Short.ofIsEmpty
#align pgame.short_0 Pgame.short0

instance short1 : Short 1 :=
  Short.mk (fun i => by cases i; infer_instance) fun j => by cases j
#align pgame.short_1 Pgame.short1

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Evidence that every `pgame` in a list is `short`. -/
inductive ListShort : List Pgame.{u} → Type (u + 1)
  | nil : list_short []
  | cons : ∀ (hd : Pgame.{u}) [Short hd] (tl : List Pgame.{u}) [list_short tl], list_short (hd::tl)
#align pgame.list_short Pgame.ListShort

attribute [class] list_short

attribute [instance] list_short.nil list_short.cons

/- warning: pgame.list_short_nth_le -> Pgame.listShortNthLe is a dubious translation:
lean 3 declaration is
  forall (L : List.{succ u1} Pgame.{u1}) [_inst_1 : Pgame.ListShort.{u1} L] (i : Fin (List.length.{succ u1} Pgame.{u1} L)), Pgame.Short.{u1} (List.nthLe.{succ u1} Pgame.{u1} L ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Fin (List.length.{succ u1} Pgame.{u1} L)) Nat (HasLiftT.mk.{1, 1} (Fin (List.length.{succ u1} Pgame.{u1} L)) Nat (CoeTCₓ.coe.{1, 1} (Fin (List.length.{succ u1} Pgame.{u1} L)) Nat (coeBase.{1, 1} (Fin (List.length.{succ u1} Pgame.{u1} L)) Nat (Fin.coeToNat (List.length.{succ u1} Pgame.{u1} L))))) i) (Pgame.ListShortNthLe._proof_1.{u1} L i))
but is expected to have type
  PUnit.{succ (succ u1)}
Case conversion may be inaccurate. Consider using '#align pgame.list_short_nth_le Pgame.listShortNthLeₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance listShortNthLe :
    ∀ (L : List Pgame.{u}) [ListShort L] (i : Fin (List.length L)), Short (List.nthLe L i i.is_lt)
  | [], _, n => by exfalso; rcases n with ⟨_, ⟨⟩⟩
  | hd::tl, @list_short.cons _ S _ _, ⟨0, _⟩ => S
  | hd::tl, @list_short.cons _ _ _ S, ⟨n + 1, h⟩ =>
    @list_short_nth_le tl S ⟨n, (add_lt_add_iff_right 1).mp h⟩
#align pgame.list_short_nth_le Pgame.listShortNthLe

instance shortOfLists : ∀ (L R : List Pgame) [ListShort L] [ListShort R], Short (Pgame.ofLists L R)
  | L, R, _, _ => by
    skip
    apply short.mk
    · intros
      infer_instance
    · intros
      apply Pgame.listShortNthLe
#align pgame.short_of_lists Pgame.shortOfLists

-- where does the subtype.val come from?
/-- If `x` is a short game, and `y` is a relabelling of `x`, then `y` is also short. -/
def shortOfRelabelling : ∀ {x y : Pgame.{u}} (R : Relabelling x y) (S : Short x), Short y
  | x, y, ⟨L, R, rL, rR⟩, S => by
    skip
    haveI := Fintype.ofEquiv _ L
    haveI := Fintype.ofEquiv _ R
    exact
      short.mk'
        (fun i => by
          rw [← L.right_inv i]
          apply short_of_relabelling (rL (L.symm i)) inferInstance)
        fun j => by simpa using short_of_relabelling (rR (R.symm j)) inferInstance
#align pgame.short_of_relabelling Pgame.shortOfRelabelling

instance shortNeg : ∀ (x : Pgame.{u}) [Short x], Short (-x)
  | mk xl xr xL xR, _ => by
    skip
    exact short.mk (fun i => short_neg _) fun i => short_neg _ decreasing_by pgame_wf_tac
#align pgame.short_neg Pgame.shortNeg

instance shortAdd : ∀ (x y : Pgame.{u}) [Short x] [Short y], Short (x + y)
  | mk xl xr xL xR, mk yl yr yL yR, _, _ => by
    skip
    apply short.mk;
    all_goals
      rintro ⟨i⟩
      · apply short_add
      · change short (mk xl xr xL xR + _)
        apply short_add decreasing_by
  pgame_wf_tac
#align pgame.short_add Pgame.shortAdd

instance shortNat : ∀ n : ℕ, Short n
  | 0 => Pgame.short0
  | n + 1 => @Pgame.shortAdd _ _ (short_nat n) Pgame.short1
#align pgame.short_nat Pgame.shortNat

instance shortBit0 (x : Pgame.{u}) [Short x] : Short (bit0 x) :=
  by
  dsimp [bit0]
  infer_instance
#align pgame.short_bit0 Pgame.shortBit0

instance shortBit1 (x : Pgame.{u}) [Short x] : Short (bit1 x) :=
  by
  dsimp [bit1]
  infer_instance
#align pgame.short_bit1 Pgame.shortBit1

/-- Auxiliary construction of decidability instances.
We build `decidable (x ≤ y)` and `decidable (x ⧏ y)` in a simultaneous induction.
Instances for the two projections separately are provided below.
-/
def leLfDecidable : ∀ (x y : Pgame.{u}) [Short x] [Short y], Decidable (x ≤ y) × Decidable (x ⧏ y)
  | mk xl xr xL xR, mk yl yr yL yR, shortx, shorty =>
    by
    skip
    constructor
    · refine' @decidable_of_iff' _ _ mk_le_mk (id _)
      apply @And.decidable _ _ _ _
      · apply @Fintype.decidableForallFintype xl _ _ (by infer_instance)
        intro i
        apply (@le_lf_decidable _ _ _ _).2 <;> infer_instance
      · apply @Fintype.decidableForallFintype yr _ _ (by infer_instance)
        intro i
        apply (@le_lf_decidable _ _ _ _).2 <;> infer_instance
    · refine' @decidable_of_iff' _ _ mk_lf_mk (id _)
      apply @Or.decidable _ _ _ _
      · apply @Fintype.decidableExistsFintype yl _ _ (by infer_instance)
        intro i
        apply (@le_lf_decidable _ _ _ _).1 <;> infer_instance
      · apply @Fintype.decidableExistsFintype xr _ _ (by infer_instance)
        intro i
        apply (@le_lf_decidable _ _ _ _).1 <;> infer_instance decreasing_by pgame_wf_tac
#align pgame.le_lf_decidable Pgame.leLfDecidable

instance leDecidable (x y : Pgame.{u}) [Short x] [Short y] : Decidable (x ≤ y) :=
  (leLfDecidable x y).1
#align pgame.le_decidable Pgame.leDecidable

instance lfDecidable (x y : Pgame.{u}) [Short x] [Short y] : Decidable (x ⧏ y) :=
  (leLfDecidable x y).2
#align pgame.lf_decidable Pgame.lfDecidable

instance ltDecidable (x y : Pgame.{u}) [Short x] [Short y] : Decidable (x < y) :=
  And.decidable
#align pgame.lt_decidable Pgame.ltDecidable

instance equivDecidable (x y : Pgame.{u}) [Short x] [Short y] : Decidable (x ≈ y) :=
  And.decidable
#align pgame.equiv_decidable Pgame.equivDecidable

example : Short 0 := by infer_instance

example : Short 1 := by infer_instance

example : Short 2 := by infer_instance

example : Short (-2) := by infer_instance

example : Short (ofLists [0] [1]) := by infer_instance

example : Short (ofLists [-2, -1] [1]) := by infer_instance

example : Short (0 + 0) := by infer_instance

example : Decidable ((1 : Pgame) ≤ 1) := by infer_instance

-- No longer works since definitional reduction of well-founded definitions has been restricted.
-- example : (0 : pgame) ≤ 0 := dec_trivial
-- example : (1 : pgame) ≤ 1 := dec_trivial
end Pgame


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import data.set.pointwise

/-!
# Sets as a semiring under union

This file defines `set_semiring α`, an alias of `set α`, which we endow with `∪` as addition and
pointwise `*` as multiplication. If `α` is a (commutative) monoid, `set_semiring α` is a
(commutative) semiring.
-/

open function set
open_locale pointwise

variables {α β : Type*}

/-- An alias for `set α`, which has a semiring structure given by `∪` as "addition" and pointwise
  multiplication `*` as "multiplication". -/
@[derive [inhabited, partial_order, order_bot]] def set_semiring (α : Type*) : Type* := set α

/-- The identity function `set α → set_semiring α`. -/
protected def set.up : set α ≃ set_semiring α := equiv.refl _

namespace set_semiring

/-- The identity function `set_semiring α → set α`. -/
protected def down : set_semiring α ≃ set α := equiv.refl _

@[simp] protected

-- TODO: These lemmas are not tagged `simp` because `set.le_eq_subset` simplifies the LHS
lemma up_le_up {s t : set α} : s.up ≤ t.up ↔ s ⊆ t := iff.rfl
lemma up_lt_up {s t : set α} : s.up < t.up ↔ s ⊂ t := iff.rfl

@[simp] lemma down_subset_down {s t : set_semiring α} : s.down ⊆ t.down ↔ s ≤ t := iff.rfl
@[simp] lemma down_ssubset_down {s t : set_semiring α} : s.down ⊂ t.down ↔ s < t := iff.rfl

instance : add_comm_monoid (set_semiring α) :=
{ add := λ s t, (s.down ∪ t.down).up,
  zero := (∅ : set α).up,
  add_assoc := union_assoc,
  zero_add := empty_union,
  add_zero := union_empty,
  add_comm := union_comm }

/- Since addition on `set_semiring` is commutative (it is set union), there is no need
to also have the instance `covariant_class (set_semiring α) (set_semiring α) (swap (+)) (≤)`. -/
instance covariant_class_add : covariant_class (set_semiring α) (set_semiring α) (+) (≤) :=
⟨λ a b c, union_subset_union_right _⟩

section has_mul
variables [has_mul α]

instance : non_unital_non_assoc_semiring (set_semiring α) :=
{ mul := λ s t, (image2 (*) s.down t.down).up,
  zero_mul := λ s, empty_mul,
  mul_zero := λ s, mul_empty,
  left_distrib := λ _ _ _, mul_union,
  right_distrib := λ _ _ _, union_mul,
  ..set_semiring.add_comm_monoid }

instance : no_zero_divisors (set_semiring α) :=
⟨λ a b ab, a.eq_empty_or_nonempty.imp_right $ λ ha, b.eq_empty_or_nonempty.resolve_right $
  λ hb, nonempty.ne_empty ⟨_, mul_mem_mul ha.some_mem hb.some_mem⟩ ab⟩

instance covariant_class_mul_left : covariant_class (set_semiring α) (set_semiring α) (*) (≤) :=
⟨λ a b c, mul_subset_mul_left⟩

instance covariant_class_mul_right :
  covariant_class (set_semiring α) (set_semiring α) (swap (*)) (≤) :=
⟨λ a b c, mul_subset_mul_right⟩

end has_mul

instance [mul_one_class α] : non_assoc_semiring (set_semiring α) :=
{ one := 1,
  mul := (*),
  ..set_semiring.non_unital_non_assoc_semiring, ..set.mul_one_class }

instance [semigroup α] : non_unital_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_non_assoc_semiring, ..set.semigroup }

instance [monoid α] : semiring (set_semiring α) :=
{ ..set_semiring.non_assoc_semiring, ..set_semiring.non_unital_semiring }

instance [comm_semigroup α] : non_unital_comm_semiring (set_semiring α) :=
{ ..set_semiring.non_unital_semiring, ..set.comm_semigroup }

instance [comm_monoid α] : canonically_ordered_comm_semiring (set_semiring α) :=
{ add_le_add_left := λ a b, add_le_add_left,
  exists_add_of_le := λ a b ab, ⟨b, (union_eq_right_iff_subset.2 ab).symm⟩,
  le_self_add := subset_union_left,
  ..set_semiring.semiring, ..set.comm_monoid, ..set_semiring.partial_order _,
  ..set_semiring.order_bot _, ..set_semiring.no_zero_divisors }

/-- The image of a set under a multiplicative homomorphism is a ring homomorphism
with respect to the pointwise operations on sets. -/
def image_hom [mul_one_class α] [mul_one_class β] (f : α →* β) :
  set_semiring α →+* set_semiring β :=
{ to_fun := image f,
  map_zero' := image_empty _,
  map_one' := by rw [image_one, map_one, singleton_one],
  map_add' := image_union _,
  map_mul' := λ _ _, image_mul f }

end set_semiring


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import order.fixed_points
import order.zorn

/-!
# Schröder-Bernstein theorem, well-ordering of cardinals

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

This file proves the Schröder-Bernstein theorem (see `schroeder_bernstein`), the well-ordering of
cardinals (see `min_injective`) and the totality of their order (see `total`).

## Notes

Cardinals are naturally ordered by `α ≤ β ↔ ∃ f : a → β, injective f`:
* `schroeder_bernstein` states that, given injections `α → β` and `β → α`, one can get a
  bijection `α → β`. This corresponds to the antisymmetry of the order.
* The order is also well-founded: any nonempty set of cardinals has a minimal element.
  `min_injective` states that by saying that there exists an element of the set that injects into
  all others.

Cardinals are defined and further developed in the file `set_theory.cardinal`.
-/

open set function
open_locale classical

universes u v

namespace function
namespace embedding

section antisymm
variables {α : Type u} {β : Type v}

/-- **The Schröder-Bernstein Theorem**:
Given injections `α → β` and `β → α`, we can get a bijection `α → β`. -/
theorem schroeder_bernstein {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g) : ∃ h : α → β, bijective h :=
begin
  casesI is_empty_or_nonempty β with hβ hβ,
  { haveI : is_empty α, from function.is_empty f,
    exact ⟨_, ((equiv.equiv_empty α).trans (equiv.equiv_empty β).symm).bijective⟩ },
  set F : set α →o set α :=
  { to_fun := λ s, (g '' (f '' s)ᶜ)ᶜ,
    monotone' := λ s t hst, compl_subset_compl.mpr $ image_subset _ $
     compl_subset_compl.mpr $ image_subset _ hst },
  set s : set α := F.lfp,
  have hs : (g '' (f '' s)ᶜ)ᶜ = s, from F.map_lfp,
  have hns : g '' (f '' s)ᶜ = sᶜ, from compl_injective (by simp [hs]),
  set g' := inv_fun g,
  have g'g : left_inverse g' g, from left_inverse_inv_fun hg,
  have hg'ns : g' '' sᶜ = (f '' s)ᶜ, by rw [← hns, g'g.image_image],
  set h : α → β := s.piecewise f g',
  have : surjective h, by rw [← range_iff_surjective, range_piecewise, hg'ns, union_compl_self],
  have : injective h,
  { refine (injective_piecewise_iff _).2 ⟨hf.inj_on _, _, _⟩,
    { intros x hx y hy hxy,
      obtain ⟨x', hx', rfl⟩ : x ∈ g '' (f '' s)ᶜ, by rwa hns,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _, g'g _] at hxy, rw hxy },
    { intros x hx y hy hxy,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _] at hxy,
      exact hy' ⟨x, hx, hxy⟩ } },
  exact ⟨h, ‹injective h›, ‹surjective h›⟩
end

/-- **The Schröder-Bernstein Theorem**: Given embeddings `α ↪ β` and `β ↪ α`, there exists an
equivalence `α ≃ β`. -/
theorem antisymm : (α ↪ β) → (β ↪ α) → nonempty (α ≃ β)
| ⟨e₁, h₁⟩ ⟨e₂, h₂⟩ :=
  let ⟨f, hf⟩ := schroeder_bernstein h₁ h₂ in
  ⟨equiv.of_bijective f hf⟩

end antisymm

section wo
parameters {ι : Type u} (β : ι → Type v)

@[reducible] private def sets := {s : set (∀ i, β i) |
  ∀ (x ∈ s) (y ∈ s) i, (x : ∀ i, β i) i = y i → x = y}

/-- The cardinals are well-ordered. We express it here by the fact that in any set of cardinals
there is an element that injects into the others. See `cardinal.linear_order` for (one of) the
lattice instances. -/
theorem min_injective [I : nonempty ι] : ∃ i, nonempty (∀ j, β i ↪ β j) :=
let ⟨s, hs, ms⟩ := show ∃ s ∈ sets, ∀ a ∈ sets, s ⊆ a → a = s, from
  zorn_subset sets (λ c hc hcc, ⟨⋃₀ c,
    λ x ⟨p, hpc, hxp⟩ y ⟨q, hqc, hyq⟩ i hi, (hcc.total hpc hqc).elim
      (λ h, hc hqc x (h hxp) y hyq i hi) (λ h, hc hpc x hxp y (h hyq) i hi),
  λ _, subset_sUnion_of_mem⟩) in
let ⟨i, e⟩ := show ∃ i, ∀ y, ∃ x ∈ s, (x : ∀ i, β i) i = y, from
  classical.by_contradiction $ λ h,
  have h : ∀ i, ∃ y, ∀ x ∈ s, (x : ∀ i, β i) i ≠ y,
    by simpa only [not_exists, not_forall] using h,
  let ⟨f, hf⟩ := classical.axiom_of_choice h in
  have f ∈ s, from
    have insert f s ∈ sets := λ x hx y hy, begin
      cases hx; cases hy, {simp [hx, hy]},
      { subst x, exact λ i e, (hf i y hy e.symm).elim },
      { subst y, exact λ i e, (hf i x hx e).elim },
      { exact hs x hx y hy }
    end, ms _ this (subset_insert f s) ▸ mem_insert _ _,
  let ⟨i⟩ := I in hf i f this rfl in
let ⟨f, hf⟩ := classical.axiom_of_choice e in
⟨i, ⟨λ j, ⟨λ a, f a j, λ a b e',
  let ⟨sa, ea⟩ := hf a, ⟨sb, eb⟩ := hf b in
  by rw [← ea, ← eb, hs _ sa _ sb _ e']⟩⟩⟩

end wo

/-- The cardinals are totally ordered. See `cardinal.linear_order` for (one of) the lattice
instance. -/
theorem total (α : Type u) (β : Type v) : nonempty (α ↪ β) ∨ nonempty (β ↪ α) :=
match @min_injective bool (λ b, cond b (ulift α) (ulift.{(max u v) v} β)) ⟨tt⟩ with
| ⟨tt, ⟨h⟩⟩ := let ⟨f, hf⟩ := h ff in or.inl ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
| ⟨ff, ⟨h⟩⟩ := let ⟨f, hf⟩ := h tt in or.inr ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
end

end embedding
end function