/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad

! This file was ported from Lean 3 source module data.int.units
! leanprover-community/mathlib commit 45a1ada01ed893722d0f8d15b9e44270996515d5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Units
import Mathbin.Data.Int.Basic
import Mathbin.Algebra.Ring.Units

/-!
# Lemmas about units in `ℤ`.

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

namespace Int

/-! ### units -/

/- warning: int.units_nat_abs -> Int.units_natAbs is a dubious translation:
lean 3 declaration is
  forall (u : Units.{0} Int Int.monoid), Eq.{1} Nat (Int.natAbs ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) (Units.{0} Int Int.monoid) Int (HasLiftT.mk.{1, 1} (Units.{0} Int Int.monoid) Int (CoeTCₓ.coe.{1, 1} (Units.{0} Int Int.monoid) Int (coeBase.{1, 1} (Units.{0} Int Int.monoid) Int (Units.hasCoe.{0} Int Int.monoid)))) u)) (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne)))
but is expected to have type
  forall (u : Units.{0} Int Int.instMonoidInt), Eq.{1} Nat (Int.natAbs (Units.val.{0} Int Int.instMonoidInt u)) (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1))
Case conversion may be inaccurate. Consider using '#align int.units_nat_abs Int.units_natAbsₓ'. -/
@[simp]
theorem units_natAbs (u : ℤˣ) : natAbs u = 1 :=
  Units.ext_iff.1 <|
    Nat.units_eq_one
      ⟨natAbs u, natAbs ↑u⁻¹, by rw [← nat_abs_mul, Units.mul_inv] <;> rfl, by
        rw [← nat_abs_mul, Units.inv_mul] <;> rfl⟩
#align int.units_nat_abs Int.units_natAbs

/- warning: int.units_eq_one_or -> Int.units_eq_one_or is a dubious translation:
lean 3 declaration is
  forall (u : Units.{0} Int Int.monoid), Or (Eq.{1} (Units.{0} Int Int.monoid) u (OfNat.ofNat.{0} (Units.{0} Int Int.monoid) 1 (OfNat.mk.{0} (Units.{0} Int Int.monoid) 1 (One.one.{0} (Units.{0} Int Int.monoid) (MulOneClass.toHasOne.{0} (Units.{0} Int Int.monoid) (Units.mulOneClass.{0} Int Int.monoid)))))) (Eq.{1} (Units.{0} Int Int.monoid) u (Neg.neg.{0} (Units.{0} Int Int.monoid) (Units.hasNeg.{0} Int Int.monoid (NonUnitalNonAssocRing.toHasDistribNeg.{0} Int (NonAssocRing.toNonUnitalNonAssocRing.{0} Int (Ring.toNonAssocRing.{0} Int Int.ring)))) (OfNat.ofNat.{0} (Units.{0} Int Int.monoid) 1 (OfNat.mk.{0} (Units.{0} Int Int.monoid) 1 (One.one.{0} (Units.{0} Int Int.monoid) (MulOneClass.toHasOne.{0} (Units.{0} Int Int.monoid) (Units.mulOneClass.{0} Int Int.monoid)))))))
but is expected to have type
  forall (u : Units.{0} Int Int.instMonoidInt), Or (Eq.{1} (Units.{0} Int Int.instMonoidInt) u (OfNat.ofNat.{0} (Units.{0} Int Int.instMonoidInt) 1 (One.toOfNat1.{0} (Units.{0} Int Int.instMonoidInt) (InvOneClass.toOne.{0} (Units.{0} Int Int.instMonoidInt) (DivInvOneMonoid.toInvOneClass.{0} (Units.{0} Int Int.instMonoidInt) (DivisionMonoid.toDivInvOneMonoid.{0} (Units.{0} Int Int.instMonoidInt) (DivisionCommMonoid.toDivisionMonoid.{0} (Units.{0} Int Int.instMonoidInt) (CommGroup.toDivisionCommMonoid.{0} (Units.{0} Int Int.instMonoidInt) (Units.instCommGroupUnitsToMonoid.{0} Int Int.instCommMonoidInt))))))))) (Eq.{1} (Units.{0} Int Int.instMonoidInt) u (Neg.neg.{0} (Units.{0} Int Int.instMonoidInt) (Units.instNegUnits.{0} Int Int.instMonoidInt (NonUnitalNonAssocRing.toHasDistribNeg.{0} Int (NonAssocRing.toNonUnitalNonAssocRing.{0} Int (Ring.toNonAssocRing.{0} Int Int.instRingInt)))) (OfNat.ofNat.{0} (Units.{0} Int Int.instMonoidInt) 1 (One.toOfNat1.{0} (Units.{0} Int Int.instMonoidInt) (InvOneClass.toOne.{0} (Units.{0} Int Int.instMonoidInt) (DivInvOneMonoid.toInvOneClass.{0} (Units.{0} Int Int.instMonoidInt) (DivisionMonoid.toDivInvOneMonoid.{0} (Units.{0} Int Int.instMonoidInt) (DivisionCommMonoid.toDivisionMonoid.{0} (Units.{0} Int Int.instMonoidInt) (CommGroup.toDivisionCommMonoid.{0} (Units.{0} Int Int.instMonoidInt) (Units.instCommGroupUnitsToMonoid.{0} Int Int.instCommMonoidInt))))))))))
Case conversion may be inaccurate. Consider using '#align int.units_eq_one_or Int.units_eq_one_orₓ'. -/
theorem units_eq_one_or (u : ℤˣ) : u = 1 ∨ u = -1 := by
  simpa only [Units.ext_iff, units_nat_abs] using nat_abs_eq u
#align int.units_eq_one_or Int.units_eq_one_or

/- warning: int.is_unit_eq_one_or -> Int.isUnit_eq_one_or is a dubious translation:
lean 3 declaration is
  forall {a : Int}, (IsUnit.{0} Int Int.monoid a) -> (Or (Eq.{1} Int a (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne)))) (Eq.{1} Int a (Neg.neg.{0} Int Int.hasNeg (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne))))))
but is expected to have type
  forall {a : Int}, (IsUnit.{0} Int Int.instMonoidInt a) -> (Or (Eq.{1} Int a (OfNat.ofNat.{0} Int 1 (instOfNatInt 1))) (Eq.{1} Int a (Neg.neg.{0} Int Int.instNegInt (OfNat.ofNat.{0} Int 1 (instOfNatInt 1)))))
Case conversion may be inaccurate. Consider using '#align int.is_unit_eq_one_or Int.isUnit_eq_one_orₓ'. -/
theorem isUnit_eq_one_or {a : ℤ} : IsUnit a → a = 1 ∨ a = -1
  | ⟨x, hx⟩ => hx ▸ (units_eq_one_or _).imp (congr_arg coe) (congr_arg coe)
#align int.is_unit_eq_one_or Int.isUnit_eq_one_or

/- warning: int.is_unit_iff -> Int.isUnit_iff is a dubious translation:
lean 3 declaration is
  forall {a : Int}, Iff (IsUnit.{0} Int Int.monoid a) (Or (Eq.{1} Int a (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne)))) (Eq.{1} Int a (Neg.neg.{0} Int Int.hasNeg (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne))))))
but is expected to have type
  forall {a : Int}, Iff (IsUnit.{0} Int Int.instMonoidInt a) (Or (Eq.{1} Int a (OfNat.ofNat.{0} Int 1 (instOfNatInt 1))) (Eq.{1} Int a (Neg.neg.{0} Int Int.instNegInt (OfNat.ofNat.{0} Int 1 (instOfNatInt 1)))))
Case conversion may be inaccurate. Consider using '#align int.is_unit_iff Int.isUnit_iffₓ'. -/
theorem isUnit_iff {a : ℤ} : IsUnit a ↔ a = 1 ∨ a = -1 :=
  by
  refine' ⟨fun h => is_unit_eq_one_or h, fun h => _⟩
  rcases h with (rfl | rfl)
  · exact isUnit_one
  · exact is_unit_one.neg
#align int.is_unit_iff Int.isUnit_iff

/- warning: int.is_unit_eq_or_eq_neg -> Int.isUnit_eq_or_eq_neg is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int}, (IsUnit.{0} Int Int.monoid a) -> (IsUnit.{0} Int Int.monoid b) -> (Or (Eq.{1} Int a b) (Eq.{1} Int a (Neg.neg.{0} Int Int.hasNeg b)))
but is expected to have type
  forall {a : Int} {b : Int}, (IsUnit.{0} Int Int.instMonoidInt a) -> (IsUnit.{0} Int Int.instMonoidInt b) -> (Or (Eq.{1} Int a b) (Eq.{1} Int a (Neg.neg.{0} Int Int.instNegInt b)))
Case conversion may be inaccurate. Consider using '#align int.is_unit_eq_or_eq_neg Int.isUnit_eq_or_eq_negₓ'. -/
theorem isUnit_eq_or_eq_neg {a b : ℤ} (ha : IsUnit a) (hb : IsUnit b) : a = b ∨ a = -b :=
  by
  rcases is_unit_eq_one_or hb with (rfl | rfl)
  · exact is_unit_eq_one_or ha
  · rwa [or_comm', neg_neg, ← is_unit_iff]
#align int.is_unit_eq_or_eq_neg Int.isUnit_eq_or_eq_neg

#print Int.eq_one_or_neg_one_of_mul_eq_one /-
theorem eq_one_or_neg_one_of_mul_eq_one {z w : ℤ} (h : z * w = 1) : z = 1 ∨ z = -1 :=
  isUnit_iff.mp (isUnit_of_mul_eq_one z w h)
#align int.eq_one_or_neg_one_of_mul_eq_one Int.eq_one_or_neg_one_of_mul_eq_one
-/

#print Int.eq_one_or_neg_one_of_mul_eq_one' /-
theorem eq_one_or_neg_one_of_mul_eq_one' {z w : ℤ} (h : z * w = 1) :
    z = 1 ∧ w = 1 ∨ z = -1 ∧ w = -1 :=
  by
  have h' : w * z = 1 := mul_comm z w ▸ h
  rcases eq_one_or_neg_one_of_mul_eq_one h with (rfl | rfl) <;>
      rcases eq_one_or_neg_one_of_mul_eq_one h' with (rfl | rfl) <;>
    tauto
#align int.eq_one_or_neg_one_of_mul_eq_one' Int.eq_one_or_neg_one_of_mul_eq_one'
-/

#print Int.eq_of_mul_eq_one /-
theorem eq_of_mul_eq_one {z w : ℤ} (h : z * w = 1) : z = w :=
  (eq_one_or_neg_one_of_mul_eq_one' h).elim (fun h => h.1.trans h.2.symm) fun h =>
    h.1.trans h.2.symm
#align int.eq_of_mul_eq_one Int.eq_of_mul_eq_one
-/

#print Int.mul_eq_one_iff_eq_one_or_neg_one /-
theorem mul_eq_one_iff_eq_one_or_neg_one {z w : ℤ} : z * w = 1 ↔ z = 1 ∧ w = 1 ∨ z = -1 ∧ w = -1 :=
  by
  refine' ⟨eq_one_or_neg_one_of_mul_eq_one', fun h => Or.elim h (fun H => _) fun H => _⟩ <;>
      rcases H with ⟨rfl, rfl⟩ <;>
    rfl
#align int.mul_eq_one_iff_eq_one_or_neg_one Int.mul_eq_one_iff_eq_one_or_neg_one
-/

#print Int.eq_one_or_neg_one_of_mul_eq_neg_one' /-
theorem eq_one_or_neg_one_of_mul_eq_neg_one' {z w : ℤ} (h : z * w = -1) :
    z = 1 ∧ w = -1 ∨ z = -1 ∧ w = 1 :=
  by
  rcases is_unit_eq_one_or (is_unit.mul_iff.mp (int.is_unit_iff.mpr (Or.inr h))).1 with (rfl | rfl)
  · exact Or.inl ⟨rfl, one_mul w ▸ h⟩
  · exact Or.inr ⟨rfl, neg_inj.mp (neg_one_mul w ▸ h)⟩
#align int.eq_one_or_neg_one_of_mul_eq_neg_one' Int.eq_one_or_neg_one_of_mul_eq_neg_one'
-/

#print Int.mul_eq_neg_one_iff_eq_one_or_neg_one /-
theorem mul_eq_neg_one_iff_eq_one_or_neg_one {z w : ℤ} :
    z * w = -1 ↔ z = 1 ∧ w = -1 ∨ z = -1 ∧ w = 1 := by
  refine' ⟨eq_one_or_neg_one_of_mul_eq_neg_one', fun h => Or.elim h (fun H => _) fun H => _⟩ <;>
      rcases H with ⟨rfl, rfl⟩ <;>
    rfl
#align int.mul_eq_neg_one_iff_eq_one_or_neg_one Int.mul_eq_neg_one_iff_eq_one_or_neg_one
-/

/- warning: int.is_unit_iff_nat_abs_eq -> Int.isUnit_iff_natAbs_eq is a dubious translation:
lean 3 declaration is
  forall {n : Int}, Iff (IsUnit.{0} Int Int.monoid n) (Eq.{1} Nat (Int.natAbs n) (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))
but is expected to have type
  forall {n : Int}, Iff (IsUnit.{0} Int Int.instMonoidInt n) (Eq.{1} Nat (Int.natAbs n) (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))
Case conversion may be inaccurate. Consider using '#align int.is_unit_iff_nat_abs_eq Int.isUnit_iff_natAbs_eqₓ'. -/
theorem isUnit_iff_natAbs_eq {n : ℤ} : IsUnit n ↔ n.natAbs = 1 := by
  simp [nat_abs_eq_iff, is_unit_iff, Nat.cast_zero]
#align int.is_unit_iff_nat_abs_eq Int.isUnit_iff_natAbs_eq

/- warning: int.is_unit.nat_abs_eq -> Int.IsUnit.natAbs_eq is a dubious translation:
lean 3 declaration is
  forall {n : Int}, (IsUnit.{0} Int Int.monoid n) -> (Eq.{1} Nat (Int.natAbs n) (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))
but is expected to have type
  forall {n : Int}, (IsUnit.{0} Int Int.instMonoidInt n) -> (Eq.{1} Nat (Int.natAbs n) (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))
Case conversion may be inaccurate. Consider using '#align int.is_unit.nat_abs_eq Int.IsUnit.natAbs_eqₓ'. -/
alias is_unit_iff_nat_abs_eq ↔ is_unit.nat_abs_eq _
#align int.is_unit.nat_abs_eq Int.IsUnit.natAbs_eq

/- warning: int.of_nat_is_unit -> Int.ofNat_isUnit is a dubious translation:
lean 3 declaration is
  forall {n : Nat}, Iff (IsUnit.{0} Int Int.monoid ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat Int (HasLiftT.mk.{1, 1} Nat Int (CoeTCₓ.coe.{1, 1} Nat Int (coeBase.{1, 1} Nat Int Int.hasCoe))) n)) (IsUnit.{0} Nat Nat.monoid n)
but is expected to have type
  forall {n : Nat}, Iff (IsUnit.{0} Int Int.instMonoidInt (Nat.cast.{0} Int instNatCastInt n)) (IsUnit.{0} Nat Nat.monoid n)
Case conversion may be inaccurate. Consider using '#align int.of_nat_is_unit Int.ofNat_isUnitₓ'. -/
@[norm_cast]
theorem ofNat_isUnit {n : ℕ} : IsUnit (n : ℤ) ↔ IsUnit n := by
  rw [Nat.isUnit_iff, is_unit_iff_nat_abs_eq, nat_abs_of_nat]
#align int.of_nat_is_unit Int.ofNat_isUnit

/- warning: int.is_unit_mul_self -> Int.isUnit_mul_self is a dubious translation:
lean 3 declaration is
  forall {a : Int}, (IsUnit.{0} Int Int.monoid a) -> (Eq.{1} Int (HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.hasMul) a a) (OfNat.ofNat.{0} Int 1 (OfNat.mk.{0} Int 1 (One.one.{0} Int Int.hasOne))))
but is expected to have type
  forall {a : Int}, (IsUnit.{0} Int Int.instMonoidInt a) -> (Eq.{1} Int (HMul.hMul.{0, 0, 0} Int Int Int (instHMul.{0} Int Int.instMulInt) a a) (OfNat.ofNat.{0} Int 1 (instOfNatInt 1)))
Case conversion may be inaccurate. Consider using '#align int.is_unit_mul_self Int.isUnit_mul_selfₓ'. -/
theorem isUnit_mul_self {a : ℤ} (ha : IsUnit a) : a * a = 1 :=
  (isUnit_eq_one_or ha).elim (fun h => h.symm ▸ rfl) fun h => h.symm ▸ rfl
#align int.is_unit_mul_self Int.isUnit_mul_self

/- warning: int.is_unit_add_is_unit_eq_is_unit_add_is_unit -> Int.isUnit_add_isUnit_eq_isUnit_add_isUnit is a dubious translation:
lean 3 declaration is
  forall {a : Int} {b : Int} {c : Int} {d : Int}, (IsUnit.{0} Int Int.monoid a) -> (IsUnit.{0} Int Int.monoid b) -> (IsUnit.{0} Int Int.monoid c) -> (IsUnit.{0} Int Int.monoid d) -> (Iff (Eq.{1} Int (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) a b) (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.hasAdd) c d)) (Or (And (Eq.{1} Int a c) (Eq.{1} Int b d)) (And (Eq.{1} Int a d) (Eq.{1} Int b c))))
but is expected to have type
  forall {a : Int} {b : Int} {c : Int} {d : Int}, (IsUnit.{0} Int Int.instMonoidInt a) -> (IsUnit.{0} Int Int.instMonoidInt b) -> (IsUnit.{0} Int Int.instMonoidInt c) -> (IsUnit.{0} Int Int.instMonoidInt d) -> (Iff (Eq.{1} Int (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) a b) (HAdd.hAdd.{0, 0, 0} Int Int Int (instHAdd.{0} Int Int.instAddInt) c d)) (Or (And (Eq.{1} Int a c) (Eq.{1} Int b d)) (And (Eq.{1} Int a d) (Eq.{1} Int b c))))
Case conversion may be inaccurate. Consider using '#align int.is_unit_add_is_unit_eq_is_unit_add_is_unit Int.isUnit_add_isUnit_eq_isUnit_add_isUnitₓ'. -/
theorem isUnit_add_isUnit_eq_isUnit_add_isUnit {a b c d : ℤ} (ha : IsUnit a) (hb : IsUnit b)
    (hc : IsUnit c) (hd : IsUnit d) : a + b = c + d ↔ a = c ∧ b = d ∨ a = d ∧ b = c :=
  by
  rw [is_unit_iff] at ha hb hc hd
  cases ha <;> cases hb <;> cases hc <;> cases hd <;> subst ha <;> subst hb <;> subst hc <;>
      subst hd <;>
    tidy
#align int.is_unit_add_is_unit_eq_is_unit_add_is_unit Int.isUnit_add_isUnit_eq_isUnit_add_isUnit

#print Int.eq_one_or_neg_one_of_mul_eq_neg_one /-
theorem eq_one_or_neg_one_of_mul_eq_neg_one {z w : ℤ} (h : z * w = -1) : z = 1 ∨ z = -1 :=
  Or.elim (eq_one_or_neg_one_of_mul_eq_neg_one' h) (fun H => Or.inl H.1) fun H => Or.inr H.1
#align int.eq_one_or_neg_one_of_mul_eq_neg_one Int.eq_one_or_neg_one_of_mul_eq_neg_one
-/

end Int


import data.real.nnreal -- non-negative reals
import topology.algebra.infinite_sum -- infinite sums
import analysis.special_functions.log.basic
import analysis.special_functions.pow
import for_mathlib.nnreal

open_locale nnreal -- notation for non-negative reals

open_locale big_operators -- notation for infinite sums
/-

# Binary stuff

Binary expansion of `nnreal` works great. If `r : ℝ≥0` then you get a
`digits` function `d(r) : ℕ → ℕ` with `d(0)=⌊r⌋₊` and all the `d(n.succ)`
are 0 or 1, and the theorem is that `r = ∑ n, 2⁻¹ ^ n * b n`.

TODO : relationship between `binary r`
and `binary (2 * r)` or `binary (2⁻¹ * r)`?

-/

/-

## Random stuff

-/

-- move
lemma two_mul_lt_two {r : ℝ≥0} (hr : r < 1) : 2 * r < 2 :=
begin
  suffices : 2 * r < 2 * 1, by simpa,
  exact (mul_lt_mul_left (by norm_num)).mpr hr,
end

-- probably true in more generality than nnreal.
lemma nnreal.tsub_lt {a b c : ℝ≥0} (hc : c ≠ 0) (h : a < b + c) : a - b < c :=
begin
  cases le_or_lt a b with hab hab,
  { rw tsub_eq_zero_of_le hab,
    exact zero_lt_iff.mpr hc },
  { rwa tsub_lt_iff_left hab.le },
end

lemma nnreal.inv_pos_le_iff_one_le_mul {a b : ℝ≥0} (ha : 0 < a) : (a⁻¹ ≤ b ↔ 1 ≤ b * a) :=
begin
  suffices : (a : ℝ)⁻¹ ≤ b ↔ (1 : ℝ) ≤ b * a,
    assumption_mod_cast,
  rw inv_pos_le_iff_one_le_mul,
  assumption_mod_cast,
end

/-

# binary

An auxiliary function which computes the digits and remainders in the binary
expanion of a non-negative real.

-/

/-- An auxiliary function which computes binary expansion of a non-negative real
and also carries around the remainder. -/
noncomputable def nnreal.nat.binary (r : ℝ≥0) : ℕ → (ℕ × (ℝ≥0))
| 0 := (⌊r⌋₊, r - ⌊r⌋₊)
| (n + 1) := let digit := if (nnreal.nat.binary n).2 < 2⁻¹ then 0 else 1 in
             (digit, 2 * (nnreal.nat.binary n).2 - (digit : ℝ≥0))

namespace nnreal

namespace nat

/-

would be nice to turn on computable reals mode with same notation

binary_aux 0.15
(0,0.15)
(0,0.3)
(0,0.6)
(1,0.2)
(0,0.4)
(0,0.8)
(1.0.6)
(1,1.2)
(1,0.4)

binary_aux 23.45
(23,0.45)
(0,0.9)
(1,0.8)

-/

namespace binary

variables (r : ℝ≥0) (n : ℕ)

lemma zero_def : binary r 0 = (⌊r⌋₊,r - ⌊r⌋₊) :=
binary.equations._eqn_1 r

/-- This is the units digit -/
lemma zero_fst_def : (binary r 0).1 = ⌊r⌋₊ := by rw zero_def

lemma zero_fst_le : ((binary r 0).1 : ℝ≥0) ≤ r :=
begin
  rw zero_fst_def,
  apply nat.floor_le,
  exact coe_nonneg r,
end

lemma zero_snd_def : (binary r 0).2 = r - (binary r 0).1 :=
begin
  rw zero_def,
end

lemma succ_fst_def : (binary r (n + 1)).1 = if (binary r n).2 < 2⁻¹ then 0 else 1 :=
by rw binary.equations._eqn_2

lemma succ_fst_le :
  ((binary r (n + 1)).1 : ℝ≥0) ≤ 2 * (binary r n).2 :=
begin
  rw succ_fst_def,
  split_ifs,
  { simp },
  { push_neg at h,
    norm_cast,
    rw inv_pos_le_iff_one_le_mul at h, swap, norm_num,
    rwa mul_comm, },
end

lemma succ_snd_def : (binary r (n + 1)).2 = 2 * (binary r n).2 - (binary r (n + 1)).1 :=
by rw binary.equations._eqn_2

/-- A slightly mathematically stronger version of `succ_snd_def`. -/
lemma succ_snd_def' :
  (binary r (n + 1)).2 + (binary r (n + 1)).1 = 2 * ((binary r n).2 ) :=
begin
  rw succ_snd_def r n,
  exact tsub_add_cancel_of_le (succ_fst_le r n),
end

-- note: the zeroth digit can be any natural.
theorem succ_fst_le_one : (binary r (n + 1)).1 ≤ 1 :=
begin
  rw succ_fst_def,
  split_ifs; linarith,
end

/-- The remainder is bounded. -/
lemma snd_bdd : (binary r n).2 < 1 :=
begin
  induction n with d hd,
  { simp [zero_def],
    have := nat.lt_floor_add_one r,
    have foo : (⌊r⌋₊ : ℝ≥0) ≤ r := nat.floor_le (zero_le'),
    exact (tsub_lt_iff_left foo).mpr this, },
  { simp only [succ_snd_def, succ_fst_def, nat.cast_ite, nat.cast_zero, nat.cast_one],
    split_ifs with LEM,
    { simp,
      rw ← mul_lt_mul_left (show (0 : ℝ≥0) < 2, by norm_num) at LEM,
      convert LEM,
      simp },
    { push_neg at LEM,
      revert hd,
      generalize hx : (binary r d).snd = x, rw hx at LEM, clear hx,
      intro hx,
      rw [← mul_lt_mul_left (show (0 : ℝ≥0) < 2, by norm_num), mul_one] at hx,
      apply nnreal.tsub_lt, norm_num,
      convert hx, }, },
end

lemma fund_thm (B : ℕ) :
  ∑ n in finset.range B.succ, ((binary r n).1 : ℝ≥0) * 2⁻¹ ^ n +
    (binary r B).2 * 2⁻¹ ^ B = r :=
begin
  induction B with d hd,
  { simp only [zero_snd_def, zero_fst_def, finset.range_one, finset.sum_singleton,
      pow_zero, mul_one],
    rw ← add_tsub_assoc_of_le, swap, apply nat.floor_le, apply zero_le,
    exact add_tsub_cancel_left ↑⌊r⌋₊ r, },
  { rw [finset.sum_range_succ, add_assoc],
    convert hd,
    rw [← add_mul, add_comm, succ_snd_def', nat.succ_eq_add_one, pow_add, pow_one],
    rw [mul_comm (2 : ℝ≥0), mul_assoc],
    congr',
    rw [mul_comm, mul_assoc, inv_mul_cancel, mul_one],
    norm_num, }
end

lemma fund_thm' (B : ℕ) :
  (binary r B).2 + (∑ n in finset.range B.succ, ((binary r n).1 * 2 ^ (B - n)) : ℕ) = r * 2 ^ B :=
begin
  have := fund_thm r B,
  apply_fun (λ x, x * (2 : ℝ≥0) ^ B) at this,
  convert this,
  rw [add_comm, add_mul],
  congr',
  { rw finset.sum_mul,
    push_cast,
    apply finset.sum_congr rfl, intros n hn,
    rw finset.mem_range_succ_iff at hn,
    rw [mul_assoc, zero_add, one_add_one_eq_two],
    congr',
    simp,
    rw [pow_sub₀ (2 : ℝ≥0) _ hn, mul_comm],
    norm_num, },
  { rw [mul_assoc, ← mul_pow, inv_mul_cancel],
    { simp, },
    { norm_num }, },
end

end binary

-- in `nnreal` namespace
noncomputable def digit (r : ℝ≥0) (n : ℕ) : ℕ := (binary r n).1

namespace digit

variables (r : ℝ≥0) (n B : ℕ)

lemma zero_def : digit r 0 = ⌊r⌋₊ := binary.zero_fst_def r

lemma zero_le : (digit r 0 : ℝ≥0) ≤ r :=
binary.zero_fst_le r

theorem succ_le_one : (digit r (n + 1)) ≤ 1 :=
binary.succ_fst_le_one r n

theorem sum_le_r : ∑ n in finset.range B.succ, ((digit r n) : ℝ≥0) * 2⁻¹ ^ n ≤ r :=
begin
  conv_rhs {rw ← binary.fund_thm r B},
  apply le_add_right,
  refl,
end

theorem r_le_pow_add_sum :
  r < 2⁻¹ ^ B + ∑ n in finset.range B.succ, ((digit r n) : ℝ≥0) * 2⁻¹ ^ n :=
begin
  conv_lhs {rw ← binary.fund_thm r B},
      rw add_comm,
    refine add_lt_add_right _ _,
    rw mul_lt_iff_lt_one_left,
    { exact binary.snd_bdd r B },
    { apply pow_pos,
      norm_num, },
end

lemma r_sub_sum_small : r - ∑ n in finset.range B.succ, ((digit r n) : ℝ≥0) * 2⁻¹ ^ n < 2⁻¹ ^ B :=
begin
  have := r_le_pow_add_sum r B,
  rw ← tsub_lt_tsub_iff_right (sum_le_r r B) at this,
  convert this,
  simp,
end

--theorem r_bounds :
--   r ∈ set.Ico
--   (∑ n in finset.range B.succ, ((digit r n) : ℝ≥0) * 2⁻¹ ^ n)
--   (2⁻¹ ^ B + ∑ n in finset.range B.succ, ((binary r n).1 : ℝ≥0) * 2⁻¹ ^ n)
--   :=
-- ⟨sum_le_r r B, r_le_pow_add_sum r B⟩

theorem summable : summable (λ (n : ℕ), (nnreal.nat.digit r n : ℝ≥0) * 2⁻¹ ^ n) :=
begin
  have foo : ∀ n, (nnreal.nat.digit r n : ℝ≥0) ≤ max (nnreal.nat.digit r 0) 1,
  { rintro (rfl | n),
    { apply le_max_left, },
    { refine le_trans _ (le_max_right _ _),
      exact_mod_cast succ_le_one r n, }, },
  have bar : ∀ n, (nnreal.nat.digit r n : ℝ≥0) * 2⁻¹ ^ n ≤ max (nnreal.nat.digit r 0) 1 * 2⁻¹ ^ n,
  { intro n,
    rw mul_le_mul_right₀, exact foo n,
    apply pow_ne_zero,
    norm_num, },
  apply summable_of_le bar,
  apply summable.mul_left,
  apply summable_geometric,
  apply two_inv_lt_one,
end

theorem has_sum : has_sum (λ n, (digit r n : ℝ≥0) * 2⁻¹ ^ n) r :=
begin
  rw summable.has_sum_iff_tendsto_nat (summable r),
  dsimp,
  intros X hX,
  rw mem_nhds_iff at hX,
  rcases hX with ⟨V, hVX, hV1, hVr⟩,
  rw filter.mem_map,
  rw filter.mem_at_top_sets,
  -- choose a large enough such that (r-2⁻¹^a,r] ⊆ V
  obtain ⟨ε, hε, hεV⟩ := metric.is_open_iff.mp hV1 r hVr,
  change 0 < ε at hε,
  have foo : ∃ a : ℕ, (2⁻¹ : ℝ≥0) ^ a ≤ ⟨ε, hε.le⟩,
  { by_cases hε1 : 1 ≤ ε,
    { use 0, simp, exact_mod_cast hε1, },
    { push_neg at hε1,
      use ⌈real.log ε / real.log 2⁻¹⌉₊,
      have := nat.le_ceil (real.log ε / real.log 2⁻¹),
      have moo : (2⁻¹ : ℝ≥0) ^ (↑⌈real.log ε / real.log 2⁻¹⌉₊) ≤
        2⁻¹ ^ (real.log ε / real.log 2⁻¹),
      exact rpow_le_rpow_of_exponent_ge (by norm_num) (by norm_num) this,
      convert le_trans moo _ using 1, norm_cast,
      -- now coerce to real
      suffices : (2⁻¹ : ℝ) ^ (real.log ε / real.log 2⁻¹) ≤ ε,
        assumption_mod_cast,
      -- convenient thing
      have inv_two_pos : (0 : ℝ) < 2⁻¹,
      { rw _root_.inv_pos, apply zero_lt_two, },
      rw ← real.log_le_log (real.rpow_pos_of_pos inv_two_pos _) hε,
      apply le_of_eq,
      rw real.log_rpow inv_two_pos,
      rw div_mul_cancel,
      apply real.log_ne_zero_of_pos_of_ne_one inv_two_pos,
      norm_num, } },
  cases foo with B hB,
  use B + 1,
  intros m hm, cases m with m, cases hm,
  rw set.mem_preimage,
  have h_le_r := sum_le_r r m,
  have h_r_lt := r_le_pow_add_sum r m,
  apply hVX,
  apply hεV,
  rw metric.mem_ball,
  change |_ - _| < ε,
  rw abs_lt,
  rw ← nnreal.coe_lt_coe at h_r_lt,
  push_cast at h_r_lt ⊢,
  split,
  { suffices : (2⁻¹ : ℝ) ^ m ≤ ε,
      linarith,
    have hB' : (2⁻¹ : ℝ) ^ B ≤ ε, assumption_mod_cast,
    refine le_trans _ hB',
    refine pow_le_pow_of_le_one (by norm_num) (by norm_num) _,
    change B + 1 ≤ m + 1 at hm,
    linarith,
  },
  { rw ← nnreal.coe_le_coe at h_le_r,
    push_cast at h_le_r,
    linarith,
  }
end

theorem tsum : ∑' n, (digit r n : ℝ≥0) * 2⁻¹ ^ n = r :=
has_sum.tsum_eq (has_sum r)

end digit

end nat

end nnreal


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker, Aaron Anderson
-/

import algebra.gcd_monoid
import ring_theory.integral_domain
import ring_theory.noetherian

/-!

# Unique factorization

## Main Definitions
* `wf_dvd_monoid` holds for `monoid`s for which a strict divisibility relation is
  well-founded.
* `unique_factorization_monoid` holds for `wf_dvd_monoid`s where
  `irreducible` is equivalent to `prime`

## To do
* set up the complete lattice structure on `factor_set`.

-/

variables {α : Type*}
local infix ` ~ᵤ ` : 50 := associated

/-- Well-foundedness of the strict version of |, which is equivalent to the descending chain
condition on divisibility and to the ascending chain condition on
principal ideals in an integral domain.
  -/
class wf_dvd_monoid (α : Type*) [comm_monoid_with_zero α] : Prop :=
(well_founded_dvd_not_unit : well_founded (@dvd_not_unit α _))

export wf_dvd_monoid (well_founded_dvd_not_unit)

@[priority 100]  -- see Note [lower instance priority]
instance is_noetherian_ring.wf_dvd_monoid [integral_domain α] [is_noetherian_ring α] :
  wf_dvd_monoid α :=
⟨by { convert inv_image.wf (λ a, ideal.span ({a} : set α)) (well_founded_submodule_gt _ _),
      ext,
      exact ideal.span_singleton_lt_span_singleton.symm }⟩

namespace wf_dvd_monoid

variables [comm_monoid_with_zero α]
open associates nat

theorem of_wf_dvd_monoid_associates (h : wf_dvd_monoid (associates α)): wf_dvd_monoid α :=
⟨begin
  haveI := h,
  refine (surjective.well_founded_iff mk_surjective _).2 wf_dvd_monoid.well_founded_dvd_not_unit,
  intros, rw mk_dvd_not_unit_mk_iff
end⟩

variables [wf_dvd_monoid α]

instance wf_dvd_monoid_associates : wf_dvd_monoid (associates α) :=
⟨begin
  refine (surjective.well_founded_iff mk_surjective _).1 wf_dvd_monoid.well_founded_dvd_not_unit,
  intros, rw mk_dvd_not_unit_mk_iff
end⟩

theorem well_founded_associates : well_founded ((<) : associates α → associates α → Prop) :=
subrelation.wf (λ x y, dvd_not_unit_of_lt) wf_dvd_monoid.well_founded_dvd_not_unit

local attribute [elab_as_eliminator] well_founded.fix

lemma exists_irreducible_factor {a : α} (ha : ¬ is_unit a) (ha0 : a ≠ 0) :
  ∃ i, irreducible i ∧ i ∣ a :=
(irreducible_or_factor a ha).elim (λ hai, ⟨a, hai, dvd_refl _⟩)
  (well_founded.fix
    wf_dvd_monoid.well_founded_dvd_not_unit
    (λ a ih ha ha0 ⟨x, y, hx, hy, hxy⟩,
      have hx0 : x ≠ 0, from λ hx0, ha0 (by rw [← hxy, hx0, zero_mul]),
      (irreducible_or_factor x hx).elim
        (λ hxi, ⟨x, hxi, hxy ▸ by simp⟩)
        (λ hxf, let ⟨i, hi⟩ := ih x ⟨hx0, y, hy, hxy.symm⟩ hx hx0 hxf in
          ⟨i, hi.1, dvd.trans hi.2 (hxy ▸ by simp)⟩)) a ha ha0)

@[elab_as_eliminator] lemma induction_on_irreducible {P : α → Prop} (a : α)
  (h0 : P 0) (hu : ∀ u : α, is_unit u → P u)
  (hi : ∀ a i : α, a ≠ 0 → irreducible i → P a → P (i * a)) :
  P a :=
by haveI := classical.dec; exact
well_founded.fix wf_dvd_monoid.well_founded_dvd_not_unit
  (λ a ih, if ha0 : a = 0 then ha0.symm ▸ h0
    else if hau : is_unit a then hu a hau
    else let ⟨i, hii, ⟨b, hb⟩⟩ := exists_irreducible_factor hau ha0 in
      have hb0 : b ≠ 0, from λ hb0, by simp * at *,
      hb.symm ▸ hi _ _ hb0 hii (ih _ ⟨hb0, i,
        hii.1, by rw [hb, mul_comm]⟩))
  a

lemma exists_factors (a : α) : a ≠ 0 →
  ∃f : multiset α, (∀b ∈ f, irreducible b) ∧ associated f.prod a :=
wf_dvd_monoid.induction_on_irreducible a
  (λ h, (h rfl).elim)
  (λ u hu _, ⟨0, ⟨by simp [hu], associated.symm (by simp [hu, associated_one_iff_is_unit])⟩⟩)
  (λ a i ha0 hii ih hia0,
    let ⟨s, hs⟩ := ih ha0 in
    ⟨i ::ₘ s, ⟨by clear _let_match; finish,
      by { rw multiset.prod_cons,
           exact associated_mul_mul (by refl) hs.2 }⟩⟩)

end wf_dvd_monoid

theorem wf_dvd_monoid.of_well_founded_associates [comm_cancel_monoid_with_zero α]
  (h : well_founded ((<) : associates α → associates α → Prop)) : wf_dvd_monoid α :=
wf_dvd_monoid.of_wf_dvd_monoid_associates
  ⟨by { convert h, ext, exact associates.dvd_not_unit_iff_lt }⟩

theorem wf_dvd_monoid.iff_well_founded_associates [comm_cancel_monoid_with_zero α] :
  wf_dvd_monoid α ↔ well_founded ((<) : associates α → associates α → Prop) :=
⟨by apply wf_dvd_monoid.well_founded_associates, wf_dvd_monoid.of_well_founded_associates⟩
section prio
set_option default_priority 100 -- see Note [default priority]
/-- unique factorization monoids.

These are defined as `comm_cancel_monoid_with_zero`s with well-founded strict divisibility
relations, but this is equivalent to more familiar definitions:

Each element (except zero) is uniquely represented as a multiset of irreducible factors.
Uniqueness is only up to associated elements.

Each element (except zero) is non-uniquely represented as a multiset
of prime factors.

To define a UFD using the definition in terms of multisets
of irreducible factors, use the definition `of_exists_unique_irreducible_factors`

To define a UFD using the definition in terms of multisets
of prime factors, use the definition `of_exists_prime_factors`

-/
class unique_factorization_monoid (α : Type*) [comm_cancel_monoid_with_zero α]
  extends wf_dvd_monoid α : Prop :=
(irreducible_iff_prime : ∀ {a : α}, irreducible a ↔ prime a)

instance ufm_of_gcd_of_wf_dvd_monoid [nontrivial α] [comm_cancel_monoid_with_zero α]
  [wf_dvd_monoid α] [gcd_monoid α] : unique_factorization_monoid α :=
{ irreducible_iff_prime := λ _, gcd_monoid.irreducible_iff_prime
  .. ‹wf_dvd_monoid α› }

instance associates.ufm [comm_cancel_monoid_with_zero α]
  [unique_factorization_monoid α] : unique_factorization_monoid (associates α) :=
{ irreducible_iff_prime := by { rw ← associates.irreducible_iff_prime_iff,
    apply unique_factorization_monoid.irreducible_iff_prime, }
  .. (wf_dvd_monoid.wf_dvd_monoid_associates : wf_dvd_monoid (associates α)) }

end prio

namespace unique_factorization_monoid
variables [comm_cancel_monoid_with_zero α] [unique_factorization_monoid α]

theorem exists_prime_factors (a : α) : a ≠ 0 →
  ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a :=
by { simp_rw ← unique_factorization_monoid.irreducible_iff_prime,
     apply wf_dvd_monoid.exists_factors a }

@[elab_as_eliminator] lemma induction_on_prime {P : α → Prop}
  (a : α) (h₁ : P 0) (h₂ : ∀ x : α, is_unit x → P x)
  (h₃ : ∀ a p : α, a ≠ 0 → prime p → P a → P (p * a)) : P a :=
begin
  simp_rw ← unique_factorization_monoid.irreducible_iff_prime at h₃,
  exact wf_dvd_monoid.induction_on_irreducible a h₁ h₂ h₃,
end

lemma factors_unique : ∀{f g : multiset α},
  (∀x∈f, irreducible x) → (∀x∈g, irreducible x) → f.prod ~ᵤ g.prod →
  multiset.rel associated f g :=
by haveI := classical.dec_eq α; exact
λ f, multiset.induction_on f
  (λ g _ hg h,
    multiset.rel_zero_left.2 $
      multiset.eq_zero_of_forall_not_mem (λ x hx,
        have is_unit g.prod, by simpa [associated_one_iff_is_unit] using h.symm,
        (hg x hx).not_unit (is_unit_iff_dvd_one.2 (dvd.trans (multiset.dvd_prod hx)
          (is_unit_iff_dvd_one.1 this)))))
  (λ p f ih g hf hg hfg,
    let ⟨b, hbg, hb⟩ := exists_associated_mem_of_dvd_prod
      (irreducible_iff_prime.1 (hf p (by simp)))
      (λ q hq, irreducible_iff_prime.1 (hg _ hq)) $
        (dvd_iff_dvd_of_rel_right hfg).1
          (show p ∣ (p ::ₘ f).prod, by simp) in
    begin
      rw ← multiset.cons_erase hbg,
      exact multiset.rel.cons hb (ih (λ q hq, hf _ (by simp [hq]))
        (λ q (hq : q ∈ g.erase b), hg q (multiset.mem_of_mem_erase hq))
        (associated_mul_left_cancel
          (by rwa [← multiset.prod_cons, ← multiset.prod_cons, multiset.cons_erase hbg]) hb
        (hf p (by simp)).ne_zero))
    end)

end unique_factorization_monoid

lemma prime_factors_unique [comm_cancel_monoid_with_zero α] : ∀ {f g : multiset α},
  (∀ x ∈ f, prime x) → (∀ x ∈ g, prime x) → f.prod ~ᵤ g.prod →
  multiset.rel associated f g :=
by haveI := classical.dec_eq α; exact
λ f, multiset.induction_on f
  (λ g _ hg h,
    multiset.rel_zero_left.2 $
    multiset.eq_zero_of_forall_not_mem $ λ x hx,
    have is_unit g.prod, by simpa [associated_one_iff_is_unit] using h.symm,
    (irreducible_of_prime $ hg x hx).not_unit $ is_unit_iff_dvd_one.2 $
    dvd.trans (multiset.dvd_prod hx) (is_unit_iff_dvd_one.1 this))
  (λ p f ih g hf hg hfg,
    let ⟨b, hbg, hb⟩ := exists_associated_mem_of_dvd_prod
      (hf p (by simp)) (λ q hq, hg _ hq) $
        (dvd_iff_dvd_of_rel_right hfg).1
          (show p ∣ (p ::ₘ f).prod, by simp) in
    begin
      rw ← multiset.cons_erase hbg,
      exact multiset.rel.cons hb (ih (λ q hq, hf _ (by simp [hq]))
        (λ q (hq : q ∈ g.erase b), hg q (multiset.mem_of_mem_erase hq))
        (associated_mul_left_cancel
          (by rwa [← multiset.prod_cons, ← multiset.prod_cons, multiset.cons_erase hbg]) hb
        (hf p (by simp)).ne_zero))
    end)

/-- If an irreducible has a prime factorization,
  then it is an associate of one of its prime factors. -/
lemma prime_factors_irreducible [comm_cancel_monoid_with_zero α] {a : α} {f : multiset α}
  (ha : irreducible a) (pfa : (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a) :
  ∃ p, a ~ᵤ p ∧ f = p ::ₘ 0 :=
begin
  haveI := classical.dec_eq α,
  refine multiset.induction_on f (λ h, (ha.not_unit
    (associated_one_iff_is_unit.1 (associated.symm h))).elim) _ pfa.2 pfa.1,
  rintros p s _ ⟨u, hu⟩ hs,
  use p,
  have hs0 : s = 0,
  { by_contra hs0,
    obtain ⟨q, hq⟩ := multiset.exists_mem_of_ne_zero hs0,
    apply (hs q (by simp [hq])).2.1,
    refine (ha.is_unit_or_is_unit (_ : _ = ((p * ↑u) * (s.erase q).prod) * _)).resolve_left _,
    { rw [mul_right_comm _ _ q, mul_assoc, ← multiset.prod_cons, multiset.cons_erase hq, ← hu,
        mul_comm, mul_comm p _, mul_assoc],
      simp, },
    apply mt is_unit_of_mul_is_unit_left (mt is_unit_of_mul_is_unit_left _),
    apply (hs p (multiset.mem_cons_self _ _)).2.1 },
  simp only [mul_one, multiset.prod_cons, multiset.prod_zero, hs0] at *,
  exact ⟨associated.symm ⟨u, hu⟩, rfl⟩,
end

section exists_prime_factors

variables [comm_cancel_monoid_with_zero α]
variables (pf : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a)

include pf

lemma wf_dvd_monoid.of_exists_prime_factors : wf_dvd_monoid α :=
⟨begin
  classical,
  apply rel_hom.well_founded (rel_hom.mk _ _) (with_top.well_founded_lt nat.lt_wf),
  { intro a,
    by_cases h : a = 0, { exact ⊤ },
    exact (classical.some (pf a h)).card },

  rintros a b ⟨ane0, ⟨c, hc, b_eq⟩⟩,
  rw dif_neg ane0,
  by_cases h : b = 0, { simp [h, lt_top_iff_ne_top] },
  rw [dif_neg h, with_top.coe_lt_coe],
  have cne0 : c ≠ 0, { refine mt (λ con, _) h, rw [b_eq, con, mul_zero] },
  calc multiset.card (classical.some (pf a ane0))
      < _ + multiset.card (classical.some (pf c cne0)) :
    lt_add_of_pos_right _ (multiset.card_pos.mpr (λ con, hc (associated_one_iff_is_unit.mp _)))
  ... = multiset.card (classical.some (pf a ane0) + classical.some (pf c cne0)) :
    (multiset.card_add _ _).symm
  ... = multiset.card (classical.some (pf b h)) :
    multiset.card_eq_card_of_rel (prime_factors_unique _ (classical.some_spec (pf _ h)).1 _),
  { convert (classical.some_spec (pf c cne0)).2.symm,
    rw [con, multiset.prod_zero] },
  { intros x hadd,
    rw multiset.mem_add at hadd,
    cases hadd; apply (classical.some_spec (pf _ _)).1 _ hadd },
  { rw multiset.prod_add,
    transitivity a * c,
    { apply associated_mul_mul; apply (classical.some_spec (pf _ _)).2 },
    { rw ← b_eq,
      apply (classical.some_spec (pf _ _)).2.symm, } }
end⟩

lemma irreducible_iff_prime_of_exists_prime_factors {p : α} : irreducible p ↔ prime p :=
begin
  by_cases hp0 : p = 0,
  { simp [hp0] },
  refine ⟨λ h, _, irreducible_of_prime⟩,
  obtain ⟨f, hf⟩ := pf p hp0,
  obtain ⟨q, hq, rfl⟩ := prime_factors_irreducible h hf,
  rw prime_iff_of_associated hq,
  exact hf.1 q (multiset.mem_cons_self _ _)
end

theorem unique_factorization_monoid.of_exists_prime_factors :
  unique_factorization_monoid α :=
{ irreducible_iff_prime := λ _, irreducible_iff_prime_of_exists_prime_factors pf,
  .. wf_dvd_monoid.of_exists_prime_factors pf }

end exists_prime_factors

theorem unique_factorization_monoid.iff_exists_prime_factors [comm_cancel_monoid_with_zero α] :
  unique_factorization_monoid α ↔
    (∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, prime b) ∧ f.prod ~ᵤ a) :=
⟨λ h, @unique_factorization_monoid.exists_prime_factors _ _ h,
  unique_factorization_monoid.of_exists_prime_factors⟩

theorem irreducible_iff_prime_of_exists_unique_irreducible_factors [comm_cancel_monoid_with_zero α]
  (eif : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, irreducible b) ∧ f.prod ~ᵤ a)
  (uif : ∀ (f g : multiset α),
  (∀ x ∈ f, irreducible x) → (∀ x ∈ g, irreducible x) → f.prod ~ᵤ g.prod →
    multiset.rel associated f g)
  (p : α) : irreducible p ↔ prime p :=
⟨by letI := classical.dec_eq α; exact λ hpi,
    ⟨hpi.ne_zero, hpi.1,
      λ a b ⟨x, hx⟩,
      if hab0 : a * b = 0
      then (eq_zero_or_eq_zero_of_mul_eq_zero hab0).elim
        (λ ha0, by simp [ha0])
        (λ hb0, by simp [hb0])
      else
        have hx0 : x ≠ 0, from λ hx0, by simp * at *,
        have ha0 : a ≠ 0, from left_ne_zero_of_mul hab0,
        have hb0 : b ≠ 0, from right_ne_zero_of_mul hab0,
        begin
          cases eif x hx0 with fx hfx,
          cases eif a ha0 with fa hfa,
          cases eif b hb0 with fb hfb,
          have h : multiset.rel associated (p ::ₘ fx) (fa + fb),
          { apply uif,
            { exact λ i hi, (multiset.mem_cons.1 hi).elim (λ hip, hip.symm ▸ hpi) (hfx.1 _), },
            { exact λ i hi, (multiset.mem_add.1 hi).elim (hfa.1 _) (hfb.1 _), },
            calc multiset.prod (p ::ₘ fx)
                  ~ᵤ a * b : by rw [hx, multiset.prod_cons];
                    exact associated_mul_mul (by refl) hfx.2
              ... ~ᵤ (fa).prod * (fb).prod :
                associated_mul_mul hfa.2.symm hfb.2.symm
              ... = _ : by rw multiset.prod_add, },
          exact let ⟨q, hqf, hq⟩ := multiset.exists_mem_of_rel_of_mem h
          (multiset.mem_cons_self p _) in
        (multiset.mem_add.1 hqf).elim
          (λ hqa, or.inl $ (dvd_iff_dvd_of_rel_left hq).2 $
            (dvd_iff_dvd_of_rel_right hfa.2).1
              (multiset.dvd_prod hqa))
          (λ hqb, or.inr $ (dvd_iff_dvd_of_rel_left hq).2 $
            (dvd_iff_dvd_of_rel_right hfb.2).1
              (multiset.dvd_prod hqb))
        end⟩, irreducible_of_prime⟩

theorem unique_factorization_monoid.of_exists_unique_irreducible_factors
  [comm_cancel_monoid_with_zero α]
  (eif : ∀ (a : α), a ≠ 0 → ∃ f : multiset α, (∀b ∈ f, irreducible b) ∧ f.prod ~ᵤ a)
  (uif : ∀ (f g : multiset α),
  (∀ x ∈ f, irreducible x) → (∀ x ∈ g, irreducible x) → f.prod ~ᵤ g.prod →
    multiset.rel associated f g) :
  unique_factorization_monoid α :=
unique_factorization_monoid.of_exists_prime_factors (by
  { convert eif,
    simp_rw irreducible_iff_prime_of_exists_unique_irreducible_factors eif uif })

namespace unique_factorization_monoid
variables [comm_cancel_monoid_with_zero α] [decidable_eq α] [nontrivial α] [normalization_monoid α]
variables [unique_factorization_monoid α]

/-- Noncomputably determines the multiset of prime factors. -/
noncomputable def factors (a : α) : multiset α := if h : a = 0 then 0 else
multiset.map normalize $ classical.some (unique_factorization_monoid.exists_prime_factors a h)

theorem factors_prod {a : α} (ane0 : a ≠ 0) : associated (factors a).prod a :=
begin
  rw [factors, dif_neg ane0],
  refine associated.trans _ (classical.some_spec (exists_prime_factors a ane0)).2,
  rw [← associates.mk_eq_mk_iff_associated, ← associates.prod_mk, ← associates.prod_mk,
      multiset.map_map],
  congr' 2,
  ext,
  rw [function.comp_apply, associates.mk_normalize],
end

theorem prime_of_factor {a : α} : ∀ (x : α), x ∈ factors a → prime x :=
begin
  rw [factors],
  split_ifs with ane0, { simp },
  intros x hx, rcases multiset.mem_map.1 hx with ⟨y, ⟨hy, rfl⟩⟩,
  rw prime_iff_of_associated (normalize_associated),
  exact (classical.some_spec (unique_factorization_monoid.exists_prime_factors a ane0)).1 y hy,
end

theorem irreducible_of_factor {a : α} : ∀ (x : α), x ∈ factors a → irreducible x :=
λ x h, irreducible_of_prime (prime_of_factor x h)

theorem normalize_factor {a : α} : ∀ (x : α), x ∈ factors a → normalize x = x :=
begin
  rw factors,
  split_ifs with h, { simp },
  intros x hx,
  obtain ⟨y, hy, rfl⟩ := multiset.mem_map.1 hx,
  apply normalize_idem
end

lemma factors_irreducible {a : α} (ha : irreducible a) :
  factors a = normalize a ::ₘ 0 :=
begin
  obtain ⟨p, a_assoc, hp⟩ := prime_factors_irreducible ha
    ⟨prime_of_factor, factors_prod ha.ne_zero⟩,
  have p_mem : p ∈ factors a,
  { rw hp, apply multiset.mem_cons_self },
  convert hp,
  rwa [← normalize_factor p p_mem, normalize_eq_normalize_iff, dvd_dvd_iff_associated]
end

lemma exists_mem_factors_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) : p ∣ a →
  ∃ q ∈ factors a, p ~ᵤ q :=
λ ⟨b, hb⟩,
have hb0 : b ≠ 0, from λ hb0, by simp * at *,
have multiset.rel associated (p ::ₘ factors b) (factors a),
  from factors_unique
    (λ x hx, (multiset.mem_cons.1 hx).elim (λ h, h.symm ▸ hp)
      (irreducible_of_factor _))
    irreducible_of_factor
    (associated.symm $ calc multiset.prod (factors a) ~ᵤ a : factors_prod ha0
      ... = p * b : hb
      ... ~ᵤ multiset.prod (p ::ₘ factors b) :
        by rw multiset.prod_cons; exact associated_mul_mul
          (associated.refl _)
          (associated.symm (factors_prod hb0))),
multiset.exists_mem_of_rel_of_mem this (by simp)

@[simp] lemma factors_zero : factors (0 : α) = 0 := dif_pos rfl

@[simp] lemma factors_one : factors (1 : α) = 0 :=
begin
  rw ← multiset.rel_zero_right,
  apply factors_unique irreducible_of_factor,
  { intros x hx,
    exfalso,
    apply multiset.not_mem_zero x hx },
  { simp [factors_prod one_ne_zero] },
  apply_instance
end

@[simp] lemma factors_mul {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  factors (x * y) = factors x + factors y :=
begin
  have h : (normalize : α → α) = associates.out ∘ associates.mk,
  { ext, rw [function.comp_apply, associates.out_mk], },
  rw [← multiset.map_id' (factors (x * y)), ← multiset.map_id' (factors x),
    ← multiset.map_id' (factors y), ← multiset.map_congr normalize_factor,
    ← multiset.map_congr normalize_factor, ← multiset.map_congr normalize_factor,
    ← multiset.map_add, h, ← multiset.map_map associates.out, eq_comm,
    ← multiset.map_map associates.out],
  refine congr rfl _,
  apply multiset.map_mk_eq_map_mk_of_rel,
  apply factors_unique,
  { intros x hx,
    rcases multiset.mem_add.1 hx with hx | hx;
    exact irreducible_of_factor x hx },
  { exact irreducible_of_factor },
  { rw multiset.prod_add,
    exact associated.trans (associated_mul_mul (factors_prod hx) (factors_prod hy))
      (factors_prod (mul_ne_zero hx hy)).symm, }
end

@[simp] lemma factors_pow {x : α} (n : ℕ) :
  factors (x ^ n) = n • factors x :=
begin
  induction n with n ih,
  { simp },
  by_cases h0 : x = 0,
  { simp [h0, zero_pow n.succ_pos, smul_zero] },
  rw [pow_succ, succ_nsmul, factors_mul h0 (pow_ne_zero _ h0), ih],
end

lemma dvd_iff_factors_le_factors {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  x ∣ y ↔ factors x ≤ factors y :=
begin
  split,
  { rintro ⟨c, rfl⟩,
    simp [hx, right_ne_zero_of_mul hy] },
  { rw [← dvd_iff_dvd_of_rel_left (factors_prod hx), ← dvd_iff_dvd_of_rel_right (factors_prod hy)],
    apply multiset.prod_dvd_prod }
end

end unique_factorization_monoid

namespace unique_factorization_monoid

open_locale classical
open multiset associates
noncomputable theory

variables [comm_cancel_monoid_with_zero α] [nontrivial α] [unique_factorization_monoid α]

/-- Noncomputably defines a `normalization_monoid` structure on a `unique_factorization_monoid`. -/
protected def normalization_monoid : normalization_monoid α :=
normalization_monoid_of_monoid_hom_right_inverse {
  to_fun := λ a : associates α, if a = 0 then 0 else ((factors a).map
    (classical.some mk_surjective.has_right_inverse : associates α → α)).prod,
  map_one' := by simp,
  map_mul' := λ x y, by {
    by_cases hx : x = 0, { simp [hx] },
    by_cases hy : y = 0, { simp [hy] },
    simp [hx, hy] } } begin
  intro x,
  dsimp,
  by_cases hx : x = 0, { simp [hx] },
  have h : associates.mk_monoid_hom ∘ (classical.some mk_surjective.has_right_inverse) =
           (id : associates α → associates α),
  { ext x,
    rw [function.comp_apply, mk_monoid_hom_apply,
      classical.some_spec mk_surjective.has_right_inverse x],
    refl },
  rw [if_neg hx, ← mk_monoid_hom_apply, monoid_hom.map_multiset_prod, map_map, h, map_id,
      ← associated_iff_eq],
  apply factors_prod hx
end

instance : inhabited (normalization_monoid α) := ⟨unique_factorization_monoid.normalization_monoid⟩

end unique_factorization_monoid

namespace unique_factorization_monoid

variables {R : Type*} [comm_cancel_monoid_with_zero R] [unique_factorization_monoid R]

lemma no_factors_of_no_prime_factors {a b : R} (ha : a ≠ 0)
  (h : (∀ {d}, d ∣ a → d ∣ b → ¬ prime d)) : ∀ {d}, d ∣ a → d ∣ b → is_unit d :=
λ d, induction_on_prime d
  (by { simp only [zero_dvd_iff], intros, contradiction })
  (λ x hx _ _, hx)
  (λ d q hp hq ih dvd_a dvd_b,
    absurd hq (h (dvd_of_mul_right_dvd dvd_a) (dvd_of_mul_right_dvd dvd_b)))

/-- Euclid's lemma: if `a ∣ b * c` and `a` and `c` have no common prime factors, `a ∣ b`.
Compare `is_coprime.dvd_of_dvd_mul_left`. -/
lemma dvd_of_dvd_mul_left_of_no_prime_factors {a b c : R} (ha : a ≠ 0) :
  (∀ {d}, d ∣ a → d ∣ c → ¬ prime d) → a ∣ b * c → a ∣ b :=
begin
  refine induction_on_prime c _ _ _,
  { intro no_factors,
    simp only [dvd_zero, mul_zero, forall_prop_of_true],
    haveI := classical.prop_decidable,
    exact is_unit_iff_forall_dvd.mp
      (no_factors_of_no_prime_factors ha @no_factors (dvd_refl a) (dvd_zero a)) _ },
  { rintros _ ⟨x, rfl⟩ _ a_dvd_bx,
    apply units.dvd_mul_right.mp a_dvd_bx },
  { intros c p hc hp ih no_factors a_dvd_bpc,
    apply ih (λ q dvd_a dvd_c hq, no_factors dvd_a (dvd_mul_of_dvd_right dvd_c _) hq),
    rw mul_left_comm at a_dvd_bpc,
    refine or.resolve_left (left_dvd_or_dvd_right_of_dvd_prime_mul hp a_dvd_bpc) (λ h, _),
    exact no_factors h (dvd_mul_right p c) hp }
end

/-- Euclid's lemma: if `a ∣ b * c` and `a` and `b` have no common prime factors, `a ∣ c`.
Compare `is_coprime.dvd_of_dvd_mul_right`. -/
lemma dvd_of_dvd_mul_right_of_no_prime_factors {a b c : R} (ha : a ≠ 0)
  (no_factors : ∀ {d}, d ∣ a → d ∣ b → ¬ prime d) : a ∣ b * c → a ∣ c :=
by simpa [mul_comm b c] using dvd_of_dvd_mul_left_of_no_prime_factors ha @no_factors

/-- If `a ≠ 0, b` are elements of a unique factorization domain, then dividing
out their common factor `c'` gives `a'` and `b'` with no factors in common. -/
lemma exists_reduced_factors : ∀ (a ≠ (0 : R)) b,
  ∃ a' b' c', (∀ {d}, d ∣ a' → d ∣ b' → is_unit d) ∧ c' * a' = a ∧ c' * b' = b :=
begin
  haveI := classical.prop_decidable,
  intros a,
  refine induction_on_prime a _ _ _,
  { intros, contradiction },
  { intros a a_unit a_ne_zero b,
    use [a, b, 1],
    split,
    { intros p p_dvd_a _,
      exact is_unit_of_dvd_unit p_dvd_a a_unit },
    { simp } },
  { intros a p a_ne_zero p_prime ih_a pa_ne_zero b,
    by_cases p ∣ b,
    { rcases h with ⟨b, rfl⟩,
      obtain ⟨a', b', c', no_factor, ha', hb'⟩ := ih_a a_ne_zero b,
      refine ⟨a', b', p * c', @no_factor, _, _⟩,
      { rw [mul_assoc, ha'] },
      { rw [mul_assoc, hb'] } },
    { obtain ⟨a', b', c', coprime, rfl, rfl⟩ := ih_a a_ne_zero b,
      refine ⟨p * a', b', c', _, mul_left_comm _ _ _, rfl⟩,
      intros q q_dvd_pa' q_dvd_b',
      cases left_dvd_or_dvd_right_of_dvd_prime_mul p_prime q_dvd_pa' with p_dvd_q q_dvd_a',
      { have : p ∣ c' * b' := dvd_mul_of_dvd_right (dvd_trans p_dvd_q q_dvd_b') _,
        contradiction },
      exact coprime q_dvd_a' q_dvd_b'  } }
end

lemma exists_reduced_factors' (a b : R) (hb : b ≠ 0) :
  ∃ a' b' c', (∀ {d}, d ∣ a' → d ∣ b' → is_unit d) ∧ c' * a' = a ∧ c' * b' = b :=
let ⟨b', a', c', no_factor, hb, ha⟩ := exists_reduced_factors b hb a
in ⟨a', b', c', λ _ hpb hpa, no_factor hpa hpb, ha, hb⟩

section multiplicity
variables [nontrivial R] [normalization_monoid R] [decidable_eq R]
variables [decidable_rel (has_dvd.dvd : R → R → Prop)]
open multiplicity multiset

lemma le_multiplicity_iff_repeat_le_factors {a b : R} {n : ℕ} (ha : irreducible a) (hb : b ≠ 0) :
  ↑n ≤ multiplicity a b ↔ repeat (normalize a) n ≤ factors b :=
begin
  rw ← pow_dvd_iff_le_multiplicity,
  revert b,
  induction n with n ih, { simp },
  intros b hb,
  split,
  { rintro ⟨c, rfl⟩,
    rw [ne.def, pow_succ, mul_assoc, mul_eq_zero, decidable.not_or_iff_and_not] at hb,
    rw [pow_succ, mul_assoc, factors_mul hb.1 hb.2, repeat_succ, factors_irreducible ha,
      cons_add, cons_le_cons_iff, zero_add, ← ih hb.2],
    apply dvd.intro _ rfl },
  { rw [multiset.le_iff_exists_add],
    rintro ⟨u, hu⟩,
    rw [← dvd_iff_dvd_of_rel_right (factors_prod hb), hu, prod_add, prod_repeat],
    apply dvd.trans (dvd_of_associated (associated_pow_pow _)) (dvd.intro u.prod rfl),
    apply associated_normalize }
end

lemma multiplicity_eq_count_factors {a b : R} (ha : irreducible a) (hb : b ≠ 0) :
  multiplicity a b = (factors b).count (normalize a) :=
begin
  apply le_antisymm,
  { apply enat.le_of_lt_add_one,
    rw [← enat.coe_one, ← enat.coe_add, lt_iff_not_ge, ge_iff_le,
      le_multiplicity_iff_repeat_le_factors ha hb, ← le_count_iff_repeat_le],
    simp },
  rw [le_multiplicity_iff_repeat_le_factors ha hb, ← le_count_iff_repeat_le],
end

end multiplicity

end unique_factorization_monoid

namespace associates
open unique_factorization_monoid associated multiset
variables [comm_cancel_monoid_with_zero α]

/-- `factor_set α` representation elements of unique factorization domain as multisets.
`multiset α` produced by `factors` are only unique up to associated elements, while the multisets in
`factor_set α` are unqiue by equality and restricted to irreducible elements. This gives us a
representation of each element as a unique multisets (or the added ⊤ for 0), which has a complete
lattice struture. Infimum is the greatest common divisor and supremum is the least common multiple.
-/
@[reducible] def {u} factor_set (α : Type u) [comm_cancel_monoid_with_zero α] :
  Type u :=
with_top (multiset { a : associates α // irreducible a })

local attribute [instance] associated.setoid

theorem factor_set.coe_add {a b : multiset { a : associates α // irreducible a }} :
  (↑(a + b) : factor_set α) = a + b :=
by norm_cast

lemma factor_set.sup_add_inf_eq_add [decidable_eq (associates α)] :
  ∀(a b : factor_set α), a ⊔ b + a ⊓ b = a + b
| none     b        := show ⊤ ⊔ b + ⊤ ⊓ b = ⊤ + b, by simp
| a        none     := show a ⊔ ⊤ + a ⊓ ⊤ = a + ⊤, by simp
| (some a) (some b) := show (a : factor_set α) ⊔ b + a ⊓ b = a + b, from
  begin
    rw [← with_top.coe_sup, ← with_top.coe_inf, ← with_top.coe_add, ← with_top.coe_add,
      with_top.coe_eq_coe],
    exact multiset.union_add_inter _ _
  end

/-- Evaluates the product of a `factor_set` to be the product of the corresponding multiset,
  or `0` if there is none. -/
def factor_set.prod : factor_set α → associates α
| none     := 0
| (some s) := (s.map coe).prod

@[simp] theorem prod_top : (⊤ : factor_set α).prod = 0 := rfl

@[simp] theorem prod_coe {s : multiset { a : associates α // irreducible a }} :
  (s : factor_set α).prod = (s.map coe).prod :=
rfl

@[simp] theorem prod_add : ∀(a b : factor_set α), (a + b).prod = a.prod * b.prod
| none b    := show (⊤ + b).prod = (⊤:factor_set α).prod * b.prod, by simp
| a    none := show (a + ⊤).prod = a.prod * (⊤:factor_set α).prod, by simp
| (some a) (some b) :=
  show (↑a + ↑b:factor_set α).prod = (↑a:factor_set α).prod * (↑b:factor_set α).prod,
    by rw [← factor_set.coe_add, prod_coe, prod_coe, prod_coe, multiset.map_add, multiset.prod_add]

theorem prod_mono : ∀{a b : factor_set α}, a ≤ b → a.prod ≤ b.prod
| none b h := have b = ⊤, from top_unique h, by rw [this, prod_top]; exact le_refl _
| a none h := show a.prod ≤ (⊤ : factor_set α).prod, by simp; exact le_top
| (some a) (some b) h := prod_le_prod $ multiset.map_le_map $ with_top.coe_le_coe.1 $ h

/-- `bcount p s` is the multiplicity of `p` in the factor_set `s` (with bundled `p`)-/
def bcount [decidable_eq (associates α)] (p : {a : associates α // irreducible a}) :
  factor_set α → ℕ
| none := 0
| (some s) := s.count p

variables [dec_irr : Π (p : associates α), decidable (irreducible p)]
include dec_irr

/-- `count p s` is the multiplicity of the irreducible `p` in the factor_set `s`.

If `p` is not irreducible, `count p s` is defined to be `0`. -/
def count [decidable_eq (associates α)] (p : associates α) :
  factor_set α → ℕ :=
if hp : irreducible p then bcount ⟨p, hp⟩  else 0

@[simp] lemma count_some [decidable_eq (associates α)] {p : associates α} (hp : irreducible p)
  (s : multiset _) : count p (some s) = s.count ⟨p, hp⟩:=
by { dunfold count, split_ifs, refl }

@[simp] lemma count_zero [decidable_eq (associates α)] {p : associates α} (hp : irreducible p) :
  count p (0 : factor_set α) = 0 :=
by { dunfold count, split_ifs, refl }

lemma count_reducible [decidable_eq (associates α)] {p : associates α} (hp : ¬ irreducible p) :
  count p = 0 := dif_neg hp

omit dec_irr

/-- membership in a factor_set (bundled version) -/
def bfactor_set_mem : {a : associates α // irreducible a} → (factor_set α) → Prop
| _ ⊤ := true
| p (some l) := p ∈ l

include dec_irr

/-- `factor_set_mem p s` is the predicate that the irreducible `p` is a member of
`s : factor_set α`.

If `p` is not irreducible, `p` is not a member of any `factor_set`. -/
def factor_set_mem (p : associates α) (s : factor_set α) : Prop :=
if hp : irreducible p then bfactor_set_mem ⟨p, hp⟩ s else false

instance : has_mem (associates α) (factor_set α) := ⟨factor_set_mem⟩

@[simp] lemma factor_set_mem_eq_mem (p : associates α) (s : factor_set α) :
  factor_set_mem p s = (p ∈ s) := rfl

lemma mem_factor_set_top {p : associates α} {hp : irreducible p} :
  p ∈ (⊤ : factor_set α) :=
begin
  dunfold has_mem.mem, dunfold factor_set_mem, split_ifs, exact trivial
end

lemma mem_factor_set_some {p : associates α} {hp : irreducible p}
   {l : multiset {a : associates α // irreducible a }} :
  p ∈ (l : factor_set α) ↔ subtype.mk p hp ∈ l :=
begin
  dunfold has_mem.mem, dunfold factor_set_mem, split_ifs, refl
end

lemma reducible_not_mem_factor_set {p : associates α} (hp : ¬ irreducible p)
  (s : factor_set α) : ¬ p ∈ s :=
λ (h : if hp : irreducible p then bfactor_set_mem ⟨p, hp⟩ s else false),
  by rwa [dif_neg hp] at h

omit dec_irr

variable [unique_factorization_monoid α]

theorem unique' {p q : multiset (associates α)} :
  (∀a∈p, irreducible a) → (∀a∈q, irreducible a) → p.prod = q.prod → p = q :=
begin
  apply multiset.induction_on_multiset_quot p,
  apply multiset.induction_on_multiset_quot q,
  assume s t hs ht eq,
  refine multiset.map_mk_eq_map_mk_of_rel (unique_factorization_monoid.factors_unique _ _ _),
  { exact assume a ha, ((irreducible_mk _).1 $ hs _ $ multiset.mem_map_of_mem _ ha) },
  { exact assume a ha, ((irreducible_mk _).1 $ ht _ $ multiset.mem_map_of_mem _ ha) },
  simpa [quot_mk_eq_mk, prod_mk, mk_eq_mk_iff_associated] using eq
end

variables [nontrivial α] [normalization_monoid α]

private theorem forall_map_mk_factors_irreducible [decidable_eq α] (x : α) (hx : x ≠ 0) :
  ∀(a : associates α), a ∈ multiset.map associates.mk (factors x) → irreducible a :=
begin
  assume a ha,
  rcases multiset.mem_map.1 ha with ⟨c, hc, rfl⟩,
  exact (irreducible_mk c).2 (irreducible_of_factor _ hc)
end

theorem prod_le_prod_iff_le {p q : multiset (associates α)}
  (hp : ∀a∈p, irreducible a) (hq : ∀a∈q, irreducible a) :
  p.prod ≤ q.prod ↔ p ≤ q :=
iff.intro
  begin
    classical,
    rintros ⟨⟨c⟩, eqc⟩,
    have : c ≠ 0, from (mt mk_eq_zero.2 $
      assume (hc : quot.mk setoid.r c = 0),
      have (0 : associates α) ∈ q, from prod_eq_zero_iff.1 $ eqc.symm ▸ hc.symm ▸ mul_zero _,
      not_irreducible_zero ((irreducible_mk 0).1 $ hq _ this)),
    have : associates.mk (factors c).prod = quot.mk setoid.r c,
      from mk_eq_mk_iff_associated.2 (factors_prod this),

    refine multiset.le_iff_exists_add.2 ⟨(factors c).map associates.mk, unique' hq _ _⟩,
    { assume x hx,
      rcases multiset.mem_add.1 hx with h | h,
      exact hp x h,
      exact forall_map_mk_factors_irreducible c ‹c ≠ 0› _ h },
    { simp [multiset.prod_add, prod_mk, *] at * }
  end
  prod_le_prod

variables [dec : decidable_eq α] [dec' : decidable_eq (associates α)]
include dec

/-- This returns the multiset of irreducible factors as a `factor_set`,
  a multiset of irreducible associates `with_top`. -/
noncomputable def factors' (a : α) :
  multiset { a : associates α // irreducible a } :=
(factors a).pmap (λa ha, ⟨associates.mk a, (irreducible_mk _).2 ha⟩)
  (irreducible_of_factor)

@[simp] theorem map_subtype_coe_factors' {a : α} :
  (factors' a).map coe = (factors a).map associates.mk :=
by simp [factors', multiset.map_pmap, multiset.pmap_eq_map]

theorem factors'_cong {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) (h : a ~ᵤ b) :
  factors' a = factors' b :=
have multiset.rel associated (factors a) (factors b), from
  factors_unique irreducible_of_factor irreducible_of_factor
    ((factors_prod ha).trans $ h.trans $ (factors_prod hb).symm),
by simpa [(multiset.map_eq_map subtype.coe_injective).symm, rel_associated_iff_map_eq_map.symm]

include dec'

/-- This returns the multiset of irreducible factors of an associate as a `factor_set`,
  a multiset of irreducible associates `with_top`. -/
noncomputable def factors (a : associates α) :
  factor_set α :=
begin
  refine (if h : a = 0 then ⊤ else
    quotient.hrec_on a (λx h, some $ factors' x) _ h),
  assume a b hab,
  apply function.hfunext,
  { have : a ~ᵤ 0 ↔ b ~ᵤ 0, from
      iff.intro (assume ha0, hab.symm.trans ha0) (assume hb0, hab.trans hb0),
    simp only [associated_zero_iff_eq_zero] at this,
    simp only [quotient_mk_eq_mk, this, mk_eq_zero] },
  exact (assume ha hb eq, heq_of_eq $ congr_arg some $ factors'_cong
    (λ c, ha (mk_eq_zero.2 c)) (λ c, hb (mk_eq_zero.2 c)) hab)
end

@[simp] theorem factors_0 : (0 : associates α).factors = ⊤ :=
dif_pos rfl

@[simp] theorem factors_mk (a : α) (h : a ≠ 0) :
  (associates.mk a).factors = factors' a :=
by { classical, apply dif_neg, apply (mt mk_eq_zero.1 h) }

theorem prod_factors : ∀(s : factor_set α), s.prod.factors = s
| none     := by simp [factor_set.prod]; refl
| (some s) :=
  begin
    unfold factor_set.prod,
    generalize eq_a : (s.map coe).prod = a,
    rcases a with ⟨a⟩,
    rw quot_mk_eq_mk at *,

    have : (s.map (coe : _ → associates α)).prod ≠ 0, from assume ha,
      let ⟨⟨a, ha⟩, h, eq⟩ := multiset.mem_map.1 (prod_eq_zero_iff.1 ha) in
      have irreducible (0 : associates α), from eq ▸ ha,
      not_irreducible_zero ((irreducible_mk _).1 this),
    have ha : a ≠ 0, by simp [*] at *,
    suffices : (unique_factorization_monoid.factors a).map associates.mk = s.map coe,
    { rw [factors_mk a ha],
      apply congr_arg some _,
      simpa [(multiset.map_eq_map subtype.coe_injective).symm] },

    refine unique'
      (forall_map_mk_factors_irreducible _ ha)
      (assume a ha, let ⟨⟨x, hx⟩, ha, eq⟩ := multiset.mem_map.1 ha in eq ▸ hx)
      _,
    rw [prod_mk, eq_a, mk_eq_mk_iff_associated],
    exact factors_prod ha
  end

@[simp]
theorem factors_prod (a : associates α) : a.factors.prod = a :=
quotient.induction_on a $ assume a, decidable.by_cases
  (assume : associates.mk a = 0, by simp [quotient_mk_eq_mk, this])
  (assume : associates.mk a ≠ 0,
    have a ≠ 0, by simp * at *,
    by simp [this, quotient_mk_eq_mk, prod_mk, mk_eq_mk_iff_associated.2 (factors_prod this)])

theorem eq_of_factors_eq_factors {a b : associates α} (h : a.factors = b.factors) : a = b :=
have a.factors.prod = b.factors.prod, by rw h,
by rwa [factors_prod, factors_prod] at this

omit dec dec'

theorem eq_of_prod_eq_prod {a b : factor_set α} (h : a.prod = b.prod) : a = b :=
begin
  classical,
  have : a.prod.factors = b.prod.factors, by rw h,
  rwa [prod_factors, prod_factors] at this
end

include dec dec'

@[simp] theorem factors_mul (a b : associates α) : (a * b).factors = a.factors + b.factors :=
eq_of_prod_eq_prod $ eq_of_factors_eq_factors $
  by rw [prod_add, factors_prod, factors_prod, factors_prod]

theorem factors_mono : ∀{a b : associates α}, a ≤ b → a.factors ≤ b.factors
| s t ⟨d, rfl⟩ := by rw [factors_mul] ; exact le_add_of_nonneg_right bot_le

theorem factors_le {a b : associates α} : a.factors ≤ b.factors ↔ a ≤ b :=
iff.intro
  (assume h, have a.factors.prod ≤ b.factors.prod, from prod_mono h,
    by rwa [factors_prod, factors_prod] at this)
  factors_mono

omit dec dec'

theorem prod_le {a b : factor_set α} : a.prod ≤ b.prod ↔ a ≤ b :=
begin
  classical,
  exact iff.intro
  (assume h, have a.prod.factors ≤ b.prod.factors, from factors_mono h,
    by rwa [prod_factors, prod_factors] at this)
  prod_mono
end

include dec dec'

noncomputable instance : has_sup (associates α) := ⟨λa b, (a.factors ⊔ b.factors).prod⟩
noncomputable instance : has_inf (associates α) := ⟨λa b, (a.factors ⊓ b.factors).prod⟩

noncomputable instance : bounded_lattice (associates α) :=
{ sup          := (⊔),
  inf          := (⊓),
  sup_le       :=
    assume a b c hac hbc, factors_prod c ▸ prod_mono (sup_le (factors_mono hac) (factors_mono hbc)),
  le_sup_left  := assume a b,
    le_trans (le_of_eq (factors_prod a).symm) $ prod_mono $ le_sup_left,
  le_sup_right := assume a b,
    le_trans (le_of_eq (factors_prod b).symm) $ prod_mono $ le_sup_right,
  le_inf :=
    assume a b c hac hbc, factors_prod a ▸ prod_mono (le_inf (factors_mono hac) (factors_mono hbc)),
  inf_le_left  := assume a b,
    le_trans (prod_mono inf_le_left) (le_of_eq (factors_prod a)),
  inf_le_right := assume a b,
    le_trans (prod_mono inf_le_right) (le_of_eq (factors_prod b)),
  .. associates.partial_order,
  .. associates.order_top,
  .. associates.order_bot }

lemma sup_mul_inf (a b : associates α) : (a ⊔ b) * (a ⊓ b) = a * b :=
show (a.factors ⊔ b.factors).prod * (a.factors ⊓ b.factors).prod = a * b,
begin
  refine eq_of_factors_eq_factors _,
  rw [← prod_add, prod_factors, factors_mul, factor_set.sup_add_inf_eq_add]
end

include dec_irr

lemma dvd_of_mem_factors {a p : associates α} {hp : irreducible p}
  (hm : p ∈ factors a) : p ∣ a :=
begin
  by_cases ha0 : a = 0, { rw ha0, exact dvd_zero p },
  obtain ⟨a0, nza, ha'⟩ := exists_non_zero_rep ha0,
  rw [← associates.factors_prod a],
  rw [← ha', factors_mk a0 nza] at hm ⊢,
  erw prod_coe,
  apply multiset.dvd_prod, apply multiset.mem_map.mpr,
  exact ⟨⟨p, hp⟩, mem_factor_set_some.mp hm, rfl⟩
end

omit dec'

lemma dvd_of_mem_factors' {a : α} {p : associates α} {hp : irreducible p} {hz : a ≠ 0}
  (h_mem : subtype.mk p hp ∈ factors' a) : p ∣ associates.mk a :=
by { haveI := classical.dec_eq (associates α),
  apply @dvd_of_mem_factors _ _ _ _ _ _ _ _ _ _ hp,
  rw factors_mk _ hz,
  apply mem_factor_set_some.2 h_mem }

omit dec_irr

lemma mem_factors'_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) (hd : p ∣ a) :
  subtype.mk (associates.mk p) ((irreducible_mk _).2 hp) ∈ factors' a :=
begin
  obtain ⟨q, hq, hpq⟩ := exists_mem_factors_of_dvd ha0 hp hd,
  apply multiset.mem_pmap.mpr, use q, use hq,
  exact subtype.eq (eq.symm (mk_eq_mk_iff_associated.mpr hpq))
end

include dec_irr

lemma mem_factors'_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  subtype.mk (associates.mk p) ((irreducible_mk _).2 hp) ∈ factors' a ↔ p ∣ a :=
begin
  split,
  { rw ← mk_dvd_mk, apply dvd_of_mem_factors', apply ha0 },
  { apply mem_factors'_of_dvd ha0 }
end

include dec'

lemma mem_factors_of_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) (hd : p ∣ a) :
  (associates.mk p) ∈ factors (associates.mk a) :=
begin
  rw factors_mk _ ha0, exact mem_factor_set_some.mpr (mem_factors'_of_dvd ha0 hp hd)
end

lemma mem_factors_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  (associates.mk p) ∈ factors (associates.mk a) ↔ p ∣ a :=
begin
  split,
  { rw ← mk_dvd_mk, apply dvd_of_mem_factors, exact (irreducible_mk p).mpr hp },
  { apply mem_factors_of_dvd ha0 hp }
end

lemma exists_prime_dvd_of_not_inf_one {a b : α}
  (ha : a ≠ 0) (hb : b ≠ 0) (h : (associates.mk a) ⊓ (associates.mk b) ≠ 1)  :
  ∃ (p : α), prime p ∧ p ∣ a ∧ p ∣ b :=
begin
  have hz : (factors (associates.mk a)) ⊓ (factors (associates.mk b)) ≠ 0,
  { contrapose! h with hf,
    change ((factors (associates.mk a)) ⊓ (factors (associates.mk b))).prod = 1,
    rw hf,
    exact multiset.prod_zero },
  rw [factors_mk a ha, factors_mk b hb, ← with_top.coe_inf] at hz,
  obtain ⟨⟨p0, p0_irr⟩, p0_mem⟩ := multiset.exists_mem_of_ne_zero ((mt with_top.coe_eq_coe.mpr) hz),
  rw multiset.inf_eq_inter at p0_mem,
  obtain ⟨p, rfl⟩ : ∃ p, associates.mk p = p0 := quot.exists_rep p0,
  refine ⟨p, _, _, _⟩,
  { rw [← irreducible_iff_prime, ← irreducible_mk],
    exact p0_irr },
  { apply dvd_of_mk_le_mk,
    apply dvd_of_mem_factors' (multiset.mem_inter.mp p0_mem).left,
    apply ha, },
  { apply dvd_of_mk_le_mk,
    apply dvd_of_mem_factors' (multiset.mem_inter.mp p0_mem).right,
    apply hb }
end

theorem coprime_iff_inf_one {a b : α} (ha0 : a ≠ 0) (hb0 : b ≠ 0) :
  (associates.mk a) ⊓ (associates.mk b) = 1 ↔ ∀ {d : α}, d ∣ a → d ∣ b → ¬ prime d :=
begin
  split,
  { intros hg p ha hb hp,
    refine ((associates.prime_mk _).mpr hp).not_unit (is_unit_of_dvd_one _ _),
    rw ← hg,
    exact le_inf (mk_le_mk_of_dvd ha) (mk_le_mk_of_dvd hb) },
  { contrapose,
    intros hg hc,
    obtain ⟨p, hp, hpa, hpb⟩ := exists_prime_dvd_of_not_inf_one ha0 hb0 hg,
    exact hc hpa hpb hp }
end

omit dec_irr

include dec_irr

theorem prime_pow_dvd_iff_le {m p : associates α} (h₁ : m ≠ 0)
  (h₂ : irreducible p) {k : ℕ} : p ^ k ≤ m ↔ k ≤ count p m.factors :=
begin
  obtain ⟨a, nz, rfl⟩ := associates.exists_non_zero_rep h₁,
  rw [factors_mk _ nz, ← with_top.some_eq_coe, count_some, multiset.le_count_iff_repeat_le,
      ← factors_le, factors_prime_pow h₂, factors_mk _ nz],
  exact with_top.coe_le_coe
end

theorem le_of_count_ne_zero {m p : associates α} (h0 : m ≠ 0)
  (hp : irreducible p) : count p m.factors ≠ 0 → p ≤ m :=
begin
  rw [← pos_iff_ne_zero],
  intro h,
  rw [← pow_one p],
  apply (prime_pow_dvd_iff_le h0 hp).2,
  simpa only
end

theorem count_mul {a : associates α} (ha : a ≠ 0) {b : associates α} (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) :
  count p (factors (a * b)) = count p a.factors + count p b.factors :=
begin
  obtain ⟨a0, nza, ha'⟩ := exists_non_zero_rep ha,
  obtain ⟨b0, nzb, hb'⟩ := exists_non_zero_rep hb,
  rw [factors_mul, ← ha', ← hb', factors_mk a0 nza, factors_mk b0 nzb, ← factor_set.coe_add,
      ← with_top.some_eq_coe, ← with_top.some_eq_coe, ← with_top.some_eq_coe, count_some hp,
      multiset.count_add, count_some hp, count_some hp]
end

theorem count_of_coprime {a : associates α} (ha : a ≠ 0) {b : associates α} (hb : b ≠ 0)
  (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) {p : associates α} (hp : irreducible p) :
  count p a.factors = 0 ∨ count p b.factors = 0 :=
begin
  rw [or_iff_not_imp_left, ← ne.def],
  intro hca,
  contrapose! hab with hcb,
  exact ⟨p, le_of_count_ne_zero ha hp hca, le_of_count_ne_zero hb hp hcb,
    (irreducible_iff_prime.mp hp)⟩,
end

theorem count_mul_of_coprime {a : associates α} (ha : a ≠ 0) {b : associates α} (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) :
  count p a.factors = 0 ∨ count p a.factors = count p (a * b).factors :=
begin
  cases count_of_coprime ha hb hab hp with hz hb0, { tauto },
  apply or.intro_right,
  rw [count_mul ha hb hp, hb0, add_zero]
end

theorem count_mul_of_coprime' {a : associates α} (ha : a ≠ 0) {b : associates α} (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) :
  count p (a * b).factors = count p a.factors
  ∨ count p (a * b).factors = count p b.factors :=
begin
  rw [count_mul ha hb hp],
  cases count_of_coprime ha hb hab hp with ha0 hb0,
  { apply or.intro_right, rw [ha0, zero_add] },
  { apply or.intro_left, rw [hb0, add_zero] }
end

theorem dvd_count_of_dvd_count_mul {a b : associates α} (ha : a ≠ 0) (hb : b ≠ 0)
  {p : associates α} (hp : irreducible p) (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d)
  {k : ℕ} (habk : k ∣ count p (a * b).factors) : k ∣ count p a.factors :=
begin
  cases count_of_coprime ha hb hab hp with hz h,
  { rw hz, exact dvd_zero k },
  { rw [count_mul ha hb hp, h] at habk, exact habk }
end

omit dec_irr

@[simp] lemma factors_one : factors (1 : associates α) = 0 :=
begin
  apply eq_of_prod_eq_prod,
  rw associates.factors_prod,
  exact multiset.prod_zero,
end

@[simp] theorem pow_factors {a : associates α} {k : ℕ} : (a ^ k).factors = k • a.factors :=
begin
  induction k with n h,
  { rw [zero_nsmul, pow_zero], exact factors_one },
  { rw [pow_succ, succ_nsmul, factors_mul, h] }
end

include dec_irr

lemma count_pow {a : associates α} (ha : a ≠ 0) {p : associates α} (hp : irreducible p)
  (k : ℕ) : count p (a ^ k).factors = k * count p a.factors :=
begin
  induction k with n h,
  { rw [pow_zero, factors_one, zero_mul, count_zero hp] },
  { rw [pow_succ, count_mul ha (pow_ne_zero _ ha) hp, h, nat.succ_eq_add_one], ring }
end

theorem dvd_count_pow {a : associates α} (ha : a ≠ 0) {p : associates α} (hp : irreducible p)
  (k : ℕ) : k ∣ count p (a ^ k).factors := by { rw count_pow ha hp, apply dvd_mul_right }

theorem is_pow_of_dvd_count {a : associates α} (ha : a ≠ 0) {k : ℕ}
  (hk : ∀ (p : associates α) (hp : irreducible p), k ∣ count p a.factors) :
  ∃ (b : associates α), a = b ^ k :=
begin
  obtain ⟨a0, hz, rfl⟩ := exists_non_zero_rep ha,
  rw [factors_mk a0 hz] at hk,
  have hk' : ∀ (p : {a : associates α // irreducible a}), k ∣ (factors' a0).count p,
  { intro p,
    have pp : p = ⟨p.val, p.2⟩, { simp only [subtype.coe_eta, subtype.val_eq_coe] },
    rw [pp, ← count_some p.2], exact hk p.val p.2 },
  obtain ⟨u, hu⟩ := multiset.exists_smul_of_dvd_count _ hk',
  use (u : factor_set α).prod,
  apply eq_of_factors_eq_factors,
  rw [pow_factors, prod_factors, factors_mk a0 hz, ← with_top.some_eq_coe, hu],
  exact with_bot.coe_nsmul u k
end

omit dec
omit dec_irr
omit dec'

theorem eq_pow_of_mul_eq_pow {a b c : associates α} (ha : a ≠ 0) (hb : b ≠ 0)
  (hab : ∀ d, d ∣ a → d ∣ b → ¬ prime d) {k : ℕ} (h : a * b = c ^ k) :
  ∃ (d : associates α), a = d ^ k :=
begin
  classical,
  by_cases hk0 : k = 0,
  { use 1,
    rw [hk0, pow_zero] at h ⊢,
    apply (mul_eq_one_iff.1 h).1 },
  { refine is_pow_of_dvd_count ha _,
    intros p hp,
    apply dvd_count_of_dvd_count_mul ha hb hp hab,
    rw h,
    apply dvd_count_pow _ hp,
    rintros rfl,
    rw zero_pow' _ hk0 at h,
    cases mul_eq_zero.mp h; contradiction }
end

end associates

section
open associates unique_factorization_monoid

/-- `to_gcd_monoid` constructs a GCD monoid out of a normalization on a
  unique factorization domain. -/
noncomputable def unique_factorization_monoid.to_gcd_monoid
  (α : Type*) [comm_cancel_monoid_with_zero α] [nontrivial α] [unique_factorization_monoid α]
  [normalization_monoid α] [decidable_eq (associates α)] [decidable_eq α] : gcd_monoid α :=
{ gcd := λa b, (associates.mk a ⊓ associates.mk b).out,
  lcm := λa b, (associates.mk a ⊔ associates.mk b).out,
  gcd_dvd_left := assume a b, (out_dvd_iff a (associates.mk a ⊓ associates.mk b)).2 $ inf_le_left,
  gcd_dvd_right := assume a b, (out_dvd_iff b (associates.mk a ⊓ associates.mk b)).2 $ inf_le_right,
  dvd_gcd := assume a b c hac hab, show a ∣ (associates.mk c ⊓ associates.mk b).out,
    by rw [dvd_out_iff, le_inf_iff, mk_le_mk_iff_dvd_iff, mk_le_mk_iff_dvd_iff]; exact ⟨hac, hab⟩,
  lcm_zero_left := assume a, show (⊤ ⊔ associates.mk a).out = 0, by simp,
  lcm_zero_right := assume a, show (associates.mk a ⊔ ⊤).out = 0, by simp,
  gcd_mul_lcm := assume a b,
    show (associates.mk a ⊓ associates.mk b).out * (associates.mk a ⊔ associates.mk b).out =
      normalize (a * b),
    by rw [← out_mk, ← out_mul, mul_comm, sup_mul_inf]; refl,
  normalize_gcd := assume a b, by convert normalize_out _,
  .. ‹normalization_monoid α› }

end


/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis, Heather Macbeth
-/

import algebra.ring.equiv

/-!
# Propositional typeclasses on several ring homs

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

This file contains three typeclasses used in the definition of (semi)linear maps:
* `ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃`, which expresses the fact that `σ₂₃.comp σ₁₂ = σ₁₃`
* `ring_hom_inv_pair σ₁₂ σ₂₁`, which states that `σ₁₂` and `σ₂₁` are inverses of each other
* `ring_hom_surjective σ`, which states that `σ` is surjective
These typeclasses ensure that objects such as `σ₂₃.comp σ₁₂` never end up in the type of a
semilinear map; instead, the typeclass system directly finds the appropriate `ring_hom` to use.
A typical use-case is conjugate-linear maps, i.e. when `σ = complex.conj`; this system ensures that
composing two conjugate-linear maps is a linear map, and not a `conj.comp conj`-linear map.

Instances of these typeclasses mostly involving `ring_hom.id` are also provided:
* `ring_hom_inv_pair (ring_hom.id R) (ring_hom.id R)`
* `[ring_hom_inv_pair σ₁₂ σ₂₁] : ring_hom_comp_triple σ₁₂ σ₂₁ (ring_hom.id R₁)`
* `ring_hom_comp_triple (ring_hom.id R₁) σ₁₂ σ₁₂`
* `ring_hom_comp_triple σ₁₂ (ring_hom.id R₂) σ₁₂`
* `ring_hom_surjective (ring_hom.id R)`
* `[ring_hom_inv_pair σ₁ σ₂] : ring_hom_surjective σ₁`

## Implementation notes

* For the typeclass `ring_hom_inv_pair σ₁₂ σ₂₁`, `σ₂₁` is marked as an `out_param`,
  as it must typically be found via the typeclass inference system.

* Likewise, for `ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃`, `σ₁₃` is marked as an `out_param`,
  for the same reason.

## Tags

`ring_hom_comp_triple`, `ring_hom_inv_pair`, `ring_hom_surjective`
-/

variables {R₁ : Type*} {R₂ : Type*} {R₃ : Type*}
variables [semiring R₁] [semiring R₂] [semiring R₃]

/-- Class that expresses the fact that three ring homomorphisms form a composition triple. This is
used to handle composition of semilinear maps. -/
class ring_hom_comp_triple (σ₁₂ : R₁ →+* R₂) (σ₂₃ : R₂ →+* R₃)
  (σ₁₃ : out_param (R₁ →+* R₃)) : Prop :=
(comp_eq : σ₂₃.comp σ₁₂ = σ₁₃)

attribute [simp] ring_hom_comp_triple.comp_eq

variables {σ₁₂ : R₁ →+* R₂} {σ₂₃ : R₂ →+* R₃} {σ₁₃ : R₁ →+* R₃}

namespace ring_hom_comp_triple

@[simp] lemma comp_apply [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] {x : R₁} :
  σ₂₃ (σ₁₂ x) = σ₁₃ x :=
ring_hom.congr_fun comp_eq x

end ring_hom_comp_triple

/-- Class that expresses the fact that two ring homomorphisms are inverses of each other. This is
used to handle `symm` for semilinear equivalences. -/
class ring_hom_inv_pair (σ : R₁ →+* R₂) (σ' : out_param (R₂ →+* R₁)) : Prop :=
(comp_eq : σ'.comp σ = ring_hom.id R₁)
(comp_eq₂ : σ.comp σ' = ring_hom.id R₂)

attribute [simp] ring_hom_inv_pair.comp_eq
attribute [simp] ring_hom_inv_pair.comp_eq₂

variables {σ : R₁ →+* R₂} {σ' : R₂ →+* R₁}

namespace ring_hom_inv_pair

variables [ring_hom_inv_pair σ σ']

@[simp] lemma comp_apply_eq {x : R₁} : σ' (σ x) = x :=
by { rw [← ring_hom.comp_apply, comp_eq], simp }

@[simp] lemma comp_apply_eq₂ {x : R₂} : σ (σ' x) = x :=
by { rw [← ring_hom.comp_apply, comp_eq₂], simp }

instance ids : ring_hom_inv_pair (ring_hom.id R₁) (ring_hom.id R₁) := ⟨rfl, rfl⟩
instance triples {σ₂₁ : R₂ →+* R₁} [ring_hom_inv_pair σ₁₂ σ₂₁] :
  ring_hom_comp_triple σ₁₂ σ₂₁ (ring_hom.id R₁) :=
⟨by simp only [comp_eq]⟩

instance triples₂ {σ₂₁ : R₂ →+* R₁} [ring_hom_inv_pair σ₁₂ σ₂₁] :
  ring_hom_comp_triple σ₂₁ σ₁₂ (ring_hom.id R₂) :=
⟨by simp only [comp_eq₂]⟩

/--
Construct a `ring_hom_inv_pair` from both directions of a ring equiv.

This is not an instance, as for equivalences that are involutions, a better instance
would be `ring_hom_inv_pair e e`. Indeed, this declaration is not currently used in mathlib.

See note [reducible non-instances].
-/
@[reducible]
lemma of_ring_equiv (e : R₁ ≃+* R₂) :
  ring_hom_inv_pair (↑e : R₁ →+* R₂) ↑e.symm :=
⟨e.symm_to_ring_hom_comp_to_ring_hom, e.symm.symm_to_ring_hom_comp_to_ring_hom⟩

/--
Swap the direction of a `ring_hom_inv_pair`. This is not an instance as it would loop, and better
instances are often available and may often be preferrable to using this one. Indeed, this
declaration is not currently used in mathlib.

See note [reducible non-instances].
-/
@[reducible]
lemma symm (σ₁₂ : R₁ →+* R₂) (σ₂₁ : R₂ →+* R₁) [ring_hom_inv_pair σ₁₂ σ₂₁] :
  ring_hom_inv_pair σ₂₁ σ₁₂ :=
⟨ring_hom_inv_pair.comp_eq₂, ring_hom_inv_pair.comp_eq⟩

end ring_hom_inv_pair

namespace ring_hom_comp_triple

instance ids : ring_hom_comp_triple (ring_hom.id R₁) σ₁₂ σ₁₂ := ⟨by { ext, simp }⟩
instance right_ids : ring_hom_comp_triple σ₁₂ (ring_hom.id R₂) σ₁₂ := ⟨by { ext, simp }⟩

end ring_hom_comp_triple

/-- Class expressing the fact that a `ring_hom` is surjective. This is needed in the context
of semilinear maps, where some lemmas require this. -/
class ring_hom_surjective (σ : R₁ →+* R₂) : Prop :=
(is_surjective : function.surjective σ)

lemma ring_hom.is_surjective (σ : R₁ →+* R₂) [t : ring_hom_surjective σ] : function.surjective σ :=
t.is_surjective

namespace ring_hom_surjective

-- The linter gives a false positive, since `σ₂` is an out_param
@[priority 100, nolint dangerous_instance] instance inv_pair {σ₁ : R₁ →+* R₂} {σ₂ : R₂ →+* R₁}
  [ring_hom_inv_pair σ₁ σ₂] : ring_hom_surjective σ₁ :=
⟨λ x, ⟨σ₂ x, ring_hom_inv_pair.comp_apply_eq₂⟩⟩

instance ids : ring_hom_surjective (ring_hom.id R₁) := ⟨is_surjective⟩

/-- This cannot be an instance as there is no way to infer `σ₁₂` and `σ₂₃`. -/
lemma comp [ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] [ring_hom_surjective σ₁₂] [ring_hom_surjective σ₂₃] :
  ring_hom_surjective σ₁₃ :=
{ is_surjective := begin
    have := σ₂₃.is_surjective.comp σ₁₂.is_surjective,
    rwa [← ring_hom.coe_comp, ring_hom_comp_triple.comp_eq] at this,
  end }

end ring_hom_surjective


import data.real.basic
import analysis.calculus.times_cont_diff
import topology.bounded_continuous_function
import measure_theory.interval_integral
import topology.metric_space.basic

import ODE_enclosures.taylors_theorem

noncomputable theory

open metric set asymptotics filter real measure_theory
open interval_integral topological_space uniform_space

open_locale topological_space classical filter uniformity

section euler_method

local infix ` →ᵇ `:25 := bounded_continuous_function

variables {E : Type*} [measurable_space E] [normed_group E] [borel_space E] [linear_order E]
                      [normed_space ℝ E] [complete_space E] [second_countable_topology E]

-- fun rk_eval :: "(nat⇒nat⇒real) ⇒ (nat⇒real) ⇒ (real×'a::real_vector ⇒ 'a) ⇒ real ⇒ real ⇒ 'a ⇒ nat ⇒ 'a" where
--   "rk_eval A c f t h x j =
--   f (t + h * c j, x + h *⇩R (∑l=1 ..< j. A j l *⇩R rk_eval A c f t h x l))"

-- primrec rk_eval_dynamic :: "(nat⇒nat⇒real) ⇒ (nat⇒real) ⇒ (real×'a::real_vector ⇒ 'a) ⇒ real ⇒ real ⇒ 'a ⇒ nat ⇒ (nat ⇒ 'a)" where
--   "rk_eval_dynamic A c f t h x 0 = (λi. 0)"
-- | "rk_eval_dynamic A c f t h x (Suc j) =
--   (let K = rk_eval_dynamic A c f t h x j in
--   K(Suc j:=f (t + h * c (Suc j), x + h *⇩R (∑l=1..j. A (Suc j) l *⇩R K l))))"

-- fun rk_eval_float :: "(nat⇒nat⇒float) ⇒ (nat⇒float) ⇒ (float×float ⇒ float) ⇒ float ⇒ float ⇒ float ⇒ nat ⇒ float" where
--   "rk_eval_float A c f t h x j =
--   f (t + h * c j, x + h * setsum (λl. A j l * rk_eval_float A c f t h x l) {1..< j})"

-- definition rk_increment where
--   "rk_increment f s A b c h t x = (∑j=1..s. b j *⇩R rk_eval A c f t h x j)"

-- definition rk_increment_float where
--   "rk_increment_float error f s A b c h t x =
--   float_down error (∑j=1..s. b j * rk_eval_float A c f t h x j)"

-- definition euler_increment where
--   "euler_increment f = rk_increment f 1 (λi j. 0) (λi. 1) (λi. 0)"

def euler_step (f : ℝ → E → E) (x : ℝ →ᵇ E) (h : ℝ) (t : ℝ) : E :=
(x t) + h • (f t (x t))

-- definition euler where
--   "euler f = grid_function (discrete_evolution (euler_increment f))"

-- definition discrete_evolution
-- where "discrete_evolution incr t1 t0 x = x + (t1 - t0) *⇩R incr (t1 - t0) t0 x"

-- definition "consistent x t T B p incr ⟷
--   (∀h≥0. t + h ≤ T ⟶ dist (x (t + h)) (discrete_evolution incr (t + h) t (x t)) ≤ B * h ^ (p + 1))"

-- lemma euler_consistent_traj:
--   fixes t
--   assumes "B ≥ 0"
--   assumes "∀s∈{t..T}. (x has_vector_derivative f (s, x s)) (at s)"
--   assumes "∀s∈{t..T}. ((λs. f (s, x s)) has_vector_derivative f' s) (at s)"
--   assumes "∀s∈{t..T}. ¦f' s¦ ≤ 2 * B"
--   shows "consistent x t T B 1 (euler_increment f)"

-- lemma euler_lipschitz:
--   fixes x::"real ⇒ real"
--   assumes t: "t ∈ {t0..T}"
--   assumes lipschitz: "∀t∈{t0..T}. lipschitz D' (λx. f (t, x)) L"
--   shows "lipschitz D' (euler_increment f h t) L"

-- locale euler_consistent =
--   has_solution i +
--   ivp_on_interval i T +
--   global_lipschitz I D' f L +
--   grid: grid_from t t0 +
--   bounded_derivative I D f B f' B'
--   for i::"real ivp" and t T D' L B f' B' +
--   fixes r
--   assumes lipschitz_area: "⋀t. t ∈ I ⟹ cball (solution t) ¦r¦ ⊆ D'"
-- begin

-- THEOREM 4
-- lemma euler_consistent_solution:
--   fixes t'
--   assumes t': "t' ∈ I"
--   shows "consistent solution t' T B' 1 (euler_increment f)"

-- lemma euler_consistent_solution':
--   assumes "t1' ∈ {t0 .. t1}"
--   shows "solution (t0 + (t1' - t0)) - discrete_evolution (euler_increment f) (t0 + (t1' - t0)) t0 (solution t0) ∈
--     op *⇩R ((t1' - t0)⇧2 / 2) ` {inf_of_appr D..sup_of_appr D}"

-- MISSING: Taylor's formula.

lemma euler_step_consistent
  -- Should be
  --    (f : ℝ → E → E) (x : ℝ →ᵇ E) (h : ℝ) (t : ℝ)
  -- but my statement of Taylor's formula is on fns ℝ → ℝ.
  (f : ℝ → ℝ → ℝ) (x : ℝ →ᵇ ℝ) (h : ℝ) (hpos : 0 < h) (t : ℝ)
  -- Initial value problem: x'(t) = f(t,x(t)).
  (hdiff : ∀ t, times_cont_diff_at ℝ 2 x t)
  (hf : ∀ t, has_deriv_at x (f t (x t)) t)
  -- Assume the derivative (of f) is bounded.
  (C : nnreal) (hbdd : ∀ s, ∥deriv (λ t, f t (x t)) s∥ ≤ C)
  -- Assume it is Lipschitz on the second argument?
  (K : nnreal) (hltz : ∀ s, lipschitz_with K (f s))
  : dist (f (t + h) (x (t + h))) (euler_step f x h t) ≤ C * h^2 / 2 :=
begin
  have h := taylor_left x.1 t 1 (hdiff t) (t + h) ((lt_add_iff_pos_right t).2 hpos),
  rcases h with ⟨c, hc1, hc2, h⟩,
  -- Proof follows from here.
  sorry,
end

-- Consistency implies convergence of:
noncomputable def euler.recursive (f : ℝ → E → E) (x : ℝ → E) (h : ℝ) (t : ℝ) : ℕ → E
| 0     := x t
| (n+1) := (euler.recursive n) + h • (f (t + h) (euler.recursive n))

-- Certification of solution.

-- File: EulerAffine.thy

-- lemma P_appr:
--   assumes x0: "x0 ∈ set_of_appr X0"
--   assumes x: "⋀t. t ∈ {t0..t1} ⟹ x t ∈ set_of_appr X"
--   assumes cont: "continuous_on {t0..t1} x"
--   assumes h': "0 ≤ t1 - t0" "t1 - t0 ≤ h"
--   assumes P_res: "P_appr optns X0 h X = Some R"
--   shows "x0 + integral {t0..t1} (λt. ode (x t)) ∈ set_of_appr R"

-- interpretation unique_on_closed_cont_diff "step_ivp t0 x0 t1 CX" t1 "λ(t, x) (dt, dx). ode_d x dx"

-- THEOREM 7.
-- lemma unique_on_euler_step:
--   assumes "t0 + h = t1"
--   shows
--     "unique_solution (euler_ivp t0 x0 t1)" (is ?th1) and
--     "⋀t. t ∈ {t0 .. t1} ⟹ ivp.solution (euler_ivp t0 x0 t1) t ∈ set_of_appr RES_ivl" (is "⋀t. ?ass2 t ⟹ ?th2 t") and
--     "ivp.solution (euler_ivp t0 x0 t1) t1 ∈ set_of_appr RES" (is ?th3)

-- THEOREM 8?
-- lemma error_overapproximation:
--   shows  "solution (t0 + h) ∈ set_of_appr RES"

-- THEOREM 9.
-- lemma euler_series_enclosure:
--   assumes pos_prestep: "0 < stepsize optns"
--   assumes x0: "x0 ∈ set_of_appr X0"
--   assumes euler_series_returns: "euler_series optns t0 X0 i = Some (j, t2, X2, ress)"
--   shows
--     "unique_solution (euler_ivp t0 x0 t2)"
--     "enclosure (ivp.solution (euler_ivp t0 x0 t2)) t0 t2 (map set_res_of_appr_res ress)"
--     "ivp.solution (euler_ivp t0 x0 t2) t2 ∈ set_of_appr X2"

end euler_method


import topology.basic
import data.real.basic
import topology.continuous_function.basic
import tactic
import topology.instances.real

open topological_space

namespace Alg_Top

noncomputable theory

def I : set ℝ := {x | 0 ≤ x ∧ x ≤ 1}
variable y : ℝ

theorem h: ↑0 ∈ I :=
begin
  rw I,
  simp,
end

variables {X Y: Type} [topological_space X][topological_space Y]

theorem ge_I (y : ℝ) : |y| + 1 >= 1 :=
begin
  simp,
  apply abs_nonneg,
end

instance : has_zero I :=
begin
  split,split,
  have h: ↑0 ∈ I,
  {
    rw I, simp,
  },
  exact h,
end

instance : has_one I :=
begin
  split,split,
  have h: ↑1 ∈ I,
  {
    rw I, simp,
  },
  exact h,
end

variable α : Type

/- Type of path from a to b

-/
structure Path (a : X)(b : X) :=
(Func : ℝ → X )
(Continuity : continuous Func)
(InitPT: Func 0 = a)
(EndPT: Func 1 = b)

structure Homotopy (f g: X → Y):=
(Func : ℝ × X → Y)
(Continuity : continuous Func)
(InitPT: ∀(x:X), Func (0,x) = f x)
(EndPT: ∀(x:X), Func (1,x) = g x)

structure Path_Homotopy {a b : X}(f g : Path a b):=
(Hom : Homotopy f.Func g.Func)
(FixInitPT: ∀(x:ℝ), Hom.Func (x,0) = a)
(FixEndPT: ∀(x:ℝ), Hom.Func (x,1) = b)

def Homotopic (f g: X → Y) := nonempty (Homotopy f g)

def Path_Homotopic {a b : X}(f g : Path a b) := nonempty (Path_Homotopy f g)

notation a ⟶ b := Path a b
/-
notation f ≡ g := Homotopic f g
notation f ≃ g := Path_Homotopic f g
-/

/-
structure FixPTHomotopy (a : X)(b : X):=
(Func : C(I × I, X))
(InitPT: ∀(t:I), Func (t,0) = a)
(EndPT: ∀(t:I), Func (t,1) = b)

structure FixPTHomotopic_with (a : X)(b : X)(f : Path a b)(g : Path a b):=
(Homotopy_map : FixPTHomotopy a b)
(InitPTEquiv: ∀(x:I), (Homotopy_map.Func (0,x) = f.Func x ))
(EndPTEquiv: ∀(x:I), (Homotopy_map.Func (1,x) = g.Func x )) -/

noncomputable def func (x : ℝ × ℝ) : ℝ := (x.fst+x.snd)/2
lemma Con : continuous func :=
begin
  apply continuous.mul,
  continuity,
end

noncomputable def FixPT_Path_LinearHomotopy {a b: ℝ} (f : Path a b) (g : Path a b): Path_Homotopy f g:=
begin

  let Func: ℝ × ℝ → ℝ:= λx, (1-(x.fst)) * (f.Func (x.snd)) + x.fst * (g.Func (x.snd)),
  have InitPT: ∀(x:ℝ), Func (0,x) = f.Func x,
  {
    intro x, simp_rw Func, simp only [add_zero, one_mul, nat.cast_zero, zero_mul, sub_zero],
  },
  have EndPT: ∀(x:ℝ), Func (1,x) = g.Func x,
  {
    intro x, simp_rw Func, simp only [one_mul, zero_mul, zero_add, nat.cast_one, sub_self],
  },
  have IsContinuous : continuous Func,
  {
    apply continuous.add,
    continuity, exact f.Continuity, exact g.Continuity,
  },
  let Hom: Homotopy f.Func g.Func,
  {
    split, exact IsContinuous,
    intro s, simp_rw Func, simp only [add_zero, one_mul, zero_mul, sub_zero],
    intro s, simp_rw Func, simp only [one_mul, zero_mul, zero_add, sub_self],
  },
  split, intro x,
  change Hom.Func (x,0) = a,
  simp_rw Func, rw f.InitPT, rw g.InitPT, ring,
  intro x, simp_rw Func, rw f.EndPT, rw g.EndPT, ring,
end

def ConstantHomotopy (f : X → Y) : continuous f → Homotopy f f:=
begin
  intro cf,
  split,
  let Func: ℝ × X → Y:= λx , f (x.snd),
  have Continuity: continuous Func,
  {
    continuity,
  }, use Continuity,
  intro x, simp,
  intro x, simp,
end

def ConstantPathHomotopy {a b :X} (f : Path a b): Path_Homotopy f f :=
begin
  let Const : Homotopy f.Func f.Func := ConstantHomotopy f.Func f.Continuity,
  have H : ∀x y, Const.Func (x,y) = f.Func y,
  {
    intro y, exact congr_fun rfl,
  },
  split,
  intro x,
  rw H, exact f.InitPT,
  intro x, rw H, exact f.EndPT,
end

lemma Homotopy_if_Homotopic {f g : X → Y} : Homotopic f g → Homotopy f g :=
begin
  intro fRg,
  rw Homotopic at fRg, apply classical.choice, exact fRg,
end

lemma Path_Homotopy_if_Homotopic {a b: X}{f g : Path a b} : Path_Homotopic f g → Path_Homotopy f g :=
begin
  intro fRg,
  rw Path_Homotopic at fRg, apply classical.choice, exact fRg,
end

theorem Path_Hom_Equiv {a b : X} : equivalence (@Path_Homotopic _ _ a b):=
begin
  split,
  {
    rw reflexive,
    intro Pab,
    split, apply ConstantPathHomotopy Pab,
  },
  split,
  {
    rw symmetric,
    intros x y h,
    have hxy: Path_Homotopy x y := Path_Homotopy_if_Homotopic h,
    split,
    let Func: ℝ × ℝ → X,
    {
      intro x,
      exact hxy.Hom.Func (1-(x.fst),x.snd),
    },
    have IsContinuous : continuous Func,
    {
      continuity, exact hxy.Hom.Continuity,
    },
    let H: Homotopy y.Func x.Func,
    {
      split, exact IsContinuous,
      intro x, simp_rw Func,simp only [sub_zero], rw hxy.Hom.EndPT,
      intro x, simp_rw Func,simp only [sub_self], rw hxy.Hom.InitPT,
    },
    split, intro s,
    change H.Func (s,0) = a,
    simp only, simp_rw Func, simp only, rw hxy.FixInitPT,
    simp only, simp_rw Func, simp only, intro x, rw hxy.FixEndPT,
  },

  {
    rw transitive,
    intros x y z xRy yRz,
    have hxy : Path_Homotopy x y := Path_Homotopy_if_Homotopic xRy,
    have hyz : Path_Homotopy y z := Path_Homotopy_if_Homotopic yRz,

    let Func: ℝ × ℝ → X := λ x, if x.fst ≤ 2⁻¹ then hxy.Hom.Func (2*x.fst,x.snd) else hyz.Hom.Func (2*x.fst-1,x.snd),
    have IsContinuous : continuous Func,
    {
      apply continuous.if, continuity,
      have h1: a_1 ∈ {x : ℝ × ℝ | x.fst = 2⁻¹},
      {
        apply frontier_le_subset_eq,continuity,
      },
      have h2: a_1.fst = 2⁻¹,
      {
        exact h1,
      },
      rw h2,simp, rw hxy.Hom.EndPT,rw hyz.Hom.InitPT,
      exact hxy.Hom.Continuity,
      exact hyz.Hom.Continuity,
    },
    let H: Homotopy x.Func z.Func,
    {
      split, exact IsContinuous,intro s, simp_rw Func,split_ifs,simp,
      rw hxy.Hom.InitPT,apply false.elim,
      simp only [zero_le_one, inv_nonneg, zero_le_bit0, not_true] at h, exact h,
      intro s, simp_rw Func,split_ifs,simp only [mul_one], apply false.elim,
      simp only at h, norm_num at h, simp, norm_num, rw hyz.Hom.EndPT,

    },
    split,split, intro s, change H.Func(s,0) = a,
    simp_rw Func,split_ifs, rw hxy.FixInitPT, rw hyz.FixInitPT,
    intro s, simp_rw Func, split_ifs, rw hxy.FixEndPT, rw hyz.FixEndPT,

  },
end

end Alg_Top


import algebra.category.Module.abelian
import sheaves_of_modules.defs
import algebraic_geometry.AffineScheme
import algebra.module.localized_module

/-

# Construction of sheaf of modules on Spec(R) associated to a module

-/

-- last week we defined sheaves of modules on a sheaf of rings
-- and gave them the structure of a category
-- this week let's make an example of a sheaf of modules

-- remark: there's a Lean repository where I push stuff
-- git@github.com:ImperialCollegeLondon/tcc-lean-alg-geom-2022.git

-- `leanproject get ImperialCollegeLondon/tcc-lean-alg-geom-2022`
-- should get it you

-- Let R be a ring and let M be an R-module

-- this says "let R be a commutative ring which is also a set"
variables {R : CommRing.{0}} -- zero means "it's a set"
-- let M be a module over R which is also a set
variable (M : Module.{0} R)

-- goal: to make a sheaf of modules over Spec(R)

-- two distinct (as far as I know) constructions.
/-

-- (1) (Stacks project, EGA) : If U=D(f) is a basic open subset
-- then define 𝓜(U) := M[1/f]
-- Now use some formal nonsense to extend to all open subsets

Problem with (1) is that can have U=D(f)=D(g) but strictly speaking
M[1/f] ≠ M[1/g]

  (2) (Hartshorne): define on all open sets at once:
  𝓜(U) := {f : U → disjoint union of M_P such that
   (a) f(P) ∈ M_P (i.e. f is a dependent function: f : Π (P : U), M_P )
   (b) f is "locally a fraction" i.e. for all P there exists some nhd V
   of P and elements m ∈ M and r ∈ R non-vanishing on V such that
   f(Q)=m/r for all Q in V

   Hartshorne defines structure sheaf on Spec(R) in this way
   and mathlib defines it like this too.
  }

We're going to go for (2) becuase it avoids "canonical isomorphism"
  nonsense which is hard to make rigorous in Lean's type theory

NB variant (1') : If U is a basic open then you can define
 𝓜(U)=M[1/S] where S is all the elements of R which are nonvanishing on U
 and this avoids the problem; it's much more functorial and this
 is what we did in the initial schemes project.

-/

-- In the below we just copy what they do for rings

open algebraic_geometry category_theory

namespace Module

/--
`M.localizations P` : The type family over `(P : prime_spectrum.Top R)` consisting of the localization
`M_P` of the module `R`-module `M` over each point.
-/
@[derive add_comm_group]
def localizations (P : prime_spectrum.Top R) : Type := localized_module (P.as_ideal.prime_compl) M

--  * Redefine `localization` for monoids and rings to coincide with `localized_module`.

/-
protected abbreviation localization.at_prime := localization I.prime_compl
-/

/-- Let type class inference see through the `M.localizations` definition and
  recognise the `R_P`-module structure on `M.localizations P := M_P` -/
instance (P : prime_spectrum.Top R) : module (structure_sheaf.localizations R P) (M.localizations P) :=
localized_module.is_module -- definitional equality.

/-
Then we'll define a predicate called "is_locally_fraction"
-/

open topological_space

/--
The predicate saying that a dependent function on an open `U` is realised as a fixed fraction
`m / s` in each of the stalks (which are localizations of a fixed module at various prime ideals).
-/
def is_fraction {U : opens (prime_spectrum.Top R)} (f : Π (P : U), M.localizations P) : Prop :=
∃ (m : M) (s : R), ∀ P : U, ∃ (hs : s ∈ (prime_spectrum.as_ideal (P.1 : prime_spectrum R)).prime_compl),
  f P = localized_module.mk m ⟨s, hs⟩

open Top

/--
The predicate `is_fraction` is "prelocal",
in the sense that if it holds on `U` it holds on any open subset `V` of `U`.
-/
def is_fraction_prelocal : prelocal_predicate (M.localizations) :=
{ pred := λ U f, M.is_fraction f,
  res := by { rintro V U i f ⟨r, s, w⟩, exact ⟨r, s, λ x, w (i x)⟩ } }

/-- A dependent section f : Π (P : U), M_P is locally a fraction
if U has an open cover such that the restriction of f to the cover
is a fraction m/s -/
def is_locally_fraction : local_predicate (M.localizations) :=
(M.is_fraction_prelocal).sheafify

/-
Then we'll make a sheaf of tyhpes
-/
/--
The sheaf of modules associated to M (valued in `Type`, not yet `Ab`) is the subsheaf consisting of
functions satisfying `is_locally_fraction`.
-/
def sheaf_in_Type : sheaf (Type) (prime_spectrum.Top R):=
subsheaf_to_Types (M.is_locally_fraction)

open opposite

/-
Then we'll show that each of these types is an abelian group
-/

instance sections_module (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  module ((structure_presheaf_in_CommRing R).obj U) (Π P : unop U, M.localizations P) :=
{ smul := λ f m P, (f.1 P) • m P,
  one_smul := sorry,
  mul_smul := sorry,
  smul_zero := sorry,
  smul_add := sorry,
  add_smul := sorry,
  zero_smul := sorry }

/--
The functions satisfying `is_locally_fraction` form a subgroup.
-/
def sections_submodule' (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  submodule ((structure_presheaf_in_CommRing R).obj U) (Π P : unop U, M.localizations P) :=
{ carrier := { f | (M.is_locally_fraction).pred f },
  zero_mem' :=
  begin
    refine λ x, ⟨unop U, x.2, 𝟙 _, 0, 1, λ y, ⟨_, _⟩⟩,
    { change (1 : R) ∉ prime_spectrum.as_ideal y.val,
      rw ←ideal.ne_top_iff_one, exact y.1.is_prime.1, },
    { simp, },
  end,
  -- neg_mem' :=
  -- begin
  --   intros a ha x,
  --   rcases ha x with ⟨V, hxV, i, m, s, hm⟩,
  --   refine ⟨V, hxV, i, -m, s, _⟩,
  --   intro y,
  --   rcases hm y with ⟨hs, w⟩,
  --   use hs,
  --   dsimp only at w ⊢,
  --   simp only [w, pi.neg_apply],
  --   apply localized_module.mk_neg,
  -- end,
  add_mem' :=
  begin
    intros a b ha hb x,
    rcases ha x with ⟨Va, ma, ia, ra, sa, wa⟩,
    rcases hb x with ⟨Vb, mb, ib, rb, sb, wb⟩,
    refine ⟨Va ⊓ Vb, ⟨ma, mb⟩, opens.inf_le_left _ _ ≫ ia, sb • ra + sa • rb, sa * sb, _⟩,
    intro y,
    rcases wa (opens.inf_le_left _ _ y) with ⟨nma, wa'⟩,
    rcases wb (opens.inf_le_right _ _ y) with ⟨nmb, wb'⟩,
    fsplit,
    { intro H, cases y.1.is_prime.mem_or_mem H; contradiction, },
    dsimp only at wa' wb' ⊢,
    change a (ia ((Va.inf_le_left Vb) y)) + b (ib ((Va.inf_le_right Vb) y)) = _,
    rw [wa', wb'],
    refl,
  end,
  smul_mem' :=
  begin
    sorry
  end, }

instance add_comm_group_sheaf_in_Type_obj (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  add_comm_group ((M.sheaf_in_Type).1.obj U) :=
(M.sections_submodule' U).to_add_subgroup.to_add_comm_group

instance module_sheaf_in_Type_obj (U : (opens (prime_spectrum.Top R))ᵒᵖ) :
  module ((structure_presheaf_in_CommRing R).obj U) ((M.sheaf_in_Type).1.obj U) :=
submodule_class.to_module (M.sections_submodule' U)

/-
Then we'll make a presheaf of abelian groups
-/

/--
The presheaf, valued in `Ab`, constructed by dressing up the `Type` valued
presheaf associated to an R-module.
-/
@[simps]
def presheaf_in_Ab : presheaf Ab (prime_spectrum.Top R) :=
{ obj := λ U, AddCommGroup.of ((M.sheaf_in_Type).1.obj U),
  map := λ U V i,
  { to_fun := ((M.sheaf_in_Type).1.map i),
    map_zero' := rfl,
    map_add' := λ x y, rfl, }, }

/--
Some glue, verifying that that structure presheaf valued in `CommRing` agrees
with the `Type` valued structure presheaf.
-/
def presheaf_comp_forget :
  M.presheaf_in_Ab ⋙ (category_theory.forget Ab) ≅ (M.sheaf_in_Type).1 :=
nat_iso.of_components
  (λ U, iso.refl _)
  (by tidy)

open Top.presheaf

/--
The structure sheaf on $Spec R$, valued in `CommRing`.

This is provided as a bundled `SheafedSpace` as `Spec.SheafedSpace R` later.
-/
def sheaf : sheaf Ab (prime_spectrum.Top R) :=
⟨M.presheaf_in_Ab,
  -- We check the sheaf condition under `forget CommRing`.
  (is_sheaf_iff_is_sheaf_comp _ _).mpr
    (is_sheaf_of_iso (M.presheaf_comp_forget).symm
      (M.sheaf_in_Type).cond)⟩

/-
and then we'll beef it up into a sheaf of modules
-/

--#check Scheme

def sheaf_of_modules: SHEAF_OF_MODULES (Spec.to_LocallyRingedSpace.obj (op R)).to_SheafedSpace :=
{ ab_sheaf := M.sheaf,
  module_structure := M.module_sheaf_in_Type_obj,
  compatibility_bit := sorry
}

end Module