/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import topology.opens
import ring_theory.ideal.prod
import linear_algebra.finsupp
import algebra.punit_instances

/-!
# Prime spectrum of a commutative ring

The prime spectrum of a commutative ring is the type of all prime ideals.
It is naturally endowed with a topology: the Zariski topology.

(It is also naturally endowed with a sheaf of rings,
which is constructed in `algebraic_geometry.structure_sheaf`.)

## Main definitions

* `prime_spectrum R`: The prime spectrum of a commutative ring `R`,
  i.e., the set of all prime ideals of `R`.
* `zero_locus s`: The zero locus of a subset `s` of `R`
  is the subset of `prime_spectrum R` consisting of all prime ideals that contain `s`.
* `vanishing_ideal t`: The vanishing ideal of a subset `t` of `prime_spectrum R`
  is the intersection of points in `t` (viewed as prime ideals).

## Conventions

We denote subsets of rings with `s`, `s'`, etc...
whereas we denote subsets of prime spectra with `t`, `t'`, etc...

## Inspiration/contributors

The contents of this file draw inspiration from
<https://github.com/ramonfmir/lean-scheme>
which has contributions from Ramon Fernandez Mir, Kevin Buzzard, Kenny Lau,
and Chris Hughes (on an earlier repository).

-/

noncomputable theory
open_locale classical

universe variables u v

variables (R : Type u) [comm_ring R]

/-- The prime spectrum of a commutative ring `R`
is the type of all prime ideals of `R`.

It is naturally endowed with a topology (the Zariski topology),
and a sheaf of commutative rings (see `algebraic_geometry.structure_sheaf`).
It is a fundamental building block in algebraic geometry. -/
@[nolint has_inhabited_instance]
def prime_spectrum := {I : ideal R // I.is_prime}

variable {R}

namespace prime_spectrum

/-- A method to view a point in the prime spectrum of a commutative ring
as an ideal of that ring. -/
abbreviation as_ideal (x : prime_spectrum R) : ideal R := x.val

instance is_prime (x : prime_spectrum R) :
  x.as_ideal.is_prime := x.2

/--
The prime spectrum of the zero ring is empty.
-/
lemma punit (x : prime_spectrum punit) : false :=
x.1.ne_top_iff_one.1 x.2.1 $ subsingleton.elim (0 : punit) 1 ▸ x.1.zero_mem

section
variables (R) (S : Type v) [comm_ring S]

/-- The prime spectrum of `R × S` is in bijection with the disjoint unions of the prime spectrum of
    `R` and the prime spectrum of `S`. -/
noncomputable def prime_spectrum_prod :
  prime_spectrum (R × S) ≃ prime_spectrum R ⊕ prime_spectrum S :=
ideal.prime_ideals_equiv R S

variables {R S}

@[simp] lemma prime_spectrum_prod_symm_inl_as_ideal (x : prime_spectrum R) :
  ((prime_spectrum_prod R S).symm (sum.inl x)).as_ideal = ideal.prod x.as_ideal ⊤ :=
by { cases x, refl }
@[simp] lemma prime_spectrum_prod_symm_inr_as_ideal (x : prime_spectrum S) :
  ((prime_spectrum_prod R S).symm (sum.inr x)).as_ideal = ideal.prod ⊤ x.as_ideal :=
by { cases x, refl }

end

@[ext] lemma ext {x y : prime_spectrum R} :
  x = y ↔ x.as_ideal = y.as_ideal :=
subtype.ext_iff_val

/-- The zero locus of a set `s` of elements of a commutative ring `R`
is the set of all prime ideals of the ring that contain the set `s`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `zero_locus s` is exactly the subset of `prime_spectrum R`
where all "functions" in `s` vanish simultaneously.
-/
def zero_locus (s : set R) : set (prime_spectrum R) :=
{x | s ⊆ x.as_ideal}

@[simp] lemma mem_zero_locus (x : prime_spectrum R) (s : set R) :
  x ∈ zero_locus s ↔ s ⊆ x.as_ideal := iff.rfl

@[simp] lemma zero_locus_span (s : set R) :
  zero_locus (ideal.span s : set R) = zero_locus s :=
by { ext x, exact (submodule.gi R R).gc s x.as_ideal }

/-- The vanishing ideal of a set `t` of points
of the prime spectrum of a commutative ring `R`
is the intersection of all the prime ideals in the set `t`.

An element `f` of `R` can be thought of as a dependent function
on the prime spectrum of `R`.
At a point `x` (a prime ideal)
the function (i.e., element) `f` takes values in the quotient ring `R` modulo the prime ideal `x`.
In this manner, `vanishing_ideal t` is exactly the ideal of `R`
consisting of all "functions" that vanish on all of `t`.
-/
def vanishing_ideal (t : set (prime_spectrum R)) : ideal R :=
⨅ (x : prime_spectrum R) (h : x ∈ t), x.as_ideal

lemma coe_vanishing_ideal (t : set (prime_spectrum R)) :
  (vanishing_ideal t : set R) = {f : R | ∀ x : prime_spectrum R, x ∈ t → f ∈ x.as_ideal} :=
begin
  ext f,
  rw [vanishing_ideal, set_like.mem_coe, submodule.mem_infi],
  apply forall_congr, intro x,
  rw [submodule.mem_infi],
end

lemma mem_vanishing_ideal (t : set (prime_spectrum R)) (f : R) :
  f ∈ vanishing_ideal t ↔ ∀ x : prime_spectrum R, x ∈ t → f ∈ x.as_ideal :=
by rw [← set_like.mem_coe, coe_vanishing_ideal, set.mem_set_of_eq]

@[simp] lemma vanishing_ideal_singleton (x : prime_spectrum R) :
  vanishing_ideal ({x} : set (prime_spectrum R)) = x.as_ideal :=
by simp [vanishing_ideal]

lemma subset_zero_locus_iff_le_vanishing_ideal (t : set (prime_spectrum R)) (I : ideal R) :
  t ⊆ zero_locus I ↔ I ≤ vanishing_ideal t :=
⟨λ h f k, (mem_vanishing_ideal _ _).mpr (λ x j, (mem_zero_locus _ _).mpr (h j) k), λ h,
  λ x j, (mem_zero_locus _ _).mpr (le_trans h (λ f h, ((mem_vanishing_ideal _ _).mp h) x j))⟩

section gc
variable (R)

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc : @galois_connection
  (ideal R) (order_dual (set (prime_spectrum R))) _ _
  (λ I, zero_locus I) (λ t, vanishing_ideal t) :=
λ I t, subset_zero_locus_iff_le_vanishing_ideal t I

/-- `zero_locus` and `vanishing_ideal` form a galois connection. -/
lemma gc_set : @galois_connection
  (set R) (order_dual (set (prime_spectrum R))) _ _
  (λ s, zero_locus s) (λ t, vanishing_ideal t) :=
have ideal_gc : galois_connection (ideal.span) coe := (submodule.gi R R).gc,
by simpa [zero_locus_span, function.comp] using galois_connection.compose _ _ _ _ ideal_gc (gc R)

lemma subset_zero_locus_iff_subset_vanishing_ideal (t : set (prime_spectrum R)) (s : set R) :
  t ⊆ zero_locus s ↔ s ⊆ vanishing_ideal t :=
(gc_set R) s t

end gc

lemma subset_vanishing_ideal_zero_locus (s : set R) :
  s ⊆ vanishing_ideal (zero_locus s) :=
(gc_set R).le_u_l s

lemma le_vanishing_ideal_zero_locus (I : ideal R) :
  I ≤ vanishing_ideal (zero_locus I) :=
(gc R).le_u_l I

@[simp] lemma vanishing_ideal_zero_locus_eq_radical (I : ideal R) :
  vanishing_ideal (zero_locus (I : set R)) = I.radical := ideal.ext $ λ f,
begin
  rw [mem_vanishing_ideal, ideal.radical_eq_Inf, submodule.mem_Inf],
  exact ⟨(λ h x hx, h ⟨x, hx.2⟩ hx.1), (λ h x hx, h x.1 ⟨hx, x.2⟩)⟩
end

@[simp] lemma zero_locus_radical (I : ideal R) : zero_locus (I.radical : set R) = zero_locus I :=
vanishing_ideal_zero_locus_eq_radical I ▸ congr_fun (gc R).l_u_l_eq_l I

lemma subset_zero_locus_vanishing_ideal (t : set (prime_spectrum R)) :
  t ⊆ zero_locus (vanishing_ideal t) :=
(gc R).l_u_le t

lemma zero_locus_anti_mono {s t : set R} (h : s ⊆ t) : zero_locus t ⊆ zero_locus s :=
(gc_set R).monotone_l h

lemma zero_locus_anti_mono_ideal {s t : ideal R} (h : s ≤ t) :
  zero_locus (t : set R) ⊆ zero_locus (s : set R) :=
(gc R).monotone_l h

lemma vanishing_ideal_anti_mono {s t : set (prime_spectrum R)} (h : s ⊆ t) :
  vanishing_ideal t ≤ vanishing_ideal s :=
(gc R).monotone_u h

lemma zero_locus_subset_zero_locus_iff (I J : ideal R) :
  zero_locus (I : set R) ⊆ zero_locus (J : set R) ↔ J ≤ I.radical :=
⟨λ h, ideal.radical_le_radical_iff.mp (vanishing_ideal_zero_locus_eq_radical I ▸
  vanishing_ideal_zero_locus_eq_radical J ▸ vanishing_ideal_anti_mono h),
λ h, zero_locus_radical I ▸ zero_locus_anti_mono_ideal h⟩

lemma zero_locus_subset_zero_locus_singleton_iff (f g : R) :
  zero_locus ({f} : set R) ⊆ zero_locus {g} ↔ g ∈ (ideal.span ({f} : set R)).radical :=
by rw [← zero_locus_span {f}, ← zero_locus_span {g}, zero_locus_subset_zero_locus_iff,
    ideal.span_le, set.singleton_subset_iff, set_like.mem_coe]

lemma zero_locus_bot :
  zero_locus ((⊥ : ideal R) : set R) = set.univ :=
(gc R).l_bot

@[simp] lemma zero_locus_singleton_zero :
  zero_locus ({0} : set R) = set.univ :=
zero_locus_bot

@[simp] lemma zero_locus_empty :
  zero_locus (∅ : set R) = set.univ :=
(gc_set R).l_bot

@[simp] lemma vanishing_ideal_univ :
  vanishing_ideal (∅ : set (prime_spectrum R)) = ⊤ :=
by simpa using (gc R).u_top

lemma zero_locus_empty_of_one_mem {s : set R} (h : (1:R) ∈ s) :
  zero_locus s = ∅ :=
begin
  rw set.eq_empty_iff_forall_not_mem,
  intros x hx,
  rw mem_zero_locus at hx,
  have x_prime : x.as_ideal.is_prime := by apply_instance,
  have eq_top : x.as_ideal = ⊤, { rw ideal.eq_top_iff_one, exact hx h },
  apply x_prime.ne_top eq_top,
end

@[simp] lemma zero_locus_singleton_one :
  zero_locus ({1} : set R) = ∅ :=
zero_locus_empty_of_one_mem (set.mem_singleton (1 : R))

lemma zero_locus_empty_iff_eq_top {I : ideal R} :
  zero_locus (I : set R) = ∅ ↔ I = ⊤ :=
begin
  split,
  { contrapose!,
    intro h,
    apply set.ne_empty_iff_nonempty.mpr,
    rcases ideal.exists_le_maximal I h with ⟨M, hM, hIM⟩,
    exact ⟨⟨M, hM.is_prime⟩, hIM⟩ },
  { rintro rfl, apply zero_locus_empty_of_one_mem, trivial }
end

@[simp] lemma zero_locus_univ :
  zero_locus (set.univ : set R) = ∅ :=
zero_locus_empty_of_one_mem (set.mem_univ 1)

lemma zero_locus_sup (I J : ideal R) :
  zero_locus ((I ⊔ J : ideal R) : set R) = zero_locus I ∩ zero_locus J :=
(gc R).l_sup

lemma zero_locus_union (s s' : set R) :
  zero_locus (s ∪ s') = zero_locus s ∩ zero_locus s' :=
(gc_set R).l_sup

lemma vanishing_ideal_union (t t' : set (prime_spectrum R)) :
  vanishing_ideal (t ∪ t') = vanishing_ideal t ⊓ vanishing_ideal t' :=
(gc R).u_inf

lemma zero_locus_supr {ι : Sort*} (I : ι → ideal R) :
  zero_locus ((⨆ i, I i : ideal R) : set R) = (⋂ i, zero_locus (I i)) :=
(gc R).l_supr

lemma zero_locus_Union {ι : Sort*} (s : ι → set R) :
  zero_locus (⋃ i, s i) = (⋂ i, zero_locus (s i)) :=
(gc_set R).l_supr

lemma zero_locus_bUnion (s : set (set R)) :
  zero_locus (⋃ s' ∈ s, s' : set R) = ⋂ s' ∈ s, zero_locus s' :=
by simp only [zero_locus_Union]

lemma vanishing_ideal_Union {ι : Sort*} (t : ι → set (prime_spectrum R)) :
  vanishing_ideal (⋃ i, t i) = (⨅ i, vanishing_ideal (t i)) :=
(gc R).u_infi

lemma zero_locus_inf (I J : ideal R) :
  zero_locus ((I ⊓ J : ideal R) : set R) = zero_locus I ∪ zero_locus J :=
set.ext $ λ x, by simpa using x.2.inf_le

lemma union_zero_locus (s s' : set R) :
  zero_locus s ∪ zero_locus s' = zero_locus ((ideal.span s) ⊓ (ideal.span s') : ideal R) :=
by { rw zero_locus_inf, simp }

lemma zero_locus_mul (I J : ideal R) :
  zero_locus ((I * J : ideal R) : set R) = zero_locus I ∪ zero_locus J :=
set.ext $ λ x, by simpa using x.2.mul_le

lemma zero_locus_singleton_mul (f g : R) :
  zero_locus ({f * g} : set R) = zero_locus {f} ∪ zero_locus {g} :=
set.ext $ λ x, by simpa using x.2.mul_mem_iff_mem_or_mem

@[simp] lemma zero_locus_pow (I : ideal R) {n : ℕ} (hn : 0 < n) :
  zero_locus ((I ^ n : ideal R) : set R) = zero_locus I :=
zero_locus_radical (I ^ n) ▸ (I.radical_pow n hn).symm ▸ zero_locus_radical I

@[simp] lemma zero_locus_singleton_pow (f : R) (n : ℕ) (hn : 0 < n) :
  zero_locus ({f ^ n} : set R) = zero_locus {f} :=
set.ext $ λ x, by simpa using x.2.pow_mem_iff_mem n hn

lemma sup_vanishing_ideal_le (t t' : set (prime_spectrum R)) :
  vanishing_ideal t ⊔ vanishing_ideal t' ≤ vanishing_ideal (t ∩ t') :=
begin
  intros r,
  rw [submodule.mem_sup, mem_vanishing_ideal],
  rintro ⟨f, hf, g, hg, rfl⟩ x ⟨hxt, hxt'⟩,
  rw mem_vanishing_ideal at hf hg,
  apply submodule.add_mem; solve_by_elim
end

lemma mem_compl_zero_locus_iff_not_mem {f : R} {I : prime_spectrum R} :
  I ∈ (zero_locus {f} : set (prime_spectrum R))ᶜ ↔ f ∉ I.as_ideal :=
by rw [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]; refl

/-- The Zariski topology on the prime spectrum of a commutative ring
is defined via the closed sets of the topology:
they are exactly those sets that are the zero locus of a subset of the ring. -/
instance zariski_topology : topological_space (prime_spectrum R) :=
topological_space.of_closed (set.range prime_spectrum.zero_locus)
  (⟨set.univ, by simp⟩)
  begin
    intros Zs h,
    rw set.sInter_eq_Inter,
    let f : Zs → set R := λ i, classical.some (h i.2),
    have hf : ∀ i : Zs, ↑i = zero_locus (f i) := λ i, (classical.some_spec (h i.2)).symm,
    simp only [hf],
    exact ⟨_, zero_locus_Union _⟩
  end
  (by { rintro _ _ ⟨s, rfl⟩ ⟨t, rfl⟩, exact ⟨_, (union_zero_locus s t).symm⟩ })

lemma is_open_iff (U : set (prime_spectrum R)) :
  is_open U ↔ ∃ s, Uᶜ = zero_locus s :=
by simp only [@eq_comm _ Uᶜ]; refl

lemma is_closed_iff_zero_locus (Z : set (prime_spectrum R)) :
  is_closed Z ↔ ∃ s, Z = zero_locus s :=
by rw [← is_open_compl_iff, is_open_iff, compl_compl]

lemma is_closed_zero_locus (s : set R) :
  is_closed (zero_locus s) :=
by { rw [is_closed_iff_zero_locus], exact ⟨s, rfl⟩ }

lemma zero_locus_vanishing_ideal_eq_closure (t : set (prime_spectrum R)) :
  zero_locus (vanishing_ideal t : set R) = closure t :=
begin
  apply set.subset.antisymm,
  { rintro x hx t' ⟨ht', ht⟩,
    obtain ⟨fs, rfl⟩ : ∃ s, t' = zero_locus s,
    by rwa [is_closed_iff_zero_locus] at ht',
    rw [subset_zero_locus_iff_subset_vanishing_ideal] at ht,
    exact set.subset.trans ht hx },
  { rw (is_closed_zero_locus _).closure_subset_iff,
    exact subset_zero_locus_vanishing_ideal t }
end

lemma vanishing_ideal_closure (t : set (prime_spectrum R)) :
  vanishing_ideal (closure t) = vanishing_ideal t :=
zero_locus_vanishing_ideal_eq_closure t ▸ congr_fun (gc R).u_l_u_eq_u t

section comap
variables {S : Type v} [comm_ring S] {S' : Type*} [comm_ring S']

/-- The function between prime spectra of commutative rings induced by a ring homomorphism.
This function is continuous. -/
def comap (f : R →+* S) : prime_spectrum S → prime_spectrum R :=
λ y, ⟨ideal.comap f y.as_ideal, by exact ideal.is_prime.comap _⟩

variables (f : R →+* S)

@[simp] lemma comap_as_ideal (y : prime_spectrum S) :
  (comap f y).as_ideal = ideal.comap f y.as_ideal :=
rfl

@[simp] lemma comap_id : comap (ring_hom.id R) = id :=
funext $ λ _, subtype.ext $ ideal.ext $ λ _, iff.rfl

@[simp] lemma comap_comp (f : R →+* S) (g : S →+* S') :
  comap (g.comp f) = comap f ∘ comap g :=
funext $ λ _, subtype.ext $ ideal.ext $ λ _, iff.rfl

@[simp] lemma preimage_comap_zero_locus (s : set R) :
  (comap f) ⁻¹' (zero_locus s) = zero_locus (f '' s) :=
begin
  ext x,
  simp only [mem_zero_locus, set.mem_preimage, comap_as_ideal, set.image_subset_iff],
  refl
end

lemma comap_continuous (f : R →+* S) : continuous (comap f) :=
begin
  rw continuous_iff_is_closed,
  simp only [is_closed_iff_zero_locus],
  rintro _ ⟨s, rfl⟩,
  exact ⟨_, preimage_comap_zero_locus f s⟩
end

end comap

section basic_open

/-- `basic_open r` is the open subset containing all prime ideals not containing `r`. -/
def basic_open (r : R) : topological_space.opens (prime_spectrum R) :=
{ val := { x | r ∉ x.as_ideal },
  property := ⟨{r}, set.ext $ λ x, set.singleton_subset_iff.trans $ not_not.symm⟩ }

@[simp] lemma mem_basic_open (f : R) (x : prime_spectrum R) :
  x ∈ basic_open f ↔ f ∉ x.as_ideal := iff.rfl

lemma is_open_basic_open {a : R} : is_open ((basic_open a) : set (prime_spectrum R)) :=
(basic_open a).property

@[simp] lemma basic_open_eq_zero_locus_compl (r : R) :
  (basic_open r : set (prime_spectrum R)) = (zero_locus {r})ᶜ :=
set.ext $ λ x, by simpa only [set.mem_compl_eq, mem_zero_locus, set.singleton_subset_iff]

@[simp] lemma basic_open_one : basic_open (1 : R) = ⊤ :=
topological_space.opens.ext $ by {simp, refl}

@[simp] lemma basic_open_zero : basic_open (0 : R) = ⊥ :=
topological_space.opens.ext $ by {simp, refl}

lemma basic_open_le_basic_open_iff (f g : R) :
  basic_open f ≤ basic_open g ↔ f ∈ (ideal.span ({g} : set R)).radical :=
by rw [topological_space.opens.le_def, basic_open_eq_zero_locus_compl,
    basic_open_eq_zero_locus_compl, set.le_eq_subset, set.compl_subset_compl,
    zero_locus_subset_zero_locus_singleton_iff]

lemma basic_open_mul (f g : R) : basic_open (f * g) = basic_open f ⊓ basic_open g :=
topological_space.opens.ext $ by {simp [zero_locus_singleton_mul]}

lemma basic_open_mul_le_left (f g : R) : basic_open (f * g) ≤ basic_open f :=
by { rw basic_open_mul f g, exact inf_le_left }

lemma basic_open_mul_le_right (f g : R) : basic_open (f * g) ≤ basic_open g :=
by { rw basic_open_mul f g, exact inf_le_right }

@[simp] lemma basic_open_pow (f : R) (n : ℕ) (hn : 0 < n) : basic_open (f ^ n) = basic_open f :=
topological_space.opens.ext $ by simpa using zero_locus_singleton_pow f n hn

lemma is_topological_basis_basic_opens : topological_space.is_topological_basis
  (set.range (λ (r : R), (basic_open r : set (prime_spectrum R)))) :=
begin
  apply topological_space.is_topological_basis_of_open_of_nhds,
  { rintros _ ⟨r, rfl⟩,
    exact is_open_basic_open },
  { rintros p U hp ⟨s, hs⟩,
    rw [← compl_compl U, set.mem_compl_eq, ← hs, mem_zero_locus, set.not_subset] at hp,
    obtain ⟨f, hfs, hfp⟩ := hp,
    refine ⟨basic_open f, ⟨f, rfl⟩, hfp, _⟩,
    rw [← set.compl_subset_compl, ← hs, basic_open_eq_zero_locus_compl, compl_compl],
    exact zero_locus_anti_mono (set.singleton_subset_iff.mpr hfs) }
end

lemma is_compact_basic_open (f : R) : is_compact (basic_open f : set (prime_spectrum R)) :=
compact_of_finite_subfamily_closed $ λ ι Z hZc hZ,
begin
  let I : ι → ideal R := λ i, vanishing_ideal (Z i),
  have hI : ∀ i, Z i = zero_locus (I i) := λ i,
    by simpa only [zero_locus_vanishing_ideal_eq_closure] using (hZc i).closure_eq.symm,
  rw [basic_open_eq_zero_locus_compl f, set.inter_comm, ← set.diff_eq,
      set.diff_eq_empty, funext hI, ← zero_locus_supr] at hZ,
  obtain ⟨n, hn⟩ : f ∈ (⨆ (i : ι), I i).radical,
  { rw ← vanishing_ideal_zero_locus_eq_radical,
    apply vanishing_ideal_anti_mono hZ,
    exact (subset_vanishing_ideal_zero_locus {f} (set.mem_singleton f)) },
  rcases submodule.exists_finset_of_mem_supr I hn with ⟨s, hs⟩,
  use s,
  -- Using simp_rw here, because `hI` and `zero_locus_supr` need to be applied underneath binders
  simp_rw [basic_open_eq_zero_locus_compl f, set.inter_comm, ← set.diff_eq,
           set.diff_eq_empty, hI, ← zero_locus_supr],
  rw ← zero_locus_radical, -- this one can't be in `simp_rw` because it would loop
  apply zero_locus_anti_mono,
  rw set.singleton_subset_iff,
  exact ⟨n, hs⟩
end

end basic_open

/-- The prime spectrum of a commutative ring is a compact topological space. -/
instance : compact_space (prime_spectrum R) :=
{ compact_univ := by { convert is_compact_basic_open (1 : R), rw basic_open_one, refl } }

section order

/-!
## The specialization order

We endow `prime_spectrum R` with a partial order,
where `x ≤ y` if and only if `y ∈ closure {x}`.

TODO: maybe define sober topological spaces, and generalise this instance to those
-/

instance : partial_order (prime_spectrum R) :=
subtype.partial_order _

@[simp] lemma as_ideal_le_as_ideal (x y : prime_spectrum R) :
  x.as_ideal ≤ y.as_ideal ↔ x ≤ y :=
subtype.coe_le_coe

@[simp] lemma as_ideal_lt_as_ideal (x y : prime_spectrum R) :
  x.as_ideal < y.as_ideal ↔ x < y :=
subtype.coe_lt_coe

lemma le_iff_mem_closure (x y : prime_spectrum R) :
  x ≤ y ↔ y ∈ closure ({x} : set (prime_spectrum R)) :=
by rw [← as_ideal_le_as_ideal, ← zero_locus_vanishing_ideal_eq_closure,
    mem_zero_locus, vanishing_ideal_singleton, set_like.coe_subset_coe]

end order

end prime_spectrum


open classical

variable p : Prop

example (h : ¬¬p) : p :=
  by_contradiction
    (assume h1 : ¬p,
      show false, from h h1)


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import logic.relator

/-!
# Quotient types

This module extends the core library's treatment of quotient types (`init.data.quot`).

## Tags

quotient
-/

variables {α : Sort*} {β : Sort*}

namespace setoid

lemma ext {α : Sort*} :
  ∀{s t : setoid α}, (∀a b, @setoid.r α s a b ↔ @setoid.r α t a b) → s = t
| ⟨r, _⟩ ⟨p, _⟩ eq :=
  have r = p, from funext $ assume a, funext $ assume b, propext $ eq a b,
  by subst this

end setoid

namespace quot
variables {ra : α → α → Prop} {rb : β → β → Prop} {φ : quot ra → quot rb → Sort*}
local notation `⟦`:max a `⟧` := quot.mk _ a

instance [inhabited α] : inhabited (quot ra) := ⟨⟦default _⟧⟩

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quot ra) (qb : quot rb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (ca : ∀ {b a₁ a₂}, ra a₁ a₂ → f a₁ b == f a₂ b)
  (cb : ∀ {a b₁ b₂}, rb b₁ b₂ → f a b₁ == f a b₂) : φ qa qb :=
quot.hrec_on qa (λ a, quot.hrec_on qb (f a) (λ b₁ b₂ pb, cb pb)) $ λ a₁ a₂ pa,
  quot.induction_on qb $ λ b,
    calc @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₁) (@cb _)
          == f a₁ b                                     : by simp [heq_self_iff_true]
      ... == f a₂ b                                     : ca pa
      ... == @quot.hrec_on _ _ (φ _) ⟦b⟧ (f a₂) (@cb _) : by simp [heq_self_iff_true]

/-- Map a function `f : α → β` such that `ra x y` implies `rb (f x) (f y)`
to a map `quot ra → quot rb`. -/
protected def map (f : α → β) (h : (ra ⇒ rb) f f) : quot ra → quot rb :=
quot.lift (λ x, ⟦f x⟧) $ assume x y (h₁ : ra x y), quot.sound $ h h₁

/-- If `ra` is a subrelation of `ra'`, then we have a natural map `quot ra → quot ra'`. -/
protected def map_right {ra' : α → α → Prop} (h : ∀a₁ a₂, ra a₁ a₂ → ra' a₁ a₂) :
  quot ra → quot ra' :=
quot.map id h

/-- weaken the relation of a quotient -/
def factor {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  quot r → quot s :=
quot.lift (quot.mk s) (λ x y rxy, quot.sound (h x y rxy))

lemma factor_mk_eq {α : Type*} (r s : α → α → Prop) (h : ∀ x y, r x y → s x y) :
  factor r s h ∘ quot.mk _ = quot.mk _ := rfl

variables {γ : Sort*} {r : α → α → Prop} {s : β → β → Prop}

/-- **Alias** of `quot.lift_beta`. -/
lemma lift_mk (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) (a : α) :
  quot.lift f h (quot.mk r a) = f a := quot.lift_beta f h a

@[simp]
lemma lift_on_mk (a : α) (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) :
  quot.lift_on (quot.mk r a) f h = f a := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β`. -/
attribute [reducible, elab_as_eliminator]
protected def lift₂
  (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b)
  (q₁ : quot r) (q₂ : quot s) : γ :=
quot.lift (λ a, quot.lift (f a) (hr a))
(λ a₁ a₂ ha, funext (λ q, quot.induction_on q (λ b, hs a₁ a₂ b ha)))
q₁ q₂

@[simp]
lemma lift₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) (a : α) (b : β) :
  quot.lift₂ f hr hs (quot.mk r a) (quot.mk s b) = f a b := rfl

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` and applies it. -/
attribute [reducible, elab_as_eliminator]
protected def lift_on₂ (p : quot r) (q : quot s) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) : γ := quot.lift₂ f hr hs p q

@[simp]
lemma lift_on₂_mk (a : α) (b : β) (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → f a b₁ = f a b₂)
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → f a₁ b = f a₂ b) :
  quot.lift_on₂ (quot.mk r a) (quot.mk s b) f hr hs = f a b := rfl

variables {t : γ → γ → Prop}

/-- Descends a function `f : α → β → γ` to quotients of `α` and `β` wih values in a quotient of
`γ`. -/
protected def map₂ (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (q₁ : quot r) (q₂ : quot s) : quot t :=
quot.lift₂ (λ a b, quot.mk t $ f a b) (λ a b₁ b₂ hb, quot.sound (hr a b₁ b₂ hb))
(λ a₁ a₂ b ha, quot.sound (hs a₁ a₂ b ha)) q₁ q₂

@[simp]
lemma map₂_mk (f : α → β → γ)
  (hr : ∀ a b₁ b₂, s b₁ b₂ → t (f a b₁) (f a b₂))
  (hs : ∀ a₁ a₂ b, r a₁ a₂ → t (f a₁ b) (f a₂ b))
  (a : α) (b : β) : quot.map₂ f hr hs (quot.mk r a) (quot.mk s b) = quot.mk t (f a b) := rfl

attribute [elab_as_eliminator]
protected lemma induction_on₂
  {δ : quot r → quot s → Prop} (q₁ : quot r) (q₂ : quot s)
  (h : ∀ a b, δ (quot.mk r a) (quot.mk s b)) : δ q₁ q₂ :=
quot.ind (λ a₁, quot.ind (λ a₂, h a₁ a₂) q₂) q₁

attribute [elab_as_eliminator]
protected lemma induction_on₃
  {δ : quot r → quot s → quot t → Prop} (q₁ : quot r) (q₂ : quot s) (q₃ : quot t)
  (h : ∀ a b c, δ (quot.mk r a) (quot.mk s b) (quot.mk t c)) : δ q₁ q₂ q₃ :=
quot.ind (λ a₁, quot.ind (λ a₂, quot.ind (λ a₃, h a₁ a₂ a₃) q₃) q₂) q₁

end quot

namespace quotient
variables [sa : setoid α] [sb : setoid β]
variables {φ : quotient sa → quotient sb → Sort*}

instance [inhabited α] : inhabited (quotient sa) := ⟨⟦default _⟧⟩

/-- Induction on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂ (qa : quotient sa) (qb : quotient sb) (f : Π a b, φ ⟦a⟧ ⟦b⟧)
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quot.hrec_on₂ qa qb f
  (λ _ _ _ p, c _ _ _ _ p (setoid.refl _))
  (λ _ _ _ p, c _ _ _ _ (setoid.refl _) p)

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map (f : α → β) (h : ((≈) ⇒ (≈)) f f) : quotient sa → quotient sb :=
quot.map f h

@[simp] lemma map_mk (f : α → β) (h : ((≈) ⇒ (≈)) f f) (x : α) :
  quotient.map f h (⟦x⟧ : quotient sa) = (⟦f x⟧ : quotient sb) :=
rfl

variables {γ : Sort*} [sc : setoid γ]

/-- Map a function `f : α → β → γ` that sends equivalent elements to equivalent elements
to a function `f : quotient sa → quotient sb → quotient sc`.
Useful to define binary operations on quotients. -/
protected def map₂ (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) :
  quotient sa → quotient sb → quotient sc :=
quotient.lift₂ (λ x y, ⟦f x y⟧) (λ x₁ y₁ x₂ y₂ h₁ h₂, quot.sound $ h h₁ h₂)

end quotient

lemma quot.eq {α : Type*} {r : α → α → Prop} {x y : α} :
  quot.mk r x = quot.mk r y ↔ eqv_gen r x y :=
⟨quot.exact r, quot.eqv_gen_sound⟩

@[simp] theorem quotient.eq [r : setoid α] {x y : α} : ⟦x⟧ = ⟦y⟧ ↔ x ≈ y :=
⟨quotient.exact, quotient.sound⟩

theorem forall_quotient_iff {α : Type*} [r : setoid α] {p : quotient r → Prop} :
  (∀a:quotient r, p a) ↔ (∀a:α, p ⟦a⟧) :=
⟨assume h x, h _, assume h a, a.induction_on h⟩

@[simp] lemma quotient.lift_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift f h (quotient.mk x) = f x := rfl

@[simp] lemma quotient.lift_on_mk [s : setoid α] (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b)
  (x : α) :
  quotient.lift_on (quotient.mk x) f h = f x := rfl

@[simp] theorem quotient.lift_on₂_mk {α : Sort*} {β : Sort*} [setoid α] (f : α → α → β)
  (h : ∀ (a₁ a₂ b₁ b₂ : α), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (x y : α) :
  quotient.lift_on₂ (quotient.mk x) (quotient.mk y) f h = f x y := rfl

/-- `quot.mk r` is a surjective function. -/
lemma surjective_quot_mk (r : α → α → Prop) : function.surjective (quot.mk r) :=
quot.exists_rep

/-- `quotient.mk` is a surjective function. -/
lemma surjective_quotient_mk (α : Sort*) [s : setoid α] :
  function.surjective (quotient.mk : α → quotient s) :=
quot.exists_rep

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quot.out {r : α → α → Prop} (q : quot r) : α :=
classical.some (quot.exists_rep q)

/-- Unwrap the VM representation of a quotient to obtain an element of the equivalence class.
  Computable but unsound. -/
meta def quot.unquot {r : α → α → Prop} : quot r → α := unchecked_cast

@[simp] theorem quot.out_eq {r : α → α → Prop} (q : quot r) : quot.mk r q.out = q :=
classical.some_spec (quot.exists_rep q)

/-- Choose an element of the equivalence class using the axiom of choice.
  Sound but noncomputable. -/
noncomputable def quotient.out [s : setoid α] : quotient s → α := quot.out

@[simp] theorem quotient.out_eq [s : setoid α] (q : quotient s) : ⟦q.out⟧ = q := q.out_eq

theorem quotient.mk_out [s : setoid α] (a : α) : ⟦a⟧.out ≈ a :=
quotient.exact (quotient.out_eq _)

instance pi_setoid {ι : Sort*} {α : ι → Sort*} [∀ i, setoid (α i)] : setoid (Π i, α i) :=
{ r := λ a b, ∀ i, a i ≈ b i,
  iseqv := ⟨
    λ a i, setoid.refl _,
    λ a b h i, setoid.symm (h _),
    λ a b c h₁ h₂ i, setoid.trans (h₁ _) (h₂ _)⟩ }

/-- Given a function `f : Π i, quotient (S i)`, returns the class of functions `Π i, α i` sending
each `i` to an element of the class `f i`. -/
noncomputable def quotient.choice {ι : Type*} {α : ι → Type*} [S : Π i, setoid (α i)]
  (f : Π i, quotient (S i)) : @quotient (Π i, α i) (by apply_instance) :=
⟦λ i, (f i).out⟧

theorem quotient.choice_eq {ι : Type*} {α : ι → Type*} [Π i, setoid (α i)]
  (f : Π i, α i) : quotient.choice (λ i, ⟦f i⟧) = ⟦f⟧ :=
quotient.sound $ λ i, quotient.mk_out _

lemma nonempty_quotient_iff (s : setoid α) : nonempty (quotient s) ↔ nonempty α :=
⟨assume ⟨a⟩, quotient.induction_on a nonempty.intro, assume ⟨a⟩, ⟨⟦a⟧⟩⟩

/-- `trunc α` is the quotient of `α` by the always-true relation. This
  is related to the propositional truncation in HoTT, and is similar
  in effect to `nonempty α`, but unlike `nonempty α`, `trunc α` is data,
  so the VM representation is the same as `α`, and so this can be used to
  maintain computability. -/
def {u} trunc (α : Sort u) : Sort u := @quot α (λ _ _, true)

theorem true_equivalence : @equivalence α (λ _ _, true) :=
⟨λ _, trivial, λ _ _ _, trivial, λ _ _ _ _ _, trivial⟩

namespace trunc

/-- Constructor for `trunc α` -/
def mk (a : α) : trunc α := quot.mk _ a

instance [inhabited α] : inhabited (trunc α) := ⟨mk (default _)⟩

/-- Any constant function lifts to a function out of the truncation -/
def lift (f : α → β) (c : ∀ a b : α, f a = f b) : trunc α → β :=
quot.lift f (λ a b _, c a b)

theorem ind {β : trunc α → Prop} : (∀ a : α, β (mk a)) → ∀ q : trunc α, β q := quot.ind

protected theorem lift_mk (f : α → β) (c) (a : α) : lift f c (mk a) = f a := rfl

/-- Lift a constant function on `q : trunc α`. -/
@[reducible, elab_as_eliminator]
protected def lift_on (q : trunc α) (f : α → β)
  (c : ∀ a b : α, f a = f b) : β := lift f c q

@[elab_as_eliminator]
protected theorem induction_on {β : trunc α → Prop} (q : trunc α)
  (h : ∀ a, β (mk a)) : β q := ind h q

theorem exists_rep (q : trunc α) : ∃ a : α, mk a = q := quot.exists_rep q

attribute [elab_as_eliminator]
protected theorem induction_on₂ {C : trunc α → trunc β → Prop} (q₁ : trunc α) (q₂ : trunc β)
  (h : ∀ a b, C (mk a) (mk b)) : C q₁ q₂ :=
trunc.induction_on q₁ $ λ a₁, trunc.induction_on q₂ (h a₁)

protected theorem eq (a b : trunc α) : a = b :=
trunc.induction_on₂ a b (λ x y, quot.sound trivial)

instance : subsingleton (trunc α) := ⟨trunc.eq⟩

/-- The `bind` operator for the `trunc` monad. -/
def bind (q : trunc α) (f : α → trunc β) : trunc β :=
trunc.lift_on q f (λ a b, trunc.eq _ _)

/-- A function `f : α → β` defines a function `map f : trunc α → trunc β`. -/
def map (f : α → β) (q : trunc α) : trunc β := bind q (trunc.mk ∘ f)

instance : monad trunc :=
{ pure := @trunc.mk,
  bind := @trunc.bind }

instance : is_lawful_monad trunc :=
{ id_map := λ α q, trunc.eq _ _,
  pure_bind := λ α β q f, rfl,
  bind_assoc := λ α β γ x f g, trunc.eq _ _ }

variable {C : trunc α → Sort*}

/-- Recursion/induction principle for `trunc`. -/
@[reducible, elab_as_eliminator]
protected def rec
   (f : Π a, C (mk a)) (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b)
   (q : trunc α) : C q :=
quot.rec f (λ a b _, h a b) q

/-- A version of `trunc.rec` taking `q : trunc α` as the first argument. -/
@[reducible, elab_as_eliminator]
protected def rec_on (q : trunc α) (f : Π a, C (mk a))
  (h : ∀ (a b : α), (eq.rec (f a) (trunc.eq (mk a) (mk b)) : C (mk b)) = f b) : C q :=
trunc.rec f h q

/-- A version of `trunc.rec_on` assuming the codomain is a `subsingleton`. -/
@[reducible, elab_as_eliminator]
protected def rec_on_subsingleton
   [∀ a, subsingleton (C (mk a))] (q : trunc α) (f : Π a, C (mk a)) : C q :=
trunc.rec f (λ a b, subsingleton.elim _ (f b)) q

/-- Noncomputably extract a representative of `trunc α` (using the axiom of choice). -/
noncomputable def out : trunc α → α := quot.out

@[simp] theorem out_eq (q : trunc α) : mk q.out = q := trunc.eq _ _

protected theorem nonempty (q : trunc α) : nonempty α :=
nonempty_of_exists q.exists_rep

end trunc

namespace quotient
variables {γ : Sort*} {φ : Sort*}
  {s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}

/-! Versions of quotient definitions and lemmas ending in `'` use unification instead
of typeclass inference for inferring the `setoid` argument. This is useful when there are
several different quotient relations on a type, for example quotient groups, rings and modules. -/

/-- A version of `quotient.mk` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
protected def mk' (a : α) : quotient s₁ := quot.mk s₁.1 a

/-- `quotient.mk'` is a surjective function. -/
lemma surjective_quotient_mk' : function.surjective (quotient.mk' : α → quotient s₁) :=
quot.exists_rep

/-- A version of `quotient.lift_on` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator, reducible]
protected def lift_on' (q : quotient s₁) (f : α → φ)
  (h : ∀ a b, @setoid.r α s₁ a b → f a = f b) : φ := quotient.lift_on q f h

@[simp]
protected lemma lift_on'_mk' (f : α → φ) (h) (x : α) :
  quotient.lift_on' (@quotient.mk' _ s₁ x) f h = f x := rfl

/-- A version of `quotient.lift_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator, reducible]
protected def lift_on₂' (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → γ)
  (h : ∀ a₁ a₂ b₁ b₂, @setoid.r α s₁ a₁ b₁ → @setoid.r β s₂ a₂ b₂ → f a₁ a₂ = f b₁ b₂) : γ :=
quotient.lift_on₂ q₁ q₂ f h

@[simp]
protected lemma lift_on₂'_mk' (f : α → β → γ) (h) (a : α) (b : β) :
  quotient.lift_on₂' (@quotient.mk' _ s₁ a) (@quotient.mk' _ s₂ b) f h = f a b := rfl

/-- A version of `quotient.ind` taking `{s : setoid α}` as an implicit argument instead of an
instance argument. -/
@[elab_as_eliminator]
protected lemma ind' {p : quotient s₁ → Prop}
  (h : ∀ a, p (quotient.mk' a)) (q : quotient s₁) : p q :=
quotient.ind h q

/-- A version of `quotient.ind₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit arguments
instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma ind₂' {p : quotient s₁ → quotient s₂ → Prop}
  (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂))
  (q₁ : quotient s₁) (q₂ : quotient s₂) : p q₁ q₂ :=
quotient.ind₂ h q₁ q₂

/-- A version of `quotient.induction_on` taking `{s : setoid α}` as an implicit argument instead
of an instance argument. -/
@[elab_as_eliminator]
protected lemma induction_on' {p : quotient s₁ → Prop} (q : quotient s₁)
  (h : ∀ a, p (quotient.mk' a)) : p q := quotient.induction_on q h

/-- A version of `quotient.induction_on₂` taking `{s₁ : setoid α} {s₂ : setoid β}` as implicit
arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₂' {p : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁)
  (q₂ : quotient s₂) (h : ∀ a₁ a₂, p (quotient.mk' a₁) (quotient.mk' a₂)) : p q₁ q₂ :=
quotient.induction_on₂ q₁ q₂ h

/-- A version of `quotient.induction_on₃` taking `{s₁ : setoid α} {s₂ : setoid β} {s₃ : setoid γ}`
as implicit arguments instead of instance arguments. -/
@[elab_as_eliminator]
protected lemma induction_on₃' {p : quotient s₁ → quotient s₂ → quotient s₃ → Prop}
  (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃)
  (h : ∀ a₁ a₂ a₃, p (quotient.mk' a₁) (quotient.mk' a₂) (quotient.mk' a₃)) : p q₁ q₂ q₃ :=
quotient.induction_on₃ q₁ q₂ q₃ h

/-- A version of `quotient.rec_on_subsingleton` taking `{s₁ : setoid α}` as an implicit argument
instead of an instance argument. -/
@[elab_as_eliminator]
protected def rec_on_subsingleton' {φ : quotient s₁ → Sort*}
  [h : ∀ a, subsingleton (φ ⟦a⟧)] (q : quotient s₁) (f : Π a, φ (quotient.mk' a)) : φ q :=
quotient.rec_on_subsingleton q f

/-- A version of `quotient.rec_on_subsingleton₂` taking `{s₁ : setoid α} {s₂ : setoid α}`
as implicit arguments instead of instance arguments. -/
attribute [reducible, elab_as_eliminator]
protected def rec_on_subsingleton₂'
   {φ : quotient s₁ → quotient s₂ → Sort*} [h : ∀ a b, subsingleton (φ ⟦a⟧ ⟦b⟧)]
   (q₁ : quotient s₁) (q₂ : quotient s₂) (f : Π a₁ a₂, φ (quotient.mk' a₁) (quotient.mk' a₂)) :
   φ q₁ q₂ :=
quotient.rec_on_subsingleton₂ q₁ q₂ f

/-- Recursion on a `quotient` argument `a`, result type depends on `⟦a⟧`. -/
protected def hrec_on' {φ : quotient s₁ → Sort*} (qa : quotient s₁) (f : Π a, φ (quotient.mk' a))
  (c : ∀ a₁ a₂, a₁ ≈ a₂ → f a₁ == f a₂) : φ qa :=
quot.hrec_on qa f c

@[simp]

/-- Recursion on two `quotient` arguments `a` and `b`, result type depends on `⟦a⟧` and `⟦b⟧`. -/
protected def hrec_on₂' {φ : quotient s₁ → quotient s₂ → Sort*} (qa : quotient s₁)
  (qb : quotient s₂) (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) : φ qa qb :=
quotient.hrec_on₂ qa qb f c

@[simp] lemma hrec_on₂'_mk' {φ : quotient s₁ → quotient s₂ → Sort*}
  (f : ∀ a b, φ (quotient.mk' a) (quotient.mk' b))
  (c : ∀ a₁ b₁ a₂ b₂, a₁ ≈ a₂ → b₁ ≈ b₂ → f a₁ b₁ == f a₂ b₂) (x : α) (qb : quotient s₂) :
  (quotient.mk' x).hrec_on₂' qb f c = qb.hrec_on' (f x) (λ b₁ b₂, c _ _ _ _ (setoid.refl _)) :=
rfl

/-- Map a function `f : α → β` that sends equivalent elements to equivalent elements
to a function `quotient sa → quotient sb`. Useful to define unary operations on quotients. -/
protected def map' (f : α → β) (h : ((≈) ⇒ (≈)) f f) :
  quotient s₁ → quotient s₂ :=
quot.map f h

@[simp] lemma map'_mk' (f : α → β) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map' f h = (quotient.mk' (f x) : quotient s₂) :=
rfl

/-- A version of `quotient.map₂` using curly braces and unification. -/
protected def map₂' (f : α → β → γ) (h : ((≈) ⇒ (≈) ⇒ (≈)) f f) :
  quotient s₁ → quotient s₂ → quotient s₃ :=
quotient.map₂ f h

@[simp] lemma map₂'_mk' (f : α → β → γ) (h) (x : α) :
  (quotient.mk' x : quotient s₁).map₂' f h =
    (quotient.map' (f x) (h (setoid.refl x)) : quotient s₂ → quotient s₃) :=
rfl

lemma exact' {a b : α} :
  (quotient.mk' a : quotient s₁) = quotient.mk' b → @setoid.r _ s₁ a b :=
quotient.exact

lemma sound' {a b : α} : @setoid.r _ s₁ a b → @quotient.mk' α s₁ a = quotient.mk' b :=
quotient.sound

@[simp]
protected lemma eq' {a b : α} : @quotient.mk' α s₁ a = quotient.mk' b ↔ @setoid.r _ s₁ a b :=
quotient.eq

/-- A version of `quotient.out` taking `{s₁ : setoid α}` as an implicit argument instead of an
instance argument. -/
noncomputable def out' (a : quotient s₁) : α := quotient.out a

@[simp] theorem out_eq' (q : quotient s₁) : quotient.mk' q.out' = q := q.out_eq

theorem mk_out' (a : α) : @setoid.r α s₁ (quotient.mk' a : quotient s₁).out' a :=
quotient.exact (quotient.out_eq _)
end quotient


import .extensionality
import .boolean_algebra_tactic
import .finset_tactic
import tactic
import tactic.interactive
import .set_tactic

universe u

/-meta def simpl_tactic : tactic unit :=
`[simp only [simpl_sdiff, simpl_eq, ext_le, ext_bot, ext_top, ext_meet, ext_join, ext_compl] at *; tauto!]-/

-- TODO: Lots of things are boolean algebras.  We should have a way to configure
-- which boolean algebras we want to solve, actually.
--
-- Functions into boolean algebras are usually not useful, so we ignore them by default.
-- Moreover, hypotheses are either Prop or functions which indirectly produce a Prop,
-- so we really should probably ignore function types with Prop in them.
meta def get_boolalg_typ (consider_function_types := ff) (e : expr) : tactic (list expr) :=
  ((do
    `(%%boolalg_typ) <- tactic.infer_type e,
    match boolalg_typ with
    -- finset T gets returned directly
    | `(finset %%set_typ) := do return [boolalg_typ]
    -- set T gets returned directly
    | `(set %%set_typ) := do return [boolalg_typ]
    -- work needs to be done if we're not working with sets/finsets,
    -- but with a type with a [boolean_algebra T] instance on it.
    | _ := (do
        boolalg_hyp <- tactic.to_expr ``(infer_instance : boolean_algebra %%boolalg_typ),
        match boolalg_typ with
        -- Function types are usually not useful
        | `(_ -> _) := if consider_function_types then return [boolalg_typ] else return []
        -- Prop is not useful
        | `(Prop) := return []
        -- Other types, we can (probably) return
        | _ := return [boolalg_typ]
        end)
    end)
  <|>
    return [])

meta def boolean_algebra_types_in_expr (consider_function_types := ff) : expr → tactic (list expr)
| e :=
  do
    e_inner <- (match e with
      -- This mostly handles basic expressions
      | expr.local_const unique pretty _ _ := get_boolalg_typ consider_function_types e
      -- applications
      | expr.app e1 e2 :=
        do l1 <- boolean_algebra_types_in_expr e1,
          l2 <- boolean_algebra_types_in_expr e2,
          return (l1 ++ l2)
      -- abstracts
      | expr.lam _ _ argtyp body :=
        do l1 <- boolean_algebra_types_in_expr argtyp,
          l2 <- boolean_algebra_types_in_expr body,
          return (l1 ++ l2)
      | expr.pi _ _ argtyp body :=
        do l1 <- boolean_algebra_types_in_expr argtyp,
          l2 <- boolean_algebra_types_in_expr body,
          return (l1 ++ l2)
      | expr.elet _ argtyp argval body :=
        do l1 <- boolean_algebra_types_in_expr argtyp,
          l2 <- boolean_algebra_types_in_expr argval,
          l3 <- boolean_algebra_types_in_expr body,
          return (l1 ++ l2 ++ l3)
      | _ := return []
      end),
    e_outer <- get_boolalg_typ consider_function_types e,
    return (e_inner ++ e_outer)

def unique_list {T: Type*} [decidable_eq T]: list T -> list T
| [] := []
| (x :: xs) := let tl := unique_list xs in
                if list.mem x tl then tl else x :: tl

meta def infer_base_simp_lemmas (type : expr) : (tactic (list pexpr)) := do
  name <- tactic.get_unused_name `_instrw,
  instance_type <- tactic.to_expr ``(boolalg_ext_lemmas %%type _),
  expr <- tactic.to_expr ``(by apply_instance : %%instance_type),
  new_hyp <- tactic.assertv name instance_type expr,
  return [``((%%new_hyp).simpl_eq),
          ``((%%new_hyp).simpl_lt),
          ``((%%new_hyp).ext_le),
          ``((%%new_hyp).ext_bot),
          ``((%%new_hyp).ext_sdiff),
          ``((%%new_hyp).ext_meet),
          ``((%%new_hyp).ext_join)]

meta def infer_top_simp_lemmas (type : expr) : (tactic (list pexpr)) := (do
  name <- tactic.get_unused_name `_instrw,
  instance_type <- tactic.to_expr ``(boolalg_ext_lemmas_top %%type _),
  expr <- tactic.to_expr ``(by apply_instance : %%instance_type),
  new_hyp <- tactic.assertv name instance_type expr,
  return [``((%%new_hyp).ext_top)]) <|> return []

meta def infer_compl_simp_lemmas (type : expr) : (tactic (list pexpr)) := (do
  name <- tactic.get_unused_name `_instrw,
  instance_type <- tactic.to_expr ``(boolalg_ext_lemmas_compl %%type _),
  expr <- tactic.to_expr ``(by apply_instance : %%instance_type),
  new_hyp <- tactic.assertv name instance_type expr,
  return [``((%%new_hyp).ext_compl)]) <|> return []

meta def rewrite_for_type (type : expr) : (tactic unit) := do
  simp_lemmas <- infer_base_simp_lemmas type,
  compl_lemmas <- infer_compl_simp_lemmas type,
  top_lemmas <- infer_top_simp_lemmas type,
  tactic.try (tactic.interactive.simp none tt
              ((simp_lemmas ++ compl_lemmas ++ top_lemmas).map tactic.simp_arg_type.expr)
                  list.nil interactive.loc.wildcard),
  tactic.skip

meta def gather_types (consider_function_types := ff) : (tactic (list expr)) := do
  goal <- tactic.target,
  hyps <- tactic.local_context,
  types <- (do
            types_in_expr <- (goal :: hyps).mmap (boolean_algebra_types_in_expr consider_function_types),
            return (unique_list (list.foldr list.append [] types_in_expr))),
  --tactic.trace "Boolean algebra types:",
  --tactic.trace types,
  return types

meta def set_ext (consider_function_types := ff) : (tactic unit) := do
  tactic.try `[simp only [ne, ge, gt, superset, ssuperset] at *],
  tactic.try cleanup.finset_cleanup,
  tactic.try cleanup.set_cleanup,
  types <- gather_types consider_function_types,
  types.mmap rewrite_for_type,
  tactic.skip

meta def specialize_all (ename : expr) : (tactic unit) := do
  context <- tactic.local_context,
  context.mmap (fun hyp, tactic.try $ do
    pf <- tactic.to_expr ``(%%hyp %%ename),
    tactic.note `H none pf,
    tactic.skip),
  tactic.skip

meta def introduce_and_specialize : (tactic unit) := do
  target <- tactic.target,
  match target with
  | expr.lam nm _ argtyp body := do
    let basename := (if (nm.to_string = "ᾰ") then `H else nm) in do
    fname <- tactic.get_unused_name basename,
    exp <- tactic.intro fname,
    specialize_all exp
  | expr.pi nm _ argtyp body := do
    let basename := (if (nm.to_string = "ᾰ") then `H else nm) in do
    fname <- tactic.get_unused_name basename,
    ename <- tactic.intro fname,
    specialize_all ename
  | _ := tactic.fail "goal not an abstraction"
  end

meta def clear_existential_hyp (hyp : expr) : (tactic (option expr)) := do
  htyp <- tactic.infer_type hyp,
  match htyp with
  | `(@Exists _ _) := do
      [(_, [witness, _])] <- tactic.cases hyp,
      return (some witness)
  | _ := return none
  end

meta def forall_hypotheses (f : expr -> tactic unit) : (tactic unit) := do
  context <- tactic.local_context,
  result <- context.mmap (fun hyp, (f hyp >> return tt) <|> return ff),
  if (result.filter (fun (x : bool), x)).empty then
    tactic.fail "could not apply function to any hypothesis"
  else tactic.skip

meta def clear_existentials_hyp_and_specialize : (tactic unit) := do
  forall_hypotheses (fun hyp,
    do some witness <- clear_existential_hyp hyp, specialize_all witness
  ) <|> tactic.fail "no existentials present"

meta def clear_existential_goal : (tactic unit) := do
  target <- tactic.target,
  match target with
  | `(@Exists %%typ _) := do
    mvar <- tactic.mk_meta_var typ,
    tactic.existsi mvar,
    tactic.skip
  | _ := tactic.fail "goal is not existential"
  end

meta def split_hypothesis (hyp : expr) : (tactic unit) := do
  htyp <- tactic.infer_type hyp,
  match htyp with
  | `(_ /\ _) := tactic.cases hyp >> tactic.skip
  | _ := tactic.fail "hypothesis is not conjunction"
  end

meta def split_all_hypothesis : (tactic unit) := do
  forall_hypotheses split_hypothesis <|> tactic.fail "no conjunctions in hypothesis"

meta def split_goal : (tactic unit) := do
  target <- tactic.target,
  match target with
  | `(_ /\ _) := tactic.split >> tactic.skip
  | _ := tactic.fail "not a conjunction"
  end

meta def finisher_step : (tactic unit) := do
  -- push negatives everywhere
  tactic.try `[push_neg at *],
  tactic.try `[push_neg],
  -- try introducing a name and specializing
  introduce_and_specialize
  <|>
  -- if that fails, eliminate existentials in the goal by filling them in
  -- with a metavariable.
  -- maybe: fail instead?  We can't automatically determine what should go in.
  clear_existential_goal
  <|>
  -- if that fails, attempt to clear existentials
  clear_existentials_hyp_and_specialize
  <|>
  -- if that fails, split all hypothesis that are conjunctions
  split_all_hypothesis
  <|>
  -- if that fails, split the goal if it is a conjunction
  split_goal
  <|>
  -- if that fails, run tauto.
  -- TODO: fill in metavariables somehow introduced by existentials????
  -- this can be hard.
  `[tauto! {closer := tactic.tidy}]

meta def set_solver_finisher : (tactic unit) := do
  tactic.repeat finisher_step,
  -- we may have a list of goals -- we need to finish all of them
  -- in order to succeed.
  tactic.all_goals $ (
    tactic.target >>= (fun (target : expr),
    match target with
    -- if there is a disjunction in the goal, try either side
    | `(_ \/ _) := ((tactic.left >> set_solver_finisher) <|> (tactic.right >> set_solver_finisher)) >> tactic.skip
    -- if there is a disjucntion in the hypothesis, split it and make sure both sides work.
    | _ := (do
      mvar1 <- tactic.mk_mvar,
      mvar2 <- tactic.mk_mvar,
      disj <- tactic.find_assumption `(%%mvar1 \/ %%mvar2),
      -- if we can't find such as disjunction, then we fail as the finisher could not work.
      tactic.cases disj [],
      tactic.all_goals set_solver_finisher,
      tactic.skip)
    end)),
  tactic.skip

meta def set_solver (consider_function_types := ff) : (tactic unit) := do
  set_ext consider_function_types,
  set_solver_finisher

example (α : Type*) [boolean_algebra α] (X Y Z P Q W : α) :
  (X ⊔ (Y ⊔ Z)) ⊔ ((W ⊓ P ⊓ Q)ᶜ ⊔ (P ⊔ W ⊔ Q)) = ⊤ :=
begin
  set_solver,
end

example (T : Type*) [fintype T] [decidable_eq T] (X Y Z P Q W : finset T)  :
  (X ⊔ (Y ⊔ Z)) ⊔ ((W ⊓ P ⊓ Q)ᶜ ⊔ (P ⊔ W ⊔ Q)) = ⊤ :=
begin
  set_solver,
end

-- note the lack of fintype T here
example (T : Type*) [decidable_eq T] (X Y Z P Q W : finset T)  :
  (X ∪ Y) ≥ X :=
begin
  set_solver,
end

example (T : Type*) [decidable_eq T] (x z : T) (Y : set T) :
  x ∈ ({z} : set T) → x = z :=
begin
  set_solver,
end

example (α : Type*) [boolean_algebra α]  (A B C D E F G : α) :
  A ≤ B →
  B ≤ C →
  C ≤ D ⊓ E →
  D ≤ Fᶜ →
  (A ⊓ F = ⊥) :=
begin
  set_ext,
  tactic.timetac "fast" $ (`[repeat {finisher_step}]),
end

example (α : Type*) [boolean_algebra α]  (A B C D E F G : α) :
  A ≤ B →
  B ≤ C →
  C ≤ D ⊓ E →
  D ≤ Fᶜ →
  (A ⊓ F = ⊥) :=
begin
  tactic.timetac "slow" $ set_solver,
end

example (α : Type*) (C E : set α) (hCE : C ⊓ E = ∅) :
  C ⊔ (E ⊔ C)ᶜ = Eᶜ :=
by {set_solver, }

example (α : Type*) (C E : set α) (h : C ⊓ E = ⊥) :
  C ⊓ (C ⊔ E)ᶜ = ∅ :=
by {set_solver, }

example (X₀ X₁ X₂ X₃ X₄ X₅ X₆ X₇ X₈ X₉ : set nat) :
  (X₀ ⊔ X₁ ⊔ (X₂ ⊓ X₃) ⊔ X₄ ⊔ X₅ ⊔ (X₆ ⊓ X₇ ⊓ X₈) ⊔ X₉)ᶜ
    ≤ (X₉ᶜ ⊓ ((X₆ᶜ ⊔ ⊥) ⊔ X₈ᶜ ⊔ X₇ᶜᶜᶜ) ⊓ X₅ᶜ ⊓ (X₀ᶜ \ X₁) ⊓ (X₃ᶜ ⊔ X₂ᶜ) ⊓ X₄ᶜ) :=
begin
  tactic.timetac "big_ext" $ set_ext,
  tactic.timetac "big_finish" $ set_solver_finisher
end

/-
example (X₀ X₁ X₂ X₃ X₄ X₅ X₆ X₇ X₈ X₉ : α) :
  (X₀ ⊔ X₁ ⊔ (X₂ ⊓ X₃) ⊔ X₄ ⊔ X₅ ⊔ (X₆ ⊓ X₇ ⊓ X₈) ⊔ X₉)ᶜ
    ≤ (X₉ᶜ ⊓ ((X₆ᶜ ⊔ ⊥) ⊔ X₈ᶜ ⊔ X₇ᶜᶜᶜ) ⊓ X₅ᶜ ⊓ (X₀ᶜ \ X₁) ⊓ (X₃ᶜ ⊔ X₂ᶜ) ⊓ X₄ᶜ) :=
by tactic.timetac "big" $ boolean_algebra_tactic

example (A B C D E F G : α) :
  A ≤ B →
  B ≤ C →
  C ≤ D ⊓ E →
  A ≤ E :=
begin
  simp only [rw_sdiff, rw_eq, rw_le, rw_bot, rw_top, rw_sup, rw_inf, rw_compl] at *,
  intros H1 H2 H3 u H4,
  specialize (H1 u),
  specialize (H2 u),
  specialize (H3 u),
  tauto!
end

example (A B C D E F G : α) :
  A ≤ B →
  B ≤ C →
  C ≤ D ⊓ E →
  D ≤ Fᶜ →
  (A ⊓ F = ⊥) :=
begin
  simp only [rw_sdiff, rw_eq, rw_le, rw_bot, rw_top, rw_sup, rw_inf, rw_compl] at *,
  intros H1 H2 H3 H4,
  split;
  intro u, specialize (H1 u), specialize (H2 u), specialize (H3 u), specialize (H4 u), tauto!,
  tauto!,
end
-/


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.erase_dup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The fold operation for a commutative associative operation over a multiset.
-/

namespace multiset

/-! ### fold -/

/-- `fold op b s` folds a commutative associative operation `op` over
  the multiset `s`. -/
def fold {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] :
    α → multiset α → α :=
  foldr op sorry

theorem fold_eq_foldr {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (s : multiset α) :
    fold op b s = foldr op (left_comm op is_commutative.comm is_associative.assoc) b s :=
  rfl

@[simp] theorem coe_fold_r {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldr op b l :=
  rfl

theorem coe_fold_l {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldl op b l :=
  sorry

theorem fold_eq_foldl {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (s : multiset α) :
    fold op b s = foldl op (right_comm op is_commutative.comm is_associative.assoc) b s :=
  quot.induction_on s fun (l : List α) => coe_fold_l op b l

@[simp] theorem fold_zero {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) : fold op b 0 = b :=
  rfl

@[simp] theorem fold_cons_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (a : α) (s : multiset α) :
    fold op b (a ::ₘ s) = op a (fold op b s) :=
  foldr_cons op (fold._proof_1 op)

theorem fold_cons_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (a : α) (s : multiset α) :
    fold op b (a ::ₘ s) = op (fold op b s) a :=
  sorry

theorem fold_cons'_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (a : α) (s : multiset α) :
    fold op b (a ::ₘ s) = fold op (op b a) s :=
  sorry

theorem fold_cons'_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (a : α) (s : multiset α) :
    fold op b (a ::ₘ s) = fold op (op a b) s :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (fold op b (a ::ₘ s) = fold op (op a b) s)) (fold_cons'_right op b a s)))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (fold op (op b a) s = fold op (op a b) s)) (is_commutative.comm b a)))
      (Eq.refl (fold op (op a b) s)))

theorem fold_add {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b₁ : α) (b₂ : α) (s₁ : multiset α) (s₂ : multiset α) :
    fold op (op b₁ b₂) (s₁ + s₂) = op (fold op b₁ s₁) (fold op b₂ s₂) :=
  sorry

theorem fold_singleton {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] (b : α) (a : α) : fold op b (a ::ₘ 0) = op a b :=
  sorry

theorem fold_distrib {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] {f : β → α} {g : β → α} (u₁ : α) (u₂ : α) (s : multiset β) :
    fold op (op u₁ u₂) (map (fun (x : β) => op (f x) (g x)) s) =
        op (fold op u₁ (map f s)) (fold op u₂ (map g s)) :=
  sorry

theorem fold_hom {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] {op' : β → β → β} [is_commutative β op'] [is_associative β op']
    {m : α → β} (hm : ∀ (x y : α), m (op x y) = op' (m x) (m y)) (b : α) (s : multiset α) :
    fold op' (m b) (map m s) = m (fold op b s) :=
  sorry

theorem fold_union_inter {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) (b₁ : α)
    (b₂ : α) :
    op (fold op b₁ (s₁ ∪ s₂)) (fold op b₂ (s₁ ∩ s₂)) = op (fold op b₁ s₁) (fold op b₂ s₂) :=
  sorry

@[simp] theorem fold_erase_dup_idem {α : Type u_1} (op : α → α → α) [hc : is_commutative α op]
    [ha : is_associative α op] [DecidableEq α] [hi : is_idempotent α op] (s : multiset α) (b : α) :
    fold op b (erase_dup s) = fold op b s :=
  sorry

theorem le_smul_erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) :
    ∃ (n : ℕ), s ≤ n •ℕ erase_dup s :=
  sorry

end Mathlib


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tim Baumann, Stephen Morgan, Scott Morrison

Defines a functor between categories.

(As it is a 'bundled' object rather than the `is_functorial` typeclass parametrised
by the underlying function on objects, the name is capitalised.)

Introduces notations
  `C ⥤ D` for the type of all functors from `C` to `D`.
    (I would like a better arrow here, unfortunately ⇒ (`\functor`) is taken by core.)
  `F X` (a coercion) for a functor `F` acting on an object `X`.
-/

import category_theory.category
import tactic.tidy

namespace category_theory

universes u v u₁ v₁ u₂ v₂ u₃ v₃

/--
`functor C D` represents a functor between categories `C` and `D`.

To apply a functor `F` to an object use `F X` (which uses a coercion), and to a morphism use `F.map f`.

The axiom `map_id_lemma` expresses preservation of identities, and
`map_comp_lemma` expresses functoriality.

Implementation note: when constructing a `functor`, you need to define the
`map'` field (which does not know about the coercion).
When using a `functor`, use the `map` field (which makes use of the coercion).
-/
structure functor (C : Type u₁) [category.{u₁ v₁} C] (D : Type u₂) [category.{u₂ v₂} D] : Type (max u₁ v₁ u₂ v₂) :=
(obj       : C → D)
(map'      : Π {X Y : C}, (X ⟶ Y) → ((obj X) ⟶ (obj Y)))
(map_id'   : ∀ (X : C), map' (𝟙 X) = 𝟙 (obj X) . obviously)
(map_comp' : ∀ {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z), map' (f ≫ g) = (map' f) ≫ (map' g) . obviously)

infixr ` ⥤ `:70 := functor       -- type as \func --

namespace functor

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C] {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

instance : has_coe_to_fun (C ⥤ D) :=
{ F   := λ F, C → D,
  coe := λ F, F.obj }

def map (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) : (F X) ⟶ (F Y) := F.map' f

@[simp] lemma map_id (F : C ⥤ D) (X : C) : F.map (𝟙 X) = 𝟙 (F X) :=
begin unfold functor.map, erw F.map_id', refl end
@[simp] lemma map_comp (F : C ⥤ D) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  F.map (f ≫ g) = F.map f ≫ F.map g :=
begin unfold functor.map, erw F.map_comp' end

-- We define a refl lemma 'refolding' the coercion,
-- and two lemmas for the coercion applied to an explicit structure.
@[simp] lemma obj_eq_coe {F : C ⥤ D} (X : C) : F.obj X = F X := rfl
@[simp] lemma mk_obj (o : C → D) (m mi mc) (X : C) :
  ({ functor . obj := o, map' := m, map_id' := mi, map_comp' := mc } : C ⥤ D) X = o X := rfl
@[simp] lemma mk_map (o : C → D) (m mi mc) {X Y : C} (f : X ⟶ Y) :
  functor.map { functor . obj := o, map' := m, map_id' := mi, map_comp' := mc } f = m f := rfl
end

section
variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C]
include 𝒞

/-- `functor.id C` is the identity functor on a category `C`. -/
protected def id : C ⥤ C :=
{ obj      := λ X, X,
  map'     := λ _ _ f, f }

variable {C}

@[simp] lemma id_obj (X : C) : (functor.id C) X = X := rfl
@[simp] lemma id_map {X Y : C} (f : X ⟶ Y) : (functor.id C).map f = f := rfl
end

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
          {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
          {E : Type u₃} [ℰ : category.{u₃ v₃} E]
include 𝒞 𝒟 ℰ

/--
`F ⋙ G` is the composition of a functor `F` and a functor `G` (`F` first, then `G`).
-/
def comp (F : C ⥤ D) (G : D ⥤ E) : C ⥤ E :=
{ obj      := λ X, G (F X),
  map'      := λ _ _ f, G.map (F.map f) }

infixr ` ⋙ `:80 := comp

@[simp] lemma comp_obj (F : C ⥤ D) (G : D ⥤ E) (X : C) : (F ⋙ G) X = G (F X) := rfl
@[simp] lemma comp_map (F : C ⥤ D) (G : D ⥤ E) (X Y : C) (f : X ⟶ Y) :
  (F ⋙ G).map f = G.map (F.map f) := rfl
end

section
variables (C : Type u₁) [𝒞 : category.{u₁ v₁} C]
include 𝒞

@[simp] def ulift_down : (ulift.{u₂} C) ⥤ C :=
{ obj := λ X, X.down,
  map' := λ X Y f, f }

@[simp] def ulift_up : C ⥤ (ulift.{u₂} C) :=
{ obj := λ X, ⟨ X ⟩,
  map' := λ X Y f, f }
end

end functor

def bundled.map {c : Type u → Type v} {d : Type u → Type v} (f : Π{a}, c a → d a) (s : bundled c) : bundled d :=
{ α := s.α, str := f s.str }

def concrete_functor
  {C : Type u → Type v} {hC : ∀{α β}, C α → C β → (α → β) → Prop} [concrete_category @hC]
  {D : Type u → Type v} {hD : ∀{α β}, D α → D β → (α → β) → Prop} [concrete_category @hD]
  (m : ∀{α}, C α → D α) (h : ∀{α β} {ia : C α} {ib : C β} {f}, hC ia ib f → hD (m ia) (m ib) f) :
  bundled C ⥤ bundled D :=
{ obj := bundled.map @m,
  map' := λ X Y f, ⟨ f, h f.2 ⟩}

end category_theory