/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Nicolò Cavalleri.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.lie.basic
import Mathlib.ring_theory.algebra_tower
import Mathlib.PostPort

universes u_1 u_2 u_3 l u_4

namespace Mathlib

/-!
# Derivations

This file defines derivation. A derivation `D` from the `R`-algebra `A` to the `A`-module `M` is an
`R`-linear map that satisfy the Leibniz rule `D (a * b) = a * D b + D a * b`.

## Notation

The notation `⁅D1, D2⁆` is used for the commutator of two derivations.

TODO: this file is just a stub to go on with some PRs in the geometry section. It only
implements the definition of derivations in commutative algebra. This will soon change: as soon
as bimodules will be there in mathlib I will change this file to take into account the
non-commutative case. Any development on the theory of derivations is discouraged until the
definitive definition of derivation will be implemented.
-/

/-- `D : derivation R A M` is an `R`-linear map from `A` to `M` that satisfies the `leibniz`
equality.
TODO: update this when bimodules are defined. -/
structure derivation (R : Type u_1) (A : Type u_2) [comm_semiring R] [comm_semiring A] [algebra R A] (M : Type u_3) [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M]
extends linear_map R A M
where
  leibniz' : ∀ (a b : A),
  linear_map.to_fun _to_linear_map (a * b) =
    a • linear_map.to_fun _to_linear_map b + b • linear_map.to_fun _to_linear_map a

namespace derivation

protected instance has_coe_to_fun {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : has_coe_to_fun (derivation R A M) :=
  has_coe_to_fun.mk (fun (D : derivation R A M) => A → M)
    fun (D : derivation R A M) => linear_map.to_fun (derivation.to_linear_map D)

protected instance has_coe_to_linear_map {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : has_coe (derivation R A M) (linear_map R A M) :=
  has_coe.mk fun (D : derivation R A M) => derivation.to_linear_map D

@[simp] theorem to_fun_eq_coe {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) : linear_map.to_fun (derivation.to_linear_map D) = ⇑D :=
  rfl

@[simp] theorem coe_fn_coe {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (f : derivation R A M) : ⇑↑f = ⇑f :=
  rfl

theorem coe_injective {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (H : ⇑D1 = ⇑D2) : D1 = D2 := sorry

theorem ext {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (H : ∀ (a : A), coe_fn D1 a = coe_fn D2 a) : D1 = D2 :=
  coe_injective (funext H)

@[simp] theorem map_add {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) : coe_fn D (a + b) = coe_fn D a + coe_fn D b :=
  is_add_hom.map_add (⇑D) a b

@[simp] theorem map_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) : coe_fn D 0 = 0 :=
  is_add_monoid_hom.map_zero ⇑D

@[simp] theorem map_smul {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (r : R) (a : A) : coe_fn D (r • a) = r • coe_fn D a :=
  linear_map.map_smul (↑D) r a

@[simp] theorem leibniz {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) : coe_fn D (a * b) = a • coe_fn D b + b • coe_fn D a :=
  derivation.leibniz' D a b

@[simp] theorem map_one_eq_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) : coe_fn D 1 = 0 := sorry

@[simp] theorem map_algebra_map {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (r : R) : coe_fn D (coe_fn (algebra_map R A) r) = 0 := sorry

protected instance has_zero {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : HasZero (derivation R A M) :=
  { zero := mk 0 sorry }

protected instance inhabited {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : Inhabited (derivation R A M) :=
  { default := 0 }

protected instance add_comm_monoid {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : add_comm_monoid (derivation R A M) :=
  add_comm_monoid.mk (fun (D1 D2 : derivation R A M) => mk (↑D1 + ↑D2) sorry) sorry 0 sorry sorry sorry

@[simp] theorem add_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (a : A) : coe_fn (D1 + D2) a = coe_fn D1 a + coe_fn D2 a :=
  rfl

protected instance derivation.Rsemimodule {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : semimodule R (derivation R A M) :=
  semimodule.mk sorry sorry

@[simp] theorem smul_to_linear_map_coe {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (r : R) : ↑(r • D) = r • ↑D :=
  rfl

@[simp] theorem Rsmul_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (r : R) (a : A) : coe_fn (r • D) a = r • coe_fn D a :=
  rfl

protected instance semimodule {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : semimodule A (derivation R A M) :=
  semimodule.mk sorry sorry

@[simp] theorem smul_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) : coe_fn (a • D) b = a • coe_fn D b :=
  rfl

protected instance is_scalar_tower {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] [is_scalar_tower R A M] : is_scalar_tower R A (derivation R A M) :=
  is_scalar_tower.mk fun (x : R) (y : A) (z : derivation R A M) => ext fun (a : A) => smul_assoc x y (coe_fn (↑z) a)

@[simp] theorem map_neg {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M] (D : derivation R A M) (a : A) : coe_fn D (-a) = -coe_fn D a :=
  linear_map.map_neg (↑D) a

@[simp] theorem map_sub {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M] (D : derivation R A M) (a : A) (b : A) : coe_fn D (a - b) = coe_fn D a - coe_fn D b :=
  linear_map.map_sub (↑D) a b

protected instance add_comm_group {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M] : add_comm_group (derivation R A M) :=
  add_comm_group.mk add_comm_monoid.add sorry add_comm_monoid.zero sorry sorry
    (fun (D : derivation R A M) => mk (-↑D) sorry) (fun (D1 D2 : derivation R A M) => mk (↑D1 - ↑D2) sorry) sorry sorry

@[simp] theorem sub_apply {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {M : Type u_3} [add_comm_group M] [module A M] [module R M] [is_scalar_tower R A M] {D1 : derivation R A M} {D2 : derivation R A M} (a : A) : coe_fn (D1 - D2) a = coe_fn D1 a - coe_fn D2 a :=
  rfl

/-! # Lie structures -/

/-- The commutator of derivations is again a derivation. -/
def commutator {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] (D1 : derivation R A A) (D2 : derivation R A A) : derivation R A A :=
  mk (linear_map.mk (linear_map.to_fun (has_bracket.bracket ↑D1 ↑D2)) sorry sorry) sorry

protected instance has_bracket {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] : has_bracket (derivation R A A) (derivation R A A) :=
  has_bracket.mk commutator

@[simp] theorem commutator_coe_linear_map {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {D1 : derivation R A A} {D2 : derivation R A A} : ↑(has_bracket.bracket D1 D2) = has_bracket.bracket ↑D1 ↑D2 :=
  rfl

theorem commutator_apply {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] {D1 : derivation R A A} {D2 : derivation R A A} (a : A) : coe_fn (has_bracket.bracket D1 D2) a = coe_fn D1 (coe_fn D2 a) - coe_fn D2 (coe_fn D1 a) :=
  rfl

protected instance lie_ring {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] : lie_ring (derivation R A A) :=
  lie_ring.mk sorry sorry sorry sorry

protected instance lie_algebra {R : Type u_1} [comm_ring R] {A : Type u_2} [comm_ring A] [algebra R A] : lie_algebra R (derivation R A A) :=
  lie_algebra.mk sorry

end derivation

namespace linear_map

/-- The composition of a linear map and a derivation is a derivation. -/
def comp_der {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] {N : Type u_4} [add_cancel_comm_monoid N] [semimodule A N] [semimodule R N] [is_scalar_tower R A M] [is_scalar_tower R A N] (f : linear_map A M N) (D : derivation R A M) : derivation R A N :=
  derivation.mk (mk (fun (a : A) => coe_fn f (coe_fn D a)) sorry sorry) sorry

@[simp] theorem comp_der_apply {R : Type u_1} [comm_semiring R] {A : Type u_2} [comm_semiring A] [algebra R A] {M : Type u_3} [add_cancel_comm_monoid M] [semimodule A M] [semimodule R M] {N : Type u_4} [add_cancel_comm_monoid N] [semimodule A N] [semimodule R N] [is_scalar_tower R A M] [is_scalar_tower R A N] (f : linear_map A M N) (D : derivation R A M) (a : A) : coe_fn (comp_der f D) a = coe_fn f (coe_fn D a) :=
  rfl


import ..src.struct_tact

inductive t
| C1 : int → t
| C2 : int → t
| C3 : int → t

def foo (xs : t × t) : int :=
let z := 10 in
match xs with
| (t.C1 i, t.C2 j) := i + j + z
| (t.C2 j, t.C1 i) := j + i + z
| (_, _) := 0
end

lemma nested_break_match :
   forall i j, foo (t.C2 i, t.C1 j) = foo (t.C1 j, t.C2 i) :=
begin
    -- intros,
    -- unfold foo,
    -- dsimp,
    -- break_match,
    admit,
end


import tactic
import data.list.func

universe u

def list2d (α : Type u) := list (list α)

namespace list2d

open list.func

variables {α : Type} {β : Type} {γ : Type} {δ : Type}
variables [inhabited α] [inhabited β]

def get2d (xy : ℕ × ℕ) (l : list2d α) : α
  := let (x,y) := xy in get x (get y l)
def set2d (a : α) (l : list2d α) (xy : ℕ × ℕ) : list2d α
  := let (x,y) := xy in set (set a (get y l) x) l y
def map2d (f : γ → δ) : list2d γ → list2d δ
  := list.map (list.map f)
def fold2d (f : γ → δ → δ) : δ → list2d γ → δ
  := list.foldr (function.swap (list.foldr f))
def pointwise2d (f : α → β → γ) : list2d α → list2d β → list2d γ
  := pointwise (pointwise f)
def dfzip2d : list2d α → list2d β → list2d (α × β)
  := pointwise2d prod.mk

def equiv (l1 l2 : list2d α)
  := ∀ (xy : ℕ × ℕ), l1.get2d xy = l2.get2d xy

def add_to_line1 (a : α) : list2d α -> list2d α
| [] := [[a]]
| (h::t) := (a::h)::t

@[simp] lemma get2d_nil : ∀ xy : ℕ×ℕ, get2d xy ([] : list2d α) = default α
| (x,y) := by simp [get2d, default]

def transpose : list2d α → list2d α := (list.foldr (pointwise list.cons)) []

instance [has_repr α] : has_repr (list2d α) := ⟨λ l, list.repr (l : list (list α))⟩

private lemma g_get_pointwise {δ : Type} [inhabited γ] {f : α → β → γ} (g : γ -> δ)
  (h1 : g (f (default α) (default β)) = g (default γ)) :
  ∀ (k : nat) (as : list α) (bs : list β),
  g (get k (pointwise f as bs)) = g (f (get k as) (get k bs))
| k [] [] := by simp only [h1, get_nil, list.func.pointwise, list.func.get]
| 0 [] (b::bs) :=
  by simp only [get_pointwise, get_nil,
      list.func.pointwise, list.func.get, nat.nat_zero_eq_zero, list.map]
| (k+1) [] (b::bs) :=
  by { have : g (get k (list.map (f $ default α) bs)) = g (f (default α) (get k bs)),
       { simpa [nil_pointwise, get_nil] using (g_get_pointwise k [] bs) },
       simpa [list.func.get, get_nil, pointwise, list.map] }
| 0 (a::as) [] :=
  by simp only [g_get_pointwise, get_nil,
     list.func.pointwise, list.func.get, nat.nat_zero_eq_zero, list.map]
| (k+1) (a::as) [] :=
  by simpa [list.func.get, get_nil, pointwise, list.map, pointwise_nil, get_nil]
     using g_get_pointwise k as []
| 0 (a::as) (b::bs) := by simp only [list.func.pointwise, list.func.get]
| (k+1) (a::as) (b::bs) :=
  by simp only [list.func.pointwise, list.func.get, g_get_pointwise k]

@[simp] theorem get2d_transpose : ∀ (xy : ℕ × ℕ) (l : list2d α),
  get2d xy (transpose l) = get2d (prod.swap xy) l :=
begin
  intros, cases xy with x y, simp, revert x, induction l, {
    intros, unfold transpose, unfold get2d,
    simp [default],
  }, {
    intros, unfold get2d, unfold transpose,
    simp [list.foldr], rewrite g_get_pointwise (get x),
    cases x, refl, apply l_ih,
    simp [default], cases x, refl, simp,
  }
end

@[simp] theorem map_pointwise {δ : Type}
  (f : α → β → γ) (g : γ → δ) : ∀ (l1 : list α) (l2 : list β),
  list.map g (list.func.pointwise f l1 l2)
  = list.func.pointwise (λ a b, g (f a b)) l1 l2
| [] [] := by simp
| (a::as) [] := by simp
| [] (b::bs) := by simp
| (a::as) (b::bs) := by simp [(map_pointwise as bs)]

@[simp] theorem map_map_circ {δ2 : Type} (f : δ → δ2) (g : γ → δ) : (list.map f) ∘ (list.map g) = list.map (f ∘ g) :=
begin apply funext, simp end

theorem nil_pointwise_curry {f : α → β → γ} : pointwise f list.nil = list.map (f (default α)) := begin apply funext, intros, apply nil_pointwise end

theorem map_pointwise2d
  (f : α → β → γ) (g : γ → δ) : ∀ (l1 : list2d α) (l2 : list2d β),
  map2d g (pointwise2d f l1 l2)
  = pointwise2d (λ a b, g (f a b)) l1 l2 :=
begin
  intros, unfold map2d, unfold pointwise2d, simp
end

theorem pointwise_dfzip2d
  (f : α → β → γ) : ∀ (l1 : list2d α) (l2 : list2d β),
  pointwise2d f l1 l2 =
(pointwise2d prod.mk l1 l2).map2d (λ ab, match ab with (a,b) := f a b end) :=
by simp [map_pointwise2d]

theorem get2d_pointwise [inhabited γ] {f : α → β → γ}
  (H : f (default α) (default β) = default γ) :
  ∀ (xy : ℕ×ℕ) (as : list2d α) (bs : list2d β),
  get2d xy (pointwise2d f as bs) = f (get2d xy as) (get2d xy bs) :=
begin
  intros, cases xy with x y, unfold get2d, unfold pointwise2d,
  repeat { rw list.func.get_pointwise, }, exact H,
  simp! [default],
end

theorem get2d_set2d {a : α} {xy : ℕ×ℕ} {l : list2d α} : (l.set2d a xy).get2d xy = a :=
begin
  cases xy with x y, unfold get2d, unfold set2d, simp!,
end
theorem get2d_set2d_eq_of_ne {a : α} {xy1 xy2 : ℕ×ℕ} {l : list2d α}
  : xy1 ≠ xy2 → (l.set2d a xy2).get2d xy1 = (l.get2d xy1) :=
begin
  cases xy1 with x1 y1,
  cases xy2 with x2 y2,
  unfold get2d, unfold set2d,
  intro H,
  by_cases Hy : y1 = y2, {
    rw Hy, rw Hy at H, rw get_set,
    by_cases Hx : x1 = x2,
    { exfalso, rw Hx at H, exact H rfl, },
    { exact get_set_eq_of_ne x2 x1 Hx, },
  }, {
    apply congr_arg, exact get_set_eq_of_ne y2 y1 Hy,
  },
end

end list2d


/-
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.traversable.lemmas
import logic.equiv.basic

/-!
# Transferring `traversable` instances along isomorphisms

This file allows to transfer `traversable` instances along isomorphisms.

## Main declarations

* `equiv.map`: Turns functorially a function `α → β` into a function `t' α → t' β` using the functor
  `t` and the equivalence `Π α, t α ≃ t' α`.
* `equiv.functor`: `equiv.map` as a functor.
* `equiv.traverse`: Turns traversably a function `α → m β` into a function `t' α → m (t' β)` using
  the traversable functor `t` and the equivalence `Π α, t α ≃ t' α`.
* `equiv.traversable`: `equiv.traverse` as a traversable functor.
* `equiv.is_lawful_traversable`: `equiv.traverse` as a lawful traversable functor.
-/

universes u

namespace equiv

section functor
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [functor t]

open functor

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {α β : Type u} (f : α → β) (x : t' α) : t' β :=
eqv β $ map f ((eqv α).symm x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor : functor t' :=
{ map := @equiv.map _ }

variables [is_lawful_functor t]

protected lemma id_map {α : Type u} (x : t' α) : equiv.map id x = x :=
by simp [equiv.map, id_map]

protected lemma comp_map {α β γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
  equiv.map (h ∘ g) x = equiv.map h (equiv.map g x) :=
by simp [equiv.map]; apply comp_map

protected lemma is_lawful_functor : @is_lawful_functor _ equiv.functor :=
{ id_map := @equiv.id_map _ _,
  comp_map := @equiv.comp_map _ _ }

protected lemma is_lawful_functor' [F : _root_.functor t']
  (h₀ : ∀ {α β} (f : α → β), _root_.functor.map f = equiv.map f)
  (h₁ : ∀ {α β} (f : β), _root_.functor.map_const f = (equiv.map ∘ function.const α) f) :
  _root_.is_lawful_functor t' :=
begin
  have : F = equiv.functor,
  { casesI F, dsimp [equiv.functor],
    congr; ext; [rw ← h₀, rw ← h₁] },
  substI this,
  exact equiv.is_lawful_functor
end

end functor

section traversable
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t]
variables {m : Type u → Type u} [applicative m]
variables {α β : Type u}

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse (f : α → m β) (x : t' α) : m (t' β) :=
eqv β <$> traverse f ((eqv α).symm x)

/-- The function `equiv.traverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable : traversable t' :=
{ to_functor := equiv.functor eqv,
  traverse := @equiv.traverse _ }

end traversable

section equiv
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t] [is_lawful_traversable t]
variables {F G : Type u → Type u} [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]
variables (η : applicative_transformation F G)
variables {α β γ : Type u}

open is_lawful_traversable functor

protected lemma id_traverse (x : t' α) :
  equiv.traverse eqv id.mk x = x :=
by simp! [equiv.traverse,id_bind,id_traverse,functor.map] with functor_norm

protected lemma traverse_eq_map_id (f : α → β) (x : t' α) :
  equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
by simp [equiv.traverse, traverse_eq_map_id] with functor_norm; refl

protected lemma comp_traverse (f : β → F γ) (g : α → G β) (x : t' α) :
  equiv.traverse eqv (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
by simp [equiv.traverse,comp_traverse] with functor_norm; congr; ext; simp

protected lemma naturality (f : α → F β) (x : t' α) :
  η (equiv.traverse eqv f x) = equiv.traverse eqv (@η _ ∘ f) x :=
by simp only [equiv.traverse] with functor_norm

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable : @is_lawful_traversable t' (equiv.traversable eqv) :=
{ to_is_lawful_functor := @equiv.is_lawful_functor _ _ eqv _ _,
  id_traverse := @equiv.id_traverse _ _,
  comp_traverse := @equiv.comp_traverse _ _,
  traverse_eq_map_id := @equiv.traverse_eq_map_id _ _,
  naturality := @equiv.naturality _ _ }

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the fact that `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' [_i : traversable t']
  (h₀ : ∀ {α β} (f : α → β),
         map f = equiv.map eqv f)
  (h₁ : ∀ {α β} (f : β),
         map_const f = (equiv.map eqv ∘ function.const α) f)
  (h₂ : ∀ {F : Type u → Type u} [applicative F],
        by exactI ∀ [is_lawful_applicative F]
          {α β} (f : α → F β),
         traverse f = equiv.traverse eqv f) :
  _root_.is_lawful_traversable t' :=
begin
    -- we can't use the same approach as for `is_lawful_functor'` because
    -- h₂ needs a `is_lawful_applicative` assumption
  refine {to_is_lawful_functor :=
    equiv.is_lawful_functor' eqv @h₀ @h₁, ..}; introsI,
  { rw [h₂, equiv.id_traverse], apply_instance },
  { rw [h₂, equiv.comp_traverse f g x, h₂], congr,
    rw [h₂], all_goals { apply_instance } },
  { rw [h₂, equiv.traverse_eq_map_id, h₀]; apply_instance },
  { rw [h₂, equiv.naturality, h₂]; apply_instance }
end

end equiv
end equiv


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

! This file was ported from Lean 3 source module data.option.defs
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

/-!
# Extra definitions on `option`

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

This file defines more operations involving `option α`. Lemmas about them are located in other
files under `data.option.`.
Other basic operations on `option` are defined in the core library.
-/

namespace Option

variable {α : Type _} {β : Type _}

attribute [inline] Option.isSome Option.isNone

#print Option.elim' /-
/-- An elimination principle for `option`. It is a nondependent version of `option.rec`. -/
@[simp]
protected def elim' (b : β) (f : α → β) : Option α → β
  | some a => f a
  | none => b
#align option.elim Option.elim'
-/

instance hasMem : Membership α (Option α) :=
  ⟨fun a b => b = some a⟩
#align option.has_mem Option.hasMem

#print Option.mem_def /-
@[simp]
theorem mem_def {a : α} {b : Option α} : a ∈ b ↔ b = some a :=
  Iff.rfl
#align option.mem_def Option.mem_def
-/

#print Option.mem_iff /-
theorem mem_iff {a : α} {b : Option α} : a ∈ b ↔ b = a :=
  Iff.rfl
#align option.mem_iff Option.mem_iff
-/

#print Option.isNone_iff_eq_none /-
theorem isNone_iff_eq_none {o : Option α} : o.isNone = true ↔ o = none :=
  ⟨Option.eq_none_of_isNone, fun e => e.symm ▸ rfl⟩
#align option.is_none_iff_eq_none Option.isNone_iff_eq_none
-/

#print Option.some_inj /-
theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp
#align option.some_inj Option.some_inj
-/

#print Option.mem_some_iff /-
theorem mem_some_iff {α : Type _} {a b : α} : a ∈ some b ↔ b = a := by simp
#align option.mem_some_iff Option.mem_some_iff
-/

#print Option.decidable_eq_none /-
/-- `o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
@[inline]
def decidable_eq_none {o : Option α} : Decidable (o = none) :=
  decidable_of_decidable_of_iff (Bool.decidableEq _ _) isNone_iff_eq_none
#align option.decidable_eq_none Option.decidable_eq_none
-/

#print Option.decidableForallMem /-
instance decidableForallMem {p : α → Prop} [DecidablePred p] :
    ∀ o : Option α, Decidable (∀ a ∈ o, p a)
  | none => isTrue (by simp [false_imp_iff])
  | some a =>
    if h : p a then isTrue fun o e => some_inj.1 e ▸ h else isFalse <| mt (fun H => H _ rfl) h
#align option.decidable_forall_mem Option.decidableForallMem
-/

/- warning: option.decidable_exists_mem -> Option.decidableExistsMem is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {p : α -> Prop} [_inst_1 : DecidablePred.{succ u1} α p] (o : Option.{u1} α), Decidable (Exists.{succ u1} α (fun (a : α) => Exists.{0} (Membership.Mem.{u1, u1} α (Option.{u1} α) (Option.hasMem.{u1} α) a o) (fun (H : Membership.Mem.{u1, u1} α (Option.{u1} α) (Option.hasMem.{u1} α) a o) => p a)))
but is expected to have type
  forall {α : Type.{u1}} {p : α -> Prop} [_inst_1 : DecidablePred.{succ u1} α p] (o : Option.{u1} α), Decidable (Exists.{succ u1} α (fun (a : α) => And (Membership.mem.{u1, u1} α (Option.{u1} α) (Option.instMembershipOption.{u1} α) a o) (p a)))
Case conversion may be inaccurate. Consider using '#align option.decidable_exists_mem Option.decidableExistsMemₓ'. -/
instance decidableExistsMem {p : α → Prop} [DecidablePred p] :
    ∀ o : Option α, Decidable (∃ a ∈ o, p a)
  | none => isFalse fun ⟨a, ⟨h, _⟩⟩ => by cases h
  | some a => if h : p a then isTrue <| ⟨_, rfl, h⟩ else isFalse fun ⟨_, ⟨rfl, hn⟩⟩ => h hn
#align option.decidable_exists_mem Option.decidableExistsMem

#print Option.iget /-
/-- Inhabited `get` function. Returns `a` if the input is `some a`, otherwise returns `default`. -/
@[reducible]
def iget [Inhabited α] : Option α → α
  | some x => x
  | none => default
#align option.iget Option.iget
-/

#print Option.iget_some /-
@[simp]
theorem iget_some [Inhabited α] {a : α} : (some a).iget = a :=
  rfl
#align option.iget_some Option.iget_some
-/

#print Option.guard /-
/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [DecidablePred p] (a : α) : Option α :=
  if p a then some a else none
#align option.guard Option.guard
-/

/- warning: option.filter -> Option.filter is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (p : α -> Prop) [_inst_1 : DecidablePred.{succ u1} α p], (Option.{u1} α) -> (Option.{u1} α)
but is expected to have type
  forall {α : Type.{u1}}, (α -> Bool) -> (Option.{u1} α) -> (Option.{u1} α)
Case conversion may be inaccurate. Consider using '#align option.filter Option.filterₓ'. -/
/-- `filter p o` returns `some a` if `o` is `some a` and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [DecidablePred p] (o : Option α) : Option α :=
  o.bind (guard p)
#align option.filter Option.filter

#print Option.toList /-
/-- Cast of `option` to `list `. Returns `[a]` if the input is `some a`, and `[]` if it is
`none`. -/
def toList : Option α → List α
  | none => []
  | some a => [a]
#align option.to_list Option.toList
-/

#print Option.mem_toList /-
@[simp]
theorem mem_toList {a : α} {o : Option α} : a ∈ toList o ↔ a ∈ o := by
  cases o <;> simp [to_list, eq_comm]
#align option.mem_to_list Option.mem_toList
-/

#print Option.liftOrGet /-
/-- Two arguments failsafe function. Returns `f a b` if the inputs are `some a` and `some b`, and
"does nothing" otherwise. -/
def liftOrGet (f : α → α → α) : Option α → Option α → Option α
  | none, none => none
  | some a, none => some a
  |-- get a
    none,
    some b => some b
  |-- get b
      some
      a,
    some b => some (f a b)
#align option.lift_or_get Option.liftOrGet
-/

#print Option.liftOrGet_isCommutative /-
-- lift f
instance liftOrGet_isCommutative (f : α → α → α) [h : IsCommutative α f] :
    IsCommutative (Option α) (liftOrGet f) :=
  ⟨fun a b => by cases a <;> cases b <;> simp [lift_or_get, h.comm]⟩
#align option.lift_or_get_comm Option.liftOrGet_isCommutative
-/

#print Option.liftOrGet_isAssociative /-
instance liftOrGet_isAssociative (f : α → α → α) [h : IsAssociative α f] :
    IsAssociative (Option α) (liftOrGet f) :=
  ⟨fun a b c => by cases a <;> cases b <;> cases c <;> simp [lift_or_get, h.assoc]⟩
#align option.lift_or_get_assoc Option.liftOrGet_isAssociative
-/

#print Option.liftOrGet_isIdempotent /-
instance liftOrGet_isIdempotent (f : α → α → α) [h : IsIdempotent α f] :
    IsIdempotent (Option α) (liftOrGet f) :=
  ⟨fun a => by cases a <;> simp [lift_or_get, h.idempotent]⟩
#align option.lift_or_get_idem Option.liftOrGet_isIdempotent
-/

#print Option.liftOrGet_isLeftId /-
instance liftOrGet_isLeftId (f : α → α → α) : IsLeftId (Option α) (liftOrGet f) none :=
  ⟨fun a => by cases a <;> simp [lift_or_get]⟩
#align option.lift_or_get_is_left_id Option.liftOrGet_isLeftId
-/

#print Option.liftOrGet_isRightId /-
instance liftOrGet_isRightId (f : α → α → α) : IsRightId (Option α) (liftOrGet f) none :=
  ⟨fun a => by cases a <;> simp [lift_or_get]⟩
#align option.lift_or_get_is_right_id Option.liftOrGet_isRightId
-/

#print Option.Rel /-
/-- Lifts a relation `α → β → Prop` to a relation `option α → option β → Prop` by just adding
`none ~ none`. -/
inductive Rel (r : α → β → Prop) : Option α → Option β → Prop/--
If `a ~ b`, then `some a ~ some b` -/

  | some {a b} : r a b → Rel (some a) (some b)/-- `none ~ none` -/

  | none : Rel none none
#align option.rel Option.Rel
-/

#print Option.pbind /-
/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp]
def pbind : ∀ x : Option α, (∀ a : α, a ∈ x → Option β) → Option β
  | none, _ => none
  | some a, f => f a rfl
#align option.pbind Option.pbind
-/

#print Option.pmap /-
/-- Partial map. If `f : Π a, p a → β` is a partial function defined on `a : α` satisfying `p`,
then `pmap f x h` is essentially the same as `map f x` but is defined only when all members of `x`
satisfy `p`, using the proof to apply `f`. -/
@[simp]
def pmap {p : α → Prop} (f : ∀ a : α, p a → β) : ∀ x : Option α, (∀ a ∈ x, p a) → Option β
  | none, _ => none
  | some a, H => some (f a (H a (mem_def.mpr rfl)))
#align option.pmap Option.pmap
-/

#print Option.join /-
/-- Flatten an `option` of `option`, a specialization of `mjoin`. -/
@[simp]
def join : Option (Option α) → Option α := fun x => bind x id
#align option.join Option.join
-/

#print Option.traverse /-
protected def traverse.{u, v} {F : Type u → Type v} [Applicative F] {α β : Type _} (f : α → F β) :
    Option α → F (Option β)
  | none => pure none
  | some x => some <$> f x
#align option.traverse Option.traverse
-/

#print Option.maybe /-
-- By analogy with `monad.sequence` in `init/category/combinators.lean`.
/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def maybe.{u, v} {m : Type u → Type v} [Monad m] {α : Type u} : Option (m α) → m (Option α)
  | none => return none
  | some fn => some <$> fn
#align option.maybe Option.maybe
-/

/- warning: option.mmap -> Option.mapM is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m] {α : Type.{u3}} {β : Type.{u1}}, (α -> (m β)) -> (Option.{u3} α) -> (m (Option.{u1} β))
but is expected to have type
  forall {m : Type.{u1} -> Type.{u2}} {_inst_1 : Type.{u3}} {α : Type.{u1}} [β : Monad.{u1, u2} m], (_inst_1 -> (m α)) -> (Option.{u3} _inst_1) -> (m (Option.{u1} α))
Case conversion may be inaccurate. Consider using '#align option.mmap Option.mapMₓ'. -/
/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def mapM.{u, v, w} {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β)
    (o : Option α) : m (Option β) :=
  (o.map f).maybe
#align option.mmap Option.mapM

/- warning: option.melim -> Option.elimM is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u1}} {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m], (m β) -> (α -> (m β)) -> (m (Option.{u1} α)) -> (m β)
but is expected to have type
  forall {α : Type.{u1} -> Type.{u2}} {β : Type.{u1}} {m : Type.{u1}} [_inst_1 : Monad.{u1, u2} α], (α (Option.{u1} β)) -> (α m) -> (β -> (α m)) -> (α m)
Case conversion may be inaccurate. Consider using '#align option.melim Option.elimMₓ'. -/
/-- A monadic analogue of `option.elim`. -/
def elimM {α β : Type _} {m : Type _ → Type _} [Monad m] (y : m β) (z : α → m β)
    (x : m (Option α)) : m β :=
  x >>= Option.elim' y z
#align option.melim Option.elimM

/- warning: option.mget_or_else -> Option.getDM' is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {m : Type.{u1} -> Type.{u2}} [_inst_1 : Monad.{u1, u2} m], (m (Option.{u1} α)) -> (m α) -> (m α)
but is expected to have type
  forall {α : Type.{u1} -> Type.{u2}} {m : Type.{u1}} [_inst_1 : Monad.{u1, u2} α], (α (Option.{u1} m)) -> (α m) -> (α m)
Case conversion may be inaccurate. Consider using '#align option.mget_or_else Option.getDM'ₓ'. -/
/-- A monadic analogue of `option.get_or_else`. -/
def getDM' {α : Type _} {m : Type _ → Type _} [Monad m] (x : m (Option α)) (y : m α) : m α :=
  elimM y pure x
#align option.mget_or_else Option.getDM'

end Option


import order.filter.filter_product
import complements.germ

/-! # Complements on filter products -/

open ultrafilter filter function

namespace filter.germ

variables {ι α β : Type*} (l : ultrafilter ι)

local notation `∀*` binders `, ` r:(scoped p, filter.eventually p l) := r
local notation `α*` := (l : filter ι).germ α
local notation `β*` := (l : filter ι).germ β
local notation `⋈` := (prod_equiv (l : filter ι) : α* × β* → (l : filter ι).germ (α × β))

/-! ## Transfer lemmas -/

/-! ### Not rules -/

lemma lift_pred_not_iff_not_lift_pred (p : α → Prop) (x : α*) :
  lift_pred (λ x, ¬ p x) x ↔ ¬ lift_pred p x :=
begin
  refine x.induction_on (λ f, _),
  rw [lift_pred_coe, lift_pred_coe, eventually_not]
end

lemma lift_rel_not_iff_not_lift_rel (r : α → β → Prop) (x : α*) (y : β*) :
  lift_rel (λ x y, ¬ r x y) x y ↔ ¬ lift_rel r x y :=
begin
  refine x.induction_on₂ y (λ f g, _),
  rw [lift_rel_coe, lift_rel_coe, eventually_not]
end

/-! ### Ne rules -/

lemma lift_pred_ne_iff_ne_map (f g : α → β) (x : α*) :
  lift_pred (λ x, f x ≠ g x) x ↔ germ.map f x ≠ germ.map g x :=
begin
  refine x.induction_on (λ u, _),
  rw [ne, eq_def, lift_pred_coe, map_coe, map_coe, lift_rel_coe, eventually_not]
end

/-! ### Imp rules -/

lemma lift_pred_imp_iff_imp_lift_pred (p q : α → Prop) (x : α*) :
  lift_pred (λ x, p x → q x) x ↔ (lift_pred p x → lift_pred q x) :=
begin
  refine x.induction_on (λ f, _),
  exact eventually_imp
end

/-! ### Forall rules -/

lemma lift_pred_forall_iff_forall_lift_rel (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∀ (y : β), r x y) x ↔ ∀ (y : β*), lift_rel r x y :=
begin
  rw [← not_iff_not, ← lift_pred_not_iff_not_lift_pred],
  push_neg,
  simp_rw [← lift_rel_not_iff_not_lift_rel],
  exact lift_pred_exists_iff_exists_lift_rel ↑l _ x,
end

lemma lift_pred_forall_iff_forall_lift_pred (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∀ (y : β), r x y) x ↔ ∀ (y : β*), lift_pred (uncurry r) (⋈ (x, y)) :=
begin
  convert lift_pred_forall_iff_forall_lift_rel l r x,
  ext,
  exact forall_congr (λ y, by rw ← lift_rel_iff_lift_pred_uncurry)
end

lemma lift_pred_forall_iff_forall_lift_pred' (r : α → β → Prop) (x : α*) :
  lift_pred (λ x, ∀ (y : β), r x y) x ↔ ∀ (y : β*), lift_pred (λ u : α × β, r u.1 u.2) (⋈ (x, y)) :=
lift_pred_forall_iff_forall_lift_pred l r x

/-! ### Or rules -/

lemma lift_pred_or_iff_or_lift_pred (p q : α → Prop) (x : α*) :
  lift_pred (λ x, p x ∨ q x) x ↔ lift_pred p x ∨ lift_pred q x :=
begin
  refine x.induction_on (λ f, _),
  exact eventually_or
end

/-! ### Lt rules -/

lemma lift_pred_lt_iff_lt_map [preorder β] (f g : α → β) (x : α*) :
  lift_pred (λ x, f x < g x) x ↔ germ.map f x < germ.map g x :=
begin
  refine x.induction_on (λ f, _),
  rw lt_def,
  refl
end

end filter.germ


import .scheduling
import data.equiv.basic

universes u v u' v'

namespace temporal
open function

instance schedulable_empty : schedulable empty :=
{ f := λ _, 0
, inj := by { intros _ _, casesm* empty, }  }

instance schedulable_unit : schedulable punit :=
{ f := λ _, 0
, inj := by { intros _ _, casesm* punit, simp }  }

instance schedulable_bool : schedulable bool :=
{ f := bool.rec 0 1
, inj := by { intros _ _, casesm* bool ; simp }  }

instance schedulable_nat : schedulable ℕ :=
{ f := id
, inj := injective_id }
open equiv

lemma equiv.inj {α β} (h : α ≃ β) : injective h :=
by { apply injective_of_left_inverse, apply h.left_inv }

instance schedulable_int : schedulable ℤ :=
{ f := int_equiv_nat
, inj := equiv.inj _ }

instance schedulable_fin (n : ℕ) : schedulable (fin n) :=
{ f := fin.val
, inj := by { intros _ _, apply fin.eq_of_veq } }

variables {α : Type u} {β : Type v} {η : α → Type u'}
variables {α' : Type u'} {β' : Type v'}

section inductive_construction

variables [schedulable α]
variables [schedulable β]
variables [∀ x, schedulable (η x)]

def sum.map (f : α → α') (g : β → β') : α ⊕ β → α' ⊕ β'
| (sum.inr x) := sum.inr (g x)
| (sum.inl x) := sum.inl (f x)

open equiv scheduling.schedulable

instance schedulable_sum : schedulable (α ⊕ β) :=
{ f := nat_sum_nat_equiv_nat ∘ sum.map scheduling.schedulable.f scheduling.schedulable.f
, inj := by { apply injective_comp, apply equiv.inj,
              intros _ _, casesm* _ ⊕ _ ; simp [sum.map] ; apply inj, } }

instance schedulable_option : schedulable (option α) :=
{ f := f ∘ option_equiv_sum_unit α
, inj :=
begin
  apply injective_comp,
  { apply inj },
  { apply equiv.inj, },
end
}

instance schedulable_list : schedulable (list α) :=
{ f := f ∘ list_nat_equiv_nat ∘ list.map f
, inj :=
begin
  apply injective_comp,
  { apply inj },
  apply injective_comp,
  { apply equiv.inj, },
  { intros xs,
    induction xs ; intro ys ; cases ys ; simp,
    intros, split,
    apply inj _ a,
    solve_by_elim },
end
}

instance schedulable_prod : schedulable (α × β) :=
{ f := nat_prod_nat_equiv_nat ∘ prod.map scheduling.schedulable.f scheduling.schedulable.f
, inj := by { apply injective_comp,
              { apply equiv.inj },
              intros _ _, casesm* _ × _,
              simp [prod.map], intros,
              split ; apply inj ; solve_by_elim } }

def index_pair : sigma η → ℕ × ℕ
 | ⟨x,y⟩ := (f x,f y)

instance schedulable_sigma : schedulable (sigma η) :=
{ f := nat_prod_nat_equiv_nat ∘ index_pair
, inj := by { apply injective_comp,
              { apply equiv.inj },
              intros _ _, casesm* sigma _,
              simp [index_pair],
              intros,
              have : a₁_fst = a₂_fst := inj _ (by solve_by_elim),
              subst a₂_fst, simp,
              exact inj _ (by solve_by_elim) }  }

end inductive_construction

section from_other_class

open fintype

local attribute [instance] classical.prop_decidable

noncomputable instance fintype_schedulable [fintype α] : schedulable α :=
{ f := (λ x, (trunc.out (equiv_fin α) x).val)
, inj := by { intros _ _ h, simp at h,
              replace h := fin.eq_of_veq h,
              apply equiv.inj _ h, } }

class countable_type (α : Type u) :=
(enum : trunc $ α ≃ ℕ)

noncomputable instance countable_type_schedulable [countable_type α] : schedulable α :=
{ f := (λ x, trunc.out (countable_type.enum α) x)
, inj := by { intros _ _ h, simp at h, exact h, } }

end from_other_class

end temporal


import Lean
open Lean Elab Term

def hello := "world"
def sss := "∀a b, a → b → a ∧ b"
elab "myt[" s:str "]" : term => do
  logInfo s!"{s}"
  pure $ mkStrLit "a"
#eval myt["nakami"]

elab "myterm[" s:str "]" : term => do
  let env ← getEnv
  let _a ← (pure:_ → IO _) "a"
  let aa := s.getString
  logInfo s!"ho:{aa}"
  let parsedSyntax ← match Lean.Parser.runParserCategory env `term s.getString with
                      | Except.ok stx => pure stx
                      | Except.error errmsg => throwError errmsg
  logInfo s!"{parsedSyntax}"
  let prop ← elabTerm parsedSyntax none-- (mkConst `Lean.Prop)
  logInfo s!"hi:{prop}"
  pure prop

theorem propStr : myterm["∀a b, a → b → a ∧ b"] :=
  fun {a b : Prop} (ha : a) (hb : b) => ⟨ha,hb⟩

def p := myterm["∀a b, a → b → a ∧ b"]
#print p


import Duper.Simp
import Duper.Util.ProofReconstruction

namespace Duper
open RuleM
open SimpResult
open Lean
open Meta

/-- Determines whether a literal has exactly the form `false = true` or `true = false`-/
def isFalseBoolLiteral (lit : Lit) : MetaM Bool := do
  if lit.ty.consumeMData == (mkConst ``Bool) then
    return lit.sign &&
      ((lit.lhs == mkConst ``true && lit.rhs == mkConst ``false) ||
      (lit.lhs == mkConst ``false && lit.rhs == mkConst ``true))
  else return false

theorem bool_false_ne_true (h : false = true) : False := ne_false_of_eq_true h (by rfl)

theorem bool_true_ne_false (h : true = false) : False := ne_true_of_eq_false h (by rfl)

def mkIdentBoolFalseElimProof (refs : List (Option Nat)) (premises : List Expr) (parents: List ProofParent)
  (transferExprs : Array Expr) (c : Clause) : MetaM Expr :=
  Meta.forallTelescope c.toForallExpr fun xs body => do
    let cLits := c.lits.map (fun l => l.map (fun e => e.instantiateRev xs))
    let (parentsLits, appliedPremises, transferExprs) ← instantiatePremises parents premises xs transferExprs
    let parentLits := parentsLits[0]!
    let appliedPremise := appliedPremises[0]!

    let mut proofCases : Array Expr := Array.mkEmpty parentLits.size
    for i in [:parentLits.size] do
      let lit := parentLits[i]!
      if (← isFalseBoolLiteral lit) then -- lit has the form `false = true` or `true = false`
        let proofCase ← Meta.withLocalDeclD `h lit.toExpr fun h => do
          if (lit.lhs == mkConst ``false) then
            let proofCase := mkApp (mkConst ``bool_false_ne_true) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          else if(lit.lhs == mkConst ``true) then
            let proofCase := mkApp (mkConst ``bool_true_ne_false) h
            let proofCase := mkApp2 (mkConst ``False.elim [levelZero]) body proofCase
            Meta.mkLambdaFVars #[h] proofCase
          else
            throwError "mkIdentBoolFalseElimProof failed to match {lit.lhs} to an expected expression"
        proofCases := proofCases.push proofCase
      else -- refs[i] should have the value (some j) where parentLits[i] == c[j]
        match refs[i]! with
        | none => throwError "Refs invariant is not satisfied in identBoolFalseElim"
        | some j =>
          let proofCase ← Meta.withLocalDeclD `h parentLits[i]!.toExpr fun h => do
            Meta.mkLambdaFVars #[h] $ ← orIntro (cLits.map Lit.toExpr) j h
          proofCases := proofCases.push proofCase
    let proof ← orCases (parentLits.map Lit.toExpr) proofCases
    Meta.mkLambdaFVars xs $ mkApp proof appliedPremise

/-- Eliminate literals that are exactly of the form `false = true` or `true = false`.
    This is a special case of the boolFalseElim inference rule in which σ is the identity.
    This rule is included as a means of giving Bools special attention. -/
def identBoolFalseElim : MSimpRule := fun c => do
  let c ← loadClause c
  /-
    Spec for newLits and refs
    If c.lits[i] is `false = true` or `true = false`, then refs[i] = none
    If c.lits[i] isn't `false = true` or `true = false`,then refs[i] = some j where newLits[j] = c.lits[i]
  -/
  let mut newLits : List Lit := []
  let mut refs : List (Option Nat) := []
  for lit in c.lits do
    if (← isFalseBoolLiteral lit) then
      refs := none :: refs
    else
      refs := (some newLits.length) :: refs
      newLits := lit :: newLits
  -- To achieve the desired spec for newLits and refs, I must reverse them
  newLits := newLits.reverse
  refs := refs.reverse
  if (newLits.length = c.lits.size) then
    return none
  else
    let resultClause ← yieldClause (MClause.mk newLits.toArray) "identity boolean false elimination"
      (some (mkIdentBoolFalseElimProof refs))
    return some #[resultClause]

end Duper


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Adam Topaz, Johan Commelin, Jakob von Raumer
-/
import category_theory.abelian.opposite
import category_theory.limits.preserves.shapes.zero
import category_theory.limits.preserves.shapes.kernels
import category_theory.preadditive.left_exact
import category_theory.adjunction.limits
import algebra.homology.exact
import tactic.tfae

/-!
# Exact sequences in abelian categories

In an abelian category, we get several interesting results related to exactness which are not
true in more general settings.

## Main results
* `(f, g)` is exact if and only if `f ≫ g = 0` and `kernel.ι g ≫ cokernel.π f = 0`. This
  characterisation tends to be less cumbersome to work with than the original definition involving
  the comparison map `image f ⟶ kernel g`.
* If `(f, g)` is exact, then `image.ι f` has the universal property of the kernel of `g`.
* `f` is a monomorphism iff `kernel.ι f = 0` iff `exact 0 f`, and `f` is an epimorphism iff
  `cokernel.π = 0` iff `exact f 0`.
* A faithful functor between abelian categories that preserves zero morphisms reflects exact
  sequences.
* `X ⟶ Y ⟶ Z ⟶ 0` is exact if and only if the second map is a cokernel of the first, and
  `0 ⟶ X ⟶ Y ⟶ Z` is exact if and only if the first map is a kernel of the second.
* An exact functor preserves exactness, more specifically, `F` preserves finite colimits and
  finite limits, if and only if `exact f g` implies `exact (F.map f) (F.map g)`.
-/

universes v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits
open category_theory.preadditive

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

namespace category_theory

namespace abelian

variables {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z)

local attribute [instance] has_equalizers_of_has_kernels

/--
In an abelian category, a pair of morphisms `f : X ⟶ Y`, `g : Y ⟶ Z` is exact
iff `image_subobject f = kernel_subobject g`.
-/
theorem exact_iff_image_eq_kernel : exact f g ↔ image_subobject f = kernel_subobject g :=
begin
  split,
  { intro h,
    fapply subobject.eq_of_comm,
    { suffices : is_iso (image_to_kernel _ _ h.w),
      { exactI as_iso (image_to_kernel _ _ h.w), },
      exact is_iso_of_mono_of_epi _, },
    { simp, }, },
  { apply exact_of_image_eq_kernel, },
end

theorem exact_iff : exact f g ↔ f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0 :=
begin
  split,
  { intro h,
    exact ⟨h.1, kernel_comp_cokernel f g h⟩ },
  { refine λ h, ⟨h.1, _⟩,
    suffices hl : is_limit
      (kernel_fork.of_ι (image_subobject f).arrow (image_subobject_arrow_comp_eq_zero h.1)),
    { have : image_to_kernel f g h.1 =
        (is_limit.cone_point_unique_up_to_iso hl (limit.is_limit _)).hom ≫
          (kernel_subobject_iso _).inv,
      { ext, simp },
      rw this,
      apply_instance, },
    refine kernel_fork.is_limit.of_ι _ _ _ _ _,
    { refine λ W u hu,
        kernel.lift (cokernel.π f) u _ ≫ (image_iso_image f).hom ≫ (image_subobject_iso _).inv,
      rw [←kernel.lift_ι g u hu, category.assoc, h.2, has_zero_morphisms.comp_zero] },
    { tidy },
    { intros, rw [←cancel_mono (image_subobject f).arrow, w],
      simp, } }
end

theorem exact_iff' {cg : kernel_fork g} (hg : is_limit cg)
  {cf : cokernel_cofork f} (hf : is_colimit cf) : exact f g ↔ f ≫ g = 0 ∧ cg.ι ≫ cf.π = 0 :=
begin
  split,
  { intro h,
    exact ⟨h.1, fork_ι_comp_cofork_π f g h cg cf⟩ },
  { rw exact_iff,
    refine λ h, ⟨h.1, _⟩,
    apply zero_of_epi_comp (is_limit.cone_point_unique_up_to_iso hg (limit.is_limit _)).hom,
    apply zero_of_comp_mono
      (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _) hf).hom,
    simp [h.2] }
end

theorem exact_tfae :
  tfae [exact f g,
        f ≫ g = 0 ∧ kernel.ι g ≫ cokernel.π f = 0,
        image_subobject f = kernel_subobject g] :=
begin
  tfae_have : 1 ↔ 2, { apply exact_iff },
  tfae_have : 1 ↔ 3, { apply exact_iff_image_eq_kernel },
  tfae_finish
end

lemma is_equivalence.exact_iff {D : Type u₁} [category.{v₁} D] [abelian D]
  (F : C ⥤ D) [is_equivalence F] :
  exact (F.map f) (F.map g) ↔ exact f g :=
begin
  simp only [exact_iff, ← F.map_eq_zero_iff, F.map_comp, category.assoc,
    ← kernel_comparison_comp_ι g F, ← π_comp_cokernel_comparison f F],
  rw [is_iso.comp_left_eq_zero (kernel_comparison g F), ← category.assoc,
    is_iso.comp_right_eq_zero _ (cokernel_comparison f F)],
end

/-- The dual result is true even in non-abelian categories, see
    `category_theory.exact_comp_mono_iff`. -/

/-- If `(f, g)` is exact, then `abelian.image.ι f` is a kernel of `g`. -/
def is_limit_image (h : exact f g) :
  is_limit
    (kernel_fork.of_ι (abelian.image.ι f) (image_ι_comp_eq_zero h.1) : kernel_fork g) :=
begin
  rw exact_iff at h,
  refine kernel_fork.is_limit.of_ι _ _ _ _ _,
  { refine λ W u hu, kernel.lift (cokernel.π f) u _,
    rw [←kernel.lift_ι g u hu, category.assoc, h.2, has_zero_morphisms.comp_zero] },
  tidy
end

/-- If `(f, g)` is exact, then `image.ι f` is a kernel of `g`. -/
def is_limit_image' (h : exact f g) :
  is_limit (kernel_fork.of_ι (limits.image.ι f) (limits.image_ι_comp_eq_zero h.1)) :=
is_kernel.iso_kernel _ _ (is_limit_image f g h) (image_iso_image f).symm $ is_image.lift_fac _ _

/-- If `(f, g)` is exact, then `coimages.coimage.π g` is a cokernel of `f`. -/
def is_colimit_coimage (h : exact f g) : is_colimit (cokernel_cofork.of_π (abelian.coimage.π g)
  (abelian.comp_coimage_π_eq_zero h.1) : cokernel_cofork f) :=
begin
  rw exact_iff at h,
  refine cokernel_cofork.is_colimit.of_π _ _ _ _ _,
  { refine λ W u hu, cokernel.desc (kernel.ι g) u _,
    rw [←cokernel.π_desc f u hu, ←category.assoc, h.2, has_zero_morphisms.zero_comp] },
  tidy
end

/-- If `(f, g)` is exact, then `factor_thru_image g` is a cokernel of `f`. -/
def is_colimit_image (h : exact f g) : is_colimit
  (cokernel_cofork.of_π (limits.factor_thru_image g) (comp_factor_thru_image_eq_zero h.1)) :=
is_cokernel.cokernel_iso _ _ (is_colimit_coimage f g h) (coimage_iso_image' g) $
  (cancel_mono (limits.image.ι g)).1 $ by simp

lemma exact_cokernel : exact f (cokernel.π f) :=
by { rw exact_iff, tidy }

instance (h : exact f g) : mono (cokernel.desc f g h.w) :=
suffices h : cokernel.desc f g h.w =
  (is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _) (is_colimit_image f g h)).hom
    ≫ limits.image.ι g, by { rw h, apply mono_comp },
(cancel_epi (cokernel.π f)).1 $ by simp

/-- If `ex : exact f g` and `epi g`, then `cokernel.desc _ _ ex.w` is an isomorphism. -/
instance (ex : exact f g) [epi g] : is_iso (cokernel.desc f g ex.w) :=
is_iso_of_mono_of_epi (limits.cokernel.desc f g ex.w)

@[simp, reassoc]
lemma cokernel.desc.inv [epi g] (ex : exact f g) :
  g ≫ inv (cokernel.desc _ _ ex.w) = cokernel.π _ :=
by simp

instance (ex : exact f g) [mono f] : is_iso (kernel.lift g f ex.w) :=
  is_iso_of_mono_of_epi (limits.kernel.lift g f ex.w)

@[simp, reassoc]
lemma kernel.lift.inv [mono f] (ex : exact f g) :
  inv (kernel.lift _ _ ex.w) ≫ f = kernel.ι g :=
by simp

/-- If `X ⟶ Y ⟶ Z ⟶ 0` is exact, then the second map is a cokernel of the first. -/
def is_colimit_of_exact_of_epi [epi g] (h : exact f g) :
  is_colimit (cokernel_cofork.of_π _ h.w) :=
is_colimit.of_iso_colimit (colimit.is_colimit _) $ cocones.ext
  ⟨cokernel.desc _ _ h.w, epi_desc g (cokernel.π f) ((exact_iff _ _).1 h).2,
    (cancel_epi (cokernel.π f)).1 (by tidy), (cancel_epi g).1 (by tidy)⟩ (λ j, by cases j; simp)

/-- If `0 ⟶ X ⟶ Y ⟶ Z` is exact, then the first map is a kernel of the second. -/
def is_limit_of_exact_of_mono [mono f] (h : exact f g) :
  is_limit (kernel_fork.of_ι _ h.w) :=
is_limit.of_iso_limit (limit.is_limit _) $ cones.ext
 ⟨mono_lift f (kernel.ι g) ((exact_iff _ _).1 h).2, kernel.lift _ _ h.w,
  (cancel_mono (kernel.ι g)).1 (by tidy), (cancel_mono f).1 (by tidy)⟩ (λ j, by cases j; simp)

lemma exact_of_is_cokernel (w : f ≫ g = 0)
  (h : is_colimit (cokernel_cofork.of_π _ w)) : exact f g :=
begin
  refine (exact_iff _ _).2 ⟨w, _⟩,
  have := h.fac (cokernel_cofork.of_π _ (cokernel.condition f)) walking_parallel_pair.one,
  simp only [cofork.of_π_ι_app] at this,
  rw [← this, ← category.assoc, kernel.condition, zero_comp]
end

lemma exact_of_is_kernel (w : f ≫ g = 0)
  (h : is_limit (kernel_fork.of_ι _ w)) : exact f g :=
begin
  refine (exact_iff _ _).2 ⟨w, _⟩,
  have := h.fac (kernel_fork.of_ι _ (kernel.condition g)) walking_parallel_pair.zero,
  simp only [fork.of_ι_π_app] at this,
  rw [← this, category.assoc, cokernel.condition, comp_zero]
end

lemma exact_iff_exact_image_ι : exact f g ↔ exact (abelian.image.ι f) g :=
by conv_lhs { rw ← abelian.image.fac f }; apply exact_epi_comp_iff

lemma exact_iff_exact_coimage_π : exact f g ↔ exact f (coimage.π g) :=
by conv_lhs { rw ← abelian.coimage.fac g}; apply exact_comp_mono_iff

section
variables (Z)

lemma tfae_mono : tfae [mono f, kernel.ι f = 0, exact (0 : Z ⟶ X) f] :=
begin
  tfae_have : 3 → 2,
  { exact kernel_ι_eq_zero_of_exact_zero_left Z },
  tfae_have : 1 → 3,
  { introsI, exact exact_zero_left_of_mono Z },
  tfae_have : 2 → 1,
  { exact mono_of_kernel_ι_eq_zero _ },
  tfae_finish
end

-- Note we've already proved `mono_iff_exact_zero_left : mono f ↔ exact (0 : Z ⟶ X) f`
-- in any preadditive category with kernels and images.

lemma mono_iff_kernel_ι_eq_zero : mono f ↔ kernel.ι f = 0 :=
(tfae_mono X f).out 0 1

lemma tfae_epi : tfae [epi f, cokernel.π f = 0, exact f (0 : Y ⟶ Z)] :=
begin
  tfae_have : 3 → 2,
  { rw exact_iff,
    rintro ⟨-, h⟩,
    exact zero_of_epi_comp _ h },
  tfae_have : 1 → 3,
  { rw exact_iff,
    introI,
    exact ⟨by simp, by simp [cokernel.π_of_epi]⟩ },
  tfae_have : 2 → 1,
  { exact epi_of_cokernel_π_eq_zero _ },
  tfae_finish
end

-- Note we've already proved `epi_iff_exact_zero_right : epi f ↔ exact f (0 : Y ⟶ Z)`
-- in any preadditive category with equalizers and images.

lemma epi_iff_cokernel_π_eq_zero : epi f ↔ cokernel.π f = 0 :=
(tfae_epi X f).out 0 1

end

section opposite

lemma exact.op (h : exact f g) : exact g.op f.op :=
begin
  rw exact_iff,
  refine ⟨by simp [← op_comp, h.w], quiver.hom.unop_inj _⟩,
  simp only [unop_comp, cokernel.π_op, eq_to_hom_refl, kernel.ι_op, category.id_comp,
    category.assoc, kernel_comp_cokernel_assoc _ _ h, zero_comp, comp_zero, unop_zero],
end

lemma exact.op_iff : exact g.op f.op ↔ exact f g :=
⟨λ e, begin
  rw ← is_equivalence.exact_iff _ _ (op_op_equivalence C).inverse,
  exact exact.op _ _ e
end, exact.op _ _⟩

lemma exact.unop {X Y Z : Cᵒᵖ} (g : X ⟶ Y) (f : Y ⟶ Z) (h : exact g f) : exact f.unop g.unop :=
begin
  rw [← f.op_unop, ← g.op_unop] at h,
  rwa ← exact.op_iff,
end

lemma exact.unop_iff {X Y Z : Cᵒᵖ} (g : X ⟶ Y) (f : Y ⟶ Z) : exact f.unop g.unop ↔ exact g f :=
⟨λ e, by rwa [← f.op_unop, ← g.op_unop, ← exact.op_iff] at e, λ e, @@exact.unop _ _ g f e⟩

end opposite

end abelian

namespace functor

section

variables {D : Type u₂} [category.{v₂} D] [abelian D]
variables (F : C ⥤ D) [preserves_zero_morphisms F]

@[priority 100]
instance reflects_exact_sequences_of_preserves_zero_morphisms_of_faithful [faithful F] :
  reflects_exact_sequences F :=
{ reflects := λ X Y Z f g hfg,
  begin
    rw [abelian.exact_iff, ← F.map_comp, F.map_eq_zero_iff] at hfg,
    refine (abelian.exact_iff _ _).2 ⟨hfg.1, F.zero_of_map_zero _ _⟩,
    obtain ⟨k, hk⟩ := kernel.lift' (F.map g) (F.map (kernel.ι g))
      (by simp only [← F.map_comp, kernel.condition, category_theory.functor.map_zero]),
    obtain ⟨l, hl⟩ := cokernel.desc' (F.map f) (F.map (cokernel.π f))
      (by simp only [← F.map_comp, cokernel.condition, category_theory.functor.map_zero]),
    rw [F.map_comp, ← hk, ← hl, category.assoc, reassoc_of hfg.2, zero_comp, comp_zero]
  end }

end

end functor

namespace functor

open limits abelian

variables {A : Type u₁} {B : Type u₂} [category.{v₁} A] [category.{v₂} B]
variables [abelian A] [abelian B]
variables (L : A ⥤ B)

section

variables [preserves_finite_limits L] [preserves_finite_colimits L]

/-- A functor preserving finite limits and finite colimits preserves exactness. The converse
result is also true, see `functor.preserves_finite_limits_of_map_exact` and
`functor.preserves_finite_colimits_of_map_exact`. -/
lemma map_exact {X Y Z : A} (f : X ⟶ Y) (g : Y ⟶ Z) (e1 : exact f g) :
  exact (L.map f) (L.map g) :=
begin
  let hcoker := is_colimit_of_has_cokernel_of_preserves_colimit L f,
  let hker := is_limit_of_has_kernel_of_preserves_limit L g,
  refine (exact_iff' _ _ hker hcoker).2 ⟨by simp [← L.map_comp, e1.1], _⟩,
  rw [fork.ι_of_ι, cofork.π_of_π, ← L.map_comp, kernel_comp_cokernel _ _ e1, L.map_zero]
end

end

section

variables (h : ∀ ⦃X Y Z : A⦄ {f : X ⟶ Y} {g : Y ⟶ Z}, exact f g → exact (L.map f) (L.map g))
include h

open_locale zero_object

/-- A functor which preserves exactness preserves zero morphisms. -/
lemma preserves_zero_morphisms_of_map_exact : L.preserves_zero_morphisms :=
begin
  replace h := (h (exact_of_zero (𝟙 0) (𝟙 0))).w,
  rw [L.map_id, category.comp_id] at h,
  exact preserves_zero_morphisms_of_map_zero_object (id_zero_equiv_iso_zero _ h),
end

/-- A functor which preserves exactness preserves monomorphisms. -/
lemma preserves_monomorphisms_of_map_exact : L.preserves_monomorphisms :=
{ preserves := λ X Y f hf,
  begin
    letI := preserves_zero_morphisms_of_map_exact L h,
    apply ((tfae_mono (L.obj 0) (L.map f)).out 2 0).mp,
    rw ←L.map_zero,
    exact h (((tfae_mono 0 f).out 0 2).mp hf)
  end }

/-- A functor which preserves exactness preserves epimorphisms. -/
lemma preserves_epimorphisms_of_map_exact : L.preserves_epimorphisms :=
{ preserves := λ X Y f hf,
  begin
    letI := preserves_zero_morphisms_of_map_exact L h,
    apply ((tfae_epi (L.obj 0) (L.map f)).out 2 0).mp,
    rw ←L.map_zero,
    exact h (((tfae_epi 0 f).out 0 2).mp hf)
  end }

/-- A functor which preserves exactness preserves kernels. -/
def preserves_kernels_of_map_exact (X Y : A) (f : X ⟶ Y) :
  preserves_limit (parallel_pair f 0) L :=
{ preserves := λ c ic,
  begin
    letI := preserves_zero_morphisms_of_map_exact L h,
    letI := preserves_monomorphisms_of_map_exact L h,
    letI := mono_of_is_limit_fork ic,
    have hf := (is_limit_map_cone_fork_equiv' L (kernel_fork.condition c)).symm
      (is_limit_of_exact_of_mono (L.map (fork.ι c)) (L.map f)
        (h (exact_of_is_kernel (fork.ι c) f (kernel_fork.condition c)
          (ic.of_iso_limit (iso_of_ι _))))),
    exact hf.of_iso_limit ((cones.functoriality _ L).map_iso (iso_of_ι _).symm),
  end }

/-- A functor which preserves exactness preserves zero cokernels. -/
def preserves_cokernels_of_map_exact (X Y : A) (f : X ⟶ Y) :
  preserves_colimit (parallel_pair f 0) L :=
{ preserves := λ c ic,
  begin
    letI := preserves_zero_morphisms_of_map_exact L h,
    letI := preserves_epimorphisms_of_map_exact L h,
    letI := epi_of_is_colimit_cofork ic,
    have hf := (is_colimit_map_cocone_cofork_equiv' L (cokernel_cofork.condition c)).symm
      (is_colimit_of_exact_of_epi (L.map f) (L.map (cofork.π c))
        (h (exact_of_is_cokernel f (cofork.π c) (cokernel_cofork.condition c)
          (ic.of_iso_colimit (iso_of_π _))))),
    exact hf.of_iso_colimit ((cocones.functoriality _ L).map_iso (iso_of_π _).symm),
  end }

/-- A functor which preserves exactness is left exact, i.e. preserves finite limits.
This is part of the inverse implication to `functor.map_exact`. -/
def preserves_finite_limits_of_map_exact : preserves_finite_limits L :=
begin
  letI := preserves_zero_morphisms_of_map_exact L h,
  letI := preserves_kernels_of_map_exact L h,
  apply preserves_finite_limits_of_preserves_kernels,
end

/-- A functor which preserves exactness is right exact, i.e. preserves finite colimits.
This is part of the inverse implication to `functor.map_exact`. -/
def preserves_finite_colimits_of_map_exact : preserves_finite_colimits L :=
begin
  letI := preserves_zero_morphisms_of_map_exact L h,
  letI := preserves_cokernels_of_map_exact L h,
  apply preserves_finite_colimits_of_preserves_cokernels,
end

end

section

/-- A functor preserving zero morphisms, monos, and cokernels preserves finite limits. -/
def preserves_finite_limits_of_preserves_monos_and_cokernels
  [preserves_zero_morphisms L] [preserves_monomorphisms L]
  [∀ {X Y} (f : X ⟶ Y), preserves_colimit (parallel_pair f 0) L] : preserves_finite_limits L :=
begin
  apply preserves_finite_limits_of_map_exact,
  intros X Y Z f g h,
  rw [← abelian.coimage.fac g, L.map_comp, exact_comp_mono_iff],
  exact exact_of_is_cokernel _ _ _
    (is_colimit_cofork_map_of_is_colimit' L _ (is_colimit_coimage f g h))
end

/-- A functor preserving zero morphisms, epis, and kernels preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_epis_and_kernels
  [preserves_zero_morphisms L] [preserves_epimorphisms L]
  [∀ {X Y} (f : X ⟶ Y), preserves_limit (parallel_pair f 0) L] : preserves_finite_colimits L :=
begin
  apply preserves_finite_colimits_of_map_exact,
  intros X Y Z f g h,
  rw [← abelian.image.fac f, L.map_comp, exact_epi_comp_iff],
  exact exact_of_is_kernel _ _ _ (is_limit_fork_map_of_is_limit' L _ (is_limit_image f g h))
end

end

end functor

end category_theory


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Andrew Yang, Pierre-Alexandre Bazin
-/
import algebra.homology.short_exact.preadditive
import category_theory.abelian.diagram_lemmas.four

/-!
# Short exact sequences in abelian categories

In an abelian category, a left-split or right-split short exact sequence admits a splitting.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.preadditive

variables {𝒜 : Type*} [category 𝒜]

namespace category_theory

variables {A B C A' B' C' : 𝒜} {f : A ⟶ B} {g : B ⟶ C} {f' : A' ⟶ B'} {g' : B' ⟶ C'}
variables [abelian 𝒜]
open_locale zero_object

lemma is_iso_of_short_exact_of_is_iso_of_is_iso (h : short_exact f g) (h' : short_exact f' g')
  (i₁ : A ⟶ A') (i₂ : B ⟶ B') (i₃ : C ⟶ C')
  (comm₁ : i₁ ≫ f' = f ≫ i₂) (comm₂ : i₂ ≫ g' = g ≫ i₃) [is_iso i₁] [is_iso i₃] :
  is_iso i₂ :=
begin
  obtain ⟨_, _, _⟩ := h,
  obtain ⟨_, _, _⟩ := h',
  resetI,
  refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso 𝒜 _ _ 0 _ _ _ 0 _ _ _
    0 f g 0 f' g' 0 i₁ i₂ i₃ _ comm₁ comm₂ 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _;
  try { simp };
  try { apply exact_zero_left_of_mono };
  try { assumption };
  rwa ← epi_iff_exact_zero_right,
end

/-- To construct a splitting of `A -f⟶ B -g⟶ C` it suffices to supply
a *morphism* `i : B ⟶ A ⊞ C` such that `f ≫ i` is the canonical map `biprod.inl : A ⟶ A ⊞ C` and
`i ≫ q = g`, where `q` is the canonical map `biprod.snd : A ⊞ C ⟶ C`,
together with proofs that `f` is mono and `g` is epi.

The morphism `i` is then automatically an isomorphism. -/
def splitting.mk' (h : short_exact f g) (i : B ⟶ A ⊞ C)
  (h1 : f ≫ i = biprod.inl) (h2 : i ≫ biprod.snd = g) : splitting f g :=
{ iso :=
  begin
    refine @as_iso _ _ _ _ i (id _),
    refine is_iso_of_short_exact_of_is_iso_of_is_iso h _ _ _ _
      (h1.trans (category.id_comp _).symm).symm (h2.trans (category.comp_id _).symm),
    split,
    apply exact_inl_snd
  end,
  comp_iso_eq_inl := by { rwa as_iso_hom, },
  iso_comp_snd_eq := h2 }

/-- To construct a splitting of `A -f⟶ B -g⟶ C` it suffices to supply
a *morphism* `i : A ⊞ C ⟶ B` such that `p ≫ i = f` where `p` is the canonical map
`biprod.inl : A ⟶ A ⊞ C`, and `i ≫ g` is the canonical map `biprod.snd : A ⊞ C ⟶ C`,
together with proofs that `f` is mono and `g` is epi.

The morphism `i` is then automatically an isomorphism. -/
def splitting.mk'' (h : short_exact f g) (i : A ⊞ C ⟶ B)
  (h1 : biprod.inl ≫ i = f) (h2 : i ≫ g = biprod.snd) : splitting f g :=
{ iso :=
  begin
    refine (@as_iso _ _ _ _ i (id _)).symm,
    refine is_iso_of_short_exact_of_is_iso_of_is_iso _ h _ _ _
      (h1.trans (category.id_comp _).symm).symm (h2.trans (category.comp_id _).symm),
    split,
    apply exact_inl_snd
  end,
  comp_iso_eq_inl := by rw [iso.symm_hom, as_iso_inv, is_iso.comp_inv_eq, h1],
  iso_comp_snd_eq := by rw [iso.symm_hom, as_iso_inv, is_iso.inv_comp_eq, h2] }

/-- A short exact sequence that is left split admits a splitting. -/
def left_split.splitting {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : splitting f g :=
splitting.mk' h.short_exact (biprod.lift h.left_split.some g)
(by { ext,
  { simpa only [biprod.inl_fst, biprod.lift_fst, category.assoc] using h.left_split.some_spec },
  { simp only [biprod.inl_snd, biprod.lift_snd, category.assoc, h.exact.w], } })
(by { simp only [biprod.lift_snd], })

/-- A short exact sequence that is right split admits a splitting. -/
def right_split.splitting {f : A ⟶ B} {g : B ⟶ C} (h : right_split f g) : splitting f g :=
splitting.mk'' h.short_exact (biprod.desc f h.right_split.some)
(biprod.inl_desc _ _)
(by { ext,
  { rw [biprod.inl_snd, ← category.assoc, biprod.inl_desc, h.exact.w] },
  { rw [biprod.inr_snd, ← category.assoc, biprod.inr_desc, h.right_split.some_spec] } })

end category_theory


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.big_operators.pi
import Mathlib.data.finsupp.default
import Mathlib.PostPort

universes u_1 u_2 u_4 u_3 u_5 u_6

namespace Mathlib

/-!
# Big operators for finsupps

This file contains theorems relevant to big operators in finitely supported functions.
-/

theorem finset.sum_apply' {α : Type u_1} {ι : Type u_2} {A : Type u_4} [add_comm_monoid A]
    {s : finset α} {f : α → ι →₀ A} (i : ι) :
    coe_fn (finset.sum s fun (k : α) => f k) i = finset.sum s fun (k : α) => coe_fn (f k) i :=
  Eq.symm (finset.sum_hom s ⇑(finsupp.apply_add_hom i))

theorem finsupp.sum_apply' {ι : Type u_2} {γ : Type u_3} {A : Type u_4} {B : Type u_5}
    [add_comm_monoid A] [add_comm_monoid B] (g : ι →₀ A) (k : ι → A → γ → B) (x : γ) :
    finsupp.sum g k x = finsupp.sum g fun (i : ι) (b : A) => k i b x :=
  finset.sum_apply x (finsupp.support g) fun (a : ι) => k a (coe_fn g a)

theorem finsupp.sum_sum_index' {α : Type u_1} {ι : Type u_2} {A : Type u_4} {C : Type u_6}
    [add_comm_monoid A] [add_comm_monoid C] {t : ι → A → C} (h0 : ∀ (i : ι), t i 0 = 0)
    (h1 : ∀ (i : ι) (x y : A), t i (x + y) = t i x + t i y) {s : finset α} {f : α → ι →₀ A} :
    finsupp.sum (finset.sum s fun (x : α) => f x) t =
        finset.sum s fun (x : α) => finsupp.sum (f x) t :=
  sorry

end Mathlib