/- Separate compilation and syntactic linking -/

import .ast .maps .lib

/- This file follows "approach A" from the paper
       "Lightweight Verification of Separate Compilation"
    by Kang, Kim, Hur, Dreyer and Vafeiadis, POPL 2016. -/

namespace linking
open ast maps

/- * Syntactic linking -/

/- A syntactic element [A] supports syntactic linking if it is equipped with the following:
- a partial binary operator [link] that produces the result of linking two elements,
  or fails if they cannot be linked (e.g. two definitions that are incompatible);
- a preorder [linkorder] with the meaning that [linkorder a1 a2] holds
  if [a2] can be obtained by linking [a1] with some other syntactic element.
-/

class linker (A : Type) :=
(link : A → A → option A)
(linkorder : A → A → Prop)
(linkorder_refl : ∀ x, linkorder x x)
(linkorder_trans : ∀ {x y z}, linkorder x y → linkorder y z → linkorder x z)
(link_linkorder : ∀ {x y z}, link x y = some z → linkorder x z ∧ linkorder y z)
export linker (link linkorder)

/- Linking variable initializers.  We adopt the following conventions:
- an "extern" variable has an empty initialization list;
- a "common" variable has an initialization list of the form [Init_space sz];
- all other initialization lists correspond to fully defined variables, neither "common" nor "extern".
-/

inductive init_class : list init_data → Type
| extern : init_class []
| common (sz) : init_class [init_data.space sz]
| definitive (il) : init_class il

def classify_init : Π (i : list init_data), init_class i
| [] := init_class.extern
| (init_data.space sz :: []) := init_class.common sz
| i := init_class.definitive i

def link_varinit (i1 i2 : list init_data) :=
match i1, i2, classify_init i1, classify_init i2 with
| ._, i2, init_class.extern, _ := some i2
| i1, ._, _, init_class.extern := some i1
| ._, i2, init_class.common sz1, _ := if sz1 = init_data.list_size i2 then some i2 else none
| i1, ._, _, init_class.common sz2 := if sz2 = init_data.list_size i1 then some i1 else none
| i1, i2, _, _ := none
end.

inductive linkorder_varinit : list init_data → list init_data → Prop
| linkorder_varinit_refl (il) : linkorder_varinit il il
| linkorder_varinit_extern (il) : linkorder_varinit [] il
| linkorder_varinit_common {sz il} :
    il ≠ list.nil → init_data.list_size il = sz →
    linkorder_varinit [init_data.space sz] il.

instance Linker_varinit : linker (list init_data) :=
{ link := link_varinit,
  linkorder := linkorder_varinit,
  linkorder_refl := sorry',
  linkorder_trans := sorry',
  link_linkorder := sorry' }

/- Linking variable definitions. -/

def link_vardef {V} [linker V] (v1 v2 : globvar V) : option (globvar V) :=
  match link v1.info v2.info with
  | none := none
  | some info :=
      match link v1.init v2.init with
      | none := none
      | some init :=
          if v1.readonly = v2.readonly ∧
             v1.volatile = v2.volatile
          then some { info := info, init := init,
                      readonly := v1.readonly,
                      volatile := v1.volatile }
          else none
      end
  end.

inductive linkorder_vardef {V} [linker V] : globvar V → globvar V → Prop
| intro {info1 info2 i1 i2} {ro vo} :
    linkorder info1 info2 →
    linkorder i1 i2 →
    linkorder_vardef ⟨info1, i1, ro, vo⟩ ⟨info2, i2, ro, vo⟩

instance Linker_vardef {V} [linker V] : linker (globvar V) :=
{ link := link_vardef,
  linkorder := linkorder_vardef,
  linkorder_refl := sorry',
  linkorder_trans := sorry',
  link_linkorder := sorry' }

/- Linking global definitions -/

def link_def {F V} [linker F] [linker V] : globdef F V → globdef F V → option (globdef F V)
| (Gfun f1) (Gfun f2) := Gfun <$> link f1 f2
| (Gvar v1) (Gvar v2) := Gvar <$> link v1 v2
| _ _ := none

inductive linkorder_def {F V} [linker F] [linker V] : globdef F V → globdef F V → Prop
| linkorder_def_fun (fd1 fd2) :
    linkorder fd1 fd2 →
    linkorder_def (Gfun fd1) (Gfun fd2)
| linkorder_def_var (v1 v2) :
    linkorder v1 v2 →
    linkorder_def (Gvar v1) (Gvar v2).

instance Linker_def {F V} [linker F] [linker V] : linker (globdef F V) :=
{ link := link_def,
  linkorder := linkorder_def,
  linkorder_refl := sorry',
  linkorder_trans := sorry',
  link_linkorder := sorry' }

/- Linking two compilation units.  Compilation units are represented like
  whole programs using the type [program F V].  If a name has
  a global definition in one unit but not in the other, this definition
  is left unchanged in the result of the link.  If a name has
  global definitions in both units, and is public (not static) in both,
  the two definitions are linked as per [Linker_def] above.

  If one or both definitions are static (not public), we should ideally
  rename it so that it can be kept unchanged in the result of the link.
  This would require a general notion of renaming of global identifiers
  in programs that we do not have yet.  Hence, as a first step, linking
  is undefined if static definitions with the same name appear in both
  compilation units. -/

section linker_prog
parameters {F V : Type} [linker F] [linker V]

section
parameters (p1 p2 : program F V)

def dm1 := prog_defmap p1
def dm2 := prog_defmap p2

def link_prog_check (x : ident) (gd1 : globdef F V) :=
match dm2^!x with
| none := tt
| some gd2 := (x ∈ p1.public) && (x ∈ p2.public) && (link gd1 gd2).is_some
end

def link_prog_merge : option (globdef F V) → option (globdef F V) → option (globdef F V)
| none o2 := o2
| o1 none := o1
| (some gd1) (some gd2) := link gd1 gd2

def link_prog : option (program F V) :=
if p1.main = p2.main ∧ PTree.for_all dm1 link_prog_check then
some { main := p1.main,
       public := p1.public ++ p2.public,
       defs := PTree.elements $ PTree.combine link_prog_merge dm1 dm2 }
else none

lemma link_prog_inv (p) (h : link_prog = some p) :
      p1.main = p2.main
   ∧ (∀ (id : ident) gd1 gd2,
         (dm1^!id) = some gd1 → (dm2^!id) = some gd2 →
         id ∈ p1.public ∧ id ∈ p2.public ∧ ∃ gd, link gd1 gd2 = some gd)
  ∧ p = { main := p1.main,
          public := p1.public ++ p2.public,
          defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) } := sorry'

lemma link_prog_succeeds (hp : p1.main = p2.main)
  (h : ∀ (id : ident) gd1 gd2,
       (dm1^!id) = some gd1 → (dm2^!id) = some gd2 →
       id ∈ p1.public ∧ id ∈ p2.public ∧ (link gd1 gd2).is_some) :
  link_prog = some {
    main := p1.main,
    public := p1.public ++ p2.public,
    defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) } := sorry'

lemma prog_defmap_elements (m: PTree (globdef F V)) (pub mn x) :
  (prog_defmap ⟨PTree.elements m, pub, mn⟩ ^! x) = (m^!x) := sorry'
end

instance linker_prog : linker (program F V) :=
{ link := link_prog,
  linkorder := λp1 p2, p1.main = p2.main
  ∧ p1.public ⊆ p2.public
  ∧ ∀ (id : ident) gd1, (prog_defmap p1^!id) = some gd1 →
     ∃ gd2, (prog_defmap p2^!id) = some gd2 ∧
       linkorder gd1 gd2 ∧ (id ∉ p2.public → gd2 = gd1),
  linkorder_refl := sorry',
  linkorder_trans := sorry',
  link_linkorder := sorry' }

lemma prog_defmap_linkorder {p1 p2 : program F V} {id gd1} :
  linkorder p1 p2 →
  (prog_defmap p1^!id) = some gd1 →
  ∃ gd2, (prog_defmap p2^!id) = some gd2 ∧ linkorder gd1 gd2 := sorry'

end linker_prog

/- * Matching between two programs -/

/- The following is a relational presentation of program transformations,
  e.g. [transf_partial_program] from module [AST].  -/

/- To capture the possibility of separate compilation, we parameterize
  the [match_fundef] relation between function definitions with
  a context, e.g. the compilation unit from which the function definition comes.
  This unit is characterized as any program that is in the [linkorder]
  relation with the final, whole program. -/

section match_program_generic

parameters {C F1 V1 F2 V2 : Type} -- [linker F1] [linker V1]
parameter match_fundef : C → F1 → F2 → Prop
parameter match_varinfo : V1 → V2 → Prop

inductive match_globvar : globvar V1 → globvar V2 → Prop
| mk (i1 i2 init ro vo) :
  match_varinfo i1 i2 →
  match_globvar ⟨i1, init, ro, vo⟩ ⟨i2, init, ro, vo⟩

variable [linker C]

inductive match_globdef (ctx : C) : globdef F1 V1 → globdef F2 V2 → Prop
| func (ctx' f1 f2) :
  linkorder ctx' ctx →
  match_fundef ctx' f1 f2 →
  match_globdef (Gfun f1) (Gfun f2)
| var {v1 v2} :
  match_globvar v1 v2 →
  match_globdef (Gvar v1) (Gvar v2).

def match_ident_globdef (ctx : C) : ident × globdef F1 V1 → ident × globdef F2 V2 → Prop
| (i1, g1) (i2, g2) := i1 = i2 ∧ match_globdef ctx g1 g2

def match_program_gen (ctx : C) (p1 : program F1 V1) (p2 : program F2 V2) : Prop :=
list.forall2 (match_ident_globdef ctx) p1.defs p2.defs
∧ p2.main = p1.main
∧ p2.public = p1.public

theorem match_program_defmap {ctx p1 p2} (hm : match_program_gen ctx p1 p2) (id) :
  option.rel (match_globdef ctx) (prog_defmap p1^!id) (prog_defmap p2^!id) := sorry'

lemma match_program_gen_main {ctx p1 p2} (hm : match_program_gen ctx p1 p2) :
  p2.main = p1.main := sorry'

lemma match_program_public {ctx p1 p2} (hm : match_program_gen ctx p1 p2) :
  p2.public = p1.public := sorry'

end match_program_generic

/- In many cases, the context for [match_program_gen] is the source program or
  source compilation unit itself.  We provide a specialized definition for this case. -/

def match_program {F1 V1 F2 V2} [linker F1] [linker V1]
  (match_fundef : program F1 V1 → F1 → F2 → Prop)
  (match_varinfo : V1 → V2 → Prop)
  (p1 : program F1 V1) (p2 : program F2 V2) : Prop :=
match_program_gen match_fundef match_varinfo p1 p1 p2

lemma match_program_main {F1 V1 F2 V2} [linker F1] [linker V1]
  {match_fundef : program F1 V1 → F1 → F2 → Prop}
  {match_varinfo : V1 → V2 → Prop}
  {p1 : program F1 V1} {p2 : program F2 V2}
  (hm : match_program match_fundef match_varinfo p1 p2) : p2.main = p1.main :=
match_program_gen_main _ _ hm

end linking


/-
Copyright (c) 2016 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.basic
import Mathlib.data.option.defs
import Mathlib.PostPort

universes u_1 u_2 u v w u_3 u_4 u_5 u_6 u_7 l

namespace Mathlib

/-!
# Miscellaneous function constructions and lemmas
-/

namespace function

/-- Evaluate a function at an argument. Useful if you want to talk about the partially applied
  `function.eval x : (Π x, β x) → β x`. -/
def eval {α : Sort u_1} {β : α → Sort u_2} (x : α) (f : (x : α) → β x) : β x := f x

@[simp] theorem eval_apply {α : Sort u_1} {β : α → Sort u_2} (x : α) (f : (x : α) → β x) :
    eval x f = f x :=
  rfl

theorem comp_apply {α : Sort u} {β : Sort v} {φ : Sort w} (f : β → φ) (g : α → β) (a : α) :
    comp f g a = f (g a) :=
  rfl

theorem const_def {α : Sort u_1} {β : Sort u_2} {y : β} : (fun (x : α) => y) = const α y := rfl

@[simp] theorem const_apply {α : Sort u_1} {β : Sort u_2} {y : β} {x : α} : const α y x = y := rfl

@[simp] theorem const_comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : α → β} {c : γ} :
    const β c ∘ f = const α c :=
  rfl

@[simp] theorem comp_const {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : β → γ} {b : β} :
    f ∘ const α b = const α (f b) :=
  rfl

theorem id_def {α : Sort u_1} : id = fun (x : α) => x := rfl

theorem hfunext {α : Sort u} {α' : Sort u} {β : α → Sort v} {β' : α' → Sort v} {f : (a : α) → β a}
    {f' : (a : α') → β' a} (hα : α = α') (h : ∀ (a : α) (a' : α'), a == a' → f a == f' a') :
    f == f' :=
  sorry

theorem funext_iff {α : Sort u_1} {β : α → Sort u_2} {f₁ : (x : α) → β x} {f₂ : (x : α) → β x} :
    f₁ = f₂ ↔ ∀ (a : α), f₁ a = f₂ a :=
  { mp := fun (h : f₁ = f₂) (a : α) => h ▸ rfl, mpr := funext }

@[simp] theorem injective.eq_iff {α : Sort u_1} {β : Sort u_2} {f : α → β} (I : injective f) {a : α}
    {b : α} : f a = f b ↔ a = b :=
  { mp := I, mpr := congr_arg f }

theorem injective.eq_iff' {α : Sort u_1} {β : Sort u_2} {f : α → β} (I : injective f) {a : α}
    {b : α} {c : β} (h : f b = c) : f a = c ↔ a = b :=
  h ▸ injective.eq_iff I

theorem injective.ne {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : injective f) {a₁ : α}
    {a₂ : α} : a₁ ≠ a₂ → f a₁ ≠ f a₂ :=
  mt fun (h : f a₁ = f a₂) => hf h

theorem injective.ne_iff {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : injective f) {x : α}
    {y : α} : f x ≠ f y ↔ x ≠ y :=
  { mp := mt (congr_arg f), mpr := injective.ne hf }

theorem injective.ne_iff' {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : injective f) {x : α}
    {y : α} {z : β} (h : f y = z) : f x ≠ z ↔ x ≠ y :=
  h ▸ injective.ne_iff hf

/-- If the co-domain `β` of an injective function `f : α → β` has decidable equality, then
the domain `α` also has decidable equality. -/
def injective.decidable_eq {α : Sort u_1} {β : Sort u_2} {f : α → β} [DecidableEq β]
    (I : injective f) : DecidableEq α :=
  fun (a b : α) => decidable_of_iff (f a = f b) (injective.eq_iff I)

theorem injective.of_comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : α → β} {g : γ → α}
    (I : injective (f ∘ g)) : injective g :=
  fun (x y : γ) (h : g x = g y) => I ((fun (this : f (g x) = f (g y)) => this) (congr_arg f h))

theorem surjective.of_comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : α → β} {g : γ → α}
    (S : surjective (f ∘ g)) : surjective f :=
  sorry

protected instance decidable_eq_pfun (p : Prop) [Decidable p] (α : p → Type u_1)
    [(hp : p) → DecidableEq (α hp)] : DecidableEq ((hp : p) → α hp) :=
  sorry

theorem surjective.forall {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → Prop} : (∀ (y : β), p y) ↔ ∀ (x : α), p (f x) :=
  sorry

theorem surjective.forall₂ {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → β → Prop} : (∀ (y₁ y₂ : β), p y₁ y₂) ↔ ∀ (x₁ x₂ : α), p (f x₁) (f x₂) :=
  iff.trans (surjective.forall hf) (forall_congr fun (x : α) => surjective.forall hf)

theorem surjective.forall₃ {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → β → β → Prop} :
    (∀ (y₁ y₂ y₃ : β), p y₁ y₂ y₃) ↔ ∀ (x₁ x₂ x₃ : α), p (f x₁) (f x₂) (f x₃) :=
  iff.trans (surjective.forall hf) (forall_congr fun (x : α) => surjective.forall₂ hf)

theorem surjective.exists {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → Prop} : (∃ (y : β), p y) ↔ ∃ (x : α), p (f x) :=
  sorry

theorem surjective.exists₂ {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → β → Prop} :
    (∃ (y₁ : β), ∃ (y₂ : β), p y₁ y₂) ↔ ∃ (x₁ : α), ∃ (x₂ : α), p (f x₁) (f x₂) :=
  iff.trans (surjective.exists hf) (exists_congr fun (x : α) => surjective.exists hf)

theorem surjective.exists₃ {α : Sort u_1} {β : Sort u_2} {f : α → β} (hf : surjective f)
    {p : β → β → β → Prop} :
    (∃ (y₁ : β), ∃ (y₂ : β), ∃ (y₃ : β), p y₁ y₂ y₃) ↔
        ∃ (x₁ : α), ∃ (x₂ : α), ∃ (x₃ : α), p (f x₁) (f x₂) (f x₃) :=
  iff.trans (surjective.exists hf) (exists_congr fun (x : α) => surjective.exists₂ hf)

/-- Cantor's diagonal argument implies that there are no surjective functions from `α`
to `set α`. -/
theorem cantor_surjective {α : Type u_1} (f : α → set α) : ¬surjective f := sorry

/-- Cantor's diagonal argument implies that there are no injective functions from `set α` to `α`. -/
theorem cantor_injective {α : Type u_1} (f : set α → α) : ¬injective f := sorry

/-- `g` is a partial inverse to `f` (an injective but not necessarily
  surjective function) if `g y = some x` implies `f x = y`, and `g y = none`
  implies that `y` is not in the range of `f`. -/
def is_partial_inv {α : Type u_1} {β : Sort u_2} (f : α → β) (g : β → Option α) :=
  ∀ (x : α) (y : β), g y = some x ↔ f x = y

theorem is_partial_inv_left {α : Type u_1} {β : Sort u_2} {f : α → β} {g : β → Option α}
    (H : is_partial_inv f g) (x : α) : g (f x) = some x :=
  iff.mpr (H x (f x)) rfl

theorem injective_of_partial_inv {α : Type u_1} {β : Sort u_2} {f : α → β} {g : β → Option α}
    (H : is_partial_inv f g) : injective f :=
  fun (a b : α) (h : f a = f b) =>
    option.some.inj (Eq.trans (Eq.symm (iff.mpr (H a (f b)) h)) (iff.mpr (H b (f b)) rfl))

theorem injective_of_partial_inv_right {α : Type u_1} {β : Sort u_2} {f : α → β} {g : β → Option α}
    (H : is_partial_inv f g) (x : β) (y : β) (b : α) (h₁ : b ∈ g x) (h₂ : b ∈ g y) : x = y :=
  Eq.trans (Eq.symm (iff.mp (H b x) h₁)) (iff.mp (H b y) h₂)

theorem left_inverse.comp_eq_id {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : left_inverse f g) : f ∘ g = id :=
  funext h

theorem left_inverse_iff_comp {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α} :
    left_inverse f g ↔ f ∘ g = id :=
  { mp := left_inverse.comp_eq_id, mpr := congr_fun }

theorem right_inverse.comp_eq_id {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : right_inverse f g) : g ∘ f = id :=
  funext h

theorem right_inverse_iff_comp {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α} :
    right_inverse f g ↔ g ∘ f = id :=
  { mp := right_inverse.comp_eq_id, mpr := congr_fun }

theorem left_inverse.comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : α → β} {g : β → α}
    {h : β → γ} {i : γ → β} (hf : left_inverse f g) (hh : left_inverse h i) :
    left_inverse (h ∘ f) (g ∘ i) :=
  sorry

theorem right_inverse.comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {f : α → β} {g : β → α}
    {h : β → γ} {i : γ → β} (hf : right_inverse f g) (hh : right_inverse h i) :
    right_inverse (h ∘ f) (g ∘ i) :=
  left_inverse.comp hh hf

theorem left_inverse.right_inverse {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : left_inverse g f) : right_inverse f g :=
  h

theorem right_inverse.left_inverse {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : right_inverse g f) : left_inverse f g :=
  h

theorem left_inverse.surjective {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : left_inverse f g) : surjective f :=
  right_inverse.surjective (left_inverse.right_inverse h)

theorem right_inverse.injective {α : Sort u_1} {β : Sort u_2} {f : α → β} {g : β → α}
    (h : right_inverse f g) : injective f :=
  left_inverse.injective (right_inverse.left_inverse h)

theorem left_inverse.eq_right_inverse {α : Sort u_1} {β : Sort u_2} {f : α → β} {g₁ : β → α}
    {g₂ : β → α} (h₁ : left_inverse g₁ f) (h₂ : right_inverse g₂ f) : g₁ = g₂ :=
  sorry

/-- We can use choice to construct explicitly a partial inverse for
  a given injective function `f`. -/
def partial_inv {α : Type u_1} {β : Sort u_2} (f : α → β) (b : β) : Option α :=
  dite (∃ (a : α), f a = b) (fun (h : ∃ (a : α), f a = b) => some (classical.some h))
    fun (h : ¬∃ (a : α), f a = b) => none

theorem partial_inv_of_injective {α : Type u_1} {β : Sort u_2} {f : α → β} (I : injective f) :
    is_partial_inv f (partial_inv f) :=
  sorry

theorem partial_inv_left {α : Type u_1} {β : Sort u_2} {f : α → β} (I : injective f) (x : α) :
    partial_inv f (f x) = some x :=
  is_partial_inv_left (partial_inv_of_injective I)

/-- Construct the inverse for a function `f` on domain `s`. This function is a right inverse of `f`
on `f '' s`. -/
def inv_fun_on {α : Type u} [n : Nonempty α] {β : Sort v} (f : α → β) (s : set α) (b : β) : α :=
  dite (∃ (a : α), a ∈ s ∧ f a = b) (fun (h : ∃ (a : α), a ∈ s ∧ f a = b) => classical.some h)
    fun (h : ¬∃ (a : α), a ∈ s ∧ f a = b) => Classical.choice n

theorem inv_fun_on_pos {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {s : set α} {b : β}
    (h : ∃ (a : α), ∃ (H : a ∈ s), f a = b) : inv_fun_on f s b ∈ s ∧ f (inv_fun_on f s b) = b :=
  sorry

theorem inv_fun_on_mem {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {s : set α} {b : β}
    (h : ∃ (a : α), ∃ (H : a ∈ s), f a = b) : inv_fun_on f s b ∈ s :=
  and.left (inv_fun_on_pos h)

theorem inv_fun_on_eq {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {s : set α} {b : β}
    (h : ∃ (a : α), ∃ (H : a ∈ s), f a = b) : f (inv_fun_on f s b) = b :=
  and.right (inv_fun_on_pos h)

theorem inv_fun_on_eq' {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {s : set α} {a : α}
    (h : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → f x = f y → x = y) (ha : a ∈ s) :
    inv_fun_on f s (f a) = a :=
  (fun (this : ∃ (a' : α), ∃ (H : a' ∈ s), f a' = f a) =>
      h (inv_fun_on (fun (a' : α) => f a') s (f a)) (inv_fun_on_mem this) a ha (inv_fun_on_eq this))
    (Exists.intro a (Exists.intro ha rfl))

theorem inv_fun_on_neg {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {s : set α} {b : β}
    (h : ¬∃ (a : α), ∃ (H : a ∈ s), f a = b) : inv_fun_on f s b = Classical.choice n :=
  sorry

/-- The inverse of a function (which is a left inverse if `f` is injective
  and a right inverse if `f` is surjective). -/
def inv_fun {α : Type u} [n : Nonempty α] {β : Sort v} (f : α → β) : β → α := inv_fun_on f set.univ

theorem inv_fun_eq {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {b : β}
    (h : ∃ (a : α), f a = b) : f (inv_fun f b) = b :=
  sorry

theorem inv_fun_neg {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} {b : β}
    (h : ¬∃ (a : α), f a = b) : inv_fun f b = Classical.choice n :=
  sorry

theorem inv_fun_eq_of_injective_of_right_inverse {α : Type u} [n : Nonempty α] {β : Sort v}
    {f : α → β} {g : β → α} (hf : injective f) (hg : right_inverse g f) : inv_fun f = g :=
  funext
    fun (b : β) =>
      hf
        (eq.mpr (id (Eq._oldrec (Eq.refl (f (inv_fun f b) = f (g b))) (hg b)))
          (inv_fun_eq (Exists.intro (g b) (hg b))))

theorem right_inverse_inv_fun {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β}
    (hf : surjective f) : right_inverse (inv_fun f) f :=
  fun (b : β) => inv_fun_eq (hf b)

theorem left_inverse_inv_fun {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β}
    (hf : injective f) : left_inverse (inv_fun f) f :=
  fun (b : α) =>
    (fun (this : f (inv_fun f (f b)) = f b) => hf this) (inv_fun_eq (Exists.intro b rfl))

theorem inv_fun_surjective {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β}
    (hf : injective f) : surjective (inv_fun f) :=
  left_inverse.surjective (left_inverse_inv_fun hf)

theorem inv_fun_comp {α : Type u} [n : Nonempty α] {β : Sort v} {f : α → β} (hf : injective f) :
    inv_fun f ∘ f = id :=
  funext (left_inverse_inv_fun hf)

theorem injective.has_left_inverse {α : Type u} [i : Nonempty α] {β : Sort v} {f : α → β}
    (hf : injective f) : has_left_inverse f :=
  Exists.intro (inv_fun f) (left_inverse_inv_fun hf)

theorem injective_iff_has_left_inverse {α : Type u} [i : Nonempty α] {β : Sort v} {f : α → β} :
    injective f ↔ has_left_inverse f :=
  { mp := injective.has_left_inverse, mpr := has_left_inverse.injective }

/-- The inverse of a surjective function. (Unlike `inv_fun`, this does not require
  `α` to be inhabited.) -/
def surj_inv {α : Sort u} {β : Sort v} {f : α → β} (h : surjective f) (b : β) : α :=
  classical.some (h b)

theorem surj_inv_eq {α : Sort u} {β : Sort v} {f : α → β} (h : surjective f) (b : β) :
    f (surj_inv h b) = b :=
  classical.some_spec (h b)

theorem right_inverse_surj_inv {α : Sort u} {β : Sort v} {f : α → β} (hf : surjective f) :
    right_inverse (surj_inv hf) f :=
  surj_inv_eq hf

theorem left_inverse_surj_inv {α : Sort u} {β : Sort v} {f : α → β} (hf : bijective f) :
    left_inverse (surj_inv (and.right hf)) f :=
  right_inverse_of_injective_of_left_inverse (and.left hf) (right_inverse_surj_inv (and.right hf))

theorem surjective.has_right_inverse {α : Sort u} {β : Sort v} {f : α → β} (hf : surjective f) :
    has_right_inverse f :=
  Exists.intro (surj_inv hf) (right_inverse_surj_inv hf)

theorem surjective_iff_has_right_inverse {α : Sort u} {β : Sort v} {f : α → β} :
    surjective f ↔ has_right_inverse f :=
  { mp := surjective.has_right_inverse, mpr := has_right_inverse.surjective }

theorem bijective_iff_has_inverse {α : Sort u} {β : Sort v} {f : α → β} :
    bijective f ↔ ∃ (g : β → α), left_inverse g f ∧ right_inverse g f :=
  sorry

theorem injective_surj_inv {α : Sort u} {β : Sort v} {f : α → β} (h : surjective f) :
    injective (surj_inv h) :=
  right_inverse.injective (right_inverse_surj_inv h)

/-- Replacing the value of a function at a given point by a given value. -/
def update {α : Sort u} {β : α → Sort v} [DecidableEq α] (f : (a : α) → β a) (a' : α) (v : β a')
    (a : α) : β a :=
  dite (a = a') (fun (h : a = a') => Eq._oldrec v (Eq.symm h)) fun (h : ¬a = a') => f a

/-- On non-dependent functions, `function.update` can be expressed as an `ite` -/
theorem update_apply {α : Sort u} [DecidableEq α] {β : Sort u_1} (f : α → β) (a' : α) (b : β)
    (a : α) : update f a' b a = ite (a = a') b (f a) :=
  sorry

@[simp] theorem update_same {α : Sort u} {β : α → Sort v} [DecidableEq α] (a : α) (v : β a)
    (f : (a : α) → β a) : update f a v a = v :=
  dif_pos rfl

theorem update_injective {α : Sort u} {β : α → Sort v} [DecidableEq α] (f : (a : α) → β a)
    (a' : α) : injective (update f a') :=
  sorry

@[simp] theorem update_noteq {α : Sort u} {β : α → Sort v} [DecidableEq α] {a : α} {a' : α}
    (h : a ≠ a') (v : β a') (f : (a : α) → β a) : update f a' v a = f a :=
  dif_neg h

theorem forall_update_iff {α : Sort u} {β : α → Sort v} [DecidableEq α] (f : (a : α) → β a) {a : α}
    {b : β a} (p : (a : α) → β a → Prop) :
    (∀ (x : α), p x (update f a b x)) ↔ p a b ∧ ∀ (x : α), x ≠ a → p x (f x) :=
  sorry

theorem update_eq_iff {α : Sort u} {β : α → Sort v} [DecidableEq α] {a : α} {b : β a}
    {f : (a : α) → β a} {g : (a : α) → β a} :
    update f a b = g ↔ b = g a ∧ ∀ (x : α), x ≠ a → f x = g x :=
  iff.trans funext_iff (forall_update_iff f fun (x : α) (y : β x) => y = g x)

theorem eq_update_iff {α : Sort u} {β : α → Sort v} [DecidableEq α] {a : α} {b : β a}
    {f : (a : α) → β a} {g : (a : α) → β a} :
    g = update f a b ↔ g a = b ∧ ∀ (x : α), x ≠ a → g x = f x :=
  iff.trans funext_iff (forall_update_iff f fun (x : α) (y : β x) => g x = y)

@[simp] theorem update_eq_self {α : Sort u} {β : α → Sort v} [DecidableEq α] (a : α)
    (f : (a : α) → β a) : update f a (f a) = f :=
  iff.mpr update_eq_iff { left := rfl, right := fun (_x : α) (_x_1 : _x ≠ a) => rfl }

theorem update_comp_eq_of_forall_ne' {α : Sort u} {β : α → Sort v} [DecidableEq α] {α' : Sort u_1}
    (g : (a : α) → β a) {f : α' → α} {i : α} (a : β i) (h : ∀ (x : α'), f x ≠ i) :
    (fun (j : α') => update g i a (f j)) = fun (j : α') => g (f j) :=
  funext fun (x : α') => update_noteq (h x) a g

/-- Non-dependent version of `function.update_comp_eq_of_forall_ne'` -/
theorem update_comp_eq_of_forall_ne {α' : Sort w} [DecidableEq α'] {α : Sort u_1} {β : Sort u_2}
    (g : α' → β) {f : α → α'} {i : α'} (a : β) (h : ∀ (x : α), f x ≠ i) :
    update g i a ∘ f = g ∘ f :=
  update_comp_eq_of_forall_ne' g a h

theorem update_comp_eq_of_injective' {α : Sort u} {β : α → Sort v} {α' : Sort w} [DecidableEq α]
    [DecidableEq α'] (g : (a : α) → β a) {f : α' → α} (hf : injective f) (i : α') (a : β (f i)) :
    (fun (j : α') => update g (f i) a (f j)) = update (fun (i : α') => g (f i)) i a :=
  iff.mpr eq_update_iff
    { left := update_same (f i) a g,
      right := fun (j : α') (hj : j ≠ i) => update_noteq (injective.ne hf hj) a g }

/-- Non-dependent version of `function.update_comp_eq_of_injective'` -/
theorem update_comp_eq_of_injective {α : Sort u} {α' : Sort w} [DecidableEq α] [DecidableEq α']
    {β : Sort u_1} (g : α' → β) {f : α → α'} (hf : injective f) (i : α) (a : β) :
    update g (f i) a ∘ f = update (g ∘ f) i a :=
  update_comp_eq_of_injective' g hf i a

theorem apply_update {ι : Sort u_1} [DecidableEq ι] {α : ι → Sort u_2} {β : ι → Sort u_3}
    (f : (i : ι) → α i → β i) (g : (i : ι) → α i) (i : ι) (v : α i) (j : ι) :
    f j (update g i v j) = update (fun (k : ι) => f k (g k)) i (f i v) j :=
  sorry

theorem comp_update {α : Sort u} [DecidableEq α] {α' : Sort u_1} {β : Sort u_2} (f : α' → β)
    (g : α → α') (i : α) (v : α') : f ∘ update g i v = update (f ∘ g) i (f v) :=
  funext (apply_update (fun (x : α) => f) g i v)

theorem update_comm {α : Sort u_1} [DecidableEq α] {β : α → Sort u_2} {a : α} {b : α} (h : a ≠ b)
    (v : β a) (w : β b) (f : (a : α) → β a) :
    update (update f a v) b w = update (update f b w) a v :=
  sorry

@[simp] theorem update_idem {α : Sort u_1} [DecidableEq α] {β : α → Sort u_2} {a : α} (v : β a)
    (w : β a) (f : (a : α) → β a) : update (update f a v) a w = update f a w :=
  sorry

/-- `extend f g e'` extends a function `g : α → γ`
along a function `f : α → β` to a function `β → γ`,
by using the values of `g` on the range of `f`
and the values of an auxiliary function `e' : β → γ` elsewhere.

Mostly useful when `f` is injective. -/
def extend {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β) (g : α → γ) (e' : β → γ) :
    β → γ :=
  fun (b : β) =>
    dite (∃ (a : α), f a = b) (fun (h : ∃ (a : α), f a = b) => g (classical.some h))
      fun (h : ¬∃ (a : α), f a = b) => e' b

theorem extend_def {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β) (g : α → γ) (e' : β → γ)
    (b : β) :
    extend f g e' b =
        dite (∃ (a : α), f a = b) (fun (h : ∃ (a : α), f a = b) => g (classical.some h))
          fun (h : ¬∃ (a : α), f a = b) => e' b :=
  rfl

@[simp] theorem extend_apply {α : Type u_1} {β : Type u_2} {γ : Type u_3} {f : α → β}
    (hf : injective f) (g : α → γ) (e' : β → γ) (a : α) : extend f g e' (f a) = g a :=
  sorry

@[simp] theorem extend_comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {f : α → β}
    (hf : injective f) (g : α → γ) (e' : β → γ) : extend f g e' ∘ f = g :=
  funext fun (a : α) => extend_apply hf g e' a

theorem uncurry_def {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ) :
    uncurry f = fun (p : α × β) => f (prod.fst p) (prod.snd p) :=
  rfl

@[simp] theorem uncurry_apply_pair {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ)
    (x : α) (y : β) : uncurry f (x, y) = f x y :=
  rfl

@[simp] theorem curry_apply {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α × β → γ) (x : α)
    (y : β) : curry f x y = f (x, y) :=
  rfl

/-- Compose a binary function `f` with a pair of unary functions `g` and `h`.
If both arguments of `f` have the same type and `g = h`, then `bicompl f g g = f on g`. -/
def bicompl {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {ε : Type u_5}
    (f : γ → δ → ε) (g : α → γ) (h : β → δ) (a : α) (b : β) : ε :=
  f (g a) (h b)

/-- Compose an unary function `f` with a binary function `g`. -/
def bicompr {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : γ → δ) (g : α → β → γ)
    (a : α) (b : β) : δ :=
  f (g a b)

-- Suggested local notation:

theorem uncurry_bicompr {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → β → γ)
    (g : γ → δ) : uncurry (bicompr g f) = g ∘ uncurry f :=
  rfl

theorem uncurry_bicompl {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {ε : Type u_5}
    (f : γ → δ → ε) (g : α → γ) (h : β → δ) : uncurry (bicompl f g h) = uncurry f ∘ prod.map g h :=
  rfl

/-- Records a way to turn an element of `α` into a function from `β` to `γ`. The most generic use
is to recursively uncurry. For instance `f : α → β → γ → δ` will be turned into
`↿f : α × β × γ → δ`. One can also add instances for bundled maps. -/
class has_uncurry (α : Type u_5) (β : outParam (Type u_6)) (γ : outParam (Type u_7)) where
  uncurry : α → β → γ

prefix:1024 "↿" => Mathlib.function.has_uncurry.uncurry

/-- Uncurrying operator. The most generic use is to recursively uncurry. For instance
`f : α → β → γ → δ` will be turned into `↿f : α × β × γ → δ`. One can also add instances
for bundled maps.-/
protected instance has_uncurry_base {α : Type u_1} {β : Type u_2} : has_uncurry (α → β) α β :=
  has_uncurry.mk id

protected instance has_uncurry_induction {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4}
    [has_uncurry β γ δ] : has_uncurry (α → β) (α × γ) δ :=
  has_uncurry.mk fun (f : α → β) (p : α × γ) => has_uncurry.uncurry (f (prod.fst p)) (prod.snd p)

/-- A function is involutive, if `f ∘ f = id`. -/
def involutive {α : Sort u_1} (f : α → α) := ∀ (x : α), f (f x) = x

theorem involutive_iff_iter_2_eq_id {α : Sort u_1} {f : α → α} :
    involutive f ↔ nat.iterate f (bit0 1) = id :=
  iff.symm funext_iff

namespace involutive

@[simp] theorem comp_self {α : Sort u} {f : α → α} (h : involutive f) : f ∘ f = id := funext h

protected theorem left_inverse {α : Sort u} {f : α → α} (h : involutive f) : left_inverse f f := h

protected theorem right_inverse {α : Sort u} {f : α → α} (h : involutive f) : right_inverse f f := h

protected theorem injective {α : Sort u} {f : α → α} (h : involutive f) : injective f :=
  left_inverse.injective (involutive.left_inverse h)

protected theorem surjective {α : Sort u} {f : α → α} (h : involutive f) : surjective f :=
  fun (x : α) => Exists.intro (f x) (h x)

protected theorem bijective {α : Sort u} {f : α → α} (h : involutive f) : bijective f :=
  { left := involutive.injective h, right := involutive.surjective h }

/-- Involuting an `ite` of an involuted value `x : α` negates the `Prop` condition in the `ite`. -/
protected theorem ite_not {α : Sort u} {f : α → α} (h : involutive f) (P : Prop) [Decidable P]
    (x : α) : f (ite P x (f x)) = ite (¬P) x (f x) :=
  sorry

end involutive

/-- The property of a binary function `f : α → β → γ` being injective.
  Mathematically this should be thought of as the corresponding function `α × β → γ` being injective.
-/
def injective2 {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} (f : α → β → γ) :=
  ∀ {a₁ a₂ : α} {b₁ b₂ : β}, f a₁ b₁ = f a₂ b₂ → a₁ = a₂ ∧ b₁ = b₂

namespace injective2

protected theorem left {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ)
    (hf : injective2 f) {a₁ : α} {a₂ : α} {b₁ : β} {b₂ : β} (h : f a₁ b₁ = f a₂ b₂) : a₁ = a₂ :=
  and.left (hf h)

protected theorem right {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ)
    (hf : injective2 f) {a₁ : α} {a₂ : α} {b₁ : β} {b₂ : β} (h : f a₁ b₁ = f a₂ b₂) : b₁ = b₂ :=
  and.right (hf h)

theorem eq_iff {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → β → γ) (hf : injective2 f)
    {a₁ : α} {a₂ : α} {b₁ : β} {b₂ : β} : f a₁ b₁ = f a₂ b₂ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
  sorry

end injective2

/-- `sometimes f` evaluates to some value of `f`, if it exists. This function is especially
interesting in the case where `α` is a proposition, in which case `f` is necessarily a
constant function, so that `sometimes f = f a` for all `a`. -/
def sometimes {α : Sort u_1} {β : Sort u_2} [Nonempty β] (f : α → β) : β :=
  dite (Nonempty α) (fun (h : Nonempty α) => f (Classical.choice h))
    fun (h : ¬Nonempty α) => Classical.choice _inst_1

theorem sometimes_eq {p : Prop} {α : Sort u_1} [Nonempty α] (f : p → α) (a : p) :
    sometimes f = f a :=
  dif_pos (Nonempty.intro a)

theorem sometimes_spec {p : Prop} {α : Sort u_1} [Nonempty α] (P : α → Prop) (f : p → α) (a : p)
    (h : P (f a)) : P (sometimes f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (P (sometimes f))) (sometimes_eq f a))) h

end function

/-- `s.piecewise f g` is the function equal to `f` on the set `s`, and to `g` on its complement. -/
def set.piecewise {α : Type u} {β : α → Sort v} (s : set α) (f : (i : α) → β i) (g : (i : α) → β i)
    [(j : α) → Decidable (j ∈ s)] (i : α) : β i :=
  ite (i ∈ s) (f i) (g i)

end Mathlib


import tactic.core

open tactic lean.parser interactive.types

run_parser do
  e ← with_input texpr "λ x:ℕ, x",
  e ← to_expr e.1,
  guard (e =ₐ `(λ x:ℕ, x)),
  emit_code_here "def foo := 1"

example : foo = 1 := rfl

-- check that `emit_code_here` terminates properly
run_parser emit_code_here "\n"


/-
Copyright (c) 2017 Mario Carneiro All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Floris van Doorn
-/
import tactic.core

namespace tactic

/-- `copy_attribute' attr_name src tgt p d_name` copy (user) attribute `attr_name` from
   `src` to `tgt` if it is defined for `src`; unlike `copy_attribute` the primed version also copies
   the parameter of the user attribute, in the user attribute case. Make it persistent if `p` is
   `tt`; if `p` is `none`, the copied attribute is made persistent iff it is persistent on `src`  -/
meta def copy_attribute' (attr_name : name) (src : name) (tgt : name) (p : option bool := none) :
tactic unit := do
  get_decl tgt <|> fail!"unknown declaration {tgt}",
  -- if the source doesn't have the attribute we do not error and simply return
  mwhen (succeeds (has_attribute attr_name src)) $
    do (p', prio) ← has_attribute attr_name src,
      let p := p.get_or_else p',
      s ← try_or_report_error (set_basic_attribute attr_name tgt p prio),
      sum.inr msg ← return s | skip,
      if msg =
        (format!("set_basic_attribute tactic failed, '{attr_name}' " ++
          "is not a basic attribute")).to_string
      then do
        user_attr_const ← (get_user_attribute_name attr_name >>= mk_const),
        tac ← eval_pexpr (tactic unit)
        ``(user_attribute.get_param_untyped %%user_attr_const %%src >>=
          λ x, user_attribute.set_untyped %%user_attr_const %%tgt x %%p %%prio),
        tac
      else fail msg

open expr
/-- Auxilliary function for `additive_test`. The bool argument *only* matters when applied
to exactly a constant. -/
meta def additive_test_aux (f : name → option name) (ignore : name_map $ list ℕ) :
  bool → expr → bool
| b (var n)                := tt
| b (sort l)               := tt
| b (const n ls)           := b || (f n).is_some
| b (mvar n m t)           := tt
| b (local_const n m bi t) := tt
| b (app e f)              := additive_test_aux tt e &&
  -- this might be inefficient.
  -- If it becomes a performance problem: we can give this info for the recursive call to `e`.
    match ignore.find e.get_app_fn.const_name with
    | some l := if e.get_app_num_args + 1 ∈ l then tt else additive_test_aux ff f
    | none   := additive_test_aux ff f
    end
| b (lam n bi e t)         := additive_test_aux ff t
| b (pi n bi e t)          := additive_test_aux ff t
| b (elet n g e f)         := additive_test_aux ff e && additive_test_aux ff f
| b (macro d args)         := tt

/--
`additive_test f replace_all ignore e` tests whether the expression `e` contains no constant
`nm` that is not applied to any arguments, and such that `f nm = none`.
This is used in `@[to_additive]` for deciding which subexpressions to transform: we only transform
constants if `additive_test` applied to their first argument returns `tt`.
This means we will replace expression applied to e.g. `α` or `α × β`, but not when applied to
e.g. `ℕ` or `ℝ × α`.
`f` is the dictionary of declarations that are in the `to_additive` dictionary.
We ignore all arguments specified in the `name_map` `ignore`.
If `replace_all` is `tt` the test always return `tt`.
-/
meta def additive_test (f : name → option name) (replace_all : bool) (ignore : name_map $ list ℕ)
  (e : expr) : bool :=
if replace_all then tt else additive_test_aux f ignore ff e

/-- transform the declaration `src` and all declarations `pre._proof_i` occurring in `src`
using the dictionary `f`.
`replace_all`, `trace`, `ignore` and `reorder` are configuration options.
`pre` is the declaration that got the `@[to_additive]` attribute and `tgt_pre` is the target of this
declaration. -/
meta def transform_decl_with_prefix_fun_aux (f : name → option name)
  (replace_all trace : bool) (relevant : name_map ℕ) (ignore reorder : name_map $ list ℕ)
  (pre tgt_pre : name) : name → command :=
λ src,
do
  -- if this declaration is not `pre` or an internal declaration, we do nothing.
  tt ← return (src = pre ∨ src.is_internal : bool) |
    if (f src).is_some then skip else fail!("@[to_additive] failed.
The declaration {pre} depends on the declaration {src} which is in the namespace {pre}, but " ++
"does not have the `@[to_additive]` attribute. This is not supported. Workaround: move {src} to " ++
"a different namespace."),
  env ← get_env,
  -- we find the additive name of `src`
  let tgt := src.map_prefix (λ n, if n = pre then some tgt_pre else none),
  -- we skip if we already transformed this declaration before
  ff ← return $ env.contains tgt | skip,
  decl ← get_decl src,
  -- we first transform all the declarations of the form `pre._proof_i`
  (decl.type.list_names_with_prefix pre).mfold () (λ n _, transform_decl_with_prefix_fun_aux n),
  (decl.value.list_names_with_prefix pre).mfold () (λ n _, transform_decl_with_prefix_fun_aux n),
  -- we transform `decl` using `f` and the configuration options.
  let decl :=
    decl.update_with_fun env (name.map_prefix f) (additive_test f replace_all ignore)
      relevant reorder tgt,
  -- o ← get_options, set_options $ o.set_bool `pp.all tt, -- print with pp.all (for debugging)
  pp_decl ← pp decl,
  when trace $ trace!"[to_additive] > generating\n{pp_decl}",
  decorate_error (format!"@[to_additive] failed. Type mismatch in additive declaration.
For help, see the docstring of `to_additive.attr`, section `Troubleshooting`.
Failed to add declaration\n{pp_decl}

Nested error message:\n").to_string $ do
  { if env.is_protected src then add_protected_decl decl else add_decl decl,
    -- we test that the declaration value type-checks, so that we get the decorated error message
    -- without this line, the type-checking might fail outside the `decorate_error`.
    decorate_error "proof doesn't type-check. " $ type_check decl.value }

/--
Make a new copy of a declaration,
replacing fragments of the names of identifiers in the type and the body using the function `f`.
This is used to implement `@[to_additive]`.
-/
meta def transform_decl_with_prefix_fun (f : name → option name) (replace_all trace : bool)
  (relevant : name_map ℕ) (ignore reorder : name_map $ list ℕ) (src tgt : name) (attrs : list name)
  : command :=
do -- In order to ensure that attributes are copied correctly we must transform declarations and
   -- attributes in the right order:
   -- first generate the transformed main declaration
   transform_decl_with_prefix_fun_aux f replace_all trace relevant ignore reorder src tgt src,
   ls ← get_eqn_lemmas_for tt src,
   -- now transform all of the equational lemmas
   ls.mmap' $
    transform_decl_with_prefix_fun_aux f replace_all trace relevant ignore reorder src tgt,
   -- copy attributes for the equational lemmas so that they know if they are refl lemmas
   ls.mmap' (λ src_eqn, do
    let tgt_eqn := src_eqn.map_prefix (λ n, if n = src then some tgt else none),
    attrs.mmap' (λ n, copy_attribute' n src_eqn tgt_eqn)),
   -- set the transformed equation lemmas as equation lemmas for the new declaration
   ls.mmap' (λ src_eqn, do
    e ← get_env,
    let tgt_eqn := src_eqn.map_prefix (λ n, if n = src then some tgt else none),
    set_env (e.add_eqn_lemma tgt_eqn)),
   -- copy attributes for the main declaration, this needs the equational lemmas to exist already
   attrs.mmap' (λ n, copy_attribute' n src tgt)

/--
Make a new copy of a declaration, replacing fragments of the names of identifiers in the type and
the body using the dictionary `dict`.
This is used to implement `@[to_additive]`.
-/
meta def transform_decl_with_prefix_dict (dict : name_map name) (replace_all trace : bool)
  (relevant : name_map ℕ) (ignore reorder : name_map $ list ℕ) (src tgt : name) (attrs : list name)
  : command :=
transform_decl_with_prefix_fun dict.find replace_all trace relevant ignore reorder src tgt attrs

end tactic


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.ext
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.shapes.binary_products
import category_theory.limits.preserves.shapes.biproducts
import category_theory.limits.preserves.shapes.products
import category_theory.preadditive.basic
import tactic.abel

/-!
# Basic facts about biproducts in preadditive categories.

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

In (or between) preadditive categories,

* Any biproduct satisfies the equality
  `total : ∑ j : J, biproduct.π f j ≫ biproduct.ι f j = 𝟙 (⨁ f)`,
  or, in the binary case, `total : fst ≫ inl + snd ≫ inr = 𝟙 X`.

* Any (binary) `product` or (binary) `coproduct` is a (binary) `biproduct`.

* In any category (with zero morphisms), if `biprod.map f g` is an isomorphism,
  then both `f` and `g` are isomorphisms.

* If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
  so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
  via Gaussian elimination.

* As a corollary of the previous two facts,
  if we have an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  we can construct an isomorphism `X₂ ≅ Y₂`.

* If `f : W ⊞ X ⟶ Y ⊞ Z` is an isomorphism, either `𝟙 W = 0`,
  or at least one of the component maps `W ⟶ Y` and `W ⟶ Z` is nonzero.

* If `f : ⨁ S ⟶ ⨁ T` is an isomorphism,
  then every column (corresponding to a nonzero summand in the domain)
  has some nonzero matrix entry.

* A functor preserves a biproduct if and only if it preserves
  the corresponding product if and only if it preserves the corresponding coproduct.
-/

open category_theory
open category_theory.preadditive
open category_theory.limits
open category_theory.functor
open category_theory.preadditive

open_locale classical
open_locale big_operators

universes v v' u u'

noncomputable theory

namespace category_theory

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

namespace limits

variables {J : Type} [fintype J]

/--
In a preadditive category, we can construct a biproduct for `f : J → C` from
any bicone `b` for `f` satisfying `total : ∑ j : J, b.π j ≫ b.ι j = 𝟙 b.X`.

(That is, such a bicone is a limit cone and a colimit cocone.)
-/
def is_bilimit_of_total {f : J → C} (b : bicone f) (total : ∑ j : J, b.π j ≫ b.ι j = 𝟙 b.X) :
  b.is_bilimit :=
{ is_limit :=
  { lift := λ s, ∑ (j : J), s.π.app ⟨j⟩ ≫ b.ι j,
    uniq' := λ s m h,
    begin
      erw [←category.comp_id m, ←total, comp_sum],
      apply finset.sum_congr rfl,
      intros j m,
      erw [reassoc_of (h ⟨j⟩)],
    end,
    fac' := λ s j,
    begin
      cases j,
      simp only [sum_comp, category.assoc, bicone.to_cone_π_app, b.ι_π, comp_dite],
      -- See note [dsimp, simp].
      dsimp, simp,
    end },
  is_colimit :=
  { desc := λ s, ∑ (j : J), b.π j ≫ s.ι.app ⟨j⟩,
    uniq' := λ s m h,
    begin
      erw [←category.id_comp m, ←total, sum_comp],
            apply finset.sum_congr rfl,
      intros j m,
      erw [category.assoc, h ⟨j⟩],
    end,
    fac' := λ s j,
    begin
      cases j,
      simp only [comp_sum, ←category.assoc, bicone.to_cocone_ι_app, b.ι_π, dite_comp],
      dsimp, simp,
    end } }

lemma is_bilimit.total {f : J → C} {b : bicone f} (i : b.is_bilimit) :
  ∑ j : J, b.π j ≫ b.ι j = 𝟙 b.X :=
i.is_limit.hom_ext (λ j, by { cases j, simp [sum_comp, b.ι_π, comp_dite] })

/--
In a preadditive category, we can construct a biproduct for `f : J → C` from
any bicone `b` for `f` satisfying `total : ∑ j : J, b.π j ≫ b.ι j = 𝟙 b.X`.

(That is, such a bicone is a limit cone and a colimit cocone.)
-/
lemma has_biproduct_of_total {f : J → C} (b : bicone f) (total : ∑ j : J, b.π j ≫ b.ι j = 𝟙 b.X) :
  has_biproduct f :=
has_biproduct.mk
{ bicone := b,
  is_bilimit := is_bilimit_of_total b total }

/-- In a preadditive category, any finite bicone which is a limit cone is in fact a bilimit
    bicone. -/
def is_bilimit_of_is_limit {f : J → C} (t : bicone f) (ht : is_limit t.to_cone) : t.is_bilimit :=
is_bilimit_of_total _ $ ht.hom_ext $
  λ j, by { cases j, simp [sum_comp, t.ι_π, dite_comp, comp_dite] }

/-- We can turn any limit cone over a pair into a bilimit bicone. -/
def bicone_is_bilimit_of_limit_cone_of_is_limit {f : J → C} {t : cone (discrete.functor f)}
  (ht : is_limit t) : (bicone.of_limit_cone ht).is_bilimit :=
is_bilimit_of_is_limit _ $
  is_limit.of_iso_limit ht $ cones.ext (iso.refl _) (by { rintro ⟨j⟩, tidy })

/-- In a preadditive category, if the product over `f : J → C` exists,
    then the biproduct over `f` exists. -/
lemma has_biproduct.of_has_product {J : Type} [finite J] (f : J → C) [has_product f] :
  has_biproduct f :=
by casesI nonempty_fintype J; exact
has_biproduct.mk
{ bicone := _,
  is_bilimit := bicone_is_bilimit_of_limit_cone_of_is_limit (limit.is_limit _) }

/-- In a preadditive category, any finite bicone which is a colimit cocone is in fact a bilimit
    bicone. -/
def is_bilimit_of_is_colimit {f : J → C} (t : bicone f) (ht : is_colimit t.to_cocone) :
  t.is_bilimit :=
is_bilimit_of_total _ $ ht.hom_ext $ λ j, begin
  cases j,
  simp_rw [bicone.to_cocone_ι_app, comp_sum, ← category.assoc, t.ι_π, dite_comp],
  tidy
end

/-- We can turn any limit cone over a pair into a bilimit bicone. -/
def bicone_is_bilimit_of_colimit_cocone_of_is_colimit {f : J → C} {t : cocone (discrete.functor f)}
  (ht : is_colimit t) : (bicone.of_colimit_cocone ht).is_bilimit :=
is_bilimit_of_is_colimit _ $
  is_colimit.of_iso_colimit ht $ cocones.ext (iso.refl _) (by { rintro ⟨j⟩, tidy })

/-- In a preadditive category, if the coproduct over `f : J → C` exists,
    then the biproduct over `f` exists. -/
lemma has_biproduct.of_has_coproduct {J : Type} [finite J] (f : J → C) [has_coproduct f] :
  has_biproduct f :=
by casesI nonempty_fintype J; exact
has_biproduct.mk
{ bicone := _,
  is_bilimit := bicone_is_bilimit_of_colimit_cocone_of_is_colimit (colimit.is_colimit _) }

/-- A preadditive category with finite products has finite biproducts. -/
lemma has_finite_biproducts.of_has_finite_products [has_finite_products C] :
  has_finite_biproducts C :=
⟨λ n, { has_biproduct := λ F, has_biproduct.of_has_product _ }⟩

/-- A preadditive category with finite coproducts has finite biproducts. -/
lemma has_finite_biproducts.of_has_finite_coproducts [has_finite_coproducts C] :
  has_finite_biproducts C :=
⟨λ n, { has_biproduct := λ F, has_biproduct.of_has_coproduct _ }⟩

section
variables {f : J → C} [has_biproduct f]

/--
In any preadditive category, any biproduct satsifies
`∑ j : J, biproduct.π f j ≫ biproduct.ι f j = 𝟙 (⨁ f)`
-/
@[simp] lemma biproduct.total : ∑ j : J, biproduct.π f j ≫ biproduct.ι f j = 𝟙 (⨁ f) :=
is_bilimit.total (biproduct.is_bilimit _)

lemma biproduct.lift_eq {T : C} {g : Π j, T ⟶ f j} :
  biproduct.lift g = ∑ j, g j ≫ biproduct.ι f j :=
begin
  ext j,
  simp only [sum_comp, biproduct.ι_π, comp_dite, biproduct.lift_π, category.assoc, comp_zero,
    finset.sum_dite_eq', finset.mem_univ, eq_to_hom_refl, category.comp_id, if_true],
end

lemma biproduct.desc_eq {T : C} {g : Π j, f j ⟶ T} :
  biproduct.desc g = ∑ j, biproduct.π f j ≫ g j :=
begin
  ext j,
  simp [comp_sum, biproduct.ι_π_assoc, dite_comp],
end

@[simp, reassoc] lemma biproduct.lift_desc {T U : C} {g : Π j, T ⟶ f j} {h : Π j, f j ⟶ U} :
  biproduct.lift g ≫ biproduct.desc h = ∑ j : J, g j ≫ h j :=
by simp [biproduct.lift_eq, biproduct.desc_eq, comp_sum, sum_comp, biproduct.ι_π_assoc,
  comp_dite, dite_comp]

lemma biproduct.map_eq [has_finite_biproducts C] {f g : J → C} {h : Π j, f j ⟶ g j} :
  biproduct.map h = ∑ j : J, biproduct.π f j ≫ h j ≫ biproduct.ι g j :=
begin
  ext,
  simp [biproduct.ι_π, biproduct.ι_π_assoc, comp_sum, sum_comp, comp_dite, dite_comp],
end

@[simp, reassoc]
lemma biproduct.matrix_desc
  {K : Type} [fintype K] [has_finite_biproducts C]
  {f : J → C} {g : K → C} (m : Π j k, f j ⟶ g k) {P} (x : Π k, g k ⟶ P) :
  biproduct.matrix m ≫ biproduct.desc x = biproduct.desc (λ j, ∑ k, m j k ≫ x k) :=
by { ext, simp, }

@[simp, reassoc]
lemma biproduct.lift_matrix
  {K : Type} [fintype K] [has_finite_biproducts C]
  {f : J → C} {g : K → C} {P} (x : Π j, P ⟶ f j) (m : Π j k, f j ⟶ g k)  :
  biproduct.lift x ≫ biproduct.matrix m = biproduct.lift (λ k, ∑ j, x j ≫ m j k) :=
by { ext, simp, }

@[reassoc]
lemma biproduct.matrix_map
  {K : Type} [fintype K] [has_finite_biproducts C]
  {f : J → C} {g : K → C} {h : K → C} (m : Π j k, f j ⟶ g k) (n : Π k, g k ⟶ h k) :
  biproduct.matrix m ≫ biproduct.map n = biproduct.matrix (λ j k, m j k ≫ n k) :=
by { ext, simp, }

@[reassoc]
lemma biproduct.map_matrix
  {K : Type} [fintype K] [has_finite_biproducts C]
  {f : J → C} {g : J → C} {h : K → C} (m : Π k, f k ⟶ g k) (n : Π j k, g j ⟶ h k) :
  biproduct.map m ≫ biproduct.matrix n = biproduct.matrix (λ j k, m j ≫ n j k) :=
by { ext, simp, }

end

/-- Reindex a categorical biproduct via an equivalence of the index types. -/
@[simps]
def biproduct.reindex {β γ : Type} [fintype β] [decidable_eq β] [decidable_eq γ]
  (ε : β ≃ γ) (f : γ → C) [has_biproduct f] [has_biproduct (f ∘ ε)] : (⨁ (f ∘ ε)) ≅ (⨁ f) :=
{ hom := biproduct.desc (λ b, biproduct.ι f (ε b)),
  inv := biproduct.lift (λ b, biproduct.π f (ε b)),
  hom_inv_id' := by { ext b b', by_cases h : b = b', { subst h, simp, }, { simp [h], }, },
  inv_hom_id' := begin
    ext g g',
    by_cases h : g = g';
    simp [preadditive.sum_comp, preadditive.comp_sum, biproduct.ι_π, biproduct.ι_π_assoc, comp_dite,
      equiv.apply_eq_iff_eq_symm_apply, finset.sum_dite_eq' finset.univ (ε.symm g') _, h],
  end, }

/--
In a preadditive category, we can construct a binary biproduct for `X Y : C` from
any binary bicone `b` satisfying `total : b.fst ≫ b.inl + b.snd ≫ b.inr = 𝟙 b.X`.

(That is, such a bicone is a limit cone and a colimit cocone.)
-/
def is_binary_bilimit_of_total {X Y : C} (b : binary_bicone X Y)
  (total : b.fst ≫ b.inl + b.snd ≫ b.inr = 𝟙 b.X) : b.is_bilimit :=
{ is_limit :=
  { lift := λ s, binary_fan.fst s ≫ b.inl +
      binary_fan.snd s ≫ b.inr,
    uniq' := λ s m h, by erw [←category.comp_id m, ←total,
      comp_add, reassoc_of (h ⟨walking_pair.left⟩), reassoc_of (h ⟨walking_pair.right⟩)],
    fac' := λ s j, by rcases j with ⟨⟨⟩⟩; simp, },
  is_colimit :=
  { desc := λ s, b.fst ≫ binary_cofan.inl s +
      b.snd ≫ binary_cofan.inr s,
    uniq' := λ s m h, by erw [←category.id_comp m, ←total,
      add_comp, category.assoc, category.assoc, h ⟨walking_pair.left⟩, h ⟨walking_pair.right⟩],
    fac' := λ s j, by rcases j with ⟨⟨⟩⟩; simp, } }

lemma is_bilimit.binary_total {X Y : C} {b : binary_bicone X Y} (i : b.is_bilimit) :
  b.fst ≫ b.inl + b.snd ≫ b.inr = 𝟙 b.X :=
i.is_limit.hom_ext (λ j, by { rcases j with ⟨⟨⟩⟩; simp, })

/--
In a preadditive category, we can construct a binary biproduct for `X Y : C` from
any binary bicone `b` satisfying `total : b.fst ≫ b.inl + b.snd ≫ b.inr = 𝟙 b.X`.

(That is, such a bicone is a limit cone and a colimit cocone.)
-/
lemma has_binary_biproduct_of_total {X Y : C} (b : binary_bicone X Y)
  (total : b.fst ≫ b.inl + b.snd ≫ b.inr = 𝟙 b.X) : has_binary_biproduct X Y :=
has_binary_biproduct.mk
{ bicone := b,
  is_bilimit := is_binary_bilimit_of_total b total }

/-- We can turn any limit cone over a pair into a bicone. -/
@[simps]
def binary_bicone.of_limit_cone {X Y : C} {t : cone (pair X Y)} (ht : is_limit t) :
  binary_bicone X Y :=
{ X := t.X,
  fst := t.π.app ⟨walking_pair.left⟩,
  snd := t.π.app ⟨walking_pair.right⟩,
  inl := ht.lift (binary_fan.mk (𝟙 X) 0),
  inr := ht.lift (binary_fan.mk 0 (𝟙 Y)) }

lemma inl_of_is_limit {X Y : C} {t : binary_bicone X Y} (ht : is_limit t.to_cone) :
  t.inl = ht.lift (binary_fan.mk (𝟙 X) 0) :=
by apply ht.uniq (binary_fan.mk (𝟙 X) 0); rintro ⟨⟨⟩⟩; dsimp; simp

lemma inr_of_is_limit {X Y : C} {t : binary_bicone X Y} (ht : is_limit t.to_cone) :
  t.inr = ht.lift (binary_fan.mk 0 (𝟙 Y)) :=
by apply ht.uniq (binary_fan.mk 0 (𝟙 Y)); rintro ⟨⟨⟩⟩; dsimp; simp

/-- In a preadditive category, any binary bicone which is a limit cone is in fact a bilimit
    bicone. -/
def is_binary_bilimit_of_is_limit {X Y : C} (t : binary_bicone X Y) (ht : is_limit t.to_cone) :
  t.is_bilimit :=
is_binary_bilimit_of_total _ (by refine binary_fan.is_limit.hom_ext ht _ _; simp)

/-- We can turn any limit cone over a pair into a bilimit bicone. -/
def binary_bicone_is_bilimit_of_limit_cone_of_is_limit {X Y : C} {t : cone (pair X Y)}
  (ht : is_limit t) : (binary_bicone.of_limit_cone ht).is_bilimit :=
is_binary_bilimit_of_total _ $ binary_fan.is_limit.hom_ext ht (by simp) (by simp)

/-- In a preadditive category, if the product of `X` and `Y` exists, then the
    binary biproduct of `X` and `Y` exists. -/
lemma has_binary_biproduct.of_has_binary_product (X Y : C) [has_binary_product X Y] :
  has_binary_biproduct X Y :=
has_binary_biproduct.mk
{ bicone := _,
  is_bilimit := binary_bicone_is_bilimit_of_limit_cone_of_is_limit (limit.is_limit _) }

/-- In a preadditive category, if all binary products exist, then all binary biproducts exist. -/
lemma has_binary_biproducts.of_has_binary_products [has_binary_products C] :
  has_binary_biproducts C :=
{ has_binary_biproduct := λ X Y, has_binary_biproduct.of_has_binary_product X Y, }

/-- We can turn any colimit cocone over a pair into a bicone. -/
@[simps]
def binary_bicone.of_colimit_cocone {X Y : C} {t : cocone (pair X Y)} (ht : is_colimit t) :
  binary_bicone X Y :=
{ X := t.X,
  fst := ht.desc (binary_cofan.mk (𝟙 X) 0),
  snd := ht.desc (binary_cofan.mk 0 (𝟙 Y)),
  inl := t.ι.app ⟨walking_pair.left⟩,
  inr := t.ι.app ⟨walking_pair.right⟩ }

lemma fst_of_is_colimit {X Y : C} {t : binary_bicone X Y} (ht : is_colimit t.to_cocone) :
  t.fst = ht.desc (binary_cofan.mk (𝟙 X) 0) :=
begin
  apply ht.uniq (binary_cofan.mk (𝟙 X) 0),
  rintro ⟨⟨⟩⟩; dsimp; simp
end

lemma snd_of_is_colimit {X Y : C} {t : binary_bicone X Y} (ht : is_colimit t.to_cocone) :
  t.snd = ht.desc (binary_cofan.mk 0 (𝟙 Y)) :=
begin
  apply ht.uniq (binary_cofan.mk 0 (𝟙 Y)),
  rintro ⟨⟨⟩⟩; dsimp; simp
end

/-- In a preadditive category, any binary bicone which is a colimit cocone is in fact a
    bilimit bicone. -/
def is_binary_bilimit_of_is_colimit {X Y : C} (t : binary_bicone X Y)
  (ht : is_colimit t.to_cocone) : t.is_bilimit :=
is_binary_bilimit_of_total _
begin
  refine binary_cofan.is_colimit.hom_ext ht _ _; simp,
  { rw [category.comp_id t.inl] },
  { rw [category.comp_id t.inr] }
end

/-- We can turn any colimit cocone over a pair into a bilimit bicone. -/
def binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit {X Y : C} {t : cocone (pair X Y)}
  (ht : is_colimit t) : (binary_bicone.of_colimit_cocone ht).is_bilimit :=
is_binary_bilimit_of_is_colimit (binary_bicone.of_colimit_cocone ht) $
  is_colimit.of_iso_colimit ht $ cocones.ext (iso.refl _) $ λ j, by { rcases j with ⟨⟨⟩⟩, tidy }

/-- In a preadditive category, if the coproduct of `X` and `Y` exists, then the
    binary biproduct of `X` and `Y` exists. -/
lemma has_binary_biproduct.of_has_binary_coproduct (X Y : C) [has_binary_coproduct X Y] :
  has_binary_biproduct X Y :=
has_binary_biproduct.mk
{ bicone := _,
  is_bilimit := binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit (colimit.is_colimit _) }

/-- In a preadditive category, if all binary coproducts exist, then all binary biproducts exist. -/
lemma has_binary_biproducts.of_has_binary_coproducts [has_binary_coproducts C] :
  has_binary_biproducts C :=
{ has_binary_biproduct := λ X Y, has_binary_biproduct.of_has_binary_coproduct X Y, }

section
variables {X Y : C} [has_binary_biproduct X Y]

/--
In any preadditive category, any binary biproduct satsifies
`biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = 𝟙 (X ⊞ Y)`.
-/
@[simp] lemma biprod.total : biprod.fst ≫ biprod.inl + biprod.snd ≫ biprod.inr = 𝟙 (X ⊞ Y) :=
begin
  ext; simp [add_comp],
end

lemma biprod.lift_eq {T : C} {f : T ⟶ X} {g : T ⟶ Y} :
  biprod.lift f g = f ≫ biprod.inl + g ≫ biprod.inr :=
begin
  ext; simp [add_comp],
end

@[simp, reassoc] lemma biprod.lift_desc {T U : C} {f : T ⟶ X} {g : T ⟶ Y} {h : X ⟶ U} {i : Y ⟶ U} :
  biprod.lift f g ≫ biprod.desc h i = f ≫ h + g ≫ i :=
by simp [biprod.lift_eq, biprod.desc_eq]

lemma biprod.map_eq [has_binary_biproducts C] {W X Y Z : C} {f : W ⟶ Y} {g : X ⟶ Z} :
  biprod.map f g = biprod.fst ≫ f ≫ biprod.inl + biprod.snd ≫ g ≫ biprod.inr :=
by apply biprod.hom_ext; apply biprod.hom_ext'; simp

/--
Every split mono `f` with a cokernel induces a binary bicone with `f` as its `inl` and
the cokernel map as its `snd`.
We will show in `is_bilimit_binary_bicone_of_split_mono_of_cokernel` that this binary bicone is in
fact already a biproduct. -/
@[simps]
def binary_bicone_of_is_split_mono_of_cokernel {X Y : C} {f : X ⟶ Y} [is_split_mono f]
  {c : cokernel_cofork f} (i : is_colimit c) : binary_bicone X c.X :=
{ X := Y,
  fst := retraction f,
  snd := c.π,
  inl := f,
  inr :=
    let c' : cokernel_cofork (𝟙 Y - (𝟙 Y - retraction f ≫ f)) :=
      cokernel_cofork.of_π (cofork.π c) (by simp) in
    let i' : is_colimit c' := is_cokernel_epi_comp i (retraction f) (by simp) in
    let i'' := is_colimit_cofork_of_cokernel_cofork i' in
    (split_epi_of_idempotent_of_is_colimit_cofork C (by simp) i'').section_,
  inl_fst' := by simp,
  inl_snd' := by simp,
  inr_fst' :=
  begin
    dsimp only,
    rw [split_epi_of_idempotent_of_is_colimit_cofork_section_,
      is_colimit_cofork_of_cokernel_cofork_desc, is_cokernel_epi_comp_desc],
    dsimp only [cokernel_cofork_of_cofork_of_π],
    letI := epi_of_is_colimit_cofork i,
    apply zero_of_epi_comp c.π,
    simp only [sub_comp, comp_sub, category.comp_id, category.assoc, is_split_mono.id, sub_self,
      cofork.is_colimit.π_desc_assoc, cokernel_cofork.π_of_π, is_split_mono.id_assoc],
    apply sub_eq_zero_of_eq,
    apply category.id_comp
  end,
  inr_snd' := by apply split_epi.id }

/-- The bicone constructed in `binary_bicone_of_split_mono_of_cokernel` is a bilimit.
This is a version of the splitting lemma that holds in all preadditive categories. -/
def is_bilimit_binary_bicone_of_is_split_mono_of_cokernel {X Y : C} {f : X ⟶ Y} [is_split_mono f]
  {c : cokernel_cofork f} (i : is_colimit c) :
  (binary_bicone_of_is_split_mono_of_cokernel i).is_bilimit :=
is_binary_bilimit_of_total _
begin
  simp only [binary_bicone_of_is_split_mono_of_cokernel_fst,
    binary_bicone_of_is_split_mono_of_cokernel_inr, binary_bicone_of_is_split_mono_of_cokernel_snd,
    split_epi_of_idempotent_of_is_colimit_cofork_section_],
  dsimp only [binary_bicone_of_is_split_mono_of_cokernel_X],
  rw [is_colimit_cofork_of_cokernel_cofork_desc, is_cokernel_epi_comp_desc],
  simp only [binary_bicone_of_is_split_mono_of_cokernel_inl, cofork.is_colimit.π_desc,
    cokernel_cofork_of_cofork_π, cofork.π_of_π, add_sub_cancel'_right]
end

/-- If `b` is a binary bicone such that `b.inl` is a kernel of `b.snd`, then `b` is a bilimit
    bicone. -/
def binary_bicone.is_bilimit_of_kernel_inl {X Y : C} (b : binary_bicone X Y)
  (hb : is_limit b.snd_kernel_fork) : b.is_bilimit :=
is_binary_bilimit_of_is_limit _ $ binary_fan.is_limit.mk _
  (λ T f g, f ≫ b.inl + g ≫ b.inr) (λ T f g, by simp) (λ T f g, by simp) $ λ T f g m h₁ h₂,
  begin
    have h₁' : (m - (f ≫ b.inl + g ≫ b.inr)) ≫ b.fst = 0 := by simpa using sub_eq_zero.2 h₁,
    have h₂' : (m - (f ≫ b.inl + g ≫ b.inr)) ≫ b.snd = 0 := by simpa using sub_eq_zero.2 h₂,
    obtain ⟨q : T ⟶ X, hq : q ≫ b.inl = m - (f ≫ b.inl + g ≫ b.inr)⟩ :=
      kernel_fork.is_limit.lift' hb _ h₂',
    rw [←sub_eq_zero, ←hq, ←category.comp_id q, ←b.inl_fst, ←category.assoc, hq, h₁', zero_comp]
  end

/-- If `b` is a binary bicone such that `b.inr` is a kernel of `b.fst`, then `b` is a bilimit
    bicone. -/
def binary_bicone.is_bilimit_of_kernel_inr {X Y : C} (b : binary_bicone X Y)
  (hb : is_limit b.fst_kernel_fork) : b.is_bilimit :=
is_binary_bilimit_of_is_limit _ $ binary_fan.is_limit.mk _
  (λ T f g, f ≫ b.inl + g ≫ b.inr) (λ t f g, by simp) (λ t f g, by simp) $ λ T f g m h₁ h₂,
  begin
    have h₁' : (m - (f ≫ b.inl + g ≫ b.inr)) ≫ b.fst = 0 := by simpa using sub_eq_zero.2 h₁,
    have h₂' : (m - (f ≫ b.inl + g ≫ b.inr)) ≫ b.snd = 0 := by simpa using sub_eq_zero.2 h₂,
    obtain ⟨q : T ⟶ Y, hq : q ≫ b.inr = m - (f ≫ b.inl + g ≫ b.inr)⟩ :=
      kernel_fork.is_limit.lift' hb _ h₁',
    rw [←sub_eq_zero, ←hq, ←category.comp_id q, ←b.inr_snd, ←category.assoc, hq, h₂', zero_comp]
  end

/-- If `b` is a binary bicone such that `b.fst` is a cokernel of `b.inr`, then `b` is a bilimit
    bicone. -/
def binary_bicone.is_bilimit_of_cokernel_fst {X Y : C} (b : binary_bicone X Y)
  (hb : is_colimit b.inr_cokernel_cofork) : b.is_bilimit :=
is_binary_bilimit_of_is_colimit _ $ binary_cofan.is_colimit.mk _
  (λ T f g, b.fst ≫ f + b.snd ≫ g) (λ T f g, by simp) (λ T f g, by simp) $ λ T f g m h₁ h₂,
  begin
    have h₁' : b.inl ≫ (m - (b.fst ≫ f + b.snd ≫ g)) = 0 := by simpa using sub_eq_zero.2 h₁,
    have h₂' : b.inr ≫ (m - (b.fst ≫ f + b.snd ≫ g)) = 0 := by simpa using sub_eq_zero.2 h₂,
    obtain ⟨q : X ⟶ T, hq : b.fst ≫ q = m - (b.fst ≫ f + b.snd ≫ g)⟩ :=
      cokernel_cofork.is_colimit.desc' hb _ h₂',
    rw [←sub_eq_zero, ←hq, ←category.id_comp q, ←b.inl_fst, category.assoc, hq, h₁', comp_zero]
  end

/-- If `b` is a binary bicone such that `b.snd` is a cokernel of `b.inl`, then `b` is a bilimit
    bicone. -/
def binary_bicone.is_bilimit_of_cokernel_snd {X Y : C} (b : binary_bicone X Y)
  (hb : is_colimit b.inl_cokernel_cofork) : b.is_bilimit :=
is_binary_bilimit_of_is_colimit _ $ binary_cofan.is_colimit.mk _
  (λ T f g, b.fst ≫ f + b.snd ≫ g) (λ T f g, by simp) (λ T f g, by simp) $ λ T f g m h₁ h₂,
  begin
    have h₁' : b.inl ≫ (m - (b.fst ≫ f + b.snd ≫ g)) = 0 := by simpa using sub_eq_zero.2 h₁,
    have h₂' : b.inr ≫ (m - (b.fst ≫ f + b.snd ≫ g)) = 0 := by simpa using sub_eq_zero.2 h₂,
    obtain ⟨q : Y ⟶ T, hq : b.snd ≫ q = m - (b.fst ≫ f + b.snd ≫ g)⟩ :=
      cokernel_cofork.is_colimit.desc' hb _ h₁',
    rw [←sub_eq_zero, ←hq, ←category.id_comp q, ←b.inr_snd, category.assoc, hq, h₂', comp_zero]
  end

/--
Every split epi `f` with a kernel induces a binary bicone with `f` as its `snd` and
the kernel map as its `inl`.
We will show in `binary_bicone_of_is_split_mono_of_cokernel` that this binary bicone is in fact
already a biproduct. -/
@[simps]
def binary_bicone_of_is_split_epi_of_kernel {X Y : C} {f : X ⟶ Y} [is_split_epi f]
  {c : kernel_fork f} (i : is_limit c) : binary_bicone c.X Y :=
{ X := X,
  fst :=
    let c' : kernel_fork (𝟙 X - (𝟙 X - f ≫ section_ f)) :=
      kernel_fork.of_ι (fork.ι c) (by simp) in
    let i' : is_limit c' := is_kernel_comp_mono i (section_ f) (by simp) in
    let i'' := is_limit_fork_of_kernel_fork i' in
    (split_mono_of_idempotent_of_is_limit_fork C (by simp) i'').retraction,
  snd := f,
  inl := c.ι,
  inr := section_ f,
  inl_fst' := by apply split_mono.id,
  inl_snd' := by simp,
  inr_fst' :=
  begin
    dsimp only,
    rw [split_mono_of_idempotent_of_is_limit_fork_retraction,
      is_limit_fork_of_kernel_fork_lift, is_kernel_comp_mono_lift],
    dsimp only [kernel_fork_of_fork_ι],
    letI := mono_of_is_limit_fork i,
    apply zero_of_comp_mono c.ι,
    simp only [comp_sub, category.comp_id, category.assoc, sub_self, fork.is_limit.lift_ι,
      fork.ι_of_ι, is_split_epi.id_assoc]
  end,
  inr_snd' := by simp }

/-- The bicone constructed in `binary_bicone_of_is_split_epi_of_kernel` is a bilimit.
This is a version of the splitting lemma that holds in all preadditive categories. -/
def is_bilimit_binary_bicone_of_is_split_epi_of_kernel {X Y : C} {f : X ⟶ Y} [is_split_epi f]
  {c : kernel_fork f} (i : is_limit c) :
  (binary_bicone_of_is_split_epi_of_kernel i).is_bilimit :=
binary_bicone.is_bilimit_of_kernel_inl _ $ i.of_iso_limit $ fork.ext (iso.refl _) (by simp)

end

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

/-- The existence of binary biproducts implies that there is at most one preadditive structure. -/
lemma biprod.add_eq_lift_id_desc [has_binary_biproduct X X] :
  f + g = biprod.lift (𝟙 X) (𝟙 X) ≫ biprod.desc f g :=
by simp

/-- The existence of binary biproducts implies that there is at most one preadditive structure. -/
lemma biprod.add_eq_lift_desc_id [has_binary_biproduct Y Y] :
  f + g = biprod.lift f g ≫ biprod.desc (𝟙 Y) (𝟙 Y) :=
by simp

end

end limits

open category_theory.limits

section
local attribute [ext] preadditive

/-- The existence of binary biproducts implies that there is at most one preadditive structure. -/
instance subsingleton_preadditive_of_has_binary_biproducts {C : Type u} [category.{v} C]
  [has_zero_morphisms C] [has_binary_biproducts C] : subsingleton (preadditive C) :=
subsingleton.intro $ λ a b,
begin
  ext X Y f g,
  have h₁ := @biprod.add_eq_lift_id_desc _ _ a _ _ f g
    (by convert (infer_instance : has_binary_biproduct X X)),
  have h₂ := @biprod.add_eq_lift_id_desc _ _ b _ _ f g
    (by convert (infer_instance : has_binary_biproduct X X)),
  refine h₁.trans (eq.trans _ h₂.symm),
  congr' 2;
  exact subsingleton.elim _ _
end
end

section
variables  [has_binary_biproducts.{v} C]

variables {X₁ X₂ Y₁ Y₂ : C}
variables (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂)

/--
The "matrix" morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` with specified components.
-/
def biprod.of_components : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂ :=
biprod.fst ≫ f₁₁ ≫ biprod.inl +
biprod.fst ≫ f₁₂ ≫ biprod.inr +
biprod.snd ≫ f₂₁ ≫ biprod.inl +
biprod.snd ≫ f₂₂ ≫ biprod.inr

@[simp]
lemma biprod.inl_of_components :
  biprod.inl ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
    f₁₁ ≫ biprod.inl + f₁₂ ≫ biprod.inr :=
by simp [biprod.of_components]

@[simp]
lemma biprod.inr_of_components :
  biprod.inr ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ =
    f₂₁ ≫ biprod.inl + f₂₂ ≫ biprod.inr :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_fst :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.fst =
    biprod.fst ≫ f₁₁ + biprod.snd ≫ f₂₁ :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_snd :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.snd =
    biprod.fst ≫ f₁₂ + biprod.snd ≫ f₂₂ :=
by simp [biprod.of_components]

@[simp]
lemma biprod.of_components_eq (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) :
  biprod.of_components (biprod.inl ≫ f ≫ biprod.fst) (biprod.inl ≫ f ≫ biprod.snd)
    (biprod.inr ≫ f ≫ biprod.fst) (biprod.inr ≫ f ≫ biprod.snd) = f :=
begin
  ext;
  simp only [category.comp_id, biprod.inr_fst, biprod.inr_snd, biprod.inl_snd, add_zero, zero_add,
    biprod.inl_of_components, biprod.inr_of_components, eq_self_iff_true, category.assoc, comp_zero,
    biprod.inl_fst, preadditive.add_comp],
end

@[simp]
lemma biprod.of_components_comp {X₁ X₂ Y₁ Y₂ Z₁ Z₂ : C}
  (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂)
  (g₁₁ : Y₁ ⟶ Z₁) (g₁₂ : Y₁ ⟶ Z₂) (g₂₁ : Y₂ ⟶ Z₁) (g₂₂ : Y₂ ⟶ Z₂) :
  biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.of_components g₁₁ g₁₂ g₂₁ g₂₂ =
    biprod.of_components
      (f₁₁ ≫ g₁₁ + f₁₂ ≫ g₂₁) (f₁₁ ≫ g₁₂ + f₁₂ ≫ g₂₂)
      (f₂₁ ≫ g₁₁ + f₂₂ ≫ g₂₁) (f₂₁ ≫ g₁₂ + f₂₂ ≫ g₂₂) :=
begin
  dsimp [biprod.of_components],
  apply biprod.hom_ext; apply biprod.hom_ext';
  simp only [add_comp, comp_add, add_comp_assoc, add_zero, zero_add,
    biprod.inl_fst, biprod.inl_snd, biprod.inr_fst, biprod.inr_snd,
    biprod.inl_fst_assoc, biprod.inl_snd_assoc, biprod.inr_fst_assoc, biprod.inr_snd_assoc,
    comp_zero, zero_comp,
    category.comp_id, category.assoc],
end

/--
The unipotent upper triangular matrix
```
(1 r)
(0 1)
```
as an isomorphism.
-/
@[simps]
def biprod.unipotent_upper {X₁ X₂ : C} (r : X₁ ⟶ X₂) : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂ :=
{ hom := biprod.of_components (𝟙 _) r 0 (𝟙 _),
  inv := biprod.of_components (𝟙 _) (-r) 0 (𝟙 _), }

/--
The unipotent lower triangular matrix
```
(1 0)
(r 1)
```
as an isomorphism.
-/
@[simps]
def biprod.unipotent_lower {X₁ X₂ : C} (r : X₂ ⟶ X₁) : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂ :=
{ hom := biprod.of_components (𝟙 _) 0 r (𝟙 _),
  inv := biprod.of_components (𝟙 _) 0 (-r) (𝟙 _), }

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.

(This is the version of `biprod.gaussian` written in terms of components.)
-/
def biprod.gaussian' [is_iso f₁₁] :
  Σ' (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) (g₂₂ : X₂ ⟶ Y₂),
    L.hom ≫ (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂) ≫ R.hom = biprod.map f₁₁ g₂₂ :=
⟨biprod.unipotent_lower (-(f₂₁ ≫ inv f₁₁)),
 biprod.unipotent_upper (-(inv f₁₁ ≫ f₁₂)),
 f₂₂ - f₂₁ ≫ (inv f₁₁) ≫ f₁₂,
 by ext; simp; abel⟩

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.
-/
def biprod.gaussian (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) [is_iso (biprod.inl ≫ f ≫ biprod.fst)] :
  Σ' (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) (g₂₂ : X₂ ⟶ Y₂),
    L.hom ≫ f ≫ R.hom = biprod.map (biprod.inl ≫ f ≫ biprod.fst) g₂₂ :=
begin
  let := biprod.gaussian'
    (biprod.inl ≫ f ≫ biprod.fst) (biprod.inl ≫ f ≫ biprod.snd)
    (biprod.inr ≫ f ≫ biprod.fst) (biprod.inr ≫ f ≫ biprod.snd),
  simpa [biprod.of_components_eq],
end

/--
If `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` via a two-by-two matrix whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim' [is_iso f₁₁] [is_iso (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂)] : X₂ ≅ Y₂ :=
begin
  obtain ⟨L, R, g, w⟩ := biprod.gaussian' f₁₁ f₁₂ f₂₁ f₂₂,
  letI : is_iso (biprod.map f₁₁ g) := by { rw ←w, apply_instance, },
  letI : is_iso g := (is_iso_right_of_is_iso_biprod_map f₁₁ g),
  exact as_iso g,
end

/--
If `f` is an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim (f : X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂) [is_iso (biprod.inl ≫ f.hom ≫ biprod.fst)] : X₂ ≅ Y₂ :=
begin
  letI : is_iso (biprod.of_components
       (biprod.inl ≫ f.hom ≫ biprod.fst)
       (biprod.inl ≫ f.hom ≫ biprod.snd)
       (biprod.inr ≫ f.hom ≫ biprod.fst)
       (biprod.inr ≫ f.hom ≫ biprod.snd)) :=
  by { simp only [biprod.of_components_eq], apply_instance, },
  exact biprod.iso_elim'
    (biprod.inl ≫ f.hom ≫ biprod.fst)
    (biprod.inl ≫ f.hom ≫ biprod.snd)
    (biprod.inr ≫ f.hom ≫ biprod.fst)
    (biprod.inr ≫ f.hom ≫ biprod.snd)
end

lemma biprod.column_nonzero_of_iso {W X Y Z : C}
  (f : W ⊞ X ⟶ Y ⊞ Z) [is_iso f] :
  𝟙 W = 0 ∨ biprod.inl ≫ f ≫ biprod.fst ≠ 0 ∨ biprod.inl ≫ f ≫ biprod.snd ≠ 0 :=
begin
  by_contra' h,
  rcases h with ⟨nz, a₁, a₂⟩,
  set x := biprod.inl ≫ f ≫ inv f ≫ biprod.fst,
  have h₁ : x = 𝟙 W, by simp [x],
  have h₀ : x = 0,
  { dsimp [x],
    rw [←category.id_comp (inv f), category.assoc, ←biprod.total],
    conv_lhs { slice 2 3, rw [comp_add], },
    simp only [category.assoc],
    rw [comp_add_assoc, add_comp],
    conv_lhs { congr, skip, slice 1 3, rw a₂, },
    simp only [zero_comp, add_zero],
    conv_lhs { slice 1 3, rw a₁, },
    simp only [zero_comp], },
  exact nz (h₁.symm.trans h₀),
end

end

lemma biproduct.column_nonzero_of_iso'
  {σ τ : Type} [finite τ]
  {S : σ → C} [has_biproduct S] {T : τ → C} [has_biproduct T]
  (s : σ) (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
  (∀ t : τ, biproduct.ι S s ≫ f ≫ biproduct.π T t = 0) → 𝟙 (S s) = 0 :=
begin
  casesI nonempty_fintype τ,
  intro z,
  set x := biproduct.ι S s ≫ f ≫ inv f ≫ biproduct.π S s,
  have h₁ : x = 𝟙 (S s), by simp [x],
  have h₀ : x = 0,
  { dsimp [x],
    rw [←category.id_comp (inv f), category.assoc, ←biproduct.total],
    simp only [comp_sum_assoc],
    conv_lhs { congr, apply_congr, skip, simp only [reassoc_of z], },
    simp, },
  exact h₁.symm.trans h₀,
end

/--
If `f : ⨁ S ⟶ ⨁ T` is an isomorphism, and `s` is a non-trivial summand of the source,
then there is some `t` in the target so that the `s, t` matrix entry of `f` is nonzero.
-/
def biproduct.column_nonzero_of_iso
  {σ τ : Type} [fintype τ]
  {S : σ → C} [has_biproduct S] {T : τ → C} [has_biproduct T]
  (s : σ) (nz : 𝟙 (S s) ≠ 0)
  (f : ⨁ S ⟶ ⨁ T) [is_iso f] :
  trunc (Σ' t : τ, biproduct.ι S s ≫ f ≫ biproduct.π T t ≠ 0) :=
begin
  classical,
  apply trunc_sigma_of_exists,
  have t := biproduct.column_nonzero_of_iso'.{v} s f,
  by_contradiction h,
  simp only [not_exists_not] at h,
  exact nz (t h)
end

section preadditive
variables {D : Type.{u'}} [category.{v'} D] [preadditive.{v'} D]
variables (F : C ⥤ D) [preserves_zero_morphisms F]

namespace limits

section fintype
variables {J : Type} [fintype J]

local attribute [tidy] tactic.discrete_cases

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_product_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_limit (discrete.functor f) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
  ((is_limit.postcompose_inv_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
    (is_bilimit_of_preserves F (bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
  cones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_product_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_products_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_limits_of_shape (discrete J) F :=
{ preserves_limit := λ f, preserves_limit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_product {f : J → C} [preserves_limit (discrete.functor f) F] :
  preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
      cones.ext (iso.refl _) (by tidy) }

/-- If the (product-like) biproduct comparison for `F` and `f` is a monomorphism, then `F`
    preserves the biproduct of `f`. For the converse, see `map_biproduct`. -/
def preserves_biproduct_of_mono_biproduct_comparison {f : J → C} [has_biproduct f]
  [has_biproduct (F.obj ∘ f)] [mono (biproduct_comparison F f)] : preserves_biproduct f F :=
begin
  have : pi_comparison F f = (F.map_iso (biproduct.iso_product f)).inv ≫
    biproduct_comparison F f ≫ (biproduct.iso_product _).hom,
  { ext, convert pi_comparison_comp_π F f j.as; simp [← functor.map_comp] },
  haveI : is_iso (biproduct_comparison F f) := is_iso_of_mono_of_is_split_epi _,
  haveI : is_iso (pi_comparison F f) := by { rw this, apply_instance },
  haveI := preserves_product.of_iso_comparison F f,
  apply preserves_biproduct_of_preserves_product
end

/-- If the (coproduct-like) biproduct comparison for `F` and `f` is an epimorphism, then `F`
    preserves the biproduct of `F` and `f`. For the converse, see `map_biproduct`. -/
def preserves_biproduct_of_epi_biproduct_comparison' {f : J → C} [has_biproduct f]
  [has_biproduct (F.obj ∘ f)] [epi (biproduct_comparison' F f)] : preserves_biproduct f F :=
begin
  haveI : epi ((split_epi_biproduct_comparison F f).section_) := by simpa,
  haveI : is_iso (biproduct_comparison F f) := is_iso.of_epi_section'
    (split_epi_biproduct_comparison F f),
  apply preserves_biproduct_of_mono_biproduct_comparison
end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_products_of_shape
  [preserves_limits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproduct_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_colimit (discrete.functor f) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
      (is_bilimit_of_preserves F
        (bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
    cocones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_coproduct_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproducts_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_colimits_of_shape (discrete J) F :=
{ preserves_colimit := λ f, preserves_colimit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_coproduct {f : J → C}
  [preserves_colimit (discrete.functor f) F] : preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
      cocones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_coproducts_of_shape
  [preserves_colimits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_coproduct F }

end fintype

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_product_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_limit (pair X Y) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
    cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_product_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_products_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_limits_of_shape (discrete walking_pair) F :=
{ preserves_limit := λ K, preserves_limit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_product {X Y : C}
  [preserves_limit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
        cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- If the (product-like) biproduct comparison for `F`, `X` and `Y` is a monomorphism, then
    `F` preserves the biproduct of `X` and `Y`. For the converse, see `map_biprod`. -/
def preserves_binary_biproduct_of_mono_biprod_comparison {X Y : C} [has_binary_biproduct X Y]
  [has_binary_biproduct (F.obj X) (F.obj Y)] [mono (biprod_comparison F X Y)] :
  preserves_binary_biproduct X Y F :=
begin
  have : prod_comparison F X Y = (F.map_iso (biprod.iso_prod X Y)).inv ≫
    biprod_comparison F X Y ≫ (biprod.iso_prod _ _).hom := by { ext; simp [← functor.map_comp] },
  haveI : is_iso (biprod_comparison F X Y) := is_iso_of_mono_of_is_split_epi _,
  haveI : is_iso (prod_comparison F X Y) := by { rw this, apply_instance },
  haveI := preserves_limit_pair.of_iso_prod_comparison F X Y,
  apply preserves_binary_biproduct_of_preserves_binary_product
end

/-- If the (coproduct-like) biproduct comparison for `F`, `X` and `Y` is an epimorphism, then
    `F` preserves the biproduct of `X` and `Y`. For the converse, see `map_biprod`. -/
def preserves_binary_biproduct_of_epi_biprod_comparison' {X Y : C} [has_binary_biproduct X Y]
  [has_binary_biproduct (F.obj X) (F.obj Y)] [epi (biprod_comparison' F X Y)] :
  preserves_binary_biproduct X Y F :=
begin
  haveI : epi ((split_epi_biprod_comparison F X Y).section_) := by simpa,
  haveI : is_iso (biprod_comparison F X Y) := is_iso.of_epi_section'
    (split_epi_biprod_comparison F X Y),
  apply preserves_binary_biproduct_of_mono_biprod_comparison
end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_products
  [preserves_limits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproduct_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_colimit (pair X Y) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_coproduct_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproducts_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_colimits_of_shape (discrete walking_pair) F :=
{ preserves_colimit := λ K, preserves_colimit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_coproduct {X Y : C}
  [preserves_colimit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
        cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_coproducts
  [preserves_colimits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_coproduct F }

end limits

end preadditive

end category_theory


import Cla.Dsl

/-! # An example of using `Cla` -/

namespace Cla.Example

structure Conf where
  verb : Nat
  inputs : List String
  output : Option String
deriving Repr, Inhabited

def Conf.default : Conf where
  verb := 1
  inputs := []
  output := none

section Conf
  variable
    (self : Conf)

  def Conf.verbDo
    (action : Nat → Nat)
  : Conf := {
    self with
      verb := action self.verb
  }

  def Conf.addInputs
    (inputs : List String)
  : Conf := {
    self with
      inputs := self.inputs ++ inputs
  }

  def Conf.addInput
    (input : String)
  : Conf :=
    self.addInputs [input]

  def Conf.revInputs : Conf := {
    self with inputs := self.inputs.reverse
  }
end Conf

section Parse
  variable
    (self : Conf)

  def Conf.clap.short
  : Char → IParseM Conf
    | 'v' =>
      self.verbDo (· + 1)
      |> pure
    | flag =>
      EStateM.throw s! "unexpected flag `-{flag}`"

  def Conf.clap.long
  : String → IParseM Conf
    | "verb"
    | "verbose" =>
      do
        let arg ←
          Parse.nextFlagArg
        if let some verb := arg.toNat? then
          self.verbDo (𝕂 verb)
          |> pure
        else
          EStateM.throw s! "expected natural, got `{arg}`"
    | "input" =>
      do
        let arg ←
          Parse.nextFlagArg
        self.addInput arg
        |> pure
    | "inputs" =>
      do
        Parse.foldFlagArgs
          (min := 1)
          (max := none)
          (fold := Conf.addInput)
          (init := self)
    | flag =>
      EStateM.throw s! "unexpected flag `--{flag}`"

  def Conf.clap.val
  : String → Nat → IParseM Conf
    | output, 0 =>
      { self with output := output }
      |> pure
    | spurious, _ =>
      EStateM.throw
        s! "already have one value (`{self.output}`), value `{spurious}` is unexpected"

  def Conf.clap
  : EParseM Parse.Err Conf :=
    do
      let conf ←
        Parse.loopDo
          clap.long
          clap.short
          clap.val
          (fun _ conf => conf)
          Conf.default
      if conf.output.isNone then
        Parse.Err.mk
          none
          s! "no output file was provided, expected exactly one"
        |> EStateM.throw
      else if conf.inputs.isEmpty then
        Parse.Err.mk
          none
          s! "no input file was provided, expected at least one"
        |> EStateM.throw
      else
        conf.revInputs
        |> pure
end Parse

namespace Tests

  def test
    (args : String)
  : String :=
    let parser :=
      Parse.mk args.splitOn
    match EStateM.run Conf.clap parser with
    | .ok conf _ =>
      s! "okay: {reprPrec conf 1}"
    | .error err _ =>
      s! "error: {err}"

  def test₁ :=
    test "--input input₁ -v -v --input input₂ output"
  #eval test₁

  def test₂ :=
    test "--input input₁ -v -v --input input₂ output --verbose 27"
  #eval test₂

  def test₃ :=
    test "--input input₁ -v -v --input input₂ output --verbose 27 -v -v"
  #eval test₃

  def test₄ :=
    test "--inputs input₁ input₂ -- output"
  #eval test₄

  def error₀ :=
    test "output"
  #eval error₀

  def error₁ :=
    test "output₁ output₂"
  #eval error₁

  def error₂ :=
    test "--input input₁ output₁ output₂"
  #eval error₂

  def error₃ :=
    test "--inputs input₁ input₂ output"
  #eval error₃

end Tests

namespace Conf.flag
  def v : Flag Conf :=
    Flag.withDesc
      "increases verbosity"
    |>.withShort 'v'
    |>.effect (
      fun () =>
        do
          let conf ← get
          conf.verbDo (fun v => v + 1)
          |> set
    )

  def q : Flag Conf :=
    Flag.withDesc
      "decreases verbosity"
    |>.withShort 'q'
    |>.effect (
      fun () =>
        do
          let conf ← get
          conf.verbDo (fun v => v - 1)
          |> set
    )

  def verb : Flag Conf :=
    Flag.withDesc
      s! "sets the verbosity (default {Conf.default.verb})"
    |>.withLong "verb"
    |>.argsTake 1
    |>.effect (
      fun verb =>
        do
          if let some verb := verb.toNat?
          then
            let conf ← get
            conf.verbDo (𝕂 verb)
            |> set
    )

  def quiet : Flag Conf :=
    Flag.withDesc
      "sets verbosity to zero"
    |>.withLong "quiet"
    |>.effect (
      fun () =>
        do
          let conf ← get
          conf.verbDo (𝕂 0)
          |> set
    )

  def inputs : Flag Conf :=
    Flag.withDesc
      "inputs, requires two values or more"
    |>.withLong "inputs"
    |>.argsAtLeast 2
    |>.effect (
      fun (h₁, h₂, tail) =>
        do
          let conf ← get
          conf
          |>.addInputs [h₁, h₂]
          |>.addInputs tail
          |> set
    )
end Conf.flag

protected def Conf.com : Com Conf :=
  let com? :=
    Com.mkBuilder
      Conf
      "myProgram"
    |>.withFlags [
      flag.v,
      flag.q,
      flag.verb,
      flag.quiet,
      flag.inputs
    ]
    |>.build
  match com? with
  | .ok com => com
  | .error err =>
    panic! s! "Failed to build command: {err}"

def Conf.parse : List String → Except Parse.Err Conf :=
  Parse.run Conf.com Conf.default

#eval Conf.parse [
  "--verb", "662",
  "-vvvv",
  "--inputs", "in₁", "in₂", "in₃", "in₄"
]

protected def Conf.com' : Except String <| Com Conf :=
  open Cla.Dsl in
  clap! my_app (conf : Conf) where
  | -v
    "increases verbosity"
    := pure (conf.verbDo <| Nat.add 1)
  | -q
    "decreases verbosity"
    := pure (conf.verbDo <| Nat.sub 1)
  | ─verb
    "sets the verbosity"
    taking (v : String) :=
      if let some v := String.toNat? v then
        .ok <| conf.verbDo <| 𝕂 v
      else
        .error s! "expected natural number, got {v}"
  | ─inputs
    "input files"
    taking (in₁ in₂ : String) (inTail : List String ≤ 3) :=
      conf.addInputs (in₁ :: in₂ :: inTail)
      |> .ok