import rescale.basic
import locally_constant.Vhat

import category_theory.preadditive.additive_functor

import facts.nnreal

noncomputable theory
open_locale big_operators classical nnreal

namespace rescale

variables {N : ℝ≥0} {V : Type*}

instance [has_norm V] : has_norm (rescale N V) :=
{ norm := λ v, ∥of.symm v∥/N }

lemma norm_def [has_norm V] (v : rescale N V) : ∥v∥ = ∥of.symm v∥/N := rfl

instance [hN : fact (0 < N)] [semi_normed_group V] : semi_normed_group (rescale N V) :=
semi_normed_group.of_core (rescale N V)
{ norm_zero := show ∥(0 : V)∥/N = 0, by rw [norm_zero, zero_div],
  triangle := λ v w,
  begin
    simp only [norm_def, ← add_div],
    exact div_le_div_of_le hN.out.le (norm_add_le _ _), -- defeq abuse
  end,
  norm_neg := λ v, by { simp only [norm_def], congr' 1, exact norm_neg _ /- defeq abuse -/ } }

instance [hN : fact (0 < N)] [normed_group V] : normed_group (rescale N V) :=
normed_group.of_core (rescale N V)
{ norm_eq_zero_iff := λ v,
  begin
    have aux : (N:ℝ) ≠ 0 := ne_of_gt hN.out,
    simp only [norm_def, div_eq_zero_iff, aux, or_false],
    exact norm_eq_zero -- defeq abuse
  end,
  triangle := λ v w,
  begin
    simp only [norm_def, ← add_div],
    exact div_le_div_of_le hN.out.le (norm_add_le _ _), -- defeq abuse
  end,
  norm_neg := λ v, by { simp only [norm_def], congr' 1, exact norm_neg _ /- defeq abuse -/ } }

lemma nnnorm_def [hN : fact (0 < N)] [semi_normed_group V] (v : rescale N V) :
  ∥v∥₊ = ∥of.symm v∥₊ / N := rfl

end rescale

namespace SemiNormedGroup

variables (r r₁ r₂ : ℝ≥0) [fact (0 < r₁)] [fact (0 < r₂)]

@[simps]
def rescale (r : ℝ≥0) [hr : fact (0 < r)] : SemiNormedGroup ⥤ SemiNormedGroup :=
{ obj := λ V, of $ rescale r V,
  map := λ V₁ V₂ f,
  { to_fun := λ v, @rescale.of r V₂ $ f ((@rescale.of r V₁).symm v),
    map_add' := f.map_add, -- defeq abuse
    bound' :=
    begin
      obtain ⟨C, C_pos, hC⟩ := f.bound,
      use C,
      intro v,
      have := hC ((@rescale.of r V₁).symm v),
      rw [← div_le_div_right (show 0 < (r:ℝ), from hr.1), mul_div_assoc] at this,
      exact this,
    end },
  map_id' := λ V, rfl, -- defeq abuse
  map_comp' := λ V₁ V₂ V₃ f g, rfl /- defeq abuse -/ }

instance rescale.additive [fact (0 < r)] : (rescale r).additive :=
{ map_add' := λ V W f g, rfl /- defeq abuse -/ }

lemma norm_rescale_map_le [fact (0 < r)] {V₁ V₂ : SemiNormedGroup}
  {f : V₁ ⟶ V₂} {C : ℝ} (hf : ∥f∥ ≤ C) :
  ∥(rescale r).map f∥ ≤ C :=
begin
  refine normed_group_hom.op_norm_le_bound _ (le_trans (norm_nonneg _) hf) (λ v, _),
  dsimp,
  erw [rescale.norm_def, rescale.norm_def, equiv.symm_apply_apply, ← mul_div_assoc],
  refine div_le_div (mul_nonneg (le_trans (norm_nonneg _) hf) (norm_nonneg _))
    (normed_group_hom.le_of_op_norm_le _ hf _) _ le_rfl,
  rw nnreal.coe_pos, exact ‹fact (0 < r)›.out
end

lemma rescale_map_isometry [fact (0 < r)]
  {V₁ V₂ : SemiNormedGroup} {f : V₁ ⟶ V₂} (hf : isometry f) :
  isometry ((rescale r).map f) :=
begin
  rw normed_group_hom.isometry_iff_norm at hf ⊢,
  intro v,
  erw [rescale.norm_def, rescale.norm_def, hf ((@rescale.of r _).symm v)],
end

lemma rescale_exact [fact (0 < r)] {V₁ V₂ V₃ : SemiNormedGroup} (f : V₁ ⟶ V₂) (g : V₂ ⟶ V₃)
  (hfg : f.range = g.ker) :
  ((rescale r).map f).range = ((rescale r).map g).ker :=
begin
  ext x,
  calc x ∈ ((rescale r).map f).range ↔ x ∈ f.range : iff.rfl
  ... ↔ x ∈ g.ker : by rw hfg
  ... ↔ x ∈ ((rescale r).map g).ker : iff.rfl,
end

lemma rescale_exists_norm_le [fact (0 < r)] {V₁ V₂ : SemiNormedGroup} (f : V₁ ⟶ V₂) (C : ℝ≥0)
  (hf : ∀ y, ∃ x, f x = y ∧ ∥x∥ ≤ C * ∥y∥) :
  ∀ y, ∃ x, (rescale r).map f x = y ∧ ∥x∥ ≤ C * ∥y∥ :=
begin
  intro y,
  obtain ⟨x, h1, h2⟩ := hf ((@rescale.of r _).symm y),
  refine ⟨@rescale.of r _ x, h1, _⟩,
  erw [rescale.norm_def, rescale.norm_def],
  simp only [div_eq_mul_inv, ← mul_assoc, equiv.symm_apply_apply, ← coe_nnnorm],
  norm_cast, exact mul_le_mul' h2 le_rfl,
end

lemma nnnorm_to_rescale {V : SemiNormedGroup} (v : V) : ∥(@rescale.of r V) v∥ ≤ r⁻¹ * ∥v∥ :=
by { rw ← div_eq_inv_mul, refl }

def to_rescale [fact (0 < r)] : 𝟭 _ ⟶ rescale r :=
{ app := λ V,
  add_monoid_hom.mk_normed_group_hom'
    (add_monoid_hom.mk' (@rescale.of r V) $ λ _ _, rfl) r⁻¹ (λ v, nnnorm_to_rescale _ v),
  naturality' := λ V W f, rfl /- defeq abuse -/ }

def of_rescale [hr : fact (0 < r)] : rescale r ⟶ 𝟭 _ :=
{ app := λ V,
  add_monoid_hom.mk_normed_group_hom' (add_monoid_hom.mk' (@rescale.of r V) .symm $ λ _ _, rfl) r
  begin
    intro v,
    erw [rescale.nnnorm_def, mul_div_cancel' _ hr.1.ne'],
    exact le_rfl
  end,
  naturality' := λ V W f, rfl /- defeq abuse -/ }

@[simps]
def iso_rescale [fact (0 < r)] : 𝟭 _ ≅ (rescale r) :=
{ hom := to_rescale r,
  inv := of_rescale r, }

open _root_.category_theory

lemma iso_rescale_isometry [fact (0 < r)] (h : r = 1) (V : SemiNormedGroup) :
  isometry ((iso_rescale r).app V).hom :=
begin
  unfreezingI { cases h },
  dsimp only [nat_iso.app_hom, iso_rescale_hom],
  apply normed_group_hom.isometry_of_norm,
  intro v,
  erw [rescale.norm_def],
  simp only [div_one, subtype.coe_mk],
  refl
end

lemma norm_to_rescale_le [fact (0 < r)] (V : SemiNormedGroup) : ∥(to_rescale r).app V∥ ≤ r⁻¹ :=
normed_group_hom.mk_normed_group_hom_norm_le _
  (inv_nonneg.2 (nnreal.zero_le_coe)) (λ v, nnnorm_to_rescale _ v)

lemma nnnorm_rescale_rescale_symm {V : SemiNormedGroup} (v : (rescale r₁).obj V) :
  ∥(@rescale.of r₂ V) ((@rescale.of r₁ V).symm v)∥₊ ≤ r₁ / r₂ * ∥v∥₊ :=
begin
  apply le_of_eq,
  show _ = r₁ / r₂ * (∥(@rescale.of r₁ V).symm v∥₊ / r₁),
  simp only [add_monoid_hom.mk'_apply, div_eq_inv_mul, rescale.nnnorm_def],
  rw [mul_assoc, mul_inv_cancel_left₀ (show r₁ ≠ 0, from ne_of_gt $ fact.out _)],
  refl
end

def scale : rescale r₁ ⟶ rescale r₂ :=
{ app := λ V,
  add_monoid_hom.mk_normed_group_hom'
    (add_monoid_hom.mk' (λ v, (@rescale.of r₂ V) $ (@rescale.of r₁ V).symm v) $
      λ _ _, rfl) (r₁ / r₂) (λ v, nnnorm_rescale_rescale_symm r₁ r₂ v),
  naturality' := λ V W f, rfl /- defeq abuse -/ }

lemma norm_scale_le (V : SemiNormedGroup) : ∥(scale r₁ r₂).app V∥ ≤ (r₁ / r₂) :=
normed_group_hom.mk_normed_group_hom_norm_le _ (div_nonneg (nnreal.coe_nonneg _)
    (nnreal.coe_nonneg _)) (λ v, nnnorm_rescale_rescale_symm r₁ r₂ v)

lemma scale_comm {V₁ V₂ W₁ W₂ : SemiNormedGroup}
  (f₁ : V₁ ⟶ W₁) (f₂ : V₂ ⟶ W₂) (φ : V₁ ⟶ V₂) (ψ : W₁ ⟶ W₂) (h : f₁ ≫ ψ = φ ≫ f₂) :
  (rescale r₁).map f₁ ≫ ((rescale r₁).map ψ ≫ (scale r₁ r₂).app W₂) =
  ((rescale r₁).map φ ≫ (scale r₁ r₂).app V₂) ≫ (rescale r₂).map f₂ :=
by rw [← category.assoc, ← category_theory.functor.map_comp, nat_trans.naturality,
    nat_trans.naturality, category.assoc, ← category_theory.functor.map_comp, h]

end SemiNormedGroup


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

import for_mathlib.algebraic_topology.homotopical_algebra.cochain_complex.basic

open category_theory category_theory.preadditive algebraic_topology

variables (C : Type*) [category C] [abelian C]

namespace cochain_complex

lemma three_of_two_quasi_isomorphisms {ι : Type*} (c : complex_shape ι):
  (quasi_isomorphisms C c).three_of_two :=
{ of_comp := λ X Y Z f g hf hg, begin
    rw mem_quasi_isomorphisms_iff at hf hg ⊢,
    haveI := hf,
    haveI := hg,
    exact quasi_iso_comp f g,
  end,
  of_comp_left := λ X Y Z f g hf hfg, begin
    rw mem_quasi_isomorphisms_iff at hf hfg ⊢,
    haveI := hf,
    haveI := hfg,
    exact quasi_iso_of_comp_left f g,
  end,
  of_comp_right := λ X Y Z f g hg hfg, begin
    rw mem_quasi_isomorphisms_iff at hg hfg ⊢,
    haveI := hg,
    haveI := hfg,
    exact quasi_iso_of_comp_right f g,
  end, }

namespace minus

namespace projective_model_structure

variable {C}

def CM2 : (arrow_classes C).CM2 :=
morphism_property.three_of_two.for_inverse_image
  (three_of_two_quasi_isomorphisms C (complex_shape.up ℤ)) _

end projective_model_structure

end minus

end cochain_complex


/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Seul Baek
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.omega.clause
import Mathlib.PostPort

namespace Mathlib

/-
Linear combination of constraints.
-/

namespace omega

/-- Linear combination of constraints. The second
    argument is the list of constraints, and the first
    argument is the list of conefficients by which the
    constraints are multiplied -/
@[simp] def lin_comb : List ℕ → List term → term :=
  sorry

theorem lin_comb_holds {v : ℕ → ℤ} {ts : List term} (ns : List ℕ) : (∀ (t : term), t ∈ ts → 0 ≤ term.val v t) → 0 ≤ term.val v (lin_comb ns ts) := sorry

/-- `unsat_lin_comb ns ts` asserts that the linear combination
    `lin_comb ns ts` is unsatisfiable  -/
def unsat_lin_comb (ns : List ℕ) (ts : List term) :=
  prod.fst (lin_comb ns ts) < 0 ∧ ∀ (x : ℤ), x ∈ prod.snd (lin_comb ns ts) → x = 0

theorem unsat_lin_comb_of (ns : List ℕ) (ts : List term) : prod.fst (lin_comb ns ts) < 0 → (∀ (x : ℤ), x ∈ prod.snd (lin_comb ns ts) → x = 0) → unsat_lin_comb ns ts :=
  fun (h1 : prod.fst (lin_comb ns ts) < 0) (h2 : ∀ (x : ℤ), x ∈ prod.snd (lin_comb ns ts) → x = 0) =>
    { left := h1, right := h2 }

theorem unsat_of_unsat_lin_comb (ns : List ℕ) (ts : List term) : unsat_lin_comb ns ts → clause.unsat ([], ts) := sorry


def foo (h : ∃ x: Nat, True) := h.1
theorem contradiction : False :=
  (by decide : 0 ≠ 1) (show foo ⟨0, trivial⟩ = foo ⟨1, trivial⟩ from rfl)


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebraic_geometry.presheafed_space
import Mathlib.topology.sheaves.sheaf
import Mathlib.PostPort

universes v u l u_1

namespace Mathlib

/-!
# Sheafed spaces

Introduces the category of topological spaces equipped with a sheaf (taking values in an
arbitrary target category `C`.)

We further describe how to apply functors and natural transformations to the values of the
presheaves.
-/

namespace algebraic_geometry

/-- A `SheafedSpace C` is a topological space equipped with a sheaf of `C`s. -/
structure SheafedSpace (C : Type u) [category_theory.category C] [category_theory.limits.has_products C]
extends PresheafedSpace C
where
  sheaf_condition : Top.presheaf.sheaf_condition (PresheafedSpace.presheaf _to_PresheafedSpace)

namespace SheafedSpace

protected instance coe_carrier {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] : has_coe (SheafedSpace C) Top :=
  has_coe.mk fun (X : SheafedSpace C) => PresheafedSpace.carrier (to_PresheafedSpace X)

/-- Extract the `sheaf C (X : Top)` from a `SheafedSpace C`. -/
def sheaf {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : Top.sheaf C ↑X :=
  Top.sheaf.mk (PresheafedSpace.presheaf (to_PresheafedSpace X)) (sheaf_condition X)

@[simp] theorem as_coe {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : PresheafedSpace.carrier (to_PresheafedSpace X) = ↑X :=
  rfl

@[simp] theorem mk_coe {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (carrier : Top) (presheaf : Top.presheaf C carrier) (h : Top.presheaf.sheaf_condition (PresheafedSpace.presheaf (PresheafedSpace.mk carrier presheaf))) : ↑(mk (PresheafedSpace.mk carrier presheaf) h) = carrier :=
  rfl

protected instance topological_space {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : topological_space ↥X :=
  category_theory.bundled.str (PresheafedSpace.carrier (to_PresheafedSpace X))

/-- The trivial `punit` valued sheaf on any topological space. -/
def punit (X : Top) : SheafedSpace (category_theory.discrete PUnit) :=
  mk
    (PresheafedSpace.mk (PresheafedSpace.carrier (PresheafedSpace.const X PUnit.unit))
      (PresheafedSpace.presheaf (PresheafedSpace.const X PUnit.unit)))
    (Top.presheaf.sheaf_condition_punit
      (PresheafedSpace.presheaf
        (PresheafedSpace.mk (PresheafedSpace.carrier (PresheafedSpace.const X PUnit.unit))
          (PresheafedSpace.presheaf (PresheafedSpace.const X PUnit.unit)))))

protected instance inhabited : Inhabited (SheafedSpace (category_theory.discrete PUnit)) :=
  { default := punit (Top.of pempty) }

protected instance category_theory.category {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] : category_theory.category (SheafedSpace C) :=
  (fun (this : category_theory.category (category_theory.induced_category (PresheafedSpace C) to_PresheafedSpace)) =>
      this)
    (category_theory.induced_category.category to_PresheafedSpace)

/-- Forgetting the sheaf condition is a functor from `SheafedSpace C` to `PresheafedSpace C`. -/
def forget_to_PresheafedSpace {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] : SheafedSpace C ⥤ PresheafedSpace C :=
  category_theory.induced_functor to_PresheafedSpace

@[simp] theorem id_base {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : PresheafedSpace.hom.base 𝟙 = 𝟙 :=
  rfl

theorem id_c {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : PresheafedSpace.hom.c 𝟙 =
  category_theory.iso.inv (category_theory.functor.left_unitor (PresheafedSpace.presheaf (to_PresheafedSpace X))) ≫
    category_theory.whisker_right
      (category_theory.nat_trans.op
        (category_theory.iso.hom (topological_space.opens.map_id (PresheafedSpace.carrier (to_PresheafedSpace X)))))
      (PresheafedSpace.presheaf (to_PresheafedSpace X)) :=
  rfl

@[simp] theorem id_c_app {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace X))ᵒᵖ) : category_theory.nat_trans.app (PresheafedSpace.hom.c 𝟙) U =
  category_theory.eq_to_hom
    (opposite.op_induction
      (fun (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace X))) =>
        subtype.cases_on U
          fun (U_val : set ↥(PresheafedSpace.carrier (to_PresheafedSpace X))) (U_property : is_open U_val) =>
            Eq.refl
              (category_theory.functor.obj (PresheafedSpace.presheaf (to_PresheafedSpace X))
                (opposite.op { val := U_val, property := U_property })))
      U) := sorry

@[simp] theorem comp_base {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : SheafedSpace C} {Y : SheafedSpace C} {Z : SheafedSpace C} (f : X ⟶ Y) (g : Y ⟶ Z) : PresheafedSpace.hom.base (f ≫ g) = PresheafedSpace.hom.base f ≫ PresheafedSpace.hom.base g :=
  rfl

@[simp] theorem comp_c_app {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : SheafedSpace C} {Y : SheafedSpace C} {Z : SheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (U : topological_space.opens ↥(PresheafedSpace.carrier (to_PresheafedSpace Z))ᵒᵖ) : category_theory.nat_trans.app (PresheafedSpace.hom.c (α ≫ β)) U =
  category_theory.nat_trans.app (PresheafedSpace.hom.c β) U ≫
    category_theory.nat_trans.app (PresheafedSpace.hom.c α)
        (opposite.op
          (category_theory.functor.obj (topological_space.opens.map (PresheafedSpace.hom.base β)) (opposite.unop U))) ≫
      category_theory.nat_trans.app
        (category_theory.iso.inv
          (Top.presheaf.pushforward.comp (PresheafedSpace.presheaf (to_PresheafedSpace X)) (PresheafedSpace.hom.base α)
            (PresheafedSpace.hom.base β)))
        U :=
  rfl

/-- The forgetful functor from `SheafedSpace` to `Top`. -/
def forget (C : Type u) [category_theory.category C] [category_theory.limits.has_products C] : SheafedSpace C ⥤ Top :=
  category_theory.functor.mk (fun (X : SheafedSpace C) => ↑X)
    fun (X Y : SheafedSpace C) (f : X ⟶ Y) => PresheafedSpace.hom.base f

/--
The restriction of a sheafed space along an open embedding into the space.
-/
def restrict {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {U : Top} (X : SheafedSpace C) (f : U ⟶ ↑X) (h : open_embedding ⇑f) : SheafedSpace C := sorry

/--
The global sections, notated Gamma.
-/
def Γ {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] : SheafedSpace Cᵒᵖ ⥤ C :=
  category_theory.functor.op forget_to_PresheafedSpace ⋙ PresheafedSpace.Γ

theorem Γ_def {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] : Γ = category_theory.functor.op forget_to_PresheafedSpace ⋙ PresheafedSpace.Γ :=
  rfl

@[simp] theorem Γ_obj {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace Cᵒᵖ) : category_theory.functor.obj Γ X =
  category_theory.functor.obj (PresheafedSpace.presheaf (to_PresheafedSpace (opposite.unop X))) (opposite.op ⊤) :=
  rfl

theorem Γ_obj_op {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] (X : SheafedSpace C) : category_theory.functor.obj Γ (opposite.op X) =
  category_theory.functor.obj (PresheafedSpace.presheaf (to_PresheafedSpace X)) (opposite.op ⊤) :=
  rfl

@[simp] theorem Γ_map {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : SheafedSpace Cᵒᵖ} {Y : SheafedSpace Cᵒᵖ} (f : X ⟶ Y) : category_theory.functor.map Γ f =
  category_theory.nat_trans.app (PresheafedSpace.hom.c (category_theory.has_hom.hom.unop f)) (opposite.op ⊤) ≫
    category_theory.functor.map (PresheafedSpace.presheaf (to_PresheafedSpace (opposite.unop Y)))
      (category_theory.has_hom.hom.op
        (topological_space.opens.le_map_top (PresheafedSpace.hom.base (category_theory.has_hom.hom.unop f)) ⊤)) :=
  rfl

theorem Γ_map_op {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : SheafedSpace C} {Y : SheafedSpace C} (f : X ⟶ Y) : category_theory.functor.map Γ (category_theory.has_hom.hom.op f) =
  category_theory.nat_trans.app (PresheafedSpace.hom.c f) (opposite.op ⊤) ≫
    category_theory.functor.map (PresheafedSpace.presheaf (to_PresheafedSpace X))
      (category_theory.has_hom.hom.op (topological_space.opens.le_map_top (PresheafedSpace.hom.base f) ⊤)) :=
  rfl


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

A type for VM-erased data.
-/

import data.set.basic data.equiv.basic

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

namespace erased

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

noncomputable def out {α} : erased α → α
| ⟨s, h⟩ := classical.some h

@[reducible] def out_type (a : erased Sort*) : Sort* := out a

theorem out_proof {p : Prop} (a : erased p) : p := out a

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

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

noncomputable def equiv (α) : erased α ≃ α :=
⟨out, mk, mk_out, out_mk⟩

instance (α : Type*) : has_repr (erased α) := ⟨λ _, "erased"⟩

def choice {α} (h : nonempty α) : erased α := mk (classical.choice h)

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

instance {α} [h : nonempty α] : nonempty (erased α) :=
erased.nonempty_iff.2 h

instance {α} [h : inhabited α] : inhabited (erased α) :=
⟨mk (default _)⟩

def bind {α β} (a : erased α) (f : α → erased β) : erased β :=
⟨λ b, (f a.out).1 b, (f a.out).2⟩

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

def join {α} (a : erased (erased α)) : erased α := bind a id

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

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

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

end erased


import category_theory.limits.limits
import category_theory.limits.shapes
import category_theory.yoneda
import category_theory.opposites
import category_theory.types
import category_theory.limits.types
-- set_option trace.simplify.rewrite true
run_cmd mk_simp_attr `PRODUCT    -----  BOF BOF
meta def PRODUCT_CAT  : tactic unit :=
`[  try {simp only with PRODUCT}]
run_cmd add_interactive [`PRODUCT_CAT]
universes v u
open category_theory
open category_theory.limits
open category_theory.category
open opposite
namespace lem --------------------------------------------------------------------
variables {C : Type u}
variables [𝒞 : category.{v} C]
variables  [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞
attribute [PRODUCT] category.assoc category.id_comp category.comp_id
@[PRODUCT] lemma prod_left_def {X Y : C} : limit.π (pair X Y) walking_pair.left = limits.prod.fst := rfl
@[PRODUCT] lemma prod_right_def {X Y : C} : limit.π (pair X Y) walking_pair.right = limits.prod.snd := rfl
lemma prod.hom_ext {A X Y : C} {a b : A ⟶ X ⨯ Y} (h1 : a ≫ limits.prod.fst = b ≫ limits.prod.fst) (h2 : a ≫ limits.prod.snd = b ≫ limits.prod.snd) : a = b :=
begin
  apply limit.hom_ext,
  rintros (_ | _),
  rw prod_left_def,
  exact h1,
  rw prod_right_def,
  exact h2,
end
@[PRODUCT, reassoc] lemma lem.prod.lift_fst {Y A B : C} (f : Y ⟶ A) (g : Y ⟶ B) : prod.lift f g ≫ category_theory.limits.prod.fst = f :=
limit.lift_π (binary_fan.mk f g) _

attribute [PRODUCT] lem.prod.lift_fst_assoc

@[PRODUCT,reassoc]lemma lem.prod.lift_snd {Y A B : C} (f : Y ⟶ A) (g : Y ⟶ B) : prod.lift f g ≫ category_theory.limits.prod.snd = g :=
limit.lift_π (binary_fan.mk f g) _
attribute [PRODUCT] lem.prod.lift_snd_assoc
end lem
namespace Product_stuff
notation f ` ⊗ `:20 g :20 := category_theory.limits.prod.map f g  ---- 20
notation  `T`C :20 := (terminal C)
notation   `T`X : 20 := (terminal.from X)
notation f ` | `:20 g :20 :=  prod.lift f g
notation `π1` := limits.prod.fst
notation `π2` := limits.prod.snd

variables {C : Type u}
variables [𝒞 : category.{v} C]
variables [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞
variables (X :C)
open lem           -------------------------------------------------------
/-
     π notation for projection
-/
example  {Y A B : C} (f : Y ⟶ A) (g : Y ⟶ B) : ( f | g) ≫ π1 = f  :=   lem.prod.lift_fst f g
/-
     we can type π : A ⨯ B ⟶ B if we need
-/
example  {Y A B : C} (f : Y ⟶ A) (g : Y ⟶ B) : ( f | g) ≫ (π2 : A ⨯ B ⟶ B) = g := lem.prod.lift_snd f g

example  {A X Y : C} {a b : A ⟶ X ⨯ Y} (h1 : a ≫ π1  = b ≫ π1 ) (h2 : a ≫ π2  = b ≫ π2)  : a = b :=  prod.hom_ext h1 h2

-- use the tatict
example  {Y A B : C} (f : Y ⟶ A) (g : Y ⟶ B) : ( f | g) ≫ (π2 : A ⨯ B ⟶ B) = g := by PRODUCT_CAT

@[PRODUCT]lemma prod.left_composition{Z' Z A B : C}(h : Z' ⟶ Z)(f : Z ⟶ A)(g : Z ⟶ B)  :
               h ≫ (f | g)  = (h ≫ f | h ≫ g) :=
begin
     apply lem.prod.hom_ext,   --- Le right member is of the form ( | )  composition π1 π2
     -- PRODUCT_CAT,  PRODUCT_CAT,  --- here assoc
     rw assoc,
     rw lem.prod.lift_fst,
     rw lem.prod.lift_fst,
     rw lem.prod.lift_snd,
     rw assoc,
     rw lem.prod.lift_snd,
end
-- #print notation
@[PRODUCT,reassoc]lemma prod.map_first{X Y Z W : C}(f  : X ⟶ Y)(g  : Z ⟶ W) :  (f ⊗ g) ≫ (π1 : Y ⨯ W ⟶ Y) = π1  ≫ f :=  begin
     exact limit.map_π (map_pair f g) walking_pair.left,
end
attribute [PRODUCT] prod.map_first_assoc
@[PRODUCT,reassoc]lemma prod.map_second{X Y Z W : C}(f  : X ⟶ Y)(g  : Z ⟶ W) :  (f ⊗ g) ≫ π2 = π2 ≫ g :=  begin
     exact limit.map_π (map_pair f g) walking_pair.right,
end
attribute [PRODUCT] prod.map_second_assoc
@[PRODUCT]lemma  prod.otimes_is_prod {X Y Z W : C}(f  : X ⟶ Y)(g  : Z ⟶ W) : (f ⊗ g) = ( π1  ≫ f | π2 ≫ g ) := begin
     apply prod.hom_ext,
     PRODUCT_CAT, PRODUCT_CAT,
     -- rw lem.prod.lift_fst,
     -- rw prod.map_first,
     -- rw lem.prod.lift_snd,
     -- rw prod.map_second,
end
-- notation π1`(`X `x` Y`)` := (limits.prod.fst : X⨯Y ⟶ X)
@[PRODUCT]lemma prod.map_ext{X Y Z W : C}(f1 f2  : X ⟶ Y)(g1 g2  : Z ⟶ W) :  (f1 ⊗ g1) = (f2 ⊗ g2) →
(π1 : X ⨯ Z ⟶ X) ≫ f1 = (π1 : X ⨯ Z ⟶ X)  ≫ f2 := λ certif, begin
     iterate 2 {rw prod.otimes_is_prod at certif},
     rw ← prod.map_first ( f1)  (g1),
     rw ← prod.map_first ( f2)  (g2),
     iterate 2 {rw prod.otimes_is_prod},
     rw certif,
end
lemma prod.map_eq {X Y Z W : C}(f1 f2  : X ⟶ Y)(g1 g2  : Z ⟶ W) :
 ((π1 : X ⨯ Z ⟶ X) ≫ f1 = (π1 : X ⨯ Z ⟶ X)  ≫ f2) →
 ((π2 : X ⨯ Z ⟶ Z) ≫ g1 = (π2 : X ⨯ Z ⟶ Z)  ≫ g2) → ((f1 ⊗ g1) = (f2 ⊗ g2)) := λ certif1 certif2, begin
     iterate 2 {rw prod.otimes_is_prod},
--     PRODUCT_CAT,
    rw certif1, rw certif2,
end

@[PRODUCT,reassoc]lemma prod.prod_otimes {X Y Z : C} (f :  Y ⟶ X) (g : X ⟶ Z ) :
     (f | 𝟙 Y) ≫ (g ⊗ (𝟙 Y)) = (f ≫ g | 𝟙 Y) :=

begin
     apply prod.hom_ext,
     PRODUCT_CAT,PRODUCT_CAT,     ---------------------- PROBLEME With the tatict HEEEEEEERRRRRRE
     -- rw [lem.prod.lift_fst],
     -- rw  assoc,
     -- rw prod.map_first,
     -- rw ← assoc,               ----- ← assoc here  Problem ?
     -- rw lem.prod.lift_fst,
     -- tidy, -- super - power tidy
end
attribute [PRODUCT] prod.prod_otimes_assoc

@[PRODUCT,reassoc] lemma prod.prod_comp_otimes {A1 A2 X1 X2 Z: C} (f1 :  Z ⟶ A1)(f2  : Z ⟶ A2)
(g1 :A1  ⟶  X1 )(g2 : A2 ⟶ X2) :
     (f1 | f2) ≫ (g1 ⊗ g2)  = (f1 ≫ g1 | f2 ≫ g2 ) := begin
     apply prod.hom_ext,
     PRODUCT_CAT,PRODUCT_CAT,
     end
attribute [PRODUCT] prod.prod_comp_otimes_assoc

def Yo (R : C)(A :C) := (yoneda.obj A).obj (op R)
def Yo_ (R : C) {A B : C}(φ : A ⟶ B) := ((yoneda.map φ).app (op R) : Yo R A ⟶ Yo R B)
-- Good notation for yoneda stuff :
-- We fix V : C and we denote by
-- R[X] := yoneda.obj X).obj (op R) and φ : A  ⟶ B (in C) R ⟦  φ ⟧   : R⟦ A⟧  → R⟦ B⟧  in type v
notation R`⟦`A`⟧`:20 := Yo R A  -- notation ??
notation R`<`φ`>`:20   := Yo_ R φ  --
def Yoneda_preserve_product (Y : C)(A B : C) :
     Y ⟦ A ⨯ B ⟧  ≅ Y ⟦ A ⟧  ⨯ Y⟦ B ⟧   :=
{ hom := prod.lift
    (λ f, f ≫ π1)
    (λ f, f ≫ π2),
  inv := λ f : (Y ⟶ A) ⨯ (Y ⟶ B),
    (prod.lift
      ((@category_theory.limits.prod.fst _ _ (Y ⟶ A) (Y ⟶ B) _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ A)) f)
      ((@category_theory.limits.prod.snd _ _ (Y ⟶ A) _ _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ B)) f : Y ⟶ B)),
  hom_inv_id' := begin
    ext f,
    cases j,
    { simp, refl},
    { simp, refl}
  end,
  inv_hom_id' := begin
    apply lem.prod.hom_ext,
    { rw assoc, rw lem.lem.prod.lift_fst, obviously},
    { rw assoc, rw lem.lem.prod.lift_snd, obviously}
  end
}
--- Here it just sugar
@[PRODUCT]lemma yoneda_sugar.composition (R : C) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : R < f ≫ g > =( R< f >) ≫ (R < g >)
 :=  begin
     unfold Yo_,
     simp,
 end
def yoneda_sugar.conv {R : C}{A : C}(g : R⟦ A⟧ ) : R ⟶ A := g
def yoneda_sugar.prod (R : C)(A B : C) : R⟦ A ⨯ B⟧  ≅ R⟦ A⟧  ⨯ R⟦ B⟧ := begin
     exact Yoneda_preserve_product R A B,
end
@[PRODUCT]lemma yoneda_sugar.prod.hom (R : C)(A B : C) :
     (yoneda_sugar.prod R A B).hom =  (R < (π1  : A ⨯ B ⟶ A) > | R < (π2  : A ⨯ B ⟶ B)> ) := rfl

@[PRODUCT]lemma yoneda_sugar.prod.first (R : C)(A B : C) :
 (yoneda_sugar.prod R A B).hom ≫ π1 = (R < π1 >) :=
 begin
     exact rfl,
 end
 @[PRODUCT]lemma yoneda_sugar.prod.hom_inv (R : C)(A B : C) :
     (yoneda_sugar.prod R A B).hom ≫ (yoneda_sugar.prod R A B).inv = 𝟙 (R⟦ A ⨯ B⟧) :=
     (Yoneda_preserve_product R A B).hom_inv_id'
 @[PRODUCT]lemma yoneda_sugar.prod.inv_hom (R : C)(A B : C) :
     (yoneda_sugar.prod R A B).inv ≫ (yoneda_sugar.prod R A B).hom = 𝟙 (R⟦ A⟧  ⨯ R⟦ B⟧) :=
     (Yoneda_preserve_product R A B).inv_hom_id'
 @[PRODUCT]lemma yoneda_sugar.prod.second (R : C)(A B : C) :
  (yoneda_sugar.prod R A B).hom ≫ limits.prod.snd = (R < limits.prod.snd >) := rfl

@[PRODUCT]lemma yoneda_sugar.id (R : C)(A : C) : R < 𝟙 A > = 𝟙 (R⟦ A⟧ ) := begin
     funext,
     exact comp_id C g,
     -- have T : ((yoneda.map (𝟙 A)).app (op R)) g = (g ≫ (𝟙 A)),
end

lemma yoneda_sugar_prod (R : C)(A B : C)(X :C)(f : X ⟶ A)(g : X ⟶ B) :
      R < (f | g) > ≫ (yoneda_sugar.prod R A B).hom  =  (R < f > | R < g > ) :=  -- the  ≫  is  :/
     begin
          PRODUCT_CAT,
          -- rw  yoneda_sugar.prod.hom R A B,
          -- rw prod.left_composition,
          iterate 2 {rw ← yoneda_sugar.composition},   -- rw ← is the problem ?
          rw lem.lem.prod.lift_fst,
          rw lem.lem.prod.lift_snd,
     end

@[PRODUCT]lemma yoneda_sugar_prod_inv (R : C)(A B : C)(X :C)(f : X ⟶ A)(g : X ⟶ B) :
     R < (f | g) >   =  (R < f > | R < g > ) ≫ (yoneda_sugar.prod R A B).inv :=
     begin
          PRODUCT_CAT,  -- noting
          rw ← yoneda_sugar_prod,
          rw assoc,
          rw yoneda_sugar.prod.hom_inv,
          exact rfl,
     end

lemma  yoneda_sugar.otimes (R : C){Y Z K :C}(f : X ⟶ Y )(g : Z ⟶ K) :
 ( R < (f ⊗ g) > ) = (yoneda_sugar.prod  _ _ _).hom ≫ ((R<f>) ⊗ R<g>) ≫ (yoneda_sugar.prod _ _ _ ).inv := begin
     PRODUCT_CAT,
     -- iterate 2 {rw prod.otimes_is_prod},
     -- rw  yoneda_sugar.prod.hom,
     -- iterate 1 {rw yoneda_sugar_prod_inv},
     rw ← assoc,
     rw prod.left_composition,
     rw ← assoc,
     rw lem.prod.lift_fst,
     rw ← assoc,
     rw lem.prod.lift_snd,
     -- rw yoneda_sugar.composition,
     -- rw yoneda_sugar.composition,
end

@[PRODUCT]lemma yonega_sugar.one_otimes (R :C)(X Y Z: C) (f : X ⟶ Y) :
 (((yoneda_sugar.prod R Z X).inv) ≫ (R <(𝟙 Z ⊗ f ) > ) ≫ (yoneda_sugar.prod R Z Y).hom) = (𝟙 (R⟦Z⟧) ⊗ R<f >) := begin
     rw yoneda_sugar.otimes,
     iterate 3 {rw ← assoc},
     rw yoneda_sugar.prod.inv_hom,
     rw id_comp,
     rw assoc,
     rw yoneda_sugar.prod.inv_hom,
     rw ← yoneda_sugar.id,
     simp,
 end
lemma yonega_sugar.one_otimes' (R :C)(X Y Z: C) (f : X ⟶ Y) :
 ( (R <(𝟙 Z ⊗ f ) > ) ≫ (yoneda_sugar.prod R Z Y).hom) = ((yoneda_sugar.prod R Z X).hom) ≫ (𝟙 (R⟦Z⟧) ⊗ R < f >) := begin
     iterate 2{ rw yoneda_sugar.prod.hom},
     rw prod.left_composition,
     iterate 2{ rw ← yoneda_sugar.composition},
     rw prod.map_first,
     rw prod.map_second,
     rw comp_id,
     rw prod.otimes_is_prod,rw prod.left_composition,rw ← assoc,
     rw lem.prod.lift_fst,rw ←  assoc,rw lem.prod.lift_snd,rw comp_id,
     rw yoneda_sugar.composition,
 end

-- def Y (R : C)(A :C) := (yoneda.obj A).obj (op R)
-- def Y_ (R : C) {A B : C}(φ : A ⟶ B) := ((yoneda.map φ).app (op R) : Y R A ⟶ Y R B)
-- -- Good notation for yoneda stuff :
-- -- We fix V : C and we denote by
-- -- R[X] := yoneda.obj X).obj (op R) and φ : A  ⟶ B (in C) R ⟦  φ ⟧   : R[A] → R[B]  in type v
-- notation R`[`A`]`:20 := Y R A  -- notation ??
-- notation R`<`φ`>`:20   := Y_ R φ  --
-- def Yoneda_preserve_product (Y : C)(A B : C) :
--      Y[A ⨯ B] ≅ (Y[A]) ⨯ (Y[B]) :=
-- { hom := prod.lift
--     (λ f, f ≫ π1)
--     (λ f, f ≫ π2),
--   inv := λ f : (Y ⟶ A) ⨯ (Y ⟶ B),
--     (prod.lift
--       ((@category_theory.limits.prod.fst _ _ (Y ⟶ A) (Y ⟶ B) _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ A)) f)
--       ((@category_theory.limits.prod.snd _ _ (Y ⟶ A) _ _ : ((Y ⟶ A) ⨯ (Y ⟶ B)) → (Y ⟶ B)) f : Y ⟶ B)),
--   hom_inv_id' := begin
--     ext f,
--     cases j,
--     { simp, refl},
--     { simp, refl}
--   end,
--   inv_hom_id' := begin
--     apply lem.prod.hom_ext,
--     { rw assoc, rw lem.lem.prod.lift_fst, obviously},
--     { rw assoc, rw lem.lem.prod.lift_snd, obviously}
--   end
-- }

-- --- Here it just sugar
-- @[PRODUCT,reassoc]lemma yoneda_sugar.composition (R : C) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : R < f ≫ g > =( R< f >) ≫ (R < g >)
--  :=  begin
--      unfold Y_,
--      simp,
--  end
--  attribute [PRODUCT] yoneda_sugar.composition_assoc
--  @[PRODUCT,reassoc]lemma yoneda_sugar.composition_rev (R : C) {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) :
--  ( R< f >) ≫ (R < g >) =  (R < f ≫ g > )
--  :=  begin
--      unfold Y_,
--      simp,
--  end
--  attribute [PRODUCT] yoneda_sugar.composition_rev_assoc
-- def yoneda_sugar.conv {R : C}{A : C}(g : R[A]) : R ⟶ A := g
-- def yoneda_sugar.prod (R : C)(A B : C) : R[A ⨯ B] ≅ R[A] ⨯ R[B] := begin
--      exact Yoneda_preserve_product R A B,
-- end
-- @[PRODUCT]lemma yoneda_sugar.prod.hom (R : C)(A B : C) :
--      (yoneda_sugar.prod R A B).hom =  (R < (π1 : A ⨯ B ⟶ A) > | R < (π2 : A ⨯ B ⟶ B)> ) := rfl

-- @[PRODUCT,reassoc]lemma yoneda_sugar.prod.first (R : C)(A B : C) :
--  (yoneda_sugar.prod R A B).hom ≫ π1  = (R < π1 >) :=
--  begin
--      exact rfl,
--  end
--  attribute [PRODUCT] yoneda_sugar.prod.first_assoc
--  @[PRODUCT,reassoc]lemma yoneda_sugar.prod.hom_inv (R : C)(A B : C) :
--      (yoneda_sugar.prod R A B).hom ≫ (yoneda_sugar.prod R A B).inv = 𝟙 (R[ A ⨯ B]) :=
--      (Yoneda_preserve_product R A B).hom_inv_id'
--  attribute [PRODUCT] yoneda_sugar.prod.hom_inv_assoc
--  @[PRODUCT,reassoc]lemma yoneda_sugar.prod.inv_hom (R : C)(A B : C) :
--      (yoneda_sugar.prod R A B).inv ≫ (yoneda_sugar.prod R A B).hom = 𝟙 ( R [A]  ⨯ R[B]) :=
--      (Yoneda_preserve_product R A B).inv_hom_id'
--       attribute [PRODUCT] yoneda_sugar.prod.inv_hom_assoc
--  @[PRODUCT,reassoc]lemma yoneda_sugar.prod.second (R : C)(A B : C) :
--   (yoneda_sugar.prod R A B).hom ≫ π2 = (R < (π2 : A ⨯ B ⟶ B) >) := rfl
-- attribute [PRODUCT] yoneda_sugar.prod.second_assoc
-- @[PRODUCT]lemma yoneda_sugar.id (R : C)(A : C) : R < 𝟙 A > = 𝟙 ( R [A] ) := begin
--      funext,
--      exact comp_id C g,
--      -- have T : ((yoneda.map (𝟙 A)).app (op R)) g = (g ≫ (𝟙 A)),
-- end
-- @[PRODUCT,reassoc,refl]lemma yoneda_sugar_prod (R : C)(A B : C)(X :C)(f : X ⟶ A)(g : X ⟶ B) :
--       R < (f | g) > ≫ (yoneda_sugar.prod R A B).hom  =  (R < f > | R < g > ) :=  -- the  ≫  is  :/
--      begin
--            PRODUCT_CAT,
--           -- rw  yoneda_sugar.prod.hom R A B,
--           -- rw prod.left_composition,
--           -- iterate 2 {rw ← yoneda_sugar.composition},   -- rw ← is the problem ?
--           -- PRODUCT_CAT,
--           -- rw lem.lem.prod.lift_fst,
--           -- rw lem.lem.prod.lift_snd,
--      end
-- attribute [PRODUCT] yoneda_sugar_prod_assoc
-- @[PRODUCT]lemma yoneda_sugar_prod_inv (R : C)(A B : C)(X :C)(f : X ⟶ A)(g : X ⟶ B) :
--      R < (f | g) >   =  (R < f > | R < g > ) ≫ (yoneda_sugar.prod R A B).inv :=
--      begin
--           PRODUCT_CAT,  -- noting   HERE PROBLEM the tatic do nothing
--           rw ← yoneda_sugar_prod,
--           rw assoc,
--           rw yoneda_sugar.prod.hom_inv,
--           exact rfl,
--      end
-- @[PRODUCT]lemma  yoneda_sugar.otimes (R : C){Y Z K :C}(f : X ⟶ Y )(g : Z ⟶ K) :
--  ( R < (f ⊗ g) > ) = (yoneda_sugar.prod  _ _ _).hom ≫ ((R<f>) ⊗ R<g>) ≫ (yoneda_sugar.prod _ _ _ ).inv := begin
--      -- PRODUCT_CAT,
--      iterate 2 {rw prod.otimes_is_prod},
--      rw  yoneda_sugar.prod.hom,
--      iterate 1 {rw yoneda_sugar_prod_inv},
--      rw ← assoc,
--      rw prod.left_composition,
--      rw ← assoc,
--      rw lem.prod.lift_fst,
--      rw ← assoc,
--      rw lem.prod.lift_snd,
--      rw yoneda_sugar.composition,
--      rw yoneda_sugar.composition,
--      exact rfl,
-- end
-- @[PRODUCT]lemma yonega_sugar.one_otimes (R :C)(X Y Z: C) (f : X ⟶ Y) :
--  (((yoneda_sugar.prod R Z X).inv) ≫ (R <(𝟙 Z ⊗ f ) > ) ≫ (yoneda_sugar.prod R Z Y).hom) = (𝟙 (R[Z]) ⊗ R < f >) := begin
--      rw yoneda_sugar.otimes,
--      iterate 3 {rw ← assoc},
--      rw yoneda_sugar.prod.inv_hom,
--      rw id_comp,
--      rw assoc,
--      rw yoneda_sugar.prod.inv_hom,
--      rw ← yoneda_sugar.id,
--      simp,
--  end
-- lemma yonega_sugar.one_otimes' (R :C)(X Y Z: C) (f : X ⟶ Y) :
--  ( (R <(𝟙 Z ⊗ f ) > ) ≫ (yoneda_sugar.prod R Z Y).hom) = ((yoneda_sugar.prod R Z X).hom) ≫ (𝟙 (R[Z]) ⊗ R < f >) := begin
--      iterate 2{ rw yoneda_sugar.prod.hom},
--      rw prod.left_composition,
--      iterate 2{ rw ← yoneda_sugar.composition},
--      rw prod.map_first,
--      rw prod.map_second,
--      rw comp_id,
--      rw prod.otimes_is_prod,rw prod.left_composition,rw ← assoc,
--      rw lem.prod.lift_fst,rw ←  assoc,rw lem.prod.lift_snd,rw comp_id,
--      rw yoneda_sugar.composition,
--      exact rfl,
--  end
--  end Product_stuff


import groupk
import category_theory.comma
import category_theory.limits.limits
import category_theory.limits.shapes
import category_theory.yoneda
open category_theory
open category_theory.limits
open category_theory.category
universes v u
open Product_stuff
open lem
/-
The goal is define group obj in a category.
          reference : Douady : Algebre et théories galoisiennes page 45
          exemple : in the category of presheaf.
          in Ring ? Idem ?
     contexte : 𝒞 a un objet final et a les produit finis !
Pour coder μ X × X ⟶ X  We see that has X ⟶ T cospan f f)

-/
-- notation         f ` ⊗ `:20 g :20 := category_theory.limits.prod.map f g
-- notation         `T`C :20 := (terminal C)
-- notation         `T`X : 20 := (terminal.from X)
-- notation         f ` | `:20 g :20 :=  prod.lift f g
/-!
#     notations :
#         T C       :  C           (objet terminal)
#         (f | g)   :  Z ⟶ X ⨯ Y
#         T X       :  X ⟶ T C
#         (f ⊗ g)  :  Z1 ⨯ Z2 ⟶ X1 ⨯ X2
!-/

structure group_obj (C : Type u)[ 𝒞 : category.{v} C ] [ (has_binary_products.{v} C) ] [ (has_terminal.{v} C) ] :=
(X : C)
(μ : X ⨯ X ⟶ X)
(inv : X ⟶ X)
(ε :  T C ⟶ X)
(hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
(hyp_mul_one  :  (𝟙 X | T X) ≫ ( 𝟙 X ⊗ ε) ≫ μ  = 𝟙 X)
(hyp_inv_mul  :  (inv | 𝟙 X) ≫  μ = (T X) ≫ ε )
(hyp_assoc    :  (μ ⊗ 𝟙 X) ≫ (μ) = (prod.associator X X X).hom ≫ (𝟙 X ⊗ μ)  ≫ μ )   -- (a *b) * c = (a * (b * c))

variables (C : Type u)
variables [𝒞 : category.{v} C]
variables  [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞
instance coee : has_coe (group_obj C) C := ⟨λ F, F.X⟩
variables (G : group_obj C)
include G
-- we start by rewriting a little
lemma mul_one' : (𝟙 G.X | T G.X) ≫ ( 𝟙 G.X ⊗ G.ε) ≫ G.μ  = (𝟙 G.X  | (T G.X) ≫ G.ε) ≫ G.μ :=
begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul' : (T G.X | 𝟙 G.X) ≫ (G.ε ⊗ 𝟙 G.X) ≫  G.μ  = ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ :=
begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul_R (R A : C) (ζ : R⟦G.X⟧ ): R < ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ > ζ  =  ζ := begin
     rw ← one_mul',rw G.hyp_one_mul,rw yoneda_sugar.id,exact rfl,
end
lemma mul_one_R (R A : C) (ζ : R⟦G.X⟧ ): R < ( 𝟙 G.X | (T G.X) ≫ G.ε ) ≫ G.μ > ζ  =  ζ :=
begin
     rw ← mul_one', rw G.hyp_mul_one,rw yoneda_sugar.id,exact rfl,
 end
def one   (R : C) : R ⟦(G.X) ⟧  :=
begin                                   ---- ici l'unité est R<ε> (T G.X) l'image du terminal
     exact (terminal.from R ≫ G.ε),
end
def mul (R : C) : R⟦ G.X⟧   → R⟦ G.X⟧  → R ⟦ G.X ⟧  :=  λ g1 g2,
begin
     let φ := ( g1 | g2),
     let β := (R< (G.μ) > : R⟦ G.X ⨯ G.X⟧  ⟶ R⟦G.X⟧),
     exact β φ,
end
variables (R : C)
include R
instance yoneda_mul : has_mul (R⟦ G.X⟧) := ⟨mul C G R ⟩
instance yoneda_one : has_one (R⟦ G.X⟧) := ⟨one C G R ⟩
@[PRODUCT]lemma mul_comp (a b : R ⟦ G.X⟧ ) : a * b = (R < G.μ >) (a | b) := rfl -- priority R < g.μ > (a | b) not ()
@[PRODUCT]lemma one_comp :  (1 : R ⟦ G.X ⟧) = terminal.from R ≫ G.ε := rfl

@[PRODUCT]lemma yoneda_sugar.apply_comp (G : group_obj C){R : C}{Z K :C}(f :  R ⟶ Z)(g : Z ⟶ K) :
     R < g > (f) = f ≫ g := rfl

lemma yoneda_sugar_right_apply {R :C}{A Y Z : C }(ζ : R ⟦ A ⟧)  (f : A ⟶ Y)(g : A ⟶ Y) :
     ( R< (f | g) >) ζ = (R < f > ζ | R < g > ζ ) :=
          begin
               rw yoneda_sugar.apply_comp C G,
               rw prod.left_composition,
               iterate 2 {rw yoneda_sugar.apply_comp  C G },
          end
lemma yoneda_sugar_otimes_apply {R :C}{A1 A2 Y Z : C }(ζ1 : R ⟦ A1 ⟧)(ζ2 : R⟦ A2 ⟧ )
 (f1 : A1 ⟶ Y)(f2 : A2 ⟶ Z) :
  R < (f1 ⊗ f2 ) > (ζ1 | ζ2) = ( R < f1 > ζ1 | R < f2 > ζ2  ) :=
 begin
     rw yoneda_sugar.apply_comp C G,
     rw prod.prod_comp_otimes,exact rfl,
 end
notation Y `⟶•`  := T Y
@[PRODUCT]lemma Terminal_comp{Y : C} ( a : R ⟶ Y) : a ≫ (Y ⟶•) = (R ⟶•) :=
by exact subsingleton.elim (a ≫ T Y) (T R)
@[PRODUCT]lemma lemmeF (a : R⟦ G.X ⟧) :

   (R < ( (T G.X) ≫ G.ε | 𝟙 G.X)> ) a =  ((T R) ≫ G.ε | a)  :=
begin
     rw yoneda_sugar_right_apply C  G,
     rw yoneda_sugar.apply_comp,rw ← assoc,
     rw Terminal_comp,rw yoneda_sugar.id,exact rfl,
     use G, use G, use R,
     -- rw ← Maxi_triviality,
     -- rw types_comp,
     -- tidy, rw Maxi_triviality,rw Yoneda_Maxi,rw Yoneda_Maxi,rw prod.left_composition,
     -- rw comp_id,rw ← assoc, rw Terminal_comp,exact rfl,iterate 3 {assumption},
end

@[PRODUCT]def one_mulf' (ζ  : R⟦G.X ⟧) :    1 * ζ  = ζ  := begin
     rw mul_comp,rw one_comp, --- (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
     let V := one_mul_R C G R R ζ,
     let r := R <G.μ>,
     rw [yoneda_sugar.apply_comp,← assoc,prod.left_composition,comp_id,
     ← assoc,Terminal_comp,← yoneda_sugar.apply_comp] at V,
     exact V,
     use G, use G, use G,
end
@[PRODUCT]def mul_onef'(ζ : R⟦G.X ⟧)  : ζ * 1 = ζ := begin
     rw mul_comp,rw one_comp,
     have V := mul_one_R C G R R ζ,
     rw [yoneda_sugar.apply_comp,← assoc,prod.left_composition,comp_id,← assoc,Terminal_comp,← yoneda_sugar.apply_comp] at V,
     exact V,
     use G, use G ,use G,
end
@[PRODUCT]def inv' (R :C) : R⟦ G.X⟧ → R⟦ G.X⟧   := λ  ζ, begin
     exact R<G.inv> ζ,
end
instance yoneda_inv (R :C) : has_inv (R⟦G.X⟧) := ⟨inv' C G R⟩
@[PRODUCT]lemma  inv_comp (ζ : R ⟦ G.X⟧ ) : ζ⁻¹  =  (R<G.inv>) ζ  := rfl
@[PRODUCT]lemma mul_left_inv' (ζ : R ⟦ G.X ⟧) : (ζ⁻¹ * ζ ) = 1 :=  begin
     rw inv_comp,rw mul_comp,rw one_comp, rw yoneda_sugar.apply_comp,
     have V : R< (G.inv | 𝟙 G.X )   ≫  G.μ> ζ = (R<(T G.X) ≫ G.ε>) ζ ,
          rw G.hyp_inv_mul,
     rw [yoneda_sugar.apply_comp,yoneda_sugar.apply_comp,← assoc,
     prod.left_composition,comp_id,← assoc,Terminal_comp,← yoneda_sugar.apply_comp C G ζ G.inv] at V,
     assumption, use G, use G, use G, use G,
end
lemma Grall (a b c : R ⟦G.X ⟧) : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))) := begin
     tidy,
     rw [yoneda_sugar.apply_comp, ← assoc,prod.left_composition,
     ← assoc,prod.prod_comp_otimes,yoneda_sugar.apply_comp,yoneda_sugar.apply_comp],
     iterate 3 {swap,use G},
     rw comp_id,tidy,PRODUCT_CAT,
     rw [← assoc,prod.left_composition,prod.lift_snd (a | b) c, ← assoc, prod.lift_fst,prod.lift_snd],
end
-- (hyp_mul_inv  :  (inv | 𝟙 X ) ≫  μ = (T X) ≫ ε )
lemma mul_assoc' (a b c : R ⟦G.X ⟧) : a * b *c = a * ( b * c ) := begin
     iterate 4 { rw mul_comp}, PRODUCT_CAT,
     have ASSOC : R<((G.μ ⊗ (𝟙 G.X)) ≫ (G.μ)) >(a | b | c) = (R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ>) (a | b | c),
          rw G.hyp_assoc,
     rw [yoneda_sugar.apply_comp,← assoc,prod.prod_comp_otimes,comp_id,
     ← yoneda_sugar.apply_comp, ← yoneda_sugar.apply_comp] at ASSOC,
     iterate 3 {swap,use G},
     have G_hyp : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))),
          exact Grall C G R a b c ,
       rw G_hyp at ASSOC,assumption,
     -- R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ> (a | b | c),

end

instance : group (R⟦G.X⟧) :=
{
     mul := has_mul.mul,
     mul_assoc := mul_assoc' C G R,
     one    := (1 : R⟦ G.X⟧),
     mul_one := mul_onef' C G R,
     one_mul := one_mulf' C G R,
     inv  := inv' C G R,
     mul_left_inv := mul_left_inv' C G R,
}


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

/-!
# The Giry monad

Let X be a measurable space. The collection of all measures on X again
forms a measurable space. This construction forms a monad on
measurable spaces and measurable functions, called the Giry monad.

Note that most sources use the term "Giry monad" for the restriction
to *probability* measures. Here we include all measures on X.

See also `measure_theory/category/Meas.lean`, containing an upgrade of the type-level
monad to an honest monad of the functor `Measure : Meas ⥤ Meas`.

## References

* <https://ncatlab.org/nlab/show/Giry+monad>

## Tags

giry monad
-/

noncomputable theory
open_locale classical big_operators ennreal

open classical set filter

variables {α β γ δ ε : Type*}

namespace measure_theory

namespace measure

variables [measurable_space α] [measurable_space β]

/-- Measurability structure on `measure`: Measures are measurable w.r.t. all projections -/
instance : measurable_space (measure α) :=
⨆ (s : set α) (hs : measurable_set s), (borel ℝ≥0∞).comap (λμ, μ s)

lemma measurable_coe {s : set α} (hs : measurable_set s) : measurable (λμ : measure α, μ s) :=
measurable.of_comap_le $ le_supr_of_le s $ le_supr_of_le hs $ le_rfl

lemma measurable_of_measurable_coe (f : β → measure α)
  (h : ∀(s : set α) (hs : measurable_set s), measurable (λb, f b s)) :
  measurable f :=
measurable.of_le_map $ bsupr_le $ assume s hs, measurable_space.comap_le_iff_le_map.2 $
  by rw [measurable_space.map_comp]; exact h s hs

lemma measurable_measure {μ : α → measure β} :
  measurable μ ↔ ∀(s : set β) (hs : measurable_set s), measurable (λb, μ b s) :=
⟨λ hμ s hs, (measurable_coe hs).comp hμ, measurable_of_measurable_coe μ⟩

lemma measurable_map (f : α → β) (hf : measurable f) :
  measurable (λμ : measure α, map f μ) :=
measurable_of_measurable_coe _ $ assume s hs,
  suffices measurable (λ (μ : measure α), μ (f ⁻¹' s)),
    by simpa [map_apply, hs, hf],
  measurable_coe (hf hs)

lemma measurable_dirac :
  measurable (measure.dirac : α → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  begin
    simp only [dirac_apply', hs],
    exact measurable_one.indicator hs
  end

lemma measurable_lintegral {f : α → ℝ≥0∞} (hf : measurable f) :
  measurable (λμ : measure α, ∫⁻ x, f x ∂μ) :=
begin
  simp only [lintegral_eq_supr_eapprox_lintegral, hf, simple_func.lintegral],
  refine measurable_supr (λ n, finset.measurable_sum _ (λ i _, _)),
  refine measurable.const_mul _ _,
  exact measurable_coe ((simple_func.eapprox f n).measurable_set_preimage _)
end

/-- Monadic join on `measure` in the category of measurable spaces and measurable
functions. -/
def join (m : measure (measure α)) : measure α :=
measure.of_measurable
  (λs hs, ∫⁻ μ, μ s ∂m)
  (by simp)
  begin
    assume f hf h,
    simp [measure_Union h hf],
    apply lintegral_tsum,
    assume i, exact measurable_coe (hf i)
  end

@[simp] lemma join_apply {m : measure (measure α)} :
  ∀{s : set α}, measurable_set s → join m s = ∫⁻ μ, μ s ∂m :=
measure.of_measurable_apply

@[simp] lemma join_zero : (0 : measure (measure α)).join = 0 :=
by { ext1 s hs, simp [hs] }

lemma measurable_join : measurable (join : measure (measure α) → measure α) :=
measurable_of_measurable_coe _ $ assume s hs,
  by simp only [join_apply hs]; exact measurable_lintegral (measurable_coe hs)

lemma lintegral_join {m : measure (measure α)} {f : α → ℝ≥0∞} (hf : measurable f) :
  ∫⁻ x, f x ∂(join m) = ∫⁻ μ, ∫⁻ x, f x ∂μ ∂m :=
begin
  rw [lintegral_eq_supr_eapprox_lintegral hf],
  have : ∀n x,
    join m (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x}) =
      ∫⁻ μ, μ ((⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {x})) ∂m :=
    assume n x, join_apply (simple_func.measurable_set_preimage _ _),
  simp only [simple_func.lintegral, this],
  transitivity,
  have : ∀(s : ℕ → finset ℝ≥0∞) (f : ℕ → ℝ≥0∞ → measure α → ℝ≥0∞)
    (hf : ∀n r, measurable (f n r)) (hm : monotone (λn μ, ∑ r in s n, r * f n r μ)),
    (⨆n:ℕ, ∑ r in s n, r * ∫⁻ μ, f n r μ ∂m) =
    ∫⁻ μ, ⨆n:ℕ, ∑ r in s n, r * f n r μ ∂m,
  { assume s f hf hm,
    symmetry,
    transitivity,
    apply lintegral_supr,
    { assume n,
      exact finset.measurable_sum _ (assume r _, (hf _ _).const_mul _) },
    { exact hm },
    congr, funext n,
    transitivity,
    apply lintegral_finset_sum,
    { assume r _, exact (hf _ _).const_mul _ },
    congr, funext r,
    apply lintegral_const_mul,
    exact hf _ _ },
  specialize this (λn, simple_func.range (simple_func.eapprox f n)),
  specialize this
    (λn r μ, μ (⇑(simple_func.eapprox (λ (a : α), f a) n) ⁻¹' {r})),
  refine this _ _; clear this,
  { assume n r,
    apply measurable_coe,
    exact simple_func.measurable_set_preimage _ _ },
  { change monotone (λn μ, (simple_func.eapprox f n).lintegral μ),
    assume n m h μ,
    refine simple_func.lintegral_mono _ le_rfl,
    apply simple_func.monotone_eapprox,
    assumption },
  congr, funext μ,
  symmetry,
  apply lintegral_eq_supr_eapprox_lintegral,
  exact hf
end

/-- Monadic bind on `measure`, only works in the category of measurable spaces and measurable
functions. When the function `f` is not measurable the result is not well defined. -/
def bind (m : measure α) (f : α → measure β) : measure β := join (map f m)

@[simp] lemma bind_zero_left (f : α → measure β) : bind 0 f = 0 :=
by simp [bind]

@[simp] lemma bind_zero_right (m : measure α) :
  bind m (0 : α → measure β) = 0 :=
begin
  ext1 s hs,
  simp only [bind, hs, join_apply, coe_zero, pi.zero_apply],
  rw [lintegral_map (measurable_coe hs) measurable_zero],
  simp
end

@[simp] lemma bind_zero_right' (m : measure α) :
  bind m (λ _, 0 : α → measure β) = 0 :=
bind_zero_right m

@[simp] lemma bind_apply {m : measure α} {f : α → measure β} {s : set β}
  (hs : measurable_set s) (hf : measurable f) :
  bind m f s = ∫⁻ a, f a s ∂m :=
by rw [bind, join_apply hs, lintegral_map (measurable_coe hs) hf]

lemma measurable_bind' {g : α → measure β} (hg : measurable g) : measurable (λm, bind m g) :=
measurable_join.comp (measurable_map _ hg)

lemma lintegral_bind {m : measure α} {μ : α → measure β} {f : β → ℝ≥0∞}
  (hμ : measurable μ) (hf : measurable f) :
  ∫⁻ x, f x ∂ (bind m μ) = ∫⁻ a, ∫⁻ x, f x ∂(μ a) ∂m:=
(lintegral_join hf).trans (lintegral_map (measurable_lintegral hf) hμ)

lemma bind_bind {γ} [measurable_space γ] {m : measure α} {f : α → measure β} {g : β → measure γ}
  (hf : measurable f) (hg : measurable g) :
  bind (bind m f) g = bind m (λa, bind (f a) g) :=
measure.ext $ assume s hs,
begin
  rw [bind_apply hs hg, bind_apply hs ((measurable_bind' hg).comp hf), lintegral_bind hf],
  { congr, funext a,
    exact (bind_apply hs hg).symm },
  exact (measurable_coe hs).comp hg
end

lemma bind_dirac {f : α → measure β} (hf : measurable f) (a : α) : bind (dirac a) f = f a :=
measure.ext $ λ s hs, by rw [bind_apply hs hf, lintegral_dirac' a ((measurable_coe hs).comp hf)]

lemma dirac_bind {m : measure α} : bind m dirac = m :=
measure.ext $ assume s hs,
by simp [bind_apply hs measurable_dirac, dirac_apply' _ hs, lintegral_indicator 1 hs]

lemma join_eq_bind (μ : measure (measure α)) : join μ = bind μ id :=
by rw [bind, map_id]

lemma join_map_map {f : α → β} (hf : measurable f) (μ : measure (measure α)) :
  join (map (map f) μ) = map f (join μ) :=
measure.ext $ assume s hs,
  begin
    rw [join_apply hs, map_apply hf hs, join_apply,
      lintegral_map (measurable_coe hs) (measurable_map f hf)],
    { congr, funext ν, exact map_apply hf hs },
    exact hf hs
  end

lemma join_map_join (μ : measure (measure (measure α))) :
  join (map join μ) = join (join μ) :=
begin
  show bind μ join = join (join μ),
  rw [join_eq_bind, join_eq_bind, bind_bind measurable_id measurable_id],
  apply congr_arg (bind μ),
  funext ν,
  exact join_eq_bind ν
end

lemma join_map_dirac (μ : measure α) : join (map dirac μ) = μ :=
dirac_bind

lemma join_dirac (μ : measure α) : join (dirac μ) = μ :=
eq.trans (join_eq_bind (dirac μ)) (bind_dirac measurable_id _)

end measure

end measure_theory


import  .groupk
import category_theory.comma
import category_theory.limits.limits
import category_theory.limits.shapes
import category_theory.yoneda
open category_theory
open category_theory.limits
open category_theory.category
universes v u
open Product_stuff
open lem
/-
The goal is define group obj in a category.
          reference : Douady : Algebre et théories galoisiennes page 45
          exemple : in the category of presheaf.
          in Ring ? Idem ?
     contexte : 𝒞 a un objet final et a les produit finis !
Pour coder μ X × X ⟶ X  We see that has X ⟶ T cospan f f)

-/
-- notation f ` ⊗ `:20 g :20 := category_theory.limits.prod.map f g
-- notation  `T`C :20 := (terminal C)
-- notation   `T`X : 20 := (terminal.from X)
-- notation f ` | `:20 g :20 :=  prod.lift f g
structure group_obj (C : Type u)[ 𝒞 : category.{v} C ] [ (has_binary_products.{v} C) ] [ (has_terminal.{v} C) ] :=
(X : C)
(μ : X ⨯ X ⟶ X)
(inv : X ⟶ X)
(ε :  T C ⟶ X)
(hyp_one_mul  :  (T X | 𝟙 X) ≫ (ε ⊗ 𝟙 X) ≫  μ  = 𝟙 X)
(hyp_mul_one  :  (𝟙 X | T X) ≫ ( 𝟙 X ⊗ ε) ≫ μ  = 𝟙 X)
(hyp_inv_mul  :  (inv | 𝟙 X) ≫  μ = (T X) ≫ ε )
(hyp_assoc    :  (μ ⊗ 𝟙 X) ≫ (μ) = (prod.associator X X X).hom ≫ (𝟙 X ⊗ μ)  ≫ μ )   -- (a *b) * c = (a * (b * c))

-- question 1.
-- Let X : C
variables (C : Type u)
variables [𝒞 : category.{v} C]
variables  [has_binary_products.{v} C][has_terminal.{v} C]
include 𝒞
instance coee : has_coe (group_obj C) C := ⟨λ F, F.X⟩
variables (G : group_obj C)
include G
lemma mul_one' : (𝟙 G.X | T G.X) ≫ ( 𝟙 G.X ⊗ G.ε) ≫ G.μ  = (𝟙 G.X  | (T G.X) ≫ G.ε) ≫ G.μ :=begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul' : (T G.X | 𝟙 G.X) ≫ (G.ε ⊗ 𝟙 G.X) ≫  G.μ  = ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ :=
begin
     rw ← assoc,
     rw prod.prod_comp_otimes,
     rw comp_id,
end
lemma one_mul_R (R A : C) (ζ : R⟦G.X⟧ ): R < ((T G.X) ≫ G.ε | 𝟙 G.X) ≫ G.μ > ζ  =  ζ := begin
     rw ← one_mul',rw G.hyp_one_mul,rw yoneda_sugar.id,exact rfl,
end
lemma mul_one_R (R A : C) (ζ : R⟦G.X⟧ ): R < ( 𝟙 G.X | (T G.X) ≫ G.ε ) ≫ G.μ > ζ  =  ζ :=
begin
     rw ← mul_one', rw G.hyp_mul_one,rw yoneda_sugar.id,exact rfl,
 end
def one   (R : C) : R ⟦(G.X) ⟧  :=
begin
     exact (terminal.from R ≫ G.ε),
end
def mul (R : C) : R⟦ G.X⟧   → R⟦ G.X⟧  → R ⟦ G.X ⟧  :=  λ g1 g2,
begin
     let φ := ( g1 | g2),
     -- let γ := (prod.mk g1 g2 : (yoneda.obj G.X).obj (op R) × (yoneda.obj G.X).obj (op R)), -- × versus ⨯
     -- let θ :=  (Yoneda_preserve_product R G.X G.X ).inv,
     let β := (R< (G.μ) > : R⟦ G.X ⨯ G.X⟧  ⟶ R⟦G.X⟧),
     exact β φ,
end
variables (R : C)
include R
instance yoneda_mul : has_mul (R⟦ G.X⟧) := ⟨mul C G R ⟩
instance yoneda_one : has_one (R⟦ G.X⟧) := ⟨one C G R ⟩
@[PRODUCT]lemma mul_comp (a b : R ⟦ G.X⟧ ) : a * b = (R < G.μ >) (a | b) := rfl -- priority R < g.μ > (a | b) not ()
@[PRODUCT]lemma one_comp :  (1 : R ⟦ G.X ⟧) = terminal.from R ≫ G.ε := rfl
-- group.mul : Π {α : Type u} [c : group α], α → α → α
-- group.mul_assoc : ∀ {α : Type u} [c : group α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
-- group.one : Π (α : Type u) [c : group α], α
-- group.one_mul : ∀ {α : Type u} [c : group α] (a : α), 1 * a = a
-- group.mul_one : ∀ {α : Type u} [c : group α] (a : α), a * 1 = a
-- group.inv : Π {α : Type u} [c : group α], α → α
-- group.mul_left_inv : ∀ {α : Type u} [c : group α] (a : α), a⁻¹ * a = 1
-- lemma pre_des (R: C) : (R < T G.X> | 𝟙 (R[G.X])) ≫ (R < G.ε > ⊗ 𝟙 (R[G.X])) =  (( R < T G.X>  ≫ (R < G.ε>)) | 𝟙 (R[G.X])) :=
-- begin exact destruction (R < T G.X>) (R < G.ε >), end

@[PRODUCT]lemma yoneda_sugar.apply_comp (G : group_obj C){R : C}{Z K :C}(f :  R ⟶ Z)(g : Z ⟶ K) : R < g > (f) = f ≫ g := rfl
-- lemma R < 𝟙 G.X> a

lemma yoneda_sugar_right_apply {R :C}{A Y Z : C }(ζ : R ⟦ A ⟧)
 (f : A ⟶ Y)(g : A ⟶ Y) : ( R< (f | g) >) ζ = (R < f > ζ | R < g > ζ ) :=
 begin
     rw yoneda_sugar.apply_comp C G,
     rw prod.left_composition,
     iterate 2 {rw yoneda_sugar.apply_comp  C G },
end
lemma yoneda_sugar_otimes_apply {R :C}{A1 A2 Y Z : C }(ζ1 : R ⟦ A1 ⟧)(ζ2 : R⟦ A2 ⟧ )
 (f1 : A1 ⟶ Y)(f2 : A2 ⟶ Z) :  R < (f1 ⊗ f2 ) > (ζ1 | ζ2) = ( R < f1 > ζ1 | R < f2 > ζ2  ) :=
 begin
     rw yoneda_sugar.apply_comp C G,
     rw prod.prod_comp_otimes,exact rfl,
 end
notation Y `⟶•`  := T Y
@[PRODUCT]lemma Terminal_comp{Y : C} ( a : R ⟶ Y) : a ≫ (Y ⟶•) = (R ⟶•) :=
by exact subsingleton.elim (a ≫ T Y) (T R)
@[PRODUCT]lemma lemmeF (a : R⟦ G.X ⟧) :

   (R < ( (T G.X) ≫ G.ε | 𝟙 G.X)> ) a =  ((T R) ≫ G.ε | a)  :=
begin
     rw yoneda_sugar_right_apply C  G,
     rw yoneda_sugar.apply_comp,rw ← assoc,
     rw Terminal_comp,rw yoneda_sugar.id,exact rfl,
     use G, use G, use R,
     -- rw ← Maxi_triviality,
     -- rw types_comp,
     -- tidy, rw Maxi_triviality,rw Yoneda_Maxi,rw Yoneda_Maxi,rw prod.left_composition,
     -- rw comp_id,rw ← assoc, rw Terminal_comp,exact rfl,iterate 3 {assumption},
end
@[PRODUCT]def one_mulf' (ζ  : R⟦G.X ⟧) :    1 * ζ  = ζ  := begin
     rw mul_comp,rw one_comp,
     let V := one_mul_R C G R R ζ,
     let r := R <G.μ>,
     rw [yoneda_sugar.apply_comp,← assoc,prod.left_composition,comp_id,
     ← assoc,Terminal_comp,← yoneda_sugar.apply_comp] at V,
     exact V,
     use G, use G, use G,
end
@[PRODUCT]def mul_onef'(ζ : R⟦G.X ⟧)  : ζ * 1 = ζ := begin
     rw mul_comp,rw one_comp,
     have V := mul_one_R C G R R ζ,
     rw [yoneda_sugar.apply_comp,← assoc,prod.left_composition,comp_id,← assoc,Terminal_comp,← yoneda_sugar.apply_comp] at V,
     exact V,
     use G, use G ,use G,
end
@[PRODUCT]def inv' (R :C) : R⟦ G.X⟧ → R⟦ G.X⟧   := λ  ζ, begin
     exact R<G.inv> ζ,
end
instance yoneda_inv (R :C) : has_inv (R⟦G.X⟧) := ⟨inv' C G R⟩
@[PRODUCT]lemma  inv_comp (ζ : R ⟦ G.X⟧ ) : ζ⁻¹  =  (R<G.inv>) ζ  := rfl
@[PRODUCT]lemma mul_left_inv' (ζ : R ⟦ G.X ⟧) : (ζ⁻¹ * ζ ) = 1 :=  begin
     rw inv_comp,rw mul_comp,rw one_comp, rw yoneda_sugar.apply_comp,
     have V : R< (G.inv | 𝟙 G.X )   ≫  G.μ> ζ = (R<(T G.X) ≫ G.ε>) ζ ,
          rw G.hyp_inv_mul,
     rw [yoneda_sugar.apply_comp,yoneda_sugar.apply_comp,← assoc,
     prod.left_composition,comp_id,← assoc,Terminal_comp,← yoneda_sugar.apply_comp C G ζ G.inv] at V,
     assumption, use G, use G, use G, use G,
end
lemma Grall (a b c : R ⟦G.X ⟧) : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))) := begin
     tidy,
     rw [yoneda_sugar.apply_comp, ← assoc,prod.left_composition,
     ← assoc,prod.prod_comp_otimes,yoneda_sugar.apply_comp,yoneda_sugar.apply_comp],
     iterate 3 {swap,use G},
     rw comp_id,tidy,PRODUCT_CAT,
     rw [← assoc,prod.left_composition,prod.lift_snd (a | b) c, ← assoc, prod.lift_fst,prod.lift_snd],
end
-- (hyp_mul_inv  :  (inv | 𝟙 X ) ≫  μ = (T X) ≫ ε )
lemma mul_assoc' (a b c : R ⟦G.X ⟧) : a * b *c = a * ( b * c ) := begin
     iterate 4 { rw mul_comp}, PRODUCT_CAT,
     have ASSOC : R<((G.μ ⊗ (𝟙 G.X)) ≫ (G.μ)) >(a | b | c) = (R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ>) (a | b | c),
          rw G.hyp_assoc,
     rw [yoneda_sugar.apply_comp,← assoc,prod.prod_comp_otimes,comp_id,
     ← yoneda_sugar.apply_comp, ← yoneda_sugar.apply_comp] at ASSOC,
     iterate 3 {swap,use G},
     have G_hyp : R < (prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ) ≫ G.μ> (a | b | c)
     =(R < G.μ>) (a | (R < G.μ> (b | c))),
          exact Grall C G R a b c ,
       rw G_hyp at ASSOC,assumption,
     -- R<(prod.associator G.X G.X G.X).hom ≫ (𝟙 G.X ⊗ G.μ)  ≫ G.μ> (a | b | c),

end

instance : group (R⟦G.X⟧) :=
{
     mul := has_mul.mul,
     mul_assoc := mul_assoc' C G R,
     one    := (1 : R⟦ G.X⟧),
     mul_one := mul_onef' C G R,
     one_mul := one_mulf' C G R,
     inv  := inv' C G R,
     mul_left_inv := mul_left_inv' C G R,
}


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

open categories
open categories.monoidal_category

namespace categories.internal_objects

universes u v

open MonoidObject

structure ModuleObject {C : Type u} [𝒞 : monoidal_category.{u v} C] (A : C) [MonoidObject A] extends SemigroupModuleObject A :=
  (identity  : (inverse_left_unitor module) ≫ ((ι A) ⊗ (𝟙 module)) ≫ action = 𝟙 module)

attribute [simp,ematch] ModuleObject.identity

variables {C : Type u} [𝒞 : monoidal_category.{u v} C] {A : C} [MonoidObject A]
include 𝒞

structure ModuleMorphism ( X Y : ModuleObject A )
  extends SemigroupModuleMorphism X.to_SemigroupModuleObject Y.to_SemigroupModuleObject

@[applicable] lemma ModuleMorphism_pointwise_equal
  { X Y : ModuleObject A }
  ( f g : ModuleMorphism X Y )
  ( w : f.map = g.map ) : f = g :=
  begin
    induction f with f_underlying,
    induction g with g_underlying,
    tidy,
  end

definition CategoryOfModules : category.{(max u v) v} (ModuleObject A) :=
{ Hom := λ X Y, ModuleMorphism X Y,
  identity := λ X, ⟨ ⟨ 𝟙 X.module, by obviously ⟩ ⟩, -- we need double ⟨ ⟨ ... ⟩ ⟩ because we're using structure extension
  compose  := λ _ _ _ f g, ⟨ ⟨ f.map ≫ g.map, by obviously ⟩ ⟩ }

end categories.internal_objects


import condensed.adjunctions
import condensed.top_comparison

noncomputable theory

universe u

open category_theory

namespace Sheaf

@[simps]
def hom_equiv {C D : Type*} [category C] [category D]
  {J : grothendieck_topology C} (F G : Sheaf J D) :
  (F ⟶ G) ≃ (F.val ⟶ G.val) :=
{ to_fun := λ f, f.val,
  inv_fun := λ f, ⟨f⟩,
  left_inv := λ f, by { cases f, refl },
  right_inv := λ f, rfl }

end Sheaf

namespace condensed

variables (M : Condensed.{u} Ab.{u+1}) (S T : Profinite.{u}ᵒᵖ) (f : S ⟶ T)

def profinite_free_adj_aux₁  :
  (CondensedSet_to_Condensed_Ab.obj (opposite.unop S).to_Condensed ⟶ M) ≃
  ((opposite.unop S).to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj M) :=
Condensed_Ab_CondensedSet_adjunction.hom_equiv S.unop.to_Condensed M

lemma profinite_free_adj_aux₁_naturality
  (x : CondensedSet_to_Condensed_Ab.obj S.unop.to_Condensed ⟶ M) :
  profinite_free_adj_aux₁ _ _
  ((CondensedSet_to_Condensed_Ab.map (Profinite_to_Condensed.map f.unop) ≫ x)) =
  Profinite_to_Condensed.map f.unop ≫ profinite_free_adj_aux₁ _ _ x :=
begin
  dsimp only [profinite_free_adj_aux₁],
  simpa only [adjunction.hom_equiv_naturality_left],
end

def profinite_free_adj_aux₂ (M : Condensed.{u} Ab.{u+1}) (S : Profinite.{u}ᵒᵖ) :
  ((opposite.unop S).to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj M) ≃
  ((opposite.unop S).to_Condensed.val ⟶ (Condensed_Ab_to_CondensedSet.obj M).val) :=
(Sheaf.hom_equiv _ _)

lemma profinite_free_adj_aux₂_naturality
  (x : S.unop.to_Condensed ⟶ Condensed_Ab_to_CondensedSet.obj M) :
  profinite_free_adj_aux₂ _ _ ((Profinite_to_Condensed.map f.unop) ≫ x) =
  (Profinite_to_Condensed.map f.unop).val ≫ profinite_free_adj_aux₂ _ _ x := rfl

def profinite_free_adj_aux₃ (M : Condensed.{u} Ab.{u+1}) (S : Profinite.{u}ᵒᵖ) :
  ((opposite.unop S).to_Condensed.val ⟶ (Condensed_Ab_to_CondensedSet.obj M).val) ≃
  (M.val.obj S) :=
yoneda'_equiv _ _

lemma profinite_free_adj_aux₃_naturality
  (x : (opposite.unop S).to_Condensed.val ⟶ (Condensed_Ab_to_CondensedSet.obj M).val) :
  profinite_free_adj_aux₃ _ _ ((Profinite_to_Condensed.map f.unop).val ≫ x) =
  (M.val.map f) (profinite_free_adj_aux₃ _ _ x) :=
begin
  have := x.naturality f,
  apply_fun (λ e, e (ulift.up (𝟙 S.unop))) at this,
  exact this,
end

def profinite_free_adj_aux (M : Condensed.{u} Ab.{u+1}) (S : Profinite.{u}ᵒᵖ):
  (AddCommGroup.of ((CondensedSet_to_Condensed_Ab.obj (opposite.unop S).to_Condensed) ⟶ M)) ≃+
  (M.val.obj S) :=
{ map_add' := λ f g, rfl,
  ..((profinite_free_adj_aux₁ M S).trans
    ((profinite_free_adj_aux₂ _ _).trans
    (profinite_free_adj_aux₃ _ _))) }

def profinite_free_adj (M : Condensed.{u} Ab.{u+1}) :
  (Profinite_to_Condensed ⋙ CondensedSet_to_Condensed_Ab).op ⋙ preadditive_yoneda.obj M ≅
  M.val :=
nat_iso.of_components
(λ S, begin
  apply add_equiv.to_AddCommGroup_iso,
  apply profinite_free_adj_aux,
end)
begin
  intros S T f, ext t,
  change ((profinite_free_adj_aux₁ M T).trans
    ((profinite_free_adj_aux₂ M T).trans (profinite_free_adj_aux₃ M T))) _ = _,
  dsimp only [equiv.trans_apply, functor.comp_map, functor.op_map, preadditive_yoneda],
  erw profinite_free_adj_aux₁_naturality,
  erw profinite_free_adj_aux₂_naturality,
  erw profinite_free_adj_aux₃_naturality,
  refl,
end

end condensed


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

! This file was ported from Lean 3 source module tactic.linarith.verification
! leanprover-community/mathlib commit 9b2660e1b25419042c8da10bf411aa3c67f14383
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Linarith.Elimination
import Mathbin.Tactic.Linarith.Parsing

/-!
# Deriving a proof of false

`linarith` uses an untrusted oracle to produce a certificate of unsatisfiability.
It needs to do some proof reconstruction work to turn this into a proof term.
This file implements the reconstruction.

## Main declarations

The public facing declaration in this file is `prove_false_by_linarith`.
-/

namespace Linarith

open Ineq Tactic Native

/-! ### Auxiliary functions for assembling proofs -/

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `mul_expr n e` creates a `pexpr` representing `n*e`.
      When elaborated, the coefficient will be a native numeral of the same type as `e`.
      -/
    unsafe
  def
    mul_expr
    ( n : ℕ ) ( e : expr ) : pexpr
    := if n = 1 then ` `( $ ( e ) ) else ` `( $ ( nat.to_pexpr n ) * $ ( e ) )
#align linarith.mul_expr linarith.mul_expr

-- failed to format: unknown constant 'term.pseudo.antiquot'
private unsafe
  def
    add_exprs_aux
    : pexpr → List pexpr → pexpr
    | p , [ ] => p
      | p , [ a ] => ` `( $ ( p ) + $ ( a ) )
      | p , h :: t => add_exprs_aux ` `( $ ( p ) + $ ( h ) ) t
#align linarith.add_exprs_aux linarith.add_exprs_aux

/-- `add_exprs l` creates a `pexpr` representing the sum of the elements of `l`, associated left.
If `l` is empty, it will be the `pexpr` 0. Otherwise, it does not include 0 in the sum.
-/
unsafe def add_exprs : List pexpr → pexpr
  | [] => ``(0)
  | h :: t => add_exprs_aux h t
#align linarith.add_exprs linarith.add_exprs

/-- If our goal is to add together two inequalities `t1 R1 0` and `t2 R2 0`,
`ineq_const_nm R1 R2` produces the strength of the inequality in the sum `R`,
along with the name of a lemma to apply in order to conclude `t1 + t2 R 0`.
-/
unsafe def ineq_const_nm : Ineq → Ineq → Name × Ineq
  | Eq, Eq => (`` eq_of_eq_of_eq, Eq)
  | Eq, le => (`` le_of_eq_of_le, le)
  | Eq, lt => (`` lt_of_eq_of_lt, lt)
  | le, Eq => (`` le_of_le_of_eq, le)
  | le, le => (`add_nonpos, le)
  | le, lt => (`add_lt_of_le_of_neg, lt)
  | lt, Eq => (`` lt_of_lt_of_eq, lt)
  | lt, le => (`add_lt_of_neg_of_le, lt)
  | lt, lt => (`left.add_neg, lt)
#align linarith.ineq_const_nm linarith.ineq_const_nm

/--
`mk_lt_zero_pf_aux c pf npf coeff` assumes that `pf` is a proof of `t1 R1 0` and `npf` is a proof
of `t2 R2 0`. It uses `mk_single_comp_zero_pf` to prove `t1 + coeff*t2 R 0`, and returns `R`
along with this proof.
-/
unsafe def mk_lt_zero_pf_aux (c : Ineq) (pf npf : expr) (coeff : ℕ) : tactic (Ineq × expr) := do
  let (iq, h') ← mk_single_comp_zero_pf coeff npf
  let (nm, niq) := ineq_const_nm c iq
  Prod.mk niq <$> mk_app nm [pf, h']
#align linarith.mk_lt_zero_pf_aux linarith.mk_lt_zero_pf_aux

/-- `mk_lt_zero_pf coeffs pfs` takes a list of proofs of the form `tᵢ Rᵢ 0`,
paired with coefficients `cᵢ`.
It produces a proof that `∑cᵢ * tᵢ R 0`, where `R` is as strong as possible.
-/
unsafe def mk_lt_zero_pf : List (expr × ℕ) → tactic expr
  | [] => fail "no linear hypotheses found"
  | [(h, c)] => Prod.snd <$> mk_single_comp_zero_pf c h
  | (h, c) :: t => do
    let (iq, h') ← mk_single_comp_zero_pf c h
    Prod.snd <$> t (fun pr ce => mk_lt_zero_pf_aux pr.1 pr.2 ce.1 ce.2) (iq, h')
#align linarith.mk_lt_zero_pf linarith.mk_lt_zero_pf

/-- If `prf` is a proof of `t R s`, `term_of_ineq_prf prf` returns `t`. -/
unsafe def term_of_ineq_prf (prf : expr) : tactic expr :=
  Prod.fst <$> (infer_type prf >>= get_rel_sides)
#align linarith.term_of_ineq_prf linarith.term_of_ineq_prf

/-- If `prf` is a proof of `t R s`, `ineq_prf_tp prf` returns the type of `t`. -/
unsafe def ineq_prf_tp (prf : expr) : tactic expr :=
  term_of_ineq_prf prf >>= infer_type
#align linarith.ineq_prf_tp linarith.ineq_prf_tp

/-- `mk_neg_one_lt_zero_pf tp` returns a proof of `-1 < 0`,
where the numerals are natively of type `tp`.
-/
unsafe def mk_neg_one_lt_zero_pf (tp : expr) : tactic expr := do
  let h ← mk_mapp `linarith.zero_lt_one [tp, none, none]
  mk_app `neg_neg_of_pos [h]
#align linarith.mk_neg_one_lt_zero_pf linarith.mk_neg_one_lt_zero_pf

/-- If `e` is a proof that `t = 0`, `mk_neg_eq_zero_pf e` returns a proof that `-t = 0`.
-/
unsafe def mk_neg_eq_zero_pf (e : expr) : tactic expr :=
  to_expr ``(neg_eq_zero.mpr $(e))
#align linarith.mk_neg_eq_zero_pf linarith.mk_neg_eq_zero_pf

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `prove_eq_zero_using tac e` tries to use `tac` to construct a proof of `e = 0`.
      -/
    unsafe
  def
    prove_eq_zero_using
    ( tac : tactic Unit ) ( e : expr ) : tactic expr
    := do let tgt ← to_expr ` `( $ ( e ) = 0 ) Prod.snd <$> solve_aux tgt ( tac >> done )
#align linarith.prove_eq_zero_using linarith.prove_eq_zero_using

/-- `add_neg_eq_pfs l` inspects the list of proofs `l` for proofs of the form `t = 0`. For each such
proof, it adds a proof of `-t = 0` to the list.
-/
unsafe def add_neg_eq_pfs : List expr → tactic (List expr)
  | [] => return []
  | h :: t => do
    let some (iq, tp) ← parse_into_comp_and_expr <$> infer_type h
    match iq with
      | ineq.eq => do
        let nep ← mk_neg_eq_zero_pf h
        let tl ← add_neg_eq_pfs t
        return <| h :: nep :: tl
      | _ => List.cons h <$> add_neg_eq_pfs t
#align linarith.add_neg_eq_pfs linarith.add_neg_eq_pfs

/-! #### The main method -/

/-- `prove_false_by_linarith` is the main workhorse of `linarith`.
Given a list `l` of proofs of `tᵢ Rᵢ 0`,
it tries to derive a contradiction from `l` and use this to produce a proof of `false`.

An oracle is used to search for a certificate of unsatisfiability.
In the current implementation, this is the Fourier Motzkin elimination routine in
`elimination.lean`, but other oracles could easily be swapped in.

The returned certificate is a map `m` from hypothesis indices to natural number coefficients.
If our set of hypotheses has the form  `{tᵢ Rᵢ 0}`,
then the elimination process should have guaranteed that
1.\ `∑ (m i)*tᵢ = 0`,
with at least one `i` such that `m i > 0` and `Rᵢ` is `<`.

We have also that
2.\ `∑ (m i)*tᵢ < 0`,
since for each `i`, `(m i)*tᵢ ≤ 0` and at least one is strictly negative.
So we conclude a contradiction `0 < 0`.

It remains to produce proofs of (1) and (2). (1) is verified by calling the `discharger` tactic
of the `linarith_config` object, which is typically `ring`. We prove (2) by folding over the
set of hypotheses.
-/
unsafe def prove_false_by_linarith (cfg : linarith_config) : List expr → tactic expr
  | [] => fail "no args to linarith"
  | l@(h :: t) => do
    let l'
      ←-- for the elimination to work properly, we must add a proof of `-1 < 0` to the list,
          -- along with negated equality proofs.
          add_neg_eq_pfs
          l
    let hz ← ineq_prf_tp h >>= mk_neg_one_lt_zero_pf
    let inputs := hz :: l'
    let-- perform the elimination and fail if no contradiction is found.
      (comps, max_var)
      ← linear_forms_and_max_var cfg.Transparency inputs
    let certificate ←
      cfg.oracle.getD fourier_motzkin.produce_certificate comps max_var <|>
          fail "linarith failed to find a contradiction"
    linarith_trace "linarith has found a contradiction"
    let enum_inputs := inputs.enum
    let-- construct a list pairing nonzero coeffs with the proof of their corresponding comparison
    zip := enum_inputs.filterMap fun ⟨n, e⟩ => Prod.mk e <$> certificate.find n
    let mls ←
      zip.mapM fun ⟨e, n⟩ => do
          let e ← term_of_ineq_prf e
          return (mul_expr n e)
    let sm
      ←-- `sm` is the sum of input terms, scaled to cancel out all variables.
          to_expr <|
          add_exprs mls
    (f!"The expression
            {← sm}
          should be both 0 and negative") >>=
        linarith_trace
    let sm_eq_zero
      ←-- we prove that `sm = 0`, typically with `ring`.
          prove_eq_zero_using
          cfg.discharger sm
    linarith_trace "We have proved that it is zero"
    let sm_lt_zero
      ←-- we also prove that `sm < 0`.
          mk_lt_zero_pf
          zip
    linarith_trace "We have proved that it is negative"
    let pftp
      ←-- this is a contradiction.
          infer_type
          sm_lt_zero
    let (_, nep, _) ← rewrite_core sm_eq_zero pftp
    let pf' ← mk_eq_mp nep sm_lt_zero
    mk_app `lt_irrefl [pf']
#align linarith.prove_false_by_linarith linarith.prove_false_by_linarith

end Linarith


/-
Copyright (c) 2022 Rémi Bottinelli. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémi Bottinelli, Junyan Xu
-/
import category_theory.groupoid.vertex_group
import category_theory.groupoid.basic
import category_theory.groupoid
import algebra.group.defs
import data.set.lattice
import group_theory.subgroup.basic
import order.galois_connection
/-!
# Subgroupoid

This file defines subgroupoids as `structure`s containing the subsets of arrows and their
stability under composition and inversion.
Also defined are:

* containment of subgroupoids is a complete lattice;
* images and preimages of subgroupoids under a functor;
* the notion of normality of subgroupoids and its stability under intersection and preimage;
* compatibility of the above with `groupoid.vertex_group`.

## Main definitions

Given a type `C` with associated `groupoid C` instance.

* `subgroupoid C` is the type of subgroupoids of `C`
* `subgroupoid.is_normal` is the property that the subgroupoid is stable under conjugation
  by arbitrary arrows, _and_ that all identity arrows are contained in the subgroupoid.
* `subgroupoid.comap` is the "preimage" map of subgroupoids along a functor.
* `subgroupoid.map` is the "image" map of subgroupoids along a functor _injective on objects_.
* `subgroupoid.vertex_subgroup` is the subgroup of the `vertex group` at a given vertex `v`,
  assuming `v` is contained in the `subgroupoid` (meaning, by definition, that the arrow `𝟙 v`
  is contained in the subgroupoid).

## Implementation details

The structure of this file is copied from/inspired by `group_theory.subgroup.basic`
and `combinatorics.simple_graph.subgraph`.

## TODO

* Equivalent inductive characterization of generated (normal) subgroupoids.
* Characterization of normal subgroupoids as kernels.
* Prove that `full` and `disconnect` preserve intersections (and `disconnect` also unions)

## Tags

subgroupoid

-/

namespace category_theory

open set groupoid

local attribute [protected] category_theory.inv

universes u v

variables {C : Type u} [groupoid C]

/--
A sugroupoid of `C` consists of a choice of arrows for each pair of vertices, closed
under composition and inverses.
-/
@[ext] structure subgroupoid (C : Type u) [groupoid C] :=
(arrows : ∀ (c d : C), set (c ⟶ d))
(inv : ∀ {c d} {p : c ⟶ d} (hp : p ∈ arrows c d),
          inv p ∈ arrows d c)
(mul : ∀ {c d e} {p} (hp : p ∈ arrows c d) {q} (hq : q ∈ arrows d e),
          p ≫ q ∈ arrows c e)

attribute [protected] subgroupoid.inv subgroupoid.mul

namespace subgroupoid

variable (S : subgroupoid C)

lemma inv_mem_iff {c d : C} (f : c ⟶ d) : inv f ∈ S.arrows d c ↔ f ∈ S.arrows c d :=
begin
  split,
  { rintro h,
    suffices : inv (inv f) ∈ S.arrows c d,
    { simpa only [inv_eq_inv, is_iso.inv_inv] using this, },
    { apply S.inv h, }, },
  { apply S.inv, },
end

lemma mul_mem_cancel_left {c d e : C} {f : c ⟶ d} {g : d ⟶ e} (hf : f ∈ S.arrows c d) :
  f ≫ g ∈ S.arrows c e ↔ g ∈ S.arrows d e :=
begin
  split,
  { rintro h,
    suffices : (inv f) ≫ f ≫ g ∈ S.arrows d e,
    { simpa only [inv_eq_inv, is_iso.inv_hom_id_assoc] using this, },
    { apply S.mul (S.inv hf) h, }, },
  { apply S.mul hf, },
end

lemma mul_mem_cancel_right {c d e : C} {f : c ⟶ d} {g : d ⟶ e} (hg : g ∈ S.arrows d e) :
  f ≫ g ∈ S.arrows c e ↔ f ∈ S.arrows c d :=
begin
  split,
  { rintro h,
    suffices : (f ≫ g) ≫ (inv g) ∈ S.arrows c d,
    { simpa only [inv_eq_inv, is_iso.hom_inv_id, category.comp_id, category.assoc] using this, },
    { apply S.mul h (S.inv hg), }, },
  { exact λ hf, S.mul hf hg, },
end

/-- The vertices of `C` on which `S` has non-trivial isotropy -/
def objs : set C := {c : C | (S.arrows c c).nonempty}

lemma mem_objs_of_src {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : c ∈ S.objs :=
⟨f ≫ inv f, S.mul h (S.inv h)⟩

lemma mem_objs_of_tgt {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : d ∈ S.objs :=
⟨(inv f) ≫ f, S.mul (S.inv h) h⟩

lemma id_mem_of_nonempty_isotropy (c : C) :
  c ∈ objs S → 𝟙 c ∈ S.arrows c c :=
begin
  rintro ⟨γ,hγ⟩,
  convert S.mul hγ (S.inv hγ),
  simp only [inv_eq_inv, is_iso.hom_inv_id],
end

lemma id_mem_of_src {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : (𝟙 c) ∈ S.arrows c c :=
id_mem_of_nonempty_isotropy S c (mem_objs_of_src S h)

lemma id_mem_of_tgt {c d : C} {f : c ⟶ d} (h : f ∈ S.arrows c d) : (𝟙 d) ∈ S.arrows d d :=
id_mem_of_nonempty_isotropy S d (mem_objs_of_tgt S h)

/-- A subgroupoid seen as a quiver on vertex set `C` -/
def as_wide_quiver : quiver C := ⟨λ c d, subtype $ S.arrows c d⟩

/-- The coercion of a subgroupoid as a groupoid -/
@[simps to_category_comp_coe, simps inv_coe (lemmas_only)]
instance coe : groupoid S.objs :=
{ hom := λ a b, S.arrows a.val b.val,
  id := λ a, ⟨𝟙 a.val, id_mem_of_nonempty_isotropy S a.val a.prop⟩,
  comp := λ a b c p q, ⟨p.val ≫ q.val, S.mul p.prop q.prop⟩,
  id_comp' := λ a b ⟨p,hp⟩, by simp only [category.id_comp],
  comp_id' := λ a b ⟨p,hp⟩, by simp only [category.comp_id],
  assoc' := λ a b c d ⟨p,hp⟩ ⟨q,hq⟩ ⟨r,hr⟩, by simp only [category.assoc],
  inv := λ a b p, ⟨inv p.val, S.inv p.prop⟩,
  inv_comp' := λ a b ⟨p,hp⟩, by simp only [inv_comp],
  comp_inv' := λ a b ⟨p,hp⟩, by simp only [comp_inv] }

@[simp] lemma coe_inv_coe' {c d : S.objs} (p : c ⟶ d) :
  (category_theory.inv p).val = category_theory.inv p.val :=
by { simp only [subtype.val_eq_coe, ←inv_eq_inv, coe_inv_coe], }

/-- The embedding of the coerced subgroupoid to its parent-/
def hom : S.objs ⥤ C :=
{ obj := λ c, c.val,
  map := λ c d f, f.val,
  map_id' := λ c, rfl,
  map_comp' := λ c d e f g, rfl }

lemma hom.inj_on_objects : function.injective (hom S).obj :=
by { rintros ⟨c,hc⟩ ⟨d,hd⟩ hcd, simp only [subtype.mk_eq_mk], exact hcd }

lemma hom.faithful :
  ∀ c d, function.injective (λ (f : c ⟶ d), (hom S).map f) :=
by { rintros ⟨c,hc⟩ ⟨d,hd⟩ ⟨f,hf⟩ ⟨g,hg⟩ hfg, simp only [subtype.mk_eq_mk], exact hfg, }

/-- The subgroup of the vertex group at `c` given by the subgroupoid -/
def vertex_subgroup {c : C} (hc : c ∈ S.objs) : subgroup (c ⟶ c) :=
{ carrier  := S.arrows c c,
  mul_mem' := λ f g hf hg, S.mul hf hg,
  one_mem' := id_mem_of_nonempty_isotropy _ _ hc,
  inv_mem' := λ f hf, S.inv hf }

instance : set_like (subgroupoid C) (Σ (c d : C), c ⟶ d) :=
{ coe := λ S, {F | F.2.2 ∈ S.arrows F.1 F.2.1},
  coe_injective' := λ ⟨S, _, _⟩ ⟨T, _, _⟩ h, by { ext c d f, apply set.ext_iff.1 h ⟨c, d, f⟩ } }

lemma mem_iff (S : subgroupoid C) (F : Σ c d, c ⟶ d) :
  F ∈ S ↔ F.2.2 ∈ S.arrows F.1 F.2.1 := iff.rfl

lemma le_iff (S T : subgroupoid C) : (S ≤ T) ↔ (∀ {c d}, (S.arrows c d) ⊆ (T.arrows c d)) :=
by { rw [set_like.le_def, sigma.forall], exact forall_congr (λ c, sigma.forall) }

instance : has_top (subgroupoid C) :=
⟨ { arrows := (λ _ _, set.univ),
    mul    := by { rintros, trivial, },
    inv    := by { rintros, trivial, } } ⟩

lemma mem_top {c d : C} (f : c ⟶ d) : f ∈ (⊤ : subgroupoid C).arrows c d := trivial

lemma mem_top_objs (c : C) : c ∈ (⊤ : subgroupoid C).objs :=
by { dsimp [has_top.top,objs], simp only [univ_nonempty], }

instance : has_bot (subgroupoid C) :=
⟨ { arrows := (λ _ _, ∅),
    mul    := λ _ _ _ _, false.elim,
    inv    := λ _ _ _, false.elim } ⟩

instance : inhabited (subgroupoid C) := ⟨⊤⟩

instance : has_inf (subgroupoid C) :=
⟨ λ S T,
  { arrows := (λ c d, (S.arrows c d) ∩ (T.arrows c d)),
    inv    := by { rintros, exact ⟨S.inv hp.1, T.inv hp.2⟩, },
    mul    := by { rintros, exact ⟨S.mul hp.1 hq.1, T.mul hp.2 hq.2⟩, } } ⟩

instance : has_Inf (subgroupoid C) :=
⟨ λ s,
  { arrows := λ c d, ⋂ S ∈ s, (subgroupoid.arrows S c d),
    inv := by { intros, rw mem_Inter₂ at hp ⊢, exact λ S hS, S.inv (hp S hS) },
    mul := by { intros, rw mem_Inter₂ at hp hq ⊢,exact λ S hS, S.mul (hp S hS) (hq S hS) } } ⟩

instance : complete_lattice (subgroupoid C) :=
{ bot          := (⊥),
  bot_le       := λ S, empty_subset _,
  top          := (⊤),
  le_top       := λ S, subset_univ _,
  inf          := (⊓),
  le_inf       := λ R S T RS RT _ pR, ⟨RS pR, RT pR⟩,
  inf_le_left  := λ R S _, and.left,
  inf_le_right := λ R S _, and.right,
  .. complete_lattice_of_Inf (subgroupoid C)
  begin
    refine (λ s, ⟨λ S Ss F, _, λ T Tl F fT, _⟩);
      simp only [Inf, mem_iff, mem_Inter],
    exacts [λ hp, hp S Ss, λ S Ss, Tl Ss fT],
  end }

lemma le_objs {S T : subgroupoid C} (h : S ≤ T) : S.objs ⊆ T.objs :=
λ s ⟨γ, hγ⟩, ⟨γ, @h ⟨s, s, γ⟩ hγ⟩

/-- The functor associated to the embedding of subgroupoids -/
def inclusion {S T : subgroupoid C} (h : S ≤ T) : S.objs ⥤ T.objs :=
{ obj := λ s, ⟨s.val, le_objs h s.prop⟩,
  map := λ s t f, ⟨f.val, @h ⟨s, t, f.val⟩ f.prop⟩,
  map_id' := λ _, rfl,
  map_comp' := λ _ _ _ _ _, rfl }

lemma inclusion_inj_on_objects {S T : subgroupoid C} (h : S ≤ T) :
  function.injective (inclusion h).obj :=
λ ⟨s,hs⟩ ⟨t,ht⟩, by simpa only [inclusion, subtype.mk_eq_mk] using id

lemma inclusion_faithful {S T : subgroupoid C} (h : S ≤ T) (s t : S.objs) :
  function.injective (λ (f : s ⟶ t), (inclusion h).map f) :=
λ ⟨f,hf⟩ ⟨g,hg⟩, by { dsimp only [inclusion], simpa only [subtype.mk_eq_mk] using id }

lemma inclusion_refl {S : subgroupoid C} : inclusion (le_refl S) = 𝟭 S.objs :=
functor.hext (λ ⟨s,hs⟩, rfl) (λ ⟨s,hs⟩ ⟨t,ht⟩ ⟨f,hf⟩, heq_of_eq rfl)

lemma inclusion_trans {R S T : subgroupoid C} (k : R ≤ S) (h : S ≤ T) :
  inclusion (k.trans h) = (inclusion k) ⋙ (inclusion h) := rfl

lemma inclusion_comp_embedding {S T : subgroupoid C} (h : S ≤ T) :
  (inclusion h) ⋙ T.hom = S.hom := rfl

/-- The family of arrows of the discrete groupoid -/
inductive discrete.arrows : Π (c d : C), (c ⟶ d) → Prop
| id (c : C) : discrete.arrows c c (𝟙 c)

/-- The only arrows of the discrete groupoid are the identity arrows. -/
def discrete : subgroupoid C :=
{ arrows := discrete.arrows,
  inv := by { rintros _ _ _ ⟨⟩, simp only [inv_eq_inv, is_iso.inv_id], split, },
  mul := by { rintros _ _ _ _ ⟨⟩ _ ⟨⟩, rw category.comp_id, split, } }

lemma mem_discrete_iff {c d : C} (f : c ⟶ d) :
  (f ∈ (discrete).arrows c d) ↔ (∃ (h : c = d), f = eq_to_hom h) :=
⟨by { rintro ⟨⟩, exact ⟨rfl, rfl⟩ }, by { rintro ⟨rfl, rfl⟩, split }⟩

/-- A subgroupoid is wide if its carrier set is all of `C`-/
structure is_wide : Prop :=
(wide : ∀ c, (𝟙 c) ∈ (S.arrows c c))

lemma is_wide_iff_objs_eq_univ : S.is_wide ↔ S.objs = set.univ :=
begin
  split,
  { rintro h,
    ext, split; simp only [top_eq_univ, mem_univ, implies_true_iff, forall_true_left],
    apply mem_objs_of_src S (h.wide x), },
  { rintro h,
    refine ⟨λ c, _⟩,
    obtain ⟨γ,γS⟩ := (le_of_eq h.symm : ⊤ ⊆ S.objs) (set.mem_univ c),
    exact id_mem_of_src S γS, },
end

lemma is_wide.id_mem {S : subgroupoid C} (Sw : S.is_wide) (c : C) :
  (𝟙 c) ∈ S.arrows c c := Sw.wide c

lemma is_wide.eq_to_hom_mem {S : subgroupoid C} (Sw : S.is_wide) {c d : C} (h : c = d) :
  (eq_to_hom h) ∈ S.arrows c d := by
{ cases h, simp only [eq_to_hom_refl], apply Sw.id_mem c, }

/-- A subgroupoid is normal if it is wide and satisfies the expected stability under conjugacy. -/
structure is_normal extends (is_wide S) : Prop :=
(conj : ∀ {c d} (p : c ⟶ d) {γ : c ⟶ c} (hs : γ ∈ S.arrows c c),
              ((inv p) ≫ γ ≫ p) ∈ (S.arrows d d))

lemma is_normal.conj' {S : subgroupoid C} (Sn : is_normal S) :
  ∀ {c d} (p : d ⟶ c) {γ : c ⟶ c} (hs : γ ∈ S.arrows c c), (p ≫ γ ≫ (inv p)) ∈ (S.arrows d d) :=
λ c d p γ hs, by { convert Sn.conj (inv p) hs, simp, }

lemma is_normal.conjugation_bij (Sn : is_normal S) {c d} (p : c ⟶ d) :
  set.bij_on (λ γ : c ⟶ c, (inv p) ≫ γ ≫ p) (S.arrows c c) (S.arrows d d) :=
begin
  refine ⟨λ γ γS, Sn.conj p γS, λ γ₁ γ₁S γ₂ γ₂S h, _, λ δ δS, ⟨p ≫ δ ≫ (inv p), Sn.conj' p δS, _⟩⟩,
  { simpa only [inv_eq_inv, category.assoc, is_iso.hom_inv_id,
                category.comp_id, is_iso.hom_inv_id_assoc] using p ≫= h =≫ inv p },
  { simp only [inv_eq_inv, category.assoc, is_iso.inv_hom_id,
               category.comp_id, is_iso.inv_hom_id_assoc] },
end

lemma top_is_normal : is_normal (⊤ : subgroupoid C) :=
{ wide := (λ c, trivial),
  conj := (λ a b c d e, trivial) }

lemma Inf_is_normal (s : set $ subgroupoid C) (sn : ∀ S ∈ s, is_normal S) : is_normal (Inf s) :=
{ wide := by { simp_rw [Inf, mem_Inter₂], exact λ c S Ss, (sn S Ss).wide c },
  conj := by { simp_rw [Inf, mem_Inter₂], exact λ c d p γ hγ S Ss, (sn S Ss).conj p (hγ S Ss) } }

lemma discrete_is_normal : (@discrete C _).is_normal :=
{ wide := λ c, by { constructor, },
  conj := λ c d f γ hγ, by
  { cases hγ, simp only [inv_eq_inv, category.id_comp, is_iso.inv_hom_id], constructor, } }

lemma is_normal.vertex_subgroup (Sn : is_normal S) (c : C) (cS : c ∈ S.objs) :
  (S.vertex_subgroup cS).normal :=
{ conj_mem := λ x hx y, by { rw mul_assoc, exact Sn.conj' y hx } }

section generated_subgroupoid

-- TODO: proof that generated is just "words in X" and generated_normal is similarly
variable (X : ∀ c d : C, set (c ⟶ d))

/-- The subgropoid generated by the set of arrows `X` -/
def generated : subgroupoid C :=
Inf {S : subgroupoid C | ∀ c d, X c d ⊆ S.arrows c d}

lemma subset_generated (c d : C) : X c d ⊆ (generated X).arrows c d :=
begin
  dsimp only [generated, Inf],
  simp only [subset_Inter₂_iff],
  exact λ S hS f fS, hS _ _ fS,
end

/-- The normal sugroupoid generated by the set of arrows `X` -/
def generated_normal : subgroupoid C :=
Inf {S : subgroupoid C | (∀ c d, X c d ⊆ S.arrows c d) ∧ S.is_normal}

lemma generated_le_generated_normal : generated X ≤ generated_normal X :=
begin
  apply @Inf_le_Inf (subgroupoid C) _,
  exact λ S ⟨h,_⟩, h,
end

lemma generated_normal_is_normal : (generated_normal X).is_normal :=
Inf_is_normal _ (λ S h, h.right)

lemma is_normal.generated_normal_le {S : subgroupoid C} (Sn : S.is_normal) :
  generated_normal X ≤ S ↔ ∀ c d, X c d ⊆ S.arrows c d :=
begin
  split,
  { rintro h c d,
    let h' := generated_le_generated_normal X,
    rw le_iff at h h',
    exact ((subset_generated X c d).trans (@h' c d)).trans (@h c d), },
  { rintro h,
    apply @Inf_le (subgroupoid C) _,
    exact ⟨h,Sn⟩, },
end

end generated_subgroupoid

section hom

variables {D : Type*} [groupoid D] (φ : C ⥤ D)

/--
A functor between groupoid defines a map of subgroupoids in the reverse direction
by taking preimages.
 -/
def comap (S : subgroupoid D) : subgroupoid C :=
{ arrows := λ c d, {f : c ⟶ d | φ.map f ∈ S.arrows (φ.obj c) (φ.obj d)},
  inv := λ c d p hp, by { rw [mem_set_of, inv_eq_inv, φ.map_inv p, ← inv_eq_inv], exact S.inv hp },
  mul := begin
    rintros,
    simp only [mem_set_of, functor.map_comp],
    apply S.mul; assumption,
  end }

lemma comap_mono (S T : subgroupoid D) :
  S ≤ T → comap φ S ≤ comap φ T := λ ST ⟨c,d,p⟩, @ST ⟨_,_,_⟩

lemma is_normal_comap {S : subgroupoid D} (Sn : is_normal S) : is_normal (comap φ S) :=
{ wide := λ c, by { rw [comap, mem_set_of, functor.map_id], apply Sn.wide, },
  conj := λ c d f γ hγ, by
  { simp_rw [inv_eq_inv f, comap, mem_set_of, functor.map_comp, functor.map_inv, ←inv_eq_inv],
    exact Sn.conj _ hγ, } }

@[simp] lemma comap_comp {E : Type*} [groupoid E] (ψ : D ⥤ E) :
  comap (φ ⋙ ψ) = (comap φ) ∘ (comap ψ) := rfl

/-- The kernel of a functor between subgroupoid is the preimage. -/
def ker : subgroupoid C := comap φ discrete

lemma mem_ker_iff {c d : C} (f : c ⟶ d) :
  f ∈ (ker φ).arrows c d ↔ ∃ (h : φ.obj c = φ.obj d), φ.map f = eq_to_hom h :=
mem_discrete_iff (φ.map f)

lemma ker_is_normal : (ker φ).is_normal := is_normal_comap φ (discrete_is_normal)

@[simp]
lemma ker_comp {E : Type*} [groupoid E] (ψ : D ⥤ E) : ker (φ ⋙ ψ) = comap φ (ker ψ) := rfl

/-- The family of arrows of the image of a subgroupoid under a functor injective on objects -/
inductive map.arrows (hφ : function.injective φ.obj) (S : subgroupoid C) :
  Π (c d : D), (c ⟶ d) → Prop
| im {c d : C} (f : c ⟶ d) (hf : f ∈ S.arrows c d) : map.arrows (φ.obj c) (φ.obj d) (φ.map f)

lemma map.arrows_iff (hφ : function.injective φ.obj) (S : subgroupoid C) {c d : D} (f : c ⟶ d) :
  map.arrows φ hφ S c d f ↔
  ∃ (a b : C) (g : a ⟶ b) (ha : φ.obj a = c) (hb : φ.obj b = d) (hg : g ∈ S.arrows a b),
    f = (eq_to_hom ha.symm) ≫ φ.map g ≫ (eq_to_hom hb) :=
begin
  split,
  { rintro ⟨g,hg⟩, exact ⟨_,_,g,rfl,rfl,hg, eq_conj_eq_to_hom _⟩ },
  { rintro ⟨a,b,g,rfl,rfl,hg,rfl⟩, rw ← eq_conj_eq_to_hom, split, exact hg },
end

/-- The "forward" image of a subgroupoid under a functor injective on objects -/
def map (hφ : function.injective φ.obj) (S : subgroupoid C) : subgroupoid D :=
{ arrows := map.arrows φ hφ S,
  inv := begin
    rintro _ _ _ ⟨⟩,
    rw [inv_eq_inv, ←functor.map_inv, ←inv_eq_inv],
    split, apply S.inv, assumption,
  end,
  mul := begin
    rintro _ _ _ _ ⟨f,hf⟩ q hq,
    obtain ⟨c₃,c₄,g,he,rfl,hg,gq⟩ := (map.arrows_iff φ hφ S q).mp hq,
    cases hφ he, rw [gq, ← eq_conj_eq_to_hom, ← φ.map_comp],
    split, exact S.mul hf hg,
  end }

lemma mem_map_iff (hφ : function.injective φ.obj) (S : subgroupoid C) {c d : D} (f : c ⟶ d) :
  f ∈ (map φ hφ S).arrows c d ↔
  ∃ (a b : C) (g : a ⟶ b) (ha : φ.obj a = c) (hb : φ.obj b = d) (hg : g ∈ S.arrows a b),
    f = (eq_to_hom ha.symm) ≫ φ.map g ≫ (eq_to_hom hb) := map.arrows_iff φ hφ S f

lemma galois_connection_map_comap (hφ : function.injective φ.obj) :
  galois_connection (map φ hφ) (comap φ) :=
begin
  rintro S T, simp_rw [le_iff], split,
  { exact λ h c d f fS, h (map.arrows.im f fS), },
  { rintros h _ _ g ⟨a,gφS⟩,
    exact h gφS, },
end

lemma map_mono (hφ : function.injective φ.obj) (S T : subgroupoid C) :
  S ≤ T → map φ hφ S ≤ map φ hφ T :=
λ h, (galois_connection_map_comap φ hφ).monotone_l h

lemma le_comap_map (hφ : function.injective φ.obj) (S : subgroupoid C) :
  S ≤ comap φ (map φ hφ S) := (galois_connection_map_comap φ hφ).le_u_l S

lemma map_comap_le (hφ : function.injective φ.obj) (T : subgroupoid D) :
  map φ hφ (comap φ T) ≤ T := (galois_connection_map_comap φ hφ).l_u_le T

lemma map_le_iff_le_comap (hφ : function.injective φ.obj)
  (S : subgroupoid C) (T : subgroupoid D) :
  map φ hφ S ≤ T ↔ S ≤ comap φ T := (galois_connection_map_comap φ hφ).le_iff_le

lemma mem_map_objs_iff (hφ : function.injective φ.obj) (d : D) :
  d ∈ (map φ hφ S).objs ↔ ∃ c ∈ S.objs, φ.obj c = d :=
begin
  dsimp [objs, map],
  split,
  { rintro ⟨f,hf⟩,
    change map.arrows φ hφ S d d f at hf, rw map.arrows_iff at hf,
    obtain ⟨c,d,g,ec,ed,eg,gS,eg⟩ := hf,
    exact ⟨c, ⟨mem_objs_of_src S eg, ec⟩⟩, },
  { rintros ⟨c,⟨γ,γS⟩,rfl⟩,
    exact ⟨φ.map γ,⟨γ,γS⟩⟩, }
end

@[simp]
lemma map_objs_eq (hφ : function.injective φ.obj) : (map φ hφ S).objs = φ.obj '' S.objs :=
by { ext, convert mem_map_objs_iff S φ hφ x, simp only [mem_image, exists_prop], }

/-- The image of a functor injective on objects -/
def im (hφ : function.injective φ.obj) := map φ hφ (⊤)

lemma mem_im_iff (hφ : function.injective φ.obj) {c d : D} (f : c ⟶ d) :
  f ∈ (im φ hφ).arrows c d ↔
  ∃ (a b : C) (g : a ⟶ b) (ha : φ.obj a = c) (hb : φ.obj b = d),
    f = (eq_to_hom ha.symm) ≫ φ.map g ≫ (eq_to_hom hb) :=
by { convert map.arrows_iff φ hφ ⊤ f, simp only [has_top.top, mem_univ, exists_true_left] }

lemma mem_im_objs_iff (hφ : function.injective φ.obj) (d : D) :
  d ∈ (im φ hφ).objs ↔ ∃ c : C, φ.obj c = d := by
{ simp only [im, mem_map_objs_iff, mem_top_objs, exists_true_left], }

lemma obj_surjective_of_im_eq_top (hφ : function.injective φ.obj) (hφ' : im φ hφ = ⊤) :
  function.surjective φ.obj :=
begin
  rintro d,
  rw [←mem_im_objs_iff, hφ'],
  apply mem_top_objs,
end

lemma is_normal_map (hφ : function.injective φ.obj) (hφ' : im φ hφ = ⊤) (Sn : S.is_normal) :
  (map φ hφ S).is_normal :=
{ wide := λ d, by
  { obtain ⟨c,rfl⟩ := obj_surjective_of_im_eq_top φ hφ hφ' d,
    change map.arrows φ hφ S _ _ (𝟙 _), rw ←functor.map_id,
    constructor, exact Sn.wide c, },
  conj := λ d d' g δ hδ, by
  { rw mem_map_iff at hδ,
    obtain ⟨c,c',γ,cd,cd',γS,hγ⟩ := hδ, subst_vars, cases hφ cd',
    have : d' ∈ (im φ hφ).objs, by { rw hφ', apply mem_top_objs, },
    rw mem_im_objs_iff at this,
    obtain ⟨c',rfl⟩ := this,
    have : g ∈ (im φ hφ).arrows (φ.obj c) (φ.obj c'), by
    { rw hφ', trivial, },
    rw mem_im_iff at this,
    obtain ⟨b,b',f,hb,hb',_,hf⟩ := this, subst_vars, cases hφ hb, cases hφ hb',
    change map.arrows φ hφ S (φ.obj c') (φ.obj c') _,
    simp only [eq_to_hom_refl, category.comp_id, category.id_comp, inv_eq_inv],
    suffices : map.arrows φ hφ S (φ.obj c') (φ.obj c') (φ.map $ inv f ≫ γ ≫ f),
    { simp only [inv_eq_inv, functor.map_comp, functor.map_inv] at this, exact this, },
    { constructor, apply Sn.conj f γS, } } }

end hom

section thin

/-- A subgroupoid `is_thin` if it has at most one arrow between any two vertices. -/
abbreviation is_thin := quiver.is_thin S.objs

lemma is_thin_iff : S.is_thin ↔ ∀ (c : S.objs), subsingleton (S.arrows c c) :=
by apply is_thin_iff

end thin

section disconnected

/-- A subgroupoid `is_totally_disconnected` if it has only isotropy arrows. -/
abbreviation is_totally_disconnected := is_totally_disconnected S.objs

lemma is_totally_disconnected_iff :
  S.is_totally_disconnected ↔ ∀ c d, (S.arrows c d).nonempty → c = d :=
begin
  split,
  { rintro h c d ⟨f,fS⟩,
    rw ←@subtype.mk_eq_mk _ _ c (mem_objs_of_src S fS) d (mem_objs_of_tgt S fS),
    exact h ⟨c, mem_objs_of_src S fS⟩ ⟨d, mem_objs_of_tgt S fS⟩ ⟨f, fS⟩, },
  { rintros h ⟨c, hc⟩ ⟨d, hd⟩ ⟨f, fS⟩,
    simp only [subtype.mk_eq_mk],
    exact h c d ⟨f, fS⟩, },
end

/-- The isotropy subgroupoid of `S` -/
def disconnect : subgroupoid C :=
{ arrows := λ c d f, c = d ∧ f ∈ S.arrows c d,
  inv := by { rintros _ _ _ ⟨rfl, h⟩, exact ⟨rfl, S.inv h⟩, },
  mul := by { rintros _ _ _ _ ⟨rfl, h⟩ _ ⟨rfl, h'⟩, exact ⟨rfl, S.mul h h'⟩, } }

lemma disconnect_le : S.disconnect ≤ S :=
by { rw le_iff, rintros _ _ _ ⟨⟩, assumption, }

lemma disconnect_normal (Sn : S.is_normal) : S.disconnect.is_normal :=
{ wide := λ c, ⟨rfl, Sn.wide c⟩,
  conj := λ c d p γ ⟨_,h'⟩, ⟨rfl, Sn.conj _ h'⟩ }

@[simp] lemma mem_disconnect_objs_iff {c : C} : c ∈ S.disconnect.objs ↔ c ∈ S.objs :=
⟨λ ⟨γ, h, γS⟩, ⟨γ, γS⟩, λ ⟨γ, γS⟩, ⟨γ, rfl, γS⟩⟩

lemma disconnect_objs : S.disconnect.objs = S.objs :=
by { apply set.ext, apply mem_disconnect_objs_iff, }

lemma disconnect_is_totally_disconnected : S.disconnect.is_totally_disconnected :=
by { rw is_totally_disconnected_iff, exact λ c d ⟨f, h, fS⟩, h }

end disconnected

section full

variable (D : set C)

/-- The full subgroupoid on a set `D : set C` -/
def full : subgroupoid C :=
{ arrows := λ c d _, c ∈ D ∧ d ∈ D,
  inv := by { rintros _ _ _ ⟨⟩, constructor; assumption, },
  mul := by { rintros _ _ _ _ ⟨⟩ _ ⟨⟩, constructor; assumption,} }

lemma full_objs : (full D).objs = D :=
set.ext $ λ _, ⟨λ ⟨f, h, _⟩, h , λ h, ⟨𝟙 _, h, h⟩⟩

@[simp]

@[simp] lemma mem_full_objs_iff {c : C} : c ∈ (full D).objs ↔ c ∈ D :=
by rw full_objs

@[simp] lemma full_empty : full ∅ = (⊥ : subgroupoid C) :=
by { ext, simp only [has_bot.bot, mem_full_iff, mem_empty_iff_false, and_self], }

@[simp] lemma full_univ : full set.univ = (⊤ : subgroupoid C) :=
by { ext, simp only [mem_full_iff, mem_univ, and_self, true_iff], }

lemma full_mono {D E : set C} (h : D ≤ E) : full D ≤ full E :=
begin
  rw le_iff,
  rintro c d f,
  simp only [mem_full_iff],
  exact λ ⟨hc, hd⟩, ⟨h hc, h hd⟩,
end

lemma full_arrow_eq_iff {c d : (full D).objs} {f g : c ⟶ d} :
  f = g ↔ (↑f : c.val ⟶ d.val) = ↑g :=
by apply subtype.ext_iff

end full

end subgroupoid

end category_theory