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

! This file was ported from Lean 3 source module category_theory.limits.shapes.kernel_pair
! leanprover-community/mathlib commit f6bab67886fb92c3e2f539cc90a83815f69a189d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Limits.Shapes.Equalizers
import Mathlib.CategoryTheory.Limits.Shapes.CommSq
import Mathlib.CategoryTheory.Limits.Shapes.RegularMono

/-!
# Kernel pairs

This file defines what it means for a parallel pair of morphisms `a b : R ⟶ X` to be the kernel pair
for a morphism `f`.
Some properties of kernel pairs are given, namely allowing one to transfer between
the kernel pair of `f₁ ≫ f₂` to the kernel pair of `f₁`.
It is also proved that if `f` is a coequalizer of some pair, and `a`,`b` is a kernel pair for `f`
then it is a coequalizer of `a`,`b`.

## Implementation

The definition is essentially just a wrapper for `IsLimit (PullbackCone.mk _ _ _)`, but the
constructions given here are useful, yet awkward to present in that language, so a basic API
is developed here.

## TODO

- Internal equivalence relations (or congruences) and the fact that every kernel pair induces one,
  and the converse in an effective regular category (WIP by b-mehta).

-/

universe v u u₂

namespace CategoryTheory

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

variable {C : Type u} [Category.{v} C]

variable {R X Y Z : C} (f : X ⟶ Y) (a b : R ⟶ X)

/-- `IsKernelPair f a b` expresses that `(a, b)` is a kernel pair for `f`, i.e. `a ≫ f = b ≫ f`
and the square
  R → X
  ↓   ↓
  X → Y
is a pullback square.
This is just an abbreviation for `IsPullback a b f f`.
-/
abbrev IsKernelPair :=
  IsPullback a b f f
#align category_theory.is_kernel_pair CategoryTheory.IsKernelPair

namespace IsKernelPair

/-- The data expressing that `(a, b)` is a kernel pair is subsingleton. -/
instance : Subsingleton (IsKernelPair f a b) :=
  ⟨fun P Q => by
    cases P
    cases Q
    congr ⟩

/-- If `f` is a monomorphism, then `(𝟙 _, 𝟙 _)`  is a kernel pair for `f`. -/
theorem id_of_mono [Mono f] : IsKernelPair f (𝟙 _) (𝟙 _) :=
  ⟨⟨rfl⟩, ⟨PullbackCone.isLimitMkIdId _⟩⟩
#align category_theory.is_kernel_pair.id_of_mono CategoryTheory.IsKernelPair.id_of_mono

instance [Mono f] : Inhabited (IsKernelPair f (𝟙 _) (𝟙 _)) :=
  ⟨id_of_mono f⟩

variable {f a b}

-- porting note: `lift` and the two following simp lemmas were introduced to ease the port
/--
Given a pair of morphisms `p`, `q` to `X` which factor through `f`, they factor through any kernel
pair of `f`.
-/
noncomputable def lift {S : C} (k : IsKernelPair f a b) (p q : S ⟶ X) (w : p ≫ f = q ≫ f) :
    S ⟶ R :=
  PullbackCone.IsLimit.lift k.isLimit _ _ w

@[reassoc (attr := simp)]
lemma lift_fst {S : C} (k : IsKernelPair f a b) (p q : S ⟶ X) (w : p ≫ f = q ≫ f) :
  k.lift p q w ≫ a = p :=
  PullbackCone.IsLimit.lift_fst _ _ _ _

@[reassoc (attr := simp)]
lemma lift_snd {S : C} (k : IsKernelPair f a b) (p q : S ⟶ X) (w : p ≫ f = q ≫ f) :
  k.lift p q w ≫ b = q :=
  PullbackCone.IsLimit.lift_snd _ _ _ _

/--
Given a pair of morphisms `p`, `q` to `X` which factor through `f`, they factor through any kernel
pair of `f`.
-/
noncomputable def lift' {S : C} (k : IsKernelPair f a b) (p q : S ⟶ X) (w : p ≫ f = q ≫ f) :
    { t : S ⟶ R // t ≫ a = p ∧ t ≫ b = q } :=
  ⟨k.lift p q w, by simp⟩
#align category_theory.is_kernel_pair.lift' CategoryTheory.IsKernelPair.lift'

/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `a ≫ f₁ = b ≫ f₁`, then `(a,b)` is a kernel pair for
just `f₁`.
That is, to show that `(a,b)` is a kernel pair for `f₁` it suffices to only show the square
commutes, rather than to additionally show it's a pullback.
-/
theorem cancel_right {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} (comm : a ≫ f₁ = b ≫ f₁)
    (big_k : IsKernelPair (f₁ ≫ f₂) a b) : IsKernelPair f₁ a b :=
  { w := comm
    isLimit' :=
      ⟨PullbackCone.isLimitAux' _ fun s =>
          by
          let s' : PullbackCone (f₁ ≫ f₂) (f₁ ≫ f₂) :=
            PullbackCone.mk s.fst s.snd (s.condition_assoc _)
          refine'
            ⟨big_k.isLimit.lift s', big_k.isLimit.fac _ WalkingCospan.left,
              big_k.isLimit.fac _ WalkingCospan.right, fun m₁ m₂ => _⟩
          apply big_k.isLimit.hom_ext
          refine' (PullbackCone.mk a b _ : PullbackCone (f₁ ≫ f₂) _).equalizer_ext _ _
          . apply reassoc_of% comm
          . apply m₁.trans (big_k.isLimit.fac s' WalkingCospan.left).symm
          . apply m₂.trans (big_k.isLimit.fac s' WalkingCospan.right).symm⟩ }
#align category_theory.is_kernel_pair.cancel_right CategoryTheory.IsKernelPair.cancel_right

/-- If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `f₂` is mono, then `(a,b)` is a kernel pair for
just `f₁`.
The converse of `comp_of_mono`.
-/
theorem cancel_right_of_mono {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [Mono f₂]
    (big_k : IsKernelPair (f₁ ≫ f₂) a b) : IsKernelPair f₁ a b :=
  cancel_right (by rw [← cancel_mono f₂, assoc, assoc, big_k.w]) big_k
#align category_theory.is_kernel_pair.cancel_right_of_mono CategoryTheory.IsKernelPair.cancel_right_of_mono

/--
If `(a,b)` is a kernel pair for `f₁` and `f₂` is mono, then `(a,b)` is a kernel pair for `f₁ ≫ f₂`.
The converse of `cancel_right_of_mono`.
-/
theorem comp_of_mono {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [Mono f₂] (small_k : IsKernelPair f₁ a b) :
    IsKernelPair (f₁ ≫ f₂) a b :=
  { w := by rw [small_k.w_assoc]
    isLimit' := ⟨by
      refine' PullbackCone.isLimitAux _
        (fun s => small_k.lift s.fst s.snd (by rw [← cancel_mono f₂, assoc, s.condition, assoc]))
        (by simp) (by simp) _
      . intro s m hm
        apply small_k.isLimit.hom_ext
        apply PullbackCone.equalizer_ext small_k.cone _ _
        . exact (hm WalkingCospan.left).trans (by simp)
        . exact (hm WalkingCospan.right).trans (by simp)⟩ }
#align category_theory.is_kernel_pair.comp_of_mono CategoryTheory.IsKernelPair.comp_of_mono

/--
If `(a,b)` is the kernel pair of `f`, and `f` is a coequalizer morphism for some parallel pair, then
`f` is a coequalizer morphism of `a` and `b`.
-/
def toCoequalizer (k : IsKernelPair f a b) [r : RegularEpi f] : IsColimit (Cofork.ofπ f k.w) := by
  let t := k.isLimit.lift (PullbackCone.mk _ _ r.w)
  have ht : t ≫ a = r.left := k.isLimit.fac _ WalkingCospan.left
  have kt : t ≫ b = r.right := k.isLimit.fac _ WalkingCospan.right
  refine' Cofork.IsColimit.mk _
    (fun s => Cofork.IsColimit.desc r.isColimit s.π
      (by rw [← ht, assoc, s.condition, reassoc_of% kt]))
    (fun s => _) (fun s m w => _)
  . apply Cofork.IsColimit.π_desc' r.isColimit
  . apply Cofork.IsColimit.hom_ext r.isColimit
    exact w.trans (Cofork.IsColimit.π_desc' r.isColimit _ _).symm
#align category_theory.is_kernel_pair.to_coequalizer CategoryTheory.IsKernelPair.toCoequalizer

/-- If `a₁ a₂ : A ⟶ Y` is a kernel pair for `g : Y ⟶ Z`, then `a₁ ×[Z] X` and `a₂ ×[Z] X`
(`A ×[Z] X ⟶ Y ×[Z] X`) is a kernel pair for `Y ×[Z] X ⟶ X`. -/
protected theorem pullback {X Y Z A : C} {g : Y ⟶ Z} {a₁ a₂ : A ⟶ Y} (h : IsKernelPair g a₁ a₂)
    (f : X ⟶ Z) [HasPullback f g] [HasPullback f (a₁ ≫ g)] :
    IsKernelPair (pullback.fst : pullback f g ⟶ X)
      (pullback.map f _ f _ (𝟙 X) a₁ (𝟙 Z) (by simp) <| Category.comp_id _)
      (pullback.map _ _ _ _ (𝟙 X) a₂ (𝟙 Z) (by simp) <| (Category.comp_id _).trans h.1.1) := by
  refine' ⟨⟨by rw [pullback.lift_fst, pullback.lift_fst]⟩, ⟨PullbackCone.isLimitAux _
    (fun s => pullback.lift (s.fst ≫ pullback.fst)
      (h.lift (s.fst ≫ pullback.snd) (s.snd ≫ pullback.snd) _ ) _) (fun s => _) (fun s => _)
        (fun s m hm => _)⟩⟩
  . simp_rw [Category.assoc, ← pullback.condition, ← Category.assoc, s.condition]
  . simp only [assoc, lift_fst_assoc, pullback.condition]
  . apply pullback.hom_ext <;> simp
  . apply pullback.hom_ext
    . simp [s.condition]
    . simp
  . apply pullback.hom_ext
    . simpa using hm WalkingCospan.left =≫ pullback.fst
    . apply PullbackCone.IsLimit.hom_ext h.isLimit
      . simpa using hm WalkingCospan.left =≫ pullback.snd
      . simpa using hm WalkingCospan.right =≫ pullback.snd
#align category_theory.is_kernel_pair.pullback CategoryTheory.IsKernelPair.pullback

theorem mono_of_isIso_fst (h : IsKernelPair f a b) [IsIso a] : Mono f := by
  obtain ⟨l, h₁, h₂⟩ := Limits.PullbackCone.IsLimit.lift' h.isLimit (𝟙 _) (𝟙 _) (by simp [h.w])
  rw [IsPullback.cone_fst, ← IsIso.eq_comp_inv, Category.id_comp] at h₁
  rw [h₁, IsIso.inv_comp_eq, Category.comp_id] at h₂
  constructor
  intro Z g₁ g₂ e
  obtain ⟨l', rfl, rfl⟩ := Limits.PullbackCone.IsLimit.lift' h.isLimit _ _ e
  rw [IsPullback.cone_fst, h₂]
#align category_theory.is_kernel_pair.mono_of_is_iso_fst CategoryTheory.IsKernelPair.mono_of_isIso_fst

theorem isIso_of_mono (h : IsKernelPair f a b) [Mono f] : IsIso a := by
  rw [←
    show _ = a from
      (Category.comp_id _).symm.trans
        ((IsKernelPair.id_of_mono f).isLimit.conePointUniqueUpToIso_inv_comp h.isLimit
          WalkingCospan.left)]
  infer_instance
#align category_theory.is_kernel_pair.is_iso_of_mono CategoryTheory.IsKernelPair.isIso_of_mono

theorem of_isIso_of_mono [IsIso a] [Mono f] : IsKernelPair f a a := by
  change IsPullback _ _ _ _
  convert (IsPullback.of_horiz_isIso ⟨(rfl : a ≫ 𝟙 X = _ )⟩).paste_vert (IsKernelPair.id_of_mono f)
  all_goals { simp }
#align category_theory.is_kernel_pair.of_is_iso_of_mono CategoryTheory.IsKernelPair.of_isIso_of_mono

end IsKernelPair

end CategoryTheory


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import data.real.basic
import combinatorics.pigeonhole
import algebra.order.euclidean_absolute_value

/-!
# Admissible absolute values

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
This file defines a structure `absolute_value.is_admissible` which we use to show the class number
of the ring of integers of a global field is finite.

## Main definitions

 * `absolute_value.is_admissible abv` states the absolute value `abv : R → ℤ`
   respects the Euclidean domain structure on `R`, and that a large enough set
   of elements of `R^n` contains a pair of elements whose remainders are
   pointwise close together.

## Main results

 * `absolute_value.abs_is_admissible` shows the "standard" absolute value on `ℤ`,
   mapping negative `x` to `-x`, is admissible.
 * `polynomial.card_pow_degree_is_admissible` shows `card_pow_degree`,
   mapping `p : polynomial 𝔽_q` to `q ^ degree p`, is admissible
-/

local infix ` ≺ `:50 := euclidean_domain.r

namespace absolute_value

variables {R : Type*} [euclidean_domain R]
variables (abv : absolute_value R ℤ)

/-- An absolute value `R → ℤ` is admissible if it respects the Euclidean domain
structure and a large enough set of elements in `R^n` will contain a pair of
elements whose remainders are pointwise close together. -/
structure is_admissible extends is_euclidean abv :=
(card : ℝ → ℕ)
(exists_partition' : ∀ (n : ℕ) {ε : ℝ} (hε : 0 < ε) {b : R} (hb : b ≠ 0) (A : fin n → R),
                     ∃ (t : fin n → fin (card ε)),
                     ∀ i₀ i₁, t i₀ = t i₁ → (abv (A i₁ % b - A i₀ % b) : ℝ) < abv b • ε)

attribute [protected] is_admissible.card

namespace is_admissible

variables {abv}

/-- For all `ε > 0` and finite families `A`, we can partition the remainders of `A` mod `b`
into `abv.card ε` sets, such that all elements in each part of remainders are close together. -/
lemma exists_partition {ι : Type*} [fintype ι] {ε : ℝ} (hε : 0 < ε) {b : R} (hb : b ≠ 0)
  (A : ι → R) (h : abv.is_admissible) :
  ∃ (t : ι → fin (h.card ε)),
  ∀ i₀ i₁, t i₀ = t i₁ → (abv (A i₁ % b - A i₀ % b) : ℝ) < abv b • ε :=
begin
  let e := fintype.equiv_fin ι,
  obtain ⟨t, ht⟩ := h.exists_partition' (fintype.card ι) hε hb (A ∘ e.symm),
  refine ⟨t ∘ e, λ i₀ i₁ h, _⟩,
  convert ht (e i₀) (e i₁) h; simp only [e.symm_apply_apply]
end

/-- Any large enough family of vectors in `R^n` has a pair of elements
whose remainders are close together, pointwise. -/
lemma exists_approx_aux (n : ℕ) (h : abv.is_admissible) :
  ∀ {ε : ℝ} (hε : 0 < ε) {b : R} (hb : b ≠ 0) (A : fin (h.card ε ^ n).succ → (fin n → R)),
  ∃ (i₀ i₁), (i₀ ≠ i₁) ∧ ∀ k, (abv (A i₁ k % b - A i₀ k % b) : ℝ) < abv b • ε :=
begin
  haveI := classical.dec_eq R,
  induction n with n ih,
  { intros ε hε b hb A,
    refine ⟨0, 1, _, _⟩,
    { simp },
    rintros ⟨i, ⟨⟩⟩ },
  intros ε hε b hb A,
  set M := h.card ε with hM,
  -- By the "nicer" pigeonhole principle, we can find a collection `s`
  -- of more than `M^n` remainders where the first components lie close together:
  obtain ⟨s, s_inj, hs⟩ : ∃ s : fin (M ^ n).succ → fin (M ^ n.succ).succ,
    function.injective s ∧
    ∀ i₀ i₁, (abv (A (s i₁) 0 % b - A (s i₀) 0 % b) : ℝ) < abv b • ε,
  { -- We can partition the `A`s into `M` subsets where
    -- the first components lie close together:
    obtain ⟨t, ht⟩ : ∃ (t : fin (M ^ n.succ).succ → fin M),
      ∀ i₀ i₁, t i₀ = t i₁ → (abv (A i₁ 0 % b - A i₀ 0 % b) : ℝ) < abv b • ε :=
      h.exists_partition hε hb (λ x, A x 0),
    -- Since the `M` subsets contain more than `M * M^n` elements total,
    -- there must be a subset that contains more than `M^n` elements.
    obtain ⟨s, hs⟩ := @fintype.exists_lt_card_fiber_of_mul_lt_card _ _ _ _ _ t (M ^ n)
      (by simpa only [fintype.card_fin, pow_succ] using nat.lt_succ_self (M ^ n.succ) ),
    refine ⟨λ i, (finset.univ.filter (λ x, t x = s)).to_list.nth_le i _, _, λ i₀ i₁, ht _ _ _⟩,
    { refine i.2.trans_le _, rwa finset.length_to_list },
    { intros i j h, ext, exact list.nodup_iff_nth_le_inj.mp (finset.nodup_to_list _) _ _ _ _ h },
    have : ∀ i h, (finset.univ.filter (λ x, t x = s)).to_list.nth_le i h ∈
      finset.univ.filter (λ x, t x = s),
    { intros i h, exact finset.mem_to_list.mp (list.nth_le_mem _ _ _) },
    obtain ⟨_, h₀⟩ := finset.mem_filter.mp (this i₀ _),
    obtain ⟨_, h₁⟩ := finset.mem_filter.mp (this i₁ _),
    exact h₀.trans h₁.symm },
  -- Since `s` is large enough, there are two elements of `A ∘ s`
  -- where the second components lie close together.
  obtain ⟨k₀, k₁, hk, h⟩ := ih hε hb (λ x, fin.tail (A (s x))),
  refine ⟨s k₀, s k₁, λ h, hk (s_inj h), λ i, fin.cases _ (λ i, _) i⟩,
  { exact hs k₀ k₁ },
  { exact h i },
end

/-- Any large enough family of vectors in `R^ι` has a pair of elements
whose remainders are close together, pointwise. -/
lemma exists_approx {ι : Type*} [fintype ι] {ε : ℝ} (hε : 0 < ε) {b : R} (hb : b ≠ 0)
  (h : abv.is_admissible)
  (A : fin (h.card ε ^ fintype.card ι).succ → ι → R) :
  ∃ (i₀ i₁), (i₀ ≠ i₁) ∧ ∀ k, (abv (A i₁ k % b - A i₀ k % b) : ℝ) < abv b • ε :=
begin
  let e := fintype.equiv_fin ι,
  obtain ⟨i₀, i₁, ne, h⟩ := h.exists_approx_aux (fintype.card ι) hε hb (λ x y, A x (e.symm y)),
  refine ⟨i₀, i₁, ne, λ k, _⟩,
  convert h (e k); simp only [e.symm_apply_apply]
end

end is_admissible

end absolute_value


/-
Copyright (c) 2021 Manuel Candales. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Manuel Candales
-/
import data.real.basic
import data.set.basic
import data.set.finite

/-!
# IMO 2008 Q2
(a) Prove that
          ```
          x^2 / (x-1)^2 + y^2 / (y-1)^2 + z^2 / (z-1)^2 ≥ 1
          ```
for all real numbers `x`,`y`, `z`, each different from 1, and satisfying `xyz = 1`.

(b) Prove that equality holds above for infinitely many triples of rational numbers `x`, `y`, `z`,
each different from 1, and satisfying `xyz = 1`.

# Solution
(a) Since `xyz = 1`, we can apply the substitution `x = a/b`, `y = b/c`, `z = c/a`.
Then we define `m = c-b`, `n = b-a` and rewrite the inequality as `LHS - 1 ≥ 0`
using `c`, `m` and `n`. We factor `LHS - 1` as a square, which finishes the proof.

(b) We present a set `W` of rational triples. We prove that `W` is a subset of the
set of rational solutions to the equation, and that `W` is infinite.
-/

lemma subst_abc {x y z : ℝ} (h : x*y*z = 1) :
  ∃ a b c : ℝ, a ≠ 0 ∧ b ≠ 0 ∧ c ≠ 0 ∧ x = a/b ∧ y = b/c ∧ z = c /a :=
begin
  use [x, 1, 1/y],
  obtain ⟨⟨hx, hy⟩, hz⟩ : (x ≠ 0 ∧ y ≠ 0) ∧ z ≠ 0,
    by simpa [not_or_distrib] using trans_rel_right (≠) h one_ne_zero,
  have : z * (y * x) = 1, by { rw ← h, ac_refl },
  field_simp *
end

theorem imo2008_q2a (x y z : ℝ) (h : x*y*z = 1) (hx : x ≠ 1) (hy : y ≠ 1) (hz : z ≠ 1) :
  x^2 / (x-1)^2 + y^2 / (y-1)^2 + z^2 / (z-1)^2 ≥ 1 :=
begin
  obtain ⟨a, b, c, ha, hb, hc, rfl, rfl, rfl⟩ := subst_abc h,
  obtain ⟨m, n, rfl, rfl⟩ : ∃ m n, b = c - m ∧ a = c - m - n,
  { use [c - b, b - a], simp },
  have hm_ne_zero : m ≠ 0,
  { contrapose! hy, field_simp, assumption },
  have hn_ne_zero : n ≠ 0,
  { contrapose! hx, field_simp, assumption },
  have hmn_ne_zero : m + n ≠ 0,
  { contrapose! hz, field_simp, linarith },
  have hc_sub_sub : c - (c - m - n) = m + n, by abel,
  rw [ge_iff_le, ← sub_nonneg],
  convert sq_nonneg ((c*(m^2+n^2+m*n) - m*(m+n)^2) / (m*n*(m+n)) ),
  field_simp *, ring
end

def rational_solutions := { s : ℚ×ℚ×ℚ | ∃ (x y z : ℚ), s = (x, y, z) ∧
  x ≠ 1 ∧ y ≠ 1 ∧ z ≠ 1 ∧ x*y*z = 1 ∧ x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2 = 1 }

theorem imo2008_q2b : set.infinite rational_solutions :=
begin
  let W := { s : ℚ×ℚ×ℚ | ∃ (x y z : ℚ), s = (x, y, z) ∧
    ∃ t : ℚ, t > 0 ∧ x = -(t+1)/t^2 ∧ y = t/(t+1)^2 ∧ z = -t*(t+1)},

  have hW_sub_S : W ⊆ rational_solutions,
  { intros s hs_in_W,
    rw rational_solutions,
    simp only [set.mem_set_of_eq] at hs_in_W ⊢,
    rcases hs_in_W with ⟨x, y, z, h₁, t, ht_gt_zero, hx_t, hy_t, hz_t⟩,
    use [x, y, z],

    have ht_ne_zero  : t ≠ 0,           exact ne_of_gt ht_gt_zero,
    have ht1_ne_zero : t+1 ≠ 0,         linarith[ht_gt_zero],
    have key_gt_zero : t^2 + t + 1 > 0, linarith[pow_pos ht_gt_zero 2, ht_gt_zero],
    have key_ne_zero : t^2 + t + 1 ≠ 0, exact ne_of_gt key_gt_zero,

    have h₂ : x ≠ 1,      { rw hx_t, field_simp, linarith[key_gt_zero] },
    have h₃ : y ≠ 1,      { rw hy_t, field_simp, linarith[key_gt_zero] },
    have h₄ : z ≠ 1,      { rw hz_t, linarith[key_gt_zero] },
    have h₅ : x*y*z = 1,  { rw [hx_t, hy_t, hz_t], field_simp, ring },

    have h₆ : x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2 = 1,
    { have hx1 : (x - 1)^2 = (t^2 + t + 1)^2/t^4,     { field_simp, rw hx_t, field_simp, ring },
      have hy1 : (y - 1)^2 = (t^2 + t + 1)^2/(t+1)^4, { field_simp, rw hy_t, field_simp, ring },
      have hz1 : (z - 1)^2 = (t^2 + t + 1)^2,         { rw hz_t, ring },
      calc  x^2/(x-1)^2 + y^2/(y-1)^2 + z^2/(z-1)^2
          = (x^2*t^4 + y^2*(t+1)^4 + z^2)/(t^2 + t + 1)^2 :
            by { rw [hx1, hy1, hz1], field_simp }
      ... = 1 :
            by { rw [hx_t, hy_t, hz_t], field_simp, ring } },

    exact ⟨h₁, h₂, h₃, h₄, h₅, h₆⟩ },

  have hW_inf : set.infinite W,
  { let g : ℚ×ℚ×ℚ → ℚ := (λs, -s.2.2),
    let K := g '' W,

    have hK_not_bdd : ¬bdd_above K,
    { rw not_bdd_above_iff,
      intro q,
      let t : ℚ := max (q+1) 1,
      use t*(t+1),

      have h₁ : t * (t + 1) ∈ K,
      { let x : ℚ := -(t + 1)/t^2,
        let y : ℚ := t/(t+1)^2,
        set z : ℚ := -t*(t+1) with hz_def,

        simp only [set.mem_image, prod.exists],
        use [x, y, z], split,
        simp only [set.mem_set_of_eq],
        { use [x, y, z], split,
          refl,
          { use t, split,
            { simp only [gt_iff_lt, lt_max_iff], right, exact zero_lt_one },
            exact ⟨rfl, rfl, rfl⟩ } },
        { have hg : g(x, y, z) = -z := rfl,
          rw [hg, hz_def], ring } },

      have h₂ : q < t * (t + 1),
      { calc q < q + 1    : by linarith
           ... ≤ t        : le_max_left (q + 1) 1
           ... ≤ t+t^2    : by linarith [sq_nonneg t]
           ... = t*(t+1)  : by ring },

      exact ⟨h₁, h₂⟩ },

    have hK_inf : set.infinite K,
    { intro h, apply hK_not_bdd, exact set.finite.bdd_above h },

    exact set.infinite_of_infinite_image g hK_inf },

  exact hW_inf.mono hW_sub_S,
end


import vorspiel

inductive bexpression : ℕ → Type
| atom {n} : fin n → bexpression n
| and  {n} : bexpression n → bexpression n → bexpression n
| or   {n} : bexpression n → bexpression n → bexpression n
| not  {n} : bexpression n → bexpression n

inductive literal (α : Type*)
| id  : α → literal
| not : α → literal

namespace literal

instance (α : Type*) [inhabited α] : inhabited (literal α) := ⟨id default⟩

@[simp] def val {n} (v : vector bool n) : literal (fin n) → bool
| (id i)  := v.nth i
| (not i) := bnot (v.nth i)

instance {α : Type*} [d : decidable_eq α] : decidable_eq (literal α)
| (id a)  (id b)  := by simp; exact d a b
| (id a)  (not b) := is_false (λ h, by simpa using h)
| (not a) (id b)  := is_false (λ h, by simpa using h)
| (not a) (not b) := by simp; exact d a b

section

@[simp] def pref {α : Type*} : bool → α → literal α
| tt a := id a
| ff a := not a

end

end literal

def CNF.clause (m n) := {s : finset (literal (fin n)) // s.card ≤ m}

-- conjunctive normal form
def CNF (m n) := finset (CNF.clause m n)

abbreviation CNF.clause3 := CNF.clause 3

abbreviation CNF3 := CNF 3

namespace CNF
open literal

section
variables {m n : ℕ} (v : vector bool n)

namespace clause

instance : inhabited (clause m n) := ⟨⟨∅, by simp⟩⟩

def val (c : clause m n) (v) : bool := c.val.sup (literal.val v)

def disj (l : fin m → literal (fin n)) : clause m n := ⟨finset.of_fn l, by simp⟩

notation `⋁` binders `, ` r:(scoped l, disj l) := r

variables (l : fin m → literal (fin n))

@[simp] lemma disj_val_ff : (⋁ i, l i).val v = ff ↔ ∀ i, (l i).val v = ff :=
begin
  simp[val, disj],
  suffices : (∀ s ∈ finset.of_fn l, literal.val v s = ⊥) ↔ (∀ i, literal.val v (l i) = ff),
  { have e := finset.sup_eq_bot_iff (literal.val v) (finset.of_fn l),
    exact e.trans this },
  split,
  { exact λ h i, h (l i) (by simp) },
  { intros h s hs,
    have : ∃ i, l i = s, from (finset.mem_of_fn_iff l).mp hs,
    rcases this with ⟨i, rfl⟩,
    exact h i }
end

@[simp] lemma disj_val_tt : (⋁ i, l i).val v = tt ↔ ∃ i, (l i).val v = tt :=
by simpa[-disj_val_ff] using iff.not (disj_val_ff v l)

end clause
open clause

instance : inhabited (CNF m n) := ⟨(∅ : finset _)⟩

def val (φ : CNF m n) (v) : bool := φ.inf (λ c, c.val v)

abbreviation size (φ : CNF m n) : ℕ := φ.card

section conjunction
variables {ι : Type*} [fintype ι] (c : ι → clause m n)

def conj (c : ι → clause m n) : CNF m n := finset.cod c

notation `⋀` binders `, ` r:(scoped l, conj l) := r

lemma conj_size : (⋀ i, c i).size ≤ fintype.card ι := finset.cod_card c

@[simp] lemma conj_val_tt : (⋀ i, c i).val v = tt ↔ ∀ i, (c i).val v = tt :=
begin
  simp[val, conj, finset.cod],
  simpa using finset.inf_eq_top_iff (λ c, clause.val c v) (finset.image c finset.univ)
end

@[simp] lemma conj_val_ff : (⋀ i, c i).val v = ff ↔ ∃ i, (c i).val v = ff :=
by simpa[-conj_val_tt] using iff.not (conj_val_tt v c)

end conjunction

end

section
variables {n : ℕ} (f : vector bool n → bool)

def to_CNF : CNF n n := ⋀ (v : {v : vector bool n // f v = ff}), ⋁ i, pref (!v.val.nth i) i

@[simp] lemma size_to_CNF_le_pow : (to_CNF f).size ≤ 2^n :=
begin
  have le₁ : (to_CNF f).size ≤ fintype.card {v // f v = ff}, from conj_size _,
  have le₂ : fintype.card {v // f v = ff} ≤ 2^n, by simpa using @fintype.card_subtype_le (vector bool n) _ _ _,
  exact le₁.trans le₂
end

@[simp] lemma val_to_CNF (v) : (to_CNF f).val v = f v :=
begin
  cases C : f v; simp[to_CNF],
  { refine ⟨v, C, _⟩,
    intros i,
    cases Ci : v.nth i; simp[Ci] },
  { intros w hw,
    have : v ≠ w, { rintros rfl, simp[hw] at C, contradiction },
    have : ∃ i, v.nth i ≠ w.nth i, by simpa using mt vector.ext this,
    rcases this with ⟨i, ne⟩,
    refine ⟨i, _⟩,
    cases Ci : w.nth i,
    { have : v.nth i = tt, from bool.eq_tt_of_ne_ff (by { rintros A, simp[Ci, A] at ne, contradiction }),
      simp[this] },
    { have : v.nth i = ff, from bool.eq_ff_of_ne_tt (by { rintros A, simp[Ci, A] at ne, contradiction }),
      simp[this] } }
end

end

end CNF


/-
Copyright (c) 2020 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.normed_space.hahn_banach
import analysis.normed_space.is_R_or_C
import analysis.locally_convex.polar

/-!
# The topological dual of a normed space

In this file we define the topological dual `normed_space.dual` of a normed space, and the
continuous linear map `normed_space.inclusion_in_double_dual` from a normed space into its double
dual.

For base field `𝕜 = ℝ` or `𝕜 = ℂ`, this map is actually an isometric embedding; we provide a
version `normed_space.inclusion_in_double_dual_li` of the map which is of type a bundled linear
isometric embedding, `E →ₗᵢ[𝕜] (dual 𝕜 (dual 𝕜 E))`.

Since a lot of elementary properties don't require `eq_of_dist_eq_zero` we start setting up the
theory for `semi_normed_group` and we specialize to `normed_group` when needed.

## Main definitions

* `inclusion_in_double_dual` and `inclusion_in_double_dual_li` are the inclusion of a normed space
  in its double dual, considered as a bounded linear map and as a linear isometry, respectively.
* `polar 𝕜 s` is the subset of `dual 𝕜 E` consisting of those functionals `x'` for which
  `∥x' z∥ ≤ 1` for every `z ∈ s`.

## Tags

dual
-/

noncomputable theory
open_locale classical topological_space
universes u v

namespace normed_space

section general
variables (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
variables (E : Type*) [semi_normed_group E] [normed_space 𝕜 E]
variables (F : Type*) [normed_group F] [normed_space 𝕜 F]

/-- The topological dual of a seminormed space `E`. -/
@[derive [inhabited, semi_normed_group, normed_space 𝕜]] def dual := E →L[𝕜] 𝕜

instance : add_monoid_hom_class (dual 𝕜 E) E 𝕜 := continuous_linear_map.add_monoid_hom_class

instance : has_coe_to_fun (dual 𝕜 E) (λ _, E → 𝕜) := continuous_linear_map.to_fun

instance : normed_group (dual 𝕜 F) := continuous_linear_map.to_normed_group

instance [finite_dimensional 𝕜 E] : finite_dimensional 𝕜 (dual 𝕜 E) :=
continuous_linear_map.finite_dimensional

/-- The inclusion of a normed space in its double (topological) dual, considered
   as a bounded linear map. -/
def inclusion_in_double_dual : E →L[𝕜] (dual 𝕜 (dual 𝕜 E)) :=
continuous_linear_map.apply 𝕜 𝕜

@[simp] lemma dual_def (x : E) (f : dual 𝕜 E) : inclusion_in_double_dual 𝕜 E x f = f x := rfl

lemma inclusion_in_double_dual_norm_eq :
  ∥inclusion_in_double_dual 𝕜 E∥ = ∥(continuous_linear_map.id 𝕜 (dual 𝕜 E))∥ :=
continuous_linear_map.op_norm_flip _

lemma inclusion_in_double_dual_norm_le : ∥inclusion_in_double_dual 𝕜 E∥ ≤ 1 :=
by { rw inclusion_in_double_dual_norm_eq, exact continuous_linear_map.norm_id_le }

lemma double_dual_bound (x : E) : ∥(inclusion_in_double_dual 𝕜 E) x∥ ≤ ∥x∥ :=
by simpa using continuous_linear_map.le_of_op_norm_le _ (inclusion_in_double_dual_norm_le 𝕜 E) x

/-- The dual pairing as a bilinear form. -/
def dual_pairing : (dual 𝕜 E) →ₗ[𝕜] E →ₗ[𝕜] 𝕜 := continuous_linear_map.coe_lm 𝕜

@[simp] lemma dual_pairing_apply {v : dual 𝕜 E} {x : E} : dual_pairing 𝕜 E v x = v x := rfl

lemma dual_pairing_separating_left : (dual_pairing 𝕜 E).separating_left :=
begin
  rw [linear_map.separating_left_iff_ker_eq_bot, linear_map.ker_eq_bot],
  exact continuous_linear_map.coe_injective,
end

end general

section bidual_isometry

variables (𝕜 : Type v) [is_R_or_C 𝕜]
  {E : Type u} [normed_group E] [normed_space 𝕜 E]

/-- If one controls the norm of every `f x`, then one controls the norm of `x`.
    Compare `continuous_linear_map.op_norm_le_bound`. -/
lemma norm_le_dual_bound (x : E) {M : ℝ} (hMp: 0 ≤ M) (hM : ∀ (f : dual 𝕜 E), ∥f x∥ ≤ M * ∥f∥) :
  ∥x∥ ≤ M :=
begin
  classical,
  by_cases h : x = 0,
  { simp only [h, hMp, norm_zero] },
  { obtain ⟨f, hf₁, hfx⟩ : ∃ f : E →L[𝕜] 𝕜, ∥f∥ = 1 ∧ f x = ∥x∥ := exists_dual_vector 𝕜 x h,
    calc ∥x∥ = ∥(∥x∥ : 𝕜)∥ : is_R_or_C.norm_coe_norm.symm
    ... = ∥f x∥ : by rw hfx
    ... ≤ M * ∥f∥ : hM f
    ... = M : by rw [hf₁, mul_one] }
end

lemma eq_zero_of_forall_dual_eq_zero {x : E} (h : ∀ f : dual 𝕜 E, f x = (0 : 𝕜)) : x = 0 :=
norm_le_zero_iff.mp (norm_le_dual_bound 𝕜 x le_rfl (λ f, by simp [h f]))

lemma eq_zero_iff_forall_dual_eq_zero (x : E) : x = 0 ↔ ∀ g : dual 𝕜 E, g x = 0 :=
⟨λ hx, by simp [hx], λ h, eq_zero_of_forall_dual_eq_zero 𝕜 h⟩

lemma eq_iff_forall_dual_eq {x y : E} :
  x = y ↔ ∀ g : dual 𝕜 E, g x = g y :=
begin
  rw [← sub_eq_zero, eq_zero_iff_forall_dual_eq_zero 𝕜 (x - y)],
  simp [sub_eq_zero],
end

/-- The inclusion of a normed space in its double dual is an isometry onto its image.-/
def inclusion_in_double_dual_li : E →ₗᵢ[𝕜] (dual 𝕜 (dual 𝕜 E)) :=
{ norm_map' := begin
    intros x,
    apply le_antisymm,
    { exact double_dual_bound 𝕜 E x },
    rw continuous_linear_map.norm_def,
    refine le_cInf continuous_linear_map.bounds_nonempty _,
    rintros c ⟨hc1, hc2⟩,
    exact norm_le_dual_bound 𝕜 x hc1 hc2
  end,
  .. inclusion_in_double_dual 𝕜 E }

end bidual_isometry

section polar_sets

open metric set normed_space

/-- Given a subset `s` in a normed space `E` (over a field `𝕜`), the polar
`polar 𝕜 s` is the subset of `dual 𝕜 E` consisting of those functionals which
evaluate to something of norm at most one at all points `z ∈ s`. -/
def polar (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] : set E → set (dual 𝕜 E) :=
(dual_pairing 𝕜 E).flip.polar

variables (𝕜 : Type*) [nondiscrete_normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]

lemma mem_polar_iff {x' : dual 𝕜 E} (s : set E) : x' ∈ polar 𝕜 s ↔ ∀ z ∈ s, ∥x' z∥ ≤ 1 := iff.rfl

@[simp] lemma polar_univ : polar 𝕜 (univ : set E) = {(0 : dual 𝕜 E)} :=
(dual_pairing 𝕜 E).flip.polar_univ
  (linear_map.flip_separating_right.mpr (dual_pairing_separating_left 𝕜 E))

lemma is_closed_polar (s : set E) : is_closed (polar 𝕜 s) :=
begin
  dunfold normed_space.polar,
  simp only [linear_map.polar_eq_Inter, linear_map.flip_apply],
  refine is_closed_bInter (λ z hz, _),
  exact is_closed_Iic.preimage (continuous_linear_map.apply 𝕜 𝕜 z).continuous.norm
end

@[simp] lemma polar_closure (s : set E) : polar 𝕜 (closure s) = polar 𝕜 s :=
((dual_pairing 𝕜 E).flip.polar_antitone subset_closure).antisymm $
  (dual_pairing 𝕜 E).flip.polar_gc.l_le $
  closure_minimal ((dual_pairing 𝕜 E).flip.polar_gc.le_u_l s) $
  (is_closed_polar _ _).preimage (inclusion_in_double_dual 𝕜 E).continuous

variables {𝕜}

/-- If `x'` is a dual element such that the norms `∥x' z∥` are bounded for `z ∈ s`, then a
small scalar multiple of `x'` is in `polar 𝕜 s`. -/
lemma smul_mem_polar {s : set E} {x' : dual 𝕜 E} {c : 𝕜}
  (hc : ∀ z, z ∈ s → ∥ x' z ∥ ≤ ∥c∥) : c⁻¹ • x' ∈ polar 𝕜 s :=
begin
  by_cases c_zero : c = 0, { simp only [c_zero, inv_zero, zero_smul],
    exact (dual_pairing 𝕜 E).flip.zero_mem_polar _ },
  have eq : ∀ z, ∥ c⁻¹ • (x' z) ∥ = ∥ c⁻¹ ∥ * ∥ x' z ∥ := λ z, norm_smul c⁻¹ _,
  have le : ∀ z, z ∈ s → ∥ c⁻¹ • (x' z) ∥ ≤ ∥ c⁻¹ ∥ * ∥ c ∥,
  { intros z hzs,
    rw eq z,
    apply mul_le_mul (le_of_eq rfl) (hc z hzs) (norm_nonneg _) (norm_nonneg _), },
  have cancel : ∥ c⁻¹ ∥ * ∥ c ∥ = 1,
  by simp only [c_zero, norm_eq_zero, ne.def, not_false_iff,
                inv_mul_cancel, norm_inv],
  rwa cancel at le,
end

lemma polar_ball_subset_closed_ball_div {c : 𝕜} (hc : 1 < ∥c∥) {r : ℝ} (hr : 0 < r) :
  polar 𝕜 (ball (0 : E) r) ⊆ closed_ball (0 : dual 𝕜 E) (∥c∥ / r) :=
begin
  intros x' hx',
  rw mem_polar_iff at hx',
  simp only [polar, mem_set_of_eq, mem_closed_ball_zero_iff, mem_ball_zero_iff] at *,
  have hcr : 0 < ∥c∥ / r, from div_pos (zero_lt_one.trans hc) hr,
  refine continuous_linear_map.op_norm_le_of_shell hr hcr.le hc (λ x h₁ h₂, _),
  calc ∥x' x∥ ≤ 1 : hx' _ h₂
  ... ≤ (∥c∥ / r) * ∥x∥ : (inv_pos_le_iff_one_le_mul' hcr).1 (by rwa inv_div)
end

variables (𝕜)

lemma closed_ball_inv_subset_polar_closed_ball {r : ℝ} :
  closed_ball (0 : dual 𝕜 E) r⁻¹ ⊆ polar 𝕜 (closed_ball (0 : E) r) :=
λ x' hx' x hx,
calc ∥x' x∥ ≤ ∥x'∥ * ∥x∥ : x'.le_op_norm x
... ≤ r⁻¹ * r :
  mul_le_mul (mem_closed_ball_zero_iff.1 hx') (mem_closed_ball_zero_iff.1 hx)
    (norm_nonneg _) (dist_nonneg.trans hx')
... = r / r : div_eq_inv_mul.symm
... ≤ 1 : div_self_le_one r

/-- The `polar` of closed ball in a normed space `E` is the closed ball of the dual with
inverse radius. -/
lemma polar_closed_ball
  {𝕜 : Type*} [is_R_or_C 𝕜] {E : Type*} [normed_group E] [normed_space 𝕜 E] {r : ℝ} (hr : 0 < r) :
  polar 𝕜 (closed_ball (0 : E) r) = closed_ball (0 : dual 𝕜 E) r⁻¹ :=
begin
  refine subset.antisymm _ (closed_ball_inv_subset_polar_closed_ball _),
  intros x' h,
  simp only [mem_closed_ball_zero_iff],
  refine continuous_linear_map.op_norm_le_of_ball hr (inv_nonneg.mpr hr.le) (λ z hz, _),
  simpa only [one_div] using linear_map.bound_of_ball_bound' hr 1 x'.to_linear_map h z
end

/-- Given a neighborhood `s` of the origin in a normed space `E`, the dual norms
of all elements of the polar `polar 𝕜 s` are bounded by a constant. -/
lemma bounded_polar_of_mem_nhds_zero {s : set E} (s_nhd : s ∈ 𝓝 (0 : E)) :
  bounded (polar 𝕜 s) :=
begin
  obtain ⟨a, ha⟩ : ∃ a : 𝕜, 1 < ∥a∥ := normed_field.exists_one_lt_norm 𝕜,
  obtain ⟨r, r_pos, r_ball⟩ : ∃ (r : ℝ) (hr : 0 < r), ball 0 r ⊆ s :=
    metric.mem_nhds_iff.1 s_nhd,
  exact bounded_closed_ball.mono (((dual_pairing 𝕜 E).flip.polar_antitone r_ball).trans $
    polar_ball_subset_closed_ball_div ha r_pos)
end

end polar_sets

end normed_space


/-
Copyright (c) 2018 Mario Carneiro, Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Kevin Buzzard
-/
import algebra.algebra.subalgebra.basic
import algebra.algebra.tower
import algebra.ring.idempotents
import group_theory.finiteness
import linear_algebra.linear_independent
import order.compactly_generated
import order.order_iso_nat
import ring_theory.finiteness
import ring_theory.nilpotent

/-!
# Noetherian rings and modules

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

The following are equivalent for a module M over a ring R:
1. Every increasing chain of submodules M₁ ⊆ M₂ ⊆ M₃ ⊆ ⋯ eventually stabilises.
2. Every submodule is finitely generated.

A module satisfying these equivalent conditions is said to be a *Noetherian* R-module.
A ring is a *Noetherian ring* if it is Noetherian as a module over itself.

(Note that we do not assume yet that our rings are commutative,
so perhaps this should be called "left Noetherian".
To avoid cumbersome names once we specialize to the commutative case,
we don't make this explicit in the declaration names.)

## Main definitions

Let `R` be a ring and let `M` and `P` be `R`-modules. Let `N` be an `R`-submodule of `M`.

* `is_noetherian R M` is the proposition that `M` is a Noetherian `R`-module. It is a class,
  implemented as the predicate that all `R`-submodules of `M` are finitely generated.

## Main statements

* `is_noetherian_iff_well_founded` is the theorem that an R-module M is Noetherian iff
  `>` is well-founded on `submodule R M`.

Note that the Hilbert basis theorem, that if a commutative ring R is Noetherian then so is R[X],
is proved in `ring_theory.polynomial`.

## References

* [M. F. Atiyah and I. G. Macdonald, *Introduction to commutative algebra*][atiyah-macdonald]
* [samuel1967]

## Tags

Noetherian, noetherian, Noetherian ring, Noetherian module, noetherian ring, noetherian module

-/

open set
open_locale big_operators pointwise

/--
`is_noetherian R M` is the proposition that `M` is a Noetherian `R`-module,
implemented as the predicate that all `R`-submodules of `M` are finitely generated.
-/
class is_noetherian (R M) [semiring R] [add_comm_monoid M] [module R M] : Prop :=
(noetherian : ∀ (s : submodule R M), s.fg)

section
variables {R : Type*} {M : Type*} {P : Type*}
variables [semiring R] [add_comm_monoid M] [add_comm_monoid P]
variables [module R M] [module R P]
open is_noetherian
include R

/-- An R-module is Noetherian iff all its submodules are finitely-generated. -/
lemma is_noetherian_def : is_noetherian R M ↔ ∀ (s : submodule R M), s.fg :=
⟨λ h, h.noetherian, is_noetherian.mk⟩

theorem is_noetherian_submodule {N : submodule R M} :
  is_noetherian R N ↔ ∀ s : submodule R M, s ≤ N → s.fg :=
begin
  refine ⟨λ ⟨hn⟩, λ s hs, have s ≤ N.subtype.range, from (N.range_subtype).symm ▸ hs,
    submodule.map_comap_eq_self this ▸ (hn _).map _, λ h, ⟨λ s, _⟩⟩,
  have f := (submodule.equiv_map_of_injective N.subtype subtype.val_injective s).symm,
  have h₁ := h (s.map N.subtype) (submodule.map_subtype_le N s),
  have h₂ : (⊤ : submodule R (s.map N.subtype)).map f = ⊤ := by simp,
  have h₃ := ((submodule.fg_top _).2 h₁).map (↑f : _ →ₗ[R] s),
  exact (submodule.fg_top _).1 (h₂ ▸ h₃),
end

theorem is_noetherian_submodule_left {N : submodule R M} :
  is_noetherian R N ↔ ∀ s : submodule R M, (N ⊓ s).fg :=
is_noetherian_submodule.trans
⟨λ H s, H _ inf_le_left, λ H s hs, (inf_of_le_right hs) ▸ H _⟩

theorem is_noetherian_submodule_right {N : submodule R M} :
  is_noetherian R N ↔ ∀ s : submodule R M, (s ⊓ N).fg :=
is_noetherian_submodule.trans
⟨λ H s, H _ inf_le_right, λ H s hs, (inf_of_le_left hs) ▸ H _⟩

instance is_noetherian_submodule' [is_noetherian R M] (N : submodule R M) : is_noetherian R N :=
is_noetherian_submodule.2 $ λ _ _, is_noetherian.noetherian _

lemma is_noetherian_of_le {s t : submodule R M} [ht : is_noetherian R t]
   (h : s ≤ t) : is_noetherian R s :=
is_noetherian_submodule.mpr (λ s' hs', is_noetherian_submodule.mp ht _ (le_trans hs' h))

variable (M)
theorem is_noetherian_of_surjective (f : M →ₗ[R] P) (hf : f.range = ⊤)
  [is_noetherian R M] : is_noetherian R P :=
⟨λ s, have (s.comap f).map f = s, from submodule.map_comap_eq_self $ hf.symm ▸ le_top,
this ▸ (noetherian _).map _⟩
variable {M}

theorem is_noetherian_of_linear_equiv (f : M ≃ₗ[R] P)
  [is_noetherian R M] : is_noetherian R P :=
is_noetherian_of_surjective _ f.to_linear_map f.range

lemma is_noetherian_top_iff :
  is_noetherian R (⊤ : submodule R M) ↔ is_noetherian R M :=
begin
  unfreezingI { split; assume h },
  { exact is_noetherian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl) },
  { exact is_noetherian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl).symm },
end

lemma is_noetherian_of_injective [is_noetherian R P] (f : M →ₗ[R] P) (hf : function.injective f) :
  is_noetherian R M :=
is_noetherian_of_linear_equiv (linear_equiv.of_injective f hf).symm

lemma fg_of_injective [is_noetherian R P] {N : submodule R M} (f : M →ₗ[R] P)
  (hf : function.injective f) : N.fg :=
@@is_noetherian.noetherian _ _ _ (is_noetherian_of_injective f hf) N

end

namespace module
variables {R M N : Type*}
variables [semiring R] [add_comm_monoid M] [add_comm_monoid N] [module R M] [module R N]

variables (R M)

@[priority 100] -- see Note [lower instance priority]
instance is_noetherian.finite [is_noetherian R M] : finite R M :=
⟨is_noetherian.noetherian ⊤⟩

variables {R M}

lemma finite.of_injective [is_noetherian R N] (f : M →ₗ[R] N)
  (hf : function.injective f) : finite R M :=
⟨fg_of_injective f hf⟩

end module

section
variables {R : Type*} {M : Type*} {P : Type*}
variables [ring R] [add_comm_group M] [add_comm_group P]
variables [module R M] [module R P]
open is_noetherian
include R

lemma is_noetherian_of_ker_bot [is_noetherian R P] (f : M →ₗ[R] P) (hf : f.ker = ⊥) :
  is_noetherian R M :=
is_noetherian_of_linear_equiv (linear_equiv.of_injective f $ linear_map.ker_eq_bot.mp hf).symm

lemma fg_of_ker_bot [is_noetherian R P] {N : submodule R M} (f : M →ₗ[R] P) (hf : f.ker = ⊥) :
  N.fg :=
@@is_noetherian.noetherian _ _ _ (is_noetherian_of_ker_bot f hf) N

instance is_noetherian_prod [is_noetherian R M]
  [is_noetherian R P] : is_noetherian R (M × P) :=
⟨λ s, submodule.fg_of_fg_map_of_fg_inf_ker (linear_map.snd R M P) (noetherian _) $
have s ⊓ linear_map.ker (linear_map.snd R M P) ≤ linear_map.range (linear_map.inl R M P),
from λ x ⟨hx1, hx2⟩, ⟨x.1, prod.ext rfl $ eq.symm $ linear_map.mem_ker.1 hx2⟩,
submodule.map_comap_eq_self this ▸ (noetherian _).map _⟩

instance is_noetherian_pi {R ι : Type*} {M : ι → Type*} [ring R]
  [Π i, add_comm_group (M i)] [Π i, module R (M i)] [finite ι]
  [∀ i, is_noetherian R (M i)] : is_noetherian R (Π i, M i) :=
begin
  casesI nonempty_fintype ι,
  haveI := classical.dec_eq ι,
  suffices on_finset : ∀ s : finset ι, is_noetherian R (Π i : s, M i),
  { let coe_e := equiv.subtype_univ_equiv finset.mem_univ,
    letI : is_noetherian R (Π i : finset.univ, M (coe_e i)) := on_finset finset.univ,
    exact is_noetherian_of_linear_equiv (linear_equiv.Pi_congr_left R M coe_e), },
  intro s,
  induction s using finset.induction with a s has ih,
  { exact ⟨λ s, by convert submodule.fg_bot⟩ },
  refine @is_noetherian_of_linear_equiv _ _ _ _ _ _ _ _
    _ (@is_noetherian_prod _ (M a) _ _ _ _ _ _ _ ih),
  fconstructor,
  { exact λ f i, or.by_cases (finset.mem_insert.1 i.2)
      (λ h : i.1 = a, show M i.1, from (eq.rec_on h.symm f.1))
      (λ h : i.1 ∈ s, show M i.1, from f.2 ⟨i.1, h⟩) },
  { intros f g, ext i, unfold or.by_cases, cases i with i hi,
    rcases finset.mem_insert.1 hi with rfl | h,
    { change _ = _ + _, simp only [dif_pos], refl },
    { change _ = _ + _, have : ¬i = a, { rintro rfl, exact has h },
      simp only [dif_neg this, dif_pos h], refl } },
  { intros c f, ext i, unfold or.by_cases, cases i with i hi,
    rcases finset.mem_insert.1 hi with rfl | h,
    { change _ = c • _, simp only [dif_pos], refl },
    { change _ = c • _, have : ¬i = a, { rintro rfl, exact has h },
      simp only [dif_neg this, dif_pos h], refl } },
  { exact λ f, (f ⟨a, finset.mem_insert_self _ _⟩, λ i, f ⟨i.1, finset.mem_insert_of_mem i.2⟩) },
  { intro f, apply prod.ext,
    { simp only [or.by_cases, dif_pos] },
    { ext ⟨i, his⟩,
      have : ¬i = a, { rintro rfl, exact has his },
      simp only [or.by_cases, this, not_false_iff, dif_neg] } },
  { intro f, ext ⟨i, hi⟩,
    rcases finset.mem_insert.1 hi with rfl | h,
    { simp only [or.by_cases, dif_pos], },
    { have : ¬i = a, { rintro rfl, exact has h },
      simp only [or.by_cases, dif_neg this, dif_pos h], } }
end

/-- A version of `is_noetherian_pi` for non-dependent functions. We need this instance because
sometimes Lean fails to apply the dependent version in non-dependent settings (e.g., it fails to
prove that `ι → ℝ` is finite dimensional over `ℝ`). -/
instance is_noetherian_pi' {R ι M : Type*} [ring R] [add_comm_group M] [module R M] [finite ι]
  [is_noetherian R M] : is_noetherian R (ι → M) :=
is_noetherian_pi

end

open is_noetherian submodule function

section
universe w
variables {R M P : Type*} {N : Type w} [semiring R] [add_comm_monoid M] [module R M]
  [add_comm_monoid N] [module R N] [add_comm_monoid P] [module R P]

theorem is_noetherian_iff_well_founded :
  is_noetherian R M ↔ well_founded ((>) : submodule R M → submodule R M → Prop) :=
begin
  rw (complete_lattice.well_founded_characterisations $ submodule R M).out 0 3,
  exact ⟨λ ⟨h⟩, λ k, (fg_iff_compact k).mp (h k), λ h, ⟨λ k, (fg_iff_compact k).mpr (h k)⟩⟩,
end

lemma is_noetherian_iff_fg_well_founded :
  is_noetherian R M ↔ well_founded
    ((>) : { N : submodule R M // N.fg } → { N : submodule R M // N.fg } → Prop) :=
begin
  let α := { N : submodule R M // N.fg },
  split,
  { introI H,
    let f : α ↪o submodule R M := order_embedding.subtype _,
    exact order_embedding.well_founded f.dual (is_noetherian_iff_well_founded.mp H) },
  { intro H,
    constructor,
    intro N,
    obtain ⟨⟨N₀, h₁⟩, e : N₀ ≤ N, h₂⟩ := well_founded.has_min
      H { N' : α | N'.1 ≤ N } ⟨⟨⊥, submodule.fg_bot⟩, bot_le⟩,
    convert h₁,
    refine (e.antisymm _).symm,
    by_contra h₃,
    obtain ⟨x, hx₁ : x ∈ N, hx₂ : x ∉ N₀⟩ := set.not_subset.mp h₃,
    apply hx₂,
    have := eq_of_le_of_not_lt _ (h₂ ⟨(R ∙ x) ⊔ N₀, _⟩ _),
    { injection this with eq,
      rw eq,
      exact (le_sup_left : (R ∙ x) ≤ (R ∙ x) ⊔ N₀) (submodule.mem_span_singleton_self _) },
    { exact submodule.fg.sup ⟨{x}, by rw [finset.coe_singleton]⟩ h₁ },
    { show N₀ ≤ (R ∙ x) ⊔ N₀, from le_sup_right },
    { exact sup_le ((submodule.span_singleton_le_iff_mem _ _).mpr hx₁) e } }
end

variables (R M)

lemma well_founded_submodule_gt (R M) [semiring R] [add_comm_monoid M] [module R M] :
  ∀ [is_noetherian R M], well_founded ((>) : submodule R M → submodule R M → Prop) :=
is_noetherian_iff_well_founded.mp

variables {R M}

/-- A module is Noetherian iff every nonempty set of submodules has a maximal submodule among them.
-/
theorem set_has_maximal_iff_noetherian :
  (∀ a : set $ submodule R M, a.nonempty → ∃ M' ∈ a, ∀ I ∈ a, ¬ M' < I) ↔ is_noetherian R M :=
by rw [is_noetherian_iff_well_founded, well_founded.well_founded_iff_has_min]

/-- A module is Noetherian iff every increasing chain of submodules stabilizes. -/
theorem monotone_stabilizes_iff_noetherian :
  (∀ (f : ℕ →o submodule R M), ∃ n, ∀ m, n ≤ m → f n = f m) ↔ is_noetherian R M :=
by rw [is_noetherian_iff_well_founded, well_founded.monotone_chain_condition]

/-- If `∀ I > J, P I` implies `P J`, then `P` holds for all submodules. -/
lemma is_noetherian.induction [is_noetherian R M] {P : submodule R M → Prop}
  (hgt : ∀ I, (∀ J > I, P J) → P I) (I : submodule R M) : P I :=
well_founded.recursion (well_founded_submodule_gt R M) I hgt

end

section
universe w
variables {R M P : Type*} {N : Type w} [ring R] [add_comm_group M] [module R M]
  [add_comm_group N] [module R N] [add_comm_group P] [module R P]

lemma finite_of_linear_independent [nontrivial R] [is_noetherian R M]
  {s : set M} (hs : linear_independent R (coe : s → M)) : s.finite :=
begin
  refine classical.by_contradiction (λ hf, (rel_embedding.well_founded_iff_no_descending_seq.1
    (well_founded_submodule_gt R M)).elim' _),
  have f : ℕ ↪ s, from set.infinite.nat_embedding s hf,
  have : ∀ n, (coe ∘ f) '' {m | m ≤ n} ⊆ s,
  { rintros n x ⟨y, hy₁, rfl⟩, exact (f y).2 },
  have : ∀ a b : ℕ, a ≤ b ↔
    span R ((coe ∘ f) '' {m | m ≤ a}) ≤ span R ((coe ∘ f) '' {m | m ≤ b}),
  { assume a b,
    rw [span_le_span_iff hs (this a) (this b),
      set.image_subset_image_iff (subtype.coe_injective.comp f.injective),
      set.subset_def],
    exact ⟨λ hab x (hxa : x ≤ a), le_trans hxa hab, λ hx, hx a (le_refl a)⟩ },
  exact ⟨⟨λ n, span R ((coe ∘ f) '' {m | m ≤ n}),
      λ x y, by simp [le_antisymm_iff, (this _ _).symm] {contextual := tt}⟩,
    by dsimp [gt]; simp only [lt_iff_le_not_le, (this _ _).symm]; tauto⟩
end

/-- If the first and final modules in a short exact sequence are noetherian,
  then the middle module is also noetherian. -/
theorem is_noetherian_of_range_eq_ker
  [is_noetherian R M] [is_noetherian R P]
  (f : M →ₗ[R] N) (g : N →ₗ[R] P)
  (hf : function.injective f)
  (hg : function.surjective g)
  (h : f.range = g.ker) :
  is_noetherian R N :=
is_noetherian_iff_well_founded.2 $
well_founded_gt_exact_sequence
  (well_founded_submodule_gt R M)
  (well_founded_submodule_gt R P)
  f.range
  (submodule.map f)
  (submodule.comap f)
  (submodule.comap g)
  (submodule.map g)
  (submodule.gci_map_comap hf)
  (submodule.gi_map_comap hg)
  (by simp [submodule.map_comap_eq, inf_comm])
  (by simp [submodule.comap_map_eq, h])

/--
For any endomorphism of a Noetherian module, there is some nontrivial iterate
with disjoint kernel and range.
-/
theorem is_noetherian.exists_endomorphism_iterate_ker_inf_range_eq_bot
  [I : is_noetherian R M] (f : M →ₗ[R] M) : ∃ n : ℕ, n ≠ 0 ∧ (f ^ n).ker ⊓ (f ^ n).range = ⊥ :=
begin
  obtain ⟨n, w⟩ := monotone_stabilizes_iff_noetherian.mpr I
    (f.iterate_ker.comp ⟨λ n, n+1, λ n m w, by linarith⟩),
  specialize w (2 * n + 1) (by linarith only),
  dsimp at w,
  refine ⟨n+1, nat.succ_ne_zero _, _⟩,
  rw eq_bot_iff,
  rintros - ⟨h, ⟨y, rfl⟩⟩,
  rw [mem_bot, ←linear_map.mem_ker, w],
  erw linear_map.mem_ker at h ⊢,
  change ((f ^ (n + 1)) * (f ^ (n + 1))) y = 0 at h,
  rw ←pow_add at h,
  convert h using 3,
  ring
end

/-- Any surjective endomorphism of a Noetherian module is injective. -/
theorem is_noetherian.injective_of_surjective_endomorphism [is_noetherian R M]
  (f : M →ₗ[R] M) (s : surjective f) : injective f :=
begin
  obtain ⟨n, ne, w⟩ := is_noetherian.exists_endomorphism_iterate_ker_inf_range_eq_bot f,
  rw [linear_map.range_eq_top.mpr (linear_map.iterate_surjective s n), inf_top_eq,
    linear_map.ker_eq_bot] at w,
  exact linear_map.injective_of_iterate_injective ne w,
end

/-- Any surjective endomorphism of a Noetherian module is bijective. -/
theorem is_noetherian.bijective_of_surjective_endomorphism [is_noetherian R M]
  (f : M →ₗ[R] M) (s : surjective f) : bijective f :=
⟨is_noetherian.injective_of_surjective_endomorphism f s, s⟩

/--
A sequence `f` of submodules of a noetherian module,
with `f (n+1)` disjoint from the supremum of `f 0`, ..., `f n`,
is eventually zero.
-/
lemma is_noetherian.disjoint_partial_sups_eventually_bot [I : is_noetherian R M]
  (f : ℕ → submodule R M) (h : ∀ n, disjoint (partial_sups f n) (f (n+1))) :
  ∃ n : ℕ, ∀ m, n ≤ m → f m = ⊥ :=
begin
  -- A little off-by-one cleanup first:
  suffices t : ∃ n : ℕ, ∀ m, n ≤ m → f (m+1) = ⊥,
  { obtain ⟨n, w⟩ := t,
    use n+1,
    rintros (_|m) p,
    { cases p, },
    { apply w,
      exact nat.succ_le_succ_iff.mp p }, },

  obtain ⟨n, w⟩ := monotone_stabilizes_iff_noetherian.mpr I (partial_sups f),
  exact ⟨n, λ m p, (h m).eq_bot_of_ge $ sup_eq_left.1 $ (w (m + 1) $ le_add_right p).symm.trans $
    w m p⟩
end

/--
If `M ⊕ N` embeds into `M`, for `M` noetherian over `R`, then `N` is trivial.
-/
noncomputable def is_noetherian.equiv_punit_of_prod_injective [is_noetherian R M]
  (f : M × N →ₗ[R] M) (i : injective f) : N ≃ₗ[R] punit.{w+1} :=
begin
  apply nonempty.some,
  obtain ⟨n, w⟩ := is_noetherian.disjoint_partial_sups_eventually_bot (f.tailing i)
    (f.tailings_disjoint_tailing i),
  specialize w n (le_refl n),
  apply nonempty.intro,
  refine (f.tailing_linear_equiv i n).symm ≪≫ₗ _,
  rw w,
  exact submodule.bot_equiv_punit,
end

end

/--
A (semi)ring is Noetherian if it is Noetherian as a module over itself,
i.e. all its ideals are finitely generated.
-/
@[reducible] def is_noetherian_ring (R) [semiring R] := is_noetherian R R

theorem is_noetherian_ring_iff {R} [semiring R] : is_noetherian_ring R ↔ is_noetherian R R :=
iff.rfl

/-- A ring is Noetherian if and only if all its ideals are finitely-generated. -/
lemma is_noetherian_ring_iff_ideal_fg (R : Type*) [semiring R] :
  is_noetherian_ring R ↔ ∀ I : ideal R, I.fg :=
is_noetherian_ring_iff.trans is_noetherian_def

@[priority 80] -- see Note [lower instance priority]
instance is_noetherian_of_finite (R M) [finite M] [semiring R] [add_comm_monoid M] [module R M] :
  is_noetherian R M :=
⟨λ s, ⟨(s : set M).to_finite.to_finset, by rw [set.finite.coe_to_finset, submodule.span_eq]⟩⟩

/-- Modules over the trivial ring are Noetherian. -/
@[priority 100] -- see Note [lower instance priority]
instance is_noetherian_of_subsingleton (R M) [subsingleton R] [semiring R] [add_comm_monoid M]
  [module R M] : is_noetherian R M :=
by { haveI := module.subsingleton R M, exact is_noetherian_of_finite R M }

theorem is_noetherian_of_submodule_of_noetherian (R M) [semiring R] [add_comm_monoid M] [module R M]
  (N : submodule R M) (h : is_noetherian R M) : is_noetherian R N :=
begin
  rw is_noetherian_iff_well_founded at h ⊢,
  exact order_embedding.well_founded (submodule.map_subtype.order_embedding N).dual h,
end

instance submodule.quotient.is_noetherian {R} [ring R] {M} [add_comm_group M] [module R M]
  (N : submodule R M) [h : is_noetherian R M] : is_noetherian R (M ⧸ N) :=
begin
  rw is_noetherian_iff_well_founded at h ⊢,
  exact order_embedding.well_founded (submodule.comap_mkq.order_embedding N).dual h,
end

/-- If `M / S / R` is a scalar tower, and `M / R` is Noetherian, then `M / S` is
also noetherian. -/
theorem is_noetherian_of_tower (R) {S M} [semiring R] [semiring S]
  [add_comm_monoid M] [has_smul R S] [module S M] [module R M] [is_scalar_tower R S M]
  (h : is_noetherian R M) : is_noetherian S M :=
begin
  rw is_noetherian_iff_well_founded at h ⊢,
  refine (submodule.restrict_scalars_embedding R S M).dual.well_founded h
end

theorem is_noetherian_of_fg_of_noetherian {R M} [ring R] [add_comm_group M] [module R M]
  (N : submodule R M) [is_noetherian_ring R] (hN : N.fg) : is_noetherian R N :=
let ⟨s, hs⟩ := hN in
begin
  haveI := classical.dec_eq M,
  haveI := classical.dec_eq R,
  letI : is_noetherian R R := by apply_instance,
  have : ∀ x ∈ s, x ∈ N, from λ x hx, hs ▸ submodule.subset_span hx,
  refine @@is_noetherian_of_surjective ((↑s : set M) → R) _ _ _ (pi.module _ _ _)
    _ _ _ is_noetherian_pi,
  { fapply linear_map.mk,
    { exact λ f, ⟨∑ i in s.attach, f i • i.1, N.sum_mem (λ c _, N.smul_mem _ $ this _ c.2)⟩ },
    { intros f g, apply subtype.eq,
      change ∑ i in s.attach, (f i + g i) • _ = _,
      simp only [add_smul, finset.sum_add_distrib], refl },
    { intros c f, apply subtype.eq,
      change ∑ i in s.attach, (c • f i) • _ = _,
      simp only [smul_eq_mul, mul_smul],
      exact finset.smul_sum.symm } },
  rw linear_map.range_eq_top,
  rintro ⟨n, hn⟩, change n ∈ N at hn,
  rw [← hs, ← set.image_id ↑s, finsupp.mem_span_image_iff_total] at hn,
  rcases hn with ⟨l, hl1, hl2⟩,
  refine ⟨λ x, l x, subtype.ext _⟩,
  change ∑ i in s.attach, l i • (i : M) = n,
  rw [@finset.sum_attach M M s _ (λ i, l i • i), ← hl2,
      finsupp.total_apply, finsupp.sum, eq_comm],
  refine finset.sum_subset hl1 (λ x _ hx, _),
  rw [finsupp.not_mem_support_iff.1 hx, zero_smul]
end

lemma is_noetherian_of_fg_of_noetherian' {R M} [ring R] [add_comm_group M] [module R M]
  [is_noetherian_ring R] (h : (⊤ : submodule R M).fg) : is_noetherian R M :=
have is_noetherian R (⊤ : submodule R M), from is_noetherian_of_fg_of_noetherian _ h,
by exactI is_noetherian_of_linear_equiv (linear_equiv.of_top (⊤ : submodule R M) rfl)

/-- In a module over a noetherian ring, the submodule generated by finitely many vectors is
noetherian. -/
theorem is_noetherian_span_of_finite (R) {M} [ring R] [add_comm_group M] [module R M]
  [is_noetherian_ring R] {A : set M} (hA : A.finite) : is_noetherian R (submodule.span R A) :=
is_noetherian_of_fg_of_noetherian _ (submodule.fg_def.mpr ⟨A, hA, rfl⟩)

theorem is_noetherian_ring_of_surjective (R) [ring R] (S) [ring S]
  (f : R →+* S) (hf : function.surjective f)
  [H : is_noetherian_ring R] : is_noetherian_ring S :=
begin
  rw [is_noetherian_ring_iff, is_noetherian_iff_well_founded] at H ⊢,
  exact order_embedding.well_founded (ideal.order_embedding_of_surjective f hf).dual H,
end

instance is_noetherian_ring_range {R} [ring R] {S} [ring S] (f : R →+* S)
  [is_noetherian_ring R] : is_noetherian_ring f.range :=
is_noetherian_ring_of_surjective R f.range f.range_restrict
  f.range_restrict_surjective

theorem is_noetherian_ring_of_ring_equiv (R) [ring R] {S} [ring S]
  (f : R ≃+* S) [is_noetherian_ring R] : is_noetherian_ring S :=
is_noetherian_ring_of_surjective R S f.to_ring_hom f.to_equiv.surjective

lemma is_noetherian_ring.is_nilpotent_nilradical (R : Type*) [comm_ring R] [is_noetherian_ring R] :
  is_nilpotent (nilradical R) :=
begin
  obtain ⟨n, hn⟩ := ideal.exists_radical_pow_le_of_fg (⊥ : ideal R) (is_noetherian.noetherian _),
  exact ⟨n, eq_bot_iff.mpr hn⟩
end


import data.real.basic

structure solution (k : ℤ) :=
  (req0 : k ≥ 1)
  (a : ℤ)
  (b : ℤ)
  (req1 : a^2 + b^2 = k*(a*b+1))
  (req2 : a ≥ 0 ∧ b ≥ 0)

structure solution_pos (k : ℤ) :=
  (s : solution k)
  (pos : s.a > 0 ∧ s.b > 0)

def nosq (k : ℤ) : Prop := ¬ ∃ l : ℤ , k = l*l

-- Goal is to prove that if k isn't a square then ∄ positive solution
-- Follows idea from https://www.youtube.com/watch?v=WCI5OaBKME4

def l1 (k  : ℤ) (s : solution k) (H2 : s.b ≥ 1) (H1 : s.a ≥ s.b) : solution k :=
begin
  let a1 := k*s.b-s.a, -- integer, must be positive
  let b := s.b,
  let a := s.a,
  have h : a1^2 + b^2 = k*(a1*b+1),
  {
    dsimp [a1],
    calc (k*b-a)^2 + b^2 = k^2*b^2 - 2*k*b*a + (a^2+b^2) : by ring
    ... = k^2*b^2 - 2*k*b*a + k*(a*b+1) : by rw s.req1
    ... = k*((k*b-a)*b+1) : by ring
  },
  have h2 : a1 ≥ 0,
  {
    by_contra hh,
    have h3 : a1 < 0,
    {
      simp,
      simp at hh,
      assumption,
    },
    have h4 : a1*b+1 ≤ 0,
    {
      rw ←  int.lt_iff_add_one_le,
      apply mul_neg_iff.mpr,
      apply or.inr,
      dsimp [b],
      split,
      assumption,
      linarith [H2, h3],
    },
    have h5 : k*(a1*b+1) ≤ 0,
    {
      rw (by ring : 0 = k * 0),
      apply int.mul_le_mul_of_nonneg_left h4,
      linarith only [s.req0],
    },
    have h6 : a1^2 + b^2 > 0,
    {
      have : 1*1 ≤ b*b,
      {
        exact int.mul_self_le_mul_self (by linarith : 0 ≤ (1 : int)) (H2),
      },
      have : a1*a1 ≥ 0,
      {
        exact mul_self_nonneg a1,
      },
      linarith,
    },
    linarith,
  },
  have s : solution k,
  {
    exact solution.mk (s.req0) a1 b h ⟨h2, by linarith⟩,
  },
  exact s,
end

lemma l2 (k : ℤ ) (s : solution k) (H2 : s.b ≥ 1) (H1 : s.a ≥ s.b)
  : (l1 k s H2 H1).a * s.a = (s.b^2 - k) :=
begin
  dsimp [l1],
  have : s.b^2 = -s.a^2 + k*(s.a*s.b+1),
  {
    linarith only [s.req1]
  },
  rw this,
  ring_nf,
end

lemma l3 (k : ℤ ) (s : solution k) (H2 : s.b ≥ 1) (H1 : s.a ≥ s.b)
  : (l1 k s H2 H1).a < s.a :=
begin
  rw ← mul_lt_mul_right (by linarith : s.a > 0),
  rw l2,
  calc s.b^2 - k < s.b^2 : by linarith [s.req0]
  ... = s.b * s.b : by ring_nf
  ... ≤ s.a * s.a : mul_self_le_mul_self (by linarith) H1
end

-- can I define this to be `→ ℕ` ??
def height {k : ℤ}: solution k → ℤ :=
  λ s, (s.a + s.b)

lemma l4 (k : ℤ) (s : solution k) (H2 : s.b ≥ 1) (H1 : s.a ≥ s.b)
  : height (l1 k s H2 H1) < height s :=
begin
  dsimp [height],
  calc (l1 k s H2 H1).a + (l1 k s H2 H1).b = (l1 k s H2 H1).a + s.b : rfl
  ... < s.a + s.b : by linarith [l3 k s H2 H1]
end

lemma l5 (k : ℤ) (s : solution k) (H2 : s.b ≥ 1) (H1 : s.a ≥ s.b) (H3 : nosq k)
  : (l1 k s H2 H1).a > 0 :=
begin
  cases lt_or_eq_of_le (l1 k s H2 H1).req2.left,
  assumption,
  exfalso,
  -- l2 : (l1 k s H2 H1).a * s.a = (s.b^2 - k) :=
  have : 0 = s.b^2 - k,
  {
    calc 0 = 0 * s.a : by ring
    ... = (l1 k s H2 H1).a * s.a : by rw [h]
    ... = s.b^2 - k : l2 k s H2 H1
  },
  apply H3,
  use s.b,
  ring_nf,
  linarith,
end

structure solution_normal (k : ℤ) :=
  (s : solution k)
  (H2 : s.b ≥ 1)
  (H1 : s.a ≥ s.b)

def normal (k : ℤ) (sp : solution_pos k) : solution_normal k :=
begin
  by_cases sp.s.a ≥ sp.s.b,
  {
    apply solution_normal.mk sp.s,
    linarith [sp.pos.right],
    assumption,
  },
  {
    exact {
      s := begin
        apply solution.mk sp.s.req0 sp.s.b sp.s.a,
        {
          let hh := sp.s.req1,
          calc sp.s.b ^ 2 + sp.s.a ^ 2 = sp.s.a ^ 2 + sp.s.b ^ 2 : by ring
          ... = k * (sp.s.a * sp.s.b + 1) : hh
          ... = k * (sp.s.b * sp.s.a + 1) : by ring,
        },
        split ; linarith [sp.s.req2],
      end,
      H2 := begin
        simp,
        linarith [sp.pos],
      end,
      H1 := begin
        simp,
        linarith,
      end,
    },
  },
end

lemma l6 (k : ℤ) (sp : solution_pos k) : height sp.s = height (normal k sp).s :=
begin
  by_cases sp.s.b ≤ sp.s.a ; dsimp [normal],
    simp [h],
  simp [h],
  dsimp [height],
  ring,
end

def step (k : ℤ) (hk : nosq k) (sn : solution_normal k) : solution_normal k :=
  normal k {
    s := l1 k sn.s sn.H2 sn.H1,
    pos := begin
      split,
      apply l5,
      exact hk,
      dsimp [l1],
      linarith [sn.H2],
    end
  }

lemma l7 (k : ℤ) (hk : nosq k) (sn : solution_normal k) : height (step k hk sn).s < height sn.s :=
begin
  dsimp [step],
  rw ← l6,
  simp,
  apply l4,
end

lemma heightn {k : ℤ} (s : solution k): ∃ (n : ℕ ), height s = n :=
begin
  have : height s ≥ 0,
  {
    dsimp [height]; linarith [s.req2],
  },
  cases int.le.dest this,
  use w,
  linarith,
end

lemma height_sequence (k : ℤ) (hk : nosq k) (sn : solution_normal k)
  : ∃ (f : ℕ → ℕ), (∀ n, f (n+1) < f n) :=
begin
  let sns : ℕ → solution_normal k := λ n, nat.rec_on n sn (λ _ sn, step k hk sn),
  have hh : ∀ (n : ℕ), ∃ (n2 : ℕ ), height (sns n).s = n2,
  {
    intro n2,
    apply heightn,
  },
  choose s1 s2 using hh,
  use s1,

  intro n,
  rw ← int.coe_nat_lt_coe_nat_iff,
  rw ← s2 n,
  rw ← s2 (n+1),
  apply l7,
end

lemma wfseq (f : ℕ → ℕ) (H : ∀ n, f (n+1) < f n) : false :=
begin
  have : ∀ k n, f n > k,
  {
    intro k,

    induction k with k hk,
    {
      intro n,
      specialize H n,
      linarith,
    },
    {
      intro n,
      specialize H n,
      specialize hk (n+1),
      calc k+1 < f (n+1) +1 : by linarith
      ... ≤ f n : H
    },
  },
  linarith [this (f 0) 0],
end

theorem no_pos_solution (k : ℤ) (hk : nosq k) (sp : solution_pos k) : false :=
begin
  cases (height_sequence k hk (normal k sp)) with f hf,
  exact wfseq f hf,
end


universe u

theorem lt_iff_sub_neg {α : Type} [ordered_comm_group α] {a b : α} :
   a - b < 0 ↔  a < b := ⟨lt_of_sub_neg,sub_neg_of_lt⟩

theorem Q4 : { x : ℝ | x ≠ 0 ∧ 3*x + 1/x < 4 } = {x : ℝ | x<0 ∨ ( ((1:ℝ)/3)<x ∧ x<1) } := sorry


/-
Copyright (c) 2020 Eric Weiser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Weiser
-/
import algebra.star.basic
import algebra.free_algebra

/-!
# A *-algebra structure on the free algebra.

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

Reversing words gives a *-structure on the free monoid or on the free algebra on a type.

## Implementation note
We have this in a separate file, rather than in `algebra.free_monoid` and `algebra.free_algebra`,
to avoid importing `algebra.star.basic` into the entire hierarchy.
-/

namespace free_monoid
variables {α : Type*}

instance : star_semigroup (free_monoid α) :=
{ star := list.reverse,
  star_involutive := list.reverse_reverse,
  star_mul := list.reverse_append, }

@[simp]
lemma star_of (x : α) : star (of x) = of x := rfl

/-- Note that `star_one` is already a global simp lemma, but this one works with dsimp too -/
@[simp]
lemma star_one : star (1 : free_monoid α) = 1 := rfl

end free_monoid

namespace free_algebra
variables {R : Type*} [comm_semiring R] {X : Type*}

/-- The star ring formed by reversing the elements of products -/
instance : star_ring (free_algebra R X) :=
{ star := mul_opposite.unop ∘ lift R (mul_opposite.op ∘ ι R),
  star_involutive := λ x, by
  { unfold has_star.star,
    simp only [function.comp_apply],
    refine free_algebra.induction R X _ _ _ _ x,
    { intros, simp only [alg_hom.commutes, mul_opposite.algebra_map_apply, mul_opposite.unop_op] },
    { intros, simp only [lift_ι_apply, mul_opposite.unop_op] },
    { intros, simp only [*, map_mul, mul_opposite.unop_mul] },
    { intros, simp only [*, map_add, mul_opposite.unop_add] } },
  star_mul := λ a b, by simp only [function.comp_app, map_mul, mul_opposite.unop_mul],
  star_add := λ a b, by simp only [function.comp_app, map_add, mul_opposite.unop_add]}

@[simp]
lemma star_ι (x : X) : star (ι R x) = (ι R x) :=
by simp [star, has_star.star]

@[simp]
lemma star_algebra_map (r : R) : star (algebra_map R (free_algebra R X) r) = (algebra_map R _ r) :=
by simp [star, has_star.star]

/-- `star` as an `alg_equiv` -/
def star_hom : free_algebra R X ≃ₐ[R] (free_algebra R X)ᵐᵒᵖ :=
{ commutes' := λ r, by simp [star_algebra_map],
  ..star_ring_equiv }

end free_algebra


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.monotonicity
import tactic.norm_num
import algebra.ordered_ring
import measure_theory.lebesgue_measure
import data.list.defs

open list tactic tactic.interactive set

example
  (h : 3 + 6 ≤ 4 + 5)
: 1 + 3 + 2 + 6 ≤ 4 + 2 + 1 + 5 :=
begin
  ac_mono,
end

example
  (h : 3 ≤ (4 : ℤ))
  (h' : 5 ≤ (6 : ℤ))
: (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
begin
  ac_mono,
  mono,
end

example
  (h : 3 ≤ (4 : ℤ))
  (h' : 5 ≤ (6 : ℤ))
: (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
begin
  transitivity (1 + 3 + 2 - 5 : ℤ),
  { ac_mono },
  { ac_mono },
end

example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y)
: (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, norm_num
end

example (x y z a b : ℤ)
  (h : a ≤ (b : ℤ))
  (h' : z ≤ y)
: (1 + a + x) - y ≤ (1 + b + x) - z :=
begin
  transitivity (1 + a + x - z),
  { mono, },
  { mono, mono, mono },
end

example (x y z : ℤ)
  (h' : z ≤ y)
: (1 + 3 + x) - y ≤ (1 + 4 + x) - z :=
begin
  transitivity (1 + 3 + x - z),
  { mono },
  { mono, mono, norm_num },
end

example (x y z : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y)
: (1 + 3 + x) - y ≤ (1 + 4 + x) - z :=
begin
  ac_mono, mono*
end

@[simp]
def list.le' {α : Type*} [has_le α] : list α → list α → Prop
 | (x::xs) (y::ys) := x ≤ y ∧ list.le' xs ys
 | [] [] := true
 | _ _ := false

@[simp]
instance list_has_le {α : Type*} [has_le α] : has_le (list α) :=
⟨ list.le' ⟩

lemma list.le_refl {α : Type*} [preorder α] {xs : list α}
: xs ≤ xs :=
begin
  induction xs with x xs,
  { trivial },
  { simp [has_le.le,list.le],
    split, apply le_refl, apply xs_ih }
end

-- @[trans]
lemma list.le_trans {α : Type*} [preorder α]
  {xs zs : list α} (ys : list α)
  (h  : xs ≤ ys)
  (h' : ys ≤ zs)
: xs ≤ zs :=
begin
  revert ys zs,
  induction xs with x xs
  ; intros ys zs h h'
  ; cases ys with y ys
  ; cases zs with z zs
  ; try { cases h ; cases h' ; done },
  { apply list.le_refl },
  { simp [has_le.le,list.le],
    split,
    apply le_trans h.left h'.left,
    apply xs_ih _ h.right h'.right, }
end

@[mono]
lemma list_le_mono_left {α : Type*} [preorder α] {xs ys zs : list α}
  (h : xs ≤ ys)
: xs ++ zs ≤ ys ++ zs :=
begin
  revert ys,
  induction xs with x xs ; intros ys h,
  { cases ys, apply list.le_refl, cases h },
  { cases ys with y ys, cases h, simp [has_le.le,list.le] at *,
    revert h, apply and.imp_right,
    apply xs_ih }
end

@[mono]
lemma list_le_mono_right {α : Type*} [preorder α] {xs ys zs : list α}
  (h : xs ≤ ys)
: zs ++ xs ≤ zs ++ ys :=
begin
  revert ys zs,
  induction xs with x xs ; intros ys zs h,
  { cases ys, { simp, apply list.le_refl }, cases h  },
  { cases ys with y ys, cases h, simp [has_le.le,list.le] at *,
    suffices : list.le' ((zs ++ [x]) ++ xs) ((zs ++ [y]) ++ ys),
    { refine cast _ this, simp, },
    apply list.le_trans (zs ++ [y] ++ xs),
    { apply list_le_mono_left,
      induction zs with z zs,
      { simp [has_le.le,list.le], apply h.left },
      { simp [has_le.le,list.le], split, apply le_refl,
        apply zs_ih, } },
    { apply xs_ih h.right, } }
end

lemma bar_bar'
  (h : [] ++ [3] ++ [2] ≤ [1] ++ [5] ++ [4])
: [] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
begin
  ac_mono,
end

lemma bar_bar''
  (h : [3] ++ [2] ++ [2] ≤ [5] ++ [4] ++ [])
: [1] ++ ([3] ++ [2]) ++ [2] ≤ [1] ++ [5] ++ ([4] ++ []) :=
begin
  ac_mono,
end

lemma bar_bar
  (h : [3] ++ [2] ≤ [5] ++ [4])
: [1] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
begin
  ac_mono,
end

def P (x : ℕ) := 7 ≤ x
def Q (x : ℕ) := x ≤ 7

@[mono]
lemma P_mono {x y : ℕ}
  (h : x ≤ y)
: P x → P y :=
by { intro h', apply le_trans h' h }

@[mono]
lemma Q_mono {x y : ℕ}
  (h : y ≤ x)
: Q x → Q y :=
by apply le_trans h

example (x y z : ℕ)
  (h : x ≤ y)
: P (x + z) → P (z + y) :=
begin
  ac_mono,
  ac_mono,
end

example (x y z : ℕ)
  (h : y ≤ x)
: Q (x + z) → Q (z + y) :=
begin
  ac_mono,
  ac_mono,
end

example (x y z k m n : ℤ)
  (h₀ : z ≤ 0)
  (h₁ : y ≤ x)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  ac_mono,
  ac_mono,
end

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  ac_mono,
  ac_mono,
end

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
  ac_mono,
  -- ⊢ m + x + n ≤ y + n + m
  ac_mono,
end

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by {  ac_mono* := h₁ }

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : m + x + n ≤ y + n + m)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by { ac_mono* := h₁ }

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : n + x + m ≤ y + n + m)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono* : m + x + n ≤ y + n + m,
  transitivity ; [ skip , apply h₁ ],
  apply le_of_eq,
  ac_refl,
end

example (x y z k m n : ℤ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono,
    success_if_fail { ac_mono },
    admit },
  trivial
end

example (x y z k m n : ℕ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono*,
    change 0 ≤ z, apply nat.zero_le, },
  trivial
end

example (x y z k m n : ℕ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono,
    change (m + x + n) * z ≤ z * (y + n + m),
    admit },
  trivial,
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
begin
  ac_mono^3,
  cc
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: z * (x + i + n + m) + k = z * (y + j + n + m) + k :=
begin
  congr,
  simp [h₁],
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
begin
  ac_mono*,
  cc,
end

example (x y : ℕ)
  (h : x ≤ y)
: true :=
begin
  (do v ← mk_mvar,
      p ← to_expr ```(%%v + x ≤ y + %%v),
      assert `h' p),
  ac_mono := h,
  trivial,
  exact 1,
end

example {x y z : ℕ} : true :=
begin
  have : y + x ≤ y + z,
  { mono,
    guard_target' x ≤ z,
    admit },
  trivial
end

example {x y z : ℕ} : true :=
begin
  suffices : x + y ≤ z + y, trivial,
  mono,
  guard_target' x ≤ z,
  admit,
end

example {x y z w : ℕ} : true :=
begin
  have : x + y ≤ z + w,
  { mono,
    guard_target' x ≤ z, admit,
    guard_target' y ≤ w, admit },
  trivial
end

example {x y z w : ℕ} : true :=
begin
  have : x * y ≤ z * w,
  { mono with [0 ≤ z,0 ≤ y],
    { guard_target 0 ≤ z, admit },
    { guard_target 0 ≤ y, admit },
    guard_target' x ≤ z, admit,
    guard_target' y ≤ w, admit },
  trivial
end

example {x y z w : Prop} : true :=
begin
  have : x ∧ y → z ∧ w,
  { mono,
    guard_target' x → z, admit,
    guard_target' y → w, admit },
  trivial
end

example {x y z w : Prop} : true :=
begin
  have : x ∨ y → z ∨ w,
  { mono,
    guard_target' x → z, admit,
    guard_target' y → w, admit },
  trivial
end

example {x y z w : ℤ} : true :=
begin
  suffices : x + y < w + z, trivial,
  have : x < w, admit,
  have : y ≤ z, admit,
  mono right,
end

example {x y z w : ℤ} : true :=
begin
  suffices : x * y < w * z, trivial,
  have : x < w, admit,
  have : y ≤ z, admit,
  mono right,
  { guard_target' 0 < y, admit },
  { guard_target' 0 ≤ w, admit },
end

open tactic

example (x y : ℕ)
  (h : x ≤ y)
: true :=
begin
  (do v ← mk_mvar,
      p ← to_expr ```(%%v + x ≤ y + %%v),
      assert `h' p),
  ac_mono := h,
  trivial,
  exact 3
end

example {α} [linear_order α]
  (a b c d e : α) :
  max a b ≤ e → b ≤ e :=
by { mono, apply le_max_right }

example (a b c d e : Prop)
  (h : d → a) (h' : c → e) :
  (a ∧ b → c) ∨ d → (d ∧ b → e) ∨ a :=
begin
  mono,
  mono,
  mono,
end

example : ∫ x in Icc 0 1, real.exp x ≤ ∫ x in Icc 0 1, real.exp (x+1) :=
begin
  mono,
  { exact real.continuous_exp.integrable_on_compact compact_Icc },
  { exact (real.continuous_exp.comp $ continuous_add_right 1).integrable_on_compact compact_Icc },
  intro x,
  dsimp only,
  mono,
  linarith
end


import algebra.ring algebra.field data.set.basic tactic.norm_num

universes u v w

-- page 1

class zero_ring (α : Type u) extends comm_ring α :=
(eq_zero : ∀ x:α, x = 0)

def zero_ring_of_zero_eq_one (α : Type u) [comm_ring α] : (0:α)=1 → zero_ring α
| h := {_inst_1 with eq_zero := λ x, calc
  x = x * 1 : eq.symm $ mul_one x
  ... = x * 0 : congr_arg _ h.symm
  ... = 0 : mul_zero x}

-- page 2

structure hom (α : Type u) (β : Type v) [comm_ring α] [comm_ring β] :=
(f : α → β)
(map_add : ∀ x y, f (x + y) = f x + f y)
(map_mul : ∀ x y, f (x * y) = f x * f y)
(map_one : f 1 = 1)

namespace hom

variables {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
variables {x y : α} {f : hom α β}

theorem map_zero : f.f 0 = 0 := calc
f.f 0 = f.f 0 + f.f 0 - f.f 0 : eq.symm $ add_sub_cancel (f.f 0) (f.f 0)
... = f.f (0 + 0) - f.f 0 : congr_arg (λ x, x - f.f 0) $ eq.symm $ f.map_add 0 0
... = f.f 0 - f.f 0 : congr_arg (λ x, f.f x - f.f 0) $ zero_add 0
... = 0 : sub_self $ f.f 0

theorem map_neg : f.f (-x) = -f.f x := calc
f.f (-x) = f.f (-x) + f.f x - f.f x : eq.symm $ add_sub_cancel (f.f (-x)) (f.f x)
... = f.f (-x + x) - f.f x : congr_arg (λ y, y - f.f x) $ eq.symm $ f.map_add (-x) x
... = f.f 0 - f.f x : congr_arg (λ y, f.f y - f.f x) $ neg_add_self x
... = 0 - f.f x : congr_arg (λ y, y - f.f x) $ map_zero
... = -f.f x : zero_sub $ f.f x

theorem map_sub : f.f (x - y) = f.f x - f.f y := calc
f.f (x - y) = f.f (x + -y) : congr_arg f.f $ sub_eq_add_neg x y
... = f.f x + f.f (-y) : f.map_add x (-y)
... = f.f x + -f.f y : congr_arg (λ z, f.f x + z) $ map_neg
... = f.f x - f.f y : eq.symm $ sub_eq_add_neg (f.f x) (f.f y)

end hom

structure subring (α : Type u) [comm_ring α] (S : set α) :=
(add_mem : ∀ x y, x ∈ S → y ∈ S → x + y ∈ S)
(neg_mem : ∀ x, x ∈ S → -x ∈ S)
(mul_mem : ∀ x y, x ∈ S → y ∈ S → x * y ∈ S)
(one_mem : (1:α) ∈ S)

instance subring.to_comm_ring (α : Type u) [comm_ring α] (S : set α)
(s : subring α S) : comm_ring {x // x ∈ S} :=
{ add := λ x y, ⟨x + y, s.add_mem x y x.property y.property⟩,
  add_assoc := λ x y z, subtype.eq $ add_assoc x y z,
  zero := ⟨0, eq.subst (add_neg_self (1:α)) $ s.add_mem 1 (-1) s.one_mem $ s.neg_mem 1 s.one_mem⟩,
  zero_add := λ x, subtype.eq $ zero_add x,
  add_zero := λ x, subtype.eq $ add_zero x,
  neg := λ x, ⟨-x, s.neg_mem x x.property⟩,
  add_left_neg := λ x, subtype.eq $ add_left_neg x,
  add_comm := λ x y, subtype.eq $ add_comm x y,
  mul := λ x y, ⟨x * y, s.mul_mem x y x.property y.property⟩,
  mul_assoc := λ x y z, subtype.eq $ mul_assoc x y z,
  one := ⟨1, s.one_mem⟩,
  one_mul := λ x, subtype.eq $ one_mul x,
  mul_one := λ x, subtype.eq $ mul_one x,
  left_distrib := λ x y z, subtype.eq $ left_distrib x y z,
  right_distrib := λ x y z, subtype.eq $ right_distrib x y z,
  mul_comm := λ x y, subtype.eq $ mul_comm x y }

def subring.hom (α : Type u) [comm_ring α] (S : set α)
(s : subring α S) : @hom {x // x ∈ S} α (subring.to_comm_ring α S s) _ :=
{ f := λ x, x,
  map_add := λ x y, rfl,
  map_mul := λ x y, rfl,
  map_one := rfl }

def hom.comp (α : Type u) (β : Type v) (γ : Type w)
[comm_ring α] [comm_ring β] [comm_ring γ]
(g : hom β γ) (f : hom α β) : hom α γ :=
{ f := g.f ∘ f.f,
  map_add := λ x y, calc
    g.f (f.f (x + y)) = g.f (f.f x + f.f y) : congr_arg g.f $ f.map_add x y
    ... = g.f (f.f x) + g.f (f.f y) : g.map_add (f.f x) (f.f y),
  map_mul := λ x y, calc
    g.f (f.f (x * y)) = g.f (f.f x * f.f y) : congr_arg g.f $ f.map_mul x y
    ... = g.f (f.f x) * g.f (f.f y) : g.map_mul (f.f x) (f.f y),
  map_one := calc
    g.f (f.f 1) = g.f 1 : congr_arg g.f $ f.map_one
    ... = 1 : g.map_one }

structure ideal (α : Type u) [comm_ring α] :=
(S : set α)
(zero_mem : (0 : α) ∈ S)
(add_mem : ∀ x y, x ∈ S → y ∈ S → x + y ∈ S)
(neg_mem : ∀ x, x ∈ S → -x ∈ S)
(mul_mem : ∀ x y, x ∈ S → x * y ∈ S)

instance coset.is_equivalent (α : Type u) [comm_ring α] (i : ideal α) : setoid α :=
{ r     := λ x y, x - y ∈ i.S,
  iseqv :=
    ⟨λ x, calc
      x - x = 0   : sub_self x
        ... ∈ i.S : i.zero_mem,
    λ x y hxy, calc
      y - x = -(x - y) : eq.symm (neg_sub x y)
        ... ∈ i.S      : i.neg_mem (x - y) hxy,
    λ x y z hxy hyz, calc
      x - z = (x - y) + (y - z) : eq.symm (sub_add_sub_cancel x y z)
        ... ∈ i.S               : i.add_mem (x - y) (y - z) hxy hyz ⟩ }

def coset (α : Type u) [comm_ring α] (i : ideal α) := quotient (coset.is_equivalent α i)

def to_coset (α : Type u) [comm_ring α] (i : ideal α) : α → coset α i :=
λ x, @quotient.mk α (coset.is_equivalent α i) x

instance quotient_ring (α : Type u) [comm_ring α] (i : ideal α) : comm_ring (coset α i) :=
{
  add := @quotient.lift₂ α α (coset α i) (coset.is_equivalent α i) (coset.is_equivalent α i) (λ m n, to_coset α i (m + n)) (λ m₁ m₂ n₁ n₂ h₁ h₂, quot.sound $ calc
    (m₁ + m₂) - (n₁ + n₂) = (m₁ - n₁) + (m₂ - n₂) : by norm_num
                      ... ∈ i.S                   : i.add_mem _ _ h₁ h₂ ),
  add_assoc := λ m n k, @quotient.induction_on₃ α α α (coset.is_equivalent α i) (coset.is_equivalent α i) (coset.is_equivalent α i) _ m n k (begin intros a b c, apply quotient.sound, exact calc
    ((a + b) + c) - (a + (b + c)) = 0   : by norm_num
                              ... ∈ i.S : i.zero_mem end),
  zero := to_coset α i 0,
  zero_add := λ m, @quotient.ind α (coset.is_equivalent α i) _ (begin intro a, apply quotient.sound, exact calc
    (0 + a) - (a) = 0   : by norm_num
              ... ∈ i.S : i.zero_mem end) m,
  add_zero := λ m, @quotient.ind α (coset.is_equivalent α i) _ (begin intro a, apply quotient.sound, exact calc
    (a + 0) - (a) = 0   : by norm_num
              ... ∈ i.S : i.zero_mem end) m,
  neg := @quotient.lift α (coset α i) (coset.is_equivalent α i) (λ m, to_coset α i (-m)) (λ m n h, quot.sound $ calc
    (-m) - (-n) = -(m - n) : by norm_num
            ... ∈ i.S      : i.neg_mem _ h ),
  add_left_neg := λ m, @quotient.ind α (coset.is_equivalent α i) _ (begin intro a, apply quotient.sound, exact calc
    (-a + a) - (0) = 0   : by norm_num
               ... ∈ i.S : i.zero_mem end) m,
  add_comm := λ m n, @quotient.ind₂ α α (coset.is_equivalent α i) (coset.is_equivalent α i) _ (begin intros a b, apply quotient.sound, exact calc
    (a + b) - (b + a) = 0   : by rw [add_comm, sub_self]
                  ... ∈ i.S : i.zero_mem end) m n,
  mul := @quotient.lift₂ α α (coset α i) (coset.is_equivalent α i) (coset.is_equivalent α i) (λ m n, to_coset α i (m * n)) (λ m₁ m₂ n₁ n₂ h₁ h₂, quot.sound $ calc
    (m₁ * m₂) - (n₁ * n₂) = (m₁ * m₂ - m₁ * n₂) + (m₁ * n₂ - n₁ * n₂) : by norm_num
                      ... = m₁ * (m₂ - n₂) + (m₁ - n₁) * n₂ : by rw [mul_sub, sub_mul]
                      ... = (m₂ - n₂) * m₁ + (m₁ - n₁) * n₂ : by ac_refl
                      ... ∈ i.S : i.add_mem _ _ (i.mul_mem _ _ h₂) (i.mul_mem _ _ h₁) ),
  mul_assoc := λ m n k, @quotient.induction_on₃ α α α (coset.is_equivalent α i) (coset.is_equivalent α i) (coset.is_equivalent α i) _ m n k (begin intros a b c, apply quotient.sound, exact calc
    ((a * b) * c) - (a * (b * c)) = 0   : by rw [mul_assoc, sub_self]
                              ... ∈ i.S : i.zero_mem end),
  one := to_coset α i 1,
  one_mul := λ m, @quotient.ind α (coset.is_equivalent α i) _ (begin intro a, apply quotient.sound, exact calc
    (1 * a) - (a) = 0   : by norm_num
              ... ∈ i.S : i.zero_mem end) m,
  mul_one := λ m, @quotient.ind α (coset.is_equivalent α i) _ (begin intro a, apply quotient.sound, exact calc
    (a * 1) - (a) = 0   : by norm_num
              ... ∈ i.S : i.zero_mem end) m,
  left_distrib := λ m n k, @quotient.induction_on₃ α α α (coset.is_equivalent α i) (coset.is_equivalent α i) (coset.is_equivalent α i) _ m n k (begin intros a b c, apply quotient.sound, exact calc
    (a * (b + c)) - ((a * b) + (a * c)) = 0   : by rw [left_distrib, sub_self]
                              ... ∈ i.S : i.zero_mem end),
  right_distrib := λ m n k, @quotient.induction_on₃ α α α (coset.is_equivalent α i) (coset.is_equivalent α i) (coset.is_equivalent α i) _ m n k (begin intros a b c, apply quotient.sound, exact calc
    ((a + b) * c) - ((a * c) + (b * c)) = 0   : by rw [right_distrib, sub_self]
                              ... ∈ i.S : i.zero_mem end),
  mul_comm := λ m n, @quotient.ind₂ α α (coset.is_equivalent α i) (coset.is_equivalent α i) _ (begin intros a b, apply quotient.sound, exact calc
    (a * b) - (b * a) = 0   : by rw [mul_comm, sub_self]
                  ... ∈ i.S : i.zero_mem end) m n,
}

def zero_ideal (α : Type u) [comm_ring α] : ideal α :=
{ S := {0},
  zero_mem := set.mem_singleton 0,
  add_mem  := λ x y hx hy, begin rw set.mem_singleton_iff at *, rw [hx, hy], simp end,
  neg_mem  := λ x hx, begin rw set.mem_singleton_iff at *, rw hx, simp end,
  mul_mem  := λ x y hx, begin rw set.mem_singleton_iff at *, rw hx, simp end }

def univ_ideal (α : Type u) [comm_ring α] : ideal α :=
{ S        := set.univ,
  zero_mem := ⟨⟩,
  add_mem  := λ x y hx hy, ⟨⟩,
  neg_mem  := λ x hx, ⟨⟩,
  mul_mem  := λ x y hx, ⟨⟩ }

def hom_preimage_ideal (α : Type u) (β : Type v) [comm_ring α] [comm_ring β] (f : hom α β) (i : ideal β) : ideal α :=
{ S        := (f.f)⁻¹' i.S,
  zero_mem := by simp [hom.map_zero, i.zero_mem],
  add_mem  := λ x y hx hy, by simp [hom.map_add, i.add_mem _ _ hx hy],
  neg_mem  := λ x hx, by simp [hom.map_neg, i.neg_mem _ hx],
  mul_mem  := λ x y hx, by simp [hom.map_mul, i.mul_mem _ _ hx] }

def to_quotient (α : Type u) [comm_ring α] (i : ideal α) : @hom α (coset α i) _ (quotient_ring α i) :=
{ f       := to_coset α i,
  map_add := λ x y, rfl,
  map_mul := λ x y, rfl,
  map_one := rfl }

-- Proposition 1.1 start

def contains_ideal (α : Type u) [comm_ring α] (i : ideal α) := {j : ideal α // i.S ⊆ j.S}
def ideal_quotient (α : Type u) [comm_ring α] (i : ideal α) := @ideal (coset α i) (quotient_ring α i)

def contains_to_quotient (α : Type u) [comm_ring α] (i : ideal α) : contains_ideal α i → ideal_quotient α i :=
λ ⟨j, hj⟩,
{ S        := (to_quotient α i).f '' j.S,
  zero_mem := ⟨0, j.zero_mem, rfl⟩,
  add_mem  := λ x y hx hy,
    begin
      simp [to_quotient] at *,
      cases hx with xw xh,
      cases hy with yw yh,
      existsi xw + yw,
      split,
      exact j.add_mem _ _ xh.1 yh.1,
      rw [←xh.2, ←yh.2],
      refl
    end,
  neg_mem  := λ x hx,
    begin
      simp [to_quotient] at *,
      cases hx with xw xh,
      existsi -xw,
      split,
      exact j.neg_mem _ xh.1,
      rw ←xh.2,
      refl
    end,
  mul_mem  := λ x y hx,
    begin
      simp [to_quotient] at *,
      cases hx with xw xh,
      cases @quotient.exists_rep α (coset.is_equivalent α i) y with yw yh,
      existsi xw * yw,
      split,
      exact j.mul_mem _ _ xh.1,
      rw [←xh.2, ←yh],
      refl
    end }

def quotient_to_contains (α : Type u) [comm_ring α] (i : ideal α) : ideal_quotient α i → contains_ideal α i :=
λ j, ⟨ @hom_preimage_ideal α (coset α i) _ (quotient_ring α i) (to_quotient α i) j, λ x hx,
  begin
    simp [hom_preimage_ideal, to_quotient, to_coset],
    have : to_coset α i x = 0,
    unfold to_coset,
    apply quotient.sound,
    exact calc
      x - 0 = x   : sub_zero x
        ... ∈ i.S : hx,
    unfold to_coset at this,
    rw this,
    exact j.zero_mem
  end ⟩

theorem contains_to_quotient_to_contains (α : Type u) [comm_ring α] (i : ideal α) : (quotient_to_contains α i) ∘ (contains_to_quotient α i) = id :=
begin
  apply funext,
  intros x,
  cases x with x hx,
  cases x,
  simp [function.comp, contains_to_quotient, quotient_to_contains, hom_preimage_ideal, to_quotient, to_coset, set.preimage],
  dsimp at *,
  congr,
  apply set.ext,
  intros y,
  split,
  intro hy,
  cases hy with z hz,
  have : z - y ∈ x_S := hx hz.2,
  exact calc
      y = z + -(z - y) : by norm_num
    ... ∈ x_S         : x_add_mem _ _ hz.1 (x_neg_mem _ this),
  intro hy,
  existsi y,
  split,
  exact hy,
  exact calc
      y - y = 0   : sub_self y
        ... ∈ i.S : i.zero_mem
end

theorem quotient_to_contains_to_quotient (α : Type u) [comm_ring α] (i : ideal α) : (contains_to_quotient α i) ∘ (quotient_to_contains α i) = id :=
begin
  apply funext,
  intros x,
  cases x with x hx,
  simp [function.comp, contains_to_quotient, quotient_to_contains, to_quotient, to_coset],
  congr,
  dsimp,
  apply set.ext,
  intros y,
  split,
  intro hy,
  cases hy with z hz,
  simp [hom_preimage_ideal] at hz,
  rw ←hz.2,
  exact hz.1,
  intro hy,
  cases @quotient.exists_rep α (coset.is_equivalent α i) y with z hz,
  existsi z,
  split,
  simp [hom_preimage_ideal],
  rwa hz,
  exact hz
end

theorem contains_to_quotient_of_subset (α : Type u) [comm_ring α] (i : ideal α) (x y : contains_ideal α i) : x.val.S ⊆ y.val.S → (contains_to_quotient α i x).S ⊆ (contains_to_quotient α i y).S :=
begin
  intros h z hz,
  cases x with x hx,
  cases y with y hy,
  simp [contains_to_quotient] at *,
  cases hz with w hw,
  existsi w,
  exact ⟨h hw.1, hw.2⟩
end

theorem quotient_to_contains_of_subset (α : Type u) [comm_ring α] (i : ideal α) (x y : ideal_quotient α i) : x.S ⊆ y.S → (quotient_to_contains α i x).val.S ⊆ (quotient_to_contains α i y).val.S :=
begin
  intros h z hz,
  simp [quotient_to_contains, hom_preimage_ideal] at *,
  exact h hz
end

-- Proposition 1.1 end