/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.dfinsupp
import data.equiv.module
import data.finsupp.basic

/-!
# Conversion between `finsupp` and homogenous `dfinsupp`

This module provides conversions between `finsupp` and `dfinsupp`.
It is in its own file since neither `finsupp` or `dfinsupp` depend on each other.

## Main definitions

* "identity" maps between `finsupp` and `dfinsupp`:
  * `finsupp.to_dfinsupp : (ι →₀ M) → (Π₀ i : ι, M)`
  * `dfinsupp.to_finsupp : (Π₀ i : ι, M) → (ι →₀ M)`
  * Bundled equiv versions of the above:
    * `finsupp_equiv_dfinsupp : (ι →₀ M) ≃ (Π₀ i : ι, M)`
    * `finsupp_add_equiv_dfinsupp : (ι →₀ M) ≃+ (Π₀ i : ι, M)`
    * `finsupp_lequiv_dfinsupp R : (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M)`
* stronger versions of `finsupp.split`:
  * `sigma_finsupp_equiv_dfinsupp : ((Σ i, η i) →₀ N) ≃ (Π₀ i, (η i →₀ N))`
  * `sigma_finsupp_add_equiv_dfinsupp : ((Σ i, η i) →₀ N) ≃+ (Π₀ i, (η i →₀ N))`
  * `sigma_finsupp_lequiv_dfinsupp : ((Σ i, η i) →₀ N) ≃ₗ[R] (Π₀ i, (η i →₀ N))`

## Theorems

The defining features of these operations is that they preserve the function and support:

* `finsupp.to_dfinsupp_coe`
* `finsupp.to_dfinsupp_support`
* `dfinsupp.to_finsupp_coe`
* `dfinsupp.to_finsupp_support`

and therefore map `finsupp.single` to `dfinsupp.single` and vice versa:

* `finsupp.to_dfinsupp_single`
* `dfinsupp.to_finsupp_single`

as well as preserving arithmetic operations.

For the bundled equivalences, we provide lemmas that they reduce to `finsupp.to_dfinsupp`:

* `finsupp_add_equiv_dfinsupp_apply`
* `finsupp_lequiv_dfinsupp_apply`
* `finsupp_add_equiv_dfinsupp_symm_apply`
* `finsupp_lequiv_dfinsupp_symm_apply`

## Implementation notes

We provide `dfinsupp.to_finsupp` and `finsupp_equiv_dfinsupp` computably by adding
`[decidable_eq ι]` and `[Π m : M, decidable (m ≠ 0)]` arguments. To aid with definitional unfolding,
these arguments are also present on the `noncomputable` equivs.
-/

variables {ι : Type*} {R : Type*} {M : Type*}

/-! ### Basic definitions and lemmas -/
section defs

/-- Interpret a `finsupp` as a homogenous `dfinsupp`. -/
def finsupp.to_dfinsupp [has_zero M] (f : ι →₀ M) : Π₀ i : ι, M :=
⟦⟨f, f.support.1, λ i, (classical.em (f i = 0)).symm.imp_left (finsupp.mem_support_iff.mpr)⟩⟧

@[simp] lemma finsupp.to_dfinsupp_coe [has_zero M] (f : ι →₀ M) : ⇑f.to_dfinsupp = f := rfl

section
variables [decidable_eq ι] [has_zero M]

@[simp] lemma finsupp.to_dfinsupp_single (i : ι) (m : M) :
  (finsupp.single i m).to_dfinsupp = dfinsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

variables [Π m : M, decidable (m ≠ 0)]

@[simp] lemma to_dfinsupp_support (f : ι →₀ M) : f.to_dfinsupp.support = f.support :=
by { ext, simp, }

/-- Interpret a homogenous `dfinsupp` as a `finsupp`.

Note that the elaborator has a lot of trouble with this definition - it is often necessary to
write `(dfinsupp.to_finsupp f : ι →₀ M)` instead of `f.to_finsupp`, as for some unknown reason
using dot notation or omitting the type ascription prevents the type being resolved correctly. -/
def dfinsupp.to_finsupp (f : Π₀ i : ι, M) : ι →₀ M :=
⟨f.support, f, λ i, by simp only [dfinsupp.mem_support_iff]⟩

@[simp] lemma dfinsupp.to_finsupp_coe (f : Π₀ i : ι, M) : ⇑f.to_finsupp = f := rfl
@[simp] lemma dfinsupp.to_finsupp_support (f : Π₀ i : ι, M) : f.to_finsupp.support = f.support :=
by { ext, simp, }

@[simp] lemma dfinsupp.to_finsupp_single (i : ι) (m : M) :
  (dfinsupp.single i m : Π₀ i : ι, M).to_finsupp = finsupp.single i m :=
by { ext, simp [finsupp.single_apply, dfinsupp.single_apply] }

@[simp] lemma finsupp.to_dfinsupp_to_finsupp (f : ι →₀ M) : f.to_dfinsupp.to_finsupp = f :=
finsupp.coe_fn_injective rfl

@[simp] lemma dfinsupp.to_finsupp_to_dfinsupp (f : Π₀ i : ι, M) : f.to_finsupp.to_dfinsupp = f :=
dfinsupp.coe_fn_injective rfl

end

end defs

/-! ### Lemmas about arithmetic operations -/
section lemmas

namespace finsupp

@[simp] lemma to_dfinsupp_zero [has_zero M] :
  (0 : ι →₀ M).to_dfinsupp = 0 := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_add [add_zero_class M] (f g : ι →₀ M) :
  (f + g).to_dfinsupp = f.to_dfinsupp + g.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_neg [add_group M] (f : ι →₀ M) :
  (-f).to_dfinsupp = -f.to_dfinsupp := dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_sub [add_group M] (f g : ι →₀ M) :
  (f - g).to_dfinsupp = f.to_dfinsupp - g.to_dfinsupp :=
dfinsupp.coe_fn_injective rfl

@[simp] lemma to_dfinsupp_smul [monoid R] [add_monoid M] [distrib_mul_action R M]
  (r : R) (f : ι →₀ M) : (r • f).to_dfinsupp = r • f.to_dfinsupp :=
dfinsupp.coe_fn_injective rfl

end finsupp

namespace dfinsupp
variables [decidable_eq ι]

@[simp] lemma to_finsupp_zero [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  to_finsupp 0 = (0 : ι →₀ M) := finsupp.coe_fn_injective rfl

@[simp] lemma to_finsupp_add [add_zero_class M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f + g) : ι →₀ M) = (to_finsupp f + to_finsupp g) :=
finsupp.coe_fn_injective $ dfinsupp.coe_add _ _

@[simp] lemma to_finsupp_neg [add_group M] [Π m : M, decidable (m ≠ 0)] (f : Π₀ i : ι, M) :
  (to_finsupp (-f) : ι →₀ M) = -to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_neg _

@[simp] lemma to_finsupp_sub [add_group M] [Π m : M, decidable (m ≠ 0)] (f g : Π₀ i : ι, M) :
  (to_finsupp (f - g) : ι →₀ M) = to_finsupp f - to_finsupp g :=
finsupp.coe_fn_injective $ dfinsupp.coe_sub _ _

@[simp] lemma to_finsupp_smul [monoid R] [add_monoid M] [distrib_mul_action R M]
  [Π m : M, decidable (m ≠ 0)]
  (r : R) (f : Π₀ i : ι, M) : (to_finsupp (r • f) : ι →₀ M) = r • to_finsupp f :=
finsupp.coe_fn_injective $ dfinsupp.coe_smul _ _

end dfinsupp

end lemmas

/-! ### Bundled `equiv`s -/

section equivs

/-- `finsupp.to_dfinsupp` and `dfinsupp.to_finsupp` together form an equiv. -/
@[simps {fully_applied := ff}]
def finsupp_equiv_dfinsupp [decidable_eq ι] [has_zero M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  left_inv := finsupp.to_dfinsupp_to_finsupp, right_inv := dfinsupp.to_finsupp_to_dfinsupp }

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_add_equiv_dfinsupp
  [decidable_eq ι] [add_zero_class M] [Π m : M, decidable (m ≠ 0)] :
  (ι →₀ M) ≃+ (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

variables (R)

/-- The additive version of `finsupp.to_finsupp`. Note that this is `noncomputable` because
`finsupp.has_add` is noncomputable. -/
@[simps {fully_applied := ff}]
noncomputable def finsupp_lequiv_dfinsupp
  [decidable_eq ι] [semiring R] [add_comm_monoid M] [Π m : M, decidable (m ≠ 0)] [module R M] :
  (ι →₀ M) ≃ₗ[R] (Π₀ i : ι, M) :=
{ to_fun := finsupp.to_dfinsupp, inv_fun := dfinsupp.to_finsupp,
  map_smul' := finsupp.to_dfinsupp_smul,
  map_add' := finsupp.to_dfinsupp_add,
  .. finsupp_equiv_dfinsupp}

section sigma
/-- ### Stronger versions of `finsupp.split` -/

noncomputable theory
open_locale classical

variables {η : ι → Type*} {N : Type*} [semiring R]

open finsupp

/-- `finsupp.split` is an equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
def sigma_finsupp_equiv_dfinsupp [has_zero N] : ((Σ i, η i) →₀ N) ≃ (Π₀ i, (η i →₀ N)) :=
{ to_fun := λ f, ⟦⟨split f, (split_support f : finset ι).val, λ i,
    begin
    rw [← finset.mem_def, mem_split_support_iff_nonzero],
    exact (decidable.em _).symm
    end⟩⟧,
  inv_fun := λ f,
  begin
    refine on_finset (finset.sigma f.support (λ j, (f j).support)) (λ ji, f ji.1 ji.2)
      (λ g hg, finset.mem_sigma.mpr ⟨_, mem_support_iff.mpr hg⟩),
    simp only [ne.def, dfinsupp.mem_support_to_fun],
    intro h,
    rw h at hg,
    simpa using hg
  end,
  left_inv := λ f, by { ext, simp [split] },
  right_inv := λ f, by { ext, simp [split] } }

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_apply [has_zero N] (f : (Σ i, η i) →₀ N) :
  (sigma_finsupp_equiv_dfinsupp f : Π i, (η i →₀ N)) = finsupp.split f := rfl

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_symm_apply [has_zero N] (f : Π₀ i, (η i →₀ N)) (s : Σ i, η i) :
  (sigma_finsupp_equiv_dfinsupp.symm f : (Σ i, η i) →₀ N) s = f s.1 s.2 := rfl

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_support [has_zero N] (f : (Σ i, η i) →₀ N) :
  (sigma_finsupp_equiv_dfinsupp f).support = finsupp.split_support f :=
begin
  ext,
  rw dfinsupp.mem_support_to_fun,
  exact (finsupp.mem_split_support_iff_nonzero _ _).symm,
end

@[simp] lemma sigma_finsupp_equiv_dfinsupp_single [has_zero N] (a : Σ i, η i) (n : N) :
  sigma_finsupp_equiv_dfinsupp (finsupp.single a n)
    = @dfinsupp.single _ (λ i, η i →₀ N) _ _ a.1 (finsupp.single a.2 n) :=
begin
  obtain ⟨i, a⟩ := a,
  ext j b,
  by_cases h : i = j,
  { subst h,
    simp [split_apply, finsupp.single_apply] },
  suffices : finsupp.single (⟨i, a⟩ : Σ i, η i) n ⟨j, b⟩ = 0,
  { simp [split_apply, dif_neg h, this] },
  have H : (⟨i, a⟩ : Σ i, η i) ≠ ⟨j, b⟩ := by simp [h],
  rw [finsupp.single_apply, if_neg H]
end

-- Without this Lean fails to find the `add_zero_class` instance on `Π₀ i, (η i →₀ N)`.
local attribute [-instance] finsupp.has_zero

@[simp]
lemma sigma_finsupp_equiv_dfinsupp_add [add_zero_class N] (f g : (Σ i, η i) →₀ N) :
  sigma_finsupp_equiv_dfinsupp (f + g) =
  (sigma_finsupp_equiv_dfinsupp f + (sigma_finsupp_equiv_dfinsupp g) : (Π₀ (i : ι), η i →₀ N)) :=
by {ext, refl}

/-- `finsupp.split` is an additive equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
@[simps]
def sigma_finsupp_add_equiv_dfinsupp [add_zero_class N] : ((Σ i, η i) →₀ N) ≃+ (Π₀ i, (η i →₀ N)) :=
{ to_fun := sigma_finsupp_equiv_dfinsupp,
  inv_fun := sigma_finsupp_equiv_dfinsupp.symm,
  map_add' := sigma_finsupp_equiv_dfinsupp_add,
  .. sigma_finsupp_equiv_dfinsupp }

local attribute [-instance] finsupp.add_zero_class

--tofix: r • (sigma_finsupp_equiv_dfinsupp f) doesn't work.
@[simp]
lemma sigma_finsupp_equiv_dfinsupp_smul {R} [monoid R] [add_monoid N] [distrib_mul_action R N]
  (r : R) (f : (Σ i, η i) →₀ N) : sigma_finsupp_equiv_dfinsupp (r • f) =
  @has_scalar.smul R (Π₀ i, η i →₀ N) mul_action.to_has_scalar r (sigma_finsupp_equiv_dfinsupp f) :=
by { ext, refl }

local attribute [-instance] finsupp.add_monoid

/-- `finsupp.split` is a linear equivalence between `(Σ i, η i) →₀ N` and `Π₀ i, (η i →₀ N)`. -/
@[simps]
def sigma_finsupp_lequiv_dfinsupp [add_comm_monoid N] [module R N] :
  ((Σ i, η i) →₀ N) ≃ₗ[R] (Π₀ i, (η i →₀ N)) :=
{ map_smul' := sigma_finsupp_equiv_dfinsupp_smul,
  .. sigma_finsupp_add_equiv_dfinsupp }

end sigma

end equivs


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.category
import pseudoelements
import tactic.combinators

open category_theory
open category_theory.abelian
open tactic

namespace tactic.chase

meta def chase_attribute : user_attribute := {
  name := `chase,
  descr := "A definition or lemma that can be used in a diagram chase."
}

meta def get_lemmas_from_attribute (f : expr) : tactic (list expr) :=
attribute.get_instances `chase >>= (list.mfiltermap $ λ n,
  (some <$> (do e ← resolve_name n, to_expr ``(%%e %%f) tt ff)) <|> return none)

run_cmd attribute.register ``chase_attribute

/-- A morphism in an abelian category. -/
@[derive decidable_eq]
meta structure morphism :=
(ex : expr)
(domain : expr)
(codomain : expr)
(app : expr)

/-- A sequence of morphisms in an abelian category, in "mathematical order":
    `[f₁, ..., fₙ]` represents `fₙ ≫ ... ≫ f₁`. -/
@[reducible]
meta def morphism_chain := list morphism

/-- An expression of the form `f₁ (f₂ (... (fₙ a)))`, with `a` a pseudoelement. -/
@[derive decidable_eq]
meta structure diagram_term :=
(ms : morphism_chain)
(elem : expr)

/-- A commutativity lemma in a category. -/
meta structure commutativity_lemma :=
(lhs rhs : morphism_chain)
(ex : expr)

/-- A lemma of the form `f₁ (f₂ (... (fₙ a))) = g₁ (g₂ (... (gₘ a)))`, with `a` a pseudoelement. -/
meta structure element_lemma :=
(lhs rhs : diagram_term)
(ex : expr)

/-- An exactness statement. -/
meta structure exactness_lemma :=
(lhs rhs : morphism_chain)
(ex : expr)

/-- The morphisms and lemmas in the context. -/
meta structure chase_data :=
(morphisms : list morphism)
(comm_lemmas : list commutativity_lemma)
(elem_lemmas : list element_lemma)
(exact_lemmas : list exactness_lemma)

meta instance format_morphism : has_to_format morphism :=
{ to_format := λ m, format!"{morphism.ex m}" }

meta instance format_diagram_term : has_to_format diagram_term :=
{ to_format := λ t, format!"{t.ms} {t.elem}" }

meta instance format_commutativity_lemma : has_to_format commutativity_lemma :=
{ to_format := λ l, format!"{l.lhs} ==> {l.rhs}" }

meta instance format_element_lemma : has_to_format element_lemma :=
{ to_format := λ l, format!"{l.lhs} ==> {l.rhs}" }

meta instance format_exactness_lemma : has_to_format exactness_lemma :=
{ to_format := λ l, format!"exact {l.lhs} {l.rhs}" }

/-- A tactic that makes use of the precomputed content of the context. -/
@[reducible]
meta def chase_tactic :=
state_t chase_data tactic

meta instance {α} : has_coe (tactic α) (chase_tactic α) :=
⟨monad_lift⟩

meta def as_expr : diagram_term → expr
| ⟨[], e⟩ := e
| ⟨t::ts, e⟩ := expr.app t.app $ as_expr ⟨ts, e⟩

meta def commutativity_lemma.symm : commutativity_lemma → tactic commutativity_lemma
| ⟨lhs, rhs, e⟩ := mk_eq_symm e >>= λ f, return ⟨rhs, lhs, f⟩

meta def element_lemma.symm : element_lemma → tactic element_lemma
| ⟨lhs, rhs, e⟩ := mk_eq_symm e >>= λ f, return ⟨rhs, lhs, f⟩

meta def morphism.is_zero (m : morphism) : tactic bool :=
do
  d ← infer_type m.ex,
  z ← i_to_expr ``(0 : %%d),

  -- Why does the following not work?
  -- z ← mk_app `has_zero.zero [d],

  (do is_def_eq m.ex z,
  return tt) <|> return ff

meta def diagram_term.type : diagram_term → tactic expr
| ⟨[], e⟩ := infer_type e
| ⟨t::ts, e⟩ := return t.codomain

meta def diagram_term.zero (t : diagram_term) : tactic diagram_term :=
do
  s ← t.type,
  x ← i_to_expr ``(0 : %%s),
  return ⟨[], x⟩

/-- Try to generate a proof of `as_expr t = 0`. -/
meta def diagram_term.to_zero : diagram_term → tactic (option expr)
| ⟨[], e⟩ := (do
  d ← infer_type e,
  f ← i_to_expr ``(0 : %%d),
  is_def_eq e f,
  some <$> mk_eq_refl e) <|> return none
| ⟨t::ts, e⟩ := do
  z ← t.is_zero,
  if z then some <$> mk_app
    `category_theory.abelian.pseudoelements.zero_apply [t.codomain, as_expr ⟨ts, e⟩] else do
    inner ← diagram_term.to_zero ⟨ts, e⟩,
    match inner with
    | none := return none
    | some i := do
      fs ← mk_app `congr_arg [t.app, i],
      sn ← mk_app `category_theory.abelian.pseudoelements.apply_zero [t.ex],
      some <$> mk_eq_trans fs sn
    end

meta def is_mono (m : morphism) : tactic bool :=
(do i_to_expr ``(mono %%(m.ex)) >>= mk_instance, return tt) <|> return ff

meta def is_epi (m : morphism) : tactic bool :=
(do i_to_expr ``(epi %%(m.ex)) >>= mk_instance, return tt) <|> return ff

meta def has_domain (e : expr) (m : morphism) : tactic bool :=
(do is_def_eq m.domain e, return tt) <|> return ff

meta def is_mono_with_domain (e : expr) (m : morphism) : tactic bool :=
do
  l ← has_domain e m,
  match l with
  | ff := return ff
  | tt := is_mono m
  end

meta def has_apply_domain (e : expr) (m : morphism) : tactic bool :=
(do
  u ← i_to_expr ``(coe_sort %%(tactic.chase.morphism.domain m)),
  is_def_eq u e,
  return tt) <|> return ff

meta def morphism.can_apply (e : expr) (m : morphism) : tactic bool :=
do t ← infer_type e, has_apply_domain t m

meta def morphism_chain.can_apply (e : expr) : morphism_chain → tactic bool
| [] := return false
| (m::[]) := m.can_apply e
| (m::ms) := morphism_chain.can_apply ms

meta def monos_with_domain (e : expr) : chase_tactic (list morphism) :=
do
  s ← get,
  list.mfilter (λ m, is_mono_with_domain e m) $ s.morphisms

meta def mono_with_domain (e : expr) : chase_tactic (option morphism) :=
monos_with_domain e >>= (return ∘ list.head')

meta def epis (e : list morphism) : tactic (list morphism) :=
list.mfilter is_epi e

/-- Try to parse `e` as a morphism. -/
meta def as_morphism (e : expr) : tactic (option morphism) :=
do
  `(%%l ⟶ %%r) ← infer_type e | return none,
  app ← mk_app `coe_fn [e],
  return $ some ⟨e, l, r, app⟩

/-- Try to parse `e` as a morphism chain. -/
meta def as_morphism_chain : expr → tactic (option morphism_chain) := λ e,
do
  self ← as_morphism e,
  match self with
  | none := return none
  | some s := do
    `(%%l ≫ %%r) ← return s.ex | return (some [s]),
    some u ← as_morphism_chain r | return none,
    some r ← as_morphism l | return none,
    return $ some (list.append u [r])
  end

/-- Try to parse `e` as a commutativity lemma. -/
meta def as_commutativity_lemma (e : expr) : tactic (option commutativity_lemma) :=
do
  `(%%l = %%r) ← infer_type e | return none,
  some lhs ← as_morphism_chain l | return none,
  some rhs ← as_morphism_chain r | return none,
  return $ some ⟨lhs, rhs, e⟩

/-- Try to parse `e` as a diagram term. -/
meta def as_diagram_term : expr → tactic (option diagram_term) := λ e,
do
  `(coe_sort %%l) ← infer_type e | return none,
  expr.app `(coe_fn %%f) `(%%x) ← return e | return $ some ⟨[], e⟩,
  some dt ← as_diagram_term x,
  some F ← as_morphism f,
  return $ some ⟨(F::diagram_term.ms dt), diagram_term.elem dt⟩

/-- Try to parse `e` as an element lemma. -/
meta def as_element_lemma (e : expr) : tactic (option element_lemma) :=
do
  `(%%l = %%r) ← infer_type e | return none,
  some lhs ← as_diagram_term l | return none,
  some rhs ← as_diagram_term r | return none,
  return $ some ⟨lhs, rhs, e⟩

/-- Try to parse `e` as an exactness lemma. -/
meta def as_exactness_lemma (e : expr) : tactic (option exactness_lemma) :=
do
  `(category_theory.abelian.exact %%f %%g) ← infer_type e | return none,
  some lhs ← as_morphism_chain f | return none,
  some rhs ← as_morphism_chain g | return none,
  return $ some ⟨lhs, rhs, e⟩

meta def epis_as_exact (e : list morphism) : tactic (list exactness_lemma) :=
epis e >>= (list.mmap $ λ m,
do
  ep ← i_to_expr ``(epi %%(m.ex)) >>= mk_instance,
  a ← mk_app `category_theory.abelian.exact_zero_of_epi' [ep],
  some l ← as_exactness_lemma a,
  return l)

meta def exactness_lemmas_for (m : morphism_chain) : chase_tactic (list exactness_lemma) :=
do
  l ← get,
  return $ list.filter (λ lem, to_bool $ exactness_lemma.lhs lem = m) l.exact_lemmas

meta def get_morphisms (ctx : list expr) : tactic (list morphism) :=
list.mfiltermap as_morphism ctx

meta def get_comm_lemmas (ctx : list expr) : tactic (list commutativity_lemma) :=
list.mfiltermap as_commutativity_lemma ctx

meta def get_elem_lemmas (ctx : list expr) : tactic (list element_lemma) :=
list.mfiltermap as_element_lemma ctx

meta def get_exact_lemmas (ctx : list expr) : tactic (list exactness_lemma) :=
list.mfiltermap as_exactness_lemma ctx

meta def get_exact_lemmas_with_epi (ctx : list expr) (ms : list morphism) :
  tactic (list exactness_lemma) :=
do
  found ← get_exact_lemmas ctx,
  ep ← epis_as_exact ms,
  return $ list.append found ep

meta def exact_lemma_to_comm_lemmas (e : exactness_lemma) : tactic (list commutativity_lemma) :=
do
  some fi ← i_to_expr ``((%%e.ex).1) >>= as_commutativity_lemma,
  some se ← i_to_expr ``((%%e.ex).2) >>= as_commutativity_lemma,
  return [fi, se]

meta def exact_lemmas_to_comm_lemmas (e : list exactness_lemma) : tactic (list commutativity_lemma) :=
do
  l ← list.mmap exact_lemma_to_comm_lemmas e,
  return $ list.join l

meta def mk_chase_data (e : option expr) : tactic chase_data :=
do
  ls ← match e with
       | none := return []
       | some e := get_lemmas_from_attribute e
       end,
  ctx ← local_context,
  let src := list.append ctx ls,
  ms ← get_morphisms src,
  cs ← get_comm_lemmas src,
  es ← get_elem_lemmas src,
  ess ← list.mmap element_lemma.symm es,
  exs ← get_exact_lemmas_with_epi src ms,
  ecs ← exact_lemmas_to_comm_lemmas exs,
  let cs' := list.append cs ecs,
  css ← list.mmap commutativity_lemma.symm cs',
  return ⟨ms, list.append cs' css, list.append es ess, exs⟩

meta def run_chase_tactic_with_data {α} (t : chase_tactic α) (d : chase_data) : tactic α :=
do (res, _) ← t.run d, return res

meta def run_chase_tactic {α} (e : option expr) (t : chase_tactic α) : tactic α :=
mk_chase_data e >>= run_chase_tactic_with_data t

meta def add_elem_lemma (l : element_lemma) : chase_tactic unit :=
do
  ⟨ms, cs, es, el⟩ ← get,
  ls ← l.symm,
  put ⟨ms, cs, (ls::l::es), el⟩

end tactic.chase


import Lib.Tactic

namespace List

instance : Functor List where
  map := List.map

variable {α β} (xs ys : List α) (f : β → α → β) (x₀ : β)

@[simp]
theorem foldl_app :
  foldl f x₀ (xs ++ ys) = foldl f (foldl f x₀ xs) ys := by
induction xs generalizing x₀ <;> auto

theorem foldl_eq_self :
  (xs.foldl (flip (.::.)) []).reverse = xs := by
simp only [flip]
trans (List.reverse [] ++ xs)
case second => simp
generalize [] = ys
induction xs generalizing ys
 <;> simp [List.foldl, *, List.append_assoc]

theorem foldr_eq_self :
  (xs.foldr (.::.) []) = xs := by
trans (xs ++ [])
case second => simp
generalize [] = ys
induction xs generalizing ys
 <;> simp [List.foldr, *, List.append_assoc]

@[simp]
theorem map_nil (f : α → β) : f <$> [] = [] := rfl

@[simp]
theorem map_cons (f : α → β) x xs :
  f <$> (x :: xs) = f x :: f <$> xs := rfl

@[simp]
theorem redLength_eq (xs : List α) :
  redLength xs = length xs := by
induction xs <;> simp [redLength, *]

@[simp]
theorem take_zero (xs : List α) : xs.take 0 = [] := by
induction xs <;> simp [take]

@[simp]
theorem drop_zero (xs : List α) : xs.drop 0 = xs := by
induction xs <;> simp [drop]

@[simp]
theorem drop_nil n : (@nil α).drop n = [] := by
cases n <;> refl

theorem cons_drop {i} {xs : List α} (h : i < length xs) :
  get xs ⟨i, h⟩ :: drop i.succ xs = drop i xs := by
induction xs generalizing i;
. cases h
cases i <;> simp [get, drop, *] at h ⊢

@[simp]
theorem take_length (xs : List α) : xs.take xs.length = xs := by
induction xs <;> simp [take, length, *]

@[simp]
theorem drop_length (xs : List α) : xs.drop xs.length = [] := by
induction xs <;> simp [drop, *]

@[simp]
theorem length_eq_zero (xs : List α) :
  xs.length = 0 ↔ xs = [] := by
cases xs <;> simp [length, Nat.add_one]

@[simp]
theorem foldl_reverse (xs : List α) (f : β → α → β) :
  xs.reverse.foldl f x₀ = xs.foldr (flip f) x₀ := by
induction xs <;> simp [foldl, foldr, *]; refl

/-- drop -/

theorem drop_append' {xs ys : List α}
        (h : xs.length = n) :
  (xs ++ ys).drop n = ys := by
induction xs generalizing n with
| nil =>
  cases n <;> simp
  cases h
| cons x xs ih =>
  cases n <;> simp only [drop, List.cons_append]
  <;> cases h
  auto

theorem drop_append {xs ys : List α} :
  (xs ++ ys).drop xs.length = ys :=
drop_append' rfl

/- mem -/

section mem

attribute [auto] List.Mem

@[simp]
theorem mem_nil : ¬ x ∈ @nil α := by
intro h; cases h

@[simp]
theorem mem_cons {ys : List α} : x ∈ y :: ys ↔ x = y ∨ x ∈ ys := by
constructor
next =>
  intro h; cases h
  . left; refl
  . right; assumption
next =>
  intro h; cases h;
  next h =>
    subst h; auto
  next => auto

end mem

/- filter -/

section filter

variable {p : α → Bool}
variable {x : α} {xs : List α}

theorem filterAux_eq :
  filterAux p xs ys = reverse ys ++ filterAux p xs [] := by
induction xs generalizing ys
next => simp [filterAux]
next x xs ih =>
  simp [filterAux]; split
  <;> simp [ih (x :: ys), ih [x], append_assoc]
  auto

theorem filter_cons_eq_ite :
  filter p (x :: xs) =
  ite (p x)
    (x :: filter p xs)
    (filter p xs) := by
simp [filter, filterAux]; split <;> simp [*]
rw [filterAux_eq]; simp

@[simp]
theorem filter_nil {p : α → Bool} :
  filter p [] = [] :=
by simp [filter, filterAux]

@[simp]
theorem filter_cons_true {p : α → Bool} {x xs}
        (h : p x = true) :
  filter p (x :: xs) = x :: filter p xs :=
by simp [filter_cons_eq_ite, *]

@[simp]
theorem filter_cons_false {p : α → Bool} {x xs}
        (h : p x = false) :
  filter p (x :: xs) = filter p xs :=
by simp [filter_cons_eq_ite, *]

attribute [local auto] Or

@[simp]
theorem mem_filter {p : α → Bool} :
  x ∈ filter p xs ↔ x ∈ xs ∧ p x := by
induction xs
next => simp
next y ys ih =>
  by_cases p y <;> simp [*]
  next =>
    constructor <;> intro h
    next =>
      cases h
      next => substAll; auto
      next h => auto
    next =>
      match h with
      | ⟨.inl h, h'⟩ =>
        subst h; left; refl
      | ⟨.inr h, h'⟩ =>
        right; auto
  next =>
    constructor <;> intro h
    next => auto
    next =>
      match h with
      | ⟨.inl h, h'⟩ =>
        substAll; auto
      | ⟨.inr h, h'⟩ =>
        auto

end filter

/- iota -/

section iota

@[simp]
theorem mem_iota :
  x ∈ iota n ↔ 1 ≤ x ∧ x ≤ n := by
induction n <;> simp [iota, *]
next =>
  intros h; cases h
  next h₀ h₁ => subst h₁; cases h₀
next =>
  admit -- linear arithmetic
  -- constructor <;> intro h
  -- skip

end iota

end List

namespace List

variable {α β γ : Type _} {f : β → α → β} {g : γ → α → γ}
variable {SIM : β → γ → Prop}
variable {x₀ y₀} (t : List α)

theorem foldl_sim :
    SIM x₀ y₀ →
    (∀ a x y, SIM x y → SIM (f x a) (g y a)) →
    SIM (foldl f x₀ t) (foldl g y₀ t) := by
induction t generalizing x₀ y₀ <;> auto

end List


import data.list tactic.omega defs single branch

lemma grow_trans : ∀ t1 t2 t3 : bintree,
      (t1 ↣ t2) → (t2 ↣ t3) → (t1 ↣ t3) :=
begin
  intro t1, induction t1,
  begin intros, auto_grow end,
  repeat { begin
    intros t2 t3 H1 H2,
    cases H1, cases H2,
    have H3 : (t1_a ↣ H2_t'), apply t1_ih, repeat {assumption},
    auto_grow
  end },
  intros t2 t3 H1 H2,
  cases H1, cases H2,
  have H3 : (t1_a ↣ H2_t1'), apply t1_ih_a, repeat {assumption},
  have H4 : (t1_a_1 ↣ H2_t2'), apply t1_ih_a_1, repeat {assumption},
  auto_grow
end

lemma grow_list_exists_one : ∀ (l : list bintree) (t : bintree), (l ↦ t) →
                           ∃ t', (t' ∈ l) ∧ (t' ↣ t) :=
begin
  intros l t h,
  induction h,
  begin existsi h_t, split, apply list.mem_cons_self, assumption end,
  begin
    cases h_ih,
    existsi h_ih_w,
    split, apply list.mem_cons_of_mem, tauto, tauto
  end
end

lemma exists_one_grow_list : ∀ l t, (∃ t', ((t' ∈ l) ∧ (t' ↣ t))) → (l ↦ t) :=
begin
  intros l,
  induction l,
  begin intros, cases a, cases a_h.left end,
  begin
    intros t h,
    cases h,
    unfold has_mem.mem list.mem at h_h,
    cases h_h.left,
    begin
      apply grow_list.head_grow,
      rewrite h at h_h,
      exact h_h.right
    end,
    begin
      apply grow_list.tail_grow,
      apply l_ih,
      existsi h_w, split,
      assumption, exact h_h.right
    end
  end
end

lemma kernel_lemma : ∀ (t : bintree) (h : ℕ),
  h ≥ 1 → h ≤ height t → ∃ b : bintree, ⟨b⟩ ∧ h = height b ∧ (b ↣ t) :=
begin
  intros t,
  induction t,
  begin -- single node
    intros, unfold height at a_1,
    have H : h = 1, omega,
    rewrite H, fapply exists.intro, exact ●,
    split, apply is_branch.single,
    split, unfold height, auto_grow,
  end,
  repeat { -- left and right
    intros h H1 H2,
    cases h, cases H1, unfold height at H2,
    have H1' : h ≥ 0, omega,
    have H2' : h ≤ height t_a, omega,
    cases h,
    begin -- h = 0, which is trivial
      fapply exists.intro, exact ●,
      split, exact is_branch.single,
      split, unfold height, apply grow.single_grow
    end,
    begin -- h ≠ 0, apply induction hypothesis
      have H3 : ∃ (b : bintree), ⟨b⟩ ∧ h.succ = height b ∧ (b↣t_a),
        apply t_ih, omega, omega,
      cases H3,
      try {
        existsi ⟦H3_w∣⟧, split, apply is_branch.left_nl, tauto,
        split, unfold height,
               have Ht : h.succ = height H3_w, tauto, omega,
        apply grow.left_grow, tauto,
      },
      try {
        existsi ⟦∣H3_w⟧, split, apply is_branch.right_nl, tauto,
        split, unfold height,
               have Ht : h.succ = height H3_w, tauto, omega,
        apply grow.right_grow, tauto,
      }
    end
  },
  intros h H1 H2, -- both left and right, completely similar, while more tedious
  cases h, cases H1, unfold height at H2,
  have H1' : h ≥ 0, omega,
  have H2' : h ≤ max (height t_a) (height t_a_1), omega,
  cases h,
  begin
    fapply exists.intro, exact ●,
    split, exact is_branch.single,
    split, unfold height, apply grow.single_grow
  end,
  begin
    have H3 : h.succ ≤ height t_a ∨ h.succ ≤ height t_a_1,
      begin
        have H3' : max (height t_a) (height t_a_1) = height t_a ∨ max (height t_a) (height t_a_1) = height t_a_1, apply max_choice,
        destruct H3',
          intro H4, left, rewrite H4 at H2', assumption,
          intro H4, right, rewrite H4 at H2', assumption
      end,
    destruct H3,
    begin
      intros H4,
      have H5 : h.succ ≥ 1, omega,
      have H6 : ∃ (b : bintree), ⟨ b ⟩ ∧ h.succ = height b ∧ (b ↣ t_a),
        apply t_ih_a, repeat {assumption},
      cases H6, cases H6_h, cases H6_h_right, existsi (⟦H6_w, ●⟧),
      split, apply is_branch.left_l, assumption,
      split, unfold height,
        have Ht : (1 ≤ height H6_w), apply ge.le, apply height_ge1,
        have Ht' : max (height H6_w) 1 = height H6_w, apply max_eq_left, assumption,
        omega,
      auto_grow
    end,
    begin
      intros H4,
      have H5 : h.succ ≥ 1, omega,
      have H6 : ∃ (b : bintree), ⟨ b ⟩ ∧ h.succ = height b ∧ (b ↣ t_a_1),
        apply t_ih_a_1, repeat {assumption},
      cases H6, cases H6_h, cases H6_h_right, existsi (⟦●, H6_w⟧),
      split, apply is_branch.right_l, assumption,
      split, unfold height,
        have Ht : (1 ≤ height H6_w), apply ge.le, apply height_ge1,
        have Ht' : max 1 (height H6_w) = height H6_w, apply max_eq_right, assumption,
        omega,
      auto_grow
    end
  end
end


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.control.applicative
import Mathlib.control.traversable.basic
import Mathlib.PostPort

universes u l v u_1

namespace Mathlib

/-!
# Free constructions

## Main definitions

* `free_magma α`: free magma (structure with binary operation without any axioms) over alphabet `α`,
  defined inductively, with traversable instance and decidable equality.
* `magma.free_semigroup α`: free semigroup over magma `α`.
* `free_semigroup α`: free semigroup over alphabet `α`, defined as a synonym for `α × list α`
  (i.e. nonempty lists), with traversable instance and decidable equality.
* `free_semigroup_free_magma α`: isomorphism between `magma.free_semigroup (free_magma α)` and
  `free_semigroup α`.
-/

/-- Free magma over a given alphabet. -/
inductive free_magma (α : Type u)
where
| of : α → free_magma α
| mul : free_magma α → free_magma α → free_magma α

/-- Free nonabelian additive magma over a given alphabet. -/
inductive free_add_magma (α : Type u)
where
| of : α → free_add_magma α
| add : free_add_magma α → free_add_magma α → free_add_magma α

namespace free_magma

protected instance Mathlib.free_add_magma.inhabited {α : Type u} [Inhabited α] : Inhabited (free_add_magma α) :=
  { default := free_add_magma.of Inhabited.default }

protected instance Mathlib.free_add_magma.has_add {α : Type u} : Add (free_add_magma α) :=
  { add := free_add_magma.add }

@[simp] theorem Mathlib.free_add_magma.add_eq {α : Type u} (x : free_add_magma α) (y : free_add_magma α) : free_add_magma.add x y = x + y :=
  rfl

/-- Recursor for `free_magma` using `x * y` instead of `free_magma.mul x y`. -/
def Mathlib.free_add_magma.rec_on' {α : Type u} {C : free_add_magma α → Sort l} (x : free_add_magma α) (ih1 : (x : α) → C (free_add_magma.of x)) (ih2 : (x y : free_add_magma α) → C x → C y → C (x + y)) : C x :=
  free_add_magma.rec_on x ih1 ih2

end free_magma

/-- Lifts a function `α → β` to a magma homomorphism `free_magma α → β` given a magma `β`. -/
def free_magma.lift {α : Type u} {β : Type v} [Mul β] (f : α → β) : free_magma α → β :=
  sorry

/-- Lifts a function `α → β` to an additive magma homomorphism `free_add_magma α → β` given
an additive magma `β`. -/
def free_add_magma.lift {α : Type u} {β : Type v} [Add β] (f : α → β) : free_add_magma α → β :=
  sorry

namespace free_magma

@[simp] theorem Mathlib.free_add_magma.lift_of {α : Type u} {β : Type v} [Add β] (f : α → β) (x : α) : free_add_magma.lift f (free_add_magma.of x) = f x :=
  rfl

@[simp] theorem lift_mul {α : Type u} {β : Type v} [Mul β] (f : α → β) (x : free_magma α) (y : free_magma α) : lift f (x * y) = lift f x * lift f y :=
  rfl

theorem lift_unique {α : Type u} {β : Type v} [Mul β] (f : free_magma α → β) (hf : ∀ (x y : free_magma α), f (x * y) = f x * f y) : f = lift (f ∘ of) := sorry

end free_magma

/-- The unique magma homomorphism `free_magma α → free_magma β` that sends
each `of x` to `of (f x)`. -/
def free_magma.map {α : Type u} {β : Type v} (f : α → β) : free_magma α → free_magma β :=
  sorry

/-- The unique additive magma homomorphism `free_add_magma α → free_add_magma β` that sends
each `of x` to `of (f x)`. -/
def free_add_magma.map {α : Type u} {β : Type v} (f : α → β) : free_add_magma α → free_add_magma β :=
  sorry

namespace free_magma

@[simp] theorem Mathlib.free_add_magma.map_of {α : Type u} {β : Type v} (f : α → β) (x : α) : free_add_magma.map f (free_add_magma.of x) = free_add_magma.of (f x) :=
  rfl

@[simp] theorem Mathlib.free_add_magma.map_add {α : Type u} {β : Type v} (f : α → β) (x : free_add_magma α) (y : free_add_magma α) : free_add_magma.map f (x + y) = free_add_magma.map f x + free_add_magma.map f y :=
  rfl

protected instance Mathlib.free_add_magma.monad : Monad free_add_magma := sorry

/-- Recursor on `free_magma` using `pure` instead of `of`. -/
protected def Mathlib.free_add_magma.rec_on'' {α : Type u} {C : free_add_magma α → Sort l} (x : free_add_magma α) (ih1 : (x : α) → C (pure x)) (ih2 : (x y : free_add_magma α) → C x → C y → C (x + y)) : C x :=
  free_add_magma.rec_on' x ih1 ih2

@[simp] theorem Mathlib.free_add_magma.map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) : f <$> pure x = pure (f x) :=
  rfl

@[simp] theorem Mathlib.free_add_magma.map_add' {α : Type u} {β : Type u} (f : α → β) (x : free_add_magma α) (y : free_add_magma α) : f <$> (x + y) = f <$> x + f <$> y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.pure_bind {α : Type u} {β : Type u} (f : α → free_add_magma β) (x : α) : pure x >>= f = f x :=
  rfl

@[simp] theorem mul_bind {α : Type u} {β : Type u} (f : α → free_magma β) (x : free_magma α) (y : free_magma α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  rfl

@[simp] theorem Mathlib.free_add_magma.pure_seq {α : Type u} {β : Type u} {f : α → β} {x : free_add_magma α} : pure f <*> x = f <$> x :=
  rfl

@[simp] theorem mul_seq {α : Type u} {β : Type u} {f : free_magma (α → β)} {g : free_magma (α → β)} {x : free_magma α} : f * g <*> x = (f <*> x) * (g <*> x) :=
  rfl

protected instance Mathlib.free_add_magma.is_lawful_monad : is_lawful_monad free_add_magma := sorry

end free_magma

/-- `free_magma` is traversable. -/
protected def free_magma.traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u} (F : α → m β) : free_magma α → m (free_magma β) :=
  sorry

/-- `free_add_magma` is traversable. -/
protected def free_add_magma.traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u} (F : α → m β) : free_add_magma α → m (free_add_magma β) :=
  sorry

namespace free_magma

protected instance Mathlib.free_add_magma.traversable : traversable free_add_magma :=
  traversable.mk free_add_magma.traverse

@[simp] theorem Mathlib.free_add_magma.traverse_pure {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) (x : α) : traverse F (pure x) = pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_pure' {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) : traverse F ∘ pure = fun (x : α) => pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_add {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) (x : free_add_magma α) (y : free_add_magma α) : traverse F (x + y) = Add.add <$> traverse F x <*> traverse F y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_add' {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) : function.comp (traverse F) ∘ Add.add = fun (x y : free_add_magma α) => Add.add <$> traverse F x <*> traverse F y :=
  rfl

@[simp] theorem Mathlib.free_add_magma.traverse_eq {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) (x : free_add_magma α) : free_add_magma.traverse F x = traverse F x :=
  rfl

@[simp] theorem mul_map_seq {α : Type u} (x : free_magma α) (y : free_magma α) : Mul.mul <$> x <*> y = x * y :=
  rfl

protected instance Mathlib.free_add_magma.is_lawful_traversable : is_lawful_traversable free_add_magma :=
  is_lawful_traversable.mk sorry sorry sorry sorry

end free_magma

/-- Representation of an element of a free magma. -/
protected def free_magma.repr {α : Type u} [has_repr α] : free_magma α → string :=
  sorry

/-- Representation of an element of a free additive magma. -/
protected def free_add_magma.repr {α : Type u} [has_repr α] : free_add_magma α → string :=
  sorry

protected instance free_add_magma.has_repr {α : Type u} [has_repr α] : has_repr (free_add_magma α) :=
  has_repr.mk free_add_magma.repr

/-- Length of an element of a free magma. -/
def free_magma.length {α : Type u} : free_magma α → ℕ :=
  sorry

/-- Length of an element of a free additive magma. -/
def free_add_magma.length {α : Type u} : free_add_magma α → ℕ :=
  sorry

/-- Associativity relations for a magma. -/
inductive magma.free_semigroup.r (α : Type u) [Mul α] : α → α → Prop
where
| intro : ∀ (x y z : α), magma.free_semigroup.r α (x * y * z) (x * (y * z))
| left : ∀ (w x y z : α), magma.free_semigroup.r α (w * (x * y * z)) (w * (x * (y * z)))

/-- Associativity relations for an additive magma. -/
inductive add_magma.free_add_semigroup.r (α : Type u) [Add α] : α → α → Prop
where
| intro : ∀ (x y z : α), add_magma.free_add_semigroup.r α (x + y + z) (x + (y + z))
| left : ∀ (w x y z : α), add_magma.free_add_semigroup.r α (w + (x + y + z)) (w + (x + (y + z)))

namespace magma

/-- Free semigroup over a magma. -/
def free_semigroup (α : Type u) [Mul α] :=
  Quot sorry

namespace free_semigroup

/-- Embedding from magma to its free semigroup. -/
def Mathlib.add_magma.free_add_semigroup.of {α : Type u} [Add α] : α → add_magma.free_add_semigroup α :=
  Quot.mk (add_magma.free_add_semigroup.r α)

protected instance Mathlib.add_magma.free_add_semigroup.inhabited {α : Type u} [Add α] [Inhabited α] : Inhabited (add_magma.free_add_semigroup α) :=
  { default := add_magma.free_add_semigroup.of Inhabited.default }

protected theorem Mathlib.add_magma.free_add_semigroup.induction_on {α : Type u} [Add α] {C : add_magma.free_add_semigroup α → Prop} (x : add_magma.free_add_semigroup α) (ih : ∀ (x : α), C (add_magma.free_add_semigroup.of x)) : C x :=
  quot.induction_on x ih

theorem of_mul_assoc {α : Type u} [Mul α] (x : α) (y : α) (z : α) : of (x * y * z) = of (x * (y * z)) :=
  quot.sound (r.intro x y z)

theorem of_mul_assoc_left {α : Type u} [Mul α] (w : α) (x : α) (y : α) (z : α) : of (w * (x * y * z)) = of (w * (x * (y * z))) :=
  quot.sound (r.left w x y z)

theorem of_mul_assoc_right {α : Type u} [Mul α] (w : α) (x : α) (y : α) (z : α) : of (w * x * y * z) = of (w * (x * y) * z) := sorry

protected instance semigroup {α : Type u} [Mul α] : semigroup (free_semigroup α) :=
  semigroup.mk
    (fun (x y : free_semigroup α) =>
      quot.lift_on x (fun (p : α) => quot.lift_on y (fun (q : α) => Quot.mk (r α) (p * q)) sorry) sorry)
    sorry

theorem Mathlib.add_magma.free_add_semigroup.of_add {α : Type u} [Add α] (x : α) (y : α) : add_magma.free_add_semigroup.of (x + y) = add_magma.free_add_semigroup.of x + add_magma.free_add_semigroup.of y :=
  rfl

/-- Lifts a magma homomorphism `α → β` to a semigroup homomorphism `magma.free_semigroup α → β`
given a semigroup `β`. -/
def lift {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β) (hf : ∀ (x y : α), f (x * y) = f x * f y) : free_semigroup α → β :=
  Quot.lift f sorry

@[simp] theorem lift_of {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β) {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : α) : lift f hf (of x) = f x :=
  rfl

@[simp] theorem lift_mul {α : Type u} [Mul α] {β : Type v} [semigroup β] (f : α → β) {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : free_semigroup α) (y : free_semigroup α) : lift f hf (x * y) = lift f hf x * lift f hf y :=
  quot.induction_on x fun (p : α) => quot.induction_on y fun (q : α) => hf p q

theorem Mathlib.add_magma.free_add_semigroup.lift_unique {α : Type u} [Add α] {β : Type v} [add_semigroup β] (f : add_magma.free_add_semigroup α → β) (hf : ∀ (x y : add_magma.free_add_semigroup α), f (x + y) = f x + f y) : f =
  add_magma.free_add_semigroup.lift (f ∘ add_magma.free_add_semigroup.of)
    fun (p q : α) => hf (add_magma.free_add_semigroup.of p) (add_magma.free_add_semigroup.of q) :=
  funext fun (x : add_magma.free_add_semigroup α) => quot.induction_on x fun (p : α) => rfl

/-- From a magma homomorphism `α → β` to a semigroup homomorphism
`magma.free_semigroup α → magma.free_semigroup β`. -/
def Mathlib.add_magma.free_add_semigroup.map {α : Type u} [Add α] {β : Type v} [Add β] (f : α → β) (hf : ∀ (x y : α), f (x + y) = f x + f y) : add_magma.free_add_semigroup α → add_magma.free_add_semigroup β :=
  add_magma.free_add_semigroup.lift (add_magma.free_add_semigroup.of ∘ f) sorry

@[simp] theorem Mathlib.add_magma.free_add_semigroup.map_of {α : Type u} [Add α] {β : Type v} [Add β] (f : α → β) {hf : ∀ (x y : α), f (x + y) = f x + f y} (x : α) : add_magma.free_add_semigroup.map f hf (add_magma.free_add_semigroup.of x) = add_magma.free_add_semigroup.of (f x) :=
  rfl

@[simp] theorem map_mul {α : Type u} [Mul α] {β : Type v} [Mul β] (f : α → β) {hf : ∀ (x y : α), f (x * y) = f x * f y} (x : free_semigroup α) (y : free_semigroup α) : map f hf (x * y) = map f hf x * map f hf y :=
  lift_mul (of ∘ f) x y

end free_semigroup

end magma

/-- Free semigroup over a given alphabet.
(Note: In this definition, the free semigroup does not contain the empty word.) -/
def free_semigroup (α : Type u) :=
  α × List α

namespace free_semigroup

protected instance semigroup {α : Type u} : semigroup (free_semigroup α) :=
  semigroup.mk (fun (L1 L2 : free_semigroup α) => (prod.fst L1, prod.snd L1 ++ prod.fst L2 :: prod.snd L2)) sorry

/-- The embedding `α → free_semigroup α`. -/
def Mathlib.free_add_semigroup.of {α : Type u} (x : α) : free_add_semigroup α :=
  (x, [])

protected instance Mathlib.free_add_semigroup.inhabited {α : Type u} [Inhabited α] : Inhabited (free_add_semigroup α) :=
  { default := free_add_semigroup.of Inhabited.default }

/-- Recursor for free semigroup using `of` and `*`. -/
protected def Mathlib.free_add_semigroup.rec_on {α : Type u} {C : free_add_semigroup α → Sort l} (x : free_add_semigroup α) (ih1 : (x : α) → C (free_add_semigroup.of x)) (ih2 : (x : α) → (y : free_add_semigroup α) → C (free_add_semigroup.of x) → C y → C (free_add_semigroup.of x + y)) : C x :=
  prod.rec_on x
    fun (f : α) (s : List α) =>
      list.rec_on s ih1
        (fun (hd : α) (tl : List α) (ih : (_a : α) → C (_a, tl)) (f : α) => ih2 f (hd, tl) (ih1 f) (ih hd)) f

end free_semigroup

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_semigroup.lift' {α : Type u} {β : Type v} [semigroup β] (f : α → β) : α → List α → β :=
  sorry

/-- Auxiliary function for `free_semigroup.lift`. -/
def free_add_semigroup.lift' {α : Type u} {β : Type v} [add_semigroup β] (f : α → β) : α → List α → β :=
  sorry

namespace free_semigroup

/-- Lifts a function `α → β` to a semigroup homomorphism `free_semigroup α → β` given
a semigroup `β`. -/
def lift {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : free_semigroup α) : β :=
  lift' f (prod.fst x) (prod.snd x)

@[simp] theorem lift_of {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : α) : lift f (of x) = f x :=
  rfl

theorem lift_of_mul {α : Type u} {β : Type v} [semigroup β] (f : α → β) (x : α) (y : free_semigroup α) : lift f (of x * y) = f x * lift f y :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.lift_add {α : Type u} {β : Type v} [add_semigroup β] (f : α → β) (x : free_add_semigroup α) (y : free_add_semigroup α) : free_add_semigroup.lift f (x + y) = free_add_semigroup.lift f x + free_add_semigroup.lift f y := sorry

theorem Mathlib.free_add_semigroup.lift_unique {α : Type u} {β : Type v} [add_semigroup β] (f : free_add_semigroup α → β) (hf : ∀ (x y : free_add_semigroup α), f (x + y) = f x + f y) : f = free_add_semigroup.lift (f ∘ free_add_semigroup.of) := sorry

/-- The unique semigroup homomorphism that sends `of x` to `of (f x)`. -/
def Mathlib.free_add_semigroup.map {α : Type u} {β : Type v} (f : α → β) : free_add_semigroup α → free_add_semigroup β :=
  free_add_semigroup.lift (free_add_semigroup.of ∘ f)

@[simp] theorem Mathlib.free_add_semigroup.map_of {α : Type u} {β : Type v} (f : α → β) (x : α) : free_add_semigroup.map f (free_add_semigroup.of x) = free_add_semigroup.of (f x) :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.map_add {α : Type u} {β : Type v} (f : α → β) (x : free_add_semigroup α) (y : free_add_semigroup α) : free_add_semigroup.map f (x + y) = free_add_semigroup.map f x + free_add_semigroup.map f y :=
  free_add_semigroup.lift_add (free_add_semigroup.of ∘ f) x y

protected instance Mathlib.free_add_semigroup.monad : Monad free_add_semigroup := sorry

/-- Recursor that uses `pure` instead of `of`. -/
def rec_on' {α : Type u} {C : free_semigroup α → Sort l} (x : free_semigroup α) (ih1 : (x : α) → C (pure x)) (ih2 : (x : α) → (y : free_semigroup α) → C (pure x) → C y → C (pure x * y)) : C x :=
  free_semigroup.rec_on x ih1 ih2

@[simp] theorem map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) : f <$> pure x = pure (f x) :=
  rfl

@[simp] theorem map_mul' {α : Type u} {β : Type u} (f : α → β) (x : free_semigroup α) (y : free_semigroup α) : f <$> (x * y) = f <$> x * f <$> y :=
  map_mul f x y

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_semigroup β) (x : α) : pure x >>= f = f x :=
  rfl

@[simp] theorem mul_bind {α : Type u} {β : Type u} (f : α → free_semigroup β) (x : free_semigroup α) (y : free_semigroup α) : x * y >>= f = (x >>= f) * (y >>= f) :=
  lift_mul f x y

@[simp] theorem Mathlib.free_add_semigroup.pure_seq {α : Type u} {β : Type u} {f : α → β} {x : free_add_semigroup α} : pure f <*> x = f <$> x :=
  rfl

@[simp] theorem mul_seq {α : Type u} {β : Type u} {f : free_semigroup (α → β)} {g : free_semigroup (α → β)} {x : free_semigroup α} : f * g <*> x = (f <*> x) * (g <*> x) :=
  mul_bind (fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_semigroup α) => lift (of ∘ f) x) α β _x x) f g

protected instance Mathlib.free_add_semigroup.is_lawful_monad : is_lawful_monad free_add_semigroup := sorry

/-- `free_semigroup` is traversable. -/
protected def Mathlib.free_add_semigroup.traverse {m : Type u → Type u} [Applicative m] {α : Type u} {β : Type u} (F : α → m β) (x : free_add_semigroup α) : m (free_add_semigroup β) :=
  free_add_semigroup.rec_on' x (fun (x : α) => pure <$> F x)
    fun (x : α) (y : free_add_semigroup α) (ihx ihy : m (free_add_semigroup β)) => Add.add <$> ihx <*> ihy

protected instance Mathlib.free_add_semigroup.traversable : traversable free_add_semigroup :=
  traversable.mk free_add_semigroup.traverse

@[simp] theorem traverse_pure {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) (x : α) : traverse F (pure x) = pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.traverse_pure' {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) : traverse F ∘ pure = fun (x : α) => pure <$> F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.traverse_add {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) [is_lawful_applicative m] (x : free_add_semigroup α) (y : free_add_semigroup α) : traverse F (x + y) = Add.add <$> traverse F x <*> traverse F y := sorry

@[simp] theorem Mathlib.free_add_semigroup.traverse_add' {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) [is_lawful_applicative m] : function.comp (traverse F) ∘ Add.add = fun (x y : free_add_semigroup α) => Add.add <$> traverse F x <*> traverse F y :=
  funext fun (x : free_add_semigroup α) => funext fun (y : free_add_semigroup α) => free_add_semigroup.traverse_add F x y

@[simp] theorem Mathlib.free_add_semigroup.traverse_eq {α : Type u} {β : Type u} {m : Type u → Type u} [Applicative m] (F : α → m β) (x : free_add_semigroup α) : free_add_semigroup.traverse F x = traverse F x :=
  rfl

@[simp] theorem Mathlib.free_add_semigroup.add_map_seq {α : Type u} (x : free_add_semigroup α) (y : free_add_semigroup α) : Add.add <$> x <*> y = x + y :=
  rfl

protected instance Mathlib.free_add_semigroup.is_lawful_traversable : is_lawful_traversable free_add_semigroup :=
  is_lawful_traversable.mk sorry sorry sorry sorry

protected instance Mathlib.free_add_semigroup.decidable_eq {α : Type u} [DecidableEq α] : DecidableEq (free_add_semigroup α) :=
  prod.decidable_eq

end free_semigroup

/-- Isomorphism between `magma.free_semigroup (free_magma α)` and `free_semigroup α`. -/
def free_add_semigroup_free_add_magma (α : Type u) : add_magma.free_add_semigroup (free_add_magma α) ≃ free_add_semigroup α :=
  equiv.mk (add_magma.free_add_semigroup.lift (free_add_magma.lift free_add_semigroup.of) sorry)
    (free_add_semigroup.lift (add_magma.free_add_semigroup.of ∘ free_add_magma.of)) sorry sorry

@[simp] theorem free_semigroup_free_magma_mul {α : Type u} (x : magma.free_semigroup (free_magma α)) (y : magma.free_semigroup (free_magma α)) : coe_fn (free_semigroup_free_magma α) (x * y) =
  coe_fn (free_semigroup_free_magma α) x * coe_fn (free_semigroup_free_magma α) y :=
  magma.free_semigroup.lift_mul (free_magma.lift free_semigroup.of) x y


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.limits.preserves.basic
import category_theory.limits.types
import category_theory.limits.shapes.wide_pullbacks
import category_theory.limits.shapes.multiequalizer
import category_theory.concrete_category.elementwise

/-!
# Facts about (co)limits of functors into concrete categories
-/

universes w v u

open category_theory

namespace category_theory.limits

local attribute [instance] concrete_category.has_coe_to_fun concrete_category.has_coe_to_sort

section limits

variables {C : Type u} [category.{v} C] [concrete_category.{v} C]
  {J : Type v} [small_category J] (F : J ⥤ C) [preserves_limit F (forget C)]

lemma concrete.to_product_injective_of_is_limit {D : cone F} (hD : is_limit D) :
  function.injective (λ (x : D.X) (j : J), D.π.app j x) :=
begin
  let E := (forget C).map_cone D,
  let hE : is_limit E := is_limit_of_preserves _ hD,
  let G := types.limit_cone (F ⋙ forget C),
  let hG := types.limit_cone_is_limit (F ⋙ forget C),
  let T : E.X ≅ G.X := hE.cone_point_unique_up_to_iso hG,
  change function.injective (T.hom ≫ (λ x j, G.π.app j x)),
  have h : function.injective T.hom,
  { intros a b h,
    suffices : T.inv (T.hom a) = T.inv (T.hom b), by simpa,
    rw h },
  suffices : function.injective (λ (x : G.X) j, G.π.app j x),
    by exact this.comp h,
  apply subtype.ext,
end

lemma concrete.is_limit_ext {D : cone F} (hD : is_limit D) (x y : D.X) :
  (∀ j, D.π.app j x = D.π.app j y) → x = y :=
λ h, concrete.to_product_injective_of_is_limit _ hD (funext h)

lemma concrete.limit_ext [has_limit F] (x y : limit F) :
  (∀ j, limit.π F j x = limit.π F j y) → x = y :=
concrete.is_limit_ext F (limit.is_limit _) _ _

section wide_pullback

open wide_pullback
open wide_pullback_shape

lemma concrete.wide_pullback_ext {B : C} {ι : Type*} {X : ι → C} (f : Π j : ι, X j ⟶ B)
  [has_wide_pullback B X f] [preserves_limit (wide_cospan B X f) (forget C)]
  (x y : wide_pullback B X f) (h₀ : base f x = base f y)
  (h : ∀ j, π f j x = π f j y) : x = y :=
begin
  apply concrete.limit_ext,
  rintro (_|j),
  { exact h₀ },
  { apply h }
end

lemma concrete.wide_pullback_ext' {B : C} {ι : Type*} [nonempty ι]
  {X : ι → C} (f : Π j : ι, X j ⟶ B) [has_wide_pullback B X f]
  [preserves_limit (wide_cospan B X f) (forget C)]
  (x y : wide_pullback B X f) (h : ∀ j, π f j x = π f j y) : x = y :=
begin
  apply concrete.wide_pullback_ext _ _ _ _ h,
  inhabit ι,
  simp only [← π_arrow f (arbitrary _), comp_apply, h],
end

end wide_pullback

section multiequalizer

lemma concrete.multiequalizer_ext {I : multicospan_index C} [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] (x y : multiequalizer I)
  (h : ∀ (t : I.L), multiequalizer.ι I t x = multiequalizer.ι I t y) : x = y :=
begin
  apply concrete.limit_ext,
  rintros (a|b),
  { apply h },
  { rw [← limit.w I.multicospan (walking_multicospan.hom.fst b),
      comp_apply, comp_apply, h] }
end

/-- An auxiliary equivalence to be used in `multiequalizer_equiv` below.-/
def concrete.multiequalizer_equiv_aux (I : multicospan_index C) :
  (I.multicospan ⋙ (forget C)).sections ≃
  { x : Π (i : I.L), I.left i // ∀ (i : I.R), I.fst i (x _) = I.snd i (x _) } :=
{ to_fun := λ x, ⟨λ i, x.1 (walking_multicospan.left _), λ i, begin
    have a := x.2 (walking_multicospan.hom.fst i),
    have b := x.2 (walking_multicospan.hom.snd i),
    rw ← b at a,
    exact a,
  end⟩,
  inv_fun := λ x,
  { val := λ j,
    match j with
    | walking_multicospan.left a := x.1 _
    | walking_multicospan.right b := I.fst b (x.1 _)
    end,
    property := begin
      rintros (a|b) (a'|b') (f|f|f),
      { change (I.multicospan.map (𝟙 _)) _ = _, simp },
      { refl },
      { dsimp, erw ← x.2 b', refl },
      { change (I.multicospan.map (𝟙 _)) _ = _, simp },
    end },
  left_inv := begin
    intros x, ext (a|b),
    { refl },
    { change _ = x.val _,
      rw ← x.2 (walking_multicospan.hom.fst b),
      refl }
  end,
  right_inv := by { intros x, ext i, refl } }

/-- The equivalence between the noncomputable multiequalizer and
and the concrete multiequalizer. -/
noncomputable
def concrete.multiequalizer_equiv (I : multicospan_index C) [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] : (multiequalizer I : C) ≃
    { x : Π (i : I.L), I.left i // ∀ (i : I.R), I.fst i (x _) = I.snd i (x _) } :=
let h1 := (limit.is_limit I.multicospan),
    h2 := (is_limit_of_preserves (forget C) h1),
    E := h2.cone_point_unique_up_to_iso (types.limit_cone_is_limit _) in
equiv.trans E.to_equiv (concrete.multiequalizer_equiv_aux I)

@[simp]
lemma concrete.multiequalizer_equiv_apply (I : multicospan_index C) [has_multiequalizer I]
  [preserves_limit I.multicospan (forget C)] (x : multiequalizer I) (i : I.L) :
  ((concrete.multiequalizer_equiv I) x : Π (i : I.L), I.left i) i = multiequalizer.ι I i x := rfl

end multiequalizer

-- TODO: Add analogous lemmas about products and equalizers.

end limits

section colimits

variables {C : Type u} [category.{v} C] [concrete_category.{v} C]
  {J : Type v} [small_category J] (F : J ⥤ C) [preserves_colimit F (forget C)]

lemma concrete.from_union_surjective_of_is_colimit {D : cocone F} (hD : is_colimit D) :
  let ff : (Σ (j : J), F.obj j) → D.X := λ a, D.ι.app a.1 a.2 in function.surjective ff :=
begin
  intro ff,
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  suffices : function.surjective (TX.hom ∘ ff),
  { intro a,
    obtain ⟨b, hb⟩ := this (TX.hom a),
    refine ⟨b, _⟩,
    apply_fun TX.inv at hb,
    change (TX.hom ≫ TX.inv) (ff b) = (TX.hom ≫ TX.inv) _ at hb,
    simpa only [TX.hom_inv_id] using hb },
  have : TX.hom ∘ ff = λ a, G.ι.app a.1 a.2,
  { ext a,
    change (E.ι.app a.1 ≫ hE.desc G) a.2 = _,
    rw hE.fac },
  rw this,
  rintro ⟨⟨j,a⟩⟩,
  exact ⟨⟨j,a⟩,rfl⟩,
end

lemma concrete.is_colimit_exists_rep {D : cocone F} (hD : is_colimit D) (x : D.X) :
  ∃ (j : J) (y : F.obj j), D.ι.app j y = x :=
begin
  obtain ⟨a, rfl⟩ := concrete.from_union_surjective_of_is_colimit F hD x,
  exact ⟨a.1, a.2, rfl⟩,
end

lemma concrete.colimit_exists_rep [has_colimit F] (x : colimit F) :
  ∃ (j : J) (y : F.obj j), colimit.ι F j y = x :=
concrete.is_colimit_exists_rep F (colimit.is_colimit _) x

lemma concrete.is_colimit_rep_eq_of_exists {D : cocone F} {i j : J} (hD : is_colimit D)
  (x : F.obj i) (y : F.obj j) (h : ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y) :
  D.ι.app i x = D.ι.app j y :=
begin
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  apply_fun TX.hom,
  swap, { suffices : function.bijective TX.hom, by exact this.1,
    rw ← is_iso_iff_bijective, apply is_iso.of_iso },
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y,
  erw [T.hom.w, T.hom.w],
  obtain ⟨k, f, g, h⟩ := h,
  have : G.ι.app i x = (G.ι.app k (F.map f x) : G.X) := quot.sound ⟨f,rfl⟩,
  rw [this, h],
  symmetry,
  exact quot.sound ⟨g,rfl⟩,
end

lemma concrete.colimit_rep_eq_of_exists [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) (h : ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y) :
  colimit.ι F i x = colimit.ι F j y :=
concrete.is_colimit_rep_eq_of_exists F (colimit.is_colimit _) x y h

section filtered_colimits

variable [is_filtered J]

lemma concrete.is_colimit_exists_of_rep_eq {D : cocone F} {i j : J} (hD : is_colimit D)
  (x : F.obj i) (y : F.obj j) (h : D.ι.app _ x = D.ι.app _ y) :
  ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
begin
  let E := (forget C).map_cocone D,
  let hE : is_colimit E := is_colimit_of_preserves _ hD,
  let G := types.colimit_cocone (F ⋙ forget C),
  let hG := types.colimit_cocone_is_colimit (F ⋙ forget C),
  let T : E ≅ G := hE.unique_up_to_iso hG,
  let TX : E.X ≅ G.X := (cocones.forget _).map_iso T,
  apply_fun TX.hom at h,
  change (E.ι.app i ≫ TX.hom) x = (E.ι.app j ≫ TX.hom) y at h,
  erw [T.hom.w, T.hom.w] at h,
  replace h := quot.exact _ h,
  suffices : ∀ (a b : Σ j, F.obj j)
    (h : eqv_gen (limits.types.quot.rel (F ⋙ forget C)) a b),
    ∃ k (f : a.1 ⟶ k) (g : b.1 ⟶ k), F.map f a.2 = F.map g b.2,
  { exact this ⟨i,x⟩ ⟨j,y⟩ h },
  intros a b h,
  induction h,
  case eqv_gen.rel : x y hh
  { obtain ⟨e,he⟩ := hh,
    use [y.1, e, 𝟙 _],
    simpa using he.symm },
  case eqv_gen.refl : x { use [x.1, 𝟙 _, 𝟙 _, rfl] },
  case eqv_gen.symm : x y _ hh
  { obtain ⟨k, f, g, hh⟩ := hh,
    use [k, g, f, hh.symm] },
  case eqv_gen.trans : x y z _ _ hh1 hh2
  { obtain ⟨k1, f1, g1, h1⟩ := hh1,
    obtain ⟨k2, f2, g2, h2⟩ := hh2,
    let k0 : J := is_filtered.max k1 k2,
    let e1 : k1 ⟶ k0 := is_filtered.left_to_max _ _,
    let e2 : k2 ⟶ k0 := is_filtered.right_to_max _ _,
    let k : J := is_filtered.coeq (g1 ≫ e1) (f2 ≫ e2),
    let e : k0 ⟶ k := is_filtered.coeq_hom _ _,
    use [k, f1 ≫ e1 ≫ e, g2 ≫ e2 ≫ e],
    simp only [F.map_comp, comp_apply, h1, ← h2],
    simp only [← comp_apply, ← F.map_comp],
    rw is_filtered.coeq_condition },
end

theorem concrete.is_colimit_rep_eq_iff_exists {D : cocone F} {i j : J}
  (hD : is_colimit D) (x : F.obj i) (y : F.obj j) :
  D.ι.app i x = D.ι.app j y ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
⟨concrete.is_colimit_exists_of_rep_eq _ hD _ _, concrete.is_colimit_rep_eq_of_exists _ hD _ _⟩

lemma concrete.colimit_exists_of_rep_eq [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) (h : colimit.ι F _ x = colimit.ι F _ y) :
  ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
concrete.is_colimit_exists_of_rep_eq F (colimit.is_colimit _) x y h

theorem concrete.colimit_rep_eq_iff_exists [has_colimit F] {i j : J}
  (x : F.obj i) (y : F.obj j) :
  colimit.ι F i x = colimit.ι F j y ↔ ∃ k (f : i ⟶ k) (g : j ⟶ k), F.map f x = F.map g y :=
⟨concrete.colimit_exists_of_rep_eq _ _ _, concrete.colimit_rep_eq_of_exists _ _ _⟩

end filtered_colimits

section wide_pushout

open wide_pushout
open wide_pushout_shape

lemma concrete.wide_pushout_exists_rep {B : C} {α : Type*} {X : α → C} (f : Π j : α, B ⟶ X j)
  [has_wide_pushout B X f] [preserves_colimit (wide_span B X f) (forget C)]
  (x : wide_pushout B X f) : (∃ y : B, head f y = x) ∨ (∃ (i : α) (y : X i), ι f i y = x) :=
begin
  obtain ⟨_ | j, y, rfl⟩ := concrete.colimit_exists_rep _ x,
  { use y },
  { right,
    use [j,y] }
end

lemma concrete.wide_pushout_exists_rep' {B : C} {α : Type*} [nonempty α] {X : α → C}
  (f : Π j : α, B ⟶ X j) [has_wide_pushout B X f]
  [preserves_colimit (wide_span B X f) (forget C)] (x : wide_pushout B X f) :
  ∃ (i : α) (y : X i), ι f i y = x :=
begin
  rcases concrete.wide_pushout_exists_rep f x with ⟨y, rfl⟩ | ⟨i, y, rfl⟩,
  { inhabit α,
    use [arbitrary _, f _ y],
    simp only [← arrow_ι _ (arbitrary α), comp_apply] },
  { use [i,y] }
end

end wide_pushout

-- TODO: Add analogous lemmas about coproducts and coequalizers.

end colimits

end category_theory.limits


import data.mv_polynomial.basic
import .general_lemmas.mv_X_mul
import .general_lemmas.single_antidiagonal
import .general_lemmas.mul_sum_symm

section

open mv_polynomial

universes u

@[simp] lemma eq_zero_of_zero_eq (R : Type u) [has_zero R] (r : R) : 0 = r ↔ r = 0 :=
begin
  exact eq_comm,
end

@[simp] lemma zero_sub_eq_iff (R : Type u) [add_comm_group R] (a b : R) : 0 - a = b ↔ a + b = 0 :=
begin
  split,
  { intro h, rw <-h, abel, },
  { intro h, rw <-h, abel, },
end

run_cmd mk_simp_attr `integral_domain_simp
run_cmd tactic.add_doc_string `simp_attr.integral_domain_simp "Attribute for lemmas that are useful in simplifying systems of equations in an integral domain"

run_cmd mk_simp_attr `polynomial_nf
run_cmd tactic.add_doc_string `simp_attr.polynomial_nf "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf] polynomial.eval₂
attribute [polynomial_nf] polynomial.sum
attribute [polynomial_nf] finsupp.sum
attribute [polynomial_nf] mul_add
attribute [polynomial_nf] add_mul
attribute [polynomial_nf] finset.sum_mul
attribute [polynomial_nf] finset.mul_sum
attribute [polynomial_nf] finset.sum_add_distrib

attribute [polynomial_nf] mul_assoc

attribute [polynomial_nf] finsupp.smul_sum
attribute [polynomial_nf] mul_smul_comm
attribute [polynomial_nf] smul_add
attribute [polynomial_nf] mul_smul
attribute [polynomial_nf] smul_mul_assoc

run_cmd mk_simp_attr `polynomial_nf_2
run_cmd tactic.add_doc_string `simp_attr.polynomial_nf_2 "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf_2] mul_add
attribute [polynomial_nf_2] add_mul
attribute [polynomial_nf_2] finset.sum_add_distrib
attribute [polynomial_nf_2] sum_X_mul
attribute [polynomial_nf_2] sum_C_mul
attribute [polynomial_nf_2] rearrange_constants_right
attribute [polynomial_nf_2] rearrange_constants_right_with_extra
attribute [polynomial_nf_2] rearrange_sums_right
attribute [polynomial_nf_2] rearrange_sums_right_with_extra
attribute [polynomial_nf_2] C_mul_C
attribute [polynomial_nf_2] finset.sum_hom
attribute [polynomial_nf_2] mv_polynomial.smul_eq_C_mul
attribute [polynomial_nf_2] mul_assoc
attribute [polynomial_nf_2] finsupp.smul_sum
attribute [polynomial_nf_2] mul_smul_comm
attribute [polynomial_nf_2] smul_add
attribute [polynomial_nf_2] mul_smul
attribute [polynomial_nf_2] smul_mul_assoc

run_cmd mk_simp_attr `polynomial_nf_3
run_cmd tactic.add_doc_string `simp_attr.polynomial_nf_3 "Attribute for lemmas that are used in the conversion of mv_polynomial expressions to a normal form consisting of adds of sums of muls of mv_polynomials"

attribute [polynomial_nf_3] mul_add
attribute [polynomial_nf_3] add_mul
attribute [polynomial_nf_3] finset.sum_add_distrib
-- attribute [polynomial_nf_3] sum_X_mul
-- attribute [polynomial_nf_3] sum_C_mul
attribute [polynomial_nf_3] mul_sum_symm
attribute [polynomial_nf_3] rearrange_constants_right
attribute [polynomial_nf_3] rearrange_constants_right_with_extra
attribute [polynomial_nf_3] rearrange_sums_right
attribute [polynomial_nf_3] rearrange_sums_right_with_extra
attribute [polynomial_nf_3] C_mul_C
attribute [polynomial_nf_3] finset.sum_hom
attribute [polynomial_nf_3] mv_polynomial.smul_eq_C_mul
attribute [polynomial_nf_3] mul_assoc
-- attribute [polynomial_nf_3] finsupp.smul_sum
-- attribute [polynomial_nf_3] mul_smul_comm
-- attribute [polynomial_nf_3] smul_add
-- attribute [polynomial_nf_3] mul_smul
-- attribute [polynomial_nf_3] smul_mul_assoc

run_cmd mk_simp_attr `rearrange
run_cmd tactic.add_doc_string `simp_attr.rearrange "TODO a few rearrangement lemmas"

-- attribute [rearrange] rearrange1
-- attribute [rearrange] rearrange2
-- attribute [rearrange] rearrange_constants_right
-- attribute [rearrange] rearrange_smul_right

-- attribute [polynomial_nf] mv_polynomial.smul_eq_C_mul

run_cmd mk_simp_attr `coeff_simp
run_cmd tactic.add_doc_string `simp_attr.coeff_simp "Attribute for lemmas that are used in the simplification of statements about coefficients of mv_polynomials"

-- attribute [coeff_simp] mv_polynomial.coeff_mul
-- attribute [coeff_simp] single_1_antidiagonal
-- attribute [coeff_simp] single_2_antidiagonal
-- attribute [coeff_simp] finset.range
-- attribute [coeff_simp] finset.image

-- attribute [coeff_simp] mv_polynomial.X_pow_eq_single
attribute [coeff_simp] mv_polynomial.coeff_sum
attribute [coeff_simp] mv_polynomial.coeff_add
attribute [coeff_simp] mv_polynomial.coeff_smul

attribute [coeff_simp] mv_polynomial.coeff_C_mul
attribute [coeff_simp] mv_polynomial.coeff_monomial
attribute [coeff_simp] mv_polynomial.coeff_mul_X'
attribute [coeff_simp] mv_polynomial.coeff_X'
attribute [coeff_simp] coeff_X_mul'
attribute [coeff_simp] coeff_X_pow_mul'
attribute [coeff_simp] mv_polynomial.coeff_C
attribute [coeff_simp] mv_polynomial.coeff_X_pow

run_cmd mk_simp_attr `finsupp_eq
run_cmd tactic.add_doc_string `simp_attr.finsupp_eq "Attribute for lemmas that are used in the simplification of equality statements between finsupps"

attribute [finsupp_eq] finsupp.mem_support_iff
attribute [finsupp_eq] finsupp.single_apply
attribute [finsupp_eq] finsupp.add_apply
attribute [finsupp_eq] finsupp.sub_apply

-- Verison without polynomial manipulation
attribute [integral_domain_simp] add_zero zero_add mul_zero zero_mul mul_one one_mul false_or or_false true_or or_true eq_self_iff_true ne.def mul_eq_zero eq_zero_of_zero_eq one_ne_zero mul_ne_zero_iff zero_sub_eq_iff not_true not_false

run_cmd mk_simp_attr `finsupp_simp
run_cmd tactic.add_doc_string `simp_attr.finsupp_simp "Attribute for lemmas that are useful in finsupp statements"

lemma zero_ne_succ (n : ℕ) : 0 ≠ nat.succ n := (nat.succ_ne_zero n).symm

-- Verison without polynomial manipulation
attribute [finsupp_simp] nat.one_ne_zero finsupp.single_eq_of_ne finsupp.single_eq_same add_zero if_true if_false  pi.add_apply pi.zero_apply
  eq_self_iff_true not_true eq_zero_of_zero_eq if_false ne.def nat.sub_zero zero_add not_false_iff bit0_eq_zero
  and_self finsupp.coe_nat_sub and_false finsupp.coe_add false_and pi.sub_apply finsupp.coe_zero
    nat.succ_ne_zero zero_ne_succ nat.succ_inj' -- To simplify nat equalities
  and_true true_and

end


import .order_emb

open_locale classical

lemma subseq.reachable_trans (S₀ S₁ : subseq) (h: ∀ i : ℕ, ∃ k : ℕ, S₀ k = S₁ i):
∃ T : subseq, S₁ = rel_embedding.trans T S₀:=
begin
  choose! f hf using h, use f, intros a b abeq, have:= hf b, rw abeq.symm at this,
  rw hf a at this, apply S₁.inj' this, intros a b, dsimp, have:=S₁.map_rel_iff',
   nth_rewrite 1 ← this, show f a ≤ f b ↔ S₁ a ≤ S₁ b, rw ←hf a, rw ← hf b,
   exact S₀.map_rel_iff'.symm, exact a, exact b, ext,
   simp [hf x],
end

lemma subseq.trans_refl {S : subseq} : S = (@rel_embedding.refl ℕ (≤)).trans S:=
begin
  ext, simp,
end

lemma subseq.trans_assoc {a b c : subseq} :
a.trans (b.trans c) = (a.trans b).trans c:=
begin
  ext, simp,
end

theorem constraints_apply (constraints: ℕ → subseq → Prop)
(constraints_stable: ∀ g : ℕ, ∀ S T : subseq, constraints g S → constraints g (rel_embedding.trans T S))
(constraints_reachable: ∀ (g : ℕ) (S : subseq), ∃ (T : subseq),
  (∀ i ≤ g, T i = i) ∧ constraints g (rel_embedding.trans T S)) :
  ∀ S : subseq, ∃ T : subseq, ∀ g, constraints g (rel_embedding.trans T S) :=
begin
  intro S,
  -- set s0 := @rel_embedding.refl ℕ (≤),

  choose! f hf using constraints_reachable,

  set f' : (ℕ × subseq) → (ℕ × subseq) := λ p, ⟨p.1 + 1, rel_embedding.trans (f p.1 p.2) p.2⟩ with hf',

  set seqs : ℕ → subseq := λ i, (f'^[i] ⟨0,S⟩).2 with h_seqs,

  set the_seq : ℕ → ℕ := λ i, (seqs i) i with h_the_seq,
  have f'_iterate_count: ∀ n, (f'^[n] (0, S)).1=n,
    { intro n, induction n with n hn,
    rw function.iterate_zero f', refl, rw function.iterate_succ_apply' f' n _,
    nth_rewrite 0 hf', dsimp, rw hn,
    },
  have hterm : ∀ i j, i ≤ j → the_seq i = (seqs j) i,
  { intros i j hle,
    simp_rw [h_the_seq, h_seqs],
    suffices: ∀ d i j, i ≤ j → j-i=d → ((f'^[i] (0, S)).snd) i = ((f'^[j] (0, S)).snd) i,
    apply this (j-i) i j hle, refl, intro d, induction d with d hd, intros a b aleb asb,
    have aeb: a = b, apply le_antisymm aleb (nat.sub_eq_zero_iff_le.1 asb), rw aeb,
    intros a b aleb abdiff, have a_eq_a_d:= hd a (a+d) (nat.le_add_right _ _) _,
    swap, rw add_comm, rw nat.add_sub_cancel d a, rw a_eq_a_d,
    rw nat.sub_eq_iff_eq_add aleb at abdiff, rw nat.succ_add at abdiff,
    rw add_comm at abdiff, rw abdiff, rw function.iterate_succ_apply' f' (a+d) _,
   nth_rewrite 1 hf', dsimp, rw f'_iterate_count (a+d),
    have:= (hf (a + d) (f'^[a + d] (0, S)).2).1 a (nat.le_add_right a d), rw this,
  },
  set S₁:subseq :={to_fun := the_seq, inj' :=
    begin
      intros i j hij,
    wlog hle: i ≤ j,
    rw [hterm i j hle, hterm j j rfl.le] at hij, apply (seqs j).inj' hij,
    end
  ,
  map_rel_iff' :=
    begin
      dsimp,
    intros i j, wlog hle: i ≤ j,
     rw [hterm i j hle, hterm j j rfl.le], exact (seqs j).map_rel_iff',
     rw [hterm j i hle, hterm i i rfl.le], exact (seqs i).map_rel_iff',
    end,
  },
  have constr: ∀ i, constraints i (f'^[i.succ] (0, S)).2,
  intro i, rw function.iterate_succ_apply' f' i (0, S), nth_rewrite 0 hf',
  dsimp, rw f'_iterate_count i, apply (hf i _).2,
  have seqs_trans: ∀ i j, i ≤ j → ∃ T : subseq, seqs j = rel_embedding.trans T (seqs i),
  {
    intros i j hle, suffices: ∀ d i j : ℕ, i ≤ j → j-i=d → ∃ T : subseq, seqs j = rel_embedding.trans T (seqs i),
    apply this (j-i) i j hle, refl, intro d, induction d with d hd, intros a b aleb asb,
    have aeb: a = b, apply le_antisymm aleb (nat.sub_eq_zero_iff_le.1 asb), rw aeb,
    use @rel_embedding.refl ℕ (≤), exact subseq.trans_refl, intros a b aleb abdiff,
    cases hd a (a+d) (nat.le_add_right _ _) _ with T₀ hT₀,
    swap, rw add_comm, rw nat.add_sub_cancel d a,
    rw nat.sub_eq_iff_eq_add aleb at abdiff, rw nat.succ_add at abdiff,
    rw add_comm at abdiff, rw abdiff,
    have seqs_succ: seqs ((a+d).succ) = (f' ((a+d), seqs (a+d))).2,
    {
      nth_rewrite 0 h_seqs, simp [function.iterate_succ_apply'],
      rw f'_iterate_count (a+d),
    },
    rw seqs_succ, rw hf', rw hT₀, dsimp,
    use rel_embedding.trans (f (a + d) (rel_embedding.trans T₀ (seqs a))) T₀,
    exact subseq.trans_assoc,
  },
  have reachable_from_step: ∀ n : ℕ, ∃ T : subseq, S₁= rel_embedding.trans T (f'^[n] (0, S)).2,
  { intro n,
    apply subseq.reachable_trans _ S₁, intro i, cases le_or_gt n i,
    cases seqs_trans n i h with T ht, simp [h_the_seq, ht], simp [h_the_seq],
    use i,
    exact (hterm i n (le_of_lt h.lt)).symm },
  cases reachable_from_step 0 with T₀ hT₀,
  use T₀, intro g, simp at hT₀, rw ←hT₀, cases reachable_from_step g.succ with T₁ ht₁,
  rw ht₁,
  apply constraints_stable g _ T₁,
  apply constr g,
end


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.natural_isomorphism
import category_theory.equivalence
import category_theory.eq_to_hom

/-!
# Quotient category

Constructs the quotient of a category by an arbitrary family of relations on its hom-sets,
by introducing a type synonym for the objects, and identifying homs as necessary.

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'. When taking the quotient by a congruence
relation, `functor_map_eq_iff` says that no unnecessary identifications have been made.
-/

/-- A `hom_rel` on `C` consists of a relation on every hom-set. -/
@[derive inhabited]
def hom_rel (C) [quiver C] := Π ⦃X Y : C⦄, (X ⟶ Y) → (X ⟶ Y) → Prop

namespace category_theory

variables {C : Type*} [category C] (r : hom_rel C)

include r

/-- A `hom_rel` is a congruence when it's an equivalence on every hom-set, and it can be composed
from left and right. -/
class congruence : Prop :=
(is_equiv : ∀ {X Y}, is_equiv _ (@r X Y))
(comp_left : ∀ {X Y Z} (f : X ⟶ Y) {g g' : Y ⟶ Z}, r g g' → r (f ≫ g) (f ≫ g'))
(comp_right : ∀ {X Y Z} {f f' : X ⟶ Y} (g : Y ⟶ Z), r f f' → r (f ≫ g) (f' ≫ g))

attribute [instance] congruence.is_equiv

/-- A type synonym for `C`, thought of as the objects of the quotient category. -/
@[ext]
structure quotient := (as : C)

instance [inhabited C] : inhabited (quotient r) := ⟨ { as := default } ⟩

namespace quotient

/-- Generates the closure of a family of relations w.r.t. composition from left and right. -/
inductive comp_closure ⦃s t : C⦄ : (s ⟶ t) → (s ⟶ t) → Prop
| intro {a b} (f : s ⟶ a) (m₁ m₂ : a ⟶ b) (g : b ⟶ t) (h : r m₁ m₂) :
  comp_closure (f ≫ m₁ ≫ g) (f ≫ m₂ ≫ g)

lemma comp_left {a b c : C} (f : a ⟶ b) : Π (g₁ g₂ : b ⟶ c) (h : comp_closure r g₁ g₂),
  comp_closure r (f ≫ g₁) (f ≫ g₂)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro (f ≫ x) m₁ m₂ y h

lemma comp_right {a b c : C} (g : b ⟶ c) : Π (f₁ f₂ : a ⟶ b) (h : comp_closure r f₁ f₂),
  comp_closure r (f₁ ≫ g) (f₂ ≫ g)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro x m₁ m₂ (y ≫ g) h

/-- Hom-sets of the quotient category. -/
def hom (s t : quotient r) := quot $ @comp_closure C _ r s.as t.as

instance (a : quotient r) : inhabited (hom r a a) := ⟨quot.mk _ (𝟙 a.as)⟩

/-- Composition in the quotient category. -/
def comp ⦃a b c : quotient r⦄ : hom r a b → hom r b c → hom r a c :=
λ hf hg, quot.lift_on hf ( λ f, quot.lift_on hg (λ g, quot.mk _ (f ≫ g))
  (λ g₁ g₂ h, quot.sound $ comp_left r f g₁ g₂ h) )
  (λ f₁ f₂ h, quot.induction_on hg $ λ g, quot.sound $ comp_right r g f₁ f₂ h)

@[simp]
lemma comp_mk {a b c : quotient r} (f : a.as ⟶ b.as) (g : b.as ⟶ c.as) :
  comp r (quot.mk _ f) (quot.mk _ g) = quot.mk _ (f ≫ g) := rfl

instance category : category (quotient r) :=
{ hom := hom r,
  id := λ a, quot.mk _ (𝟙 a.as),
  comp := comp r }

/-- The functor from a category to its quotient. -/
@[simps]
def functor : C ⥤ quotient r :=
{ obj := λ a, { as := a },
  map := λ _ _ f, quot.mk _ f }

noncomputable instance : full (functor r) :=
{ preimage := λ X Y f, quot.out f, }

instance : ess_surj (functor r) :=
{ mem_ess_image := λ Y, ⟨Y.as, ⟨eq_to_iso (by { ext, refl, })⟩⟩ }

protected lemma induction {P : Π {a b : quotient r}, (a ⟶ b) → Prop}
  (h : ∀ {x y : C} (f : x ⟶ y), P ((functor r).map f)) :
  ∀ {a b : quotient r} (f : a ⟶ b), P f :=
by { rintros ⟨x⟩ ⟨y⟩ ⟨f⟩, exact h f, }

protected lemma sound {a b : C} {f₁ f₂ : a ⟶ b} (h : r f₁ f₂) :
  (functor r).map f₁ = (functor r).map f₂ :=
by simpa using quot.sound (comp_closure.intro (𝟙 a) f₁ f₂ (𝟙 b) h)

variables {D : Type*} [category D]
  (F : C ⥤ D)
  (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂)
include H

/-- The induced functor on the quotient category. -/
@[simps]
def lift : quotient r ⥤ D :=
{ obj := λ a, F.obj a.as,
  map := λ a b hf, quot.lift_on hf (λ f, F.map f)
    (by { rintros _ _ ⟨_, _, _, _, _, _, h⟩, simp [H _ _ _ _ h], }),
  map_id' := λ a, F.map_id a.as,
  map_comp' := by { rintros a b c ⟨f⟩ ⟨g⟩, exact F.map_comp f g, } }

/-- The original functor factors through the induced functor. -/
def lift.is_lift : (functor r) ⋙ lift r F H ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma lift.is_lift_hom (X : C) : (lift.is_lift r F H).hom.app X = 𝟙 (F.obj X) :=
rfl
@[simp]
lemma lift.is_lift_inv (X : C) : (lift.is_lift r F H).inv.app X = 𝟙 (F.obj X) :=
rfl

lemma lift_map_functor_map {X Y : C} (f : X ⟶ Y) :
  (lift r F H).map ((functor r).map f) = F.map f :=
by { rw ←(nat_iso.naturality_1 (lift.is_lift r F H)), dsimp, simp, }

end quotient

end category_theory


inductive Foo (n: Nat)
  | mk: n = 0 → Foo n

example (h: Foo x): x + 1 = 1 := by
  cases h
  subst x
  rfl


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

/-!
# Bitraversable type class

Type class for traversing bifunctors. The concepts and laws are taken from
<https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

Simple examples of `bitraversable` are `prod` and `sum`. A more elaborate example is
to define an a-list as:

```
def alist (key val : Type) := list (key × val)
```

Then we can use `f : key → io key'` and `g : val → io val'` to manipulate the `alist`'s key
and value respectively with `bitraverse f g : alist key val → io (alist key' val')`

## Main definitions
  * bitraversable - exposes the `bitraverse` function
  * is_lawful_bitraversable - laws similar to is_lawful_traversable

## Tags

traversable bitraversable iterator functor bifunctor applicative

-/

universes u

class bitraversable (t : Type u → Type u → Type u)
  extends bifunctor t :=
(bitraverse : Π {m : Type u → Type u} [applicative m] {α α' β β'},
  (α → m α') → (β → m β') → t α β → m (t α' β'))
export bitraversable ( bitraverse )

def bisequence {t m} [bitraversable t] [applicative m] {α β} : t (m α) (m β) → m (t α β) :=
bitraverse id id

open functor

class is_lawful_bitraversable (t : Type u → Type u → Type u) [bitraversable t]
  extends is_lawful_bifunctor t :=
(id_bitraverse : ∀ {α β} (x : t α β), bitraverse id.mk id.mk x = id.mk x )
(comp_bitraverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α α' β β' γ γ'} (f : β → F γ) (f' : β' → F γ')
    (g : α → G β) (g' : α' → G β') (x : t α α'),
  bitraverse (comp.mk ∘ map f ∘ g) (comp.mk ∘ map f' ∘ g') x =
  comp.mk (bitraverse f f' <$> bitraverse g g' x) )
(bitraverse_eq_bimap_id : ∀ {α α' β β'} (f : α → β) (f' : α' → β') (x : t α α'),
   bitraverse (id.mk ∘ f) (id.mk ∘ f') x = id.mk (bimap f f' x))
(binaturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α α' β β'}
    (f : α → F β) (f' : α' → F β') (x : t α α'),
  η (bitraverse f f' x) = bitraverse (@η _ ∘ f) (@η _ ∘ f') x)

export is_lawful_bitraversable ( id_bitraverse comp_bitraverse
                                 bitraverse_eq_bimap_id  )
open is_lawful_bitraversable

attribute [higher_order bitraverse_id_id] id_bitraverse
attribute [higher_order bitraverse_comp] comp_bitraverse
attribute [higher_order] binaturality bitraverse_eq_bimap_id

export is_lawful_bitraversable (bitraverse_id_id bitraverse_comp)


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Functors with two arguments
-/

import data.sum
       category.basic category.functor
       tactic.basic

universes u₀ u₁ u₂ v₀ v₁ v₂

class bifunctor (F : Type u₀ → Type u₁ → Type u₂) :=
(bimap : Π {α α' β β'}, (α → α') → (β → β') → F α β → F α' β')
export bifunctor ( bimap )

class is_lawful_bifunctor (F : Type u₀ → Type u₁ → Type u₂) [bifunctor F] :=
(id_bimap : Π {α β} (x : F α β), bimap id id x = x)
(bimap_bimap : Π {α₀ α₁ α₂ β₀ β₁ β₂} (f : α₀ → α₁) (f' : α₁ → α₂)
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α₀ β₀),
  bimap f' g' (bimap f g x) = bimap (f' ∘ f) (g' ∘ g) x)

export is_lawful_bifunctor (id_bimap bimap_bimap)

attribute [higher_order bimap_id_id] id_bimap
attribute [higher_order bimap_comp_bimap] bimap_bimap

export is_lawful_bifunctor (bimap_id_id bimap_comp_bimap)
variables {F : Type u₀ → Type u₁ → Type u₂} [bifunctor F]

namespace bifunctor

@[reducible]
def fst {α α' β} (f : α → α') : F α β → F α' β :=
bimap f id

@[reducible]
def snd {α β β'} (f : β → β') : F α β → F α β' :=
bimap id f

variable [is_lawful_bifunctor F]

@[higher_order fst_id]
lemma id_fst : Π {α β} (x : F α β), fst id x = x :=
@id_bimap _ _ _

@[higher_order snd_id]
lemma id_snd : Π {α β} (x : F α β), snd id x = x :=
@id_bimap _ _ _

@[higher_order fst_comp_fst]
lemma comp_fst {α₀ α₁ α₂ β}
  (f : α₀ → α₁) (f' : α₁ → α₂) (x : F α₀ β) :
  fst f' (fst f x) = fst (f' ∘ f)  x :=
by simp [fst,bimap_bimap]

@[higher_order fst_comp_snd]
lemma fst_snd {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  fst f (snd f' x) = bimap f f' x :=
by simp [fst,bimap_bimap]

@[higher_order snd_comp_fst]
lemma snd_fst {α₀ α₁ β₀ β₁}
  (f : α₀ → α₁) (f' : β₀ → β₁) (x : F α₀ β₀) :
  snd f' (fst f x) = bimap f f' x :=
by simp [snd,bimap_bimap]

@[higher_order snd_comp_snd]
lemma comp_snd {α β₀ β₁ β₂}
  (g : β₀ → β₁) (g' : β₁ → β₂) (x : F α β₀) :
  snd g' (snd g x) = snd (g' ∘ g) x :=
by simp [snd,bimap_bimap]

attribute [functor_norm] bimap_bimap comp_snd comp_fst
  snd_comp_snd snd_comp_fst fst_comp_snd fst_comp_fst bimap_comp_bimap
  bimap_id_id fst_id snd_id

def bicompl (F : Type* → Type* → Type*) (G : Type* → Type*) (H : Type* → Type*) (α β) :=
F (G α) (H β)

def bicompr (F : Type* → Type*) (G : Type* → Type* → Type*) (α β) :=
F (G α β)

end bifunctor
open functor
instance : bifunctor prod :=
{ bimap := @prod.map }

instance : is_lawful_bifunctor prod :=
by refine { .. }; intros; cases x; refl

instance bifunctor.const : bifunctor const :=
{ bimap := (λ α α' β β f _, f) }

instance is_lawful_bifunctor.const : is_lawful_bifunctor const  :=
by refine { .. }; intros; refl

instance bifunctor.flip : bifunctor (flip F) :=
{ bimap := (λ α α' β β' f f' x, (bimap f' f x : F β' α')) }

instance is_lawful_bifunctor.flip [is_lawful_bifunctor F] : is_lawful_bifunctor (flip F)  :=
by refine { .. }; intros; simp [bimap] with functor_norm

instance : bifunctor sum :=
{ bimap := @sum.map }

instance : is_lawful_bifunctor sum :=
by refine { .. }; intros; cases x; refl

open bifunctor functor

@[priority 0]
instance bifunctor.functor {α} : functor (F α) :=
{ map := λ _ _, snd }

@[priority 0]
instance bifunctor.is_lawful_functor [is_lawful_bifunctor F] {α} : is_lawful_functor (F α) :=
by refine {..}; intros; simp [functor.map] with functor_norm

section bicompl

variables (G : Type* → Type u₀) (H : Type* → Type u₁) [functor G] [functor H]

instance : bifunctor (bicompl F G H) :=
{ bimap := λ α α' β β' f f' x, (bimap (map f) (map f') x : F (G α') (H β')) }

instance [is_lawful_functor G]  [is_lawful_functor H] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompl F G H) :=
by constructor; intros; simp [bimap,map_id,map_comp_map] with functor_norm

end bicompl
section bicompr

variables (G : Type u₂ → Type*) [functor G]

instance : bifunctor (bicompr G F) :=
{ bimap := λ α α' β β' f f' x, (map (bimap f f') x : G (F α' β')) }

instance [is_lawful_functor G] [is_lawful_bifunctor F] :
  is_lawful_bifunctor (bicompr G F) :=
by constructor; intros; simp [bimap] with functor_norm

end bicompr


import data.fin.basic
import data.fintype.basic
import data.list
import ..automata_typeclass

variables {Sigma : Type} [decidable_eq Sigma]

def append_lang (P Q : lang Sigma) : lang Sigma
:= λ w, ∃ u v : word Sigma, P u ∧ Q v ∧ w = u ++ v

def append_ε_nfa {Sigma : Type*} [decidable_eq Sigma] (A : ε_nfa Sigma) (B : ε_nfa Sigma) : ε_nfa Sigma :=
  {
    Q := A.Q ⊕ B.Q,
    finQ := @sum.fintype A.Q B.Q A.finQ B.finQ,
    decQ := @sum.decidable_eq A.Q A.decQ B.Q B.decQ,
    inits := λ q, sum.cases_on q A.inits (λ _, false),
    decI := begin
      assume a,
      cases a;
      simp at *,
      exact A.decI a,
      exact is_false id,
    end,
    final := λ q, sum.cases_on q (λ _, false) B.final,
    decF := begin
      assume a,
      cases a;
      simp at *,
      exact is_false id,
      exact B.decF a,
    end,
    δ := λ a x b, match a, b with
        | (sum.inl a), (sum.inl b) := A.δ a x b
        | (sum.inl a), (sum.inr b) := A.final a ∧ B.inits b ∧ x = none
        | (sum.inr a), (sum.inl b) := false
        | (sum.inr a), (sum.inr b) := B.δ a x b
      end,
    decD := begin
      assume a,
      cases a with ax b, cases ax with a x,
      cases a; cases b; dsimp [sigma.uncurry],
      exact A.decD ⟨⟨a, x⟩, b⟩,
      {
        letI dF := A.decF,
        letI dI := B.decI,
        letI deq := @sum.decidable_eq A.Q A.decQ B.Q B.decQ,
        unfold_aux,
        apply_instance,
      },
      exact is_false id,
      exact B.decD ⟨⟨a, x⟩, b⟩,
    end,
  }

lemma left_append : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : A.Q,
  ε_nfa_δ_star A q0 w q1 → ε_nfa_δ_star (append_ε_nfa A B) (sum.inl q0) w (sum.inl q1) :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    constructor,
  },
  case ε_nfa_δ_star.step : q11 q22 q33 x w h1 h2 ih
  {
    fconstructor,
    exact (sum.inl q22),
    exact h1,
    exact ih,
  },
  case ε_nfa_δ_star.epsilon : q11 q22 q33 w h1 h2 ih
  {
    fconstructor,
    exact (sum.inl q22),
    exact h1,
    exact ih,
  }
end

lemma right_append : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : B.Q,
  ε_nfa_δ_star B q0 w q1 → ε_nfa_δ_star (append_ε_nfa A B) (sum.inr q0) w (sum.inr q1) :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    constructor,
  },
  case ε_nfa_δ_star.step : q11 q22 q33 x w h1 h2 ih
  {
    fconstructor,
    exact (sum.inr q22),
    exact h1,
    exact ih,
  },
  case ε_nfa_δ_star.epsilon : q11 q22 q33 w h1 h2 ih
  {
    fconstructor,
    exact (sum.inr q22),
    exact h1,
    exact ih,
  }
end

lemma append_lemᵣ : ∀ A B : ε_nfa Sigma, ∀ u v : word Sigma, ∀ q0 : A.Q, ∀ q1 : B.Q,
  (∃ q2 : A.Q, ∃ q3 : B.Q, A.final q2 ∧ B.inits q3
   ∧ ε_nfa_δ_star A q0 u q2 ∧ ε_nfa_δ_star B q3 v q1) →
  ε_nfa_δ_star (append_ε_nfa A B) (sum.inl q0) (u ++ v) (sum.inr q1) :=
begin
  assume A B u v q0 q1 h,
  cases h with q2 h, cases h with q3 h,
  cases h with Afinal h, cases h with Binits h,
  cases h with Astar Bstar,
  have a2b : (append_ε_nfa A B).δ (sum.inl q2) none (sum.inr q3),
  {
    constructor, exact Afinal,
    constructor, exact Binits,
    refl,
  },
  induction Astar,
  case ε_nfa_δ_star.empty : q
  {
    simp,fconstructor,
    exact (sum.inr q3),
    exact a2b, exact right_append A B v q3 q1 Bstar,
  },
  case ε_nfa_δ_star.step : q00 q11 q22 x w h1 h2 ih
  {
    fconstructor,
    exact sum.inl q11,
    exact h1,
    apply ih,
    exact Afinal,
    exact a2b,
  },
  case ε_nfa_δ_star.epsilon : q00 q11 q22 w h1 h2 ih
  {
    fconstructor,
    exact sum.inl q11,
    exact h1,
    apply ih,
    exact Afinal,
    exact a2b,
  }
end

lemma append_lem : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma, ∀ q0 q1 : (append_ε_nfa A B).Q,
  ε_nfa_δ_star (append_ε_nfa A B) q0 w q1 →
  (∃ q0' : A.Q, ∃ q1' : B.Q, q0 = sum.inl q0' ∧ q1 = sum.inr q1'
   ∧ ∃ u v : word Sigma, ∃ q2' : A.Q, ∃ q3' : B.Q, A.final q2' ∧ B.inits q3'
   ∧ ε_nfa_δ_star A q0' u q2' ∧ ε_nfa_δ_star B q3' v q1'
   ∧ u ++ v = w)
  ∨ (∃ q0' q1' : A.Q, q0 = sum.inl q0' ∧ q1 = sum.inl q1'
     ∧ ε_nfa_δ_star A q0' w q1')
  ∨ (∃ q0' q1' : B.Q, q0 = sum.inr q0' ∧ q1 = sum.inr q1'
     ∧ ε_nfa_δ_star B q0' w q1') :=
begin
  assume A B w q0 q1 h,
  induction h,
  case ε_nfa_δ_star.empty : q
  {
    cases q,
    right, left, existsi [q, q],
    simp, constructor,
    right, right, existsi [q, q],
    simp, constructor,
  },
  case ε_nfa_δ_star.step : q00 q11 q22 x w h1 h2 ih
  {
    cases q00,
    {
      cases q11,
      {
        cases ih,
        {
          left,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 ih,
          cases ih with u ih, cases ih with v ih,
          cases ih with q2' ih, cases ih with q3 ih,
          cases ih with Afinal ih, cases ih with Binits ih,
          cases ih with Astar ih, cases ih with Bstar split_eq,
          existsi [q00, q1'], constructor, refl,
          constructor, exact eq2,
          existsi [(x :: u), v],
          existsi [q2', q3],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor,
          {
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1,
            exact Astar,
          },
          constructor,
          {
            exact Bstar,
          },
          {
            rw← split_eq,
            exact list.cons_append x u v,
          }
        },
        {
          cases ih,
          {
            right, left,
            cases ih with q0' ih, cases ih with q1' ih,
            existsi [q00, q1'],
            cases ih with eq1 ih, cases ih with eq2 Astar,
            simp, constructor, exact eq2,
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1, exact Astar,
          },
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          }
        }
      },
      {
        cases h1 with _ h1, cases h1 with _ f, cases f,
      }
    },
    {
      cases q11,
      {
        cases h1,
      },
      {
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases ih,
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          },
          {
            right, right,
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with eq1 ih, cases ih with eq2 Bstar,
            existsi [q00, q1'],
            simp, constructor, exact eq2,
            fconstructor,
            exact q11,
            exact h1, injection eq1 with eq1, rw eq1,
            exact Bstar,
          }
        },
      }
    },
  },
  case ε_nfa_δ_star.epsilon : q00 q11 q22 w h1 h2 ih
  {
    cases q00,
    {
      cases q11,
      {
        cases ih,
        {
          left,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 ih,
          cases ih with u ih, cases ih with v ih,
          cases ih with q2' ih, cases ih with q3 ih,
          cases ih with Afinal ih, cases ih with Binits ih,
          cases ih with Astar ih, cases ih with Bstar split_eq,
          existsi [q00, q1'], constructor, refl,
          constructor, exact eq2,
          existsi [u, v],
          existsi [q2', q3],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor,
          {
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1,
            exact Astar,
          },
          constructor,
          {
            exact Bstar,
          },
          {
            rw← split_eq,
          }
        },
        {
          cases ih,
          {
            right, left,
            cases ih with q0' ih, cases ih with q1' ih,
            existsi [q00, q1'],
            cases ih with eq1 ih, cases ih with eq2 Astar,
            simp, constructor, exact eq2,
            fconstructor,
            exact q11, exact h1,
            injection eq1 with eq1, rw eq1, exact Astar,
          },
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          }
        }
      },
      {
        left,
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases h1 with Afinal h1, cases h1 with Binits _,
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with eq1 ih, cases ih with eq2 Bstar,
          existsi [q00, q1'],
          constructor, refl,
          constructor, exact eq2,
          existsi [[], w, q00, q11],
          constructor, exact Afinal,
          constructor, exact Binits,
          constructor, constructor,
          constructor, injection eq1 with eq1, rw eq1, exact Bstar,
          exact list.nil_append w,
        }
      }
    },
    {
      cases q11,
      {
        cases h1,
      },
      {
        cases ih,
        {
          cases ih with q0' ih, cases ih with q1' ih,
          cases ih with f _, cases f,
        },
        {
          cases ih,
          {
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with f _, cases f,
          },
          {
            right, right,
            cases ih with q0' ih, cases ih with q1' ih,
            cases ih with eq1 ih, cases ih with eq2 Bstar,
            existsi [q00, q1'],
            simp, constructor, exact eq2,
            fconstructor,
            exact q11,
            exact h1, injection eq1 with eq1, rw eq1,
            exact Bstar,
          }
        },
      }
    },
  },
end

lemma append_ε_nfa_lang : ∀ A B : ε_nfa Sigma, ∀ w : word Sigma,
  ε_nfa_lang (append_ε_nfa A B) w ↔ append_lang (ε_nfa_lang A) (ε_nfa_lang B) w :=
begin
  assume A B w,
  constructor,
  {
    dsimp [ε_nfa_lang, append_lang],
    assume h,
    cases h with q0 h, cases h with q1 h,
    cases h with h1 h, cases h with h2 h3,
    have g := append_lem A B w q0 q1 h2,
    cases g,
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 g,
      cases g with u g, cases g with v g,
      cases g with q2' g, cases g with q3' g,
      cases g with Afinal g, cases g with Binits ih,
      cases ih with Astar g, cases g with Bstar split_eq,
      existsi [u, v],
      constructor,
      {
        existsi [q0', q2'],
        constructor, finish,
        constructor, exact Astar, exact Afinal,
      },
      constructor,
      {
        existsi [q3', q1'],
        constructor, exact Binits,
        constructor, exact Bstar, finish,
      },
      exact eq.symm split_eq,
    },
    cases g,
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 Astar,
      existsi [w, []],
      rw eq2 at h3, cases h3,
    },
    {
      cases g with q0' g, cases g with q1' g,
      cases g with eq1 g, cases g with eq2 Astar,
      rw eq1 at h1, cases h1,
    }
  },
  {
    dsimp [ε_nfa_lang, append_lang],
    assume h,
    cases h with u h, cases h with v h,
    cases h with h1 h2, cases h2 with h2 h3,
    cases h1 with q0 h1, cases h1 with q2 h1,
    cases h2 with q3 h2, cases h2 with q1 h2,
    existsi [sum.inl q0, sum.inr q1],
    constructor, exact (and.elim_left h1),
    constructor,
    {
      let h11 : ε_nfa_δ_star A q0 u q2, exact (and.elim_left $ and.elim_right $ h1),
      let h22 : ε_nfa_δ_star B q3 v q1, exact (and.elim_left $ and.elim_right $ h2),
      rw h3,
      apply append_lemᵣ A B u v q0 q1,
      existsi [q2, q3],
      constructor, exact (and.elim_right $ and.elim_right $ h1),
      constructor, exact (and.elim_left h2),
      constructor, exact h11,
      exact h22,
    },
    exact (and.elim_right (and.elim_right h2)),
  }
end


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.category.default
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!
# Bundled types

`bundled c` provides a uniform structure for bundling a type equipped with a type class.

We provide `category` instances for these in `category_theory/unbundled_hom.lean`
(for categories with unbundled homs, e.g. topological spaces)
and in `category_theory/bundled_hom.lean` (for categories with bundled homs, e.g. monoids).
-/

namespace category_theory

/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
structure bundled (c : Type u → Type v) where
  α : Type u
  str :
    autoParam (c α)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])

namespace bundled

/-- A generic function for lifting a type equipped with an instance to a bundled object. -/
-- Usually explicit instances will provide their own version of this, e.g. `Mon.of` and `Top.of`.

def of {c : Type u → Type v} (α : Type u) [str : c α] : bundled c := mk α

protected instance has_coe_to_sort {c : Type u → Type v} : has_coe_to_sort (bundled c) :=
  has_coe_to_sort.mk (Type u) α

@[simp] theorem coe_mk {c : Type u → Type v} (α : Type u)
    (str :
      autoParam (c α)
        (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
          (Lean.Name.mkStr
            (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
            "apply_instance")
          [])) :
    ↥(mk α) = α :=
  rfl

/-
`bundled.map` is reducible so that, if we define a category

  def Ring : Type (u+1) := induced_category SemiRing (bundled.map @ring.to_semiring)

instance search is able to "see" that a morphism R ⟶ S in Ring is really
a (semi)ring homomorphism from R.α to S.α, and not merely from
`(bundled.map @ring.to_semiring R).α` to `(bundled.map @ring.to_semiring S).α`.
-/

/-- Map over the bundled structure -/
def map {c : Type u → Type v} {d : Type u → Type v} (f : {α : Type u} → c α → d α) (b : bundled c) :
    bundled d :=
  mk ↥b

end Mathlib