import tactic
import analysis.special_functions.trigonometric
/-

# Topology in Lean

In this and the next meetings we will discuss how to do various areas of math in mathlib.
We will start with topology.
-/
noncomputable theory
open set topological_space filter
open_locale topological_space filter big_operators classical

#check @topological_space

example {X} {g : set (set X)} : topological_space X :=
{ is_open :=
  ⋂ (t : topological_space X) (h : ∀ s ∈ g, t.is_open s),
  { s | t.is_open s },
  is_open_univ := _,
  is_open_inter := _,
  is_open_sUnion := _ }

#check @topological_space.generate_open
/-
There is a Galois insertion between sets and topological spaces.
As in last week, this gives topological spaces the structure of a complete lattice.
However, in mathlib the order is given by *reverse* inclusion.
So e.g. `⊥` is the discrete topology and `⊤` is the indiscrete topology.
-/
#check @topological_space.complete_lattice

/-- The topology on `X × Y` is the coarsest topology
  that makes both projections continuous. -/
example {X Y : Type*} [t₁ : topological_space X]
  [t₂ : topological_space Y] : topological_space (X × Y) :=
induced prod.fst t₁ ⊓ induced prod.snd t₂

#check @continuous
#check @is_open_compl_iff
example {X Y : Type*} [topological_space X] [topological_space Y] (f : X → Y) :
  continuous f ↔ ∀ C : set Y, is_closed C → is_closed (f ⁻¹' C) :=
begin
  rw [continuous_def],
  split,
  {
    intros h C hC, rw [← is_open_compl_iff] at hC ⊢, rw [← preimage_compl], apply h, assumption,
  },
  sorry
end

example {f : ℝ → ℝ} (hf : continuous f) :
  continuous (λ x, x * f (x ^ 2 + 37)) :=
by continuity

class my_metric_space (α : Type*) :=
(dist : α → α → ℝ)
(dist_self : ∀ x : α, dist x x = 0)
(eq_of_dist_eq_zero : ∀ {x y : α}, dist x y = 0 → x = y)
(dist_comm : ∀ x y : α, dist x y = dist y x)
(dist_triangle : ∀ x y z : α, dist x z ≤ dist x y + dist y z)

/- Every metric space (as defined in mathlib) is a topological space. -/

example {X : Type} [metric_space X] (U : set X) :
  is_open U ↔ ∀ x ∈ U, ∃ ε > 0, metric.ball x ε ⊆ U :=
metric.is_open_iff

/-
The above is not quite the definition in Lean.

Suppose that `X` and `Y` are metric spaces,
we can define the topology on `X × Y` in two ways:
* the product topology of `X` and `Y`
* the topology given by the metric space `X × Y`.

These are provably the same, but not exactly the same.

To avoid this distinction,
we add the correct topological space as a field

-/

class my_metric_space2 (α : Type*) :=
(dist : α → α → ℝ)
(dist_self : ∀ x : α, dist x x = 0)
(eq_of_dist_eq_zero : ∀ {x y : α}, dist x y = 0 → x = y)
(dist_comm : ∀ x y : α, dist x y = dist y x)
(dist_triangle : ∀ x y z : α, dist x z ≤ dist x y + dist y z)
(topology : topological_space α)
(topology_opens : ∀ U : set α, is_open U ↔ ∀ x ∈ U, ∃ ε > 0, { y | dist x y < ε } ⊆ U)

instance my_metric_space2.topological_space {X : Type*}
  [my_metric_space2 X] : topological_space X :=
my_metric_space2.topology

example {X Y : Type*} [my_metric_space2 X] [my_metric_space2 Y] :
  my_metric_space2 (X × Y) :=
{ dist := sorry,
  dist_self := sorry,
  eq_of_dist_eq_zero := sorry,
  dist_comm := sorry,
  dist_triangle := sorry,
  topology := prod.topological_space,
  topology_opens := sorry }

#print uniform_space

/- You can now define the product metric space
  where the `topology` field is the product topology. -/

/- This is still not quite the definition of metric space in mathlib,
  which is defined in terms of *uniform spaces*,
  but I won't get into that now -/

/-! ## Limits -/

/-
  We want to define multiple limits:
  * As x ⟶ a, then f(x) ⟶ b
  * As n ⟶ ∞, then a(n) ⟶ b⁻
  * As x ⟶ a⁺ (x ≠ a), then f(x) ⟶ - ∞

  If we want all combinations of a, a⁺, a⁻, ± ∞,
  possibly with the added condition that x ≠ a.
  We could even take some crazier limits, like constraining `x` to be rational.

  Even worse is the composition of limits:
  * If
    - as x ⟶ a, then f(x) ⟶ b
    - as y ⟶ b, then g(y) ⟶ c
    then
    - as x ⟶ a, then g(f(x)) ⟶ c

  For a uniform way of dealing with limits we use filters.
-/

#print filter

/- The neighborhood filter `𝓝 a` -/
#check @mem_nhds_sets_iff

/- The filter `at_top` (at ∞) -/
#check @mem_at_top_sets

/- The principal filter `𝓟 A = { B | A ⊆ B } `-/
#check @mem_principal_sets

/-
  Now we can define the limit
  * As x ⟶ a, then f(x) ⟶ b
  as follows
-/

definition simple_limit {X Y} [topological_space X]
  [topological_space Y] (f : X → Y) (a : X) (b : Y) : Prop :=
∀ V ∈ 𝓝 b, f ⁻¹' V ∈ 𝓝 a

/- In full generality, the limit is defined as follows.
  Filters are ordered by *reverse* inclusion. -/
def my_tendsto {X Y} (f : X → Y) (l₁ : filter X) (l₂ : filter Y) :=
l₁.map f ≤ l₂

lemma tendsto.comp {X Y Z} {f : X → Y} {g : Y → Z}
  {x : filter X} {y : filter Y} {z : filter Z}
  (hg : tendsto g y z) (hf : tendsto f x y) :
  tendsto (g ∘ f) x z :=
calc map (g ∘ f) x = map g (map f x) : by rw [map_map]
  ... ≤ map g y : map_mono hf
  ... ≤ z : hg

/-
Here are some propositions:
* For `N` large enough, `P(N)`
* For `y` close enough to `z`, `P(y)`
* For almost every `y`, `P(y)`

These are all examples of `{x | P(x)} ∈ F`
for some filter `F`. Notation: `∀ᶠ x in F, P(x)`
-/

example {X} [topological_space X] (P : X → Prop) (y : X) :
  (∀ᶠ x in 𝓝 y, P x) ↔
  ∃ (U : set X), (∀ x ∈ U, P x) ∧ is_open U ∧ y ∈ U :=
eventually_nhds_iff

/- We can formulate topological properties
in terms of filters -/

#check @t2_iff_nhds
#print t2_space
#check @ne_bot_iff
#check @empty_in_sets_eq_bot

#print is_compact

#check @cluster_pt_iff

#check @compact_iff_finite_subcover

#check @complete_space

#print instances locally_compact_space

/- Heine-Borel -/
#check @metric.compact_iff_closed_bounded
/- ℝⁿ is "proper" -/
example (n : ℕ) : proper_space (fin n → ℝ) :=
by apply_instance

/- We can use limits to define infinite sums.
  Note: the default sum for mathlib only exists for
  absolutely convergent sequences, but has some nice properties,
  like invariance under reordering. -/

variables {I X : Type*} [topological_space X] [add_comm_group X]
  [topological_add_group X]

def my_has_sum (f : I → X) (a : X) : Prop :=
tendsto (λ A : finset I, ∑ b in A, f b) at_top (𝓝 a)

/- We can pick a value for the sum.
 This is only well-behaved if X is a T₂-space. -/
def my_tsum (f : I → X) :=
if h : ∃ a, my_has_sum f a then classical.some h else 0

example [t2_space X] (f : I → X) {a₁ a₂ : X} :
  my_has_sum f a₁ → my_has_sum f a₂ → a₁ = a₂ :=
tendsto_nhds_unique

example [t2_space X] (f : ℕ → X) :
  tendsto (λ i, ∑' k, f (k + i)) at_top (𝓝 0) :=
tendsto_sum_nat_add f


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import linear_algebra.finite_dimensional

/-!

# Projective Spaces

This file contains the definition of the projectivization of a vector space over a field,
as well as the bijection between said projectivization and the collection of all one
dimensional subspaces of the vector space.

## Notation
`ℙ K V` is notation for `projectivization K V`, the projectivization of a `K`-vector space `V`.

## Constructing terms of `ℙ K V`.
We have three ways to construct terms of `ℙ K V`:
- `projectivization.mk K v hv` where `v : V` and `hv : v ≠ 0`.
- `projectivization.mk' K v` where `v : { w : V // w ≠ 0 }`.
- `projectivization.mk'' H h` where `H : submodule K V` and `h : finrank H = 1`.

## Other definitions
- For `v : ℙ K V`, `v.submodule` gives the corresponding submodule of `V`.
- `projectivization.equiv_submodule` is the equivalence between `ℙ K V`
  and `{ H : submodule K V // finrank H = 1 }`.
- For `v : ℙ K V`, `v.rep : V` is a representative of `v`.

## Projects
Everything in this file can be done for `division_ring`s instead of `field`s, but
this would require a significant refactor of the results from
`linear_algebra.finite_dimensional` and its imports.

-/

variables (K V : Type*) [field K] [add_comm_group V] [module K V]

/-- The setoid whose quotient is the projectivization of `V`. -/
def projectivization_setoid : setoid { v : V // v ≠ 0 } :=
(mul_action.orbit_rel Kˣ V).comap coe

/-- The projectivization of the `K`-vector space `V`.
The notation `ℙ K V` is preferred. -/
@[nolint has_inhabited_instance]
def projectivization := quotient (projectivization_setoid K V)

notation `ℙ` := projectivization

namespace projectivization

variables {V}

/-- Construct an element of the projectivization from a nonzero vector. -/
def mk (v : V) (hv : v ≠ 0) : ℙ K V := quotient.mk' ⟨v,hv⟩

/-- A variant of `projectivization.mk` in terms of a subtype. `mk` is preferred. -/
def mk' (v : { v : V // v ≠ 0 }) : ℙ K V := quotient.mk' v

@[simp] lemma mk'_eq_mk (v : { v : V // v ≠ 0}) :
  mk' K v = mk K v v.2 :=
by { dsimp [mk, mk'], congr' 1, simp }

instance [nontrivial V] : nonempty (ℙ K V) :=
let ⟨v, hv⟩ := exists_ne (0 : V) in ⟨mk K v hv⟩

variable {K}

/-- Choose a representative of `v : projectivization K V` in `V`. -/
protected noncomputable def rep (v : ℙ K V) : V := v.out'

lemma rep_nonzero (v : ℙ K V) : v.rep ≠ 0 := v.out'.2

@[simp]
lemma mk_rep (v : ℙ K V) :
  mk K v.rep v.rep_nonzero = v :=
by { dsimp [mk, projectivization.rep], simp }

open finite_dimensional

/-- Consider an element of the projectivization as a submodule of `V`. -/
protected def submodule (v : ℙ K V) : submodule K V :=
quotient.lift_on' v (λ v, K ∙ (v : V)) $ begin
  rintro ⟨a, ha⟩ ⟨b, hb⟩ ⟨x, (rfl : x • b = a)⟩,
  exact (submodule.span_singleton_group_smul_eq _ x _),
end

variable (K)

lemma mk_eq_mk_iff (v w : V) (hv : v ≠ 0) (hw : w ≠ 0) :
  mk K v hv = mk K w hw ↔ ∃ (a : Kˣ), a • w = v :=
quotient.eq'

lemma exists_smul_eq_mk_rep
  (v : V) (hv : v ≠ 0) : ∃ (a : Kˣ), a • v = (mk K v hv).rep :=
show (projectivization_setoid K V).rel _ _, from quotient.mk_out' ⟨v, hv⟩

variable {K}

/-- An induction principle for `projectivization`.
Use as `induction v using projectivization.ind`. -/
@[elab_as_eliminator]
lemma ind {P : ℙ K V → Prop} (h : ∀ (v : V) (h : v ≠ 0), P (mk K v h)) :
  ∀ p, P p :=
quotient.ind' $ subtype.rec $ by exact h

@[simp]
lemma submodule_mk (v : V) (hv : v ≠ 0) : (mk K v hv).submodule = K ∙ v := rfl

lemma submodule_eq (v : ℙ K V) : v.submodule = K ∙ v.rep :=
by { conv_lhs { rw ← v.mk_rep }, refl }

lemma finrank_submodule (v : ℙ K V) : finrank K v.submodule = 1 :=
begin
  rw submodule_eq,
  exact finrank_span_singleton v.rep_nonzero,
end

instance (v : ℙ K V) : finite_dimensional K v.submodule :=
by { rw ← v.mk_rep, change finite_dimensional K (K ∙ v.rep), apply_instance }

variables (K V)
/-- The equivalence between the projectivization and the
collection of subspaces of dimension 1. -/
noncomputable
def equiv_submodule : ℙ K V ≃ { H : submodule K V // finrank K H = 1 } :=
equiv.of_bijective (λ v, ⟨v.submodule, v.finrank_submodule⟩)
begin
  split,
  { intros u v h, apply_fun (λ e, e.val) at h,
    apply submodule_injective h },
  { rintros ⟨H, h⟩,
    rw finrank_eq_one_iff' at h,
    obtain ⟨v, hv, h⟩ := h,
    have : (v : V) ≠ 0 := λ c, hv (subtype.coe_injective c),
    use mk K v this,
    symmetry,
    ext x, revert x, erw ← set.ext_iff, ext x,
    dsimp,
    rw [submodule.span_singleton_eq_range],
    refine ⟨λ hh, _, _⟩,
    { obtain ⟨c,hc⟩ := h ⟨x,hh⟩,
      exact ⟨c, congr_arg coe hc⟩ },
    { rintros ⟨c,rfl⟩,
      refine submodule.smul_mem _ _ v.2 } }
end
variables {K V}

/-- Construct an element of the projectivization from a subspace of dimension 1. -/
noncomputable
def mk'' (H : _root_.submodule K V) (h : finrank K H = 1) : ℙ K V :=
(equiv_submodule K V).symm ⟨H,h⟩

@[simp]
lemma submodule_mk'' (H : _root_.submodule K V) (h : finrank K H = 1) :
  (mk'' H h).submodule = H :=
begin
  suffices : (equiv_submodule K V) (mk'' H h) = ⟨H,h⟩, by exact congr_arg coe this,
  dsimp [mk''],
  simp
end

@[simp]
lemma mk''_submodule (v : ℙ K V) : mk'' v.submodule v.finrank_submodule = v :=
show (equiv_submodule K V).symm (equiv_submodule K V _) = _, by simp

section map

variables {L W : Type*} [field L] [add_comm_group W] [module L W]

/-- An injective semilinear map of vector spaces induces a map on projective spaces. -/
def map {σ : K →+* L} (f : V →ₛₗ[σ] W) (hf : function.injective f) :
  ℙ K V → ℙ L W :=
quotient.map' (λ v, ⟨f v, λ c, v.2 (hf (by simp [c]))⟩)
begin
  rintros ⟨u,hu⟩ ⟨v,hv⟩ ⟨a,ha⟩,
  use units.map σ.to_monoid_hom a,
  dsimp at ⊢ ha,
  erw [← f.map_smulₛₗ, ha],
end

/-- Mapping with respect to a semilinear map over an isomorphism of fields yields
an injective map on projective spaces. -/
lemma map_injective {σ : K →+* L} {τ : L →+* K} [ring_hom_inv_pair σ τ]
  (f : V →ₛₗ[σ] W) (hf : function.injective f) :
  function.injective (map f hf) :=
begin
  intros u v h,
  rw [← u.mk_rep, ← v.mk_rep] at *,
  apply quotient.sound',
  dsimp [map, mk] at h,
  simp only [quotient.eq'] at h,
  obtain ⟨a,ha⟩ := h,
  use units.map τ.to_monoid_hom a,
  dsimp at ⊢ ha,
  have : (a : L) = σ (τ a), by rw ring_hom_inv_pair.comp_apply_eq₂,
  change (a : L) • f v.rep = f u.rep at ha,
  rw [this, ← f.map_smulₛₗ] at ha,
  exact hf ha,
end

@[simp]
lemma map_id : map
  (linear_map.id : V →ₗ[K] V)
  (linear_equiv.refl K V).injective = id :=
by { ext v, induction v using projectivization.ind, refl }

@[simp]
lemma map_comp {F U : Type*} [field F] [add_comm_group U] [module F U]
  {σ : K →+* L} {τ : L →+* F} {γ : K →+* F} [ring_hom_comp_triple σ τ γ]
  (f : V →ₛₗ[σ] W) (hf : function.injective f)
  (g : W →ₛₗ[τ] U) (hg : function.injective g) :
  map (g.comp f) (hg.comp hf) = map g hg ∘ map f hf :=
by { ext v, induction v using projectivization.ind, refl }

end map

end projectivization


variables (α : Type) (p q : α → Prop)

example : (∀ x : α, p x ∧ q x) → ∀ x : α, p x :=
  assume h : ∀ x : α, p x ∧ q x,
  assume z : α,
  show p z, from (h z).left


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Keeley Hoek, Patrick Massot
-/
import tactic.monotonicity

namespace tactic

/-- Apply the function `f` given by `e : pexpr` to the local hypothesis `hyp`, which must either be
of the form `a = b` or `a ≤ b`, replacing the type of `hyp` with `f a = f b` or `f a ≤ f b`. If
`hyp` names an inequality then a new goal `monotone f` is created, unless the name of a proof of
this fact is passed as the optional argument `mono_lem`, or the `mono` tactic can prove it.
-/
meta def apply_fun_to_hyp (e : pexpr) (mono_lem : option pexpr) (hyp : expr) : tactic unit :=
do
{ t ← infer_type hyp >>= instantiate_mvars,
  prf ← match t with
  | `(%%l = %%r) := do
      ltp ← infer_type l,
      mv ← mk_mvar,
      to_expr ``(congr_arg (%%e : %%ltp → %%mv) %%hyp)
  | `(%%l ≤ %%r) := do
       Hmono ← match mono_lem with
        | some mono_lem :=
          tactic.i_to_expr mono_lem
        | none := do
          n ← get_unused_name `mono,
          to_expr ``(monotone %%e) >>= assert n,
          -- In order to resolve implicit arguments in `%%e`,
          -- we build (and discard) the expression `%%n %%hyp` before calling the `mono` tactic.
          swap,
          n ← get_local n,
          to_expr ``(%%n %%hyp),
          swap,
          do { intro_lst [`x, `y, `h], `[try { dsimp }, mono] } <|> swap,
          return n
        end,
       to_expr ``(%%Hmono %%hyp)
  | _ := fail!"failed to apply {e} at {hyp}"
  end,
  clear hyp,
  hyp ← note hyp.local_pp_name none prf,
  -- let's try to force β-reduction at `h`
  try $ tactic.dsimp_hyp hyp simp_lemmas.mk [] { eta := false, beta := true } }

/--
Attempt to "apply" a function `f` represented by the argument `e : pexpr` to the goal.

If the goal is of the form `a ≠ b`, we obtain the new goal `f a ≠ f b`.
If the goal is of the form `a = b`, we obtain a new goal `f a = f b`, and a subsidiary goal
`injective f`.
(We attempt to discharge this subsidiary goal automatically, or using the optional argument.)
If the goal is of the form `a ≤ b` (or similarly for `a < b`), and `f` is an `order_iso`,
we obtain a new goal `f a ≤ f b`.
-/
meta def apply_fun_to_goal (e : pexpr) (lem : option pexpr) : tactic unit :=
do t ← target,
  match t with
  | `(%%l ≠ %%r) := to_expr ``(ne_of_apply_ne %%e) >>= apply >> skip
  | `(¬%%l = %%r) := to_expr ``(ne_of_apply_ne %%e) >>= apply >> skip
  | `(%%l ≤ %%r) := to_expr ``((order_iso.le_iff_le %%e).mp) >>= apply >> skip
  | `(%%l < %%r) := to_expr ``((order_iso.lt_iff_lt %%e).mp) >>= apply >> skip
  | `(%%l = %%r) := focus1 (do
      to_expr ``(%%e %%l), -- build and discard an application, to fill in implicit arguments
      n ← get_unused_name `inj,
      to_expr ``(function.injective %%e) >>= assert n,
      -- Attempt to discharge the `injective f` goal
      (focus1 $
      assumption <|>
        (to_expr ``(equiv.injective) >>= apply >> done) <|>
        -- We require that applying the lemma closes the goal, not just makes progress:
        (lem.mmap (λ l, to_expr l >>= apply) >> done))
        <|> swap, -- return to the main goal if we couldn't discharge `injective f`.
      n ← get_local n,
      apply n,
      clear n)
  | _ := fail!"failed to apply {e} to the goal"
  end

namespace interactive

setup_tactic_parser

/--
Apply a function to an equality or inequality in either a local hypothesis or the goal.

* If we have `h : a = b`, then `apply_fun f at h` will replace this with `h : f a = f b`.
* If we have `h : a ≤ b`, then `apply_fun f at h` will replace this with `h : f a ≤ f b`,
  and create a subsidiary goal `monotone f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using `mono`,
  or an explicit solution can be provided with `apply_fun f at h using P`, where `P : monotone f`.
* If the goal is `a ≠ b`, `apply_fun f` will replace this with `f a ≠ f b`.
* If the goal is `a = b`, `apply_fun f` will replace this with `f a = f b`,
  and create a subsidiary goal `injective f`.
  `apply_fun` will automatically attempt to discharge this subsidiary goal using local hypotheses,
  or if `f` is actually an `equiv`,
  or an explicit solution can be provided with `apply_fun f using P`, where `P : injective f`.
* If the goal is `a ≤ b` (or similarly for `a < b`), and `f` is actually an `order_iso`,
  `apply_fun f` will replace the goal with `f a ≤ f b`.
  If `f` is anything else (e.g. just a function, or an `equiv`), `apply_fun` will fail.

Typical usage is:
```lean
open function

example (X Y Z : Type) (f : X → Y) (g : Y → Z) (H : injective $ g ∘ f) :
  injective f :=
begin
  intros x x' h,
  apply_fun g at h,
  exact H h
end
```
 -/
meta def apply_fun (q : parse texpr) (locs : parse location) (lem : parse (tk "using" *> texpr)?)
  : tactic unit :=
locs.apply (apply_fun_to_hyp q lem) (apply_fun_to_goal q lem)

add_tactic_doc
{ name       := "apply_fun",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_fun],
  tags       := ["context management"] }

end interactive

end tactic


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro
-/

import linear_algebra.tensor_product
import algebra.direct_sum.module

/-!
# Tensor products of direct sums

This file shows that taking `tensor_product`s commutes with taking `direct_sum`s in both arguments.
-/

section ring

namespace tensor_product

open_locale tensor_product
open_locale direct_sum
open linear_map
local attribute [ext] tensor_product.ext

variables (R : Type*) [comm_ring R]
variables (ι₁ : Type*) (ι₂ : Type*)
variables [decidable_eq ι₁] [decidable_eq ι₂]
variables (M₁ : ι₁ → Type*) (M₂ : ι₂ → Type*)
variables [Π i₁, add_comm_group (M₁ i₁)] [Π i₂, add_comm_group (M₂ i₂)]
variables [Π i₁, module R (M₁ i₁)] [Π i₂, module R (M₂ i₂)]

/-- The linear equivalence `(⨁ i₁, M₁ i₁) ⊗ (⨁ i₂, M₂ i₂) ≃ (⨁ i₁, ⨁ i₂, M₁ i₁ ⊗ M₂ i₂)`, i.e.
"tensor product distributes over direct sum". -/
def direct_sum :
  (⨁ i₁, M₁ i₁) ⊗[R] (⨁ i₂, M₂ i₂) ≃ₗ[R] (⨁ (i : ι₁ × ι₂), M₁ i.1 ⊗[R] M₂ i.2) :=
begin
  refine linear_equiv.of_linear
    (lift $ direct_sum.to_module R _ _ $ λ i₁, flip $ direct_sum.to_module R _ _ $ λ i₂,
      flip $ curry $ direct_sum.lof R (ι₁ × ι₂) (λ i, M₁ i.1 ⊗[R] M₂ i.2) (i₁, i₂))
    (direct_sum.to_module R _ _ $ λ i, map (direct_sum.lof R _ _ _) (direct_sum.lof R _ _ _))
    _ _; [ext ⟨i₁, i₂⟩ x₁ x₂ : 4, ext i₁ i₂ x₁ x₂ : 5],
  repeat { rw compr₂_apply <|> rw comp_apply <|> rw id_apply <|> rw mk_apply <|>
    rw direct_sum.to_module_lof <|> rw map_tmul <|> rw lift.tmul <|> rw flip_apply <|>
    rw curry_apply },
end

@[simp] theorem direct_sum_lof_tmul_lof (i₁ : ι₁) (m₁ : M₁ i₁) (i₂ : ι₂) (m₂ : M₂ i₂) :
  direct_sum R ι₁ ι₂ M₁ M₂ (direct_sum.lof R ι₁ M₁ i₁ m₁ ⊗ₜ direct_sum.lof R ι₂ M₂ i₂ m₂) =
  direct_sum.lof R (ι₁ × ι₂) (λ i, M₁ i.1 ⊗[R] M₂ i.2) (i₁, i₂) (m₁ ⊗ₜ m₂) :=
by simp [direct_sum]

end tensor_product

end ring


import Qpf
import Qpf.Examples._01_List
import Qpf.Examples._02_Tree

/-
## Projections
-/

-- every qpf whose target is just a variable, gets compiled to a projection
qpf F₁ α β γ := γ

-- The supplied name is bound to the curried function
#print F₁
-- while the internal, uncurried, function is exposed as `.typefun`
#print F₁.typefun

-- We can confirm the expected results with reduce
#reduce F₁.typefun ![Nat, Int, (List Nat)]
#reduce F₁ Nat Int (List Nat)

-- Note that we can use `_` holes for unused variables
qpf F₂ α _ _ := α

#print F₂.typefun

#reduce F₂ Nat Int (List Nat)

/-
## Constants
-/
qpf F_int α β := Int

#print F_int
#print F_int.typefun

#reduce F_int Nat Nat

qpf F_list α β := QpfList Nat

#print F_list
#print F_list.typefun

#reduce F_list Nat Nat

/-
## Composition
-/
example : MvQPF F₁.typefun := inferInstance
example : MvQPF (TypeFun.ofCurried F₁) := inferInstance

qpf F₃ α β := F₁ α β α

#print F₃.typefun
#reduce F₃ Nat Int

/-
  ## Dead variables

  So-called "dead" variables are non-functorial arguments.
  That is, if `F` takes three arguments, say `F α β γ`, of which one, `α`, is dead, then
  `F α` is a binary qpf, for all `α`, but `F` by itself is *not* a ternary qpf.

  A variable can be marked dead by using a bracketed binder, and all dead variables must come before
  live variables.
-/

qpf F_dead (α : Nat) β γ := β
qpf F_dead' (α m : Nat) {a : Type} β γ := β

/-
  The following will cause a parse error, either mark `α` dead as well, or re-order the variables
  ```
  qpf F_dead' α (γ : Nat) β := β
  ```
-/

example : MvQPF (TypeFun.ofCurried $ F_dead a) := inferInstance

/-
  The following does not even typecheck. Since `α` may live in a different universe than the live
  arguments, we cannot uncurry `F_dead`
```lean4
example : MvQPF (TypeFun.ofCurried F_dead)
  := by sorry
```
-/

/-
  A very common example of a type constructor with dead variables is that of (non-dependent)
  arrows `α → β`. It is functorial in `β`, but not in `α`
-/

-- qpf arrow {α : Type _} (a : α) β := Prod.curried a β

-- #check (Nat → Int)
-- #reduce arrow Nat Int

example (F : TypeFun 2) [q : MvQPF F] : true := by constructor

/-
  We can define functor combinators with the macro. For example, the following will flip the arguments
  to any binary qpf.
  `ToMvQPF F` is just a shorthand to say that the uncurried version of `F` implements `MvQPF`

-/
qpf flipF (F : CurriedTypeFun 2) [q : ToMvQPF F] α β := F β α

qpf Id' α := α

/-
  The following fails, as it should, because `Arrow` is *not* functorial in the first argument.
  The macro will try to synthesize an instance of `MvQPF (TypeFun.ofCurried Arrow)` and fail

  ```
  qpf withArrow α β := Id' (α → β)
  ```
-/

-- It does work when we "kill" the first argument
qpf withArrow (α : Type _) β := Id' (α → β)

/-
  Note that (non-dependent) arrow `α → β` are automatically translated to `MvQPF.Arrow`.
  This is fine; the translation preserves definitional equality
-/
example : withArrow α β = (α → β) := rfl


/-
Copyright (c) 2022 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Frédéric Dupuis, Heather Macbeth
-/
import analysis.inner_product_space.basic
import analysis.normed_space.banach
import linear_algebra.sesquilinear_form

/-!
# Symmetric linear maps in an inner product space

This file defines and proves basic theorems about symmetric **not necessarily bounded** operators
on an inner product space, i.e linear maps `T : E → E` such that `∀ x y, ⟪T x, y⟫ = ⟪x, T y⟫`.

In comparison to `is_self_adjoint`, this definition works for non-continuous linear maps, and
doesn't rely on the definition of the adjoint, which allows it to be stated in non-complete space.

## Main definitions

* `linear_map.is_symmetric`: a (not necessarily bounded) operator on an inner product space is
symmetric, if for all `x`, `y`, we have `⟪T x, y⟫ = ⟪x, T y⟫`

## Main statements

* `is_symmetric.continuous`: if a symmetric operator is defined on a complete space, then
  it is automatically continuous.

## Tags

self-adjoint, symmetric
-/

open is_R_or_C
open_locale complex_conjugate

variables {𝕜 E E' F G : Type*} [is_R_or_C 𝕜]
variables [normed_add_comm_group E] [inner_product_space 𝕜 E]
variables [normed_add_comm_group F] [inner_product_space 𝕜 F]
variables [normed_add_comm_group G] [inner_product_space 𝕜 G]
variables [normed_add_comm_group E'] [inner_product_space ℝ E']
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

namespace linear_map

/-! ### Symmetric operators -/

/-- A (not necessarily bounded) operator on an inner product space is symmetric, if for all
`x`, `y`, we have `⟪T x, y⟫ = ⟪x, T y⟫`. -/
def is_symmetric (T : E →ₗ[𝕜] E) : Prop := ∀ x y, ⟪T x, y⟫ = ⟪x, T y⟫

section real

variables

/-- An operator `T` on an inner product space is symmetric if and only if it is
`linear_map.is_self_adjoint` with respect to the sesquilinear form given by the inner product. -/
lemma is_symmetric_iff_sesq_form (T : E →ₗ[𝕜] E) :
  T.is_symmetric ↔
  @linear_map.is_self_adjoint 𝕜 E _ _ _ (star_ring_end 𝕜) sesq_form_of_inner T :=
⟨λ h x y, (h y x).symm, λ h x y, (h y x).symm⟩

end real

lemma is_symmetric.conj_inner_sym {T : E →ₗ[𝕜] E} (hT : is_symmetric T) (x y : E) :
  conj ⟪T x, y⟫ = ⟪T y, x⟫ :=
by rw [hT x y, inner_conj_symm]

@[simp] lemma is_symmetric.apply_clm {T : E →L[𝕜] E} (hT : is_symmetric (T : E →ₗ[𝕜] E))
  (x y : E) : ⟪T x, y⟫ = ⟪x, T y⟫ :=
hT x y

lemma is_symmetric_zero : (0 : E →ₗ[𝕜] E).is_symmetric :=
λ x y, (inner_zero_right x : ⟪x, 0⟫ = 0).symm ▸ (inner_zero_left y : ⟪0, y⟫ = 0)

lemma is_symmetric_id : (linear_map.id : E →ₗ[𝕜] E).is_symmetric :=
λ x y, rfl

lemma is_symmetric.add {T S : E →ₗ[𝕜] E} (hT : T.is_symmetric) (hS : S.is_symmetric) :
  (T + S).is_symmetric :=
begin
  intros x y,
  rw [linear_map.add_apply, inner_add_left, hT x y, hS x y, ← inner_add_right],
  refl
end

/-- The **Hellinger--Toeplitz theorem**: if a symmetric operator is defined on a complete space,
  then it is automatically continuous. -/
lemma is_symmetric.continuous [complete_space E] {T : E →ₗ[𝕜] E} (hT : is_symmetric T) :
  continuous T :=
begin
  -- We prove it by using the closed graph theorem
  refine T.continuous_of_seq_closed_graph (λ u x y hu hTu, _),
  rw [←sub_eq_zero, ←@inner_self_eq_zero 𝕜],
  have hlhs : ∀ k : ℕ, ⟪T (u k) - T x, y - T x⟫ = ⟪u k - x, T (y - T x)⟫ :=
  by { intro k, rw [←T.map_sub, hT] },
  refine tendsto_nhds_unique ((hTu.sub_const _).inner tendsto_const_nhds) _,
  simp_rw hlhs,
  rw ←inner_zero_left (T (y - T x)),
  refine filter.tendsto.inner _ tendsto_const_nhds,
  rw ←sub_self x,
  exact hu.sub_const _,
end

/-- For a symmetric operator `T`, the function `λ x, ⟪T x, x⟫` is real-valued. -/
@[simp] lemma is_symmetric.coe_re_apply_inner_self_apply
  {T : E →L[𝕜] E} (hT : is_symmetric (T : E →ₗ[𝕜] E)) (x : E) :
  (T.re_apply_inner_self x : 𝕜) = ⟪T x, x⟫ :=
begin
  rsuffices ⟨r, hr⟩ : ∃ r : ℝ, ⟪T x, x⟫ = r,
  { simp [hr, T.re_apply_inner_self_apply] },
  rw ← eq_conj_iff_real,
  exact hT.conj_inner_sym x x
end

/-- If a symmetric operator preserves a submodule, its restriction to that submodule is
symmetric. -/
lemma is_symmetric.restrict_invariant {T : E →ₗ[𝕜] E} (hT : is_symmetric T)
  {V : submodule 𝕜 E} (hV : ∀ v ∈ V, T v ∈ V) :
  is_symmetric (T.restrict hV) :=
λ v w, hT v w

lemma is_symmetric.restrict_scalars {T : E →ₗ[𝕜] E} (hT : T.is_symmetric) :
  @linear_map.is_symmetric ℝ E _ _ (inner_product_space.is_R_or_C_to_real 𝕜 E)
  (@linear_map.restrict_scalars ℝ 𝕜 _ _ _ _ _ _
    (inner_product_space.is_R_or_C_to_real 𝕜 E).to_module
    (inner_product_space.is_R_or_C_to_real 𝕜 E).to_module _ _ _ T) :=
λ x y, by simp [hT x y, real_inner_eq_re_inner, linear_map.coe_restrict_scalars_eq_coe]

section complex

variables {V : Type*}
  [normed_add_comm_group V] [inner_product_space ℂ V]

/-- A linear operator on a complex inner product space is symmetric precisely when
`⟪T v, v⟫_ℂ` is real for all v.-/
lemma is_symmetric_iff_inner_map_self_real (T : V →ₗ[ℂ] V):
  is_symmetric T ↔ ∀ (v : V), conj ⟪T v, v⟫_ℂ = ⟪T v, v⟫_ℂ :=
begin
  split,
  { intros hT v,
    apply is_symmetric.conj_inner_sym hT },
  { intros h x y,
    nth_rewrite 1 ← inner_conj_symm,
    nth_rewrite 1 inner_map_polarization,
    simp only [star_ring_end_apply, star_div', star_sub, star_add, star_mul],
    simp only [← star_ring_end_apply],
    rw [h (x + y), h (x - y), h (x + complex.I • y), h (x - complex.I • y)],
    simp only [complex.conj_I],
    rw inner_map_polarization',
    norm_num,
    ring },
end

end complex

end linear_map


import .formula

/-- Determines the number of logical and modal connectives in a formula. -/
def formula.size : formula → ℕ
| ⊤ := 0
| ⊥ := 0
| (formula.symbol s) := 0
| ¬a := a.size + 1
| (a ∧ b) := a.size + b.size + 1
| (a ∨ b) := a.size + b.size + 1
| (a ⟶ b) := a.size + b.size + 1
| (a ↔ b) := a.size + b.size + 1
| □a := a.size + 1
| ◇a := a.size + 1

/-- Determines the largest symbol contained in a formula. -/
def formula.max_sym : formula → ℕ
| ⊤ := 0
| ⊥ := 0
| (formula.symbol s) := s
| ¬a := a.max_sym
| (a ∧ b) := (max a.max_sym b.max_sym)
| (a ∨ b) := (max a.max_sym b.max_sym)
| (a ⟶ b) := (max a.max_sym b.max_sym)
| (a ↔ b) := (max a.max_sym b.max_sym)
| □a := a.max_sym
| ◇a := a.max_sym

/-- `build vars n` contains all of the formulas of size `n` using only the variables in `vars`. -/
def build (vars : list ℕ) : ℕ → list formula
| 0 := ⊥ :: ⊤ :: vars.map formula.symbol
| (n + 1) :=
  let xs := build n in
  list.join [
    xs,
    list.join (xs.map (λa, [¬a, □a, ◇a])),
    list.join (xs.map (λa, list.join (xs.map (λb, [a ∧ b, a ∨ b, a ⟶ b, a ↔ b]))))
  ]

lemma build.nonempty (vars : list ℕ) (n : ℕ) : (build vars n).length > 0 :=
begin
  induction n; simp [build],
  apply nat.add_pos_left,
  exact n_ih,
end

lemma build.monotonic {vars vars' : list ℕ} {m n : ℕ} {hv : vars ⊆ vars'} {hmn : m ≤ n} :
  build vars m ⊆ build vars' n :=
sorry

/-- `enumerateₙ n` enumerate all formulas of size `n` with max symbol `n`. -/
def enumerateₙ (stage : ℕ) : list formula := build (list.range (stage + 1)) stage

lemma enumerateₙ.nonempty (n : ℕ) : (enumerateₙ n).length > 0 :=
begin
  rw enumerateₙ,
  induction n; simp [build.nonempty],
end

def enumerateₙ.complete (n : ℕ) (a : formula) : a.max_sym ≤ n ∧ a.size ≤ n → a ∈ enumerateₙ n :=
begin
  intro ha,
  cases ha with hm hs,
  rw enumerateₙ,
  induction n; cases a; simp [formula.size, formula.max_sym, hm, hs, build] at *,
  assumption',
  repeat { apply build.monotonic n_ih,
    simp [list.range_subset], },
  { apply @build.monotonic (list.range (n_n + 2)) _ 0 _,
    { simp [list.range_subset], },
    { linarith, },
    { rw build,
      simp [hm, nat.lt_succ_iff], }, },
  repeat { sorry, },
end

lemma sub_pos_lt {n m : ℕ} (hm : m > 0) : n + 1 - m < n + 1 :=
begin
  have hm' : m ≥ 1 := nat.succ_le_iff.mpr hm,
  calc n + 1 = n + 1 : by refl
         ... > n + (1 - 1) : by simp [nat.add_lt_add_right]
         ... ≥ n + 1 - m : tsub_le_tsub_left hm' (n + 1)
end

/-- `enumerate' n m` is the `n`th formula from the start of the `m`th stage of the enumeration. -/
def enumerate' : ℕ → ℕ → formula
| 0 stage :=
  match enumerateₙ stage with
  | list.nil := ⊥
  | (x :: xs) := x
  end
| (n + 1) stage :=
  let xs := enumerateₙ stage in
  match xs.nth (n + 1) with
  | (some x) := x
  | none :=
    have n + 1 - (enumerateₙ stage).length < n + 1 := sub_pos_lt (enumerateₙ.nonempty stage),
    enumerate' (n + 1 - xs.length) (stage + 1)
  end

def enumerate'.complete (a : formula) : ∃n stage, enumerate' n stage = a :=
sorry

/-- Enumerates all possible formulas. -/
def enumerate (n : ℕ) : formula :=
enumerate' n 0

def enumerate.complete : ∀a, ∃n, enumerate n = a :=
begin
  intro a,
  apply exists.elim (enumerate'.complete a),
  intros n hs,
  cases hs with stage h,
  apply exists.intro ((list.map (λs, (enumerateₙ s).length) (list.range stage)).sum + n),
  rw enumerate,
  induction n with n' ih,
  { simp [enumerate', h], sorry },
  { sorry }
end


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.distribution_semantics.defs.prob_event
import probability.independence

/-!
# Independent Events for Oracle Computations

Defines to types of independence for events after an `oracle_comp`,
  corresponding to mathlibs two measure-theoretic indepence definitions.
`indep_events` says that all events in a set are independent of each other.
`indep_event` says that two particular events are independent for the computation.
-/

namespace oracle_comp

open oracle_comp
open_locale big_operators nnreal ennreal

variables {α β γ ι : Type} {spec spec' : oracle_spec}
  (oa : oracle_comp spec α) (oa' : oracle_comp spec' α)
  (ob : α → oracle_comp spec β) (ob' : α → oracle_comp spec' β)
  (a a' : α) (e e' : set α) (e'' : set β)

section indep_events

/-- Two collections of sets are independent if any two sets have intersection
  of probaility equal to the product of the individual probability.
  Independence is defined using a measure with `measurable_space` `⊤`.
  Further lemmas are written to be independent of this. -/
def indep_events (oa : oracle_comp spec α) (events events' : set (set α)) : Prop :=
@probability_theory.indep_sets α ⊤ events events' (@pmf.to_measure α ⊤ ⁅oa⁆)

variables (events events' : set (set α))

lemma indep_events_iff_indep_sets (oa : oracle_comp spec α) (es es' : set (set α)) :
  indep_events oa es es' ↔ @probability_theory.indep_sets α ⊤ es es' (@pmf.to_measure α ⊤ ⁅oa⁆) :=
iff.rfl

lemma indep_events_iff : indep_events oa events events' ↔
  ∀ e e', e ∈ events → e' ∈ events' → ⁅e ∩ e' | oa⁆ = ⁅e | oa⁆ * ⁅e' | oa⁆ :=
by simp_rw [indep_events_iff_indep_sets, probability_theory.indep_sets,
  prob_event_eq_to_measure_apply]

lemma indep_events_iff_of_eval_dist_eq (h : ⁅oa⁆ = ⁅oa'⁆) :
  oa.indep_events events events' ↔ oa'.indep_events events events' :=
by simp only [indep_events_iff, prob_event, h]

lemma prob_event_inter_eq_mul_of_indep_events (h : indep_events oa events events')
  (he : e ∈ events) (he' : e' ∈ events') : ⁅ e ∩ e' | oa ⁆ = ⁅ e | oa ⁆ * ⁅ e' | oa ⁆ :=
(indep_events_iff oa events events').1 h e e' he he'

end indep_events

section indep_event

/-- To events are independent if the prob of the intersection equals product of individual probs.
  Equivalent to `indep_events` with singleton collections of sets-/
def indep_event (oa : oracle_comp spec α) (e e' : set α) : Prop :=
indep_events oa {e} {e'}

lemma indep_event_iff_indep_events : indep_event oa e e' ↔ indep_events oa {e} {e'} :=
iff.rfl

lemma indep_event_of_indep_events (h : oa.indep_events {e} {e'}) : oa.indep_event e e' :=
(oa.indep_event_iff_indep_events e e').2 h

lemma indep_event_iff_indep_set : indep_event oa e e' ↔
  @probability_theory.indep_set α ⊤ e e' (@pmf.to_measure α ⊤ ⁅oa⁆) :=
by rw [indep_event_iff_indep_events, indep_events_iff_indep_sets,
  probability_theory.indep_set_iff_indep_sets_singleton]; apply measurable_space.measurable_set_top

lemma indep_event_iff : indep_event oa e e' ↔ ⁅e ∩ e' | oa⁆ = ⁅e | oa⁆ * ⁅e' | oa⁆ :=
begin
  simp_rw [indep_event_iff_indep_set, prob_event_eq_to_measure_apply],
  exact probability_theory.indep_set_iff_measure_inter_eq_mul trivial trivial _,
end

lemma indep_event_iff_of_eval_dist_eq (h : ⁅oa⁆ = ⁅oa'⁆) :
  oa.indep_event e e' ↔ oa'.indep_event e e' :=
by simp only [indep_event_iff, prob_event, h]

lemma prob_event_inter_eq_mul_of_indep_event (h : indep_event oa e e') :
  ⁅e ∩ e' | oa⁆ = ⁅e | oa⁆ * ⁅e' | oa⁆ :=
(indep_event_iff oa e e').1 h

end indep_event

lemma indep_events_iff_forall_indep_event (es es' : set (set α)) :
  oa.indep_events es es' ↔ ∀ e ∈ es, ∀ e' ∈ es', oa.indep_event e e' :=
begin
  simp [indep_events_iff, indep_event_iff], sorry,
end

end oracle_comp


import combinatorics.simple_graph.basic
import data.list.basic
import data.sum
import algebra.big_operators.basic
import data.list.rotate

-- Definition of multi_graph adapted from mathlib combinatorics.simple_graph

universe u

structure multi_graph (V : Type u) :=
  (adj : V → V → ℕ)
  (sym : ∀ ⦃u v : V⦄, adj u v = adj v u)

-- NOTE simple_graph is an extension with ∀ ⦃u v : V⦄, adj u v ≤ 1 and irreflexivity

namespace multi_graph
  variables {V : Type u} (G : multi_graph V)

  def adj_simple (u v : V) := G.adj u v > 0

  lemma sym_simple : symmetric G.adj_simple :=
  begin
    rw symmetric,
    intros u v,
    rw adj_simple,
    rw adj_simple,
    rw sym,
    simp,
  end

  def edge_set_simple : set (sym2 V) := sym2.from_rel G.sym_simple
  def neighbor_set_simple (v : V) := set_of (G.adj_simple v)

  lemma mem_neighbor_set (v w : V) : w ∈ G.neighbor_set_simple v ↔ G.adj_simple v w := iff.rfl

  def locally_finite := Π (v : V), fintype (G.neighbor_set_simple v)

  section decidable_eq
    variables [decidable_eq V]

    instance adj_simple_decidable_rel : decidable_rel (G.adj_simple) :=
    begin
      rw decidable_rel,
      intros u v,
      rw adj_simple,
      sorry
    end
  end decidable_eq

  section finite
    variables [fintype V] [decidable_eq V]

    instance neighbor_set_fintype (v : V) : fintype (G.neighbor_set_simple v) :=
    @subtype.fintype _ _ (by { simp_rw mem_neighbor_set, apply_instance }) _

    def neighbor_set_simple_finset (v : V) := (G.neighbor_set_simple v).to_finset
    def degree_simple (v : V) := (G.neighbor_set_simple_finset v).card
    def degree (v : V) := finset.sum (G.neighbor_set_simple_finset v) (G.adj v)
  end finite
end multi_graph

structure walk {V : Type u} (G : multi_graph V) :=
  (vertices : list V)
  (in_graph : list.chain' G.adj_simple vertices)
  -- (nonempty : vertices ≠ list.nil)

def closed_list {V : Type u} (l: list V) := l.head' = l.last'

namespace walk
  variables {V : Type u} {G : multi_graph V} [decidable_eq V] (W : walk G)

  def closed := closed_list W.vertices
  def edges : list (V × V) := list.zip W.vertices W.vertices.tail
  def edges_sym2 : list (sym2 V) := list.map (function.uncurry (λ (u v : V), ⟦(u, v)⟧)) W.edges
  def edges_count (u v : V) := W.edges_sym2.count ⟦(u,v)⟧
  def in_degree (v : V) := (W.edges.map prod.fst).count v
  def out_degree (v : V) := (W.edges.map prod.snd).count v
  def degree := W.in_degree + W.out_degree  -- Make sure we double count loops
  def edge_rel (u v: V) : Prop := ⟦(u,v)⟧ ∈ W.edges_sym2
  lemma edge_rel_sym : symmetric W.edge_rel :=
  begin
    rw symmetric,
    intros u v,
    rw edge_rel,
    rw sym2.eq_swap,
    rw ← edge_rel,
    simp,
  end
  def edge_set : set (sym2 V) := sym2.from_rel W.edge_rel_sym
  def eulerian := ∀ (u v: V), W.edges_count u v = G.adj u v
end walk

namespace multi_graph
  variables {V : Type u} (G : multi_graph V)

  def connected := ∀ ⦃u v : V⦄, ∃ (W : walk G),
    W.vertices.head' = u ∧ W.vertices.last' = v
end multi_graph

section eulerian

variables {V : Type u} (G : multi_graph V) [fintype V] [decidable_eq V] [decidable_rel G.adj_simple]

lemma count_eq_shift {v : V} {l₁ l₂: list V} (rot: l₂ = l₁.rotate 1) :
list.count v l₁ = list.count v l₂ :=
begin
  -- Base case empty list
  cases l₁,
  rw ← list.rotate_nil 1,
  rw rot,

  -- Inductive step
  rw rot,
  rw list.rotate_cons_succ,
  rw list.rotate_zero,
  rw list.count_append,
  rw add_comm,
  rw ← list.count_append,
  rw list.singleton_append,
end

lemma list_cons_unzip_sip_fst {V : Type u} (a b : V) (l : list V) :
((a :: b :: l).zip (b :: l)).unzip.fst = a :: ((b :: l).init) :=
begin
  simp,
  conv in ((b :: l).zip l){
    rw ← list.init_append_last (list.cons_ne_nil b l),
    congr,
    skip,
    rw ← list.append_nil l,
  },
  rw list.zip_append,
  rw list.zip_nil_right,
  rw list.append_nil,
  rw list.unzip_zip,
  simp,
  simp,
end

lemma circuit_indeg_eq_outdeg {W : walk G} (closed: W.closed) (v : V):
W.in_degree v = W.out_degree v :=
begin
  rw walk.in_degree,
  rw walk.out_degree,
  rw count_eq_shift,

  rw walk.edges,
  rw ← list.unzip_right,
  rw list.unzip_zip_right,
  swap,  -- Go ahead and show that tail is shorter
    rw (list.length_tail W.vertices),
    exact (nat.sub_le W.vertices.length 1),
  rw ← list.unzip_left,

  rw [walk.closed, closed_list] at closed,

  cases W.vertices,
    -- Base case empty list
    rw list.tail_nil,
    rw list.zip_nil_left,
    simp,

    cases tl,
      -- Singleton list
      simp,

      -- At least two elements
      rw list.tail_cons,
      rw list_cons_unzip_sip_fst hd tl_hd tl_tl,
      rw list.rotate_cons_succ,
      simp,
      rw list.init_append_last',
      simp,
      rw list.head' at closed,
      simp at closed,
      symmetry,
      exact closed,
end

lemma circuit_degree_even {W : walk G} (closed: W.closed) (v : V):
even (W.degree v) :=
begin
  rw walk.degree,
  simp,
  rw circuit_indeg_eq_outdeg G closed v,
  rw ← two_mul,
  rw even,
  existsi W.out_degree v,
  refl,
end

lemma eulerian_degree_eq {W : walk G} (euler: W.eulerian) (v : V):
W.degree v = G.degree v :=
begin
  -- TODO possibly use equiv.of_bijective and fintype.of_equiv_card
  -- TODO possibly prove handshake lemma for multigraphs and then make
  --      a contradiction if there exists one vertex with smaller degree
  --      in the walk than the graph (since it can't be larger)
  rw walk.degree,
  simp,
  rw [walk.in_degree,walk.out_degree],
  rw [multi_graph.degree, multi_graph.neighbor_set_simple_finset],
  rw walk.eulerian at euler,
  let edges_count_eq_adj := funext (euler v),
  simp at edges_count_eq_adj,
  rw ← edges_count_eq_adj,

  sorry
end

theorem eulerian_circuit_iff_even_degrees (conn: G.connected):
(∀ (v : V), even (G.degree v)) ↔ ∃ (W : walk G), W.eulerian ∧ W.closed :=
begin
  apply iff.intro,
  swap,
  -- Left direction
  intro exists_euler,
  cases exists_euler with W W_euler_circuit,
  cases W_euler_circuit with W_euler W_closed,

  intro v,
  rw ← eulerian_degree_eq G W_euler,
  apply circuit_degree_even G W_closed,

  -- Right direction
  -- TODO this direction will probably be a lot harder

  repeat { sorry },
end

end eulerian


import algebra.lattice.dcpo
universe u
open lattice

namespace lattice

inductive flat (α : Type u) : Type u
| bot {} : flat
| top {} : flat
| elem   : Π a : α, flat

instance {α : Type u} : has_bot (flat α) := ⟨ flat.bot ⟩
instance {α : Type u} : has_top (flat α) := ⟨ flat.top ⟩

namespace flat
variables {α : Type u}[decidable_eq α]

protected
def sup : flat α → flat α → flat α
| bot y := y
| x  bot := x
| top _ := top
| _ top := top
| (elem a) (elem b) := if a = b then elem a else top

instance : has_sup (flat α) := ⟨ flat.sup ⟩

@[simp]
lemma sup_bot_left  (x : flat α) : ⊥ ⊔ x = x := match x with
                                                | bot := rfl
                                                | top := rfl
                                                | (elem _) := rfl
                                                end

@[simp]
lemma sup_bot_right : Π (x : flat α), x ⊔ ⊥ = x
| bot := rfl
| top := rfl
| (elem _) := rfl

@[simp]
lemma sup_top_left : Π (x : flat α), ⊤ ⊔ x = ⊤
| bot := rfl
| top := rfl
| (elem _) := rfl

@[simp]
lemma sup_top_right : Π (x : flat α), x ⊔ ⊤ = ⊤
| bot := rfl
| top := rfl
| (elem _) := rfl

@[simp]
lemma sup_idem : Π (x : flat α), x ⊔ x = x
| bot := rfl
| top := rfl
| (elem _) := if_pos rfl

lemma sup_comm : Π {x y : flat α}, x ⊔ y = y ⊔ x
| bot _ := rfl
| top _ := rfl
| _   bot := rfl
| _  top := rfl
| (elem a) (elem b) := if H : a = b then
                          eq.rec_on H (eq.trans sup_idem sup_idem.symm)
                          else
                          begin
                          unfold has_sup.sup,
                          simp [flat.sup],
                          rw if_neg H,
                          rw if_neg (ne.symm H),
                          end

protected
def inf : flat α → flat α → flat α
| bot _ := bot
| _ bot := bot
| top y := y
| x top := x
| (elem a) (elem b) := if a = b then elem a else bot

instance : has_inf (flat α) := ⟨ flat.inf ⟩

protected
def le (x y : flat α) : Prop := y = x ⊔ y
instance : has_le (flat α) := ⟨flat.le⟩

protected
lemma bot_le {x : flat α} : ⊥ ≤ x := match x with
                                   | bot     := rfl
                                   | top     := rfl
                                   | elem _  := rfl
                                   end
lemma eq_of_le_bot {x : flat α} : x ≤ ⊥ → x = ⊥ :=
  begin intro h, cases x, refl, contradiction, contradiction end

protected
lemma  le_top {x : flat α} : x ≤ ⊤  := match x with
                                   | bot     := rfl
                                   | top     := rfl
                                   | elem _  := rfl
                                   end
lemma eq_of_top_le {x : flat α} : ⊤ ≤ x → x = ⊤ :=
  begin intro h, cases x, contradiction, refl, contradiction end

@[refl]
protected lemma le_refl : ∀ x : flat α, x ≤ x := take x, sup_idem.symm

@[trans]
protected lemma le_trans : ∀ x y z : flat α, x ≤ y → y ≤ z → x ≤ z
| bot _ _ := assume hxy hyz, flat.bot_le
| top _ _ := assume hxy, eq.rec_on (eq_of_top_le hxy).symm
            (assume hyz, eq.rec_on (eq_of_top_le hyz).symm (flat.le_refl _))
| _ bot _ := assume hxy hyz, eq.rec_on (eq_of_le_bot hxy).symm flat.bot_le
| _ top _ := assume hxy hyz, eq.rec_on (eq_of_top_le hyz).symm flat.le_top
| _ _   bot := begin intros hxy hyz, revert hxy, rw eq_of_le_bot hyz, intro hxy, rw eq_of_le_bot hxy, refl end
| _ _  top  := assume hxy hyz, flat.le_top
| (elem a) (elem b) (elem c) := assume hxy hyz,
                                if Hab : a = b then eq.rec_on Hab.symm hyz
                                else begin
                                        assert H : elem b = flat.sup (elem a) (elem b),
                                          assumption,
                                        assert eq : elem b = ⊤,
                                          rw H,
                                          simp [flat.sup],
                                          rw if_neg Hab, refl,
                                        contradiction
                                     end
protected lemma le_antisymm (x y : flat α) : x ≤ y → y ≤ x → x = y
:= assume hxy hyx, eq.trans hyx (eq.trans sup_comm hxy.symm)

protected lemma le_sup_left (x y : flat α) : x ≤ x ⊔ y :=
end flat
end lattice


/-
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
-/
import algebra.divisibility.basic
import algebra.group_power.lemmas
import algebra.parity

/-!
# Associated, prime, and irreducible elements.

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

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section prime
variables [comm_monoid_with_zero α]

/-- prime element of a `comm_monoid_with_zero` -/
def prime (p : α) : Prop :=
p ≠ 0 ∧ ¬ is_unit p ∧ (∀a b, p ∣ a * b → p ∣ a ∨ p ∣ b)

namespace prime
variables {p : α} (hp : prime p)
include hp

lemma ne_zero : p ≠ 0 :=
hp.1

lemma not_unit : ¬ is_unit p :=
hp.2.1

lemma not_dvd_one : ¬ p ∣ 1 :=
mt (is_unit_of_dvd_one _) hp.not_unit

lemma ne_one : p ≠ 1 :=
λ h, hp.2.1 (h.symm ▸ is_unit_one)

lemma dvd_or_dvd (hp : prime p) {a b : α} (h : p ∣ a * b) :
  p ∣ a ∨ p ∣ b :=
hp.2.2 a b h

lemma dvd_of_dvd_pow (hp : prime p) {a : α} {n : ℕ} (h : p ∣ a^n) :
  p ∣ a :=
begin
  induction n with n ih,
  { rw pow_zero at h,
    have := is_unit_of_dvd_one _ h,
    have := not_unit hp,
    contradiction },
  rw pow_succ at h,
  cases dvd_or_dvd hp h with dvd_a dvd_pow,
  { assumption },
  exact ih dvd_pow
end

end prime

@[simp] lemma not_prime_zero : ¬ prime (0 : α) :=
λ h, h.ne_zero rfl

@[simp] lemma not_prime_one : ¬ prime (1 : α) :=
λ h, h.not_unit is_unit_one

section map
variables [comm_monoid_with_zero β] {F : Type*} {G : Type*}
  [monoid_with_zero_hom_class F α β] [mul_hom_class G β α] (f : F) (g : G) {p : α}

lemma comap_prime (hinv : ∀ a, g (f a : β) = a) (hp : prime (f p)) : prime p :=
⟨ λ h, hp.1 $ by simp [h],  λ h, hp.2.1 $ h.map f,  λ a b h, by
  { refine (hp.2.2 (f a) (f b) $ by { convert map_dvd f h, simp }).imp _ _;
    { intro h, convert ← map_dvd g h; apply hinv } } ⟩

lemma mul_equiv.prime_iff (e : α ≃* β) : prime p ↔ prime (e p) :=
⟨ λ h, comap_prime e.symm e (λ a, by simp) $ (e.symm_apply_apply p).substr h,
  comap_prime e e.symm (λ a, by simp) ⟩

end map

end prime

lemma prime.left_dvd_or_dvd_right_of_dvd_mul [cancel_comm_monoid_with_zero α] {p : α}
  (hp : prime p) {a b : α} : a ∣ p * b → p ∣ a ∨ a ∣ b :=
begin
  rintro ⟨c, hc⟩,
  rcases hp.2.2 a c (hc ▸ dvd_mul_right _ _) with h | ⟨x, rfl⟩,
  { exact or.inl h },
  { rw [mul_left_comm, mul_right_inj' hp.ne_zero] at hc,
    exact or.inr (hc.symm ▸ dvd_mul_right _ _) }
end

lemma prime.pow_dvd_of_dvd_mul_left
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ a) (h' : p ^ n ∣ a * b) : p ^ n ∣ b :=
begin
  induction n with n ih,
  { rw pow_zero, exact one_dvd b },
  { obtain ⟨c, rfl⟩ := ih (dvd_trans (pow_dvd_pow p n.le_succ) h'),
    rw pow_succ',
    apply mul_dvd_mul_left _ ((hp.dvd_or_dvd _).resolve_left h),
    rwa [←mul_dvd_mul_iff_left (pow_ne_zero n hp.ne_zero), ←pow_succ', mul_left_comm] }
end

lemma prime.pow_dvd_of_dvd_mul_right
  [cancel_comm_monoid_with_zero α]
  {p a b : α} (hp : prime p) (n : ℕ) (h : ¬p ∣ b) (h' : p ^ n ∣ a * b) : p ^ n ∣ a :=
by { rw [mul_comm] at h', exact hp.pow_dvd_of_dvd_mul_left n h h' }

lemma prime.dvd_of_pow_dvd_pow_mul_pow_of_square_not_dvd [cancel_comm_monoid_with_zero α]
  {p a b : α} {n : ℕ} (hp : prime p) (hpow : p ^ n.succ ∣ a ^ n.succ * b ^ n)
  (hb : ¬ p ^ 2 ∣ b) : p ∣ a :=
begin
  -- Suppose `p ∣ b`, write `b = p * x` and `hy : a ^ n.succ * b ^ n = p ^ n.succ * y`.
  cases (hp.dvd_or_dvd ((dvd_pow_self p (nat.succ_ne_zero n)).trans hpow)) with H hbdiv,
  { exact hp.dvd_of_dvd_pow H },
  obtain ⟨x, rfl⟩ := hp.dvd_of_dvd_pow hbdiv,
  obtain ⟨y, hy⟩ := hpow,
  -- Then we can divide out a common factor of `p ^ n` from the equation `hy`.
  have : a ^ n.succ * x ^ n = p * y,
  { refine mul_left_cancel₀ (pow_ne_zero n hp.ne_zero) _,
    rw [← mul_assoc _ p, ← pow_succ', ← hy, mul_pow, ← mul_assoc (a ^ n.succ),
      mul_comm _ (p ^ n), mul_assoc] },
  -- So `p ∣ a` (and we're done) or `p ∣ x`, which can't be the case since it implies `p^2 ∣ b`.
  refine hp.dvd_of_dvd_pow ((hp.dvd_or_dvd ⟨_, this⟩).resolve_right (λ hdvdx, hb _)),
  obtain ⟨z, rfl⟩ := hp.dvd_of_dvd_pow hdvdx,
  rw [pow_two, ← mul_assoc],
  exact dvd_mul_right _ _,
end

lemma prime_pow_succ_dvd_mul {α : Type*} [cancel_comm_monoid_with_zero α]
  {p x y : α} (h : prime p) {i : ℕ} (hxy : p ^ (i + 1) ∣ x * y) :
  p ^ (i + 1) ∣ x ∨ p ∣ y :=
begin
  rw or_iff_not_imp_right,
  intro hy,
  induction i with i ih generalizing x,
  { simp only [zero_add, pow_one] at *,
    exact (h.dvd_or_dvd hxy).resolve_right hy },
  rw pow_succ at hxy ⊢,
  obtain ⟨x', rfl⟩ := (h.dvd_or_dvd (dvd_of_mul_right_dvd hxy)).resolve_right hy,
  rw mul_assoc at hxy,
  exact mul_dvd_mul_left p (ih ((mul_dvd_mul_iff_left h.ne_zero).mp hxy)),
end

/-- `irreducible p` states that `p` is non-unit and only factors into units.

We explicitly avoid stating that `p` is non-zero, this would require a semiring. Assuming only a
monoid allows us to reuse irreducible for associated elements.
-/
structure irreducible [monoid α] (p : α) : Prop :=
(not_unit : ¬ is_unit p)
(is_unit_or_is_unit' : ∀a b, p = a * b → is_unit a ∨ is_unit b)

namespace irreducible

lemma not_dvd_one [comm_monoid α] {p : α} (hp : irreducible p) : ¬ p ∣ 1 :=
mt (is_unit_of_dvd_one _) hp.not_unit

lemma is_unit_or_is_unit [monoid α] {p : α} (hp : irreducible p) {a b : α} (h : p = a * b) :
  is_unit a ∨ is_unit b :=
hp.is_unit_or_is_unit' a b h

end irreducible

lemma irreducible_iff [monoid α] {p : α} :
  irreducible p ↔ ¬ is_unit p ∧ ∀a b, p = a * b → is_unit a ∨ is_unit b :=
⟨λ h, ⟨h.1, h.2⟩, λ h, ⟨h.1, h.2⟩⟩

@[simp] theorem not_irreducible_one [monoid α] : ¬ irreducible (1 : α) :=
by simp [irreducible_iff]

theorem irreducible.ne_one [monoid α] : ∀ {p:α}, irreducible p → p ≠ 1
| _ hp rfl := not_irreducible_one hp

@[simp] theorem not_irreducible_zero [monoid_with_zero α] : ¬ irreducible (0 : α)
| ⟨hn0, h⟩ := have is_unit (0:α) ∨ is_unit (0:α), from h 0 0 ((mul_zero 0).symm),
  this.elim hn0 hn0

theorem irreducible.ne_zero [monoid_with_zero α] : ∀ {p:α}, irreducible p → p ≠ 0
| _ hp rfl := not_irreducible_zero hp

theorem of_irreducible_mul {α} [monoid α] {x y : α} :
  irreducible (x * y) → is_unit x ∨ is_unit y
| ⟨_, h⟩ := h _ _ rfl

theorem of_irreducible_pow {α} [monoid α] {x : α} {n : ℕ} (hn : n ≠ 1) :
  irreducible (x ^ n) → is_unit x :=
begin
  obtain hn|hn := hn.lt_or_lt,
  { simp only [nat.lt_one_iff.mp hn, is_empty.forall_iff, not_irreducible_one, pow_zero] },
  intro h,
  obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_lt hn,
  rw [pow_succ, add_comm] at h,
  exact (or_iff_left_of_imp is_unit_pow_succ_iff.mp).mp (of_irreducible_mul h)
end

theorem irreducible_or_factor {α} [monoid α] (x : α) (h : ¬ is_unit x) :
  irreducible x ∨ ∃ a b, ¬ is_unit a ∧ ¬ is_unit b ∧ a * b = x :=
begin
  haveI := classical.dec,
  refine or_iff_not_imp_right.2 (λ H, _),
  simp [h, irreducible_iff] at H ⊢,
  refine λ a b h, classical.by_contradiction $ λ o, _,
  simp [not_or_distrib] at o,
  exact H _ o.1 _ o.2 h.symm
end

/-- If `p` and `q` are irreducible, then `p ∣ q` implies `q ∣ p`. -/
lemma irreducible.dvd_symm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q → q ∣ p :=
begin
  unfreezingI { rintros ⟨q', rfl⟩ },
  rw is_unit.mul_right_dvd (or.resolve_left (of_irreducible_mul hq) hp.not_unit),
end

lemma irreducible.dvd_comm [monoid α] {p q : α}
  (hp : irreducible p) (hq : irreducible q) : p ∣ q ↔ q ∣ p :=
⟨hp.dvd_symm hq, hq.dvd_symm hp⟩

section
variables [monoid α]

lemma irreducible_units_mul (a : αˣ) (b : α) : irreducible (↑a * b) ↔ irreducible b :=
begin
  simp only [irreducible_iff, units.is_unit_units_mul, and.congr_right_iff],
  refine λ hu, ⟨λ h A B HAB, _, λ h A B HAB, _⟩,
  { rw [←a.is_unit_units_mul],
    apply h,
    rw [mul_assoc, ←HAB] },
  { rw [←(a⁻¹).is_unit_units_mul],
    apply h,
    rw [mul_assoc, ←HAB, units.inv_mul_cancel_left] },
end

lemma irreducible_is_unit_mul {a b : α} (h : is_unit a) : irreducible (a * b) ↔ irreducible b :=
let ⟨a, ha⟩ := h in ha ▸ irreducible_units_mul a b

lemma irreducible_mul_units (a : αˣ) (b : α) : irreducible (b * ↑a) ↔ irreducible b :=
begin
  simp only [irreducible_iff, units.is_unit_mul_units, and.congr_right_iff],
  refine λ hu, ⟨λ h A B HAB, _, λ h A B HAB, _⟩,
  { rw [←units.is_unit_mul_units B a],
    apply h,
    rw [←mul_assoc, ←HAB] },
  { rw [←units.is_unit_mul_units B a⁻¹],
    apply h,
    rw [←mul_assoc, ←HAB, units.mul_inv_cancel_right] },
end

lemma irreducible_mul_is_unit {a b : α} (h : is_unit a) : irreducible (b * a) ↔ irreducible b :=
let ⟨a, ha⟩ := h in ha ▸ irreducible_mul_units a b

lemma irreducible_mul_iff {a b : α} :
  irreducible (a * b) ↔ (irreducible a ∧ is_unit b) ∨ (irreducible b ∧ is_unit a) :=
begin
  split,
  { refine λ h, or.imp (λ h', ⟨_, h'⟩) (λ h', ⟨_, h'⟩) (h.is_unit_or_is_unit rfl).symm,
    { rwa [irreducible_mul_is_unit h'] at h },
    { rwa [irreducible_is_unit_mul h'] at h } },
  { rintros (⟨ha, hb⟩|⟨hb, ha⟩),
    { rwa [irreducible_mul_is_unit hb] },
    { rwa [irreducible_is_unit_mul ha] } },
end

end

section comm_monoid
variables [comm_monoid α] {a : α}

lemma irreducible.not_square (ha : irreducible a) : ¬ is_square a :=
by { rintro ⟨b, rfl⟩, simp only [irreducible_mul_iff, or_self] at ha, exact ha.1.not_unit ha.2 }

lemma is_square.not_irreducible (ha : is_square a) : ¬ irreducible a := λ h, h.not_square ha

end comm_monoid

section cancel_comm_monoid_with_zero
variables [cancel_comm_monoid_with_zero α] {a p : α}

protected lemma prime.irreducible (hp : prime p) : irreducible p :=
⟨hp.not_unit, λ a b hab,
  (show a * b ∣ a ∨ a * b ∣ b, from hab ▸ hp.dvd_or_dvd (hab ▸ dvd_rfl)).elim
    (λ ⟨x, hx⟩, or.inr (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show a ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))
    (λ ⟨x, hx⟩, or.inl (is_unit_iff_dvd_one.2
      ⟨x, mul_right_cancel₀ (show b ≠ 0, from λ h, by simp [*, prime] at *)
        $ by conv {to_lhs, rw hx}; simp [mul_comm, mul_assoc, mul_left_comm]⟩))⟩

lemma succ_dvd_or_succ_dvd_of_succ_sum_dvd_mul (hp : prime p) {a b : α} {k l : ℕ} :
  p ^ k ∣ a → p ^ l ∣ b → p ^ ((k + l) + 1) ∣ a * b → p ^ (k + 1) ∣ a ∨ p ^ (l + 1) ∣ b :=
λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩,
have h : p ^ (k + l) * (x * y) = p ^ (k + l) * (p * z),
  by simpa [mul_comm, pow_add, hx, hy, mul_assoc, mul_left_comm] using hz,
have hp0: p ^ (k + l) ≠ 0, from pow_ne_zero _ hp.ne_zero,
have hpd : p ∣ x * y, from ⟨z, by rwa [mul_right_inj' hp0] at h⟩,
(hp.dvd_or_dvd hpd).elim
  (λ ⟨d, hd⟩, or.inl ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)
  (λ ⟨d, hd⟩, or.inr ⟨d, by simp [*, pow_succ, mul_comm, mul_left_comm, mul_assoc]⟩)

lemma prime.not_square (hp : prime p) : ¬ is_square p := hp.irreducible.not_square
lemma is_square.not_prime (ha : is_square a) : ¬ prime a := λ h, h.not_square ha

lemma pow_not_prime {n : ℕ} (hn : n ≠ 1) : ¬ prime (a ^ n) :=
λ hp, hp.not_unit $ is_unit.pow _ $ of_irreducible_pow hn $ hp.irreducible

end cancel_comm_monoid_with_zero

/-- Two elements of a `monoid` are `associated` if one of them is another one
multiplied by a unit on the right. -/
def associated [monoid α] (x y : α) : Prop := ∃u:αˣ, x * u = y

local infix ` ~ᵤ ` : 50 := associated

namespace associated

@[refl] protected theorem refl [monoid α] (x : α) : x ~ᵤ x := ⟨1, by simp⟩
instance [monoid α] : is_refl α associated := ⟨associated.refl⟩

@[symm] protected theorem symm [monoid α] : ∀{x y : α}, x ~ᵤ y → y ~ᵤ x
| x _ ⟨u, rfl⟩ := ⟨u⁻¹, by rw [mul_assoc, units.mul_inv, mul_one]⟩
instance [monoid α] : is_symm α associated := ⟨λ a b, associated.symm⟩

protected theorem comm [monoid α] {x y : α} : x ~ᵤ y ↔ y ~ᵤ x :=
⟨associated.symm, associated.symm⟩

@[trans] protected theorem trans [monoid α] : ∀{x y z : α}, x ~ᵤ y → y ~ᵤ z → x ~ᵤ z
| x _ _ ⟨u, rfl⟩ ⟨v, rfl⟩ := ⟨u * v, by rw [units.coe_mul, mul_assoc]⟩
instance [monoid α] : is_trans α associated := ⟨λ a b c, associated.trans⟩

/-- The setoid of the relation `x ~ᵤ y` iff there is a unit `u` such that `x * u = y` -/
protected def setoid (α : Type*) [monoid α] : setoid α :=
{ r := associated, iseqv := ⟨associated.refl, λa b, associated.symm, λa b c, associated.trans⟩ }

end associated

local attribute [instance] associated.setoid

theorem unit_associated_one [monoid α] {u : αˣ} : (u : α) ~ᵤ 1 := ⟨u⁻¹, units.mul_inv u⟩

theorem associated_one_iff_is_unit [monoid α] {a : α} : (a : α) ~ᵤ 1 ↔ is_unit a :=
iff.intro
  (assume h, let ⟨c, h⟩ := h.symm in h ▸ ⟨c, (one_mul _).symm⟩)
  (assume ⟨c, h⟩, associated.symm ⟨c, by simp [h]⟩)

theorem associated_zero_iff_eq_zero [monoid_with_zero α] (a : α) : a ~ᵤ 0 ↔ a = 0 :=
iff.intro
  (assume h, let ⟨u, h⟩ := h.symm in by simpa using h.symm)
  (assume h, h ▸ associated.refl a)

theorem associated_one_of_mul_eq_one [comm_monoid α] {a : α} (b : α) (hab : a * b = 1) : a ~ᵤ 1 :=
show (units.mk_of_mul_eq_one a b hab : α) ~ᵤ 1, from unit_associated_one

theorem associated_one_of_associated_mul_one [comm_monoid α] {a b : α} :
  a * b ~ᵤ 1 → a ~ᵤ 1
| ⟨u, h⟩ := associated_one_of_mul_eq_one (b * u) $ by simpa [mul_assoc] using h

lemma associated_mul_unit_left {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated (a * u) a :=
let ⟨u', hu⟩ := hu in ⟨u'⁻¹, hu ▸ units.mul_inv_cancel_right _ _⟩

lemma associated_unit_mul_left {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated (u * a) a :=
begin
  rw mul_comm,
  exact associated_mul_unit_left _ _ hu
end

lemma associated_mul_unit_right {β : Type*} [monoid β] (a u : β) (hu : is_unit u) :
  associated a (a * u) :=
(associated_mul_unit_left a u hu).symm

lemma associated_unit_mul_right {β : Type*} [comm_monoid β] (a u : β) (hu : is_unit u) :
  associated a (u * a) :=
(associated_unit_mul_left a u hu).symm

lemma associated_mul_is_unit_left_iff {β : Type*} [monoid β] {a u b : β} (hu : is_unit u) :
  associated (a * u) b ↔ associated a b :=
⟨trans (associated_mul_unit_right _ _ hu), trans (associated_mul_unit_left _ _ hu)⟩

lemma associated_is_unit_mul_left_iff {β : Type*} [comm_monoid β] {u a b : β} (hu : is_unit u) :
  associated (u * a) b ↔ associated a b :=
begin
  rw mul_comm,
  exact associated_mul_is_unit_left_iff hu
end

lemma associated_mul_is_unit_right_iff {β : Type*} [monoid β] {a b u : β} (hu : is_unit u) :
  associated a (b * u) ↔ associated a b :=
associated.comm.trans $ (associated_mul_is_unit_left_iff hu).trans associated.comm

lemma associated_is_unit_mul_right_iff {β : Type*} [comm_monoid β] {a u b : β} (hu : is_unit u) :
  associated a (u * b) ↔ associated a b :=
associated.comm.trans $ (associated_is_unit_mul_left_iff hu).trans associated.comm

@[simp]
lemma associated_mul_unit_left_iff {β : Type*} [monoid β] {a b : β} {u : units β} :
  associated (a * u) b ↔ associated a b :=
associated_mul_is_unit_left_iff u.is_unit

@[simp]
lemma associated_unit_mul_left_iff {β : Type*} [comm_monoid β] {a b : β} {u : units β} :
  associated (↑u * a) b ↔ associated a b :=
associated_is_unit_mul_left_iff u.is_unit

@[simp]
lemma associated_mul_unit_right_iff {β : Type*} [monoid β] {a b : β} {u : units β} :
  associated a (b * u) ↔ associated a b :=
associated_mul_is_unit_right_iff u.is_unit

@[simp]
lemma associated_unit_mul_right_iff {β : Type*} [comm_monoid β] {a b : β} {u : units β} :
  associated a (↑u * b) ↔ associated a b :=
associated_is_unit_mul_right_iff u.is_unit

lemma associated.mul_mul [comm_monoid α] {a₁ a₂ b₁ b₂ : α} :
  a₁ ~ᵤ b₁ → a₂ ~ᵤ b₂ → (a₁ * a₂) ~ᵤ (b₁ * b₂)
| ⟨c₁, h₁⟩ ⟨c₂, h₂⟩ := ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩

lemma associated.mul_left [comm_monoid α] (a : α) {b c : α} (h : b ~ᵤ c) :
  (a * b) ~ᵤ (a * c) :=
(associated.refl a).mul_mul h

lemma associated.mul_right [comm_monoid α] {a b : α} (h : a ~ᵤ b) (c : α) :
  (a * c) ~ᵤ (b * c) :=
h.mul_mul (associated.refl c)

lemma associated.pow_pow [comm_monoid α] {a b : α} {n : ℕ} (h : a ~ᵤ b) :
  a ^ n ~ᵤ b ^ n :=
begin
  induction n with n ih, { simp [h] },
  convert h.mul_mul ih;
    rw pow_succ
end

protected lemma associated.dvd [monoid α] {a b : α} : a ~ᵤ b → a ∣ b := λ ⟨u, hu⟩, ⟨u, hu.symm⟩

protected lemma associated.dvd_dvd [monoid α] {a b : α} (h : a ~ᵤ b) : a ∣ b ∧ b ∣ a :=
⟨h.dvd, h.symm.dvd⟩

theorem associated_of_dvd_dvd [cancel_monoid_with_zero α]
  {a b : α} (hab : a ∣ b) (hba : b ∣ a) : a ~ᵤ b :=
begin
  rcases hab with ⟨c, rfl⟩,
  rcases hba with ⟨d, a_eq⟩,
  by_cases ha0 : a = 0,
  { simp [*] at * },
  have hac0 : a * c ≠ 0,
  { intro con, rw [con, zero_mul] at a_eq, apply ha0 a_eq, },
  have : a * (c * d) =  a * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hcd : (c * d) = 1, from mul_left_cancel₀ ha0 this,
  have : a * c * (d * c) = a * c * 1 := by rw [← mul_assoc, ← a_eq, mul_one],
  have hdc : d * c = 1, from mul_left_cancel₀ hac0 this,
  exact ⟨⟨c, d, hcd, hdc⟩, rfl⟩
end

theorem dvd_dvd_iff_associated [cancel_monoid_with_zero α] {a b : α} : a ∣ b ∧ b ∣ a ↔ a ~ᵤ b :=
⟨λ ⟨h1, h2⟩, associated_of_dvd_dvd h1 h2, associated.dvd_dvd⟩

instance [cancel_monoid_with_zero α] [decidable_rel ((∣) : α → α → Prop)] :
  decidable_rel ((~ᵤ) : α → α → Prop) :=
λ a b, decidable_of_iff _ dvd_dvd_iff_associated

lemma associated.dvd_iff_dvd_left [monoid α] {a b c : α} (h : a ~ᵤ b) : a ∣ c ↔ b ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.mul_right_dvd.symm

lemma associated.dvd_iff_dvd_right [monoid α] {a b c : α} (h : b ~ᵤ c) : a ∣ b ↔ a ∣ c :=
let ⟨u, hu⟩ := h in hu ▸ units.dvd_mul_right.symm

lemma associated.eq_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a = 0 ↔ b = 0 :=
⟨λ ha, let ⟨u, hu⟩ := h in by simp [hu.symm, ha],
  λ hb, let ⟨u, hu⟩ := h.symm in by simp [hu.symm, hb]⟩

lemma associated.ne_zero_iff [monoid_with_zero α] {a b : α} (h : a ~ᵤ b) : a ≠ 0 ↔ b ≠ 0 :=
not_congr h.eq_zero_iff

protected lemma associated.prime [comm_monoid_with_zero α] {p q : α} (h : p ~ᵤ q) (hp : prime p) :
  prime q :=
⟨h.ne_zero_iff.1 hp.ne_zero,
  let ⟨u, hu⟩ := h in
    ⟨λ ⟨v, hv⟩, hp.not_unit ⟨v * u⁻¹, by simp [hv, hu.symm]⟩,
      hu ▸ by { simp [units.mul_right_dvd], intros a b, exact hp.dvd_or_dvd }⟩⟩

lemma irreducible.associated_of_dvd [cancel_monoid_with_zero α] {p q : α}
  (p_irr : irreducible p) (q_irr : irreducible q) (dvd : p ∣ q) : associated p q :=
associated_of_dvd_dvd dvd (p_irr.dvd_symm q_irr dvd)

lemma irreducible.dvd_irreducible_iff_associated [cancel_monoid_with_zero α]
  {p q : α} (pp : irreducible p) (qp : irreducible q) :
  p ∣ q ↔ associated p q :=
⟨irreducible.associated_of_dvd pp qp, associated.dvd⟩

lemma prime.associated_of_dvd [cancel_comm_monoid_with_zero α] {p q : α}
  (p_prime : prime p) (q_prime : prime q) (dvd : p ∣ q) : associated p q :=
p_prime.irreducible.associated_of_dvd q_prime.irreducible dvd

theorem prime.dvd_prime_iff_associated [cancel_comm_monoid_with_zero α]
  {p q : α} (pp : prime p) (qp : prime q) :
  p ∣ q ↔ associated p q :=
pp.irreducible.dvd_irreducible_iff_associated qp.irreducible
lemma associated.prime_iff [comm_monoid_with_zero α] {p q : α}
  (h : p ~ᵤ q) : prime p ↔ prime q :=
⟨h.prime, h.symm.prime⟩

protected lemma associated.is_unit [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a → is_unit b :=
let ⟨u, hu⟩ := h in λ ⟨v, hv⟩, ⟨v * u, by simp [hv, hu.symm]⟩

lemma associated.is_unit_iff [monoid α] {a b : α} (h :  a ~ᵤ b) : is_unit a ↔ is_unit b :=
⟨h.is_unit, h.symm.is_unit⟩

protected lemma associated.irreducible [monoid α] {p q : α} (h : p ~ᵤ q)
  (hp : irreducible p) : irreducible q :=
⟨mt h.symm.is_unit hp.1,
  let ⟨u, hu⟩ := h in λ a b hab,
  have hpab : p = a * (b * (u⁻¹ : αˣ)),
    from calc p = (p * u) * (u ⁻¹ : αˣ) : by simp
      ... = _ : by rw hu; simp [hab, mul_assoc],
  (hp.is_unit_or_is_unit hpab).elim or.inl (λ ⟨v, hv⟩, or.inr ⟨v * u, by simp [hv]⟩)⟩

protected lemma associated.irreducible_iff [monoid α] {p q : α} (h : p ~ᵤ q) :
  irreducible p ↔ irreducible q :=
⟨h.irreducible, h.symm.irreducible⟩

lemma associated.of_mul_left [cancel_comm_monoid_with_zero α] {a b c d : α}
  (h : a * b ~ᵤ c * d) (h₁ : a ~ᵤ c) (ha : a ≠ 0) : b ~ᵤ d :=
let ⟨u, hu⟩ := h in let ⟨v, hv⟩ := associated.symm h₁ in
⟨u * (v : αˣ), mul_left_cancel₀ ha
  begin
    rw [← hv, mul_assoc c (v : α) d, mul_left_comm c, ← hu],
    simp [hv.symm, mul_assoc, mul_comm, mul_left_comm]
  end⟩

lemma associated.of_mul_right [cancel_comm_monoid_with_zero α] {a b c d : α} :
  a * b ~ᵤ c * d → b ~ᵤ d → b ≠ 0 → a ~ᵤ c :=
by rw [mul_comm a, mul_comm c]; exact associated.of_mul_left

lemma associated.of_pow_associated_of_prime [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₁) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
begin
  have : p₁ ∣ p₂ ^ k₂,
  { rw ←h.dvd_iff_dvd_right,
    apply dvd_pow_self _ hk₁.ne' },
  rw ←hp₁.dvd_prime_iff_associated hp₂,
  exact hp₁.dvd_of_dvd_pow this,
end

lemma associated.of_pow_associated_of_prime' [cancel_comm_monoid_with_zero α] {p₁ p₂ : α}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₂ : 0 < k₂) (h : p₁ ^ k₁ ~ᵤ p₂ ^ k₂) :
  p₁ ~ᵤ p₂ :=
(h.symm.of_pow_associated_of_prime hp₂ hp₁ hk₂).symm

section unique_units
variables [monoid α] [unique αˣ]

lemma units_eq_one (u : αˣ) : u = 1 := subsingleton.elim u 1

theorem associated_iff_eq {x y : α} : x ~ᵤ y ↔ x = y :=
begin
  split,
  { rintro ⟨c, rfl⟩, rw [units_eq_one c, units.coe_one, mul_one] },
  { rintro rfl, refl },
end

theorem associated_eq_eq : (associated : α → α → Prop) = eq :=
by { ext, rw associated_iff_eq }

lemma prime_dvd_prime_iff_eq
  {M : Type*} [cancel_comm_monoid_with_zero M] [unique Mˣ] {p q : M} (pp : prime p) (qp : prime q) :
  p ∣ q ↔ p = q :=
by rw [pp.dvd_prime_iff_associated qp, ←associated_eq_eq]

end unique_units

section unique_units₀

variables {R : Type*} [cancel_comm_monoid_with_zero R] [unique Rˣ] {p₁ p₂ : R} {k₁ k₂ : ℕ}

lemma eq_of_prime_pow_eq (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₁) (h : p₁ ^ k₁ = p₂ ^ k₂) :
  p₁ = p₂ :=
by { rw [←associated_iff_eq] at h ⊢, apply h.of_pow_associated_of_prime hp₁ hp₂ hk₁ }

lemma eq_of_prime_pow_eq' (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₂) (h : p₁ ^ k₁ = p₂ ^ k₂) :
  p₁ = p₂ :=
by { rw [←associated_iff_eq] at h ⊢, apply h.of_pow_associated_of_prime' hp₁ hp₂ hk₁ }

end unique_units₀

/-- The quotient of a monoid by the `associated` relation. Two elements `x` and `y`
  are associated iff there is a unit `u` such that `x * u = y`. There is a natural
  monoid structure on `associates α`. -/
def associates (α : Type*) [monoid α] : Type* :=
quotient (associated.setoid α)

namespace associates
open associated

/-- The canonical quotient map from a monoid `α` into the `associates` of `α` -/
protected def mk {α : Type*} [monoid α] (a : α) : associates α :=
⟦ a ⟧

instance [monoid α] : inhabited (associates α) := ⟨⟦1⟧⟩

theorem mk_eq_mk_iff_associated [monoid α] {a b : α} :
  associates.mk a = associates.mk b ↔ a ~ᵤ b :=
iff.intro quotient.exact quot.sound

theorem quotient_mk_eq_mk [monoid α] (a : α) : ⟦ a ⟧ = associates.mk a := rfl

theorem quot_mk_eq_mk [monoid α] (a : α) : quot.mk setoid.r a = associates.mk a := rfl

theorem forall_associated [monoid α] {p : associates α → Prop} :
  (∀a, p a) ↔ (∀a, p (associates.mk a)) :=
iff.intro
  (assume h a, h _)
  (assume h a, quotient.induction_on a h)

theorem mk_surjective [monoid α] : function.surjective (@associates.mk α _) :=
forall_associated.2 (λ a, ⟨a, rfl⟩)

instance [monoid α] : has_one (associates α) := ⟨⟦ 1 ⟧⟩

@[simp] lemma mk_one [monoid α] : associates.mk (1 : α) = 1 := rfl

theorem one_eq_mk_one [monoid α] : (1 : associates α) = associates.mk 1 := rfl

instance [monoid α] : has_bot (associates α) := ⟨1⟩

lemma bot_eq_one [monoid α] : (⊥ : associates α) = 1 := rfl

lemma exists_rep [monoid α] (a : associates α) : ∃ a0 : α, associates.mk a0 = a :=
quot.exists_rep a

instance [monoid α] [subsingleton α] : unique (associates α) :=
{ default := 1,
  uniq := λ a, by { apply quotient.rec_on_subsingleton₂, intros a b, congr } }

lemma mk_injective [monoid α] [unique (units α)] : function.injective (@associates.mk α _) :=
λ a b h, associated_iff_eq.mp (associates.mk_eq_mk_iff_associated.mp h)

section comm_monoid
variable [comm_monoid α]

instance : has_mul (associates α) :=
⟨λa' b', quotient.lift_on₂ a' b' (λa b, ⟦ a * b ⟧) $
  assume a₁ a₂ b₁ b₂ ⟨c₁, h₁⟩ ⟨c₂, h₂⟩,
  quotient.sound $ ⟨c₁ * c₂, by simp [h₁.symm, h₂.symm, mul_assoc, mul_comm, mul_left_comm]⟩⟩

theorem mk_mul_mk {x y : α} : associates.mk x * associates.mk y = associates.mk (x * y) :=
rfl

instance : comm_monoid (associates α) :=
{ one       := 1,
  mul       := (*),
  mul_one   := assume a', quotient.induction_on a' $
    assume a, show ⟦a * 1⟧ = ⟦ a ⟧, by simp,
  one_mul   := assume a', quotient.induction_on a' $
    assume a, show ⟦1 * a⟧ = ⟦ a ⟧, by simp,
  mul_assoc := assume a' b' c', quotient.induction_on₃ a' b' c' $
    assume a b c, show ⟦a * b * c⟧ = ⟦a * (b * c)⟧, by rw [mul_assoc],
  mul_comm  := assume a' b', quotient.induction_on₂ a' b' $
    assume a b, show ⟦a * b⟧ = ⟦b * a⟧, by rw [mul_comm] }

instance : preorder (associates α) :=
{ le := has_dvd.dvd,
  le_refl := dvd_refl,
  le_trans := λ a b c, dvd_trans}

/-- `associates.mk` as a `monoid_hom`. -/
protected def mk_monoid_hom : α →* (associates α) := ⟨associates.mk, mk_one, λ x y, mk_mul_mk⟩

@[simp] lemma mk_monoid_hom_apply (a : α) : associates.mk_monoid_hom a = associates.mk a := rfl

lemma associated_map_mk {f : associates α →* α}
  (hinv : function.right_inverse f associates.mk) (a : α) :
  a ~ᵤ f (associates.mk a) :=
associates.mk_eq_mk_iff_associated.1 (hinv (associates.mk a)).symm

lemma mk_pow (a : α) (n : ℕ) : associates.mk (a ^ n) = (associates.mk a) ^ n :=
by induction n; simp [*, pow_succ, associates.mk_mul_mk.symm]

lemma dvd_eq_le : ((∣) : associates α → associates α → Prop) = (≤) := rfl

theorem mul_eq_one_iff {x y : associates α} : x * y = 1 ↔ (x = 1 ∧ y = 1) :=
iff.intro
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b ~ᵤ 1, from quotient.exact h,
    ⟨quotient.sound $ associated_one_of_associated_mul_one this,
      quotient.sound $ associated_one_of_associated_mul_one $ by rwa [mul_comm] at this⟩)
  (by simp {contextual := tt})

theorem units_eq_one (u : (associates α)ˣ) : u = 1 :=
units.ext (mul_eq_one_iff.1 u.val_inv).1

instance unique_units : unique ((associates α)ˣ) :=
{ default := 1, uniq := associates.units_eq_one }

theorem coe_unit_eq_one (u : (associates α)ˣ): (u : associates α) = 1 :=
by simp

theorem is_unit_iff_eq_one (a : associates α) : is_unit a ↔ a = 1 :=
iff.intro
  (assume ⟨u, h⟩, h ▸ coe_unit_eq_one _)
  (assume h, h.symm ▸ is_unit_one)

lemma is_unit_iff_eq_bot {a : associates α} : is_unit a ↔ a = ⊥ :=
by rw [associates.is_unit_iff_eq_one, bot_eq_one]

theorem is_unit_mk {a : α} : is_unit (associates.mk a) ↔ is_unit a :=
calc is_unit (associates.mk a) ↔ a ~ᵤ 1 :
    by rw [is_unit_iff_eq_one, one_eq_mk_one, mk_eq_mk_iff_associated]
  ... ↔ is_unit a : associated_one_iff_is_unit

section order

theorem mul_mono {a b c d : associates α} (h₁ : a ≤ b) (h₂ : c ≤ d) :
  a * c ≤ b * d :=
let ⟨x, hx⟩ := h₁, ⟨y, hy⟩ := h₂ in
⟨x * y, by simp [hx, hy, mul_comm, mul_assoc, mul_left_comm]⟩

theorem one_le {a : associates α} : 1 ≤ a :=
dvd.intro _ (one_mul a)

theorem le_mul_right {a b : associates α} : a ≤ a * b := ⟨b, rfl⟩

theorem le_mul_left {a b : associates α} : a ≤ b * a :=
by rw [mul_comm]; exact le_mul_right

instance : order_bot (associates α) :=
{ bot := 1,
  bot_le := assume a, one_le }

end order

theorem dvd_of_mk_le_mk {a b : α} : associates.mk a ≤ associates.mk b → a ∣ b
| ⟨c', hc'⟩ := (quotient.induction_on c' $ assume c hc,
    let ⟨d, hd⟩ := (quotient.exact hc).symm in
    ⟨(↑d) * c,
      calc b = (a * c) * ↑d : hd.symm
        ... = a * (↑d * c) : by ac_refl⟩) hc'

theorem mk_le_mk_of_dvd {a b : α} : a ∣ b → associates.mk a ≤ associates.mk b :=
assume ⟨c, hc⟩, ⟨associates.mk c, by simp [hc]; refl⟩

theorem mk_le_mk_iff_dvd_iff {a b : α} : associates.mk a ≤ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

theorem mk_dvd_mk {a b : α} : associates.mk a ∣ associates.mk b ↔ a ∣ b :=
iff.intro dvd_of_mk_le_mk mk_le_mk_of_dvd

end comm_monoid

instance [has_zero α] [monoid α] : has_zero (associates α) := ⟨⟦ 0 ⟧⟩
instance [has_zero α] [monoid α] : has_top (associates α) := ⟨0⟩

section monoid_with_zero
variables [monoid_with_zero α]

@[simp] theorem mk_eq_zero {a : α} : associates.mk a = 0 ↔ a = 0 :=
⟨assume h, (associated_zero_iff_eq_zero a).1 $ quotient.exact h, assume h, h.symm ▸ rfl⟩

theorem mk_ne_zero {a : α} : associates.mk a ≠ 0 ↔ a ≠ 0 :=
not_congr mk_eq_zero

instance [nontrivial α] : nontrivial (associates α) :=
⟨⟨0, 1,
assume h,
have (0 : α) ~ᵤ 1, from quotient.exact h,
have (0 : α) = 1, from ((associated_zero_iff_eq_zero 1).1 this.symm).symm,
zero_ne_one this⟩⟩

lemma exists_non_zero_rep {a : associates α} : a ≠ 0 → ∃ a0 : α, a0 ≠ 0 ∧ associates.mk a0 = a :=
quotient.induction_on a (λ b nz, ⟨b, mt (congr_arg quotient.mk) nz, rfl⟩)

end monoid_with_zero

section comm_monoid_with_zero

variables [comm_monoid_with_zero α]

instance : comm_monoid_with_zero (associates α) :=
{ zero_mul := by { rintro ⟨a⟩, show associates.mk (0 * a) = associates.mk 0, rw [zero_mul] },
  mul_zero := by { rintro ⟨a⟩, show associates.mk (a * 0) = associates.mk 0, rw [mul_zero] },
  .. associates.comm_monoid, .. associates.has_zero }

instance : order_top (associates α) :=
{ top := 0,
  le_top := assume a, ⟨0, (mul_zero a).symm⟩ }

instance : bounded_order (associates α) :=
{ .. associates.order_top,
  .. associates.order_bot }

instance [decidable_rel ((∣) : α → α → Prop)] :
  decidable_rel ((∣) : associates α → associates α → Prop) :=
λ a b, quotient.rec_on_subsingleton₂ a b (λ a b, decidable_of_iff' _ mk_dvd_mk)

lemma prime.le_or_le {p : associates α} (hp : prime p) {a b : associates α} (h : p ≤ a * b) :
  p ≤ a ∨ p ≤ b :=
hp.2.2 a b h

lemma prime_mk (p : α) : prime (associates.mk p) ↔ _root_.prime p :=
begin
  rw [prime, _root_.prime, forall_associated],
  transitivity,
  { apply and_congr, refl,
    apply and_congr, refl,
    apply forall_congr, assume a,
    exact forall_associated },
  apply and_congr mk_ne_zero,
  apply and_congr,
  { rw [is_unit_mk], },
  refine forall₂_congr (λ a b, _),
  rw [mk_mul_mk, mk_dvd_mk, mk_dvd_mk, mk_dvd_mk],
end

theorem irreducible_mk (a : α) : irreducible (associates.mk a) ↔ irreducible a :=
begin
  simp only [irreducible_iff, is_unit_mk],
  apply and_congr iff.rfl,
  split,
  { rintro h x y rfl,
    simpa [is_unit_mk] using h (associates.mk x) (associates.mk y) rfl },
  { intros h x y,
    refine quotient.induction_on₂ x y (assume x y a_eq, _),
    rcases quotient.exact a_eq.symm with ⟨u, a_eq⟩,
    rw mul_assoc at a_eq,
    show is_unit (associates.mk x) ∨ is_unit (associates.mk y),
    simpa [is_unit_mk] using h _ _ a_eq.symm }
end

theorem mk_dvd_not_unit_mk_iff {a b : α} :
  dvd_not_unit (associates.mk a) (associates.mk b) ↔
  dvd_not_unit a b :=
begin
  rw [dvd_not_unit, dvd_not_unit, mk_ne_zero],
  apply and_congr_right, intro ane0,
  split,
  { contrapose!, rw forall_associated,
    intros h x hx hbax,
    rw [mk_mul_mk, mk_eq_mk_iff_associated] at hbax,
    cases hbax with u hu,
    apply h (x * ↑u⁻¹),
    { rw is_unit_mk at hx,
      rw associated.is_unit_iff,
      apply hx,
      use u,
      simp, },
    simp [← mul_assoc, ← hu] },
  { rintro ⟨x, ⟨hx, rfl⟩⟩,
    use associates.mk x,
    simp [is_unit_mk, mk_mul_mk, hx], }
end

theorem dvd_not_unit_of_lt {a b : associates α} (hlt : a < b) :
  dvd_not_unit a b :=
begin
  split, { rintro rfl, apply not_lt_of_le _ hlt, apply dvd_zero },
  rcases hlt with ⟨⟨x, rfl⟩, ndvd⟩,
  refine ⟨x, _, rfl⟩,
  contrapose! ndvd,
  rcases ndvd with ⟨u, rfl⟩,
  simp,
end

theorem irreducible_iff_prime_iff :
  (∀ a : α, irreducible a ↔ prime a) ↔ (∀ a : (associates α), irreducible a ↔ prime a) :=
by simp_rw [forall_associated, irreducible_mk, prime_mk]

end comm_monoid_with_zero

section cancel_comm_monoid_with_zero
variable [cancel_comm_monoid_with_zero α]

instance : partial_order (associates α) :=
{ le_antisymm := λ a' b', quotient.induction_on₂ a' b' (λ a b hab hba,
  quot.sound $ associated_of_dvd_dvd (dvd_of_mk_le_mk hab) (dvd_of_mk_le_mk hba))
  .. associates.preorder }

instance : ordered_comm_monoid (associates α) :=
{ mul_le_mul_left := λ a b ⟨d, hd⟩ c, hd.symm ▸ mul_assoc c a d ▸ le_mul_right,
  ..associates.comm_monoid,
  ..associates.partial_order}

instance : no_zero_divisors (associates α) :=
⟨λ x y,
  (quotient.induction_on₂ x y $ assume a b h,
    have a * b = 0, from (associated_zero_iff_eq_zero _).1 (quotient.exact h),
    have a = 0 ∨ b = 0, from mul_eq_zero.1 this,
    this.imp (assume h, h.symm ▸ rfl) (assume h, h.symm ▸ rfl))⟩

instance : cancel_comm_monoid_with_zero (associates α) :=
{ mul_left_cancel_of_ne_zero :=
    begin
      rintros ⟨a⟩ ⟨b⟩ ⟨c⟩ ha h,
      rcases quotient.exact' h with ⟨u, hu⟩,
      rw [mul_assoc] at hu,
      exact quotient.sound' ⟨u, mul_left_cancel₀ (mk_ne_zero.1 ha) hu⟩
    end,
  .. (infer_instance : comm_monoid_with_zero (associates α)) }

lemma le_of_mul_le_mul_left (a b c : associates α) (ha : a ≠ 0) :
  a * b ≤ a * c → b ≤ c
| ⟨d, hd⟩ := ⟨d, mul_left_cancel₀ ha $ by rwa ← mul_assoc⟩

lemma one_or_eq_of_le_of_prime :
  ∀(p m : associates α), prime p → m ≤ p → (m = 1 ∨ m = p)
| _ m ⟨hp0, hp1, h⟩ ⟨d, rfl⟩ :=
match h m d dvd_rfl with
| or.inl h := classical.by_cases (assume : m = 0, by simp [this]) $
  assume : m ≠ 0,
  have m * d ≤ m * 1, by simpa using h,
  have d ≤ 1, from associates.le_of_mul_le_mul_left m d 1 ‹m ≠ 0› this,
  have d = 1, from bot_unique this,
  by simp [this]
| or.inr h := classical.by_cases (assume : d = 0, by simp [this] at hp0; contradiction) $
  assume : d ≠ 0,
  have d * m ≤ d * 1, by simpa [mul_comm] using h,
  or.inl $ bot_unique $ associates.le_of_mul_le_mul_left d m 1 ‹d ≠ 0› this
end

instance : canonically_ordered_monoid (associates α) :=
{ exists_mul_of_le := λ a b, id,
  le_self_mul := λ a b, ⟨b, rfl⟩,
  ..associates.cancel_comm_monoid_with_zero,
  ..associates.bounded_order,
  ..associates.ordered_comm_monoid}

theorem dvd_not_unit_iff_lt {a b : associates α} :
  dvd_not_unit a b ↔ a < b :=
dvd_and_not_dvd_iff.symm

end cancel_comm_monoid_with_zero

end associates

section comm_monoid_with_zero

lemma dvd_not_unit.is_unit_of_irreducible_right [comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) (hq : irreducible q) : is_unit p :=
begin
  obtain ⟨hp', x, hx, hx'⟩ := h,
  exact or.resolve_right ((irreducible_iff.1 hq).right p x hx') hx
end

lemma not_irreducible_of_not_unit_dvd_not_unit [comm_monoid_with_zero α] {p q : α}
  (hp : ¬is_unit p) (h : dvd_not_unit p q) : ¬ irreducible q :=
mt h.is_unit_of_irreducible_right hp

lemma dvd_not_unit.not_unit [comm_monoid_with_zero α] {p q : α}
  (hp : dvd_not_unit p q) : ¬ is_unit q :=
begin
  obtain ⟨-, x, hx, rfl⟩ := hp,
  exact λ hc, hx (is_unit_iff_dvd_one.mpr (dvd_of_mul_left_dvd (is_unit_iff_dvd_one.mp hc))),
end

lemma dvd_not_unit_of_dvd_not_unit_associated [comm_monoid_with_zero α]
  [nontrivial α] {p q r : α} (h : dvd_not_unit p q) (h' : associated q r) : dvd_not_unit p r :=
begin
  obtain ⟨u, rfl⟩ := associated.symm h',
  obtain ⟨hp, x, hx⟩ := h,
  refine ⟨hp, x * ↑(u⁻¹), dvd_not_unit.not_unit ⟨u⁻¹.ne_zero, x, hx.left, mul_comm _ _⟩, _⟩,
  rw [← mul_assoc, ← hx.right, mul_assoc, units.mul_inv, mul_one]
end

end comm_monoid_with_zero

section cancel_comm_monoid_with_zero

lemma is_unit_of_associated_mul [cancel_comm_monoid_with_zero α]
  {p b : α} (h : associated (p * b) p) (hp : p ≠ 0) : is_unit b :=
begin
  cases h with a ha,
  refine is_unit_of_mul_eq_one b a ((mul_right_inj' hp).mp _),
  rwa [← mul_assoc, mul_one],
end

lemma dvd_not_unit.not_associated [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : ¬ associated p q :=
begin
  rintro ⟨a, rfl⟩,
  obtain ⟨hp, x, hx, hx'⟩ := h,
  rcases (mul_right_inj' hp).mp hx' with rfl,
  exact hx a.is_unit,
end

lemma dvd_not_unit.ne [cancel_comm_monoid_with_zero α] {p q : α}
  (h : dvd_not_unit p q) : p ≠ q :=
begin
  by_contra hcontra,
  obtain ⟨hp, x, hx', hx''⟩ := h,
  conv_lhs at hx'' {rw [← hcontra, ← mul_one p]},
  rw (mul_left_cancel₀ hp hx'').symm at hx',
  exact hx' is_unit_one,
end

lemma pow_injective_of_not_unit [cancel_comm_monoid_with_zero α] {q : α}
  (hq : ¬ is_unit q) (hq' : q ≠ 0): function.injective (λ (n : ℕ), q^n) :=
begin
  refine injective_of_lt_imp_ne (λ n m h, dvd_not_unit.ne ⟨pow_ne_zero n hq', q^(m - n), _, _⟩),
  { exact not_is_unit_of_not_is_unit_dvd hq (dvd_pow (dvd_refl _) (nat.sub_pos_of_lt h).ne') },
  { exact (pow_mul_pow_sub q h.le).symm  }
end

lemma dvd_prime_pow [cancel_comm_monoid_with_zero α] {p q : α} (hp : prime p) (n : ℕ) :
  q ∣ p^n ↔ ∃ i ≤ n, associated q (p ^ i) :=
begin
  induction n with n ih generalizing q,
  { simp [← is_unit_iff_dvd_one, associated_one_iff_is_unit] },
  refine ⟨λ h, _, λ ⟨i, hi, hq⟩, hq.dvd.trans (pow_dvd_pow p hi)⟩,
  rw pow_succ at h,
  rcases hp.left_dvd_or_dvd_right_of_dvd_mul h with (⟨q, rfl⟩ | hno),
  { rw [mul_dvd_mul_iff_left hp.ne_zero, ih] at h,
    rcases h with ⟨i, hi, hq⟩,
    refine ⟨i + 1, nat.succ_le_succ hi, (hq.mul_left p).trans _⟩,
    rw pow_succ },
  { obtain ⟨i, hi, hq⟩ := ih.mp hno,
    exact ⟨i, hi.trans n.le_succ, hq⟩ }
end

end cancel_comm_monoid_with_zero

assert_not_exists multiset


/- Exercise 4.1: Mathematics — Foundation -/

/- Question 1: Hilbert choice -/

/- The following command enables noncomputable decidability on every `Prop`. The `priority 0`
attribute ensures this is used only when necessary; otherwise, it would make some computable
definitions noncomputable for Lean. -/

local attribute [instance, priority 0] classical.prop_decidable

/- 1.1. Prove the following lemma. -/

lemma exists_minimal_arg.aux (f : ℕ → ℕ) :
  ∀x n, f n = x → ∃n, ∀i, f n ≤ f i
| x n eq :=
  begin
    -- this works thanks to `classical.prop_decidable`
    by_cases (∃n', f n' < x),
    cases h,
    apply exists_minimal_arg.aux _ h_w _,
    apply x,
    apply le_e
    cases eq,

  end

/- Now this interesting lemma falls off: -/

lemma exists_minimal_arg (f : ℕ → ℕ) : ∃n : ℕ, ∀i : ℕ, f n ≤ f i :=
exists_minimal_arg.aux f _ 0 rfl

/- 1.2. Use what you learned in the lecture notes to define the following function, which returns
the (or an) index of the minimal element in `f`'s image. -/

noncomputable def minimal_arg (f : ℕ → ℕ) : ℕ :=
sorry

/- 1.3. Prove the following characteristic lemma about your definition. -/

lemma minimal_arg_spec (f : ℕ → ℕ) : ∀i : ℕ, f (minimal_arg f) ≤ f i :=
sorry

/- Question 2: Integers as quotients -/

/- First, we repeat some material from the lecture. As usual, ignore the `sorry`. -/

namespace exercise

instance int.rel : setoid (ℕ × ℕ) :=
{ r     := λa b, a.1 + b.2 = b.1 + a.2,
  iseqv :=
  ⟨ (assume a, rfl),
    (assume a b eq, eq.symm),
    (assume a b c fst snd,
    have (a.fst + c.snd) + b.snd = (c.fst + a.snd) + b.snd :=
    calc (a.fst + c.snd) + b.snd = (a.fst + b.snd) + c.snd    : by ac_refl
                             ... =  a.snd + (b.fst + c.snd)   : by {rw[fst], ac_refl}
                             ... =  (c.fst + a.snd ) + b.snd  : by {rw[snd], ac_refl},
    calc (a.fst + c.snd) = (c.fst + a.snd)                    : by {apply eq_of_add_eq_add_right this})⟩
    }

def count {α: Type} (a: α) [decidable_eq α]: list α → ℕ
| [] := 0
| (x :: xs) := if x = a then 1 + count xs else count xs

#reduce count 2[2,2,2,2]

  instance list.rel (α: Type) : setoid (list α) :=
{ r     := λxs ys, ∀x, count x xs = count x ys,
  iseqv :=
  ⟨ (assume xs, begin simp end),
  (assume xs ys a b c, begin simp *, end)
  (assume xs ys zs xs_zs ys_zs, by simp *) ⟩ }

lemma rel_set {α: Type} (xs ys: list α): xs ≈ ys ↔ count xs = count ys := sorry

def multiset (α: Type): Type := quotient (list.rel α)

-- lemma counter {α: Type} (xs xs_ys ys ys_xs: list α): count (xs ++ ys) = count xs + count ys

lemma r_reflexive {α: Type} (xs : list α) : r count xs xs
lemma r_symmetric (xs ys : list α) : r xs ys → r ys xs
lemma r_transitive (xs ys zs : listα) : r xs ys→r ys zs→r xs zs

def empty_mset {α: Type}: multiset α :=  ⟦[]⟧
def singleton_mset {α: Type} (a: α) : multiset α :=  ⟦[a]⟧
def sum_mset {α: Type} (A: multiset α) (B: multiset α) : multiset α :=
quotient.lift_on₂ A B (λxs ys, ⟦xs ++ ys⟧ )
begin
intros xs ys xs_ys ys_xs,
intro xs1,
intro ys1,
apply quotient.sound,
simp[rel_set],
simp[rel_set] at xs1,
simp[rel_set] at ys1,

end

inductive finite {α: Type}: set α → Prop
|empty : finite ∅
|singleton (a: α) : finite({a})
|union (A B: set α) (h: finite A) (s: finite B) : finite(A ∪ B)

def multiset2 (α: Type) : Type := subtype (finite α)

@[simp] lemma rel_iff (a b : ℕ × ℕ) : a ≈ b ↔ a.1 + b.2 = b.1 + a.2 := iff.rfl

def int : Type := quotient int.rel

/- 2.1. Define negation using `quotient.lift_on`. -/

def neg (a : int) : int :=
quotient.lift_on a (λpn, ⟦(pn.2, pn.1)⟧ )
begin
intros pn b pnb,
simp[rel_iff],
apply quotient.sound,
simp,
simp at pnb,
rw[pnb]
end

/- 2.2. Prove the following lemmas. -/

lemma neg_mk (p n : ℕ) : neg ⟦(p, n)⟧ = ⟦(n, p)⟧:=
begin
unfold neg,
apply quotient.sound,
rw[rel_iff]
end

lemma neg_neg (a : int) : neg (neg a) = a :=
begin
apply quotient.induction_on a,
intro n,
cases n,
refl
end

end exercise