/-
Copyright (c) 2020 Dany Fabian. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Dany Fabian
-/
import tactic.unfold_cases

open tactic

variable {α : Type*}

inductive color
| red
| black

inductive node (α)
| leaf {} : node
| tree {} (color : color) (left : node) (val : α) (right : node) : node

/-- this function creates 122 cases as opposed to the 5 we see here. -/
def balance_eqn_compiler {α} : color → node α → α → node α → node α
| color.black (node.tree color.red (node.tree color.red a x b) y c) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black (node.tree color.red a x (node.tree color.red b y c)) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black a x (node.tree color.red (node.tree color.red b y c) z d) :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black a x (node.tree color.red b y (node.tree color.red c z d)) :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color a x b := node.tree color a x b

example : ∀ a (x:α) b y c z d, balance_eqn_compiler color.black (node.tree color.red (node.tree color.red a x b) y c) z d =
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d) :=
begin
  unfold_cases { refl },
end

/-- this function creates 122 cases as opposed to the 5 we see here. -/
def balance_match {α}  (c:color) (l:node α) (v:α) (r:node α) : node α :=
match c, l, v, r with
| color.black, node.tree color.red (node.tree color.red a x b) y c, z, d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, node.tree color.red a x (node.tree color.red b y c), z, d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, a, x, node.tree color.red (node.tree color.red b y c) z d :=
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color.black, a, x, node.tree color.red b y (node.tree color.red c z d) :=
     node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d)
| color, a, x, b := node.tree color a x b
end

example : ∀ a (x:α) b y c z d, balance_match color.black (node.tree color.red (node.tree color.red a x b) y c) z d =
    node.tree color.red (node.tree color.black a x b) y (node.tree color.black c z d) :=
begin
  unfold_cases { refl },
end

def foo : ℕ → ℕ → ℕ
| 0 0 := 17
| (n+2) 17 := 17
| 1 0 := 23
| 0 (n+18) := 15
| 0 17 := 17
| 1 17 := 17
| _ (n+18) := 27
| _ _ := 15

example : ∀ x, foo x 17 = 17 :=
begin
  unfold_cases { refl },
end

def bar : ℕ → ℕ
| 17 := 17
| 9 := 17
| n := 17

example : ∀ x, bar x = 17 :=
begin
  unfold_cases { refl }
end

def baz : ℕ → ℕ → Prop
| 0 0 := false
| 0 n := true
| n 0 := false
| n m := n < m

example : ∀ x, baz x 0 = false :=
begin
  unfold_cases { refl },
end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.limits.over
import category_theory.limits.shapes.images
import category_theory.adjunction.reflective

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
@[derive [category]]
def mono_over (X : C) := full_subcategory (λ (f : over X), mono f.hom)

namespace mono_over

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : mono f] : mono_over X := { obj := over.mk f, property := hf }

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : mono_over X ⥤ over X := full_subcategory_inclusion _

instance : has_coe (mono_over X) C :=
{ coe := λ Y, Y.obj.left, }

@[simp]
lemma forget_obj_left {f} : ((forget X).obj f).left = (f : C) := rfl

@[simp] lemma mk'_coe' {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f : C) = A := rfl

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbreviation arrow (f : mono_over X) : (f : C) ⟶ X := ((forget X).obj f).hom

@[simp] lemma mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f).arrow = f := rfl

@[simp]
lemma forget_obj_hom {f} : ((forget X).obj f).hom = f.arrow := rfl

instance : full (forget X) := full_subcategory.full _
instance : faithful (forget X) := full_subcategory.faithful _

instance mono (f : mono_over X) : mono f.arrow := f.property

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance is_thin {X : C} : quiver.is_thin (mono_over X) :=
λ f g,
  ⟨begin
    intros h₁ h₂,
    ext1,
    erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
  end⟩

@[reassoc] lemma w {f g : mono_over X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbreviation hom_mk {f g : mono_over X} (h : f.obj.left ⟶ g.obj.left) (w : h ≫ g.arrow = f.arrow) :
  f ⟶ g :=
over.hom_mk h w

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def iso_mk {f g : mono_over X} (h : f.obj.left ≅ g.obj.left) (w : h.hom ≫ g.arrow = f.arrow) :
  f ≅ g :=
{ hom := hom_mk h.hom w,
  inv := hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp] def mk'_arrow_iso {X : C} (f : mono_over X) : (mk' f.arrow) ≅ f :=
iso_mk (iso.refl _) (by simp)

/--
Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  mono_over Y ⥤ mono_over X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (mono_over.forget X).preimage ((mono_over.forget Y ⋙ F).map k), }

/--
Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def lift_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  lift F₁ h₁ ≅ lift F₂ h₂ :=
fully_faithful_cancel_right (mono_over.forget X) (iso_whisker_left (mono_over.forget Y) i)

/-- `mono_over.lift` commutes with composition of functors. -/
def lift_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

/-- `mono_over.lift` preserves the identity functor. -/
def lift_id :
  lift (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

@[simp]
lemma lift_comm (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  lift F h ⋙ mono_over.forget X = mono_over.forget Y ⋙ F :=
rfl

@[simp]
lemma lift_obj_arrow {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) (f : mono_over Y) :
  ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).hom :=
rfl

/--
Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : over A} (h₁ h₂) : mono_over f ≌ mono_over f.left :=
{ functor := mono_over.lift f.iterated_slice_equiv.functor h₁,
  inverse := mono_over.lift f.iterated_slice_equiv.inverse h₂,
  unit_iso := mono_over.lift_id.symm ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫
    (mono_over.lift_comp _ _ _ _).symm,
  counit_iso := mono_over.lift_comp _ _ _ _ ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫
    mono_over.lift_id }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : mono_over Y ⥤ mono_over X :=
mono_over.lift (over.pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
lift_iso _ _ (over.pullback_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullback_id : pullback (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.pullback_id ≪≫ lift_id

@[simp] lemma pullback_obj_left (f : X ⟶ Y) (g : mono_over Y) :
  (((pullback f).obj g) : C) = limits.pullback g.arrow f :=
rfl

@[simp] lemma pullback_obj_arrow (f : X ⟶ Y) (g : mono_over Y) :
  ((pullback f).obj g).arrow = pullback.snd :=
rfl

end pullback

section map

attribute [instance] mono_comp

/--
We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y :=
lift (over.map f)
(λ g, by apply mono_comp g.arrow f)

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  map (f ≫ g) ≅ map f ⋙ map g :=
lift_iso _ _ (over.map_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def map_id : map (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.map_id ≪≫ lift_id

@[simp] lemma map_obj_left (f : X ⟶ Y) [mono f] (g : mono_over X) :
  (((map f).obj g) : C) = g.obj.left :=
rfl

@[simp]
lemma map_obj_arrow (f : X ⟶ Y) [mono f] (g : mono_over X) :
  ((map f).obj g).arrow = g.arrow ≫ f :=
rfl

instance full_map (f : X ⟶ Y) [mono f] : full (map f) :=
{ preimage := λ g h e,
  begin
    refine hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply w e,
  end }

instance faithful_map (f : X ⟶ Y) [mono f] : faithful (map f) := {}.

/--
Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps] def map_iso {A B : C} (e : A ≅ B) : mono_over A ≌ mono_over B :=
{ functor := map e.hom,
  inverse := map e.inv,
  unit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id).symm,
  counit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id) }

section
variables (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps] def congr (e : C ≌ D) : mono_over X ≌ mono_over (e.functor.obj X) :=
{ functor := lift (over.post e.functor) $ λ f, by { dsimp, apply_instance },
  inverse := (lift (over.post e.inverse) $ λ f, by { dsimp, apply_instance })
    ⋙ (map_iso (e.unit_iso.symm.app X)).functor,
  unit_iso := nat_iso.of_components (λ Y, iso_mk (e.unit_iso.app Y) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ Y, iso_mk (e.counit_iso.app Y) (by tidy)) (by tidy) }

end

section
variable [has_pullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def map_pullback_adj (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
adjunction.restrict_fully_faithful
  (forget X) (forget Y) (over.map_pullback_adj f) (iso.refl _) (iso.refl _)

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullback_map_self (f : X ⟶ Y) [mono f] :
  map f ⋙ pullback f ≅ 𝟭 _ :=
(as_iso (mono_over.map_pullback_adj f).unit).symm

end

end map

section image
variables (f : X ⟶ Y) [has_image f]

/--
The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def image_mono_over (f : X ⟶ Y) [has_image f] : mono_over Y := mono_over.mk' (image.ι f)

@[simp] lemma image_mono_over_arrow (f : X ⟶ Y) [has_image f] :
  (image_mono_over f).arrow = image.ι f :=
rfl

end image

section image

variables [has_images C]

/--
Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : over X ⥤ mono_over X :=
{ obj := λ f, image_mono_over f.hom,
  map := λ f g k,
  begin
    apply (forget X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

/--
`mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def image_forget_adj : image ⊣ forget X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.obj.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance : is_right_adjoint (forget X) :=
{ left := image, adj := image_forget_adj }

instance reflective : reflective (forget X) := {}.

/--
Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forget_image : forget X ⋙ image ≅ 𝟭 (mono_over X) :=
as_iso (adjunction.counit image_forget_adj)

end image

section «exists»
variables [has_images C]

/--
In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def «exists» (f : X ⟶ Y) : mono_over X ⥤ mono_over Y :=
forget _ ⋙ over.map f ⋙ image

instance faithful_exists (f : X ⟶ Y) : faithful («exists» f) := {}.

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f ≅ map f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget _).obj ((«exists» f).obj Z) ≅ (forget _).obj ((map f).obj Z),
    apply (forget _).preimage_iso this,
  apply over.iso_mk _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- `exists` is adjoint to `pullback` when images exist -/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
adjunction.restrict_fully_faithful (forget X) (𝟭 _)
  ((over.map_pullback_adj f).comp image_forget_adj)
  (iso.refl _)
  (iso.refl _)

end «exists»

end mono_over

end category_theory


/-
Copyright (c) Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.adjunction.limits
import category_theory.limits.shapes.terminal

/-!
# Transporting existence of specific limits across equivalences

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

For now, we only treat the case of initial and terminal objects, but other special shapes can be
added in the future.
-/

open category_theory category_theory.limits

namespace category_theory
universes v₁ v₂ u₁ u₂
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]

lemma has_initial_of_equivalence (e : D ⥤ C) [is_equivalence e] [has_initial C] : has_initial D :=
adjunction.has_colimits_of_shape_of_equivalence e

lemma equivalence.has_initial_iff (e : C ≌ D) : has_initial C ↔ has_initial D :=
⟨λ h, by exactI has_initial_of_equivalence e.inverse,
 λ h, by exactI has_initial_of_equivalence e.functor⟩

lemma has_terminal_of_equivalence (e : D ⥤ C) [is_equivalence e] [has_terminal C] :
  has_terminal D :=
adjunction.has_limits_of_shape_of_equivalence e

lemma equivalence.has_terminal_iff (e : C ≌ D) : has_terminal C ↔ has_terminal D :=
⟨λ h, by exactI has_terminal_of_equivalence e.inverse,
 λ h, by exactI has_terminal_of_equivalence e.functor⟩

end category_theory


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

Natural homomorphism from the natural numbers into a monoid with one.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.cast
import Mathlib.data.fintype.basic
import Mathlib.tactic.wlog
import Mathlib.PostPort

universes u_1 l

namespace Mathlib

/-- Typeclass for monoids with characteristic zero.
  (This is usually stated on fields but it makes sense for any additive monoid with 1.) -/
class char_zero (R : Type u_1) [add_monoid R] [HasOne R]
where
  cast_injective : function.injective coe

theorem char_zero_of_inj_zero {R : Type u_1} [add_left_cancel_monoid R] [HasOne R] (H : ∀ (n : ℕ), ↑n = 0 → n = 0) : char_zero R := sorry

protected instance linear_ordered_semiring.to_char_zero {R : Type u_1} [linear_ordered_semiring R] : char_zero R :=
  char_zero.mk (strict_mono.injective nat.strict_mono_cast)

namespace nat

theorem cast_injective {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] : function.injective coe :=
  char_zero.cast_injective

@[simp] theorem cast_inj {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {m : ℕ} {n : ℕ} : ↑m = ↑n ↔ m = n :=
  function.injective.eq_iff cast_injective

@[simp] theorem cast_eq_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {n : ℕ} : ↑n = 0 ↔ n = 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n = 0 ↔ n = 0)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n = ↑0 ↔ n = 0)) (propext cast_inj))) (iff.refl (n = 0)))

theorem cast_ne_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] {n : ℕ} : ↑n ≠ 0 ↔ n ≠ 0 :=
  not_congr cast_eq_zero

theorem cast_add_one_ne_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] (n : ℕ) : ↑n + 1 ≠ 0 := sorry

@[simp] theorem cast_dvd_char_zero {k : Type u_1} [field k] [char_zero k] {m : ℕ} {n : ℕ} (n_dvd : n ∣ m) : ↑(m / n) = ↑m / ↑n := sorry

end nat

protected instance char_zero.infinite (M : Type u_1) [add_monoid M] [HasOne M] [char_zero M] : infinite M :=
  infinite.of_injective coe nat.cast_injective

theorem two_ne_zero' {M : Type u_1} [add_monoid M] [HasOne M] [char_zero M] : bit0 1 ≠ 0 :=
  (fun (this : ↑(bit0 1) ≠ 0) => eq.mp (Eq._oldrec (Eq.refl (↑(bit0 1) ≠ 0)) nat.cast_two) this)
    (iff.mpr nat.cast_ne_zero (of_as_true trivial))

theorem add_self_eq_zero {R : Type u_1} [semiring R] [no_zero_divisors R] [char_zero R] {a : R} : a + a = 0 ↔ a = 0 := sorry

theorem bit0_eq_zero {R : Type u_1} [semiring R] [no_zero_divisors R] [char_zero R] {a : R} : bit0 a = 0 ↔ a = 0 :=
  add_self_eq_zero

@[simp] theorem half_add_self {R : Type u_1} [division_ring R] [char_zero R] (a : R) : (a + a) / bit0 1 = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((a + a) / bit0 1 = a)) (Eq.symm (mul_two a))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * bit0 1 / bit0 1 = a)) (mul_div_cancel a two_ne_zero'))) (Eq.refl a))

@[simp] theorem add_halves' {R : Type u_1} [division_ring R] [char_zero R] (a : R) : a / bit0 1 + a / bit0 1 = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a / bit0 1 + a / bit0 1 = a)) (Eq.symm (add_div a a (bit0 1)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((a + a) / bit0 1 = a)) (half_add_self a))) (Eq.refl a))

theorem sub_half {R : Type u_1} [division_ring R] [char_zero R] (a : R) : a - a / bit0 1 = a / bit0 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a - a / bit0 1 = a / bit0 1)) (propext sub_eq_iff_eq_add)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a = a / bit0 1 + a / bit0 1)) (add_halves' a))) (Eq.refl a))

theorem half_sub {R : Type u_1} [division_ring R] [char_zero R] (a : R) : a / bit0 1 - a = -(a / bit0 1) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a / bit0 1 - a = -(a / bit0 1))) (Eq.symm (neg_sub a (a / bit0 1)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (-(a - a / bit0 1) = -(a / bit0 1))) (sub_half a))) (Eq.refl (-(a / bit0 1))))

namespace with_top

protected instance char_zero {R : Type u_1} [add_monoid R] [HasOne R] [char_zero R] : char_zero (with_top R) :=
  char_zero.mk
    fun (m n : ℕ) (h : ↑m = ↑n) =>
      eq.mp (Eq._oldrec (Eq.refl (↑m = ↑n)) (propext nat.cast_inj))
        (eq.mp (Eq._oldrec (Eq.refl (↑↑m = ↑↑n)) (propext coe_eq_coe))
          (eq.mp (Eq._oldrec (Eq.refl (↑↑m = ↑n)) (Eq.symm (coe_nat n)))
            (eq.mp (Eq._oldrec (Eq.refl (↑m = ↑n)) (Eq.symm (coe_nat m))) h)))


def Ctx := String → Type
abbrev State (Γ : Ctx) := {x : String} → Γ x

constant p {Γ : Ctx} (s : State Γ) : Prop

theorem ex {Γ : Ctx} (s : State Γ) (h : (a : State Γ) → @p Γ a) : @p Γ s :=
  h ‹_›


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

/-!
Let's get started on the second half of the exercise.
-/

lemma equiv_preserves_mono {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
begin
  -- Again I've started with:
  tidy,
  -- Now we want to map the equation in `w` over to `C`.
  -- This is actually a bit of a hassle, and probably deserves custom tactic support. Want to help?
  replace w := congr_arg (λ k, e.inverse.map k) w,
  simp at w,
  sorry

end


import ECTate.Algebra.EllipticCurve.TateInt

open Int Model ValidModel

@[simp] lemma b2_mordell (p) : Model.b2 ⟨0,0,0,0, (p : Int)⟩ = 0 := by simp [b2]
@[simp] lemma b4_mordell (p) : Model.b4 ⟨0,0,0,0, (p : Int)⟩ = 0 := by simp [b4]
@[simp] lemma b6_mordell (p) : Model.b6 ⟨0,0,0,0, (p : Int)⟩ = 4 * p := by simp [b6]
@[simp] lemma b8_mordell (p) : Model.b8 ⟨0,0,0,0, (p : Int)⟩ = 0 := by simp [b8]
@[simp] lemma c4_mordell (p) : Model.c4 ⟨0,0,0,0, (p : Int)⟩ = 0 := by simp [c4]
@[simp]
lemma c6_mordell (p) : Model.c6 ⟨0,0,0,0, (p : Int)⟩ = - 864 * p :=
by
  simp only [c6, b2, mul_zero, add_zero, neg_zero, pow_succ, pow_zero, mul_one, b4, b6,
    zero_add, zero_sub, neg_mul, neg_inj]
  rw [← mul_assoc]
  norm_num

@[simp]
lemma discr_mordell (p) : Model.discr ⟨0,0,0,0, (p : Int)⟩ = - 432 * p ^ 2 :=
by
  -- TODO copying simp only message from problems panel causes panic
  -- but now ive changed the proof, go back in time to see problem
  simp only [discr, b2, mul_zero, add_zero, neg_zero, b8, zero_mul, sub_self, b4,
    pow_succ, pow_zero, mul_one,  b6, zero_add, zero_sub, neg_mul, neg_inj]
  ring

open SurjVal

-- TODO how does unnecessary simpa work
lemma val_discr_mordell (p : ℕ) (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) (h) :
  val_discr_to_nat (primeEVR hp).valtn ⟨⟨0,0,0,0, b⟩, h⟩ = 2 * (nat_of_val (primeEVR hp).valtn (λ hb => by simp [hb] at h : b ≠ 0)) :=
by
  rw [Enat.eq_ofN, ofN_val_discr_to_nat]
  dsimp
  conv =>
    lhs
    rw [discr_mordell]
  simp [neg_mul, val_neg, SurjVal.v_mul_eq_add_v, nat_of_val] -- need simp lemma coe_of_nat_of_val
  norm_num
  convert zero_add (?_ : Enat) -- TODO lean needs help here why, no _
  sorry
  exact rfl
  exact rfl

-- TODO clean up these examples like last
lemma Mordell_KodairaTypeII (p) (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) :
  (tate_algorithm p hp ⟨⟨0, 0, 0, 0, p⟩, by simp [hp.ne_zero]⟩).1 = .II := -- TODO maybe expand this to say more about conductor exponent etc
by
  rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
  generalize h : (⟨⟨0,0,0,0,p⟩, _⟩ : ValidModel ℤ) = e
  have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞ := by
    simp [← h, c4_mordell]
  have valdisc : val_discr_to_nat (primeEVR hp).valtn e = 2 := by
    rw [← h, val_discr_mordell _ _ hn23, nat_of_val]
    simp
  have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 2 := by
    simp [valdisc]
  simp [valc4, valdisc']

lemma Mordell_KodairaTypeIIs (p) (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) :
  (tate_algorithm p hp ⟨⟨0, 0, 0, 0, (p : ℤ)^5⟩, by simp [hp.ne_zero]⟩).1 = .IIs := -- TODO maybe expand this to say more about conductor exponent etc
by
  rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
  generalize h : (⟨⟨0,0,0,0,(p:ℤ)^5⟩, _⟩ : ValidModel ℤ) = e
  have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞ := by
    simp [← h, c4_mordell]
  have valdisc : val_discr_to_nat (primeEVR hp).valtn e = 10 := by
    rw [← h, val_discr_mordell _ _ hn23, nat_of_val]
    simp [SurjVal.v_uniformizer]
  have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 10 := by
    simp [valdisc]
  simp [valc4, valdisc']

lemma Mordell_KodairaTypeIV (p) (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) :
  (tate_algorithm p hp ⟨⟨0, 0, 0, 0, (p : ℤ)^2⟩, by simp [hp.ne_zero]⟩).1 = .IV := -- TODO maybe expand this to say more about conductor exponent etc
by
  rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
  generalize h : (⟨⟨0,0,0,0,(p : ℤ)^2⟩, _⟩ : ValidModel ℤ) = e
  have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞ := by
    simp [← h, c4_mordell]
  have valdisc : val_discr_to_nat (primeEVR hp).valtn e = 4 := by
    rw [← h, val_discr_mordell _ _ hn23, nat_of_val]
    simp
  have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 4 := by
    simp [valdisc]
  simp [valc4, valdisc']

lemma Mordell_KodairaTypeIVs (p) (hp : Nat.Prime p) (hn23 : p ≠ 2 ∧ p ≠ 3) :
  (tate_algorithm p hp ⟨⟨0, 0, 0, 0, (p : ℤ)^4⟩, by simp [hp.ne_zero]⟩).1 = .IVs := -- TODO maybe expand this to say more about conductor exponent etc
by
  rw [tate_algorithm, if_neg hn23.1, if_neg hn23.2, tate_big_prime]
  generalize h : (⟨⟨0,0,0,0,(p : ℤ)^4⟩, _⟩ : ValidModel ℤ) = e
  have valc4 : 3 * (primeEVR hp).valtn e.c4 = ∞; simp [← h, c4_mordell]
  have valdisc' : val_discr_to_nat (primeEVR hp).valtn e % 12 = 8
  . simp [← h, val_discr_mordell _ _ hn23, nat_of_val, c4_mordell]
  simp [valc4, valdisc']


import algebra.homology.homology
import category_theory.abelian.homology

import for_mathlib.commsq
import for_mathlib.exact_lift_desc

/-!

# `has_homology f g H`

If `A B C H` are objects of an abelian category, if `f : A ⟶ B` and if `g : B ⟶ C`, then
a term of type `has_homology f g H` can be thought of as the claim that `H` "is" the
homology of the complex `A ⟶ B ⟶ C`, or, more precisely, as an isomorphism between `H`
and the homology of this complex.

-/

noncomputable theory

universes v u

open category_theory category_theory.limits

variables {𝓐 : Type u} [category.{v} 𝓐] [abelian 𝓐]
variables {A B C : 𝓐} {f : A ⟶ B} {g : B ⟶ C} {H : 𝓐}

/-- If `f : A ⟶ B` and `g : B ⟶ C` are morphisms in an abelian category, then `has_homology f g H`
is the claim that `f ≫ g = 0` and furthermore an identification of `H` with the middle homology of
the corresponding three term exact sequence formed by `f` and `g`. -/
structure has_homology (f : A ⟶ B) (g : B ⟶ C) (H : 𝓐) :=
(w : f ≫ g = 0)
(π : kernel g ⟶ H)
(ι : H ⟶ cokernel f)
(π_ι : π ≫ ι = kernel.ι _ ≫ cokernel.π _)
(ex_π : exact (kernel.lift g f w) π)
(ι_ex : exact ι (cokernel.desc f g w))
[epi_π : epi π]
[mono_ι : mono ι]

-- move me
instance (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) : epi (homology.π' f g w) := epi_comp _ _
-- move me
instance (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) : mono (homology.ι f g w) := mono_comp _ _

/-- If `f ≫ g = 0` then `homology f g w` can be identified with the homology of the three
term exact sequence coming from `f` and `g`. -/
def homology.has (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) :
  has_homology f g (homology f g w) :=
{ w := w,
  π := homology.π' f g w,
  ι := homology.ι f g w,
  π_ι := homology.π'_ι _ _ _,
  ex_π := begin
    delta homology.π',
    rw exact_comp_iso,
    exact abelian.exact_cokernel _
  end,
  ι_ex := begin
    delta homology.ι,
    rw exact_iso_comp,
    exact exact_kernel_ι
  end,
  epi_π := by apply_instance,
  mono_ι := by apply_instance }

lemma homology.has_π {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) :
  (homology.has f g w).π = homology.π' f g w := rfl

lemma homology.has_ι {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) :
  (homology.has f g w).ι = homology.ι f g w := rfl

namespace has_homology

attribute [instance] epi_π mono_ι
attribute [reassoc] π_ι

section misc

@[simp, reassoc] lemma ι_desc (hH : has_homology f g H) : hH.ι ≫ cokernel.desc f g hH.w = 0 :=
hH.ι_ex.w

@[simp, reassoc] lemma lift_π (hH : has_homology f g H) : kernel.lift g f hH.w ≫ hH.π = 0 :=
hH.ex_π.w

def of_iso {H₁ H₂ : 𝓐} (hH : has_homology f g H₁) (i : H₁ ≅ H₂) : has_homology f g H₂ :=
{ w := hH.w,
  π := hH.π ≫ i.hom,
  ι := i.inv ≫ hH.ι,
  π_ι := by simp [hH.π_ι],
  ex_π := exact_comp_iso.2 hH.ex_π,
  ι_ex := exact_iso_comp.2 hH.ι_ex,
  epi_π := epi_comp _ _,
  mono_ι := mono_comp _ _ }

end misc

section degenerate

-- move this; I couldn't find it
lemma exact_iso_comp_snd_iff_exact_comp_iso_fst_iff {D : 𝓐} (f : A ⟶ B) {e : B ⟶ C} (g : C ⟶ D)
  [is_iso e] : exact f (e ≫ g) ↔ exact (f ≫ e) g :=
⟨preadditive.exact_of_iso_of_exact' f (e ≫ g) (f ≫ e) g (iso.refl A) (as_iso e) (iso.refl D)
 (by simp) (by simp), preadditive.exact_of_iso_of_exact' (f ≫ e) g f (e ≫ g) (iso.refl A)
 (as_iso e).symm (iso.refl D) (by simp) (by simp)⟩

 -- move this; I couldn't find it
lemma exact_zero_right_of_epi [epi f] : exact f (0 : B ⟶ C) :=
⟨comp_zero, image_to_kernel_epi_of_epi_of_zero f⟩

local attribute [instance] epi_comp --`mono_comp` is a global instance!

def fst_eq_zero : has_homology (0 : A ⟶ B) g (kernel g) :=
{ w := zero_comp,
  π := 𝟙 _,
  ι := kernel.ι g ≫ cokernel.π 0,
  π_ι := by simp,
  ex_π := begin
    rw kernel.lift_zero,
    exact exact_zero_left_of_mono A,
  end,
  ι_ex := begin
    rw [← exact_iso_comp_snd_iff_exact_comp_iso_fst_iff, cokernel.π_desc],
    exact exact_kernel_ι,
  end,
  epi_π := infer_instance,
  mono_ι := infer_instance }

def snd_eq_zero : has_homology f (0 : B ⟶ C) (cokernel f) :=
{ w := comp_zero,
  π := kernel.ι 0 ≫ cokernel.π f,
  ι := 𝟙 _,
  π_ι := by simp,
  ex_π := begin
    rw [exact_iso_comp_snd_iff_exact_comp_iso_fst_iff, kernel.lift_ι],
    exact abelian.exact_cokernel f,
  end,
  ι_ex := begin
    rw [cokernel.desc_zero],
    exact exact_zero_right_of_epi,
  end,
  epi_π := infer_instance,
  mono_ι := infer_instance }

def snd_eq_zero' (hg : g = 0) : has_homology f g (cokernel f) :=
{ w := hg.symm ▸ comp_zero,
  π := kernel.ι g ≫ cokernel.π f,
  ι := 𝟙 _,
  π_ι := by simp,
  ex_π := begin
    subst hg,
    simp [exact_iso_comp_snd_iff_exact_comp_iso_fst_iff, kernel.lift_ι],
    exact abelian.exact_cokernel f,
  end,
  ι_ex := begin
    subst hg,
    rw [cokernel.desc_zero],
    exact exact_zero_right_of_epi,
  end,
  epi_π := by subst hg; apply_instance,
  mono_ι := infer_instance }

def fst_snd_eq_zero : has_homology (0 : A ⟶ B) (0 : B ⟶ C) B :=
{ w := comp_zero,
  π := kernel.ι 0,
  ι := cokernel.π 0,
  π_ι := rfl,
  ex_π := begin
    rw kernel.lift_zero,
    exact exact_zero_left_of_mono A,
  end,
  ι_ex := begin
    rw cokernel.desc_zero,
    exact exact_zero_right_of_epi,
  end,
  epi_π := infer_instance,
  mono_ι := infer_instance }

def fst_snd_eq_zero' (hf : f = 0) (hg : g = 0) : has_homology f g B :=
{ w := hf.symm ▸ zero_comp,
  π := kernel.ι g,
  ι := cokernel.π f,
  π_ι := rfl,
  ex_π := begin
    subst hf,
    rw kernel.lift_zero,
    exact exact_zero_left_of_mono A,
  end,
  ι_ex := begin
    subst hg,
    rw cokernel.desc_zero,
    exact exact_zero_right_of_epi,
  end,
  epi_π := by subst hg; apply_instance,
  mono_ι := by subst hf; apply_instance }

end degenerate

section ext

lemma ext_π (hH : has_homology f g H) {X : 𝓐} (φ ψ : H ⟶ X) (h : hH.π ≫ φ = hH.π ≫ ψ) : φ = ψ :=
by rwa cancel_epi at h

lemma ext_ι (hH : has_homology f g H) {X : 𝓐} (φ ψ : X ⟶ H) (h : φ ≫ hH.ι = ψ ≫ hH.ι) : φ = ψ :=
by rwa cancel_mono at h

end ext

section lift

variables (hH : has_homology f g H)
variables {X : 𝓐} (φ : X ⟶ cokernel f) (hφ : φ ≫ cokernel.desc f g hH.w = 0)

/-- If ``has_homology f g H` and `φ : X ⟶ cokernel f` composes to zero with the canonical
map `cokernel f ⟶ C` then `has_homology.lift φ` is the morphism `X ⟶ H` which recovers `φ` after
composing with the canonical map `H ⟶ cokernel f` (the statement that the triangle commutes
is `lift_comp_ι`). -/
def lift : X ⟶ H := hH.ι_ex.mono_lift φ hφ

@[simp, reassoc] lemma lift_comp_ι : hH.lift φ hφ ≫ hH.ι = φ := hH.ι_ex.mono_lift_comp φ hφ

lemma lift_unique (e : X ⟶ H) (he : e ≫ hH.ι = φ) : e = hH.lift φ hφ :=
hH.ι_ex.mono_lift_unique _ _ e he

@[simp] lemma lift_ι : hH.lift hH.ι hH.ι_desc = 𝟙 H :=
(hH.lift_unique _ _ _ $ category.id_comp _).symm

lemma π_eq_lift : hH.π = hH.lift (kernel.ι _ ≫ cokernel.π _)
  (by simp only [category.assoc, cokernel.π_desc, kernel.condition]) :=
lift_unique _ _ _ _ hH.π_ι

@[reassoc] lemma comp_lift {X Y : 𝓐} (φ : X ⟶ Y) (ψ : Y ⟶ cokernel f)
  (hψ : ψ ≫ cokernel.desc f g hH.w = 0) : φ ≫ hH.lift ψ hψ = hH.lift (φ ≫ ψ)
  (by rw [category.assoc, hψ, comp_zero]) :=
by { apply lift_unique, rw [category.assoc, lift_comp_ι] }

lemma homology_lift_eq {X Y Z W : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0)
  (φ : W ⟶ cokernel f) (hφ) :
  homology.lift f g w φ hφ = (homology.has f g w).lift φ hφ :=
begin
  ext,
  simp only [homology.lift_ι],
  dsimp [has_homology.lift],
  erw [exact.mono_lift_comp],
end

end lift

section desc

variables (hH : has_homology f g H)
variables {X : 𝓐} (φ : kernel g ⟶ X) (hφ : kernel.lift g f hH.w ≫ φ = 0)

/-- If `has_homology f g H` and `φ : kernel g ⟶ X` becomes zero when precomposed with
the canonical map from `A` to `kernel g`, then `has_homology.desc φ` is the morphism `H ⟶ X` which
recovers `φ` after composing with the canonical map `kernel g ⟶ H`. The proof that this
triangle commutes is `π_comp_desc`. -/
def desc : H ⟶ X := hH.ex_π.epi_desc φ hφ

@[simp, reassoc] lemma π_comp_desc : hH.π ≫ hH.desc φ hφ = φ := hH.ex_π.comp_epi_desc φ hφ

lemma desc_unique (e : H ⟶ X) (he : hH.π ≫ e = φ) : e = hH.desc φ hφ :=
hH.ex_π.epi_desc_unique _ _ e he

@[simp] lemma desc_π : hH.desc hH.π hH.lift_π = 𝟙 H :=
(hH.desc_unique _ _ _ $ category.comp_id _).symm

lemma ι_eq_desc : hH.ι =
  hH.desc (kernel.ι _ ≫ cokernel.π _) (by simp only [kernel.lift_ι_assoc, cokernel.condition]) :=
desc_unique _ _ _ _ hH.π_ι

@[reassoc] lemma desc_comp {X Y : 𝓐} (φ : kernel g ⟶ X) (ψ : X ⟶ Y) (hφ : kernel.lift g f hH.w ≫ φ = 0) :
  hH.desc φ hφ ≫ ψ = hH.desc (φ ≫ ψ) (by rw [reassoc_of hφ, zero_comp]) :=
by { apply desc_unique, rw [π_comp_desc_assoc] }

lemma homology_desc_eq {X Y Z W : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (w)
  (φ : kernel g ⟶ W) (hφ) :
  homology.desc' f g w φ hφ = (homology.has f g w).desc φ hφ :=
begin
  ext,
  simp only [homology.π'_desc'],
  dsimp [has_homology.desc],
  simp only [exact.comp_epi_desc],
end

end desc

section map

variables {A₁ B₁ C₁ H₁ A₂ B₂ C₂ H₂ A₃ B₃ C₃ H₃ : 𝓐}
variables {f₁ : A₁ ⟶ B₁} {g₁ : B₁ ⟶ C₁} (h₁ : has_homology f₁ g₁ H₁)
variables {f₂ : A₂ ⟶ B₂} {g₂ : B₂ ⟶ C₂} (h₂ : has_homology f₂ g₂ H₂)
variables {f₃ : A₃ ⟶ B₃} {g₃ : B₃ ⟶ C₃} (h₃ : has_homology f₃ g₃ H₃)
variables {α : A₁ ⟶ A₂} {β : B₁ ⟶ B₂} {γ : C₁ ⟶ C₂}
variables {α' : A₂ ⟶ A₃} {β' : B₂ ⟶ B₃} {γ' : C₂ ⟶ C₃}
variables (sq1 : commsq f₁ α β f₂) (sq2 : commsq g₁ β γ g₂)
variables (sq1' : commsq f₂ α' β' f₃) (sq2' : commsq g₂ β' γ' g₃)

include h₁ h₂ sq1 sq2

/-- If `h₁ : has_homology f₁ g₁ H₁` and `h₂ : has_homology f₂ g₂ H₂` then given compatible morphisms
`f₁ ⟶ g₁` and `f₂ ⟶ g₂`, `has_homology.map h₁ h₂` is the induced morphism `H₁ ⟶ H₂`. -/
def map : H₁ ⟶ H₂ :=
h₁.desc (h₂.lift (kernel.ι _ ≫ β ≫ cokernel.π _) $
  by simp only [category.assoc, cokernel.π_desc, ← sq2.w, kernel.condition_assoc, zero_comp]) $
begin
  apply h₂.ext_ι,
  simp only [category.assoc, zero_comp, h₂.lift_comp_ι, kernel.lift_ι_assoc, sq1.w_assoc,
    cokernel.condition, comp_zero],
end

omit h₁ h₂ sq1 sq2

@[simp, reassoc] lemma π_map :
  h₁.π ≫ h₁.map h₂ sq1 sq2 = (h₂.lift (kernel.ι _ ≫ β ≫ cokernel.π _) $
  by simp only [category.assoc, cokernel.π_desc, ← sq2.w, kernel.condition_assoc, zero_comp]) :=
h₁.π_comp_desc _ _

@[simp, reassoc] lemma map_ι :
  h₁.map h₂ sq1 sq2 ≫ h₂.ι = (h₁.desc (kernel.ι _ ≫ β ≫ cokernel.π _) $
  by simp only [kernel.lift_ι_assoc, sq1.w_assoc, cokernel.condition, comp_zero]) :=
by { apply h₁.desc_unique, rw [h₁.π_map_assoc, h₂.lift_comp_ι] }

lemma π_map_ι : h₁.π ≫ h₁.map h₂ sq1 sq2 ≫ h₂.ι = kernel.ι _ ≫ β ≫ cokernel.π _ := by simp

lemma homology_map_eq (w₁ : f₁ ≫ g₁ = 0) (w₂ : f₂ ≫ g₂ = 0)
  (e₁ : α ≫ (arrow.mk f₂).hom = (arrow.mk f₁).hom ≫ β)
  (e₂ : β ≫ (arrow.mk g₂).hom = (arrow.mk g₁).hom ≫ γ) :
  homology.map w₁ w₂ (arrow.hom_mk e₁) (arrow.hom_mk e₂) rfl =
  (homology.has f₁ g₁ w₁).map (homology.has f₂ g₂ w₂)
  (commsq.of_eq e₁.symm) (commsq.of_eq e₂.symm) :=
begin
  --- I don't think using `exact.epi_desc` and `exact.mono_desc` is a good choice...
  rw homology.map_eq_desc'_lift_left,
  apply (homology.has _ _ w₁).ext_π,
  apply (homology.has _ _ w₂).ext_ι,
  simp [homology_lift_eq, homology_desc_eq],
end

lemma homology_map_eq' (w₁ : f₁ ≫ g₁ = 0) (w₂ : f₂ ≫ g₂ = 0) :
  homology.map w₁ w₂ ⟨α, β, sq1.w.symm⟩ ⟨β, γ, sq2.w.symm⟩ rfl =
  (homology.has f₁ g₁ w₁).map (homology.has f₂ g₂ w₂) sq1 sq2 :=
homology_map_eq _ _ _ _

lemma eq_map_of_π_map_ι (φ : H₁ ⟶ H₂) (hφ : h₁.π ≫ φ ≫ h₂.ι = kernel.ι g₁ ≫ β ≫ cokernel.π f₂) :
  φ = h₁.map h₂ sq1 sq2 :=
by rwa [← π_map_ι h₁ h₂ sq1 sq2, cancel_epi, cancel_mono] at hφ

@[simp, reassoc] lemma lift_map
  {X : 𝓐} (φ : X ⟶ cokernel f₁) (hφ : φ ≫ cokernel.desc f₁ g₁ h₁.w = 0) :
  h₁.lift φ hφ ≫ h₁.map h₂ sq1 sq2 = h₂.lift (φ ≫ cokernel.map f₁ f₂ α β sq1.w)
    (by { rw [category.assoc, cokernel.map_desc, reassoc_of hφ, zero_comp], exact sq2.w }) :=
begin
  apply lift_unique, rw [category.assoc, map_ι],
  conv_rhs { rw [← lift_comp_ι h₁ φ hφ, category.assoc] },
  congr' 1,
  apply h₁.ext_π,
  rw [π_comp_desc, π_ι_assoc, cokernel.π_desc],
end

-- move this
attribute [reassoc] limits.kernel.lift_map

@[simp, reassoc] lemma map_desc
  {X : 𝓐} (φ : kernel g₂ ⟶ X) (hφ : kernel.lift g₂ f₂ h₂.w ≫ φ = 0) :
  h₁.map h₂ sq1 sq2 ≫ h₂.desc φ hφ = h₁.desc (kernel.map g₁ g₂ β γ sq2.w ≫ φ)
    (by { rw [category_theory.limits.kernel.lift_map_assoc, hφ, comp_zero], exact sq1.w }) :=
begin
  apply desc_unique, rw [π_map_assoc],
  conv_rhs { rw [← π_comp_desc h₂ φ hφ, ← category.assoc] },
  congr' 1,
  apply h₂.ext_ι,
  rw [lift_comp_ι, category.assoc, π_ι, kernel.lift_ι_assoc, category.assoc],
end

/-- Gluing two commutative squares "vertically" (the convention is that `f`s and `g`s are
horizontal morphisms, and `α`s and `β`s are vertical morphisms). -/
def _root_.commsq.vcomp : commsq f₁ (α ≫ α') (β ≫ β') f₃ :=
commsq.of_eq $
calc f₁ ≫ β ≫ β' = α ≫ f₂ ≫ β'   : sq1.w_assoc β'
              ... = α ≫ α' ≫ f₃   : congr_arg _ $ sq1'.w
              ... = (α ≫ α') ≫ f₃ : (category.assoc _ _ _).symm

/-- A commutative square with identity isomorphisms for the two vertical maps. -/
def _root_.commsq.vrefl (f : A ⟶ B) : commsq f (iso.refl _).hom (iso.refl _).hom f :=
commsq.of_eq $ by rw [iso.refl_hom, iso.refl_hom, category.id_comp, category.comp_id]

/-- The reflection of a vertical square with isomorphisms for the vertical maps. -/
def _root_.commsq.vinv {α : A₁ ≅ A₂} {β : B₁ ≅ B₂} (sq1 : commsq f₁ α.hom β.hom f₂) :
  commsq f₂ α.inv β.inv f₁ :=
commsq.of_eq $ by rw [iso.comp_inv_eq, category.assoc, iso.eq_inv_comp, sq1.w]

lemma map_comp_map :
  h₁.map h₂ sq1 sq2 ≫ h₂.map h₃ sq1' sq2' = h₁.map h₃ (sq1.vcomp sq1') (sq2.vcomp sq2') :=
begin
  apply h₁.ext_π, apply h₃.ext_ι,
  simp only [category.assoc, map_ι, map_desc, π_comp_desc, kernel.lift_ι_assoc],
end

lemma map_id (h : has_homology f g H) {α : A ⟶ A} {β : B ⟶ B} {γ : C ⟶ C}
  (sq1 : commsq f α β f) (sq2 : commsq g β γ g) (hβ : β = 𝟙 _) :
  h.map h sq1 sq2 = 𝟙 H :=
begin
  apply h.ext_π, apply h.ext_ι,
  rw [π_map, lift_comp_ι, category.comp_id, π_ι, hβ, category.id_comp],
end

/- The isomorphism on `has_homology` induced by isomorphisms `f₁ ≅ f₂` and `g₁ ≅ g₂`. -/
@[simps] def map_iso {α : A₁ ≅ A₂} {β : B₁ ≅ B₂} {γ : C₁ ≅ C₂}
  (sq1 : commsq f₁ α.hom β.hom f₂) (sq2 : commsq g₁ β.hom γ.hom g₂) :
  H₁ ≅ H₂ :=
{ hom := h₁.map h₂ sq1 sq2,
  inv := h₂.map h₁ sq1.vinv sq2.vinv,
  hom_inv_id' := by { rw [map_comp_map, map_id], exact β.hom_inv_id },
  inv_hom_id' := by { rw [map_comp_map, map_id], exact β.inv_hom_id } }

/- The canonical isomorphism between H₁ and H₂ if both satisfy `has_homology f g Hᵢ`. -/
abbreviation iso (h₁ : has_homology f g H₁) (h₂ : has_homology f g H₂) :
  H₁ ≅ H₂ :=
map_iso h₁ h₂ (_root_.commsq.vrefl f) (_root_.commsq.vrefl g)

lemma iso_inv (h₁ : has_homology f g H₁) (h₂ : has_homology f g H₂) :
  (iso h₁ h₂).inv = (iso h₂ h₁).hom := rfl

lemma π_iso (h₁ : has_homology f g H₁) (h₂ : has_homology f g H₂) :
  h₁.π ≫ (h₁.iso h₂).hom = h₂.π :=
begin
  simp only [iso.refl_hom, category.id_comp, map_iso_hom, π_map],
  exact (π_eq_lift h₂).symm,
end

lemma iso_ι (h₁ : has_homology f g H₁) (h₂ : has_homology f g H₂) :
  (h₁.iso h₂).hom ≫ h₂.ι = h₁.ι :=
begin
  simp only [iso.refl_hom, category.id_comp, map_iso_hom, map_ι],
  exact (ι_eq_desc h₁).symm,
end

lemma map_iso_homology_map :
has_homology.map h₁ h₂ sq1 sq2 = (has_homology.iso h₁ (homology.has f₁ g₁ h₁.w)).hom ≫
  (homology.map h₁.w h₂.w ⟨α, β, sq1.w.symm⟩ ⟨β, γ, sq2.w.symm⟩ rfl) ≫
  (has_homology.iso h₂ (homology.has f₂ g₂ h₂.w)).inv:=
begin
  apply h₁.ext_π,
  apply h₂.ext_ι,
  simp [homology_map_eq'],
end

end map

section op

open opposite

def op (h : has_homology f g H) : has_homology g.op f.op (op H) :=
{ w := by rw [← op_comp, h.w, op_zero],
  π := (kernel_op_op f).hom ≫ h.ι.op,
  ι := h.π.op ≫ (cokernel_op_op g).inv,
  π_ι := by {
    simp only [kernel_op_op_hom, cokernel_op_op_inv, ← op_comp, category.assoc, h.π_ι_assoc,
      kernel.lift_ι_assoc, cokernel.π_desc], refl, },
  ex_π := begin
    rw [← exact_comp_hom_inv_comp_iff (kernel_op_op f), iso.inv_hom_id_assoc, kernel_op_op_hom],
    convert h.ι_ex.op using 1,
    apply quiver.hom.unop_inj,
    apply category_theory.limits.coequalizer.hom_ext,
    erw [unop_comp, coequalizer.π_desc_assoc, coequalizer.π_desc],
    rw [← unop_comp, kernel.lift_ι, g.unop_op],
  end,
  ι_ex := begin
    rw [← exact_comp_hom_inv_comp_iff (cokernel_op_op g), category.assoc, iso.inv_hom_id,
      category.comp_id, cokernel_op_op_inv],
    convert h.ex_π.op using 1,
    apply quiver.hom.unop_inj,
    apply category_theory.limits.equalizer.hom_ext,
    erw [unop_comp, equalizer.lift_ι, category.assoc, equalizer.lift_ι],
    rw [← unop_comp, cokernel.π_desc, f.unop_op],
  end,
  epi_π := epi_comp _ _,
  mono_ι := mono_comp _ _ }

-- @[simps]
def homology_unop_iso {A B C : 𝓐ᵒᵖ} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) :
  homology f g w ≅ opposite.op (homology g.unop f.unop (by { rw [← unop_comp, w, unop_zero] })) :=
(homology.has f g w).iso (homology.has g.unop f.unop _).op

def homology_op_iso {A B C : 𝓐} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) :
  homology g.op f.op (by rw [← op_comp, w, op_zero]) ≅ opposite.op (homology f g w) :=
homology_unop_iso _ _ _

end op

end has_homology


import Mathlib.Data.Nat.Basic
import Lean.Elab.Tactic.Basic
import Mathlib.Tactic.NormNum
import Mathlib.Tactic.Clear!
import Mathlib.Util.AtomM
import Logic.Vorspiel.Vorspiel

open Qq Lean Elab Meta Tactic

universe u v

namespace Qq

def rflQ {α : Q(Sort u)} (a : Q($α)) : Q($a = $a) := q(rfl)

set_option linter.unusedVariables false in
def decideTQ (p : Q(Prop)) : MetaM Q($p) := do
  let dec : Q(Decidable $p) ← synthInstanceQ q(Decidable $p)
  let h : Q(decide $p = true) := rflQ q(true)
  return q(of_decide_eq_true $h)

def finQVal {n : Q(ℕ)} (e : Q(Fin $n)) : MetaM (Option ℕ) := do
  let val : Q(ℕ) ← whnf q(Fin.val $e)
  val.natLit?

-- Returns literal f e when e is literal
def natAppFunQ (f : ℕ → ℕ) (e : Q(ℕ)) : MetaM Q(ℕ) := do
  let e : Q(ℕ) ← whnf e
  let some n := Lean.Expr.natLit? e | throwError "not ℕ"
  Lean.Expr.ofNat q(ℕ) (f n)

-- https://leanprover-community.github.io/mathlib4_docs//Mathlib/Tactic/Linarith/Verification.html#Qq.inferTypeQ'
def inferSortQ' (e : Expr) : MetaM ((u : Level) × (α : Q(Sort $u)) × Q($α)) := do
  let α ← inferType e
  let .sort u ← instantiateMVars (← whnf (← inferType α))
    | throwError "not a type{indentExpr α}"
  pure ⟨u, α, e⟩

-- given an Expr e representing type α : Sort u, returns u and q(α)
def checkSortQ' (e : Expr) : MetaM (Option ((u : Level) × Q(Sort $u))) := do
  if let ⟨.succ u, α, e⟩ ← inferSortQ' e then
    if ← isDefEq α q(Sort $u) then
      return some ⟨u, e⟩
    else return none
  else return none

def inferSortQOfUniverse' (e : Expr) (ty : Q(Sort $u)) : MetaM (Option Q($ty)) := do
  if let ⟨.succ _, α, e⟩ ← inferSortQ' e then
    if ← isDefEq α q($ty) then
      return some e
    else return none
  else return none

set_option linter.unusedVariables false in
def MditeQ {α : Q(Sort u)} (c : Q(Prop)) (dec : Q(Decidable $c)) (t : MetaM Q($c → $α)) (e : MetaM Q(¬$c → $α)) : MetaM Q($α) := do
  let t ← t
  let e ← e
  return q(dite $c (fun h => $t h) (fun h => $e h))

class NormalizeQ (α : Q(Type u)) where
  normalize : (e : Q($α)) → MetaM ((res : Q($α)) × Q($res = $e))

structure Result (α : Q(Type u)) (e : Q($α)) where
  expr : Q($α)
  proof : Q($e = $expr)

namespace Result
variable  {α : Q(Type u)}

@[reducible] def refl (e : Q($α)) : Result α e := ⟨e, q(rfl)⟩

end Result

set_option linter.unusedVariables false in
def BEqQ {α : Q(Sort u)} {a b : Q($α)} (h : a == b) : Q($a = $b) := (q(@rfl $α $a) : Expr)

def eqQUnsafe {α : Q(Sort u)} (a b : Q($α)) : Q($a = $b) := (q(@rfl $α $a) : Expr)

def toQList {α : Q(Type u)} : List Q($α) → Q(List $α)
  | []     => q([])
  | a :: v => q($a :: $(toQList v))

section List
variable {α : Type u}

lemma List.mem_of_eq {a b : α} {l} (h : a = b) : a ∈ b :: l := by simp[h]

lemma List.mem_of_mem {a b : α} {l : List α} (h : a ∈ l) : a ∈ b :: l := by simp[h]

def toQListOfElem {α : Q(Type u)} {a : Q($α)} : {l : List Q($α)} → l.elem a → Q($a ∈ $(toQList (u := u) l))
  | [],     h => by contradiction
  | b :: l, h =>
      match be : a == b with
      | true =>
        let e : Q($a = $b) := rflQ a
        q(List.mem_of_eq $e)
      | false =>
        let ih : Q($a ∈ $(toQList (u := u) l)) := toQListOfElem (by simpa[be] using h)
        q(List.mem_of_mem $ih)

example : 2 ∈ [3,4,5,2,6] := of_decide_eq_true rfl

lemma List.cons_congr {a b : α} {l k : List α} (ha : a = b) (hl : l = k) : a :: l = b :: k :=
  congr_arg₂ _ ha hl

def resultList {α : Q(Type u)} (res : (a : Q($α)) → MetaM ((res : Q($α)) × Q($a = $res))) :
    (l : List Q($α)) → MetaM ((lres : List Q($α)) × Q($(toQList (u := u) l) = $(toQList (u := u) lres)))
  | []     => pure ⟨[], q(rfl)⟩
  | a :: l => do
    let ⟨an, e⟩ ← res a
    let ⟨ihl, ihe⟩ ← resultList res l
    return ⟨an :: ihl, q(List.cons_congr $e $ihe)⟩

def funResultList {α β : Q(Type u)} (f : Q($α → $β)) (res : (a : Q($α)) → MetaM ((res : Q($β)) × Q($f $a = $res))) :
    (l : List Q($α)) → MetaM ((lres : List Q($β)) × Q(List.map $f $(toQList (u := u) l) = $(toQList (u := u) lres)))
  | []     => pure ⟨[], q(rfl)⟩
  | a :: l => do
    let ⟨an, e⟩ ← res a
    let ⟨ihl, ihe⟩ ← funResultList f res l
    return ⟨an :: ihl, q(List.cons_congr $e $ihe)⟩

end List

end Qq


import LTS property_catalogue.LTL.patterns tactic proof_state

open tactic

variable {M : LTS}
variable {α : Type}

namespace absent
namespace globally

lemma by_partition_before_aft {π : path M} (P S : formula M) :
    (sat (exist.globally S) π ) → (sat (absent.before P S) π) → (sat (absent.after P S) π) → (sat (absent.globally P) π) :=
begin
    intros H1 H2 H3,
    rw absent.globally, rw sat,
    rw exist.globally at H1, rw sat at H1,
    rw absent.before at H2, iterate 3 {rw sat at H2},
    rw absent.after at H3, iterate 3 {rw sat at H3},
    simp at *,
    cases H1 with k H1,
    intro i,
    replace H2 := H2 k,
    replace H2 := H2 H1,
    cases H2 with w H2,
    have EM : (i < w) ∨ ¬ (i < w), from em (i<w),
    cases EM,
    apply H2.2,
    assumption,
    simp at EM,
    replace H3 := H3 w,
    cases H2 with L R,
    replace H3 := H3 L,
    have : ∃ j, i = w + j, from le_iff_exists_add.mp EM,
    cases this with j H4, rw H4,
    replace H3 := H3 j,
    rw path.drop_drop at H3,
    assumption,
end

meta def solve_by_partition (tok1 tok2 : expr) (ps : PROOF_STATE α ): tactic (PROOF_STATE α) :=
do
  tactic.interactive.apply ``(by_partition_before_aft %%tok1 %%tok2),
  return ps
-- t1 ← tok1.log_format, t2 ← tok2.log_format,
--  s.log $ "apply by_partition_before_aft" ++ t1 ++ t2 ++ "\n"

meta def solve (tok : expr) (ps : PROOF_STATE α) : list expr → tactic (PROOF_STATE α)
| [] :=  return ps
| (h::t) :=
   do typ ← infer_type h,
   match typ with
   | `(sat (absent.before %%tok %%new) %%path):=
   do {ps ←  solve_by_partition tok new ps, return ps }<|> solve t
   | `(sat (absent.after %%tok %%new) %%path) :=
   do {ps ← solve_by_partition tok new ps, return ps }<|> solve t
   | _ := do solve t
   end

end globally

namespace between

theorem absent_between_response {M : LTS} {p : path M} { B I C : formula M} ( A : formula M) :
(sat (responds.globally  (C) (A) ) p) ∧
(sat (absent.between (B) (C) (A)) p) ∧
(sat (absent.between (B) (A) (I)) p)→ (sat (absent.between (B) (C) (I)) p) :=
begin rintros ⟨ H1, H2, H3⟩,
intro i,
replace H1 := H1 i,
intro Hcond, cases Hcond with L R,
replace H1 := H1 L,
rw absent.between at H2,
have : ((p.drop i) ⊨ (C &  ◆A)), by {rw sat, split,assumption,assumption},
replace H2 := H2 (i) this,
cases H1 with w Hw,
cases R with k Hk,
clear this,
cases H2 with z Hz,
cases Hz with z1 z2,
have : k < z ∨ ¬ (k < z), from or_not,
cases this,
use k,
split, assumption,
intros j Hj,
have fact : j < z, by omega,
replace z2 := z2 j fact, assumption,
simp at this,
have EM : z = k ∨ z < k, by omega,
clear this,
cases EM, use k,
split, assumption, rw ← EM, assumption,
replace H3 := H3 (i+z),
rw ← path.drop_drop at H3,
have help : (((p.drop i).drop z) ⊨ ◆(I)), by {use (k-z),
rw path.drop_drop, rw path.drop_drop,have : i + (z + (k - z)) = i+k, by omega, rw this, rw ← path.drop_drop, assumption,},
have : ( ((p.drop i).drop z) ⊨  (A &  ◆I)), by {rw sat, split, assumption, assumption,},
clear help, replace H3 := H3 this,
cases H3 with t Ht,
clear this,
cases Ht with Ht Ht',
rw path.drop_drop at *,
use (z+t),split,
assumption,
intros j Hj,
have : j < z ∨ ¬ (j < z), from or_not,
cases this, replace z2 := z2 j this,
assumption,
simp at this,
have EM' : z = j ∨ z < j, by omega,
cases EM', rw EM' at Hj,
replace Ht' := Ht' 0 _,
rw path.drop_drop at Ht',
rw← EM',
simp at Ht', rw path.drop_drop,assumption,
omega,
clear this,
replace Ht' := Ht' (j-z),
rw path.drop_drop at Ht',
have : (i + z + (j - z)) = (i + j), by omega,
rw this at Ht',
rw path.drop_drop,
 apply Ht', omega,
end

theorem foo {M : LTS} {P Q R : formula M} {x : path M} : (x ⊨ R ⇒ (P W Q)) ↔ (x ⊨ R ⇒ (P U Q)) ∨ (x ⊨ R ⇒ ◾ P) :=
begin
split,
intro H,
rw sat at H,
rw sat.weak_until at H,
rw imp_or_distrib at H,
cases H,
right, assumption,
left, assumption,
intro H,
rw sat,
rw sat.weak_until,
cases H,
intro Hr, replace H := H Hr,
right, assumption,
intro Hr, replace H := H Hr,left, assumption,
end

theorem absent_after_between_response {M : LTS} {p : path M} { B I C : formula M} ( A : formula M) :
(sat (responds.globally  (C) (A) ) p) ∧
(sat (absent.between (B) (C) (A)) p) ∧
(sat (absent.after_until (B) (A) (I)) p)→ (sat (absent.after_until (B) (C) (I)) p) :=
begin
  rintros ⟨H1, H2, H3⟩,
  rw after_until,
  intro i,
  rw foo,
  left,
  apply absent_between_response A,split,assumption,
  split,assumption,
  clear H2, clear H1,clear i,
  rw after_until at H3,
  rw between,
  intros i H,
  replace H3 := H3 i H,
  cases H with L R,
  cases H3,
  cases R with w Hw, use w, split, assumption,
  intros i _,
  replace H3 := H3 i, assumption, assumption,
end

meta def solve_by_absent_between_response (A : expr) (ps : PROOF_STATE α): tactic (PROOF_STATE α) :=
do
  tactic.interactive.apply ``(absent_between_response %%A),
  repeat1 (applyc `and.intro), `[repeat {assumption}],
  return ps

meta def solve  (ps : PROOF_STATE α) : list expr → tactic (PROOF_STATE α)
| [] :=  return ps
| (h::t) :=
   do typ ← infer_type h,
   match typ with
   | `(sat (responds.globally %%C %%A) _):=
    do {ps ← solve_by_absent_between_response A ps, return ps} <|> solve t
   | _ := do solve t
   end

end between

namespace after_until

theorem from_absent_between_response {M : LTS} {p : path M} { B I C : formula M} ( A : formula M) :
(sat (responds.globally  (C) (A) ) p) ∧
(sat (absent.between (B) (C) (A)) p) ∧
(sat (absent.after_until (B) (A) (I)) p)→ (sat (absent.after_until (B) (C) (I)) p) :=
begin
  rintros ⟨H1, H2, H3⟩,
  rw after_until,
  intro i,
  rw between.foo,
  left,
  apply between.absent_between_response A,split,assumption,
  split,assumption,
  clear H2, clear H1,clear i,
  rw after_until at H3,
  rw between,
  intros i H,
  replace H3 := H3 i H,
  cases H with L R,
  cases H3,
  cases R with w Hw, use w, split, assumption,
  intros i _,
  replace H3 := H3 i, assumption, assumption,
end

meta def solve_by_absent_between_response (A : expr) (ps : PROOF_STATE α): tactic (PROOF_STATE α) :=
do
  tactic.interactive.apply ``(from_absent_between_response %%A),
  ps ← ps.log "apply absent.after_until.from_absent_between_response",
  let ps := {used := ps.used ++ ["apply absent.after_until.from_absent_between_response"], ..ps},
  repeat1 (applyc `and.intro), `[repeat {assumption}],
  ps ← ps.log "match_premises",
  return {used := ps.used ++ ["match_premises"], ..ps}

meta def solve  (ps : PROOF_STATE α) : list expr → tactic (PROOF_STATE α)
| [] :=  return ps
| (h::t) :=
   do typ ← infer_type h,
   match typ with
   | `(sat (responds.globally %%C %%A) _):=
     do {ps ← solve_by_absent_between_response A ps, return ps} <|> solve t
   | _ := do solve t
   end

end after_until

end absent


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

! This file was ported from Lean 3 source module category_theory.monoidal.Mod
! leanprover-community/mathlib commit 7013e5b7c9aba9a165023c1f20cd8d238d58f433
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.Mon_

/-!
# The category of module objects over a monoid object.
-/

universe v₁ v₂ u₁ u₂

open CategoryTheory

open CategoryTheory.MonoidalCategory

variable (C : Type u₁) [Category.{v₁} C] [MonoidalCategory.{v₁} C]

variable {C}

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A module object for a monoid object, all internal to some monoidal category. -/
structure ModCat (A : Mon_ C) where
  pt : C
  act : A.pt ⊗ X ⟶ X
  one_act' : (A.one ⊗ 𝟙 X) ≫ act = (λ_ X).Hom := by obviously
  assoc' : (A.mul ⊗ 𝟙 X) ≫ act = (α_ A.pt A.pt X).Hom ≫ (𝟙 A.pt ⊗ act) ≫ act := by obviously
#align Mod ModCat

restate_axiom ModCat.one_act'

restate_axiom ModCat.assoc'

attribute [simp, reassoc.1] ModCat.one_act ModCat.assoc

namespace ModCat

variable {A : Mon_ C} (M : ModCat A)

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem assoc_flip :
    (𝟙 A.pt ⊗ M.act) ≫ M.act = (α_ A.pt A.pt M.pt).inv ≫ (A.mul ⊗ 𝟙 M.pt) ≫ M.act := by simp
#align Mod.assoc_flip ModCat.assoc_flip

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A morphism of module objects. -/
@[ext]
structure Hom (M N : ModCat A) where
  Hom : M.pt ⟶ N.pt
  act_hom' : M.act ≫ hom = (𝟙 A.pt ⊗ hom) ≫ N.act := by obviously
#align Mod.hom ModCat.Hom

restate_axiom hom.act_hom'

attribute [simp, reassoc.1] hom.act_hom

/-- The identity morphism on a module object. -/
@[simps]
def id (M : ModCat A) : Hom M M where Hom := 𝟙 M.pt
#align Mod.id ModCat.id

instance homInhabited (M : ModCat A) : Inhabited (Hom M M) :=
  ⟨id M⟩
#align Mod.hom_inhabited ModCat.homInhabited

/-- Composition of module object morphisms. -/
@[simps]
def comp {M N O : ModCat A} (f : Hom M N) (g : Hom N O) : Hom M O where Hom := f.Hom ≫ g.Hom
#align Mod.comp ModCat.comp

instance : Category (ModCat A) where
  Hom M N := Hom M N
  id := id
  comp M N O f g := comp f g

@[simp]
theorem id_hom' (M : ModCat A) : (𝟙 M : Hom M M).Hom = 𝟙 M.pt :=
  rfl
#align Mod.id_hom' ModCat.id_hom'

@[simp]
theorem comp_hom' {M N K : ModCat A} (f : M ⟶ N) (g : N ⟶ K) :
    (f ≫ g : Hom M K).Hom = f.Hom ≫ g.Hom :=
  rfl
#align Mod.comp_hom' ModCat.comp_hom'

variable (A)

/-- A monoid object as a module over itself. -/
@[simps]
def regular : ModCat A where
  pt := A.pt
  act := A.mul
#align Mod.regular ModCat.regular

instance : Inhabited (ModCat A) :=
  ⟨regular A⟩

/-- The forgetful functor from module objects to the ambient category. -/
def forget : ModCat A ⥤ C where
  obj A := A.pt
  map A B f := f.Hom
#align Mod.forget ModCat.forget

open CategoryTheory.MonoidalCategory

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- A morphism of monoid objects induces a "restriction" or "comap" functor
between the categories of module objects.
-/
@[simps]
def comap {A B : Mon_ C} (f : A ⟶ B) : ModCat B ⥤ ModCat A
    where
  obj M :=
    { pt := M.pt
      act := (f.Hom ⊗ 𝟙 M.pt) ≫ M.act
      one_act' := by
        slice_lhs 1 2 => rw [← comp_tensor_id]
        rw [f.one_hom, one_act]
      assoc' :=
        by
        -- oh, for homotopy.io in a widget!
        slice_rhs 2 3 => rw [id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
        rw [id_tensor_comp]
        slice_rhs 4 5 => rw [ModCat.assoc_flip]
        slice_rhs 3 4 => rw [associator_inv_naturality]
        slice_rhs 2 3 => rw [← tensor_id, associator_inv_naturality]
        slice_rhs 1 3 => rw [iso.hom_inv_id_assoc]
        slice_rhs 1 2 => rw [← comp_tensor_id, tensor_id_comp_id_tensor]
        slice_rhs 1 2 => rw [← comp_tensor_id, ← f.mul_hom]
        rw [comp_tensor_id, category.assoc] }
  map M N g :=
    { Hom := g.Hom
      act_hom' := by
        dsimp
        slice_rhs 1 2 => rw [id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
        slice_rhs 2 3 => rw [← g.act_hom]
        rw [category.assoc] }
#align Mod.comap ModCat.comap

-- Lots more could be said about `comap`, e.g. how it interacts with
-- identities, compositions, and equalities of monoid object morphisms.
end ModCat


/-
Copyright (c) 2021 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin
-/
import topology.order.lattice
import analysis.normed.group.basic
import algebra.order.lattice_group

/-!
# Normed lattice ordered groups

Motivated by the theory of Banach Lattices, we then define `normed_lattice_add_comm_group` as a
lattice with a covariant normed group addition satisfying the solid axiom.

## Main statements

We show that a normed lattice ordered group is a topological lattice with respect to the norm
topology.

## References

* [Meyer-Nieberg, Banach lattices][MeyerNieberg1991]

## Tags

normed, lattice, ordered, group
-/

/-!
### Normed lattice orderd groups

Motivated by the theory of Banach Lattices, this section introduces normed lattice ordered groups.
-/

local notation `|`a`|` := abs a

/--
Let `α` be a normed commutative group equipped with a partial order covariant with addition, with
respect which `α` forms a lattice. Suppose that `α` is *solid*, that is to say, for `a` and `b` in
`α`, with absolute values `|a|` and `|b|` respectively, `|a| ≤ |b|` implies `∥a∥ ≤ ∥b∥`. Then `α` is
said to be a normed lattice ordered group.
-/
class normed_lattice_add_comm_group (α : Type*)
  extends normed_group α, lattice α :=
(add_le_add_left : ∀ a b : α, a ≤ b → ∀ c : α, c + a ≤ c + b)
(solid : ∀ a b : α, |a| ≤ |b| → ∥a∥ ≤ ∥b∥)

lemma solid {α : Type*} [normed_lattice_add_comm_group α] {a b : α} (h : |a| ≤ |b|) : ∥a∥ ≤ ∥b∥ :=
normed_lattice_add_comm_group.solid a b h

noncomputable instance : normed_lattice_add_comm_group ℝ :=
{ add_le_add_left := λ _ _ h _, add_le_add le_rfl h,
  solid := λ _ _, id, }
/--
A normed lattice ordered group is an ordered additive commutative group
-/
@[priority 100] -- see Note [lower instance priority]
instance normed_lattice_add_comm_group_to_ordered_add_comm_group {α : Type*}
  [h : normed_lattice_add_comm_group α] : ordered_add_comm_group α := { ..h }

/--
Let `α` be a normed group with a partial order. Then the order dual is also a normed group.
-/
@[priority 100] -- see Note [lower instance priority]
instance {α : Type*} : Π [normed_group α], normed_group (order_dual α) := id

variables {α : Type*} [normed_lattice_add_comm_group α]
open lattice_ordered_comm_group

lemma dual_solid (a b : α) (h: b⊓-b ≤ a⊓-a) : ∥a∥ ≤ ∥b∥ :=
begin
  apply solid,
  rw abs_eq_sup_neg,
  nth_rewrite 0 ← neg_neg a,
  rw ← neg_inf_eq_sup_neg,
  rw abs_eq_sup_neg,
  nth_rewrite 0 ← neg_neg b,
  rwa [← neg_inf_eq_sup_neg, neg_le_neg_iff, @inf_comm _ _ _ b, @inf_comm _ _ _ a],
end

/--
Let `α` be a normed lattice ordered group, then the order dual is also a
normed lattice ordered group.
-/
@[priority 100] -- see Note [lower instance priority]
instance : normed_lattice_add_comm_group (order_dual α) :=
{ add_le_add_left := begin
    intros a b h₁ c,
    rw ← order_dual.dual_le,
    rw ← order_dual.dual_le at h₁,
    exact add_le_add_left h₁ _,
  end,
  solid := begin
    intros a b h₂,
    apply dual_solid,
    rw ← order_dual.dual_le at h₂,
    exact h₂,
  end, }

lemma norm_abs_eq_norm (a : α) : ∥|a|∥ = ∥a∥ :=
(solid (abs_abs a).le).antisymm (solid (abs_abs a).symm.le)

lemma norm_inf_sub_inf_le_add_norm (a b c d : α) : ∥a ⊓ b - c ⊓ d∥ ≤ ∥a - c∥ + ∥b - d∥ :=
begin
  rw [← norm_abs_eq_norm (a - c), ← norm_abs_eq_norm (b - d)],
  refine le_trans (solid _) (norm_add_le (|a - c|) (|b - d|)),
  rw abs_of_nonneg (|a - c| + |b - d|) (add_nonneg (abs_nonneg (a - c)) (abs_nonneg (b - d))),
  calc |a ⊓ b - c ⊓ d| =
    |a ⊓ b - c ⊓ b + (c ⊓ b - c ⊓ d)| : by rw sub_add_sub_cancel
  ... ≤ |a ⊓ b - c ⊓ b| + |c ⊓ b - c ⊓ d| : abs_add_le _ _
  ... ≤ |a -c| + |b - d| : by
    { apply add_le_add,
      { exact abs_inf_sub_inf_le_abs _ _ _, },
      { rw [@inf_comm _ _ c, @inf_comm _ _ c],
        exact abs_inf_sub_inf_le_abs _ _ _, } },
end

lemma norm_sup_sub_sup_le_add_norm (a b c d : α) : ∥a ⊔ b - (c ⊔ d)∥ ≤ ∥a - c∥ + ∥b - d∥ :=
begin
  rw [← norm_abs_eq_norm (a - c), ← norm_abs_eq_norm (b - d)],
  refine le_trans (solid _) (norm_add_le (|a - c|) (|b - d|)),
  rw abs_of_nonneg (|a - c| + |b - d|) (add_nonneg (abs_nonneg (a - c)) (abs_nonneg (b - d))),
  calc |a ⊔ b - (c ⊔ d)| =
    |a ⊔ b - (c ⊔ b) + (c ⊔ b - (c ⊔ d))| : by rw sub_add_sub_cancel
  ... ≤ |a ⊔ b - (c ⊔ b)| + |c ⊔ b - (c ⊔ d)| : abs_add_le _ _
  ... ≤ |a -c| + |b - d| : by
    { apply add_le_add,
      { exact abs_sup_sub_sup_le_abs _ _ _, },
      { rw [@sup_comm _ _ c, @sup_comm _ _ c],
        exact abs_sup_sub_sup_le_abs _ _ _, } },
end

/--
Let `α` be a normed lattice ordered group. Then the infimum is jointly continuous.
-/
@[priority 100] -- see Note [lower instance priority]
instance normed_lattice_add_comm_group_has_continuous_inf : has_continuous_inf α :=
begin
  refine ⟨continuous_iff_continuous_at.2 $ λ q, tendsto_iff_norm_tendsto_zero.2 $ _⟩,
  have : ∀ p : α × α, ∥p.1 ⊓ p.2 - q.1 ⊓ q.2∥ ≤ ∥p.1 - q.1∥ + ∥p.2 - q.2∥,
    from λ _, norm_inf_sub_inf_le_add_norm _ _ _ _,
  refine squeeze_zero (λ e, norm_nonneg _) this _,
  convert (((continuous_fst.tendsto q).sub tendsto_const_nhds).norm).add
        (((continuous_snd.tendsto q).sub tendsto_const_nhds).norm),
  simp,
end

@[priority 100] -- see Note [lower instance priority]
instance normed_lattice_add_comm_group_has_continuous_sup {α : Type*}
  [normed_lattice_add_comm_group α] :
  has_continuous_sup α :=
order_dual.has_continuous_sup (order_dual α)

/--
Let `α` be a normed lattice ordered group. Then `α` is a topological lattice in the norm topology.
-/
@[priority 100] -- see Note [lower instance priority]
instance normed_lattice_add_comm_group_topological_lattice : topological_lattice α :=
topological_lattice.mk

lemma norm_abs_sub_abs (a b : α) :
  ∥ |a| - |b| ∥ ≤ ∥a-b∥ :=
solid (lattice_ordered_comm_group.abs_abs_sub_abs_le _ _)

lemma norm_sup_sub_sup_le_norm (x y z : α) : ∥x ⊔ z - (y ⊔ z)∥ ≤ ∥x - y∥ :=
solid (abs_sup_sub_sup_le_abs x y z)

lemma norm_inf_sub_inf_le_norm (x y z : α) : ∥x ⊓ z - (y ⊓ z)∥ ≤ ∥x - y∥ :=
solid (abs_inf_sub_inf_le_abs x y z)

lemma lipschitz_with_sup_right (z : α) : lipschitz_with 1 (λ x, x ⊔ z) :=
lipschitz_with.of_dist_le_mul $ λ x y, by
{ rw [nonneg.coe_one, one_mul, dist_eq_norm, dist_eq_norm], exact norm_sup_sub_sup_le_norm x y z, }

lemma lipschitz_with_pos : lipschitz_with 1 (has_pos_part.pos : α → α) :=
lipschitz_with_sup_right 0

lemma continuous_pos : continuous (has_pos_part.pos : α → α) :=
lipschitz_with.continuous lipschitz_with_pos

lemma continuous_neg' : continuous (has_neg_part.neg : α → α) :=
continuous_pos.comp continuous_neg

lemma is_closed_nonneg {E} [normed_lattice_add_comm_group E] : is_closed {x : E | 0 ≤ x} :=
begin
  suffices : {x : E | 0 ≤ x} = has_neg_part.neg ⁻¹' {(0 : E)},
  by { rw this, exact is_closed.preimage continuous_neg' is_closed_singleton, },
  ext1 x,
  simp only [set.mem_preimage, set.mem_singleton_iff, set.mem_set_of_eq, neg_eq_zero_iff],
end

lemma is_closed_le_of_is_closed_nonneg {G} [ordered_add_comm_group G] [topological_space G]
  [has_continuous_sub G] (h : is_closed {x : G | 0 ≤ x}) :
  is_closed {p : G × G | p.fst ≤ p.snd} :=
begin
  have : {p : G × G | p.fst ≤ p.snd} = (λ p : G × G, p.snd - p.fst) ⁻¹' {x : G | 0 ≤ x},
    by { ext1 p, simp only [sub_nonneg, set.preimage_set_of_eq], },
  rw this,
  exact is_closed.preimage (continuous_snd.sub continuous_fst) h,
end

@[priority 100]  -- See note [lower instance priority]
instance normed_lattice_add_comm_group.order_closed_topology {E} [normed_lattice_add_comm_group E] :
  order_closed_topology E :=
⟨is_closed_le_of_is_closed_nonneg is_closed_nonneg⟩


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BoolAlg
import order.category.FinPartialOrder
import order.hom.complete_lattice

/-!
# The category of finite boolean algebras

This file defines `FinBoolAlg`, the category of finite boolean algebras.

## TODO

Birkhoff's representation for finite Boolean algebras.

`Fintype_to_FinBoolAlg_op.left_op ⋙ FinBoolAlg.dual ≅ Fintype_to_FinBoolAlg_op.left_op`

`FinBoolAlg` is essentially small.
-/

universes u

open category_theory order_dual opposite

/-- The category of finite boolean algebras with bounded lattice morphisms. -/
structure FinBoolAlg :=
(to_BoolAlg : BoolAlg)
[is_fintype : fintype to_BoolAlg]

namespace FinBoolAlg

instance : has_coe_to_sort FinBoolAlg Type* := ⟨λ X, X.to_BoolAlg⟩
instance (X : FinBoolAlg) : boolean_algebra X := X.to_BoolAlg.str

attribute [instance]  FinBoolAlg.is_fintype

@[simp] lemma coe_to_BoolAlg (X : FinBoolAlg) : ↥X.to_BoolAlg = ↥X := rfl

/-- Construct a bundled `FinBoolAlg` from `boolean_algebra` + `fintype`. -/
def of (α : Type*) [boolean_algebra α] [fintype α] : FinBoolAlg := ⟨⟨α⟩⟩

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

instance : inhabited FinBoolAlg := ⟨of punit⟩

instance large_category : large_category FinBoolAlg :=
induced_category.category FinBoolAlg.to_BoolAlg

instance concrete_category : concrete_category FinBoolAlg :=
induced_category.concrete_category FinBoolAlg.to_BoolAlg

instance has_forget_to_BoolAlg : has_forget₂ FinBoolAlg BoolAlg :=
induced_category.has_forget₂ FinBoolAlg.to_BoolAlg

instance forget_to_BoolAlg_full : full (forget₂ FinBoolAlg BoolAlg) := induced_category.full _
instance forget_to_BoolAlg_faithful : faithful (forget₂ FinBoolAlg BoolAlg) :=
induced_category.faithful _

@[simps] instance has_forget_to_FinPartialOrder : has_forget₂ FinBoolAlg FinPartialOrder :=
{ forget₂ := { obj := λ X, FinPartialOrder.of X, map := λ X Y f,
    show order_hom X Y, from ↑(show bounded_lattice_hom X Y, from f) } }

instance forget_to_FinPartialOrder_faithful : faithful (forget₂ FinBoolAlg FinPartialOrder) :=
⟨λ X Y f g h, by { have := congr_arg (coe_fn : _ → X → Y) h, exact fun_like.coe_injective this }⟩

/-- Constructs an equivalence between finite Boolean algebras from an order isomorphism between
them. -/
@[simps] def iso.mk {α β : FinBoolAlg.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : FinBoolAlg ⥤ FinBoolAlg :=
{ obj := λ X, of (order_dual X), map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `FinBoolAlg` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : FinBoolAlg ≌ FinBoolAlg :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end FinBoolAlg

/-- The powerset functor. `set` as a functor. -/
@[simps] def Fintype_to_FinBoolAlg_op : Fintype ⥤ FinBoolAlgᵒᵖ :=
{ obj := λ X, op $ FinBoolAlg.of (set X),
  map := λ X Y f, quiver.hom.op $
    (complete_lattice_hom.set_preimage f : bounded_lattice_hom (set Y) (set X)) }