import set_theory.cardinal.ordinal
import mathlib.logic.equiv.local_perm

namespace local_perm

/-!
Utilities to complete orbits of functions into local permutations.

Suppose we have a function `f : α → α`, and a set `s` on which `f` is injective.
We will construct a pair of functions `to_fun` and `inv_fun` that agree with `f` and its inverse
on `s`, in such a way that forms a local permutation of `α`. In particular, consider the diagram
```
... → l 2 → l 1 → l 0 → s \ f '' s → ... → f '' s \ s → r 0 → r 1 → r 2 → ...
```
To fill in orbits of `f`, we construct a sequence of disjoint subsets of `α` called `l i` and `r i`
for each `i : ℕ`, where `#(l i) = #(s \ f '' s)` and `#(r i) = #(f '' s \ s)`.
There are natural bijections along this diagram, mapping `l (n + 1)` to `l n` and `r n` to
`r (n + 1)`, and there are also bijections `f '' s \ s → r 0` and `l 0 → s \ f '' s`.
This yields a local permutation defined on `s`, `f '' s \ s`, the `l i`, and the `r i`.
-/

open cardinal function set
open_locale cardinal classical

variables {α : Type*} {f : α → α} {s : set α} {t : set α}
  (hs : #(s ∆ (f '' s) : set α) ≤ #t) (ht : ℵ₀ ≤ #t)

lemma exists_sandbox_subset (hs : #(s ∆ (f '' s) : set α) ≤ #t) (ht : ℵ₀ ≤ #t) :
  #((ℕ × (s \ f '' s : set α)) ⊕ (ℕ × (f '' s \ s : set α))) ≤ #t :=
begin
  rw [set.symm_diff_def, mk_union_of_disjoint] at hs,
  simp only [mk_sum, mk_prod, mk_denumerable, lift_aleph_0, lift_uzero, lift_id, ← mul_add] at hs ⊢,
  exact le_trans (mul_le_max_of_aleph_0_le_left le_rfl) (max_le ht hs),
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem],
  exact λ x hx, hx.1.2 hx.2.1,
end

/-- Creates a "sandbox" subset of `t` on which we will define an extension of `f`. -/
def sandbox_subset : set α :=
(le_mk_iff_exists_subset.mp $ exists_sandbox_subset hs ht).some

lemma sandbox_subset_subset : sandbox_subset hs ht ⊆ t :=
(le_mk_iff_exists_subset.mp $ exists_sandbox_subset hs ht).some_spec.1

noncomputable def sandbox_subset_equiv :
  sandbox_subset hs ht ≃ (ℕ × (s \ f '' s : set α)) ⊕ (ℕ × (f '' s \ s : set α)) :=
(cardinal.eq.mp (le_mk_iff_exists_subset.mp $ exists_sandbox_subset hs ht).some_spec.2).some

/-- Considered an implementation detail; use lemmas about `complete` instead. -/
noncomputable def shift_right : (ℕ × (s \ f '' s : set α)) ⊕ (ℕ × (f '' s \ s : set α)) → α
| (sum.inl ⟨0, a⟩) := a
| (sum.inl ⟨n + 1, a⟩) := (sandbox_subset_equiv hs ht).symm (sum.inl ⟨n, a⟩)
| (sum.inr ⟨n, a⟩) := (sandbox_subset_equiv hs ht).symm (sum.inr ⟨n + 1, a⟩)

/-- Considered an implementation detail; use lemmas about `complete` instead. -/
noncomputable def complete_to_fun (a : α) : α :=
if h : a ∈ sandbox_subset hs ht then
  shift_right hs ht (sandbox_subset_equiv hs ht ⟨a, h⟩)
else if h : a ∈ f '' s \ s then
  (sandbox_subset_equiv hs ht).symm (sum.inr ⟨0, a, h⟩)
else
  f a

/-- Considered an implementation detail; use lemmas about `complete` instead. -/
noncomputable def shift_left : (ℕ × (s \ f '' s : set α)) ⊕ (ℕ × (f '' s \ s : set α)) → α
| (sum.inl ⟨n, a⟩) := (sandbox_subset_equiv hs ht).symm (sum.inl ⟨n + 1, a⟩)
| (sum.inr ⟨0, a⟩) := a.1
| (sum.inr ⟨n + 1, a⟩) := (sandbox_subset_equiv hs ht).symm (sum.inr ⟨n, a⟩)

/-- Considered an implementation detail; use lemmas about `complete` instead. -/
noncomputable def complete_inv_fun [nonempty α] (a : α) : α :=
if h : a ∈ sandbox_subset hs ht then
  shift_left hs ht (sandbox_subset_equiv hs ht ⟨a, h⟩)
else if h : a ∈ s \ f '' s then
  (sandbox_subset_equiv hs ht).symm (sum.inl ⟨0, a, h⟩)
else
  inv_fun_on f s a

/-- The domain on which we will define the completion of a function to a local permutation. -/
def complete_domain : set α :=
s ∪ f '' s ∪ sandbox_subset hs ht

lemma complete_to_fun_domain (x : α) (h : x ∈ complete_domain hs ht) :
  complete_to_fun hs ht x ∈ complete_domain hs ht :=
begin
  unfold complete_to_fun complete_domain,
  split_ifs with h₁ h₂,
  cases sandbox_subset_equiv hs ht ⟨x, h₁⟩,
  { obtain ⟨_ | n, x⟩ := val,
    { exact or.inl (or.inl x.prop.1), },
    { exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, }, },
  { obtain ⟨n, x⟩ := val,
    exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, },
  { exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, },
  { rw [mem_diff, not_and_distrib, not_not] at h₂,
    refine or.inl (or.inr ⟨x, _, rfl⟩),
    cases h₂,
    { obtain ((h | h) | h) := h,
      exact h,
      cases h₂ h,
      cases h₁ h, },
    { exact h₂, }, },
end

lemma complete_inv_fun_domain [nonempty α] (x : α) (h : x ∈ complete_domain hs ht) :
  complete_inv_fun hs ht x ∈ complete_domain hs ht :=
begin
  unfold complete_inv_fun complete_domain,
  split_ifs with h₁ h₂,
  cases sandbox_subset_equiv hs ht ⟨x, h₁⟩,
  { obtain ⟨n, x⟩ := val,
    exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, },
  { obtain ⟨_ | n, x⟩ := val,
    { exact or.inl (or.inr x.prop.1), },
    { exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, }, },
  { exact or.inr ((sandbox_subset_equiv hs ht).symm _).prop, },
  { rw [mem_diff, not_and_distrib, not_not] at h₂,
    cases h₂,
    { rw complete_domain at h,
      obtain ((h | h) | h) := h,
      cases h₂ h,
      { refine or.inl (or.inl _),
        simp only [mem_image, ← exists_prop] at h,
        exact inv_fun_on_mem h, },
      cases h₁ h, },
    simp only [mem_image, ← exists_prop] at h₂,
    refine or.inl (or.inl (inv_fun_on_mem h₂)), },
end

lemma complete_left_inv [nonempty α] (hst : disjoint (s ∪ f '' s) t) (hf : inj_on f s)
  (x : α) (h : x ∈ complete_domain hs ht) : complete_inv_fun hs ht (complete_to_fun hs ht x) = x :=
begin
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem] at hst,
  by_cases h₁ : x ∈ s,
  { rw [complete_to_fun, dif_neg, dif_neg, complete_inv_fun, dif_neg, dif_neg],
    { exact hf (inv_fun_on_apply_mem h₁) h₁
        (show f (inv_fun_on f s (f x)) = f x, from inv_fun_on_apply_eq h₁), },
    { exact λ h', h'.2 ⟨x, h₁, rfl⟩, },
    { exact λ hx, hst (f x) ⟨or.inr ⟨x, h₁, rfl⟩, sandbox_subset_subset hs ht hx⟩, },
    { exact λ h', h'.2 h₁, },
    { exact λ hx, hst x ⟨or.inl h₁, sandbox_subset_subset hs ht hx⟩, }, },
  by_cases h₂ : x ∈ f '' s,
  { rw [complete_to_fun, dif_neg, dif_pos, complete_inv_fun, dif_pos],
    simp only [subtype.coe_eta, equiv.apply_symm_apply],
    refl,
    { exact ((sandbox_subset_equiv hs ht).symm _).prop,
      exact ⟨h₂, h₁⟩, },
    { exact λ h, hst x ⟨or.inr h₂, sandbox_subset_subset hs ht h⟩, }, },
  obtain ((h | h) | h) := h,
  { cases h₁ h, },
  { cases h₂ h, },
  rw [complete_to_fun, dif_pos h, complete_inv_fun],
  by_cases h₃ : ∃ a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inl ⟨0, a⟩,
  { obtain ⟨a, ha⟩ := h₃,
    rw [dif_neg, dif_pos, subtype.coe_eq_iff],
    refine ⟨h, _⟩,
    simp only [ha],
    exact a.prop,
    { rw equiv.symm_apply_eq, simp only [ha], ext; refl, },
    { rw ha,
      exact λ h, hst _ ⟨or.inl a.prop.1, sandbox_subset_subset hs ht h⟩, }, },
  have h₄ : (∃ n a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inl ⟨n + 1, a⟩) ∨
    ∃ n a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inr ⟨n, a⟩,
  { set val := sandbox_subset_equiv hs ht ⟨x, h⟩,
    clear_value val,
    obtain (⟨_ | n, b⟩ | ⟨n, b⟩) := val,
    cases h₃ ⟨b, rfl⟩,
    exact or.inl ⟨n, b, rfl⟩,
    exact or.inr ⟨n, b, rfl⟩, },
  cases h₄;
  { obtain ⟨n, a, ha⟩ := h₄,
    rw [dif_pos],
    simp only [ha],
    unfold shift_right,
    simp only [subtype.coe_eta, equiv.apply_symm_apply],
    exact subtype.coe_inj.mpr ((equiv.symm_apply_eq _).mpr ha.symm),
    rw ha,
    exact ((sandbox_subset_equiv hs ht).symm _).prop, },
end

lemma complete_right_inv [nonempty α] (hst : disjoint (s ∪ f '' s) t) (hf : inj_on f s)
  (x : α) (h : x ∈ complete_domain hs ht) : complete_to_fun hs ht (complete_inv_fun hs ht x) = x :=
begin
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem] at hst,
  by_cases h₁ : x ∈ f '' s,
  { rw [complete_inv_fun, dif_neg, dif_neg, complete_to_fun, dif_neg, dif_neg],
    { exact inv_fun_on_eq (set.mem_image_iff_bex.mp h₁), },
    { exact λ h', h'.2 (inv_fun_on_mem (set.mem_image_iff_bex.mp h₁)), },
    { exact λ hx, hst _ ⟨or.inl (inv_fun_on_mem (set.mem_image_iff_bex.mp h₁)),
        sandbox_subset_subset hs ht hx⟩, },
    { exact λ h', h'.2 h₁, },
    { exact λ hx, hst x ⟨or.inr h₁, sandbox_subset_subset hs ht hx⟩, }, },
  by_cases h₂ : x ∈ s,
  { rw [complete_inv_fun, dif_neg, dif_pos, complete_to_fun, dif_pos],
    simp only [subtype.coe_eta, equiv.apply_symm_apply],
    refl,
    { exact ((sandbox_subset_equiv hs ht).symm _).prop,
      exact ⟨h₂, h₁⟩, },
    { exact λ h, hst x ⟨or.inl h₂, sandbox_subset_subset hs ht h⟩, }, },
  obtain ((h | h) | h) := h,
  { cases h₂ h, },
  { cases h₁ h, },
  rw [complete_inv_fun, dif_pos h, complete_to_fun],
  by_cases h₃ : ∃ a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inr ⟨0, a⟩,
  { obtain ⟨a, ha⟩ := h₃,
    rw [dif_neg, dif_pos, subtype.coe_eq_iff],
    refine ⟨h, _⟩,
    simp only [ha],
    exact a.prop,
    { rw equiv.symm_apply_eq, simp only [ha], ext; refl, },
    { rw ha,
      exact λ h, hst _ ⟨or.inr a.prop.1, sandbox_subset_subset hs ht h⟩, }, },
  have h₄ : (∃ n a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inr ⟨n + 1, a⟩) ∨
    ∃ n a, sandbox_subset_equiv hs ht ⟨x, h⟩ = sum.inl ⟨n, a⟩,
  { set val := sandbox_subset_equiv hs ht ⟨x, h⟩,
    clear_value val,
    obtain (⟨n, b⟩ | ⟨_ | n, b⟩) := val,
    exact or.inr ⟨n, b, rfl⟩,
    cases h₃ ⟨b, rfl⟩,
    exact or.inl ⟨n, b, rfl⟩, },
  cases h₄;
  { obtain ⟨n, a, ha⟩ := h₄,
    rw [dif_pos],
    simp only [ha],
    unfold shift_left,
    simp only [subtype.coe_eta, equiv.apply_symm_apply],
    exact subtype.coe_inj.mpr ((equiv.symm_apply_eq _).mpr ha.symm),
    rw ha,
    exact ((sandbox_subset_equiv hs ht).symm _).prop, },
end

/-- Completes a function `f` on a domain `s` into a local permutation that agrees with `f` on `s`,
with domain contained in `s ∪ (f '' s) ∪ t`. -/
noncomputable def complete [nonempty α] (f : α → α) (s : set α) (t : set α)
  (hs : #(s ∆ (f '' s) : set α) ≤ #t) (ht : ℵ₀ ≤ #t) (hst : disjoint (s ∪ f '' s) t)
  (hf : inj_on f s) : local_perm α := {
  to_fun := complete_to_fun hs ht,
  inv_fun := complete_inv_fun hs ht,
  domain := complete_domain hs ht,
  to_fun_domain' := complete_to_fun_domain hs ht,
  inv_fun_domain' := complete_inv_fun_domain hs ht,
  left_inv' := complete_left_inv hs ht hst hf,
  right_inv' := complete_right_inv hs ht hst hf,
}

variables [nonempty α] {hst : disjoint (s ∪ f '' s) t} {hf : inj_on f s}

@[simp] lemma complete_domain_eq :
  (complete f s t hs ht hst hf).domain = complete_domain hs ht := rfl

lemma mem_complete_domain_of_mem (x : α) (hx : x ∈ s) : x ∈ complete_domain hs ht :=
or.inl (or.inl hx)

lemma mem_complete_domain_of_mem_image (x : α) (hx : x ∈ f '' s) : x ∈ complete_domain hs ht :=
or.inl (or.inr hx)

lemma not_mem_sandbox_of_mem (hst : disjoint (s ∪ f '' s) t) (x : α) (hx : x ∈ s) :
  x ∉ sandbox_subset hs ht :=
begin
  intro h,
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem] at hst,
  exact hst x ⟨or.inl hx, sandbox_subset_subset hs ht h⟩,
end

lemma not_mem_sandbox_of_mem_image (hst : disjoint (s ∪ f '' s) t) (x : α) (hx : x ∈ f '' s) :
  x ∉ sandbox_subset hs ht :=
begin
  intro h,
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem] at hst,
  exact hst x ⟨or.inr hx, sandbox_subset_subset hs ht h⟩,
end

@[simp] lemma complete_apply_eq (x : α) (hx : x ∈ s) : complete f s t hs ht hst hf x = f x :=
begin
  rw [complete, coe_mk, complete_to_fun, dif_neg, dif_neg],
  exact λ h', h'.2 hx,
  exact not_mem_sandbox_of_mem hs ht hst x hx,
end

end local_perm


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.applicative
import control.traversable.basic

/-!
# Traversing collections

This file proves basic properties of traversable and applicative functors and defines
`pure_transformation F`, the natural applicative transformation from the identity functor to `F`.

## References

Inspired by [The Essence of the Iterator Pattern][gibbons2009].
-/

universes u

open is_lawful_traversable
open function (hiding comp)
open functor

attribute [functor_norm] is_lawful_traversable.naturality
attribute [simp] is_lawful_traversable.id_traverse

namespace traversable

variable {t : Type u → Type u}
variables [traversable t] [is_lawful_traversable t]
variables F G : Type u → Type u

variables [applicative F] [is_lawful_applicative F]
variables [applicative G] [is_lawful_applicative G]
variables {α β γ : Type u}
variables g : α → F β
variables h : β → G γ
variables f : β → γ

/-- The natural applicative transformation from the identity functor
to `F`, defined by `pure : Π {α}, α → F α`. -/
def pure_transformation : applicative_transformation id F :=
{ app := @pure F _,
  preserves_pure' := λ α x, rfl,
  preserves_seq' := λ α β f x, by { simp only [map_pure, seq_pure], refl } }

@[simp]

variables {F G} (x : t β)

lemma map_eq_traverse_id : map f = @traverse t _ _ _ _ _ (id.mk ∘ f) :=
funext $ λ y, (traverse_eq_map_id f y).symm

theorem map_traverse (x : t α) : map f <$> traverse g x = traverse (map f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ f,
  refine (comp_traverse (id.mk ∘ f) g x).symm.trans _,
  congr, apply comp.applicative_comp_id
end

theorem traverse_map (f : β → F γ) (g : α → β) (x : t α) :
  traverse f (g <$> x) = traverse (f ∘ g) x :=
begin
  rw @map_eq_traverse_id t _ _ _ _ g,
  refine (comp_traverse f (id.mk ∘ g) x).symm.trans _,
  congr, apply comp.applicative_id_comp
end

lemma pure_traverse (x : t α) : traverse pure x = (pure x : F (t α)) :=
by have : traverse pure x = pure (traverse id.mk x) :=
     (naturality (pure_transformation F) id.mk x).symm;
   rwa id_traverse at this

lemma id_sequence (x : t α) : sequence (id.mk <$> x) = id.mk x :=
by simp [sequence, traverse_map, id_traverse]; refl

lemma comp_sequence (x : t (F (G α))) :
  sequence (comp.mk <$> x) = comp.mk (sequence <$> sequence x) :=
by simp [sequence, traverse_map]; rw ← comp_traverse; simp [map_id]

lemma naturality' (η : applicative_transformation F G) (x : t (F α)) :
  η (sequence x) = sequence (@η _ <$> x) :=
by simp [sequence, naturality, traverse_map]

@[functor_norm]
lemma traverse_id : traverse id.mk = (id.mk : t α → id (t α)) :=
by { ext, exact id_traverse _ }

@[functor_norm]
lemma traverse_comp (g : α → F β) (h : β → G γ) :
  traverse (comp.mk ∘ map h ∘ g) =
  (comp.mk ∘ map (traverse h) ∘ traverse g : t α → comp F G (t γ)) :=
by { ext, exact comp_traverse _ _ _ }

lemma traverse_eq_map_id' (f : β → γ) : traverse (id.mk ∘ f) = id.mk ∘ (map f : t β → t γ) :=
by { ext, exact traverse_eq_map_id _ _ }

-- @[functor_norm]
lemma traverse_map' (g : α → β) (h : β → G γ) :
  traverse (h ∘ g) = (traverse h ∘ map g : t α → G (t γ)) :=
by { ext, rw [comp_app, traverse_map] }

lemma map_traverse' (g : α → G β) (h : β → γ) :
  traverse (map h ∘ g) = (map (map h) ∘ traverse g : t α → G (t γ)) :=
by { ext, rw [comp_app, map_traverse] }

lemma naturality_pf (η : applicative_transformation F G) (f : α → F β) :
  traverse (@η _ ∘ f) = @η _ ∘ (traverse f : t α → F (t β)) :=
by { ext, rw [comp_app, naturality] }

end traversable


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Riccardo Brasca
-/
import analysis.normed.group.hom
import category_theory.limits.shapes.zero

/-!
# The category of seminormed groups

We define `SemiNormedGroup`, the category of seminormed groups and normed group homs between them,
as well as `SemiNormedGroup₁`, the subcategory of norm non-increasing morphisms.
-/

noncomputable theory

universes u

open category_theory

/-- The category of seminormed abelian groups and bounded group homomorphisms. -/
def SemiNormedGroup : Type (u+1) := bundled semi_normed_group

namespace SemiNormedGroup

instance bundled_hom : bundled_hom @normed_group_hom :=
⟨@normed_group_hom.to_fun, @normed_group_hom.id, @normed_group_hom.comp, @normed_group_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] SemiNormedGroup

instance : has_coe_to_sort SemiNormedGroup (Type u) := bundled.has_coe_to_sort

/-- Construct a bundled `SemiNormedGroup` from the underlying type and typeclass. -/
def of (M : Type u) [semi_normed_group M] : SemiNormedGroup := bundled.of M

instance (M : SemiNormedGroup) : semi_normed_group M := M.str

@[simp] lemma coe_of (V : Type u) [semi_normed_group V] : (SemiNormedGroup.of V : Type u) = V := rfl
@[simp] lemma coe_id (V : SemiNormedGroup) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl

instance : has_zero SemiNormedGroup := ⟨of punit⟩
instance : inhabited SemiNormedGroup := ⟨0⟩

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup := {}

@[simp] lemma zero_apply {V W : SemiNormedGroup} (x : V) : (0 : V ⟶ W) x = 0 := rfl

instance has_zero_object : limits.has_zero_object SemiNormedGroup.{u} :=
{ zero := 0,
  unique_to := λ X,
  { default := 0,
    uniq := λ a, by { ext ⟨⟩, exact a.map_zero, }, },
  unique_from := λ X,
  { default := 0,
    uniq := λ f, by ext } }

lemma iso_isometry_of_norm_noninc {V W : SemiNormedGroup} (i : V ≅ W)
  (h1 : i.hom.norm_noninc) (h2 : i.inv.norm_noninc) :
  isometry i.hom :=
begin
  apply normed_group_hom.isometry_of_norm,
  intro v,
  apply le_antisymm (h1 v),
  calc ∥v∥ = ∥i.inv (i.hom v)∥ : by rw [coe_hom_inv_id]
  ... ≤ ∥i.hom v∥ : h2 _,
end

end SemiNormedGroup

/--
`SemiNormedGroup₁` is a type synonym for `SemiNormedGroup`,
which we shall equip with the category structure consisting only of the norm non-increasing maps.
-/
def SemiNormedGroup₁ : Type (u+1) := bundled semi_normed_group

namespace SemiNormedGroup₁

instance : has_coe_to_sort SemiNormedGroup₁ (Type u) := bundled.has_coe_to_sort

instance : large_category.{u} SemiNormedGroup₁ :=
{ hom := λ X Y, { f : normed_group_hom X Y // f.norm_noninc },
  id := λ X, ⟨normed_group_hom.id X, normed_group_hom.norm_noninc.id⟩,
  comp := λ X Y Z f g, ⟨(g : normed_group_hom Y Z).comp (f : normed_group_hom X Y), g.2.comp f.2⟩, }

@[ext] lemma hom_ext {M N : SemiNormedGroup₁} (f g : M ⟶ N) (w : (f : M → N) = (g : M → N)) :
  f = g :=
subtype.eq (normed_group_hom.ext (congr_fun w))

instance : concrete_category.{u} SemiNormedGroup₁ :=
{ forget :=
  { obj := λ X, X,
    map := λ X Y f, f, },
  forget_faithful := {} }

/-- Construct a bundled `SemiNormedGroup₁` from the underlying type and typeclass. -/
def of (M : Type u) [semi_normed_group M] : SemiNormedGroup₁ := bundled.of M

instance (M : SemiNormedGroup₁) : semi_normed_group M := M.str

/-- Promote a morphism in `SemiNormedGroup` to a morphism in `SemiNormedGroup₁`. -/
def mk_hom {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) :
  SemiNormedGroup₁.of M ⟶ SemiNormedGroup₁.of N :=
⟨f, i⟩

@[simp] lemma mk_hom_apply {M N : SemiNormedGroup} (f : M ⟶ N) (i : f.norm_noninc) (x) :
  mk_hom f i x = f x := rfl

/-- Promote an isomorphism in `SemiNormedGroup` to an isomorphism in `SemiNormedGroup₁`. -/
@[simps]
def mk_iso {M N : SemiNormedGroup} (f : M ≅ N) (i : f.hom.norm_noninc) (i' : f.inv.norm_noninc) :
  SemiNormedGroup₁.of M ≅ SemiNormedGroup₁.of N :=
{ hom := mk_hom f.hom i,
  inv := mk_hom f.inv i',
  hom_inv_id' := by { apply subtype.eq, exact f.hom_inv_id, },
  inv_hom_id' := by { apply subtype.eq, exact f.inv_hom_id, }, }

instance : has_forget₂ SemiNormedGroup₁ SemiNormedGroup :=
{ forget₂ :=
  { obj := λ X, X,
    map := λ X Y f, f.1, }, }

@[simp] lemma coe_of (V : Type u) [semi_normed_group V] : (SemiNormedGroup₁.of V : Type u) = V :=
rfl
@[simp] lemma coe_id (V : SemiNormedGroup₁) : ⇑(𝟙 V) = id := rfl
@[simp] lemma coe_comp {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : M → K) = g ∘ f := rfl
-- If `coe_fn_coe_base` fires before `coe_comp`, `coe_comp'` puts us back in normal form.
@[simp] lemma coe_comp' {M N K : SemiNormedGroup₁} (f : M ⟶ N) (g : N ⟶ K) :
  ((f ≫ g) : normed_group_hom M K) = (↑g : normed_group_hom N K).comp ↑f := rfl

instance : has_zero SemiNormedGroup₁ := ⟨of punit⟩
instance : inhabited SemiNormedGroup₁ := ⟨0⟩

instance : limits.has_zero_morphisms.{u (u+1)} SemiNormedGroup₁ :=
{ has_zero := λ X Y, { zero := ⟨0, normed_group_hom.norm_noninc.zero⟩, },
  comp_zero' := λ X Y f Z, by { ext, refl, },
  zero_comp' := λ X Y Z f, by { ext, simp [coe_fn_coe_base'] } }

@[simp] lemma zero_apply {V W : SemiNormedGroup₁} (x : V) : (0 : V ⟶ W) x = 0 := rfl

instance has_zero_object : limits.has_zero_object SemiNormedGroup₁.{u} :=
{ zero := 0,
  unique_to := λ X,
  { default := 0,
    uniq := λ a, by { ext ⟨⟩, exact a.1.map_zero, }, },
  unique_from := λ X,
  { default := 0,
    uniq := λ f, by ext } }

lemma iso_isometry {V W : SemiNormedGroup₁} (i : V ≅ W) :
  isometry i.hom :=
begin
  apply normed_group_hom.isometry_of_norm,
  intro v,
  apply le_antisymm (i.hom.2 v),
  calc ∥v∥ = ∥i.inv (i.hom v)∥ : by rw [coe_hom_inv_id]
      ... ≤ ∥i.hom v∥ : i.inv.2 _,
end

end SemiNormedGroup₁


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor
import Mathlib.PostPort

universes u v w l s t u_1

namespace Mathlib

/-!
# Traversable type class

Type classes for traversing collections. The concepts and laws are taken from
<http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Traversable.html>

Traversable collections are a generalization of functors. Whereas
functors (such as `list`) allow us to apply a function to every
element, it does not allow functions which external effects encoded in
a monad. Consider for instance a functor `invite : email → io response`
that takes an email address, sends an email and waits for a
response. If we have a list `guests : list email`, using calling
`invite` using `map` gives us the following: `map invite guests : list
(io response)`.  It is not what we need. We need something of type `io
(list response)`. Instead of using `map`, we can use `traverse` to
send all the invites: `traverse invite guests : io (list response)`.
`traverse` applies `invite` to every element of `guests` and combines
all the resulting effects. In the example, the effect is encoded in the
monad `io` but any applicative functor is accepted by `traverse`.

For more on how to use traversable, consider the Haskell tutorial:
<https://en.wikibooks.org/wiki/Haskell/Traversable>

## Main definitions
  * `traversable` type class - exposes the `traverse` function
  * `sequence` - based on `traverse`, turns a collection of effects into an effect returning a collection
  * `is_lawful_traversable` - laws for a traversable functor
  * `applicative_transformation` - the notion of a natural transformation for applicative functors

## Tags

traversable iterator functor applicative

## References

 * "Applicative Programming with Effects", by Conor McBride and Ross Paterson,
   Journal of Functional Programming 18:1 (2008) 1-13, online at
   <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>
 * "The Essence of the Iterator Pattern", by Jeremy Gibbons and Bruno Oliveira,
   in Mathematically-Structured Functional Programming, 2006, online at
   <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>
 * "An Investigation of the Laws of Traversals", by Mauro Jaskelioff and Ondrej Rypacek,
   in Mathematically-Structured Functional Programming, 2012,
   online at <http://arxiv.org/pdf/1202.2919>
-/

/-- A transformation between applicative functors.  It a natural
transformation such that `app` preserves the `has_pure.pure` and
`functor.map` (`<*>`) operations. See
`applicative_transformation.preserves_map` for naturality. -/
structure applicative_transformation (F : Type u → Type v) [Applicative F] [is_lawful_applicative F]
    (G : Type u → Type w) [Applicative G] [is_lawful_applicative G]
    where
  app : (α : Type u) → F α → G α
  preserves_pure' : ∀ {α : Type u} (x : α), app α (pure x) = pure x
  preserves_seq' :
    ∀ {α β : Type u} (x : F (α → β)) (y : F α), app β (x <*> y) = app (α → β) x <*> app α y

namespace applicative_transformation

protected instance has_coe_to_fun (F : Type u → Type v) [Applicative F] [is_lawful_applicative F]
    (G : Type u → Type w) [Applicative G] [is_lawful_applicative G] :
    has_coe_to_fun (applicative_transformation F G) :=
  has_coe_to_fun.mk (fun (_x : applicative_transformation F G) => {α : Type u} → F α → G α)
    fun (a : applicative_transformation F G) => app a

@[simp] theorem app_eq_coe {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) : app η = ⇑η :=
  rfl

@[simp] theorem coe_mk {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G] (f : (α : Type u) → F α → G α)
    (pp : ∀ {α : Type u} (x : α), f α (pure x) = pure x)
    (ps : ∀ {α β : Type u} (x : F (α → β)) (y : F α), f β (x <*> y) = f (α → β) x <*> f α y) :
    ⇑(mk f pp ps) = f :=
  rfl

protected theorem congr_fun {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) (η' : applicative_transformation F G) (h : η = η')
    {α : Type u} (x : F α) : coe_fn η α x = coe_fn η' α x :=
  congr_arg (fun (η'' : applicative_transformation F G) => coe_fn η'' α x) h

protected theorem congr_arg {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} {x : F α} {y : F α} (h : x = y) :
    coe_fn η α x = coe_fn η α y :=
  congr_arg (fun (z : F α) => coe_fn η α z) h

theorem coe_inj {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    {η : applicative_transformation F G} {η' : applicative_transformation F G} (h : ⇑η = ⇑η') :
    η = η' :=
  sorry

theorem ext {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] {G : Type u → Type w}
    [Applicative G] [is_lawful_applicative G] {η : applicative_transformation F G}
    {η' : applicative_transformation F G}
    (h : ∀ (α : Type u) (x : F α), coe_fn η α x = coe_fn η' α x) : η = η' :=
  coe_inj (funext fun (α : Type u) => funext (h α))

theorem ext_iff {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    {η : applicative_transformation F G} {η' : applicative_transformation F G} :
    η = η' ↔ ∀ (α : Type u) (x : F α), coe_fn η α x = coe_fn η' α x :=
  { mp := fun (h : η = η') (α : Type u) (x : F α) => h ▸ rfl,
    mpr := fun (h : ∀ (α : Type u) (x : F α), coe_fn η α x = coe_fn η' α x) => ext h }

theorem preserves_pure {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} (x : α) : coe_fn η α (pure x) = pure x :=
  preserves_pure' η

theorem preserves_seq {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} {β : Type u} (x : F (α → β)) (y : F α) :
    coe_fn η β (x <*> y) = coe_fn η (α → β) x <*> coe_fn η α y :=
  preserves_seq' η

theorem preserves_map {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} {β : Type u} (x : α → β) (y : F α) :
    coe_fn η β (x <$> y) = x <$> coe_fn η α y :=
  sorry

theorem preserves_map' {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u} {β : Type u} (x : α → β) :
    coe_fn η β ∘ Functor.map x = Functor.map x ∘ coe_fn η α :=
  funext fun (y : F α) => preserves_map η x y

/-- The identity applicative transformation from an applicative functor to itself. -/
def id_transformation {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] :
    applicative_transformation F F :=
  mk (fun (α : Type u) => id) sorry sorry

protected instance inhabited {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] :
    Inhabited (applicative_transformation F F) :=
  { default := id_transformation }

/-- The composition of applicative transformations. -/
def comp {F : Type u → Type v} [Applicative F] [is_lawful_applicative F] {G : Type u → Type w}
    [Applicative G] [is_lawful_applicative G] {H : Type u → Type s} [Applicative H]
    [is_lawful_applicative H] (η' : applicative_transformation G H)
    (η : applicative_transformation F G) : applicative_transformation F H :=
  mk (fun (α : Type u) (x : F α) => coe_fn η' α (coe_fn η α x)) sorry sorry

@[simp] theorem comp_apply {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G] {H : Type u → Type s}
    [Applicative H] [is_lawful_applicative H] (η' : applicative_transformation G H)
    (η : applicative_transformation F G) {α : Type u} (x : F α) :
    coe_fn (comp η' η) α x = coe_fn η' α (coe_fn η α x) :=
  rfl

theorem comp_assoc {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G] {H : Type u → Type s}
    [Applicative H] [is_lawful_applicative H] {I : Type u → Type t} [Applicative I]
    [is_lawful_applicative I] (η'' : applicative_transformation H I)
    (η' : applicative_transformation G H) (η : applicative_transformation F G) :
    comp (comp η'' η') η = comp η'' (comp η' η) :=
  rfl

@[simp] theorem comp_id {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) : comp η id_transformation = η :=
  ext fun (α : Type u) (x : F α) => rfl

@[simp] theorem id_comp {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {G : Type u → Type w} [Applicative G] [is_lawful_applicative G]
    (η : applicative_transformation F G) : comp id_transformation η = η :=
  ext fun (α : Type u) (x : F α) => rfl

end applicative_transformation

/-- A traversable functor is a functor along with a way to commute
with all applicative functors (see `sequence`).  For example, if `t`
is the traversable functor `list` and `m` is the applicative functor
`io`, then given a function `f : α → io β`, the function `functor.map f` is
`list α → list (io β)`, but `traverse f` is `list α → io (list β)`. -/
class traversable (t : Type u → Type u) extends Functor t where
  traverse :
    {m : Type u → Type u} → [_inst_1 : Applicative m] → {α β : Type u} → (α → m β) → t α → m (t β)

/-- A traversable functor commutes with all applicative functors. -/
def sequence {t : Type u → Type u} {α : Type u} {f : Type u → Type u} [Applicative f]
    [traversable t] : t (f α) → f (t α) :=
  traverse id

/-- A traversable functor is lawful if its `traverse` satisfies a
number of additional properties.  It must send `id.mk` to `id.mk`,
send the composition of applicative functors to the composition of the
`traverse` of each, send each function `f` to `λ x, f <$> x`, and
satisfy a naturality condition with respect to applicative
transformations. -/
class is_lawful_traversable (t : Type u → Type u) [traversable t] extends is_lawful_functor t where
  id_traverse : ∀ {α : Type u} (x : t α), traverse id.mk x = x
  comp_traverse :
    ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G]
      [_inst_3 : is_lawful_applicative F] [_inst_4 : is_lawful_applicative G] {α β γ : Type u}
      (f : β → F γ) (g : α → G β) (x : t α),
      traverse (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (traverse f <$> traverse g x)
  traverse_eq_map_id :
    ∀ {α β : Type u} (f : α → β) (x : t α), traverse (id.mk ∘ f) x = id.mk (f <$> x)
  naturality :
    ∀ {F G : Type u → Type u} [_inst_1_1 : Applicative F] [_inst_2 : Applicative G]
      [_inst_3 : is_lawful_applicative F] [_inst_4 : is_lawful_applicative G]
      (η : applicative_transformation F G) {α β : Type u} (f : α → F β) (x : t α),
      coe_fn η (t β) (traverse f x) = traverse (coe_fn η β ∘ f) x

protected instance id.traversable : traversable id :=
  traversable.mk fun (_x : Type u_1 → Type u_1) (_x_1 : Applicative _x) (_x_2 _x_3 : Type u_1) => id

protected instance id.is_lawful_traversable : is_lawful_traversable id :=
  is_lawful_traversable.mk sorry sorry sorry sorry

protected instance option.traversable : traversable Option := traversable.mk option.traverse

protected instance list.traversable : traversable List := traversable.mk list.traverse

namespace sum

/-- Defines a `traverse` function on the second component of a sum type.
This is used to give a `traversable` instance for the functor `σ ⊕ -`. -/
protected def traverse {σ : Type u} {F : Type u → Type u} [Applicative F] {α : Type u_1}
    {β : Type u} (f : α → F β) : σ ⊕ α → F (σ ⊕ β) :=
  sorry

end sum

protected instance sum.traversable {σ : Type u} : traversable (sum σ) := traversable.mk sum.traverse

end Mathlib


import Std.Data.AssocList
import Lib.Data.Foldable

namespace Std.AssocList
open Std

def keys : AssocList α β → List α
| nil => []
| cons k x xs => k :: keys xs

@[simp]
def length : AssocList α β → Nat
| nil => 0
| cons _ _ l => l.length.succ

@[simp]
theorem keys_mapVal (xs : AssocList k α) (f : α → β) :
  (xs.mapVal f).keys = xs.keys := by
induction xs with
| nil => simp [mapVal]; rfl
| cons k x xs => simp [keys, mapVal, *]

section mapFilter
variable (f : k → α → Option β)

def mapFilter :
  AssocList k α → AssocList k β
| nil => nil
| cons i x xs =>
  let xs' := mapFilter xs
  match f i x with
  | none => xs'
  | some x' => cons i x' xs'

-- @[simp]
-- theorem keys_mapFilter (xs : AssocList k α) :
--   (xs.mapFilter f).keys = xs.keys := by
-- induction xs with
-- | nil => simp [mapFilter]; rfl
-- | cons k x xs =>
--   simp [mapFilter]
--   cases f k x <;> simp [keys, *]
def foldr (f : ι → α → β → β) (x₀ : β) : AssocList ι α → β
| nil => x₀
| cons k x xs => f k x (foldr f x₀ xs)

instance : IdxFoldable ι (AssocList ι) where
  foldl := foldl
  foldr := foldr

instance : LawfulIdxFoldable ι (AssocList ι) where
  foldl_sim := by
    intros; next SIM x₀ y₀ xs h₀ ih =>
    simp [IdxFoldable.foldl, foldl, Id.run]
    induction xs generalizing x₀ y₀
    <;> simp [foldlM, *]

end mapFilter

section DecidableEq

variable [DecidableEq α]

def eraseAll (x : α) : AssocList α β → AssocList α β
| nil => nil
| cons k v xs =>
  let xs' := eraseAll x xs
  if x = k then xs'
  else cons k v xs'

end DecidableEq

end Std.AssocList


/-
Copyright (c) 2017 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Jesse Michael Han
-/
import tactic.hint

/-!
# The `finish` family of tactics

These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
eliminate existential quantifiers on the left, and look for contradictions. They rely on ematching
and congruence closure to try to finish off a goal at the end.

The procedures *do* split on disjunctions and recreate the smt state for each terminal call, so
they are only meant to be used on small, straightforward problems.

## Main definitions

We provide the following tactics:

* `finish`  -- solves the goal or fails
* `clarify` -- makes as much progress as possible while not leaving more than one goal
* `safe`    -- splits freely, finishes off whatever subgoals it can, and leaves the rest

All accept an optional list of simplifier rules, typically definitions that should be expanded.
(The equations and identities should not refer to the local context.)

-/

declare_trace auto.done
declare_trace auto.finish

namespace tactic

namespace interactive

meta def revert_all := tactic.revert_all

end interactive

end tactic

open tactic expr

namespace auto

/-! ### Utilities -/

meta def whnf_reducible (e : expr) : tactic expr := whnf e reducible

-- stolen from interactive.lean
meta def add_simps : simp_lemmas → list name → tactic simp_lemmas
| s []      := return s
| s (n::ns) := do s' ← s.add_simp n, add_simps s' ns

/--
Configuration information for the auto tactics.
* `(use_simp := tt)`: call the simplifier
* `(max_ematch_rounds := 20)`: for the "done" tactic
-/
@[derive decidable_eq, derive inhabited]
structure auto_config : Type :=
(use_simp := tt)
(max_ematch_rounds := 20)

/-!
### Preprocess goal.

We want to move everything to the left of the sequent arrow. For intuitionistic logic,
we replace the goal `p` with `∀ f, (p → f) → f` and introduce.
-/

theorem by_contradiction_trick (p : Prop) (h : ∀ f : Prop, (p → f) → f) : p :=
h p id

meta def preprocess_goal : tactic unit :=
do repeat (intro1 >> skip),
   tgt ← target >>= whnf_reducible,
   if (¬ (is_false tgt)) then
     (mk_mapp ``classical.by_contradiction [some tgt]) >>= apply >> intro1 >> skip
   else
     skip

/-!
### Normalize hypotheses

Bring conjunctions to the outside (for splitting),
bring universal quantifiers to the outside (for ematching). The classical normalizer
eliminates `a → b` in favor of `¬ a ∨ b`.

For efficiency, we push negations inwards from the top down. (For example, consider
simplifying `¬ ¬ (p ∨ q)`.)
-/

section

universe u
variable  {α : Type u}
variables (p q : Prop)
variable  (s : α → Prop)

local attribute [instance, priority 10] classical.prop_decidable
theorem not_not_eq : (¬ ¬ p) = p := propext not_not
theorem not_and_eq : (¬ (p ∧ q)) = (¬ p ∨ ¬ q) := propext not_and_distrib
theorem not_or_eq : (¬ (p ∨ q)) = (¬ p ∧ ¬ q) := propext not_or_distrib
theorem not_forall_eq : (¬ ∀ x, s x) = (∃ x, ¬ s x) := propext not_forall
theorem not_exists_eq : (¬ ∃ x, s x) = (∀ x, ¬ s x) := propext not_exists
theorem not_implies_eq : (¬ (p → q)) = (p ∧ ¬ q) := propext not_imp

theorem classical.implies_iff_not_or : (p → q) ↔ (¬ p ∨ q) := imp_iff_not_or

end

def common_normalize_lemma_names : list name :=
[``bex_def, ``forall_and_distrib, ``exists_imp_distrib, ``or.assoc, ``or.comm, ``or.left_comm,
  ``and.assoc, ``and.comm, ``and.left_comm]

def classical_normalize_lemma_names : list name :=
common_normalize_lemma_names ++ [``classical.implies_iff_not_or]

/-- optionally returns an equivalent expression and proof of equivalence -/
private meta def transform_negation_step (cfg : auto_config) (e : expr) :
  tactic (option (expr × expr)) :=
do e ← whnf_reducible e,
   match e with
   | `(¬ %%ne) :=
      (do ne ← whnf_reducible ne,
      match ne with
      | `(¬ %%a)      := do pr ← mk_app ``not_not_eq [a],
                            return (some (a, pr))
      | `(%%a ∧ %%b)  := do pr ← mk_app ``not_and_eq [a, b],
                            return (some (`(¬ %%a ∨ ¬ %%b), pr))
      | `(%%a ∨ %%b)  := do pr ← mk_app ``not_or_eq [a, b],
                            return (some (`(¬ %%a ∧ ¬ %%b), pr))
      | `(Exists %%p) := do pr ← mk_app ``not_exists_eq [p],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
      | (pi n bi d p) := if p.has_var then do
                            pr ← mk_app ``not_forall_eq [lam n bi d (expr.abstract_local p n)],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
                         else do
                            pr ← mk_app ``not_implies_eq [d, p],
                            `(%%_ = %%e') ← infer_type pr,
                            return (some (e', pr))
      | _             := return none
      end)
    | _        := return none
  end

/-- given an expr `e`, returns a new expression and a proof of equality -/
private meta def transform_negation (cfg : auto_config) : expr → tactic (option (expr × expr)) :=
λ e, do
  opr ← transform_negation_step cfg e,
  match opr with
  | (some (e', pr)) := do
    opr' ← transform_negation e',
    match opr' with
    | none              := return (some (e', pr))
    | (some (e'', pr')) := do pr'' ← mk_eq_trans pr pr',
                              return (some (e'', pr''))
    end
  | none            := return none
  end

meta def normalize_negations (cfg : auto_config) (h : expr) : tactic unit :=
do t ← infer_type h,
   (_, e, pr) ← simplify_top_down ()
                   (λ _, λ e, do
                       oepr ← transform_negation cfg e,
                       match oepr with
                       | (some (e', pr)) := return ((), e', pr)
                       | none            := do pr ← mk_eq_refl e, return ((), e, pr)
                       end)
                   t,
   replace_hyp h e pr,
   skip

meta def normalize_hyp (cfg : auto_config) (simps : simp_lemmas) (h : expr) : tactic unit :=
(do (h, _) ← simp_hyp simps [] h, try (normalize_negations cfg h)) <|>
try (normalize_negations cfg h)

meta def normalize_hyps (cfg : auto_config) : tactic unit :=
do simps ← add_simps simp_lemmas.mk classical_normalize_lemma_names,
   local_context >>= monad.mapm' (normalize_hyp cfg simps)

/-!
### Eliminate existential quantifiers
-/

/-- eliminate an existential quantifier if there is one -/
meta def eelim : tactic unit :=
do ctx ← local_context,
   first $ ctx.map $ λ h,
     do t ← infer_type h >>= whnf_reducible,
        guard (is_app_of t ``Exists),
        tgt ← target,
        to_expr ``(@exists.elim _ _ %%tgt %%h) >>= apply,
        intros,
        clear h

/-- eliminate all existential quantifiers, fails if there aren't any -/
meta def eelims : tactic unit := eelim >> repeat eelim

/-!
### Substitute if there is a hypothesis `x = t` or `t = x`
-/

/-- carries out a subst if there is one, fails otherwise -/
meta def do_subst : tactic unit :=
do ctx ← local_context,
   first $ ctx.map $ λ h,
     do t ← infer_type h >>= whnf_reducible,
        match t with
        | `(%%a = %%b) := subst h
        | _            := failed
        end

meta def do_substs : tactic unit := do_subst >> repeat do_subst

/-!
### Split all conjunctions
-/

/-- Assumes `pr` is a proof of `t`. Adds the consequences of `t` to the context
 and returns `tt` if anything nontrivial has been added. -/
meta def add_conjuncts : expr → expr → tactic bool :=
λ pr t,
let assert_consequences := λ e t, mcond (add_conjuncts e t) skip (note_anon t e >> skip) in
do t' ← whnf_reducible t,
   match t' with
   | `(%%a ∧ %%b) :=
     do e₁ ← mk_app ``and.left [pr],
        assert_consequences e₁ a,
        e₂ ← mk_app ``and.right [pr],
        assert_consequences e₂ b,
        return tt
  | `(true) :=
     do return tt
  | _ := return ff
end

/-- return `tt` if any progress is made -/
meta def split_hyp (h : expr) : tactic bool :=
do t ← infer_type h,
   mcond (add_conjuncts h t) (clear h >> return tt) (return ff)

/-- return `tt` if any progress is made -/
meta def split_hyps_aux : list expr → tactic bool
| []        := return ff
| (h :: hs) := do b₁ ← split_hyp h,
                  b₂ ← split_hyps_aux hs,
                  return (b₁ || b₂)

/-- fail if no progress is made -/
meta def split_hyps : tactic unit := local_context >>= split_hyps_aux >>= guardb

/-!
### Eagerly apply all the preprocessing rules
-/

/-- Eagerly apply all the preprocessing rules -/
meta def preprocess_hyps (cfg : auto_config) : tactic unit :=
do repeat (intro1 >> skip),
   preprocess_goal,
   normalize_hyps cfg,
   repeat (do_substs <|> split_hyps <|> eelim /-<|> self_simplify_hyps-/)

/-!
### Terminal tactic
-/

/--
The terminal tactic, used to try to finish off goals:
- Call the contradiction tactic.
- Open an SMT state, and use ematching and congruence closure, with all the universal
  statements in the context.

TODO(Jeremy): allow users to specify attribute for ematching lemmas?
-/

meta def mk_hinst_lemmas : list expr → smt_tactic hinst_lemmas
| []        := -- return hinst_lemmas.mk
               do get_hinst_lemmas_for_attr `ematch
| (h :: hs) := do his ← mk_hinst_lemmas hs,
                  t ← infer_type h,
                  match t with
                  | (pi _ _ _ _) :=
                    do t' ← infer_type t,
                       if t' = `(Prop) then
                          (do new_lemma ← hinst_lemma.mk h,
                             return (hinst_lemmas.add his new_lemma)) <|> return his
                       else return his
                  | _ := return his
                  end

private meta def report_invalid_em_lemma {α : Type} (n : name) : smt_tactic α :=
fail format!"invalid ematch lemma '{n}'"

private meta def add_hinst_lemma_from_name (md : transparency) (lhs_lemma : bool) (n : name)
  (hs : hinst_lemmas) (ref : pexpr) : smt_tactic hinst_lemmas :=
do p ← resolve_name n,
   match p with
   | expr.const n _ := (do h ← hinst_lemma.mk_from_decl_core md n lhs_lemma,
                           tactic.save_const_type_info n ref, return $ hs.add h) <|>
                       (do hs₁ ← smt_tactic.mk_ematch_eqn_lemmas_for_core md n,
                           tactic.save_const_type_info n ref, return $ hs.merge hs₁) <|>
                        report_invalid_em_lemma n
   | _              := (do e ← to_expr p, h ← hinst_lemma.mk_core md e lhs_lemma,
                        try (tactic.save_type_info e ref), return $ hs.add h) <|>
                        report_invalid_em_lemma n
   end

private meta def add_hinst_lemma_from_pexpr (md : transparency) (lhs_lemma : bool)
  (hs : hinst_lemmas) : pexpr → smt_tactic hinst_lemmas
| p@(expr.const c [])          := add_hinst_lemma_from_name md lhs_lemma c hs p
| p@(expr.local_const c _ _ _) := add_hinst_lemma_from_name md lhs_lemma c hs p
| p                          := do new_e ← to_expr p, h ← hinst_lemma.mk_core md new_e lhs_lemma,
                                   return $ hs.add h

private meta def add_hinst_lemmas_from_pexprs (md : transparency) (lhs_lemma : bool)
  (ps : list pexpr) (hs : hinst_lemmas) : smt_tactic hinst_lemmas :=
list.mfoldl (add_hinst_lemma_from_pexpr md lhs_lemma) hs ps

/--
`done` first attempts to close the goal using `contradiction`. If this fails, it creates an
SMT state and will repeatedly use `ematch` (using `ematch` lemmas in the environment,
universally quantified assumptions, and the supplied lemmas `ps`) and congruence closure.
-/
meta def done (ps : list pexpr) (cfg : auto_config := {}) : tactic unit :=
do trace_state_if_enabled `auto.done "entering done",
   contradiction <|>
   (solve1 $
     (do revert_all,
         using_smt
         (do smt_tactic.intros,
             ctx ← local_context,
             hs ← mk_hinst_lemmas ctx,
             hs' ← add_hinst_lemmas_from_pexprs reducible ff ps hs,
             smt_tactic.iterate_at_most cfg.max_ematch_rounds
               (smt_tactic.ematch_using hs' >> smt_tactic.try smt_tactic.close))))
/-!
### Tactics that perform case splits
-/
@[derive decidable_eq, derive inhabited]
inductive case_option
| force        -- fail unless all goals are solved
| at_most_one  -- leave at most one goal
| accept       -- leave as many goals as necessary

private meta def case_cont (s : case_option) (cont : case_option → tactic unit) : tactic unit :=
do match s with
   | case_option.force := cont case_option.force >> cont case_option.force
   | case_option.at_most_one :=
       -- if the first one succeeds, commit to it, and try the second
       (mcond (cont case_option.force >> return tt) (cont case_option.at_most_one) skip) <|>
       -- otherwise, try the second
       (swap >> cont case_option.force >> cont case_option.at_most_one)
   | case_option.accept := focus' [cont case_option.accept, cont case_option.accept]
   end

-- three possible outcomes:
--   finds something to case, the continuations succeed ==> returns tt
--   finds something to case, the continutations fail ==> fails
--   doesn't find anything to case ==> returns ff
meta def case_hyp (h : expr) (s : case_option) (cont : case_option → tactic unit) : tactic bool :=
do t ← infer_type h,
   match t with
   | `(%%a ∨ %%b) := cases h >> case_cont s cont >> return tt
   | _            := return ff
   end

meta def case_some_hyp_aux (s : case_option) (cont : case_option → tactic unit) :
  list expr → tactic bool
| []      := return ff
| (h::hs) := mcond (case_hyp h s cont) (return tt) (case_some_hyp_aux hs)

meta def case_some_hyp (s : case_option) (cont : case_option → tactic unit) : tactic bool :=
local_context >>= case_some_hyp_aux s cont

/-!
### The main tactics
-/

/--
`safe_core s ps cfg opt` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `s`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `ps`) and congruence closure.

`safe_core` is complete for propositional logic. Depending on the form of `opt`
it will:

- (if `opt` is `case_option.force`) fail if it does not close the goal,
- (if `opt` is `case_option.at_most_one`) fail if it produces more than one goal, and
- (if `opt` is `case_option.accept`) ignore the number of goals it produces.
-/
meta def safe_core (s : simp_lemmas × list name) (ps : list pexpr) (cfg : auto_config) :
  case_option → tactic unit :=
λ co, focus1 $
do trace_state_if_enabled `auto.finish "entering safe_core",
   if cfg.use_simp then do
     trace_if_enabled `auto.finish "simplifying hypotheses",
     simp_all s.1 s.2 { fail_if_unchanged := ff },
     trace_state_if_enabled `auto.finish "result:"
   else skip,
   tactic.done <|>
   do trace_if_enabled `auto.finish "preprocessing hypotheses",
      preprocess_hyps cfg,
      trace_state_if_enabled `auto.finish "result:",
      done ps cfg <|>
        (mcond (case_some_hyp co safe_core)
          skip
          (match co with
            | case_option.force       := done ps cfg
            | case_option.at_most_one := try (done ps cfg)
            | case_option.accept      := try (done ps cfg)
            end))

/--
`clarify` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.at_most_one`.
-/
meta def clarify (s : simp_lemmas × list name) (ps : list pexpr)
  (cfg : auto_config := {}) : tactic unit := safe_core s ps cfg case_option.at_most_one

/--
`safe` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.accept`.
-/
meta def safe (s : simp_lemmas × list name) (ps : list pexpr)
  (cfg : auto_config := {}) : tactic unit := safe_core s ps cfg case_option.accept

/--
`finish` is `safe_core`, but with the `(opt : case_option)`
parameter fixed at `case_option.force`.
-/
meta def finish (s : simp_lemmas × list name) (ps : list pexpr)
  (cfg : auto_config := {}) : tactic unit := safe_core s ps cfg case_option.force

end auto

/-! ### interactive versions -/

open auto

namespace tactic
namespace interactive

setup_tactic_parser

/--
`clarify [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`clarify` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`clarify` will fail if it produces more than one goal.
-/
meta def clarify (hs : parse simp_arg_list) (ps : parse (tk "using" *> pexpr_list_or_texpr)?)
  (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.clarify s (ps.get_or_else []) cfg

/--
`safe [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`safe` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`safe` ignores the number of goals it produces, and should never fail.
-/
meta def safe (hs : parse simp_arg_list) (ps : parse (tk "using" *> pexpr_list_or_texpr)?)
  (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.safe s (ps.get_or_else []) cfg

/--
`finish [h1,...,hn] using [e1,...,en]` negates the goal, normalizes hypotheses
(by splitting conjunctions, eliminating existentials, pushing negations inwards,
and calling `simp` with the supplied lemmas `h1,...,hn`), and then tries `contradiction`.

If this fails, it will create an SMT state and repeatedly use `ematch`
(using `ematch` lemmas in the environment, universally quantified assumptions,
and the supplied lemmas `e1,...,en`) and congruence closure.

`finish` is complete for propositional logic.

Either of the supplied simp lemmas or the supplied ematch lemmas are optional.

`finish` will fail if it does not close the goal.
-/
meta def finish (hs : parse simp_arg_list) (ps : parse (tk "using" *> pexpr_list_or_texpr)?)
  (cfg : auto_config := {}) : tactic unit :=
do s ← mk_simp_set ff [] hs,
   auto.finish s (ps.get_or_else []) cfg

add_hint_tactic "finish"

/--
These tactics do straightforward things: they call the simplifier, split conjunctive assumptions,
eliminate existential quantifiers on the left, and look for contradictions. They rely on ematching
and congruence closure to try to finish off a goal at the end.

The procedures *do* split on disjunctions and recreate the smt state for each terminal call, so
they are only meant to be used on small, straightforward problems.

* `finish`:  solves the goal or fails
* `clarify`: makes as much progress as possible while not leaving more than one goal
* `safe`:    splits freely, finishes off whatever subgoals it can, and leaves the rest

All accept an optional list of simplifier rules, typically definitions that should be expanded.
(The equations and identities should not refer to the local context.) All also accept an optional
list of `ematch` lemmas, which must be preceded by `using`.
-/
add_tactic_doc
{ name        := "finish / clarify / safe",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.finish, `tactic.interactive.clarify,
                  `tactic.interactive.safe],
  tags        := ["logic", "finishing"] }

end interactive
end tactic


import category_theory.functor.left_derived
import data.matrix.notation

import for_mathlib.homological_complex
import for_mathlib.horseshoe
import for_mathlib.les_homology
import for_mathlib.split_exact

noncomputable theory

open category_theory
open category_theory.limits
open short_exact_sequence

universes w v u

namespace category_theory

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

-- Importing `category_theory.abelian.projective` and assuming
-- `[abelian C] [enough_projectives C] [abelian D]` suffices to acquire all the following:
-- variables [preadditive C] [has_zero_object C] [has_equalizers C]
-- variables [has_images C] [has_projective_resolutions C]
-- variables [preadditive D] [has_zero_object D] [has_equalizers D] [has_cokernels D]
-- variables [has_images D] [has_image_maps D]

variables [abelian C] [enough_projectives C] [abelian D]

namespace functor
namespace left_derived

variables (F : C ⥤ D)

/-- We can compute a left derived functor using a chosen projective resolution. -/
@[simps]
def functor.left_derived_obj_iso' (F : C ⥤ D) [F.additive] (n : ℕ)
  (X : C) (P : chain_complex C ℕ) (π : P ⟶ ((chain_complex.single₀ C).obj X))
  (h : P.is_projective_resolution X π) :
  (F.left_derived n).obj X ≅
    (homology_functor D _ n).obj ((F.map_homological_complex _).obj P) :=
(F.left_derived_obj_iso n (h.mk_ProjectiveResolution P X π) : _)

/-- We can compute a left derived functor on a morphism using a lift of that morphism to a chain map
between chosen projective resolutions. -/
lemma functor.left_derived_map_eq' (F : C ⥤ D) [F.additive] (n : ℕ) (X Y : C) (f : X ⟶ Y)
  (PX : chain_complex C ℕ) (πX : PX ⟶ ((chain_complex.single₀ C).obj X))
  (PY : chain_complex C ℕ) (πY : PY ⟶ ((chain_complex.single₀ C).obj Y)) (g : PX ⟶ PY)
  (hX : PX.is_projective_resolution X πX) (hY : PY.is_projective_resolution Y πY)
  (w : g ≫ πY = πX ≫ (chain_complex.single₀ C).map f) :
  (F.left_derived n).map f =
  (functor.left_derived_obj_iso' F n X PX πX hX).hom ≫
    (homology_functor D _ n).map ((F.map_homological_complex _).map g) ≫
    (functor.left_derived_obj_iso' F n Y PY πY hY).inv :=
begin
  let PXr := (hX.mk_ProjectiveResolution PX X πX),
  let PYr := (hY.mk_ProjectiveResolution PY Y πY),
  let gr : PXr.complex ⟶ PYr.complex := g,
  simpa using functor.left_derived_map_eq F n f gr w,
end
.

abbreviation α [F.additive] :
  ((short_exact_sequence.Fst C ⋙ F).map_homological_complex (complex_shape.down ℕ)) ⟶
    ((short_exact_sequence.Snd C ⋙ F).map_homological_complex (complex_shape.down ℕ)) :=
nat_trans.map_homological_complex (whisker_right (short_exact_sequence.f_nat _) _) _

abbreviation β [F.additive] :
  ((short_exact_sequence.Snd C ⋙ F).map_homological_complex (complex_shape.down ℕ)) ⟶
    ((short_exact_sequence.Trd C ⋙ F).map_homological_complex (complex_shape.down ℕ)) :=
    nat_trans.map_homological_complex (whisker_right (short_exact_sequence.g_nat _) _) _

lemma exact_α_β_horseshoe [F.additive] (A : short_exact_sequence C) (n : ℕ) :
  short_exact (((α F).app (horseshoe A)).f n) (((β F).app (horseshoe A)).f n) :=
begin
  apply split.short_exact,
  apply split.map,
  obtain ⟨φ, χ, h1, h2, h3, h4⟩ := horseshoe_split A n,
  exact ⟨⟨φ, χ, h1, h2, short_exact_sequence.f_comp_g _, h3, h4⟩⟩,
end

def δ [F.additive] (n : ℕ) (A : short_exact_sequence C) :
  (F.left_derived (n+1)).obj A.3 ⟶ (F.left_derived n).obj A.1 :=
begin
  let f₃ := functor.left_derived_obj_iso' F (n+1) _ _ _ (horseshoe_is_projective_resolution₃ A),
  let f₁ := functor.left_derived_obj_iso' F n _ _ _ (horseshoe_is_projective_resolution₁ A),
  exact f₃.hom ≫ (homological_complex.δ _ _ (exact_α_β_horseshoe F A) _ _ rfl) ≫ f₁.symm.hom,
end

lemma exact_of_short_exact [F.additive] (n : ℕ) (A : short_exact_sequence C) :
  exact ((F.left_derived n).map A.f) ((F.left_derived n).map A.g) :=
begin
  have := ((homological_complex.six_term_exact_seq _ _
    (exact_α_β_horseshoe F A) _ n rfl).drop 3).pair,
  have H₁₂ := functor.left_derived_map_eq' F n A.1 A.2 A.f
    ((homological_complex.Fst C).obj (horseshoe A)) (horseshoe_to_single₁ A)
    ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
    ((homological_complex.Fst_Snd C).app (horseshoe A))
    (horseshoe_is_projective_resolution₁ A)
    (horseshoe_is_projective_resolution₂ A) _,
  have H₂₃ := functor.left_derived_map_eq' F n A.2 A.3 A.g
    ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
    ((homological_complex.Trd C).obj (horseshoe A)) (horseshoe_to_single₃ A)
    ((homological_complex.Snd_Trd C).app (horseshoe A))
    (horseshoe_is_projective_resolution₂ A)
    (horseshoe_is_projective_resolution₃ A) _,
  refine preadditive.exact_of_iso_of_exact' _ _ _ _ _ _ _ _ _ this,
  { let := functor.left_derived_obj_iso' F n A.1
      ((homological_complex.Fst C).obj (horseshoe A)) (horseshoe_to_single₁ A)
      (horseshoe_is_projective_resolution₁ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F n A.2
      ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
      (horseshoe_is_projective_resolution₂ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F n A.3
      ((homological_complex.Trd C).obj (horseshoe A)) (horseshoe_to_single₃ A)
      (horseshoe_is_projective_resolution₃ A),
    exact this.symm },
  { rw [H₁₂, ← category.assoc, iso.symm_hom, iso.inv_hom_id, category.id_comp],
    simpa },
  { rw [H₂₃, ← category.assoc, iso.symm_hom, iso.inv_hom_id, category.id_comp],
    simpa },
  { ext i,
    apply horseshoe_g_comp_to_single₃_f, },
  { ext i,
    apply horseshoe_f_comp_to_single₂_f }
end

lemma exact_of_short_exact.δ_right [F.additive] (n : ℕ) (A : short_exact_sequence C) :
  exact ((F.left_derived (n + 1)).map A.g) (δ F n A) :=
begin
  have := ((homological_complex.six_term_exact_seq _ _
    (exact_α_β_horseshoe F A) _ n rfl).drop 1).pair,
  have H₂₃ := functor.left_derived_map_eq' F (n+1) A.2 A.3 A.g
    ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
    ((homological_complex.Trd C).obj (horseshoe A)) (horseshoe_to_single₃ A)
    ((homological_complex.Snd_Trd C).app (horseshoe A))
    (horseshoe_is_projective_resolution₂ A)
    (horseshoe_is_projective_resolution₃ A) _,
  refine preadditive.exact_of_iso_of_exact' _ _ _ _ _ _ _ _ _ this,
  { let := functor.left_derived_obj_iso' F (n+1) A.2
      ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
      (horseshoe_is_projective_resolution₂ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F (n+1) A.3
      ((homological_complex.Trd C).obj (horseshoe A)) (horseshoe_to_single₃ A)
      (horseshoe_is_projective_resolution₃ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F n A.1
      ((homological_complex.Fst C).obj (horseshoe A)) (horseshoe_to_single₁ A)
      (horseshoe_is_projective_resolution₁ A),
    exact this.symm },
  { rw [H₂₃, ← category.assoc, iso.symm_hom, iso.inv_hom_id, category.id_comp],
    simpa },
  { unfold δ,
    dsimp,
    simp only [category.assoc, iso.inv_hom_id_assoc], },
  { ext i,
    apply horseshoe_g_comp_to_single₃_f }
end

lemma exact_of_short_exact.δ_left [F.additive] (n : ℕ) (A : short_exact_sequence C) :
  exact (δ F n A) ((F.left_derived n).map A.f) :=
begin
  have := ((homological_complex.six_term_exact_seq _ _
    (exact_α_β_horseshoe F A) _ n rfl).drop 2).pair,
  have H₁₂ := functor.left_derived_map_eq' F n A.1 A.2 A.f
    ((homological_complex.Fst C).obj (horseshoe A)) (horseshoe_to_single₁ A)
    ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
    ((homological_complex.Fst_Snd C).app (horseshoe A))
    (horseshoe_is_projective_resolution₁ A)
    (horseshoe_is_projective_resolution₂ A) _,
  refine preadditive.exact_of_iso_of_exact' _ _ _ _ _ _ _ _ _ this,
  { let := functor.left_derived_obj_iso' F (n+1) A.3
      ((homological_complex.Trd C).obj (horseshoe A)) (horseshoe_to_single₃ A)
      (horseshoe_is_projective_resolution₃ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F n A.1
      ((homological_complex.Fst C).obj (horseshoe A)) (horseshoe_to_single₁ A)
      (horseshoe_is_projective_resolution₁ A),
    exact this.symm },
  { let := functor.left_derived_obj_iso' F n A.2
      ((homological_complex.Snd C).obj (horseshoe A)) (horseshoe_to_single₂ A)
      (horseshoe_is_projective_resolution₂ A),
    exact this.symm },
  { unfold δ,
    dsimp,
    simp only [category.assoc, iso.inv_hom_id_assoc], },
  { rw [H₁₂, ← category.assoc, iso.symm_hom, iso.inv_hom_id, category.id_comp],
    simpa },
  { ext i,
    apply horseshoe_f_comp_to_single₂_f }
end

lemma six_term_exact_seq [F.additive] (n : ℕ) (A : short_exact_sequence C) :
  exact_seq D [
    (F.left_derived (n+1)).map A.f, (F.left_derived (n+1)).map A.g,
    δ F n A,
    (F.left_derived n).map A.f, (F.left_derived n).map A.g] :=
(exact_of_short_exact _ _ _).cons $
(exact_of_short_exact.δ_right _ _ _).cons $
(exact_of_short_exact.δ_left _ _ _).cons $
(exact_of_short_exact _ _ _).exact_seq

end left_derived
end functor
end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.basic
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.strong_epi
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes v₁ u₁ l

namespace Mathlib

/-!
# Definitions and basic properties of regular monomorphisms and epimorphisms.

A regular monomorphism is a morphism that is the equalizer of some parallel pair.

We give the constructions
* `split_mono → regular_mono` and
* `regular_mono → mono`
as well as the dual constructions for regular epimorphisms. Additionally, we give the
construction
* `regular_epi ⟶ strong_epi`.

-/

namespace category_theory

/-- A regular monomorphism is a morphism which is the equalizer of some parallel pair. -/
class regular_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  Z : C
  left : Y ⟶ Z
  right : Y ⟶ Z
  w : f ≫ left = f ≫ right
  is_limit : limits.is_limit (limits.fork.of_ι f w)

theorem regular_mono.w_assoc {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [c : regular_mono f] {X' : C} (f' : regular_mono.Z f ⟶ X') : f ≫ regular_mono.left ≫ f' = f ≫ regular_mono.right ≫ f' := sorry

/-- Every regular monomorphism is a monomorphism. -/
protected instance regular_mono.mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [regular_mono f] : mono f :=
  limits.mono_of_is_limit_parallel_pair regular_mono.is_limit

protected instance equalizer_regular {C : Type u₁} [category C] {X : C} {Y : C} (g : X ⟶ Y) (h : X ⟶ Y) [limits.has_limit (limits.parallel_pair g h)] : regular_mono (limits.equalizer.ι g h) :=
  regular_mono.mk Y g h (limits.equalizer.condition g h)
    (limits.fork.is_limit.mk (limits.fork.of_ι (limits.equalizer.ι g h) (limits.equalizer.condition g h))
      (fun (s : limits.fork g h) => limits.limit.lift (limits.parallel_pair g h) s) sorry sorry)

/-- Every split monomorphism is a regular monomorphism. -/
protected instance regular_mono.of_split_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_mono f] : regular_mono f :=
  regular_mono.mk Y 𝟙 (retraction f ≫ f) (limits.cone_of_split_mono._proof_1 f) (limits.split_mono_equalizes f)

/-- If `f` is a regular mono, then any map `k : W ⟶ Y` equalizing `regular_mono.left` and
    `regular_mono.right` induces a morphism `l : W ⟶ X` such that `l ≫ f = k`. -/
def regular_mono.lift' {C : Type u₁} [category C] {X : C} {Y : C} {W : C} (f : X ⟶ Y) [regular_mono f] (k : W ⟶ Y) (h : k ≫ regular_mono.left = k ≫ regular_mono.right) : Subtype fun (l : W ⟶ X) => l ≫ f = k :=
  limits.fork.is_limit.lift' regular_mono.is_limit k h

/--
The second leg of a pullback cone is a regular monomorphism if the right component is too.

See also `pullback.snd_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_fst_of_regular` for the flipped version.
-/
def regular_of_is_pullback_snd_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [hr : regular_mono h] (comm : f ≫ h = g ≫ k) (t : limits.is_limit (limits.pullback_cone.mk f g comm)) : regular_mono g := sorry

/--
The first leg of a pullback cone is a regular monomorphism if the left component is too.

See also `pullback.fst_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_snd_of_regular` for the flipped version.
-/
def regular_of_is_pullback_fst_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [hr : regular_mono k] (comm : f ≫ h = g ≫ k) (t : limits.is_limit (limits.pullback_cone.mk f g comm)) : regular_mono f :=
  regular_of_is_pullback_snd_of_regular sorry (limits.pullback_cone.flip_is_limit t)

/-- A regular monomorphism is an isomorphism if it is an epimorphism. -/
def is_iso_of_regular_mono_of_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [regular_mono f] [e : epi f] : is_iso f :=
  limits.is_iso_limit_cone_parallel_pair_of_epi regular_mono.is_limit

/-- A regular epimorphism is a morphism which is the coequalizer of some parallel pair. -/
class regular_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
where
  W : C
  left : W ⟶ X
  right : W ⟶ X
  w : left ≫ f = right ≫ f
  is_colimit : limits.is_colimit (limits.cofork.of_π f w)

theorem regular_epi.w_assoc {C : Type u₁} [category C] {X : C} {Y : C} {f : X ⟶ Y} [c : regular_epi f] {X' : C} (f' : Y ⟶ X') : regular_epi.left ≫ f ≫ f' = regular_epi.right ≫ f ≫ f' := sorry

/-- Every regular epimorphism is an epimorphism. -/
protected instance regular_epi.epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [regular_epi f] : epi f :=
  limits.epi_of_is_colimit_parallel_pair regular_epi.is_colimit

protected instance coequalizer_regular {C : Type u₁} [category C] {X : C} {Y : C} (g : X ⟶ Y) (h : X ⟶ Y) [limits.has_colimit (limits.parallel_pair g h)] : regular_epi (limits.coequalizer.π g h) :=
  regular_epi.mk X g h (limits.coequalizer.condition g h)
    (limits.cofork.is_colimit.mk (limits.cofork.of_π (limits.coequalizer.π g h) (limits.coequalizer.condition g h))
      (fun (s : limits.cofork g h) => limits.colimit.desc (limits.parallel_pair g h) s) sorry sorry)

/-- Every split epimorphism is a regular epimorphism. -/
protected instance regular_epi.of_split_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [split_epi f] : regular_epi f :=
  regular_epi.mk X 𝟙 (f ≫ section_ f) (limits.cocone_of_split_epi._proof_1 f) (limits.split_epi_coequalizes f)

/-- If `f` is a regular epi, then every morphism `k : X ⟶ W` coequalizing `regular_epi.left` and
    `regular_epi.right` induces `l : Y ⟶ W` such that `f ≫ l = k`. -/
def regular_epi.desc' {C : Type u₁} [category C] {X : C} {Y : C} {W : C} (f : X ⟶ Y) [regular_epi f] (k : X ⟶ W) (h : regular_epi.left ≫ k = regular_epi.right ≫ k) : Subtype fun (l : Y ⟶ W) => f ≫ l = k :=
  limits.cofork.is_colimit.desc' regular_epi.is_colimit k h

/--
The second leg of a pushout cocone is a regular epimorphism if the right component is too.

See also `pushout.snd_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_fst_of_regular` for the flipped version.
-/
def regular_of_is_pushout_snd_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [gr : regular_epi g] (comm : f ≫ h = g ≫ k) (t : limits.is_colimit (limits.pushout_cocone.mk h k comm)) : regular_epi h := sorry

/--
The first leg of a pushout cocone is a regular epimorphism if the left component is too.

See also `pushout.fst_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_snd_of_regular` for the flipped version.
-/
def regular_of_is_pushout_fst_of_regular {C : Type u₁} [category C] {P : C} {Q : C} {R : C} {S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S} [fr : regular_epi f] (comm : f ≫ h = g ≫ k) (t : limits.is_colimit (limits.pushout_cocone.mk h k comm)) : regular_epi k :=
  regular_of_is_pushout_snd_of_regular sorry (limits.pushout_cocone.flip_is_colimit t)

/-- A regular epimorphism is an isomorphism if it is a monomorphism. -/
def is_iso_of_regular_epi_of_mono {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [regular_epi f] [m : mono f] : is_iso f :=
  limits.is_iso_limit_cocone_parallel_pair_of_epi regular_epi.is_colimit

protected instance strong_epi_of_regular_epi {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y) [regular_epi f] : strong_epi f := sorry