import feather_model.basic

universe u

open_locale classical

/-!
In this file, we prove that the model, as defined in `feather_model.basic`,
produces a lawful type of terms, assuming the same is true for the lower level.
-/

namespace feather_model

variables {T : Type u} [term_struct T] [type_data T] [term T]

lemma empty_runtime_ok : runtime_ok (⟨∅, ∅, ∅⟩ : runtime_context (mterm T)) :=
runtime_ok.empty

lemma empty_rir_ok : rir_ok (⟨∅, ∅⟩ : rir_context (mterm T)) :=
rir_ok.empty

lemma runtime_ok_Γ (C : runtime_context (mterm T)) {v : V} {α : mterm T} :
  runtime_ok C → is_type C.rir α → runtime_ok (C + ⟨{(v, α)}, ∅, ∅⟩) :=
runtime_ok.Γ C v α

lemma runtime_ok_Θ (C : runtime_context (mterm T)) {v : V} {α : mterm T} :
  runtime_ok C → is_type C.rir α → runtime_ok (C + ⟨∅, {(v, α)}, ∅⟩) :=
runtime_ok.Θ C v α

lemma runtime_ok_Ξ (C : runtime_context (mterm T)) {v : V} {α : mterm T} :
  runtime_ok C → is_type C.rir α → runtime_ok (C + ⟨∅, ∅, {(v, α)}⟩) :=
runtime_ok.Ξ C v α

lemma rir_ok_Γ (C : rir_context (mterm T)) {v : V} {α : mterm T} :
  rir_ok C → is_type C α → rir_ok (C ∪ ⟨{(v, α)}, ∅⟩) :=
rir_ok.Γ C v α

lemma rir_ok_Ξ (C : rir_context (mterm T)) {v : V} {α : mterm T} :
  rir_ok C → is_type C α → rir_ok (C ∪ ⟨∅, {(v, α)}⟩) :=
rir_ok.Ξ C v α

lemma defeq_reflexive (C : rir_context (mterm T)) {x α : mterm T} :
  C ⊢ x : α → C ⊢ x ≡ x : α :=
begin
  intros h I hI,
  exact ⟨rfl, h.interpret I hI⟩,
end

lemma defeq_symmetric (C : rir_context (mterm T)) {x y α : mterm T} :
  C ⊢ x ≡ y : α → C ⊢ y ≡ x : α :=
begin
  intros h I hI,
  obtain ⟨h₁, h₂⟩ := h I hI,
  rw h₁ at h₂ ⊢,
  exact ⟨rfl, h₂⟩,
end

lemma defeq_transitive (C : rir_context (mterm T)) {x y z α : mterm T} :
  C ⊢ x ≡ y : α → C ⊢ y ≡ z : α → C ⊢ x ≡ z : α :=
begin
  intros hxy hyz I hI,
  obtain ⟨h₁, h₂⟩ := hxy I hI,
  obtain ⟨h₃, h₄⟩ := hyz I hI,
  rw [h₁, h₃] at h₂ ⊢,
  exact ⟨rfl, h₂⟩,
end

/-
instance : term (mterm T) := {
  empty_runtime_ok := empty_runtime_ok,
  empty_rir_ok := empty_rir_ok,
  runtime_ok_Γ := runtime_ok_Γ,
  runtime_ok_Θ := runtime_ok_Θ,
  runtime_ok_Ξ := runtime_ok_Ξ,
  rir_ok_Γ := rir_ok_Γ,
  rir_ok_Ξ := rir_ok_Ξ,
  defeq_reflexive := defeq_reflexive,
  defeq_symmetric := defeq_symmetric,
  defeq_transitive := defeq_transitive,
}
-/

end feather_model


import data.fintype.parity
import data.nat.prime_norm_num
import data.zmod.basic
import linear_algebra.free_module.finite.basic
import number_theory.assorted_lemmas
import ring_theory.adjoin_root
import ring_theory.class_group
import ring_theory.dedekind_domain.integral_closure
import ring_theory.norm
import tactic.norm_cast

/-!
# Adjoining a root of a quadratic polynomial

## Main definitions

`quad_ring F a b` is the ring `F[α]`, where `α` is a root of the polynomial `X^2 - aX - b`.

To construct elements of `quad_ring F a b`:
 * the coercion `(↑(r : F) : quad_ring F a b)` sends `r` to `r + 0 α`
 * `quad_ring.root F a b` corresponds to `0 + 1 α`
 * `quad_ring` has a `comm_ring` instance providing `0`, `1`, `+`, `*`, and `-`

To compute with elements of `quad_ring F a b` by reducing equations to the ring `F`,
use the tactic `quad_ring.calc_tac`.

## Main results

 * `quad_ring.comm_ring`: `quad_ring F a b` is a commutative ring if `F` is
 * `quad_ring.field`: `quad_ring F 0 b` is a field if `F` is and `b` is not a square
 * `quad_ring.power_basis`: shows `quad_ring F a b` is generated by adjoining `root F a b`

 * `quad_ring.map`: lift a ring homomorphism `R → S` to a ring homomorphism `R[α] → S[α]`
 * `quad_ring.congr`: lift a ring isomorphism `R ≃ S` to a ring isomorphism `R[α] ≃ S[α]`
 * `quad_ring.lift`: lift a ring homomorphism `R → S` to a ring homomorphism `R[α] → S`,
   given a suitable image for `α`

 * `quad_ring.algebra''` (requires `open_locale quad_ring`): lift an `R`-algebra on `S`
   to a `quad_ring R a b`-algebra on `quad_ring S a' b'`, given that `a b` map to `a' b'`.
   Note that we only require `a' b' : S` to be the image propositionally (not just definitionally),
   this allows easy use of numerals, e.g. `quad_ring ℤ 0 (-5)` and `quad_ring ℚ 0 (-5)`
   (otherwise we'd have `quad_ring ℚ (↑0) (↑-5)`).

 * `quad_ring.norm_eq`: the norm of `⟨a, b⟩ : quad_ring R 0 d` is `a^2 - d * b^2`
   (see also `algebra.norm`)

 * `quad_ring.is_integral_closure_23`,
   `quad_ring.is_integral_closure_1`: together specify the ring of integers of
   `ℚ(√d)` (where `d` is squarefree, of course)

-/

section move_me

lemma dvd_of_pow_dvd_pow_self {R : Type*} [comm_ring R] [is_domain R]
  [unique_factorization_monoid R] {a b : R} {k : ℕ} (hk : k ≠ 0)
  (h : a ^ k ∣ b ^ k) : a ∣ b :=
begin
  by_cases hb : b = 0,
  { simp [hb] },
  by_cases ha : a = 0,
  { simpa [ha, hk, pow_eq_zero_iff (nat.pos_of_ne_zero hk)] using h },
  have hak : a ^ k ≠ 0 := pow_ne_zero _ ha,
  have hbk : b ^ k ≠ 0 := pow_ne_zero _ hb,
  letI := classical.dec_eq R,
  letI : normalization_monoid R := unique_factorization_monoid.normalization_monoid,
  rw [unique_factorization_monoid.dvd_iff_normalized_factors_le_normalized_factors,
      multiset.le_iff_count] at h ⊢,
  any_goals { assumption },
  simp only [unique_factorization_monoid.normalized_factors_pow, multiset.count_nsmul] at h,
  exact λ a, (mul_le_mul_left (nat.pos_of_ne_zero hk)).mp (h a)
end

lemma irreducible.not_is_square {R : Type*} [semiring R] {p : R} (hp : irreducible p) :
  ¬ is_square p
| ⟨a, ha⟩ := by cases (hp.is_unit_or_is_unit ha) with hua hua; simpa [ha] using hp.not_unit

-- TODO version of this for arbitrary fraction rings? needs a good way of getting a numerator
lemma rat.is_square_int_cast_iff (n : ℤ) : is_square (n : ℚ) ↔ is_square n :=
begin
  split; rintros ⟨a, ha⟩,
  { use a.num,
    apply_fun rat.num at ha,
    rwa [rat.mul_self_num, rat.coe_int_num] at ha },
  { use ↑a,
    exact_mod_cast ha }
end

end move_me

/-- `quad_ring F a b` adjoins a root `α` of `x^2 - ax - b` to the ring (field) `F`.
For example, `ℤ[√5]` can be defined as `quad_ring ℤ 0 5`.

Elements of `quad_ring` are represented as a pair `⟨b1, b2⟩` standing for the element `b1 + b2 α`.
-/
@[ext]
structure quad_ring (F : Type*) (a b : F) :=
mk {} :: (b1 : F) (b2 : F)

attribute [pp_using_anonymous_constructor] quad_ring

namespace quad_ring

section

variables (F : Type*) (a b : F)

@[simp] theorem eta : ∀ z : quad_ring F a b, (⟨z.b1,z.b2⟩ : quad_ring F a b) = z
| ⟨_,_⟩ := rfl

/-!
### Basic constructions of elements in `quad_ring R a b`
-/

/-- The standard inclusion `F → quad_ring F a b`. -/
instance [has_zero F] : has_coe_t F (quad_ring F a b) := ⟨λ r, ⟨r, 0⟩⟩

@[simp, norm_cast] lemma coe_b1 [has_zero F] (r : F) : (r : quad_ring F a b).b1 = r := rfl

@[simp, norm_cast] lemma coe_b2 [has_zero F] (r : F) : (r : quad_ring F a b).b2 = 0 := rfl

@[simp, norm_cast] theorem coe_inj [has_zero F] {z w : F} : (z : quad_ring F a b) = w ↔ z = w :=
⟨congr_arg b1, congr_arg _⟩

lemma coe_injective [has_zero F] : function.injective (coe : F → quad_ring F a b) :=
λ a b, (coe_inj _ _ _).mp

/-- `quad_ring.root F a b` is the adjoined root `α` of the polynomial `x^2 - ax - b`. -/
def root [has_zero F] [has_one F] : quad_ring F a b := ⟨0, 1⟩

@[simp] lemma root_b1 [has_zero F] [has_one F]: (root F a b).b1 = 0 := rfl
@[simp] lemma root_b2 [has_zero F] [has_one F]: (root F a b).b2 = 1 := rfl

variables [comm_ring F]
/-!
### Ring stucture on `quad_ring R a b`
-/

instance : has_zero (quad_ring F a b) := ⟨(0 : F)⟩
instance : inhabited (quad_ring F a b) := ⟨0⟩

@[simp] lemma zero_b1 : (0 : quad_ring F a b).b1 = 0 := rfl
@[simp] lemma zero_b2 : (0 : quad_ring F a b).b2 = 0 := rfl

@[simp] lemma coe_zero : ((0 : F) : quad_ring F a b) = 0 := rfl

@[simp] theorem coe_eq_zero {z : F} : (z : quad_ring F a b) = 0 ↔ z = 0 :=
coe_inj F a b

instance : has_one (quad_ring F a b) := ⟨(1 : F)⟩

@[simp] lemma one_b1 : (1 : quad_ring F a b).b1 = 1 := rfl
@[simp] lemma one_b2 : (1 : quad_ring F a b).b2 = 0 := rfl

@[simp, norm_cast] lemma coe_one : ((1 : F) : quad_ring F a b) = 1 := rfl

instance : has_add (quad_ring F a b) := ⟨λ z w, ⟨z.b1 + w.b1, z.b2 + w.b2⟩⟩

@[simp] lemma add_b1 (z w : quad_ring F a b) : (z + w).b1 = z.b1 + w.b1 := rfl
@[simp] lemma add_b2 (z w : quad_ring F a b) : (z + w).b2 = z.b2 + w.b2 := rfl

@[simp, norm_cast] lemma coe_add (r s : F) : ((r + s : F) : quad_ring F a b) = r + s :=
(quad_ring.ext_iff _ _).2 $ by simp

instance : has_neg (quad_ring F a b) := ⟨λ z, ⟨-z.b1, -z.b2⟩⟩

@[simp] lemma neg_b1 (z : quad_ring F a b) : (-z).b1 = -z.b1 := rfl
@[simp] lemma neg_b2 (z : quad_ring F a b) : (-z).b2 = -z.b2 := rfl

@[simp, norm_cast] lemma coe_neg (n : F) : (↑(-n) : quad_ring F a b) = - ↑n := by ext; simp

instance : has_sub (quad_ring F a b) := ⟨λ z w, ⟨z.b1 - w.b1, z.b2 - w.b2⟩⟩

@[simp] lemma sub_b1 (z w : quad_ring F a b) : (z - w).b1 = z.b1 - w.b1 := rfl
@[simp] lemma sub_b2 (z w : quad_ring F a b) : (z - w).b2 = z.b2 - w.b2 := rfl

@[simp, norm_cast] lemma coe_sub (z w : F) : (↑(z - w) : quad_ring F a b) = ↑z - ↑w := by ext; simp

/-- This scalar multiplication is used to define `nsmul`, `zsmul` and `qsmul`. -/
instance {R F : Type*} [has_smul R F] (a b : F) : has_smul R (quad_ring F a b) :=
{ smul := λ c x, ⟨c • x.b1, c • x.b2⟩ }

@[simp] lemma smul_b1 {R F : Type*} [has_smul R F] {a b : F} (c : R) (z : quad_ring F a b) :
  (c • z).b1 = c • z.b1 := rfl
@[simp] lemma smul_b2 {R F : Type*} [has_smul R F] {a b : F} (c : R) (z : quad_ring F a b) :
  (c • z).b2 = c • z.b2 := rfl

/-! We want to define the `comm_ring (quad_ring F a b)` instance in multiple steps,
so we can insert the right operations on `ℕ`, `ℤ` (and `ℚ`).
These operations have to be defined in the right way to ensure all diamond instances
involving e.g. `quad_ring ℤ a b` are indeed definitionally equal.
-/

instance : add_comm_monoid_with_one (quad_ring F a b) :=
{ add := (+),
  zero := (0),
  one := (1),
  add_assoc := by intros; ext; apply add_assoc,
  add_comm := by intros; ext; apply add_comm,
  zero_add := by intros; ext; apply zero_add,
  add_zero := by intros; ext; apply add_zero,
  nsmul := (•),
  nsmul_zero' := by intros; ext; apply zero_nsmul,
  nsmul_succ' := by intros; ext; apply succ_nsmul,
  nat_cast := λ n, ↑(n : F),
  nat_cast_zero := by simp,
  nat_cast_succ := by intros; simp }

@[simp, norm_cast] lemma coe_coe_nat (n : ℕ) : ((n : F) : quad_ring F a b) = n := rfl

instance : add_comm_group (quad_ring F a b) :=
{ add := (+),
  zero := (0),
  neg := has_neg.neg,
  add_left_neg := by intros; ext; apply add_left_neg,
  sub := has_sub.sub,
  nsmul := (•),
  zsmul := (•),
  zsmul_zero' := by intros; ext; apply zero_zsmul,
  zsmul_succ' := by intros; ext; simp [add_mul, add_comm],
  zsmul_neg' := by intros; ext; simp [add_mul],
  sub_eq_add_neg := by intros; ext; apply sub_eq_add_neg,
  .. quad_ring.add_comm_monoid_with_one F a b }

instance : add_comm_group_with_one (quad_ring F a b) :=
{ add := (+),
  zero := (0),
  neg := has_neg.neg,
  one := (1),
  sub := has_sub.sub,
  nsmul := (•),
  zsmul := (•),
  nat_cast := λ n, ↑(n : F),
  int_cast := λ n, ↑(n : F),
  int_cast_of_nat := by intros; simp,
  int_cast_neg_succ_of_nat := by intros; simp [-neg_add_rev, neg_add, ← sub_eq_add_neg],
  .. quad_ring.add_comm_monoid_with_one F a b,
  .. quad_ring.add_comm_group F a b }

@[simp, norm_cast] lemma coe_coe_int (n : ℤ) : ((n : F) : quad_ring F a b) = n := rfl

@[simp, norm_cast] lemma coe_nat_b1 (n : ℕ) : (n : quad_ring F a b).b1 = n := rfl
@[simp, norm_cast] lemma coe_nat_b2 (n : ℕ) : (n : quad_ring F a b).b2 = 0 := rfl

@[simp, norm_cast] lemma coe_nat_add (r s : ℕ) : (↑(r + s) : quad_ring F a b) = r + s :=
by { ext; simp only [coe_nat_b1, coe_nat_b2, add_b1, add_b2, nat.cast_add, add_zero] }

@[simp] lemma coe_int_b1 (n : ℤ) : (n : quad_ring F a b).b1 = n := rfl
@[simp] lemma coe_int_b2 (n : ℤ) : (n : quad_ring F a b).b2 = 0 := rfl

-- This used to be a non-defeq diamond, we solve this by supplying a custom value for
-- `add_group_with_one.int_cast`
example (a b : ℤ) (n) :
  @@coe (@@coe_to_lift (quad_ring.has_coe_t ℤ a b)) n = @@coe (@@coe_to_lift int.cast_coe) n :=
rfl

@[simp, norm_cast] lemma coe_int_add (r s : ℤ) : (↑(r + s) : quad_ring F a b) = r + s :=
by { ext; simp only [coe_int_b1, coe_int_b2, add_b1, add_b2, int.cast_add, add_zero] }

instance : has_mul (quad_ring F a b) :=
⟨λ z w, ⟨z.1 * w.1 + z.2 * w.2 * b ,z.2 * w.1 + z.1 * w.2 + z.2 * w.2 * a⟩⟩

@[simp] lemma mul_b1 (z w : quad_ring F a b) :
  (z * w).b1 = z.1 * w.1 + z.2 * w.2 * b := rfl
@[simp] lemma mul_b2 (z w : quad_ring F a b) :
  (z * w).b2 = z.2 * w.1 + z.1 * w.2 + z.2 * w.2 * a := rfl

@[simp, norm_cast] lemma coe_mul (r s : F) : ((r * s : F) : quad_ring F a b) = r * s :=
by apply (ext_iff _ _).2; simp [mul_comm]

/-- Simplify `quad_ring F a b` expressions by doing calculations componentwise in the ring `F`. -/
meta def calc_tac : tactic unit :=
`[rw quad_ring.ext_iff; repeat { split; simp; ring }]

instance : comm_semiring (quad_ring F a b) :=
{ zero := (0 : quad_ring F a b),
  add := (+),
  one := 1,
  mul := (*),
  nsmul := (•),
  npow := npow_rec,
  nat_cast := coe,
  mul_comm := by intros; calc_tac,
  mul_one := by intros; calc_tac,
  one_mul := by intros; calc_tac,
  mul_assoc := by intros; calc_tac,
  mul_zero := by intros; calc_tac,
  zero_mul := by intros; calc_tac,
  right_distrib := by intros; calc_tac,
  left_distrib := by intros; calc_tac,
  ..quad_ring.add_comm_monoid_with_one F a b }

instance : comm_ring (quad_ring F a b) :=
{ zero := (0 : quad_ring F a b),
  add := (+),
  neg := has_neg.neg,
  sub := has_sub.sub,
  one := 1,
  mul := (*),
  nsmul := (•),
  npow := npow_rec,
  nat_cast := coe,
  zsmul := (•),
  int_cast := coe,
  ..quad_ring.comm_semiring F a b,
  ..quad_ring.add_comm_group_with_one F a b }

instance [nontrivial F] : nontrivial (quad_ring F a b) :=
⟨⟨0, 1, by simp [ext_iff]⟩⟩

instance [char_zero F] : char_zero (quad_ring F a b) :=
⟨(coe_injective F a b).comp nat.cast_injective⟩

@[simp, norm_cast] lemma coe_pow (x : F) : ∀ (n : ℕ), (↑(x ^ n) : quad_ring F a b) = x ^ n
| 0 := by simp
| (n + 1) := by rw [pow_succ, coe_mul, coe_pow n, pow_succ]

/-! We finish off by helping `calc_tac` with some basic computations. -/

@[simp] lemma bit0_b1 (z : quad_ring F a b) : (bit0 z).b1 = bit0 z.b1 := rfl
@[simp] lemma bit0_b2 (z : quad_ring F a b) : (bit0 z).b2 = bit0 z.b2 := rfl
@[simp] lemma bit1_b1 (z : quad_ring F a b) : (bit1 z).b1 = bit1 z.b1 := rfl
@[simp] lemma bit1_b2 (z : quad_ring F a b) : (bit1 z).b2 = bit0 z.b2 := by simp [bit1]

lemma square_of (z : quad_ring F a b) : z^2 = ⟨z.1^2 + z.2^2 * b, 2 * z.1 * z.2 + z.2^2 * a⟩ :=
by { rw pow_two, calc_tac }

@[simp]
lemma square_of_b1 (z : quad_ring F a b) : (z^2).b1 = z.1^2 + z.2^2 * b :=
by rw square_of

@[simp]
lemma square_of_b2 (z : quad_ring F a b) : (z^2).b2 = 2 * z.1 * z.2 + z.2^2 * a :=
by rw square_of

lemma cube_of (z : quad_ring F a b) : z^3 =
  ⟨(z.1^2 + z.2^2 * b) * z.1 + (2 * z.1 * z.2 + z.2^2 * a) * z.2 * b,
   (2*z.1 * z.2 + z.2^2 * a) * z.1 + (z.1^2 + z.2^2 * b) * z.2 +
   (2*z.1 * z.2 + z.2 * z.2 * a) * z.2 * a⟩ :=
by { rw [pow_succ, pow_two], calc_tac }

/-! ### Maps between `quad_ring` and other rings -/

/-- Promote the inclusion `F → quad_ring F a b` to a canonical ring homomorphism.

See also `quad_ring.algebra'`
-/
instance : algebra F (quad_ring F a b) :=
{ smul := (•),
  to_fun := coe,
  map_one' := by calc_tac,
  map_mul' := λ x y, by calc_tac,
  map_zero' := by calc_tac,
  map_add' := λ x y, by calc_tac,
  commutes' := λ x y, by calc_tac,
  smul_def' := λ x y, by calc_tac }

/-- Prefer the coercion as the `simp`-normal form. -/
@[simp] lemma algebra_map_apply (x : F) : algebra_map F (quad_ring F a b) x = x := rfl

/-- Lift a ring homomorphism `R → S` to a ring homomorphism `R[α] → S[α]` -/
def map {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R) :
  quad_ring R a b →+* quad_ring S (f a) (f b) :=
{ to_fun := λ s, ⟨f s.b1, f s.b2⟩,
  map_one' := by ext; simp only [quad_ring.one_b1, quad_ring.one_b2, map_zero, map_one],
  map_mul' := λ x y, by ext;
    simp only [map_add, add_left_inj, quad_ring.mul_b1, map_mul, quad_ring.mul_b2],
  map_zero' := by ext; simp only [quad_ring.zero_b1, quad_ring.zero_b2, map_zero],
  map_add' := λ x y, by ext; simp only [map_add, add_left_inj, quad_ring.add_b1, quad_ring.add_b2] }

@[simp] lemma map_b1 {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R) (x) :
  (map f a b x).b1 = f x.b1 := rfl
@[simp] lemma map_b2 {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R) (x) :
  (map f a b x).b2 = f x.b2 := rfl
@[simp] lemma map_coe {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b x : R) :
  map f a b (x : quad_ring R a b) = f x :=
by { ext; simp only [coe_b1, coe_b2, map, ring_hom.coe_mk, map_zero] }

/-- Lift a ring isomorphism `R ≃ S` to a ring isomorphism `R[α] ≃ S[α]` -/
def congr {R S : Type*} [comm_ring R] [comm_ring S] (f : R ≃+* S) {a b : R} {a' b' : S}
  (ha : f a = a') (hb : f b = b') :
  quad_ring R a b ≃+* quad_ring S a' b' :=
{ to_fun := λ s, ⟨f s.b1, f s.b2⟩,
  inv_fun := λ r, ⟨f.symm r.b1, f.symm r.b2⟩,
  left_inv := λ s, by simp only [ring_equiv.symm_apply_apply, quad_ring.eta, eq_self_iff_true],
  right_inv := λ r, by simp only [quad_ring.eta, eq_self_iff_true, ring_equiv.apply_symm_apply],
  map_mul' := λ x y, by ext; simp only [map_add, add_left_inj, eq_self_iff_true,
    hb, quad_ring.mul_b1, map_mul, quad_ring.mul_b2, ha],
  map_add' := λ x y, by ext; simp only [map_add, add_left_inj, eq_self_iff_true, quad_ring.add_b1,
    embedding_like.apply_eq_iff_eq, quad_ring.add_b2] }

@[simp] lemma congr_b1 {R S : Type*} [comm_ring R] [comm_ring S]
  (f : R ≃+* S) {a b : R} {a' b' : S} (ha : f a = a') (hb : f b = b') (x : quad_ring R a b) :
  (congr f ha hb x).b1 = f x.b1 := rfl
@[simp] lemma congr_b2 {R S : Type*} [comm_ring R] [comm_ring S]
  (f : R ≃+* S) {a b : R} {a' b' : S} (ha : f a = a') (hb : f b = b') (x : quad_ring R a b) :
  (congr f ha hb x).b2 = f x.b2 := rfl
@[simp] lemma congr_coe {R S : Type*} [comm_ring R] [comm_ring S]
  (f : R ≃+* S) {a b : R} {a' b' : S} (ha : f a = a') (hb : f b = b')
  (x : R) :
  congr f ha hb x = f x :=
by { ext; simp only [coe_b1, coe_b2, congr, ring_equiv.coe_mk, map_zero] }

/-- Lift a ring homomorphism `R → S` to a ring homomorphism `R[α] → S`,
given a suitable image for `α` -/
@[simps]
def lift {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R)
  (z : S) (hz : z^2 - f a * z - f b = 0) :
  quad_ring R a b →+* S :=
have hz' : z^2 = f a * z + f b := sub_eq_iff_eq_add'.mp $ sub_eq_zero.mp hz,
{ to_fun := λ s, f s.b1 + z * f s.b2,
  map_one' := by simp only [quad_ring.one_b1, quad_ring.one_b2, map_zero, map_one, mul_zero, add_zero],
  map_zero' := by simp only [quad_ring.zero_b1, quad_ring.zero_b2, map_zero, zero_add, mul_zero],
  map_add' := λ x y, by simp only [map_add, quad_ring.add_b1, quad_ring.add_b2]; ring,
  map_mul' := λ x y, begin
    simp only [hz', map_add, add_left_inj, quad_ring.mul_b1, map_mul, quad_ring.mul_b2],
    calc f x.b1 * f y.b1 + f x.b2 * f y.b2 * f b +
           z * (f x.b2 * f y.b1 + f x.b1 * f y.b2 + f x.b2 * f y.b2 * f a)
        = (f y.b1 + z * f y.b2) * f x.b1 +
          (z * f x.b2 * f y.b1 + (f a * z + f b) * f y.b2 * f x.b2) : by ring
    ... = (f y.b1 + z * f y.b2) * f x.b1 + (z * f x.b2 * f y.b1 + z ^ 2 * f y.b2 * f x.b2) :
      by rw hz'
    ... = (f x.b1 + z * f x.b2) * (f y.b1 + z * f y.b2) : by ring,
  end }

@[simp] lemma lift_coe {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R) (z h)
  (x : R) : lift f a b z h (x : quad_ring R a b) = f x :=
by { simp only [coe_b1, coe_b2, lift_apply, map_zero, mul_zero, add_zero] }

@[simp] lemma lift_mk {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S) (a b : R) (z h)
  (x y : R) : lift f a b z h (⟨x, y⟩ : quad_ring R a b) = f x + z * f y :=
rfl

section algebra_numeric_coeff

variables {R S : Type*} [comm_ring R] [comm_ring S]
variables {G : Type*} (g : G)

/-!
## "Natural" algebra structures where the coefficients are numeric

We want to get an `algebra (quad_ring ℤ 0 (-5)) (quad_ring ℚ 0 (-5))` instance,
so we can say e.g. that `ℤ[√-5]` is the ring of integers of `ℚ[√-5]`.
However, the `-5`s in the types are different, and we need to do a bit of computation
to show that they are mapped to each other in the corresponding inclusion.
Luckily, we can program the typeclass system like it's Prolog,
and use instance synthesis to do this computation for us.

Even nicer would be to supply these `fact`s through tactics, which should be possible with
`auto_param`s, but those don't work nicely with the synthesis algorithm.
Hopefully this can be fixed using Lean 4's more sophisticated elaboration order.
-/
-- Perhaps this should be in a `quad_ring` locale?
lemma fact_map_zero [zero_hom_class G R S] : fact (g 0 = 0) := ⟨map_zero _⟩
lemma fact_map_one [one_hom_class G R S] : fact (g 1 = 1) := ⟨map_one _⟩
lemma fact_map_bit0 [ring_hom_class G R S] (n : R) (n' : S) [h : fact (g n = n')] :
  fact (g (bit0 n) = bit0 n') :=
⟨by rw [map_bit0, h.1]⟩
lemma fact_map_bit1 [ring_hom_class G R S] (n : R) (n' : S) [h : fact (g n = n')] :
  fact (g (bit1 n) = bit1 n') :=
⟨by rw [map_bit1, h.1]⟩
lemma fact_map_neg [add_monoid_hom_class G R S] (n : R) (n' : S) [h : fact (g n = n')] :
  fact (g (- n) = - n') :=
⟨by rw [map_neg, h.1]⟩
lemma fact_map_int_cast [ring_hom_class G R S] (d : ℤ) : fact (g d = d) :=
⟨map_int_cast g d⟩
lemma fact_eq_int_cast [ring_hom_class G ℤ S] (d : ℤ) : fact (g d = d) :=
⟨eq_int_cast g d⟩
@[priority 500] -- Fallback, use lower priority because this can trigger expensive unification.
lemma fact_refl {α : Sort*} (x : α) : fact (x = x) :=
⟨rfl⟩

/-- Lift a canonical map `R → S` to a canonical map `quad_ring R a b → quad_ring S a' b'`,
given that `a` is sent to `a'` and `b` to `b'`.

This is a principled way of defining the inclusion `quad_ring ℤ 0 (-5) → quad_ring ℚ 0 (-5)`:
since `(↑(0 : ℤ) : ℚ)` and `0 : ℚ` are different, we can't use a more naïve definition like
`algebra (quad_ring R a b) (quad_ring S ↑a ↑b)`.
-/
def algebra'' (R S : Type*) [comm_ring R] [comm_ring S] [algebra R S] (a b : R)
  (a' b' : S) [fact (algebra_map R S a = a')] [fact (algebra_map R S b = b')] :
  algebra (quad_ring R a b) (quad_ring S a' b') :=
((quad_ring.congr (ring_equiv.refl S)
    (show _, from fact.out (algebra_map R S a = a'))
    (show _, from fact.out (algebra_map R S b = b'))).to_ring_hom.comp
  (map (algebra_map R S) a b)).to_algebra

localized "attribute [instance] fact_map_zero fact_map_one fact_map_bit0 fact_map_bit1 fact_map_neg
  fact_map_int_cast fact_eq_int_cast quad_ring.algebra''"
  in quad_ring
localized "attribute [instance, priority 500] fact_refl"
  in quad_ring

section
open_locale quad_ring

@[simp] lemma algebra_map_b1 {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] (a b : R)
  (a' b' : S) [h1 : fact (algebra_map R S a = a')] [h2 : fact (algebra_map R S b = b')] (x) :
  (algebra_map (quad_ring R a b) (quad_ring S a' b') x).b1 = algebra_map R S x.b1 :=
rfl
@[simp] lemma algebra_map_b2 {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] (a b : R)
  (a' b' : S) [h1 : fact (algebra_map R S a = a')] [h2 : fact (algebra_map R S b = b')] (x) :
  (algebra_map (quad_ring R a b) (quad_ring S a' b') x).b2 = algebra_map R S x.b2 :=
rfl

@[simp] lemma algebra_map_coe {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] (a b : R)
  (a' b' : S) [h1 : fact (algebra_map R S a = a')] [h2 : fact (algebra_map R S b = b')] (x : R) :
  algebra_map (quad_ring R a b) (quad_ring S a' b') x = algebra_map R S x :=
by rw [ring_hom.algebra_map_to_algebra, ring_hom.comp_apply, ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.coe_to_ring_hom, map_coe, congr_coe, ring_equiv.refl_apply]

lemma algebra_map_injective {R S : Type*} [comm_ring R] [comm_ring S] [algebra R S] (a b : R)
  (a' b' : S) [h1 : fact (algebra_map R S a = a')] [h2 : fact (algebra_map R S b = b')]
  (hRS : function.injective (algebra_map R S)) :
  function.injective (algebra_map (quad_ring R a b) (quad_ring S a' b')) :=
begin
  intros x y h,
  rw quad_ring.ext_iff at h ⊢,
  exact ⟨hRS h.1, hRS h.2⟩
end

end

-- about 100 ms for instance synthesis, not bad!
example : algebra (quad_ring ℤ 0 (-5)) (quad_ring ℚ 0 (-5)) :=
quad_ring.algebra'' _ _ _ _ _ _

-- about 50 ms for instance synthesis, not bad!
example (d : ℤ) : algebra (quad_ring ℤ 0 d) (quad_ring ℚ 0 d) :=
quad_ring.algebra'' _ _ _ _ _ _

end algebra_numeric_coeff

section root

/-! ### `quad_ring F a b` as `F[α]` -/

open polynomial

/-- `quad_ring.root F a b` is indeed a root of `X^2 - a * X - b` -/
theorem aeval_root : aeval (root F a b) (X^2 - C a * X - C b) = 0 :=
by { simp only [map_sub, map_mul, aeval_C, aeval_X, map_pow], calc_tac }

@[simp]
lemma root_sq : (root F a b)^2 = a * root F a b + b :=
by calc_tac

/-- The canonical basis on `quad_ring F a b` with basis vectors `1` and `root F a b`. -/
protected noncomputable def basis : basis (fin 2) F (quad_ring F a b) :=
basis.of_equiv_fun $
{ to_fun := λ z, ![z.b1, z.b2],
  inv_fun := λ v, ⟨v 0, v 1⟩,
  left_inv := λ z, by ext; refl,
  right_inv := λ v, by ext i; fin_cases i; refl,
  map_add' := λ z w, by ext i; fin_cases i; refl,
  map_smul' := λ c z, by ext i; fin_cases i; refl }

@[simp] lemma coe_basis : (quad_ring.basis F a b : fin 2 → quad_ring F a b) = ![1, root F a b] :=
by ext i;
  -- Speed up the proof somewhat by simplifying the common cases first.
  simp only [quad_ring.basis, basis.coe_of_equiv_fun, linear_equiv.coe_symm_mk];
  fin_cases i;
  simp

@[simp] lemma basis_repr (z i) : (quad_ring.basis F a b).repr z i = ![z.b1, z.b2] i := rfl

instance : module.free F (quad_ring F a b) := module.free.of_basis (quad_ring.basis F a b)
instance : module.finite F (quad_ring F a b) := module.finite.of_basis (quad_ring.basis F a b)

/-- `quad_ring F a b` is the extension of `F` generated by a single element `root F a b`.

This is a powerful way to show `quadRing F a b` corresponds to `F[α]`.
-/
@[simps]
protected noncomputable def power_basis : power_basis F (quad_ring F a b) :=
{ dim := 2,
  gen := root F a b,
  basis := quad_ring.basis F a b,
  basis_eq_pow := λ i, by fin_cases i; simp }

end root

end

section sqrt_d

section ring

/-! ## The ring `R[√d]` -/

variables {R : Type*} [comm_ring R] {d s : R}

open polynomial

/-- The conjugation map in `R[√d]` maps `√d` to `- √d`. -/
@[simps] def conj {d s : R} (x : quad_ring R s d) : quad_ring R s d :=
x.1 * ⟨1, 0⟩ + x.2 * ⟨s, -1⟩

@[simp] lemma conj_zero {d s : R} : (0 : quad_ring R s d).conj = 0 := by calc_tac

@[simp] lemma conj_eq_zero_iff {d s : R} {z : quad_ring R s d} : z.conj = 0 ↔ z = 0 :=
by cases z; simp [ext_iff] {contextual := tt}

@[simp] lemma conj_mul {d s : R} (x : quad_ring R s d) :
  x.conj * x = x.1^2 + s * x.1 * x.2 - d * x.2^2 :=
by { norm_cast, ext; simp only [mul_b1, conj_b1, mul_b2, conj_b2, coe_b1, coe_b2]; ring }

@[simp] lemma mul_conj {d s : R} (x : quad_ring R s d) :
  x * x.conj = x.1^2 + s * x.1 * x.2 - d * x.2^2 :=
by rw [mul_comm, conj_mul]

/-! ### Norm on `R[√d]` -/

lemma left_mul_matrix_apply {a b : R} (x : quad_ring R a b) :
  algebra.left_mul_matrix (quad_ring.basis R a b) x = ![![x.1, x.2 * b], ![x.2, x.1 + x.2 * a]] :=
begin
  ext i j,
  cases x with A B,
  simp only [algebra.left_mul_matrix_eq_repr_mul, coe_basis, basis_repr],
  fin_cases j; fin_cases i;
    simp,
end

-- Not the most principled proof, but it works!
@[simp]
lemma norm_eq {a b : R} (x : quad_ring R a b) :
  algebra.norm R x = x.1^2 + a * x.1 * x.2 - b * x.2 ^ 2 :=
begin
  -- Unfold the definitions
  erw [algebra.norm, monoid_hom.comp_apply, ring_hom.to_monoid_hom_eq_coe, ring_hom.coe_monoid_hom,
      alg_hom.to_ring_hom_eq_coe, alg_hom.coe_to_ring_hom,
      ← linear_map.det_to_matrix (quad_ring.basis R a b), algebra.to_matrix_lmul_eq,
      left_mul_matrix_apply, matrix.det_fin_two],
  -- Expand all the matrix coefficients
  simp only [matrix.head_cons, matrix.cons_val_one, matrix.cons_val_zero],
  ring
end

open algebra

@[simp] lemma norm_one : norm R (1 : quad_ring R s d) = 1 := by simp
@[simp] lemma norm_zero : norm R (0 : quad_ring R s d) = 0 := by simp
@[simp] lemma norm_coe (n : R) : norm R (n : quad_ring R s d) = n ^ 2 := by simp
@[simp] lemma norm_coe_nat (n : ℕ) : norm R (n : quad_ring R s d) = n ^ 2 := by simp
@[simp] lemma norm_coe_int (n : ℤ) : norm R (n : quad_ring R s d) = n ^ 2 := by simp

lemma norm_nonneg {R : Type*} [linear_ordered_comm_ring R] {d : R} (hd : d ≤ 0)
  (x : quad_ring R 0 d) : 0 ≤ norm R x :=
begin
  rw norm_eq,
  nlinarith,
end

/-- special case of below with weaker assumption in char 2 -/
lemma eq_zero_iff_norm_zero [is_domain R] [unique_factorization_monoid R]
  {d : R} (hd : ¬ is_square d) (x : quad_ring R 0 d) : norm R x = 0 ↔ x = 0 :=
begin
  simp,
  simp only [ext_iff, zero_b1, zero_b2],
  split; intro h,
  { rw [sub_eq_zero] at h,
    by_cases hb2 : x.b2 = 0,
    { simpa [hb2] using h },
    contrapose! hd,
    have : x.b2 ^ 2 ∣ x.b1 ^ 2 := ⟨_, h.trans $ mul_comm _ _⟩,
    obtain ⟨x, hx⟩ := dvd_of_pow_dvd_pow_self (by norm_num) this,
    use x,
    rw [hx, mul_comm, mul_pow, pow_two] at h,
    exact (mul_right_cancel₀ (pow_ne_zero 2 hb2) h).symm },
  { simp only [norm, zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero,
      not_false_iff, mul_zero, add_zero, h, sub_zero], },
end

lemma eq_zero_iff_norm [is_domain R] [unique_factorization_monoid R]
  {d s : R} (hd : ¬ is_square (4 * d + s ^ 2)) (x : quad_ring R s d) : norm R x = 0 ↔ x = 0 :=
begin
  simp,
  simp only [ext_iff, zero_b1, zero_b2],
  split; intro h,
  { rw [sub_eq_zero] at h,
    by_cases hb2 : x.b2 = 0,
    { simpa [hb2] using h },
    contrapose! hd,
    apply_fun ((*) 4) at h,
    rw show 4 * (x.b1 ^ 2 + s * x.b1 * x.b2) = ((2 * x.b1 + s * x.b2) ^ 2 - s ^ 2 * x.b2 ^ 2), by ring at h,
    rw sub_eq_iff_eq_add at h,
    rw show 4 * (d * x.b2 ^ 2) + s ^ 2 * x.b2 ^ 2 = (4 * d + s ^ 2) * x.b2 ^ 2, by ring at h,
    have : x.b2 ^ 2 ∣ (2 * x.b1 + s * x.b2) ^ 2 := ⟨_, h.trans $ mul_comm _ _⟩,
    obtain ⟨x, hx⟩ := dvd_of_pow_dvd_pow_self (by norm_num) this,
    use x,
    rw [hx, mul_comm, mul_pow, pow_two] at h,
    exact (mul_right_cancel₀ (pow_ne_zero 2 hb2) h).symm },
  { simp only [norm, zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero,
      not_false_iff, mul_zero, add_zero, h, sub_zero], },
end

lemma norm_ne_zero_of_mem_non_zero_divisors [nontrivial R] {d s : R} (x : quad_ring R s d)
  (h : x ∈ non_zero_divisors (quad_ring R s d)) : norm R x ≠ 0 :=
begin
  have h0 := non_zero_divisors.ne_zero h,
  rw mem_non_zero_divisors_iff at h,
  contrapose! h,
  refine ⟨x.conj, _, mt conj_eq_zero_iff.mp h0⟩,
  simp only [norm_eq, ←coe_eq_zero R s d, coe_sub, coe_pow, coe_mul, coe_add] at h,
  rw conj_mul,
  assumption_mod_cast,
end

end ring

/-! ## The ring `ℤ[√d]` -/

notation `ℤ[√` d `]` := quad_ring ℤ 0 d
notation `ℚ(√` d `)` := quad_ring ℚ 0 d

section int

variables {d : ℤ} {d' : ℚ} [hdd' : fact $ algebra_map ℤ ℚ d = d']

open algebra

lemma is_domain_of_not_square {R : Type*} [comm_ring R] [is_domain R]
  [unique_factorization_monoid R] {d s : R} (hd : ¬ is_square (4 * d + s ^ 2)) :
  is_domain $ quad_ring R s d :=
@@no_zero_divisors.to_is_domain _ _ _
{ eq_zero_or_eq_zero_of_mul_eq_zero := begin
    rintros a b h,
    apply_fun (norm R) at h,
    simpa only [norm_zero, eq_zero_iff_norm hd, map_mul, mul_eq_zero] using h,
  end }

lemma is_square_four : is_square (4 : ℤ) :=
begin
  rw show (4 : ℤ) = 2 * 2, by norm_num,
  apply is_square_mul_self,
end

lemma is_square.is_square_mul_iff
  {R : Type*} [comm_ring R] [is_domain R] [unique_factorization_monoid R]
  {m n : R} (h : is_square m) (hn : m ≠ 0) :
  is_square (m * n) ↔ is_square n :=
begin
  split; intro hi,
  { rcases h with ⟨h_w, rfl⟩,
    rcases hi with ⟨hi_w, hh⟩,
    have : h_w ^ 2 ∣ hi_w ^ 2,
    { use n,
      simp [pow_two, hh], },
    obtain ⟨x, rfl⟩ := dvd_of_pow_dvd_pow_self (by norm_num) this,
    use x,
    rw ← sub_eq_zero at hh,
    rw show h_w * h_w * n - h_w * x * (h_w * x) = h_w ^ 2 * (n - x ^ 2), by ring at hh,
    simp only [mul_eq_zero, pow_eq_zero_iff, nat.succ_pos'] at hh,
    rcases hh with rfl | hh,
    { simpa using hn, },
    { simpa [sub_eq_zero, pow_two] using hh, }, },
  { exact h.mul hi, }
end

instance [fact $ ¬ is_square d] : is_domain ℤ[√d] :=
begin
  apply is_domain_of_not_square,
  simp only [zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero, not_false_iff, add_zero],
  intro h,
  apply _inst_1.out,
  rwa is_square_four.is_square_mul_iff (by norm_num) at h,
end

instance is_domain_one' (m : ℤ) [hm : fact $ ¬ is_square (4 * m + 1)] :
  is_domain $ quad_ring ℤ 1 m :=
is_domain_of_not_square (by simpa using hm.out)

instance is_domain_one
  [hdsq : fact $ ¬ is_square d] [hd : fact $ d % 4 = 1] :
  is_domain $ quad_ring ℤ 1 ((d - 1) / 4) :=
begin
  set m := (d - 1) / 4 with hm,
  clear_value m,
  unfreezingI { obtain rfl : d = 4 * m + 1,
    { rw [hm, ← sub_eq_iff_eq_add, int.mul_div_cancel' (int.dvd_sub_of_mod_eq (hd.out))] } },
  exact is_domain_of_not_square (by simpa using hdsq.out)
end

end int

/-! ## The field `K(√d)` -/

section field

variables {K : Type*} [field K] (d s : K)

open algebra
noncomputable theory
instance : has_inv (quad_ring K s d) :=
⟨λ z, ↑((norm K z)⁻¹ : K) * z.conj⟩

variables {d s}

lemma inv_def (z : quad_ring K s d) : z⁻¹ = ↑((norm K z)⁻¹ : K) * z.conj := rfl

@[simp] lemma inv_b1 (z : quad_ring K 0 d) : (z⁻¹).b1 = z.b1 / (norm K z) :=
show (↑((norm K z)⁻¹) * z.conj).b1 = z.b1 / (norm K z),
by simp [mul_b1, coe_b1, conj_b1, coe_b2, zero_mul, zero_mul, add_zero, div_eq_inv_mul]

@[simp] lemma inv_b2 (z : quad_ring K 0 d) : (z⁻¹).b2 = - z.b2 / (norm K z) :=
show (↑((norm K z)⁻¹) * z.conj).b2 = - z.b2 / (norm K z),
by rw [mul_b2, coe_b1, coe_b2, zero_mul, zero_add, mul_zero, add_zero, conj_b2, zero_add, zero_add,
       zero_add, zero_add, add_zero, mul_neg, mul_one,
       div_eq_inv_mul]

lemma inv_zero : (0 : quad_ring K 0 d)⁻¹ = 0 := by { ext; simp }

lemma mul_inv_cancel' {z : quad_ring K 0 d} (h : (norm K z) ≠ 0) : z * z⁻¹ = 1 :=
begin
  rw [inv_def, mul_left_comm, mul_conj],
  simp only [norm_eq, ne.def] at h ⊢,
  exact_mod_cast inv_mul_cancel h
end

/-- `K[√d]` is a field, except it has zero divisors if `d` is a square. -/
@[reducible]
def field_of_not_square (hd : ¬ is_square d) :
  field (quad_ring K 0 d) :=
{ zero := 0,
  add := (+),
  neg := has_neg.neg,
  sub := has_sub.sub,
  one := 1,
  mul := (*),
  nsmul := (•),
  npow := npow_rec,
  nat_cast := coe,
  zsmul := (•),
  int_cast := coe,
  exists_pair_ne := ⟨0, 1, by simp⟩,
  inv := has_inv.inv,
  rat_cast := λ q, ↑(q : K),
  rat_cast_mk := λ a b h1 h2, by { ext; simp [rat.cast_def, sq]; field_simp },
  qsmul := λ q z, (q : K) • z,
  qsmul_eq_mul' := λ q z, by { ext; simp },
  mul_inv_cancel := λ a ha0, mul_inv_cancel' (mt (eq_zero_iff_norm_zero hd _).mp ha0),
  inv_zero := inv_zero,
  .. quad_ring.comm_ring _ _ _ }

instance {d' : ℚ} [fact $ ¬ is_square d'] : field ℚ(√d') :=
field_of_not_square (fact.out _)

-- TODO clean this up
instance quad_ring.field_neg_five : field (quad_ring ℚ 0 (-5)) :=
quad_ring.field_of_not_square $ begin
  convert mt (rat.is_square_int_cast_iff (-5)).mp _,
  { norm_num },
  refine irreducible.not_is_square (prime.irreducible $ int.prime_iff_nat_abs_prime.mpr $ _),
  norm_num
end

-- Thanks to PR #14894, this diamond is fixed!
example (n : ℚ) {d' : ℚ} [fact $ ¬ is_square d'] :
  @@coe (@@coe_to_lift (quad_ring.has_coe_t ℚ 0 d')) n = @@coe (@@coe_to_lift rat.cast_coe) n :=
rfl
example {d' : ℚ} [fact $ ¬ is_square d'] : quad_ring.algebra ℚ 0 d' = algebra_rat := rfl

end field

/-! ## The field `ℚ(√d)` as field of fractions of `ℤ[√d]` -/

section rat
-- We use different variables `d : ℤ` and `d' : ℚ`,
-- since `-5 : ℚ` is not the same as `↑ (-5 : ℤ)`.
variables (d : ℤ) (d' : ℚ) [hdd' : fact $ algebra_map ℤ ℚ d = d']

include hdd'
open_locale quad_ring

lemma coe_d : (d : ℚ) = d' := hdd'.out

variables {d d'}

/-- We map from `ℤ[√d]` to `ℚ(√d)` by applying the coercion `ℤ → ℚ` componentwise.

This is not true for arbitrary `R[√d] → K(√d)` since there might not be such a coercion.
-/
@[simp] lemma algebra_map_mk (x y : ℤ) :
  algebra_map ℤ[√d] ℚ(√d') ⟨x, y⟩ = ⟨x, y⟩ :=
rfl

variables (d d')

lemma fraction_ring_surj_aux (a b : ℚ) :
  (⟨a, b⟩ : quad_ring ℚ 0 d') *
      algebra_map ℤ[√d] ℚ(√d') (↑(a.denom) * ↑(b.denom)) =
    algebra_map ℤ[√d] ℚ(√d') ⟨a.num * ↑(b.denom), b.num * ↑(a.denom)⟩ :=
begin
  ext : 1;
    simp only [algebra_map_mk, mul_b1, mul_b2, set_like.coe_mk, map_mul, coe_coe,
      algebra_map_coe, map_nat_cast, map_int_cast, coe_b1, coe_b2,
      coe_int_b1, coe_int_b2, coe_nat_b1, coe_nat_b2, zero_mul, mul_zero, zero_add, add_zero],
  { rw [← mul_assoc, int.cast_coe_nat, @rat.mul_denom_eq_num a], norm_cast },
  { rw [mul_comm ↑↑a.denom, ← mul_assoc, int.cast_coe_nat, @rat.mul_denom_eq_num b], norm_cast }
end

/-- If `d` is not a square, then `ℚ(√d)` is the field of fractions of `ℤ[√d]`. -/
instance [not_sq : fact $ ¬ is_square d] : is_fraction_ring ℤ[√d] ℚ(√d') :=
{ map_units := begin
    haveI : fact (¬ is_square d'),
    { rw [← hdd'.out, eq_int_cast],
      exact ⟨(rat.is_square_int_cast_iff _).not.mpr not_sq.out⟩ },
    rintro ⟨⟨a, b⟩, hy⟩,
    apply is_unit.mk0 _,
    simp only [set_like.coe_mk, algebra_map_mk, ne.def, ext_iff, zero_b1, zero_b2,
      int.cast_eq_zero],
    rintro ⟨rfl, rfl⟩,
    exact non_zero_divisors.ne_zero hy rfl
  end,
  surj := begin
    rintro ⟨a, b⟩,
    refine ⟨⟨⟨a.num * b.denom, b.num * a.denom⟩,
             ⟨a.denom * b.denom, mul_mem _ _⟩⟩,
            fraction_ring_surj_aux d d' a b⟩,
    repeat { exact mem_non_zero_divisors_of_ne_zero
      (mt (coe_eq_zero _ _ _).mp (int.coe_nat_ne_zero.mpr (rat.denom_ne_zero _))) },
  end,
  eq_iff_exists := begin
    intros x y,
    split,
    { intro h,
      use 1,
      rw [algebra_map_injective 0 d 0 d' (ring_hom.injective_int _) h,
          one_mem_class.coe_one, mul_one] },
    rintro ⟨c, h⟩,
    rw [mul_right_cancel₀ (non_zero_divisors.coe_ne_zero c) h]
  end
}
omit hdd'

/-! ### Ring of integers of `ℚ(√d)`, `d ≠ 1` mod 4.  -/

open polynomial

variables (d) {d'}

/-- The minimal polynomial for `a + b √d` when `a b ∈ R`. -/
noncomputable def minpoly_a_add_b_sqrt_d {R : Type*} [comm_ring R] (dR a b : R) : polynomial R :=
X^2 - C (2 * a) * X + C (a^2 - dR * b^2)

namespace minpoly_a_add_b_sqrt_d

variables {R : Type*} [comm_ring R] (dR a b : R)

protected lemma coeff_zero : (minpoly_a_add_b_sqrt_d dR a b).coeff 0 = a^2 - dR * b^2 :=
by simp only [minpoly_a_add_b_sqrt_d, pow_two, coeff_add, coeff_sub,
  mul_coeff_zero, coeff_X_zero, coeff_C_zero,
  mul_zero, zero_sub, neg_zero, zero_add, int.cast_id]

protected lemma coeff_one : (minpoly_a_add_b_sqrt_d dR a b).coeff 1 = - 2 * a :=
by simp only [minpoly_a_add_b_sqrt_d, pow_two, coeff_add, coeff_sub,
  coeff_mul_X, coeff_X_zero, coeff_C_ne_zero (show (1 : ℕ) ≠ 0, from one_ne_zero), coeff_C_zero,
  zero_sub, add_zero, neg_mul]

protected lemma coeff_two : (minpoly_a_add_b_sqrt_d dR a b).coeff 2 = 1 :=
by simp only [minpoly_a_add_b_sqrt_d, pow_two, coeff_add, coeff_sub,
  coeff_mul_X, coeff_X_one, coeff_C_ne_zero (show (1 : ℕ) ≠ 0, from one_ne_zero),
  coeff_C_ne_zero (show (2 : ℕ) ≠ 0, from two_ne_zero), sub_zero, add_zero]

@[simp] protected lemma degree [nontrivial R] : degree (minpoly_a_add_b_sqrt_d dR a b) = 2 :=
begin
  have deg_X2_X :=
    calc degree (C (2 * a) * X) ≤ 1 : by compute_degree_le
                            ... < 2 : with_bot.coe_lt_coe.mpr one_lt_two
                            ... = degree (X^2) : (degree_X_pow _).symm,
  refine (degree_add_eq_left_of_degree_lt _).trans
    ((degree_sub_eq_left_of_degree_lt deg_X2_X).trans
    (degree_X_pow 2)),
  calc degree (C _) ≤ 0 : degree_C_le
                ... < 2 : with_bot.coe_lt_coe.mpr zero_lt_two
                ... = degree (X^2) : (degree_X_pow _).symm
                ... = degree _ : (degree_sub_eq_left_of_degree_lt deg_X2_X).symm,
  apply_instance
end

protected lemma monic : monic (minpoly_a_add_b_sqrt_d dR a b) :=
begin
  nontriviality R,
  -- TODO: unify with previous lemma
  have deg_X2_X :=
    calc degree (C (2 * a) * X) ≤ 1 : by compute_degree_le
                            ... < 2 : with_bot.coe_lt_coe.mpr one_lt_two
                            ... = degree (X^2) : (degree_X_pow _).symm,
  refine ((monic_X_pow _).sub_of_left deg_X2_X).add_of_left _,
  calc degree (C _) ≤ 0 : degree_C_le
                ... < 2 : with_bot.coe_lt_coe.mpr zero_lt_two
                ... = degree (X^2) : (degree_X_pow _).symm
                ... = degree _ : (degree_sub_eq_left_of_degree_lt deg_X2_X).symm,
  apply_instance
end

@[simp] lemma eval₂_eq {S : Type*} [comm_ring S] (f : R →+* S) (x : S) :
  eval₂ f x (minpoly_a_add_b_sqrt_d dR a b) = x^2 - f (2 * a) * x + f (a^2 - dR * b^2) :=
by simp only [minpoly_a_add_b_sqrt_d, eval₂_add, eval₂_sub, eval₂_pow, eval₂_mul, eval₂_X, eval₂_C]

lemma aeval_mk_eq_zero : -- can be proved by `aeval_eq_zero`
  aeval (⟨a, b⟩ : quad_ring R 0 dR) (minpoly_a_add_b_sqrt_d dR a b) = 0 :=
begin
  simp only [aeval_def, eval₂_eq, map_sub, map_mul, map_pow, map_bit0, map_one],
  calc_tac
end

@[simp] lemma aeval_eq_zero (x : quad_ring R 0 dR) :
  aeval x (minpoly_a_add_b_sqrt_d dR x.b1 x.b2) = 0 :=
begin
  cases x with a b,
  exact aeval_mk_eq_zero dR a b
end

end minpoly_a_add_b_sqrt_d

protected lemma is_integral_mk' (a b : ℤ) : is_integral ℤ (⟨a, b⟩ : quad_ring ℤ 0 d) :=
⟨minpoly_a_add_b_sqrt_d d a b,
 minpoly_a_add_b_sqrt_d.monic _ _ _,
 minpoly_a_add_b_sqrt_d.aeval_mk_eq_zero d a b⟩

protected lemma is_integral : algebra.is_integral ℤ (ℤ[√d]) :=
λ ⟨a, b⟩, quad_ring.is_integral_mk' _ a b

section
include hdd'

protected lemma is_integral_mk (a b : ℤ) : is_integral ℤ (⟨a, b⟩ : quad_ring ℚ 0 d') :=
begin
  rw [← @@algebra_map_mk hdd', is_integral_algebra_map_iff],
  { exact quad_ring.is_integral_mk' d a b },
  { exact algebra_map_injective 0 d 0 d' (ring_hom.injective_int _) }
end

lemma minpoly_eq [fact (¬ is_square d')] (x : ℚ(√d')) :
  (∃ y : ℚ, x = y) ∨ minpoly ℚ x = minpoly_a_add_b_sqrt_d d' x.b1 x.b2 :=
begin
  rw or_iff_not_imp_left,
  intro x_triv,
  refine (minpoly.unique _ x (minpoly_a_add_b_sqrt_d.monic d' x.b1 x.b2) _ _).symm,
  { exact minpoly_a_add_b_sqrt_d.aeval_eq_zero d' x },
  -- After all, this polynomial is of degree 2, so any (monic) polynomial that has root x
  -- of smaller degree implies x is trivial.
  intros q q_monic aeval_q,
  rw [minpoly_a_add_b_sqrt_d.degree, degree_eq_nat_degree q_monic.ne_zero],
  refine with_bot.coe_le_coe.mpr (show 2 ≤ q.nat_degree, from le_of_not_lt _),
  intros h,
  have := q.nat_degree.zero_le,
  interval_cases using this h with h,
  { rw [eq_C_of_nat_degree_eq_zero h_1, ← h_1, q_monic.coeff_nat_degree, aeval_C, map_one]
      at aeval_q,
    exact one_ne_zero aeval_q },
  refine x_triv ⟨(- q.coeff 0) / q.coeff 1, _⟩,
  rw [polynomial.eq_X_add_C_of_nat_degree_le_one h_1.le, aeval_add,
      aeval_mul, aeval_C, aeval_X, aeval_C] at aeval_q,
  have q_coeff_one : q.coeff 1 ≠ 0,
  { rw [← h_1, q_monic.coeff_nat_degree],
    exact one_ne_zero },
  refine mul_left_cancel₀ (show algebra_map ℚ ℚ(√d') (q.coeff 1) ≠ 0, from _) _,
  { exact (map_ne_zero_iff _ ((algebra_map ℚ ℚ(√d')).injective)).mpr q_coeff_one },
  rw [← eq_rat_cast (algebra_map ℚ _), ← _root_.map_mul, mul_div_cancel' _ q_coeff_one, map_neg,
      add_eq_zero_iff_eq_neg.mp aeval_q],
end

lemma exists_c1_c0 [fact (¬ is_square d')] (x : ℚ(√d')) (hx : is_integral ℤ x) :
  (∃ y : ℚ, x = y) ∨ (∃ c1 c0 : ℤ, -2 * x.b1 = c1 ∧ x.b1^2 - d * x.b2^2 = c0) :=
begin
  cases minpoly_eq d x with triv minpoly_eq,
  { exact or.inl triv },
  have : ∀ n, (minpoly_a_add_b_sqrt_d d' x.b1 x.b2).coeff n = (minpoly ℤ x).coeff n,
  { intros n,
    rw [← minpoly_eq, minpoly.gcd_domain_eq_field_fractions' ℚ hx, coeff_map,
        algebra_map_int_eq, eq_int_cast] },
  refine or.inr ⟨(minpoly ℤ x).coeff 1, (minpoly ℤ x).coeff 0, _, _⟩,
  { simpa only [minpoly_a_add_b_sqrt_d.coeff_one] using this 1 },
  { simpa only [minpoly_a_add_b_sqrt_d.coeff_zero, ← hdd'.out] using this 0 }
end

end

lemma rat.denom_eq_one_iff_exists_int {b : ℚ} : b.denom = 1 ↔ ∃ b' : ℤ, b = b' :=
(rat.denom_eq_one_iff _).trans ⟨λ h, ⟨b.num, h.symm⟩, by { rintro ⟨b', rfl⟩, simp }⟩

/-- If `d` is squarefree, and `d * (b^2 : ℚ)` is an integer, then `b` is an integer. -/
lemma eq_int_of_squarefree_mul_sq_eq_int {b : ℚ} {c d : ℤ} (hd : squarefree d)
  (h : ↑d * b^2 = c) : ∃ (b' : ℤ), b = b' :=
begin
  rw [← rat.denom_eq_one_iff_exists_int, ← nat.is_unit_iff, ← int.of_nat_is_unit],
  apply hd,
  rw ← pow_two,
  rw [← b.num_div_denom, div_pow, mul_div, div_eq_iff, mul_comm ↑c] at h,
  norm_cast at h,
  exact is_coprime.dvd_of_dvd_mul_right
    (is_coprime.pow (int.coprime_iff_nat_coprime.mpr b.cop.symm)) ⟨_, h⟩,
  { simpa using b.pos.ne' }
end

/-- Let `r = 2` or `r = 3`, then r is not a quadratic remainder mod `4`,
so `r*b^2 = a^2` has no solutions if `b` is odd. -/
lemma zmod_4.two_or_three_mul_odd_sq_ne_sq {r : zmod 4} (hr : r = 2 ∨ r = 3)
  (a b : zmod 4) (hb : odd b) :
  r * b^2 ≠ a^2 :=
begin
  unfold odd at hb,
  dec_trivial!
end

lemma zmod_4.not_square_of_eq_two_or_three {d : zmod 4} (hr : d = 2 ∨ d = 3) :
  ¬ is_square d :=
begin
  dec_trivial!
end

lemma not_square_of_eq_two_or_three_mod_four {d : ℤ} (hr : d % 4 = 2 ∨ d % 4 = 3) :
  ¬ is_square d :=
begin
  refine _ ∘ is_square.map (int.cast_ring_hom (zmod 4)),
  rw int.coe_cast_ring_hom,
  refine zmod_4.not_square_of_eq_two_or_three _,
  cases hr,
  { exact or.inl ((zmod.int_coe_eq_int_coe_iff' d 2 4).mpr hr) },
  { exact or.inr ((zmod.int_coe_eq_int_coe_iff' d 3 4).mpr hr) }
end

/-- The number theoretic argument showing ℤ[√d] is the ring of integers of ℚ(√d), if d = 2 or 3 mod 4:
the coefficients of the minimal polynomial of an integral number must be integers,
which implies the coordinates are integers.
-/
lemma is_integral_closure_23_aux
  {d c1 c0 : ℤ} {a b : ℚ} (hd2 : squarefree d) (hr : d % 4 = 2 ∨ d % 4 = 3)
  (hc1 : -2 * a = c1) (hc0 : a^2 - d * b^2 = c0) :
  ∃ (a' b' : ℤ), a = a' ∧ b = b' :=
begin
  -- `a` is an integer up to a factor 2
  rw [neg_mul, neg_eq_iff_neg_eq, ← int.cast_neg, eq_comm] at hc1,
  set a' := - c1 with ha',
  clear_value a',
  -- And after some rewriting, `b` is an integer up to a factor 2 too (since `d` is squarefree)
  have four_hc0 : (2 * a)^2 - d * (2 * b)^2 = 4 * c0, { rw ← hc0, ring },
  rw [hc1, sub_eq_iff_eq_add, ← sub_eq_iff_eq_add', eq_comm] at four_hc0,
  norm_cast at four_hc0,
  -- So let `a2' = 2a` and `b' = 2b` be integers, so we get the equation `d b'^2 = a'^2 - 4c0`.
  obtain ⟨b', hb'⟩ := eq_int_of_squarefree_mul_sq_eq_int hd2 four_hc0,
  rw hb' at four_hc0,
  norm_cast at four_hc0,
  -- It suffices to show `b'` is even, in particular that `b'` is not odd.
  suffices : even b',
  { obtain ⟨b', rfl⟩ := (even_iff_exists_two_mul _).mp this,
    obtain ⟨a', rfl⟩ := (even_iff_exists_two_mul _).mp (show even a', from _),
    { refine ⟨a', b', _, _⟩,
      { push_cast at hc1,
        exact mul_left_cancel₀ (by norm_num) hc1 },
      { push_cast at hb',
        exact mul_left_cancel₀ (by norm_num) hb' } },
    { refine (int.even_pow.mp (show even (a'^2), from _)).1,
      rw sub_eq_iff_eq_add'.mp four_hc0.symm,
      exact even.add
        (even.mul_right (by norm_num) _)
        (even.mul_left (even.pow_of_ne_zero this (by norm_num)) _) } },
  rw int.even_iff_not_odd,
  intros b_odd,
  -- Consider the possible values for `a'`, `b'` that satisfy the equation mod 4.
  have coe_b_odd : odd (b' : zmod 4) := b_odd.map (int.cast_ring_hom (zmod 4)),
  have hc0_mod_4 := congr_arg (coe : ℤ → zmod 4) four_hc0,
  rw [int.cast_mul, int.cast_sub, int.cast_pow, int.cast_pow,
      (zmod.int_coe_zmod_eq_zero_iff_dvd (4 * c0) 4).mpr (dvd_mul_right 4 c0), sub_zero]
    at hc0_mod_4,
  refine zmod_4.two_or_three_mul_odd_sq_ne_sq _ a' b' coe_b_odd hc0_mod_4,
  cases hr,
  { exact or.inl ((zmod.int_coe_eq_int_coe_iff' d 2 4).mpr hr) },
  { exact or.inr ((zmod.int_coe_eq_int_coe_iff' d 3 4).mpr hr) }
end

section

include hdd'

/-- ℤ[√d] is the ring of integers of ℚ(√d), if d = 2 or 3 mod 4. -/
lemma is_integral_closure_23 (hr : d % 4 = 2 ∨ d % 4 = 3)
  (hd2 : squarefree d) :
  is_integral_closure ℤ[√d] ℤ ℚ(√d') :=
{ algebra_map_injective := algebra_map_injective 0 d 0 d' (ring_hom.injective_int _),
  is_integral_iff := begin
    haveI : fact (¬ is_square d'),
    { constructor,
      rw ← coe_d d d',
      rw rat.is_square_int_cast_iff,
      exact not_square_of_eq_two_or_three_mod_four hr },
    intros x,
    split,
    { intros hx,
      -- Either x is trivial, or the minimal polynomial of x is `x^2 - 2 a x + (a^2 - d b^2).
      rcases exists_c1_c0 d x hx with ⟨y, rfl⟩ | ⟨c1, c0, hc1, hc0⟩,
      { rw [← eq_rat_cast (algebra_map ℚ _),
            is_integral_algebra_map_iff ((algebra_map ℚ ℚ(√d')).injective)] at hx,
        obtain ⟨y, rfl⟩ := unique_factorization_monoid.integer_of_integral hx,
        refine ⟨y, algebra_map_coe _ _ _ _ _⟩,
        { apply_instance } },
      -- Therefore, `-2 * a` and `a^2 - d * b^2` are integers.
      obtain ⟨a', b', ha, hb⟩ := is_integral_closure_23_aux hd2 hr hc1 hc0,
      refine ⟨⟨a', b'⟩, _⟩,
      ext : 1; simp only [algebra_map_mk, ha, hb] },
    { rintro ⟨⟨a, b⟩, rfl⟩,
      rw algebra_map_mk,
      exact quad_ring.is_integral_mk d a b }
 end }

end

-- TODO probably remove these special cases
instance : is_integral_closure (quad_ring ℤ 0 (-5)) ℤ (quad_ring ℚ 0 (-5)) :=
is_integral_closure_23 (-5) (or.inr rfl)
  (squarefree.squarefree_of_dvd ((neg_dvd _ _).mpr (dvd_refl 5)) $ prime.squarefree $
    int.prime_iff_nat_abs_prime.mpr $ by norm_num)

instance quad_ring.is_integral_closure_3 {d : ℤ} [fact $ d % 4 = 3]
  [fact $ squarefree d] {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')] :
  is_integral_closure ℤ[√d] ℤ ℚ(√d') :=
is_integral_closure_23 d (or.inr $ fact.out _) (fact.out _)

instance quad_ring.is_integral_closure_2 {d : ℤ} [fact $ d % 4 = 2]
  [fact $ squarefree d] {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')] :
  is_integral_closure ℤ[√d] ℤ ℚ(√d') :=
is_integral_closure_23 d (or.inl $ fact.out _) (fact.out _)

instance quad_ring.is_integral_closure_2_or_three {d : ℤ}
  [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d] {d' : ℚ}
  [hdd' : fact (algebra_map ℤ ℚ d = d')] :
  is_integral_closure ℤ[√d] ℤ ℚ(√d') :=
is_integral_closure_23 d (fact.out _) (fact.out _)

namespace one_mod_four

/-! ### Ring of integers of `ℚ(√d)`, `d = 1` mod 4.

Here we'll use notation `α = 1/2 (1 + √d)` and `m = (d - 1) / 4`.

If `d = 1` mod 4 then `ℤ[√d]` is not integrally closed, so we have to adjoin a root
`α` of the polynomial `X^2 - X - (d - 1)/4` instead, giving the ring `quad_ring ℤ 1 m`.
-/

open polynomial

variables {R : Type*} [comm_ring R] (a b : R)

/-- The minimal polynomial for `a + b * α` when `a b ∈ R`. -/
noncomputable def minpoly_a_add_b_alpha {R : Type*} [comm_ring R] (m a b : R) : polynomial R :=
X^2 - C (2 * a + b) * X + C (a^2 + a*b - b^2 * m)

namespace minpoly_a_add_b_alpha

variables (m : R)

protected lemma coeff_zero : (minpoly_a_add_b_alpha m a b).coeff 0 = a^2 + a*b - b^2 * m :=
by simp only [minpoly_a_add_b_alpha, pow_two, coeff_add, coeff_sub,
  mul_coeff_zero, coeff_X_zero, coeff_C_zero,
  mul_zero, zero_sub, neg_zero, zero_add, int.cast_id]

protected lemma coeff_one : (minpoly_a_add_b_alpha m a b).coeff 1 = - (2 * a + b) :=
by simp only [minpoly_a_add_b_alpha, pow_two, coeff_add, coeff_sub,
  coeff_mul_X, coeff_X_zero, coeff_C_ne_zero (show (1 : ℕ) ≠ 0, from one_ne_zero), coeff_C_zero,
  zero_sub, add_zero, neg_mul]

protected lemma coeff_two : (minpoly_a_add_b_alpha m a b).coeff 2 = 1 :=
by simp only [minpoly_a_add_b_alpha, pow_two, coeff_add, coeff_sub,
  coeff_mul_X, coeff_X_one, coeff_C_ne_zero (show (1 : ℕ) ≠ 0, from one_ne_zero),
  coeff_C_ne_zero (show (2 : ℕ) ≠ 0, from two_ne_zero), sub_zero, add_zero]

@[simp] protected lemma degree [nontrivial R] : degree (minpoly_a_add_b_alpha m a b) = 2 :=
begin
  -- TODO: this should be automatable (using Damiano's tactics?)
  have deg_X2_X :=
    calc degree (C (2 * a + b) * X) ≤ degree (C (2 * a + b)) + degree X : degree_mul_le _ _
                            ... ≤ 0 + 1 : add_le_add degree_C_le degree_X_le
                            ... < 2 : with_bot.coe_lt_coe.mpr one_lt_two
                            ... = degree (X^2) : (degree_X_pow _).symm,
  refine (degree_add_eq_left_of_degree_lt _).trans
    ((degree_sub_eq_left_of_degree_lt deg_X2_X).trans
    (degree_X_pow 2)),
  calc degree (C _) ≤ 0 : degree_C_le
                ... < 2 : with_bot.coe_lt_coe.mpr zero_lt_two
                ... = degree (X^2) : (degree_X_pow _).symm
                ... = degree _ : (degree_sub_eq_left_of_degree_lt deg_X2_X).symm,
  apply_instance
end

protected lemma monic : monic (minpoly_a_add_b_alpha m a b) :=
begin
  nontriviality R,
  -- TODO: unify with previous lemma
  have deg_X2_X :=
    calc degree (C (2 * a + b) * X) ≤ degree (C (2 * a + b)) + degree X : degree_mul_le _ _
                            ... ≤ 0 + 1 : add_le_add degree_C_le degree_X_le
                            ... < 2 : with_bot.coe_lt_coe.mpr one_lt_two
                            ... = degree (X^2) : (degree_X_pow _).symm,
  refine ((monic_X_pow _).sub_of_left deg_X2_X).add_of_left _,
  calc degree (C _) ≤ 0 : degree_C_le
                ... < 2 : with_bot.coe_lt_coe.mpr zero_lt_two
                ... = degree (X^2) : (degree_X_pow _).symm
                ... = degree _ : (degree_sub_eq_left_of_degree_lt deg_X2_X).symm,
  apply_instance
end

@[simp] lemma eval₂_eq {S : Type*} [comm_ring S] (f : R →+* S) (x : S) :
  eval₂ f x (minpoly_a_add_b_alpha m a b) = x^2 - f (2 * a + b) * x + f (a^2 + a * b - b^2 * m) :=
by simp only [minpoly_a_add_b_alpha, eval₂_add, eval₂_sub, eval₂_pow, eval₂_mul, eval₂_X, eval₂_C]

lemma aeval_mk_eq_zero : -- can be proved by `aeval_eq_zero`
  aeval (⟨a, b⟩ : quad_ring R 1 m) (minpoly_a_add_b_alpha m a b) = 0 :=
begin
  simp only [aeval_def, eval₂_eq, map_sub, map_mul, map_pow, map_bit0, map_one],
  calc_tac
end

@[simp] lemma aeval_eq_zero (x : quad_ring R 1 m) :
  aeval x (minpoly_a_add_b_alpha m x.b1 x.b2) = 0 :=
begin
  cases x with a b,
  exact aeval_mk_eq_zero a b m
end

end minpoly_a_add_b_alpha

variables (m : ℤ)

protected lemma is_integral_mk' (a b : ℤ) : is_integral ℤ (⟨a, b⟩ : quad_ring ℤ 1 m) :=
⟨minpoly_a_add_b_alpha m a b,
 minpoly_a_add_b_alpha.monic _ _ _,
 minpoly_a_add_b_alpha.aeval_mk_eq_zero a b m⟩

protected lemma is_integral (a b : ℤ) : algebra.is_integral ℤ (quad_ring ℤ 1 m) :=
λ ⟨a, b⟩, quad_ring.one_mod_four.is_integral_mk' m a b

section

theorem smul_inv_cancel₀ {M : Type*} {α : Type*} [group_with_zero M] [mul_action M α] [monoid α]
  {r : M} (hr : r ≠ 0) (x : α) : (r • r⁻¹ • x) = x :=
by rw [← mul_smul, mul_inv_cancel hr, one_smul]

theorem smul_sq {M : Type*} {α : Type*} [monoid M] [mul_action M α] [monoid α]
  (r : M) (x : α) [is_scalar_tower M α α] [smul_comm_class M α α] :
  (r • x)^2 = (r^2) • (x^2) :=
by simp only [pow_two, smul_mul_smul]

variables [hdm : fact $ d' = 4 * m + 1]
include hdm

instance : algebra (quad_ring ℤ 1 m) ℚ(√d') :=
ring_hom.to_algebra $ quad_ring.lift (algebra_map ℤ ℚ(√d')) 1 m
  -- Since d' might be a square, multiply by `1/2 : ℚ` instead of dividing by `2 : ℚ(√d')`.
  ((2⁻¹ : ℚ) • (1 + root ℚ 0 d')) $
begin
  refine smul_right_injective ℚ(√d') (show (4 : ℚ) ≠ 0, by norm_num) _,
  simp only [smul_zero, smul_sub, smul_add, smul_sq, inv_pow, map_one, one_mul, add_sq, root_sq,
    hdm.out],
  calc_tac
end

@[simp] lemma algebra_map_b1 (x : quad_ring ℤ 1 m) :
  (algebra_map (quad_ring ℤ 1 m) ℚ(√d') x).b1 = x.b1 + 1/2 * x.b2 :=
begin
  cases x,
  rw [ring_hom.algebra_map_to_algebra, lift_mk],
  simp only [smul_add, algebra_map_int_eq, one_div, quad_ring.root_b2, quad_ring.smul_b2, add_zero,
      rat.cast_eq_id, algebra.id.smul_eq_mul, quad_ring.add_b1, quad_ring.coe_int_b2,
      rat.smul_one_eq_coe, quad_ring.one_b2, eq_int_cast, int.cast_inj, id.def, add_left_inj,
      zero_mul, quad_ring.mul_b1, quad_ring.root_b1, quad_ring.coe_int_b1, zero_add,
      quad_ring.smul_b1, mul_zero, quad_ring.add_b2, quad_ring.one_b1],
end

@[simp] lemma algebra_map_b2 (x : quad_ring ℤ 1 m) :
  (algebra_map (quad_ring ℤ 1 m) ℚ(√d') x).b2 = 1/2 * x.b2 :=
begin
  cases x,
  rw [ring_hom.algebra_map_to_algebra, lift_mk],
  simp only [smul_add, algebra_map_int_eq, one_div, quad_ring.root_b2, quad_ring.smul_b2, add_zero,
      rat.cast_eq_id, algebra.id.smul_eq_mul, quad_ring.add_b1, quad_ring.coe_int_b2,
      rat.smul_one_eq_coe, quad_ring.one_b2, eq_int_cast, quad_ring.mul_b2, id.def,
      quad_ring.root_b1, quad_ring.coe_int_b1, zero_add, quad_ring.smul_b1, mul_zero,
      quad_ring.add_b2, quad_ring.one_b1]
end

@[simp] lemma algebra_map_mk (a b : ℤ) :
  algebra_map (quad_ring ℤ 1 m) ℚ(√d') ⟨a, b⟩ = ⟨a + 1/2 * b, 1/2 * b⟩ :=
by simp only [ext_iff, algebra_map_b1, algebra_map_b2, eq_self_iff_true, and_true]

@[simp] lemma algebra_map_coe (a : ℤ) :
  algebra_map (quad_ring ℤ 1 m) ℚ(√d') a = a :=
begin
  rw [ring_hom.algebra_map_to_algebra, lift_coe, eq_int_cast]
end

lemma algebra_map_injective :
  function.injective (algebra_map (quad_ring ℤ 1 m) ℚ(√d')) :=
begin
  rintros ⟨x1, x2⟩ ⟨y1, y2⟩ h,
  rw [algebra_map_mk, algebra_map_mk, ext_iff, mul_right_inj', int.cast_inj] at h,
  have := h.2,
  subst this,
  rw [eq_self_iff_true, and_true, add_left_inj, int.cast_inj] at h,
  subst h,
  { norm_num }
end

lemma is_integral_mk_alpha (a b : ℤ) :
  is_integral ℤ (⟨a + 1/2 * b, 1/2 * b⟩ : quad_ring ℚ 0 d') :=
begin
  rw [← @@algebra_map_mk m hdm, is_integral_algebra_map_iff],
  { exact quad_ring.one_mod_four.is_integral_mk' m a b },
  { exact algebra_map_injective m }
end

lemma exists_mem_z_alpha_iff (y : ℚ(√d')) :
  (∃ (x : quad_ring ℤ 1 m), algebra_map _ _ x = y) ↔
   ∃ a b : ℤ, y.b1 = a + 1/2 * b ∧ y.b2 = 1/2 * b :=
begin
  split,
  { rintros ⟨x, rfl⟩,
    exact ⟨x.b1, x.b2, algebra_map_b1 _ _, algebra_map_b2 _ _⟩ },
  { rintros ⟨a, b, hy1, hy2⟩,
    refine ⟨⟨a, b⟩, ext _ _ _ _⟩,
    { rw [hy1, algebra_map_mk] },
    { rw [hy2, algebra_map_mk] } }
end

namespace zmod

open zmod

omit hdm

/-- See also `zmod.int_coe_zmod_eq_iff` which is slightly nicer but only applies for `p > 0`. -/
lemma int_coe_zmod_eq_iff' {p : ℕ} {n : ℤ} {z : zmod p} :
  ↑n = z ↔ ∃ k, n = z.val_min_abs + p * k :=
begin
  by_cases hp : p = 0,
  { subst hp,
    split,
    { rintro rfl,
      use 0,
      simp },
    rintro ⟨k, rfl⟩,
    simp },
  haveI : ne_zero p := ⟨hp⟩,
  split,
  { rintro rfl,
    refine ⟨if (n : zmod p).val ≤ p / 2 then n / p else n / p + 1, _⟩,
    rw zmod.val_min_abs_def_pos,
    split_ifs,
    { rw [zmod.val_int_cast, int.mod_add_div] },
    { rw [zmod.val_int_cast, mul_add, mul_one, sub_add_add_cancel, int.mod_add_div] } },
  { rintro ⟨k, rfl⟩,
    rw [int.cast_add, int.cast_mul, int.cast_coe_nat, zmod.coe_val_min_abs, zmod.nat_cast_self,
        zero_mul, add_zero] }
end

end zmod

omit hdm

lemma zmod.dvd_coe_iff {k n : ℕ} {a : ℤ} (hkn : k ∣ n) : ↑k ∣ (a : zmod n) ↔ ↑k ∣ a :=
begin
  by_cases hn : n = 0,
  { subst hn, exact iff.rfl },
  by_cases hk : k = n,
  { subst hk, simpa using zmod.int_coe_zmod_eq_zero_iff_dvd a k },
  haveI : ne_zero n := ⟨hn⟩,
  split; rintro ⟨d, hd⟩,
  { obtain ⟨a, rfl⟩ := (zmod.int_coe_zmod_eq_iff _ _ _).mp hd,
    refine dvd_add _ ((map_dvd (nat.cast_ring_hom ℤ) hkn).mul_right _),
    norm_cast,
    rw [zmod.val_mul, nat.dvd_mod_iff hkn,
        zmod.val_cast_of_lt ((nat.le_of_dvd (nat.pos_of_ne_zero hn) hkn).lt_of_ne hk)],
    exact dvd_mul_right _ _ },
  { subst hd,
    exact_mod_cast dvd_mul_right (k : zmod n) (d : zmod n) },
end

lemma zmod.even_coe {n : ℕ} {a : ℤ} (hn : even n) : even (a : zmod n) ↔ even a :=
begin
  simp only [even_iff_two_dvd] at ⊢ hn,
  simpa using zmod.dvd_coe_iff hn,
end

lemma even_iff_sq_mod_four {a : ℤ} : even a ↔ (a : zmod 4)^2 = 0 :=
begin
  split,
  { intro h,
    obtain ⟨a', rfl⟩ := (even_iff_exists_two_mul _).mp h,
    calc ↑(2 * a') ^ 2
        = (2 * (a' : zmod 4))^2 : by push_cast
    ... = 4 * (a' : zmod 4)^2 : by ring
    ... = 0 : _,
    -- TODO: can we do this in a nicer way?
    generalize : (a' : zmod 4) = a'',
    revert a'',
    dec_trivial },
  { contrapose!,
    intro h,
    obtain ⟨a', rfl⟩ := int.odd_iff_not_even.mpr h,
    -- TODO: can we do this in a nicer way?
    push_cast,
    generalize : (a' : zmod 4) = a'',
    revert a'',
    dec_trivial },
end

lemma sub_even_of_sq_eq_sq_mod_four (a b : ℤ) (h : (a : zmod 4)^2 = b^2) :
  even (a - b) :=
by rw [int.even_sub, even_iff_sq_mod_four, even_iff_sq_mod_four, h]

/-- The number theoretic argument showing ℤ[α] is the ring of integers of ℚ(√d), if d = 1:
the coefficients of the minimal polynomial of an integral number must be integers,
which implies the coordinates in ℤ[α] are integers.
-/
lemma is_integral_closure_1_aux (m c0 c1 : ℤ) (x y : ℚ)
  (hm : squarefree (4 * m + 1)) (hc1 : -2 * x = c1) (hc0 : x^2 - (4 * m + 1) * y^2 = c0) :
  ∃ (a b : ℤ), x = a + 1/2 * b ∧ y = 1/2 * b :=
begin
  -- `x` is an integer up to a factor 2
  rw [neg_mul, neg_eq_iff_neg_eq, ← int.cast_neg, eq_comm] at hc1,
  set x' := - c1 with hx',
  clear_value x',
  -- And after some rewriting, `y` is an integer up to a factor 2 too (since `d` is squarefree)
  have four_hc0 : (2 * x)^2 - (4 * m + 1) * (2 * y)^2 = 4 * c0, { rw ← hc0, ring },
  have four_hc0' := four_hc0, -- Needed for later
  rw [hc1, sub_eq_iff_eq_add, ← sub_eq_iff_eq_add', eq_comm] at four_hc0,
  norm_cast at four_hc0,
  -- So let `x' = 2x` and `b = 2y` be integers.
  obtain ⟨b, hb⟩ := eq_int_of_squarefree_mul_sq_eq_int hm four_hc0,
  -- To get an `a`, it suffices to show `x - y` is an integer.
  rsuffices ⟨a, ha⟩ : ∃ a : ℤ, x - y = a,
  { refine ⟨a, b, _, _⟩,
    { rw [← ha, ← hb], simp },
    { rw ← hb, simp } },
  -- Which is the case iff `2x - 2y = x' - b` is even.
  obtain ⟨a, ha⟩ := (even_iff_exists_two_mul _).mp
    (show even (x' - b), from sub_even_of_sq_eq_sq_mod_four _ _ _),
  { use a,
    have ha' : (↑(x' - b) : ℚ) = _ := int.cast_inj.mpr ha,
    push_cast at ha',
    rw [← hc1, ← hb, ← mul_sub] at ha',
    exact mul_left_cancel₀ (by norm_num) ha' },
  -- This follows from considering the equation `(4m + 1) * (2y)^2 = x'^2 - 4*c0` mod 4.
  rw [hc1, hb] at four_hc0',
  norm_cast at four_hc0',
  have hc0_mod_4 := congr_arg (coe : ℤ → zmod 4) four_hc0',
  rwa [int.cast_sub, int.cast_pow, int.cast_mul, int.cast_add, int.cast_pow, int.cast_one,
      (zmod.int_coe_zmod_eq_zero_iff_dvd (4 * m) 4).mpr (dvd_mul_right 4 m),
      (zmod.int_coe_zmod_eq_zero_iff_dvd (4 * c0) 4).mpr (dvd_mul_right 4 c0),
      zero_add, one_mul, sub_eq_zero]
    at hc0_mod_4,
end

include hdm

/-- ℤ[1/2 + 1/2√d] is the ring of integers of ℚ(√d), if d = 1 mod 4. -/
lemma is_integral_closure_1 (hd' : ¬ is_square d') (hd2 : squarefree (4*m + 1)) :
  is_integral_closure (quad_ring ℤ 1 m) ℤ ℚ(√d') :=
{ algebra_map_injective := algebra_map_injective m,
  is_integral_iff := begin
    haveI : fact (¬ is_square d') := ⟨hd'⟩,
    intros x,
    split,
    { intros hx,
      haveI hdd' : fact (algebra_map ℤ ℚ (4 * m + 1) = d') := ⟨by simpa using hdm.out.symm⟩,
      -- Either x is trivial, or we know the coefficients of its minimal polynomial,
      -- which are integral.
      rcases exists_c1_c0 (4 * m + 1) x hx with ⟨y, rfl⟩ | ⟨c1, c0, hc1, hc0⟩,
      { rw [← eq_rat_cast (algebra_map ℚ _),
            is_integral_algebra_map_iff ((algebra_map ℚ ℚ(√d')).injective)] at hx,
        obtain ⟨y, rfl⟩ := unique_factorization_monoid.integer_of_integral hx,
        refine ⟨y, algebra_map_coe _ _⟩,
        { apply_instance } },
      push_cast at hc0,
      rw exists_mem_z_alpha_iff,
      exact is_integral_closure_1_aux m _ _ x.b1 x.b2 hd2 hc1 hc0 },
    { rintro ⟨⟨a, b⟩, rfl⟩,
      rw algebra_map_mk,
      exact is_integral_mk_alpha m a b }
 end }

end

end one_mod_four

section

instance {K : Type*} [field K] (a b : K) : finite_dimensional K (quad_ring K a b) :=
finite_dimensional.of_fintype_basis (quad_ring.basis K a b)

instance fact_not_square_of_eq_three_mod_four {d : ℤ} [hd : fact $ d % 4 = 3] :
  fact $ ¬ is_square d :=
⟨quad_ring.not_square_of_eq_two_or_three_mod_four (or.inr hd.out)⟩

instance fact_not_square_of_eq_two_mod_four {d : ℤ} [hd : fact $ d % 4 = 2] :
  fact $ ¬ is_square d :=
⟨quad_ring.not_square_of_eq_two_or_three_mod_four (or.inl hd.out)⟩

instance fact_not_square_of_eq_two_or_three_mod_four {d : ℤ} [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] :
  fact $ ¬ is_square d :=
⟨quad_ring.not_square_of_eq_two_or_three_mod_four hd.out⟩

lemma fact_not_square'_of_eq_three_mod_four (d : ℤ) {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')]
  [hd : fact $ d % 4 = 3] : fact $ ¬ is_square d' :=
⟨begin
  erw [← hdd'.out, rat.is_square_int_cast_iff],
  exact quad_ring.not_square_of_eq_two_or_three_mod_four (or.inr hd.out)
end⟩

lemma fact_not_square'_of_eq_two_mod_four (d : ℤ) {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')]
  [hd : fact $ d % 4 = 2] : fact $ ¬ is_square d' :=
⟨begin
  erw [← hdd'.out, rat.is_square_int_cast_iff],
  exact quad_ring.not_square_of_eq_two_or_three_mod_four (or.inl hd.out)
end⟩

lemma fact_not_square'_of_eq_two_or_three_mod_four (d : ℤ) {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')]
  [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] : fact $ ¬ is_square d' :=
⟨begin
  erw [← hdd'.out, rat.is_square_int_cast_iff],
  exact quad_ring.not_square_of_eq_two_or_three_mod_four hd.out
end⟩

 -- `d` is a free variable so these can't be instances
local attribute [instance] fact_not_square'_of_eq_three_mod_four
local attribute [instance] fact_not_square'_of_eq_two_mod_four
local attribute [instance] fact_not_square'_of_eq_two_or_three_mod_four

instance quad_ring.mod_three_is_dedekind_domain {d : ℤ} [fact $ d % 4 = 3] [fact $ squarefree d] :
  is_dedekind_domain ℤ[√d] :=
is_integral_closure.is_dedekind_domain ℤ ℚ (quad_ring ℚ 0 d) ℤ[√d]

instance quad_ring.mod_two_is_dedekind_domain {d : ℤ} [fact $ d % 4 = 2] [fact $ squarefree d] :
  is_dedekind_domain ℤ[√d] :=
is_integral_closure.is_dedekind_domain ℤ ℚ (quad_ring ℚ 0 d) ℤ[√d]

instance quad_ring.mod_two_or_three_is_dedekind_domain {d : ℤ} [fact $ d % 4 = 2 ∨ d % 4 = 3]
  [fact $ squarefree d] :
  is_dedekind_domain ℤ[√d] :=
is_integral_closure.is_dedekind_domain ℤ ℚ (quad_ring ℚ 0 d) ℤ[√d]

@[simp]
lemma d_one_mod_four_fact [hdmod : fact (d % 4 = 1)] : 4 * ((d - 1) / 4) + 1 = d :=
begin
  rw [int.mul_div_cancel_of_mod_eq_zero, sub_add_cancel],
  rw [int.sub_mod, hdmod.out],
  norm_num,
end

instance algebra_sub_one [hdmod : fact $ d % 4 = 1] [hdd' : fact (algebra_map ℤ ℚ d = d')] :
  algebra (quad_ring ℤ 1 ((d - 1) / 4)) ℚ(√d') :=
begin
  haveI : fact (d' = 4 * (↑((d - 1) / 4) : ℚ) + 1) := fact.mk _,
  apply_instance,
  simp only [←hdd'.out, eq_int_cast],
  norm_cast,
  exact (d_one_mod_four_fact d).symm,
end

lemma fact_not_square'_of_not_square (d : ℤ) {d' : ℚ} [hdd' : fact (algebra_map ℤ ℚ d = d')]
  [hd : fact $ ¬ is_square d] : fact $ ¬ is_square d' :=
⟨begin
  erw [← hdd'.out, rat.is_square_int_cast_iff],
  exact fact.out _,
end⟩

local attribute [instance] fact_not_square'_of_not_square

instance quad_ring.mod_one_is_dedekind_domain {d : ℤ} [hdmod : fact $ d % 4 = 1]
  [fact $ squarefree d]
  [fact $ ¬ is_square d] :
  is_dedekind_domain (quad_ring ℤ 1 ((d - 1) / 4)) :=
begin
  haveI : fact ((d : ℚ) = 4 * ↑((d - 1) / 4) + 1), -- TODO clean up repetition of this proof
  { apply fact.mk,
    norm_cast,
    rw d_one_mod_four_fact, },
  haveI : is_integral_closure (quad_ring ℤ 1 ((d - 1) / 4)) ℤ (quad_ring ℚ 0 d) :=
    one_mod_four.is_integral_closure_1 ((d - 1) / 4) (fact.out _) _,
  exact is_integral_closure.is_dedekind_domain ℤ ℚ (quad_ring ℚ 0 d) (quad_ring ℤ 1 ((d - 1) / 4)),
  rw d_one_mod_four_fact,
  exact fact.out _,
end

end

open algebra
lemma norm_eq_one_of_mul_eq_one {d : ℤ} (hd : d ≤ 0) {st uv : quad_ring ℤ 0 d} (h : st * uv = 1) :
  norm ℤ st = 1 :=
begin
  apply_fun norm ℤ at h,
  rw [map_mul, quad_ring.norm_one] at h,
  exact int.eq_one_of_mul_eq_one_right (quad_ring.norm_nonneg hd _) h,
end

lemma units_quad {d : ℤ} (hd : d ≤ -2) (u : ℤ[√d]ˣ) : u = 1 ∨ u = -1 :=
begin
  rcases u with ⟨⟨u_val_b1, u_val_b2⟩, ⟨u_inv_b1, u_inv_b2⟩, u_val_inv, u_inv_val⟩,
  have h := norm_eq_one_of_mul_eq_one (by linarith) u_val_inv,
  rw [quad_ring.norm_eq] at h,
  have : u_val_b2 = 0,
  { nlinarith, },
  simp only [this, zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero, not_false_iff, mul_zero,
    sq_eq_one_iff, sub_zero, add_zero] at h,
  cases h; [left, right]; simpa [h, this, units.ext_iff],
end

lemma units_quad_neg_one (u : (quad_ring ℤ 0 (-1))ˣ) : u = 1 ∨ u = -1 ∨
  u = units.mk_of_mul_eq_one (⟨0,1⟩ : quad_ring ℤ 0 (-1)) (⟨0,-1⟩ : quad_ring ℤ 0 (-1)) (by calc_tac) ∨
  u = units.mk_of_mul_eq_one (⟨0,-1⟩ : quad_ring ℤ 0 (-1)) (⟨0,1⟩ : quad_ring ℤ 0 (-1)) (by calc_tac) :=
begin
  rcases u with ⟨⟨u_val_b1, u_val_b2⟩, ⟨u_inv_b1, u_inv_b2⟩, u_val_inv, u_inv_val⟩,
  have h := norm_eq_one_of_mul_eq_one (by linarith) u_val_inv,
  rw [quad_ring.norm_eq] at h,
  have hle : u_val_b2 ≤ 1,
  { nlinarith, },
  have hge : -1 ≤ u_val_b2,
  { nlinarith, },
  interval_cases u_val_b2,
  { simp only [neg_one_sq, mul_one, sub_neg_eq_add, add_left_eq_self,
      pow_eq_zero_iff, nat.succ_pos', zero_mul] at h,
    simp [h, units.ext_iff], },
  { simp only [zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero, not_false_iff,
      mul_zero, sq_eq_one_iff, sub_zero, add_zero] at h,
    cases h; [left, right]; simpa [h, units.ext_iff], },
  { simp only [one_pow, mul_one, sub_neg_eq_add, add_left_eq_self,
      pow_eq_zero_iff, nat.succ_pos', zero_mul] at h,
    simp [h, units.ext_iff], },
end

lemma units_quad_cubes {d : ℤ} (hd : d ≤ -1) (u : ℤ[√d]ˣ) : ∃ v, u = v ^ 3 :=
begin
  rw le_iff_lt_or_eq at hd,
  rcases hd with hd | rfl,
  { have : d ≤ -2,
    linarith,
    rcases units_quad this u with rfl | rfl,
    use [1], simp,
    use [-1], simp, },
  { use u⁻¹,
    rcases units_quad_neg_one u with rfl | rfl | rfl | rfl,
    { simp, },
    { simp, },
    { rw units.ext_iff,
      calc_tac, },
    { rw units.ext_iff,
      calc_tac, }, }
end

.
lemma aux (m d : zmod 9) (hd : d ∈ ({0,2,3,4,5,6,8} : set (zmod 9))) : m ^ 2 * 3 + d ≠ 1 := by dec_trivial!
-- not 1 or 7 mod 9, so sufficient is not a square mod 9
-- Big, unused
lemma aux'' (m n : zmod 9) : n * (m ^ 2 * 3 + n ^ 2 * -5) ≠ 1 := by dec_trivial!
lemma aux' (m d : zmod 3) (hd : d ∈ ({0,1} : set (zmod 3))) : -d - (m ^ 2 * 3) ≠ 1 := by dec_trivial!

lemma minpoly_int_eq {d : ℤ} [fact (¬ is_square d)] (x : ℤ[√d]) :
  (∃ y : ℤ, x = y) ∨ minpoly ℤ x = minpoly_a_add_b_sqrt_d d x.b1 x.b2 :=
begin
  haveI : fact (¬ is_square (d : ℚ)) := ⟨(rat.is_square_int_cast_iff _).not.mpr (fact.out _)⟩,
  haveI : fact (algebra_map ℤ ℚ d = d) := ⟨eq_int_cast _ _⟩,
  have inj_int : function.injective (algebra_map ℤ ℚ) := int.cast_injective,
  have inj_rat : function.injective (algebra_map ℚ ℚ(√d)) := quad_ring.coe_injective ℚ 0 d,
  have inj_quad : function.injective (algebra_map ℤ[√d] ℚ(√d)) :=
    quad_ring.algebra_map_injective _ _ _ _ inj_int,
  rcases minpoly_eq d (algebra_map _ (ℚ(√d)) x) with ⟨y, h⟩ | h,
  { have : is_integral ℤ y,
    { rw [← is_integral_algebra_map_iff inj_rat, algebra_map_apply, ← h,
          is_integral_algebra_map_iff inj_quad],
      exact quad_ring.is_integral d x,
      { convert add_comm_group.int_is_scalar_tower }, -- TODO: where is this diamond coming from?
      { apply_instance } },
    obtain ⟨y', rfl⟩ := unique_factorization_monoid.integer_of_integral this,
    rw [← algebra_map_apply, ← is_scalar_tower.algebra_map_apply,
        is_scalar_tower.algebra_map_apply ℤ ℤ[√d]] at h,
    exact or.inl ⟨y', inj_quad h⟩ },
  refine or.inr (polynomial.map_injective (algebra_map ℤ ℚ) inj_int _),
  rw [← minpoly.gcd_domain_eq_field_fractions ℚ (quad_ring ℚ 0 d) (quad_ring.is_integral d x),
      h],
  simp only [minpoly_a_add_b_sqrt_d, polynomial.map_add, polynomial.map_mul, polynomial.map_C,
    polynomial.map_X, polynomial.map_sub, polynomial.map_pow, algebra_map_b1, algebra_map_b2,
    eq_int_cast (algebra_map ℤ ℚ), int.cast_add, int.cast_mul, int.cast_sub, int.cast_pow,
    int.cast_bit0, int.cast_bit1, int.cast_zero, int.cast_one],
end

lemma minpoly_int_root (d : ℤ) [fact (¬ is_square d)] :
  minpoly ℤ (root ℤ 0 d) = minpoly_a_add_b_sqrt_d d 0 1 :=
begin
  refine (minpoly_int_eq _).resolve_left _,
  rw [not_exists],
  intros,
  rw [ext_iff, root_b2, coe_b2],
  exact mt and.right one_ne_zero
end

lemma minpoly_int_root_thirteen :
  minpoly ℤ (root ℤ 0 (-13)) = minpoly_a_add_b_sqrt_d (-13 : ℤ) 0 1 :=
by { haveI : fact ((-13 : ℤ) % 4 = 3) := ⟨by norm_num⟩, exact minpoly_int_root _ }

end rat

end sqrt_d

end quad_ring


import pseudo_normed_group.basic

local attribute [instance] type_pow

open_locale nnreal big_operators

namespace pseudo_normed_group

section splittable

class splittable (M : Type*) [pseudo_normed_group M] (N : ℕ) (d : ℝ≥0) : Prop :=
(exists_sum : ∀ (c : ℝ≥0) (x : M) (hx : x ∈ filtration M c),
  ∃ y : fin N → M, (x = ∑ i, y i) ∧ (∀ i, y i ∈ filtration M (c/N + d)))

variables {M : Type*} [pseudo_normed_group M] (N : ℕ) (d : ℝ≥0) [splittable M N d]

lemma exists_sum (c : ℝ≥0) (x : M) (hx : x ∈ filtration M c) :
  ∃ y : fin N → M, (x = ∑ i, y i) ∧ (y ∈ filtration (M^N) (c/N + d)) :=
splittable.exists_sum c x hx

instance splittable_pi {ι : Type*} (M : ι → Type*) [Π i, pseudo_normed_group (M i)]
  (N : ℕ) (d : ℝ≥0) [∀ i, splittable (M i) N d] :
  splittable (Π i, M i) N d :=
{ exists_sum := λ c x hx,
  begin
    have := λ i, exists_sum N d c (x i) (hx i),
    choose y hy1 hy2 using this,
    refine ⟨function.swap y, _, function.swap hy2⟩,
    ext i, rw [hy1], symmetry, convert finset.sum_apply i _ _,
  end }

end splittable

end pseudo_normed_group


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebraic_topology.dold_kan.functor_gamma
import category_theory.idempotents.homological_complex

/-! The counit isomorphism of the Dold-Kan equivalence

The purpose of this file is to construct natural isomorphisms
`N₁Γ₀ : Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ)`
and `N₂Γ₂ : Γ₂ ⋙ N₂ ≅ 𝟭 (karoubi (chain_complex C ℕ))`.

-/

noncomputable theory

open category_theory category_theory.category category_theory.limits category_theory.idempotents
  opposite simplicial_object
open_locale simplicial

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C] [has_finite_coproducts C]

/-- The isomorphism  `(Γ₀.splitting K).nondeg_complex ≅ K` for all `K : chain_complex C ℕ`. -/
@[simps]
def Γ₀_nondeg_complex_iso (K : chain_complex C ℕ) : (Γ₀.splitting K).nondeg_complex ≅ K :=
homological_complex.hom.iso_of_components (λ n, iso.refl _)
begin
  rintros _ n (rfl : n+1=_),
  dsimp,
  simp only [id_comp, comp_id, alternating_face_map_complex.obj_d_eq,
    preadditive.sum_comp, preadditive.comp_sum],
  rw fintype.sum_eq_single (0 : fin (n+2)),
  { simp only [fin.coe_zero, pow_zero, one_zsmul],
    erw [Γ₀.obj.map_mono_on_summand_id_assoc, Γ₀.obj.termwise.map_mono_δ₀,
      splitting.ι_π_summand_eq_id, comp_id], },
  { intros i hi,
    dsimp,
    simp only [preadditive.zsmul_comp, preadditive.comp_zsmul, assoc],
    erw [Γ₀.obj.map_mono_on_summand_id_assoc, Γ₀.obj.termwise.map_mono_eq_zero,
      zero_comp, zsmul_zero],
    { intro h,
      replace h := congr_arg simplex_category.len h,
      change n+1 = n at h,
      linarith, },
    { simpa only [is_δ₀.iff] using hi, }, },
end

/-- The natural isomorphism `(Γ₀.splitting K).nondeg_complex ≅ K` for `K : chain_complex C ℕ`. -/
def Γ₀'_comp_nondeg_complex_functor :
  Γ₀' ⋙ split.nondeg_complex_functor ≅ 𝟭 (chain_complex C ℕ) :=
nat_iso.of_components Γ₀_nondeg_complex_iso
  (λ X Y f, by { ext n, dsimp, simp only [comp_id, id_comp], })

/-- The natural isomorphism `Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ)`. -/
def N₁Γ₀ : Γ₀ ⋙ N₁ ≅ to_karoubi (chain_complex C ℕ) :=
calc Γ₀ ⋙ N₁ ≅ Γ₀' ⋙ split.forget C ⋙ N₁ : functor.associator _ _ _
... ≅ Γ₀' ⋙ split.nondeg_complex_functor ⋙ to_karoubi _ :
  iso_whisker_left Γ₀' split.to_karoubi_nondeg_complex_functor_iso_N₁.symm
... ≅ (Γ₀' ⋙ split.nondeg_complex_functor) ⋙ to_karoubi _ : (functor.associator _ _ _).symm
... ≅ 𝟭 _ ⋙ to_karoubi (chain_complex C ℕ) : iso_whisker_right Γ₀'_comp_nondeg_complex_functor _
... ≅ to_karoubi (chain_complex C ℕ) : functor.left_unitor _

lemma N₁Γ₀_app (K : chain_complex C ℕ) :
  N₁Γ₀.app K = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.symm
    ≪≫ (to_karoubi _).map_iso (Γ₀_nondeg_complex_iso K) :=
begin
  ext1,
  dsimp [N₁Γ₀],
  erw [id_comp, comp_id, comp_id],
  refl,
end

lemma N₁Γ₀_hom_app (K : chain_complex C ℕ) :
  N₁Γ₀.hom.app K = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.inv
    ≫ (to_karoubi _).map (Γ₀_nondeg_complex_iso K).hom :=
by { change (N₁Γ₀.app K).hom = _, simpa only [N₁Γ₀_app], }

lemma N₁Γ₀_inv_app (K : chain_complex C ℕ) :
  N₁Γ₀.inv.app K = (to_karoubi _).map (Γ₀_nondeg_complex_iso K).inv ≫
   (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.hom :=
by { change (N₁Γ₀.app K).inv = _, simpa only [N₁Γ₀_app], }

@[simp]
lemma N₁Γ₀_hom_app_f_f (K : chain_complex C ℕ) (n : ℕ) :
  (N₁Γ₀.hom.app K).f.f n = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.inv.f.f n :=
by { rw N₁Γ₀_hom_app, apply comp_id, }

@[simp]
lemma N₁Γ₀_inv_app_f_f (K : chain_complex C ℕ) (n : ℕ) :
  (N₁Γ₀.inv.app K).f.f n = (Γ₀.splitting K).to_karoubi_nondeg_complex_iso_N₁.hom.f.f n :=
by { rw N₁Γ₀_inv_app, apply id_comp, }

lemma N₂Γ₂_to_karoubi : to_karoubi (chain_complex C ℕ) ⋙ Γ₂ ⋙ N₂ = Γ₀ ⋙ N₁ :=
begin
  have h := functor.congr_obj (functor_extension₂_comp_whiskering_left_to_karoubi
    (chain_complex C ℕ) (simplicial_object C)) Γ₀,
  have h' := functor.congr_obj (functor_extension₁_comp_whiskering_left_to_karoubi
    (simplicial_object C) (chain_complex C ℕ)) N₁,
  dsimp [N₂, Γ₂, functor_extension₁] at h h' ⊢,
  rw [← functor.assoc, h, functor.assoc, h'],
end

/-- Compatibility isomorphism between `to_karoubi _ ⋙ Γ₂ ⋙ N₂` and `Γ₀ ⋙ N₁` which
are functors `chain_complex C ℕ ⥤ karoubi (chain_complex C ℕ)`. -/
@[simps]
def N₂Γ₂_to_karoubi_iso : to_karoubi (chain_complex C ℕ) ⋙ Γ₂ ⋙ N₂ ≅ Γ₀ ⋙ N₁ :=
eq_to_iso (N₂Γ₂_to_karoubi)

/-- The counit isomorphism of the Dold-Kan equivalence for additive categories. -/
def N₂Γ₂ : Γ₂ ⋙ N₂ ≅ 𝟭 (karoubi (chain_complex C ℕ)) :=
((whiskering_left _ _ _).obj (to_karoubi (chain_complex C ℕ))).preimage_iso
  (N₂Γ₂_to_karoubi_iso ≪≫ N₁Γ₀)

lemma N₂Γ₂_compatible_with_N₁Γ₀ (K : chain_complex C ℕ) :
  N₂Γ₂.hom.app ((to_karoubi _).obj K) = N₂Γ₂_to_karoubi_iso.hom.app K ≫ N₁Γ₀.hom.app K :=
congr_app (((whiskering_left _ _ (karoubi (chain_complex C ℕ ))).obj
  (to_karoubi (chain_complex C ℕ))).image_preimage
  (N₂Γ₂_to_karoubi_iso.hom ≫ N₁Γ₀.hom : _ ⟶ to_karoubi _ ⋙ 𝟭 _)) K

@[simp]
lemma N₂Γ₂_inv_app_f_f (X : karoubi (chain_complex C ℕ)) (n : ℕ) :
  (N₂Γ₂.inv.app X).f.f n =
    X.p.f n ≫ (Γ₀.splitting X.X).ι_summand (splitting.index_set.id (op [n])) :=
begin
  dsimp only [N₂Γ₂, functor.preimage_iso, iso.trans],
  simp only [whiskering_left_obj_preimage_app, N₂Γ₂_to_karoubi_iso_inv, functor.id_map,
    nat_trans.comp_app, eq_to_hom_app, functor.comp_map, assoc, karoubi.comp_f,
    karoubi.eq_to_hom_f, eq_to_hom_refl, comp_id, karoubi.comp_p_assoc, N₂_map_f_f,
    homological_complex.comp_f, N₁Γ₀_inv_app_f_f, P_infty_on_Γ₀_splitting_summand_eq_self_assoc,
    splitting.to_karoubi_nondeg_complex_iso_N₁_hom_f_f, Γ₂_map_f_app, karoubi.decomp_id_p_f],
  dsimp [to_karoubi],
  rw [splitting.ι_desc],
  dsimp [splitting.index_set.id],
  rw karoubi.homological_complex.p_idem_assoc,
end

end dold_kan

end algebraic_topology


import for_mathlib.exact_seq3
import for_mathlib.bicartesian2
.

open category_theory category_theory.limits

universe u
local notation `𝓐` := Ab.{u}

-- Consider the following diagram
variables {     Kv₁   Kv₂        : 𝓐}
variables {Kh₁  A₁₁   A₁₂  Qh₁   : 𝓐}
variables {Kh₂  A₂₁   A₂₂  Qh₂   : 𝓐}
variables {     Qv₁   Qv₂        : 𝓐}
-- with morphisms
variables                         (fKv : Kv₁ ⟶ Kv₂)
variables                 {ιv₁ : Kv₁ ⟶ A₁₁} {ιv₂ : Kv₂ ⟶ A₁₂}
variables         {ιh₁ : Kh₁ ⟶ A₁₁} {f₁ : A₁₁ ⟶ A₁₂} {πh₁ : A₁₂ ⟶ Qh₁}
variables (gKh : Kh₁ ⟶ Kh₂) {g₁ : A₁₁ ⟶ A₂₁} {g₂ : A₁₂ ⟶ A₂₂} (gQh : Qh₁ ⟶ Qh₂)
variables         {ιh₂ : Kh₂ ⟶ A₂₁} {f₂ : A₂₁ ⟶ A₂₂} {πh₂ : A₂₂ ⟶ Qh₂}
variables                 {πv₁ : A₂₁ ⟶ Qv₁}  {πv₂ : A₂₂ ⟶ Qv₂}
variables                         (fQv : Qv₁ ⟶ Qv₂)
-- with exact rows and columns
variables (H₁ : exact_seq 𝓐 [ιh₁, f₁, πh₁])
variables (H₂ : exact_seq 𝓐 [ιh₂, f₂, πh₂])
variables (V₁ : exact_seq 𝓐 [ιv₁, g₁, πv₁])
variables (V₂ : exact_seq 𝓐 [ιv₂, g₂, πv₂])
-- and such that all the extremal maps are appropriately monos or epis
variables [mono ιv₁] [mono ιv₂] [mono ιh₁] [mono ιh₂]
variables [epi πv₁] [epi πv₂] [epi πh₁] [epi πh₂]
-- of course the diagram should commute
variables (sqᵤ : commsq fKv ιv₁ ιv₂ f₁)
variables (sqₗ : commsq ιh₁ gKh g₁ ιh₂) (sqm : commsq f₁ g₁ g₂ f₂)
variables (sqᵣ : commsq πh₁ g₂ gQh πh₂)
variables (sqₛ : commsq f₂ πv₁ πv₂ fQv)

open_locale zero_object
open category_theory.abelian

def is_limit_of_is_limit_comp {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z}
  {c : kernel_fork (f ≫ g)} (hc : is_limit c) (h : c.ι ≫ f = 0) :
  is_limit (kernel_fork.of_ι c.ι h) :=
is_limit.of_ι _ _
  (λ T l hl, hc.lift (kernel_fork.of_ι l (by rw [reassoc_of hl, zero_comp])))
  (λ T l hl, hc.fac _ _)
  (λ T l hl m hm, fork.is_limit.hom_ext hc (by { erw [hm, hc.fac], refl }))

def is_colimit_of_is_colimit_comp {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z}
  {c : cokernel_cofork (f ≫ g)} (hc : is_colimit c) (h : g ≫ c.π = 0) :
  is_colimit (cokernel_cofork.of_π c.π h) :=
is_colimit.of_π _ _
  (λ T l hl, hc.desc (cokernel_cofork.of_π l (by rw [category.assoc, hl, comp_zero])))
  (λ T l hl, hc.fac _ _)
  (λ T l hl m hm, cofork.is_colimit.hom_ext hc (by { erw [hm, hc.fac], refl }))

section
include sqₗ sqm

lemma is_iso_of_is_limit (H₁ : exact ιh₁ f₁) (H₂ : exact ιh₂ f₂)
  (h : is_limit (pullback_cone.mk f₁ g₁ sqm.w)) : is_iso gKh :=
begin
  haveI : mono gKh,
  { refine preadditive.mono_of_cancel_zero _ (λ P g hg, _),
    apply zero_of_comp_mono ιh₁,
    apply pullback_cone.is_limit.hom_ext h,
    { rw [pullback_cone.mk_fst, category.assoc, zero_comp, H₁.w, comp_zero] },
    { rw [pullback_cone.mk_snd, category.assoc, sqₗ.w, ← category.assoc, hg, zero_comp,
        zero_comp] } },
  obtain ⟨l, hl₁, hl₂ : l ≫ g₁ = _⟩ :=
    pullback_cone.is_limit.lift' h 0 ιh₂ (by simp [H₂.w]),
  let ker := is_limit_of_exact_of_mono _ _ H₁,
  obtain ⟨inv, hinv : inv ≫ ιh₁ = l⟩ := kernel_fork.is_limit.lift' ker l hl₁,
  have hinv' : inv ≫ gKh = 𝟙 _,
   { rw [← cancel_mono ιh₂, category.assoc, ← sqₗ.w, reassoc_of hinv, hl₂, category.id_comp] },
  refine ⟨⟨inv, _, hinv'⟩⟩,
  rw [← cancel_mono gKh, category.assoc, hinv', category.comp_id, category.id_comp]
end

end

section
include sqm sqᵣ

lemma is_iso_of_is_colimit (H₁ : exact f₁ πh₁) (H₂ : exact f₂ πh₂)
  (h : is_colimit (pushout_cocone.mk _ _ sqm.w)) : is_iso gQh :=
begin
  haveI : epi gQh,
  { refine preadditive.epi_of_cancel_zero _ (λ P g hg, _),
    apply zero_of_epi_comp πh₂,
    apply pushout_cocone.is_colimit.hom_ext h,
    { rw [pushout_cocone.mk_inl, ← category.assoc, ← sqᵣ.w, category.assoc, hg, comp_zero,
        comp_zero] },
    { rw [pushout_cocone.mk_inr, ← category.assoc, H₂.w, comp_zero, zero_comp] } },
  obtain ⟨l, hl₁ : g₂ ≫ l = _, hl₂⟩ :=
    pushout_cocone.is_colimit.desc' h πh₁ 0 (by simp [H₁.w]),
  let coker := is_colimit_of_exact_of_epi _ _ H₂,
  obtain ⟨inv, hinv : πh₂ ≫ inv = l⟩ := cokernel_cofork.is_colimit.desc' coker l hl₂,
  have hinv' : gQh ≫ inv = 𝟙 _,
  { rw [← cancel_epi πh₁, ← category.assoc, sqᵣ.w, category.assoc, hinv, hl₁, category.comp_id] },
  refine ⟨⟨inv, hinv', _⟩⟩,
  rw [← cancel_epi gQh, reassoc_of hinv', category.comp_id]
end

end

include H₁ H₂ sqₗ sqm sqᵣ

lemma commsq.bicartesian_iff_isos : sqm.bicartesian ↔ (is_iso gKh ∧ is_iso gQh) :=
begin
  split,
  { intro h, split,
    { exact is_iso_of_is_limit gKh sqₗ sqm ((exact_iff_exact_seq _ _).2 (H₁.extract 0 2))
      ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) h.is_limit },
    { exact is_iso_of_is_colimit gQh sqm sqᵣ ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2))
      ((exact_iff_exact_seq _ _).2 (H₂.extract 1 2)) h.is_colimit } },
  { rintros ⟨gKh_iso, gQh_iso⟩,
    resetI,
    apply commsq.bicartesian.of_is_limit_of_is_colimt,
    { apply is_limit.of_point_iso (limit.is_limit _),
      { apply_instance },
      { let r := pullback.lift _ _ sqm.w,
        let x : Kh₁ ⟶ kernel (pullback.fst : pullback g₂ f₂ ⟶ A₁₂),
        { refine kernel.lift _ (ιh₁ ≫ r) _,
          simp only [(H₁.extract 0 2).w, category.assoc, pullback.lift_fst] },
        haveI : is_iso x,
        { let psq := commsq.of_eq (@pullback.condition _ _ _ _ _ g₂ f₂ _),
          let hker := abelian.is_limit_of_exact_of_mono _ _
            ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)),
          obtain ⟨u : _ ⟶ Kh₂, hu⟩ := kernel_fork.is_limit.lift' hker
            (kernel.ι (pullback.fst : pullback g₂ f₂ ⟶ A₁₂) ≫ pullback.snd) _,
          { rw fork.ι_of_ι at hu,
            let lsq := commsq.of_eq hu.symm,
            haveI : is_iso u := is_iso_of_is_limit u lsq psq _ _ _,
            { have hxu : x ≫ u = gKh,
              { simp only [← cancel_mono ιh₂, category.assoc, hu, x, kernel.lift_ι_assoc, r,
                pullback.lift_snd, sqₗ.w] },
              have hx : x = gKh ≫ inv u,
              { rw [← is_iso.comp_inv_eq, is_iso.inv_inv, hxu] },
              rw hx,
              apply_instance },
            { exact exact_kernel_ι },
            { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) },
            { exact pullback_is_pullback _ _ } },
          { rw [category.assoc, ← pullback.condition, kernel.condition_assoc, zero_comp] } },
        refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso _ _ _ 0 _ _ _ 0 _ _ _
         0 ιh₁ f₁ 0 (kernel.ι (pullback.fst : pullback g₂ f₂ ⟶ A₁₂)) pullback.fst 0 x r (𝟙 _)
         _ _ _ _ _ πh₁ πh₁ (𝟙 _) _ _ _ _ _ _ _ _ _ _ _,
        { simp only [eq_iff_true_of_subsingleton] },
        { simp only [kernel.lift_ι] },
        { simp only [pullback.lift_fst, category.comp_id] },
        { simp only [category.id_comp, category.comp_id] },
        { exact exact_zero_mono ιh₁ },
        { exact (exact_iff_exact_seq _ _).2 (H₁.extract 0 2) },
        { exact (exact_iff_exact_seq _ _).2 (H₁.extract 1 2) },
        { exact exact_zero_mono (kernel.ι pullback.fst) },
        { exact exact_kernel_ι },
        { have : (pullback.fst : pullback g₂ f₂ ⟶ A₁₂) ≫ πh₁ = 0,
          { apply zero_of_comp_mono gQh,
            rw [category.assoc, sqᵣ.w, pullback.condition_assoc, (H₂.extract 1 2).w, comp_zero] },
          apply abelian.exact_of_is_cokernel _ _ this,
          have hex := (exact_iff_exact_seq _ _).2 (H₁.extract 1 2),
          rw ← pullback.lift_fst _ _ sqm.w at hex,
          exact is_colimit_of_is_colimit_comp (abelian.is_colimit_of_exact_of_epi _ _ hex) _ } } },
    { apply is_colimit.of_point_iso (colimit.is_colimit _),
      { apply_instance },
      { let r := pushout.desc _ _ sqm.w,
        let x : cokernel (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) ⟶ Qh₂,
        { refine cokernel.desc _ (r ≫ πh₂) _,
          simp only [(H₂.extract 1 2).w, ← category.assoc, pushout.inr_desc] },
        haveI : is_iso x,
        { let psq := commsq.of_eq (@pushout.condition _ _ _ _ _ f₁ g₁ _),
          let hcoker := abelian.is_colimit_of_exact_of_epi _ _
            ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2)),
          obtain ⟨u : Qh₁ ⟶ _, hu⟩ := cokernel_cofork.is_colimit.desc' hcoker
            (pushout.inl ≫ (cokernel.π (pushout.inr : A₂₁ ⟶ pushout f₁ g₁))) _,
          { rw cofork.π_of_π at hu,
            let lsq := commsq.of_eq hu,
            haveI : is_iso u := is_iso_of_is_colimit u psq lsq _ _ _,
            { have hxu : u ≫ x = gQh,
              { simp only [← cancel_epi πh₁, hu, x, cokernel.π_desc, reassoc_of hu, r,
                  pushout.inl_desc_assoc, sqᵣ.w] },
              have hx : x = inv u ≫ gQh,
              { rw [← is_iso.inv_comp_eq, is_iso.inv_inv, hxu] },
              rw hx,
              apply_instance },
            { exact ((exact_iff_exact_seq _ _).2 (H₁.extract 1 2)) },
            { exact exact_cokernel pushout.inr },
            { exact pushout_is_pushout _ _ } },
          { rw [← category.assoc, pushout.condition, category.assoc, cokernel.condition,
              comp_zero] } },
        refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso _ _ _ _ _ _ _ _ _ _ _
          ιh₂ (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) (cokernel.π (pushout.inr : A₂₁ ⟶ pushout f₁ g₁))
          ιh₂ f₂ πh₂ (𝟙 _) (𝟙 _) r x _ _ _ 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _,
        { simp only [category.id_comp, category.comp_id] },
        { simp only [category.id_comp, pushout.inr_desc] },
        { simp only [cokernel.π_desc] },
        { simp only [eq_iff_true_of_subsingleton] },
        { have : ιh₂ ≫ (pushout.inr : A₂₁ ⟶ pushout f₁ g₁) = 0,
          { apply zero_of_epi_comp gKh,
            rw [← sqₗ.w_assoc, ← pushout.condition, reassoc_of (H₁.extract 0 2).w, zero_comp] },
          apply abelian.exact_of_is_kernel _ _ this,
          have hex := (exact_iff_exact_seq _ _).2 (H₂.extract 0 2),
          rw ← pushout.inr_desc _ _ sqm.w at hex,
          exact is_limit_of_is_limit_comp (abelian.is_limit_of_exact_of_mono _ _ hex) _ },
        { exact exact_cokernel pushout.inr },
        { exact exact_epi_zero (cokernel.π pushout.inr) },
        { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 0 2)) },
        { exact ((exact_iff_exact_seq _ _).2 (H₂.extract 1 2)) },
        { exact exact_epi_zero πh₂ } } } }
end


def top := ∀ p : Prop, p → p
def pext := ∀ (A B : Prop), A → B → A = B
def supercast (h : pext) (A B : Prop) (a : A) (b : B) : B
  := @cast A B (h A B a b) a
def omega : pext → top :=
  λ h A a => supercast h (top → top) A
    (λ z: top => z (top → top) (λ x => x) z) a
def Omega : pext → top :=
  λ h => omega h (top → top) (λ x => x) (omega h)
def Omega' : pext → top := λ h => (λ p x => x)

theorem loopy : Omega = Omega' := rfl


import Iris.BI
import Iris.Instances.Data

namespace Iris.Examples
open Iris.BI Iris.Instances.Data

/- This file shows how to instantiate the type class `BIBase` with a setoid / quotient type. The
separation logic in this example is classical separation logic, even though setoids are not
required here. For an example instance of `BIBase` and `BI` for classical separation logic without
setoids see `Iris/Instances/Classical`. -/

abbrev HeapProp (Val : Type) := State Val → Prop

instance heapPropSetoid (Val : Type) : Setoid (HeapProp Val) where
  r P Q := ∀ σ, P σ ↔ Q σ
  iseqv := {
    refl := by
      intro _ _
      exact Iff.refl _
    symm := by
      intro _ _ h σ
      apply Iff.symm
      exact h σ
    trans := by
      intro _ _ _ h_xy h_yz σ
      exact Iff.trans (h_xy σ) (h_yz σ)
  }

instance (Val : Type) : BIBase (Quotient (heapPropSetoid Val)) where
  entails P Q := Quotient.liftOn₂ P Q (fun P Q => ∀ σ, P σ → Q σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    apply forall_congr
    intro σ
    rw [h₁ σ, h₂ σ])
  emp := Quotient.mk _ fun σ => σ = ∅
  pure φ := Quotient.mk _ fun _ => φ
  and P Q := Quotient.mk _ fun σ => Quotient.liftOn₂ P Q (fun P Q => P σ ∧ Q σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    rw [h₁ σ, h₂ σ])
  or P Q := Quotient.mk _ fun σ => Quotient.liftOn₂ P Q (fun P Q => P σ ∨ Q σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    rw [h₁ σ, h₂ σ])
  impl P Q := Quotient.mk _ fun σ => Quotient.liftOn₂ P Q (fun P Q => P σ → Q σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    rw [h₁ σ, h₂ σ])
  «forall» Ψ := Quotient.mk _ fun σ => ∀ a, Quotient.liftOn (Ψ a) (fun P => P σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ h
    rw [h σ])
  exist Ψ := Quotient.mk _ fun σ => ∃ a, Quotient.liftOn (Ψ a) (fun P => P σ) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ h
    rw [h σ])
  sep P Q := Quotient.mk _ fun σ => Quotient.liftOn₂ P Q (fun P Q => ∃ σ₁ σ₂ , σ = σ₁ ∪ σ₂ ∧ σ₁ || σ₂ ∧ P σ₁ ∧ Q σ₂) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    apply propext ?_
    constructor
    case' mp =>
      intro ⟨σ₁, σ₂, h⟩
      rw [h₁ σ₁, h₂ σ₂] at h
    case' mpr =>
      intro ⟨σ₁, σ₂, h⟩
      rw [← h₁ σ₁, ← h₂ σ₂] at h
    all_goals
      apply Exists.intro σ₁
      apply Exists.intro σ₂
      exact h)
  wand P Q := Quotient.mk _ fun σ => Quotient.liftOn₂ P Q (fun P Q => ∀ σ', σ || σ' → P σ' → Q (σ ∪ σ')) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ _ _ h₁ h₂
    apply forall_congr
    intro σ'
    rw [h₁ σ', h₂ (σ ∪ σ')])
  persistently P := Quotient.mk _ fun _ => Quotient.liftOn P (fun P => P ∅) (by
    simp only [HasEquiv.Equiv, Setoid.r]
    intro _ _ h
    rw [h ∅])

end Iris.Examples