/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro
-/
import data.list.sigma

/-!
# Association Lists

This file defines association lists. An association list is a list where every element consists of
a key and a value, and no two entries have the same key. The type of the value is allowed to be
dependent on the type of the key.

This type dependence is implemented using `sigma`: The elements of the list are of type `sigma β`,
for some type index `β`.

## Main definitions

Association lists are represented by the `alist` structure. This file defines this structure and
provides ways to access, modify, and combine `alist`s.

* `alist.keys` returns a list of keys of the alist.
* `alist.mem` returns membership in the set of keys.
* `alist.erase` removes a certain key.
* `alist.insert` adds a key-value mapping to the list.
* `alist.union` combines two association lists.

## References

* <https://en.wikipedia.org/wiki/Association_list>

-/

universes u v w
open list
variables {α : Type u} {β : α → Type v}

/-- `alist β` is a key-value map stored as a `list` (i.e. a linked list).
  It is a wrapper around certain `list` functions with the added constraint
  that the list have unique keys. -/
structure alist (β : α → Type v) : Type (max u v) :=
(entries : list (sigma β))
(nodupkeys : entries.nodupkeys)

/-- Given `l : list (sigma β)`, create a term of type `alist β` by removing
entries with duplicate keys. -/
def list.to_alist [decidable_eq α] {β : α → Type v} (l : list (sigma β)) : alist β :=
{ entries := _,
  nodupkeys := nodupkeys_erase_dupkeys l }

namespace alist

@[ext] theorem ext : ∀ {s t : alist β}, s.entries = t.entries → s = t
| ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ H := by congr'

lemma ext_iff {s t : alist β} : s = t ↔ s.entries = t.entries :=
⟨congr_arg _, ext⟩

instance [decidable_eq α] [∀ a, decidable_eq (β a)] : decidable_eq (alist β) :=
λ xs ys, by rw ext_iff; apply_instance

/-! ### keys -/

/-- The list of keys of an association list. -/
def keys (s : alist β) : list α := s.entries.keys

theorem keys_nodup (s : alist β) : s.keys.nodup := s.nodupkeys

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (alist β) := ⟨λ a s, a ∈ s.keys⟩

theorem mem_keys {a : α} {s : alist β} : a ∈ s ↔ a ∈ s.keys := iff.rfl

theorem mem_of_perm {a : α} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) : a ∈ s₁ ↔ a ∈ s₂ :=
(p.map sigma.fst).mem_iff

/-! ### empty -/

/-- The empty association list. -/
instance : has_emptyc (alist β) := ⟨⟨[], nodupkeys_nil⟩⟩

instance : inhabited (alist β) := ⟨∅⟩

theorem not_mem_empty (a : α) : a ∉ (∅ : alist β) :=
not_mem_nil a

@[simp] theorem empty_entries : (∅ : alist β).entries = [] := rfl

@[simp] theorem keys_empty : (∅ : alist β).keys = [] := rfl

/-! ### singleton -/

/-- The singleton association list. -/
def singleton (a : α) (b : β a) : alist β :=
⟨[⟨a, b⟩], nodupkeys_singleton _⟩

@[simp]

@[simp] theorem keys_singleton (a : α) (b : β a) : (singleton a b).keys = [a] := rfl

/-! ### lookup -/

section

variables [decidable_eq α]

/-- Look up the value associated to a key in an association list. -/
def lookup (a : α) (s : alist β) : option (β a) :=
s.entries.lookup a

@[simp] theorem lookup_empty (a) : lookup a (∅ : alist β) = none :=
rfl

theorem lookup_is_some {a : α} {s : alist β} :
  (s.lookup a).is_some ↔ a ∈ s := lookup_is_some

theorem lookup_eq_none {a : α} {s : alist β} :
  lookup a s = none ↔ a ∉ s :=
lookup_eq_none

theorem perm_lookup {a : α} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) :
  s₁.lookup a = s₂.lookup a :=
perm_lookup _ s₁.nodupkeys s₂.nodupkeys p

instance (a : α) (s : alist β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

/-! ### replace -/

/-- Replace a key with a given value in an association list.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : alist β) : alist β :=
⟨kreplace a b s.entries, (kreplace_nodupkeys a b).2 s.nodupkeys⟩

@[simp] theorem keys_replace (a : α) (b : β a) (s : alist β) :
  (replace a b s).keys = s.keys :=
keys_kreplace _ _ _

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : alist β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
by rw [mem_keys, keys_replace, ←mem_keys]

theorem perm_replace {a : α} {b : β a} {s₁ s₂ : alist β} :
  s₁.entries ~ s₂.entries → (replace a b s₁).entries ~ (replace a b s₂).entries :=
perm.kreplace s₁.nodupkeys

end

/-- Fold a function over the key-value pairs in the map. -/
def foldl {δ : Type w} (f : δ → Π a, β a → δ) (d : δ) (m : alist β) : δ :=
m.entries.foldl (λ r a, f r a.1 a.2) d

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present, do nothing. -/
def erase (a : α) (s : alist β) : alist β :=
⟨kerase a s.entries, kerase_nodupkeys _ s.nodupkeys⟩

@[simp] theorem keys_erase (a : α) (s : alist β) :
  (erase a s).keys = s.keys.erase a :=
by simp only [erase, keys, keys_kerase]

@[simp] theorem mem_erase {a a' : α} {s : alist β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
by rw [mem_keys, keys_erase, mem_erase_iff_of_nodup s.keys_nodup, ←mem_keys]

theorem perm_erase {a : α} {s₁ s₂ : alist β} :
  s₁.entries ~ s₂.entries → (erase a s₁).entries ~ (erase a s₂).entries :=
perm.kerase s₁.nodupkeys

@[simp] theorem lookup_erase (a) (s : alist β) : lookup a (erase a s) = none :=
lookup_kerase a s.nodupkeys

@[simp] theorem lookup_erase_ne {a a'} {s : alist β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
lookup_kerase_ne h

theorem erase_erase (a a' : α) (s : alist β) :
  (s.erase a).erase a' = (s.erase a').erase a :=
ext $ kerase_kerase

/-! ### insert -/

/-- Insert a key-value pair into an association list and erase any existing pair
  with the same key. -/
def insert (a : α) (b : β a) (s : alist β) : alist β :=
⟨kinsert a b s.entries, kinsert_nodupkeys a b s.nodupkeys⟩

@[simp] theorem insert_entries {a} {b : β a} {s : alist β} :
  (insert a b s).entries = sigma.mk a b :: kerase a s.entries :=
rfl

theorem insert_entries_of_neg {a} {b : β a} {s : alist β} (h : a ∉ s) :
  (insert a b s).entries = ⟨a, b⟩ :: s.entries :=
by rw [insert_entries, kerase_of_not_mem_keys h]

@[simp] theorem mem_insert {a a'} {b' : β a'} (s : alist β) :
  a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
mem_keys_kinsert

@[simp] theorem keys_insert {a} {b : β a} (s : alist β) :
  (insert a b s).keys = a :: s.keys.erase a :=
by simp [insert, keys, keys_kerase]

theorem perm_insert {a} {b : β a} {s₁ s₂ : alist β} (p : s₁.entries ~ s₂.entries) :
  (insert a b s₁).entries ~ (insert a b s₂).entries :=
by simp only [insert_entries]; exact p.kinsert s₁.nodupkeys

@[simp] theorem lookup_insert {a} {b : β a} (s : alist β) : lookup a (insert a b s) = some b :=
by simp only [lookup, insert, lookup_kinsert]

@[simp] theorem lookup_insert_ne {a a'} {b' : β a'} {s : alist β} (h : a ≠ a') :
  lookup a (insert a' b' s) = lookup a s :=
lookup_kinsert_ne h

@[simp] theorem lookup_to_alist {a} (s : list (sigma β)) : lookup a s.to_alist = s.lookup a :=
by rw [list.to_alist,lookup,lookup_erase_dupkeys]

@[simp] theorem insert_insert {a} {b b' : β a} (s : alist β) :
  (s.insert a b).insert a b' = s.insert a b' :=
by ext : 1; simp only [alist.insert_entries, list.kerase_cons_eq];
   constructor_matching* [_ ∧ _]; refl

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : alist β) (h : a ≠ a') :
  ((s.insert a b).insert a' b').entries ~ ((s.insert a' b').insert a b).entries :=
by simp only [insert_entries]; rw [kerase_cons_ne,kerase_cons_ne,kerase_comm];
   [apply perm.swap, exact h, exact h.symm]

@[simp] lemma insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
ext $ by simp only [alist.insert_entries, list.kerase_cons_eq, and_self, alist.singleton_entries,
  heq_iff_eq, eq_self_iff_true]

@[simp] theorem entries_to_alist (xs : list (sigma β)) :
  (list.to_alist xs).entries = erase_dupkeys xs := rfl

theorem to_alist_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_alist (⟨a,b⟩ :: xs) = insert a b xs.to_alist := rfl

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : alist β) : option (β a) × alist β :=
have (kextract a s.entries).2.nodupkeys,
by rw [kextract_eq_lookup_kerase]; exact kerase_nodupkeys _ s.nodupkeys,
match kextract a s.entries, this with
| (b, l), h := (b, ⟨l, h⟩)
end

@[simp] theorem extract_eq_lookup_erase (a : α) (s : alist β) :
  extract a s = (lookup a s, erase a s) :=
by simp [extract]; split; refl

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two association lists. It is
left-biased: if there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`.
-/
def union (s₁ s₂ : alist β) : alist β :=
⟨kunion s₁.entries s₂.entries, kunion_nodupkeys s₁.nodupkeys s₂.nodupkeys⟩

instance : has_union (alist β) := ⟨union⟩

@[simp] theorem union_entries {s₁ s₂ : alist β} :
  (s₁ ∪ s₂).entries = kunion s₁.entries s₂.entries :=
rfl

@[simp] theorem empty_union {s : alist β} : (∅ : alist β) ∪ s = s :=
ext rfl

@[simp] theorem union_empty {s : alist β} : s ∪ (∅ : alist β) = s :=
ext $ by simp

@[simp] theorem mem_union {a} {s₁ s₂ : alist β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
mem_keys_kunion

theorem perm_union {s₁ s₂ s₃ s₄ : alist β}
  (p₁₂ : s₁.entries ~ s₂.entries) (p₃₄ : s₃.entries ~ s₄.entries) :
  (s₁ ∪ s₃).entries ~ (s₂ ∪ s₄).entries :=
by simp [p₁₂.kunion s₃.nodupkeys p₃₄]

theorem union_erase (a : α) (s₁ s₂ : alist β) : erase a (s₁ ∪ s₂) = erase a s₁ ∪ erase a s₂ :=
ext kunion_kerase.symm

@[simp] theorem lookup_union_left {a} {s₁ s₂ : alist β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
lookup_kunion_left

@[simp] theorem lookup_union_right {a} {s₁ s₂ : alist β} :
  a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
lookup_kunion_right

@[simp] theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : alist β} :
  b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
mem_lookup_kunion

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : alist β} :
  b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
mem_lookup_kunion_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : alist β} :
  insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
by ext; simp

theorem union_assoc {s₁ s₂ s₃ : alist β} : ((s₁ ∪ s₂) ∪ s₃).entries ~ (s₁ ∪ (s₂ ∪ s₃)).entries :=
lookup_ext (alist.nodupkeys _) (alist.nodupkeys _)
(by simp [decidable.not_or_iff_and_not,or_assoc,and_or_distrib_left,and_assoc])

end

/-! ### disjoint -/

/-- Two associative lists are disjoint if they have no common keys. -/
def disjoint (s₁ s₂ : alist β) : Prop :=
∀ k ∈ s₁.keys, ¬ k ∈ s₂.keys

variables [decidable_eq α]

theorem union_comm_of_disjoint {s₁ s₂ : alist β} (h : disjoint s₁ s₂) :
  (s₁ ∪ s₂).entries ~ (s₂ ∪ s₁).entries :=
lookup_ext (alist.nodupkeys _) (alist.nodupkeys _)
(begin
   intros, simp,
   split; intro h',
   cases h',
   { right, refine ⟨_,h'⟩,
     apply h, rw [keys,← list.lookup_is_some,h'], exact rfl },
   { left, rw h'.2 },
   cases h',
   { right, refine ⟨_,h'⟩, intro h'',
     apply h _ h'', rw [keys,← list.lookup_is_some,h'], exact rfl },
   { left, rw h'.2 },
 end)

end alist


import algebra.category.Module.adjunctions
import group_theory.free_abelian_group_finsupp
import algebra.category.Group.adjunctions
import algebra.category.Group.filtered_colimits
import algebra.category.Group.biproducts
import algebra.category.Group.abelian
import algebra.category.Group.Z_Module_equivalence
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.filtered
import category_theory.limits.shapes.terminal
import linear_algebra.free_module.pid
import for_mathlib.AddCommGroup.epi
import algebra.group.ulift

open category_theory

universes v u

namespace AddCommGroup

noncomputable theory

@[simps]
def free' : Type u ⥤ AddCommGroup.{u} :=
{ obj := λ X, AddCommGroup.of $ X →₀ ℤ,
  map := λ X Y f, finsupp.map_domain.add_monoid_hom f,
  map_id' := begin
    intros X, ext, dsimp, simp,
  end,
  map_comp' := begin
    intros X Y Z f g, ext, dsimp, simp,
  end } .

@[simps]
def of_iso {A B : Type u} [add_comm_group A] [add_comm_group B]
  (e : A ≃+ B) : of A ≅ of B :=
{ hom := e.to_add_monoid_hom,
  inv := e.symm.to_add_monoid_hom,
  hom_inv_id' := begin
    ext, dsimp, simp,
  end,
  inv_hom_id' := begin
    ext, dsimp, simp,
  end } .

@[simps]
def free_iso_free' : free.{u} ≅ free'.{u} :=
category_theory.nat_iso.of_components
(λ X, of_iso (free_abelian_group.equiv_finsupp X))
begin
  intros X Y f, ext, dsimp, simp,
end

def adj' : free'.{u} ⊣ forget AddCommGroup.{u} :=
AddCommGroup.adj.of_nat_iso_left $ free_iso_free'.{u}

end AddCommGroup

def types.pt {α : Type u} (a : α) : ⊤_ _ ⟶ α :=
λ x, a

def types.punit_iso : (punit : Type u) ≅ ⊤_ _ :=
{ hom := limits.terminal.from _,
  inv := types.pt punit.star }

namespace AddCommGroup

def tunit : AddCommGroup.{u} :=
  AddCommGroup.free'.obj (⊤_ _)

def tunit.lift {A : AddCommGroup.{u}} (e : ⊤_ _ ⟶ (forget _).obj A) :
  tunit ⟶ A :=
(AddCommGroup.adj'.hom_equiv _ _).symm e

-- Do we really not have this?!
def _root_.finsupp.punit_add_equiv (M : Type*) [add_monoid M] :
  ((punit : Type u) →₀ M) ≃+ M :=
{ to_fun := λ f, f punit.star,
  inv_fun := λ m, finsupp.single punit.star m,
  left_inv := λ x, by { ext, dsimp, simp },
  right_inv := λ x, by { dsimp, simp },
  map_add' := λ f g, by simp }

-- Do we really not have this?!
def add_equiv_of_iso (A B : AddCommGroup.{u}) (e : A ≅ B) :
  A ≃+ B :=
{ to_fun := e.hom,
  inv_fun := e.inv,
  left_inv := λ x, by simp,
  right_inv := λ x, by simp,
  map_add' := λ x y, e.hom.map_add _ _ }

def tunit_add_equiv : tunit.{u} ≃+ ℤ :=
add_equiv.trans (add_equiv_of_iso _ _ $ AddCommGroup.free'.map_iso
  types.punit_iso.symm) (finsupp.punit_add_equiv ℤ)

def tunit.gen : tunit.{u} :=
AddCommGroup.adj'.unit.app _ $
  (limits.terminal.from (punit : Type u) : punit → ⊤_ (Type u)) punit.star

open_locale classical

def coproduct_cocone_of_basis {ι : Type v} {A : AddCommGroup.{u}} (𝓑 : basis ι ℤ A) :
  limits.cofan (λ i : ι, tunit.{u}) :=
limits.cofan.mk A (λ i, AddCommGroup.of_hom
  ((zmultiples_add_hom A.α (𝓑 i)).comp tunit_add_equiv.to_add_monoid_hom))

def coproduct_cocone_of_basis_is_colimit {ι : Type v} {A : AddCommGroup.{u}}
  (𝓑 : basis ι ℤ A) : limits.is_colimit (coproduct_cocone_of_basis 𝓑) :=
{ desc := λ s, AddCommGroup.of_hom
    ((finsupp.total ι s.X.α ℤ (λ i, s.ι.app ⟨i⟩ (tunit_add_equiv.symm 1))).comp
      𝓑.repr.to_linear_map).to_add_monoid_hom,
  fac' := begin
    rintros s ⟨j⟩,
    apply finsupp.add_hom_ext,
    intros x y,
    dsimp [coproduct_cocone_of_basis],
    simp [← map_zsmul],
  end,
  uniq' := begin
    intros s m e,
    apply (add_monoid_hom_lequiv_int ℤ).injective,
    swap, { apply_instance },
    apply 𝓑.ext,
    intro i,
    convert concrete_category.congr_hom (e ⟨i⟩) (tunit_add_equiv.symm 1) using 1,
   { dsimp [coproduct_cocone_of_basis], simp },
    { dsimp, simp }
  end }
.
-- set_option pp.universes true
-- Of course this is true without the fintype assumption...
def iso_of_basis {ι : Type v} [limits.has_coproduct (λ (i : ι), tunit.{u})]
  {A : AddCommGroup.{u}} (𝓑 : basis ι ℤ A) :
  (∐ (λ i : ι, tunit.{u})) ≅ A :=
limits.is_colimit.cocone_point_unique_up_to_iso (limits.coproduct_is_coproduct _)
  (coproduct_cocone_of_basis_is_colimit 𝓑)
-- begin
--   -- This is very messy...
--   let e : (∐ (λ i : ι, tunit.{u})) ≅ (⨁ (λ i, tunit.{u})) :=
--     (limits.colimit.is_colimit _).cocone_point_unique_up_to_iso
--       (limits.biproduct.is_bilimit _).is_colimit,
--   refine e ≪≫ _,
--   refine biproduct_iso_pi _ ≪≫ _,
--   let e : A ≃+ ulift.{u} (ι →₀ ℤ) := 𝓑.repr.to_add_equiv.trans add_equiv.ulift.symm,
--   refine AddCommGroup.of_iso _ ≪≫ (AddCommGroup.of_iso e).symm ≪≫
--     ⟨add_monoid_hom.id _, add_monoid_hom.id _, by { ext, refl }, by { ext, refl }⟩,
--   refine add_equiv.trans _ add_equiv.ulift.symm,
--   let q : tunit.{u} ≃+ ℤ := tunit_add_equiv,
--   let e : (ι →₀ ℤ) ≃+ (ι → ℤ),
--   { fconstructor,
--     exact finsupp.equiv_fun_on_fintype,
--     exact finsupp.equiv_fun_on_fintype.symm,
--     exact finsupp.equiv_fun_on_fintype.left_inverse_symm,
--     exact finsupp.equiv_fun_on_fintype.right_inverse_symm,
--     intros x y, refl },
--   refine add_equiv.trans _ e.symm,
--   fconstructor,
--   { intros f i, exact q (f i) },
--   { intros f i, exact q.symm (f i) },
--   { intros f, ext, dsimp, simp },
--   { intros f, ext, dsimp, simp },
--   { intros f g, ext i, simp, },
-- end

@[derive partial_order]
def index_cat (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] : Type u :=
{ H : add_subgroup A // H.fg } -- Is this the condition we want?

instance nonempty_index_cat (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  nonempty A.index_cat := ⟨⟨⊥, ∅, by simp⟩⟩

instance semilattice_sup_index_cat
  (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  semilattice_sup A.index_cat :=
{ sup := λ I J, ⟨I.1 ⊔ J.1, begin
    obtain ⟨S,hS⟩ := I.2,
    obtain ⟨T,hT⟩ := J.2,
    rw [← hS, ← hT],
    use S ∪ T,
    simp only [finset.coe_union, add_subgroup.closure_union],
  end⟩,
  le_sup_left := λ I J, @le_sup_left (add_subgroup A) _ _ _,
  le_sup_right := λ I J, @le_sup_right (add_subgroup A) _ _ _,
  sup_le := λ I J K h1 h2, @sup_le (add_subgroup A) _ _ _ _ h1 h2,
  ..(infer_instance : partial_order _) }

def diagram (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  A.index_cat ⥤ AddCommGroup.{u} :=
{ obj := λ I, AddCommGroup.of I.1,
  map := λ I J h, add_subgroup.inclusion h.le }

def cocone (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.cocone A.diagram :=
{ X := A,
  ι := { app := λ I, I.1.subtype } }

def is_colimit_cocone (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.is_colimit A.cocone :=
{ desc := λ S,
  { to_fun := λ a, S.ι.app ⟨add_subgroup.closure {a}, {a}, by simp⟩
      ⟨a, add_subgroup.subset_closure rfl⟩,
    map_zero' := add_monoid_hom.map_zero _,
    map_add' := λ x y, begin
      let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
      let J : A.index_cat := ⟨add_subgroup.closure {y}, {y}, by simp⟩,
      let K : A.index_cat := ⟨add_subgroup.closure {x + y}, {x + y}, by simp⟩,
      let IJ : A.index_cat := ⟨add_subgroup.closure {x,y}, {x,y}, by simp⟩,
      let iI : I ⟶ IJ := hom_of_le (add_subgroup.closure_mono $ by simp),
      let iJ : J ⟶ IJ := hom_of_le (add_subgroup.closure_mono $ by simp),
      let iK : K ⟶ IJ := hom_of_le ((add_subgroup.closure_le _).2 _),
      swap,
      { rintro a (rfl : a = _), change x + y ∈ IJ.1, apply IJ.1.add_mem,
        { apply add_subgroup.subset_closure, simp },
        { apply add_subgroup.subset_closure, simp } },
      rw [← S.w iI, ← S.w iJ, ← S.w iK, comp_apply, comp_apply, comp_apply,
        ← add_monoid_hom.map_add],
      refl,
    end },
  fac' := begin
    rintros S J, ext ⟨x,hx⟩,
    let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
    let e : I ⟶ J := hom_of_le ((add_subgroup.closure_le _).2 _),
    { rw comp_apply, dsimp [cocone], rw ← S.w e, refl },
    rintros x (rfl : x = _), exact hx,
  end,
  uniq' := begin
    intros S m hm, ext x, dsimp [cocone] at x ⊢,
    let I : A.index_cat := ⟨add_subgroup.closure {x}, {x}, by simp⟩,
    specialize hm I,
    let y : I.1 := ⟨x, add_subgroup.subset_closure rfl⟩,
    apply_fun (λ e, e y) at hm, exact hm,
  end }

def colimit_comparison (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A] :
  limits.colimit A.diagram ≅ A :=
(limits.colimit.is_colimit A.diagram).cocone_point_unique_up_to_iso
  A.is_colimit_cocone

lemma exists_basis_of_index (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type v) [fintype ι]
  (𝓑 : basis ι ℤ (AddCommGroup.of I.1)), true :=
begin
  obtain ⟨S,hS⟩ := I.2,
  let e : S → I.1 := λ s, ⟨s,_⟩,
  swap, { rw ← hS, apply add_subgroup.subset_closure, exact s.2 },
  haveI : no_zero_smul_divisors ℤ I.1,
  { constructor, rintros c ⟨x, hx⟩ h, apply_fun (λ e, e.val) at h,
    dsimp at h,
    cases no_zero_smul_divisors.eq_zero_or_eq_zero_of_smul_eq_zero h,
    left, assumption,
    right, ext, assumption },
  obtain ⟨n,B⟩ := @module.free_of_finite_type_torsion_free S ℤ _ _ _ I.1 _ _ _ e _ _,
  { use [ulift (fin n), infer_instance],
    refine ⟨_, trivial⟩,
    apply B.reindex,
    exact equiv.ulift.symm },
  { apply le_antisymm, { intros x hx, trivial },
    rintros ⟨x,hx⟩ -,
    let J := (submodule.span ℤ (set.range e)).to_add_subgroup,
    change _ ∈ J,
    have hJ : J = (J.map I.1.subtype).comap I.1.subtype, -- is this not a lemma?!
    { apply le_antisymm,
      { exact add_subgroup.le_comap_map I.val.subtype J },
      { intros t ht,
        simpa using ht } },
    rw [hJ, add_subgroup.mem_comap], clear hJ,
    dsimp [J],
    convert hx,
    rw [← hS, submodule.span_int_eq_add_subgroup_closure, add_monoid_hom.map_closure], congr' 1,
    ext t,
    split,
    { rintros ⟨t,⟨t,rfl⟩,rfl⟩, exact t.2 },
    { intros ht, refine ⟨⟨t, _⟩, ⟨⟨t, ht⟩, rfl⟩, rfl⟩ } },
end
.

lemma exists_sigma_iso_of_index (A : AddCommGroup.{u})
  [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type v) [fintype ι]
  (e : by exactI (∐ (λ i : ι, tunit.{u})) ≅ AddCommGroup.of I.1), true :=
begin
  obtain ⟨ι,hι,𝓑,-⟩ := exists_basis_of_index.{v} A I,
  resetI,
  exact ⟨ι, hι, iso_of_basis 𝓑, trivial⟩,
end

@[priority 100]
instance {C J : Type*} [fintype J] [category C] [limits.has_zero_morphisms C]
  [limits.has_finite_biproducts C] : limits.has_biproducts_of_shape J C :=
⟨λ F, begin
  have : F = (F ∘ (fintype.equiv_fin J).inv_fun) ∘ (fintype.equiv_fin J).to_fun,
  { ext, dsimp, rw equiv.symm_apply_apply },
  rw this,
  exact ⟨⟨⟨_, (limits.bicone.whisker_is_bilimit_iff _ (fintype.equiv_fin J)).symm
  (limits.biproduct.is_bilimit $ F ∘ (fintype.equiv_fin J).inv_fun)⟩⟩⟩
end⟩

lemma exists_biprod_iso_of_index
  (A : AddCommGroup.{u}) [no_zero_smul_divisors ℤ A]
  (I : A.index_cat) : ∃ (ι : Type v) [fintype ι]
  (e : by exactI (⨁ (λ i : ι, tunit.{u})) ≅ AddCommGroup.of I.1), true :=
begin
  obtain ⟨ι,hι,e,-⟩ := exists_sigma_iso_of_index A I,
  resetI, use [ι, hι],
  use (limits.biproduct.is_bilimit _).is_colimit.cocone_point_unique_up_to_iso
      (limits.colimit.is_colimit _) ≪≫ e,
end

universes u'

lemma is_iso_of_preserves {𝓐 : Type u'} [category.{u} 𝓐] [preadditive 𝓐]
  (F G : AddCommGroup ⥤ 𝓐)
  [F.additive]
  [G.additive]
  [limits.preserves_filtered_colimits F]
  [limits.preserves_filtered_colimits G]
  (η : F ⟶ G)
  [hη : is_iso (η.app tunit)]
  (A : AddCommGroup.{u})
  [no_zero_smul_divisors ℤ A] :
  is_iso (η.app A) :=
begin
  let T := (limits.cocones.precompose (whisker_left A.diagram η)).obj
    (G.map_cocone A.cocone),
  let S := F.map_cocone A.cocone,
  let hS : limits.is_colimit S :=
    limits.is_colimit_of_preserves F A.is_colimit_cocone,
  have : η.app A = hS.desc T,
  { apply hS.hom_ext, intros j, rw hS.fac,
    dsimp, apply η.naturality },
  rw this, clear this,
  suffices : ∀ I : A.index_cat, is_iso (η.app (A.diagram.obj I)),
  { resetI,
    haveI : is_iso (whisker_left A.diagram η),
    { apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
      intros I, exact this I },
    let hT : limits.is_colimit T :=
      (limits.is_colimit.precompose_hom_equiv (as_iso (whisker_left A.diagram η))
      (G.map_cocone A.cocone)).symm (limits.is_colimit_of_preserves G A.is_colimit_cocone),
    use hT.desc S,
    split,
    { apply hS.hom_ext,
      intros j,
      erw [hS.fac_assoc, hT.fac, category.comp_id] },
    { apply hT.hom_ext,
      intros j,
      erw [hT.fac_assoc, hS.fac, category.comp_id] }
  }, --^ general colimit nonsense..., but I can't find applicable lemmas :-(
  intros I,
  obtain ⟨ι : Type,hι,e,-⟩ := A.exists_biprod_iso_of_index.{0} I,
  -- now use the fact that the functors are additive and that there exists some iso with a biproduct
  resetI,
  let eF : F.obj (⨁ λ (i : ι), tunit.{u}) ≅ ⨁ λ (i : ι), F.obj tunit :=
    (limits.is_bilimit_of_preserves F
    (limits.biproduct.is_bilimit (λ i : ι, tunit.{u}))).is_colimit.cocone_point_unique_up_to_iso
    (limits.biproduct.is_bilimit (λ i : ι, F.obj tunit)).is_colimit,
  let eG : G.obj (⨁ λ (i : ι), tunit.{u}) ≅ ⨁ λ (i : ι), G.obj tunit :=
    (limits.is_bilimit_of_preserves G
    (limits.biproduct.is_bilimit (λ i : ι, tunit.{u}))).is_colimit.cocone_point_unique_up_to_iso
    (limits.biproduct.is_bilimit (λ i : ι, G.obj tunit)).is_colimit,
  have : η.app (A.diagram.obj I) =
    F.map e.inv ≫ eF.hom ≫ limits.biproduct.map (λ i, η.app _) ≫ eG.inv ≫ G.map e.hom,
  { rw [← functor.map_iso_inv, iso.eq_inv_comp, ← iso.inv_comp_eq],
    apply limits.biproduct.hom_ext', intros i,
    simp only [functor.map_iso_hom, nat_trans.naturality,
      limits.biproduct.ι_map_assoc, category.assoc],
    erw [limits.biproduct.ι_desc_assoc, limits.biproduct.ι_desc_assoc],
    dsimp, rw η.naturality_assoc },
  rw this,
  apply_with is_iso.comp_is_iso { instances := ff },
  apply_instance,
  apply_with is_iso.comp_is_iso { instances := ff },
  apply_instance,
  apply_with is_iso.comp_is_iso { instances := ff },
  swap,
  apply_instance,
  use limits.biproduct.desc
      (λ i, inv (η.app _) ≫ limits.biproduct.ι _ i),
  split,
  { ext, simp },
  { ext, simp },
end

def is_tensor_unit (A : AddCommGroup.{u}) : Prop :=
∃ a : A, ∀ (B : AddCommGroup.{u}), function.bijective
  (λ f : A ⟶ B, (f : A → B) a)

def is_tensor_unit.gen {A : AddCommGroup.{u}} (h : A.is_tensor_unit) :
  A := h.some

def is_tensor_unit.as_hom {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (b : B) : A ⟶ B :=
((h.some_spec B).2 b).some

@[simp]
lemma is_tensor_unit.eval_as_hom {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (b : B) : h.as_hom b h.gen = b :=
((h.some_spec B).2 b).some_spec

lemma is_tensor_unit.ext {A B : AddCommGroup.{u}} (h : A.is_tensor_unit)
  (f g : A ⟶ B) (hh : f h.gen = g h.gen) : f = g :=
(h.some_spec B).1 hh

def is_tensor_unit.iso {A B : AddCommGroup.{u}} (hA : A.is_tensor_unit)
  (hB : B.is_tensor_unit) : A ≅ B :=
{ hom := hA.as_hom hB.gen,
  inv := hB.as_hom hA.gen,
  hom_inv_id' := begin
    apply hA.ext,
    simp,
  end,
  inv_hom_id' := begin
    apply hB.ext,
    simp,
  end }

lemma is_tensor_unit_tunit : tunit.{u}.is_tensor_unit :=
begin
  use tunit.gen,
  intros B,
  split,
  { intros f g h,
    dsimp [tunit.gen] at h,
    change (adj'.unit.app _ ≫ (forget _).map f) _ =
      (adj'.unit.app _ ≫ (forget _).map g) _ at h,
    apply_fun adj'.hom_equiv _ _,
    simp only [adjunction.hom_equiv_unit],
    ext t,
    let e := limits.terminal.from (punit : Type u),
    suffices : t = e punit.star,
    { rw this, exact h },
    apply_fun types.punit_iso.inv,
    { simp },
    intros i j h, apply_fun types.punit_iso.hom at h,
    simpa using h },
  { intros t,
    use tunit.lift (types.pt t),
    dsimp only [tunit.lift, types.pt, tunit.gen],
    simp only [adjunction.hom_equiv_counit],
    change (adj'.unit.app _ ≫
      (forget _).map (free'.map (λ (x : ⊤_ Type u), t) ≫ adj'.counit.app B)) _ = _,
    simp only [functor.map_comp, adjunction.unit_naturality_assoc],
    erw adj'.right_triangle_components, refl }
end

lemma is_iso_of_preserves_of_is_tensor_unit {𝓐 : Type u'} [category.{u} 𝓐] [preadditive 𝓐]
  (F G : AddCommGroup ⥤ 𝓐)
  [F.additive]
  [G.additive]
  [limits.preserves_filtered_colimits F]
  [limits.preserves_filtered_colimits G]
  (η : F ⟶ G)
  (U : AddCommGroup)
  (hU : U.is_tensor_unit)
  [hη : is_iso (η.app U)]
  (A : AddCommGroup.{u})
  [no_zero_smul_divisors ℤ A] :
  is_iso (η.app A) :=
begin
  suffices : is_iso (η.app tunit),
  { resetI, apply is_iso_of_preserves },
  let e : tunit ≅ U := is_tensor_unit_tunit.iso hU,
  suffices : η.app tunit = F.map e.hom ≫ η.app U ≫ G.map e.inv,
  { rw this, apply is_iso.comp_is_iso, },
  rw [← η.naturality, ← F.map_comp_assoc, e.hom_inv_id, F.map_id, category.id_comp],
end

end AddCommGroup


import data.real.basic tactic.ring tactic.tidy

/- Definitions -/

definition double (n : ℕ) : ℕ := n + n

#check double

#check double ∘ double

definition quadruple : ℕ → ℕ := double ∘ double

definition FLT : Prop :=
∀ n > 2, ∀ x y z, x^n + y^n = z^n → (x = 0 ∨ y = 0)

theorem Wiles : FLT :=
begin
  unfold FLT,
  intros,
  sorry
end

--- --- --- --- --- --- --- --- --- --- --- --- --- ---

lemma transitive_imply (P Q R : Prop)
(P_imp_Q : P → Q)
(Q_imp_R : Q → R) :
  P → R :=
begin
  intro P_is_true,
  apply Q_imp_R,
  apply P_imp_Q,
  assumption,
end

lemma transitive_imply' (P Q R : Prop)
(P_imp_Q : P → Q)
(Q_imp_R : Q → R) :
  P → R := Q_imp_R ∘ P_imp_Q


/-
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.big_operators.associated
import algebra.gcd_monoid.basic
import data.finsupp.multiset
import ring_theory.noetherian
import ring_theory.multiplicity

/-!

# 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 [comm_ring α] [is_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 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 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) 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 :=
let ⟨b, hs, hr⟩ := well_founded_dvd_not_unit.has_min {b | b ∣ a ∧ ¬ is_unit b} ⟨a, dvd_rfl, ha⟩ in
⟨b, ⟨hs.2, λ c d he, let h := dvd_trans ⟨d, he⟩ hs.1 in or_iff_not_imp_left.2 $
  λ hc, of_not_not $ λ hd, hr c ⟨h, hc⟩ ⟨ne_zero_of_dvd_ne_zero ha0 h, d, hd, he⟩⟩, hs.1⟩

@[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_dvd_not_unit.fix
  (λ a ih, if ha0 : a = 0 then ha0.substr h0
    else if hau : is_unit a then hu a hau
    else let ⟨i, hii, b, hb⟩ := exists_irreducible_factor hau ha0,
      hb0 : b ≠ 0 := ne_zero_of_dvd_ne_zero ha0 ⟨i, mul_comm i b ▸ hb⟩ in
      hb.symm ▸ hi b i hb0 hii $ ih b ⟨hb0, i, hii.1, mul_comm i b ▸ hb⟩)
  a

lemma exists_factors (a : α) : a ≠ 0 →
  ∃ f : multiset α, (∀ b ∈ f, irreducible b) ∧ associated f.prod a :=
induction_on_irreducible a
  (λ h, (h rfl).elim)
  (λ u hu _, ⟨0, λ _ h, h.elim, hu.unit, one_mul _⟩)
  (λ a i ha0 hi ih _,
    let ⟨s, hs⟩ := ih ha0 in
    ⟨i ::ₘ s, λ b H, (multiset.mem_cons.1 H).elim (λ h, h.symm ▸ hi) (hs.1 b),
      by { rw s.prod_cons i, exact hs.2.mul_left i }⟩)

lemma not_unit_iff_exists_factors_eq (a : α) (hn0 : a ≠ 0) :
  ¬ is_unit a ↔ ∃ f : multiset α, (∀ b ∈ f, irreducible b) ∧ f.prod = a ∧ f ≠ ∅ :=
⟨λ hnu, begin
  obtain ⟨f, hi, u, rfl⟩ := exists_factors a hn0,
  obtain ⟨b, h⟩ := multiset.exists_mem_of_ne_zero (λ h : f = 0, hnu $ by simp [h]),
  classical, refine ⟨(f.erase b).cons (b * u), λ a ha, _, _, multiset.cons_ne_zero⟩,
  { obtain (rfl|ha) := multiset.mem_cons.1 ha,
    exacts [associated.irreducible ⟨u,rfl⟩ (hi b h), hi a (multiset.mem_of_mem_erase ha)] },
  { rw [multiset.prod_cons, mul_comm b, mul_assoc, multiset.prod_erase h, mul_comm] },
end,
λ ⟨f, hi, he, hne⟩, let ⟨b, h⟩ := multiset.exists_mem_of_ne_zero hne in
  not_is_unit_of_not_is_unit_dvd (hi b h).not_unit $ he ▸ multiset.dvd_prod h⟩

end wf_dvd_monoid

theorem wf_dvd_monoid.of_well_founded_associates [cancel_comm_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 [cancel_comm_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 `cancel_comm_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*) [cancel_comm_monoid_with_zero α]
  extends wf_dvd_monoid α : Prop :=
(irreducible_iff_prime : ∀ {a : α}, irreducible a ↔ prime a)

/-- Can't be an instance because it would cause a loop `ufm → wf_dvd_monoid → ufm → ...`. -/
@[reducible] lemma ufm_of_gcd_of_wf_dvd_monoid [cancel_comm_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 [cancel_comm_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 [cancel_comm_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 ((multiset.dvd_prod hx).trans
          (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)) $
        hfg.dvd_iff_dvd_right.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.of_mul_left
          (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 [cancel_comm_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,
    (hg x hx).not_unit $ is_unit_iff_dvd_one.2 $
    (multiset.dvd_prod hx).trans (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) $
        hfg.dvd_iff_dvd_right.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.of_mul_left
          (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 [cancel_comm_monoid_with_zero α] {a : α} {f : multiset α}
  (ha : irreducible a) (pfa : (∀ b ∈ f, prime b) ∧ f.prod ~ᵤ a) :
  ∃ p, a ~ᵤ p ∧ f = {p} :=
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 [cancel_comm_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,
  refine rel_hom_class.well_founded
    (rel_hom.mk _ _ : (dvd_not_unit : α → α → Prop) →r ((<) : with_top ℕ → with_top ℕ → Prop))
    (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, _, prime.irreducible⟩,
  obtain ⟨f, hf⟩ := pf p hp0,
  obtain ⟨q, hq, rfl⟩ := prime_factors_irreducible h hf,
  rw hq.prime_iff,
  exact hf.1 q (multiset.mem_singleton_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 [cancel_comm_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⟩

section
variables {β : Type*} [cancel_comm_monoid_with_zero α] [cancel_comm_monoid_with_zero β]

lemma mul_equiv.unique_factorization_monoid (e : α ≃* β)
  (hα : unique_factorization_monoid α) : unique_factorization_monoid β :=
begin
  rw unique_factorization_monoid.iff_exists_prime_factors at hα ⊢, intros a ha,
  obtain ⟨w,hp,u,h⟩ := hα (e.symm a) (λ h, ha $ by { convert ← map_zero e, simp [← h] }),
  exact ⟨ w.map e,
    λ b hb, let ⟨c,hc,he⟩ := multiset.mem_map.1 hb in he ▸ e.prime_iff.1 (hp c hc),
    units.map e.to_monoid_hom u,
    by { erw [multiset.prod_hom, ← e.map_mul, h], simp } ⟩,
end

lemma mul_equiv.unique_factorization_monoid_iff (e : α ≃* β) :
  unique_factorization_monoid α ↔ unique_factorization_monoid β :=
⟨ e.unique_factorization_monoid, e.symm.unique_factorization_monoid ⟩

end

theorem irreducible_iff_prime_of_exists_unique_irreducible_factors [cancel_comm_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 hfx.2.mul_left _
              ... ~ᵤ (fa).prod * (fb).prod :
                hfa.2.symm.mul_mul 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 $ hq.dvd_iff_dvd_left.2 $
            hfa.2.dvd_iff_dvd_right.1
              (multiset.dvd_prod hqa))
          (λ hqb, or.inr $ hq.dvd_iff_dvd_left.2 $
            hfb.2.dvd_iff_dvd_right.1
              (multiset.dvd_prod hqb))
        end⟩, prime.irreducible⟩

theorem unique_factorization_monoid.of_exists_unique_irreducible_factors
  [cancel_comm_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 [cancel_comm_monoid_with_zero α] [decidable_eq α]
variables [unique_factorization_monoid α]
/-- Noncomputably determines the multiset of prime factors. -/
noncomputable def factors (a : α) : multiset α := if h : a = 0 then 0 else
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],
  exact (classical.some_spec (exists_prime_factors a ane0)).2
end

theorem prime_of_factor {a : α} : ∀ (x : α), x ∈ factors a → prime x :=
begin
  rw [factors],
  split_ifs with ane0, { simp only [multiset.not_mem_zero, forall_false_left, forall_const] },
  intros x hx,
  exact (classical.some_spec (unique_factorization_monoid.exists_prime_factors a ane0)).1 x hx,
end

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

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 (factors_prod hb0).symm.mul_left _),
multiset.exists_mem_of_rel_of_mem this (by simp)

end unique_factorization_monoid

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero α] [decidable_eq α] [normalization_monoid α]
variables [unique_factorization_monoid α]

/-- Noncomputably determines the multiset of prime factors. -/
noncomputable def normalized_factors (a : α) : multiset α :=
multiset.map normalize $ factors a

/-- An arbitrary choice of factors of `x : M` is exactly the (unique) normalized set of factors,
if `M` has a trivial group of units. -/
@[simp] lemma factors_eq_normalized_factors {M : Type*} [cancel_comm_monoid_with_zero M]
  [decidable_eq M] [unique_factorization_monoid M] [unique (Mˣ)] (x : M) :
  factors x = normalized_factors x :=
begin
  unfold normalized_factors,
  convert (multiset.map_id (factors x)).symm,
  ext p,
  exact normalize_eq p
end

theorem normalized_factors_prod {a : α} (ane0 : a ≠ 0) : associated (normalized_factors a).prod a :=
begin
  rw [normalized_factors, 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_normalized_factor {a : α} : ∀ (x : α), x ∈ normalized_factors a → prime x :=
begin
  rw [normalized_factors, factors],
  split_ifs with ane0, { simp },
  intros x hx, rcases multiset.mem_map.1 hx with ⟨y, ⟨hy, rfl⟩⟩,
  rw (normalize_associated _).prime_iff,
  exact (classical.some_spec (unique_factorization_monoid.exists_prime_factors a ane0)).1 y hy,
end

theorem irreducible_of_normalized_factor {a : α} :
  ∀ (x : α), x ∈ normalized_factors a → irreducible x :=
λ x h, (prime_of_normalized_factor x h).irreducible

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

lemma normalized_factors_irreducible {a : α} (ha : irreducible a) :
  normalized_factors a = {normalize a} :=
begin
  obtain ⟨p, a_assoc, hp⟩ := prime_factors_irreducible ha
    ⟨prime_of_normalized_factor, normalized_factors_prod ha.ne_zero⟩,
  have p_mem : p ∈ normalized_factors a,
  { rw hp, exact multiset.mem_singleton_self _ },
  convert hp,
  rwa [← normalize_normalized_factor p p_mem, normalize_eq_normalize_iff, dvd_dvd_iff_associated]
end

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

@[simp] lemma normalized_factors_zero : normalized_factors (0 : α) = 0 :=
by simp [normalized_factors, factors]

@[simp] lemma normalized_factors_one : normalized_factors (1 : α) = 0 :=
begin
  nontriviality α using [normalized_factors, factors],
  rw ← multiset.rel_zero_right,
  apply factors_unique irreducible_of_normalized_factor,
  { intros x hx,
    exfalso,
    apply multiset.not_mem_zero x hx },
  { simp [normalized_factors_prod (@one_ne_zero α _ _)] },
  apply_instance
end

@[simp] lemma normalized_factors_mul {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  normalized_factors (x * y) = normalized_factors x + normalized_factors y :=
begin
  have h : (normalize : α → α) = associates.out ∘ associates.mk,
  { ext, rw [function.comp_apply, associates.out_mk], },
  rw [← multiset.map_id' (normalized_factors (x * y)), ← multiset.map_id' (normalized_factors x),
    ← multiset.map_id' (normalized_factors y), ← multiset.map_congr rfl normalize_normalized_factor,
    ← multiset.map_congr rfl normalize_normalized_factor,
    ← multiset.map_congr rfl normalize_normalized_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_normalized_factor x hx },
  { exact irreducible_of_normalized_factor },
  { rw multiset.prod_add,
    exact ((normalized_factors_prod hx).mul_mul (normalized_factors_prod hy)).trans
      (normalized_factors_prod (mul_ne_zero hx hy)).symm }
end

@[simp] lemma normalized_factors_pow {x : α} (n : ℕ) :
  normalized_factors (x ^ n) = n • normalized_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, normalized_factors_mul h0 (pow_ne_zero _ h0), ih],
end

theorem _root_.irreducible.normalized_factors_pow {p : α} (hp : irreducible p) (k : ℕ) :
  normalized_factors (p ^ k) = multiset.repeat (normalize p) k :=
by rw [normalized_factors_pow, normalized_factors_irreducible hp, multiset.nsmul_singleton]

lemma dvd_iff_normalized_factors_le_normalized_factors {x y : α} (hx : x ≠ 0) (hy : y ≠ 0) :
  x ∣ y ↔ normalized_factors x ≤ normalized_factors y :=
begin
  split,
  { rintro ⟨c, rfl⟩,
    simp [hx, right_ne_zero_of_mul hy] },
  { rw [← (normalized_factors_prod hx).dvd_iff_dvd_left,
      ← (normalized_factors_prod hy).dvd_iff_dvd_right],
    apply multiset.prod_dvd_prod_of_le }
end

theorem normalized_factors_of_irreducible_pow {p : α} (hp : irreducible p) (k : ℕ) :
  normalized_factors (p ^ k) = multiset.repeat (normalize p) k :=
by rw [normalized_factors_pow, normalized_factors_irreducible hp, multiset.nsmul_singleton]

lemma zero_not_mem_normalized_factors (x : α) : (0 : α) ∉ normalized_factors x :=
λ h, prime.ne_zero (prime_of_normalized_factor _ h) rfl

lemma dvd_of_mem_normalized_factors {a p : α} (H : p ∈ normalized_factors a) : p ∣ a :=
begin
  by_cases hcases : a = 0,
  { rw hcases,
    exact dvd_zero p },
  { exact dvd_trans (multiset.dvd_prod H) (associated.dvd (normalized_factors_prod hcases)) },
end

lemma exists_associated_prime_pow_of_unique_normalized_factor {p r : α}
  (h : ∀ {m}, m ∈ normalized_factors r → m = p) (hr : r ≠ 0) : ∃ (i : ℕ), associated (p ^ i) r :=
begin
  use (normalized_factors r).card,
  have := unique_factorization_monoid.normalized_factors_prod hr,
  rwa [multiset.eq_repeat_of_mem (λ b, h), multiset.prod_repeat] at this
end

end unique_factorization_monoid

namespace unique_factorization_monoid

open_locale classical
open multiset associates
noncomputable theory

variables [cancel_comm_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 ((normalized_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 normalized_factors_prod hx
end

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

end unique_factorization_monoid

namespace unique_factorization_monoid

variables {R : Type*} [cancel_comm_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_c.mul_left _) hq),
    rw mul_left_comm at a_dvd_bpc,
    refine or.resolve_left (hp.left_dvd_or_dvd_right_of_dvd_mul 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 p_prime.left_dvd_or_dvd_right_of_dvd_mul q_dvd_pa' with p_dvd_q q_dvd_a',
      { have : p ∣ c' * b' := dvd_mul_of_dvd_right (p_dvd_q.trans 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 [dec_dvd : decidable_rel (has_dvd.dvd : R → R → Prop)]
open multiplicity multiset

include dec_dvd
lemma le_multiplicity_iff_repeat_le_normalized_factors {a b : R} {n : ℕ}
  (ha : irreducible a) (hb : b ≠ 0) :
  ↑n ≤ multiplicity a b ↔ repeat (normalize a) n ≤ normalized_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, normalized_factors_mul hb.1 hb.2, repeat_succ,
      normalized_factors_irreducible ha, singleton_add, cons_le_cons_iff, ← ih hb.2],
    apply dvd.intro _ rfl },
  { rw [multiset.le_iff_exists_add],
    rintro ⟨u, hu⟩,
    rw [← (normalized_factors_prod hb).dvd_iff_dvd_right, hu, prod_add, prod_repeat],
    exact (associated.pow_pow $ associated_normalize a).dvd.trans (dvd.intro u.prod rfl) }
end

/-- The multiplicity of an irreducible factor of a nonzero element is exactly the number of times
the normalized factor occurs in the `normalized_factors`.

See also `count_normalized_factors_eq` which expands the definition of `multiplicity`
to produce a specification for `count (normalized_factors _) _`..
-/
lemma multiplicity_eq_count_normalized_factors {a b : R} (ha : irreducible a) (hb : b ≠ 0) :
  multiplicity a b = (normalized_factors b).count (normalize a) :=
begin
  apply le_antisymm,
  { apply enat.le_of_lt_add_one,
    rw [← nat.cast_one, ← nat.cast_add, lt_iff_not_ge, ge_iff_le,
      le_multiplicity_iff_repeat_le_normalized_factors ha hb, ← le_count_iff_repeat_le],
    simp },
  rw [le_multiplicity_iff_repeat_le_normalized_factors ha hb, ← le_count_iff_repeat_le],
end

omit dec_dvd
/-- The number of times an irreducible factor `p` appears in `normalized_factors x` is defined by
the number of times it divides `x`.

See also `multiplicity_eq_count_normalized_factors` if `n` is given by `multiplicity p x`.
-/
lemma count_normalized_factors_eq {p x : R} (hp : irreducible p) (hnorm : normalize p = p) {n : ℕ}
  (hle : p^n ∣ x) (hlt : ¬ (p^(n+1) ∣ x)) :
  (normalized_factors x).count p = n :=
begin
  letI : decidable_rel ((∣) : R → R → Prop) := λ _ _, classical.prop_decidable _,
  by_cases hx0 : x = 0,
  { simp [hx0] at hlt, contradiction },
  rw [← enat.coe_inj],
  convert (multiplicity_eq_count_normalized_factors hp hx0).symm,
  { exact hnorm.symm },
  exact (multiplicity.eq_coe_iff.mpr ⟨hle, hlt⟩).symm
end

end multiplicity

end unique_factorization_monoid

namespace associates
open unique_factorization_monoid associated multiset
variables [cancel_comm_monoid_with_zero α]

/-- `factor_set α` representation elements of unique factorization domain as multisets.
`multiset α` produced by `normalized_factors` are only unique up to associated elements, while the
multisets in `factor_set α` are unique 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) [cancel_comm_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_rfl
| 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

theorem factor_set.prod_eq_zero_iff [nontrivial α] (p : factor_set α) :
  p.prod = 0 ↔ p = ⊤ :=
begin
  induction p using with_top.rec_top_coe,
  { simp only [iff_self, eq_self_iff_true, associates.prod_top] },
  simp only [prod_coe, with_top.coe_ne_top, iff_false, prod_eq_zero_iff, multiset.mem_map],
  rintro ⟨⟨a, ha⟩, -, eq⟩,
  rw [subtype.coe_mk] at eq,
  exact ha.ne_zero eq,
end

/-- `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

theorem factor_set.unique [nontrivial α] {p q : factor_set α} (h : p.prod = q.prod) : p = q :=
begin
  induction p using with_top.rec_top_coe;
  induction q using with_top.rec_top_coe,
  { refl },
  { rw [eq_comm, ←factor_set.prod_eq_zero_iff, ←h, associates.prod_top] },
  { rw [←factor_set.prod_eq_zero_iff, h, associates.prod_top] },
  { congr' 1,
    rw  ←multiset.map_eq_map subtype.coe_injective,
    apply unique' _ _ h;
    { intros a ha,
      obtain ⟨⟨a', irred⟩, -, rfl⟩ := multiset.mem_map.mp ha,
      rwa [subtype.coe_mk] } },
end

theorem prod_le_prod_iff_le [nontrivial α] {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⟩,
    refine multiset.le_iff_exists_add.2 ⟨factors c, unique' hq (λ x hx, _) _⟩,
    { obtain h|h := multiset.mem_add.1 hx,
      { exact hp x h },
      { exact irreducible_of_factor _ h } },
    { rw [eqc, multiset.prod_add],
      congr,
      refine associated_iff_eq.mp (factors_prod (λ hc, _)).symm,
      refine not_irreducible_zero (hq _ _),
      rw [←prod_eq_zero_iff, eqc, hc, mul_zero] }
  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 : α} (h : a ~ᵤ b) :
  factors' a = factors' b :=
begin
  obtain rfl|hb := eq_or_ne b 0,
  { rw associated_zero_iff_eq_zero at h, rw h },
  have ha : a ≠ 0,
  { contrapose! hb with ha,
    rw [←associated_zero_iff_eq_zero, ←ha],
    exact h.symm },
  rw [←multiset.map_eq_map subtype.coe_injective, map_subtype_coe_factors',
    map_subtype_coe_factors', ←rel_associated_iff_map_eq_map],
  exact factors_unique irreducible_of_factor irreducible_of_factor
    ((factors_prod ha).trans $ h.trans $ (factors_prod hb).symm),
end

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 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) }

@[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 prod_factors [nontrivial α] (s : factor_set α) : s.prod.factors = s :=
factor_set.unique $ factors_prod _

@[nontriviality] lemma factors_subsingleton [subsingleton α] {a : associates α} :
  a.factors = option.none :=
by { convert factors_0; apply_instance }

lemma factors_eq_none_iff_zero {a : associates α} :
  a.factors = option.none ↔ a = 0 :=
begin
  nontriviality α,
  exact ⟨λ h, by rwa [← factors_prod a, factor_set.prod_eq_zero_iff], λ h, h.symm ▸ factors_0⟩
end

lemma factors_eq_some_iff_ne_zero {a : associates α} :
  (∃ (s : multiset {p : associates α // irreducible p}), a.factors = some s) ↔ a ≠ 0 :=
by rw [← option.is_some_iff_exists, ← option.ne_none_iff_is_some, ne.def, ne.def,
  factors_eq_none_iff_zero]

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 [nontrivial α] {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' dec_irr

theorem eq_factors_of_eq_counts {a b : associates α} (ha : a ≠ 0) (hb : b ≠ 0)
  (h : ∀ (p : associates α) (hp : irreducible p), p.count a.factors = p.count b.factors) :
  a.factors = b.factors :=
begin
  obtain ⟨sa, h_sa⟩ := factors_eq_some_iff_ne_zero.mpr ha,
  obtain ⟨sb, h_sb⟩ := factors_eq_some_iff_ne_zero.mpr hb,
  rw [h_sa, h_sb] at h ⊢,
  rw option.some_inj,
  have h_count : ∀ (p : associates α) (hp : irreducible p), sa.count ⟨p, hp⟩ = sb.count ⟨p, hp⟩,
  { intros p hp, rw [← count_some, ← count_some, h p hp] },
  apply multiset.to_finsupp.injective,
  ext ⟨p, hp⟩,
  rw [multiset.to_finsupp_apply, multiset.to_finsupp_apply, h_count p hp]
end

theorem eq_of_eq_counts {a b : associates α} (ha : a ≠ 0) (hb  : b ≠ 0)
  (h : ∀ (p : associates α), irreducible p → p.count a.factors = p.count b.factors) : a = b :=
eq_of_factors_eq_factors (eq_factors_of_eq_counts ha hb h)

lemma count_le_count_of_factors_le {a b p : associates α} (hb : b ≠ 0)
  (hp : irreducible p) (h : a.factors ≤ b.factors) : p.count a.factors ≤ p.count b.factors :=
begin
  by_cases ha : a = 0,
  { simp [*] at *, },
  obtain ⟨sa, h_sa⟩ := factors_eq_some_iff_ne_zero.mpr ha,
  obtain ⟨sb, h_sb⟩ := factors_eq_some_iff_ne_zero.mpr hb,
  rw [h_sa, h_sb] at h ⊢,
  rw [count_some hp, count_some hp], rw with_top.some_le_some at h,
  exact multiset.count_le_of_le _ h
end

omit dec_irr

@[simp] theorem factors_mul (a b : associates α) :
  (a * b).factors = a.factors + b.factors :=
begin
  casesI subsingleton_or_nontrivial α,
  { simp [subsingleton.elim a 0], },
  refine (eq_of_prod_eq_prod (eq_of_factors_eq_factors _)),
  rw [prod_add, factors_prod, factors_prod, factors_prod],
end

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

include dec_irr

lemma count_le_count_of_le {a b p : associates α} (hb : b ≠ 0)
  (hp : irreducible p) (h : a ≤ b) : p.count a.factors ≤ p.count b.factors :=
count_le_count_of_factors_le hb hp $ factors_mono h

omit dec dec' dec_irr

theorem prod_le [nontrivial α] {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 : 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 }

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
  nontriviality α,
  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

theorem factors_self [nontrivial α] {p : associates α}  (hp : irreducible p) :
  p.factors = some ({⟨p, hp⟩}) :=
eq_of_prod_eq_prod (by rw [factors_prod, factor_set.prod, map_singleton, prod_singleton,
                            subtype.coe_mk])

theorem factors_prime_pow [nontrivial α] {p : associates α} (hp : irreducible p)
  (k : ℕ) : factors (p ^ k) = some (multiset.repeat ⟨p, hp⟩ k) :=
eq_of_prod_eq_prod (by rw [associates.factors_prod, factor_set.prod, multiset.map_repeat,
                           multiset.prod_repeat, subtype.coe_mk])

include dec_irr

theorem prime_pow_dvd_iff_le [nontrivial α] {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
  nontriviality α,
  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_ne_zero_iff_dvd {a p : α} (ha0 : a ≠ 0) (hp : irreducible p) :
  (associates.mk p).count (associates.mk a).factors ≠ 0 ↔ p ∣ a :=
begin
  nontriviality α,
  rw ← associates.mk_le_mk_iff_dvd_iff,
  refine ⟨λ h, associates.le_of_count_ne_zero (associates.mk_ne_zero.mpr ha0)
    ((associates.irreducible_mk p).mpr hp) h, λ h, _⟩,
  { rw [← pow_one (associates.mk p), associates.prime_pow_dvd_iff_le
      (associates.mk_ne_zero.mpr ha0) ((associates.irreducible_mk p).mpr hp)] at h,
    exact (zero_lt_one.trans_le h).ne' }
end

theorem count_self [nontrivial α] {p : associates α} (hp : irreducible p) :
  p.count p.factors = 1 :=
by simp [factors_self hp, associates.count_some hp]

lemma count_eq_zero_of_ne {p q : associates α} (hp : irreducible p) (hq : irreducible q)
  (h : p ≠ q) : p.count q.factors = 0 :=
not_ne_iff.mp $ λ h', h $ associated_iff_eq.mp $ hp.associated_of_dvd hq $
by { nontriviality α, exact le_of_count_ne_zero hq.ne_zero hp h' }

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 α} {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
  by_cases ha : a = 0,
  { simp [ha], },
  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 b : associates α}
  {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
  by_cases ha : a = 0, { simp [ha], },
  by_cases hb : b = 0, { simp [hb], },
  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 α} (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
  by_cases ha : a = 0, { simpa [*] using habk, },
  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 [nontrivial α] : factors (1 : associates α) = 0 :=
begin
  apply eq_of_prod_eq_prod,
  rw associates.factors_prod,
  exact multiset.prod_zero,
end

@[simp] theorem pow_factors [nontrivial α] {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 [nontrivial α] {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 [nontrivial α] {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 [nontrivial α] {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, p ∈ (factors' a0) → k ∣ (factors' a0).count p,
  { rintros 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

/-- The only divisors of prime powers are prime powers. See `eq_pow_find_of_dvd_irreducible_pow`
for an explicit expression as a p-power (without using `count`). -/
theorem eq_pow_count_factors_of_dvd_pow {p a : associates α} (hp : irreducible p)
  {n : ℕ} (h : a ∣ p ^ n) : a = p ^ p.count a.factors :=
begin
  nontriviality α,
  have hph := pow_ne_zero n hp.ne_zero,
  have ha := ne_zero_of_dvd_ne_zero hph h,
  apply eq_of_eq_counts ha (pow_ne_zero _ hp.ne_zero),
  have eq_zero_of_ne : ∀ (q : associates α), irreducible q → q ≠ p → _ = 0 :=
  λ q hq h', nat.eq_zero_of_le_zero $ by
  { convert count_le_count_of_le hph hq h, symmetry,
    rw [count_pow hp.ne_zero hq, count_eq_zero_of_ne hq hp h', mul_zero] },
  intros q hq,
  rw count_pow hp.ne_zero hq,
  by_cases h : q = p,
  { rw [h, count_self hp, mul_one] },
  { rw [count_eq_zero_of_ne hq hp h, mul_zero, eq_zero_of_ne q hq h] }
end

lemma count_factors_eq_find_of_dvd_pow {a p : associates α} (hp : irreducible p)
  [∀ n : ℕ, decidable (a ∣ p ^ n)] {n : ℕ} (h : a ∣ p ^ n) : nat.find ⟨n, h⟩ = p.count a.factors :=
begin
  apply le_antisymm,
  { refine nat.find_le ⟨1, _⟩, rw mul_one, symmetry, exact eq_pow_count_factors_of_dvd_pow hp h },
  { have hph := pow_ne_zero (nat.find ⟨n, h⟩) hp.ne_zero,
    casesI (subsingleton_or_nontrivial α) with hα hα,
    { simpa using hph, },
    convert count_le_count_of_le hph hp (nat.find_spec ⟨n, h⟩),
    rw [count_pow hp.ne_zero hp, count_self hp, mul_one] }
end

omit dec
omit dec_irr
omit dec'

theorem eq_pow_of_mul_eq_pow [nontrivial α] {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 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

/-- The only divisors of prime powers are prime powers. -/
theorem eq_pow_find_of_dvd_irreducible_pow {a p : associates α} (hp : irreducible p)
  [∀ n : ℕ, decidable (a ∣ p ^ n)] {n : ℕ} (h : a ∣ p ^ n) : a = p ^ nat.find ⟨n, h⟩ :=
by { classical, rw [count_factors_eq_find_of_dvd_pow hp, ← eq_pow_count_factors_of_dvd_pow hp h] }

end associates

section
open associates unique_factorization_monoid

lemma associates.quot_out {α : Type*} [comm_monoid α] (a : associates α):
associates.mk (quot.out (a)) = a :=
by rw [←quot_mk_eq_mk, quot.out_eq]

/-- `to_gcd_monoid` constructs a GCD monoid out of a unique factorization domain. -/
noncomputable def unique_factorization_monoid.to_gcd_monoid
  (α : Type*) [cancel_comm_monoid_with_zero α] [unique_factorization_monoid α]
  [decidable_eq (associates α)] [decidable_eq α] : gcd_monoid α :=
{ gcd := λa b, quot.out (associates.mk a ⊓ associates.mk b : associates α),
  lcm := λa b, quot.out (associates.mk a ⊔ associates.mk b : associates α),
  gcd_dvd_left := λ a b, by
  { rw [←mk_dvd_mk, (associates.mk a ⊓ associates.mk b).quot_out, dvd_eq_le],
    exact inf_le_left },
  gcd_dvd_right := λ a b, by
  { rw [←mk_dvd_mk, (associates.mk a ⊓ associates.mk b).quot_out, dvd_eq_le],
    exact inf_le_right },
  dvd_gcd := λ a b c hac hab, by
  { rw [←mk_dvd_mk, (associates.mk c ⊓ associates.mk b).quot_out, dvd_eq_le,
      le_inf_iff, mk_le_mk_iff_dvd_iff, mk_le_mk_iff_dvd_iff],
    exact ⟨hac, hab⟩ },
  lcm_zero_left := λ a, by
  { have : associates.mk (0 : α) = ⊤ := rfl,
    rw [this, top_sup_eq, ←this, ←associated_zero_iff_eq_zero, ←mk_eq_mk_iff_associated,
      ←associated_iff_eq, associates.quot_out] },
  lcm_zero_right := λ a, by
  { have : associates.mk (0 : α) = ⊤ := rfl,
    rw [this, sup_top_eq, ←this, ←associated_zero_iff_eq_zero, ←mk_eq_mk_iff_associated,
      ←associated_iff_eq, associates.quot_out] },
  gcd_mul_lcm := λ a b, by
  { rw [←mk_eq_mk_iff_associated, ←associates.mk_mul_mk, ←associated_iff_eq, associates.quot_out,
      associates.quot_out, mul_comm, sup_mul_inf, associates.mk_mul_mk] } }

/-- `to_normalized_gcd_monoid` constructs a GCD monoid out of a normalization on a
  unique factorization domain. -/
noncomputable def unique_factorization_monoid.to_normalized_gcd_monoid
  (α : Type*) [cancel_comm_monoid_with_zero α] [unique_factorization_monoid α]
  [normalization_monoid α] [decidable_eq (associates α)] [decidable_eq α] :
  normalized_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, by
  { rw [← out_mul, mul_comm, sup_mul_inf, mk_mul_mk, out_mk],
    exact normalize_associated (a * b) },
  normalize_gcd := assume a b, by convert normalize_out _,
  normalize_lcm := assume a b, by convert normalize_out _,
  .. ‹normalization_monoid α› }

end

namespace unique_factorization_monoid

/-- If `y` is a nonzero element of a unique factorization monoid with finitely
many units (e.g. `ℤ`, `ideal (ring_of_integers K)`), it has finitely many divisors. -/
noncomputable def fintype_subtype_dvd {M : Type*} [cancel_comm_monoid_with_zero M]
  [unique_factorization_monoid M] [fintype Mˣ]
  (y : M) (hy : y ≠ 0) :
  fintype {x // x ∣ y} :=
begin
  haveI : nontrivial M := ⟨⟨y, 0, hy⟩⟩,
  haveI : normalization_monoid M := unique_factorization_monoid.normalization_monoid,
  haveI := classical.dec_eq M,
  haveI := classical.dec_eq (associates M),
  -- We'll show `λ (u : Mˣ) (f ⊆ factors y) → u * Π f` is injective
  -- and has image exactly the divisors of `y`.
  refine fintype.of_finset
    (((normalized_factors y).powerset.to_finset.product (finset.univ : finset Mˣ)).image
      (λ s, (s.snd : M) * s.fst.prod))
    (λ x, _),
  simp only [exists_prop, finset.mem_image, finset.mem_product, finset.mem_univ, and_true,
    multiset.mem_to_finset, multiset.mem_powerset, exists_eq_right, multiset.mem_map],
  split,
  { rintros ⟨s, hs, rfl⟩,
    have prod_s_ne : s.fst.prod ≠ 0,
    { intro hz,
      apply hy (eq_zero_of_zero_dvd _),
      have hz := (@multiset.prod_eq_zero_iff M _ _ _ s.fst).mp hz,
      rw ← (normalized_factors_prod hy).dvd_iff_dvd_right,
      exact multiset.dvd_prod (multiset.mem_of_le hs hz) },
    show (s.snd : M) * s.fst.prod ∣ y,
    rw [(unit_associated_one.mul_right s.fst.prod).dvd_iff_dvd_left, one_mul,
        ← (normalized_factors_prod hy).dvd_iff_dvd_right],
    exact multiset.prod_dvd_prod_of_le hs },
  { rintro (h : x ∣ y),
    have hx : x ≠ 0, { refine mt (λ hx, _) hy, rwa [hx, zero_dvd_iff] at h },
    obtain ⟨u, hu⟩ := normalized_factors_prod hx,
    refine ⟨⟨normalized_factors x, u⟩, _, (mul_comm _ _).trans hu⟩,
    exact (dvd_iff_normalized_factors_le_normalized_factors hx hy).mp h }
end

end unique_factorization_monoid

section finsupp
variables [cancel_comm_monoid_with_zero α] [unique_factorization_monoid α]
variables [normalization_monoid α] [decidable_eq α]

open unique_factorization_monoid

/-- This returns the multiset of irreducible factors as a `finsupp` -/
noncomputable def factorization (n : α) : α →₀ ℕ := (normalized_factors n).to_finsupp

lemma factorization_eq_count {n p : α} :
  factorization n p = multiset.count p (normalized_factors n) :=
by simp [factorization]

@[simp] lemma factorization_zero : factorization (0 : α) = 0 := by simp [factorization]

@[simp] lemma factorization_one : factorization (1 : α) = 0 := by simp [factorization]

/-- The support of `factorization n` is exactly the finset of normalized factors -/
@[simp] lemma support_factorization {n : α} :
  (factorization n).support = (normalized_factors n).to_finset :=
by simp [factorization, multiset.to_finsupp_support]

/-- For nonzero `a` and `b`, the power of `p` in `a * b` is the sum of the powers in `a` and `b` -/
@[simp] lemma factorization_mul {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) :
  factorization (a * b) = factorization a + factorization b :=
by simp [factorization, normalized_factors_mul ha hb]

/-- For any `p`, the power of `p` in `x^n` is `n` times the power in `x` -/
lemma factorization_pow {x : α} {n : ℕ} :
  factorization (x^n) = n • factorization x :=
by { ext, simp [factorization] }

lemma associated_of_factorization_eq (a b: α) (ha: a ≠ 0) (hb: b ≠ 0)
  (h: factorization a = factorization b) : associated a b :=
begin
  simp only [factorization, add_equiv.apply_eq_iff_eq] at h,
  have ha' := normalized_factors_prod ha,
  rw h at ha',
  exact associated.trans ha'.symm (normalized_factors_prod hb),
end

end finsupp


import tactic.interactive
import data.nat.basic

variables (p : ℕ → Prop) (a b : ℕ)

example (h : p (a + b)) : p (b + a) :=
begin
  rw add_comm,
  -- `guard_target` fails because the instances don't match
  success_if_fail { guard_target p (a + b) },
  guard_target_mod_implicit p (a + b),
  assumption
end

example (h : p (b + a)) : p (a + b) :=
begin
  rw add_comm at h,
  -- `guard_hyp` fails because the instances don't match
  success_if_fail { guard_hyp h : p (a + b) },
  guard_hyp_mod_implicit h : p (a + b),
  assumption
end


/-
Copyright (c) 2022 Youjack. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Youjack
-/
import data.real.nnreal
import data.finsupp.basic

/-!
# Some math lemmas

## Notations

This file defines the notation `ℝ₊` for positive real numbers `{c : ℝ // 0 < c}`.
-/

section real

@[reducible] def posreal := {c : ℝ // 0 < c}
notation `ℝ₊` := posreal
namespace posreal
instance coe_nnreal : has_coe ℝ₊ nnreal := ⟨λ c, ⟨c.val, le_of_lt c.property⟩⟩
lemma ne_zero (c : ℝ₊) : (c:ℝ) ≠ 0 := by { rw ←subtype.val_eq_coe, exact ne_of_gt c.property }
end posreal

lemma real.max_mul_nonneg_zero (c x : ℝ) (hc : 0 ≤ c) : max (c * x) 0 = c * (max x 0) :=
  if hx : 0 ≤ x then by {
    have : max (c * x) 0 = c * x, from max_eq_left (mul_nonneg hc hx), rw this,
    have : max      x  0 =     x, from max_eq_left hx                , rw this, }
  else by {
    have hx := le_of_lt (not_le.elim_left hx),
    have : max (c * x) 0 = 0, from
      max_eq_right (mul_nonpos_iff.elim_right (or.inl ⟨hc, hx⟩)), rw this,
    have : max      x  0 = 0, from max_eq_right hx, rw this,
    rw mul_zero, }
--

end real

namespace finsupp
open finset

variables {α : Type*} [decidable_eq α]
variables {R : Type*} [decidable_eq R] [semiring R] [no_zero_smul_divisors R R]
variables {f g : α →₀ R}

@[reducible] def sum_image (f : α →₀ R) := f.support.sum f
lemma extend_support_sum_iamge {s : finset α}
  (s_extend_supp : f.support ⊆ s) : s.sum f = f.sum_image := by {
  rw ←sum_sdiff s_extend_supp,
  simp only [sum_image],
  suffices : (s \ f.support).sum f = 0,
    rw [this, zero_add],
  apply sum_eq_zero, assume x hx,
  simp only [mem_sdiff, mem_support_iff, not_not] at hx,
  exact hx.elim_right, }
lemma sum_image_add : (f + g).sum_image = f.sum_image + g.sum_image := by {
  let s := f.support ∪ g.support,
  have : (f + g).support ⊆ s, from support_add           , rw ←extend_support_sum_iamge this,
  have :  f     .support ⊆ s, from subset_union_left  _ _, rw ←extend_support_sum_iamge this,
  have :      g .support ⊆ s, from subset_union_right _ _, rw ←extend_support_sum_iamge this,
  exact finset.sum_add_distrib, }
lemma sum_image_smul {c : R} : (c • f).sum_image = c • f.sum_image :=
  if hc : c = 0 then by
    simp [hc, sum_image]
  else by {
    unfold sum_image,
    have : (c • f).support = f.support, from support_smul_eq hc, rw this,
    simp [finset.smul_sum], }
--

lemma support_add_exact {supp : finset α}
  (non_zero_on_supp   : ∀ x ∈ supp                           , f x + g x ≠ 0)
  (zero_on_sdiff_supp : ∀ x ∈ (f.support ∪ g.support) \ supp, f x + g x = 0) :
  (f + g).support = supp := by {
  ext x, split,
  { apply function.mtr,
    assume hx_supp,
    exact if hx_union : x ∈ (f.support ∪ g.support) then by {
      simp only [mem_support_iff, coe_add, pi.add_apply, not_not],
      exact zero_on_sdiff_supp x (mem_sdiff.elim_right ⟨hx_union, hx_supp⟩), }
    else by {
      have : (f + g).support ⊆ (f.support ∪ g.support), from support_add,
      exact not_mem_mono this hx_union, } },
  { simp only [mem_support_iff, coe_add, pi.add_apply],
    exact non_zero_on_supp x, } }
--

lemma support_smul_exact {c : R} {supp : finset α}
  (supp_is_supp : f.support = supp)
  (non_zero_smul : c ≠ 0) :
  (c • f).support = supp := by {
  rw ←supp_is_supp,
  exact support_smul_eq non_zero_smul, }
--

end finsupp