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

universes u v

namespace Mathlib

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

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

-/

namespace Top

namespace presheaf

namespace sheaf_condition_equalizer_products

/-- The product of the sections of a presheaf over a family of open sets. -/
/--
def pi_opens {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : C :=
  ∏ fun (i : ι) => category_theory.functor.obj F (opposite.op (U i))

The product of the sections of a presheaf over the pairwise intersections of
a family of open sets.
-/
def pi_inters {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : C :=
  ∏ fun (p : ι × ι) => category_theory.functor.obj F (opposite.op (U (prod.fst p) ⊓ U (prod.snd p)))

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U i` to `U i ⊓ U j`.
-/
def left_res {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : pi_opens F U ⟶ pi_inters F U :=
  category_theory.limits.pi.lift
    fun (p : ι × ι) =>
      category_theory.limits.pi.π (fun (i : ι) => category_theory.functor.obj F (opposite.op (U i))) (prod.fst p) ≫
        category_theory.functor.map F
          (category_theory.has_hom.hom.op (topological_space.opens.inf_le_left (U (prod.fst p)) (U (prod.snd p))))

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def right_res {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : pi_opens F U ⟶ pi_inters F U :=
  category_theory.limits.pi.lift
    fun (p : ι × ι) =>
      category_theory.limits.pi.π (fun (i : ι) => category_theory.functor.obj F (opposite.op (U i))) (prod.snd p) ≫
        category_theory.functor.map F
          (category_theory.has_hom.hom.op (topological_space.opens.inf_le_right (U (prod.fst p)) (U (prod.snd p))))

/--
The morphism `F.obj U ⟶ Π F.obj (U i)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def res {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.functor.obj F (opposite.op (supr U)) ⟶ pi_opens F U :=
  category_theory.limits.pi.lift
    fun (i : ι) => category_theory.functor.map F (category_theory.has_hom.hom.op (topological_space.opens.le_supr U i))

theorem w {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : res F U ≫ left_res F U = res F U ≫ right_res F U := sorry

/--
The equalizer diagram for the sheaf condition.
-/
def diagram {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.limits.walking_parallel_pair ⥤ C :=
  category_theory.limits.parallel_pair (left_res F U) (right_res F U)

/--
The restriction map `F.obj U ⟶ Π F.obj (U i)` gives a cone over the equalizer diagram
for the sheaf condition. The sheaf condition asserts this cone is a limit cone.
-/
def fork {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.limits.fork (left_res F U) (right_res F U) :=
  category_theory.limits.fork.of_ι (res F U) sorry

@[simp] theorem fork_X {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.limits.cone.X (fork F U) = category_theory.functor.obj F (opposite.op (supr U)) :=
  rfl

@[simp] theorem fork_ι {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.limits.fork.ι (fork F U) = res F U :=
  rfl

@[simp] theorem fork_π_app_walking_parallel_pair_zero {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.nat_trans.app (category_theory.limits.cone.π (fork F U))
    category_theory.limits.walking_parallel_pair.zero =
  res F U :=
  rfl

@[simp] theorem fork_π_app_walking_parallel_pair_one {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.nat_trans.app (category_theory.limits.cone.π (fork F U))
    category_theory.limits.walking_parallel_pair.one =
  res F U ≫ left_res F U :=
  rfl

/-- Isomorphic presheaves have isomorphic `pi_opens` for any cover `U`. -/
@[simp] def pi_opens.iso_of_iso {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} (U : ι → topological_space.opens ↥X) {G : presheaf C X} (α : F ≅ G) : pi_opens F U ≅ pi_opens G U :=
  category_theory.limits.pi.map_iso fun (X_1 : ι) => category_theory.iso.app α (opposite.op (U X_1))

/-- Isomorphic presheaves have isomorphic `pi_inters` for any cover `U`. -/
@[simp] def pi_inters.iso_of_iso {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} (U : ι → topological_space.opens ↥X) {G : presheaf C X} (α : F ≅ G) : pi_inters F U ≅ pi_inters G U :=
  category_theory.limits.pi.map_iso
    fun (X_1 : ι × ι) => category_theory.iso.app α (opposite.op (U (prod.fst X_1) ⊓ U (prod.snd X_1)))

/-- Isomorphic presheaves have isomorphic sheaf condition diagrams. -/
def diagram.iso_of_iso {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} (U : ι → topological_space.opens ↥X) {G : presheaf C X} (α : F ≅ G) : diagram F U ≅ diagram G U :=
  category_theory.nat_iso.of_components
    (fun (X_1 : category_theory.limits.walking_parallel_pair) =>
      category_theory.limits.walking_parallel_pair.cases_on X_1 (pi_opens.iso_of_iso U α) (pi_inters.iso_of_iso U α))
    sorry

/--
If `F G : presheaf C X` are isomorphic presheaves,
then the `fork F U`, the canonical cone of the sheaf condition diagram for `F`,
is isomorphic to `fork F G` postcomposed with the corresponding isomorphism between
sheaf condition diagrams.
-/
def fork.iso_of_iso {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} (U : ι → topological_space.opens ↥X) {G : presheaf C X} (α : F ≅ G) : fork F U ≅
  category_theory.functor.obj
    (category_theory.limits.cones.postcompose (category_theory.iso.inv (diagram.iso_of_iso U α))) (fork G U) :=
  category_theory.limits.fork.ext (category_theory.iso.app α (opposite.op (supr U))) sorry

/--
Push forward a cover along an open embedding.
-/
@[simp] def cover.of_open_embedding {X : Top} {ι : Type v} {V : Top} {j : V ⟶ X} (oe : open_embedding ⇑j) (𝒰 : ι → topological_space.opens ↥V) : ι → topological_space.opens ↥X :=
  fun (i : ι) => category_theory.functor.obj (is_open_map.functor sorry) (𝒰 i)

/--
The isomorphism between `pi_opens` corresponding to an open embedding.
-/
@[simp] def pi_opens.iso_of_open_embedding {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} {V : Top} {j : V ⟶ X} (oe : open_embedding ⇑j) (𝒰 : ι → topological_space.opens ↥V) : pi_opens (category_theory.functor.op (is_open_map.functor (pi_opens.iso_of_open_embedding._proof_2 oe)) ⋙ F) 𝒰 ≅
  pi_opens F (cover.of_open_embedding oe 𝒰) :=
  category_theory.limits.pi.map_iso
    fun (X_1 : ι) =>
      category_theory.functor.map_iso F
        (category_theory.iso.refl
          (category_theory.functor.obj (category_theory.functor.op (is_open_map.functor sorry)) (opposite.op (𝒰 X_1))))

/--
The isomorphism between `pi_inters` corresponding to an open embedding.
-/
@[simp] def pi_inters.iso_of_open_embedding {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} {V : Top} {j : V ⟶ X} (oe : open_embedding ⇑j) (𝒰 : ι → topological_space.opens ↥V) : pi_inters (category_theory.functor.op (is_open_map.functor (pi_inters.iso_of_open_embedding._proof_2 oe)) ⋙ F) 𝒰 ≅
  pi_inters F (cover.of_open_embedding oe 𝒰) :=
  category_theory.limits.pi.map_iso
    fun (X_1 : ι × ι) =>
      category_theory.functor.map_iso F
        (id
          (category_theory.iso.op
            (category_theory.iso.mk (category_theory.hom_of_le sorry) (category_theory.hom_of_le sorry))))

/-- The isomorphism of sheaf condition diagrams corresponding to an open embedding. -/
def diagram.iso_of_open_embedding {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} {V : Top} {j : V ⟶ X} (oe : open_embedding ⇑j) (𝒰 : ι → topological_space.opens ↥V) : diagram (category_theory.functor.op (is_open_map.functor (diagram.iso_of_open_embedding._proof_2 oe)) ⋙ F) 𝒰 ≅
  diagram F (cover.of_open_embedding oe 𝒰) :=
  category_theory.nat_iso.of_components
    (fun (X_1 : category_theory.limits.walking_parallel_pair) =>
      category_theory.limits.walking_parallel_pair.cases_on X_1 (pi_opens.iso_of_open_embedding oe 𝒰)
        (pi_inters.iso_of_open_embedding oe 𝒰))
    sorry

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

We use this to show that the restriction of sheaf along an open embedding is still a sheaf.
-/
def fork.iso_of_open_embedding {C : Type u} [category_theory.category C] [category_theory.limits.has_products C] {X : Top} {F : presheaf C X} {ι : Type v} {V : Top} {j : V ⟶ X} (oe : open_embedding ⇑j) (𝒰 : ι → topological_space.opens ↥V) : fork (category_theory.functor.op (is_open_map.functor (fork.iso_of_open_embedding._proof_2 oe)) ⋙ F) 𝒰 ≅
  category_theory.functor.obj
    (category_theory.limits.cones.postcompose (category_theory.iso.inv (diagram.iso_of_open_embedding oe 𝒰)))
    (fork F (cover.of_open_embedding oe 𝒰)) :=
  category_theory.limits.fork.ext
    (id
      (category_theory.functor.map_iso F
        (category_theory.iso.op
          (category_theory.iso.mk (category_theory.hom_of_le sorry) (category_theory.hom_of_le sorry)))))
    sorry


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.adjunction.basic
import category_theory.conj
import category_theory.yoneda

/-!
# Adjoints of fully faithful functors

A left adjoint is fully faithful, if and only if the unit is an isomorphism
(and similarly for right adjoints and the counit).

`adjunction.restrict_fully_faithful` shows that an adjunction can be restricted along fully faithful
inclusions.

## Future work

The statements from Riehl 4.5.13 for adjoints which are either full, or faithful.
-/

open category_theory

namespace category_theory
universes v₁ v₂ u₁ u₂

open category
open opposite

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R)

/--
If the left adjoint is fully faithful, then the unit is an isomorphism.

See
* Lemma 4.5.13 from [Riehl][riehl2017]
* https://math.stackexchange.com/a/2727177
* https://stacks.math.columbia.edu/tag/07RB (we only prove the forward direction!)
-/
instance unit_is_iso_of_L_fully_faithful [full L] [faithful L] : is_iso (adjunction.unit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.unit h) $ λ X,
@yoneda.is_iso _ _ _ _ ((adjunction.unit h).app X)
⟨⟨{ app := λ Y f, L.preimage ((h.hom_equiv (unop Y) (L.obj X)).symm f) },
  ⟨begin
    ext x f, dsimp,
    apply L.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_counit, preimage_comp, preimage_map, category.assoc],
    rw ←h.unit_naturality,
    simp,
  end⟩⟩⟩

/--
If the right adjoint is fully faithful, then the counit is an isomorphism.

See <https://stacks.math.columbia.edu/tag/07RB> (we only prove the forward direction!)
-/
instance counit_is_iso_of_R_fully_faithful [full R] [faithful R] : is_iso (adjunction.counit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.counit h) $ λ X,
@is_iso_of_op _ _ _ _ _ $
@coyoneda.is_iso _ _ _ _ ((adjunction.counit h).app X).op
⟨⟨{ app := λ Y f, R.preimage ((h.hom_equiv (R.obj X) Y) f) },
  ⟨begin
    ext x f, dsimp,
    apply R.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_unit, preimage_comp, preimage_map],
    rw ←h.counit_naturality,
    simp,
  end⟩⟩⟩

/-- If the unit of an adjunction is an isomorphism, then its inverse on the image of L is given
by L whiskered with the counit. -/
@[simp]
lemma inv_map_unit {X : C} [is_iso (h.unit.app X)] :
  inv (L.map (h.unit.app X)) = h.counit.app (L.obj X) :=
is_iso.inv_eq_of_hom_inv_id h.left_triangle_components

/-- If the unit is an isomorphism, bundle one has an isomorphism `L ⋙ R ⋙ L ≅ L`. -/
@[simps]
noncomputable def whisker_left_L_counit_iso_of_is_iso_unit [is_iso h.unit] :
  L ⋙ R ⋙ L ≅ L :=
(L.associator R L).symm ≪≫ iso_whisker_right (as_iso h.unit).symm L ≪≫ functor.left_unitor _

/-- If the counit of an adjunction is an isomorphism, then its inverse on the image of R is given
by R whiskered with the unit. -/
@[simp]
lemma inv_counit_map {X : D} [is_iso (h.counit.app X)] :
  inv (R.map (h.counit.app X)) = h.unit.app (R.obj X) :=
is_iso.inv_eq_of_inv_hom_id h.right_triangle_components

/-- If the counit of an is an isomorphism, one has an isomorphism `(R ⋙ L ⋙ R) ≅ R`. -/
@[simps]
noncomputable def whisker_left_R_unit_iso_of_is_iso_counit [is_iso h.counit] :
  (R ⋙ L ⋙ R) ≅ R :=
(R.associator L R).symm ≪≫ iso_whisker_right (as_iso h.counit) R ≪≫ functor.left_unitor _

/-- If the unit is an isomorphism, then the left adjoint is full-/
noncomputable
def L_full_of_unit_is_iso [is_iso h.unit] : full L :=
{ preimage := λ X Y f, (h.hom_equiv X (L.obj Y) f) ≫ inv (h.unit.app Y) }

/-- If the unit is an isomorphism, then the left adjoint is faithful-/
lemma L_faithful_of_unit_is_iso [is_iso h.unit] : faithful L :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv X (L.obj Y)).apply_eq_iff_eq at H,
    simpa using H =≫ inv (h.unit.app Y),
  end }

/-- If the counit is an isomorphism, then the right adjoint is full-/
noncomputable
def R_full_of_counit_is_iso [is_iso h.counit] : full R :=
{ preimage := λ X Y f, inv (h.counit.app X) ≫ (h.hom_equiv (R.obj X) Y).symm f }

/-- If the counit is an isomorphism, then the right adjoint is faithful-/
lemma R_faithful_of_counit_is_iso [is_iso h.counit] : faithful R :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv (R.obj X) Y).symm.apply_eq_iff_eq at H,
    simpa using inv (h.counit.app X) ≫= H,
  end }

instance whisker_left_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_left L h.counit) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_right_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_right h.counit R) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_left_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_left R h.unit) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

instance whisker_right_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_right h.unit L) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

-- TODO also do the statements from Riehl 4.5.13 for full and faithful separately?

universes v₃ v₄ u₃ u₄

variables {C' : Type u₃} [category.{v₃} C']
variables {D' : Type u₄} [category.{v₄} D']

-- TODO: This needs some lemmas describing the produced adjunction, probably in terms of `adj`,
-- `iC` and `iD`.
/--
If `C` is a full subcategory of `C'` and `D` is a full subcategory of `D'`, then we can restrict
an adjunction `L' ⊣ R'` where `L' : C' ⥤ D'` and `R' : D' ⥤ C'` to `C` and `D`.
The construction here is slightly more general, in that `C` is required only to have a full and
faithful "inclusion" functor `iC : C ⥤ C'` (and similarly `iD : D ⥤ D'`) which commute (up to
natural isomorphism) with the proposed restrictions.
-/
def adjunction.restrict_fully_faithful (iC : C ⥤ C') (iD : D ⥤ D') {L' : C' ⥤ D'} {R' : D' ⥤ C'}
  (adj : L' ⊣ R') {L : C ⥤ D} {R : D ⥤ C} (comm1 : iC ⋙ L' ≅ L ⋙ iD) (comm2 : iD ⋙ R' ≅ R ⋙ iC)
  [full iC] [faithful iC] [full iD] [faithful iD] :
  L ⊣ R :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  calc (L.obj X ⟶ Y) ≃ (iD.obj (L.obj X) ⟶ iD.obj Y) : equiv_of_fully_faithful iD
       ... ≃ (L'.obj (iC.obj X) ⟶ iD.obj Y) : iso.hom_congr (comm1.symm.app X) (iso.refl _)
       ... ≃ (iC.obj X ⟶ R'.obj (iD.obj Y)) : adj.hom_equiv _ _
       ... ≃ (iC.obj X ⟶ iC.obj (R.obj Y)) : iso.hom_congr (iso.refl _) (comm2.app Y)
       ... ≃ (X ⟶ R.obj Y) : (equiv_of_fully_faithful iC).symm,
  hom_equiv_naturality_left_symm' := λ X' X Y f g,
  begin
    apply iD.map_injective,
    simpa using (comm1.inv.naturality_assoc f _).symm,
  end,
  hom_equiv_naturality_right' := λ X Y' Y f g,
  begin
    apply iC.map_injective,
    suffices : R'.map (iD.map g) ≫ comm2.hom.app Y = comm2.hom.app Y' ≫ iC.map (R.map g),
      simp [this],
    apply comm2.hom.naturality g,
  end }

end category_theory


-- author: Ben Sherman

import galois.network.network_implementation
       galois.network.network_local_abs
       galois.temporal.fixpoint
       galois.temporal.classical
       galois.temporal.LTS

universes u v

/-- reflexive-transitive closure of a relation -/
inductive RTclosure {A : Type u} (R : A → A → Prop) (x : A) : A → Prop
  | refl {} : RTclosure x
  | step {} : ∀ {y z : A}, R y z → RTclosure y → RTclosure z

inductive RTclosure' {A : Type u} (R : A → A → Prop) (x z : A) : Prop
  | refl {} : x = z → RTclosure'
  | step {} : ∀ {y : A}, R y z → RTclosure R x y → RTclosure'

namespace RTclosure

def stepL {A : Type u} {R : A → A → Prop} {x y : A} (r : R x y)
  : ∀ {z : A}, RTclosure R y z → RTclosure R x z
:= begin
intros z s, induction s, apply step, assumption, apply refl,
apply step; assumption,
end

def invert {A : Type u} {R : A → A → Prop} {x z : A}
  (r : RTclosure R x z) :
  RTclosure' R x z
:= begin
induction r, left, reflexivity,
right, assumption, assumption
end

end RTclosure

namespace network

open temporal

section
parameter {agents : map ip agent}

def indLabel {A} (P : agent_label → Prop)
  := λ a_next, P ∘ @dlabel_to_label A a_next

instance inLabeld_decidable {ag : agent} (P : agent_label → Prop)
  [decP : decidable_pred P]
  : decidable_pred (@loc.inLabeld ag (indLabel P))
:= begin
intros x, dsimp [loc.inLabeld, indLabel, function.comp],
induction x, dsimp, apply decP
end

inductive sys_agent_does (ag : agents.member)
  (P : agent_label → Prop)
  : sigma sys_dlabel → Prop
| mk : ∀ sys dlabel, P (dlabel_to_label dlabel) → sys_agent_does (sigma.mk sys (sys_dlabel.mk ag dlabel))

@[trace_map]
lemma label_refine_eqd {ag : agents.member} (P : agent_label → Prop)
 : inSkipLabel (@loc.inLabeld ag.value (indLabel P)) ∘
       (Refinement.SL_refine (refinesd ag))
 = sys_agent_does ag P
:= begin
apply funext, intros x, dsimp [function.comp],
apply propext, split; intros H,
{
  induction x, induction snd,
  dsimp [inSkipLabel] at H,
  dsimp [Refinement.SL_refine, refinesd, inSkipLabel] at H,
  dsimp [sys_dlabel_to_local] at H,
  apply (if Hag : ag_1 = ag then _ else _),
  { subst ag_1, constructor,
    rw (option.precondition_true_bind (eq.refl ag)) at H,
    dsimp [sys_dlabel_to_local] at H,
    dsimp [inSkipLabel] at H,
    dsimp [loc.inLabeld] at H,
    dsimp [indLabel] at H,
    apply H },
  { rw (option.precondition_false Hag) at H,
    dsimp [has_bind.bind, option.bind] at H,
    dsimp [inSkipLabel] at H, contradiction,
  },
},
{ induction H,
  dsimp [Refinement.SL_refine, refinesd, inSkipLabel],
  dsimp [sys_dlabel_to_local],
  rw (option.precondition_true_bind (eq.refl ag)),
  dsimp [sys_dlabel_to_local], dsimp [inSkipLabel],
  unfold loc.inLabeld, unfold indLabel, assumption
}
end

instance decidable_sys_agent_does (a P)
  [decidable_pred P] : decidable_pred (sys_agent_does a P)
:= begin
intros l, induction l with s l,
induction l with a' l,
apply (if Hip : a = a' then _ else _),
{ apply (if H : P (dlabel_to_label l) then _ else _),
  subst a',
  { apply decidable.is_true,
    constructor, assumption } ,
  { apply decidable.is_false,
    intros contra, cases contra, contradiction }
 },
{ apply decidable.is_false, intros contra,
  cases contra, contradiction }
end

inductive next_state_from_label_ind' (ag : agents.member) (s : system_state) (la : dlabel ((ag.value).loop (s.local_state ag))) (s' : @system_state agents) : Prop
| mk : ∀ (new_state : (ag.value).state_type)
         (updatef : global_state_t → global_state_t)
         (Hagl : next_agent_state_from_dlabel (ag.key) (ag.value) (s.global_state (ag.key)) la = some (new_state, updatef))
         (Hupd : s' = {local_state := lookup_update ag new_state (s.local_state), global_state := updatef (s.global_state)})
         , next_state_from_label_ind'

lemma agent_update_invert_st'
  {ag : agents.member}
  {s la s'}
  : LTSd s (sys_dlabel.mk ag la) s'
  → next_state_from_label_ind' ag s la s'
:= begin
intros H,
simp [LTSd] at H,
simp [next_state_from_dlabel] at H,
apply_in H option.bind_some',
induction H with res p, induction p with Hag1 Hag2,
induction res with new_state updatef,
dsimp [next_agent_state_from_dlabel] at Hag1,
dsimp [next_state_from_dlabel] at Hag2,
injection Hag2 with Hag2', clear Hag2,
constructor; try { assumption }, symmetry, assumption
end

/-- Every agent always eventually gets to step -/
def fairness_specd : @TP agents
  := λ tr, ∀ (a : agents.member),
   fair (now (sys_agent_does a (λ _, true))) tr

/-- Indicates that an agent is at the beginning of running
    an iteration of its loop (or doing something equivalent
    to that)
-/
def starts_loop {a : agents.member} (next : act a.value.state_type) : Prop :=
  ∃ (s : a.value.state_type), next = a.value.loop s

def inLocalState (a : agents.member) (P : a.value.state_type → Prop)
  {L : system_state → Type u}
  : sigma L → Prop
  := inState (λ s, P (s.local_state a))

/-- If a transition occurs that doesn't involve a particular agent,
    that agent's state doesn't change.
-/
lemma local_state_stays_constant {s l s'}
  (a : agents.member)
  (HLTS : LTSd s l s')
  (Hagent : ¬sys_agent_does a (λ (_x : agent_label), true) ⟨ _, l ⟩)
  : s.local_state a = s'.local_state a
:= begin
induction l with a' la,
apply_in HLTS agent_update_invert_st',
induction HLTS with new_state updatef H1 Hs',
subst s', dsimp,
unfold lookup_update lookup_updatef,
apply (if Heq : a' = a then _ else _),
{ exfalso, subst a',
 apply Hagent,
 constructor, trivial },
{ rw (dif_neg Heq) }
end

def agent_has_state {L : @system_state agents → Type u}
  (ag : agents.member)
  (P : ag.value.state_type → Prop)
  : tProp (sigma L) := now (@inLocalState ag P L)

lemma agent_has_state_refine_eq (ag : agents.member)
  (P : ag.value.state_type → Prop) :
  agent_has_state ag P =
     now (inState P ∘ Refinement.SL_refine (refinesd ag))
:= begin
apply funext, intros x, reflexivity
end

/-- A statement of the fact that a particular agent's state
    doesn't change (weak-) until it takes a step within
    temporal logic.
    (Using the sort of Leibniz equality: Any predicate `P`
    that held on the old state will hold on the new state)
-/
lemma local_state_stays_constant_ltl (a : agents.member)
  (P : a.value.state_type → Prop)
  : ⊩ valid_trace LTSd
    => □ (now (inLocalState a P)
    => (◯ (now (inLocalState a P))
        𝓦
       now (sys_agent_does a (λ _, true)))
    )
:= begin
intros tr validtr n Pst,
unfold inLocalState,
apply (invariant_holds_while LTSd _ (delayn n tr)),
apply valid_trace_always, assumption, assumption,
apply_instance,
intros,
have H := local_state_stays_constant _ a_1 a_2,
rw ← H, assumption,
end

/-- If an agent always eventually polls, and if it is sent a message,
    then it eventually receives that message.
-/
def message_fairness_specd : @TP agents := λ tr,
  ∀ (a : agents.member) (sock : socket) (mess : message_t),
    (fair (   now (inLocalState a (polls_on_socket sock ∘ a.value.loop))
            ∩ now (sys_agent_does a (λ _, true)))
     => □ (now (inState (λ s : system_state, (sock, mess) ∈ (s.global_state a.key).messages))
           => ◇ (now (sys_agent_does a (receives_message sock mess))))) tr

end

section
parameters {agents : map ip agent}
  (a : agents.member)
  (P : socket → message_t → Prop)

lemma blocks_until_not_never_receives_always_polls
  (s : socket)
  : ⊩ valid_trace (@LTSd agents)
    => (◇ (now (inLocalState a (polls_on_socket s ∘ a.value.loop))
           ∩ now (sys_agent_does a (λ _, true)))
        𝓦 (now (sys_agent_does a (receives P))))
    => □ (tNot (now (sys_agent_does a (receives P))))
    => fair (now (inLocalState a (polls_on_socket s ∘ a.value.loop))
             ∩ now (sys_agent_does a (λ _, true)))
:= begin
intros tr valid nows never,
apply weak_until_not_always; assumption,
end

/--
   As Joey and I discussed, the way this proof should go is as follows:
   Use classical logic to do a proof by contradiction. Assume that we
   never receive the message. Then,
   use message fairness in conjunction with with the fact that we
   have a message in the queue to derive that
   H : if the agent always eventually polls, it eventually receives the message.
   Next, use the fact that we do *not* eventually receive the message,
   together with the fact that we block until we receive the message,
   to derive that we always eventually poll.
   Combining this with the `H` specified above, we find that we
   eventually do receive the message, a contradiction.
-/
theorem blocking_agent_eventually_receives_message
  {s : socket}
  : ⊩ valid_trace (@LTSd agents)
    => message_fairness_specd
    => (◇ (now (inLocalState a (polls_on_socket s ∘ a.value.loop))
          ∩ now (sys_agent_does a (λ _, true))))
        𝓦 (now (sys_agent_does a (receives P)))
    => now (inState (λ ss : system_state, ∃ mess : message_t,
         P s mess ∧
         (s, mess) ∈ (ss.global_state a.key).messages))
    => ◇ (now (sys_agent_does a (receives P)))
:= begin
intros tr valid mfair nowstate H,
apply classical.not_always_not_implies_eventually,
intros contra,
have H' := blocks_until_not_never_receives_always_polls
  _ _ _ _ valid nowstate contra,
induction H with mess Hmess,
induction Hmess with Hmess1 Hmess2,
specialize (mfair a s mess H'),
rw ← (delayn_zero tr) at Hmess2,
specialize (mfair 0 Hmess2),
rw ← not_eventually_always_not at contra,
apply contra,
revert mfair, rw delayn_zero,
apply eventually_mono,
intros x H,
unfold now later inLabel at H,
unfold now later inLabel,
induction H with s l Psl,
constructor, unfold receives_message at Psl,
induction Psl with t rn mess' ms H,
induction H with H1 H2, subst mess', subst s,
constructor, assumption,
end

/-- Agent fairness in the global transition system implies
    "skip fairness" in the local system, where there is only
    a single agent
-/
lemma fairness_Skip_impl (agents : map ip agent) (ag : agents.member) :
 ⊩ fairness_specd => (fairness_SkipLTS ∘ trace.map (Refinement.SL_refine (refinesd ag)))
:= begin
intros tr agent_fair,
unfold fairness_SkipLTS,
dsimp, rw fair_map, rw now_map,
unfold fairness_specd at agent_fair,
specialize (agent_fair ag),
rw ← label_refine_eqd at agent_fair,
assumption,
end

end

end network


import Kenny.sites.lattice

universes v w u

namespace category_theory

def presheaf (C : Type u) [category.{v} C] : Type (max u v (w+1)) :=
Cᵒᵖ ⥤ Type w

namespace presheaf

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

def eval (U : C) : Type w :=
F.1 (opposite.op U)

def res {U V : C} (f : U ⟶ V) : F.eval V → F.eval U :=
F.2 (has_hom.hom.op f)

@[simp] lemma res_id (U : C) (s : F.eval U) : F.res (𝟙 U) s = s :=
congr_fun (F.map_id (opposite.op U)) s

@[simp] lemma res_res (U V W : C) (f : W ⟶ V) (g : V ⟶ U) (s : F.eval U) :
  F.res f (F.res g s) = F.res (f ≫ g) s :=
(congr_fun (F.map_comp (has_hom.hom.op g) (has_hom.hom.op f)) s).symm

end presheaf

structure sheaf (C : Type u) [category.{v} C] [has_pullback C] [has_site.{v} C] : Type (max u v (w+1)) :=
(to_presheaf : presheaf.{v w} C)
(ext : ∀ U : C, ∀ s t : to_presheaf.eval U, ∀ c ∈ has_site.cov U,
  (∀ d : Σ V, V ⟶ U, d ∈ c → to_presheaf.res d.2 s = to_presheaf.res d.2 t) →
  s = t)
(glue : ∀ U : C, ∀ c ∈ has_site.cov U, ∀ F : Π d : Σ V, V ⟶ U, d ∈ c → to_presheaf.eval d.1,
  (∀ d1 d2 : Σ V, V ⟶ U, ∀ H1 : d1 ∈ c, ∀ H2 : d2 ∈ c,
    to_presheaf.res (pullback.fst d1.2 d2.2) (F d1 H1) =
    to_presheaf.res (@@pullback.snd _ _inst_2 d1.2 d2.2) (F d2 H2)) →
  ∃ g : to_presheaf.eval U, ∀ d : Σ V, V ⟶ U, ∀ H : d ∈ c,
    to_presheaf.res d.2 g = F d H)

end category_theory


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ScopedEnvExtension
import Lean.Util.Recognizers
import Lean.Meta.DiscrTree
import Lean.Meta.AppBuilder
import Lean.Meta.Eqns
import Lean.Meta.Tactic.AuxLemma
import Lean.DocString
namespace Lean.Meta

/--
An `Origin` is an identifier for simp theorems which indicates roughly
what action the user took which lead to this theorem existing in the simp set.
-/
inductive Origin where
  /-- A global declaration in the environment. -/
  | decl (declName : Name)
  /--
  A local hypothesis.
  When `contextual := true` is enabled, this fvar may exist in an extension
  of the current local context; it will not be used for rewriting by simp once
  it is out of scope but it may end up in the `usedSimps` trace.
  -/
  | fvar (fvarId : FVarId)
  /--
  A proof term provided directly to a call to `simp [ref, ...]` where `ref`
  is the provided simp argument (of kind `Parser.Tactic.simpLemma`).
  The `id` is a unique identifier for the call.
  -/
  | stx (id : Name) (ref : Syntax)
  /--
  Some other origin. `name` should not collide with the other types
  for erasure to work correctly, and simp trace will ignore this lemma.
  The other origins should be preferred if possible.
  -/
  | other (name : Name)
  deriving Inhabited, Repr

/-- A unique identifier corresponding to the origin. -/
def Origin.key : Origin → Name
  | .decl declName => declName
  | .fvar fvarId => fvarId.name
  | .stx id _ => id
  | .other name => name

instance : BEq Origin := ⟨(·.key == ·.key)⟩
instance : Hashable Origin := ⟨(hash ·.key)⟩

/-
Note: we want to use iota reduction when indexing instaces. Otherwise,
we cannot use simp theorems such as
```
@[simp] theorem liftOn_mk (a : α) (f : α → γ) (h : ∀ a₁ a₂, r a₁ a₂ → f a₁ = f a₂) :
    Quot.liftOn (Quot.mk r a) f h = f a := rfl
```
If we use `iota`, then the lhs is reduced to `f a`.
See comment at `DiscrTree`.
-/

abbrev SimpTheoremKey := DiscrTree.Key (simpleReduce := true)

/--
  The fields `levelParams` and `proof` are used to encode the proof of the simp theorem.
  If the `proof` is a global declaration `c`, we store `Expr.const c []` at `proof` without the universe levels, and `levelParams` is set to `#[]`
  When using the lemma, we create fresh universe metavariables.
  Motivation: most simp theorems are global declarations, and this approach is faster and saves memory.

  The field `levelParams` is not empty only when we elaborate an expression provided by the user, and it contains universe metavariables.
  Then, we use `abstractMVars` to abstract the universe metavariables and create new fresh universe parameters that are stored at the field `levelParams`.
-/
structure SimpTheorem where
  keys        : Array SimpTheoremKey := #[]
  /--
    It stores universe parameter names for universe polymorphic proofs.
    Recall that it is non-empty only when we elaborate an expression provided by the user.
    When `proof` is just a constant, we can use the universe parameter names stored in the declaration.
   -/
  levelParams : Array Name := #[]
  proof       : Expr
  priority    : Nat  := eval_prio default
  post        : Bool := true
  /-- `perm` is true if lhs and rhs are identical modulo permutation of variables. -/
  perm        : Bool := false
  /--
    `origin` is mainly relevant for producing trace messages.
    It is also viewed an `id` used to "erase" `simp` theorems from `SimpTheorems`.
  -/
  origin      : Origin
  /-- `rfl` is true if `proof` is by `Eq.refl` or `rfl`. -/
  rfl         : Bool
  deriving Inhabited

mutual
  partial def isRflProofCore (type : Expr) (proof : Expr) : CoreM Bool := do
    match type with
    | .forallE _ _ type _ =>
      if let .lam _ _ proof _ := proof then
        isRflProofCore type proof
      else
        return false
    | _ =>
      if type.isAppOfArity ``Eq 3 then
        if proof.isAppOfArity ``Eq.refl 2 || proof.isAppOfArity ``rfl 2 then
          return true
        else if proof.isAppOfArity ``Eq.symm 4 then
          -- `Eq.symm` of rfl theorem is a rfl theorem
          isRflProofCore type proof.appArg! -- small hack: we don't need to set the exact type
        else if proof.isApp && proof.getAppFn.isConst then
          -- The application of a `rfl` theorem is a `rfl` theorem
          isRflTheorem proof.getAppFn.constName!
        else
          return false
      else
        return false

  partial def isRflTheorem (declName : Name) : CoreM Bool := do
    let .thmInfo info ← getConstInfo declName | return false
    isRflProofCore info.type info.value
end

def isRflProof (proof : Expr) : MetaM Bool := do
  if let .const declName .. := proof then
    isRflTheorem declName
  else
    isRflProofCore (← inferType proof) proof

instance : ToFormat SimpTheorem where
  format s :=
    let perm := if s.perm then ":perm" else ""
    let name := format s.origin.key
    let prio := f!":{s.priority}"
    name ++ prio ++ perm

def ppOrigin [Monad m] [MonadEnv m] [MonadError m] : Origin → m MessageData
  | .decl n => mkConstWithLevelParams n
  | .fvar n => return mkFVar n
  | .stx _ ref => return ref
  | .other n => return n

def ppSimpTheorem [Monad m] [MonadLiftT IO m] [MonadEnv m] [MonadError m] (s : SimpTheorem) : m MessageData := do
  let perm := if s.perm then ":perm" else ""
  let name ← ppOrigin s.origin
  let prio := m!":{s.priority}"
  return name ++ prio ++ perm

instance : BEq SimpTheorem where
  beq e₁ e₂ := e₁.proof == e₂.proof

abbrev SimpTheoremTree := DiscrTree SimpTheorem (simpleReduce := true)

structure SimpTheorems where
  pre          : SimpTheoremTree := DiscrTree.empty
  post         : SimpTheoremTree := DiscrTree.empty
  lemmaNames   : PHashSet Origin := {}
  toUnfold     : PHashSet Name := {}
  erased       : PHashSet Origin := {}
  toUnfoldThms : PHashMap Name (Array Name) := {}
  deriving Inhabited

def addSimpTheoremEntry (d : SimpTheorems) (e : SimpTheorem) : SimpTheorems :=
  if e.post then
    { d with post := d.post.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
  else
    { d with pre := d.pre.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
where
  updateLemmaNames (s : PHashSet Origin) : PHashSet Origin :=
    s.insert e.origin

def SimpTheorems.addDeclToUnfoldCore (d : SimpTheorems) (declName : Name) : SimpTheorems :=
  { d with toUnfold := d.toUnfold.insert declName }

/-- Return `true` if `declName` is tagged to be unfolded using `unfoldDefinition?` (i.e., without using equational theorems). -/
def SimpTheorems.isDeclToUnfold (d : SimpTheorems) (declName : Name) : Bool :=
  d.toUnfold.contains declName

def SimpTheorems.isLemma (d : SimpTheorems) (thmId : Origin) : Bool :=
  d.lemmaNames.contains thmId

/-- Register the equational theorems for the given definition. -/
def SimpTheorems.registerDeclToUnfoldThms (d : SimpTheorems) (declName : Name) (eqThms : Array Name) : SimpTheorems :=
  { d with toUnfoldThms := d.toUnfoldThms.insert declName eqThms }

partial def SimpTheorems.eraseCore (d : SimpTheorems) (thmId : Origin) : SimpTheorems :=
  let d := { d with erased := d.erased.insert thmId, lemmaNames := d.lemmaNames.erase thmId }
  if let .decl declName := thmId then
    let d := { d with toUnfold := d.toUnfold.erase declName }
    if let some thms := d.toUnfoldThms.find? declName then
      thms.foldl (init := d) (eraseCore · <| .decl ·)
    else
      d
  else
    d

def SimpTheorems.erase [Monad m] [MonadError m] (d : SimpTheorems) (thmId : Origin) : m SimpTheorems := do
  unless d.isLemma thmId ||
    match thmId with
    | .decl declName => d.isDeclToUnfold declName || d.toUnfoldThms.contains declName
    | _ => false
  do
    throwError "'{thmId.key}' does not have [simp] attribute"
  return d.eraseCore thmId

private partial def isPerm : Expr → Expr → MetaM Bool
  | Expr.app f₁ a₁, Expr.app f₂ a₂ => isPerm f₁ f₂ <&&> isPerm a₁ a₂
  | Expr.mdata _ s, t => isPerm s t
  | s, Expr.mdata _ t => isPerm s t
  | s@(Expr.mvar ..), t@(Expr.mvar ..) => isDefEq s t
  | Expr.forallE n₁ d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.lam n₁ d₁ b₁ _, Expr.lam _ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.letE n₁ t₁ v₁ b₁ _, Expr.letE _  t₂ v₂ b₂ _ =>
    isPerm t₁ t₂ <&&> isPerm v₁ v₂ <&&> withLetDecl n₁ t₁ v₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.proj _ i₁ b₁, Expr.proj _ i₂ b₂ => pure (i₁ == i₂) <&&> isPerm b₁ b₂
  | s, t => return s == t

private def checkBadRewrite (lhs rhs : Expr) : MetaM Unit := do
  let lhs ← DiscrTree.reduceDT lhs (root := true) (simpleReduce := true)
  if lhs == rhs && lhs.isFVar then
    throwError "invalid `simp` theorem, equation is equivalent to{indentExpr (← mkEq lhs rhs)}"

private partial def shouldPreprocess (type : Expr) : MetaM Bool :=
  forallTelescopeReducing type fun _ result => do
    if let some (_, lhs, rhs) := result.eq? then
      checkBadRewrite lhs rhs
      return false
    else
      return true

private partial def preprocess (e type : Expr) (inv : Bool) (isGlobal : Bool) : MetaM (List (Expr × Expr)) :=
  go e type
where
  go (e type : Expr) : MetaM (List (Expr × Expr)) := do
  let type ← whnf type
  if type.isForall then
    forallTelescopeReducing type fun xs type => do
      let e := mkAppN e xs
      let ps ← go e type
      ps.mapM fun (e, type) =>
        return (← mkLambdaFVars xs e, ← mkForallFVars xs type)
  else if let some (_, lhs, rhs) := type.eq? then
    if isGlobal then
      checkBadRewrite lhs rhs
    if inv then
      let type ← mkEq rhs lhs
      let e    ← mkEqSymm e
      return [(e, type)]
    else
      return [(e, type)]
  else if let some (lhs, rhs) := type.iff? then
    if isGlobal then
      checkBadRewrite lhs rhs
    if inv then
      let type ← mkEq rhs lhs
      let e    ← mkEqSymm (← mkPropExt e)
      return [(e, type)]
    else
      let type ← mkEq lhs rhs
      let e    ← mkPropExt e
      return [(e, type)]
  else if let some (_, lhs, rhs) := type.ne? then
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'False'"
    if rhs.isConstOf ``Bool.true then
      return [(← mkAppM ``Bool.of_not_eq_true #[e], ← mkEq lhs (mkConst ``Bool.false))]
    else if rhs.isConstOf ``Bool.false then
      return [(← mkAppM ``Bool.of_not_eq_false #[e], ← mkEq lhs (mkConst ``Bool.true))]
    let type ← mkEq (← mkEq lhs rhs) (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some p := type.not? then
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'False'"
    if let some (_, lhs, rhs) := p.eq? then
      if rhs.isConstOf ``Bool.true then
        return [(← mkAppM ``Bool.of_not_eq_true #[e], ← mkEq lhs (mkConst ``Bool.false))]
      else if rhs.isConstOf ``Bool.false then
        return [(← mkAppM ``Bool.of_not_eq_false #[e], ← mkEq lhs (mkConst ``Bool.true))]
    let type ← mkEq p (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some (type₁, type₂) := type.and? then
    let e₁ := mkProj ``And 0 e
    let e₂ := mkProj ``And 1 e
    return (← go e₁ type₁) ++ (← go e₂ type₂)
  else
    if inv then
      throwError "invalid '←' modifier in rewrite rule to 'True'"
    let type ← mkEq type (mkConst ``True)
    let e    ← mkEqTrue e
    return [(e, type)]

private def checkTypeIsProp (type : Expr) : MetaM Unit :=
  unless (← isProp type) do
    throwError "invalid 'simp', proposition expected{indentExpr type}"

private def mkSimpTheoremCore (origin : Origin) (e : Expr) (levelParams : Array Name) (proof : Expr) (post : Bool) (prio : Nat) : MetaM SimpTheorem := do
  assert! origin != .fvar ⟨.anonymous⟩
  let type ← instantiateMVars (← inferType e)
  withNewMCtxDepth do
    let (_, _, type) ← withReducible <| forallMetaTelescopeReducing type
    let type ← whnfR type
    let (keys, perm) ←
      match type.eq? with
      | some (_, lhs, rhs) => pure (← DiscrTree.mkPath lhs, ← isPerm lhs rhs)
      | none => throwError "unexpected kind of 'simp' theorem{indentExpr type}"
    return { origin, keys, perm, post, levelParams, proof, priority := prio, rfl := (← isRflProof proof) }

private def mkSimpTheoremsFromConst (declName : Name) (post : Bool) (inv : Bool) (prio : Nat) : MetaM (Array SimpTheorem) := do
  let cinfo ← getConstInfo declName
  let val := mkConst declName (cinfo.levelParams.map mkLevelParam)
  withReducible do
    let type ← inferType val
    checkTypeIsProp type
    if inv || (← shouldPreprocess type) then
      let mut r := #[]
      for (val, type) in (← preprocess val type inv (isGlobal := true)) do
        let auxName ← mkAuxLemma cinfo.levelParams type val
        r := r.push <| (← mkSimpTheoremCore (.decl declName) (mkConst auxName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst auxName) post prio)
      return r
    else
      return #[← mkSimpTheoremCore (.decl declName) (mkConst declName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst declName) post prio]

inductive SimpEntry where
  | thm      : SimpTheorem → SimpEntry
  | toUnfold : Name → SimpEntry
  | toUnfoldThms : Name → Array Name → SimpEntry
  deriving Inhabited

abbrev SimpExtension := SimpleScopedEnvExtension SimpEntry SimpTheorems

def SimpExtension.getTheorems (ext : SimpExtension) : CoreM SimpTheorems :=
  return ext.getState (← getEnv)

def addSimpTheorem (ext : SimpExtension) (declName : Name) (post : Bool) (inv : Bool) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
  let simpThms ← mkSimpTheoremsFromConst declName post inv prio
  for simpThm in simpThms do
    ext.add (SimpEntry.thm simpThm) attrKind

def mkSimpAttr (attrName : Name) (attrDescr : String) (ext : SimpExtension)
    (ref : Name := by exact decl_name%) : IO Unit :=
  registerBuiltinAttribute {
    ref   := ref
    name  := attrName
    descr := attrDescr
    applicationTime := AttributeApplicationTime.afterCompilation
    add   := fun declName stx attrKind =>
      let go : MetaM Unit := do
        let info ← getConstInfo declName
        let post := if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost
        let prio ← getAttrParamOptPrio stx[2]
        if (← isProp info.type) then
          addSimpTheorem ext declName post (inv := false) attrKind prio
        else if info.hasValue then
          if let some eqns ← getEqnsFor? declName then
            for eqn in eqns do
              addSimpTheorem ext eqn post (inv := false) attrKind prio
            ext.add (SimpEntry.toUnfoldThms declName eqns) attrKind
            if hasSmartUnfoldingDecl (← getEnv) declName then
              ext.add (SimpEntry.toUnfold declName) attrKind
          else
            ext.add (SimpEntry.toUnfold declName) attrKind
        else
          throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)"
      discard <| go.run {} {}
    erase := fun declName => do
      let s := ext.getState (← getEnv)
      let s ← s.erase (.decl declName)
      modifyEnv fun env => ext.modifyState env fun _ => s
  }

def mkSimpExt (name : Name := by exact decl_name%) : IO SimpExtension :=
  registerSimpleScopedEnvExtension {
    name     := name
    initial  := {}
    addEntry := fun d e =>
      match e with
      | SimpEntry.thm e => addSimpTheoremEntry d e
      | SimpEntry.toUnfold n => d.addDeclToUnfoldCore n
      | SimpEntry.toUnfoldThms n thms => d.registerDeclToUnfoldThms n thms
  }

abbrev SimpExtensionMap := HashMap Name SimpExtension

builtin_initialize simpExtensionMapRef : IO.Ref SimpExtensionMap ← IO.mkRef {}

def registerSimpAttr (attrName : Name) (attrDescr : String)
    (ref : Name := by exact decl_name%) : IO SimpExtension := do
  let ext ← mkSimpExt ref
  mkSimpAttr attrName attrDescr ext ref -- Remark: it will fail if it is not performed during initialization
  simpExtensionMapRef.modify fun map => map.insert attrName ext
  return ext

builtin_initialize simpExtension : SimpExtension ← registerSimpAttr `simp "simplification theorem"

def getSimpExtension? (attrName : Name) : IO (Option SimpExtension) :=
  return (← simpExtensionMapRef.get).find? attrName

def getSimpTheorems : CoreM SimpTheorems :=
  simpExtension.getTheorems

/-- Auxiliary method for adding a global declaration to a `SimpTheorems` datastructure. -/
def SimpTheorems.addConst (s : SimpTheorems) (declName : Name) (post := true) (inv := false) (prio : Nat := eval_prio default) : MetaM SimpTheorems := do
  let s := { s with erased := s.erased.erase (.decl declName) }
  let simpThms ← mkSimpTheoremsFromConst declName post inv prio
  return simpThms.foldl addSimpTheoremEntry s

def SimpTheorem.getValue (simpThm : SimpTheorem) : MetaM Expr := do
  if simpThm.proof.isConst && simpThm.levelParams.isEmpty then
    let info ← getConstInfo simpThm.proof.constName!
    if info.levelParams.isEmpty then
      return simpThm.proof
    else
      return simpThm.proof.updateConst! (← info.levelParams.mapM (fun _ => mkFreshLevelMVar))
  else
    let us ← simpThm.levelParams.mapM fun _ => mkFreshLevelMVar
    return simpThm.proof.instantiateLevelParamsArray simpThm.levelParams us

private def preprocessProof (val : Expr) (inv : Bool) : MetaM (Array Expr) := do
  let type ← inferType val
  checkTypeIsProp type
  let ps ← preprocess val type inv (isGlobal := false)
  return ps.toArray.map fun (val, _) => val

/-- Auxiliary method for creating simp theorems from a proof term `val`. -/
def mkSimpTheorems (id : Origin) (levelParams : Array Name) (proof : Expr) (post := true) (inv := false) (prio : Nat := eval_prio default) : MetaM (Array SimpTheorem) :=
  withReducible do
    (← preprocessProof proof inv).mapM fun val => mkSimpTheoremCore id val levelParams val post prio

/-- Auxiliary method for adding a local simp theorem to a `SimpTheorems` datastructure. -/
def SimpTheorems.add (s : SimpTheorems) (id : Origin) (levelParams : Array Name) (proof : Expr) (inv := false) (post := true) (prio : Nat := eval_prio default) : MetaM SimpTheorems := do
  if proof.isConst then
    s.addConst proof.constName! post inv prio
  else
    let simpThms ← mkSimpTheorems id levelParams proof post inv prio
    return simpThms.foldl addSimpTheoremEntry s

def SimpTheorems.addDeclToUnfold (d : SimpTheorems) (declName : Name) : MetaM SimpTheorems := do
  if let some eqns ← getEqnsFor? declName then
    let mut d := d
    for eqn in eqns do
      d ← SimpTheorems.addConst d eqn
    if hasSmartUnfoldingDecl (← getEnv) declName then
      d := d.addDeclToUnfoldCore declName
    return d
  else
    return d.addDeclToUnfoldCore declName

abbrev SimpTheoremsArray := Array SimpTheorems

def SimpTheoremsArray.addTheorem (thmsArray : SimpTheoremsArray) (id : Origin) (h : Expr) : MetaM SimpTheoremsArray :=
  if thmsArray.isEmpty then
    let thms : SimpTheorems := {}
    return #[ (← thms.add id #[] h) ]
  else
    thmsArray.modifyM 0 fun thms => thms.add id #[] h

def SimpTheoremsArray.eraseTheorem (thmsArray : SimpTheoremsArray) (thmId : Origin) : SimpTheoremsArray :=
  thmsArray.map fun thms => thms.eraseCore thmId

def SimpTheoremsArray.isErased (thmsArray : SimpTheoremsArray) (thmId : Origin) : Bool :=
  thmsArray.any fun thms => thms.erased.contains thmId

def SimpTheoremsArray.isDeclToUnfold (thmsArray : SimpTheoremsArray) (declName : Name) : Bool :=
  thmsArray.any fun thms => thms.isDeclToUnfold declName

macro (name := _root_.Lean.Parser.Command.registerSimpAttr) doc:(docComment)?
  "register_simp_attr" id:ident : command => do
  let str := id.getId.toString
  let idParser := mkIdentFrom id (`Parser.Attr ++ id.getId)
  let descr := quote (removeLeadingSpaces (doc.map (·.getDocString) |>.getD s!"simp set for {id.getId.toString}"))
  `($[$doc:docComment]? initialize ext : SimpExtension ← registerSimpAttr $(quote id.getId) $descr $(quote id.getId)
    $[$doc:docComment]? syntax (name := $idParser:ident) $(quote str):str (Parser.Tactic.simpPre <|> Parser.Tactic.simpPost)? (prio)? : attr)

end Meta

end Lean


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  assume h1 : G.colorable 2,
  have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from by {
    obtain ⟨f,hf⟩ := h1,
    have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), ∀ (a b : A ⊕ B), (a ≠ b) → (f a ≠ f b), from by {
      have h4 : ∀ (a b : A ⊕ B), (a ≠ b) → (f a ≠ f b), from by {
        assume a b : A ⊕ B,
        assume h5 : a ≠ b,
        assume h6 : f a = f b,
        have h7 : a = b, from by {
          cases a, cases b,
          {rw ← h6, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf, rw hf
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h : G.colorable 2,
    have h1 : ∃ A B : Type*, (A ⊕ B) = V, from by {
      have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅, from by {
        have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V, from by {
          have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V), from by {
            have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V), from by {
              have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V), from by {
                have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                  have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                    have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                      have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                        have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                          have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V ⊕ V), from by {
                            have h1 : ∃ A B : Type*, (A ⊕ B) = V ∧ (A ⊕ B) ≠ ∅ ∧ (A ⊕ B) ≠ V ∧ (A ⊕ B) ≠ (V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V) ∧ (A ⊕ B) ≠ (V ⊕ V ⊕ V ⊕ V) ∧ (A ⊕ B)
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
begin
  split,
  {
    assume h1 : G.colorable 2,
    have h2 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
    begin
      have h3 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
      begin
        have h4 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
        begin
          have h5 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
          begin
            have h6 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
            begin
              have h7 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
              begin
                have h8 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                begin
                  have h9 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                  begin
                    have h10 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                    begin
                      have h11 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                      begin
                        have h12 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                        begin
                          have h13 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                          begin
                            have h14 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                            begin
                              have h15 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                              begin
                                have h16 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                begin
                                  have h17 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                  begin
                                    have h18 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                    begin
                                      have h19 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                      begin
                                        have h20 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                        begin
                                          have h21 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                          begin
                                            have h22 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                            begin
                                              have h23 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                              begin
                                                have h24 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                begin
                                                  have h25 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                  begin
                                                    have h26 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                    begin
                                                      have h27 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                      begin
                                                        have h28 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                        begin
                                                          have h29 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                          begin
                                                            have h30 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                            begin
                                                              have h31 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                              begin
                                                                have h32 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                                begin
                                                                  have h33 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                                  begin
                                                                    have h34 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                                    begin
                                                                      have h35 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B), from
                                                                      begin
                                                                        have h36 : ∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B),
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem  bipartite_iff_two_colorable {V : Type*} (G : simple_graph V) [fintype V] : (G.colorable 2) ↔ (∃ (A B : Type*) (h : (A ⊕ B) = V), G ≤ cast (congr_arg _ h) (complete_bipartite_graph A B)) :=
FEW SHOT PROMPTS TO CODEX(END)-/


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

! This file was ported from Lean 3 source module tactic.unify_equations
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Core

/-!
# The `unify_equations` tactic

This module defines `unify_equations`, a first-order unification tactic that
unifies one or more equations in the context. It implements the Qnify algorithm
from [McBride, Inverting Inductively Defined Relations in LEGO][mcbride1996].

The tactic takes as input some equations which it simplifies one after the
other. Each equation is simplified by applying one of several possible
unification steps. Each such step may output other (simpler) equations which are
unified recursively until no unification step applies any more. See
`tactic.interactive.unify_equations` for an example and an explanation of the
different steps.
-/

open Expr

namespace Tactic

namespace UnifyEquations

/-- The result of a unification step:

- `simplified hs` means that the step succeeded and produced some new (simpler)
  equations `hs`. `hs` can be empty.
- `goal_solved` means that the step succeeded and solved the goal (by deriving a
  contradiction from the given equation).
- `not_simplified` means that the step failed to simplify the equation.
-/
unsafe inductive unification_step_result : Type
  | simplified (next_equations : List Name)
  | not_simplified
  | goal_solved
#align tactic.unify_equations.unification_step_result tactic.unify_equations.unification_step_result

export UnificationStepResult ()

/-- A unification step is a tactic that attempts to simplify a given equation and
returns a `unification_step_result`. The inputs are:

- `equ`, the equation being processed. Must be a local constant.
- `lhs_type` and `rhs_type`, the types of equ's LHS and RHS. For homogeneous
  equations, these are defeq.
- `lhs` and `rhs`, `equ`'s LHS and RHS.
- `lhs_whnf` and `rhs_whnf`, `equ`'s LHS and RHS in WHNF.
- `u`, `equ`'s level.

So `equ : @eq.{u} lhs_type lhs rhs` or `equ : @heq.{u} lhs_type lhs rhs_type rhs`.
-/
@[reducible]
unsafe def unification_step : Type :=
  ∀ (equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf : expr) (u : level),
    tactic unification_step_result
#align tactic.unify_equations.unification_step tactic.unify_equations.unification_step

/-- For `equ : t == u` with `t : T` and `u : U`, if `T` and `U` are defeq,
we replace `equ` with `equ : t = u`.
-/
unsafe def unify_heterogeneous : unification_step := fun equ lhs_type rhs_type lhs rhs _ _ _ =>
  (do
      is_def_eq lhs_type rhs_type
      let p ← to_expr ``(@eq_of_hEq $(lhs_type) $(lhs) $(rhs) $(equ))
      let t ← to_expr ``(@Eq $(lhs_type) $(lhs) $(rhs))
      let equ' ← note equ.local_pp_name t p
      clear equ
      pure <| simplified [equ']) <|>
    pure not_simplified
#align tactic.unify_equations.unify_heterogeneous tactic.unify_equations.unify_heterogeneous

/-- For `equ : t = u`, if `t` and `u` are defeq, we delete `equ`.
-/
unsafe def unify_defeq : unification_step := fun equ lhs_type _ _ _ lhs_whnf rhs_whnf _ =>
  (do
      is_def_eq lhs_whnf rhs_whnf
      clear equ
      pure <| simplified []) <|>
    pure not_simplified
#align tactic.unify_equations.unify_defeq tactic.unify_equations.unify_defeq

/-- For `equ : x = t` or `equ : t = x`, where `x` is a local constant, we
substitute `x` with `t` in the goal.
-/
unsafe def unify_var : unification_step := fun equ type _ lhs rhs lhs_whnf rhs_whnf u =>
  (do
      let lhs_is_local := lhs_whnf.is_local_constant
      let rhs_is_local := rhs_whnf.is_local_constant
      guard <| lhs_is_local ∨ rhs_is_local
      let t :=
        if lhs_is_local then (const `eq [u]) type lhs_whnf rhs
        else (const `eq [u]) type lhs rhs_whnf
      change_core t (some equ)
      let equ ← get_local equ.local_pp_name
      subst_core equ
      pure <| simplified []) <|>
    pure not_simplified
#align tactic.unify_equations.unify_var tactic.unify_equations.unify_var

-- TODO This is an improved version of `injection_with` from core
-- (init/meta/injection_tactic). Remove when the improvements have landed in
-- core.
private unsafe def injection_with' (h : expr) (ns : List Name) (base := `h) (offset := some 1) :
    tactic (Option (List expr) × List Name) := do
  let H ← infer_type h
  let (lhs, rhs, constructor_left, constructor_right, inj_name) ←
    (do
          let (lhs, rhs) ← match_eq H
          let constructor_left ← get_app_fn_const_whnf lhs semireducible false
          let constructor_right ← get_app_fn_const_whnf rhs semireducible false
          let inj_name ← resolve_constant <| constructor_left ++ "inj_arrow"
          pure (lhs, rhs, constructor_left, constructor_right, inj_name)) <|>
        fail
          ("injection tactic failed, argument must be an equality proof where lhs and rhs " ++
            "are of the form (c ...), where c is a constructor")
  if constructor_left = constructor_right then do
      let inj
        ←-- C.inj_arrow, for a given constructor C of datatype D, has type
            --
            --     ∀ (A₁ ... Aₙ) (x₁ ... xₘ) (y₁ ... yₘ), C x₁ ... xₘ = C y₁ ... yₘ
            --       → ∀ ⦃P : Sort u⦄, (x₁ = y₁ → ... → yₖ = yₖ → P) → P
            --
            -- where the Aᵢ are parameters of D and the xᵢ/yᵢ are arguments of C.
            -- Note that if xᵢ/yᵢ are propositions, no equation is generated, so the
            -- number of equations is not necessarily the constructor arity.
            -- First, we find out how many equations we need to intro later.
            mk_const
            inj_name
      let inj_type ← infer_type inj
      let inj_arity ← get_pi_arity inj_type
      let num_equations := (inj_type (inj_arity - 1)).binding_domain.pi_arity
      let tgt
        ←-- Now we generate the actual proof of the target.
          target
      let proof ← mk_mapp inj_name (List.replicate (inj_arity - 3) none ++ [some h, some tgt])
      eapply proof
      let (next, ns) ← intron_with num_equations ns base offset
      let next
        ←-- The following filters out 'next' hypotheses of type `true`. The
            -- `inj_arrow` lemmas introduce these for nullary constructors.
            next
            fun h => do
            let q(True) ← infer_type h |
              pure tt
            clear h >> pure ff <|> pure tt
      pure (some next, ns)
    else do
      let tgt ← target
      let constructor_left
        ←-- The following construction deals with a corner case involing
            -- mutual/nested inductive types. For these, Lean does not generate
            -- no-confusion principles. However, the regular inductive data type which a
            -- mutual/nested inductive type is compiled to does have a no-confusion
            -- principle which we can (usually? always?) use. To find it, we normalise
            -- the constructor with `unfold_ginductive = tt`.
            get_app_fn_const_whnf
            lhs semireducible tt
      let no_confusion := constructor_left ++ "no_confusion"
      let pr ← mk_app no_confusion [tgt, lhs, rhs, h]
      exact pr
      return (none, ns)
#align tactic.unify_equations.injection_with' tactic.unify_equations.injection_with'

/-- Given `equ : C x₁ ... xₙ = D y₁ ... yₘ` with `C` and `D` constructors of the
same datatype `I`:

- If `C ≠ D`, we solve the goal by contradiction using the no-confusion rule.
- If `C = D`, we clear `equ` and add equations `x₁ = y₁`, ..., `xₙ = yₙ`.
-/
unsafe def unify_constructor_headed : unification_step := fun equ _ _ _ _ _ _ _ =>
  (do
      let (next, _) ← injection_with' equ [] `_ none
      try <| clear equ
      pure <|
          match next with
          | none => goal_solved
          | some next => simplified <| next expr.local_pp_name) <|>
    pure not_simplified
#align tactic.unify_equations.unify_constructor_headed tactic.unify_equations.unify_constructor_headed

/-- For `type = I x₁ ... xₙ`, where `I` is an inductive type, `get_sizeof type`
returns the constant `I.sizeof`. Fails if `type` is not of this form or if no
such constant exists.
-/
unsafe def get_sizeof (type : expr) : tactic pexpr := do
  let n ← get_app_fn_const_whnf type semireducible false
  resolve_name <| n ++ `sizeof
#align tactic.unify_equations.get_sizeof tactic.unify_equations.get_sizeof

theorem add_add_one_ne (n m : ℕ) : n + (m + 1) ≠ n :=
  by
  apply ne_of_gt
  apply Nat.lt_add_of_pos_right
  apply Nat.pos_of_ne_zero
  contradiction
#align tactic.unify_equations.add_add_one_ne Tactic.UnifyEquations.add_add_one_ne

-- Linarith could prove this, but I want to avoid that dependency.
/-- `match_n_plus_m n e` matches `e` of the form `nat.succ (... (nat.succ e')...)`.
It returns `n` plus the number of `succ` constructors and `e'`. The matching is
performed up to normalisation with transparency `md`.
-/
unsafe def match_n_plus_m (md) : ℕ → expr → tactic (ℕ × expr) := fun n e => do
  let e ← whnf e md
  match e with
    | q(Nat.succ $(e)) => match_n_plus_m (n + 1) e
    | _ => pure (n, e)
#align tactic.unify_equations.match_n_plus_m tactic.unify_equations.match_n_plus_m

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Given `equ : n + m = n` or `equ : n = n + m` with `n` and `m` natural numbers
      and `m` a nonzero literal, this tactic produces a proof of `false`. More
      precisely, the two sides of the equation must be of the form
      `nat.succ (... (nat.succ e)...)` with different numbers of `nat.succ`
      constructors. Matching is performed with transparency `md`.
      -/
    unsafe
  def
    contradict_n_eq_n_plus_m
    ( md : Transparency ) ( equ lhs rhs : expr ) : tactic expr
    :=
      do
        let ⟨ lhs_n , lhs_e ⟩ ← match_n_plus_m md 0 lhs
          let ⟨ rhs_n , rhs_e ⟩ ← match_n_plus_m md 0 rhs
          is_def_eq lhs_e rhs_e md
            <|>
            fail
              (
                "contradict_n_eq_n_plus_m:\nexpected {lhs_e} and {rhs_e} to be definitionally "
                  ++
                  "equal at transparency {md}."
                )
          let common := lhs_e
          guard ( lhs_n ≠ rhs_n )
            <|>
            fail "contradict_n_eq_n_plus_m:\nexpected {lhs_n} and {rhs_n} to be different."
          let
            ⟨ equ , lhs_n , rhs_n ⟩
              ←
              if
                lhs_n > rhs_n
                then
                pure ( equ , lhs_n , rhs_n )
                else
                do let equ ← to_expr ` `( Eq.symm $ ( equ ) ) pure ( equ , rhs_n , lhs_n )
          let diff := lhs_n - rhs_n
          let rhs_n_expr := reflect rhs_n
          let n ← to_expr ` `( $ ( common ) + $ ( rhs_n_expr ) )
          let m := reflect ( diff - 1 )
          pure q( add_add_one_ne $ ( n ) $ ( m ) $ ( equ ) )
#align tactic.unify_equations.contradict_n_eq_n_plus_m tactic.unify_equations.contradict_n_eq_n_plus_m

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Given `equ : t = u` with `t, u : I` and `I.sizeof t ≠ I.sizeof u`, we solve the
      goal by contradiction.
      -/
    unsafe
  def
    unify_cyclic
    : unification_step
    :=
      fun
        equ type _ _ _ lhs_whnf rhs_whnf _
          =>
          (
              do
                let sizeof ← get_sizeof type
                  let hyp_lhs ← to_expr ` `( $ ( SizeOf.sizeOf ) $ ( lhs_whnf ) )
                  let hyp_rhs ← to_expr ` `( $ ( SizeOf.sizeOf ) $ ( rhs_whnf ) )
                  let hyp_type ← to_expr ` `( @ Eq ℕ $ ( hyp_lhs ) $ ( hyp_rhs ) )
                  let
                    hyp_proof
                      ←
                      to_expr
                        `
                          `(
                            @ congr_arg
                              $ ( type )
                                ℕ
                                $ ( lhs_whnf )
                                $ ( rhs_whnf )
                                $ ( SizeOf.sizeOf )
                                $ ( equ )
                            )
                  let hyp_name ← mk_fresh_name
                  let hyp ← note hyp_name hyp_type hyp_proof
                  let falso ← contradict_n_eq_n_plus_m semireducible hyp hyp_lhs hyp_rhs
                  exfalso
                  exact falso
                  pure goal_solved
              )
            <|>
            pure not_simplified
#align tactic.unify_equations.unify_cyclic tactic.unify_equations.unify_cyclic

/-- `orelse_step s t` first runs the unification step `s`. If this was successful
(i.e. `s` simplified or solved the goal), it returns the result of `s`.
Otherwise, it runs `t` and returns its result.
-/
unsafe def orelse_step (s t : unification_step) : unification_step :=
  fun equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u => do
  let r ← s equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u
  match r with
    | simplified _ => pure r
    | goal_solved => pure r
    | not_simplified => t equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u
#align tactic.unify_equations.orelse_step tactic.unify_equations.orelse_step

/-- For `equ : t = u`, try the following methods in order: `unify_defeq`,
`unify_var`, `unify_constructor_headed`, `unify_cyclic`. If any of them is
successful, stop and return its result. If none is successful, fail.
-/
unsafe def unify_homogeneous : unification_step :=
  List.foldl orelse_step (fun _ _ _ _ _ _ _ _ => pure not_simplified)
    [unify_defeq, unify_var, unify_constructor_headed, unify_cyclic]
#align tactic.unify_equations.unify_homogeneous tactic.unify_equations.unify_homogeneous

end UnifyEquations

open UnifyEquations

/-- If `equ` is the display name of a local constant with type `t = u` or `t == u`,
then `unify_equation_once equ` simplifies it once using
`unify_equations.unify_homogeneous` or `unify_equations.unify_heterogeneous`.

Otherwise it fails.
-/
unsafe def unify_equation_once (equ : Name) : tactic unification_step_result := do
  let eque ← get_local equ
  let t ← infer_type eque
  match t with
    | app (app (app (const `eq [u]) type) lhs) rhs => do
      let lhs_whnf ← whnf_ginductive lhs
      let rhs_whnf ← whnf_ginductive rhs
      unify_homogeneous eque type type lhs rhs lhs_whnf rhs_whnf u
    | app (app (app (app (const `heq [u]) lhs_type) lhs) rhs_type) rhs => do
      let lhs_whnf ← whnf_ginductive lhs
      let rhs_whnf ← whnf_ginductive rhs
      unify_heterogeneous eque lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u
    | _ =>
      throwError "Expected {(← equ)} to be an equation, but its type is
        {← t}."
#align tactic.unify_equation_once tactic.unify_equation_once

/-- Given a list of display names of local hypotheses that are (homogeneous or
heterogeneous) equations, `unify_equations` performs first-order unification on
each hypothesis in order. See `tactic.interactive.unify_equations` for an
example and an explanation of what unification does.

Returns true iff the goal has been solved during the unification process.

Note: you must make sure that the input names are unique in the context.
-/
unsafe def unify_equations : List Name → tactic Bool
  | [] => pure false
  | h :: hs => do
    let res ← unify_equation_once h
    match res with
      | simplified hs' => unify_equations <| hs' ++ hs
      | not_simplified => unify_equations hs
      | goal_solved => pure tt
#align tactic.unify_equations tactic.unify_equations

namespace Interactive

open Lean.Parser

/-- `unify_equations eq₁ ... eqₙ` performs a form of first-order unification on the
hypotheses `eqᵢ`. The `eqᵢ` must be homogeneous or heterogeneous equations.
Unification means that the equations are simplified using various facts about
constructors. For instance, consider this goal:

```
P : ∀ n, fin n → Prop
n m : ℕ
f : fin n
g : fin m
h₁ : n + 1 = m + 1
h₂ : f == g
h₃ : P n f
⊢ P m g
```

After `unify_equations h₁ h₂`, we get

```
P : ∀ n, fin n → Prop
n : ℕ
f : fin n
h₃ : P n f
⊢ P n f
```

In the example, `unify_equations` uses the fact that every constructor is
injective to conclude `n = m` from `h₁`. Then it replaces every `m` with `n` and
moves on to `h₂`. The types of `f` and `g` are now equal, so the heterogeneous
equation turns into a homogeneous one and `g` is replaced by `f`. Note that the
equations are processed from left to right, so `unify_equations h₂ h₁` would not
simplify as much.

In general, `unify_equations` uses the following steps on each equation until
none of them applies any more:

- Constructor injectivity: if `nat.succ n = nat.succ m` then `n = m`.
- Substitution: if `x = e` for some hypothesis `x`, then `x` is replaced by `e`
  everywhere.
- No-confusion: `nat.succ n = nat.zero` is a contradiction. If we have such an
  equation, the goal is solved immediately.
- Cycle elimination: `n = nat.succ n` is a contradiction.
- Redundancy: if `t = u` but `t` and `u` are already definitionally equal, then
  this equation is removed.
- Downgrading of heterogeneous equations: if `t == u` but `t` and `u` have the
  same type (up to definitional equality), then the equation is replaced by
  `t = u`.
-/
unsafe def unify_equations (eqs : interactive.parse (many ident)) : tactic Unit :=
  tactic.unify_equations eqs *> skip
#align tactic.interactive.unify_equations tactic.interactive.unify_equations

add_tactic_doc
  { Name := "unify_equations"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.unify_equations]
    tags := ["simplification"] }

end Interactive

end Tactic


example [Add α] [Neg α] [Mul α] [∀ n, OfNat α n] {a b : α} :=
  calc
    4 + 5 * b = -6 + 5 * (b + 2) := sorry
    _         = -6 + 5 * 3       := sorry


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

import category_theory.preadditive.projective
import algebra.homology.homological_complex
import category_theory.abelian.basic
import for_mathlib.algebra.homology.twist_cocycle
import for_mathlib.algebraic_topology.homotopical_algebra.cochain_complex.basic
import for_mathlib.algebra.homology.homological_complex_biprod

noncomputable theory

open category_theory category_theory.category
open category_theory.limits algebraic_topology

open_locale zero_object

namespace category_theory

namespace limits

@[simps]
def is_zero.unique_up_to_iso {C : Type*} [category C]
  {X Y : C} (hX : is_zero X)
  (hY : is_zero Y) : X ≅ Y :=
is_initial.unique_up_to_iso hX.is_initial hY.is_initial

end limits

namespace projective

variables {C : Type*} [category C] [enough_projectives C] [has_zero_object C]

def over' (X : C) : C :=
begin
  by_cases is_zero X,
  { exact 0, },
  { exact (enough_projectives.presentation X).some.P, },
end
lemma over'_eq_zero (X : C) (hX : is_zero X) : over' X = 0 :=
begin
  dsimp [over'],
  split_ifs,
  refl,
end

lemma over'_eq (X : C) (hX : ¬is_zero X) : over' X = over X :=
begin
  dsimp [over'],
  split_ifs,
  refl,
end

def π' (X : C) : over' X ⟶ X :=
begin
  by_cases is_zero X,
  { let e : 0 ≅ X := limits.is_zero.unique_up_to_iso (is_zero_zero C) h,
    refine eq_to_hom (over'_eq_zero X h) ≫ e.hom, },
  { exact eq_to_hom (over'_eq X h) ≫ projective.π X, },
end

instance (X : C) : epi (π' X) :=
by { dsimp only [π'], split_ifs; apply epi_comp, }

instance (X : C) [has_zero_morphisms C] : projective (over' X) :=
begin
  dsimp [over'],
  split_ifs,
  { apply projective.zero_projective, },
  { exact projective.projective_over X,},
end

end projective

end category_theory

namespace cochain_complex

namespace minus

namespace projective_model_structure

variables {C : Type*} [category C] [abelian C] [enough_projectives C]

/-namespace CM5a

open cochain_complex.hom_complex

@[simps]
def P (L : cochain_complex C ℤ) : cochain_complex C ℤ :=
{ X := λ q, category_theory.projective.over' (L.X (q-1)),
  d := λ i j, 0,
  shape' := λ i j hij, rfl,
  d_comp_d' := λ i j k hij hjk, comp_zero, }

instance (L : cochain_complex C ℤ) (n : ℤ) : projective ((P L).X n) :=
by { dsimp [P], apply_instance, }

@[simps]
def Q (L : cochain_complex C ℤ) : cochain_complex C ℤ :=
twist (cocycle.of_hom (𝟙 (P L)))

instance Q_is_degreewise_projective (L : cochain_complex C ℤ) (n : ℤ) :
  projective ((Q L).X n) :=
by { dsimp only [Q, twist], apply_instance, }

@[simps]
def π (L : cochain_complex C ℤ) : Q L ⟶ L :=
begin
  refine twist.desc (cocycle.of_hom (𝟙 (P L))) (cochain.mk _) _ (neg_add_self 1) _,
  { exact (λ p q hpq, category_theory.projective.π' _ ≫ eq_to_hom (by { congr, linarith})), },
  { exact { f := λ i, category_theory.projective.π' _ ≫ L.d (i-1) i, }, },
  { ext,
    simp only [δ_v (-1) 0 rfl _ p p (add_zero p).symm (p-1) (p+1) rfl rfl,
      add_zero, zero_comp, cochain.mk_v, eq_to_hom_refl, comp_id, P_d,
      smul_zero, cocycle.of_hom_coe, cochain.id_comp, cochain.of_hom_v],
    },
end

lemma π_is_degreewise_epi (L : cochain_complex C ℤ) :
  projective_structure.arrow_classes.fib (π L) :=
begin
  intro n,
  have h : epi ((cochain.comp (twist.inl _ (show -(1 : ℤ)+1 = 0, by linarith))
    (cochain.of_hom (π L)) (add_zero (-1)).symm).v (n+1) n (by linarith)),
  { dsimp only [π, twist.desc, hom_complex.twist.desc_hom_as_cocycle],
    simp only [cocycle.cochain_of_hom_hom_of_eq_coe, twist.desc_cocycle_coe],
    rw twist.inl_comp_desc_cochain,
    dsimp,
    apply epi_comp, },
  simp only [cochain.comp_v _ _ (add_zero (-(1 : ℤ))).symm (n+1) n n
    (by linarith) (by linarith), cochain.of_hom_v] at h,
  simp only [twist.inl, cochain.mk, cochain.v, cochain.of_hom, cochain.of_homs,
    homological_complex.id_f, id_comp] at h,
  exact @epi_of_epi _ _ _ _ _ _ _ h,
end

@[simps]
def id_Q_homotopy_to_zero (L : cochain_complex C ℤ) :
  homotopy (𝟙 (Q L)) 0 :=
begin
  equiv_rw hom_complex.equiv_homotopy _ _,
  refine ⟨cochain.comp (twist.snd _ ) (twist.inl _ (by linarith)) (zero_add (-1)).symm, _⟩,
  dsimp only [Q],
  simpa only [add_zero, add_left_neg, eq_self_iff_true, δ_comp_of_first_is_zero_cochain,
    twist.δ_inl, cocycle.of_hom_coe, cochain.id_comp, cochain.of_hom_zero,
    twist.δ_snd _ (zero_add 1), ε_odd _ odd_neg_one, zsmul_neg, cochain.neg_comp, neg_zsmul,
    one_zsmul, neg_neg, twist.id_eq _ (show -(1 : ℤ)+1=0, by linarith) (zero_add 1),
    cochain.comp_id] using add_comm _ _,
end

variables {K L : cochain_complex C ℤ} (f : K ⟶ L)

include f
@[simps, nolint unused_arguments]
def obj := homological_complex.biprod K (Q L)

@[simps]
def i : K ⟶ obj f := homological_complex.biprod.inl

@[simps]
def p : obj f ⟶ L := homological_complex.biprod.desc f (π L)

@[simp, reassoc]
lemma fac : i f ≫ p f = f :=
by simp only [i, p, homological_complex.biprod.inl_desc]

lemma p_is_fib :
  projective_structure.arrow_classes.fib (p f) :=
begin
  intro n,
  have h : biprod.inr ≫ biprod.desc (f.f n) ((π L).f n) = (π L).f n := biprod.inr_desc _ _,
  haveI : epi ((π L).f n) := π_is_degreewise_epi L n,
  exact epi_of_epi_fac h,
end

lemma i_is_cof :
  projective_structure.arrow_classes.cof (i f) :=
begin
  intro n,
  apply preadditive.mono_with_projective_coker.of_biprod_inl,
end

def homotopy_equiv_i : homotopy_equiv K (obj f) :=
{ hom := i f,
  inv := homological_complex.biprod.fst,
  homotopy_hom_inv_id := by { simp only [i, homological_complex.biprod.inl_fst], },
  homotopy_inv_hom_id := begin
    symmetry,
    equiv_rw homotopy.equiv_sub_zero,
    dsimp only [obj, i],
    simpa only [zero_comp, comp_zero, id_comp, ← homological_complex.biprod.total,
      add_sub_cancel'] using ((id_Q_homotopy_to_zero L).comp_right
        homological_complex.biprod.inr).comp_left homological_complex.biprod.snd,
  end, }

lemma i_is_weq :
  projective_structure.arrow_classes.weq (i f) :=
(homotopy_equiv_i f).to_quasi_iso

lemma i_is_triv_cof :
  projective_structure.arrow_classes.triv_cof (i f) := ⟨i_is_cof f, i_is_weq f⟩

end CM5a

end projective_structure

end cochain_complex

namespace bounded_above_cochain_complex

namespace projective_model_structure

variables {C : Type*} [category C] [abelian C] [enough_projectives C]

namespace CM5a

variables {K L : bounded_above_cochain_complex C} (f : K ⟶ L)

open cochain_complex.projective_structure
include f

@[simps, nolint unused_arguments]
def obj : bounded_above_cochain_complex C := ⟨CM5a.obj f,
begin
  apply cochain_complex.is_bounded_above.of_biprod,
  { exact K.2, },
  { apply cochain_complex.hom_complex.twist.is_bounded_above,
    all_goals {
      cases L.2 with l hl,
      use (l+1),
      intros i hi,
      dsimp,
      rw category_theory.projective.over'_eq_zero, swap,
      { apply hl,
        linarith, },
      apply is_zero_zero, }, },
end⟩

@[simps]
def i : K ⟶ obj f := CM5a.i f

@[simps]
def p : obj f ⟶ L := CM5a.p f

lemma fac : i f ≫ p f = f := CM5a.fac f

lemma p_is_fib : arrow_classes.fib (p f) := CM5a.p_is_fib f

lemma i_is_triv_cof : arrow_classes.triv_cof (i f) := CM5a.i_is_triv_cof f

end CM5a-/

lemma CM5a' {X Z : minus C} (f : X ⟶ Z) (n : ℤ) [X.obj.is_strictly_le n]
  [Z.obj.is_strictly_le n] : ∃ (Y : minus C)
  (hY : Y.obj.is_strictly_le n) (i : X ⟶ Y) (p : Y ⟶ Z)
  (hi : (arrow_classes C).triv_cof i) (hp : (arrow_classes C).fib p), i ≫ p = f := sorry

lemma CM5a : (arrow_classes C).CM5a :=
λ X Z f, begin
  obtain ⟨nX, hX⟩ := X.property,
  obtain ⟨nZ, hZ⟩ := Z.property,
  haveI := hX,
  haveI := hZ,
  let n := max nX nZ,
  haveI : X.obj.is_strictly_le n := is_strictly_le_of_le _ _ _ (le_max_left _ _),
  haveI : Z.obj.is_strictly_le n := is_strictly_le_of_le _ _ _ (le_max_right _ _),
  obtain ⟨Y, hY, i, p, hi, hp, fac⟩ := CM5a' f n,
  exact ⟨Y, i, hi, p, hp, fac⟩,
end

end projective_model_structure

end minus

end cochain_complex