/-
Copyright (c) 2021 Ashvni Narayanan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ashvni Narayanan
-/
import bernoulli_measure.ind_fn
import bernoulli_measure.loc_const_properties
import bernoulli_measure.from_loc_const

/-!
# Bernoulli measure and the p-adic L-function
This file defines the Bernoulli measure on `zmod d × ℤ_[p]`. We prove that
this p-adic distribution is indeed a p-adic measure. As a consequence, we are also able to define
the p-adic L-function in terms of a p-adic integral.

## Main definitions
 * `bernoulli_measure`

## Implementation notes
 * `g_to_seq` replaced with `from_loc_const_to_seq`

## References
Introduction to Cyclotomic Fields, Washington (Chapter 12, Section 2)

## Tags
p-adic, L-function, Bernoulli measure
-/

local attribute [instance] zmod.topological_space

variables {p : ℕ} [fact p.prime] {d : ℕ} (R : Type*) [normed_comm_ring R] {c : ℕ} [fact (0 < d)]

set_option old_structure_cmd true

open_locale big_operators

open padic_int zmod nat locally_constant eventually_constant_seq

namespace clopen_from
lemma char_fn_eq {n : ℕ} (i : zmod (d * p^n)) :
  _root_.char_fn R (clopen_from.is_clopen (i.val : zmod (d * p^n))) =
  _root_.char_fn R (clopen_from.is_clopen i) := by { congr, rw [nat_cast_val, zmod.cast_id], }
end clopen_from

open clopen_from

lemma helper_3 (f : locally_constant ((zmod d) × ℤ_[p]) R) {n : ℕ} (i : zmod (d * p^n)) :
  (f (i.val)) • _root_.char_fn R (clopen_from.is_clopen (i.val : zmod (d * p^n))) =
  f i • _root_.char_fn R (clopen_from.is_clopen i) := by { rw [nat_cast_val, char_fn_eq], }

lemma s_nonempty [normed_algebra ℚ_[p] R] (hc : c.coprime p) (hc' : c.coprime d)
  (h' : d.coprime p) (n : ℕ) (f : locally_constant ((zmod d) × ℤ_[p]) R) :
  {i : zmod (d * p^n) | ∥(loc_const_to_seq_limit R hc hc' h') (f ↑i •
  _root_.char_fn R (clopen_from.is_clopen i))∥ = ⨆ (i : zmod (d * p ^ n)),
  ∥(loc_const_to_seq_limit R hc hc' h') (f i • _root_.char_fn R (clopen_from.is_clopen i))∥ }.nonempty :=
begin
  have := set.nonempty.cSup_mem _ _,
  swap 4, { refine set.range (λ (i : zmod (d * p^n)), ∥((loc_const_to_seq_limit R hc hc' h'))
    (f ↑i • _root_.char_fn R (clopen_from.is_clopen i))∥), },
  { cases this with y hy,
    simp only [algebra.id.smul_eq_mul, linear_map.map_smul] at hy,
    refine ⟨y, _⟩,
    simp only [zmod.cast_id', algebra.id.smul_eq_mul, id.def, set.mem_set_of_eq,
      finset.mem_range, linear_map.map_smul, nat_cast_val, hy, Sup_range], },
  { apply_instance, },
  { rw set.range_nonempty_iff_nonempty, apply_instance, },
  { rw ←set.image_univ, apply set.finite.image, exact set.finite_univ, },
end

open discrete_quotient_of_to_zmod_pow clopen_from

lemma exists_mul_inv_val_eq (hc' : c.coprime d) (hc : c.coprime p) (k : ℕ) :
  ∃ z : ℕ, c * ((c : zmod (d * p^(2 * k)))⁻¹.val) = dite (1 < d * p^(2 * k))
  (λ h, 1 + z * (d * p^(2 * k))) (λ h, 0) :=
begin
  by_cases eq_one : (d * p^(2 * k)) = 1,
  { have k_zero : ¬ 1 < d * p^(2 * k) := by { rw [eq_one, nat.lt_one_iff], apply nat.one_ne_zero, },
    refine ⟨1, _⟩,
    rw [dif_neg k_zero, eq_one],
    simp only [nat.mul_eq_zero, zmod.val_eq_zero, eq_iff_true_of_subsingleton, or_true], },
  have h : (1 : zmod (d * p^(2 * k))).val = 1,
  { have : ((1 : ℕ) : zmod (d * p^(2 * k))) = 1 := nat.cast_one,
    rw [←this, zmod.val_cast_of_lt (nat.one_lt_mul_pow_of_ne_one eq_one)], },
  simp_rw dif_pos (nat.one_lt_mul_pow_of_ne_one eq_one),
  conv { congr, funext, find 1 {rw ← h}, rw mul_comm z _, },
  apply (nat_coe_zmod_eq_iff (d * p^(2 * k)) _ _).1 _,
  { rw [nat.cast_mul, nat_cast_val, cast_inv (coprime.mul_pow _ hc' hc) dvd_rfl,
      @cast_nat_cast _ (zmod (d * p ^ (2 * k))) _ _ (zmod.char_p _) dvd_rfl c],
    apply coe_mul_inv_eq_one _ (coprime.mul_pow _ hc' hc), },
end
.
open nat
lemma helper_meas_bernoulli_distribution {n : ℕ} (a : zmod (d * p^n)) (hc' : c.coprime d)
  (hc : c.coprime p) : ∃ z : ℤ, int.fract ((a.val : ℚ) / (↑d * ↑p ^ n)) -
  ↑c * int.fract (↑((c : zmod (d * p^(2 * n)))⁻¹.val) * (a : ℚ) / (↑d * ↑p ^ n)) = z :=
begin
  obtain ⟨z, hz⟩ := int.fract_mul_nat ((↑((c : zmod (d * p^(2 * n)))⁻¹.val) *
    (a : ℚ) / (↑d * ↑p ^ n))) c,
  obtain ⟨z', hz'⟩ := exists_mul_inv_val_eq hc' hc n,
  rw [mul_comm, mul_comm _ (c : ℚ), ←mul_div, ←mul_assoc, ←nat.cast_mul] at hz,
  by_cases pos : 1 < d * p^(2 * n),
  { refine ⟨-z, _⟩,
    rw dif_pos pos at hz',
    rw [hz', nat.cast_add, nat.cast_one, one_add_mul] at hz,
    conv at hz { congr, congr, skip, congr, congr, skip, congr, rw [pow_mul', pow_succ, pow_one], },
    rw [←mul_assoc d (p^n), mul_comm (d * p^n) (p^n), ←mul_assoc z' _ _, nat.cast_mul,
      mul_comm _ (↑(d * p ^ n)), mul_assoc, mul_div (↑(z' * p ^ n)) _ _, ←nat.cast_pow,
      ←nat.cast_mul, mul_div_cancel', ←nat_cast_val, ←nat.cast_mul,
      ←int.cast_coe_nat (z' * p ^ n * a.val), int.fract_add_int] at hz,
    { rw [int.cast_neg, ←hz, neg_sub, nat_cast_val a, nat.cast_mul d _, nat.cast_pow, mul_div], },
    { norm_cast, apply ne_zero_of_lt' 0, apply_instance, }, },
  { simp_rw [←nat.cast_pow, ←nat_cast_val a, ←nat.cast_mul,
      mul_pow_eq_one_of_mul_pow_sq_not_one_lt pos, nat.cast_one, div_one, ←int.cast_coe_nat],
    refine ⟨0, by { simp_rw [int.cast_zero, int.fract_coe, mul_zero, sub_zero] }⟩, },
end

lemma meas_bernoulli_distribution [normed_algebra ℚ_[p] R] [norm_one_class R] {n : ℕ} {a : zmod (d * p^n)}
  (hc : c.coprime p) (hc' : c.coprime d) (h' : d.coprime p) : ∥(loc_const_to_seq_limit R hc hc' h')
  (_root_.char_fn R (clopen_from.is_clopen a))∥ ≤ 1 + ∥(algebra_map ℚ ℚ_[p]) (((c - 1) / 2 : ℚ))∥ :=
begin
  convert_to ∥(algebra_map ℚ_[p] R) (bernoulli_distribution p d c n a)∥ ≤ _,
  { rw [linear_map.coe_mk, sequence_limit_eq _ _ (seq_lim_from_loc_const_char_fn R a hc hc' h'),
      from_loc_const_to_seq], },
  obtain ⟨z, hz⟩ := helper_meas_bernoulli_distribution a hc' hc,
  rw [bernoulli_distribution], simp only,
  rw [ring_hom.map_add, norm_algebra_map'],
  apply le_trans (norm_add_le _ _) (add_le_add_right _ _),
  rw [hz, ring_hom.map_int_cast],
  apply padic_norm_e.norm_int_le_one z,
end

open loc_const_ind_fn

/-- Constructs a Bernoulli measure from `loc_const_to_seq_limit`. -/
-- we choose to work with `val` and `nat` because it gives common ground without having to use CRT
noncomputable def bernoulli_measure [normed_algebra ℚ_[p] R] [norm_one_class R] [nontrivial R]
  (hc : c.gcd p = 1) (hc' : c.gcd d = 1) (h' : d.gcd p = 1)
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥∑ i in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f (i.val)∥) :
  measures (units (zmod d) × units ℤ_[p]) R :=
⟨ { to_fun := λ f, loc_const_to_seq_limit R hc hc' h' (loc_const_ind_fn f),
    map_add' := λ f1 f2, by { rw [add, linear_map.map_add], },
    map_smul' := λ m f, by { rw [smul R m f, linear_map.map_smul, ring_hom.id_apply], }, },
  begin
    set K := 1 + ∥(algebra_map ℚ ℚ_[p]) (((c - 1) / 2 : ℚ))∥ with hK,
    have Kpos : 0 < K,
    { rw [hK, add_comm],
      apply add_pos_of_nonneg_of_pos (norm_nonneg _) zero_lt_one, },
    refine ⟨K, Kpos, λ f, _⟩,
    obtain ⟨n, hn⟩ := loc_const_eq_sum_char_fn R (loc_const_ind_fn f) h',
    change ∥loc_const_to_seq_limit R hc hc' h' (loc_const_ind_fn f)∥ ≤ _,
    rw [hn, linear_map.map_sum],
    apply le_trans (na (d * p^n) _) _,
    simp_rw [helper_3],
    set i := (s_nonempty R hc hc' h' n (loc_const_ind_fn f)).some with hi,
    have hi' := (s_nonempty R hc hc' h' n (loc_const_ind_fn f)).some_spec,
    change ∥loc_const_to_seq_limit R hc hc' h' ((loc_const_ind_fn f) ↑i •
      _root_.char_fn R (clopen_from.is_clopen i))∥ = ⨆ (i : zmod (d * p ^ n)),
      ∥loc_const_to_seq_limit R hc hc' h' (((loc_const_ind_fn f) ↑i) •
      _root_.char_fn R (clopen_from.is_clopen i))∥ at hi',
    by_cases is_unit (i : zmod d × ℤ_[p]).fst ∧ is_unit (i : zmod d × ℤ_[p]).snd,
    { suffices : (⨆ (i : zmod (d * p ^ n)), ∥loc_const_to_seq_limit R hc hc' h'
        (((loc_const_ind_fn f) ↑i) • _root_.char_fn R (clopen_from.is_clopen i))∥) ≤
        K * ∥(loc_const_ind_fn f) ↑i∥,
      { apply le_trans this ((mul_le_mul_left Kpos).2 _),
        rw continuous_map.norm_eq_supr_norm,
        refine le_cSup (set.finite.bdd_above (is_locally_constant.range_finite
          (is_locally_constant.comp f.is_locally_constant _))) ⟨(is_unit.unit h.1,
          is_unit.unit h.2), by { rw [loc_const_ind_fn_def, ind_fn.map_ind_fn_eq_fn _ h], refl, }⟩, },
      { rw [←hi', linear_map.map_smul, smul_eq_mul],
        apply le_trans (norm_mul_le _ _) _,
        rw mul_comm,
        refine mul_le_mul (meas_bernoulli_distribution R hc hc' h') le_rfl (norm_nonneg _) (le_of_lt Kpos), }, },
    { rw [loc_const_ind_fn_def, ind_fn.map_ind_fn_eq_zero _ h, zero_smul, linear_map.map_zero,
        norm_zero] at hi',
      rw [←hi'],
      apply mul_nonneg (le_of_lt Kpos) (norm_nonneg _), }, end⟩
.

lemma integral_loc_const_eval [nontrivial R] [complete_space R] [normed_algebra ℚ_[p] R] [norm_one_class R]
  (hc : c.gcd p = 1) (hc' : c.gcd d = 1) (hd : d.gcd p = 1)
  (na : ∀ (n : ℕ) (f : ℕ → R), ∥∑ i in finset.range n, f i∥ ≤ ⨆ (i : zmod n), ∥f (i.val)∥)
  (f : locally_constant ((zmod d)ˣ × ℤ_[p]ˣ) R) :
  measure.integral (bernoulli_measure R hc hc' hd na) f = (bernoulli_measure R hc hc' hd na).val f :=
begin
  delta measure.integral,
  simp only [continuous_linear_map.coe_mk', linear_map.coe_mk, subtype.val_eq_coe],
  convert dense_inducing.extend_eq (measure.dense_ind_inclusion _ _) (measure.integral_cont _) _,
  apply_instance,
  apply_instance,
  apply_instance,
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.lattice
import Mathlib.PostPort

universes v l

namespace Mathlib

/-!
# The category of "pairwise intersections".

Given `ι : Type v`, we build the diagram category `pairwise ι`
with objects `single i` and `pair i j`, for `i j : ι`,
whose only non-identity morphisms are
`left : pair i j ⟶ single i` and `right : pair i j ⟶ single j`.

We use this later in describing (one formulation of) the sheaf condition.

Given any function `U : ι → α`, where `α` is some complete lattice (e.g. `(opens X)ᵒᵖ`),
we produce a functor `pairwise ι ⥤ α` in the obvious way,
and show that `supr U` provides a colimit cocone over this functor.
-/

namespace category_theory

/--
An inductive type representing either a single term of a type `ι`, or a pair of terms.
We use this as the objects of a category to describe the sheaf condition.
-/
inductive pairwise (ι : Type v) where
| single : ι → pairwise ι
| pair : ι → ι → pairwise ι

namespace pairwise

protected instance pairwise_inhabited {ι : Type v} [Inhabited ι] : Inhabited (pairwise ι) :=
  { default := single Inhabited.default }

/--
Morphisms in the category `pairwise ι`. The only non-identity morphisms are
`left i j : single i ⟶ pair i j` and `right i j : single j ⟶ pair i j`.
-/
inductive hom {ι : Type v} : pairwise ι → pairwise ι → Type v where
| id_single : (i : ι) → hom (single i) (single i)
| id_pair : (i j : ι) → hom (pair i j) (pair i j)
| left : (i j : ι) → hom (pair i j) (single i)
| right : (i j : ι) → hom (pair i j) (single j)

protected instance hom_inhabited {ι : Type v} [Inhabited ι] :
    Inhabited (hom (single Inhabited.default) (single Inhabited.default)) :=
  { default := hom.id_single Inhabited.default }

/--
The identity morphism in `pairwise ι`.
-/
def id {ι : Type v} (o : pairwise ι) : hom o o := sorry

/-- Composition of morphisms in `pairwise ι`. -/
def comp {ι : Type v} {o₁ : pairwise ι} {o₂ : pairwise ι} {o₃ : pairwise ι} (f : hom o₁ o₂)
    (g : hom o₂ o₃) : hom o₁ o₃ :=
  sorry

protected instance category_theory.category {ι : Type v} : category (pairwise ι) := category.mk

/-- Auxilliary definition for `diagram`. -/
@[simp] def diagram_obj {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] :
    pairwise ι → α :=
  sorry

/-- Auxilliary definition for `diagram`. -/
@[simp] def diagram_map {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] {o₁ : pairwise ι}
    {o₂ : pairwise ι} (f : o₁ ⟶ o₂) : diagram_obj U o₁ ⟶ diagram_obj U o₂ :=
  sorry

/--
Given a function `U : ι → α` for `[semilattice_inf α]`, we obtain a functor `pairwise ι ⥤ α`,
sending `single i` to `U i` and `pair i j` to `U i ⊓ U j`,
and the morphisms to the obvious inequalities.
-/
def diagram {ι : Type v} {α : Type v} (U : ι → α) [semilattice_inf α] : pairwise ι ⥤ α :=
  functor.mk (diagram_obj U) fun (X Y : pairwise ι) (f : X ⟶ Y) => diagram_map U f

-- `complete_lattice` is not really needed, as we only ever use `inf`,

-- but the appropriate structure has not been defined.

/-- Auxilliary definition for `cocone`. -/
def cocone_ι_app {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] (o : pairwise ι) :
    diagram_obj U o ⟶ supr U :=
  sorry

/--
Given a function `U : ι → α` for `[complete_lattice α]`,
`supr U` provides a cocone over `diagram U`.
-/
@[simp] theorem cocone_X {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] :
    limits.cocone.X (cocone U) = supr U :=
  Eq.refl (limits.cocone.X (cocone U))

/--
Given a function `U : ι → α` for `[complete_lattice α]`,
`infi U` provides a limit cone over `diagram U`.
-/
def cocone_is_colimit {ι : Type v} {α : Type v} (U : ι → α) [complete_lattice α] :
    limits.is_colimit (cocone U) :=
  limits.is_colimit.mk fun (s : limits.cocone (diagram U)) => hom_of_le sorry

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.bifunctor
import control.traversable.basic

/-!
# Bitraversable type class

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

Type class for traversing bifunctors.

Simple examples of `bitraversable` are `prod` and `sum`. A more elaborate example is
to define an a-list as:

```
def alist (key val : Type) := list (key × val)
```

Then we can use `f : key → io key'` and `g : val → io val'` to manipulate the `alist`'s key
and value respectively with `bitraverse f g : alist key val → io (alist key' val')`

## Main definitions

* `bitraversable`: Bare typeclass to hold the `bitraverse` function.
* `is_lawful_bitraversable`: Typeclass for the laws of the `bitraverse` function. Similar to
  `is_lawful_traversable`.

## References

The concepts and laws are taken from
<https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

## Tags

traversable bitraversable iterator functor bifunctor applicative
-/

universes u

/-- Lawless bitraversable bifunctor. This only holds data for the bimap and bitraverse. -/
class bitraversable (t : Type u → Type u → Type u)
  extends bifunctor t :=
(bitraverse : Π {m : Type u → Type u} [applicative m] {α α' β β'},
  (α → m α') → (β → m β') → t α β → m (t α' β'))
export bitraversable ( bitraverse )

/-- A bitraversable functor commutes with all applicative functors. -/
def bisequence {t m} [bitraversable t] [applicative m] {α β} : t (m α) (m β) → m (t α β) :=
bitraverse id id

open functor

/-- Bifunctor. This typeclass asserts that a lawless bitraversable bifunctor is lawful. -/
class is_lawful_bitraversable (t : Type u → Type u → Type u) [bitraversable t]
  extends is_lawful_bifunctor t :=
(id_bitraverse : ∀ {α β} (x : t α β), bitraverse id.mk id.mk x = id.mk x )
(comp_bitraverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α α' β β' γ γ'} (f : β → F γ) (f' : β' → F γ')
    (g : α → G β) (g' : α' → G β') (x : t α α'),
  bitraverse (comp.mk ∘ map f ∘ g) (comp.mk ∘ map f' ∘ g') x =
  comp.mk (bitraverse f f' <$> bitraverse g g' x) )
(bitraverse_eq_bimap_id : ∀ {α α' β β'} (f : α → β) (f' : α' → β') (x : t α α'),
   bitraverse (id.mk ∘ f) (id.mk ∘ f') x = id.mk (bimap f f' x))
(binaturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α α' β β'}
    (f : α → F β) (f' : α' → F β') (x : t α α'),
  η (bitraverse f f' x) = bitraverse (@η _ ∘ f) (@η _ ∘ f') x)

export is_lawful_bitraversable ( id_bitraverse comp_bitraverse
                                 bitraverse_eq_bimap_id  )
open is_lawful_bitraversable

attribute [higher_order bitraverse_id_id] id_bitraverse
attribute [higher_order bitraverse_comp] comp_bitraverse
attribute [higher_order] binaturality bitraverse_eq_bimap_id

export is_lawful_bitraversable (bitraverse_id_id bitraverse_comp)


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.bifunctor
import control.traversable.basic

/-!
# Bitraversable type class

Type class for traversing bifunctors.

Simple examples of `bitraversable` are `prod` and `sum`. A more elaborate example is
to define an a-list as:

```
def alist (key val : Type) := list (key × val)
```

Then we can use `f : key → io key'` and `g : val → io val'` to manipulate the `alist`'s key
and value respectively with `bitraverse f g : alist key val → io (alist key' val')`

## Main definitions

* `bitraversable`: Bare typeclass to hold the `bitraverse` function.
* `is_lawful_bitraversable`: Typeclass for the laws of the `bitraverse` function. Similar to
  `is_lawful_traversable`.

## References

The concepts and laws are taken from
<https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

## Tags

traversable bitraversable iterator functor bifunctor applicative
-/

universes u

/-- Lawless bitraversable bifunctor. This only holds data for the bimap and bitraverse. -/
class bitraversable (t : Type u → Type u → Type u)
  extends bifunctor t :=
(bitraverse : Π {m : Type u → Type u} [applicative m] {α α' β β'},
  (α → m α') → (β → m β') → t α β → m (t α' β'))
export bitraversable ( bitraverse )

/-- A bitraversable functor commutes with all applicative functors. -/
def bisequence {t m} [bitraversable t] [applicative m] {α β} : t (m α) (m β) → m (t α β) :=
bitraverse id id

open functor

/-- Bifunctor. This typeclass asserts that a lawless bitraversable bifunctor is lawful. -/
class is_lawful_bitraversable (t : Type u → Type u → Type u) [bitraversable t]
  extends is_lawful_bifunctor t :=
(id_bitraverse : ∀ {α β} (x : t α β), bitraverse id.mk id.mk x = id.mk x )
(comp_bitraverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α α' β β' γ γ'} (f : β → F γ) (f' : β' → F γ')
    (g : α → G β) (g' : α' → G β') (x : t α α'),
  bitraverse (comp.mk ∘ map f ∘ g) (comp.mk ∘ map f' ∘ g') x =
  comp.mk (bitraverse f f' <$> bitraverse g g' x) )
(bitraverse_eq_bimap_id : ∀ {α α' β β'} (f : α → β) (f' : α' → β') (x : t α α'),
   bitraverse (id.mk ∘ f) (id.mk ∘ f') x = id.mk (bimap f f' x))
(binaturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α α' β β'}
    (f : α → F β) (f' : α' → F β') (x : t α α'),
  η (bitraverse f f' x) = bitraverse (@η _ ∘ f) (@η _ ∘ f') x)

export is_lawful_bitraversable ( id_bitraverse comp_bitraverse
                                 bitraverse_eq_bimap_id  )
open is_lawful_bitraversable

attribute [higher_order bitraverse_id_id] id_bitraverse
attribute [higher_order bitraverse_comp] comp_bitraverse
attribute [higher_order] binaturality bitraverse_eq_bimap_id

export is_lawful_bitraversable (bitraverse_id_id bitraverse_comp)


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.equiv.defs

/-!
# A type for VM-erased data

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

This file defines a type `erased α` which is classically isomorphic to `α`,
but erased in the VM. That is, at runtime every value of `erased α` is
represented as `0`, just like types and proofs.
-/

universes u

/-- `erased α` is the same as `α`, except that the elements
  of `erased α` are erased in the VM in the same way as types
  and proofs. This can be used to track data without storing it
  literally. -/
def erased (α : Sort u) : Sort (max 1 u) :=
Σ' s : α → Prop, ∃ a, (λ b, a = b) = s

namespace erased

/-- Erase a value. -/
@[inline] def mk {α} (a : α) : erased α := ⟨λ b, a = b, a, rfl⟩

/-- Extracts the erased value, noncomputably. -/
noncomputable def out {α} : erased α → α
| ⟨s, h⟩ := classical.some h

/--
Extracts the erased value, if it is a type.

Note: `(mk a).out_type` is not definitionally equal to `a`.
-/
@[reducible] def out_type (a : erased (Sort u)) : Sort u := out a

/-- Extracts the erased value, if it is a proof. -/
theorem out_proof {p : Prop} (a : erased p) : p := out a

@[simp] theorem out_mk {α} (a : α) : (mk a).out = a :=
begin
  let h, show classical.some h = a,
  have := classical.some_spec h,
  exact cast (congr_fun this a).symm rfl
end

@[simp] theorem mk_out {α} : ∀ (a : erased α), mk (out a) = a
| ⟨s, h⟩ := by simp [mk]; congr; exact classical.some_spec h

@[ext] lemma out_inj {α} (a b : erased α) (h : a.out = b.out) : a = b :=
by simpa using congr_arg mk h

/-- Equivalence between `erased α` and `α`. -/
noncomputable def equiv (α) : erased α ≃ α :=
⟨out, mk, mk_out, out_mk⟩

instance (α : Type u) : has_repr (erased α) := ⟨λ _, "erased"⟩
instance (α : Type u) : has_to_string (erased α) := ⟨λ _, "erased"⟩
meta instance (α : Type u) : has_to_format (erased α) := ⟨λ _, ("erased" : format)⟩

/-- Computably produce an erased value from a proof of nonemptiness. -/
def choice {α} (h : nonempty α) : erased α := mk (classical.choice h)

@[simp] theorem nonempty_iff {α} : nonempty (erased α) ↔ nonempty α :=
⟨λ ⟨a⟩, ⟨a.out⟩, λ ⟨a⟩, ⟨mk a⟩⟩

instance {α} [h : nonempty α] : inhabited (erased α) :=
⟨choice h⟩

/--
`(>>=)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `monad`).
-/
def bind {α β} (a : erased α) (f : α → erased β) : erased β :=
⟨λ b, (f a.out).1 b, (f a.out).2⟩

@[simp] theorem bind_eq_out {α β} (a f) : @bind α β a f = f a.out :=
by delta bind bind._proof_1; cases f a.out; refl

/--
Collapses two levels of erasure.
-/
def join {α} (a : erased (erased α)) : erased α := bind a id

@[simp] theorem join_eq_out {α} (a) : @join α a = a.out := bind_eq_out _ _

/--
`(<$>)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `functor`).
-/
def map {α β} (f : α → β) (a : erased α) : erased β :=
bind a (mk ∘ f)

@[simp] theorem map_out {α β} {f : α → β} (a : erased α) : (a.map f).out = f a.out :=
by simp [map]

instance : monad erased := { pure := @mk, bind := @bind, map := @map }

@[simp] lemma pure_def {α} : (pure : α → erased α) = @mk _ := rfl
@[simp] lemma bind_def {α β} : ((>>=) : erased α → (α → erased β) → erased β) = @bind _ _ := rfl
@[simp] lemma map_def {α β} : ((<$>) : (α → β) → erased α → erased β) = @map _ _ := rfl

instance : is_lawful_monad erased := by refine {..}; intros; ext; simp

end erased


/-
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, Floris van Doorn, Mario Carneiro
-/

import tactic.core

/-!
# `choose` tactic

Performs Skolemization, that is, given `h : ∀ a:α, ∃ b:β, p a b |- G` produces
`f : α → β, hf: ∀ a, p a (f a) |- G`.
-/

namespace tactic

/-- Given `α : Sort u`, `nonemp : nonempty α`, `p : α → Prop`, a context of local variables
`ctxt`, and a pair of an element `val : α` and `spec : p val`,
`mk_sometimes u α nonemp p ctx (val, spec)` produces another pair `val', spec'`
such that `val'` does not have any free variables from elements of `ctxt` whose types are
propositions. This is done by applying `function.sometimes` to abstract over all the propositional
arguments. -/
meta def mk_sometimes (u : level) (α nonemp p : expr) :
  list expr → expr × expr → tactic (expr × expr)
| [] (val, spec) := pure (val, spec)
| (e :: ctxt) (val, spec) := do
  (val, spec) ← mk_sometimes ctxt (val, spec),
  t ← infer_type e,
  b ← is_prop t,
  pure $ if b then
    let val' := expr.bind_lambda val e in
    (expr.const ``function.sometimes [level.zero, u] t α nonemp val',
     expr.const ``function.sometimes_spec [u] t α nonemp p val' e spec)
  else (val, spec)

/-- Changes `(h : ∀xs, ∃a:α, p a) ⊢ g` to `(d : ∀xs, a) (s : ∀xs, p (d xs)) ⊢ g` and
`(h : ∀xs, p xs ∧ q xs) ⊢ g` to `(d : ∀xs, p xs) (s : ∀xs, q xs) ⊢ g`.
`choose1` returns a pair of the second local constant it introduces,
and the error result (see below).

If `nondep` is true and `α` is inhabited, then it will remove the dependency of `d` on
all propositional assumptions in `xs`. For example if `ys` are propositions then
`(h : ∀xs ys, ∃a:α, p a) ⊢ g` becomes `(d : ∀xs, a) (s : ∀xs ys, p (d xs)) ⊢ g`.

The second value returned by `choose1` is the result of nondep elimination:
* `none`: nondep elimination was not attempted or was not applicable
* `some none`: nondep elimination was successful
* ``some (some `(nonempty α))``: nondep elimination was unsuccessful
  because we could not find a `nonempty α` instance
-/
meta def choose1 (nondep : bool) (h : expr) (data : name) (spec : name) :
  tactic (expr × option (option expr)) := do
  t ← infer_type h,
  (ctxt, t) ← whnf t >>= open_pis,
  t ← whnf t transparency.all,
  match t with
  | `(@Exists %%α %%p) := do
    α_t ← infer_type α,
    expr.sort u ← whnf α_t transparency.all,
    (ne_fail, nonemp) ← if nondep then do
      let ne := expr.const ``nonempty [u] α,
      nonemp ← try_core (mk_instance ne <|> retrieve' (do
        m ← mk_meta_var ne,
        set_goals [m],
        ctxt.mmap' (λ e, do
          b ← is_proof e,
          monad.unlessb b $
            (mk_app ``nonempty.intro [e] >>= note_anon none) $> ()),
        unfreeze_local_instances >> apply_instance,
        instantiate_mvars m)),
      pure (some (option.guard (λ _, nonemp.is_none) ne), nonemp)
    else pure (none, none),
    ctxt' ← if nonemp.is_some then ctxt.mfilter (λ e, bnot <$> is_proof e) else pure ctxt,
    value ← mk_local_def data (α.pis ctxt'),
    t' ← head_beta (p.app (value.mk_app ctxt')),
    spec ← mk_local_def spec (t'.pis ctxt),
    (value_proof, spec_proof) ← nonemp.elim pure (λ nonemp, mk_sometimes u α nonemp p ctxt)
      (expr.const ``classical.some [u] α p (h.mk_app ctxt),
       expr.const ``classical.some_spec [u] α p (h.mk_app ctxt)),
    dependent_pose_core [(value, value_proof.lambdas ctxt'), (spec, spec_proof.lambdas ctxt)],
    try (tactic.clear h),
    intro1,
    e ← intro1,
    pure (e, ne_fail)
  | `(%%p ∧ %%q) := do
    mk_app ``and.elim_left [h.mk_app ctxt] >>= lambdas ctxt >>= note data none,
    hq ← mk_app ``and.elim_right [h.mk_app ctxt] >>= lambdas ctxt >>= note spec none,
    try (tactic.clear h),
    pure (hq, none)
  | _ := fail "expected a term of the shape `∀xs, ∃a, p xs a` or `∀xs, p xs ∧ q xs`"
  end

/-- Changes `(h : ∀xs, ∃as, p as ∧ q as) ⊢ g` to a list of functions `as`,
and a final hypothesis on `p as` and `q as`. If `nondep` is true then the functions will
be made to not depend on propositional arguments, when possible.

The last argument is an internal recursion variable, indicating whether nondep elimination
has been useful so far. The tactic fails if `nondep` is true, and nondep elimination is
attempted at least once, and it fails every time it is attempted, in which case it returns
an error complaining about the first attempt.
-/
meta def choose (nondep : bool) : expr → list name →
  opt_param (option (option expr)) none → tactic unit
| h [] _ := fail "expect list of variables"
| h [n] (some (some ne)) := do
  g ← mk_meta_var ne, set_goals [g], -- make a reasonable error state
  fail "choose: failed to synthesize nonempty instance"
| h [n] _ := do
  cnt ← revert h,
  intro n,
  intron (cnt - 1),
  return ()
| h (n::ns) ne_fail₁ := do
  (v, ne_fail₂) ← get_unused_name >>= choose1 nondep h n,
  choose v ns $
    match ne_fail₁, ne_fail₂ with
    | none, _ := ne_fail₂
    | some none, _ := some none
    | _, some none := some none
    | _, _ := ne_fail₁
    end

namespace interactive
setup_tactic_parser

/-- `choose a b h h' using hyp` takes an hypothesis `hyp` of the form
`∀ (x : X) (y : Y), ∃ (a : A) (b : B), P x y a b ∧ Q x y a b`
for some `P Q : X → Y → A → B → Prop` and outputs
into context a function `a : X → Y → A`, `b : X → Y → B` and two assumptions:
`h : ∀ (x : X) (y : Y), P x y (a x y) (b x y)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x y) (b x y)`. It also works with dependent versions.

`choose! a b h h' using hyp` does the same, except that it will remove dependency of
the functions on propositional arguments if possible. For example if `Y` is a proposition
and `A` and `B` are nonempty in the above example then we will instead get
`a : X → A`, `b : X → B`, and the assumptions
`h : ∀ (x : X) (y : Y), P x y (a x) (b x)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x) (b x)`.

Examples:

```lean
example (h : ∀n m : ℕ, ∃i j, m = n + i ∨ m + j = n) : true :=
begin
  choose i j h using h,
  guard_hyp i : ℕ → ℕ → ℕ,
  guard_hyp j : ℕ → ℕ → ℕ,
  guard_hyp h : ∀ (n m : ℕ), m = n + i n m ∨ m + j n m = n,
  trivial
end
```

```lean
example (h : ∀ i : ℕ, i < 7 → ∃ j, i < j ∧ j < i+i) : true :=
begin
  choose! f h h' using h,
  guard_hyp f : ℕ → ℕ,
  guard_hyp h : ∀ (i : ℕ), i < 7 → i < f i,
  guard_hyp h' : ∀ (i : ℕ), i < 7 → f i < i + i,
  trivial,
end
```
-/
meta def choose (nondep : parse (tk "!")?) (first : parse ident) (names : parse ident*)
  (tgt : parse (tk "using" *> texpr)?) : tactic unit := do
tgt ← match tgt with
  | none := get_local `this
  | some e := tactic.i_to_expr_strict e
  end,
tactic.choose nondep.is_some tgt (first :: names),
try (interactive.simp none none tt [simp_arg_type.expr
  ``(exists_prop)] [] (loc.ns $ some <$> names)),
try (tactic.clear tgt)

add_tactic_doc
{ name       := "choose",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.choose],
  tags       := ["classical logic"] }

end interactive
end tactic


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.const
import category_theory.discrete_category

/-!
# The category `discrete punit`

We define `star : C ⥤ discrete punit` sending everything to `punit.star`,
show that any two functors to `discrete punit` are naturally isomorphic,
and construct the equivalence `(discrete punit ⥤ C) ≌ C`.
-/

universes v u -- morphism levels before object levels. See note [category_theory universes].

namespace category_theory

namespace functor
variables (C : Type u) [category.{v} C]

/-- The constant functor sending everything to `punit.star`. -/
def star : C ⥤ discrete punit :=
(functor.const _).obj punit.star

variable {C}
/-- Any two functors to `discrete punit` are isomorphic. -/
def punit_ext (F G : C ⥤ discrete punit) : F ≅ G :=
nat_iso.of_components (λ _, eq_to_iso dec_trivial) (λ _ _ _, dec_trivial)

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
lemma punit_ext' (F G : C ⥤ discrete punit) : F = G :=
functor.ext (λ _, dec_trivial) (λ _ _ _, dec_trivial)

/-- The functor from `discrete punit` sending everything to the given object. -/
abbreviation from_punit (X : C) : discrete punit.{v+1} ⥤ C :=
(functor.const _).obj X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simps]
def equiv : (discrete punit ⥤ C) ≌ C :=
{ functor :=
  { obj := λ F, F.obj punit.star,
    map := λ F G θ, θ.app punit.star },
  inverse := functor.const _,
  unit_iso :=
  begin
    apply nat_iso.of_components _ _,
    intro X,
    apply discrete.nat_iso,
    rintro ⟨⟩,
    apply iso.refl _,
    intros,
    ext ⟨⟩,
    simp,
  end,
  counit_iso :=
  begin
    refine nat_iso.of_components iso.refl _,
    intros X Y f,
    dsimp, simp,  -- See note [dsimp, simp].
  end }

end functor

end category_theory


import category_theory.category.basic
import category_theory.functor

import algebra.category.Group.images
import algebra.category.Group.colimits
import algebra.category.Group.abelian
import algebra.category.Module.monoidal
import algebra.category.Ring.basic

import category_theory.abelian.basic
import category_theory.limits.shapes.finite_limits

import topology.instances.real
import topology.category.Top
import topology.category.UniformSpace

/-!
This is a demo of the category theory library in mathlib,
as part of "Lean for the Curious Mathematician 2020".

You can get this file by:
* installing Lean if necessary: https://leanprover-community.github.io/get_started.html#regular-install
* `leanproject get mathlib`
* `code mathlib`
* open the file `docs/tutorial/lftcm2020/src/demos/category_theory.lean`

If you've already got a copy of `mathlib`, you should update it now, using
```
  cd /path/to/mathlib/
  git pull
  leanproject get-cache
```

There are also exercises associated with this demo, in
`exercise_sources/thursday/category_theory/`
with hints at
`hints/category_theory/`
and (partial) solutions at
`solutions/thursday/category_theory/`
Any of Exercises 1-7 should be approachable after the demo.
The later exercises are quite hard, and will take you longer than the afternoon problem session!
-/

open category_theory

/-!
## Categories

Categories are implemented in mathlib as a typeclass, parametrised by the type of objects.

Thus to talk about an arbitrary category, we can write
-/
variables (C : Type) [category C]

/-!
There is special notation for the morphisms in a category: if `X Y : C`, we write
* `X ⟶ Y` for the type of morphisms from `X` to `Y`.
  (To enter the special arrow `⟶`, type `\hom`, or hover over the symbol to see the hint.)
* `𝟙 X` is a the identity morphisms on `X` (i.e., a term of type `X ⟶ X`).
* If `f : X ⟶ Y` and `g : Y ⟶ Z`, then we write `f ≫ g` for the composition, a morphism `X ⟶ Z`.
-/

example {W X Y Z : C} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f ≫ (𝟙 X ≫ g)) ≫ h = f ≫ g ≫ h :=
begin
  rw category.id_comp,
  rw category.assoc,
  -- alternatively, just `simp` will do
end

/-!
## Functors

To introduce functors, we'll need a second category around.
-/
variables (D : Type) [category D]

/-!
We write a functor as `F : C ⥤ D`.
(Unlike categories, which are partially unbundled, a functor is "fully bundled",
containing the function on objects as field. This parallels the design for algebraic structures.)
-/

example (F : C ⥤ D) (X : C) : F.map (𝟙 X) = 𝟙 (F.obj X) :=
F.map_id X

example (F : C ⥤ D) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : F.map (f ≫ g) = F.map f ≫ F.map g :=
F.map_comp f g

/-!
The identity functor is written as `𝟭 C`, and functor composition is written `⋙`.
-/
example (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) : (𝟭 C ⋙ F).map (f ≫ 𝟙 Y) = F.map f :=
begin
  rw functor.comp_map,
  rw functor.map_comp,
  rw category_theory.functor.map_id, -- yuck! we really should fix this
  rw functor.id_map,
  rw functor.map_comp,
  rw category_theory.functor.map_id,
  rw category.comp_id,
  -- or just replace the entire proof with `by simp`
end

/-!
To build a functor `F : C ⥤ D` we need to specify four fields
* `obj : C → D`
* `map : ∀ {X Y : C} (f : X ⟶ Y), obj X ⟶ obj Y`
* `map_id'` and `map_comp'`, expressing the functor laws.
-/

example {X : C} : C ⥤ Type* :=
{ obj := λ Y, X ⟶ Y,
  map := λ Y Y' f g, g ≫ f,
  map_id' := λ X, begin funext, simp, end,
  map_comp' := λ X Y Z f g, begin funext, simp, end }

/-!
However Lean will automatically attempt to fill in the `map_id'` and `map_comp'` fields itself,
because these fields are marked with `auto_param`. This lets us specify a tactic to use to
try to synthesize the field.

(In fact, the whole category theory library started off as an experiment to see how far we could
push this automation.)
-/

example {X : C} : C ⥤ Type* :=
{ obj := λ Y, X ⟶ Y,
  map := λ Y Y' f g, g ≫ f, }

/-!
Lean automatically checked functoriality here!
This was pretty easy: we just need to use `category.comp_id` and `category.assoc`.
The more powerful we make the `simp` lemmas, the more boring goals can be discharged automatically.

Most of the `auto_param`s appearing in mathlib so far are in the `category_theory` library,
where they are nearly all filled using the tactic `tidy`, which repeatedly attempts to use
one of a list of "conservative" tactics.

You can see what `tidy` is doing using `tidy?`:
-/

example {X : C} : C ⥤ Type* :=
{ obj := λ Y, X ⟶ Y,
  map := λ Y Y' f g, g ≫ f,
  map_id' := by tidy?,
  map_comp' := by tidy? }

/-!
Sebastien's talk on differential geometry tomorrow will give another example of `auto_param` being used.

You can also watch me doing a speed-run https://youtu.be/oz3z2NSNY8c of Floris's "pointed map" exercises
from yesterday, taking advantage of `auto_param`.
-/

/-!
## Natural transformations

The collection of functors from `C` to `D` has been given the structure of a category:
to talk about the natural transformations, you just write `F ⟶ G` using the usual "morphism" arrow.

If `α : F ⟶ G`, then `α.app X` is the component at `X`, i.e. a morphism `F.obj X ⟶ G.obj X`.
-/
example {F G : C ⥤ D} {α : F ⟶ G} {X Y : C} (f : X ⟶ Y) :
  F.map f ≫ α.app Y = α.app X ≫ G.map f :=
α.naturality f   -- or just `by simp`

/-!
Again, to construct a natural transformation `F ⟶ G` we need to provide two fields
* `app : Π X : C, F.obj X ⟶ G.obj X` and
* `naturality'`, which often is provided by automation.
-/

/-!
## A note on universes

Before we go on, we should mention a slight complication: out in the world we meet
both small and large categories. In set-theoretic foundations, this distinction is about
whether the objects form a set or merely a class.

In the type-theoretic foundations used in Lean, this distinction is about whether
the objects and morphisms live in the same universe, or if the objects live one universe higher up.

Rather than making separate definitions for the two cases, we simply allow the objects and morphisms
to live in two unrelated universes. To talk about a general category we thus write
-/
universes u v

variables (E : Type u) [category.{v} E]

/-!
This says that the objects live in universe `u`, while the morphisms live in universe `v`.
In fact, the definition `category` is paramaterised by two universe levels, and
when we write `category.{v} E` Lean actually understands this as `category.{v u} E`,
automatically filling in the second argument from the universe level of `E`.

There are abbreviations available for the two standard cases:
* if `E : Type (u+1)`, then `large_category E` means `category.{u (u+1)} E`
* if `E : Type u`, then `small_category E` means `category.{u u} E`.

However you'll rarely use these except when setting up particular examples.
All the "concrete" categories, like `Group`, `Ring`, and `Top`, described below,
are instances of `large_category`.
Typically the indexing diagrams for limits and colimits are instances of `small_category`.

If you're talking about an arbitrary category, and you don't mind whether it is small or large,
you should just allow two independent universe variables, as above.
-/

/-!
## Concrete categories

We've set up a number of concrete categories in mathlib.
-/

example (R S : CommRing) (f : R ⟶ S) (x y : R) : f (x * y) = f x * f y := by simp

/-!
Note here we have a particularly succinct way of introducing a commutative ring:
we just write `R : CommRing`, rather than `(R : Type) [comm_ring R]`.
Rather than writing `f : R →+* S` for a `ring_hom`, we can just use the morphism arrow,
and Lean works out the appropriate notion automatically.

There's a coercion from `CommRing` to `Type`,
so we can still talk about elements by writing `x : R`,
and morphisms automatically behave properly as functions (e.g. in `f (x * y)`).
-/

/-!
## Limits and colimits

We talk about limits using the following notions:
* For `F : J ⥤ C`, `c : cone F` consists of
  * `c.X : C` an object in `C`, and
  * `c.π`, a natural transformation with components `c.π.app j : c.X ⟶ F.obj j`.
* For `c : cone F`, `is_limit c` expresses that `c` is a limit cone.
* `has_limit F`, a typeclass specifying a particular choice of limit cone for a functor `F`.
* `has_limits C`, a typeclass specifying a choice of limit for any functor into `C`.

(There are also all the dual notions, `cocone`, `is_colimit`, `has_colimit`, etc.)

There are also typeclasses for various "special shapes", in particular
* `has_equalizers`
* `has_pullbacks`
* `has_binary_products` / `has_finite_products` / `has_products`
* `has_terminal`

A related typeclass `has_zero_morphisms C` specifies a choice of zero morphism in each hom space,
satisfying the usual axioms (equivalent to `C` being enriched in pointed sets), and using that
we can also express some other special shapes, including
* `has_kernels`
* `has_binary_biproducts` / `has_finite_biproducts`
* `has_zero_object`

For most of the concrete categories, these instances are all available when appropriate.
-/

/-!
### Examples of using (co)limits in `Top`
-/

noncomputable theory
open category_theory.limits

def R : Top := Top.of ℝ
def I : Top := Top.of (set.Icc 0 1 : set ℝ)
def pt : Top := Top.of unit

-- Let's construct the mapping cylinder.
def to_pt (X : Top) : X ⟶ pt :=
{ to_fun := λ _, unit.star, continuous_to_fun := continuous_const }

def I₀ : pt ⟶ I :=
{ to_fun := λ _, ⟨(0 : ℝ), by norm_num [set.left_mem_Icc]⟩,
  continuous_to_fun := continuous_const }

def I₁ : pt ⟶ I :=
{ to_fun := λ _, ⟨(1 : ℝ), by norm_num [set.right_mem_Icc]⟩,
  continuous_to_fun := continuous_const }

-- We now construct a cylinder as a categorical limit.
-- `limits.prod` is a shorthand for constructing a limit over the two point diagram:
def cylinder (X : Top) : Top := prod X I

-- To define a map to the cylinder, we give a map to each factor.
-- `prod.lift` is a helper method, providing a wrapper around `limit.lift` for binary products.
def cylinder₀ (X : Top) : X ⟶ cylinder X := prod.lift (𝟙 X) (to_pt X ≫ I₀)
def cylinder₁ (X : Top) : X ⟶ cylinder X := prod.lift (𝟙 X) (to_pt X ≫ I₁)

/--
The mapping cylinder is the pushout of the diagram
```
    X
   ↙ ↘
  Y   (X x I)
```
(`pushout` is implemented just as a wrapper around `colimit`)
-/
def mapping_cylinder {X Y : Top} (f : X ⟶ Y) : Top := pushout f (cylinder₁ X)

/-!
It's perhaps worth admitting here that constructing objects using categorical (co)limits
typically gives quite ghastly "definitional" properties --- if you want to use these objects,
you're going to have to work through their universal properties.

This is not necessarily a bad thing, but takes some getting used to.
-/

/-!
## Applications

We're only just getting to the point in mathlib where we're ready to do the sorts of mathematics
that rely on category theory as a basic language. There's lots more to come ---
big chunks of algebraic geometry, homological algebra, quantum topology, etc.

One important way in which we'll use the category theory library is to achieve polymorphism.
We don't want to separately prove theorems about sheaves of sets, sheaves of rings, etc.
Instead we'd like to talk about sheaves in an arbitrary category,
possibly with some additional typeclasses providing extra structure
(`has_products`, `concrete_category`, `monoidal_category`, etc),
and prove our theorems there.
-/

/-!
## Odds and ends

There's a bunch in mathlib's `category_theory/` folder that hasn't been mentioned at all here,
including:

* Adjunctions
* Equivalences
* Monads
* Abelian categories
* Monoidal categories
* ...

Built on top of the category theory library we have things like
* (Co)homology of chain complexes in `algebra.homology.homology`.
* The (pre)sheaf of continuous functions in `topology.sheaves.sheaf_of_functions`.
* The Giry monad in `measure_theory.category.Meas`.
-/

#print category_theory.adjunction.right_adjoint_preserves_limits

#print category_theory.abelian

-- When this tutorial was written we didn't have a single instance of `abelian` in the library.
example : abelian AddCommGroup.{0} := by apply_instance
example (R : Ring) : abelian (Module R) := by apply_instance

example (R : CommRing.{u}) : monoidal_category (Module.{u} R) := by apply_instance

example : reflective (forget₂ CpltSepUniformSpace UniformSpace) := by apply_instance


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.full_subcategory
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.products
import topology.sheaves.presheaf

/-!
# The sheaf condition in terms of an equalizer of products

Here we set up the machinery for the "usual" definition of the sheaf condition,
e.g. as in https://stacks.math.columbia.edu/tag/0072
in terms of an equalizer diagram where the two objects are
`∏ F.obj (U i)` and `∏ F.obj (U i) ⊓ (U j)`.

-/

universes v u

noncomputable theory

open category_theory
open category_theory.limits
open topological_space
open opposite
open topological_space.opens

namespace Top

variables {C : Type u} [category.{v} C] [has_products C]
variables {X : Top.{v}} (F : presheaf C X) {ι : Type v} (U : ι → opens X)

namespace presheaf

namespace sheaf_condition_equalizer_products

/-- The product of the sections of a presheaf over a family of open sets. -/
def pi_opens : C := ∏ (λ i : ι, F.obj (op (U i)))
/--
The product of the sections of a presheaf over the pairwise intersections of
a family of open sets.
-/
def pi_inters : C := ∏ (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2)))

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U i` to `U i ⊓ U j`.
-/
def left_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.1 ≫ F.map (inf_le_left (U p.1) (U p.2)).op)

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def right_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.2 ≫ F.map (inf_le_right (U p.1) (U p.2)).op)

/--
The morphism `F.obj U ⟶ Π F.obj (U i)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def res : F.obj (op (supr U)) ⟶ pi_opens F U :=
pi.lift (λ i : ι, F.map (topological_space.opens.le_supr U i).op)

@[simp, elementwise]
lemma res_π (i : ι) : res F U ≫ limit.π _ ⟨i⟩ = F.map (opens.le_supr U i).op :=
by rw [res, limit.lift_π, fan.mk_π_app]

@[elementwise]
lemma w : res F U ≫ left_res F U = res F U ≫ right_res F U :=
begin
  dsimp [res, left_res, right_res],
  ext,
  simp only [limit.lift_π, limit.lift_π_assoc, fan.mk_π_app, category.assoc],
  rw [←F.map_comp],
  rw [←F.map_comp],
  congr,
end

/--
The equalizer diagram for the sheaf condition.
-/
@[reducible]
def diagram : walking_parallel_pair.{v} ⥤ C :=
parallel_pair (left_res F U) (right_res F U)

/--
The restriction map `F.obj U ⟶ Π F.obj (U i)` gives a cone over the equalizer diagram
for the sheaf condition. The sheaf condition asserts this cone is a limit cone.
-/
def fork : fork.{v} (left_res F U) (right_res F U) := fork.of_ι _ (w F U)

@[simp]
lemma fork_X : (fork F U).X = F.obj (op (supr U)) := rfl

@[simp]
lemma fork_ι : (fork F U).ι = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_zero :
  (fork F U).π.app walking_parallel_pair.zero = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_one :
  (fork F U).π.app walking_parallel_pair.one = res F U ≫ left_res F U := rfl

variables {F} {G : presheaf C X}

/-- Isomorphic presheaves have isomorphic `pi_opens` for any cover `U`. -/
@[simp]
def pi_opens.iso_of_iso (α : F ≅ G) : pi_opens F U ≅ pi_opens G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic `pi_inters` for any cover `U`. -/
@[simp]
def pi_inters.iso_of_iso (α : F ≅ G) : pi_inters F U ≅ pi_inters G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic sheaf condition diagrams. -/
def diagram.iso_of_iso (α : F ≅ G) : diagram F U ≅ diagram G U :=
nat_iso.of_components
  begin rintro ⟨⟩, exact pi_opens.iso_of_iso U α, exact pi_inters.iso_of_iso U α end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext, simp [left_res], },
    { ext, simp [right_res], },
    { simp, },
  end.

/--
If `F G : presheaf C X` are isomorphic presheaves,
then the `fork F U`, the canonical cone of the sheaf condition diagram for `F`,
is isomorphic to `fork F G` postcomposed with the corresponding isomorphism between
sheaf condition diagrams.
-/
def fork.iso_of_iso (α : F ≅ G) :
  fork F U ≅ (cones.postcompose (diagram.iso_of_iso U α).inv).obj (fork G U) :=
begin
  fapply fork.ext,
  { apply α.app, },
  { ext,
    dunfold fork.ι, -- Ugh, `simp` can't unfold abbreviations.
    simp [res, diagram.iso_of_iso], }
end

section open_embedding

variables {V : Top.{v}} {j : V ⟶ X} (oe : open_embedding j)
variables (𝒰 : ι → opens V)

/--
Push forward a cover along an open embedding.
-/
@[simp]
def cover.of_open_embedding : ι → opens X := (λ i, oe.is_open_map.functor.obj (𝒰 i))

/--
The isomorphism between `pi_opens` corresponding to an open embedding.
-/
@[simp]
def pi_opens.iso_of_open_embedding :
  pi_opens (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_opens F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso (iso.refl _))

/--
The isomorphism between `pi_inters` corresponding to an open embedding.
-/
@[simp]
def pi_inters.iso_of_open_embedding :
  pi_inters (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_inters F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso
  begin
    dsimp [is_open_map.functor],
    exact iso.op
    { hom := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }),
      inv := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }), },
  end)

/-- The isomorphism of sheaf condition diagrams corresponding to an open embedding. -/
def diagram.iso_of_open_embedding :
  diagram (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ diagram F (cover.of_open_embedding oe 𝒰) :=
nat_iso.of_components
  begin
    rintro ⟨⟩,
    exact pi_opens.iso_of_open_embedding oe 𝒰,
    exact pi_inters.iso_of_open_embedding oe 𝒰
  end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext,
      dsimp [left_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { ext,
      dsimp [right_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { simp, },
  end.

/--
If `F : presheaf C X` is a presheaf, and `oe : U ⟶ X` is an open embedding,
then the sheaf condition fork for a cover `𝒰` in `U` for the composition of `oe` and `F` is
isomorphic to sheaf condition fork for `oe '' 𝒰`, precomposed with the isomorphism
of indexing diagrams `diagram.iso_of_open_embedding`.

We use this to show that the restriction of sheaf along an open embedding is still a sheaf.
-/
def fork.iso_of_open_embedding :
  fork (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅
    (cones.postcompose (diagram.iso_of_open_embedding oe 𝒰).inv).obj
      (fork F (cover.of_open_embedding oe 𝒰)) :=
begin
  fapply fork.ext,
  { dsimp [is_open_map.functor],
    exact
    F.map_iso (iso.op
    { hom := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset, set.image_Union]),
      inv := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset,
                     set.image_Union]) }), },
  { ext ⟨j⟩,
    dunfold fork.ι, -- Ugh, it is unpleasant that we need this.
    simp only [res, diagram.iso_of_open_embedding, discrete.nat_iso_inv_app, functor.map_iso_inv,
      limit.lift_π, cones.postcompose_obj_π, functor.comp_map,
      fork_π_app_walking_parallel_pair_zero, pi_opens.iso_of_open_embedding,
      nat_iso.of_components.inv_app, functor.map_iso_refl, functor.op_map, limit.lift_map,
      fan.mk_π_app, nat_trans.comp_app, quiver.hom.unop_op, category.assoc, lim_map_eq_lim_map],
    dsimp,
    rw [category.comp_id, ←F.map_comp],
    refl, },
end

end open_embedding

end sheaf_condition_equalizer_products

end presheaf

end Top


abbrev M := ExceptT String <| StateT Nat Id

def f (xs : List Nat) : M Unit := do
for x in xs do
  if x == 0 then
    throw "contains zero"

#eval f [1, 2, 3] |>.run' 0
#eval f [1, 0, 3] |>.run' 0

theorem ex1 : (f [1, 2, 3] |>.run' 0) = Except.ok () :=
rfl

theorem ex2 : (f [1, 0, 3] |>.run' 0) = Except.error "contains zero" :=
rfl

universe u

abbrev N := ExceptT (ULift.{u} String) Id

def idM {α : Type u} (a : α) : N α :=
pure a

def checkEq {α : Type u} [BEq α] [ToString α] (a b : α) : N PUnit := do
unless a == b do
  throw (ULift.up s!"{a} is not equal to {b}")

def g {α : Type u} [BEq α] [ToString α] (xs : List α) (a : α) : N PUnit := do
for x in xs do
  let a ← idM a
  checkEq x a

#eval g [1, (2:Nat), 3] 1 |>.run


/-
Copyright (c) 2020 Kenji Nakagawa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenji Nakagawa, Anne Baanen, Filippo A. E. Nuccio
-/
import ring_theory.ideal.over
import ring_theory.polynomial.rational_root

/-!
# Dedekind domains

This file defines the notion of a Dedekind domain (or Dedekind ring),
as a Noetherian integrally closed commutative ring of Krull dimension at most one.

## Main definitions

 - `is_dedekind_domain` defines a Dedekind domain as a commutative ring that is
   Noetherian, integrally closed in its field of fractions and has Krull dimension at most one.
   `is_dedekind_domain_iff` shows that this does not depend on the choice of field of fractions.

## Implementation notes

The definitions that involve a field of fractions choose a canonical field of fractions,
but are independent of that choice. The `..._iff` lemmas express this independence.

Often, definitions assume that Dedekind domains are not fields. We found it more practical
to add a `(h : ¬ is_field A)` assumption whenever this is explicitly needed.

## References

* [D. Marcus, *Number Fields*][marcus1977number]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags

dedekind domain, dedekind ring
-/

variables (R A K : Type*) [comm_ring R] [comm_ring A] [field K]

open_locale non_zero_divisors polynomial

/-- A ring `R` has Krull dimension at most one if all nonzero prime ideals are maximal. -/
def ring.dimension_le_one : Prop :=
∀ p ≠ (⊥ : ideal R), p.is_prime → p.is_maximal

open ideal ring

namespace ring

lemma dimension_le_one.principal_ideal_ring
  [is_domain A] [is_principal_ideal_ring A] : dimension_le_one A :=
λ p nonzero prime, by { haveI := prime, exact is_prime.to_maximal_ideal nonzero }

lemma dimension_le_one.integral_closure [nontrivial R] [is_domain A] [algebra R A]
  (h : dimension_le_one R) : dimension_le_one (integral_closure R A) :=
h.is_integral_closure R A (integral_closure R A)

variables {R}

lemma dimension_le_one.not_lt_lt (h : ring.dimension_le_one R)
  (p₀ p₁ p₂ : ideal R) [hp₁ : p₁.is_prime] [hp₂ : p₂.is_prime] :
  ¬ (p₀ < p₁ ∧ p₁ < p₂)
| ⟨h01, h12⟩ := h12.ne ((h p₁ (bot_le.trans_lt h01).ne' hp₁).eq_of_le hp₂.ne_top h12.le)

lemma dimension_le_one.eq_bot_of_lt (h : ring.dimension_le_one R)
  (p P : ideal R) [hp : p.is_prime] [hP : P.is_prime] (hpP : p < P) : p = ⊥ :=
by_contra (λ hp0, h.not_lt_lt ⊥ p P ⟨ne.bot_lt hp0, hpP⟩)

end ring

variables [is_domain A]

/--
A Dedekind domain is an integral domain that is Noetherian, integrally closed, and
has Krull dimension at most one.

This is definition 3.2 of [Neukirch1992].

The integral closure condition is independent of the choice of field of fractions:
use `is_dedekind_domain_iff` to prove `is_dedekind_domain` for a given `fraction_map`.

This is the default implementation, but there are equivalent definitions,
`is_dedekind_domain_dvr` and `is_dedekind_domain_inv`.
TODO: Prove that these are actually equivalent definitions.
-/
class is_dedekind_domain : Prop :=
(is_noetherian_ring : is_noetherian_ring A)
(dimension_le_one : dimension_le_one A)
(is_integrally_closed : is_integrally_closed A)

-- See library note [lower instance priority]
attribute [instance, priority 100]
  is_dedekind_domain.is_noetherian_ring is_dedekind_domain.is_integrally_closed

/-- An integral domain is a Dedekind domain iff and only if it is
Noetherian, has dimension ≤ 1, and is integrally closed in a given fraction field.
In particular, this definition does not depend on the choice of this fraction field. -/
lemma is_dedekind_domain_iff (K : Type*) [field K] [algebra A K] [is_fraction_ring A K] :
  is_dedekind_domain A ↔ is_noetherian_ring A ∧ dimension_le_one A ∧
    (∀ {x : K}, is_integral A x → ∃ y, algebra_map A K y = x) :=
⟨λ ⟨hr, hd, hi⟩, ⟨hr, hd, λ x, (is_integrally_closed_iff K).mp hi⟩,
 λ ⟨hr, hd, hi⟩, ⟨hr, hd, (is_integrally_closed_iff K).mpr @hi⟩⟩

@[priority 100] -- See library note [lower instance priority]
instance is_principal_ideal_ring.is_dedekind_domain [is_principal_ideal_ring A] :
  is_dedekind_domain A :=
⟨principal_ideal_ring.is_noetherian_ring,
 ring.dimension_le_one.principal_ideal_ring A,
 unique_factorization_monoid.is_integrally_closed⟩