/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.algebra.basic
import ring_theory.ideal.basic

/-!
# Quotients of non-commutative rings

Unfortunately, ideals have only been developed in the commutative case as `ideal`,
and it's not immediately clear how one should formalise ideals in the non-commutative case.

In this file, we directly define the quotient of a semiring by any relation,
by building a bigger relation that represents the ideal generated by that relation.

We prove the universal properties of the quotient, and recommend avoiding relying on the actual
definition, which is made irreducible for this purpose.

Since everything runs in parallel for quotients of `R`-algebras, we do that case at the same time.
-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} [semiring R]
variables {S : Type u₂} [comm_semiring S]
variables {A : Type u₃} [semiring A] [algebra S A]

namespace ring_quot

/--
Given an arbitrary relation `r` on a ring, we strengthen it to a relation `rel r`,
such that the equivalence relation generated by `rel r` has `x ~ y` if and only if
`x - y` is in the ideal generated by elements `a - b` such that `r a b`.
-/
inductive rel (r : R → R → Prop) : R → R → Prop
| of ⦃x y : R⦄ (h : r x y) : rel x y
| add_left ⦃a b c⦄ : rel a b → rel (a + c) (b + c)
| mul_left ⦃a b c⦄ : rel a b → rel (a * c) (b * c)
| mul_right ⦃a b c⦄ : rel b c → rel (a * b) (a * c)

theorem rel.add_right {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) : rel r (a + b) (a + c) :=
by { rw [add_comm a b, add_comm a c], exact rel.add_left h }

theorem rel.neg {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b : R⦄ (h : rel r a b) :
  rel r (-a) (-b) :=
by simp only [neg_eq_neg_one_mul a, neg_eq_neg_one_mul b, rel.mul_right h]

theorem rel.sub_left {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r a b) :
  rel r (a - c) (b - c) :=
by simp only [sub_eq_add_neg, h.add_left]

theorem rel.sub_right {R : Type u₁} [ring R] {r : R → R → Prop} ⦃a b c : R⦄ (h : rel r b c) :
  rel r (a - b) (a - c) :=
by simp only [sub_eq_add_neg, h.neg.add_right]

theorem rel.smul {r : A → A → Prop} (k : S) ⦃a b : A⦄ (h : rel r a b) : rel r (k • a) (k • b) :=
by simp only [algebra.smul_def, rel.mul_right h]

end ring_quot

/-- The quotient of a ring by an arbitrary relation. -/
structure ring_quot (r : R → R → Prop) :=
(to_quot : quot (ring_quot.rel r))

namespace ring_quot

variable (r : R → R → Prop)

@[irreducible] private def zero : ring_quot r := ⟨quot.mk _ 0⟩
@[irreducible] private def one : ring_quot r := ⟨quot.mk _ 1⟩
@[irreducible] private def add : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (+) rel.add_right rel.add_left a b⟩
@[irreducible] private def mul : ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ (*) rel.mul_right rel.mul_left a b⟩
@[irreducible] private def neg {R : Type u₁} [ring R] (r : R → R → Prop) : ring_quot r → ring_quot r
| ⟨a⟩:= ⟨quot.map (λ a, -a) rel.neg a⟩
@[irreducible] private def sub {R : Type u₁} [ring R] (r : R → R → Prop) :
  ring_quot r → ring_quot r → ring_quot r
| ⟨a⟩ ⟨b⟩ := ⟨quot.map₂ has_sub.sub rel.sub_right rel.sub_left a b⟩
@[irreducible] private def smul [algebra S R] (n : S) : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (λ a, n • a) (rel.smul n) a⟩

instance : has_zero (ring_quot r) := ⟨zero r⟩
instance : has_one (ring_quot r) := ⟨one r⟩
instance : has_add (ring_quot r) := ⟨add r⟩
instance : has_mul (ring_quot r) := ⟨mul r⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_neg (ring_quot r) := ⟨neg r⟩
instance {R : Type u₁} [ring R] (r : R → R → Prop) : has_sub (ring_quot r) := ⟨sub r⟩
instance [algebra S R] : has_scalar S (ring_quot r) := ⟨smul r⟩

lemma zero_quot : (⟨quot.mk _ 0⟩ : ring_quot r) = 0 := show _ = zero r, by rw zero
lemma one_quot : (⟨quot.mk _ 1⟩ : ring_quot r) = 1 := show _ = one r, by rw one
lemma add_quot {a b} : (⟨quot.mk _ a⟩ + ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a + b)⟩ :=
by { show add r _ _ = _, rw add, refl }
lemma mul_quot {a b} : (⟨quot.mk _ a⟩ * ⟨quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a * b)⟩ :=
by { show mul r _ _ = _, rw mul, refl }
lemma neg_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a} :
  (-⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (-a)⟩ :=
by { show neg r _ = _, rw neg, refl }
lemma sub_quot {R : Type u₁} [ring R] (r : R → R → Prop) {a b} :
  (⟨quot.mk _ a⟩ - ⟨ quot.mk _ b⟩ : ring_quot r) = ⟨quot.mk _ (a - b)⟩ :=
by { show sub r _ _ = _, rw sub, refl }
lemma smul_quot [algebra S R] {n : S} {a : R} :
  (n • ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (n • a)⟩ :=
by { show smul r _ _ = _, rw smul, refl }

instance (r : R → R → Prop) : semiring (ring_quot r) :=
{ add           := (+),
  mul           := (*),
  zero          := 0,
  one           := 1,
  add_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_assoc] },
  zero_add      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot] },
  add_zero      := by { rintros ⟨⟨⟩⟩, simp [add_quot, ← zero_quot], },
  zero_mul      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  mul_zero      := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← zero_quot], },
  add_comm      := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [add_quot, add_comm], },
  mul_assoc     := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_assoc] },
  one_mul       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  mul_one       := by { rintros ⟨⟨⟩⟩, simp [mul_quot, ← one_quot] },
  left_distrib  := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, left_distrib] },
  right_distrib := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, add_quot, right_distrib] },
  nsmul         := (•),
  nsmul_zero'   := by { rintros ⟨⟨⟩⟩, simp [smul_quot, ← zero_quot] },
  nsmul_succ'   := by { rintros n ⟨⟨⟩⟩, simp [smul_quot, add_quot, add_mul, add_comm] } }

instance {R : Type u₁} [ring R] (r : R → R → Prop) : ring (ring_quot r) :=
{ neg           := has_neg.neg,
  add_left_neg  := by { rintros ⟨⟨⟩⟩, simp [neg_quot, add_quot, ← zero_quot], },
  sub            := has_sub.sub,
  sub_eq_add_neg := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [neg_quot, sub_quot, add_quot, sub_eq_add_neg] },
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_semiring R] (r : R → R → Prop) : comm_semiring (ring_quot r) :=
{ mul_comm := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [mul_quot, mul_comm], }
  .. (ring_quot.semiring r) }

instance {R : Type u₁} [comm_ring R] (r : R → R → Prop) : comm_ring (ring_quot r) :=
{ .. (ring_quot.comm_semiring r),
  .. (ring_quot.ring r) }

instance (r : R → R → Prop) : inhabited (ring_quot r) := ⟨0⟩

instance [algebra S R] (r : R → R → Prop) : algebra S (ring_quot r) :=
{ smul      := (•),
  to_fun    := λ r, ⟨quot.mk _ (algebra_map S R r)⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot],
  commutes' := λ r, by { rintro ⟨⟨a⟩⟩, simp [algebra.commutes, mul_quot] },
  smul_def' := λ r, by { rintro ⟨⟨a⟩⟩, simp [smul_quot, algebra.smul_def, mul_quot], }, }

/--
The quotient map from a ring to its quotient, as a homomorphism of rings.
-/
def mk_ring_hom (r : R → R → Prop) : R →+* ring_quot r :=
{ to_fun := λ x, ⟨quot.mk _ x⟩,
  map_one'  := by simp [← one_quot],
  map_mul'  := by simp [mul_quot],
  map_zero' := by simp [← zero_quot],
  map_add'  := by simp [add_quot], }

lemma mk_ring_hom_rel {r : R → R → Prop} {x y : R} (w : r x y) :
  mk_ring_hom r x = mk_ring_hom r y :=
by simp [mk_ring_hom, quot.sound (rel.of w)]

lemma mk_ring_hom_surjective (r : R → R → Prop) : function.surjective (mk_ring_hom r) :=
by { dsimp [mk_ring_hom], rintro ⟨⟨⟩⟩, simp, }

@[ext]
lemma ring_quot_ext {T : Type u₄} [semiring T] {r : R → R → Prop} (f g : ring_quot r →+* T)
  (w : f.comp (mk_ring_hom r) = g.comp (mk_ring_hom r)) : f = g :=
begin
  ext,
  rcases mk_ring_hom_surjective r x with ⟨x, rfl⟩,
  exact (ring_hom.congr_fun w x : _),
end

variables  {T : Type u₄} [semiring T]

/--
Any ring homomorphism `f : R →+* T` which respects a relation `r : R → R → Prop`
factors uniquely through a morphism `ring_quot r →+* T`.
-/
def lift {r : R → R → Prop} :
  {f : R →+* T // ∀ ⦃x y⦄, r x y → f x = f y} ≃ (ring_quot r →+* T) :=
{ to_fun := λ f', let f := (f' : R →+* T) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y], },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y] }, },
  inv_fun := λ F, ⟨F.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩,
  left_inv := λ f, by { ext, simp, refl },
  right_inv := λ F, by { ext, simp, refl } }

@[simp]
lemma lift_mk_ring_hom_apply (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y) (x) :
  lift ⟨f, w⟩ (mk_ring_hom r x) = f x :=
rfl

-- note this is essentially `lift.symm_apply_eq.mp h`
lemma lift_unique (f : R →+* T) {r : R → R → Prop} (w : ∀ ⦃x y⦄, r x y → f x = f y)
  (g : ring_quot r →+* T) (h : g.comp (mk_ring_hom r) = f) : g = lift ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_comp_mk_ring_hom {r : R → R → Prop} (f : ring_quot r →+* T) :
  f = lift ⟨f.comp (mk_ring_hom r), λ x y h, by { dsimp, rw mk_ring_hom_rel h, }⟩ :=
(lift.apply_symm_apply f).symm

section comm_ring
/-!
We now verify that in the case of a commutative ring, the `ring_quot` construction
agrees with the quotient by the appropriate ideal.
-/

variables {B : Type u₁} [comm_ring B]

/-- The universal ring homomorphism from `ring_quot r` to `(ideal.of_rel r).quotient`. -/
def ring_quot_to_ideal_quotient (r : B → B → Prop) :
  ring_quot r →+* (ideal.of_rel r).quotient :=
lift
  ⟨ideal.quotient.mk (ideal.of_rel r),
   λ x y h, quot.sound (submodule.mem_Inf.mpr (λ p w, w ⟨x, y, h, sub_add_cancel x y⟩))⟩

@[simp] lemma ring_quot_to_ideal_quotient_apply (r : B → B → Prop) (x : B) :
  ring_quot_to_ideal_quotient r (mk_ring_hom r x) = ideal.quotient.mk _ x := rfl

/-- The universal ring homomorphism from `(ideal.of_rel r).quotient` to `ring_quot r`. -/
def ideal_quotient_to_ring_quot (r : B → B → Prop) :
  (ideal.of_rel r).quotient →+* ring_quot r :=
ideal.quotient.lift (ideal.of_rel r) (mk_ring_hom r)
begin
  refine λ x h, submodule.span_induction h _ _ _ _,
  { rintro y ⟨a, b, h, su⟩,
    symmetry' at su,
    rw ←sub_eq_iff_eq_add at su,
    rw [ ← su, ring_hom.map_sub, mk_ring_hom_rel h, sub_self], },
  { simp, },
  { intros a b ha hb, simp [ha, hb], },
  { intros a x hx, simp [hx], },
end

@[simp] lemma ideal_quotient_to_ring_quot_apply (r : B → B → Prop) (x : B) :
  ideal_quotient_to_ring_quot r (ideal.quotient.mk _ x) = mk_ring_hom r x := rfl

/--
The ring equivalence between `ring_quot r` and `(ideal.of_rel r).quotient`
-/
def ring_quot_equiv_ideal_quotient (r : B → B → Prop) :
  ring_quot r ≃+* (ideal.of_rel r).quotient :=
ring_equiv.of_hom_inv (ring_quot_to_ideal_quotient r) (ideal_quotient_to_ring_quot r)
  (by { ext, simp, }) (by { ext ⟨x⟩, simp, })

end comm_ring

section star_ring

variables [star_ring R] (r) (hr : ∀ a b, r a b → r (star a) (star b))
include hr

theorem rel.star ⦃a b : R⦄ (h : rel r a b) :
  rel r (star a) (star b) :=
begin
  induction h,
  { exact rel.of (hr _ _ h_h) },
  { rw [star_add, star_add], exact rel.add_left h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_right h_ih, },
  { rw [star_mul, star_mul], exact rel.mul_left h_ih, },
end

@[irreducible] private def star' : ring_quot r → ring_quot r
| ⟨a⟩ := ⟨quot.map (_root_.star : R → R) (rel.star r hr) a⟩

lemma star'_quot (hr : ∀ a b, r a b → r (star a) (star b)) {a} :
  (star' r hr ⟨quot.mk _ a⟩ : ring_quot r) = ⟨quot.mk _ (star a)⟩ :=
by { show star' r _ _ = _, rw star', refl }

/-- Transfer a star_ring instance through a quotient, if the quotient is invariant to `star` -/
def star_ring {R : Type u₁} [semiring R] [star_ring R] (r : R → R → Prop)
  (hr : ∀ a b, r a b → r (star a) (star b)) :
  star_ring (ring_quot r) :=
{ star := star' r hr,
  star_involutive := by { rintros ⟨⟨⟩⟩, simp [star'_quot], },
  star_mul := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, mul_quot, star_mul], },
  star_add := by { rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩, simp [star'_quot, add_quot, star_add], } }

end star_ring

section algebra

variables (S)

/--
The quotient map from an `S`-algebra to its quotient, as a homomorphism of `S`-algebras.
-/
def mk_alg_hom (s : A → A → Prop) : A →ₐ[S] ring_quot s :=
{ commutes' := λ r, rfl,
  ..mk_ring_hom s }

@[simp]
lemma mk_alg_hom_coe (s : A → A → Prop) : (mk_alg_hom S s : A →+* ring_quot s) = mk_ring_hom s :=
rfl

lemma mk_alg_hom_rel {s : A → A → Prop} {x y : A} (w : s x y) :
  mk_alg_hom S s x = mk_alg_hom S s y :=
by simp [mk_alg_hom, mk_ring_hom, quot.sound (rel.of w)]

lemma mk_alg_hom_surjective (s : A → A → Prop) : function.surjective (mk_alg_hom S s) :=
by { dsimp [mk_alg_hom], rintro ⟨⟨a⟩⟩, use a, refl, }

variables {B : Type u₄} [semiring B] [algebra S B]

@[ext]
lemma ring_quot_ext' {s : A → A → Prop}
  (f g : ring_quot s →ₐ[S] B) (w : f.comp (mk_alg_hom S s) = g.comp (mk_alg_hom S s)) : f = g :=
begin
  ext,
  rcases mk_alg_hom_surjective S s x with ⟨x, rfl⟩,
  exact (alg_hom.congr_fun w x : _),
end

/--
Any `S`-algebra homomorphism `f : A →ₐ[S] B` which respects a relation `s : A → A → Prop`
factors uniquely through a morphism `ring_quot s →ₐ[S]  B`.
-/
def lift_alg_hom {s : A → A → Prop} :
  { f : A →ₐ[S] B // ∀ ⦃x y⦄, s x y → f x = f y} ≃ (ring_quot s →ₐ[S] B) :=
{ to_fun := λ f', let f := (f' : A →ₐ[S] B) in
  { to_fun := λ x, quot.lift f
    begin
      rintros _ _ r,
      induction r,
      case of : _ _ r { exact f'.prop r, },
      case add_left : _ _ _ _ r' { simp [r'], },
      case mul_left : _ _ _ _ r' { simp [r'], },
      case mul_right : _ _ _ _ r' { simp [r'], },
    end x.to_quot,
    map_zero' := by simp [← zero_quot, f.map_zero],
    map_add' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [add_quot, f.map_add x y] },
    map_one' := by simp [← one_quot, f.map_one],
    map_mul' := by { rintros ⟨⟨x⟩⟩ ⟨⟨y⟩⟩, simp [mul_quot, f.map_mul x y], },
    commutes' := by { rintros x, simp [← one_quot, smul_quot, algebra.algebra_map_eq_smul_one] } },
  inv_fun := λ F, ⟨F.comp (mk_alg_hom S s), λ _ _ h, by { dsimp, erw mk_alg_hom_rel S h }⟩,
  left_inv := λ f, by { ext, simp, refl },
  right_inv := λ F, by { ext, simp, refl } }

@[simp]
lemma lift_alg_hom_mk_alg_hom_apply (f : A →ₐ[S] B) {s : A → A → Prop}
  (w : ∀ ⦃x y⦄, s x y → f x = f y) (x) :
  (lift_alg_hom S ⟨f, w⟩) ((mk_alg_hom S s) x) = f x :=
rfl

-- note this is essentially `(lift_alg_hom S).symm_apply_eq.mp h`
lemma lift_alg_hom_unique (f : A →ₐ[S] B) {s : A → A → Prop} (w : ∀ ⦃x y⦄, s x y → f x = f y)
  (g : ring_quot s →ₐ[S] B) (h : g.comp (mk_alg_hom S s) = f) : g = lift_alg_hom S ⟨f, w⟩ :=
by { ext, simp [h], }

lemma eq_lift_alg_hom_comp_mk_alg_hom {s : A → A → Prop} (f : ring_quot s →ₐ[S] B) :
  f = lift_alg_hom S ⟨f.comp (mk_alg_hom S s), λ x y h, by { dsimp, erw mk_alg_hom_rel S h, }⟩ :=
((lift_alg_hom S).apply_symm_apply f).symm

end algebra

attribute [irreducible] mk_ring_hom mk_alg_hom lift lift_alg_hom

end ring_quot


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

import ring_theory.non_zero_divisors
import data.polynomial.algebra_map

/-!
# Scaling the roots of a polynomial

This file defines `scale_roots p s` for a polynomial `p` in one variable and a ring element `s` to
be the polynomial with root `r * s` for each root `r` of `p` and proves some basic results about it.
-/

section scale_roots

variables {A K R S : Type*} [comm_ring A] [is_domain A] [field K] [comm_ring R] [comm_ring S]
variables {M : submonoid A}

open polynomial
open_locale big_operators polynomial

/-- `scale_roots p s` is a polynomial with root `r * s` for each root `r` of `p`. -/
noncomputable def scale_roots (p : R[X]) (s : R) : R[X] :=
∑ i in p.support, monomial i (p.coeff i * s ^ (p.nat_degree - i))

@[simp] lemma coeff_scale_roots (p : R[X]) (s : R) (i : ℕ) :
  (scale_roots p s).coeff i = coeff p i * s ^ (p.nat_degree - i) :=
by simp [scale_roots, coeff_monomial] {contextual := tt}

@[simp] lemma zero_scale_roots (s : R) : scale_roots 0 s = 0 := by { ext, simp }

lemma scale_roots_ne_zero {p : R[X]} (hp : p ≠ 0) (s : R) :
  scale_roots p s ≠ 0 :=
begin
  intro h,
  have : p.coeff p.nat_degree ≠ 0 := mt leading_coeff_eq_zero.mp hp,
  have : (scale_roots p s).coeff p.nat_degree = 0 :=
    congr_fun (congr_arg (coeff : R[X] → ℕ → R) h) p.nat_degree,
  rw [coeff_scale_roots_nat_degree] at this,
  contradiction
end

lemma support_scale_roots_le (p : R[X]) (s : R) :
  (scale_roots p s).support ≤ p.support :=
by { intro, simpa using left_ne_zero_of_mul }

lemma support_scale_roots_eq (p : R[X]) {s : R} (hs : s ∈ non_zero_divisors R) :
  (scale_roots p s).support = p.support :=
le_antisymm (support_scale_roots_le p s)
  begin
    intro i,
    simp only [coeff_scale_roots, polynomial.mem_support_iff],
    intros p_ne_zero ps_zero,
    have := ((non_zero_divisors R).pow_mem hs (p.nat_degree - i)) _ ps_zero,
    contradiction
  end

@[simp] lemma degree_scale_roots (p : R[X]) {s : R} :
  degree (scale_roots p s) = degree p :=
begin
  haveI := classical.prop_decidable,
  by_cases hp : p = 0,
  { rw [hp, zero_scale_roots] },
  have := scale_roots_ne_zero hp s,
  refine le_antisymm (finset.sup_mono (support_scale_roots_le p s)) (degree_le_degree _),
  rw coeff_scale_roots_nat_degree,
  intro h,
  have := leading_coeff_eq_zero.mp h,
  contradiction,
end

@[simp] lemma nat_degree_scale_roots (p : R[X]) (s : R) :
  nat_degree (scale_roots p s) = nat_degree p :=
by simp only [nat_degree, degree_scale_roots]

lemma monic_scale_roots_iff {p : R[X]} (s : R) :
  monic (scale_roots p s) ↔ monic p :=
by simp only [monic, leading_coeff, nat_degree_scale_roots, coeff_scale_roots_nat_degree]

lemma scale_roots_eval₂_eq_zero {p : S[X]} (f : S →+* R)
  {r : R} {s : S} (hr : eval₂ f r p = 0) :
  eval₂ f (f s * r) (scale_roots p s) = 0 :=
calc eval₂ f (f s * r) (scale_roots p s) =
  (scale_roots p s).support.sum (λ i, f (coeff p i * s ^ (p.nat_degree - i)) * (f s * r) ^ i) :
  by simp [eval₂_eq_sum, sum_def]
... = p.support.sum (λ i, f (coeff p i * s ^ (p.nat_degree - i)) * (f s * r) ^ i) :
  finset.sum_subset (support_scale_roots_le p s)
  (λ i hi hi', let this : coeff p i * s ^ (p.nat_degree - i) = 0 :=
  by simpa using hi' in by simp [this])
... = p.support.sum (λ (i : ℕ), f (p.coeff i) * f s ^ (p.nat_degree - i + i) * r ^ i) :
  finset.sum_congr rfl
  (λ i hi, by simp_rw [f.map_mul, f.map_pow, pow_add, mul_pow, mul_assoc])
... = p.support.sum (λ (i : ℕ), f s ^ p.nat_degree * (f (p.coeff i) * r ^ i)) :
  finset.sum_congr rfl
  (λ i hi, by { rw [mul_assoc, mul_left_comm, tsub_add_cancel_of_le],
                exact le_nat_degree_of_ne_zero (polynomial.mem_support_iff.mp hi) })
... = f s ^ p.nat_degree * p.support.sum (λ (i : ℕ), (f (p.coeff i) * r ^ i)) : finset.mul_sum.symm
... = f s ^ p.nat_degree * eval₂ f r p : by { simp [eval₂_eq_sum, sum_def] }
... = 0 : by rw [hr, _root_.mul_zero]

lemma scale_roots_aeval_eq_zero [algebra S R] {p : S[X]}
  {r : R} {s : S} (hr : aeval r p = 0) :
  aeval (algebra_map S R s * r) (scale_roots p s) = 0 :=
scale_roots_eval₂_eq_zero (algebra_map S R) hr

lemma scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero
  {p : A[X]} {f : A →+* K} (hf : function.injective f)
  {r s : A} (hr : eval₂ f (f r / f s) p = 0) (hs : s ∈ non_zero_divisors A) :
  eval₂ f (f r) (scale_roots p s) = 0 :=
begin
  convert scale_roots_eval₂_eq_zero f hr,
  rw [←mul_div_assoc, mul_comm, mul_div_cancel],
  exact map_ne_zero_of_mem_non_zero_divisors _ hf hs
end

lemma scale_roots_aeval_eq_zero_of_aeval_div_eq_zero [algebra A K]
  (inj : function.injective (algebra_map A K)) {p : A[X]} {r s : A}
  (hr : aeval (algebra_map A K r / algebra_map A K s) p = 0) (hs : s ∈ non_zero_divisors A) :
  aeval (algebra_map A K r) (scale_roots p s) = 0 :=
scale_roots_eval₂_eq_zero_of_eval₂_div_eq_zero inj hr hs

end scale_roots


import Mathlib.Init.Data.Nat.Notation
import Mathlib.Tactic.Basic
import Mathlib.Tactic.ApplyFun
import Mathlib.Init.Function
import Mathlib.Data.Fintype.Card
-- import Mathlib.Data.Matrix.Basic

open Function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : Injective $ g ∘ f) : Injective f := by
  intros x x' h
  apply_fun g at h
  exact H h

example (x : Int) (h : x = 1) : 1 = 1 := by
  apply_fun (fun p => p) at h
  rfl

example (a b : Int) (h : a = b) : a + 1 = b + 1 := by
  -- Make sure that we infer the type of the function only after we see the hypothesis:
  apply_fun (fun n => n + 1) at h
  -- check that `h` was β-reduced
  guard_hyp h :ₛ a + 1 = b + 1
  exact h

-- Verify failure when applying a dependently typed function.
example (P : Nat → Type) (Q : (n : Nat) -> P n) (a b : Nat) (h : a = b) : True := by
  fail_if_success apply_fun Q at h
  trivial

-- TODO restore and port these tests from mathlib3

example (f : ℕ → ℕ) (a b : ℕ) (monof : Monotone f) (h : a ≤ b) : f a ≤ f b := by
  apply_fun f at h using monof
  assumption

example (f : ℕ → ℕ) (a b : ℕ) (monof : Monotone f) (h : a ≤ b) : f a ≤ f b := by
  apply_fun f at h
  · assumption
  · assumption

example (n m : ℕ) (f : ℕ → ℕ) (h : f n ≠ f m) : n ≠ m := by
  apply_fun f
  exact h

example (n m : ℕ) (f : ℕ → ℕ) (w : Function.Injective f) (h : f n = f m) : n = m := by
  apply_fun f
  assumption

example (n m : ℕ) (f : ℕ → ℕ) (w : Function.Injective f) (h : f n = f m) : n = m := by
  apply_fun f using w
  assumption

example (n m : ℕ) (f : ℕ → ℕ) (w : Function.Injective f ∧ true) (h : f n = f m) : n = m := by
  apply_fun f using w.1
  assumption

example (a b : List α) (P : a = b) : True := by
  apply_fun List.length at P
  trivial

-- -- monotonicity will be proved by `mono` in the next example
-- example (a b : ℕ) (h : a ≤ b) : a + 1 ≤ b + 1 :=
-- begin
--   apply_fun (λ n, n+1) at h,
--   exact h
-- end

-- example {n : Type} [fintype n] {X : Type} [semiring X]
--   (f : matrix n n X → matrix n n X) (A B : matrix n n X) (h : A * B = 0) : f (A * B) = f 0 :=
-- begin
--   apply_fun f at h,
--   -- check that our β-reduction didn't mess things up:
--   -- (previously `apply_fun` was producing `f (A.mul B) = f 0`)
--   guard_hyp' h : f (A * B) = f 0,
--   exact h,
-- end

-- -- Verify that `apply_fun` works with `fin.cast_succ`, even though it has an implicit argument.
-- example (n : ℕ) (a b : fin n) (H : a ≤ b) : a.cast_succ ≤ b.cast_succ :=
-- begin
--   apply_fun fin.cast_succ at H,
--   exact H,
-- end

-- example (n m : ℕ) (f : ℕ ≃ ℕ) (h : f n = f m) : n = m :=
-- begin
--   apply_fun f,
--   assumption,
-- end

-- example (n m : ℕ) (f : ℕ ≃o ℕ) (h : f n ≤ f m) : n ≤ m :=
-- begin
--   apply_fun f,
--   assumption,
-- end

-- example (n m : ℕ) (f : ℕ ≃o ℕ) (h : f n < f m) : n < m :=
-- begin
--   apply_fun f,
--   assumption,
-- end

example : ∀ m n : ℕ, m = n → (m < 2) = (n < 2) := by
  refine fun m n h => ?_
  apply_fun (· < 2) at h
  exact h

example : ∀ m n : ℕ, m = n → (m < 2) = (n < 2) := by
  intro m n h
  apply_fun (· < 2) at h
  exact h

example (f : ℕ ≃ ℕ) (a b : ℕ) (h : a = b) : True := by
  apply_fun f at h
  guard_hyp h : f a = f b
  trivial

example (f : ℤ ≃ ℤ) (a b : ℕ) (h : a = b) : True := by
  apply_fun f at h
  guard_hyp h : f a = f b
  trivial

example (f : ℤ ≃ ℤ) (a b : α) (h : a = b) : True := by
  fail_if_success apply_fun f at h
  trivial

example (f : ℕ → ℕ) (a b : ℕ) (h : a = b) : True := by
  apply_fun f at h
  guard_hyp h : f a = f b
  trivial

example (f : {i : Nat} → Fin i → ℕ) (a b : Fin 37) (h : a = b) : True := by
  apply_fun f at h
  guard_hyp h : f a = f b
  trivial

example (f : (p : Prop) → [Decidable p] → Nat) (p q : Prop) (h : p = q)
    (h' : {n m : Nat} → n = m → True) : True := by
  classical
  apply_fun f at h
  apply h'
  exact h

example (f : (p : Prop) → [Decidable p] → Nat) (p q : Prop) (h : p = q)
    (h' : {n m : Nat} → n = m → True) : True := by
  classical
  apply_fun (fun x [Decidable x] => f x) at h
  apply h'
  exact h

example (a b : ℕ) (h : a = b) : True := by
  apply_fun (fun i => i + ?_) at h
  · trivial
  · exact 37

-- Check that it can solve congruence (needs Subsingleton.elim for the fintype instances)
example (α β : Type u) [Fintype α] [Fintype β] (h : α = β) : True := by
  apply_fun Fintype.card at h
  guard_hyp h : Fintype.card α = Fintype.card β
  trivial


/-
Copyright (c) 2020 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Yury G. Kudryashov
-/
import data.sum
import order.basic

/-!
# Unbundled relation classes

In this file we prove some properties of `is_*` classes defined in `init.algebra.classes`. The main
difference between these classes and the usual order classes (`preorder` etc) is that usual classes
extend `has_le` and/or `has_lt` while these classes take a relation as an explicit argument.

-/

universes u v

variables {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop}

open function

theorem is_refl.swap (r) [is_refl α r] : is_refl α (swap r) := ⟨refl_of r⟩
theorem is_irrefl.swap (r) [is_irrefl α r] : is_irrefl α (swap r) := ⟨irrefl_of r⟩
theorem is_trans.swap (r) [is_trans α r] : is_trans α (swap r) :=
⟨λ a b c h₁ h₂, trans_of r h₂ h₁⟩
theorem is_antisymm.swap (r) [is_antisymm α r] : is_antisymm α (swap r) :=
⟨λ a b h₁ h₂, antisymm h₂ h₁⟩
theorem is_asymm.swap (r) [is_asymm α r] : is_asymm α (swap r) :=
⟨λ a b h₁ h₂, asymm_of r h₂ h₁⟩
theorem is_total.swap (r) [is_total α r] : is_total α (swap r) :=
⟨λ a b, (total_of r a b).swap⟩
theorem is_trichotomous.swap (r) [is_trichotomous α r] : is_trichotomous α (swap r) :=
⟨λ a b, by simpa [swap, or.comm, or.left_comm] using trichotomous_of r a b⟩
theorem is_preorder.swap (r) [is_preorder α r] : is_preorder α (swap r) :=
{..@is_refl.swap α r _, ..@is_trans.swap α r _}
theorem is_strict_order.swap (r) [is_strict_order α r] : is_strict_order α (swap r) :=
{..@is_irrefl.swap α r _, ..@is_trans.swap α r _}
theorem is_partial_order.swap (r) [is_partial_order α r] : is_partial_order α (swap r) :=
{..@is_preorder.swap α r _, ..@is_antisymm.swap α r _}
theorem is_total_preorder.swap (r) [is_total_preorder α r] : is_total_preorder α (swap r) :=
{..@is_preorder.swap α r _, ..@is_total.swap α r _}
theorem is_linear_order.swap (r) [is_linear_order α r] : is_linear_order α (swap r) :=
{..@is_partial_order.swap α r _, ..@is_total.swap α r _}

protected theorem is_asymm.is_antisymm (r) [is_asymm α r] : is_antisymm α r :=
⟨λ x y h₁ h₂, (asymm h₁ h₂).elim⟩
protected theorem is_asymm.is_irrefl [is_asymm α r] : is_irrefl α r :=
⟨λ a h, asymm h h⟩
protected theorem is_total.is_trichotomous (r) [is_total α r] : is_trichotomous α r :=
⟨λ a b, or.left_comm.1 (or.inr $ total_of r a b)⟩

/- Convert algebraic structure style to explicit relation style typeclasses -/
instance [preorder α] : is_refl α (≤) := ⟨le_refl⟩
instance [preorder α] : is_refl α (≥) := is_refl.swap _
instance [preorder α] : is_trans α (≤) := ⟨@le_trans _ _⟩
instance [preorder α] : is_trans α (≥) := is_trans.swap _
instance [preorder α] : is_preorder α (≤) := {}
instance [preorder α] : is_preorder α (≥) := {}
instance [preorder α] : is_irrefl α (<) := ⟨lt_irrefl⟩
instance [preorder α] : is_irrefl α (>) := is_irrefl.swap _
instance [preorder α] : is_trans α (<) := ⟨@lt_trans _ _⟩
instance [preorder α] : is_trans α (>) := is_trans.swap _
instance [preorder α] : is_asymm α (<) := ⟨@lt_asymm _ _⟩
instance [preorder α] : is_asymm α (>) := is_asymm.swap _
instance [preorder α] : is_antisymm α (<) := is_asymm.is_antisymm _
instance [preorder α] : is_antisymm α (>) := is_asymm.is_antisymm _
instance [preorder α] : is_strict_order α (<) := {}
instance [preorder α] : is_strict_order α (>) := {}
instance [partial_order α] : is_antisymm α (≤) := ⟨@le_antisymm _ _⟩
instance [partial_order α] : is_antisymm α (≥) := is_antisymm.swap _
instance [partial_order α] : is_partial_order α (≤) := {}
instance [partial_order α] : is_partial_order α (≥) := {}
instance [linear_order α] : is_total α (≤) := ⟨le_total⟩
instance [linear_order α] : is_total α (≥) := is_total.swap _
instance linear_order.is_total_preorder [linear_order α] : is_total_preorder α (≤) :=
  by apply_instance
instance [linear_order α] : is_total_preorder α (≥) := {}
instance [linear_order α] : is_linear_order α (≤) := {}
instance [linear_order α] : is_linear_order α (≥) := {}
instance [linear_order α] : is_trichotomous α (<) := ⟨lt_trichotomy⟩
instance [linear_order α] : is_trichotomous α (>) := is_trichotomous.swap _
instance [linear_order α] : is_trichotomous α (≤) := is_total.is_trichotomous _
instance [linear_order α] : is_trichotomous α (≥) := is_total.is_trichotomous _

instance order_dual.is_total_le [has_le α] [is_total α (≤)] : is_total (order_dual α) (≤) :=
@is_total.swap α _ _

lemma ne_of_irrefl {r} [is_irrefl α r] : ∀ {x y : α}, r x y → x ≠ y
| _ _ h rfl := irrefl _ h

lemma trans_trichotomous_left [is_trans α r] [is_trichotomous α r] {a b c : α} :
  ¬r b a → r b c → r a c :=
begin
  intros h₁ h₂, rcases trichotomous_of r a b with h₃|h₃|h₃,
  exact trans h₃ h₂, rw h₃, exact h₂, exfalso, exact h₁ h₃
end

lemma trans_trichotomous_right [is_trans α r] [is_trichotomous α r] {a b c : α} :
  r a b → ¬r c b → r a c :=
begin
  intros h₁ h₂, rcases trichotomous_of r b c with h₃|h₃|h₃,
  exact trans h₁ h₃, rw ←h₃, exact h₁, exfalso, exact h₂ h₃
end

/-- Construct a partial order from a `is_strict_order` relation.

See note [reducible non-instances]. -/
@[reducible] def partial_order_of_SO (r) [is_strict_order α r] : partial_order α :=
{ le := λ x y, x = y ∨ r x y,
  lt := r,
  le_refl := λ x, or.inl rfl,
  le_trans := λ x y z h₁ h₂,
    match y, z, h₁, h₂ with
    | _, _, or.inl rfl, h₂ := h₂
    | _, _, h₁, or.inl rfl := h₁
    | _, _, or.inr h₁, or.inr h₂ := or.inr (trans h₁ h₂)
    end,
  le_antisymm := λ x y h₁ h₂,
    match y, h₁, h₂ with
    | _, or.inl rfl, h₂ := rfl
    | _, h₁, or.inl rfl := rfl
    | _, or.inr h₁, or.inr h₂ := (asymm h₁ h₂).elim
    end,
  lt_iff_le_not_le := λ x y,
    ⟨λ h, ⟨or.inr h, not_or
      (λ e, by rw e at h; exact irrefl _ h)
      (asymm h)⟩,
    λ ⟨h₁, h₂⟩, h₁.resolve_left (λ e, h₂ $ e ▸ or.inl rfl)⟩ }

/-- This is basically the same as `is_strict_total_order`, but that definition has a redundant
assumption `is_incomp_trans α lt`. -/
@[algebra] class is_strict_total_order' (α : Type u) (lt : α → α → Prop)
  extends is_trichotomous α lt, is_strict_order α lt : Prop.

/-- Construct a linear order from an `is_strict_total_order'` relation.

See note [reducible non-instances]. -/
@[reducible]
def linear_order_of_STO' (r) [is_strict_total_order' α r] [Π x y, decidable (¬ r x y)] :
  linear_order α :=
{ le_total := λ x y,
    match y, trichotomous_of r x y with
    | y, or.inl h := or.inl (or.inr h)
    | _, or.inr (or.inl rfl) := or.inl (or.inl rfl)
    | _, or.inr (or.inr h) := or.inr (or.inr h)
    end,
  decidable_le := λ x y, decidable_of_iff (¬ r y x)
    ⟨λ h, ((trichotomous_of r y x).resolve_left h).imp eq.symm id,
      λ h, h.elim (λ h, h ▸ irrefl_of _ _) (asymm_of r)⟩,
  ..partial_order_of_SO r }

theorem is_strict_total_order'.swap (r) [is_strict_total_order' α r] :
  is_strict_total_order' α (swap r) :=
{..is_trichotomous.swap r, ..is_strict_order.swap r}

instance [linear_order α] : is_strict_total_order' α (<) := {}

/-- A connected order is one satisfying the condition `a < c → a < b ∨ b < c`.
  This is recognizable as an intuitionistic substitute for `a ≤ b ∨ b ≤ a` on
  the constructive reals, and is also known as negative transitivity,
  since the contrapositive asserts transitivity of the relation `¬ a < b`.  -/
@[algebra] class is_order_connected (α : Type u) (lt : α → α → Prop) : Prop :=
(conn : ∀ a b c, lt a c → lt a b ∨ lt b c)

theorem is_order_connected.neg_trans {r : α → α → Prop} [is_order_connected α r]
  {a b c} (h₁ : ¬ r a b) (h₂ : ¬ r b c) : ¬ r a c :=
mt (is_order_connected.conn a b c) $ by simp [h₁, h₂]

theorem is_strict_weak_order_of_is_order_connected [is_asymm α r]
  [is_order_connected α r] : is_strict_weak_order α r :=
{ trans := λ a b c h₁ h₂, (is_order_connected.conn _ c _ h₁).resolve_right (asymm h₂),
  incomp_trans := λ a b c ⟨h₁, h₂⟩ ⟨h₃, h₄⟩,
    ⟨is_order_connected.neg_trans h₁ h₃, is_order_connected.neg_trans h₄ h₂⟩,
  ..@is_asymm.is_irrefl α r _ }

@[priority 100] -- see Note [lower instance priority]
instance is_order_connected_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_order_connected α r :=
⟨λ a b c h, (trichotomous _ _).imp_right (λ o,
  o.elim (λ e, e ▸ h) (λ h', trans h' h))⟩

@[priority 100] -- see Note [lower instance priority]
instance is_strict_total_order_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_strict_total_order α r :=
{..is_strict_weak_order_of_is_order_connected}

instance [linear_order α] : is_strict_total_order α (<) := by apply_instance
instance [linear_order α] : is_order_connected α (<) := by apply_instance
instance [linear_order α] : is_incomp_trans α (<) := by apply_instance
instance [linear_order α] : is_strict_weak_order α (<) := by apply_instance

/-- An extensional relation is one in which an element is determined by its set
  of predecessors. It is named for the `x ∈ y` relation in set theory, whose
  extensionality is one of the first axioms of ZFC. -/
@[algebra] class is_extensional (α : Type u) (r : α → α → Prop) : Prop :=
(ext : ∀ a b, (∀ x, r x a ↔ r x b) → a = b)

@[priority 100] -- see Note [lower instance priority]
instance is_extensional_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_extensional α r :=
⟨λ a b H, ((@trichotomous _ r _ a b)
  .resolve_left $ mt (H _).2 (irrefl a))
  .resolve_right $ mt (H _).1 (irrefl b)⟩

/-- A well order is a well-founded linear order. -/
@[algebra] class is_well_order (α : Type u) (r : α → α → Prop)
  extends is_strict_total_order' α r : Prop :=
(wf : well_founded r)

@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_strict_total_order {α} (r : α → α → Prop) [is_well_order α r] :
  is_strict_total_order α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_extensional {α} (r : α → α → Prop) [is_well_order α r] :
  is_extensional α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_trichotomous {α} (r : α → α → Prop) [is_well_order α r] :
  is_trichotomous α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_trans {α} (r : α → α → Prop) [is_well_order α r] :
  is_trans α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_irrefl {α} (r : α → α → Prop) [is_well_order α r] :
  is_irrefl α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_asymm {α} (r : α → α → Prop) [is_well_order α r] :
  is_asymm α r := by apply_instance

/-- Construct a decidable linear order from a well-founded linear order. -/
noncomputable def is_well_order.linear_order (r : α → α → Prop) [is_well_order α r] :
  linear_order α :=
by { letI := λ x y, classical.dec (¬r x y), exact linear_order_of_STO' r }

instance empty_relation.is_well_order [subsingleton α] : is_well_order α empty_relation :=
{ trichotomous := λ a b, or.inr $ or.inl $ subsingleton.elim _ _,
  irrefl       := λ a, id,
  trans        := λ a b c, false.elim,
  wf           := ⟨λ a, ⟨_, λ y, false.elim⟩⟩ }

instance nat.lt.is_well_order : is_well_order ℕ (<) := ⟨nat.lt_wf⟩

instance sum.lex.is_well_order [is_well_order α r] [is_well_order β s] :
  is_well_order (α ⊕ β) (sum.lex r s) :=
{ trichotomous := λ a b, by cases a; cases b; simp; apply trichotomous,
  irrefl       := λ a, by cases a; simp; apply irrefl,
  trans        := λ a b c, by cases a; cases b; simp; cases c; simp; apply trans,
  wf           := sum.lex_wf is_well_order.wf is_well_order.wf }

instance prod.lex.is_well_order [is_well_order α r] [is_well_order β s] :
  is_well_order (α × β) (prod.lex r s) :=
{ trichotomous := λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩,
    match @trichotomous _ r _ a₁ b₁ with
    | or.inl h₁ := or.inl $ prod.lex.left _ _ h₁
    | or.inr (or.inr h₁) := or.inr $ or.inr $ prod.lex.left _ _ h₁
    | or.inr (or.inl e) := e ▸  match @trichotomous _ s _ a₂ b₂ with
      | or.inl h := or.inl $ prod.lex.right _ h
      | or.inr (or.inr h) := or.inr $ or.inr $ prod.lex.right _ h
      | or.inr (or.inl e) := e ▸ or.inr $ or.inl rfl
      end
    end,
  irrefl := λ ⟨a₁, a₂⟩ h, by cases h with _ _ _ _ h _ _ _ h;
     [exact irrefl _ h, exact irrefl _ h],
  trans := λ a b c h₁ h₂, begin
    cases h₁ with a₁ a₂ b₁ b₂ ab a₁ b₁ b₂ ab;
    cases h₂ with _ _ c₁ c₂ bc _ _ c₂ bc,
    { exact prod.lex.left _ _ (trans ab bc) },
    { exact prod.lex.left _ _ ab },
    { exact prod.lex.left _ _ bc },
    { exact prod.lex.right _ (trans ab bc) }
  end,
  wf := prod.lex_wf is_well_order.wf is_well_order.wf }

/-- An unbounded or cofinal set -/
def unbounded (r : α → α → Prop) (s : set α) : Prop := ∀ a, ∃ b ∈ s, ¬ r b a
/-- A bounded or final set -/
def bounded (r : α → α → Prop) (s : set α) : Prop := ∃a, ∀ b ∈ s, r b a

@[simp] lemma not_bounded_iff {r : α → α → Prop} (s : set α) : ¬bounded r s ↔ unbounded r s :=
begin
  classical,
  simp only [bounded, unbounded, not_forall, not_exists, exists_prop, not_and, not_not]
end

@[simp] lemma not_unbounded_iff {r : α → α → Prop} (s : set α) : ¬unbounded r s ↔ bounded r s :=
by { classical, rw [not_iff_comm, not_bounded_iff] }

namespace prod

instance is_refl_preimage_fst {r : α → α → Prop} [h : is_refl α r] :
  is_refl (α × α) (prod.fst ⁻¹'o r) := ⟨λ a, refl_of r a.1⟩

instance is_refl_preimage_snd {r : α → α → Prop} [h : is_refl α r] :
  is_refl (α × α) (prod.snd ⁻¹'o r) := ⟨λ a, refl_of r a.2⟩

instance is_trans_preimage_fst {r : α → α → Prop} [h : is_trans α r] :
  is_trans (α × α) (prod.fst ⁻¹'o r) := ⟨λ _ _ _, trans_of r⟩

instance is_trans_preimage_snd {r : α → α → Prop} [h : is_trans α r] :
  is_trans (α × α) (prod.snd ⁻¹'o r) := ⟨λ _ _ _, trans_of r⟩

end prod


/-
Copyright (c) 2019 Calle Sönne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Calle Sönne
-/
import analysis.special_functions.trigonometric.basic

/-!
# The type of angles

In this file we define `real.angle` to be the quotient group `ℝ/2πℤ` and prove a few simple lemmas
about trigonometric functions and angles.
-/

open_locale real

noncomputable theory

namespace real

/-- The type of angles -/
@[derive [add_comm_group, topological_space, topological_add_group]]
def angle : Type :=
ℝ ⧸ (add_subgroup.zmultiples (2 * π))

namespace angle

instance : inhabited angle := ⟨0⟩

instance : has_coe ℝ angle := ⟨quotient_add_group.mk' _⟩

@[continuity] lemma continuous_coe : continuous (coe : ℝ → angle) :=
continuous_quotient_mk

/-- Coercion `ℝ → angle` as an additive homomorphism. -/
def coe_hom : ℝ →+ angle := quotient_add_group.mk' _

@[simp] lemma coe_coe_hom : (coe_hom : ℝ → angle) = coe := rfl

/-- An induction principle to deduce results for `angle` from those for `ℝ`, used with
`induction θ using real.angle.induction_on`. -/
@[elab_as_eliminator]
protected lemma induction_on {p : angle → Prop} (θ : angle) (h : ∀ x : ℝ, p x) : p θ :=
quotient.induction_on' θ h

@[simp] lemma coe_zero : ↑(0 : ℝ) = (0 : angle) := rfl
@[simp] lemma coe_add (x y : ℝ) : ↑(x + y : ℝ) = (↑x + ↑y : angle) := rfl
@[simp] lemma coe_neg (x : ℝ) : ↑(-x : ℝ) = -(↑x : angle) := rfl
@[simp] lemma coe_sub (x y : ℝ) : ↑(x - y : ℝ) = (↑x - ↑y : angle) := rfl

@[simp, norm_cast] lemma coe_nat_mul_eq_nsmul (x : ℝ) (n : ℕ) :
  ↑((n : ℝ) * x) = n • (↑x : angle) :=
by simpa only [nsmul_eq_mul] using coe_hom.map_nsmul x n

@[simp, norm_cast] lemma coe_int_mul_eq_zsmul (x : ℝ) (n : ℤ) :
  ↑((n : ℝ) * x : ℝ) = n • (↑x : angle) :=
by simpa only [zsmul_eq_mul] using coe_hom.map_zsmul x n

lemma angle_eq_iff_two_pi_dvd_sub {ψ θ : ℝ} : (θ : angle) = ψ ↔ ∃ k : ℤ, θ - ψ = 2 * π * k :=
by simp only [quotient_add_group.eq, add_subgroup.zmultiples_eq_closure,
  add_subgroup.mem_closure_singleton, zsmul_eq_mul', (sub_eq_neg_add _ _).symm, eq_comm]

@[simp] lemma coe_two_pi : ↑(2 * π : ℝ) = (0 : angle) :=
angle_eq_iff_two_pi_dvd_sub.2 ⟨1, by rw [sub_zero, int.cast_one, mul_one]⟩

@[simp] lemma neg_coe_pi : -(π : angle) = π :=
begin
  rw [←coe_neg, angle_eq_iff_two_pi_dvd_sub],
  use -1,
  simp [two_mul, sub_eq_add_neg]
end

lemma sub_coe_pi_eq_add_coe_pi (θ : angle) : θ - π = θ + π :=
by rw [sub_eq_add_neg, neg_coe_pi]

@[simp] lemma two_nsmul_coe_pi : (2 : ℕ) • (π : angle) = 0 :=
by simp [←coe_nat_mul_eq_nsmul]

@[simp] lemma two_zsmul_coe_pi : (2 : ℤ) • (π : angle) = 0 :=
by simp [←coe_int_mul_eq_zsmul]

@[simp] lemma coe_pi_add_coe_pi : (π : real.angle) + π = 0 :=
by rw [←two_nsmul, two_nsmul_coe_pi]

theorem cos_eq_iff_eq_or_eq_neg {θ ψ : ℝ} : cos θ = cos ψ ↔ (θ : angle) = ψ ∨ (θ : angle) = -ψ :=
begin
  split,
  { intro Hcos,
    rw [← sub_eq_zero, cos_sub_cos, mul_eq_zero, mul_eq_zero, neg_eq_zero,
        eq_false_intro two_ne_zero, false_or, sin_eq_zero_iff, sin_eq_zero_iff] at Hcos,
    rcases Hcos with ⟨n, hn⟩ | ⟨n, hn⟩,
    { right,
      rw [eq_div_iff_mul_eq (@two_ne_zero ℝ _ _), ← sub_eq_iff_eq_add] at hn,
      rw [← hn, coe_sub, eq_neg_iff_add_eq_zero, sub_add_cancel, mul_assoc,
          coe_int_mul_eq_zsmul, mul_comm, coe_two_pi, zsmul_zero] },
    { left,
      rw [eq_div_iff_mul_eq (@two_ne_zero ℝ _ _), eq_sub_iff_add_eq] at hn,
      rw [← hn, coe_add, mul_assoc,
          coe_int_mul_eq_zsmul, mul_comm, coe_two_pi, zsmul_zero, zero_add] },
    apply_instance, },
  { rw [angle_eq_iff_two_pi_dvd_sub, ← coe_neg, angle_eq_iff_two_pi_dvd_sub],
    rintro (⟨k, H⟩ | ⟨k, H⟩),
    rw [← sub_eq_zero, cos_sub_cos, H, mul_assoc 2 π k,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero],
    rw [← sub_eq_zero, cos_sub_cos, ← sub_neg_eq_add, H, mul_assoc 2 π k,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero,
        zero_mul] }
end

theorem sin_eq_iff_eq_or_add_eq_pi {θ ψ : ℝ} :
  sin θ = sin ψ ↔ (θ : angle) = ψ ∨ (θ : angle) + ψ = π :=
begin
  split,
  { intro Hsin, rw [← cos_pi_div_two_sub, ← cos_pi_div_two_sub] at Hsin,
    cases cos_eq_iff_eq_or_eq_neg.mp Hsin with h h,
    { left, rw [coe_sub, coe_sub] at h, exact sub_right_inj.1 h },
      right, rw [coe_sub, coe_sub, eq_neg_iff_add_eq_zero, add_sub,
      sub_add_eq_add_sub, ← coe_add, add_halves, sub_sub, sub_eq_zero] at h,
    exact h.symm },
  { rw [angle_eq_iff_two_pi_dvd_sub, ←eq_sub_iff_add_eq, ←coe_sub, angle_eq_iff_two_pi_dvd_sub],
    rintro (⟨k, H⟩ | ⟨k, H⟩),
    rw [← sub_eq_zero, sin_sub_sin, H, mul_assoc 2 π k,
         mul_div_cancel_left _ (@two_ne_zero ℝ _ _), mul_comm π _, sin_int_mul_pi, mul_zero,
         zero_mul],
    have H' : θ + ψ = (2 * k) * π + π := by rwa [←sub_add, sub_add_eq_add_sub, sub_eq_iff_eq_add,
      mul_assoc, mul_comm π _, ←mul_assoc] at H,
    rw [← sub_eq_zero, sin_sub_sin, H', add_div, mul_assoc 2 _ π,
        mul_div_cancel_left _ (@two_ne_zero ℝ _ _), cos_add_pi_div_two, sin_int_mul_pi, neg_zero,
        mul_zero] }
end

theorem cos_sin_inj {θ ψ : ℝ} (Hcos : cos θ = cos ψ) (Hsin : sin θ = sin ψ) : (θ : angle) = ψ :=
begin
  cases cos_eq_iff_eq_or_eq_neg.mp Hcos with hc hc, { exact hc },
  cases sin_eq_iff_eq_or_add_eq_pi.mp Hsin with hs hs, { exact hs },
  rw [eq_neg_iff_add_eq_zero, hs] at hc,
  cases quotient.exact' hc with n hn, change n • _ = _ at hn,
  rw [← neg_one_mul, add_zero, ← sub_eq_zero, zsmul_eq_mul, ← mul_assoc, ← sub_mul,
      mul_eq_zero, eq_false_intro (ne_of_gt pi_pos), or_false, sub_neg_eq_add,
      ← int.cast_zero, ← int.cast_one, ← int.cast_bit0, ← int.cast_mul, ← int.cast_add,
      int.cast_inj] at hn,
  have : (n * 2 + 1) % (2:ℤ) = 0 % (2:ℤ) := congr_arg (%(2:ℤ)) hn,
  rw [add_comm, int.add_mul_mod_self] at this,
  exact absurd this one_ne_zero
end

/-- The sine of a `real.angle`. -/
def sin (θ : angle) : ℝ := sin_periodic.lift θ

@[simp] lemma sin_coe (x : ℝ) : sin (x : angle) = real.sin x :=
rfl

@[continuity] lemma continuous_sin : continuous sin :=
continuous_quotient_lift_on' _ real.continuous_sin

/-- The cosine of a `real.angle`. -/
def cos (θ : angle) : ℝ := cos_periodic.lift θ

@[simp] lemma cos_coe (x : ℝ) : cos (x : angle) = real.cos x :=
rfl

@[continuity] lemma continuous_cos : continuous cos :=
continuous_quotient_lift_on' _ real.continuous_cos

end angle

end real


import data.set
import data.set.lattice
import order.lattice

import .subsets

open classical

@[simp]
def downset (α : Type) [partial_order α] := {S : set α | ∀ (a : S) (b : α), b ≤ a → b ∈ S}

variables {α : Type} [partial_order α]

@[simp]
lemma empty_is_downset : ∅ ∈ downset α := by simp

@[simp]
lemma full_set_is_downset : (⊤ : set α) ∈ downset α :=
  (by simp; intros; trivial)

@[simp]
def down_closure : α → set α := λ a, {b | b ≤ a}

lemma lower_downset (a : downset α) (x : a) (y : α) : y ≤ x → y ∈ (a : set α) :=
begin
  intro h₁,
  exact a.property x y h₁
end

lemma down_closure_is_downset (a : α) : down_closure a ∈ downset α :=
begin
  simp,
  intros,
  rw set.mem_set_of_eq,
  transitivity;
  assumption
end

@[simp]
lemma intersections_of_downsets_are_downsets (a b : downset α) : (a : set α) ∩ b ∈ downset α :=
begin
  intros,
  dunfold downset,
  simp,
  intros,
  simp,
  have h_1 : b_1 ∈ (a : set α) := lower_downset a ⟨ x, set.mem_of_mem_inter_left h ⟩ b_1 a_1,
  have h_2 : b_1 ∈ (b : set α) := lower_downset b ⟨ x, set.mem_of_mem_inter_right h ⟩ b_1 a_1,
  exact ⟨ h_1 , h_2 ⟩
end

@[simp]
lemma union_of_downsets_are_downsets (a b : downset α) : (a : set α) ∪ b ∈ downset α :=
begin
  intros,
  dunfold downset,
  intros x y h₁,
  simp,
  have h₂ : x.val ∈ (a : set α) ∨ x.val ∈ (b : set α) := @set.mem_or_mem_of_mem_union α x a b x.property,
  cases h₂,
  exact or.inl (lower_downset a ⟨x, h₂ ⟩ y h₁),
  exact or.inr (lower_downset b ⟨x, h₂ ⟩ y h₁)
end

instance bounded_lattice_of_downset : lattice.bounded_lattice (downset α) :=
  s_bounded_lattice (downset α) (intersections_of_downsets_are_downsets) (union_of_downsets_are_downsets) (empty_is_downset) (full_set_is_downset)


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.algebra.polynomial
import topology.continuous_function.algebra
import topology.continuous_function.compact
import topology.unit_interval

/-!
# Constructions relating polynomial functions and continuous functions.

## Main definitions

* `polynomial.to_continuous_map_on p X`: for `X : set R`, interprets a polynomial `p`
  as a bundled continuous function in `C(X, R)`.
* `polynomial.to_continuous_map_on_alg_hom`: the same, as an `R`-algebra homomorphism.
* `polynomial_functions (X : set R) : subalgebra R C(X, R)`: polynomial functions as a subalgebra.
* `polynomial_functions_separates_points (X : set R) : (polynomial_functions X).separates_points`:
  the polynomial functions separate points.

-/

variables {R : Type*}

open_locale polynomial
namespace polynomial

section
variables [semiring R] [topological_space R] [topological_semiring R]

/--
Every polynomial with coefficients in a topological semiring gives a (bundled) continuous function.
-/
@[simps]
def to_continuous_map (p : R[X]) : C(R, R) :=
⟨λ x : R, p.eval x, by continuity⟩

/--
A polynomial as a continuous function,
with domain restricted to some subset of the semiring of coefficients.

(This is particularly useful when restricting to compact sets, e.g. `[0,1]`.)
-/
@[simps]
def to_continuous_map_on (p : R[X]) (X : set R) : C(X, R) :=
⟨λ x : X, p.to_continuous_map x, by continuity⟩

-- TODO some lemmas about when `to_continuous_map_on` is injective?

end

section
variables {α : Type*} [topological_space α]
  [comm_semiring R] [topological_space R] [topological_semiring R]

@[simp] lemma aeval_continuous_map_apply (g : R[X]) (f : C(α, R)) (x : α) :
  ((polynomial.aeval f) g) x = g.eval (f x) :=
begin
  apply polynomial.induction_on' g,
  { intros p q hp hq, simp [hp, hq], },
  { intros n a, simp [pi.pow_apply f x n], },
end

end

section

noncomputable theory

variables [comm_semiring R] [topological_space R] [topological_semiring R]

/--
The algebra map from `polynomial R` to continuous functions `C(R, R)`.
-/
@[simps]
def to_continuous_map_alg_hom : R[X] →ₐ[R] C(R, R) :=
{ to_fun := λ p, p.to_continuous_map,
  map_zero' := by { ext, simp, },
  map_add' := by { intros, ext, simp, },
  map_one' := by { ext, simp, },
  map_mul' := by { intros, ext, simp, },
  commutes' := by { intros, ext, simp [algebra.algebra_map_eq_smul_one], }, }

/--
The algebra map from `polynomial R` to continuous functions `C(X, R)`, for any subset `X` of `R`.
-/
@[simps]
def to_continuous_map_on_alg_hom (X : set R) : R[X] →ₐ[R] C(X, R)  :=
{ to_fun := λ p, p.to_continuous_map_on X,
  map_zero' := by { ext, simp, },
  map_add' := by { intros, ext, simp, },
  map_one' := by { ext, simp, },
  map_mul' := by { intros, ext, simp, },
  commutes' := by { intros, ext, simp [algebra.algebra_map_eq_smul_one], }, }

end

end polynomial

section
variables [comm_semiring R] [topological_space R] [topological_semiring R]

/--
The subalgebra of polynomial functions in `C(X, R)`, for `X` a subset of some topological semiring
`R`.
-/
def polynomial_functions (X : set R) : subalgebra R C(X, R) :=
(⊤ : subalgebra R R[X]).map (polynomial.to_continuous_map_on_alg_hom X)

@[simp]
lemma polynomial_functions_coe (X : set R) :
  (polynomial_functions X : set C(X, R)) = set.range (polynomial.to_continuous_map_on_alg_hom X) :=
by { ext, simp [polynomial_functions], }

-- TODO:
-- if `f : R → R` is an affine equivalence, then pulling back along `f`
-- induces a normed algebra isomorphism between `polynomial_functions X` and
-- `polynomial_functions (f ⁻¹' X)`, intertwining the pullback along `f` of `C(R, R)` to itself.

lemma polynomial_functions_separates_points (X : set R) :
  (polynomial_functions X).separates_points :=
λ x y h,
begin
  -- We use `polynomial.X`, then clean up.
  refine ⟨_, ⟨⟨_, ⟨⟨polynomial.X, ⟨algebra.mem_top, rfl⟩⟩, rfl⟩⟩, _⟩⟩,
  dsimp, simp only [polynomial.eval_X],
  exact (λ h', h (subtype.ext h')),
end

open_locale unit_interval
open continuous_map

/-- The preimage of polynomials on `[0,1]` under the pullback map by `x ↦ (b-a) * x + a`
is the polynomials on `[a,b]`. -/
lemma polynomial_functions.comap'_comp_right_alg_hom_Icc_homeo_I (a b : ℝ) (h : a < b) :
  (polynomial_functions I).comap'
    (comp_right_alg_hom ℝ (Icc_homeo_I a b h).symm.to_continuous_map) =
    polynomial_functions (set.Icc a b) :=
begin
  ext f,
  fsplit,
  { rintro ⟨p, ⟨-,w⟩⟩,
    rw fun_like.ext_iff at w,
    dsimp at w,
    let q := p.comp ((b - a)⁻¹ • polynomial.X + polynomial.C (-a * (b-a)⁻¹)),
    refine ⟨q, ⟨_, _⟩⟩,
    { simp, },
    { ext x,
      simp only [neg_mul,
        ring_hom.map_neg, ring_hom.map_mul, alg_hom.coe_to_ring_hom,
        polynomial.eval_X, polynomial.eval_neg, polynomial.eval_C, polynomial.eval_smul,
        polynomial.eval_mul, polynomial.eval_add, polynomial.coe_aeval_eq_eval,
        polynomial.eval_comp, polynomial.to_continuous_map_on_alg_hom_apply,
        polynomial.to_continuous_map_on_to_fun, polynomial.to_continuous_map_to_fun],
      convert w ⟨_, _⟩; clear w,
      { -- why does `comm_ring.add` appear here!?
        change x = (Icc_homeo_I a b h).symm ⟨_ + _, _⟩,
        ext,
        simp only [Icc_homeo_I_symm_apply_coe, subtype.coe_mk],
        replace h : b - a ≠ 0 := sub_ne_zero_of_ne h.ne.symm,
        simp only [mul_add],
        field_simp, ring, },
      { change _ + _ ∈ I,
        rw [mul_comm (b-a)⁻¹, ←neg_mul, ←add_mul, ←sub_eq_add_neg],
        have w₁ : 0 < (b-a)⁻¹ := inv_pos.mpr (sub_pos.mpr h),
        have w₂ : 0 ≤ (x : ℝ) - a := sub_nonneg.mpr x.2.1,
        have w₃ : (x : ℝ) - a ≤ b - a := sub_le_sub_right x.2.2 a,
        fsplit,
        { exact mul_nonneg w₂ (le_of_lt w₁), },
        { rw [←div_eq_mul_inv, div_le_one (sub_pos.mpr h)],
          exact w₃, }, }, }, },
  { rintro ⟨p, ⟨-,rfl⟩⟩,
    let q := p.comp ((b - a) • polynomial.X + polynomial.C a),
    refine ⟨q, ⟨_, _⟩⟩,
    { simp, },
    { ext x, simp [mul_comm], }, },
end

end


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.basic
import Mathlib.data.equiv.encodable.basic
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!
# Order ideals, cofinal sets, and the Rasiowa–Sikorski lemma

## Main definitions

Throughout this file, `P` is at least a preorder, but some sections require more
structure, such as a bottom element, a top element, or a join-semilattice structure.

- `ideal P`: the type of upward directed, downward closed subsets of `P`.
             Dual to the notion of a filter on a preorder.
- `cofinal P`: the type of subsets of `P` containing arbitrarily large elements.
               Dual to the notion of 'dense set' used in forcing.
- `ideal_of_cofinals p 𝒟`, where `p : P`, and `𝒟` is a countable family of cofinal
  subsets of P: an ideal in `P` which contains `p` and intersects every set in `𝒟`.

## References

- https://en.wikipedia.org/wiki/Ideal_(order_theory)
- https://en.wikipedia.org/wiki/Cofinal_(mathematics)
- https://en.wikipedia.org/wiki/Rasiowa–Sikorski_lemma

Note that for the Rasiowa–Sikorski lemma, Wikipedia uses the opposite ordering on `P`,
in line with most presentations of forcing.

## Tags

ideal, cofinal, dense, countable, generic

-/

namespace order

/-- An ideal on a preorder `P` is a subset of `P` that is
  - nonempty
  - upward directed
  - downward closed. -/
structure ideal (P : Type u_2) [preorder P]
where
  carrier : set P
  nonempty : set.nonempty carrier
  directed : directed_on LessEq carrier
  mem_of_le : ∀ {x y : P}, x ≤ y → y ∈ carrier → x ∈ carrier

namespace ideal

/-- The smallest ideal containing a given element. -/
def principal {P : Type u_1} [preorder P] (p : P) : ideal P :=
  mk (set_of fun (x : P) => x ≤ p) sorry sorry sorry

protected instance inhabited {P : Type u_1} [preorder P] [Inhabited P] : Inhabited (ideal P) :=
  { default := principal Inhabited.default }

/-- An ideal of `P` can be viewed as a subset of `P`. -/
protected instance set.has_coe {P : Type u_1} [preorder P] : has_coe (ideal P) (set P) :=
  has_coe.mk carrier

/-- For the notation `x ∈ I`. -/
protected instance has_mem {P : Type u_1} [preorder P] : has_mem P (ideal P) :=
  has_mem.mk fun (x : P) (I : ideal P) => x ∈ ↑I

/-- Two ideals are equal when their underlying sets are equal. -/
theorem ext {P : Type u_1} [preorder P] (I : ideal P) (J : ideal P) : ↑I = ↑J → I = J := sorry

/-- The partial ordering by subset inclusion, inherited from `set P`. -/
protected instance partial_order {P : Type u_1} [preorder P] : partial_order (ideal P) :=
  partial_order.lift coe ext

theorem mem_of_mem_of_le {P : Type u_1} [preorder P] {x : P} {I : ideal P} {J : ideal P} : x ∈ I → I ≤ J → x ∈ J :=
  set.mem_of_mem_of_subset

@[simp] theorem principal_le_iff {P : Type u_1} [preorder P] {x : P} {I : ideal P} : principal x ≤ I ↔ x ∈ I :=
  { mp := fun (h : ∀ {y : P}, y ≤ x → y ∈ I) => h (le_refl x),
    mpr := fun (h_mem : x ∈ I) (y : P) (h_le : y ≤ x) => mem_of_le I h_le h_mem }

/-- A specific witness of `I.nonempty` when `P` has a bottom element. -/
@[simp] theorem bot_mem {P : Type u_1} [order_bot P] {I : ideal P} : ⊥ ∈ I :=
  mem_of_le I bot_le (set.nonempty.some_mem (nonempty I))

/-- There is a bottom ideal when `P` has a bottom element. -/
protected instance order_bot {P : Type u_1} [order_bot P] : order_bot (ideal P) :=
  order_bot.mk (principal ⊥) partial_order.le partial_order.lt sorry sorry sorry sorry

/-- There is a top ideal when `P` has a top element. -/
protected instance order_top {P : Type u_1} [order_top P] : order_top (ideal P) :=
  order_top.mk (principal ⊤) partial_order.le partial_order.lt sorry sorry sorry sorry

/-- A specific witness of `I.directed` when `P` has joins. -/
theorem sup_mem {P : Type u_1} [semilattice_sup P] {I : ideal P} (x : P) (y : P) (H : x ∈ I) : y ∈ I → x ⊔ y ∈ I := sorry

@[simp] theorem sup_mem_iff {P : Type u_1} [semilattice_sup P] {x : P} {y : P} {I : ideal P} : x ⊔ y ∈ I ↔ x ∈ I ∧ y ∈ I :=
  { mp := fun (h : x ⊔ y ∈ I) => { left := mem_of_le I le_sup_left h, right := mem_of_le I le_sup_right h },
    mpr := fun (h : x ∈ I ∧ y ∈ I) => sup_mem x y (and.left h) (and.right h) }

end ideal

/-- For a preorder `P`, `cofinal P` is the type of subsets of `P`
  containing arbitrarily large elements. They are the dense sets in
  the topology whose open sets are terminal segments. -/
structure cofinal (P : Type u_2) [preorder P]
where
  carrier : set P
  mem_gt : ∀ (x : P), ∃ (y : P), ∃ (H : y ∈ carrier), x ≤ y

namespace cofinal

protected instance inhabited {P : Type u_1} [preorder P] : Inhabited (cofinal P) :=
  { default := mk set.univ sorry }

protected instance has_mem {P : Type u_1} [preorder P] : has_mem P (cofinal P) :=
  has_mem.mk fun (x : P) (D : cofinal P) => x ∈ carrier D

/-- A (noncomputable) element of a cofinal set lying above a given element. -/
def above {P : Type u_1} [preorder P] (D : cofinal P) (x : P) : P :=
  classical.some (mem_gt D x)

theorem above_mem {P : Type u_1} [preorder P] (D : cofinal P) (x : P) : above D x ∈ D :=
  exists.elim (classical.some_spec (mem_gt D x))
    fun (a : classical.some (mem_gt D x) ∈ carrier D) (_x : x ≤ classical.some (mem_gt D x)) => a

theorem le_above {P : Type u_1} [preorder P] (D : cofinal P) (x : P) : x ≤ above D x :=
  exists.elim (classical.some_spec (mem_gt D x))
    fun (_x : classical.some (mem_gt D x) ∈ carrier D) (b : x ≤ classical.some (mem_gt D x)) => b

end cofinal

/-- Given a starting point, and a countable family of cofinal sets,
  this is an increasing sequence that intersects each cofinal set. -/
def sequence_of_cofinals {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) : ℕ → P :=
  sorry

theorem sequence_of_cofinals.monotone {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) : monotone (sequence_of_cofinals p 𝒟) := sorry

theorem sequence_of_cofinals.encode_mem {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) (i : ι) : sequence_of_cofinals p 𝒟 (encodable.encode i + 1) ∈ 𝒟 i := sorry

/-- Given an element `p : P` and a family `𝒟` of cofinal subsets of a preorder `P`,
  indexed by a countable type, `ideal_of_cofinals p 𝒟` is an ideal in `P` which
  - contains `p`, according to `mem_ideal_of_cofinals p 𝒟`, and
  - intersects every set in `𝒟`, according to `cofinal_meets_ideal_of_cofinals p 𝒟`.

  This proves the Rasiowa–Sikorski lemma. -/
def ideal_of_cofinals {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) : ideal P :=
  ideal.mk (set_of fun (x : P) => ∃ (n : ℕ), x ≤ sequence_of_cofinals p 𝒟 n) sorry sorry sorry

theorem mem_ideal_of_cofinals {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) : p ∈ ideal_of_cofinals p 𝒟 :=
  Exists.intro 0 (le_refl p)

/-- `ideal_of_cofinals p 𝒟` is `𝒟`-generic. -/
theorem cofinal_meets_ideal_of_cofinals {P : Type u_1} [preorder P] (p : P) {ι : Type u_2} [encodable ι] (𝒟 : ι → cofinal P) (i : ι) : ∃ (x : P), x ∈ 𝒟 i ∧ x ∈ ideal_of_cofinals p 𝒟 :=
  Exists.intro (sequence_of_cofinals p 𝒟 (encodable.encode i + 1))
    { left := sequence_of_cofinals.encode_mem p 𝒟 i,
      right := Exists.intro (encodable.encode i + 1) (le_refl (sequence_of_cofinals p 𝒟 (encodable.encode i + 1))) }


import tactic -- hide

import data.real.basic -- imports the real numbers
/-

-/
open_locale classical -- allow proofs by contradiction
/-

-/
noncomputable theory -- don't fuss about the reals being noncomputable

namespace xena -- hide

-- Let a, b, c be real numbers
variables {a b c : ℝ}

/-
# Chapter ? : Max and abs

## Level 1

In this chapter we develop a basic interface for the `max a b` and `abs a`
function on the real numbers. Before we start, you will need to know
the basic API for `≤` and `<`, which looks like this:

```
example : a ≤ a := le_refl a

example : a ≤ b → b ≤ c → a ≤ c := le_trans

example : a ≤ b → b ≤ a → a = b := le_antisymm

example : a ≤ b ∨ b ≤ a := le_total a b

example : a < b ↔ a ≤ b ∧ a ≠ b := lt_iff_le_and_ne

example : a ≤ b → b < c → a < c := lt_of_le_of_lt

example : a < b → b ≤ c → a < c := lt_of_lt_of_le
```
-/

/- Axiom : le_refl a : a ≤ a
-/

/- Axiom : le_trans : a ≤ b → b ≤ c → a ≤ c
-/

/- Axiom : le_antisymm : a ≤ b → b ≤ a → a = b
-/

/- Axiom : le_total a b : a ≤ b ∨ b ≤ a
-/

/- Axiom : lt_iff_le_and_ne : a < b ↔ a ≤ b ∧ a ≠ b
-/

/- Axiom : lt_of_le_of_lt : a ≤ b → b < c → a < c
-/

/- Axiom : lt_of_lt_of_le : a < b → b ≤ c → a < c
-/

/-
We start with `max a b := if a ≤ b then b else a`. It is
uniquely characterised by the following two properties, which are hence
all you will need to know:

```
theorem max_eq_right : a ≤ b → max a b = b

theorem max_eq_left : b ≤ a → max a b = a
```
-/

/- Axiom : max_eq_right : a ≤ b → max a b = b
-/

/- Axiom : max_eq_left : b ≤ a → max a b = a
-/

-- begin hide
def max (a b : ℝ) := if a ≤ b then b else a

-- need if_pos to do this one
theorem max_eq_right (hab : a ≤ b) : max a b = b :=
begin
  unfold max,
  rw if_pos hab,
end

-- need if_neg to do this one
theorem max_eq_left (hba : b ≤ a) : max a b = a :=
begin
  by_cases hab : a ≤ b,
  { rw max_eq_right hab,
    exact le_antisymm hba hab,
  },
  { unfold max,
    rw if_neg hab,
  }
end
-- end hide

/-
All of these theorems are in the theorem statement box on the left.
See if you can now prove the useful `max_choice` lemma using them.
-/

/- Hint : Hint
Do a case split with `cases le_total a b`.
-/

/- Lemma
For any two real numbers $a$ and $b$, either $\max(a,b) = a$
or $\max(a,b) = b$.
-/
theorem max_choice (a b : ℝ) : max a b = a ∨ max a b = b :=
begin
  cases le_total a b with hab hba,
  { right,
    exact max_eq_right hab
  },
  { left,
    exact max_eq_left hba
  }

end

end xena --hide


-- Math 52: Cheatsheet

--------------------------------
-- BASIC GOAL TRANSFORMATIONS --
--------------------------------

-- Conjunctive Goal
-- Use `split`:
example (P Q : Prop) : P ∧ Q :=
begin
split,
-- you can use braces to separate the two resulting goals
{ sorry },
{ sorry },
end

-- Disjunctive Goal
-- Use `left` or `right` to pick one of the two alternatives:
example (P Q : Prop) : P ∨ Q :=
begin
left,
sorry,
end
example (P Q : Prop) : P ∨ Q :=
begin
right,
sorry,
end

-- Conditional Goal
-- Use `intro`:
example (P Q : Prop) : P → Q :=
begin
intro H, -- you can give the hypothesis any name you want
sorry,
end

-- Universal Goal
-- Use `intro`:
example (U : Type) (P : U → Prop) : ∀ (x : U), P x :=
begin
intro x, -- you can rename the variable x if necessary
sorry,
end

-- Existential Goal
-- Use `existsi`:
example (U : Type) (P : U → Prop) : ∃ (x : U), P x :=
begin
existsi (sorry : U), -- you need to figure out what to put in
sorry,
end

---------------------------------
-- BASIC GIVEN TRANSFORMATIONS --
---------------------------------

-- Conjunctive Hypothesis
-- Use `cases`:
example (P Q R : Prop) (H : P ∧ Q) : R :=
begin
cases H with H₁ H₂,
sorry,
end

-- Disjunctive Hypothesis
-- Use `cases`:
example (P Q R : Prop) (H : P ∨ Q) : R :=
begin
cases H with H₁ H₂,
-- you can use braces to separate the two resulting goals.
{ sorry },
{ sorry },
end

-- Conditional Hypothesis
-- Use `apply`:
example (P Q : Prop) (H : P → Q) : Q :=
begin
apply H,
sorry,
end

-- Existential Hypothesis
-- Use `cases`:
example (U : Type) (P : U → Prop) (R : Prop)
  (H : ∃ (x : U), P x) : R :=
begin
cases H with x Hx, -- you can use any name you want for x
sorry,
end

-- Universal Hypothesis
-- Use `apply`:
example (U : Type) (P : U → Prop)
  (H : ∀ (x : U), P x) (a : U) : P a :=
begin
apply H,
end

-----------------------
-- COMMON IDENTITIES --
-----------------------

#check add_assoc -- (a + b) + c = a + (b + c)
#check add_comm -- a + b = b + a
#check add_zero -- a + 0 = a
#check zero_add -- 0 + a = a
#check mul_assoc -- (a * b) * c = a * (b * c)
#check mul_comm -- a * b = b * a
#check mul_one -- a * 1 = a
#check one_mul -- 1 * a = a
#check mul_zero -- a * 0 = 0
#check zero_mul -- 0 * a = 0
#check add_mul -- (a + b) * c = a * c + b * c
#check mul_add -- a * (b + c) = a * b + a * c

-------------------
-- COMMON LEMMAS --
-------------------

#check le_refl -- a ≤ a
#check le_antisymm -- a ≤ b → b ≤ a → a = b
#check le_trans -- a ≤ b → b ≤ c → a ≤ c
#check lt_irrefl -- ¬(a < a)
#check lt_asymm -- a < b → ¬(b < a)
#check ne_of_lt -- a < b → a ≠ b
#check le_of_eq -- a = b → a ≤ b
#check le_of_lt -- a < b → a ≤ b
#check le_of_not_gt -- ¬(a > b) → a ≤ b
#check lt_of_not_ge -- ¬(a ≤ b) → a < b
#check lt_of_lt_of_le -- a < b → b ≤ c → a < c
#check lt_of_le_of_lt -- a ≤ b → b < c → a < c
#check add_le_add -- a ≤ b → c ≤ d → a + c ≤ b + d
#check add_le_add_left -- a ≤ b → (∀ c, c + a ≤ c + b)
#check add_le_add_right -- a ≤ b → (∀ c, a + c ≤ b + c)
#check add_lt_add -- a < b → c < c → a + c < b + d
#check add_lt_add_left -- a < b → (∀ c, c + a < c + b)
#check add_lt_add_right -- a < b → (∀ c, a + c < b + c)
#check mul_lt_mul_of_pos_left -- a < b → 0 < c → c * a < c * b
#check mul_lt_mul_of_pos_right -- a < b → 0 < c → a * c < b * c
#check mul_lt_mul_of_neg_left -- b < a → c < 0 → c * a < c * b
#check mul_lt_mul_of_neg_right -- b < a → c < 0 → a * c < b * c
#check mul_le_mul_of_nonneg_left -- a ≤ b → 0 ≤ c → c * a ≤ c * b
#check mul_le_mul_of_nonneg_right -- a ≤ b → 0 ≤ c → a * c ≤ b * c
#check mul_le_mul_of_nonpos_left -- b ≤ a → c ≤ 0 → c * a ≤ c * b
#check mul_le_mul_of_nonpos_right -- b ≤ a → c ≤ 0 → a * c ≤ b * c
#check mul_pos -- a > 0 → b > 0 → a * b > 0
#check mul_neg_of_pos_of_neg -- a > 0 → b < 0 → a * b < 0
#check mul_neg_of_neg_of_pos -- a < 0 → b > 0 → a * b < 0
#check mul_pos_of_neg_of_neg -- a < 0 → b < 0 → a * b > 0
#check mul_nonneg -- a ≥ b → b ≥ 0 → a * b ≥ 0
#check mul_nonpos_of_nonneg_of_nonpos -- a ≥ 0 → b ≤ 0 → a * b ≤ 0
#check mul_nonpos_of_nonneg_of_nonpos -- a ≤ 0 → b ≥ 0 → a * b ≤ 0
#check mul_nonneg_of_nonpos_of_nonpos -- a ≤ 0 → b ≤ 0 → a * b ≥ 0


import topology.basic
import topology.maps
import topology.homeomorph
open topological_space
open set filter classical
variables {X Y : Type} [topological_space X] [topological_space Y] [nonempty X] [nonempty Y] {A E F U V : set X}

/-Exercise 2.2.2. [⋆] Show that the following are equivalent for a continuous map 𝑓 ∶ 𝑋 → 𝑌
between spaces (𝑋, 𝒪𝑋) and (𝑌, 𝒪𝑌).
(i) 𝑓 ∶ 𝑋 → 𝑌 is a homeomorphism.
(ii) 𝑓 is an open bijection.
(iii) 𝑓 is a closed bijection.
♣

Exercise 2.2.7. [+] Let 𝒮 be the collection from Exercise 2.2.6. Show that the collection
𝒮𝑛 = {𝑝ᵢ⁻¹(𝑆) ∶ all 𝑆 ∈ 𝒮 and 1 ≤ 𝑖 ≤ 𝑛}
where the 𝑝𝑖 are the 𝑛 coordinate projections, is a subbase for the standard topology on ℝ𝑛
. ♣-/

-- definitions
-- open function is defined the same way with the name is_open_map
-- the same for closed function
def is_inv {X' Y' : Type} (f : X' → Y') (f' : Y' → X') :=
function.left_inverse f f' ∧ function.right_inverse f f'
def is_homeomorphism (f : X → Y) :=
function.bijective f ∧ continuous f ∧ ∃ (f' : Y → X) (H : is_inv f f'), continuous f'
def is_hom (f : X → Y) :=
continuous f ∧ ∃ (f' : Y → X), is_inv f f' ∧ continuous f'

-- I am very angry at how inverse function is coded in Lean
-- Are the following lemmas not in lean or am I blind???

lemma inv_imp_bij {X' Y' : Type} (f : X' → Y') (f' : Y' → X'):
is_inv f' f → function.bijective f:=
begin
  intro f'inv,
  refine function.bijective_iff_has_inverse.mpr _,
  use f',
  exact f'inv,
end

lemma linv_imp_rinv_swap {X' Y' : Type} (f : X' → Y') (f' : Y' → X') :
function.left_inverse f f' → function.right_inverse f' f :=
begin
  intros linv x,
  exact linv x,
end

lemma rinv_imp_linv_swap {X' Y' : Type} (f : X' → Y') (f' : Y' → X') :
function.right_inverse f f' → function.left_inverse f' f :=
begin
  intros rinv x,
  exact rinv x,
end

lemma inv_swap {X' Y' : Type} (f : X' → Y') (f' : Y' → X') : is_inv f f' → is_inv f' f :=
begin
  intros h,
  split,
  exact rinv_imp_linv_swap f f' h.right,
  exact linv_imp_rinv_swap f f' h.left,
end

lemma inv_symm {X' Y' : Type} (f : X' → Y') (f' : Y' → X') : is_inv f f' ↔ is_inv f' f :=
begin
  split,
  have := inv_swap f f',
  exact this,
  have := inv_swap f' f,
  exact this,
end

lemma hom_homeo_equiv (f : X → Y) : is_hom f ↔ is_homeomorphism f :=
begin
  split,
  {
    intros fhom,
    rcases fhom with ⟨ fcont, f', f'inv, f'cont ⟩ ,
    split,
    rw inv_symm at f'inv,
    exact inv_imp_bij f f' f'inv,
    split,
    exact fcont,
    use f',
    exact ⟨f'inv, f'cont⟩,
  },
  {
    intros fhomeo,
    rcases fhomeo with ⟨ fbij, fcont, f', f'inv, f'cont ⟩ ,
    split,
    exact fcont,
    use f',
    exact ⟨f'inv, f'cont⟩,
  },
end

lemma bij_inv_bij {X' Y' : Type} (f : X' → Y') (f' : Y' → X') : is_inv f f' →
(function.bijective f ↔ function.bijective f') :=
begin
  intros f'inv,
  split;
  intro fbij,
  exact inv_imp_bij f' f f'inv,
  exact inv_imp_bij f f' (inv_swap f f' f'inv),
end

lemma unique_preimage {X' Y' : Type} (f : X' → Y') (f' : Y' → X') : is_inv f f' →
∀ (s : set Y'), preimage f s = image f' s :=
begin
  intros f'inv s,
  have img_img:= function.left_inverse.image_image f'inv.left s,
  rw inv_symm at f'inv,
  have := inv_imp_bij f f' f'inv,
  rw set.preimage_eq_iff_eq_image this,
  exact eq.symm img_img,
end

-- Finally some solving!!
-- Exercise 2.2.2.
-- cycle implication to show equivalence
-- (i.e. (h1 → h2 →  ... → hn → h1) ↔ (h1 ↔ h2 ↔ ... ↔ hn) )

lemma step1 (f : X → Y) (fcont : continuous f) : is_homeomorphism f →
function.bijective f ∧ is_open_map f :=
begin
  intros fhom,
  rcases fhom with ⟨ fbij, fcont, f', f'inv, f'cont ⟩ ,
  split,
  {exact fbij,},
  {exact is_open_map.of_inverse f'cont f'inv.left f'inv.right,},
end

lemma step2 (f : X → Y) (fcont : continuous f) : function.bijective f ∧ is_open_map f →
function.bijective f ∧ is_closed_map f :=
begin
  intros fhom,
  rcases fhom with ⟨ fbij, fopen ⟩ ,
  split,
  {exact fbij,},
  {
    intros s sclosed,
    have    : is_open sᶜ            := sclosed.is_open_compl,
    have hf : is_open (f '' sᶜ)     := fopen sᶜ this,
    have    : f '' sᶜ = (f '' s)ᶜ   :=  set.image_compl_eq fbij,
    refine {is_open_compl := _},
    rwa this at hf,
  },
end

lemma step3 (f : X → Y) (fcont : continuous f) : function.bijective f ∧ is_closed_map f →
is_homeomorphism f :=
begin
  intros fclosedbij,
  rw ← hom_homeo_equiv,
  split,
  exact fcont,
  {
    rcases fclosedbij with ⟨ fbij, fclosed ⟩ ,
    rw function.bijective_iff_has_inverse at fbij,
    rcases fbij with ⟨ f', f'inv ⟩ ,
    use f',
    split,
    {exact (inv_symm f' f).mp f'inv,},
    {
      rw continuous_iff_is_closed,
      intros s sclosed,
      have : f' ⁻¹' s = f '' s := unique_preimage f' f (f'inv) s,
      rw this,
      exact fclosed s sclosed,
    },
  },
end

lemma finish_up (f : X → Y) (fcont : continuous f) :
(is_homeomorphism f                      ↔ function.bijective f ∧ is_open_map f   )∧
(function.bijective f ∧ is_open_map f   ↔ function.bijective f ∧ is_closed_map f )∧
(function.bijective f ∧ is_closed_map f ↔ is_homeomorphism f                      ):=
begin
  split;
  split,
    exact step1 f fcont,
    intro H,
    exact step3 f fcont (step2 f fcont H),
  split,
    exact step2 f fcont,
    intro H,
    exact step1 f fcont (step3 f fcont H),
  split,
    exact step3 f fcont,
    intro H,
    exact step2 f fcont (step1 f fcont H),
end

/-Exercise 2.2.7. [+] Let 𝒮 be the collection from Exercise 2.2.6. Show that the collection
𝒮𝑛 = {𝑝ᵢ⁻¹(𝑆) ∶ all 𝑆 ∈ 𝒮 and 1 ≤ 𝑖 ≤ 𝑛}
where the 𝑝𝑖 are the 𝑛 coordinate projections, is a subbase for the standard topology on ℝ𝑛
. ♣-/


opaque Var : Type
opaque Val : Type

variable [DecidableEq Var] [Nonempty Val]

def I := Var → Val

def update (i : I) (x : Var) (v : Val) : Var → Val := fun k =>
  if x = k then v else i k

notation i "[" x " ↦ " v "]" => update i x v

inductive Atom where
  | var : Var → Atom
  | func : Var → List Var → Atom

inductive Formula where
  | atom : Atom → Formula
  | not : Formula → Formula
  | and : Formula → Formula → Formula
  | imp : Formula → Formula → Formula
  | or : Formula → Formula → Formula
  | forall : Var → Formula → Formula
  | exists : Var → Formula → Formula

opaque Models : I → Formula → Prop
opaque NotModels : I → Formula → Prop

axiom Models.not {i a} : NotModels i (.not a) → Models i a
axiom Models.forall {i x a} : Models i (.forall x a) → (∀ v, Models (i[x ↦ v]) a)
axiom Models.exists {i x a} : Models i (.exists x a) → (v : Val) → Models (i[x ↦ v]) a

axiom NotModels.not  {i a} : Models i (.not a) → NotModels i a
axiom NotModels.exists {i x a} : NotModels i (.exists x a) → (∀ v, Models (i[x ↦ v]) a)

notation i " ⊨ " a => Models i a
notation i " ⊭ " a => NotModels i a

-- axiom Models.imp {}

theorem t {x y : Var} : (i ⊨ .forall x a) → i ⊨ (.not $ .exists x (.not a)) := by
  intro h
  have hf : ∀ (v : Val), i[x ↦ v] ⊨ a := Models.forall h
  apply Models.not
  admit