/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.basic
import Mathlib.category_theory.adjunction.basic
import Mathlib.category_theory.reflects_isomorphisms
import Mathlib.PostPort

universes v₁ u₁ l

namespace Mathlib

/-!
# Eilenberg-Moore (co)algebras for a (co)monad

This file defines Eilenberg-Moore (co)algebras for a (co)monad,
and provides the category instance for them.

Further it defines the adjoint pair of free and forgetful functors, respectively
from and to the original category, as well as the adjoint pair of forgetful and
cofree functors, respectively from and to the original category.

## References
* [Riehl, *Category theory in context*, Section 5.2.4][riehl2017]
-/

namespace category_theory

namespace monad

/-- An Eilenberg-Moore algebra for a monad `T`.
    cf Definition 5.2.3 in [Riehl][riehl2017]. -/
structure algebra {C : Type u₁} [category C] (T : C ⥤ C) [monad T]
where
  A : C
  a : functor.obj T A ⟶ A
  unit' : autoParam (nat_trans.app η_ A ≫ a = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  assoc' : autoParam (nat_trans.app μ_ A ≫ a = functor.map T a ≫ a)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

theorem algebra.unit {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (c : algebra T) : nat_trans.app η_ (algebra.A c) ≫ algebra.a c = 𝟙 := sorry

theorem algebra.assoc {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (c : algebra T) : nat_trans.app μ_ (algebra.A c) ≫ algebra.a c = functor.map T (algebra.a c) ≫ algebra.a c := sorry

theorem algebra.assoc_assoc {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (c : algebra T) {X' : C} (f' : algebra.A c ⟶ X') : nat_trans.app μ_ (algebra.A c) ≫ algebra.a c ≫ f' = functor.map T (algebra.a c) ≫ algebra.a c ≫ f' := sorry

namespace algebra

/-- A morphism of Eilenberg–Moore algebras for the monad `T`. -/
structure hom {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (A : algebra T) (B : algebra T)
where
  f : A A ⟶ A B
  h' : autoParam (functor.map T f ≫ a B = a A ≫ f)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.h {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {A : algebra T} {B : algebra T} (c : hom A B) : functor.map T (hom.f c) ≫ a B = a A ≫ hom.f c := sorry

@[simp] theorem hom.h_assoc {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {A : algebra T} {B : algebra T} (c : hom A B) {X' : C} (f' : A B ⟶ X') : functor.map T (hom.f c) ≫ a B ≫ f' = a A ≫ hom.f c ≫ f' := sorry

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore algebra. -/
def id {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (A : algebra T) : hom A A :=
  mk 𝟙

protected instance inhabited {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (A : algebra T) : Inhabited (hom A A) :=
  { default := mk 𝟙 }

/-- Composition of Eilenberg–Moore algebra homomorphisms. -/
def comp {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {P : algebra T} {Q : algebra T} {R : algebra T} (f : hom P Q) (g : hom Q R) : hom P R :=
  mk (f f ≫ f g)

end hom

protected instance category_theory.category_struct {C : Type u₁} [category C] {T : C ⥤ C} [monad T] : category_struct (algebra T) :=
  category_struct.mk hom.id hom.comp

@[simp] theorem comp_eq_comp {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {A : algebra T} {A' : algebra T} {A'' : algebra T} (f : A ⟶ A') (g : A' ⟶ A'') : hom.comp f g = f ≫ g :=
  rfl

@[simp] theorem id_eq_id {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (A : algebra T) : hom.id A = 𝟙 :=
  rfl

@[simp] theorem id_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T] (A : algebra T) : hom.f 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {A : algebra T} {A' : algebra T} {A'' : algebra T} (f : A ⟶ A') (g : A' ⟶ A'') : hom.f (f ≫ g) = hom.f f ≫ hom.f g :=
  rfl

/-- The category of Eilenberg-Moore algebras for a monad.
    cf Definition 5.2.4 in [Riehl][riehl2017]. -/
protected instance EilenbergMoore {C : Type u₁} [category C] {T : C ⥤ C} [monad T] : category (algebra T) :=
  category.mk

/--
To construct an isomorphism of algebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simp] theorem iso_mk_hom_f {C : Type u₁} [category C] {T : C ⥤ C} [monad T] {A : algebra T} {B : algebra T} (h : A A ≅ A B) (w : functor.map T (iso.hom h) ≫ a B = a A ≫ iso.hom h) : hom.f (iso.hom (iso_mk h w)) = iso.hom h :=
  Eq.refl (hom.f (iso.hom (iso_mk h w)))

end algebra

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the algebraic structure. -/
@[simp] theorem forget_map {C : Type u₁} [category C] (T : C ⥤ C) [monad T] (A : algebra T) (B : algebra T) (f : A ⟶ B) : functor.map (forget T) f = algebra.hom.f f :=
  Eq.refl (functor.map (forget T) f)

/-- The free functor from the Eilenberg-Moore category, constructing an algebra for any object. -/
@[simp] theorem free_obj_A {C : Type u₁} [category C] (T : C ⥤ C) [monad T] (X : C) : algebra.A (functor.obj (free T) X) = functor.obj T X :=
  Eq.refl (algebra.A (functor.obj (free T) X))

protected instance algebra.inhabited {C : Type u₁} [category C] (T : C ⥤ C) [monad T] [Inhabited C] : Inhabited (algebra T) :=
  { default := functor.obj (free T) Inhabited.default }

/-- The adjunction between the free and forgetful constructions for Eilenberg-Moore algebras for a monad.
    cf Lemma 5.2.8 of [Riehl][riehl2017]. -/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if

-- those are added too

@[simp] theorem adj_counit {C : Type u₁} [category C] (T : C ⥤ C) [monad T] : adjunction.counit (adj T) =
  nat_trans.mk
    fun (Y : algebra T) =>
      equiv.inv_fun
        (adjunction.core_hom_equiv.hom_equiv
          (adjunction.core_hom_equiv.mk
            fun (X : C) (Y : algebra T) =>
              equiv.mk (fun (f : functor.obj (free T) X ⟶ Y) => nat_trans.app η_ X ≫ algebra.hom.f f)
                (fun (f : X ⟶ functor.obj (forget T) Y) => algebra.hom.mk (functor.map T f ≫ algebra.a Y))
                (adj._proof_2 T X Y) (adj._proof_3 T X Y))
          (functor.obj (forget T) Y) (functor.obj 𝟭 Y))
        𝟙 :=
  Eq.refl (adjunction.counit (adj T))

/--
Given an algebra morphism whose carrier part is an isomorphism, we get an algebra isomorphism.
-/
def algebra_iso_of_iso {C : Type u₁} [category C] (T : C ⥤ C) [monad T] {A : algebra T} {B : algebra T} (f : A ⟶ B) [is_iso (algebra.hom.f f)] : is_iso f :=
  is_iso.mk (algebra.hom.mk (inv (algebra.hom.f f)))

protected instance forget_reflects_iso {C : Type u₁} [category C] (T : C ⥤ C) [monad T] : reflects_isomorphisms (forget T) :=
  reflects_isomorphisms.mk fun (A B : algebra T) => algebra_iso_of_iso T

protected instance forget_faithful {C : Type u₁} [category C] (T : C ⥤ C) [monad T] : faithful (forget T) :=
  faithful.mk

end monad

namespace comonad

/-- An Eilenberg-Moore coalgebra for a comonad `T`. -/
structure coalgebra {C : Type u₁} [category C] (G : C ⥤ C) [comonad G]
where
  A : C
  a : A ⟶ functor.obj G A
  counit' : autoParam (a ≫ nat_trans.app ε_ A = 𝟙)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  coassoc' : autoParam (a ≫ nat_trans.app δ_ A = a ≫ functor.map G a)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

theorem coalgebra.counit {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (c : coalgebra G) : coalgebra.a c ≫ nat_trans.app ε_ (coalgebra.A c) = 𝟙 := sorry

theorem coalgebra.coassoc {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (c : coalgebra G) : coalgebra.a c ≫ nat_trans.app δ_ (coalgebra.A c) = coalgebra.a c ≫ functor.map G (coalgebra.a c) := sorry

theorem coalgebra.counit_assoc {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (c : coalgebra G) {X' : C} (f' : coalgebra.A c ⟶ X') : coalgebra.a c ≫ nat_trans.app ε_ (coalgebra.A c) ≫ f' = f' := sorry

namespace coalgebra

/-- A morphism of Eilenberg-Moore coalgebras for the comonad `G`. -/
structure hom {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (A : coalgebra G) (B : coalgebra G)
where
  f : A A ⟶ A B
  h' : autoParam (a A ≫ functor.map G f = f ≫ a B)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.h {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {A : coalgebra G} {B : coalgebra G} (c : hom A B) : a A ≫ functor.map G (hom.f c) = hom.f c ≫ a B := sorry

@[simp] theorem hom.h_assoc {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {A : coalgebra G} {B : coalgebra G} (c : hom A B) {X' : C} (f' : functor.obj G (A B) ⟶ X') : a A ≫ functor.map G (hom.f c) ≫ f' = hom.f c ≫ a B ≫ f' := sorry

namespace hom

/-- The identity homomorphism for an Eilenberg–Moore coalgebra. -/
def id {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (A : coalgebra G) : hom A A :=
  mk 𝟙

/-- Composition of Eilenberg–Moore coalgebra homomorphisms. -/
def comp {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {P : coalgebra G} {Q : coalgebra G} {R : coalgebra G} (f : hom P Q) (g : hom Q R) : hom P R :=
  mk (f f ≫ f g)

end hom

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
protected instance category_theory.category_struct {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] : category_struct (coalgebra G) :=
  category_struct.mk hom.id hom.comp

@[simp] theorem comp_eq_comp {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {A : coalgebra G} {A' : coalgebra G} {A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') : hom.comp f g = f ≫ g :=
  rfl

@[simp] theorem id_eq_id {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (A : coalgebra G) : hom.id A = 𝟙 :=
  rfl

@[simp] theorem id_f {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] (A : coalgebra G) : hom.f 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_f {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {A : coalgebra G} {A' : coalgebra G} {A'' : coalgebra G} (f : A ⟶ A') (g : A' ⟶ A'') : hom.f (f ≫ g) = hom.f f ≫ hom.f g :=
  rfl

/-- The category of Eilenberg-Moore coalgebras for a comonad. -/
protected instance EilenbergMoore {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] : category (coalgebra G) :=
  category.mk

/--
To construct an isomorphism of coalgebras, it suffices to give an isomorphism of the carriers which
commutes with the structure morphisms.
-/
@[simp] theorem iso_mk_hom_f {C : Type u₁} [category C] {G : C ⥤ C} [comonad G] {A : coalgebra G} {B : coalgebra G} (h : A A ≅ A B) (w : a A ≫ functor.map G (iso.hom h) = iso.hom h ≫ a B) : hom.f (iso.hom (iso_mk h w)) = iso.hom h :=
  Eq.refl (hom.f (iso.hom (iso_mk h w)))

end coalgebra

/-- The forgetful functor from the Eilenberg-Moore category, forgetting the coalgebraic structure. -/
def forget {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] : coalgebra G ⥤ C :=
  functor.mk (fun (A : coalgebra G) => coalgebra.A A) fun (A B : coalgebra G) (f : A ⟶ B) => coalgebra.hom.f f

/--
Given a coalgebra morphism whose carrier part is an isomorphism, we get a coalgebra isomorphism.
-/
def coalgebra_iso_of_iso {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] {A : coalgebra G} {B : coalgebra G} (f : A ⟶ B) [is_iso (coalgebra.hom.f f)] : is_iso f :=
  is_iso.mk (coalgebra.hom.mk (inv (coalgebra.hom.f f)))

protected instance forget_reflects_iso {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] : reflects_isomorphisms (forget G) :=
  reflects_isomorphisms.mk fun (A B : coalgebra G) => coalgebra_iso_of_iso G

/-- The cofree functor from the Eilenberg-Moore category, constructing a coalgebra for any object. -/
@[simp] theorem cofree_map_f {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] (X : C) (Y : C) (f : X ⟶ Y) : coalgebra.hom.f (functor.map (cofree G) f) = functor.map G f :=
  Eq.refl (coalgebra.hom.f (functor.map (cofree G) f))

/--
The adjunction between the cofree and forgetful constructions for Eilenberg-Moore coalgebras
for a comonad.
-/
-- The other two `simps` projection lemmas can be derived from these two, so `simp_nf` complains if

-- those are added too

@[simp] theorem adj_counit {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] : adjunction.counit (adj G) = nat_trans.mk (nat_trans.app ε_) := sorry

protected instance forget_faithful {C : Type u₁} [category C] (G : C ⥤ C) [comonad G] : faithful (forget G) :=
  faithful.mk


/-
Copyright (c) 2020 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.lint.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Linter for simplification lemmas

This files defines several linters that prevent common mistakes when declaring simp lemmas:

 * `simp_nf` checks that the left-hand side of a simp lemma is not simplified by a different lemma.
 * `simp_var_head` checks that the head symbol of the left-hand side is not a variable.
 * `simp_comm` checks that commutativity lemmas are not marked as simplification lemmas.
-/

/-- `simp_lhs_rhs ty` returns the left-hand and right-hand side of a simp lemma with type `ty`. -/
-- We only detect a fixed set of simp relations here.

-- This is somewhat justified since for a custom simp relation R,

-- the simp lemma `R a b` is implicitly converted to `R a b ↔ true` as well.

/-- `simp_lhs ty` returns the left-hand side of a simp lemma with type `ty`. -/
/--
`simp_is_conditional_core ty` returns `none` if `ty` is a conditional simp
lemma, and `some lhs` otherwise.
-/
/--
`simp_is_conditional ty` returns true iff the simp lemma with type `ty` is conditional.
-/
/-- Checks whether two expressions are equal for the simplifier. That is,
they are reducibly-definitional equal, and they have the same head symbol. -/
/-- Reports declarations that are simp lemmas whose left-hand side is not in simp-normal form. -/
-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.

-- In this case, ignore the declaration if it is not a valid simp lemma by itself.

/--
This note gives you some tips to debug any errors that the simp-normal form linter raises
end Mathlib


import tactic.hint
import tactic.split_ifs
import tactic.finish

example : 1 = 1 :=
begin
  (do hints ← tactic.hint, guard $ ("refl", 0) ∈ hints),
  refl
end

-- `split_ifs` is designated as a `hint_tactic` in its own file
example : if 1 = 1 then true else false :=
begin
  (do hints ← tactic.hint, guard $ ("split_ifs", 2) ∈ hints),
  split_ifs; trivial
end

-- Check we don't provide any hints on `false`.
example : false ∨ true :=
begin
  success_if_fail { left, hint },
  right, trivial,
end

-- Check that tactics are sorted by the number of goals they leave.
example : 1 = 1 ∧ 2 = 2 :=
begin
  (do hints ← tactic.hint,
      guard $ hints.indexes_of ("finish", 0) < hints.indexes_of ("fconstructor", 2)),
  finish
end

example (h : false) : false :=
begin
  (do hints ← tactic.hint, guard $ ("assumption", 0) ∈ hints),
  assumption
end

example {P Q : Prop} (p : P) (h : P → Q) : Q :=
begin
  (do hints ← tactic.hint, guard $ ("solve_by_elim", 0) ∈ hints),
  solve_by_elim,
end

-- Check that `num_goals` is counted correctly, when `hint` is called with multiple goals.
example : 1 = 1 ∧ 2 = 2 :=
begin
  split,
  (do hints ← tactic.hint, guard $ ("solve_by_elim", 0) ∈ hints),
  solve_by_elim,
  (do hints ← tactic.hint, guard $ ("refl", 0) ∈ hints),
  refl,
end


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.hom.lattice

/-!
# Heyting algebra morphisms

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

A Heyting homomorphism between two Heyting algebras is a bounded lattice homomorphism that preserves
Heyting implication.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `heyting_hom`: Heyting homomorphisms.
* `coheyting_hom`: Co-Heyting homomorphisms.
* `biheyting_hom`: Bi-Heyting homomorphisms.

## Typeclasses

* `heyting_hom_class`
* `coheyting_hom_class`
* `biheyting_hom_class`
-/

open function

variables {F α β γ δ : Type*}

/-- The type of Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that preserve
Heyting implication. -/
@[protect_proj]
structure heyting_hom (α β : Type*) [heyting_algebra α] [heyting_algebra β]
  extends lattice_hom α β :=
(map_bot' : to_fun ⊥ = ⊥)
(map_himp' : ∀ a b, to_fun (a ⇨ b) = to_fun a ⇨ to_fun b)

/-- The type of co-Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that
preserve difference. -/
@[protect_proj]
structure coheyting_hom (α β : Type*) [coheyting_algebra α] [coheyting_algebra β]
  extends lattice_hom α β :=
(map_top' : to_fun ⊤ = ⊤)
(map_sdiff' : ∀ a b, to_fun (a \ b) = to_fun a \ to_fun b)

/-- The type of bi-Heyting homomorphisms from `α` to `β`. Bounded lattice homomorphisms that
preserve Heyting implication and difference. -/
@[protect_proj]
structure biheyting_hom (α β : Type*) [biheyting_algebra α] [biheyting_algebra β]
  extends lattice_hom α β :=
(map_himp' : ∀ a b, to_fun (a ⇨ b) = to_fun a ⇨ to_fun b)
(map_sdiff' : ∀ a b, to_fun (a \ b) = to_fun a \ to_fun b)

/-- `heyting_hom_class F α β` states that `F` is a type of Heyting homomorphisms.

You should extend this class when you extend `heyting_hom`. -/
class heyting_hom_class (F : Type*) (α β : out_param $ Type*) [heyting_algebra α]
  [heyting_algebra β] extends lattice_hom_class F α β :=
(map_bot (f : F) : f ⊥ = ⊥)
(map_himp (f : F) : ∀ a b, f (a ⇨ b) = f a ⇨ f b)

/-- `coheyting_hom_class F α β` states that `F` is a type of co-Heyting homomorphisms.

You should extend this class when you extend `coheyting_hom`. -/
class coheyting_hom_class (F : Type*) (α β : out_param $ Type*) [coheyting_algebra α]
  [coheyting_algebra β] extends lattice_hom_class F α β :=
(map_top (f : F) : f ⊤ = ⊤)
(map_sdiff (f : F) : ∀ a b, f (a \ b) = f a \ f b)

/-- `biheyting_hom_class F α β` states that `F` is a type of bi-Heyting homomorphisms.

You should extend this class when you extend `biheyting_hom`. -/
class biheyting_hom_class (F : Type*) (α β : out_param $ Type*) [biheyting_algebra α]
  [biheyting_algebra β] extends lattice_hom_class F α β :=
(map_himp (f : F) : ∀ a b, f (a ⇨ b) = f a ⇨ f b)
(map_sdiff (f : F) : ∀ a b, f (a \ b) = f a \ f b)

export heyting_hom_class (map_himp)
export coheyting_hom_class (map_sdiff)

attribute [simp] map_himp map_sdiff

@[priority 100] -- See note [lower instance priority]
instance heyting_hom_class.to_bounded_lattice_hom_class [heyting_algebra α] [heyting_algebra β]
  [heyting_hom_class F α β] : bounded_lattice_hom_class F α β :=
{ map_top := λ f, by rw [←@himp_self α _ ⊥, ←himp_self, map_himp],
  ..‹heyting_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance coheyting_hom_class.to_bounded_lattice_hom_class [coheyting_algebra α]
  [coheyting_algebra β] [coheyting_hom_class F α β] : bounded_lattice_hom_class F α β :=
{ map_bot := λ f, by rw [←@sdiff_self α _ ⊤, ←sdiff_self, map_sdiff],
  ..‹coheyting_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance biheyting_hom_class.to_heyting_hom_class [biheyting_algebra α] [biheyting_algebra β]
  [biheyting_hom_class F α β] :
  heyting_hom_class F α β :=
{ map_bot := λ f, by rw [←@sdiff_self α _ ⊤, ←sdiff_self, biheyting_hom_class.map_sdiff],
  ..‹biheyting_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance biheyting_hom_class.to_coheyting_hom_class [biheyting_algebra α] [biheyting_algebra β]
  [biheyting_hom_class F α β] :
  coheyting_hom_class F α β :=
{ map_top := λ f, by rw [←@himp_self α _ ⊥, ←himp_self, map_himp],
  ..‹biheyting_hom_class F α β› }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_heyting_hom_class [heyting_algebra α] [heyting_algebra β]
  [order_iso_class F α β] :
  heyting_hom_class F α β :=
{ map_himp := λ f a b, eq_of_forall_le_iff $ λ c,
    by { simp only [←map_inv_le_iff, le_himp_iff], rw ←order_iso_class.map_le_map_iff f, simp },
  ..order_iso_class.to_bounded_lattice_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_coheyting_hom_class [coheyting_algebra α] [coheyting_algebra β]
  [order_iso_class F α β] :
  coheyting_hom_class F α β :=
{ map_sdiff := λ f a b, eq_of_forall_ge_iff $ λ c,
    by { simp only [←le_map_inv_iff, sdiff_le_iff], rw ←order_iso_class.map_le_map_iff f, simp },
  ..order_iso_class.to_bounded_lattice_hom_class }

@[priority 100] -- See note [lower instance priority]
instance order_iso_class.to_biheyting_hom_class [biheyting_algebra α] [biheyting_algebra β]
  [order_iso_class F α β] :
  biheyting_hom_class F α β :=
{ map_himp := λ f a b, eq_of_forall_le_iff $ λ c,
    by { simp only [←map_inv_le_iff, le_himp_iff], rw ←order_iso_class.map_le_map_iff f, simp },
  map_sdiff := λ f a b, eq_of_forall_ge_iff $ λ c,
    by { simp only [←le_map_inv_iff, sdiff_le_iff], rw ←order_iso_class.map_le_map_iff f, simp },
  ..order_iso_class.to_lattice_hom_class }

/-- This can't be an instance because of typeclass loops. -/
@[reducible] -- See note [reducible non instances]
def bounded_lattice_hom_class.to_biheyting_hom_class [boolean_algebra α] [boolean_algebra β]
  [bounded_lattice_hom_class F α β] :
  biheyting_hom_class F α β :=
{ map_himp := λ f a b, by rw [himp_eq, himp_eq, map_sup, (is_compl_compl.map _).compl_eq],
  map_sdiff := λ f a b, by rw [sdiff_eq, sdiff_eq, map_inf, (is_compl_compl.map _).compl_eq],
   ..‹bounded_lattice_hom_class F α β› }

section heyting_algebra
variables [heyting_algebra α] [heyting_algebra β] [heyting_hom_class F α β] (f : F)
include β

@[simp] lemma map_compl (a : α) : f aᶜ = (f a)ᶜ := by rw [←himp_bot, ←himp_bot, map_himp, map_bot]

@[simp] lemma map_bihimp (a b : α) : f (a ⇔ b) = f a ⇔ f b :=
by simp_rw [bihimp, map_inf, map_himp]

-- TODO: `map_bihimp`

end heyting_algebra

section coheyting_algebra
variables [coheyting_algebra α] [coheyting_algebra β] [coheyting_hom_class F α β] (f : F)
include β

@[simp] lemma map_hnot (a : α) : f ￢a = ￢f a :=
by rw [←top_sdiff', ←top_sdiff', map_sdiff, map_top]

@[simp] lemma map_symm_diff (a b : α) : f (a ∆ b) = f a ∆ f b :=
by simp_rw [symm_diff, map_sup, map_sdiff]

end coheyting_algebra

instance [heyting_algebra α] [heyting_algebra β] [heyting_hom_class F α β] :
  has_coe_t F (heyting_hom α β) :=
⟨λ f, { to_fun := f,
        map_sup' := map_sup f,
        map_inf' := map_inf f,
        map_bot' := map_bot f,
        map_himp' := map_himp f }⟩

instance [coheyting_algebra α] [coheyting_algebra β] [coheyting_hom_class F α β] :
  has_coe_t F (coheyting_hom α β) :=
⟨λ f, { to_fun := f,
        map_sup' := map_sup f,
        map_inf' := map_inf f,
        map_top' := map_top f,
        map_sdiff' := map_sdiff f }⟩

instance [biheyting_algebra α] [biheyting_algebra β] [biheyting_hom_class F α β] :
  has_coe_t F (biheyting_hom α β) :=
⟨λ f, { to_fun := f,
        map_sup' := map_sup f,
        map_inf' := map_inf f,
        map_himp' := map_himp f,
        map_sdiff' := map_sdiff f }⟩

namespace heyting_hom
variables [heyting_algebra α] [heyting_algebra β] [heyting_algebra γ] [heyting_algebra δ]

instance : heyting_hom_class (heyting_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_bot := λ f, f.map_bot',
  map_himp := heyting_hom.map_himp' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (heyting_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : heyting_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : heyting_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `heyting_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : heyting_hom α β) (f' : α → β) (h : f' = f) : heyting_hom α β :=
{ to_fun := f',
  map_sup' := by simpa only [h] using map_sup f,
  map_inf' := by simpa only [h] using map_inf f,
  map_bot' := by simpa only [h] using map_bot f,
  map_himp' := by simpa only [h] using map_himp f }

@[simp] lemma coe_copy (f : heyting_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl
lemma copy_eq (f : heyting_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as a `heyting_hom`. -/
protected def id : heyting_hom α α :=
{ to_lattice_hom := lattice_hom.id _,
  map_himp' := λ a b, rfl,
  ..bot_hom.id _ }

@[simp] lemma coe_id : ⇑(heyting_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : heyting_hom.id α a = a := rfl

instance : inhabited (heyting_hom α α) := ⟨heyting_hom.id _⟩

instance : partial_order (heyting_hom α β) := partial_order.lift _ fun_like.coe_injective

/-- Composition of `heyting_hom`s as a `heyting_hom`. -/
def comp (f : heyting_hom β γ) (g : heyting_hom α β) : heyting_hom α γ :=
{ to_fun := f ∘ g,
  map_bot' := by simp,
  map_himp' := λ a b, by simp,
  ..f.to_lattice_hom.comp g.to_lattice_hom }

variables {f f₁ f₂ : heyting_hom α β} {g g₁ g₂ : heyting_hom β γ}

@[simp]

lemma cancel_right (hf : surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left (hg : injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, heyting_hom.ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end heyting_hom

namespace coheyting_hom
variables [coheyting_algebra α] [coheyting_algebra β] [coheyting_algebra γ] [coheyting_algebra δ]

instance : coheyting_hom_class (coheyting_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_top := λ f, f.map_top',
  map_sdiff := coheyting_hom.map_sdiff' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (coheyting_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : coheyting_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : coheyting_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `coheyting_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : coheyting_hom α β) (f' : α → β) (h : f' = f) : coheyting_hom α β :=
{ to_fun := f',
  map_sup' := by simpa only [h] using map_sup f,
  map_inf' := by simpa only [h] using map_inf f,
  map_top' := by simpa only [h] using map_top f,
  map_sdiff' := by simpa only [h] using map_sdiff f }

@[simp]
lemma coe_copy (f : coheyting_hom α β) (f' : α → β) (h : f' = f) : ⇑(f.copy f' h) = f' := rfl

lemma copy_eq (f : coheyting_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as a `coheyting_hom`. -/
protected def id : coheyting_hom α α :=
{ to_lattice_hom := lattice_hom.id _,
  map_sdiff' := λ a b, rfl,
  ..top_hom.id _ }

@[simp] lemma coe_id : ⇑(coheyting_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : coheyting_hom.id α a = a := rfl

instance : inhabited (coheyting_hom α α) := ⟨coheyting_hom.id _⟩

instance : partial_order (coheyting_hom α β) := partial_order.lift _ fun_like.coe_injective

/-- Composition of `coheyting_hom`s as a `coheyting_hom`. -/
def comp (f : coheyting_hom β γ) (g : coheyting_hom α β) : coheyting_hom α γ :=
{ to_fun := f ∘ g,
  map_top' := by simp,
  map_sdiff' := λ a b, by simp,
  ..f.to_lattice_hom.comp g.to_lattice_hom }

variables {f f₁ f₂ : coheyting_hom α β} {g g₁ g₂ : coheyting_hom β γ}

@[simp] lemma coe_comp (f : coheyting_hom β γ) (g : coheyting_hom α β) : ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : coheyting_hom β γ) (g : coheyting_hom α β) (a : α) :
 f.comp g a = f (g a) := rfl
@[simp] lemma comp_assoc (f : coheyting_hom γ δ) (g : coheyting_hom β γ) (h : coheyting_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : coheyting_hom α β) : f.comp (coheyting_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : coheyting_hom α β) : (coheyting_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right (hf : surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left (hg : injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, coheyting_hom.ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end coheyting_hom

namespace biheyting_hom
variables [biheyting_algebra α] [biheyting_algebra β] [biheyting_algebra γ] [biheyting_algebra δ]

instance : biheyting_hom_class (biheyting_hom α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := f; obtain ⟨⟨⟨_, _⟩, _⟩, _⟩ := g; congr',
  map_sup := λ f, f.map_sup',
  map_inf := λ f, f.map_inf',
  map_himp := λ f, f.map_himp',
  map_sdiff := λ f, f.map_sdiff' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (biheyting_hom α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : biheyting_hom α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : biheyting_hom α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `biheyting_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : biheyting_hom α β) (f' : α → β) (h : f' = f) : biheyting_hom α β :=
{ to_fun := f',
  map_sup' := by simpa only [h] using map_sup f,
  map_inf' := by simpa only [h] using map_inf f,
  map_himp' := by simpa only [h] using map_himp f,
  map_sdiff' := by simpa only [h] using map_sdiff f }

@[simp] lemma coe_copy (f : biheyting_hom α β) (f' : α → β) (h : f' = f) :
  ⇑(f.copy f' h) = f' :=
rfl

lemma copy_eq (f : biheyting_hom α β) (f' : α → β) (h : f' = f) : f.copy f' h = f := fun_like.ext' h

variables (α)

/-- `id` as a `biheyting_hom`. -/
protected def id : biheyting_hom α α :=
{ to_lattice_hom := lattice_hom.id _,
  ..heyting_hom.id _, ..coheyting_hom.id _ }

@[simp] lemma coe_id : ⇑(biheyting_hom.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : biheyting_hom.id α a = a := rfl

instance : inhabited (biheyting_hom α α) := ⟨biheyting_hom.id _⟩

instance : partial_order (biheyting_hom α β) := partial_order.lift _ fun_like.coe_injective

/-- Composition of `biheyting_hom`s as a `biheyting_hom`. -/
def comp (f : biheyting_hom β γ) (g : biheyting_hom α β) : biheyting_hom α γ :=
{ to_fun := f ∘ g,
  map_himp' := λ a b, by simp,
  map_sdiff' := λ a b, by simp,
  ..f.to_lattice_hom.comp g.to_lattice_hom }

variables {f f₁ f₂ : biheyting_hom α β} {g g₁ g₂ : biheyting_hom β γ}

@[simp] lemma coe_comp (f : biheyting_hom β γ) (g : biheyting_hom α β) : ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : biheyting_hom β γ) (g : biheyting_hom α β) (a : α) :
 f.comp g a = f (g a) := rfl
@[simp] lemma comp_assoc (f : biheyting_hom γ δ) (g : biheyting_hom β γ) (h : biheyting_hom α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : biheyting_hom α β) : f.comp (biheyting_hom.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : biheyting_hom α β) : (biheyting_hom.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right (hf : surjective f) : g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left (hg : injective g) : g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, biheyting_hom.ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end biheyting_hom


import data.nat.squarefree
import data.int.sqrt
import number_theory.number_field.class_number
import number_theory.quad_ring.basic

/-!
# Showing the class group of `ℤ[√d]` is nontrivial
-/

open_locale non_zero_divisors
open quad_ring
open_locale quad_ring

section to_mathlib

section

/-!
### The class group is independent of choice of fraction field or ring of integers
-/

open submodule

/-- This is `submodule.map_mul` where `g` satisfies the conditions of `alg_hom`
except it's semilinear. -/
protected lemma submodule.map_mulₛₗ {R R' A A'} [comm_semiring R] [comm_semiring R']
  [semiring A] [semiring A'] [algebra R A] [algebra R' A']
  (f : R →+* R') [ring_hom_surjective f]
  (g : A →ₛₗ[f] A') (hg : ∀ (x y : A), g (x * y) = g x * g y) (M N : submodule R A) :
  map g (M * N) = map g M * map g N :=
calc map g (M * N)
    = ⨆ (i : M), (N.map (algebra.lmul R A i)).map g : map_supr _ _
... = map g M * map g N  :
  begin
    apply congr_arg Sup,
    ext S,
    split; rintros ⟨y, hy⟩,
    { use [g y, mem_map.mpr ⟨y.1, y.2, rfl⟩],
      refine trans _ hy,
      ext,
      simp [hg] },
    { obtain ⟨y', hy', fy_eq⟩ := mem_map.mp y.2,
      use [y', hy'],
      refine trans _ hy,
      ext,
      simp [fy_eq, hg] }
end

end

lemma ideal.span_eq_span_iff {R : Type*} [comm_ring R]
  {s t : set R} : ideal.span s = ideal.span t ↔ s ⊆ ideal.span t ∧ t ⊆ ideal.span s :=
le_antisymm_iff.trans (by simp only [ideal.span_le])

/-- `is_localization.map` bundled as a semilinear map. -/
@[simps]
noncomputable def is_localization.map_semilinear {R S} (Rₘ Sₙ : Type*)
  [comm_ring R] [comm_ring S] (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : M ≤ N.comap f) : Rₘ →ₛₗ[(f : R →+* S)] Sₙ :=
{ to_fun := is_localization.map Sₙ (f : R →+* S) hf,
  map_smul' := λ r x, is_localization.map_smul _ _ _,
  .. is_localization.map Sₙ (f : R →+* S) hf }

-- Should be a congr lemma but can't because `@[congr]` doesn't
-- understand `coe_fn`
lemma is_localization.map_semilinear_congr {R S Rₘ Sₙ : Type*} [comm_ring R] [comm_ring S]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  {F : Type*} [ring_hom_class F R S] (f g : F) (hf : M ≤ N.comap f) (hg : M ≤ N.comap g)
  (h : f = g) (x y : Rₘ) (hxy : x = y) :
  (is_localization.map_semilinear Rₘ Sₙ M N f hf) x =
    (is_localization.map_semilinear Rₘ Sₙ M N g hg) y :=
by subst h; subst hxy; refl

@[simp] lemma is_localization.map_semilinear_eq {R S Rₘ Sₙ : Type*} [comm_ring R] [comm_ring S]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : M ≤ N.comap f) (x : R) :
  is_localization.map_semilinear Rₘ Sₙ M N f hf (algebra_map R Rₘ x) = algebra_map S Sₙ (f x) :=
is_localization.map_eq _ _

@[simp] lemma is_localization.map_semilinear_mul {R S Rₘ Sₙ : Type*} [comm_ring R] [comm_ring S]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : M ≤ N.comap f) (x y : Rₘ) :
  is_localization.map_semilinear Rₘ Sₙ M N f hf (x * y) =
    is_localization.map_semilinear Rₘ Sₙ M N f hf x *
    is_localization.map_semilinear Rₘ Sₙ M N f hf y :=
by simp only [is_localization.map_semilinear, linear_map.coe_mk, map_mul]

@[simp] lemma is_localization.map_semilinear_comp_apply {R S T Rₘ Sₙ Tₚ : Type*}
  [comm_ring R] [comm_ring S] [comm_ring T]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  (P : submonoid T) [comm_ring Tₚ] [algebra T Tₚ] [is_localization P Tₚ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : M ≤ N.comap f)
  {G : Type*} [ring_hom_class G S T] (g : G) (hg : N ≤ P.comap g)
  {GF : Type*} [ring_hom_class GF R T] (gf : GF) (hgf : M ≤ P.comap gf)
  [ring_hom_comp_triple (f : R →+* S) (g : S →+* T) gf]
  (x : Rₘ) :
  (is_localization.map_semilinear _ Tₚ M P gf hgf : Rₘ →ₛₗ[_] _) x =
    is_localization.map_semilinear _ Tₚ N P g hg
      (is_localization.map_semilinear _ Sₙ M N f hf x) :=
begin
  simp only [is_localization.map_semilinear, linear_map.coe_mk, linear_map.coe_comp],
  -- Help the elaborator with inserting the coercions
  convert fun_like.ext_iff.mp
    (@is_localization.map_comp_map R _ _ Rₘ _ _ S _ _ f _ Sₙ _ hf _ _ T _ _ Tₚ _ _ _ g hg).symm x,
  exact ring_hom_comp_triple.comp_eq.symm
end

@[simp] lemma is_localization.map_semilinear_comp {R S T Rₘ Sₙ Tₚ : Type*}
  [comm_ring R] [comm_ring S] [comm_ring T]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  (P : submonoid T) [comm_ring Tₚ] [algebra T Tₚ] [is_localization P Tₚ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : M ≤ N.comap f)
  {G : Type*} [ring_hom_class G S T] (g : G) (hg : N ≤ P.comap g)
  {GF : Type*} [ring_hom_class GF R T] (gf : GF) (hgf : M ≤ P.comap gf)
  [ring_hom_comp_triple (f : R →+* S) (g : S →+* T) gf] :
  (is_localization.map_semilinear _ Tₚ M P gf hgf : Rₘ →ₛₗ[_] _) =
    (is_localization.map_semilinear _ Tₚ N P g hg).comp
      (is_localization.map_semilinear _ Sₙ M N f hf) :=
begin
  ext x,
  apply is_localization.map_semilinear_comp_apply
end

@[simp] lemma is_localization.map_semilinear_id_apply {R Rₘ : Type*}
  [comm_ring R]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (x : Rₘ) :
  (is_localization.map_semilinear Rₘ Rₘ M M (ring_hom.id R)
      (submonoid.comap_id M).le : Rₘ →ₛₗ[_] _) x =
    x :=
is_localization.map_id x (submonoid.comap_id M).le

@[simp] lemma fractional_ideal.mem_mk {R Rₘ : Type*} [comm_ring R] {M : submonoid R} [comm_ring Rₘ]
  [algebra R Rₘ] {S : submodule R Rₘ} {h : is_fractional M S} {x} :
  x ∈ (show fractional_ideal M Rₘ, from ⟨S, h⟩) ↔ x ∈ S :=
iff.rfl

/-- If `f : R →+* S` maps `M : submonoid R` to `N : submonoid S`, then the fractional ideals
at `M` can be mapped to those at `N`. -/
@[simps apply]
noncomputable def fractional_ideal.map_base {R S Rₘ Sₙ : Type*} [comm_ring R] [comm_ring S]
  (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  {F : Type*} [ring_hom_class F R S] (f : F) (hf : function.surjective f) (hfM : M ≤ N.comap f) :
  fractional_ideal M Rₘ →+* fractional_ideal N Sₙ :=
{ to_fun := λ I, ⟨by haveI : ring_hom_surjective (f : R →+* S) := ⟨hf⟩;
    exact submodule.map (is_localization.map_semilinear Rₘ Sₙ M N f hfM) (I : submodule R Rₘ),
    begin
      obtain ⟨a, haM, ha⟩ := I.2,
      refine ⟨f a, hfM haM, _⟩,
      simp only [submodule.mem_map, fractional_ideal.mem_coe, forall_exists_index, and_imp,
        forall_apply_eq_imp_iff₂],
      intros b hb,
      obtain ⟨ab, hab⟩ := ha b hb,
      use f ab,
      -- Work around the `↑f` because `linear_map.map_smulₛₗ` is non-generic in `f`.
      rw [← ring_hom.coe_coe f, ← linear_map.map_smulₛₗ, ← hab, is_localization.map_semilinear_eq,
          ring_hom.coe_coe f]
    end⟩,
  map_zero' := by ext; simp only [submodule.map_bot, fractional_ideal.coe_zero, submodule.mem_bot,
    fractional_ideal.mem_zero_iff, fractional_ideal.mem_mk],
  -- TODO: do the following lines with just `fractional_ideal.ext`
  map_add' := λ I J, fractional_ideal.coe_to_submodule_injective $
    by simp only [fractional_ideal.coe_add, submodule.map_sup, submodule.add_eq_sup, fractional_ideal.coe_mk],
  map_one' := fractional_ideal.coe_to_submodule_injective $ begin
    ext,
    simp only [fractional_ideal.coe_mk, fractional_ideal.coe_one, submodule.mem_map,
      submodule.mem_one, exists_exists_eq_and],
    split,
    { rintros ⟨a, rfl⟩,
      simp only [is_localization.map_semilinear_eq, exists_apply_eq_apply] },
    { rintros ⟨a, rfl⟩,
      obtain ⟨x, rfl⟩ := hf a,
      simp only [is_localization.map_semilinear_eq, exists_apply_eq_apply] },
  end,
  map_mul' := λ I J, fractional_ideal.coe_to_submodule_injective $ begin
    simp only [fractional_ideal.coe_mul, fractional_ideal.coe_mk],
    apply submodule.map_mulₛₗ,
    apply is_localization.map_semilinear_mul
  end }

section
universes u v u' v'
/-- If `e : R ≃+* S` maps `M : submonoid R` to `N : submonoid S`, then the fractional ideals
at `M` are isomorphic to those at `N`. -/
@[simps]
noncomputable def fractional_ideal.congr {R : Type u} {S : Type v} (Rₘ : Type u') (Sₙ : Type v')
  [comm_ring R] [comm_ring S] (M : submonoid R) [comm_ring Rₘ] [algebra R Rₘ] [is_localization M Rₘ]
  (N : submonoid S) [comm_ring Sₙ] [algebra S Sₙ] [is_localization N Sₙ]
  (e : R ≃+* S) (he : M.map e = N) : fractional_ideal M Rₘ ≃+* fractional_ideal N Sₙ :=
{ to_fun := fractional_ideal.map_base M N e e.surjective (submonoid.map_le_iff_le_comap.mp he.le),
  inv_fun := fractional_ideal.map_base N M e.symm e.symm.surjective (submonoid.map_le_iff_le_comap.mp
    (eq.le $ begin
      rw ← he,
      refine (submonoid.map_map M (e.symm : S →* R) (e : R →* S)).trans _,
      convert submonoid.map_id _,
      ext,
      exact e.symm_apply_apply x
    end)),
  -- TODO: the next lines should be doable using `fractional_ideal.ext`
  left_inv := λ I, fractional_ideal.coe_to_submodule_injective $ begin
    simp only [fractional_ideal.map_base_apply, fractional_ideal.coe_mk],
    haveI : ring_hom_surjective (e : R →+* S) := ⟨e.surjective⟩,
    haveI : ring_hom_surjective (e.symm : S →+* R) := ⟨e.symm.surjective⟩,
    haveI : ring_hom_comp_triple (e : R →+* S) (e.symm : S →+* R) (ring_hom.id R) :=
      ⟨e.symm_to_ring_hom_comp_to_ring_hom⟩,
    haveI : ring_hom_comp_triple (e.symm : S →+* R) (e : R →+* S) (ring_hom.id S) :=
      ⟨e.to_ring_hom_comp_symm_to_ring_hom⟩,
    -- Come on, Lean!
    calc submodule.map (is_localization.map_semilinear Sₙ Rₘ N M e.symm _) (submodule.map (is_localization.map_semilinear Rₘ Sₙ M N e _) ↑I)
        = submodule.map ((is_localization.map_semilinear Sₙ Rₘ N M e.symm _).comp (is_localization.map_semilinear Rₘ Sₙ M N e _)) ↑I : (submodule.map_comp (is_localization.map_semilinear Rₘ Sₙ M N e _) (is_localization.map_semilinear Sₙ Rₘ N M e.symm _) _).symm
    ... = submodule.map linear_map.id ↑I : _
    ... = ↑I : submodule.map_id _,
    congr,
    ext x,
    calc (is_localization.map_semilinear Sₙ Rₘ N M e.symm _).comp
            (is_localization.map_semilinear Rₘ Sₙ M N e _) x
        = is_localization.map_semilinear Rₘ Rₘ M M (ring_hom.id R) _ x :
      (is_localization.map_semilinear_comp_apply M N M e _ e.symm _ _ _ x).symm
    ... = x : is_localization.map_semilinear_id_apply M x
    ... = linear_map.id x : (linear_map.id_apply x).symm
  end,
  right_inv := λ I, fractional_ideal.coe_to_submodule_injective $ begin
    simp only [fractional_ideal.map_base_apply, fractional_ideal.coe_mk],
    haveI : ring_hom_surjective (e : R →+* S) := ⟨e.surjective⟩,
    haveI : ring_hom_surjective (e.symm : S →+* R) := ⟨e.symm.surjective⟩,
    haveI : ring_hom_comp_triple (e : R →+* S) (e.symm : S →+* R) (ring_hom.id R) :=
      ⟨e.symm_to_ring_hom_comp_to_ring_hom⟩,
    haveI : ring_hom_comp_triple (e.symm : S →+* R) (e : R →+* S) (ring_hom.id S) :=
      ⟨e.to_ring_hom_comp_symm_to_ring_hom⟩,
    calc submodule.map (is_localization.map_semilinear Rₘ Sₙ M N e _) (submodule.map (is_localization.map_semilinear Sₙ Rₘ N M e.symm _) ↑I)
        = submodule.map ((is_localization.map_semilinear Rₘ Sₙ M N e _).comp (is_localization.map_semilinear Sₙ Rₘ N M e.symm _)) ↑I : (submodule.map_comp (is_localization.map_semilinear Sₙ Rₘ N M e.symm _) (is_localization.map_semilinear Rₘ Sₙ M N e _) _).symm
    ... = submodule.map linear_map.id ↑I : _
    ... = ↑I : submodule.map_id _,
    congr,
    ext x,
    calc (is_localization.map_semilinear Rₘ Sₙ M N e _).comp (is_localization.map_semilinear Sₙ Rₘ N M e.symm _) x
        = is_localization.map_semilinear Sₙ Sₙ N N (ring_hom.id S) _ x :
      (is_localization.map_semilinear_comp_apply N M N e.symm _ e _ _ _ x).symm
    ... = x : is_localization.map_semilinear_id_apply N x
    ... = linear_map.id x : (linear_map.id_apply x).symm
  end,
  .. fractional_ideal.map_base M N e e.surjective _ }
end

-- TODO: the existence of this instance helps the elaborator unify quotient_group.group with comm_group.to_group
noncomputable instance (R : Type*) [comm_ring R] [is_domain R] :
  group (class_group R) := quotient_group.quotient.group _

@[simp] lemma map_non_zero_divisors {R S : Type*} [comm_ring R] [is_domain R] [comm_ring S] [is_domain S]
  (e : R ≃+* S) : submonoid.map e R⁰ = S⁰ :=
begin
  ext,
  simp only [submonoid.mem_map],
  split,
  { rintro ⟨x, hx, rfl⟩,
    exact map_mem_non_zero_divisors e e.injective hx },
  { intro hx,
    exact ⟨e.symm x, map_mem_non_zero_divisors e.symm e.symm.injective hx, e.apply_symm_apply x⟩ }
end

lemma units_map_equiv_congr_to_principal_ideal {R S : Type*} (K L : Type*)
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S]
  [field K] [field L] [algebra R K] [is_fraction_ring R K] [algebra S L] [is_fraction_ring S L]
  (e : R ≃+* S) (x : Kˣ) :
  (units.map_equiv ↑(fractional_ideal.congr K L R⁰ S⁰ e (map_non_zero_divisors e))) (to_principal_ideal R K x) =
    to_principal_ideal S L (units.map_equiv ↑(is_localization.ring_equiv_of_ring_equiv K L e (map_non_zero_divisors e)) x) :=
begin
  ext : 1,
  rw coe_to_principal_ideal,
  show fractional_ideal.congr K L R⁰ S⁰ e _ (to_principal_ideal R K x) = _,
 rw coe_to_principal_ideal,
 apply fractional_ideal.coe_to_submodule_injective,
 simp only [is_localization.ring_equiv_of_ring_equiv_apply, fractional_ideal.map_base_apply,
   ring_equiv.coe_to_mul_equiv, fractional_ideal.coe_span_singleton,
   fractional_ideal.congr_apply, fractional_ideal.coe_mk, submodule.map_span,
   set.image_singleton, is_localization.map_semilinear_apply],
  refl
end

universes u v

/-- The class group of `R` is isomorphic to that of `S`, if `R` is isomorphic to `S`. -/
noncomputable def class_group.congr {R : Type u} {S : Type v}
  [comm_ring R] [is_domain R] [comm_ring S] [is_domain S]
  (e : R ≃+* S) : class_group R ≃* class_group S :=
quotient_group.congr (to_principal_ideal R (fraction_ring R)).range (to_principal_ideal S (fraction_ring S)).range
  (units.map_equiv ↑(fractional_ideal.congr (fraction_ring R) (fraction_ring S) R⁰ S⁰ e (map_non_zero_divisors e))) $
  by { rw [monoid_hom.range_eq_map, subgroup.map_map, monoid_hom.range_eq_map],
       ext,
       simp only [subgroup.mem_map, subgroup.mem_top, exists_prop, true_and,
          monoid_hom.comp_apply],
       let e' : fraction_ring R ≃* fraction_ring S := is_localization.ring_equiv_of_ring_equiv
        (fraction_ring R) (fraction_ring S) e (map_non_zero_divisors e),
       split; rintro ⟨x, rfl⟩,
       { exact ⟨units.map_equiv e' x, (units_map_equiv_congr_to_principal_ideal _ _ e x).symm⟩ },
       { refine ⟨units.map_equiv e'.symm x, (units_map_equiv_congr_to_principal_ideal _ _ e _).trans _⟩,
         congr, ext : 1,
         exact mul_equiv.apply_symm_apply _ x } }

end to_mathlib

section to_mathlib

/-- The class number of a number field does not depend on a choice of ring of integers. -/
theorem number_field.class_number_eq (R : Type*) (K : Type*) [comm_ring R] [is_domain R]
  [field K] [algebra R K] [is_fraction_ring R K] [number_field K] [is_integral_closure R ℤ K]
  [fintype (class_group R)] :
  number_field.class_number K = fintype.card (class_group R) :=
begin
  unfold number_field.class_number,
  convert fintype.card_eq.mpr ⟨(class_group.congr _).to_equiv⟩,
  exact number_field.ring_of_integers.equiv _,
end

/-- The class number of a number field does not depend on a choice of ring of integers. -/
theorem number_field.class_number_eq' (R : Type*) (K : Type*) [comm_ring R] [is_domain R]
  [field K] [algebra R K] [is_fraction_ring R K] [number_field K] [is_integral_closure R ℤ K] :
  number_field.class_number K = @fintype.card (class_group R)
    (class_group.fintype_of_admissible_of_finite ℚ K absolute_value.abs_is_admissible) :=
by letI : fintype (class_group R) :=
  class_group.fintype_of_admissible_of_finite ℚ K absolute_value.abs_is_admissible;
exact number_field.class_number_eq R K

end to_mathlib

open_locale pointwise

section to_mathlib

@[simp]
lemma set.insert_mul {M : Type*} [has_mul M]
  (s t : set M) (x : M) : insert x s * t = x • t ∪ s * t :=
by rw [set.insert_eq, set.union_mul, set.singleton_mul]; refl
@[simp]
lemma set.mul_insert {M : Type*} [comm_monoid M]
  (s t : set M) (x : M) : s * insert x t = x • s ∪ s * t :=
by rw [set.insert_eq, set.mul_union, set.mul_singleton];
  -- TODO: clean me!
  congr' 2; ext; apply mul_comm

@[simp]
lemma set.smul_set_insert {M : Type*} [comm_monoid M]
  (x y : M) (s : set M) : x • insert y s = insert (x * y) (x • s) :=
by rw [set.insert_eq, set.smul_set_union, set.smul_set_singleton, set.insert_eq]; refl

@[simp]
lemma set.image_insert {α β : Type*} (f : α → β) (x : α) (s : set α) :
  f '' (insert x s) = insert (f x) (f '' s) :=
by simp only [set.insert_eq, set.image_union, set.image_singleton]

lemma ideal.span_eq_bot_iff_subset {α : Type*} [comm_semiring α] {S : set α} :
  ideal.span S = ⊥ ↔ S ⊆ {0} :=
ideal.span_eq_bot.trans set.subset_singleton_iff.symm

lemma set.not_subset_singleton_iff {α : Type*} {s : set α} {x : α} :
  ¬ (s ⊆ {x}) ↔ s ≠ ∅ ∧ s ≠ {x} :=
by rw [set.subset_singleton_iff_eq, not_or_distrib]

lemma ideal.span_ne_bot_iff {α : Type*} [comm_semiring α] {S : set α} :
  ideal.span S ≠ ⊥ ↔ (S.nonempty ∧ S ≠ {0}) :=
by simp only [ne.def, ideal.span_eq_bot_iff_subset, set.not_subset_singleton_iff,
              set.nonempty_iff_ne_empty]

@[simp] lemma set.ne_singleton_of_ne {α : Type*} {s : set α} {x y : α}
  (hxs : x ∈ s) (hxy : x ≠ y) : s ≠ {y} :=
by { contrapose! hxy, rw hxy at hxs, exact set.eq_of_mem_singleton hxs }

end to_mathlib

section basic

@[simp] lemma coe_dvd_mk {R : Type*} [comm_ring R] {n a b x y : R} :
  ↑n ∣ (⟨x, y⟩ : quad_ring R a b) ↔ n ∣ x ∧ n ∣ y :=
begin
  split,
  { rintro ⟨⟨da, db⟩, hd⟩,
    simp only [quad_ring.ext_iff, add_zero, int.cast_id, quad_ring.mul_b2, zero_mul,
      quad_ring.mul_b1, quad_ring.coe_b1, zero_add, quad_ring.coe_b2, mul_zero] at hd,
    exact ⟨⟨_, hd.1⟩, ⟨_, hd.2⟩⟩ },
  { rintro ⟨⟨da, hda⟩, ⟨db, hdb⟩⟩,
    refine ⟨⟨da, db⟩, _⟩,
    ext; simp [hda, hdb] }
end

instance {b : ℚ} [fact $ ¬ is_square b] : number_field (quad_ring ℚ 0 b) :=
{ to_finite_dimensional := quad_ring.finite_dimensional 0 b }

end basic

/-- The ideal `⟨2⟩` in ℤ[√d] is a square if `d % 4 = 3`.  -/
lemma exists_sqrt_2_mod_three (d : ℤ) (hd : d % 4 = 3) :
  (ideal.span ({⟨1, 1⟩, 2} : set (quad_ring ℤ 0 d)))^2 = ideal.span {2} :=
begin
  have : (1 + d) % 4 = 0 := by { rw int.add_mod, norm_num [hd] },
  rw ← int.dvd_iff_mod_eq_zero at this,

  -- We show a very explicit equality by checking the inclusion of the span on both sides.
  simp only [pow_two, ideal.span_mul_span', set.insert_mul, set.mul_insert, set.singleton_mul,
    set.mul_singleton, set.smul_set_singleton, set.smul_set_insert, smul_eq_mul,
    set.insert_union, set.singleton_union, set.image_insert, set.image_singleton,
    set.insert_eq_of_mem, set.mem_insert_iff, eq_self_iff_true, true_or],
  rw [show (⟨1, 1⟩ : quad_ring ℤ 0 d) * (⟨ 1, 1 ⟩) = ⟨1 + d, 2⟩, by quad_ring.calc_tac,
      show (⟨1, 1⟩ : quad_ring ℤ 0 d) * 2 = ⟨2, 2⟩, by quad_ring.calc_tac,
      show (2 : quad_ring ℤ 0 d) * 2 = 4, by norm_num],
  refine ideal.span_eq_span_iff.mpr ⟨_, _⟩;
    simp only [set.insert_subset, set.singleton_subset_iff, ideal.mem_span_singleton,
      set_like.mem_coe],
  refine ⟨_, _, _⟩; refine coe_dvd_mk.mpr ⟨_, _⟩,
  { calc 2 ∣ 4 : by norm_num
       ... ∣ 1 + d : this },
  { refl },
  { refl },
  { refl },
  { exact (show (2 : ℤ) ∣ 4, by norm_num) },
  { exact (show (2 : ℤ) ∣ 0, by norm_num) },
  { obtain ⟨k, hk⟩ := this,
    simp only [ideal.mem_span_insert, ideal.mem_span_singleton, exists_prop],
    refine ⟨-1, _, ⟨1, _, ⟨k, rfl⟩, rfl⟩, _⟩,
    rw hk,
    ext; simp },
end

/-- The ideal `⟨2⟩` in ℤ[√d] is a square if `d % 4 = 2`.  -/
lemma exists_sqrt_2_mod_two (d : ℤ) (hd : d % 4 = 2) :
  (ideal.span ({⟨0, 1⟩, 2} : set (quad_ring ℤ 0 d)))^2 = ideal.span {2} :=
begin
  have : (2 + d) % 4 = 0 := by { rw int.add_mod, norm_num [hd] },
  rw ← int.dvd_iff_mod_eq_zero at this,

  -- We show a very explicit equality by checking the inclusion of the span on both sides.
  simp only [pow_two, ideal.span_mul_span', set.insert_mul, set.mul_insert, set.singleton_mul,
    set.mul_singleton, set.smul_set_singleton, set.smul_set_insert, smul_eq_mul,
    set.insert_union, set.singleton_union, set.image_insert, set.image_singleton,
    set.insert_eq_of_mem, set.mem_insert_iff, eq_self_iff_true, true_or],
  rw [show (⟨0, 1⟩ : quad_ring ℤ 0 d) * (⟨ 0, 1 ⟩) = ⟨d, 0⟩, by quad_ring.calc_tac,
      show (⟨0, 1⟩ : quad_ring ℤ 0 d) * 2 = ⟨0, 2⟩, by quad_ring.calc_tac,
      show (2 : quad_ring ℤ 0 d) * 2 = 4, by norm_num],
  refine ideal.span_eq_span_iff.mpr ⟨_, _⟩;
    simp only [set.insert_subset, set.singleton_subset_iff, ideal.mem_span_singleton,
      set_like.mem_coe],
  refine ⟨_, _, _⟩; refine coe_dvd_mk.mpr ⟨_, _⟩,
  { have := calc 2 ∣ 4 : by norm_num
       ... ∣ 2 + d : this,
    simpa },
  { exact dvd_zero _, },
  { exact dvd_zero _, },
  { refl },
  { exact (show (2 : ℤ) ∣ 4, by norm_num) },
  { exact (show (2 : ℤ) ∣ 0, by norm_num) },
  { obtain ⟨k, hk⟩ := this,
    simp only [ideal.mem_span_insert, ideal.mem_span_singleton, exists_prop],
    refine ⟨-1, _, ⟨0, _, ⟨k, rfl⟩, rfl⟩, _⟩,
    rw_mod_cast ← hk,
    ext; simp },
end

lemma norm_ne_two {d : ℤ} (hd2 : d < -2)
  (x : quad_ring ℤ 0 d) : algebra.norm ℤ x ≠ 2 :=
begin
  rw quad_ring.norm_eq,
  simp only [zero_mul, add_zero],
  by_cases hb2 : x.b2 = 0,
  { simp only [hb2, pow_two, mul_zero, sub_zero],
    have : ¬ is_square (2 : ℤ) :=
      (int.prime_iff_nat_abs_prime.mpr $ by norm_num).irreducible.not_is_square,
    rw [is_square, not_exists] at this,
    exact ne.symm (this x.b1) },
  { have hb2 : 0 < x.b2^2 := (sq_pos_iff _).mpr hb2,
    refine ne_of_gt _,
    calc 2 < -d : by linarith
       ... ≤ - d * x.b2^2 : by nlinarith
       ... ≤ x.b1^2 - d * x.b2^2 : by nlinarith }
end

/-- In `ℤ[√d]`, if `d < -2`, the square root of the ideal ⟨2⟩ is not principal. -/
lemma not_principal_of_sq_eq_two {d : ℤ} (hd2 : d < -2)
  (I : ideal (quad_ring ℤ 0 d)) (h : I^2 = ideal.span {2}) :
  ¬ I.is_principal :=
begin
  rintro ⟨x, rfl⟩,
  rw [pow_two, ideal.submodule_span_eq, ideal.span_singleton_mul_span_singleton] at h,
  obtain ⟨a, ha⟩ := ideal.span_singleton_le_span_singleton.mp h.le,
  obtain ⟨b, hb⟩ := ideal.span_singleton_le_span_singleton.mp h.ge,
  rw ha at hb,
  apply_fun algebra.norm ℤ at ha hb,
  have hy : algebra.norm ℤ (2 : quad_ring ℤ 0 d) = 2^2 := quad_ring.norm_coe 2,
  simp only [map_mul, hy, mul_assoc] at ha hb,
  have : algebra.norm ℤ a = 1,
  { cases mul_right_eq_self₀.mp hb.symm with hb hb, swap,
    { norm_num at hb },
    cases int.is_unit_eq_one_or (is_unit_of_mul_eq_one _ _ hb) with hb hb,
    { assumption },
    { have := quad_ring.norm_nonneg _ a; linarith } },
  rw [this, mul_one, ← pow_two, sq_eq_sq (quad_ring.norm_nonneg _ x)] at ha,
  exact norm_ne_two hd2 x ha,
  repeat { linarith }
end

lemma is_not_principal_mod_three {d : ℤ} (hd : d % 4 = 3) (hd2 : d < -2) :
  ¬ submodule.is_principal (ideal.span ({⟨1, 1⟩, 2} : set (quad_ring ℤ 0 d))) :=
not_principal_of_sq_eq_two hd2 _ (exists_sqrt_2_mod_three d hd)

lemma is_not_principal_mod_two {d : ℤ} (hd : d % 4 = 2) (hd2 : d < -2) :
  ¬ submodule.is_principal (ideal.span ({⟨0, 1⟩, 2} : set (quad_ring ℤ 0 d))) :=
not_principal_of_sq_eq_two hd2 _ (exists_sqrt_2_mod_two d hd)

 -- `d` is a free variable so this can't be an instance
local attribute [instance] quad_ring.fact_not_square'_of_eq_two_or_three_mod_four

/-- `sqrt_2` is the square root of the ideal `⟨2⟩` of `ℤ[√d]`, when `d % 4 ∈ {2, 3}`. -/
def sqrt_2 (d : ℤ) [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] : (ideal (quad_ring ℤ 0 d))⁰ :=
if d % 4 = 2 then
  ⟨ideal.span ({⟨0, 1⟩, 2} : set (quad_ring ℤ 0 d)),
    mem_non_zero_divisors_of_ne_zero (ideal.span_ne_bot_iff.mpr ⟨set.insert_nonempty _ _,
      set.ne_singleton_of_ne (set.mem_insert_of_mem _ (set.mem_singleton 2)) two_ne_zero⟩)⟩
else
  ⟨ideal.span ({⟨1, 1⟩, 2} : set (quad_ring ℤ 0 d)),
    mem_non_zero_divisors_of_ne_zero (ideal.span_ne_bot_iff.mpr ⟨set.insert_nonempty _ _,
      set.ne_singleton_of_ne (set.mem_insert_of_mem _ (set.mem_singleton 2)) two_ne_zero⟩)⟩

lemma sqrt_2_pow_two (d : ℤ) [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] :
  ((sqrt_2 d)^2 : ideal (quad_ring ℤ 0 d)) = ideal.span {2} :=
begin
  rw sqrt_2,
  split_ifs,
  { simp [exists_sqrt_2_mod_two d h], },
  { simp [exists_sqrt_2_mod_three d (hd.out.resolve_left h)], },
end

/-- `class_group.sqrt_2` is the square root of `⟨2⟩` in the ideal class group of `ℚ(√d')`,
when `d % 4 ∈ {2, 3}`. -/
protected noncomputable def class_group.sqrt_2 (d : ℤ)
  [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d] :
  class_group (quad_ring ℤ 0 d) :=
class_group.mk0 (sqrt_2 d)

-- TODO a version of this for d = -2 and -1 saying that the order is 1
lemma order_of_sqrt2 {d : ℤ} [hd : fact $ d % 4 = 2 ∨ d % 4 = 3] [fact $ squarefree d]
  (hd2 : d < -2) : order_of (class_group.sqrt_2 d) = 2 :=
begin
  refine order_of_eq_prime _ _,
  { rw [class_group.sqrt_2, sqrt_2],
    split_ifs;
    simp_rw ← map_pow,
    { refine (class_group.mk0_eq_one_iff _).mpr _,
      simp only [exists_sqrt_2_mod_two d h],
      exact ⟨⟨2, rfl⟩⟩ },
    { refine (class_group.mk0_eq_one_iff _).mpr _,
      simp only [exists_sqrt_2_mod_three d (hd.out.resolve_left h)],
      exact ⟨⟨2, rfl⟩⟩ }, },
  { rw [ne.def, class_group.sqrt_2, sqrt_2],
    split_ifs; erw [class_group.mk0_eq_one_iff],
    exact is_not_principal_mod_two h hd2,
    exact is_not_principal_mod_three (hd.out.resolve_left h) hd2, },
end

theorem two_dvd_class_number (d : ℤ) (d' : ℚ) [hd : fact $ d % 4 = 2 ∨ d % 4 = 3]
  [fact $ squarefree d]
  (hd2 : d < -2) [hdd' : fact $ algebra_map ℤ ℚ d = d'] :
  2 ∣ number_field.class_number (quad_ring ℚ 0 d') :=
begin
  letI : fintype (class_group (quad_ring ℤ 0 d)) :=
    class_group.fintype_of_admissible_of_finite ℚ (quad_ring ℚ 0 d')
      absolute_value.abs_is_admissible,
  rw [← order_of_sqrt2 hd2, number_field.class_number_eq (quad_ring ℤ 0 d) (quad_ring ℚ 0 d')],
  exact order_of_dvd_card_univ,
end

instance : fact $ ¬ is_square (-5 : ℤ) :=
⟨(int.prime_iff_nat_abs_prime.mpr $ by norm_num).irreducible.not_is_square⟩

theorem class_group_nontrivial :
  nontrivial (class_group (quad_ring ℤ 0 (-5))) :=
begin
  haveI : fact (algebra_map ℤ ℚ (-5) = (-5)) := ⟨by simp⟩,
  haveI : fact ((-5 : ℤ) % 4 = 2 ∨ (-5 : ℤ) % 4 = 3) := ⟨by norm_num⟩,
  haveI : fact (squarefree (-5 : ℤ)) := ⟨by norm_num [int.squarefree_iff_squarefree_nat_abs]⟩,
  haveI : is_dedekind_domain (quad_ring ℤ 0 (-5)) :=
    is_integral_closure.is_dedekind_domain ℤ ℚ (quad_ring ℚ 0 (-5)) _,
  letI : fintype (class_group (quad_ring ℤ 0 (-5))) :=
    class_group.fintype_of_admissible_of_finite ℚ (quad_ring ℚ 0 (-5)) absolute_value.abs_is_admissible,
  rw [← fintype.one_lt_card_iff_nontrivial,
      ← number_field.class_number_eq (quad_ring ℤ 0 (-5)) (quad_ring ℚ 0 (-5))],
  have := nat.le_of_dvd _ (two_dvd_class_number (-5) (-5) (by norm_num)),
  { linarith },
  unfold number_field.class_number,
  rw fintype.card_pos_iff,
  exact has_one.nonempty,
end