import order.zorn
import tactic
import .basic
import ..helpers
import data.set

open_locale classical

variables {T : Type*} [pregeom T]

namespace pregeom
namespace basis

open has_cl

/--
A set `S` is independent if for all `x ∈ S`, the element `x` is not contained in

`cl (S - {x})`
-/
def is_indep (S : set T) := ∀ {x : T}, x ∈ S → x ∉ cl (S - {x})

/--
A set `S` is spanning if `∀ t : T, t ∈ cl S`.
-/
def is_spanning (S : set T) := ∀ t : T, t ∈ cl S

/-- A basis is a spanning independent set. -/
def is_basis (S : set T) := is_indep S ∧ is_spanning S

/-- If `A` spans, and `A ≤ B`, then `B` spans. -/
@[simp]
lemma super_spans {A B : set T} {spans : is_spanning A} (le : A ≤ B): is_spanning B :=
begin
  unfold is_spanning at *,
  have mono: cl A ≤ cl B, by exact pregeom.monotone le,
  intro t,
  replace spans := spans t,
  exact mono spans,
end

/-- If `S` is independent and `t ∉ cl S` then `insert t S` is independent. -/
lemma insert_indep {t : T} {S : set T} : is_indep S → t ∉ cl S → is_indep (insert t S) :=
begin
  intros h ht,
  by_contradiction,
  unfold is_indep at a,
  rw not_forall at a,
  cases a with z hz,
  simp only [set.mem_insert_iff, set.not_not_mem, set.sub_eq_diff, classical.not_imp] at hz,
  cases hz with h1 h2,
  cases h1,
  { rw h1 at *,
    suffices : insert t S - {t} ≤ S,
    { replace h2 := monotone this h2,
      contradiction, },
    tidy, },
  { have : insert t S \ {z} = insert t (S \ {z}), by tidy; finish,
    rw this at h2, clear this,
    have : z ∉ cl (S \ {z}), by {apply h, tidy, },
    have bad := exchange h2 this,
    have : insert z (S \ {z}) = S, by tidy; finish,
    rw this at bad,
    contradiction, }
end

/-- A basis is a maximal independent set. -/
theorem basis_iff_maximal_indep {S : set T} :
  is_basis S ↔
  is_indep S ∧ (∀ S' : set T, S ≤ S' → is_indep S' → S = S') :=
begin
  split,
  { intro h,
    refine ⟨h.1,_⟩,
    intros S' hle hindep,
    suffices : S' ≤ S, by exact le_antisymm hle this,
    intros t ht,
    cases h with h1 h2,
    replace h2 := h2 t,
    by_contradiction contra,
    have claim1 : S ≤ S' - {t},
    { intros s hs,
      refine ⟨hle hs,_⟩,
      change s ≠ t,
      intro c,
      rw c at hs,
      contradiction, },
    have claim2 : t ∈ cl (S' - {t}), by exact monotone claim1 h2,
    replace hindep := hindep ht,
    contradiction, },
  { rintros ⟨h1,h2⟩,
    refine ⟨by assumption,_⟩,
    by_contradiction contra,
    have : ∃ t : T, t ∉ cl S,
    { unfold is_spanning at contra,
      rw not_forall at contra,
      assumption, },
    cases this with t ht,
    replace h2 := h2 (insert t S),
    have : S ≤ insert t S, by finish,
    replace h2 := h2 this, clear this,
    have : is_indep (insert t S), by apply insert_indep; assumption,
    replace h2 := h2 @this,
    rw h2 at ht,
    have : t ∈ cl (insert t S),
    { apply inclusive,
      simp, },
    contradiction, }
end

/-- If `S` spans and `t ∈ cl (S - {t})` then `S - {t}` spans as well. -/
lemma subtract_spanning {t : T} {S : set T} : is_spanning S → t ∈ cl (S - {t}) → is_spanning (S - {t}) :=
begin
  intros spanning ht,
  unfold is_spanning,
  intro u,
  have sets : {t} ⊆ cl (S - {t}), by simpa,
  have pull_in := cl_union_eq sets,
  rw ← pull_in,
  simp,
  have hu : u ∈ cl S, by exact spanning u,
  have le : S ≤ insert t S, by
  { intros s hs,
    exact set.mem_insert_of_mem t hs, },
  apply pregeom.monotone le,
  assumption,
end

/-- A basis is a minimal spanning set. -/
theorem basis_iff_minimal_spanning {S : set T} :
  is_basis S ↔
  is_spanning S ∧ (∀ S' : set T, S' ≤ S → is_spanning S' → S = S') :=
begin
  split,
  { intro basis,
    refine ⟨ basis.2, _ ⟩,
    intros S' le spanning,
    tidy,
    by_contradiction contra,
    have remove : S' ≤ S - {x}, by exact helpers.smaller le contra,
    have smaller_spans: is_spanning (S - {x}),
    { apply super_spans remove,
      exact spanning, },
    have x_seperate: x ∉ cl (S - {x}), by
    { unfold is_indep at basis_left,
      replace basis_left := basis_left a,
      exact basis_left, },
    have x_included: x ∈ cl (S - {x}), by
    { unfold is_spanning at smaller_spans,
      replace smaller_spans := smaller_spans x,
      exact smaller_spans, },
    contradiction, },
  { intro h,
    cases h with spans inf,
    unfold is_basis,
    refine ⟨ _, spans⟩,
    unfold is_indep,
    intros x hx,
    intro contra,
    have lt : S - {x} ≤ S, by
    { intros t ht,
      finish, },
    replace inf := inf (S - {x}) lt,
    suffices : is_spanning (S - {x}), by
    { replace inf := inf this,
      have problem: ¬ S = S - {x}, by exact helpers.missing_elem S hx,
      contradiction, },
    exact subtract_spanning spans contra, }
end

-- Ignore these definitions: they are only here to help in some of the proofs.
variable (T)
private def indep_sets := { S : set T // is_indep S }
variable {T}
private def indep_sets_rel : indep_sets T → indep_sets T → Prop := λ A B, A.1 ≤ B.1
private def indep_sets_union (S : set (indep_sets T)) : set T := Sup (subtype.val '' S)

-- This proof takes a while to check! Can it be simplified?
private lemma union_chain_indep {S : set (indep_sets T)} :
  zorn.chain indep_sets_rel S → is_indep (indep_sets_union S) :=
begin
  intros zorn t ht contra,
  rcases finchar contra with ⟨A,hA1,hA2⟩,
  suffices claim : ∀ A : finset T, ↑A ≤ indep_sets_union S - {t} →
    ∃ B : indep_sets T, B ∈ S ∧ t ∈ B.val ∧ ↑A ≤ B.val,
  { replace claim := claim A hA1,
    rcases claim with ⟨⟨B,hB⟩,hB1,hB2,hB3⟩,
    dsimp at hB2 hB3,
    have : ↑A ≤ B - {t},
    { intros a ha,
      refine ⟨hB3 ha,_⟩,
      dsimp,
      change a ≠ t,
      replace ha := hA1 ha,
      finish, },
    replace hA2 := monotone this hA2,
    unfold is_indep at hB,
    replace hB := hB hB2,
    contradiction, },
  refine finset.induction _ _,
  { intro,
    rcases ht with ⟨B,⟨C,hC1,hC2⟩,h1⟩,
    use C,
    tidy, },
  { rintros a B ha ind useful,
    have : ↑B ≤ indep_sets_union S - {t},
    { intros b hb,
      apply useful,
      finish, },
    replace ind := ind this,
    rcases ind with ⟨C,hC1,hC2,hC3⟩,
    have : a ∈ indep_sets_union S - {t},
    { apply useful,
      simp, },
    rcases this with ⟨⟨D,⟨⟨E,hE1,rfl⟩,hE3⟩⟩, h3⟩,
    by_cases eq : C = E,
    { rw eq at *,
      use E,
      refine ⟨hC1,hC2,_⟩,
      tidy, },
    { cases @zorn _ hC1 _ hE1 eq,
      { use E, tidy, },
      { use C, tidy, } } }
end

/-- Any pregeometry has a basis. -/
theorem exists_basis : ∃ S : set T, is_basis S :=
begin
  have zorn := @zorn.exists_maximal_of_chains_bounded
    (indep_sets T)
    (λ A B, A.1 ≤ B.1) _ _,
  { rcases zorn with ⟨⟨B,hB1⟩,hB2⟩,
    use B,
    rw basis_iff_maximal_indep,
    refine ⟨@hB1,_⟩,
    intros S' h1 h2,
    replace hB2 := hB2 ⟨S',@h2⟩ h1,
    rw le_antisymm_iff,
    exact ⟨h1,hB2⟩, },
  { intro C,
    intro hZ,
    refine ⟨⟨Sup (subtype.val '' C),_⟩,_⟩,
    { apply union_chain_indep,
      assumption, },
    { intros,
      dsimp,
      cases a with a ha,
      dsimp at *,
      change a ≤ _,
      refine le_Sup _,
      tidy, } },
  { tidy, }
end

end basis
end pregeom


import Playlean4.Group.Basic

namespace Group

section

variable (G : Type) (law : G → G → G) [grp : Group G law] (H : Set G)

local infixl:70 " * " => id' law
@[appUnexpander id'] def subgroup.unexpandMul : Lean.PrettyPrinter.Unexpander
  | `(id' law G $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK
local notation g"⁻¹" => grp.inv g

class Subgroup where
  oneMem : one ∈ H
  mulMem : ∀ {g}, g ∈ H → ∀ {g'}, g' ∈ H → g * g' ∈ H
  invMem : ∀ {g}, g ∈ H → (g⁻¹) ∈ H

end

namespace Subgroup

variable {G : Type} (law : G → G → G) [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandGMul : Lean.PrettyPrinter.Unexpander
  | `(id' Magma.law G $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK
local notation g"⁻¹" => grp.inv g

def subgroupLaw (H : Set G) [Subgroup G law H] : H → H → H :=
  λ g g' => ⟨ (g : G) * (g' : G), mulMem g.2 g'.2 ⟩

instance GroupOfSubgroup (H : Set G) [Subgroup G law H] : Group H (subgroupLaw law H) where
  one' := ⟨ one, oneMem ⟩
  assoc := λ g g' g'' => Subtype.eq <| grp.assoc g.val g'.val g''.val
  oneNeutralRight := λ g => Subtype.eq <| grp.oneNeutralRight g.val
  invertible := λ g => ⟨ ⟨ (g.val)⁻¹, invMem g.2 ⟩, Subtype.eq <| invCancelRight (g.val : G) ⟩

section -- "variable" doesn't work here for some reason

theorem lemma₁ {H : G → Prop}
  (inhabited : ∃ g : G, g ∈ H)
  (mulInvStable : ∀ {g}, g ∈ H → ∀ {g'}, g' ∈ H → g * g'⁻¹ ∈ H) : one ∈ H :=
match inhabited with
  | ⟨ g, h ⟩ => invCancelRight g ▸ mulInvStable h h

theorem lemma₂ {H : G → Prop}
  (inhabited : ∃ g : G, g ∈ H)
  (mulInvStable : ∀ {g}, g ∈ H → ∀ {g'}, g' ∈ H → g * g'⁻¹ ∈ H) :
    ∀ {g}, g ∈ H → g⁻¹ ∈ H := λ {g} hg =>
oneNeutralLeft (g⁻¹) ▸ mulInvStable (lemma₁ law inhabited mulInvStable) hg

theorem lemma₃ {H : G → Prop}
  (inhabited : ∃ g : G, g ∈ H)
  (mulInvStable : ∀ {g : G}, g ∈ H → ∀ {g' : G}, g' ∈ H → g * g'⁻¹ ∈ H) :
    ∀ {g}, g ∈ H → ∀ {g'}, g' ∈ H → g * g' ∈ H := λ {g} hg {g'} hg' =>
invInvolutive g' ▸ mulInvStable hg (lemma₂ law inhabited mulInvStable hg')

end

instance ofInhabitedMulInvStable {H : G → Prop}
  (inhabited : ∃ g : G, g ∈ H)
  (mulInvStable : ∀ {g}, g ∈ H → ∀ {g'}, g' ∈ H → g * g'⁻¹ ∈ H) : Subgroup G law H where
  oneMem := lemma₁ law inhabited mulInvStable
  mulMem := lemma₃ law inhabited mulInvStable
  invMem := lemma₂ law inhabited mulInvStable

variable (H : Set G) [sg : Subgroup G law H]

instance opIsSubgroup : Subgroup G (lawᵒᵖ) H where
  oneMem := sg.oneMem
  mulMem := λ {g} hg {g'} hg' => sg.mulMem hg' hg
  invMem := sg.invMem

end Subgroup

end Group


example : ∀ a b c d : Nat, a = b → a = d → a = c → c = b := by
  intros
  rename_i h1 _ h2
  apply Eq.trans
  apply Eq.symm
  exact h2
  exact h1


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker, Johan Commelin
-/

import data.polynomial.basic
import data.polynomial.div
import data.polynomial.algebra_map
import data.set.finite

/-!
# Theory of univariate polynomials

This file starts looking like the ring theory of $ R[X] $

-/

noncomputable theory
local attribute [instance, priority 100] classical.prop_decidable

open finset

namespace polynomial
universes u v w z
variables {R : Type u} {S : Type v} {T : Type w} {A : Type z} {a b : R} {n : ℕ}

section comm_ring
variables [comm_ring R] {p q : polynomial R}

variables [comm_ring S]

lemma nat_degree_pos_of_aeval_root [algebra R S] {p : polynomial R} (hp : p ≠ 0)
  {z : S} (hz : aeval z p = 0) (inj : ∀ (x : R), algebra_map R S x = 0 → x = 0) :
  0 < p.nat_degree :=
nat_degree_pos_of_eval₂_root hp (algebra_map R S) hz inj

lemma degree_pos_of_aeval_root [algebra R S] {p : polynomial R} (hp : p ≠ 0)
  {z : S} (hz : aeval z p = 0) (inj : ∀ (x : R), algebra_map R S x = 0 → x = 0) :
  0 < p.degree :=
nat_degree_pos_iff_degree_pos.mp (nat_degree_pos_of_aeval_root hp hz inj)

lemma aeval_mod_by_monic_eq_self_of_root [algebra R S]
  {p q : polynomial R} (hq : q.monic) {x : S} (hx : aeval x q = 0) :
  aeval x (p %ₘ q) = aeval x p :=
eval₂_mod_by_monic_eq_self_of_root hq hx

end comm_ring

section no_zero_divisors
variables [comm_ring R] [no_zero_divisors R] {p q : polynomial R}

instance : no_zero_divisors (polynomial R) :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b h, begin
    rw [← leading_coeff_eq_zero, ← leading_coeff_eq_zero],
    refine eq_zero_or_eq_zero_of_mul_eq_zero _,
    rw [← leading_coeff_zero, ← leading_coeff_mul, h],
  end }

lemma nat_degree_mul (hp : p ≠ 0) (hq : q ≠ 0) : nat_degree (p * q) =
  nat_degree p + nat_degree q :=
by rw [← with_bot.coe_eq_coe, ← degree_eq_nat_degree (mul_ne_zero hp hq),
    with_bot.coe_add, ← degree_eq_nat_degree hp,
    ← degree_eq_nat_degree hq, degree_mul]

@[simp] lemma nat_degree_pow (p : polynomial R) (n : ℕ) :
  nat_degree (p ^ n) = n * nat_degree p :=
if hp0 : p = 0
then if hn0 : n = 0 then by simp [hp0, hn0]
  else by rw [hp0, zero_pow (nat.pos_of_ne_zero hn0)]; simp
else nat_degree_pow'
  (by rw [← leading_coeff_pow, ne.def, leading_coeff_eq_zero]; exact pow_ne_zero _ hp0)

lemma root_mul : is_root (p * q) a ↔ is_root p a ∨ is_root q a :=
by simp_rw [is_root, eval_mul, mul_eq_zero]

lemma root_or_root_of_root_mul (h : is_root (p * q) a) : is_root p a ∨ is_root q a :=
root_mul.1 h

lemma degree_le_mul_left (p : polynomial R) (hq : q ≠ 0) : degree p ≤ degree (p * q) :=
if hp : p = 0 then by simp only [hp, zero_mul, le_refl]
else by rw [degree_mul, degree_eq_nat_degree hp,
    degree_eq_nat_degree hq];
  exact with_bot.coe_le_coe.2 (nat.le_add_right _ _)

theorem nat_degree_le_of_dvd {p q : polynomial R} (h1 : p ∣ q) (h2 : q ≠ 0) :
  p.nat_degree ≤ q.nat_degree :=
begin
  rcases h1 with ⟨q, rfl⟩, rw mul_ne_zero_iff at h2,
  rw [nat_degree_mul h2.1 h2.2], exact nat.le_add_right _ _
end

end no_zero_divisors

section integral_domain
variables [integral_domain R] {p q : polynomial R}

instance : integral_domain (polynomial R) :=
{ ..polynomial.no_zero_divisors,
  ..polynomial.nontrivial,
  ..polynomial.comm_ring }

lemma nat_trailing_degree_mul (hp : p ≠ 0) (hq : q ≠ 0) :
  (p * q).nat_trailing_degree = p.nat_trailing_degree + q.nat_trailing_degree :=
begin
  simp only [←nat.sub_eq_of_eq_add (nat_degree_eq_reverse_nat_degree_add_nat_trailing_degree _)],
  rw [reverse_mul_of_domain, nat_degree_mul hp hq, nat_degree_mul (mt reverse_eq_zero.mp hp)
    (mt reverse_eq_zero.mp hq), reverse_nat_degree, reverse_nat_degree, ←nat.sub_sub, nat.add_comm,
    nat.add_sub_assoc (nat.sub_le _ _), add_comm, nat.add_sub_assoc (nat.sub_le _ _)],
end

section roots

open multiset

local attribute [reducible] with_zero

lemma degree_eq_zero_of_is_unit (h : is_unit p) : degree p = 0 :=
let ⟨q, hq⟩ := is_unit_iff_dvd_one.1 h in
have hp0 : p ≠ 0, from λ hp0, by simpa [hp0] using hq,
have hq0 : q ≠ 0, from λ hp0, by simpa [hp0] using hq,
have nat_degree (1 : polynomial R) = nat_degree (p * q),
  from congr_arg _ hq,
by rw [nat_degree_one, nat_degree_mul hp0 hq0, eq_comm,
    _root_.add_eq_zero_iff, ← with_bot.coe_eq_coe,
    ← degree_eq_nat_degree hp0] at this;
  exact this.1

@[simp] lemma degree_coe_units (u : units (polynomial R)) :
  degree (u : polynomial R) = 0 :=
degree_eq_zero_of_is_unit ⟨u, rfl⟩

theorem prime_X_sub_C {r : R} : prime (X - C r) :=
⟨X_sub_C_ne_zero r, not_is_unit_X_sub_C,
 λ _ _, by { simp_rw [dvd_iff_is_root, is_root.def, eval_mul, mul_eq_zero], exact id }⟩

theorem prime_X : prime (X : polynomial R) :=
by { convert (prime_X_sub_C : prime (X - C 0 : polynomial R)), simp }

lemma prime_of_degree_eq_one_of_monic (hp1 : degree p = 1)
  (hm : monic p) : prime p :=
have p = X - C (- p.coeff 0),
  by simpa [hm.leading_coeff] using eq_X_add_C_of_degree_eq_one hp1,
this.symm ▸ prime_X_sub_C

theorem irreducible_X_sub_C (r : R) : irreducible (X - C r) :=
irreducible_of_prime prime_X_sub_C

theorem irreducible_X : irreducible (X : polynomial R) :=
irreducible_of_prime prime_X

lemma irreducible_of_degree_eq_one_of_monic (hp1 : degree p = 1)
  (hm : monic p) : irreducible p :=
irreducible_of_prime (prime_of_degree_eq_one_of_monic hp1 hm)

theorem eq_of_monic_of_associated (hp : p.monic) (hq : q.monic) (hpq : associated p q) : p = q :=
begin
  obtain ⟨u, hu⟩ := hpq,
  unfold monic at hp hq,
  rw eq_C_of_degree_le_zero (le_of_eq $ degree_coe_units _) at hu,
  rw [← hu, leading_coeff_mul, hp, one_mul, leading_coeff_C] at hq,
  rwa [hq, C_1, mul_one] at hu
end

@[simp] lemma root_multiplicity_zero {x : R} : root_multiplicity x 0 = 0 := dif_pos rfl

lemma root_multiplicity_eq_zero {p : polynomial R} {x : R} (h : ¬ is_root p x) :
  root_multiplicity x p = 0 :=
begin
  rw root_multiplicity_eq_multiplicity,
  split_ifs, { refl },
  rw [← enat.coe_inj, enat.coe_get, multiplicity.multiplicity_eq_zero_of_not_dvd, enat.coe_zero],
  intro hdvd,
  exact h (dvd_iff_is_root.mp hdvd)
end

lemma root_multiplicity_pos {p : polynomial R} (hp : p ≠ 0) {x : R} :
  0 < root_multiplicity x p ↔ is_root p x :=
begin
  rw [← dvd_iff_is_root, root_multiplicity_eq_multiplicity, dif_neg hp,
      ← enat.coe_lt_coe, enat.coe_get],
  exact multiplicity.dvd_iff_multiplicity_pos
end

lemma root_multiplicity_mul {p q : polynomial R} {x : R} (hpq : p * q ≠ 0) :
  root_multiplicity x (p * q) = root_multiplicity x p + root_multiplicity x q :=
begin
  have hp : p ≠ 0 := left_ne_zero_of_mul hpq,
  have hq : q ≠ 0 := right_ne_zero_of_mul hpq,
  rw [root_multiplicity_eq_multiplicity (p * q), dif_neg hpq,
      root_multiplicity_eq_multiplicity p, dif_neg hp,
      root_multiplicity_eq_multiplicity q, dif_neg hq,
      @multiplicity.mul' _ _ _ (X - C x) _ _ prime_X_sub_C],
end

lemma root_multiplicity_X_sub_C_self {x : R} :
  root_multiplicity x (X - C x) = 1 :=
by rw [root_multiplicity_eq_multiplicity, dif_neg (X_sub_C_ne_zero x),
       multiplicity.get_multiplicity_self]

lemma root_multiplicity_X_sub_C {x y : R} :
  root_multiplicity x (X - C y) = if x = y then 1 else 0 :=
begin
  split_ifs with hxy,
  { rw hxy,
    exact root_multiplicity_X_sub_C_self },
  exact root_multiplicity_eq_zero (mt root_X_sub_C.mp (ne.symm hxy))
end

/-- The multiplicity of `a` as root of `(X - a) ^ n` is `n`. -/
lemma root_multiplicity_X_sub_C_pow (a : R) (n : ℕ) : root_multiplicity a ((X - C a) ^ n) = n :=
begin
  induction n with n hn,
  { refine root_multiplicity_eq_zero _,
    simp only [eval_one, is_root.def, not_false_iff, one_ne_zero, pow_zero] },
  have hzero :=  (ne_zero_of_monic (monic_pow (monic_X_sub_C a) n.succ)),
  rw pow_succ (X - C a) n at hzero ⊢,
  simp only [root_multiplicity_mul hzero, root_multiplicity_X_sub_C_self, hn, nat.one_add]
end

/-- If `(X - a) ^ n` divides a polynomial `p` then the multiplicity of `a` as root of `p` is at
least `n`. -/
lemma root_multiplicity_of_dvd {p : polynomial R} {a : R} {n : ℕ}
  (hzero : p ≠ 0) (h : (X - C a) ^ n ∣ p) : n ≤ root_multiplicity a p :=
begin
  obtain ⟨q, hq⟩ := exists_eq_mul_right_of_dvd h,
  rw hq at hzero,
  simp only [hq, root_multiplicity_mul hzero, root_multiplicity_X_sub_C_pow,
             ge_iff_le, _root_.zero_le, le_add_iff_nonneg_right],
end

/-- The multiplicity of `p + q` is at least the minimum of the multiplicities. -/
lemma root_multiplicity_add {p q : polynomial R} (a : R) (hzero : p + q ≠ 0) :
  min (root_multiplicity a p) (root_multiplicity a q) ≤ root_multiplicity a (p + q) :=
begin
  refine root_multiplicity_of_dvd hzero _,
  have hdivp : (X - C a) ^ root_multiplicity a p ∣ p := pow_root_multiplicity_dvd p a,
  have hdivq : (X - C a) ^ root_multiplicity a q ∣ q := pow_root_multiplicity_dvd q a,
  exact min_pow_dvd_add hdivp hdivq
end

lemma exists_multiset_roots : ∀ {p : polynomial R} (hp : p ≠ 0),
  ∃ s : multiset R, (s.card : with_bot ℕ) ≤ degree p ∧ ∀ a, s.count a = root_multiplicity a p
| p := λ hp, by haveI := classical.prop_decidable (∃ x, is_root p x); exact
if h : ∃ x, is_root p x
then
  let ⟨x, hx⟩ := h in
  have hpd : 0 < degree p := degree_pos_of_root hp hx,
  have hd0 : p /ₘ (X - C x) ≠ 0 :=
    λ h, by rw [← mul_div_by_monic_eq_iff_is_root.2 hx, h, mul_zero] at hp; exact hp rfl,
  have wf : degree (p /ₘ _) < degree p :=
    degree_div_by_monic_lt _ (monic_X_sub_C x) hp
    ((degree_X_sub_C x).symm ▸ dec_trivial),
  let ⟨t, htd, htr⟩ := @exists_multiset_roots (p /ₘ (X - C x)) hd0 in
  have hdeg : degree (X - C x) ≤ degree p := begin
    rw [degree_X_sub_C, degree_eq_nat_degree hp],
    rw degree_eq_nat_degree hp at hpd,
    exact with_bot.coe_le_coe.2 (with_bot.coe_lt_coe.1 hpd)
  end,
  have hdiv0 : p /ₘ (X - C x) ≠ 0 := mt (div_by_monic_eq_zero_iff (monic_X_sub_C x)
    (ne_zero_of_monic (monic_X_sub_C x))).1 $ not_lt.2 hdeg,
  ⟨x ::ₘ t, calc (card (x ::ₘ t) : with_bot ℕ) = t.card + 1 :
      by exact_mod_cast card_cons _ _
    ... ≤ degree p :
      by rw [← degree_add_div_by_monic (monic_X_sub_C x) hdeg,
          degree_X_sub_C, add_comm];
        exact add_le_add (le_refl (1 : with_bot ℕ)) htd,
  begin
    assume a,
    conv_rhs { rw ← mul_div_by_monic_eq_iff_is_root.mpr hx },
    rw [root_multiplicity_mul (mul_ne_zero (X_sub_C_ne_zero _) hdiv0),
        root_multiplicity_X_sub_C, ← htr a],
    split_ifs with ha,
    { rw [ha, count_cons_self, nat.succ_eq_add_one, add_comm] },
    { rw [count_cons_of_ne ha, zero_add] },
  end⟩
else
  ⟨0, (degree_eq_nat_degree hp).symm ▸ with_bot.coe_le_coe.2 (nat.zero_le _),
    by { intro a, rw [count_zero, root_multiplicity_eq_zero (not_exists.mp h a)] }⟩
using_well_founded {dec_tac := tactic.assumption}

/-- `roots p` noncomputably gives a multiset containing all the roots of `p`,
including their multiplicities. -/
noncomputable def roots (p : polynomial R) : multiset R :=
if h : p = 0 then ∅ else classical.some (exists_multiset_roots h)

@[simp] lemma roots_zero : (0 : polynomial R).roots = 0 :=
dif_pos rfl

lemma card_roots (hp0 : p ≠ 0) : ((roots p).card : with_bot ℕ) ≤ degree p :=
begin
  unfold roots,
  rw dif_neg hp0,
  exact (classical.some_spec (exists_multiset_roots hp0)).1
end

lemma card_roots' {p : polynomial R} (hp0 : p ≠ 0) : p.roots.card ≤ nat_degree p :=
with_bot.coe_le_coe.1 (le_trans (card_roots hp0) (le_of_eq $ degree_eq_nat_degree hp0))

lemma card_roots_sub_C {p : polynomial R} {a : R} (hp0 : 0 < degree p) :
  ((p - C a).roots.card : with_bot ℕ) ≤ degree p :=
calc ((p - C a).roots.card : with_bot ℕ) ≤ degree (p - C a) :
  card_roots $ mt sub_eq_zero.1 $ λ h, not_le_of_gt hp0 $ h.symm ▸ degree_C_le
... = degree p : by rw [sub_eq_add_neg, ← C_neg]; exact degree_add_C hp0

lemma card_roots_sub_C' {p : polynomial R} {a : R} (hp0 : 0 < degree p) :
  (p - C a).roots.card ≤ nat_degree p :=
with_bot.coe_le_coe.1 (le_trans (card_roots_sub_C hp0) (le_of_eq $ degree_eq_nat_degree
  (λ h, by simp [*, lt_irrefl] at *)))

@[simp] lemma count_roots (hp : p ≠ 0) : p.roots.count a = root_multiplicity a p :=
by { rw [roots, dif_neg hp], exact (classical.some_spec (exists_multiset_roots hp)).2 a }

@[simp] lemma mem_roots (hp : p ≠ 0) : a ∈ p.roots ↔ is_root p a :=
by rw [← count_pos, count_roots hp, root_multiplicity_pos hp]

lemma eq_zero_of_infinite_is_root
  (p : polynomial R) (h : set.infinite {x | is_root p x}) : p = 0 :=
begin
  by_contradiction hp,
  apply h,
  convert p.roots.to_finset.finite_to_set using 1,
  ext1 r,
  simp only [mem_roots hp, multiset.mem_to_finset, set.mem_set_of_eq, finset.mem_coe]
end

lemma exists_max_root [linear_order R] (p : polynomial R) (hp : p ≠ 0) :
  ∃ x₀, ∀ x, p.is_root x → x ≤ x₀ :=
set.exists_upper_bound_image _ _ $ not_not.mp (mt (eq_zero_of_infinite_is_root p) hp)

lemma exists_min_root [linear_order R] (p : polynomial R) (hp : p ≠ 0) :
  ∃ x₀, ∀ x, p.is_root x → x₀ ≤ x :=
set.exists_lower_bound_image _ _ $ not_not.mp (mt (eq_zero_of_infinite_is_root p) hp)

lemma eq_of_infinite_eval_eq {R : Type*} [integral_domain R]
  (p q : polynomial R) (h : set.infinite {x | eval x p = eval x q}) : p = q :=
begin
  rw [← sub_eq_zero],
  apply eq_zero_of_infinite_is_root,
  simpa only [is_root, eval_sub, sub_eq_zero]
end

lemma roots_mul {p q : polynomial R} (hpq : p * q ≠ 0) : (p * q).roots = p.roots + q.roots :=
multiset.ext.mpr $ λ r,
  by rw [count_add, count_roots hpq, count_roots (left_ne_zero_of_mul hpq),
         count_roots (right_ne_zero_of_mul hpq), root_multiplicity_mul hpq]

@[simp] lemma mem_roots_sub_C {p : polynomial R} {a x : R} (hp0 : 0 < degree p) :
  x ∈ (p - C a).roots ↔ p.eval x = a :=
(mem_roots (show p - C a ≠ 0, from mt sub_eq_zero.1 $ λ h,
    not_le_of_gt hp0 $ h.symm ▸ degree_C_le)).trans
  (by rw [is_root.def, eval_sub, eval_C, sub_eq_zero])

@[simp] lemma roots_X_sub_C (r : R) : roots (X - C r) = r ::ₘ 0 :=
begin
  ext s,
  rw [count_roots (X_sub_C_ne_zero r), root_multiplicity_X_sub_C],
  split_ifs with h,
  { rw [h, count_singleton] },
  { rw [count_cons_of_ne h, count_zero] }
end

@[simp] lemma roots_C (x : R) : (C x).roots = 0 :=
if H : x = 0 then by rw [H, C_0, roots_zero] else multiset.ext.mpr $ λ r,
have h : C x ≠ 0, from λ h, H $ C_inj.1 $ h.symm ▸ C_0.symm,
have not_root : ¬ is_root (C x) r := mt (λ (h : eval r (C x) = 0), trans eval_C.symm h) H,
by rw [count_roots h, count_zero, root_multiplicity_eq_zero not_root]

@[simp] lemma roots_one : (1 : polynomial R).roots = ∅ :=
roots_C 1

lemma roots_list_prod (L : list (polynomial R)) :
  ((0 : polynomial R) ∉ L) → L.prod.roots = (L : multiset (polynomial R)).bind roots :=
list.rec_on L (λ _, roots_one) $ λ hd tl ih H,
begin
  rw [list.mem_cons_iff, not_or_distrib] at H,
  rw [list.prod_cons, roots_mul (mul_ne_zero (ne.symm H.1) $ list.prod_ne_zero H.2),
      ← multiset.cons_coe, multiset.cons_bind, ih H.2]
end

lemma roots_multiset_prod (m : multiset (polynomial R)) :
  (0 : polynomial R) ∉ m → m.prod.roots = m.bind roots :=
by { rcases m with ⟨L⟩, simpa only [coe_prod, quot_mk_to_coe''] using roots_list_prod L }

lemma roots_prod {ι : Type*} (f : ι → polynomial R) (s : finset ι) :
  s.prod f ≠ 0 → (s.prod f).roots = s.val.bind (λ i, roots (f i)) :=
begin
  rcases s with ⟨m, hm⟩,
  simpa [multiset.prod_eq_zero_iff, bind_map] using roots_multiset_prod (m.map f)
end

lemma roots_prod_X_sub_C (s : finset R) :
  (s.prod (λ a, X - C a)).roots = s.val :=
(roots_prod (λ a, X - C a) s (prod_ne_zero_iff.mpr (λ a _, X_sub_C_ne_zero a))).trans
  (by simp_rw [roots_X_sub_C, bind_cons, bind_zero, add_zero, multiset.map_id'])

lemma card_roots_X_pow_sub_C {n : ℕ} (hn : 0 < n) (a : R) :
  (roots ((X : polynomial R) ^ n - C a)).card ≤ n :=
with_bot.coe_le_coe.1 $
calc ((roots ((X : polynomial R) ^ n - C a)).card : with_bot ℕ)
      ≤ degree ((X : polynomial R) ^ n - C a) : card_roots (X_pow_sub_C_ne_zero hn a)
  ... = n : degree_X_pow_sub_C hn a

section nth_roots

/-- `nth_roots n a` noncomputably returns the solutions to `x ^ n = a`-/
def nth_roots (n : ℕ) (a : R) : multiset R :=
roots ((X : polynomial R) ^ n - C a)

@[simp] lemma mem_nth_roots {n : ℕ} (hn : 0 < n) {a x : R} :
  x ∈ nth_roots n a ↔ x ^ n = a :=
by rw [nth_roots, mem_roots (X_pow_sub_C_ne_zero hn a),
  is_root.def, eval_sub, eval_C, eval_pow, eval_X, sub_eq_zero]

@[simp] lemma nth_roots_zero (r : R) : nth_roots 0 r = 0 :=
by simp only [empty_eq_zero, pow_zero, nth_roots, ← C_1, ← C_sub, roots_C]

lemma card_nth_roots (n : ℕ) (a : R) :
  (nth_roots n a).card ≤ n :=
if hn : n = 0
then if h : (X : polynomial R) ^ n - C a = 0
  then by simp only [nat.zero_le, nth_roots, roots, h, dif_pos rfl, empty_eq_zero, card_zero]
  else with_bot.coe_le_coe.1 (le_trans (card_roots h)
   (by rw [hn, pow_zero, ← C_1, ← @is_ring_hom.map_sub _ _ _ _ (@C R _)];
      exact degree_C_le))
else by rw [← with_bot.coe_le_coe, ← degree_X_pow_sub_C (nat.pos_of_ne_zero hn) a];
  exact card_roots (X_pow_sub_C_ne_zero (nat.pos_of_ne_zero hn) a)

/-- The multiset `nth_roots ↑n (1 : R)` as a finset. -/
def nth_roots_finset (n : ℕ) (R : Type*) [integral_domain R] : finset R :=
multiset.to_finset (nth_roots n (1 : R))

@[simp] lemma mem_nth_roots_finset {n : ℕ} (h : 0 < n) {x : R} :
  x ∈ nth_roots_finset n R ↔ x ^ (n : ℕ) = 1 :=
by rw [nth_roots_finset, mem_to_finset, mem_nth_roots h]

end nth_roots

lemma coeff_comp_degree_mul_degree (hqd0 : nat_degree q ≠ 0) :
  coeff (p.comp q) (nat_degree p * nat_degree q) =
  leading_coeff p * leading_coeff q ^ nat_degree p :=
if hp0 : p = 0 then by simp [hp0] else
calc coeff (p.comp q) (nat_degree p * nat_degree q)
  = p.sum (λ n a, coeff (C a * q ^ n) (nat_degree p * nat_degree q)) :
    by rw [comp, eval₂, coeff_sum]
... = coeff (C (leading_coeff p) * q ^ nat_degree p) (nat_degree p * nat_degree q) :
  finset.sum_eq_single _
  begin
    assume b hbs hbp,
    have hq0 : q ≠ 0, from λ hq0, hqd0 (by rw [hq0, nat_degree_zero]),
    have : coeff p b ≠ 0,  by rwa finsupp.mem_support_iff at hbs,
    refine coeff_eq_zero_of_degree_lt _,
    erw [degree_mul, degree_C this, degree_pow, zero_add, degree_eq_nat_degree hq0,
      ← with_bot.coe_nsmul, nsmul_eq_mul, with_bot.coe_lt_coe, nat.cast_id,
      mul_lt_mul_right (pos_iff_ne_zero.mpr hqd0)],
    exact lt_of_le_of_ne (le_nat_degree_of_ne_zero this) hbp,
  end
  begin
    intro h, contrapose! hp0,
    rw finsupp.mem_support_iff at h, push_neg at h,
    rwa ← leading_coeff_eq_zero,
  end
... = _ :
  have coeff (q ^ nat_degree p) (nat_degree p * nat_degree q) = leading_coeff (q ^ nat_degree p),
    by rw [leading_coeff, nat_degree_pow],
  by rw [coeff_C_mul, this, leading_coeff_pow]

lemma nat_degree_comp : nat_degree (p.comp q) = nat_degree p * nat_degree q :=
le_antisymm nat_degree_comp_le
  (if hp0 : p = 0 then by rw [hp0, zero_comp, nat_degree_zero, zero_mul]
  else if hqd0 : nat_degree q = 0
  then have degree q ≤ 0, by rw [← with_bot.coe_zero, ← hqd0]; exact degree_le_nat_degree,
    by rw [eq_C_of_degree_le_zero this]; simp
  else le_nat_degree_of_ne_zero $
    have hq0 : q ≠ 0, from λ hq0, hqd0 $ by rw [hq0, nat_degree_zero],
    calc coeff (p.comp q) (nat_degree p * nat_degree q)
        = leading_coeff p * leading_coeff q ^ nat_degree p :
      coeff_comp_degree_mul_degree hqd0
    ... ≠ 0 : mul_ne_zero (mt leading_coeff_eq_zero.1 hp0)
      (pow_ne_zero _ (mt leading_coeff_eq_zero.1 hq0)))

lemma leading_coeff_comp (hq : nat_degree q ≠ 0) : leading_coeff (p.comp q) =
  leading_coeff p * leading_coeff q ^ nat_degree p :=
by rw [← coeff_comp_degree_mul_degree hq, ← nat_degree_comp]; refl

@[simp] lemma nat_degree_coe_units (u : units (polynomial R)) :
  nat_degree (u : polynomial R) = 0 :=
nat_degree_eq_of_degree_eq_some (degree_coe_units u)

lemma comp_eq_zero_iff :
  p.comp q = 0 ↔ p = 0 ∨ (p.eval (q.coeff 0) = 0 ∧ q = C (q.coeff 0)) :=
begin
  split,
  { intro h,
    have key : p.nat_degree = 0 ∨ q.nat_degree = 0,
    { rw [←mul_eq_zero, ←nat_degree_comp, h, nat_degree_zero] },
    replace key := or.imp eq_C_of_nat_degree_eq_zero eq_C_of_nat_degree_eq_zero key,
    cases key,
    { rw [key, C_comp] at h,
      exact or.inl (key.trans h) },
    { rw [key, comp_C, C_eq_zero] at h,
      exact or.inr ⟨h, key⟩ }, },
  { exact λ h, or.rec (λ h, by rw [h, zero_comp]) (λ h, by rw [h.2, comp_C, h.1, C_0]) h },
end

lemma zero_of_eval_zero [infinite R] (p : polynomial R) (h : ∀ x, p.eval x = 0) : p = 0 :=
by classical; by_contradiction hp; exact
infinite.not_fintype ⟨p.roots.to_finset, λ x, multiset.mem_to_finset.mpr ((mem_roots hp).mpr (h _))⟩

lemma funext [infinite R] {p q : polynomial R} (ext : ∀ r : R, p.eval r = q.eval r) : p = q :=
begin
  rw ← sub_eq_zero,
  apply zero_of_eval_zero,
  intro x,
  rw [eval_sub, sub_eq_zero, ext],
end

/-- The set of distinct roots of `p` in `E`.

If you have a non-separable polynomial, use `polynomial.roots` for the multiset
where multiple roots have the appropriate multiplicity. -/
def root_set (p : polynomial R) (S) [integral_domain S] [algebra R S] : set S :=
(p.map (algebra_map R S)).roots.to_finset

lemma root_set_def (p : polynomial R) (S) [integral_domain S] [algebra R S] :
  p.root_set S = (p.map (algebra_map R S)).roots.to_finset :=
rfl

@[simp] lemma root_set_zero (S) [integral_domain S] [algebra R S] :
  (0 : polynomial R).root_set S = ∅ :=
by rw [root_set_def, polynomial.map_zero, roots_zero, to_finset_zero, finset.coe_empty]

instance root_set_fintype {R : Type*} [integral_domain R] (p : polynomial R) (S : Type*)
  [integral_domain S] [algebra R S] : fintype (p.root_set S) :=
finset_coe.fintype _

lemma root_set_finite {R : Type*} [integral_domain R] (p : polynomial R) (S : Type*)
  [integral_domain S] [algebra R S] : (p.root_set S).finite :=
⟨polynomial.root_set_fintype p S⟩

end roots

theorem is_unit_iff {f : polynomial R} : is_unit f ↔ ∃ r : R, is_unit r ∧ C r = f :=
⟨λ hf, ⟨f.coeff 0,
  is_unit_C.1 $ eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit hf) ▸ hf,
  (eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit hf)).symm⟩,
λ ⟨r, hr, hrf⟩, hrf ▸ is_unit_C.2 hr⟩

lemma coeff_coe_units_zero_ne_zero (u : units (polynomial R)) :
  coeff (u : polynomial R) 0 ≠ 0 :=
begin
  conv in (0) {rw [← nat_degree_coe_units u]},
  rw [← leading_coeff, ne.def, leading_coeff_eq_zero],
  exact units.ne_zero _
end

lemma degree_eq_degree_of_associated (h : associated p q) : degree p = degree q :=
let ⟨u, hu⟩ := h in by simp [hu.symm]

lemma degree_eq_one_of_irreducible_of_root (hi : irreducible p) {x : R} (hx : is_root p x) :
  degree p = 1 :=
let ⟨g, hg⟩ := dvd_iff_is_root.2 hx in
have is_unit (X - C x) ∨ is_unit g, from hi.is_unit_or_is_unit hg,
this.elim
  (λ h, have h₁ : degree (X - C x) = 1, from degree_X_sub_C x,
    have h₂ : degree (X - C x) = 0, from degree_eq_zero_of_is_unit h,
    by rw h₁ at h₂; exact absurd h₂ dec_trivial)
  (λ hgu, by rw [hg, degree_mul, degree_X_sub_C, degree_eq_zero_of_is_unit hgu, add_zero])

/-- Division by a monic polynomial doesn't change the leading coefficient. -/
lemma leading_coeff_div_by_monic_of_monic {R : Type u} [integral_domain R] {p q : polynomial R}
  (hmonic : q.monic) (hdegree : q.degree ≤ p.degree) : (p /ₘ q).leading_coeff = p.leading_coeff :=
begin
  have hp := mod_by_monic_add_div p hmonic,
  have hzero : (p /ₘ q) ≠ 0,
  { intro h,
    exact not_lt_of_le hdegree ((div_by_monic_eq_zero_iff hmonic (monic.ne_zero hmonic)).1 h) },
  have deglt : (p %ₘ q).degree < (q * (p /ₘ q)).degree,
  { rw degree_mul,
    refine lt_of_lt_of_le (degree_mod_by_monic_lt p hmonic (monic.ne_zero hmonic)) _,
    rw [degree_eq_nat_degree (monic.ne_zero hmonic), degree_eq_nat_degree hzero],
    norm_cast,
    simp only [zero_le, le_add_iff_nonneg_right] },
  have hrew := (leading_coeff_add_of_degree_lt deglt),
  rw leading_coeff_mul q (p /ₘ q) at hrew,
  simp only [hmonic, one_mul, monic.leading_coeff] at hrew,
  nth_rewrite 1 ← hp,
  exact hrew.symm
end

lemma eq_of_monic_of_dvd_of_nat_degree_le (hp : p.monic) (hq : q.monic) (hdiv : p ∣ q)
  (hdeg : q.nat_degree ≤ p.nat_degree) : q = p :=
begin
  obtain ⟨r, hr⟩ := hdiv,
  have rzero : r ≠ 0,
  { intro h,
    simpa [h, monic.ne_zero hq] using hr },
  rw [hr, nat_degree_mul (monic.ne_zero hp) rzero] at hdeg,
  have hdegeq : p.nat_degree + r.nat_degree = p.nat_degree,
  { suffices hdegle : p.nat_degree ≤ p.nat_degree + r.nat_degree,
    { exact le_antisymm hdeg hdegle },
    exact nat.le.intro rfl },
  replace hdegeq := eq_C_of_nat_degree_eq_zero (((@add_right_inj _ _ p.nat_degree) _ 0).1 hdegeq),
  suffices hlead : 1 = r.leading_coeff,
  { have hcoeff := leading_coeff_C (r.coeff 0),
    rw [← hdegeq, ← hlead] at hcoeff,
    rw [← hcoeff, C_1] at hdegeq,
    rwa [hdegeq, mul_one] at hr },
  have hprod : q.leading_coeff = p.leading_coeff * r.leading_coeff,
  { simp only [hr, leading_coeff_mul] },
  rwa [monic.leading_coeff hp, monic.leading_coeff hq, one_mul] at hprod
end

end integral_domain

section

variables [semiring R] [integral_domain S] (φ : R →+* S)

lemma is_unit_of_is_unit_leading_coeff_of_is_unit_map
  (f : polynomial R) (hf : is_unit (leading_coeff f)) (H : is_unit (map φ f)) :
  is_unit f :=
begin
  have dz := degree_eq_zero_of_is_unit H,
  rw degree_map_eq_of_leading_coeff_ne_zero at dz,
  { rw eq_C_of_degree_eq_zero dz,
    apply is_unit.map',
    convert hf,
    rw (degree_eq_iff_nat_degree_eq _).1 dz,
    rintro rfl,
    simpa using H, },
  { intro h,
    have u : is_unit (φ f.leading_coeff) := is_unit.map' _ hf,
    rw h at u,
    simpa using u, }
end

end

section
variables [integral_domain R] [integral_domain S] (φ : R →+* S)
/--
A polynomial over an integral domain `R` is irreducible if it is monic and
  irreducible after mapping into an integral domain `S`.

A special case of this lemma is that a polynomial over `ℤ` is irreducible if
  it is monic and irreducible over `ℤ/pℤ` for some prime `p`.
-/
lemma monic.irreducible_of_irreducible_map (f : polynomial R)
  (h_mon : monic f) (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  fsplit,
  { intro h,
    exact h_irr.not_unit (is_unit.map (monoid_hom.of (map φ)) h), },
  { intros a b h,

    have q := (leading_coeff_mul a b).symm,
    rw ←h at q,
    dsimp [monic] at h_mon,
    rw h_mon at q,
    have au : is_unit a.leading_coeff := is_unit_of_mul_eq_one _ _ q,
    rw mul_comm at q,
    have bu : is_unit b.leading_coeff := is_unit_of_mul_eq_one _ _ q,
    clear q h_mon,

    have h' := congr_arg (map φ) h,
    simp only [map_mul] at h',
    cases h_irr.is_unit_or_is_unit h' with w w,
    { left,
      exact is_unit_of_is_unit_leading_coeff_of_is_unit_map _ _ au w, },
    { right,
      exact is_unit_of_is_unit_leading_coeff_of_is_unit_map _ _ bu w, }, }
end

end

end polynomial

namespace is_integral_domain

variables {R : Type*} [comm_ring R]

/-- Lift evidence that `is_integral_domain R` to `is_integral_domain (polynomial R)`. -/
lemma polynomial (h : is_integral_domain R) : is_integral_domain (polynomial R) :=
@integral_domain.to_is_integral_domain _ (@polynomial.integral_domain _ (h.to_integral_domain _))

end is_integral_domain


import tactic
-- the next two lines let us use the law of the excluded middle without trouble
noncomputable theory
open_locale classical

--BEGIN--

/--------------------------------------------------------------------------

Delete the ``sorry,`` below and replace them with a legitimate proof.

--------------------------------------------------------------------------/

-- camper is a type.
-- If x : camper then x is a camper in the main lounge.
-- singing(x) is inhabited if x is singing

theorem math_campers_singing_paradox
  (camper : Type)
  (singing : camper → Prop)
  (alice : camper) -- making sure that there is at least one camper in the lounge
  : ∃ x : camper, (singing x → (∀ y : camper, singing y)) :=
begin
  sorry,
end
--END--


instance {α : Type u} : HAppend (Fin m → α) (Fin n → α) (Fin (m + n) → α) where
  hAppend a b i := if h : i < m then a ⟨i, h⟩ else b ⟨i - m, sorry⟩

def empty : Fin 0 → Nat := (nomatch ·)

theorem append_empty (x : Fin i → Nat) : x ++ empty = x :=
  funext fun i => dif_pos _

opaque f : (Fin 0 → Nat) → Prop
example : f (empty ++ empty) = f empty := by simp only [append_empty] -- should work

@[congr] theorem Array.get_congr (as bs : Array α) (h : as = bs) (i : Fin as.size) (j : Nat) (hi : i = j) :
    as.get i = bs.get ⟨j, h ▸ hi ▸ i.2⟩ := by
  subst bs; subst j; rfl

example (as : Array Nat) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ = as.get ⟨x, Nat.zero_add x ▸ h⟩ := by
  simp -- should work

example (as : Array (Nat → Nat)) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ i = as.get ⟨x, Nat.zero_add x ▸ h⟩ i := by
  simp -- should also work

example (as : Array (Nat → Nat)) (h : 0 + x < as.size) :
    as.get ⟨0 + x, h⟩ i = as.get ⟨x, Nat.zero_add x ▸ h⟩ (0+i) := by
  simp -- should also work

example [Decidable p] : decide (p ∧ True) = decide p := by simp -- should work

def Pi.single [DecidableEq ι] {f : ι → Type u} [∀ i, Inhabited (f i)] (i : ι) (x : f i) : ∀ i, f i :=
  fun j => if h : j = i then h ▸ x else default

structure Set (α : Type u) where of :: mem : α → Prop

instance : CoeSort (Set α) (Type u) where coe s := Subtype s.mem

@[congr]
theorem dep_congr [DecidableEq ι] {p : ι → Set α} [∀ i, Inhabited (p i)] :
    ∀ {i j} (h : i = j) (x : p i) (y : α) (hx : x = y), Pi.single (f := (p ·)) i x = Pi.single (f := (p ·)) j ⟨y, hx ▸ h ▸ x.2⟩
  | _, _, rfl, _, _, rfl => rfl

theorem aux {p : Nat → Set Nat} {i j y : Nat} (x : p j) (h₁ : x = y) (h₂ : i = j) : Set.mem (p i) y := by
  have := x.2
  subst h₁ h₂
  assumption

example {p : Nat → Set Nat} [∀ i, Inhabited (p i)] (i : Nat) (x : p (0 + i)) (y : Nat) : Pi.single (f := (p ·)) (0 + i) x = Pi.single (f := (p ·)) i ⟨x, aux x rfl (Nat.zero_add i).symm ⟩ := by
  simp

def Submodule (α : Type u) [OfNat α 0] := { s : Set α // s.mem 0 }
instance [OfNat α 0] : CoeSort (Submodule α) (Type u) where coe s := s.1
instance [OfNat α 0] (p : Submodule α) : Inhabited p where default := ⟨0, p.2⟩

example (p : Nat → Submodule Nat) :
    Pi.single (f := (p ·)) (x - x) ⟨0, (p ..).2⟩ = Pi.single 0 ⟨0, (p ..).2⟩ := by
  simp only [Nat.sub_self] -- should work


/-
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, Yaël Dillies
-/
import order.partial_sups

/-!
# Consecutive differences of sets

This file defines the way to make a sequence of elements into a sequence of disjoint elements with
the same partial sups.

For a sequence `f : ℕ → α`, this new sequence will be `f 0`, `f 1 \ f 0`, `f 2 \ (f 0 ⊔ f 1)`.
It is actually unique, as `disjointed_unique` shows.

## Main declarations

* `disjointed f`: The sequence `f 0`, `f 1 \ f 0`, `f 2 \ (f 0 ⊔ f 1)`, ....
* `partial_sups_disjointed`: `disjointed f` has the same partial sups as `f`.
* `disjoint_disjointed`: The elements of `disjointed f` are pairwise disjoint.
* `disjointed_unique`: `disjointed f` is the only pairwise disjoint sequence having the same partial
  sups as `f`.
* `supr_disjointed`: `disjointed f` has the same supremum as `f`. Limiting case of
  `partial_sups_disjointed`.

We also provide set notation variants of some lemmas.

## TODO

Find a useful statement of `disjointed_rec_succ`.

One could generalize `disjointed` to any locally finite bot preorder domain, in place of `ℕ`.
Related to the TODO in the module docstring of `order.partial_sups`.
-/

variables {α β : Type*}

section generalized_boolean_algebra
variables [generalized_boolean_algebra α]

/-- If `f : ℕ → α` is a sequence of elements, then `disjointed f` is the sequence formed by
subtracting each element from the nexts. This is the unique disjoint sequence whose partial sups
are the same as the original sequence. -/
def disjointed (f : ℕ → α) : ℕ → α
| 0       := f 0
| (n + 1) := f (n + 1) \ (partial_sups f n)

@[simp] lemma disjointed_zero (f : ℕ → α) : disjointed f 0 = f 0 := rfl

lemma disjointed_succ (f : ℕ → α) (n : ℕ) :
  disjointed f (n + 1) = f (n + 1) \ (partial_sups f n) :=
rfl

lemma disjointed_le_id : disjointed ≤ (id : (ℕ → α) → ℕ → α) :=
begin
  rintro f n,
  cases n,
  { refl },
  { exact sdiff_le }
end

lemma disjointed_le (f : ℕ → α) : disjointed f ≤ f := disjointed_le_id f

lemma disjoint_disjointed (f : ℕ → α) : pairwise (disjoint on disjointed f) :=
begin
  refine (symmetric.pairwise_on disjoint.symm _).2 (λ m n h, _),
  cases n,
  { exact (nat.not_lt_zero _ h).elim },
  exact disjoint_sdiff_self_right.mono_left ((disjointed_le f m).trans
    (le_partial_sups_of_le f (nat.lt_add_one_iff.1 h))),
end

/-- An induction principle for `disjointed`. To define/prove something on `disjointed f n`, it's
enough to define/prove it for `f n` and being able to extend through diffs. -/
def disjointed_rec {f : ℕ → α} {p : α → Sort*} (hdiff : ∀ ⦃t i⦄, p t → p (t \ f i)) :
  ∀ ⦃n⦄, p (f n) → p (disjointed f n)
| 0       := id
| (n + 1) := λ h,
  begin
    suffices H : ∀ k, p (f (n + 1) \ partial_sups f k),
    { exact H n },
    rintro k,
    induction k with k ih,
    { exact hdiff h },
    rw [partial_sups_succ, ←sdiff_sdiff_left],
    exact hdiff ih,
  end

@[simp] lemma disjointed_rec_zero {f : ℕ → α} {p : α → Sort*} (hdiff : ∀ ⦃t i⦄, p t → p (t \ f i))
  (h₀ : p (f 0)) :
  disjointed_rec hdiff h₀ = h₀ := rfl

-- TODO: Find a useful statement of `disjointed_rec_succ`.

lemma monotone.disjointed_eq {f : ℕ → α} (hf : monotone f) (n : ℕ) :
  disjointed f (n + 1) = f (n + 1) \ f n :=
by rw [disjointed_succ, hf.partial_sups_eq]

@[simp] lemma partial_sups_disjointed (f : ℕ → α) :
  partial_sups (disjointed f) = partial_sups f :=
begin
  ext n,
  induction n with k ih,
  { rw [partial_sups_zero, partial_sups_zero, disjointed_zero] },
  { rw [partial_sups_succ, partial_sups_succ, disjointed_succ, ih, sup_sdiff_self_right] }
end

/-- `disjointed f` is the unique sequence that is pairwise disjoint and has the same partial sups
as `f`. -/
lemma disjointed_unique {f d : ℕ → α} (hdisj : pairwise (disjoint on d))
  (hsups : partial_sups d = partial_sups f) : d = disjointed f :=
begin
  ext n,
  cases n,
  { rw [←partial_sups_zero d, hsups, partial_sups_zero, disjointed_zero] },
  suffices h : d n.succ = partial_sups d n.succ \ partial_sups d n,
  { rw [h, hsups, partial_sups_succ, disjointed_succ, sup_sdiff, sdiff_self, bot_sup_eq] },
  rw [partial_sups_succ, sup_sdiff, sdiff_self, bot_sup_eq, eq_comm, sdiff_eq_self_iff_disjoint],
  suffices h : ∀ m ≤ n, disjoint (partial_sups d m) (d n.succ),
  { exact h n le_rfl },
  rintro m hm,
  induction m with m ih,
  { exact hdisj _ _ (nat.succ_ne_zero _).symm },
  rw [partial_sups_succ, disjoint_iff, inf_sup_right, sup_eq_bot_iff, ←disjoint_iff, ←disjoint_iff],
  exact ⟨ih (nat.le_of_succ_le hm), hdisj _ _ (nat.lt_succ_of_le hm).ne⟩,
end

end generalized_boolean_algebra

section complete_boolean_algebra
variables [complete_boolean_algebra α]

lemma supr_disjointed (f : ℕ → α) : (⨆ n, disjointed f n) = (⨆ n, f n) :=
supr_eq_supr_of_partial_sups_eq_partial_sups (partial_sups_disjointed f)

lemma disjointed_eq_inf_compl (f : ℕ → α) (n : ℕ) :
  disjointed f n = f n ⊓ (⨅ i < n, (f i)ᶜ) :=
begin
  cases n,
  { rw [disjointed_zero, eq_comm, inf_eq_left],
    simp_rw le_infi_iff,
    exact λ i hi, (i.not_lt_zero hi).elim },
  simp_rw [disjointed_succ, partial_sups_eq_bsupr, sdiff_eq, compl_supr],
  congr,
  ext i,
  rw nat.lt_succ_iff,
end

end complete_boolean_algebra

/-! ### Set notation variants of lemmas -/

lemma disjointed_subset (f : ℕ → set α) (n : ℕ) : disjointed f n ⊆ f n :=
disjointed_le f n

lemma Union_disjointed {f : ℕ → set α} : (⋃ n, disjointed f n) = (⋃ n, f n) :=
supr_disjointed f

lemma disjointed_eq_inter_compl (f : ℕ → set α) (n : ℕ) :
  disjointed f n = f n ∩ (⋂ i < n, (f i)ᶜ) :=
disjointed_eq_inf_compl f n

lemma preimage_find_eq_disjointed (s : ℕ → set α) (H : ∀ x, ∃ n, x ∈ s n)
  [∀ x n, decidable (x ∈ s n)] (n : ℕ) :
  (λ x, nat.find (H x)) ⁻¹' {n} = disjointed s n :=
by { ext x, simp [nat.find_eq_iff, disjointed_eq_inter_compl] }


/-
Copyright (c) 2018 Andreas Swerdlow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andreas Swerdlow, Kenny Lau
-/
import data.equiv.ring
import algebra.opposites

/-!
# Ring involutions

This file defines a ring involution as a structure extending `R ≃+* Rᵒᵖ`,
with the additional fact `f.involution : (f (f x).unop).unop = x`.

## Notations

We provide a coercion to a function `R → Rᵒᵖ`.

## References

* <https://en.wikipedia.org/wiki/Involution_(mathematics)#Ring_theory>

## Tags

Ring involution
-/

variables (R : Type*)

/-- A ring involution -/
structure ring_invo [semiring R] extends R ≃+* Rᵒᵖ :=
(involution' : ∀ x, (to_fun (to_fun x).unop).unop = x)

namespace ring_invo
variables {R} [semiring R]

/-- Construct a ring involution from a ring homomorphism. -/
def mk' (f : R →+* Rᵒᵖ) (involution : ∀ r, (f (f r).unop).unop = r) :
  ring_invo R :=
{ inv_fun := λ r, (f r.unop).unop,
  left_inv := λ r, involution r,
  right_inv := λ r, congr_arg opposite.op (involution (r.unop)),
  involution' := involution,
  ..f }

instance : has_coe_to_fun (ring_invo R) := ⟨_, λ f, f.to_ring_equiv.to_fun⟩

@[simp]
lemma to_fun_eq_coe (f : ring_invo R) : f.to_fun = f := rfl

@[simp]
lemma involution (f : ring_invo R) (x : R) : (f (f x).unop).unop = x :=
f.involution' x

instance has_coe_to_ring_equiv : has_coe (ring_invo R) (R ≃+* Rᵒᵖ) :=
⟨ring_invo.to_ring_equiv⟩

@[norm_cast] lemma coe_ring_equiv (f : ring_invo R) (a : R) :
  (f : R ≃+* Rᵒᵖ) a = f a := rfl

@[simp] lemma map_eq_zero_iff (f : ring_invo R) {x : R} : f x = 0 ↔ x = 0 :=
f.to_ring_equiv.map_eq_zero_iff

end ring_invo

open ring_invo

section comm_ring
variables [comm_ring R]

/-- The identity function of a `comm_ring` is a ring involution. -/
protected def ring_invo.id : ring_invo R :=
{ involution' := λ r, rfl,
  ..(ring_equiv.to_opposite R) }

instance : inhabited (ring_invo R) := ⟨ring_invo.id _⟩

end comm_ring


import Euclid.tarski_2
open classical set
namespace Euclidean_plane
variables {point : Type} [Euclidean_plane point]

local attribute [instance] prop_decidable

-- Right Angles

def R (a b c : point) : Prop := eqd a c a (S b c)

theorem R.symm {a b c : point} : R a b c → R c b a :=
begin
intro h,
have h1 := seven13 b a (S b c),
simp at h1,
unfold R at h,
exact (eqd.trans h h1).flip
end

theorem eight3 {a b c a' : point} : R a b c → a ≠ b → col b a a' → R a' b c :=
begin
intros h h1 h2,
unfold R at *,
exact four17 h1.symm h2 (seven5 b c).2 h
end

theorem R.flip {a b c : point} : R a b c → R a b (S b c) :=
begin
intro h,
unfold R at *,
simpa using h.symm
end

@[simp] theorem eight4 (a b : point) : R a a b := (seven5 a b).2

@[simp] theorem eight5a (a b : point) : R a b b := (eight4 b a).symm

theorem eight6 {a b c a' : point} : R a b c → R a' b c → B a c a' → b = c :=
begin
intros h h1 h2,
unfold R at *,
generalize h3 : S b c = c',
rw h3 at *,
have : c = c',
  exact four19 h2 h h1.flip,
rw ←this at *,
exact (seven10.1 h3).symm
end

theorem eight7 {a b c : point} : R a b c → R a c b → b = c :=
begin
intros h h1,
have h_1 : eqd a c a (S b c),
  unfold R at h,
  exact h,
have h_2 : eqd a b a (S c b),
  unfold R at h1,
  exact h1,
have h2 := seven5 b c,
generalize h3 : S b c = c',
rw h3 at *,
generalize h4 : S c a = a',
by_contradiction h5,
have h6 : col c b c',
  left,
  exact h2.1,
have h7 := eight3 h1.symm h5 h6,
unfold R at h7,
rw h4 at h7,
have h8 := seven5 c a,
rw h4 at h8,
have h9 := h8.2,
have h10 : R a' b c,
  unfold R,
  rw h3,
  exact eqd.trans h9.symm.flip (eqd.trans h_1 h7.flip),
exact h5 (eight6 h h10 h8.1)
end

theorem eight8 {a b : point} : R a b a → a = b :=
begin
intro h,
exact eight7 (eight5a b a).symm h
end

theorem eight9 {a b c : point} : R a b c → col a b c → a = b ∨ c = b :=
begin
intros h h1,
cases em (a = b),
  simp *,
right,
have h2 := eight3 h h_1 (four11 h1).2.1,
exact eight8 h2
end

theorem eight10 {a b c a' b' c' : point} : R a b c → cong a b c a' b' c' → R a' b' c' :=
begin
intros h h1,
cases em (b = c),
  rw h_1 at *,
  have h2 : b' = c',
    exact id_eqd h1.2.1.symm,
  rw h2,
  exact eight5a a' c',
unfold R at *,
generalize h2 : S b c = d,
generalize h3 : S b' c' = d',
have h4 := seven5 b c,
have h5 := seven5 b' c',
rw h2 at *,
rw h3 at *,
have h6 : afs c b d a c' b' d' a',
  repeat {split},
    exact h4.1,
    exact h5.1,
    exact h1.2.1.flip,
    exact eqd.trans h4.2.symm (eqd.trans h1.2.1 h5.2),
    exact h1.2.2.flip,
  exact h1.1.flip,
have h7 := afive_seg h6 (ne.symm h_1),
exact eqd.trans h1.2.2.symm (eqd.trans h h7.flip)
end

def xperp (x : point) (A A' : set point) : Prop := line A ∧ line A' ∧ x ∈ A ∧ x ∈ A' ∧
∀ {u v}, u ∈ A → v ∈ A' → R u x v

def perp (A A' : set point) : Prop := ∃ x, xperp x A A'

notation A ` ⊥ ` B  := perp A B

theorem xperp.symm {x : point} {A A' : set point} : xperp x A A' → xperp x A' A :=
begin
intro h,
unfold xperp at *,
split,
  exact h.2.1,
split,
  exact h.1,
split,
  exact h.2.2.2.1,
split,
  exact h.2.2.1,
intros u v hu hv,
exact (h.2.2.2.2 hv hu).symm
end

theorem perp.symm {A A' : set point} : perp A A' → perp A' A :=
begin
intro h,
cases h with x hx,
constructor,
exact hx.symm
end

theorem eight14a {A A' : set point} : perp A A' → A ≠ A' :=
begin
intros h h1,
unfold perp at h,
cases h with x hx,
unfold xperp at hx,
cases hx.1 with u hu,
cases hu with v hv,
  cases em (u = x),
  rw h at *,
  rw ←h1 at *,
  rw hv.2 at *,
  have h2 := hx.2.2.2.2 (six17b x v) (six17b x v),
  exact hv.1 (eight8 h2).symm,
rw ←h1 at *,
  rw hv.2 at *,
  have h2 := hx.2.2.2.2 (six17a u v) (six17a u v),
exact h (eight8 h2)
end

theorem eight14b {x : point} {A A' : set point} : xperp x A A' → A ≠ A' :=
begin
intro h,
apply eight14a,
constructor,
exact h
end

theorem eight14c {x : point} {A A' : set point} : xperp x A A' ↔ perp A A' ∧ is x A A' :=
begin
split,
  intro h,
  split,
  constructor,
    exact h,
  have h1 : perp A A',
    constructor,
      exact h,
  unfold xperp at h,
  unfold is,
  split,
    exact h.1,
  split,
    exact h.2.1,
  split,
    exact eight14a h1,
  split,
    exact h.2.2.1,
  exact h.2.2.2.1,
intro h,
cases h with h h1,
cases h with y hy,
unfold is at h1,
suffices : x = y,
  rwa ←this at hy,
by_contradiction,
suffices : A = A',
  exact h1.2.2.1 this,
apply six21 a h1.1 h1.2.1 h1.2.2.2.1 h1.2.2.2.2,
  unfold xperp at hy,
  exact hy.2.2.1,
exact hy.2.2.2.1
end

theorem eight14d {x y : point} {A A' : set point} : xperp x A A' → xperp y A A' → x = y :=
begin
intros hx hy,
by_contradiction,
have h : perp A A',
  constructor,
    exact hx,
have h1 := eight14a h,
suffices : A = A',
  exact h1 this,
unfold xperp at *,
exact six21 a hx.1 hx.2.1 hx.2.2.1 hx.2.2.2.1 hy.2.2.1 hy.2.2.2.1
end

theorem eight14e {A A' : set point} : perp A A' → line A ∧ line A' :=
begin
intro h,
cases h with x hx,
split,
  exact hx.1,
exact hx.2.1
end

theorem eight14f {a b c : point} {A : set point} : perp (l a b) A → col a b c → a ≠ c → perp (l a c) A :=
begin
intros h h1 h2,
suffices : l a b = l a c,
  rwa ←this,
exact six18 (eight14e h).1 h2 (six17a a b) h1
end

theorem eight13 {x : point} {A A' : set point} : xperp x A A' ↔ line A ∧ line A' ∧ x ∈ A ∧ x ∈ A' ∧
∃ u v, u ∈ A ∧ v ∈ A' ∧ u ≠ x ∧ v ≠ x ∧ R u x v :=
begin
split,
  intro h,
  split,
    exact h.1,
  split,
    exact h.2.1,
  split,
    exact h.2.2.1,
  split,
    exact h.2.2.2.1,
  unfold xperp at h,
  cases six22 h.1 h.2.2.1 with u hu,
  cases six22 h.2.1 h.2.2.2.1 with v hv,
  existsi u,
  existsi v,
  have h1 : u ∈ A,
    rw hu.2,
    simp,
  have h2 : v ∈ A',
    rw hv.2,
    simp,
  split,
    exact h1,
  split,
    exact h2,
  split,
    exact hu.1.symm,
  split,
    exact hv.1.symm,
  exact h.2.2.2.2 h1 h2,
intro h,
unfold xperp,
split,
  exact h.1,
split,
  exact h.2.1,
split,
  exact h.2.2.1,
split,
  exact h.2.2.2.1,
intros a b ha hb,
cases h.2.2.2.2 with u hu,
cases hu with v hv,
have h1 : R a x v,
  apply eight3 hv.2.2.2.2 hv.2.2.1,
  have h_1 : A = l x u,
    exact six18 h.1 hv.2.2.1.symm h.2.2.1 hv.1,
  rw h_1 at ha,
  exact ha,
apply R.symm,
apply eight3 h1.symm hv.2.2.2.1,
have h_2 : A' = l x v,
  exact six18 h.2.1 hv.2.2.2.1.symm h.2.2.2.1 hv.2.1,
rw h_2 at hb,
exact hb
end

theorem eight15 {x : point} {A B : set point} : perp A B → x ∈ A → x ∈ B → xperp x A B :=
begin
intros h h1 h2,
cases h with y hy,
suffices : x = y,
  subst x,
  exact hy,
by_contradiction h_1,
apply eight14b hy,
apply six21 h_1,
  exact hy.1,
  exact hy.2.1,
  exact h1,
  exact h2,
  exact hy.2.2.1,
exact hy.2.2.2.1
end

theorem eight16 {a b c u x : point} : col a b x → col a b u → u ≠ x →
(c ≠ x ∧ perp (l a b) (l c x) ↔ ¬col a b c ∧ R c x u) :=
begin
intros h1 h2 h3,
split,
  intro h4,
  have h5 : xperp x (l a b) (l c x),
    exact eight15 h4.2 h1 (six17b c x),
  split,
    intro h_1,
    apply eight14b h5,
    exact six18 h5.1 h4.1 h_1 h1,
  apply R.symm,
  exact h5.2.2.2.2 h2 (six17a c x),
intro h4,
cases h4 with h4 h5,
have h_1 : c ≠ x,
  intro h_1,
  rw h_1 at h4,
  exact h4 h1,
split,
  exact h_1,
existsi x,
apply eight13.2,
split,
  exact six14 (six26 h4).1,
split,
  exact six14 h_1,
split,
  exact h1,
split,
  simp,
existsi u,
existsi c,
split,
  exact h2,
split,
  exact (six17a c x),
split,
  exact h3,
split,
  exact h_1,
exact h5.symm
end

theorem eight18 {c : point} {A : set point} : line A → c ∉ A → ∃! x, x ∈ A ∧ perp A (l c x) :=
begin
intros h1 h,
rcases h1 with ⟨a, b, ha, h2⟩,
subst h2,
cases seg_cons a a c b with y hy,
cases seven25 hy.2.symm with p hp,
have h1: R a p y,
  unfold R,
  suffices : S p y = c,
    rw this,
    exact hy.2,
  exact (seven6 hp.symm).symm,
cases seg_cons y y p a with z hz,
cases seg_cons y y a p with q hq,
generalize hq' : S z q = q',
cases seg_cons y y c q' with c' hc',
have h2 : afs a y z q q y p a,
  focus {repeat {split}},
    exact hz.1,
    exact hq.1.symm,
    exact hq.2.symm.flip,
    exact hz.2,
    exact two5 (eqd.refl a q),
  exact hq.2,
have h3 : a ≠ y,
  intro h_1,
  rw h_1 at *,
  have : y = c,
    exact id_eqd hy.2.symm,
  exact (six26 h).2.2 this,
have h4 := afive_seg h2 h3,
have h5 : cong a p y q z y,
  split,
    exact h4.symm.flip,
  split,
    exact hz.2.symm.flip,
  exact hq.2.symm.flip,
have h6 := (eight10 h1 h5).symm,
have h7 : eqd y q y q',
  unfold R at h6,
  rwa hq' at h6,
cases seven25 hc'.2 with x hx,
existsi x,
have h8 : R y x c,
  unfold R,
  suffices : S x c = c',
    rw this,
    exact hc'.2.symm,
  exact (seven6 hx.symm).symm,
have h9 : c ≠ y,
  intro h_1,
  rw ←h_1 at hy,
  apply h,
  right, right,
  exact hy.1.symm,
have h10 : y ≠ p,
  intro h_1,
  rw ←h_1 at hp,
  unfold M at hp,
  apply h9,
  exact id_eqd hp.2.flip,
have h11 : hourglass q q' y c c' z x,
  have h_1 := seven5 z q,
  rw hq' at h_1,
  focus {repeat {split}},
    exact (three7a hp.1 hq.1 h10.symm).symm,
    exact hc'.1,
    exact h7,
    exact hc'.2.symm,
    exact h_1.1,
    exact h_1.2,
    exact hx.1.symm,
  exact hx.2.symm,
have h12 := seven22 h11,
have h13 : y ≠ z,
  intro h_1,
  rw ←h_1 at hz,
  exact h10 (id_eqd hz.2.symm),
have h14 : a ≠ y,
  intro h_1,
  rw ←h_1 at hy,
  apply (six26 h).2.2,
  exact id_eqd hy.2.symm,
have h15 : l y z = l a b,
  apply six18 (six14 h13) (six26 h).1,
    right, right,
    exact hz.1,
  right, right,
  exact three7a hy.1 hz.1 h14,
have h16 : c ≠ x,
  intro h_1,
  rw h_1 at *,
  apply h,
  have h_2 : x ∈ l a b,
    rw ←h15,
  right, right,
  exact h12.symm,
  exact h_2,
have h17 : q ≠ z,
  intro h_1,
  rw h_1 at *,
  have h_2 : B z y c,
    exact three7b hq.1.symm hp.1.symm h10,
  apply h,
  suffices : c ∈ l a b,
    exact this,
  rw ←h15,
  right, right,
  exact h_2.symm,
have h18 : xperp x (l y z) (l c x),
  apply eight13.2,
  split,
    exact six14 h13,
  split,
    exact (six14 h16),
  split,
    right, right,
    exact h12.symm,
  split,
    simp,
  existsi y,
  existsi c,
  simp,
  split,
    intro h_1,
    rw h_1 at *,
    have h_1 : q ∈ l c x,
      left,
      exact three7a hp.1 hq.1 h10.symm,
    have h_2 : q' ∈ l c x,
      suffices : c' ≠ x,
        cases five2 this hx.1 hc'.1.symm,
          right, right,
          exact h_2.symm,
        right, left,
        exact h_2,
      intro h_2,
      rw h_2 at *,
      apply h9,
      exact id_eqd hx.2.symm.flip,
    have h_3 := seven5 z q,
    rw hq' at h_3,
    have h_4 : q ≠ q',
      intro h_4,
      rw ←h_4 at *,
      apply h17,
      exact seven3.1 h_3,
    have h_5 : l c x = l q q',
      exact six18 (six14 h9) h_4 h_1 h_2,
    have h_6 : z ∈ l c x,
      rw h_5,
      right, left,
      exact h_3.1.symm,
    have h_7 := (four11 h_6).2.2.1,
    have h_8 : c ∈ l a b,
      rw ←h15,
      exact h_7,
    exact h h_8,
  split,
    exact h16,
  exact h8,
rw h15 at h18,
have h19 : x ∈ l y z,
  right, right,
  exact h12.symm,
split,
  split,
    rw h15 at h19,
    exact h19,
  constructor,
    exact h18,
intros x' hx',
have h20 : c ≠ x',
  intro h_1,
  apply h,
  rw ←h_1 at hx',
  exact hx'.1,
have h21 : xperp x' (l a b) (l c x'),
  exact eight15 hx'.2 hx'.1 (six17b c x'),
have h22 : R c x x',
  apply (h18.symm).2.2.2.2,
    simp,
  exact hx'.1,
have h23 : R c x' x,
  apply (h21.symm).2.2.2.2,
    simp,
  rw ←h15,
  exact h19,
exact eight7 h23 h22
end

theorem eight17 {a : point} {A : set point}: line A → a ∉ A → ∃! x, x ∈ A ∧ perp A (l a x) :=
begin
intros h h1,
cases h with p hp,
cases hp with q hq,
cases hq with hq h2,
subst h2,
have h3 : ¬col p q a,
  intro h_1,
  exact h1 h_1,
exact eight18 (six14 hq) h3
end

theorem eight19 {p q r : point} (a : point) : R p q r ↔ R (S a p) (S a q) (S a r) :=
begin
unfold R,
split,
  intro h,
  suffices : (S (S a q) (S a r)) = (S a (S q r)),
    rw this,
    exact (seven16 a).1 h,
  have h1 := seven5 (S a q) (S a r),
  suffices : M (S a r) (S a q) (S a (S q r)),
    exact unique_of_exists_unique (seven4 (S a q) (S a r)) h1 this,
  apply (seven14 a).1,
  exact seven5 q r,
intro h,
suffices : S a ((S (S a q) (S a r))) = S q r,
  rw ←this,
  apply (seven16 a).2,
  simp,
  exact h,
suffices : S a (S a (S (S a q) (S a r))) = (S a (S q r)),
  exact seven9 this,
simp,
have h1 := seven5 (S a q) (S a r),
suffices : M (S a r) (S a q) (S a (S q r)),
  exact unique_of_exists_unique (seven4 (S a q) (S a r)) h1 this,
apply (seven14 a).1,
exact seven5 q r
end

theorem eight20 {a b c p : point} : R a b c → M (S a c) p (S b c) → R b a p ∧ (b ≠ c → a ≠ p) :=
begin
intros h h1,
have h2 := seven5 b c,
have h3 := seven5 a b,
have h4 := seven5 a c,
have h5 := seven5 a (S b c),
have h6 := seven5 a p,
have h7 : R (S a b) b c,
  cases em (a = b),
    rw h_1 at *,
    simp,
    apply eight3 h h_1,
  left,
  exact h3.1,
have h8 := (eight19 a).1 h7,
unfold R at h7,
have h9 := (seven16 a).1 h7,
simp at *,
have h10 : ifs (S a c) p (S b c) b (S a (S b c)) (S a p) c b,
  focus {repeat {split}},
    exact h1.1,
    have h_1 := (seven15 a).1 h1.1,
    simp at h_1,
    exact h_1.symm,
    apply two5,
    have h_2 := seven13 a (S a c) (S b c),
    simp at h_2,
    exact h_2,
    apply eqd.trans h1.2.symm,
    have h_3 := seven13 a p (S a c),
    simp at h_3,
    exact h_3,
    exact h9.flip,
  exact h2.2.symm.flip,
have h11 := four2 h10,
split,
  unfold R,
  exact h11.flip,
intros hbc hap,
apply hbc,
have h12 := seven7 a c,
rw hap at *,
have h13 := seven5 p (S p c),
simp at h13,
have h14 := unique_of_exists_unique (seven4 p (S p c)) h13 h1,
rw ←h14 at h2,
exact (seven3.1 h2).symm
end

theorem eight21 {a b : point} (hab : a ≠ b) (c : point) : ∃ p t, perp (l a b) (l p a) ∧ col a b t ∧ B c t p :=
begin
cases em (col a b c) with habc h,
  cases six25 hab with c' h,
  cases eight18 (six14 hab) h with x hx,
  have h1 : c' ≠ x,
    intro h_1,
    rw h_1 at *,
    exact h hx.1.1,
  have h2 : xperp x (l a b) (l c' x),
    exact eight15 hx.1.2 hx.1.1 (six17b c' x),
  unfold xperp at h2,
  have h3 := h2.2.2.2.2 (six17a a b) (six17a c' x),
  unfold R at h3,
  have h4 := seven5 a c',
  cases seven25 (eqd.trans h4.2.symm h3) with p hp,
  have h5 := eight20 (h2.2.2.2.2 (six17a a b) (six17a c' x)) hp,
  have h6 := h5.2 h1.symm,
  existsi p,
  existsi c,
  cases em (x = a),
    rw h_1 at hx,
    rw h_1 at hp,
    have h_2 : S a c' = p,
      exact seven3.1 hp,
    rw h_2 at h4,
    have h_3 : col c' a p,
      left,
      exact h4.1,
    have h_4 : l c' a = l p a,
      apply six18 (six14 (six26 h).2.2.symm) h6.symm h_3 (six17b c' a),
    have h_5 := hx.1,
    rw h_4 at h_5,
    split,
      exact h_5.2,
    split,
      exact habc,
    exact three3 c p,
  split,
    existsi a,
    apply eight13.2,
    split,
      exact six14 (six26 h).1,
    split,
      exact six14 h6.symm,
    split,
      simp,
    split,
      simp,
    existsi x,
    existsi p,
    split,
      exact hx.1.1,
    simp,
    split,
      exact h_1,
    split,
      exact h6.symm,
    exact h5.1,
  split,
    exact habc,
  exact three3 c p,
cases eight18 (six14 hab) h with x hx,
have h1 : c ≠ x,
  intro h_1,
  rw h_1 at *,
  exact h hx.1.1,
have h2 : xperp x (l a b) (l c x),
  exact eight15 hx.1.2 hx.1.1 (six17b c x),
unfold xperp at h2,
have h3 := h2.2.2.2.2 (six17a a b) (six17a c x),
unfold R at h3,
have h4 := seven5 a c,
cases seven25 (eqd.trans h4.2.symm h3) with p hp,
have h5 := eight20 (h2.2.2.2.2 (six17a a b) (six17a c x)) hp,
have h6 := h5.2 h1.symm,
cases three17 (seven5 x c).1.symm h4.1.symm hp.1.symm with t ht,
cases em (x = a),
  rw h_1 at ht,
  existsi p,
  existsi a,
  have h_2 : t = a,
    exact (bet_same ht.2).symm,
  rw h_2 at *,
  rw h_1 at hx,
  have h_3 := hx.1,
  have h_4 : l c a = l p a,
    apply six18 (six14 (six26 h).2.2.symm) h6.symm,
      left,
      exact ht.1.symm,
    simp,
  rw h_4 at h_3,
  split,
    exact h_3.2,
  split,
    exact h_3.1,
  exact ht.1.symm,
existsi p,
existsi t,
have h7 : col a b t,
  have h_2 : col a x t,
    right, left,
    exact ht.2,
  exact five4 (ne.symm h_1) (four11 hx.1.1).1 h_2,
split,
  existsi a,
  apply eight13.2,
  split,
    exact six14 (six26 h).1,
  split,
    exact six14 h6.symm,
  split,
    simp,
  split,
    simp,
  existsi x,
  existsi p,
  split,
    exact hx.1.1,
  split,
    simp,
  split,
    exact h_1,
  split,
    exact h6.symm,
  exact h5.1,
split,
  exact h7,
exact ht.1.symm
end

lemma eight23 {a b p q t t' r : point} (hp : ((l a b) ⊥ l p a) ∧ col a b t' ∧ B a t' p)
(ht : ((l b a) ⊥ l q b) ∧ col b a t ∧ B p t q) (hr : B b r q ∧ eqd a p b r): ∃ x, M a x b ∧ M p x r :=
begin
have h : a ≠ b,
  exact six13 (eight14e hp.1).1,
cases pasch ht.2.2 hr.1 with x hx,
have h1 : col a b x,
  have h_1 : col b t x,
    right, left,
    exact hx.1,
  cases em (b = t),
    rw ←h_2 at *,
    have h_3 : x = b,
      exact (bet_same hx.1).symm,
    rw h_3,
    left,
    exact three1 a b,
  exact (four11 (five4 h_2 (four11 ht.2.1).1 h_1)).2.1,
have h2 : xperp a (l a b) (l p a),
  exact eight15 hp.1 (four11 (four12 a b)).1 (six17b p a),
have h3 : xperp b (l b a) (l q b),
  exact eight15 ht.1 (four11 (four12 b a)).1 (six17b q b),
have h4 := h2.2.2.2.2 (six17b a b) (six17a p a),
have h5 := h3.2.2.2.2 (six17b b a) (six17a q b),
have h6 : R a b r,
  have : col b q r,
    right, left,
    exact hr.1.symm,
  exact (eight3 h5.symm (six13 h3.2.1) this).symm,
have h7 : ¬col a p b,
  intro h_1,
  cases eight9 h4 (four11 h_1).2.2.2.1,
    exact h h_2.symm,
  exact (six13 h2.2.1) h_2,
have h8 : ¬col a b r,
  intro h_1,
  cases eight9 h6 h_1,
    exact h h_2,
  rw h_2 at *,
  exact (six13 h2.2.1).symm (id_eqd hr.2),
suffices : eqd b p a r,
  have h_1 : p ≠ r,
    intro h_1,
    rw h_1 at hx,
    have h_2 : r = x,
      exact bet_same hx.2,
    rw h_2 at h8,
    exact h8 h1,
  constructor,
  apply seven21 h7 h_1 hr.2 this.flip (four11 h1).1,
  left,
  exact hx.2.symm,
have h9 : x ≠ a,
  intro h_1,
  rw h_1 at *,
  have h_2 : col a p r,
    right, right,
    exact hx.2,
  have h_3 : R r a b,
    exact eight3 h4.symm (six13 h2.2.1) h_2,
  apply h,
  exact eight7 h_3 h6.symm,
have h10 := seven5 a p,
cases seg_cons x x r (S a p) with r' hr',
cases seven25 hr'.2 with m hm,
have h11 := seven5 m r,
have h12 := unique_of_exists_unique (seven4 m r) h11 hm.symm,
have h13 : R x m r,
  unfold R,
  rw ←h12 at hr',
  exact hr'.2.symm,
have h14 : R x a p,
  exact eight3 h4 (ne.symm h) h1,
have h15 : ¬col x p (S a p),
  intro h_1,
  have h_2 : col p a (S a p),
    left,
    exact (seven5 a p).1,
  have h_3 : p ≠ (S a p),
    intro h_3,
    exact (six13 h2.2.1) (seven10.1 h_3.symm),
  have h_3 : col p a x,
    exact five4 h_3 (four11 h_2).1 (four11 h_1).2.2.1,
  cases eight9 h14.symm h_3,
    exact (six13 h2.2.1) h_4,
  exact h9 h_4,
have h16 : hourglass p (S a p) x r r' a m,
  focus {repeat {split}},
    exact hx.2.symm,
    exact hr'.1,
    unfold R at h14,
    exact h14,
    exact hr'.2.symm,
    exact h10.1,
    exact h10.2,
    rw ←h12,
    exact h11.1,
    rw ←h12,
  exact h11.2,
have h17 := seven22 h16,
have h18 : r ≠ m,
  intro h_1,
  rw ←h_1 at h17,
  have h_2 : col a x r,
    left,
    exact h17,
  apply h8,
  exact five4 h9.symm (four11 h1).1 h_2,
have h19 : x ≠ m,
  intro h_1,
  have h_2 : col r x p,
    left,
    exact hx.2,
  have h_3 : x ≠ r',
    intro h_3,
    rw [←h_1, ←h_3] at h12,
    rw ←h_1 at h18,
    apply h18,
    exact seven9 (eq.trans h12 (seven11 x).symm),
  have h_4 : col r x (S a p),
    have h_4 : col x r' (S a p),
      right, right,
      exact hr'.1,
    have h_5 : col x r' r,
      rw h_1,
      right, right,
      exact hm.1.symm,
    exact (four11 (five4 h_3 h_5 h_4)).2.1,
  have h_5 : x ≠ r,
    intro h_5,
    rw h_5 at h_1,
    exact h18 h_1,
  apply h15,
  exact five4 h_5 (four11 h_2).2.1 (four11 h_4).2.1,
have h20 : col a b m,
  have h_1 : col a x m,
    left,
    exact h17,
  exact five4 h9.symm (four11 h1).1 h_1,
have h21 : xperp b (l a b) (l r b),
  apply eight13.2,
  split,
    exact six14 h,
  split,
    exact six14 (six26 h8).2.1.symm,
  split,
    simp,
  split,
    simp,
  existsi a,
  existsi r,
  simp,
  split,
    exact h,
  split,
    exact (six26 h8).2.1.symm,
  exact h6,
have h22 : xperp m (l a b) (l r m),
  apply eight13.2,
  split,
    exact six14 h,
  split,
    exact six14 h18,
  split,
    exact h20,
  split,
    simp,
  existsi x,
  existsi r,
  split,
    exact h1,
  simp,
  split,
    exact h19,
  split,
    exact h18,
  exact h13,
have h23 : perp (l a b) (l r b),
  constructor,
  exact h21,
have h24 : perp (l a b) (l r m),
  constructor,
  exact h22,
have h25 : m = b,
  apply unique_of_exists_unique (eight18 (six14 h) h8),
    split,
      exact h20,
    exact h24,
  split,
    left,
    exact three1 a b,
  exact h23,
subst m,
have h26 : ifs (S a p) a p r r b r' (S a p),
  focus {repeat {split}},
    exact h10.1.symm,
    exact hm.1.symm,
    apply two4,
    apply two11 h10.1 hm.1.symm,
      exact hr.2.flip,
      exact eqd.trans h10.2.symm (eqd.trans hr.2 hm.2.symm),
    exact eqd.trans hr.2 hm.2.symm,
    exact two4 (eqd.refl r (S a p)),
  apply two5,
  apply two11 hx.2.symm hr'.1,
    unfold R at h14,
    exact h14.flip,
  exact hr'.2.symm,
have h27 := four2 h26,
unfold R at h4,
exact eqd.trans h4 h27.symm
end

theorem eight22 (a b : point) : ∃! x, M a x b :=
begin
cases em (a = b),
  rw h,
  existsi b,
  split,
    apply seven3.2,
    refl,
  intros y hy,
  exact (seven3.1 hy).symm,
apply exists_unique_of_exists_of_unique,
  cases eight21 h a with p hp,
  cases eight21 (ne.symm h) p with q hq,
  cases hp with t' hp,
  cases hq with t ht,
  cases five10 a p b q,
    cases h_1 with r hr,
    cases eight23 hp ht hr with x hx,
    constructor,
    exact hx.1,
  suffices : ∃ x, M b x a,
    cases this with x hx,
    constructor,
    exact hx.symm,
  cases h_1 with r hr,
  have : ∃ x, M b x a ∧ M q x r,
    apply eight23,
        split,
          exact ht.1,
        split,
          exact (four11 (four12 b a)).1,
        exact three3 b q,
      split,
        exact hp.1,
      split,
        exact (four11 ht.2.1).2.1,
      exact ht.2.2.symm,
    exact hr,
  cases this with x hx,
  constructor,
  exact hx.1,
intros x y hx hy,
exact seven17 hx hy
end

theorem eight24 {a b p q r t : point} : perp (l p a) (l a b) → perp (l q b) (l a b) →
col a b t → B p t q → B b r q → eqd a p b r → ∃ x, M a x b ∧ M p x r :=
begin
intros g3 g4 g5 g6 g7 g8,
have g9 := (four11 (four12 a b)).1,
have g10 := three3 a p,
have g11 := six17 a b,
rw g11 at g4,
have hp : ((l a b) ⊥ l p a) ∧ col a b a ∧ B a a p,
  exact ⟨g3.symm, ⟨g9, g10⟩⟩,
have ht : ((l b a) ⊥ l q b) ∧ col b a t ∧ B p t q,
  exact ⟨g4.symm, ⟨(four11 g5).2.1, g6⟩⟩,
have hr : B b r q ∧ eqd a p b r,
  exact ⟨g7, g8⟩,
exact eight23 hp ht hr
end

theorem eight25 {a b : point} : a ≠ b → ∃ c, R a b c ∧ c ≠ b :=
begin
intro h,
rcases eight21 h.symm a with ⟨c, p, h1⟩,
refine ⟨c, (eight15 h1.1 (six17a b a) (six17b c b)).2.2.2.2 (six17b b a) (six17a c b), _⟩,
exact six13 (eight14e h1.1).2
end

end Euclidean_plane


import semantics.model
import syntax.syntaxCLK
import semantics.playability
import data.fintype.basic
-- cl.syntax.syntaxCL data.set.basic
-- import del.semantics.translationfunction
local attribute [instance] classical.prop_decidable

open formCLK set

---------------------- Semantics ----------------------

-- structure frameCL (agents : Type) :=
-- (states : Type)
-- (hs : nonempty states)
-- (ha : nonempty agents)
-- (E  : playable_effectivity_struct states ha)

-- structure frameCLK (agents : Type) extends frameCL agents :=
-- (rel   : agents → states → set states)
-- (rfl   : ∀ i s, s ∈ (rel i s))
-- (sym   : ∀ i s t, t ∈ (rel i s) → s ∈ (rel i t))
-- (trans : ∀ i s t u, t ∈ (rel i s) → u ∈ (rel i t) → u ∈ (rel i s))

-- structure modelCLK (agents : Type) :=
-- (f : frameCLK agents)
-- (v : ℕ → set f.states)

@[simp]
protected def formCLK.sizeof' (agents : Type) [agents_inst : has_sizeof agents] : formCLK agents → ℕ
| bot := 1
| (var n) := 1 + sizeof n
| (imp φ ψ) := 1 + formCLK.sizeof' φ + formCLK.sizeof' ψ
| (and φ ψ) := 1 + formCLK.sizeof' φ + formCLK.sizeof' ψ
| ([G] φ) := 1 + sizeof G + formCLK.sizeof' φ
| (K' i φ) := 1 + sizeof i + formCLK.sizeof' φ
| (E' i φ) := 1 + sizeof i + formCLK.sizeof' φ + 1 -- Make recursion from E' to K' possible

def formCLK.has_sizeof' {agents} : has_sizeof (formCLK agents) := ⟨formCLK.sizeof' _⟩
local attribute [instance] formCLK.has_sizeof'

-- Definition of semantic entailment
-- Order of arguments is swapped to help the equation compiler find the recursive parameter
def s_entails_CLK.aux {agents : Type} : ∀ m : modelCLK agents,
  formCLK agents → m.f.states → Prop
| m bot       s  := false
| m (var n)   s  := s ∈ m.v n
| m (imp φ ψ) s  := (s_entails_CLK.aux m φ s) → (s_entails_CLK.aux m ψ s)
| m (and φ ψ) s  := (s_entails_CLK.aux m φ s) ∧ (s_entails_CLK.aux m ψ s)
| m ([G] φ)   s  := {t: m.f.states | s_entails_CLK.aux m φ t} ∈ m.f.E.E (s) (G)
| m (K' i φ)  s  := ∀ t: m.f.states, t ∈ (m.f.rel i s) → s_entails_CLK.aux m φ t
| m (E' G φ)  s  := ∀ i ∈ G, s_entails_CLK.aux m (K' i φ) s

-- Definition of semantic entailment
def s_entails_CLK {agents : Type} (m : modelCLK agents) (s : m.f.states) (φ : formCLK agents) : Prop :=
s_entails_CLK.aux m φ s

variables {agents : Type}

-- φ is valid in a model M = (f,v)
def valid_m (m: modelCLK agents) (φ : formCLK agents) :=
  ∀ s, s_entails_CLK m s φ

def global_valid (φ : formCLK agents) :=
  ∀ m, valid_m m φ

lemma not_s_entails_imp (m : modelCLK agents) : ∀ s φ,
  (¬(s_entails_CLK m s φ)) ↔ (s_entails_CLK m s (¬ φ)) :=
begin
  intros s φ,
  unfold s_entails_CLK s_entails_CLK.aux,
  refl,
end