import testbed.graph_theory

import tactic
open simple_graph tactic

--------------------  TACTIC: GET ALL THEOREMS (or names, statements, proofs) --------------------

meta def get_thm_decls_env: tactic (list declaration) := do {
  env ←  get_env,
  -- get their declarations to filter them based on if they are theorems
  let all_decls := env.get_trusted_decls,
  let thm_decls := all_decls.filter (λ (d : declaration), d.is_theorem = tt), -- get the ones that are theorems (not axioms or defs)
  return thm_decls
}

--------------------  TACTIC: GET ALL THEOREMS (or names, statements, proofs) TAGGED BY PROBLEM DOMAIN E.G. GRAPH THEORY --------------------

meta def get_thm_decls (subject_area : name): tactic (list declaration) := do {
  -- get all statements from the subject area
  all_names  ← attribute.get_instances subject_area,
  -- get their declarations to filter them based on if they are theorems
  all_decls  ← all_names.mmap (λ n, tactic.get_decl n), -- get all graph theory theorems
  let thm_decls := all_decls.filter (λ (d : declaration), d.is_theorem = tt), -- get the ones that are theorems (not axioms or defs)
  return thm_decls
}

#eval get_thm_decls `graph_theory >>= λ thm_decls, do{ let thm_names := thm_decls.map (λd, d.to_name), return thm_names} >>= trace

--------------------  TACTIC: GET A PARTICULAR THEOREM BY NAME --------------------

meta def get_thm_decl (n : name): tactic declaration := do {
  thm_decls ← get_thm_decls_env,

  thm ←  thm_decls.mfirst (λ d, if d.to_name=n then return d else tactic.failed),
  return thm
}

#eval get_thm_decl `nat.add_one >>= trace
#eval get_thm_decl `degree_sum >>= trace

meta def get_thm_statement (n : name): tactic expr := do {
  thm_decl ← get_thm_decl n,

  return thm_decl.type
}

#eval get_thm_statement `degree_sum >>= trace

meta def get_thm_proof (n : name): tactic expr := do {
  thm_decl ← get_thm_decl n,

  return thm_decl.value
}

#eval get_thm_proof `degree_sum >>= trace

-- meta def get_thm_proofs (subject_area : name): tactic (list expr) := do {
--   thm_decls ← get_thm_decls subject_area,

--   let thm_proofs := thm_decls.map (λd, d.value),
--   return thm_proofs
-- }


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.data.vector2
import Mathlib.PostPort

universes u u_1 w v

namespace Mathlib

namespace d_array

protected instance inhabited {n : ℕ} {α : fin n → Type u} [(i : fin n) → Inhabited (α i)] :
    Inhabited (d_array n α) :=
  { default := mk fun (_x : fin n) => Inhabited.default }

end d_array

namespace array

protected instance inhabited {n : ℕ} {α : Type u_1} [Inhabited α] : Inhabited (array n α) :=
  d_array.inhabited

theorem to_list_of_heq {n₁ : ℕ} {n₂ : ℕ} {α : Type u_1} {a₁ : array n₁ α} {a₂ : array n₂ α}
    (hn : n₁ = n₂) (ha : a₁ == a₂) : to_list a₁ = to_list a₂ :=
  sorry

/- rev_list -/

theorem rev_list_reverse_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i ≤ n) (t : List α) :
    list.reverse_core
          (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) t =
        d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h t :=
  sorry

@[simp] theorem rev_list_reverse {n : ℕ} {α : Type u} {a : array n α} :
    list.reverse (rev_list a) = to_list a :=
  rev_list_reverse_aux n d_array.iterate._proof_1 []

@[simp] theorem to_list_reverse {n : ℕ} {α : Type u} {a : array n α} :
    list.reverse (to_list a) = rev_list a :=
  sorry

/- mem -/

theorem mem.def {n : ℕ} {α : Type u} {v : α} {a : array n α} :
    v ∈ a ↔ ∃ (i : fin n), read a i = v :=
  iff.rfl

theorem mem_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} {i : ℕ} (h : i ≤ n) :
    (∃ (j : fin n), ↑j < i ∧ read a j = v) ↔
        v ∈ d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h [] :=
  sorry

@[simp] theorem mem_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} :
    v ∈ rev_list a ↔ v ∈ a :=
  sorry

@[simp] theorem mem_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ to_list a ↔ v ∈ a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (v ∈ to_list a ↔ v ∈ a)) (Eq.symm rev_list_reverse)))
    (iff.trans list.mem_reverse mem_rev_list)

/- foldr -/

theorem rev_list_foldr_aux {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α}
    {i : ℕ} (h : i ≤ n) :
    list.foldr f b
          (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) =
        d_array.iterate_aux a (fun (_x : fin n) => f) i h b :=
  sorry

theorem rev_list_foldr {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α} :
    list.foldr f b (rev_list a) = foldl a b f :=
  rev_list_foldr_aux d_array.iterate._proof_1

/- foldl -/

theorem to_list_foldl {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : β → α → β} {a : array n α} :
    list.foldl f b (to_list a) = foldl a b (function.swap f) :=
  sorry

/- length -/

theorem rev_list_length_aux {n : ℕ} {α : Type u} (a : array n α) (i : ℕ) (h : i ≤ n) :
    list.length
          (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) =
        i :=
  sorry

@[simp] theorem rev_list_length {n : ℕ} {α : Type u} (a : array n α) :
    list.length (rev_list a) = n :=
  rev_list_length_aux a n d_array.iterate._proof_1

@[simp] theorem to_list_length {n : ℕ} {α : Type u} (a : array n α) : list.length (to_list a) = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (list.length (to_list a) = n)) (Eq.symm rev_list_reverse)))
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (list.length (list.reverse (rev_list a)) = n))
          (list.length_reverse (rev_list a))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (list.length (rev_list a) = n)) (rev_list_length a)))
        (Eq.refl n)))

/- nth -/

theorem to_list_nth_le_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (ih : i < n) (j : ℕ)
    {jh : j ≤ n} {t : List α}
    {h' :
      i <
        list.length
          (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh
            t)} :
    (∀ (k : ℕ) (tl : k < list.length t),
          j + k = i → list.nth_le t k tl = read a { val := i, property := ih }) →
        list.nth_le
            (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh t)
            i h' =
          read a { val := i, property := ih } :=
  sorry

theorem to_list_nth_le {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i < n)
    (h' : i < list.length (to_list a)) :
    list.nth_le (to_list a) i h' = read a { val := i, property := h } :=
  to_list_nth_le_aux i h n fun (k : ℕ) (tl : k < list.length []) => absurd tl (nat.not_lt_zero k)

@[simp] theorem to_list_nth_le' {n : ℕ} {α : Type u} (a : array n α) (i : fin n)
    (h' : ↑i < list.length (to_list a)) : list.nth_le (to_list a) (↑i) h' = read a i :=
  sorry

theorem to_list_nth {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} :
    list.nth (to_list a) i = some v ↔ ∃ (h : i < n), read a { val := i, property := h } = v :=
  sorry

theorem write_to_list {n : ℕ} {α : Type u} {a : array n α} {i : fin n} {v : α} :
    to_list (write a i v) = list.update_nth (to_list a) (↑i) v :=
  sorry

/- enum -/

theorem mem_to_list_enum {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} :
    (i, v) ∈ list.enum (to_list a) ↔ ∃ (h : i < n), read a { val := i, property := h } = v :=
  sorry

/- to_array -/

@[simp] theorem to_list_to_array {n : ℕ} {α : Type u} (a : array n α) :
    list.to_array (to_list a) == a :=
  sorry

@[simp] theorem to_array_to_list {α : Type u} (l : List α) : to_list (list.to_array l) = l :=
  list.ext_le (to_list_length (list.to_array l))
    fun (n : ℕ) (h1 : n < list.length (to_list (list.to_array l))) (h2 : n < list.length l) =>
      to_list_nth_le n h2 h1

/- push_back -/

theorem push_back_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} (i : ℕ) (h : i ≤ n + 1)
    (h' : i ≤ n) :
    d_array.iterate_aux (push_back a v) (fun (_x : fin (n + 1)) (_x : α) (_y : List α) => _x :: _y)
          i h [] =
        d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h' [] :=
  sorry

@[simp] theorem push_back_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} :
    rev_list (push_back a v) = v :: rev_list a :=
  sorry

@[simp] theorem push_back_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} :
    to_list (push_back a v) = to_list a ++ [v] :=
  sorry

/- foreach -/

@[simp] theorem read_foreach {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : fin n → α → β}
    {a : array n α} : read (foreach a f) i = f i (read a i) :=
  rfl

/- map -/

theorem read_map {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : α → β} {a : array n α} :
    read (map a f) i = f (read a i) :=
  read_foreach

/- map₂ -/

@[simp] theorem read_map₂ {n : ℕ} {α : Type u} {i : fin n} {f : α → α → α} {a₁ : array n α}
    {a₂ : array n α} : read (map₂ f a₁ a₂) i = f (read a₁ i) (read a₂ i) :=
  read_foreach

end array

namespace equiv

/-- The natural equivalence between length-`n` heterogeneous arrays
and dependent functions from `fin n`. -/
def d_array_equiv_fin {n : ℕ} (α : fin n → Type u_1) : d_array n α ≃ ((i : fin n) → α i) :=
  mk d_array.read d_array.mk sorry sorry

/-- The natural equivalence between length-`n` arrays and functions from `fin n`. -/
def array_equiv_fin (n : ℕ) (α : Type u_1) : array n α ≃ (fin n → α) :=
  d_array_equiv_fin fun (_x : fin n) => α

/-- The natural equivalence between length-`n` vectors and functions from `fin n`. -/
def vector_equiv_fin (α : Type u_1) (n : ℕ) : vector α n ≃ (fin n → α) :=
  mk vector.nth vector.of_fn vector.of_fn_nth sorry

/-- The natural equivalence between length-`n` vectors and length-`n` arrays. -/
def vector_equiv_array (α : Type u_1) (n : ℕ) : vector α n ≃ array n α :=
  equiv.trans (vector_equiv_fin α n) (equiv.symm (array_equiv_fin n α))

end equiv

namespace array

protected instance traversable {n : ℕ} : traversable (array n) :=
  equiv.traversable fun (α : Type u_1) => equiv.vector_equiv_array α n

protected instance is_lawful_traversable {n : ℕ} : is_lawful_traversable (array n) :=
  equiv.is_lawful_traversable fun (α : Type u_1) => equiv.vector_equiv_array α n

end Mathlib


example (p q r : Prop) (hp : p) (hq : q) (hr : r) : p ∧ q ∧ r :=
  by split; try { split }; assumption


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather
-/
import tactic.pi_instances

/-!
# Bundled types

`bundled c` provides a uniform structure for bundling a type equipped with a type class.

We provide `category` instances for these in `category_theory/unbundled_hom.lean`
(for categories with unbundled homs, e.g. topological spaces)
and in `category_theory/bundled_hom.lean` (for categories with bundled homs, e.g. monoids).
-/

universes u v

namespace category_theory
variables {c d : Type u → Type v} {α : Type u}

/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
@[nolint has_inhabited_instance]
structure bundled (c : Type u → Type v) : Type (max (u+1) v) :=
(α : Type u)
(str : c α . tactic.apply_instance)

namespace bundled

/-- A generic function for lifting a type equipped with an instance to a bundled object. -/
-- Usually explicit instances will provide their own version of this, e.g. `Mon.of` and `Top.of`.
def of {c : Type u → Type v} (α : Type u) [str : c α] : bundled c := ⟨α, str⟩

instance : has_coe_to_sort (bundled c) (Type u) := ⟨bundled.α⟩

@[simp] lemma coe_mk (α) (str) : (@bundled.mk c α str : Type u) = α := rfl

/-
`bundled.map` is reducible so that, if we define a category

  def Ring : Type (u+1) := induced_category SemiRing (bundled.map @ring.to_semiring)

instance search is able to "see" that a morphism R ⟶ S in Ring is really
a (semi)ring homomorphism from R.α to S.α, and not merely from
`(bundled.map @ring.to_semiring R).α` to `(bundled.map @ring.to_semiring S).α`.
-/
/-- Map over the bundled structure -/
@[reducible] def map (f : Π {α}, c α → d α) (b : bundled c) : bundled d :=
⟨b, f b.str⟩

end bundled

end category_theory


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.shapes.products
import category_theory.limits.shapes.images
import category_theory.isomorphism_classes
import category_theory.limits.shapes.zero_objects

/-!
# Zero morphisms and zero objects

A category "has zero morphisms" if there is a designated "zero morphism" in each morphism space,
and compositions of zero morphisms with anything give the zero morphism. (Notice this is extra
structure, not merely a property.)

A category "has a zero object" if it has an object which is both initial and terminal. Having a
zero object provides zero morphisms, as the unique morphisms factoring through the zero object.

## References

* https://en.wikipedia.org/wiki/Zero_morphism
* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
-/

noncomputable theory

universes v u
universes v' u'

open category_theory
open category_theory.category
open_locale classical

namespace category_theory.limits

variables (C : Type u) [category.{v} C]
variables (D : Type u') [category.{v'} D]

/-- A category "has zero morphisms" if there is a designated "zero morphism" in each morphism space,
and compositions of zero morphisms with anything give the zero morphism. -/
class has_zero_morphisms :=
[has_zero : Π X Y : C, has_zero (X ⟶ Y)]
(comp_zero' : ∀ {X Y : C} (f : X ⟶ Y) (Z : C), f ≫ (0 : Y ⟶ Z) = (0 : X ⟶ Z) . obviously)
(zero_comp' : ∀ (X : C) {Y Z : C} (f : Y ⟶ Z), (0 : X ⟶ Y) ≫ f = (0 : X ⟶ Z) . obviously)

attribute [instance] has_zero_morphisms.has_zero
restate_axiom has_zero_morphisms.comp_zero'
restate_axiom has_zero_morphisms.zero_comp'

variables {C}

@[simp] lemma comp_zero [has_zero_morphisms C] {X Y : C} {f : X ⟶ Y} {Z : C} :
  f ≫ (0 : Y ⟶ Z) = (0 : X ⟶ Z) := has_zero_morphisms.comp_zero f Z
@[simp] lemma zero_comp [has_zero_morphisms C] {X : C} {Y Z : C} {f : Y ⟶ Z} :
  (0 : X ⟶ Y) ≫ f = (0 : X ⟶ Z) := has_zero_morphisms.zero_comp X f

instance has_zero_morphisms_pempty : has_zero_morphisms (discrete pempty) :=
{ has_zero := by tidy }

instance has_zero_morphisms_punit : has_zero_morphisms (discrete punit) :=
{ has_zero := by tidy }

namespace has_zero_morphisms
variables {C}

/-- This lemma will be immediately superseded by `ext`, below. -/
private lemma ext_aux (I J : has_zero_morphisms C)
  (w : ∀ X Y : C, (@has_zero_morphisms.has_zero _ _ I X Y).zero =
    (@has_zero_morphisms.has_zero _ _ J X Y).zero) : I = J :=
begin
  casesI I, casesI J,
  congr,
  { ext X Y,
    exact w X Y },
  { apply proof_irrel_heq, },
  { apply proof_irrel_heq, }
end

/--
If you're tempted to use this lemma "in the wild", you should probably
carefully consider whether you've made a mistake in allowing two
instances of `has_zero_morphisms` to exist at all.

See, particularly, the note on `zero_morphisms_of_zero_object` below.
-/
lemma ext (I J : has_zero_morphisms C) : I = J :=
begin
  apply ext_aux,
  intros X Y,
  rw ←@has_zero_morphisms.comp_zero _ _ I X X (@has_zero_morphisms.has_zero _ _ J X X).zero,
  rw @has_zero_morphisms.zero_comp _ _ J,
end

instance : subsingleton (has_zero_morphisms C) :=
⟨ext⟩

end has_zero_morphisms

open opposite has_zero_morphisms

instance has_zero_morphisms_opposite [has_zero_morphisms C] :
  has_zero_morphisms Cᵒᵖ :=
{ has_zero := λ X Y, ⟨(0 : unop Y ⟶ unop X).op⟩,
  comp_zero' := λ X Y f Z, congr_arg quiver.hom.op (has_zero_morphisms.zero_comp (unop Z) f.unop),
  zero_comp' := λ X Y Z f, congr_arg quiver.hom.op (has_zero_morphisms.comp_zero f.unop (unop X)), }

section
variables {C} [has_zero_morphisms C]

lemma zero_of_comp_mono {X Y Z : C} {f : X ⟶ Y} (g : Y ⟶ Z) [mono g] (h : f ≫ g = 0) : f = 0 :=
by { rw [←zero_comp, cancel_mono] at h, exact h }

lemma zero_of_epi_comp {X Y Z : C} (f : X ⟶ Y) {g : Y ⟶ Z} [epi f] (h : f ≫ g = 0) : g = 0 :=
by { rw [←comp_zero, cancel_epi] at h, exact h }

lemma eq_zero_of_image_eq_zero {X Y : C} {f : X ⟶ Y} [has_image f] (w : image.ι f = 0) : f = 0 :=
by rw [←image.fac f, w, has_zero_morphisms.comp_zero]

lemma nonzero_image_of_nonzero {X Y : C} {f : X ⟶ Y} [has_image f] (w : f ≠ 0) : image.ι f ≠ 0 :=
λ h, w (eq_zero_of_image_eq_zero h)
end

section

variables [has_zero_morphisms D]

instance : has_zero_morphisms (C ⥤ D) :=
{ has_zero := λ F G, ⟨{ app := λ X, 0, }⟩ }

@[simp] lemma zero_app (F G : C ⥤ D) (j : C) : (0 : F ⟶ G).app j = 0 := rfl

end

namespace is_zero
variables [has_zero_morphisms C]

lemma eq_zero_of_src {X Y : C} (o : is_zero X) (f : X ⟶ Y) : f = 0 :=
o.eq_of_src _ _

lemma eq_zero_of_tgt {X Y : C} (o : is_zero Y) (f : X ⟶ Y) : f = 0 :=
o.eq_of_tgt _ _

lemma iff_id_eq_zero (X : C) : is_zero X ↔ (𝟙 X = 0) :=
⟨λ h, h.eq_of_src _ _,
 λ h, ⟨
  λ Y, ⟨⟨⟨0⟩, λ f, by { rw [←id_comp f, ←id_comp default, h, zero_comp, zero_comp], }⟩⟩,
  λ Y, ⟨⟨⟨0⟩, λ f, by { rw [←comp_id f, ←comp_id default, h, comp_zero, comp_zero], }⟩⟩⟩⟩

lemma of_mono_zero (X Y : C) [mono (0 : X ⟶ Y)] : is_zero X :=
(iff_id_eq_zero X).mpr ((cancel_mono (0 : X ⟶ Y)).1 (by simp))

lemma of_epi_zero (X Y : C) [epi (0 : X ⟶ Y)] : is_zero Y :=
(iff_id_eq_zero Y).mpr ((cancel_epi (0 : X ⟶ Y)).1 (by simp))

lemma of_mono_eq_zero {X Y : C} (f : X ⟶ Y) [mono f] (h : f = 0) : is_zero X :=
by { unfreezingI { subst h, }, apply of_mono_zero X Y, }

lemma of_epi_eq_zero {X Y : C} (f : X ⟶ Y) [epi f] (h : f = 0) : is_zero Y :=
by { unfreezingI { subst h, }, apply of_epi_zero X Y, }

lemma iff_split_mono_eq_zero {X Y : C} (f : X ⟶ Y) [split_mono f] : is_zero X ↔ f = 0 :=
begin
  rw iff_id_eq_zero,
  split,
  { intro h, rw [←category.id_comp f, h, zero_comp], },
  { intro h, rw [←split_mono.id f], simp [h], },
end

lemma iff_split_epi_eq_zero {X Y : C} (f : X ⟶ Y) [split_epi f] : is_zero Y ↔ f = 0 :=
begin
  rw iff_id_eq_zero,
  split,
  { intro h, rw [←category.comp_id f, h, comp_zero], },
  { intro h, rw [←split_epi.id f], simp [h], },
end

lemma of_mono {X Y : C} (f : X ⟶ Y) [mono f] (i : is_zero Y) : is_zero X :=
begin
  unfreezingI { have hf := i.eq_zero_of_tgt f, subst hf, },
  exact is_zero.of_mono_zero X Y,
end

lemma of_epi {X Y : C} (f : X ⟶ Y) [epi f] (i : is_zero X) : is_zero Y :=
begin
  unfreezingI { have hf := i.eq_zero_of_src f, subst hf, },
  exact is_zero.of_epi_zero X Y,
end

end is_zero

/-- A category with a zero object has zero morphisms.

    It is rarely a good idea to use this. Many categories that have a zero object have zero
    morphisms for some other reason, for example from additivity. Library code that uses
    `zero_morphisms_of_zero_object` will then be incompatible with these categories because
    the `has_zero_morphisms` instances will not be definitionally equal. For this reason library
    code should generally ask for an instance of `has_zero_morphisms` separately, even if it already
    asks for an instance of `has_zero_objects`. -/
def is_zero.has_zero_morphisms {O : C} (hO : is_zero O) : has_zero_morphisms C :=
{ has_zero := λ X Y,
  { zero := hO.from X ≫ hO.to Y },
  zero_comp' := λ X Y Z f, by { rw category.assoc, congr, apply hO.eq_of_src, },
  comp_zero' := λ X Y Z f, by { rw ←category.assoc, congr, apply hO.eq_of_tgt, }}

namespace has_zero_object

variables [has_zero_object C]
open_locale zero_object

/-- A category with a zero object has zero morphisms.

    It is rarely a good idea to use this. Many categories that have a zero object have zero
    morphisms for some other reason, for example from additivity. Library code that uses
    `zero_morphisms_of_zero_object` will then be incompatible with these categories because
    the `has_zero_morphisms` instances will not be definitionally equal. For this reason library
    code should generally ask for an instance of `has_zero_morphisms` separately, even if it already
    asks for an instance of `has_zero_objects`. -/
def zero_morphisms_of_zero_object : has_zero_morphisms C :=
{ has_zero := λ X Y,
  { zero := (default : X ⟶ 0) ≫ default },
  zero_comp' := λ X Y Z f, by { dunfold has_zero.zero, rw category.assoc, congr, },
  comp_zero' := λ X Y Z f, by { dunfold has_zero.zero, rw ←category.assoc, congr, }}

section has_zero_morphisms
variables [has_zero_morphisms C]

@[simp] lemma zero_iso_is_initial_hom {X : C} (t : is_initial X) :
  (zero_iso_is_initial t).hom = 0 :=
by ext

@[simp] lemma zero_iso_is_initial_inv {X : C} (t : is_initial X) :
  (zero_iso_is_initial t).inv = 0 :=
by ext

@[simp] lemma zero_iso_is_terminal_hom {X : C} (t : is_terminal X) :
  (zero_iso_is_terminal t).hom = 0 :=
by ext

@[simp] lemma zero_iso_is_terminal_inv {X : C} (t : is_terminal X) :
  (zero_iso_is_terminal t).inv = 0 :=
by ext

@[simp] lemma zero_iso_initial_hom [has_initial C] : zero_iso_initial.hom = (0 : 0 ⟶ ⊥_ C) :=
by ext

@[simp] lemma zero_iso_initial_inv [has_initial C] : zero_iso_initial.inv = (0 : ⊥_ C ⟶ 0) :=
by ext

@[simp]

@[simp] lemma zero_iso_terminal_inv [has_terminal C] : zero_iso_terminal.inv = (0 : ⊤_ C ⟶ 0) :=
by ext

end has_zero_morphisms

open_locale zero_object

instance {B : Type*} [category B] : has_zero_object (B ⥤ C) :=
(((category_theory.functor.const B).obj (0 : C)).is_zero $ λ X, is_zero_zero _).has_zero_object

end has_zero_object

open_locale zero_object

variables {D}

@[simp] lemma is_zero.map [has_zero_object D] [has_zero_morphisms D] {F : C ⥤ D} (hF : is_zero F)
  {X Y : C} (f : X ⟶ Y) : F.map f = 0 :=
(hF.obj _).eq_of_src _ _

@[simp] lemma _root_.category_theory.functor.zero_obj [has_zero_object D]
  (X : C) : is_zero ((0 : C ⥤ D).obj X) :=
(is_zero_zero _).obj _

@[simp] lemma _root_.category_theory.zero_map [has_zero_object D] [has_zero_morphisms D]
  {X Y : C} (f : X ⟶ Y) : (0 : C ⥤ D).map f = 0 :=
(is_zero_zero _).map _

section
variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

@[simp]
lemma id_zero : 𝟙 (0 : C) = (0 : 0 ⟶ 0) :=
by ext

/--  An arrow ending in the zero object is zero -/
-- This can't be a `simp` lemma because the left hand side would be a metavariable.
lemma zero_of_to_zero {X : C} (f : X ⟶ 0) : f = 0 :=
by ext

lemma zero_of_target_iso_zero {X Y : C} (f : X ⟶ Y) (i : Y ≅ 0) : f = 0 :=
begin
  have h : f = f ≫ i.hom ≫ 𝟙 0 ≫ i.inv := by simp only [iso.hom_inv_id, id_comp, comp_id],
  simpa using h,
end

/-- An arrow starting at the zero object is zero -/
lemma zero_of_from_zero {X : C} (f : 0 ⟶ X) : f = 0 :=
by ext

lemma zero_of_source_iso_zero {X Y : C} (f : X ⟶ Y) (i : X ≅ 0) : f = 0 :=
begin
  have h : f = i.hom ≫ 𝟙 0 ≫ i.inv ≫ f := by simp only [iso.hom_inv_id_assoc, id_comp, comp_id],
  simpa using h,
end

lemma zero_of_source_iso_zero' {X Y : C} (f : X ⟶ Y) (i : is_isomorphic X 0) : f = 0 :=
zero_of_source_iso_zero f (nonempty.some i)
lemma zero_of_target_iso_zero' {X Y : C} (f : X ⟶ Y) (i : is_isomorphic Y 0) : f = 0 :=
zero_of_target_iso_zero f (nonempty.some i)

lemma mono_of_source_iso_zero {X Y : C} (f : X ⟶ Y) (i : X ≅ 0) : mono f :=
⟨λ Z g h w, by rw [zero_of_target_iso_zero g i, zero_of_target_iso_zero h i]⟩

lemma epi_of_target_iso_zero {X Y : C} (f : X ⟶ Y) (i : Y ≅ 0) : epi f :=
⟨λ Z g h w, by rw [zero_of_source_iso_zero g i, zero_of_source_iso_zero h i]⟩

/--
An object `X` has `𝟙 X = 0` if and only if it is isomorphic to the zero object.

Because `X ≅ 0` contains data (even if a subsingleton), we express this `↔` as an `≃`.
-/
def id_zero_equiv_iso_zero (X : C) : (𝟙 X = 0) ≃ (X ≅ 0) :=
{ to_fun    := λ h, { hom := 0, inv := 0, },
  inv_fun   := λ i, zero_of_target_iso_zero (𝟙 X) i,
  left_inv  := by tidy,
  right_inv := by tidy, }

@[simp]
lemma id_zero_equiv_iso_zero_apply_hom (X : C) (h : 𝟙 X = 0) :
  ((id_zero_equiv_iso_zero X) h).hom = 0 := rfl

@[simp]
lemma id_zero_equiv_iso_zero_apply_inv (X : C) (h : 𝟙 X = 0) :
  ((id_zero_equiv_iso_zero X) h).inv = 0 := rfl

/-- If `0 : X ⟶ Y` is an monomorphism, then `X ≅ 0`. -/
@[simps]
def iso_zero_of_mono_zero {X Y : C} (h : mono (0 : X ⟶ Y)) : X ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := (cancel_mono (0 : X ⟶ Y)).mp (by simp) }

/-- If `0 : X ⟶ Y` is an epimorphism, then `Y ≅ 0`. -/
@[simps]
def iso_zero_of_epi_zero {X Y : C} (h : epi (0 : X ⟶ Y)) : Y ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' := (cancel_epi (0 : X ⟶ Y)).mp (by simp) }

/-- If a monomorphism out of `X` is zero, then `X ≅ 0`. -/
def iso_zero_of_mono_eq_zero {X Y : C} {f : X ⟶ Y} [mono f] (h : f = 0) : X ≅ 0 :=
by { unfreezingI { subst h, }, apply iso_zero_of_mono_zero ‹_›, }

/-- If an epimorphism in to `Y` is zero, then `Y ≅ 0`. -/
def iso_zero_of_epi_eq_zero {X Y : C} {f : X ⟶ Y} [epi f] (h : f = 0) : Y ≅ 0 :=
by { unfreezingI { subst h, }, apply iso_zero_of_epi_zero ‹_›, }

/-- If an object `X` is isomorphic to 0, there's no need to use choice to construct
an explicit isomorphism: the zero morphism suffices. -/
def iso_of_is_isomorphic_zero {X : C} (P : is_isomorphic X 0) : X ≅ 0 :=
{ hom := 0,
  inv := 0,
  hom_inv_id' :=
  begin
    casesI P,
    rw ←P.hom_inv_id,
    rw ←category.id_comp P.inv,
    simp,
  end,
  inv_hom_id' := by simp, }

end

section is_iso
variables [has_zero_morphisms C]

/--
A zero morphism `0 : X ⟶ Y` is an isomorphism if and only if
the identities on both `X` and `Y` are zero.
-/
@[simps]
def is_iso_zero_equiv (X Y : C) : is_iso (0 : X ⟶ Y) ≃ (𝟙 X = 0 ∧ 𝟙 Y = 0) :=
{ to_fun := by { introsI i, rw ←is_iso.hom_inv_id (0 : X ⟶ Y),
    rw ←is_iso.inv_hom_id (0 : X ⟶ Y), simp },
  inv_fun := λ h, ⟨⟨(0 : Y ⟶ X), by tidy⟩⟩,
  left_inv := by tidy,
  right_inv := by tidy, }

/--
A zero morphism `0 : X ⟶ X` is an isomorphism if and only if
the identity on `X` is zero.
-/
def is_iso_zero_self_equiv (X : C) : is_iso (0 : X ⟶ X) ≃ (𝟙 X = 0) :=
by simpa using is_iso_zero_equiv X X

variables [has_zero_object C]
open_locale zero_object

/--
A zero morphism `0 : X ⟶ Y` is an isomorphism if and only if
`X` and `Y` are isomorphic to the zero object.
-/
def is_iso_zero_equiv_iso_zero (X Y : C) : is_iso (0 : X ⟶ Y) ≃ (X ≅ 0) × (Y ≅ 0) :=
begin
  -- This is lame, because `prod` can't cope with `Prop`, so we can't use `equiv.prod_congr`.
  refine (is_iso_zero_equiv X Y).trans _,
  symmetry,
  fsplit,
  { rintros ⟨eX, eY⟩, fsplit,
    exact (id_zero_equiv_iso_zero X).symm eX,
    exact (id_zero_equiv_iso_zero Y).symm eY, },
  { rintros ⟨hX, hY⟩, fsplit,
    exact (id_zero_equiv_iso_zero X) hX,
    exact (id_zero_equiv_iso_zero Y) hY, },
  { tidy, },
  { tidy, },
end

lemma is_iso_of_source_target_iso_zero {X Y : C} (f : X ⟶ Y) (i : X ≅ 0) (j : Y ≅ 0) : is_iso f :=
begin
  rw zero_of_source_iso_zero f i,
  exact (is_iso_zero_equiv_iso_zero _ _).inv_fun ⟨i, j⟩,
end

/--
A zero morphism `0 : X ⟶ X` is an isomorphism if and only if
`X` is isomorphic to the zero object.
-/
def is_iso_zero_self_equiv_iso_zero (X : C) : is_iso (0 : X ⟶ X) ≃ (X ≅ 0) :=
(is_iso_zero_equiv_iso_zero X X).trans subsingleton_prod_self_equiv

end is_iso

/-- If there are zero morphisms, any initial object is a zero object. -/
lemma has_zero_object_of_has_initial_object
  [has_zero_morphisms C] [has_initial C] : has_zero_object C :=
begin
  refine ⟨⟨⊥_ C, λ X, ⟨⟨⟨0⟩, by tidy⟩⟩, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩⟩⟩,
  calc
    f = f ≫ 𝟙 _ : (category.comp_id _).symm
    ... = f ≫ 0 : by congr
    ... = 0     : has_zero_morphisms.comp_zero _ _
end

/-- If there are zero morphisms, any terminal object is a zero object. -/
lemma has_zero_object_of_has_terminal_object
  [has_zero_morphisms C] [has_terminal C] : has_zero_object C :=
begin
  refine ⟨⟨⊤_ C, λ X, ⟨⟨⟨0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨0⟩, by tidy⟩⟩⟩⟩,
  calc
    f = 𝟙 _ ≫ f : (category.id_comp _).symm
    ... = 0 ≫ f : by congr
    ... = 0     : zero_comp
end

section image
variable [has_zero_morphisms C]

lemma image_ι_comp_eq_zero {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} [has_image f]
  [epi (factor_thru_image f)] (h : f ≫ g = 0) : image.ι f ≫ g = 0 :=
zero_of_epi_comp (factor_thru_image f) $ by simp [h]

lemma comp_factor_thru_image_eq_zero {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} [has_image g]
  (h : f ≫ g = 0) : f ≫ factor_thru_image g = 0 :=
zero_of_comp_mono (image.ι g) $ by simp [h]

variables [has_zero_object C]
open_locale zero_object

/--
The zero morphism has a `mono_factorisation` through the zero object.
-/
@[simps]
def mono_factorisation_zero (X Y : C) : mono_factorisation (0 : X ⟶ Y) :=
{ I := 0, m := 0, e := 0, }

/--
The factorisation through the zero object is an image factorisation.
-/
def image_factorisation_zero (X Y : C) : image_factorisation (0 : X ⟶ Y) :=
{ F := mono_factorisation_zero X Y,
  is_image := { lift := λ F', 0 } }

instance has_image_zero {X Y : C} : has_image (0 : X ⟶ Y) :=
has_image.mk $ image_factorisation_zero _ _

/-- The image of a zero morphism is the zero object. -/
def image_zero {X Y : C} : image (0 : X ⟶ Y) ≅ 0 :=
is_image.iso_ext (image.is_image (0 : X ⟶ Y)) (image_factorisation_zero X Y).is_image

/-- The image of a morphism which is equal to zero is the zero object. -/
def image_zero' {X Y : C} {f : X ⟶ Y} (h : f = 0) [has_image f] : image f ≅ 0 :=
image.eq_to_iso h ≪≫ image_zero

@[simp]
lemma image.ι_zero {X Y : C} [has_image (0 : X ⟶ Y)] : image.ι (0 : X ⟶ Y) = 0 :=
begin
  rw ←image.lift_fac (mono_factorisation_zero X Y),
  simp,
end

/--
If we know `f = 0`,
it requires a little work to conclude `image.ι f = 0`,
because `f = g` only implies `image f ≅ image g`.
-/
@[simp]
lemma image.ι_zero' [has_equalizers C] {X Y : C} {f : X ⟶ Y} (h : f = 0) [has_image f] :
  image.ι f = 0 :=
by { rw image.eq_fac h, simp }

end image

/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
instance split_mono_sigma_ι
  {β : Type v} [has_zero_morphisms C]
  (f : β → C) [has_colimit (discrete.functor f)] (b : β) : split_mono (sigma.ι f b) :=
{ retraction := sigma.desc (λ b', if h : b' = b then eq_to_hom (congr_arg f h) else 0), }

/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
instance split_epi_pi_π
  {β : Type v} [has_zero_morphisms C]
  (f : β → C) [has_limit (discrete.functor f)] (b : β) : split_epi (pi.π f b) :=
{ section_ := pi.lift (λ b', if h : b = b' then eq_to_hom (congr_arg f h) else 0), }

/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
instance split_mono_coprod_inl
  [has_zero_morphisms C] {X Y : C} [has_colimit (pair X Y)] :
  split_mono (coprod.inl : X ⟶ X ⨿ Y) :=
{ retraction := coprod.desc (𝟙 X) 0, }
/-- In the presence of zero morphisms, coprojections into a coproduct are (split) monomorphisms. -/
instance split_mono_coprod_inr
  [has_zero_morphisms C] {X Y : C} [has_colimit (pair X Y)] :
  split_mono (coprod.inr : Y ⟶ X ⨿ Y) :=
{ retraction := coprod.desc 0 (𝟙 Y), }

/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
instance split_epi_prod_fst
  [has_zero_morphisms C] {X Y : C} [has_limit (pair X Y)] :
  split_epi (prod.fst : X ⨯ Y ⟶ X) :=
{ section_ := prod.lift (𝟙 X) 0, }
/-- In the presence of zero morphisms, projections into a product are (split) epimorphisms. -/
instance split_epi_prod_snd
  [has_zero_morphisms C] {X Y : C} [has_limit (pair X Y)] :
  split_epi (prod.snd : X ⨯ Y ⟶ Y) :=
{ section_ := prod.lift 0 (𝟙 Y), }

end category_theory.limits


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/

import order.omega_complete_partial_order
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.constructions.limits_of_products_and_equalizers
import category_theory.concrete_category.bundled_hom

/-!
# Category of types with a omega complete partial order

In this file, we bundle the class `omega_complete_partial_order` into a
concrete category and prove that continuous functions also form
a `omega_complete_partial_order`.

## Main definitions

 * `ωCPO`
   * an instance of `category` and `concrete_category`

 -/

open category_theory

universes u v

/-- The category of types with a omega complete partial order. -/
def ωCPO : Type (u+1) := bundled omega_complete_partial_order

namespace ωCPO

open omega_complete_partial_order

instance : bundled_hom @continuous_hom :=
{ to_fun := @continuous_hom.simps.apply,
  id := @continuous_hom.id,
  comp := @continuous_hom.comp,
  hom_ext := @continuous_hom.coe_inj }

attribute [derive [large_category, concrete_category]] ωCPO

instance : has_coe_to_sort ωCPO Type* := bundled.has_coe_to_sort

/-- Construct a bundled ωCPO from the underlying type and typeclass. -/
def of (α : Type*) [omega_complete_partial_order α] : ωCPO := bundled.of α

@[simp] lemma coe_of (α : Type*) [omega_complete_partial_order α] : ↥(of α) = α := rfl

instance : inhabited ωCPO := ⟨of punit⟩

instance (α : ωCPO) : omega_complete_partial_order α := α.str

section

open category_theory.limits

namespace has_products

/-- The pi-type gives a cone for a product. -/
def product {J : Type v} (f : J → ωCPO.{v}) : fan f :=
fan.mk (of (Π j, f j)) (λ j, continuous_hom.of_mono (pi.eval_order_hom j) (λ c, rfl))

/-- The pi-type is a limit cone for the product. -/
def is_product (J : Type v) (f : J → ωCPO) : is_limit (product f) :=
{ lift := λ s,
    ⟨⟨λ t j, s.π.app ⟨j⟩ t, λ x y h j, (s.π.app ⟨j⟩).monotone h⟩,
     λ x, funext (λ j, (s.π.app ⟨j⟩).continuous x)⟩,
  uniq' := λ s m w,
  begin
    ext t j,
    change m t j = s.π.app ⟨j⟩ t,
    rw ← w ⟨j⟩,
    refl,
  end,
  fac' := λ s j, by { cases j, tidy, } }.

instance (J : Type v) (f : J → ωCPO.{v}) : has_product f :=
has_limit.mk ⟨_, is_product _ f⟩

end has_products

instance omega_complete_partial_order_equalizer
  {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) : omega_complete_partial_order {a : α // f a = g a} :=
omega_complete_partial_order.subtype _ $ λ c hc,
begin
  rw [f.continuous, g.continuous],
  congr' 1,
  ext,
  apply hc _ ⟨_, rfl⟩,
end

namespace has_equalizers

/-- The equalizer inclusion function as a `continuous_hom`. -/
def equalizer_ι {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) :
  {a : α // f a = g a} →𝒄 α :=
continuous_hom.of_mono (order_hom.subtype.val _) (λ c, rfl)

/-- A construction of the equalizer fork. -/
def equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) :
  fork f g :=
@fork.of_ι _ _ _ _ _ _ (ωCPO.of {a // f a = g a}) (equalizer_ι f g)
  (continuous_hom.ext _ _ (λ x, x.2))

/-- The equalizer fork is a limit. -/
def is_equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) : is_limit (equalizer f g) :=
fork.is_limit.mk' _ $ λ s,
⟨{ to_fun := λ x, ⟨s.ι x, by apply continuous_hom.congr_fun s.condition⟩,
    monotone' := λ x y h, s.ι.monotone h,
    cont := λ x, subtype.ext (s.ι.continuous x) },
  by { ext, refl },
  λ m hm,
  begin
    ext,
    apply continuous_hom.congr_fun hm,
  end⟩

end has_equalizers

instance : has_products.{v} ωCPO.{v} :=
λ J, { has_limit := λ F, has_limit_of_iso discrete.nat_iso_functor.symm }

instance {X Y : ωCPO.{v}} (f g : X ⟶ Y) : has_limit (parallel_pair f g) :=
has_limit.mk ⟨_, has_equalizers.is_equalizer f g⟩

instance : has_equalizers ωCPO.{v} := has_equalizers_of_has_limit_parallel_pair _

instance : has_limits ωCPO.{v} := has_limits_of_has_equalizers_and_products

end

end ωCPO


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis
-/
import data.bool
import meta.rb_map
import tactic.lint.basic

/-!
# Various linters

This file defines several small linters:
  - `ge_or_gt` checks that `>` and `≥` do not occur in the statement of theorems.
  - `dup_namespace` checks that no declaration has a duplicated namespace such as `list.list.monad`.
  - `unused_arguments` checks that definitions and theorems do not have unused arguments.
  - `doc_blame` checks that every definition has a documentation string.
  - `doc_blame_thm` checks that every theorem has a documentation string (not enabled by default).
  - `def_lemma` checks that a declaration is a lemma iff its type is a proposition.
  - `check_type` checks that the statement of a declaration is well-typed.
  - `check_univs` checks that there are no bad `max u v` universe levels.
  - `syn_taut` checks that declarations are not syntactic tautologies.
  - `unused_haves_suffices` checks that declarations produced via term mode do not have
    ineffectual `have` or `suffices` statements
-/

open tactic expr

/-!
## Linter against use of `>`/`≥`
-/
/-- The names of `≥` and `>`, mostly disallowed in lemma statements -/
private meta def illegal_ge_gt : list name := [`gt, `ge]

set_option eqn_compiler.max_steps 20000
/--
  Checks whether `≥` and `>` occurs in an illegal way in the expression.
  The main ways we legally use these orderings are:
  - `f (≥)`
  - `∃ x ≥ t, b`. This corresponds to the expression
    `@Exists α (fun (x : α), (@Exists (x > t) (λ (H : x > t), b)))`
  This function returns `tt` when it finds `ge`/`gt`, except in the following patterns
  (which are the same for `gt`):
  - `f (@ge _ _)`
  - `f (&0 ≥ y) (λ x : t, b)`
  - `λ H : &0 ≥ t, b`
  Here `&0` is the 0-th de Bruijn variable.
-/
private meta def contains_illegal_ge_gt : expr → bool
| (const nm us) := if nm ∈ illegal_ge_gt then tt else ff
| (app f e@(app (app (const nm us) tp) tc)) :=
  contains_illegal_ge_gt f || if nm ∈ illegal_ge_gt then ff else contains_illegal_ge_gt e
| (app (app custom_binder (app (app (app (app (const nm us) tp) tc) (var 0)) t))
    e@(lam var_name bi var_type body)) :=
  contains_illegal_ge_gt e || if nm ∈ illegal_ge_gt then ff else contains_illegal_ge_gt e
| (app f x) := contains_illegal_ge_gt f || contains_illegal_ge_gt x
| (lam `H bi type@(app (app (app (app (const nm us) tp) tc) (var 0)) t) body) :=
  contains_illegal_ge_gt body || if nm ∈ illegal_ge_gt then ff else contains_illegal_ge_gt type
| (lam var_name bi var_type body) := contains_illegal_ge_gt var_type || contains_illegal_ge_gt body
| (pi `H bi type@(app (app (app (app (const nm us) tp) tc) (var 0)) t) body) :=
  contains_illegal_ge_gt body || if nm ∈ illegal_ge_gt then ff else contains_illegal_ge_gt type
| (pi var_name bi var_type body) := contains_illegal_ge_gt var_type || contains_illegal_ge_gt body
| (elet var_name type assignment body) :=
  contains_illegal_ge_gt type || contains_illegal_ge_gt assignment || contains_illegal_ge_gt body
| _ := ff

/-- Checks whether a `>`/`≥` is used in the statement of `d`.

It first does a quick check to see if there is any `≥` or `>` in the statement, and then does a
slower check whether the occurrences of `≥` and `>` are allowed.
Currently it checks only the conclusion of the declaration, to eliminate false positive from
binders such as `∀ ε > 0, ...` -/
private meta def ge_or_gt_in_statement (d : declaration) : tactic (option string) :=
return $ if d.type.contains_constant (λ n, n ∈ illegal_ge_gt) &&
  contains_illegal_ge_gt d.type
  then some "the type contains ≥/>. Use ≤/< instead."
  else none

-- TODO: the commented out code also checks for classicality in statements, but needs fixing
-- TODO: this probably needs to also check whether the argument is a variable or @eq <var> _ _
-- meta def illegal_constants_in_statement (d : declaration) : tactic (option string) :=
-- return $ if d.type.contains_constant (λ n, (n.get_prefix = `classical ∧
--   n.last ∈ ["prop_decidable", "dec", "dec_rel", "dec_eq"]) ∨ n ∈ [`gt, `ge])
-- then
--   let illegal1 := [`classical.prop_decidable, `classical.dec, `classical.dec_rel,
--     `classical.dec_eq],
--       illegal2 := [`gt, `ge],
--       occur1 := illegal1.filter (λ n, d.type.contains_constant (eq n)),
--       occur2 := illegal2.filter (λ n, d.type.contains_constant (eq n)) in
--   some $ sformat!"the type contains the following declarations: {occur1 ++ occur2}." ++
--     (if occur1 = [] then "" else " Add decidability type-class arguments instead.") ++
--     (if occur2 = [] then "" else " Use ≤/< instead.")
-- else none

/-- A linter for checking whether illegal constants (≥, >) appear in a declaration's type. -/
@[linter] meta def linter.ge_or_gt : linter :=
{ test := ge_or_gt_in_statement,
  auto_decls := ff,
  no_errors_found := "Not using ≥/> in declarations.",
  errors_found := "The following declarations use ≥/>, probably in a way where we would prefer
  to use ≤/< instead. See note [nolint_ge] for more information.",
  is_fast := ff }

/--
Currently, the linter forbids the use of `>` and `≥` in definitions and
statements, as they cause problems in rewrites.
They are still allowed in statements such as `bounded (≥)` or `∀ ε > 0` or `⨆ n ≥ m`,
and the linter allows that.
If you write a pattern where you bind two or more variables, like `∃ n m > 0`, the linter will
flag this as illegal, but it is also allowed. In this case, add the line
```
@[nolint ge_or_gt] -- see Note [nolint_ge]
```
-/
library_note "nolint_ge"

/-!
## Linter for duplicate namespaces
-/

/-- Checks whether a declaration has a namespace twice consecutively in its name -/
private meta def dup_namespace (d : declaration) : tactic (option string) :=
is_instance d.to_name >>= λ is_inst,
return $ let nm := d.to_name.components in if nm.chain' (≠) ∨ is_inst then none
  else let s := (nm.find $ λ n, nm.count n ≥ 2).iget.to_string in
  some $ "The namespace `" ++ s ++ "` is duplicated in the name"

/-- A linter for checking whether a declaration has a namespace twice consecutively in its name. -/
@[linter] meta def linter.dup_namespace : linter :=
{ test := dup_namespace,
  auto_decls := ff,
  no_errors_found := "No declarations have a duplicate namespace.",
  errors_found := "DUPLICATED NAMESPACES IN NAME:" }

/-!
## Linter for unused arguments
-/

/-- Auxiliary definition for `check_unused_arguments` -/
private meta def check_unused_arguments_aux : list ℕ → ℕ → ℕ → expr → list ℕ | l n n_max e :=
if n > n_max then l else
if ¬ is_lambda e ∧ ¬ is_pi e then l else
  let b := e.binding_body in
  let l' := if b.has_var_idx 0 then l else n :: l in check_unused_arguments_aux l' (n+1) n_max b

/-- Check which arguments of a declaration are not used.
Prints a list of natural numbers corresponding to which arguments are not used (e.g.
  this outputs [1, 4] if the first and fourth arguments are unused).
Checks both the type and the value of `d` for whether the argument is used
(in rare cases an argument is used in the type but not in the value).
We return [] if the declaration was automatically generated.
We print arguments that are larger than the arity of the type of the declaration
(without unfolding definitions). -/
meta def check_unused_arguments (d : declaration) : option (list ℕ) :=
let l := check_unused_arguments_aux [] 1 d.type.pi_arity d.value in
if l = [] then none else
let l2 := check_unused_arguments_aux [] 1 d.type.pi_arity d.type in
(l.filter $ λ n, n ∈ l2).reverse

/-- Check for unused arguments, and print them with their position, variable name, type and whether
the argument is a duplicate.
See also `check_unused_arguments`.
This tactic additionally filters out all unused arguments of type `parse _`.
We skip all declarations that contain `sorry` in their value. -/
private meta def unused_arguments (d : declaration) : tactic (option string) := do
  ff ← d.to_name.contains_sorry | return none,
  let ns := check_unused_arguments d,
  tt ← return ns.is_some | return none,
  let ns := ns.iget,
  (ds, _) ← get_pi_binders d.type,
  let ns := ns.map (λ n, (n, (ds.nth $ n - 1).iget)),
  let ns := ns.filter (λ x, x.2.type.get_app_fn ≠ const `interactive.parse []),
  ff ← return ns.empty | return none,
  ds' ← ds.mmap pp,
  ns ← ns.mmap (λ ⟨n, b⟩, (λ s, to_fmt "argument " ++ to_fmt n ++ ": " ++ s ++
    (if ds.countp (λ b', b.type = b'.type) ≥ 2 then " (duplicate)" else "")) <$> pp b),
  return $ some $ ns.to_string_aux tt

/-- A linter object for checking for unused arguments. This is in the default linter set. -/
@[linter] meta def linter.unused_arguments : linter :=
{ test := unused_arguments,
  auto_decls := ff,
  no_errors_found := "No unused arguments.",
  errors_found := "UNUSED ARGUMENTS." }

attribute [nolint unused_arguments] imp_intro

/-!
## Linter for documentation strings
-/

/-- Reports definitions and constants that are missing doc strings -/
private meta def doc_blame_report_defn : declaration → tactic (option string)
| (declaration.defn n _ _ _ _ _) := doc_string n >> return none <|> return "def missing doc string"
| (declaration.cnst n _ _ _) := doc_string n >> return none <|> return "constant missing doc string"
| _ := return none

/-- Reports definitions and constants that are missing doc strings -/
private meta def doc_blame_report_thm : declaration → tactic (option string)
| (declaration.thm n _ _ _) := doc_string n >> return none <|> return "theorem missing doc string"
| _ := return none

/-- A linter for checking definition doc strings -/
@[linter] meta def linter.doc_blame : linter :=
{ test := λ d, mcond (bnot <$> has_attribute' `instance d.to_name)
    (doc_blame_report_defn d) (return none),
  auto_decls := ff,
  no_errors_found := "No definitions are missing documentation.",
  errors_found := "DEFINITIONS ARE MISSING DOCUMENTATION STRINGS:" }

/-- A linter for checking theorem doc strings. This is not in the default linter set. -/
meta def linter.doc_blame_thm : linter :=
{ test := doc_blame_report_thm,
  auto_decls := ff,
  no_errors_found := "No theorems are missing documentation.",
  errors_found := "THEOREMS ARE MISSING DOCUMENTATION STRINGS:",
  is_fast := ff }

/-!
## Linter for correct usage of `lemma`/`def`
-/

/--
Checks whether the correct declaration constructor (definition or theorem) by
comparing it to its sort. Instances will not be printed.

This test is not very quick: maybe we can speed-up testing that something is a proposition?
This takes almost all of the execution time.
-/
private meta def incorrect_def_lemma (d : declaration) : tactic (option string) :=
  if d.is_constant ∨ d.is_axiom
  then return none else do
    is_instance_d ← is_instance d.to_name,
    if is_instance_d then return none else do
      -- the following seems to be a little quicker than `is_prop d.type`.
      expr.sort n ← infer_type d.type,
      is_pattern ← has_attribute' `pattern d.to_name,
      return $
        if d.is_theorem ↔ n = level.zero then none
        else if d.is_theorem then "is a lemma/theorem, should be a def"
        else if is_pattern then none -- declarations with `@[pattern]` are allowed to be a `def`.
        else "is a def, should be a lemma/theorem"

/-- A linter for checking whether the correct declaration constructor (definition or theorem)
has been used. -/
@[linter] meta def linter.def_lemma : linter :=
{ test := incorrect_def_lemma,
  auto_decls := ff,
  no_errors_found := "All declarations correctly marked as def/lemma.",
  errors_found := "INCORRECT DEF/LEMMA:" }

/-!
## Linter that checks whether declarations are well-typed
-/

/-- Checks whether the statement of a declaration is well-typed. -/
meta def check_type (d : declaration) : tactic (option string) :=
(type_check d.type >> return none) <|> return "The statement doesn't type-check"

/-- A linter for missing checking whether statements of declarations are well-typed. -/
@[linter]
meta def linter.check_type : linter :=
{ test := check_type,
  auto_decls := ff,
  no_errors_found :=
    "The statements of all declarations type-check with default reducibility settings.",
  errors_found := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS DO NOT TYPE-CHECK.
Some definitions in the statement are marked `@[irreducible]`, which means that the statement " ++
"is now ill-formed. It is likely that these definitions were locally marked as `@[reducible]` " ++
"or `@[semireducible]`. This can especially cause problems with type class inference or " ++
"`@[simps]`.",
  is_fast := tt }

/-!
## Linter for universe parameters
-/

open native
/--
  `univ_params_grouped e` computes for each `level` `u` of `e` the parameters that occur in `u`,
  and returns the corresponding set of lists of parameters.
  In pseudo-mathematical form, this returns `{ { p : parameter | p ∈ u } | (u : level) ∈ e }`
  We use `list name` instead of `name_set`, since `name_set` does not have an order.
  It will ignore `nm₀._proof_i` declarations.
-/
meta def expr.univ_params_grouped (e : expr) (nm₀ : name) : rb_set (list name) :=
e.fold mk_rb_set $ λ e n l,
  match e with
  | e@(sort u) := l.insert u.params.to_list
  | e@(const nm us) := if nm.get_prefix = nm₀ ∧ nm.last.starts_with "_proof_" then l else
      l.union $ rb_set.of_list $ us.map $ λ u : level, u.params.to_list
  | _ := l
  end

/--
  The good parameters are the parameters that occur somewhere in the `rb_set` as a singleton or
  (recursively) with only other good parameters.
  All other parameters in the `rb_set` are bad.
-/
meta def bad_params : rb_set (list name) → list name | l :=
let good_levels : name_set :=
  l.fold mk_name_set $ λ us prev, if us.length = 1 then prev.insert us.head else prev in
if good_levels.empty then
l.fold [] list.union
else bad_params $ rb_set.of_list $ l.to_list.map $ λ us, us.filter $ λ nm, !good_levels.contains nm

/--
Checks whether all universe levels `u` in the type of `d` are "good".
This means that `u` either occurs in a `level` of `d` by itself, or (recursively)
with only other good levels.
When this fails, usually this means that there is a level `max u v`, where neither `u` nor `v`
occur by themselves in a level. It is ok if *one* of `u` or `v` never occurs alone. For example,
`(α : Type u) (β : Type (max u v))` is a occasionally useful method of saying that `β` lives in
a higher universe level than `α`.
-/
meta def check_univs (d : declaration) : tactic (option string) := do
  let l := d.type.univ_params_grouped d.to_name,
  let bad := bad_params l,
  if bad.empty then return none else
    return $ some $ "universes " ++ to_string bad ++ " only occur together."

/-- A linter for checking that there are no bad `max u v` universe levels. -/
@[linter]
meta def linter.check_univs : linter :=
{ test := check_univs,
  auto_decls := ff,
  no_errors_found :=
    "All declarations have good universe levels.",
  errors_found := "THE STATEMENTS OF THE FOLLOWING DECLARATIONS HAVE BAD UNIVERSE LEVELS. " ++
"This usually means that there is a `max u v` in the type where neither `u` nor `v` " ++
"occur by themselves. Solution: Find the type (or type bundled with data) that has this " ++
"universe argument and provide the universe level explicitly. If this happens in an implicit " ++
"argument of the declaration, a better solution is to move this argument to a `variables` " ++
"command (then it's not necessary to provide the universe level).
It is possible that this linter gives a false positive on definitions where the value of the " ++
"definition has the universes occur separately, and the definition will usually be used with " ++
"explicit universe arguments. In this case, feel free to add `@[nolint check_univs]`.",
  is_fast := tt }

/-!
## Linter for syntactic tautologies
-/

/--
Checks whether a lemma is a declaration of the form `∀ a b ... z, e₁ = e₂`
where `e₁` and `e₂` are identical exprs.
We call declarations of this form syntactic tautologies.
Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving basic facts
with rfl when elaboration results in a different term than the user intended.
-/
meta def syn_taut (d : declaration) : tactic (option string) :=
  (do (el, er) ← d.type.pi_codomain.is_eq,
    guardb (el =ₐ er),
    return $ some "LHS equals RHS syntactically") <|>
  return none

/-- A linter for checking that declarations aren't syntactic tautologies. -/
@[linter]
meta def linter.syn_taut : linter :=
{ test := syn_taut,
  auto_decls := ff, -- many false positives with this enabled
  no_errors_found :=
    "No declarations are syntactic tautologies.",
  errors_found := "THE FOLLOWING DECLARATIONS ARE SYNTACTIC TAUTOLOGIES. " ++
"This usually means that they are of the form `∀ a b ... z, e₁ = e₂` where `e₁` and `e₂` are " ++
"identical expressions. We call declarations of this form syntactic tautologies. " ++
"Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving " ++
"basic facts using `rfl`, when elaboration results in a different term than the user intended. " ++
"You should check that the declaration really says what you think it does.",
  is_fast := tt }

attribute [nolint syn_taut] rfl

/-!
## Linters for ineffectual have and suffices statements in term mode
-/

/--
Check if an expression contains `var 0` by folding over the expression and matching the binder depth
-/
meta def expr.has_zero_var (e : expr) : bool :=
e.fold ff $ λ e' d res, res || match e' with | var k := k = d | _ := ff end

/--
Return a list of unused have and suffices terms in an expression
-/
meta def find_unused_have_suffices_macros : expr → tactic (list string)
| (app a b) := (++) <$> find_unused_have_suffices_macros a <*> find_unused_have_suffices_macros b
| (lam var_name bi var_type body) := find_unused_have_suffices_macros body
| (pi var_name bi var_type body) := find_unused_have_suffices_macros body
| (elet var_name type assignment body) := (++) <$> find_unused_have_suffices_macros assignment
                                               <*> find_unused_have_suffices_macros body
| m@(macro md [l@(lam ppnm bi vt bd)]) := do -- term mode have statements are tagged with a macro
  -- if the macro annotation is `have then this lambda came from a term mode have statement
  (++) (if m.is_annotation.iget.fst = `have ∧ ¬bd.has_zero_var then
      ["unnecessary have " ++ ppnm.to_string ++ " : " ++ vt.to_string]
    else []) <$>
  find_unused_have_suffices_macros l
| m@(macro md [app l@(lam ppnm bi vt bd) arg]) := do
  -- term mode suffices statements are tagged with a macro
  -- if the macro annotation is `suffices then this lambda came from a term mode suffices statement
  (++) (if m.is_annotation.iget.fst = `suffices ∧ ¬bd.has_zero_var then
      ["unnecessary suffices " ++ ppnm.to_string ++ " : " ++ vt.to_string]
    else []) <$>
  ((++) <$> find_unused_have_suffices_macros l <*> find_unused_have_suffices_macros arg)
| (macro md l) := list.join <$> l.mmap find_unused_have_suffices_macros
| _ := return []

/--
Return a list of unused have and suffices terms in a declaration
-/
meta def unused_have_of_decl : declaration → tactic (list string)
| (declaration.defn _ _ _ bd _ _) := find_unused_have_suffices_macros bd
| (declaration.thm _ _ _ bd) := find_unused_have_suffices_macros bd.get
| _ := return []

/--
Checks whether a declaration contains term mode have statements that have no effect on the resulting
term.
-/
meta def has_unused_haves_suffices (d : declaration) : tactic (option string) := do
  ns ← unused_have_of_decl d,
  if ns.length = 0 then
    return none
  else
    return (", ".intercalate (ns.map to_string))

/-- A linter for checking that declarations don't have unused term mode have statements. We do not
tag this as `@[linter]` so that it is not in the default linter set as it is slow and an uncommon
problem. -/
meta def linter.unused_haves_suffices : linter :=
{ test := has_unused_haves_suffices,
  auto_decls := ff,
  no_errors_found := "No declarations have unused term mode have statements.",
  errors_found := "THE FOLLOWING DECLARATIONS HAVE INEFFECTUAL TERM MODE HAVE/SUFFICES BLOCKS. " ++
"In the case of `have` this is a term of the form `have h := foo, bar` where `bar` does not " ++
"refer to `foo`. Such statements have no effect on the generated proof, and can just be " ++
"replaced by `bar`, in addition to being ineffectual, they may make unnecessary assumptions " ++
"in proofs appear as if they are used. " ++
"For `suffices` this is a term of the form `suffices h : foo, proof_of_goal, proof_of_foo` where" ++
" `proof_of_goal` does not refer to `foo`. " ++
"Such statements have no effect on the generated proof, and can just be replaced by " ++
"`proof_of_goal`, in addition to being ineffectual, they may make unnecessary assumptions in " ++
"proofs appear as if they are used. ",
  is_fast := ff }