/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebraic_topology.alternating_face_map_complex
import algebraic_topology.simplicial_set
import algebraic_topology.cech_nerve
import algebra.homology.homotopy
import tactic.fin_cases

/-!

# Augmented simplicial objects with an extra degeneracy

In simplicial homotopy theory, in order to prove that the connected components
of a simplicial set `X` are contractible, it suffices to construct an extra
degeneracy as it is defined in *Simplicial Homotopy Theory* by Goerss-Jardine p. 190.
It consists of a series of maps `π₀ X → X _[0]` and `X _[n] → X _[n+1]` which
behave formally like an extra degeneracy `σ (-1)`. It can be thought as a datum
associated to the augmented simplicial set `X → π₀ X`.

In this file, we adapt this definition to the case of augmented
simplicial objects in any category.

## Main definitions

- the structure `extra_degeneracy X` for any `X : simplicial_object.augmented C`
- `extra_degeneracy.map`: extra degeneracies are preserved by the application of any
functor `C ⥤ D`
- `sSet.augmented.standard_simplex.extra_degeneracy`: the standard `n`-simplex has
an extra degeneracy
- `arrow.augmented_cech_nerve.extra_degeneracy`: the Čech nerve of a split
epimorphism has an extra degeneracy
- `extra_degeneracy.homotopy_equiv`: in the case the category `C` is preadditive,
if we have an extra degeneracy on `X : simplicial_object.augmented C`, then
the augmentation on the alternating face map complex of `X` is a homotopy
equivalence.

## References
* [Paul G. Goerss, John F. Jardine, *Simplical Homotopy Theory*][goerss-jardine-2009]

-/

open category_theory category_theory.category
open category_theory.simplicial_object.augmented
open opposite
open_locale simplicial

namespace simplicial_object

namespace augmented

variables {C : Type*} [category C]

/-- The datum of an extra degeneracy is a technical condition on
augmented simplicial objects. The morphisms `s'` and `s n` of the
structure formally behave like extra degeneracies `σ (-1)`. -/
@[ext]
structure extra_degeneracy (X : simplicial_object.augmented C) :=
(s' : point.obj X ⟶ (drop.obj X) _[0])
(s : Π (n : ℕ), (drop.obj X) _[n] ⟶ (drop.obj X) _[n+1])
(s'_comp_ε' : s' ≫ X.hom.app (op [0]) = 𝟙 _)
(s₀_comp_δ₁' : s 0 ≫ (drop.obj X).δ 1 = X.hom.app (op [0]) ≫ s')
(s_comp_δ₀' : Π (n : ℕ), s n ≫ (drop.obj X).δ 0 = 𝟙 _)
(s_comp_δ' : Π (n : ℕ) (i : fin (n+2)), s (n+1) ≫ (drop.obj X).δ i.succ =
  (drop.obj X).δ i ≫ s n)
(s_comp_σ' : Π (n : ℕ) (i : fin (n+1)), s n ≫ (drop.obj X).σ i.succ =
  (drop.obj X).σ i ≫ s (n+1))

namespace extra_degeneracy

restate_axiom s'_comp_ε'
restate_axiom s₀_comp_δ₁'
restate_axiom s_comp_δ₀'
restate_axiom s_comp_δ'
restate_axiom s_comp_σ'
attribute [reassoc] s'_comp_ε s₀_comp_δ₁ s_comp_δ₀ s_comp_δ s_comp_σ
attribute [simp] s'_comp_ε s_comp_δ₀

/-- If `ed` is an extra degeneracy for `X : simplicial_object.augmented C` and
`F : C ⥤ D` is a functor, then `ed.map F` is an extra degeneracy for the
augmented simplical object in `D` obtained by applying `F` to `X`. -/
def map {D : Type*} [category D]
  {X : simplicial_object.augmented C} (ed : extra_degeneracy X) (F : C ⥤ D) :
  extra_degeneracy (((whiskering _ _).obj F).obj X) :=
{ s' := F.map ed.s',
  s := λ n, F.map (ed.s n),
  s'_comp_ε' := by { dsimp, erw [comp_id, ← F.map_comp, ed.s'_comp_ε, F.map_id], },
  s₀_comp_δ₁' := by { dsimp, erw [comp_id, ← F.map_comp, ← F.map_comp, ed.s₀_comp_δ₁], },
  s_comp_δ₀' := λ n, by { dsimp, erw [← F.map_comp, ed.s_comp_δ₀, F.map_id], },
  s_comp_δ' := λ n i, by { dsimp, erw [← F.map_comp, ← F.map_comp, ed.s_comp_δ], refl, },
  s_comp_σ' := λ n i, by { dsimp, erw [← F.map_comp, ← F.map_comp, ed.s_comp_σ], refl, }, }

/-- If `X` and `Y` are isomorphic augmented simplicial objects, then an extra
degeneracy for `X` gives also an extra degeneracy for `Y` -/
def of_iso {X Y : simplicial_object.augmented C} (e : X ≅ Y) (ed : extra_degeneracy X) :
  extra_degeneracy Y :=
{ s' := (point.map_iso e).inv ≫ ed.s' ≫ (drop.map_iso e).hom.app (op [0]),
  s := λ n, (drop.map_iso e).inv.app (op [n]) ≫ ed.s n ≫ (drop.map_iso e).hom.app (op [n+1]),
  s'_comp_ε' := by simpa only [functor.map_iso, assoc, w₀, ed.s'_comp_ε_assoc]
    using (point.map_iso e).inv_hom_id,
  s₀_comp_δ₁' := begin
    have h := w₀ e.inv,
    dsimp at h ⊢,
    simp only [assoc, ← simplicial_object.δ_naturality, ed.s₀_comp_δ₁_assoc, reassoc_of h],
  end,
  s_comp_δ₀' := λ n, begin
    have h := ed.s_comp_δ₀',
    dsimp at ⊢ h,
    simpa only [assoc, ← simplicial_object.δ_naturality, reassoc_of h]
      using congr_app (drop.map_iso e).inv_hom_id (op [n]),
  end,
  s_comp_δ' := λ n i, begin
    have h := ed.s_comp_δ' n i,
    dsimp at ⊢ h,
    simp only [assoc, ← simplicial_object.δ_naturality, reassoc_of h,
      ← simplicial_object.δ_naturality_assoc],
  end,
  s_comp_σ' := λ n i, begin
    have h := ed.s_comp_σ' n i,
    dsimp at ⊢ h,
    simp only [assoc, ← simplicial_object.σ_naturality, reassoc_of h,
      ← simplicial_object.σ_naturality_assoc],
  end,}

end extra_degeneracy

end augmented

end simplicial_object

namespace sSet

namespace augmented

namespace standard_simplex

/-- When `[has_zero X]`, the shift of a map `f : fin n → X`
is a map `fin (n+1) → X` which sends `0` to `0` and `i.succ` to `f i`. -/
def shift_fun {n : ℕ} {X : Type*} [has_zero X] (f : fin n → X) (i : fin (n+1)) : X :=
dite (i = 0) (λ h, 0) (λ h, f (i.pred h))

@[simp]
lemma shift_fun_0 {n : ℕ} {X : Type*} [has_zero X] (f : fin n → X) : shift_fun f 0 = 0 := rfl

@[simp]
lemma shift_fun_succ {n : ℕ} {X : Type*} [has_zero X] (f : fin n → X)
  (i : fin n) : shift_fun f i.succ = f i :=
begin
  dsimp [shift_fun],
  split_ifs,
  { exfalso,
    simpa only [fin.ext_iff, fin.coe_succ] using h, },
  { simp only [fin.pred_succ], },
end

/-- The shift of a morphism `f : [n] → Δ` in `simplex_category` corresponds to
the monotone map which sends `0` to `0` and `i.succ` to `f.to_order_hom i`. -/
@[simp]
def shift {n : ℕ} {Δ : simplex_category} (f : [n] ⟶ Δ) : [n+1] ⟶ Δ := simplex_category.hom.mk
{ to_fun := shift_fun f.to_order_hom,
  monotone' := λ i₁ i₂ hi, begin
    by_cases h₁ : i₁ = 0,
    { subst h₁,
      simp only [shift_fun_0, fin.zero_le], },
    { have h₂ : i₂ ≠ 0 := by { intro h₂, subst h₂, exact h₁ (le_antisymm hi (fin.zero_le _)), },
      cases fin.eq_succ_of_ne_zero h₁ with j₁ hj₁,
      cases fin.eq_succ_of_ne_zero h₂ with j₂ hj₂,
      substs hj₁ hj₂,
      simpa only [shift_fun_succ] using f.to_order_hom.monotone (fin.succ_le_succ_iff.mp hi), },
  end, }

/-- The obvious extra degeneracy on the standard simplex. -/
@[protected]
def extra_degeneracy (Δ : simplex_category) :
  simplicial_object.augmented.extra_degeneracy (standard_simplex.obj Δ) :=
{ s' := λ x, simplex_category.hom.mk (order_hom.const _ 0),
  s := λ n f, shift f,
  s'_comp_ε' := by { ext1 j, fin_cases j, },
  s₀_comp_δ₁' := by { ext x j, fin_cases j, refl, },
  s_comp_δ₀' := λ n, begin
    ext φ i : 4,
    dsimp [simplicial_object.δ, simplex_category.δ, sSet.standard_simplex],
    simp only [shift_fun_succ],
  end,
  s_comp_δ' := λ n i, begin
    ext φ j : 4,
    dsimp [simplicial_object.δ, simplex_category.δ, sSet.standard_simplex],
    by_cases j = 0,
    { subst h,
      simp only [fin.succ_succ_above_zero, shift_fun_0], },
    { cases fin.eq_succ_of_ne_zero h with k hk,
      subst hk,
      simp only [fin.succ_succ_above_succ, shift_fun_succ], },
  end,
  s_comp_σ' := λ n i, begin
    ext φ j : 4,
    dsimp [simplicial_object.σ, simplex_category.σ, sSet.standard_simplex],
    by_cases j = 0,
    { subst h,
      simpa only [shift_fun_0] using shift_fun_0 φ.to_order_hom, },
    { cases fin.eq_succ_of_ne_zero h with k hk,
      subst hk,
      simp only [fin.succ_pred_above_succ, shift_fun_succ], },
  end, }

instance nonempty_extra_degeneracy_standard_simplex (Δ : simplex_category) :
  nonempty (simplicial_object.augmented.extra_degeneracy (standard_simplex.obj Δ)) :=
⟨standard_simplex.extra_degeneracy Δ⟩

end standard_simplex

end augmented

end sSet

namespace category_theory

open limits

namespace arrow

namespace augmented_cech_nerve

variables {C : Type*} [category C] (f : arrow C)
  [∀ n : ℕ, has_wide_pullback f.right (λ i : fin (n+1), f.left) (λ i, f.hom)]
  (S : split_epi f.hom)

include S

/-- The extra degeneracy map on the Čech nerve of a split epi. It is
given on the `0`-projection by the given section of the split epi,
and by shifting the indices on the other projections. -/
noncomputable def extra_degeneracy.s (n : ℕ) :
  f.cech_nerve.obj (op [n]) ⟶ f.cech_nerve.obj (op [n + 1]) :=
wide_pullback.lift (wide_pullback.base _)
  (λ i, dite (i = 0) (λ h, wide_pullback.base _ ≫ S.section_)
    (λ h, wide_pullback.π _ (i.pred h)))
  (λ i, begin
    split_ifs,
    { subst h,
      simp only [assoc, split_epi.id, comp_id], },
    { simp only [wide_pullback.π_arrow], },
  end)

@[simp]
lemma extra_degeneracy.s_comp_π_0 (n : ℕ) :
  extra_degeneracy.s f S n ≫ wide_pullback.π _ 0 = wide_pullback.base _ ≫ S.section_ :=
by { dsimp [extra_degeneracy.s], simpa only [wide_pullback.lift_π], }

@[simp]
lemma extra_degeneracy.s_comp_π_succ (n : ℕ) (i : fin (n+1)) :
  extra_degeneracy.s f S n ≫ wide_pullback.π _ i.succ = wide_pullback.π _ i :=
begin
  dsimp [extra_degeneracy.s],
  simp only [wide_pullback.lift_π],
  split_ifs,
  { exfalso,
    simpa only [fin.ext_iff, fin.coe_succ, fin.coe_zero, nat.succ_ne_zero] using h, },
  { congr,
    apply fin.pred_succ, },
end

@[simp]
lemma extra_degeneracy.s_comp_base (n : ℕ) :
  extra_degeneracy.s f S n ≫ wide_pullback.base _ = wide_pullback.base _ :=
by apply wide_pullback.lift_base

/-- The augmented Čech nerve associated to a split epimorphism has an extra degeneracy. -/
noncomputable def extra_degeneracy :
  simplicial_object.augmented.extra_degeneracy f.augmented_cech_nerve :=
{ s' := S.section_ ≫ wide_pullback.lift f.hom (λ i, 𝟙 _) (λ i, by rw id_comp),
  s := λ n, extra_degeneracy.s f S n,
  s'_comp_ε' :=
    by simp only [augmented_cech_nerve_hom_app, assoc, wide_pullback.lift_base, split_epi.id],
  s₀_comp_δ₁' := begin
    dsimp [cech_nerve, simplicial_object.δ, simplex_category.δ],
    ext j,
    { fin_cases j,
      simpa only [assoc, wide_pullback.lift_π, comp_id] using extra_degeneracy.s_comp_π_0 f S 0, },
    { simpa only [assoc, wide_pullback.lift_base, split_epi.id, comp_id]
        using extra_degeneracy.s_comp_base f S 0, },
  end,
  s_comp_δ₀' := λ n, begin
    dsimp [cech_nerve, simplicial_object.δ, simplex_category.δ],
    ext j,
    { simpa only [assoc, wide_pullback.lift_π, id_comp]
        using extra_degeneracy.s_comp_π_succ f S n j, },
    { simpa only [assoc, wide_pullback.lift_base, id_comp]
        using extra_degeneracy.s_comp_base f S n, },
  end,
  s_comp_δ' := λ n i, begin
    dsimp [cech_nerve, simplicial_object.δ, simplex_category.δ],
    ext j,
    { simp only [assoc, wide_pullback.lift_π],
      by_cases j = 0,
      { subst h,
        erw [fin.succ_succ_above_zero, extra_degeneracy.s_comp_π_0, extra_degeneracy.s_comp_π_0],
        dsimp,
        simp only [wide_pullback.lift_base_assoc], },
      { cases fin.eq_succ_of_ne_zero h with k hk,
        subst hk,
        erw [fin.succ_succ_above_succ, extra_degeneracy.s_comp_π_succ,
          extra_degeneracy.s_comp_π_succ],
        dsimp,
        simp only [wide_pullback.lift_π], }, },
    { simp only [assoc, wide_pullback.lift_base],
      erw [extra_degeneracy.s_comp_base, extra_degeneracy.s_comp_base],
      dsimp,
      simp only [wide_pullback.lift_base], },
  end,
  s_comp_σ' := λ n i, begin
    dsimp [cech_nerve, simplicial_object.σ, simplex_category.σ],
    ext j,
    { simp only [assoc, wide_pullback.lift_π],
      by_cases j = 0,
      { subst h,
        erw [extra_degeneracy.s_comp_π_0, extra_degeneracy.s_comp_π_0],
        dsimp,
        simp only [wide_pullback.lift_base_assoc], },
      { cases fin.eq_succ_of_ne_zero h with k hk,
        subst hk,
        erw [fin.succ_pred_above_succ, extra_degeneracy.s_comp_π_succ,
          extra_degeneracy.s_comp_π_succ],
        dsimp,
        simp only [wide_pullback.lift_π], }, },
    { simp only [assoc, wide_pullback.lift_base],
      erw [extra_degeneracy.s_comp_base, extra_degeneracy.s_comp_base],
      dsimp,
      simp only [wide_pullback.lift_base], },
  end, }

end augmented_cech_nerve

end arrow

end category_theory

namespace simplicial_object

namespace augmented

namespace extra_degeneracy

open algebraic_topology category_theory category_theory.limits

/-- If `C` is a preadditive category and `X` is an augmented simplicial object
in `C` that has an extra degeneracy, then the augmentation on the alternating
face map complex of `X` is an homotopy equivalence. -/
noncomputable
def homotopy_equiv {C : Type*} [category C]
  [preadditive C] [has_zero_object C] {X : simplicial_object.augmented C}
  (ed : extra_degeneracy X) :
  homotopy_equiv (algebraic_topology.alternating_face_map_complex.obj (drop.obj X))
    ((chain_complex.single₀ C).obj (point.obj X)) :=
{ hom := alternating_face_map_complex.ε.app X,
  inv := (chain_complex.from_single₀_equiv _ _).inv_fun ed.s',
  homotopy_inv_hom_id := homotopy.of_eq (by { ext, exact ed.s'_comp_ε, }),
  homotopy_hom_inv_id :=
  { hom := λ i j, begin
      by_cases i+1 = j,
      { exact (-ed.s i) ≫ eq_to_hom (by congr'), },
      { exact 0, },
    end,
    zero' := λ i j hij, begin
      split_ifs,
      { exfalso, exact hij h, },
      { simp only [eq_self_iff_true], },
    end,
    comm := λ i, begin
      cases i,
      { rw [homotopy.prev_d_chain_complex, homotopy.d_next_zero_chain_complex, zero_add],
        dsimp [chain_complex.from_single₀_equiv, chain_complex.to_single₀_equiv],
        simp only [zero_add, eq_self_iff_true, preadditive.neg_comp, comp_id, if_true,
          alternating_face_map_complex.obj_d_eq, fin.sum_univ_two, fin.coe_zero, pow_zero,
          one_zsmul, fin.coe_one, pow_one, neg_smul, preadditive.comp_add, ← s₀_comp_δ₁,
          s_comp_δ₀, preadditive.comp_neg, neg_add_rev, neg_neg, neg_add_cancel_right,
          neg_add_cancel_comm], },
      { rw [homotopy.prev_d_chain_complex, homotopy.d_next_succ_chain_complex],
        dsimp [chain_complex.to_single₀_equiv, chain_complex.from_single₀_equiv],
        simp only [zero_comp, alternating_face_map_complex.obj_d_eq, eq_self_iff_true,
          preadditive.neg_comp, comp_id, if_true, preadditive.comp_neg,
          @fin.sum_univ_succ _ _ (i+2), preadditive.comp_add, fin.coe_zero, pow_zero, one_zsmul,
          s_comp_δ₀, fin.coe_succ, pow_add, pow_one, mul_neg, neg_zsmul,
          preadditive.comp_sum, preadditive.sum_comp, neg_neg, mul_one,
          preadditive.comp_zsmul, preadditive.zsmul_comp, s_comp_δ, zsmul_neg],
        rw [add_comm (-𝟙 _), add_assoc, add_assoc, add_left_neg, add_zero,
          finset.sum_neg_distrib, add_left_neg], },
    end, }, }

end extra_degeneracy

end augmented

end simplicial_object


/-
Copyright (c) 2018 Andreas Swerdlow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andreas Swerdlow
-/
import algebra.module.linear_map
import linear_algebra.bilinear_map
import linear_algebra.matrix.basis

/-!
# Sesquilinear form

This files provides properties about sesquilinear forms. The maps considered are of the form
`M₁ →ₛₗ[I₁] M₂ →ₛₗ[I₂] R`, where `I₁ : R₁ →+* R` and `I₂ : R₂ →+* R` are ring homomorphisms and
`M₁` is a module over `R₁` and `M₂` is a module over `R₂`.
Sesquilinear forms are the special case that `M₁ = M₂`, `R₁ = R₂ = R`, and `I₁ = ring_hom.id R`.
Taking additionally `I₂ = ring_hom.id R`, then one obtains bilinear forms.

These forms are a special case of the bilinear maps defined in `bilinear_map.lean` and all basic
lemmas about construction and elementary calculations are found there.

## Main declarations

* `is_ortho`: states that two vectors are orthogonal with respect to a sesquilinear form
* `is_symm`, `is_alt`: states that a sesquilinear form is symmetric and alternating, respectively
* `orthogonal_bilin`: provides the orthogonal complement with respect to sesquilinear form

## References

* <https://en.wikipedia.org/wiki/Sesquilinear_form#Over_arbitrary_rings>

## Tags

Sesquilinear form,
-/

open_locale big_operators

variables {R R₁ R₂ R₃ M M₁ M₂ K K₁ K₂ V V₁ V₂ n: Type*}

namespace linear_map

/-! ### Orthogonal vectors -/

section comm_ring

-- the `ₗ` subscript variables are for special cases about linear (as opposed to semilinear) maps
variables [comm_semiring R] [comm_semiring R₁] [add_comm_monoid M₁] [module R₁ M₁]
  [comm_semiring R₂] [add_comm_monoid M₂] [module R₂ M₂]
  {I₁ : R₁ →+* R} {I₂ : R₂ →+* R} {I₁' : R₁ →+* R}

/-- The proposition that two elements of a sesquilinear form space are orthogonal -/
def is_ortho (B : M₁ →ₛₗ[I₁] M₂ →ₛₗ[I₂] R) (x y) : Prop := B x y = 0

lemma is_ortho_def {B : M₁ →ₛₗ[I₁] M₂ →ₛₗ[I₂] R} {x y} :
  B.is_ortho x y ↔ B x y = 0 := iff.rfl

lemma is_ortho_zero_left (B : M₁ →ₛₗ[I₁] M₂ →ₛₗ[I₂] R) (x) : is_ortho B (0 : M₁) x :=
  by { dunfold is_ortho, rw [ map_zero B, zero_apply] }

lemma is_ortho_zero_right (B : M₁ →ₛₗ[I₁] M₂ →ₛₗ[I₂] R) (x) : is_ortho B x (0 : M₂) :=
  map_zero (B x)

/-- A set of vectors `v` is orthogonal with respect to some bilinear form `B` if and only
if for all `i ≠ j`, `B (v i) (v j) = 0`. For orthogonality between two elements, use
`bilin_form.is_ortho` -/
def is_Ortho {n : Type*} (B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₁'] R) (v : n → M₁) : Prop :=
pairwise (B.is_ortho on v)

lemma is_Ortho_def {n : Type*} {B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₁'] R} {v : n → M₁} :
  B.is_Ortho v ↔ ∀ i j : n, i ≠ j → B (v i) (v j) = 0 := iff.rfl

end comm_ring
section field

variables [field K] [field K₁] [add_comm_group V₁] [module K₁ V₁]
  [field K₂] [add_comm_group V₂] [module K₂ V₂]
  {I₁ : K₁ →+* K} {I₂ : K₂ →+* K} {I₁' : K₁ →+* K}
  {J₁ : K →+* K} {J₂ : K →+* K}

-- todo: this also holds for [comm_ring R] [is_domain R] when J₁ is invertible
lemma ortho_smul_left {B : V₁ →ₛₗ[I₁] V₂ →ₛₗ[I₂] K} {x y} {a : K₁} (ha : a ≠ 0) :
  (is_ortho B x y) ↔ (is_ortho B (a • x) y) :=
begin
  dunfold is_ortho,
  split; intro H,
  { rw [map_smulₛₗ₂, H, smul_zero]},
  { rw [map_smulₛₗ₂, smul_eq_zero] at H,
    cases H,
    { rw I₁.map_eq_zero at H, trivial },
    { exact H }}
end

-- todo: this also holds for [comm_ring R] [is_domain R] when J₂ is invertible
lemma ortho_smul_right {B : V₁ →ₛₗ[I₁] V₂ →ₛₗ[I₂] K} {x y} {a : K₂} {ha : a ≠ 0} :
(is_ortho B x y) ↔ (is_ortho B x (a • y)) :=
begin
  dunfold is_ortho,
  split; intro H,
  { rw [map_smulₛₗ, H, smul_zero] },
  { rw [map_smulₛₗ, smul_eq_zero] at H,
    cases H,
    { simp at H,
      exfalso,
      exact ha H },
    { exact H }}
end

/-- A set of orthogonal vectors `v` with respect to some sesquilinear form `B` is linearly
  independent if for all `i`, `B (v i) (v i) ≠ 0`. -/
lemma linear_independent_of_is_Ortho {B : V₁ →ₛₗ[I₁] V₁ →ₛₗ[I₁'] K} {v : n → V₁}
  (hv₁ : B.is_Ortho v) (hv₂ : ∀ i, ¬ B.is_ortho (v i) (v i)) : linear_independent K₁ v :=
begin
  classical,
  rw linear_independent_iff',
  intros s w hs i hi,
  have : B (s.sum $ λ (i : n), w i • v i) (v i) = 0,
  { rw [hs, map_zero, zero_apply] },
  have hsum : s.sum (λ (j : n), I₁(w j) * B (v j) (v i)) = I₁(w i) * B (v i) (v i),
  { apply finset.sum_eq_single_of_mem i hi,
    intros j hj hij,
    rw [is_Ortho_def.1 hv₁ _ _ hij, mul_zero], },
  simp_rw [B.map_sum₂, map_smulₛₗ₂, smul_eq_mul, hsum] at this,
  apply I₁.map_eq_zero.mp,
  exact eq_zero_of_ne_zero_of_mul_right_eq_zero (hv₂ i) this,
end

end field

variables [comm_ring R] [add_comm_group M] [module R M]
  [comm_ring R₁] [add_comm_group M₁] [module R₁ M₁]
  {I : R →+* R} {I₁ : R₁ →+* R} {I₂ : R₁ →+* R}
  {B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₂] R}
  {B' : M →ₗ[R] M →ₛₗ[I] R}

/-! ### Reflexive bilinear forms -/

/-- The proposition that a sesquilinear form is reflexive -/
def is_refl (B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₂] R) : Prop :=
  ∀ (x y), B x y = 0 → B y x = 0

namespace is_refl

variable (H : B.is_refl)

lemma eq_zero : ∀ {x y}, B x y = 0 → B y x = 0 := λ x y, H x y

lemma ortho_comm {x y} : is_ortho B x y ↔ is_ortho B y x := ⟨eq_zero H, eq_zero H⟩

end is_refl

/-! ### Symmetric bilinear forms -/

/-- The proposition that a sesquilinear form is symmetric -/
def is_symm (B : M →ₗ[R] M →ₛₗ[I] R) : Prop :=
  ∀ (x y), I (B x y) = B y x

namespace is_symm

variable (H : B'.is_symm)
include H

protected lemma eq (x y) : (I (B' x y)) = B' y x := H x y

lemma is_refl : B'.is_refl := λ x y H1, by { rw [←H], simp [H1] }

lemma ortho_comm {x y} : is_ortho B' x y ↔ is_ortho B' y x := H.is_refl.ortho_comm

end is_symm

/-! ### Alternating bilinear forms -/

/-- The proposition that a sesquilinear form is alternating -/
def is_alt (B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₂] R) : Prop := ∀ x, B x x = 0

namespace is_alt

variable (H : B.is_alt)
include H

lemma self_eq_zero (x) : B x x = 0 := H x

lemma neg (x y) : - B x y = B y x :=
begin
  have H1 : B (y + x) (y + x) = 0,
  { exact self_eq_zero H (y + x) },
  simp [map_add, self_eq_zero H] at H1,
  rw [add_eq_zero_iff_neg_eq] at H1,
  exact H1,
end

lemma is_refl : B.is_refl :=
begin
  intros x y h,
  rw [←neg H, h, neg_zero],
end

lemma ortho_comm {x y} : is_ortho B x y ↔ is_ortho B y x := H.is_refl.ortho_comm

end is_alt

end linear_map

namespace submodule

/-! ### The orthogonal complement -/

variables [comm_ring R] [comm_ring R₁] [add_comm_group M₁] [module R₁ M₁]
  {I₁ : R₁ →+* R} {I₂ : R₁ →+* R}
  {B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₂] R}

/-- The orthogonal complement of a submodule `N` with respect to some bilinear form is the set of
elements `x` which are orthogonal to all elements of `N`; i.e., for all `y` in `N`, `B x y = 0`.

Note that for general (neither symmetric nor antisymmetric) bilinear forms this definition has a
chirality; in addition to this "left" orthogonal complement one could define a "right" orthogonal
complement for which, for all `y` in `N`, `B y x = 0`.  This variant definition is not currently
provided in mathlib. -/
def orthogonal_bilin (N : submodule R₁ M₁) (B : M₁ →ₛₗ[I₁] M₁ →ₛₗ[I₂] R) : submodule R₁ M₁ :=
{ carrier := { m | ∀ n ∈ N, B.is_ortho n m },
  zero_mem' := λ x _, B.is_ortho_zero_right x,
  add_mem' := λ x y hx hy n hn,
    by rw [linear_map.is_ortho, map_add, show B n x = 0, by exact hx n hn,
        show B n y = 0, by exact hy n hn, zero_add],
  smul_mem' := λ c x hx n hn,
    by rw [linear_map.is_ortho, linear_map.map_smulₛₗ, show B n x = 0, by exact hx n hn,
        smul_zero] }

variables {N L : submodule R₁ M₁}

@[simp] lemma mem_orthogonal_bilin_iff {m : M₁} :
  m ∈ N.orthogonal_bilin B ↔ ∀ n ∈ N, B.is_ortho n m := iff.rfl

lemma orthogonal_bilin_le (h : N ≤ L) : L.orthogonal_bilin B ≤ N.orthogonal_bilin B :=
λ _ hn l hl, hn l (h hl)

lemma le_orthogonal_bilin_orthogonal_bilin (b : B.is_refl) :
  N ≤ (N.orthogonal_bilin B).orthogonal_bilin B :=
λ n hn m hm, b _ _ (hm n hn)

end submodule

namespace linear_map

section orthogonal

variables [field K] [add_comm_group V] [module K V]
  [field K₁] [add_comm_group V₁] [module K₁ V₁]
  {J : K →+* K} {J₁ : K₁ →+* K} {J₁' : K₁ →+* K}

-- ↓ This lemma only applies in fields as we require `a * b = 0 → a = 0 ∨ b = 0`
lemma span_singleton_inf_orthogonal_eq_bot
  (B : V₁ →ₛₗ[J₁] V₁ →ₛₗ[J₁'] K) (x : V₁) (hx : ¬ B.is_ortho x x) :
  (K₁ ∙ x) ⊓ submodule.orthogonal_bilin (K₁ ∙ x) B = ⊥ :=
begin
  rw ← finset.coe_singleton,
  refine eq_bot_iff.2 (λ y h, _),
  rcases mem_span_finset.1 h.1 with ⟨μ, rfl⟩,
  have := h.2 x _,
  { rw finset.sum_singleton at this ⊢,
    suffices hμzero : μ x = 0,
    { rw [hμzero, zero_smul, submodule.mem_bot] },
    change B x (μ x • x) = 0 at this, rw [map_smulₛₗ, smul_eq_mul] at this,
    exact or.elim (zero_eq_mul.mp this.symm)
    (λ y, by { simp at y, exact y })
    (λ hfalse, false.elim $ hx hfalse) },
  { rw submodule.mem_span; exact λ _ hp, hp $ finset.mem_singleton_self _ }
end

-- ↓ This lemma only applies in fields since we use the `mul_eq_zero`
lemma orthogonal_span_singleton_eq_to_lin_ker {B : V →ₗ[K] V →ₛₗ[J] K} (x : V) :
  submodule.orthogonal_bilin (K ∙ x) B = (B x).ker :=
begin
  ext y,
  simp_rw [submodule.mem_orthogonal_bilin_iff, linear_map.mem_ker,
           submodule.mem_span_singleton ],
  split,
  { exact λ h, h x ⟨1, one_smul _ _⟩ },
  { rintro h _ ⟨z, rfl⟩,
    rw [is_ortho, map_smulₛₗ₂, smul_eq_zero],
    exact or.intro_right _ h }
end

-- todo: Generalize this to sesquilinear maps
lemma span_singleton_sup_orthogonal_eq_top {B : V →ₗ[K] V →ₗ[K] K}
  {x : V} (hx : ¬ B.is_ortho x x) :
  (K ∙ x) ⊔ submodule.orthogonal_bilin (K ∙ x) B = ⊤ :=
begin
  rw orthogonal_span_singleton_eq_to_lin_ker,
  exact (B x).span_singleton_sup_ker_eq_top hx,
end

-- todo: Generalize this to sesquilinear maps
/-- Given a bilinear form `B` and some `x` such that `B x x ≠ 0`, the span of the singleton of `x`
  is complement to its orthogonal complement. -/
lemma is_compl_span_singleton_orthogonal {B : V →ₗ[K] V →ₗ[K] K}
  {x : V} (hx : ¬ B.is_ortho x x) : is_compl (K ∙ x) (submodule.orthogonal_bilin (K ∙ x) B) :=
{ inf_le_bot := eq_bot_iff.1 $
    (span_singleton_inf_orthogonal_eq_bot B x hx),
  top_le_sup := eq_top_iff.1 $ span_singleton_sup_orthogonal_eq_top hx }

end orthogonal

end linear_map


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.functor
import Mathlib.data.mv_polynomial.equiv
import Mathlib.data.mv_polynomial.comm_ring
import Mathlib.ring_theory.free_ring
import Mathlib.PostPort

universes u v u_1 u_2

namespace Mathlib

/-!
# Free commutative rings

The theory of the free commutative ring generated by a type `α`.
It is isomorphic to the polynomial ring over ℤ with variables
in `α`

## Main definitions

* `free_comm_ring α`     : the free commutative ring on a type α
* `lift_hom (f : α → R)` : the ring hom `free_comm_ring α →+* R` induced by functoriality from `f`.
* `map (f : α → β)`      : the ring hom `free_comm_ring α →*+ free_comm_ring β` induced by
                           functoriality from f.

## Main results

`free_comm_ring` has functorial properties (it is an adjoint to the forgetful functor).
In this file we have:

* `of : α → free_comm_ring α`
* `lift_hom (f : α → R) : free_comm_ring α →+* R`
* `map (f : α → β) : free_comm_ring α →+* free_comm_ring β`

* `free_comm_ring_equiv_mv_polynomial_int : free_comm_ring α ≃+* mv_polynomial α ℤ` :
    `free_comm_ring α` is isomorphic to a polynomial ring.

## Implementation notes

`free_comm_ring α` is implemented not using `mv_polynomial` but
directly as the free abelian group on `multiset α`, the type
of monomials in this free commutative ring.

## Tags

free commutative ring, free ring
-/

/-- `free_comm_ring α` is the free commutative ring on the type `α`. -/
def free_comm_ring (α : Type u) := free_abelian_group (multiplicative (multiset α))

namespace free_comm_ring

/-- The structure of a commutative ring on `free_comm_ring α`. -/
protected instance comm_ring (α : Type u) : comm_ring (free_comm_ring α) :=
  free_abelian_group.comm_ring (multiplicative (multiset α))

protected instance inhabited (α : Type u) : Inhabited (free_comm_ring α) := { default := 0 }

/-- The canonical map from `α` to the free commutative ring on `α`. -/
def of {α : Type u} (x : α) : free_comm_ring α := free_abelian_group.of ↑[x]

theorem of_injective {α : Type u} : function.injective of :=
  function.injective.comp free_abelian_group.of_injective
    fun (x y : α) => iff.mp (iff.trans multiset.coe_eq_coe list.singleton_perm_singleton)

protected theorem induction_on {α : Type u} {C : free_comm_ring α → Prop} (z : free_comm_ring α)
    (hn1 : C (-1)) (hb : ∀ (b : α), C (of b))
    (ha : ∀ (x y : free_comm_ring α), C x → C y → C (x + y))
    (hm : ∀ (x y : free_comm_ring α), C x → C y → C (x * y)) : C z :=
  sorry

/-- Lift a map `α → R` to a additive group homomorphism `free_comm_ring α → R`.
For a version producing a bundled homomorphism, see `lift_hom`. -/
def lift {α : Type u} {R : Type v} [comm_ring R] (f : α → R) : free_comm_ring α →+* R :=
  ring_hom.mk
    (add_monoid_hom.to_fun
      (free_abelian_group.lift
        fun (s : multiplicative (multiset α)) =>
          multiset.prod (multiset.map f (coe_fn multiplicative.to_add s))))
    sorry sorry sorry sorry

@[simp] theorem lift_of {α : Type u} {R : Type v} [comm_ring R] (f : α → R) (x : α) :
    coe_fn (lift f) (of x) = f x :=
  sorry

@[simp] theorem lift_comp_of {α : Type u} {R : Type v} [comm_ring R] (f : free_comm_ring α →+* R) :
    lift (⇑f ∘ of) = f :=
  sorry

/-- A map `f : α → β` produces a ring homomorphism `free_comm_ring α →+* free_comm_ring β`. -/
def map {α : Type u} {β : Type v} (f : α → β) : free_comm_ring α →+* free_comm_ring β :=
  lift (of ∘ f)

@[simp] theorem map_of {α : Type u} {β : Type v} (f : α → β) (x : α) :
    coe_fn (map f) (of x) = of (f x) :=
  lift_of (of ∘ f) x

/-- `is_supported x s` means that all monomials showing up in `x` have variables in `s`. -/
def is_supported {α : Type u} (x : free_comm_ring α) (s : set α) := x ∈ ring.closure (of '' s)

theorem is_supported_upwards {α : Type u} {x : free_comm_ring α} {s : set α} {t : set α}
    (hs : is_supported x s) (hst : s ⊆ t) : is_supported x t :=
  ring.closure_mono (set.monotone_image hst) hs

theorem is_supported_add {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α}
    (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x + y) s :=
  is_add_submonoid.add_mem hxs hys

theorem is_supported_neg {α : Type u} {x : free_comm_ring α} {s : set α} (hxs : is_supported x s) :
    is_supported (-x) s :=
  is_add_subgroup.neg_mem hxs

theorem is_supported_sub {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α}
    (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x - y) s :=
  is_add_subgroup.sub_mem hxs hys

theorem is_supported_mul {α : Type u} {x : free_comm_ring α} {y : free_comm_ring α} {s : set α}
    (hxs : is_supported x s) (hys : is_supported y s) : is_supported (x * y) s :=
  is_submonoid.mul_mem hxs hys

theorem is_supported_zero {α : Type u} {s : set α} : is_supported 0 s := is_add_submonoid.zero_mem

theorem is_supported_one {α : Type u} {s : set α} : is_supported 1 s := is_submonoid.one_mem

theorem is_supported_int {α : Type u} {i : ℤ} {s : set α} : is_supported (↑i) s := sorry

/-- The restriction map from `free_comm_ring α` to `free_comm_ring s` where `s : set α`, defined
  by sending all variables not in `s` to zero. -/
def restriction {α : Type u} (s : set α) [decidable_pred s] :
    free_comm_ring α →+* free_comm_ring ↥s :=
  lift
    fun (p : α) =>
      dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0

@[simp] theorem restriction_of {α : Type u} (s : set α) [decidable_pred s] (p : α) :
    coe_fn (restriction s) (of p) =
        dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0 :=
  lift_of
    (fun (p : α) =>
      dite (p ∈ s) (fun (H : p ∈ s) => of { val := p, property := H }) fun (H : ¬p ∈ s) => 0)
    p

theorem is_supported_of {α : Type u} {p : α} {s : set α} : is_supported (of p) s ↔ p ∈ s := sorry

theorem map_subtype_val_restriction {α : Type u} {x : free_comm_ring α} (s : set α)
    [decidable_pred s] (hxs : is_supported x s) :
    coe_fn (map subtype.val) (coe_fn (restriction s) x) = x :=
  sorry

theorem exists_finite_support {α : Type u} (x : free_comm_ring α) :
    ∃ (s : set α), set.finite s ∧ is_supported x s :=
  sorry

theorem exists_finset_support {α : Type u} (x : free_comm_ring α) :
    ∃ (s : finset α), is_supported x ↑s :=
  sorry

end free_comm_ring

namespace free_ring

/-- The canonical ring homomorphism from the free ring generated by `α` to the free commutative ring
    generated by `α`. -/
def to_free_comm_ring {α : Type u_1} : free_ring α →+* free_comm_ring α := lift free_comm_ring.of

protected instance free_comm_ring.has_coe (α : Type u) : has_coe (free_ring α) (free_comm_ring α) :=
  has_coe.mk ⇑to_free_comm_ring

protected instance coe.is_ring_hom (α : Type u) : is_ring_hom coe :=
  ring_hom.is_ring_hom to_free_comm_ring

@[simp] protected theorem coe_zero (α : Type u) : ↑0 = 0 := rfl

@[simp] protected theorem coe_one (α : Type u) : ↑1 = 1 := rfl

@[simp] protected theorem coe_of {α : Type u} (a : α) : ↑(of a) = free_comm_ring.of a :=
  lift_of free_comm_ring.of a

@[simp] protected theorem coe_neg {α : Type u} (x : free_ring α) : ↑(-x) = -↑x :=
  ring_hom.map_neg (lift free_comm_ring.of) x

@[simp] protected theorem coe_add {α : Type u} (x : free_ring α) (y : free_ring α) :
    ↑(x + y) = ↑x + ↑y :=
  ring_hom.map_add (lift free_comm_ring.of) x y

@[simp] protected theorem coe_sub {α : Type u} (x : free_ring α) (y : free_ring α) :
    ↑(x - y) = ↑x - ↑y :=
  ring_hom.map_sub (lift free_comm_ring.of) x y

@[simp] protected theorem coe_mul {α : Type u} (x : free_ring α) (y : free_ring α) :
    ↑(x * y) = ↑x * ↑y :=
  ring_hom.map_mul (lift free_comm_ring.of) x y

protected theorem coe_surjective (α : Type u) : function.surjective coe := sorry

theorem coe_eq (α : Type u) : coe = Functor.map fun (l : List α) => ↑l := sorry

-- FIXME This was in `deprecated.ring`, but only used here.

-- It would be good to inline it into the next construction.

/-- Interpret an equivalence `f : R ≃ S` as a ring equivalence `R ≃+* S`. -/
def of' {R : Type u_1} {S : Type u_2} [ring R] [ring S] (e : R ≃ S) [is_ring_hom ⇑e] : R ≃+* S :=
  ring_equiv.mk (equiv.to_fun e) (equiv.inv_fun e) (equiv.left_inv e) (equiv.right_inv e) sorry
    sorry

/-- If α has size at most 1 then the natural map from the free ring on `α` to the
    free commutative ring on `α` is an isomorphism of rings. -/
def subsingleton_equiv_free_comm_ring (α : Type u) [subsingleton α] :
    free_ring α ≃+* free_comm_ring α :=
  of' (functor.map_equiv free_abelian_group (multiset.subsingleton_equiv α))

protected instance comm_ring (α : Type u) [subsingleton α] : comm_ring (free_ring α) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

end free_ring

/-- The free commutative ring on `α` is isomorphic to the polynomial ring over ℤ with
    variables in `α` -/
def free_comm_ring_equiv_mv_polynomial_int (α : Type u) : free_comm_ring α ≃+* mv_polynomial α ℤ :=
  ring_equiv.mk (⇑(free_comm_ring.lift fun (a : α) => mv_polynomial.X a))
    (mv_polynomial.eval₂ (int.cast_ring_hom (free_comm_ring α)) free_comm_ring.of) sorry sorry sorry
    sorry

/-- The free commutative ring on the empty type is isomorphic to `ℤ`. -/
def free_comm_ring_pempty_equiv_int : free_comm_ring pempty ≃+* ℤ :=
  ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int pempty)
    (mv_polynomial.pempty_ring_equiv ℤ)

/-- The free commutative ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_comm_ring_punit_equiv_polynomial_int : free_comm_ring PUnit ≃+* polynomial ℤ :=
  ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int PUnit) (mv_polynomial.punit_ring_equiv ℤ)

/-- The free ring on the empty type is isomorphic to `ℤ`. -/
def free_ring_pempty_equiv_int : free_ring pempty ≃+* ℤ :=
  ring_equiv.trans (free_ring.subsingleton_equiv_free_comm_ring pempty)
    free_comm_ring_pempty_equiv_int

/-- The free ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_ring_punit_equiv_polynomial_int : free_ring PUnit ≃+* polynomial ℤ :=
  ring_equiv.trans (free_ring.subsingleton_equiv_free_comm_ring PUnit)
    free_comm_ring_punit_equiv_polynomial_int

end Mathlib


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison
-/
import category_theory.fin_category
import category_theory.limits.cones
import category_theory.adjunction.basic
import category_theory.category.preorder
import category_theory.category.ulift
import order.bounded_order

/-!
# Filtered categories

A category is filtered if every finite diagram admits a cocone.
We give a simple characterisation of this condition as
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

Filtered colimits are often better behaved than arbitrary colimits.
See `category_theory/limits/types` for some details.

Filtered categories are nice because colimits indexed by filtered categories tend to be
easier to describe than general colimits (and more often preserved by functors).

In this file we show that any functor from a finite category to a filtered category admits a cocone:
* `cocone_nonempty [fin_category J] [is_filtered C] (F : J ⥤ C) : nonempty (cocone F)`
More generally,
for any finite collection of objects and morphisms between them in a filtered category
(even if not closed under composition) there exists some object `Z` receiving maps from all of them,
so that all the triangles (one edge from the finite set, two from morphisms to `Z`) commute.
This formulation is often more useful in practice and is available via `sup_exists`,
which takes a finset of objects, and an indexed family (indexed by source and target)
of finsets of morphisms.

Furthermore, we give special support for two diagram categories: The `bowtie` and the `tulip`.
This is because these shapes show up in the proofs that forgetful functors of algebraic categories
(e.g. `Mon`, `CommRing`, ...) preserve filtered colimits.

All of the above API, except for the `bowtie` and the `tulip`, is also provided for cofiltered
categories.

## See also
In `category_theory.limits.filtered_colimit_commutes_finite_limit` we show that filtered colimits
commute with finite limits.

-/

open function

universes v v₁ u u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

namespace category_theory

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

/--
A category `is_filtered_or_empty` if
1. for every pair of objects there exists another object "to the right", and
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal.
-/
class is_filtered_or_empty : Prop :=
(cocone_objs : ∀ (X Y : C), ∃ Z (f : X ⟶ Z) (g : Y ⟶ Z), true)
(cocone_maps : ∀ ⦃X Y : C⦄ (f g : X ⟶ Y), ∃ Z (h : Y ⟶ Z), f ≫ h = g ≫ h)

/--
A category `is_filtered` if
1. for every pair of objects there exists another object "to the right",
2. for every pair of parallel morphisms there exists a morphism to the right so the compositions
   are equal, and
3. there exists some object.

See <https://stacks.math.columbia.edu/tag/002V>. (They also define a diagram being filtered.)
-/
class is_filtered extends is_filtered_or_empty C : Prop :=
[nonempty : nonempty C]

@[priority 100]
instance is_filtered_or_empty_of_semilattice_sup
  (α : Type u) [semilattice_sup α] : is_filtered_or_empty α :=
{ cocone_objs := λ X Y, ⟨X ⊔ Y, hom_of_le le_sup_left, hom_of_le le_sup_right, trivial⟩,
  cocone_maps := λ X Y f g, ⟨Y, 𝟙 _, (by ext)⟩, }

@[priority 100]
instance is_filtered_of_semilattice_sup_nonempty
  (α : Type u) [semilattice_sup α] [nonempty α] : is_filtered α := {}

@[priority 100]
instance is_filtered_or_empty_of_directed_le (α : Type u) [preorder α] [is_directed α (≤)] :
  is_filtered_or_empty α :=
{ cocone_objs := λ X Y, let ⟨Z, h1, h2⟩ := exists_ge_ge X Y in
    ⟨Z, hom_of_le h1, hom_of_le h2, trivial⟩,
  cocone_maps := λ X Y f g, ⟨Y, 𝟙 _, by simp⟩ }

@[priority 100]
instance is_filtered_of_directed_le_nonempty  (α : Type u) [preorder α] [is_directed α (≤)]
  [nonempty α] :
  is_filtered α := {}

-- Sanity checks
example (α : Type u) [semilattice_sup α] [order_bot α] : is_filtered α := by apply_instance
example (α : Type u) [semilattice_sup α] [order_top α] : is_filtered α := by apply_instance

namespace is_filtered

variables {C} [is_filtered C]

/--
`max j j'` is an arbitrary choice of object to the right of both `j` and `j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def max (j j' : C) : C :=
(is_filtered_or_empty.cocone_objs j j').some

/--
`left_to_max j j'` is an arbitrarily choice of morphism from `j` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def left_to_max (j j' : C) : j ⟶ max j j' :=
(is_filtered_or_empty.cocone_objs j j').some_spec.some

/--
`right_to_max j j'` is an arbitrarily choice of morphism from `j'` to `max j j'`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def right_to_max (j j' : C) : j' ⟶ max j j' :=
(is_filtered_or_empty.cocone_objs j j').some_spec.some_spec.some

/--
`coeq f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of object
which admits a morphism `coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq {j j' : C} (f f' : j ⟶ j') : C :=
(is_filtered_or_empty.cocone_maps f f').some

/--
`coeq_hom f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of morphism
`coeq_hom f f' : j' ⟶ coeq f f'` such that
`coeq_condition : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq_hom {j j' : C} (f f' : j ⟶ j') : j' ⟶ coeq f f' :=
(is_filtered_or_empty.cocone_maps f f').some_spec.some

/--
`coeq_condition f f'`, for morphisms `f f' : j ⟶ j'`, is the proof that
`f ≫ coeq_hom f f' = f' ≫ coeq_hom f f'`.
-/
@[simp, reassoc]
lemma coeq_condition {j j' : C} (f f' : j ⟶ j') : f ≫ coeq_hom f f' = f' ≫ coeq_hom f f' :=
(is_filtered_or_empty.cocone_maps f f').some_spec.some_spec

open category_theory.limits

/--
Any finite collection of objects in a filtered category has an object "to the right".
-/
lemma sup_objs_exists (O : finset C) : ∃ (S : C), ∀ {X}, X ∈ O → _root_.nonempty (X ⟶ S) :=
begin
  classical,
  apply finset.induction_on O,
  { exact ⟨is_filtered.nonempty.some, (by rintros - ⟨⟩)⟩, },
  { rintros X O' nm ⟨S', w'⟩,
    use max X S',
    rintros Y mY,
    obtain rfl|h := eq_or_ne Y X,
    { exact ⟨left_to_max _ _⟩, },
    { exact ⟨(w' (finset.mem_of_mem_insert_of_ne mY h)).some ≫ right_to_max _ _⟩, }, }
end

variables (O : finset C) (H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y))

/--
Given any `finset` of objects `{X, ...}` and
indexed collection of `finset`s of morphisms `{f, ...}` in `C`,
there exists an object `S`, with a morphism `T X : X ⟶ S` from each `X`,
such that the triangles commute: `f ≫ T Y = T X`, for `f : X ⟶ Y` in the `finset`.
-/
lemma sup_exists :
  ∃ (S : C) (T : Π {X : C}, X ∈ O → (X ⟶ S)), ∀ {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y},
    (⟨X, Y, mX, mY, f⟩ : (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y)) ∈ H → f ≫ T mY = T mX :=
begin
  classical,
  apply finset.induction_on H,
  { obtain ⟨S, f⟩ := sup_objs_exists O,
    refine ⟨S, λ X mX, (f mX).some, _⟩,
    rintros - - - - - ⟨⟩, },
  { rintros ⟨X, Y, mX, mY, f⟩ H' nmf ⟨S', T', w'⟩,
    refine ⟨coeq (f ≫ T' mY) (T' mX), λ Z mZ, T' mZ ≫ coeq_hom (f ≫ T' mY) (T' mX), _⟩,
    intros X' Y' mX' mY' f' mf',
    rw [←category.assoc],
    by_cases h : X = X' ∧ Y = Y',
    { rcases h with ⟨rfl, rfl⟩,
      by_cases hf : f = f',
      { subst hf,
        apply coeq_condition, },
      { rw @w' _ _ mX mY f' (by simpa [hf ∘ eq.symm] using mf') }, },
    { rw @w' _ _ mX' mY' f' _,
      apply finset.mem_of_mem_insert_of_ne mf',
      contrapose! h,
      obtain ⟨rfl, h⟩ := h,
      rw [heq_iff_eq, psigma.mk.inj_iff] at h,
      exact ⟨rfl, h.1.symm⟩ }, },
end

/--
An arbitrary choice of object "to the right"
of a finite collection of objects `O` and morphisms `H`,
making all the triangles commute.
-/
noncomputable
def sup : C :=
(sup_exists O H).some

/--
The morphisms to `sup O H`.
-/
noncomputable
def to_sup {X : C} (m : X ∈ O) :
  X ⟶ sup O H :=
(sup_exists O H).some_spec.some m

/--
The triangles of consisting of a morphism in `H` and the maps to `sup O H` commute.
-/
lemma to_sup_commutes
  {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y}
  (mf : (⟨X, Y, mX, mY, f⟩ : Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) ∈ H) :
  f ≫ to_sup O H mY = to_sup O H mX :=
(sup_exists O H).some_spec.some_spec mX mY mf

variables {J : Type v} [small_category J] [fin_category J]

/--
If we have `is_filtered C`, then for any functor `F : J ⥤ C` with `fin_category J`,
there exists a cocone over `F`.
-/
lemma cocone_nonempty (F : J ⥤ C) : _root_.nonempty (cocone F) :=
begin
  classical,
  let O := (finset.univ.image F.obj),
  let H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) :=
    finset.univ.bUnion (λ X : J, finset.univ.bUnion (λ Y : J, finset.univ.image (λ f : X ⟶ Y,
      ⟨F.obj X, F.obj Y, by simp, by simp, F.map f⟩))),
  obtain ⟨Z, f, w⟩ := sup_exists O H,
  refine ⟨⟨Z, ⟨λ X, f (by simp), _⟩⟩⟩,
  intros j j' g,
  dsimp,
  simp only [category.comp_id],
  apply w,
  simp only [finset.mem_univ, finset.mem_bUnion, exists_and_distrib_left,
    exists_prop_of_true, finset.mem_image],
  exact ⟨j, rfl, j', g, (by simp)⟩,
end

/--
An arbitrary choice of cocone over `F : J ⥤ C`, for `fin_category J` and `is_filtered C`.
-/
noncomputable def cocone (F : J ⥤ C) : cocone F :=
(cocone_nonempty F).some

variables {D : Type u₁} [category.{v₁} D]

/--
If `C` is filtered, and we have a functor `R : C ⥤ D` with a left adjoint, then `D` is filtered.
-/
lemma of_right_adjoint {L : D ⥤ C} {R : C ⥤ D} (h : L ⊣ R) : is_filtered D :=
{ cocone_objs := λ X Y,
    ⟨_, h.hom_equiv _ _ (left_to_max _ _), h.hom_equiv _ _ (right_to_max _ _), ⟨⟩⟩,
  cocone_maps := λ X Y f g,
    ⟨_, h.hom_equiv _ _ (coeq_hom _ _),
     by rw [← h.hom_equiv_naturality_left, ← h.hom_equiv_naturality_left, coeq_condition]⟩,
  nonempty := is_filtered.nonempty.map R.obj }

/-- If `C` is filtered, and we have a right adjoint functor `R : C ⥤ D`, then `D` is filtered. -/
lemma of_is_right_adjoint (R : C ⥤ D) [is_right_adjoint R] : is_filtered D :=
of_right_adjoint (adjunction.of_right_adjoint R)

/-- Being filtered is preserved by equivalence of categories. -/
lemma of_equivalence (h : C ≌ D) : is_filtered D :=
of_right_adjoint h.symm.to_adjunction

section special_shapes

/--
`max₃ j₁ j₂ j₃` is an arbitrary choice of object to the right of `j₁`, `j₂` and `j₃`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def max₃ (j₁ j₂ j₃ : C) : C := max (max j₁ j₂) j₃

/--
`first_to_max₃ j₁ j₂ j₃` is an arbitrarily choice of morphism from `j₁` to `max₃ j₁ j₂ j₃`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def first_to_max₃ (j₁ j₂ j₃ : C) : j₁ ⟶ max₃ j₁ j₂ j₃ :=
left_to_max j₁ j₂ ≫ left_to_max (max j₁ j₂) j₃

/--
`second_to_max₃ j₁ j₂ j₃` is an arbitrarily choice of morphism from `j₂` to `max₃ j₁ j₂ j₃`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def second_to_max₃ (j₁ j₂ j₃ : C) : j₂ ⟶ max₃ j₁ j₂ j₃ :=
right_to_max j₁ j₂ ≫ left_to_max (max j₁ j₂) j₃

/--
`third_to_max₃ j₁ j₂ j₃` is an arbitrarily choice of morphism from `j₃` to `max₃ j₁ j₂ j₃`,
whose existence is ensured by `is_filtered`.
-/
noncomputable def third_to_max₃ (j₁ j₂ j₃ : C) : j₃ ⟶ max₃ j₁ j₂ j₃ :=
right_to_max (max j₁ j₂) j₃

/--
`coeq₃ f g h`, for morphisms `f g h : j₁ ⟶ j₂`, is an arbitrary choice of object
which admits a morphism `coeq₃_hom f g h : j₂ ⟶ coeq₃ f g h` such that
`coeq₃_condition₁`, `coeq₃_condition₂` and `coeq₃_condition₃` are satisfied.
Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq₃ {j₁ j₂ : C} (f g h : j₁ ⟶ j₂) : C :=
coeq (coeq_hom f g ≫ left_to_max (coeq f g) (coeq g h))
  (coeq_hom g h ≫ right_to_max (coeq f g) (coeq g h))

/--
`coeq₃_hom f g h`, for morphisms `f g h : j₁ ⟶ j₂`, is an arbitrary choice of morphism
`j₂ ⟶ coeq₃ f g h` such that `coeq₃_condition₁`, `coeq₃_condition₂` and `coeq₃_condition₃`
are satisfied. Its existence is ensured by `is_filtered`.
-/
noncomputable def coeq₃_hom {j₁ j₂ : C} (f g h : j₁ ⟶ j₂) : j₂ ⟶ coeq₃ f g h :=
coeq_hom f g ≫ left_to_max (coeq f g) (coeq g h) ≫
coeq_hom (coeq_hom f g ≫ left_to_max (coeq f g) (coeq g h))
  (coeq_hom g h ≫ right_to_max (coeq f g) (coeq g h))

lemma coeq₃_condition₁ {j₁ j₂ : C} (f g h : j₁ ⟶ j₂) :
  f ≫ coeq₃_hom f g h = g ≫ coeq₃_hom f g h :=
begin
  dsimp [coeq₃_hom],
  slice_lhs 1 2 { rw coeq_condition f g },
  simp only [category.assoc],
end

lemma coeq₃_condition₂ {j₁ j₂ : C} (f g h : j₁ ⟶ j₂) :
  g ≫ coeq₃_hom f g h = h ≫ coeq₃_hom f g h :=
begin
  dsimp [coeq₃_hom],
  slice_lhs 2 4 { rw [← category.assoc, coeq_condition _ _] },
  slice_rhs 2 4 { rw [← category.assoc, coeq_condition _ _] },
  slice_lhs 1 3 { rw [← category.assoc, coeq_condition _ _] },
  simp only [category.assoc],
end

lemma coeq₃_condition₃ {j₁ j₂ : C} (f g h : j₁ ⟶ j₂) :
  f ≫ coeq₃_hom f g h = h ≫ coeq₃_hom f g h :=
eq.trans (coeq₃_condition₁ f g h) (coeq₃_condition₂ f g h)

/--
Given a "bowtie" of morphisms
```
 j₁   j₂
 |\  /|
 | \/ |
 | /\ |
 |/  \∣
 vv  vv
 k₁  k₂
```
in a filtered category, we can construct an object `s` and two morphisms from `k₁` and `k₂` to `s`,
making the resulting squares commute.
-/
lemma bowtie {j₁ j₂ k₁ k₂ : C}
  (f₁ : j₁ ⟶ k₁) (g₁ : j₁ ⟶ k₂) (f₂ : j₂ ⟶ k₁) (g₂ : j₂ ⟶ k₂) :
  ∃ (s : C) (α : k₁ ⟶ s) (β : k₂ ⟶ s), f₁ ≫ α = g₁ ≫ β ∧ f₂ ≫ α = g₂ ≫ β :=
begin
  let sa := max k₁ k₂,
  let sb := coeq (f₁ ≫ left_to_max _ _) (g₁ ≫ right_to_max _ _),
  let sc := coeq (f₂ ≫ left_to_max _ _) (g₂ ≫ right_to_max _ _),
  let sd := max sb sc,
  let s := coeq ((coeq_hom _ _ : sa ⟶ sb) ≫ left_to_max _ _)
    ((coeq_hom _ _ : sa ⟶ sc) ≫ right_to_max _ _),
  use s,
  fsplit,
  exact left_to_max k₁ k₂ ≫ coeq_hom _ _ ≫ left_to_max sb sc ≫ coeq_hom _ _,
  fsplit,
  exact right_to_max k₁ k₂ ≫ coeq_hom _ _ ≫ right_to_max sb sc ≫ coeq_hom _ _,
  fsplit,
  { slice_lhs 1 3 { rw [←category.assoc, coeq_condition], },
    slice_lhs 3 5 { rw [←category.assoc, coeq_condition], },
    simp only [category.assoc], },
  { slice_lhs 3 5 { rw [←category.assoc, coeq_condition], },
    slice_lhs 1 3 { rw [←category.assoc, coeq_condition], },
    simp only [category.assoc], }
end

/--
Given a "tulip" of morphisms
```
 j₁    j₂    j₃
 |\   / \   / |
 | \ /   \ /  |
 |  vv    vv  |
 \  k₁    k₂ /
  \         /
   \       /
    \     /
     \   /
      v v
       l
```
in a filtered category, we can construct an object `s` and three morphisms from `k₁`, `k₂` and `l`
to `s`, making the resulting sqaures commute.
-/
lemma tulip {j₁ j₂ j₃ k₁ k₂ l : C} (f₁ : j₁ ⟶ k₁) (f₂ : j₂ ⟶ k₁) (f₃ : j₂ ⟶ k₂) (f₄ : j₃ ⟶ k₂)
  (g₁ : j₁ ⟶ l) (g₂ : j₃ ⟶ l) :
  ∃ (s : C) (α : k₁ ⟶ s) (β : l ⟶ s) (γ : k₂ ⟶ s),
    f₁ ≫ α = g₁ ≫ β ∧ f₂ ≫ α = f₃ ≫ γ ∧ f₄ ≫ γ = g₂ ≫ β :=
begin
  let sa := max₃ k₁ l k₂,
  let sb := coeq (f₁ ≫ first_to_max₃ k₁ l k₂) (g₁ ≫ second_to_max₃ k₁ l k₂),
  let sc := coeq (f₂ ≫ first_to_max₃ k₁ l k₂) (f₃ ≫ third_to_max₃ k₁ l k₂),
  let sd := coeq (f₄ ≫ third_to_max₃ k₁ l k₂) (g₂ ≫ second_to_max₃ k₁ l k₂),
  let se := max₃ sb sc sd,
  let sf := coeq₃ (coeq_hom _ _ ≫ first_to_max₃ sb sc sd)
    (coeq_hom _ _ ≫ second_to_max₃ sb sc sd) (coeq_hom _ _ ≫ third_to_max₃ sb sc sd),
  use sf,
  use first_to_max₃ k₁ l k₂ ≫ coeq_hom _ _ ≫ first_to_max₃ sb sc sd ≫ coeq₃_hom _ _ _,
  use second_to_max₃ k₁ l k₂ ≫ coeq_hom _ _ ≫ second_to_max₃ sb sc sd ≫ coeq₃_hom _ _ _,
  use third_to_max₃ k₁ l k₂ ≫ coeq_hom _ _ ≫ third_to_max₃ sb sc sd ≫ coeq₃_hom _ _ _,
  fsplit,
  slice_lhs 1 3 { rw [← category.assoc, coeq_condition] },
  slice_lhs 3 6 { rw [← category.assoc, coeq₃_condition₁] },
  simp only [category.assoc],
  fsplit,
  slice_lhs 3 6 { rw [← category.assoc, coeq₃_condition₁] },
  slice_lhs 1 3 { rw [← category.assoc, coeq_condition] },
  slice_rhs 3 6 { rw [← category.assoc, ← coeq₃_condition₂] },
  simp only [category.assoc],
  slice_rhs 3 6 { rw [← category.assoc, coeq₃_condition₂] },
  slice_rhs 1 3 { rw [← category.assoc, ← coeq_condition] },
  simp only [category.assoc],
end

end special_shapes

end is_filtered

/--
A category `is_cofiltered_or_empty` if
1. for every pair of objects there exists another object "to the left", and
2. for every pair of parallel morphisms there exists a morphism to the left so the compositions
   are equal.
-/
class is_cofiltered_or_empty : Prop :=
(cocone_objs : ∀ (X Y : C), ∃ W (f : W ⟶ X) (g : W ⟶ Y), true)
(cocone_maps : ∀ ⦃X Y : C⦄ (f g : X ⟶ Y), ∃ W (h : W ⟶ X), h ≫ f = h ≫ g)

/--
A category `is_cofiltered` if
1. for every pair of objects there exists another object "to the left",
2. for every pair of parallel morphisms there exists a morphism to the left so the compositions
   are equal, and
3. there exists some object.

See <https://stacks.math.columbia.edu/tag/04AZ>.
-/
class is_cofiltered extends is_cofiltered_or_empty C : Prop :=
[nonempty : nonempty C]

@[priority 100]
instance is_cofiltered_or_empty_of_semilattice_inf
  (α : Type u) [semilattice_inf α] : is_cofiltered_or_empty α :=
{ cocone_objs := λ X Y, ⟨X ⊓ Y, hom_of_le inf_le_left, hom_of_le inf_le_right, trivial⟩,
  cocone_maps := λ X Y f g, ⟨X, 𝟙 _, (by ext)⟩, }

@[priority 100]
instance is_cofiltered_of_semilattice_inf_nonempty
  (α : Type u) [semilattice_inf α] [nonempty α] : is_cofiltered α := {}

@[priority 100]
instance is_cofiltered_or_empty_of_directed_ge (α : Type u) [preorder α]
  [is_directed α (≥)] :
  is_cofiltered_or_empty α :=
{ cocone_objs := λ X Y, let ⟨Z, hX, hY⟩ := exists_le_le X Y in
    ⟨Z, hom_of_le hX, hom_of_le hY, trivial⟩,
  cocone_maps := λ X Y f g, ⟨X, 𝟙 _, by simp⟩ }

@[priority 100]
instance is_cofiltered_of_directed_ge_nonempty  (α : Type u) [preorder α] [is_directed α (≥)]
  [nonempty α] :
  is_cofiltered α := {}

-- Sanity checks
example (α : Type u) [semilattice_inf α] [order_bot α] : is_cofiltered α := by apply_instance
example (α : Type u) [semilattice_inf α] [order_top α] : is_cofiltered α := by apply_instance

namespace is_cofiltered

variables {C} [is_cofiltered C]

/--
`min j j'` is an arbitrary choice of object to the left of both `j` and `j'`,
whose existence is ensured by `is_cofiltered`.
-/
noncomputable def min (j j' : C) : C :=
(is_cofiltered_or_empty.cocone_objs j j').some

/--
`min_to_left j j'` is an arbitrarily choice of morphism from `min j j'` to `j`,
whose existence is ensured by `is_cofiltered`.
-/
noncomputable def min_to_left (j j' : C) : min j j' ⟶ j :=
(is_cofiltered_or_empty.cocone_objs j j').some_spec.some

/--
`min_to_right j j'` is an arbitrarily choice of morphism from `min j j'` to `j'`,
whose existence is ensured by `is_cofiltered`.
-/
noncomputable def min_to_right (j j' : C) : min j j' ⟶ j' :=
(is_cofiltered_or_empty.cocone_objs j j').some_spec.some_spec.some

/--
`eq f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of object
which admits a morphism `eq_hom f f' : eq f f' ⟶ j` such that
`eq_condition : eq_hom f f' ≫ f = eq_hom f f' ≫ f'`.
Its existence is ensured by `is_cofiltered`.
-/
noncomputable def eq {j j' : C} (f f' : j ⟶ j') : C :=
(is_cofiltered_or_empty.cocone_maps f f').some

/--
`eq_hom f f'`, for morphisms `f f' : j ⟶ j'`, is an arbitrary choice of morphism
`eq_hom f f' : eq f f' ⟶ j` such that
`eq_condition : eq_hom f f' ≫ f = eq_hom f f' ≫ f'`.
Its existence is ensured by `is_cofiltered`.
-/
noncomputable def eq_hom {j j' : C} (f f' : j ⟶ j') : eq f f' ⟶ j :=
(is_cofiltered_or_empty.cocone_maps f f').some_spec.some

/--
`eq_condition f f'`, for morphisms `f f' : j ⟶ j'`, is the proof that
`eq_hom f f' ≫ f = eq_hom f f' ≫ f'`.
-/
@[simp, reassoc]
lemma eq_condition {j j' : C} (f f' : j ⟶ j') : eq_hom f f' ≫ f = eq_hom f f' ≫ f' :=
(is_cofiltered_or_empty.cocone_maps f f').some_spec.some_spec

open category_theory.limits

/--
Any finite collection of objects in a cofiltered category has an object "to the left".
-/
lemma inf_objs_exists (O : finset C) : ∃ (S : C), ∀ {X}, X ∈ O → _root_.nonempty (S ⟶ X) :=
begin
  classical,
  apply finset.induction_on O,
  { exact ⟨is_cofiltered.nonempty.some, (by rintros - ⟨⟩)⟩, },
  { rintros X O' nm ⟨S', w'⟩,
    use min X S',
    rintros Y mY,
    obtain rfl|h := eq_or_ne Y X,
    { exact ⟨min_to_left _ _⟩, },
    { exact ⟨min_to_right _ _ ≫ (w' (finset.mem_of_mem_insert_of_ne mY h)).some⟩, }, }
end

variables (O : finset C) (H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y))

/--
Given any `finset` of objects `{X, ...}` and
indexed collection of `finset`s of morphisms `{f, ...}` in `C`,
there exists an object `S`, with a morphism `T X : S ⟶ X` from each `X`,
such that the triangles commute: `T X ≫ f = T Y`, for `f : X ⟶ Y` in the `finset`.
-/
lemma inf_exists :
  ∃ (S : C) (T : Π {X : C}, X ∈ O → (S ⟶ X)), ∀ {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y},
    (⟨X, Y, mX, mY, f⟩ : (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y)) ∈ H → T mX ≫ f = T mY :=
begin
  classical,
  apply finset.induction_on H,
  { obtain ⟨S, f⟩ := inf_objs_exists O,
    refine ⟨S, λ X mX, (f mX).some, _⟩,
    rintros - - - - - ⟨⟩, },
  { rintros ⟨X, Y, mX, mY, f⟩ H' nmf ⟨S', T', w'⟩,
    refine ⟨eq (T' mX ≫ f) (T' mY), λ Z mZ, eq_hom (T' mX ≫ f) (T' mY) ≫ T' mZ, _⟩,
    intros X' Y' mX' mY' f' mf',
    rw [category.assoc],
    by_cases h : X = X' ∧ Y = Y',
    { rcases h with ⟨rfl, rfl⟩,
      by_cases hf : f = f',
      { subst hf,
        apply eq_condition, },
      { rw @w' _ _ mX mY f' (by simpa [hf ∘ eq.symm] using mf') }, },
    { rw @w' _ _ mX' mY' f' _,
      apply finset.mem_of_mem_insert_of_ne mf',
      contrapose! h,
      obtain ⟨rfl, h⟩ := h,
      rw [heq_iff_eq, psigma.mk.inj_iff] at h,
      exact ⟨rfl, h.1.symm⟩ }, },
end

/--
An arbitrary choice of object "to the left"
of a finite collection of objects `O` and morphisms `H`,
making all the triangles commute.
-/
noncomputable
def inf : C :=
(inf_exists O H).some

/--
The morphisms from `inf O H`.
-/
noncomputable
def inf_to {X : C} (m : X ∈ O) :
  inf O H ⟶ X :=
(inf_exists O H).some_spec.some m

/--
The triangles consisting of a morphism in `H` and the maps from `inf O H` commute.
-/
lemma inf_to_commutes
  {X Y : C} (mX : X ∈ O) (mY : Y ∈ O) {f : X ⟶ Y}
  (mf : (⟨X, Y, mX, mY, f⟩ : Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) ∈ H) :
  inf_to O H mX ≫ f = inf_to O H mY :=
(inf_exists O H).some_spec.some_spec mX mY mf

variables {J : Type v} [small_category J] [fin_category J]

/--
If we have `is_cofiltered C`, then for any functor `F : J ⥤ C` with `fin_category J`,
there exists a cone over `F`.
-/
lemma cone_nonempty (F : J ⥤ C) : _root_.nonempty (cone F) :=
begin
  classical,
  let O := (finset.univ.image F.obj),
  let H : finset (Σ' (X Y : C) (mX : X ∈ O) (mY : Y ∈ O), X ⟶ Y) :=
    finset.univ.bUnion (λ X : J, finset.univ.bUnion (λ Y : J, finset.univ.image (λ f : X ⟶ Y,
      ⟨F.obj X, F.obj Y, by simp, by simp, F.map f⟩))),
  obtain ⟨Z, f, w⟩ := inf_exists O H,
  refine ⟨⟨Z, ⟨λ X, f (by simp), _⟩⟩⟩,
  intros j j' g,
  dsimp,
  simp only [category.id_comp],
  symmetry,
  apply w,
  simp only [finset.mem_univ, finset.mem_bUnion, exists_and_distrib_left,
    exists_prop_of_true, finset.mem_image],
  exact ⟨j, rfl, j', g, (by simp)⟩,
end

/--
An arbitrary choice of cone over `F : J ⥤ C`, for `fin_category J` and `is_cofiltered C`.
-/
noncomputable def cone (F : J ⥤ C) : cone F :=
(cone_nonempty F).some

variables {D : Type u₁} [category.{v₁} D]

/--
If `C` is cofiltered, and we have a functor `L : C ⥤ D` with a right adjoint,
then `D` is cofiltered.
-/
lemma of_left_adjoint {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) : is_cofiltered D :=
{ cocone_objs := λ X Y,
    ⟨L.obj (min (R.obj X) (R.obj Y)),
      (h.hom_equiv _ X).symm (min_to_left _ _), (h.hom_equiv _ Y).symm (min_to_right _ _), ⟨⟩⟩,
  cocone_maps := λ X Y f g,
    ⟨L.obj (eq (R.map f) (R.map g)), (h.hom_equiv _ _).symm (eq_hom _ _),
     by rw [← h.hom_equiv_naturality_right_symm, ← h.hom_equiv_naturality_right_symm,
       eq_condition]⟩,
  nonempty := is_cofiltered.nonempty.map L.obj }

/-- If `C` is cofiltered, and we have a left adjoint functor `L : C ⥤ D`, then `D` is cofiltered. -/

/-- Being cofiltered is preserved by equivalence of categories. -/
lemma of_equivalence (h : C ≌ D) : is_cofiltered D :=
of_left_adjoint h.to_adjunction

end is_cofiltered

section opposite
open opposite

instance is_cofiltered_op_of_is_filtered [is_filtered C] : is_cofiltered Cᵒᵖ :=
{ cocone_objs := λ X Y, ⟨op (is_filtered.max X.unop Y.unop),
    (is_filtered.left_to_max _ _).op, (is_filtered.right_to_max _ _).op, trivial⟩,
  cocone_maps := λ X Y f g, ⟨op (is_filtered.coeq f.unop g.unop),
    (is_filtered.coeq_hom _ _).op, begin
      rw [(show f = f.unop.op, by simp), (show g = g.unop.op, by simp),
        ← op_comp, ← op_comp],
      congr' 1,
      exact is_filtered.coeq_condition f.unop g.unop,
    end⟩,
  nonempty := ⟨op is_filtered.nonempty.some⟩ }

instance is_filtered_op_of_is_cofiltered [is_cofiltered C] : is_filtered Cᵒᵖ :=
{ cocone_objs := λ X Y, ⟨op (is_cofiltered.min X.unop Y.unop),
    (is_cofiltered.min_to_left X.unop Y.unop).op,
    (is_cofiltered.min_to_right X.unop Y.unop).op, trivial⟩,
  cocone_maps := λ X Y f g, ⟨op (is_cofiltered.eq f.unop g.unop),
    (is_cofiltered.eq_hom f.unop g.unop).op, begin
      rw [(show f = f.unop.op, by simp), (show g = g.unop.op, by simp),
        ← op_comp, ← op_comp],
      congr' 1,
      exact is_cofiltered.eq_condition f.unop g.unop,
    end⟩,
  nonempty := ⟨op is_cofiltered.nonempty.some⟩ }

end opposite

section ulift

instance [is_filtered C] : is_filtered (ulift.{u₂} C) :=
is_filtered.of_equivalence ulift.equivalence

instance [is_cofiltered C] : is_cofiltered (ulift.{u₂} C) :=
is_cofiltered.of_equivalence ulift.equivalence

instance [is_filtered C] : is_filtered (ulift_hom C) :=
is_filtered.of_equivalence ulift_hom.equiv

instance [is_cofiltered C] : is_cofiltered (ulift_hom C) :=
is_cofiltered.of_equivalence ulift_hom.equiv

instance [is_filtered C] : is_filtered (as_small C) :=
is_filtered.of_equivalence as_small.equiv

instance [is_cofiltered C] : is_cofiltered (as_small C) :=
is_cofiltered.of_equivalence as_small.equiv

end ulift

end category_theory


import data.real.basic
import tactic
import real_definitions
import utils

-- #print linarith.make_comp_with_zero

open lean.parser tactic interactive
open interactive (loc.ns)
open interactive.types
open expr

-- useful lemmas:
-- ge_iff_le
-- gt_iff_lt
-- lt_of_le_of_ne
-- le_of_lt
-- div_pos
-- mul_pos
-- inv_pos

open tactic.interactive

-------------------------------------------
-------------------------------------------
-- Make 'a < b' from 'a ≠ b' and 'a ≤ b' --
-------------------------------------------
-------------------------------------------
-- This is achieved by the following sequence of tactics:
-- * make_ineq  take "a ≤ b" and "a' ≠ b'" and try to make "a < b"
-- * extract_gt extract the list of inequalities "a ≤ b" from a list of expressions
-- * extract_non_eq does the same for "a ≠ b"
-- * list_prod make the product list of two lists
-- * get_pos_from_pos_eq_from_list is build on the previous ones:
-- it takes a list of expressions,
-- extract inequalities and non-equalities,
-- take all pairs and try to make "a < b" by applying make_ineq
-- * get_pos_from_pos_eq is an interactive tactic that applies this to the local context

----------------
---- Lemmas ----
----------------
namespace compute_lemmas
lemma ineq_from_non_eq {α: Type} [linear_order α] (a b : α) : ¬ a = b ↔ (a < b ∨ b < a) :=
begin
    todo
end

/- Unused? -/
lemma definition.useful_abs {α: Type} [decidable_linear_ordered_add_comm_group α] (a: α) :
abs a = if a ≥ 0 then a else -a :=
begin
    todo
end

end compute_lemmas

open compute_lemmas

--------------------------------------------------
--------------------------------------------------
-- Detecting abs, max, strict inequalities etc. --
--------------------------------------------------
--------------------------------------------------
namespace tactic.interactive
/- Just a front-end to trace, easy to desactivate. -/
meta def compute_trace  {α : Type} [has_to_tactic_format α] (a : α) : tactic unit :=
do trace"DEBUG:", trace a

/- Check if some expression contains some constant name inside app. -/
meta def contain_cst (cst_name: name) : expr → bool
| (const a a_1) := (a = cst_name)
| (app a a_1) := (contain_cst a) ∨ (contain_cst a_1)
| _ := ff

/- Check if some expression contains some constant name of a list. -/
meta def contain_csts : (list name) × expr → bool
| ([], _) := ff
| ((n :: tail), e) := if (contain_cst n e) then tt else (contain_csts (tail, e))

/- Check if expr contains abs inside app. -/
meta def contain_abs (e: expr) : tactic bool :=
return (contain_cst `abs e)

/- List of constants that will launch `develop_ite`in `compute_n`. -/
def cst_for_ite : list name := [`abs, `max, `min] -- TODO: move in compute.cfg

/- Check if expr contains abs inside app. -/
meta def contain_ite (e: expr) : tactic bool :=
return (contain_csts (cst_for_ite, e))

/- Detect abs in target in app. -/
meta def target_abs : tactic bool :=
do  target ← tactic.target, e ← infer_type target,
    b ← contain_abs target,
    -- tactic.trace b,
    return b

/- Detect abs in target in app. -/
meta def target_ite : tactic bool :=
do  target ← tactic.target, e ← infer_type target,
    b ← contain_ite target,
    -- tactic.trace b,
    return b

-- example : 0 < 1 + max 2 3 := begin target_ite, sorry end  -- tt
-- example : 0 < 1 + 2/3 := begin target_ite, sorry end  -- ff

/- Check if target is a strict inequality. -/
meta def target_lt_or_gt : tactic bool :=
do  target ← tactic.target,
    match target with
    | `(%%a < %%b) := -- do trace "1",
        return tt
    | `(%%a > %%b) := -- do trace "2",
        return tt
    | `(¬(%%a = %%b)) := -- do trace "3",
        return tt
    | _ := -- do trace "4",
        return ff
    end

---------------------------
---------------------------
-- Chaining tactic string -
---------------------------
---------------------------
-- set_option trace.linarith true
-- set_option trace.eqn_compiler.elim_match true

/- Concatenate a list of strings using commas as separators-/
def string.concatenate : (list string) → string
-- (l: list string) : string :=
-- list.foldl (λ (s: string) (t: string), s ++ ", " ++ t) "" l
| []  := ""
| [s] := s
| ("" :: tail) := string.concatenate tail
| (head :: tail) := do let tail_string := string.concatenate tail,
                    match tail_string with
                    | "" := head
                    | _  := head ++ ", " ++ tail_string
                    end

/- Try some (tactic string) and in case of success return its string.
Always succeed. -/
meta def try_and_return_code (my_tactic: tactic string) : tactic string :=
do {s ← my_tactic, return s} <|> return ""

meta def norm_num_and_return_code : tactic string :=
do `[norm_num at *, return "norm_num at *"] <|> return ""

/- Iterate some (tactic string) and return the concatenated returned strings.
Stops as soon as the tactic makes no progress,
i.e. returns the empty string or num_goals = 0.
Fail if some tactic fails. -/
meta def iterate_and_return_code : nat → tactic string → tactic string
| 0       my_tactic := return ""
| (n + 1) my_tactic := do -- trace "(iterating tactic...)",
    first_code ← my_tactic, l ← num_goals,
    match first_code, l with
    | "", _  := return ""
    | s, 0   := return s
    | _ , _  := do
        remaining_code ← iterate_and_return_code n my_tactic,
        return $ string.concatenate [first_code, remaining_code]
    end

/- Apply successively tactics in a given list,
but stop as soon as there is no more goal,
and return concatenation of returned code.
Fail if some tactic fails. -/
meta def and_then_and_return_code : list (tactic string) → tactic string
| []                  := return ""
| (first_tac :: tail) :=  do
    first_code ← first_tac, l ← num_goals,
    match first_code, l with
    | s, 0   := return s
    | _ , _  := do
        remaining_code ← and_then_and_return_code tail,
        return $ string.concatenate [first_code, remaining_code]
    end

meta def or_else_and_return_code : list (tactic string) → tactic string
| [] := fail ""
| (head :: tail) := do head <|> or_else_and_return_code tail

/- Try some tactic to solve all current goals. If the tactic fails to solve some goal, then
stop and fail. Otherwiser, return the list of successfull codes. -/
meta def solve_all_and_return_code (tac: tactic string) : tactic (string) :=
 do strings ← tactic.all_goals tac, return (string.concatenate strings)

meta def try_tactic_string (my_tac: tactic string) : tactic string :=
do {my_tac <|> return ""}

meta def skip_tactic_string : tactic string :=
do {skip, return ""}

/- Apply some tactic string and trace the returned string as effective code with id-/
meta def apply_and_trace_code (id: string) (my_tactic: tactic string) : tactic unit:=
do  effective_code ← my_tactic,
    tactic.trace $ "EFFECTIVE CODE LEAN n°" ++ id ++ ":" ++ effective_code,
    tactic.trace $ "Try this: "++ effective_code

-------------------
-------------------
-- Pre-processing -
-------------------
-------------------
/- Series of tactic when target is a strict inequality, or contains abs / min / max. -/

lemma inv_pos_mpr {α : Type} [linear_ordered_field α] (a:α) :
0 < a → 0 < a⁻¹ := inv_pos.mpr

-- TODO: when target abs add  apply abs_pos_of_ne_zero, apply sub_ne_zero_of_ne,

/- Unfold some definitions using if_then_else, then get rid of if_then_else by case reasoning.
Unfolded definitions includes abs, max, min. (Fails if there is nothing to unfold.) -/
meta def develop_ite : tactic string :=
    -- do ite ← target_ite, if ite then
        do  {`[unfold abs], `[unfold min max], `[split_ifs],
             compute_trace "develope ite, #goals = ", compute_trace num_goals,  -- for debugging
             return "unfold abs, unfold min max, split_ifs"}
       --  else return "COMPUTE DEBUG: (no if-then-else found)"

/- The same for all goals: more precisely, keep unfolding and splitting in any goal
until there is nothing to unfold anymore. Always succeeds. -/
meta def develop_ite' : tactic string :=
    -- do ite ← target_ite, if ite then
        do  {`[repeat {any_goals {unfold abs, unfold min max, split_ifs}}],
             compute_trace "develope ite', #goals = ", compute_trace num_goals,  -- for debugging
             return "repeat {any_goals {unfold abs, unfold min max, split_ifs}}"}
       --  else return "COMPUTE DEBUG: (no if-then-else found)"

/- Split non-equalities `a≠b` into `a<b or b<a`, then split cases. -/
meta def develop_neq : tactic string :=
    -- do ineq ← target_lt_or_gt, if ineq then
        do {`[rw ineq_from_non_eq at *], `[cases_type* or],
            compute_trace "develope neq, #goals = ", compute_trace num_goals,  -- for debugging
            return "rw ineq_from_non_eq at *, cases_type* or"}
        -- else return "(target is not a strict inequality)"

meta def split_tacs : (bool × bool) → list (tactic string)
        | (tt, tt) := [develop_neq, develop_ite'] -- todo
        | (tt, ff) := [develop_neq]
        | (ff, tt) := [develop_ite]
        | (ff, ff) := []

meta def mk_tac_str : (name × string) → tactic string
| (n, s) := do {tactic.applyc ``n, return s}

-------------------
-------------------
-- Tactic compute -
-------------------
-------------------
/-- A configuration object for `compute1`.
 develop_ite: set to tt to develop if_then_else definitions, e.g. abs and max.
 -/
meta structure compute_config : Type :=
(nb_iterations : nat := 1)
(develop_ite : bool := tt) -- unused
(develop_neq : bool := tt) -- unused
(ineq_tactics: list (name × string) := [(`mul_pos, "mul_pos"),
                                        (`inv_pos_mpr, "inv_pos.mpr"),
                                        (`mul_ne_zero, "mul_ne_zero")])

open linarith
/- Non-interactive version of nl_linarith. -/
meta def nl_linarith (cfg : linarith_config := {}): tactic unit :=
do
{
tactic.linarith false false []
  { cfg with preprocessors := some $
      cfg.preprocessors.get_or_else default_preprocessors ++ [nlinarith_extras] }
}

/- Try assumption, tautology, linarith, nl_linarith. -/
meta def compute1 : tactic string :=
do compute_trace "(compute1...)",
do {   do {assumption, return "assumption"}
    <|>
    -- solve e.g. "n_0 ≤ n_0 ∨ n_0 ≤ n_1"
    -- with norm_num, solves "n_0 ≤ max n_0 n_1"
    do {tactic.tautology, return "tautology"}
    <|>
    do {tactic.linarith false false [], return "linarith"}
    <|>
    do {nl_linarith, return "nl_linarith"}
}

/- Repeat n times the tactic compute1, inserting various strategies according to
whether
            -- target is a stric inequality, and
            -- contains ite expr (`abs`, `max`, and so on).
Always start with linarith before splitting.
-/
meta def compute_n  (cfg: compute_config := {}) : tactic string :=
    do  t_ineq ← target_lt_or_gt, t_abs ← target_ite, match (t_ineq, t_abs) with
        | (ff, ff) := do compute_trace "Target is NOT a strict inequality and does NOT contain ite",
            compute1 -- nothing more to try here (?)
        | (ff, tt) := do compute_trace "Target is NOT a strict inequality but contains ite",
        -- Essentially unfold def and split if_then_else, then re-try linarith
            let ite_tacs :=
                and_then_and_return_code [develop_ite,
                                          (solve_all_and_return_code compute1)]
            in or_else_and_return_code [compute1, ite_tacs]
        | (tt, ff) := do compute_trace "Target is a strict inequality but does NOT contain ite",
        -- Essentially try successively specific tactics on the target and linarith
            let ineq_tacs_1 :=
                iterate_and_return_code cfg.nb_iterations $ or_else_and_return_code $
                    (cfg.ineq_tactics.map mk_tac_str) ++ [compute1]
            -- if this fails then split non_equalities
            in let ineq_tacs_2 :=
                and_then_and_return_code [develop_neq, (solve_all_and_return_code compute1)]
            in or_else_and_return_code [compute1, ineq_tacs_1, ineq_tacs_2]
        | (tt, tt) := do compute_trace "Target is a strict inequality and contains ite",
            let ineq_tacs_1 :=
                iterate_and_return_code cfg.nb_iterations $ or_else_and_return_code $
                    (cfg.ineq_tactics.map mk_tac_str) ++ [compute1]
            -- if this fails then split non_equalities
            in let ineq_tacs_2 :=
                and_then_and_return_code [try_and_return_code develop_neq, develop_ite', (solve_all_and_return_code compute1)]
            in or_else_and_return_code [compute1, ineq_tacs_1, ineq_tacs_2]
        end

/- Apply norm_num at * if possible, then the compute_n tactic n times,
and in case of success trace the effective code with id. -/
meta def compute_and_trace_code (id: string)  (cfg: compute_config := {}):
tactic unit := let tacs := [norm_num_and_return_code, (tactic.interactive.compute_n cfg)] in
do apply_and_trace_code id (and_then_and_return_code tacs)

end tactic.interactive


/-
Copyright (c) 2020 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.pi
import Mathlib.group_theory.group_action.default
import Mathlib.data.support
import Mathlib.data.finset.lattice
import Mathlib.PostPort

universes u_1 u_3 u_2 u_4 u_5

namespace Mathlib

/-!
# Indicator function

`indicator (s : set α) (f : α → β) (a : α)` is `f a` if `a ∈ s` and is `0` otherwise.

## Implementation note

In mathematics, an indicator function or a characteristic function is a function used to indicate
membership of an element in a set `s`, having the value `1` for all elements of `s` and the value `0`
otherwise. But since it is usually used to restrict a function to a certain set `s`, we let the
indicator function take the value `f x` for some function `f`, instead of `1`. If the usual indicator
function is needed, just set `f` to be the constant function `λx, 1`.

## Tags
indicator, characteristic
-/

namespace set

/-- `indicator s f a` is `f a` if `a ∈ s`, `0` otherwise.  -/
def indicator {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (f : α → β) : α → β :=
  fun (x : α) => ite (x ∈ s) (f x) 0

@[simp] theorem piecewise_eq_indicator {α : Type u_1} {β : Type u_3} [HasZero β] {f : α → β} {s : set α} : piecewise s f 0 = indicator s f :=
  rfl

theorem indicator_apply {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (f : α → β) (a : α) : indicator s f a = ite (a ∈ s) (f a) 0 :=
  rfl

@[simp] theorem indicator_of_mem {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {a : α} (h : a ∈ s) (f : α → β) : indicator s f a = f a :=
  if_pos h

@[simp] theorem indicator_of_not_mem {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {a : α} (h : ¬a ∈ s) (f : α → β) : indicator s f a = 0 :=
  if_neg h

theorem indicator_eq_zero_or_self {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (f : α → β) (a : α) : indicator s f a = 0 ∨ indicator s f a = f a :=
  dite (a ∈ s) (fun (h : a ∈ s) => Or.inr (indicator_of_mem h f)) fun (h : ¬a ∈ s) => Or.inl (indicator_of_not_mem h f)

/-- If an indicator function is nonzero at a point, that
point is in the set. -/
theorem mem_of_indicator_ne_zero {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} {a : α} (h : indicator s f a ≠ 0) : a ∈ s :=
  iff.mp not_imp_comm (fun (hn : ¬a ∈ s) => indicator_of_not_mem hn f) h

theorem eq_on_indicator {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} : eq_on (indicator s f) f s :=
  fun (x : α) (hx : x ∈ s) => indicator_of_mem hx f

theorem support_indicator {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} : function.support (indicator s f) ⊆ s :=
  fun (x : α) (hx : x ∈ function.support (indicator s f)) =>
    not.imp_symm (fun (h : ¬x ∈ s) => indicator_of_not_mem h f) hx

@[simp] theorem indicator_apply_eq_self {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} {a : α} : indicator s f a = f a ↔ ¬a ∈ s → f a = 0 :=
  iff.trans ite_eq_left_iff
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬a ∈ s → 0 = f a ↔ ¬a ∈ s → f a = 0)) (propext eq_comm)))
      (iff.refl (¬a ∈ s → 0 = f a)))

@[simp] theorem indicator_eq_self {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} : indicator s f = f ↔ function.support f ⊆ s := sorry

@[simp] theorem indicator_support {α : Type u_1} {β : Type u_3} [HasZero β] {f : α → β} : indicator (function.support f) f = f :=
  iff.mpr indicator_eq_self (subset.refl (function.support f))

@[simp] theorem indicator_apply_eq_zero {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} {a : α} : indicator s f a = 0 ↔ a ∈ s → f a = 0 :=
  ite_eq_right_iff

@[simp] theorem indicator_eq_zero {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} : (indicator s f = fun (x : α) => 0) ↔ disjoint (function.support f) s := sorry

@[simp] theorem indicator_eq_zero' {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} : indicator s f = 0 ↔ disjoint (function.support f) s :=
  indicator_eq_zero

@[simp] theorem indicator_range_comp {α : Type u_1} {β : Type u_3} [HasZero β] {ι : Sort u_2} (f : ι → α) (g : α → β) : indicator (range f) g ∘ f = g ∘ f :=
  piecewise_range_comp f (fun (x : α) => g x) fun (x : α) => 0

theorem indicator_congr {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} {g : α → β} (h : ∀ (a : α), a ∈ s → f a = g a) : indicator s f = indicator s g := sorry

@[simp] theorem indicator_univ {α : Type u_1} {β : Type u_3} [HasZero β] (f : α → β) : indicator univ f = f :=
  iff.mpr indicator_eq_self (subset_univ (function.support f))

@[simp] theorem indicator_empty {α : Type u_1} {β : Type u_3} [HasZero β] (f : α → β) : indicator ∅ f = fun (a : α) => 0 :=
  iff.mpr indicator_eq_zero (disjoint_empty (function.support f))

@[simp] theorem indicator_zero {α : Type u_1} (β : Type u_3) [HasZero β] (s : set α) : (indicator s fun (x : α) => 0) = fun (x : α) => 0 := sorry

@[simp] theorem indicator_zero' {α : Type u_1} (β : Type u_3) [HasZero β] {s : set α} : indicator s 0 = 0 :=
  indicator_zero β s

theorem indicator_indicator {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (t : set α) (f : α → β) : indicator s (indicator t f) = indicator (s ∩ t) f := sorry

theorem comp_indicator {α : Type u_1} {β : Type u_3} {γ : Type u_4} [HasZero β] (h : β → γ) (f : α → β) {s : set α} {x : α} : h (indicator s f x) = piecewise s (h ∘ f) (function.const α (h 0)) x :=
  comp_piecewise s h

theorem indicator_comp_right {α : Type u_1} {β : Type u_3} {γ : Type u_4} [HasZero β] {s : set α} (f : γ → α) {g : α → β} {x : γ} : indicator (f ⁻¹' s) (g ∘ f) x = indicator s g (f x) := sorry

theorem indicator_comp_of_zero {α : Type u_1} {β : Type u_3} {γ : Type u_4} [HasZero β] {s : set α} {f : α → β} [HasZero γ] {g : β → γ} (hg : g 0 = 0) : indicator s (g ∘ f) = g ∘ indicator s f := sorry

theorem indicator_preimage {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (f : α → β) (B : set β) : indicator s f ⁻¹' B = s ∩ f ⁻¹' B ∪ sᶜ ∩ (fun (a : α) => 0) ⁻¹' B :=
  piecewise_preimage s f 0 B

theorem indicator_preimage_of_not_mem {α : Type u_1} {β : Type u_3} [HasZero β] (s : set α) (f : α → β) {t : set β} (ht : ¬0 ∈ t) : indicator s f ⁻¹' t = s ∩ f ⁻¹' t := sorry

theorem mem_range_indicator {α : Type u_1} {β : Type u_3} [HasZero β] {r : β} {s : set α} {f : α → β} : r ∈ range (indicator s f) ↔ r = 0 ∧ s ≠ univ ∨ r ∈ f '' s := sorry

theorem indicator_rel_indicator {α : Type u_1} {β : Type u_3} [HasZero β] {s : set α} {f : α → β} {g : α → β} {a : α} {r : β → β → Prop} (h0 : r 0 0) (ha : a ∈ s → r (f a) (g a)) : r (indicator s f a) (indicator s g a) := sorry

/-- Consider a sum of `g i (f i)` over a `finset`.  Suppose `g` is a
function such as multiplication, which maps a second argument of 0 to
0.  (A typical use case would be a weighted sum of `f i * h i` or `f i
• h i`, where `f` gives the weights that are multiplied by some other
function `h`.)  Then if `f` is replaced by the corresponding indicator
function, the `finset` may be replaced by a possibly larger `finset`
without changing the value of the sum. -/
theorem sum_indicator_subset_of_eq_zero {α : Type u_1} {β : Type u_3} [HasZero β] {γ : Type u_2} [add_comm_monoid γ] (f : α → β) (g : α → β → γ) {s₁ : finset α} {s₂ : finset α} (h : s₁ ⊆ s₂) (hg : ∀ (a : α), g a 0 = 0) : (finset.sum s₁ fun (i : α) => g i (f i)) = finset.sum s₂ fun (i : α) => g i (indicator (↑s₁) f i) := sorry

/-- Summing an indicator function over a possibly larger `finset` is
the same as summing the original function over the original
`finset`. -/
theorem sum_indicator_subset {α : Type u_1} {γ : Type u_2} [add_comm_monoid γ] (f : α → γ) {s₁ : finset α} {s₂ : finset α} (h : s₁ ⊆ s₂) : (finset.sum s₁ fun (i : α) => f i) = finset.sum s₂ fun (i : α) => indicator (↑s₁) f i :=
  sum_indicator_subset_of_eq_zero (fun (i : α) => f i) (fun (a : α) (b : γ) => b) h fun (_x : α) => rfl

theorem indicator_union_of_not_mem_inter {α : Type u_1} {β : Type u_3} [add_monoid β] {s : set α} {t : set α} {a : α} (h : ¬a ∈ s ∩ t) (f : α → β) : indicator (s ∪ t) f a = indicator s f a + indicator t f a := sorry

theorem indicator_union_of_disjoint {α : Type u_1} {β : Type u_3} [add_monoid β] {s : set α} {t : set α} (h : disjoint s t) (f : α → β) : indicator (s ∪ t) f = fun (a : α) => indicator s f a + indicator t f a := sorry

theorem indicator_add {α : Type u_1} {β : Type u_3} [add_monoid β] (s : set α) (f : α → β) (g : α → β) : (indicator s fun (a : α) => f a + g a) = fun (a : α) => indicator s f a + indicator s g a := sorry

@[simp] theorem indicator_compl_add_self_apply {α : Type u_1} {β : Type u_3} [add_monoid β] (s : set α) (f : α → β) (a : α) : indicator (sᶜ) f a + indicator s f a = f a := sorry

@[simp] theorem indicator_compl_add_self {α : Type u_1} {β : Type u_3} [add_monoid β] (s : set α) (f : α → β) : indicator (sᶜ) f + indicator s f = f :=
  funext (indicator_compl_add_self_apply s f)

@[simp] theorem indicator_self_add_compl_apply {α : Type u_1} {β : Type u_3} [add_monoid β] (s : set α) (f : α → β) (a : α) : indicator s f a + indicator (sᶜ) f a = f a := sorry

@[simp] theorem indicator_self_add_compl {α : Type u_1} {β : Type u_3} [add_monoid β] (s : set α) (f : α → β) : indicator s f + indicator (sᶜ) f = f :=
  funext (indicator_self_add_compl_apply s f)

protected instance is_add_monoid_hom.indicator {α : Type u_1} (β : Type u_3) [add_monoid β] (s : set α) : is_add_monoid_hom fun (f : α → β) => indicator s f :=
  is_add_monoid_hom.mk (indicator_zero β s)

theorem indicator_smul {α : Type u_1} {β : Type u_3} [add_monoid β] {𝕜 : Type u_5} [monoid 𝕜] [distrib_mul_action 𝕜 β] (s : set α) (r : 𝕜) (f : α → β) : (indicator s fun (x : α) => r • f x) = fun (x : α) => r • indicator s f x := sorry

theorem indicator_add_eq_left {α : Type u_1} {β : Type u_3} [add_monoid β] {f : α → β} {g : α → β} (h : univ ⊆ f ⁻¹' singleton 0 ∪ g ⁻¹' singleton 0) : indicator (f ⁻¹' singleton 0ᶜ) (f + g) = f := sorry

theorem indicator_add_eq_right {α : Type u_1} {β : Type u_3} [add_monoid β] {f : α → β} {g : α → β} (h : univ ⊆ f ⁻¹' singleton 0 ∪ g ⁻¹' singleton 0) : indicator (g ⁻¹' singleton 0ᶜ) (f + g) = g := sorry

protected instance is_add_group_hom.indicator {α : Type u_1} (β : Type u_3) [add_group β] (s : set α) : is_add_group_hom fun (f : α → β) => indicator s f :=
  is_add_group_hom.mk

theorem indicator_neg {α : Type u_1} {β : Type u_3} [add_group β] (s : set α) (f : α → β) : (indicator s fun (a : α) => -f a) = fun (a : α) => -indicator s f a :=
  (fun (this : indicator s (-f) = -indicator s f) => this) (is_add_group_hom.map_neg (indicator s) f)

theorem indicator_sub {α : Type u_1} {β : Type u_3} [add_group β] (s : set α) (f : α → β) (g : α → β) : (indicator s fun (a : α) => f a - g a) = fun (a : α) => indicator s f a - indicator s g a :=
  (fun (this : indicator s (f - g) = indicator s f - indicator s g) => this) (is_add_group_hom.map_sub (indicator s) f g)

theorem indicator_compl {α : Type u_1} {β : Type u_3} [add_group β] (s : set α) (f : α → β) : indicator (sᶜ) f = f - indicator s f :=
  eq_sub_of_add_eq (indicator_compl_add_self s f)

theorem indicator_finset_sum {α : Type u_1} {β : Type u_2} [add_comm_monoid β] {ι : Type u_3} (I : finset ι) (s : set α) (f : ι → α → β) : indicator s (finset.sum I fun (i : ι) => f i) = finset.sum I fun (i : ι) => indicator s (f i) := sorry

theorem indicator_finset_bUnion {α : Type u_1} {β : Type u_2} [add_comm_monoid β] {ι : Type u_3} (I : finset ι) (s : ι → set α) {f : α → β} : (∀ (i : ι), i ∈ I → ∀ (j : ι), j ∈ I → i ≠ j → s i ∩ s j = ∅) →
  indicator (Union fun (i : ι) => Union fun (H : i ∈ I) => s i) f =
    fun (a : α) => finset.sum I fun (i : ι) => indicator (s i) f a := sorry

theorem indicator_mul {α : Type u_1} {β : Type u_3} [mul_zero_class β] (s : set α) (f : α → β) (g : α → β) : (indicator s fun (a : α) => f a * g a) = fun (a : α) => indicator s f a * indicator s g a := sorry

theorem indicator_mul_left {α : Type u_1} {β : Type u_3} [mul_zero_class β] {a : α} (s : set α) (f : α → β) (g : α → β) : indicator s (fun (a : α) => f a * g a) a = indicator s f a * g a := sorry

theorem indicator_mul_right {α : Type u_1} {β : Type u_3} [mul_zero_class β] {a : α} (s : set α) (f : α → β) (g : α → β) : indicator s (fun (a : α) => f a * g a) a = f a * indicator s g a := sorry

theorem indicator_prod_one {α : Type u_1} {α' : Type u_2} {β : Type u_3} [monoid_with_zero β] {s : set α} {t : set α'} {x : α} {y : α'} : indicator (set.prod s t) 1 (x, y) = indicator s 1 x * indicator t 1 y := sorry

theorem indicator_nonneg' {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} {a : α} (h : a ∈ s → 0 ≤ f a) : 0 ≤ indicator s f a := sorry

theorem indicator_nonneg {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} (h : ∀ (a : α), a ∈ s → 0 ≤ f a) (a : α) : 0 ≤ indicator s f a :=
  indicator_nonneg' (h a)

theorem indicator_nonpos' {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} {a : α} (h : a ∈ s → f a ≤ 0) : indicator s f a ≤ 0 := sorry

theorem indicator_nonpos {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} (h : ∀ (a : α), a ∈ s → f a ≤ 0) (a : α) : indicator s f a ≤ 0 :=
  indicator_nonpos' (h a)

theorem indicator_le' {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} {g : α → β} (hfg : ∀ (a : α), a ∈ s → f a ≤ g a) (hg : ∀ (a : α), ¬a ∈ s → 0 ≤ g a) : indicator s f ≤ g := sorry

theorem indicator_le_indicator {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} {g : α → β} {a : α} (h : f a ≤ g a) : indicator s f a ≤ indicator s g a :=
  indicator_rel_indicator (le_refl 0) fun (_x : a ∈ s) => h

theorem indicator_le_indicator_of_subset {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {t : set α} {f : α → β} (h : s ⊆ t) (hf : ∀ (a : α), 0 ≤ f a) (a : α) : indicator s f a ≤ indicator t f a := sorry

theorem indicator_le_self' {α : Type u_1} {β : Type u_3} [HasZero β] [preorder β] {s : set α} {f : α → β} (hf : ∀ (x : α), ¬x ∈ s → 0 ≤ f x) : indicator s f ≤ f :=
  indicator_le' (fun (_x : α) (_x_1 : _x ∈ s) => le_refl (f _x)) hf

theorem indicator_le_self {α : Type u_1} {β : Type u_2} [canonically_ordered_add_monoid β] (s : set α) (f : α → β) : indicator s f ≤ f :=
  indicator_le_self' fun (_x : α) (_x_1 : ¬_x ∈ s) => zero_le (f _x)

theorem indicator_le {α : Type u_1} {β : Type u_2} [canonically_ordered_add_monoid β] {s : set α} {f : α → β} {g : α → β} (hfg : ∀ (a : α), a ∈ s → f a ≤ g a) : indicator s f ≤ g :=
  indicator_le' hfg fun (_x : α) (_x_1 : ¬_x ∈ s) => zero_le (g _x)

theorem indicator_Union_apply {α : Type u_1} {ι : Sort u_2} {β : Type u_3} [complete_lattice β] [HasZero β] (h0 : ⊥ = 0) (s : ι → set α) (f : α → β) (x : α) : indicator (Union fun (i : ι) => s i) f x = supr fun (i : ι) => indicator (s i) f x := sorry

end set

theorem add_monoid_hom.map_indicator {α : Type u_1} {M : Type u_2} {N : Type u_3} [add_monoid M] [add_monoid N] (f : M →+ N) (s : set α) (g : α → M) (x : α) : coe_fn f (set.indicator s g x) = set.indicator s (⇑f ∘ g) x :=
  congr_fun (Eq.symm (set.indicator_comp_of_zero (add_monoid_hom.map_zero f))) x


import Basic
import Tangle
open Brick

structure Graph (α : Type) where
  V: List α
  E: List (α × α)
  deriving Repr

namespace Graph
def from_edges {α : Type} [BEq α] (e : List (α × α)) : Graph α :=
  Graph.mk
    (e.foldr (fun n ns =>
        match (ns.elem n.fst, ns.elem n.snd) with
        | (true, true) => ns
        | (false, true) => n.fst::ns
        | (true, false) => n.snd::ns
        | (false, false) => n.snd::n.fst::ns
      )
      [])
    e

def contains_vert [BEq α] (g : Graph α) : α → Bool := g.V.elem
def contains_edge_directed [BEq α] (g : Graph α) : (α × α) → Bool := g.E.elem
def contains_edge [BEq α] (g : Graph α) (a b : α) : Bool :=
  (g.contains_edge_directed (a, b)) ∨ (g.contains_edge_directed (b, a))

def add_vert [BEq α] (g : Graph α) (v : α) : Graph α :=
  match (g.V.elem v) with
  | true => g
  | false => Graph.mk (v::g.V) g.E

def add_edge [BEq α] (g : Graph α) (a b : α) : Graph α :=
  match g.contains_edge a b with
  | false =>
      let V := match (g.V.elem a), (g.V.elem b) with
        | true, true => g.V
        | true, false => b::g.V
        | false, true => a::g.V
        | false, false => b::a::g.V
      Graph.mk V ((a, b)::g.E)
  | _ => g

structure Acc where
  N: Nat
  I: List Nat
  O: List Nat
  E: List (Nat × Nat)
  deriving Repr

-- specialized List.zip which carries proof that lengths are equal
def zip_eq (a b : List Nat) (leneq : a.length = b.length) : List (Nat × Nat) := match a, b with
  | [], [] => []
  | a::a', b::b' =>
      have leneq' : a'.length = b'.length := by
        simp [List.length] at leneq
        assumption
      (Prod.mk a b)::(zip_eq a' b' leneq')

def stack (acc acc': Acc) (iolen: acc.O.length = acc'.I.length) : Acc :=
  Acc.mk
    (Nat.max acc.N acc'.N)
    acc.I
    acc'.O
    (((zip_eq acc.O acc'.I iolen).append acc.E).append acc'.E)

theorem stack_length_eq {acc acc' : Acc} {iolen : acc.O.length = acc'.I.length} :
  (stack acc acc' iolen).I.length = acc.I.length ∧ (stack acc acc' iolen).O.length = acc'.O.length := by
  rewrite [stack]
  simp

def acc_brick : Brick → Acc → Acc
  | Vert,  ⟨n, i, o, e⟩ => ⟨n+2, n::i,        (n+1)::o,        ⟨n, n+1⟩::e⟩
  | Cap,   ⟨n, i, o, e⟩ => ⟨n+2, i,           (n+1)::n::o,     ⟨n, n+1⟩::e⟩
  | Cup,   ⟨n, i, o, e⟩ => ⟨n+2, (n+1)::n::i, o,               ⟨n, n+1⟩::e⟩
  | Over,  ⟨n, i, o, e⟩ => ⟨n+4, (n+1)::n::i, (n+3)::(n+2)::o, ⟨n, n+3⟩::⟨n+1, n+2⟩::e⟩
  | Under, ⟨n, i, o, e⟩ => ⟨n+4, (n+1)::n::i, (n+3)::(n+2)::o, ⟨n, n+3⟩::⟨n+1, n+2⟩::e⟩

def acc_bricks (bs: Bricks) (acc: Acc) : Acc := match bs with
  | [] => acc
  | b::bs => acc_brick b (acc_bricks bs acc)

theorem acc_brick_io {b : Brick} {acc : Acc} :
      ((acc_brick b acc).I.length = acc.I.length + b.domain)
    ∧ ((acc_brick b acc).O.length = acc.O.length + b.codomain) := by
  cases b <;> simp [acc_brick, Brick.domain, Brick.codomain]

theorem acc_bricks_io {bs : Bricks} {acc : Acc} :
      ((acc_bricks bs acc).I.length = acc.I.length + bs.domain)
    ∧ ((acc_bricks bs acc).O.length = acc.O.length + bs.codomain) := by
  induction bs
  case nil => simp [acc_bricks, Bricks.domain, Bricks.codomain, List.foldr]
  case cons hd tl hind =>
    simp [acc_bricks, List.length, Bricks.domain, Bricks.codomain, List.foldr]
    rewrite [←Bricks.domain, ←Bricks.codomain]
    apply And.intro
    case left =>
      rewrite [Nat.add_comm hd.domain _, ←Nat.add_assoc]
      rewrite [acc_brick_io.left, hind.left]
      rfl
    case right =>
      rewrite [Nat.add_comm hd.codomain _, ←Nat.add_assoc]
      rewrite [acc_brick_io.right, hind.right]
      rfl

def acc_tangle_aux (bs : Bricks) (w : Wall) (ht : isTangle (bs::w)) (acc : Acc) (domeq : bs.domain = acc.O.length) : Acc := match w, ht with
  | [], _ =>
      let acc' := acc_bricks bs (Acc.mk acc.N [] [] [])
      have hs: acc.O.length = acc'.I.length := by
        rewrite [acc_bricks_io.left, List.length, domeq, Nat.add_comm, Nat.add_zero]
        exact Eq.refl _
      stack acc acc' hs
  | bs'::w, ht =>
      let acc' := acc_bricks bs (Acc.mk acc.N [] [] [])
      have hs: acc.O.length = acc'.I.length := by
        rewrite [acc_bricks_io.left, List.length, domeq, Nat.add_comm, Nat.add_zero]
        exact Eq.refl _
      let acc := stack acc acc' hs
      have hs' : bs'.domain = acc.O.length := by
        have codomeq : bs.codomain = acc.O.length := by
          rewrite [stack_length_eq.right, acc_bricks_io.right]
          simp
        rw [isTangle] at ht
        rw [←ht.left]
        exact codomeq
      have ht' : isTangle (bs'::w) := by
        rw [isTangle] at ht
        exact ht.right
      acc_tangle_aux bs' w ht' acc hs'
def acc_tangle : (t: Tangle) → (acc: Acc) → (domeq: t.domain = acc.O.length) → Acc
  | ⟨[], _⟩, acc, _ => acc
  | ⟨bs::w, prop⟩, acc, domeq => acc_tangle_aux bs w prop acc domeq

def subgraphsAux {α : Type} [BEq α] (gs : List (Graph α)) : List (α × α) → List (Graph α)
  | [] => gs
  | (a, b)::e =>
      let vnew := match gs.partition (fun vs => (vs.contains_vert a) ∨ (vs.contains_vert b)) with
        | ([], eqGrps) => (Graph.mk [a,b] [(a,b)])::eqGrps
        | (g::gs', gs) => ((gs'.foldr (fun g' g => Graph.mk (g'.V.append g.V) (g'.E.append g.E)) g).add_edge a b)::gs
      subgraphsAux vnew e
/-- partitions a graph into its independent subgraphs -/
def subgraphs {α : Type} [BEq α] (g : Graph α) : List (Graph α) :=
  subgraphsAux (g.V.map (fun v => Graph.mk [v] [])) g.E

theorem ind_subgraph_idempotent [BEq α] {g : Graph α} :
  (hlen : 0 < (subgraphs g).length)
  → subgraphs ((subgraphs g)[0]) = [(subgraphs g)[0]] := sorry

namespace Example
def g : Graph Nat := Graph.from_edges [⟨0, 1⟩]
#eval g
#eval Graph.subgraphsAux (g.V.map (fun v => Graph.mk [v] [])) g.E
#eval Graph.subgraphs g
end Example

end Graph

theorem List.iota_length_eq_n {n : Nat} : (List.iota n).length = n := by
  induction n
  case zero =>
    rewrite [List.iota, List.length]
    exact Eq.refl _
  case succ n ind =>
    rewrite [List.iota, List.length, Nat.succ_eq_add_one, ind]
    exact Eq.refl _

namespace Tangle
/-- thread count is to tangle as link number is to links -/
def thread_count (t : Tangle) : Nat :=
  let acc0 : Graph.Acc := ⟨0, [], List.iota t.domain, []⟩
  let acc := Graph.acc_tangle t acc0 (Eq.symm List.iota_length_eq_n)
  -- graph from edges
  let g := Graph.from_edges acc.E
  -- add any dangling verts, shouldn't happen with tangles?
  let g := (acc.I.append acc.O).foldr (fun v g => g.add_vert v) g
  (g.subgraphs).length

namespace Example
def unknot : Tangle :=
  let unknot : Wall := [
    [Cap],
    [Cup]
  ]
  ⟨unknot, by simp [isTangle]⟩

#eval thread_count unknot

def ltrefoil : Tangle :=
  let trefoil : Wall := [
    [Cap],
    [Vert, Cap, Vert],
    [Over, Over],
    [Vert, Under, Vert],
    [Cup, Cup]
  ]
  ⟨trefoil, by simp [isTangle]⟩

#eval List.iota ltrefoil.domain
#eval Graph.acc_tangle ltrefoil ⟨0, [], List.iota ltrefoil.domain, []⟩ (Eq.symm List.iota_length_eq_n)
#eval Graph.subgraphs (Graph.from_edges [⟨0,1⟩, ⟨1,2⟩, ⟨2,0⟩])
#eval Graph.subgraphs (Graph.from_edges (Graph.acc_tangle ltrefoil ⟨0, [], List.iota ltrefoil.domain, []⟩ (Eq.symm List.iota_length_eq_n)).E)
#eval thread_count ltrefoil

def hopf_link : Tangle :=
  let hopf_link : Wall := [
    [Cap, Cap],
    [Vert, Over, Vert],
    [Vert, Over, Vert],
    [Cup, Cup]
  ]
  ⟨hopf_link, by simp [isTangle]⟩

#eval thread_count hopf_link

end Example

end Tangle


lemma add_comm (a b : mynat) : a + b = b + a :=
begin
induction b with k Pk,
rw add_zero, rw zero_add, refl,
rw add_succ, rw succ_add, rw Pk, refl,
end