import substances math.fuzzy
open set topological_space classical
set_option pp.generalized_field_notation true
local attribute [instance] prop_decidable
noncomputable theory

-- tentative idea for formalizing ppc via intensional similarities
-- in a variant of nuclear trope theory

namespace ontology

variable {ω : ontology}

namespace iontology
/-- Intensional similarity relation -/
structure sim (Ω : ω.iontology) :=
  (r : Ω.ientity → Ω.ientity → ω.world → fuzzy)
  (reflexive : ∀ {e : Ω.ientity} {w}, e.exists w → r e e w = 1)
  (symmetric : ∀ {e₁ e₂}, r e₁ e₂ = r e₂ e₁)
  -- I think this follows from the stronger property of transitivity discussed by Zadeh
  (triangular : ∀ (w) e₁ e₂ e₃, ((r e₁ e₂ w) : ℝ) * (r e₂ e₃ w) ≤ r e₁ e₃ w)
  (tolerance : fuzzy  := 0)
  -- TODO: prove this as a theorem, follows from triangular inequality
  -- (subst : ∀ e₁ e₂, r e₁ e₂ = 1 → ∀ e₃, r e₁ e₃ = r e₂ e₃)
  -- these principles are probably wrong, will think about them later.
  -- consubstantial entities with the same essence are exactly similar
  -- (coessence : ∀ e₁ e₂, 0 < r e₁ e₂ → e₁ ≈ e₂ → r e₁ e₂ = 1)
  -- -- substances do not have the same essence as their accidents
  -- (essence : ∀ e₁ e₂, 0 < r e₁ e₂ → e₁ ≈ e₂ → e₁ ⇎ e₂ → ¬ e₁.up.compatible e₂)

attribute [class] sim
attribute [simp, refl] sim.reflexive
attribute [simp, symm] sim.symmetric

section basic
variables {Ω : ω.iontology} [sim : Ω.sim] (e : Ω.ientity)
include sim

/-- An entity is said to be **wholly dissimilar** to another if
    their similarity is always 0. -/
def wdiss (e' : Ω.ientity) : Prop := ∀ w, 0 = sim.r e e' w

/-- An entity is said to be **similar** to another,
    if it is not wholly dissimilar to it, i.e. if
    their similarity is strictly greater than 0. -/
def similar (e' : Ω.ientity) : Prop := ¬ wdiss e e'

/-- An entity is said to be **exactly similar** to, or **indiscernible** from,
    another if their similarity is always 1. -/
def esimilar (e' : Ω.ientity) : Prop := ∀ w, 1 = sim.r e e' w

local infixr ` ≅ `:50 := similar
local infixr ` ≇ `:50 := wdiss
-- TODO: maybe set == notation for esimilar.

-- fuzzy needs has_Inf. Will need to migrate to newer
-- version of mathlib to make this work properly.
/-- Infimum degree of similarity between two entities.
    Introduced so we can get rid of possible worlds. -/
def ientity.sim (e₁ : Ω.ientity) (e₂ : Ω.ientity) : fuzzy := sorry --Inf $ sim.r e₁ e₂ '' univ

-- -- TODO: check later if this is indeed a good definition
-- /-- A **bare particular** is an entity wholly dissimilar to any entity distinct from itself. -/
-- def ientity.bare : Prop := ∀ e', e' ≠ e → e' ≇ e

-- /-- A **trope like** entity is a non-bare particular which is incompatible with any entity
--     distinct, similar and consubstantial to itself. -/
-- def ientity.trope_like : Prop := ¬ e.bare ∧ ∀ e', e' ≠ e → e' ≈ e → e' ≅ e → ¬ e'.up.compatible e

-- /-- A **strongly trope like** entity is an entity which is only similar to trope like entities. -/
-- def ientity.strope_like : Prop := ∀ e', e' ≅ e → e'.trope_like

-- /-- A **bare like** entity is an entity wholly dissimilar from all trope like entities,
--     which is however not necessarily a bare particular. -/
-- def ientity.substratum : Prop := ∀ e' : Ω.ientity, e'.trope_like → e' ≇ e

-- substrata in the same nucleus (i.e. equivalent) have the same essence
-- def substratum_sim : Prop := ∀ e₁ e₂ : Ω.ientity, e₁.substratum → e₂.substratum → e₁ ≡ e₂ → e₁ ≅ e₂
-- -- whatever
-- def sim_closure : Prop := ∀ e₁ e₂ : Ω.ientity, e₁.trope → e₁ ≅ e₂ → e₂.trope

-- TODO: we may need a notion of the origin trope being more perfect than
-- the caused entity.
-- def ppc (c : Ω.ientity → Ω.ientity → ω.event) : Prop :=
--   ∀ e₁ e₂, ⋄c e₁ e₂ →
--   ∃ trope, trope ≈ e₁ ∧ trope ≅ e₂ ∧ trope ≠ e₂
--   ∧ trope.strope_like ∧ c e₁ e₂ ⇒' trope.exists ∧
--   ∀ e₃, c e₃ trope ∩ c e₁ e₂ ⇒ c e₃ e₂

-- needs has_Inf
/-- Infimum possible degree of similarity among entities of a set. -/
def inf_sim (C : set Ω.ientity) : fuzzy := sorry --Inf {d : fuzzy | ∃ (w : ω.world) e₁ e₂ ∈ C, sim.r e₁ e₂ w = d}

/-- Infimum degree of similarity among entities in a possible world. -/
def sim.inf_sim_at (sim : Ω.sim) (w : ω.world) : fuzzy := sorry --Inf {d : fuzzy | ∃ e₁ e₂ ∈ w, sim.r e₁ e₂ w = d}

-- needs has_Sup
/-- Supremum possible degree of similarity among entities of a set. -/
def sup_sim (C : set Ω.ientity) : fuzzy := sorry -- Sup {d : fuzzy | ∃ (w : ω.world) e₁ e₂ ∈ C, e₁ ≠ e₂ ∧ sim.r e₁ e₂ w = d}

/-- Supremum degree of similarity among distinct entities in a possible world. -/
def sim.sup_sim_at (sim : Ω.sim) (w : ω.world) : fuzzy := sorry -- Sup {d : fuzzy | ∃ e₁ e₂ ∈ w, e₁ ≠ e₂ ∧ sim.r e₁ e₂ w = d}

-- needs has_Sup
/-- Supremum possible degree of similarity between a set and an entity. -/
def sdsim (e : Ω.ientity) (C : set Ω.ientity) : fuzzy := sorry --Sup {d : fuzzy | ∃ (w : ω.world) e' ∈ C, sim.r e e' w = d}

/-- Supremum degree of similarity between an entity and the entities which exist in a possible world. -/
def sdsim_at (e : Ω.ientity) (w : ω.world) : fuzzy := sorry --Sup {d : fuzzy | ∃ e' ∈ w, sim.r e e' w = d}

/-- A **resemblance class** is a set of entities which always resemble each other at least as much as they
    might resemble any entity outside of the set. -/
def rclass (C : set Ω.ientity) : Prop :=
  ∀ e ∈ C, sdsim e (-C) ≤ inf_sim C

/-- A **strict resemblance class** is a set of entities which always resemble each other more than they
    might resemble any entity outside of the set. -/
def srclass (C : set Ω.ientity) : Prop :=
  ∀ e ∈ C, sdsim e (-C) < inf_sim C

-- don't know if we will need it. Left incomplete
-- /-- A **local resemblance class** is a set of entities which, within some world `w`,
--     resemble each other more than they
--     resemble, in `w`, any entity outside of the set. -/
-- def lrclass (C : set Ω.ientity) (w : ω.world) : Prop :=
--   ∀ e ∈ C, sdsim e (-C) ≤ inf_sim C

/-- A set of entities is **simply independent** if its distinct elements are pairwise independent, i.e. incomparable. -/
def sindependent (C : set Ω.ientity) : Prop := ∀ e₁ e₂ ∈ C, e₁ ≠ e₂ → e₁ ≢ e₂

/-- A **clique** of degree **d**, or d-clique, is a set
    of entities which are similar to each
    other to degree at least **d** in any possible world. -/
def clique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  ∀ (w : ω.world) (e₁ e₂ : Ω.ientity),
  e₁ ∈ C → e₂ ∈ C → d ≤ sim.r e₁ e₂ w

/-- An **existential clique** of degree **d**, or d-eclique, is a set
    of entities which are similar to each
    other to degree at least **d** in any possible
    world in which both exist.
    Every clique is an existential clique,
    but the converse need not hold. -/
def eclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  ∀ (w : ω.world) (e₁ e₂ : Ω.ientity),
  e₁ ∈ C → e₂ ∈ C → e₁.exists w → e₂.exists w →
  d ≤ sim.r e₁ e₂ w

/-- A **maximum clique** of degree **d**, or d-mclique, is a d-clique which cannot be enlarged. -/
def mclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  clique d C ∧ ∀ C' : set Ω.ientity, clique d C' → C ⊆ C' → C = C'

/-- An **analogical clique** of degree **d**, or d-aclique, is a d-mclique
    which is also a resemblance class. -/
def aclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  mclique d C ∧ rclass C

/-- A **strict analogical clique** of degree **d**, or d-aclique, is a d-mclique
    which is also a strict resemblance class. -/
def saclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  mclique d C ∧ srclass C

/-- A **near perfect clique** of degree **d**, or d-npclique, is an infinite d-saclique. -/
def npclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  set.infinite C ∧ saclique d C

/-- An entity is a **trope** if and only if its similarity to any other
    entities does not vary across time and worlds (beyond the allowed tolerance). -/
def ientity.trope (e : Ω.ientity) : Prop := ∀ e' w w', abs ((sim.r e e' w : ℝ) - sim.r e e' w') ≤ sim.tolerance

-- TODO: consider bumping the definition below to full independence
-- (lack of entailment between aggregates, lack of generic dependences) later.
-- Also consider specifying that the clique should not contain entities from
-- different corners of the ontological square.
-- These are some of the conditions I term "univocity conditions".
-- For now, it won't matter much to produce a very strict definition of univocity
-- for perfect cliques. The basic idea of them can be expressed just
-- with the following conditions.

/-- A **perfect clique** of degree **d**, or d-pclique, is a simply independent d-npclique,
    which does not contain both tropes and non-tropes. -/
def pclique (d : fuzzy) (C : set Ω.ientity) : Prop :=
  npclique d C ∧ sindependent C ∧
  ¬ ∃ e t : Ω.ientity, e ∈ C ∧ t ∈ C ∧ t.trope ∧ ¬e.trope

/-- The **degrees of analogy** of an entity **e** is the set of degrees for which **e** has a near perfect clique.
    An entity is said to be analogically similar to **e** if it resembles the things resembling **e** to at least
    some of these degrees. -/
def ientity.danalogy (e : Ω.ientity) : set fuzzy := {d : fuzzy | ∃ (C : set Ω.ientity), e ∈ C ∧ npclique d C}

/-- The **analogies** of an entity **e** is the set of near perfect cliques containing **e**.
    An entity is said to analogically similar to **e** if it shares a near perfect clique with **e**. -/
def ientity.analogies (e : Ω.ientity) : set $ set Ω.ientity := {C : set Ω.ientity | ∃ d, e ∈ C ∧ npclique d C}

/-- The **degrees of genera** of an entity **e** is the set of degrees for which **e** has a perfect clique.
    An entity is said to be in one of the same genus as **e** if it resembles the things resembling **e** to at least
    some of these degrees. -/
def ientity.dgenera (e : Ω.ientity) : set fuzzy := {d : fuzzy | ∃ (C : set Ω.ientity), e ∈ C ∧ pclique d C}

/-- The **genera** of an entity **e** is the set of perfect cliques containing **e**.
    An entity is said to be in one of the same genus as **e** if it shares a perfect clique with **e**. -/
def ientity.genera (e : Ω.ientity) : set $ set Ω.ientity := {C : set Ω.ientity | ∃ d, e ∈ C ∧ pclique d C}

/-- An entity is said to be **quasi-unintelligible** if it does not admit analogies of degree greater than 0.
    In this case, it either has no essence, or at least its essence cannot be explained by
    resemblance nominalism, but only by trope-resemblance nominalism. -/
def ientity.qunint (e : Ω.ientity) : Prop := ¬ ∃ d ∈ e.danalogy, (0 : fuzzy) < d

/-- An entity is said to be **unintelligible** if it quasi-unintelligible and is not
    existentially equivalent to any non-quasi-unintelligible tropes.
    If it were equivalent to some such tropes, i.e. if it had *essential* tropes,
    its essence might be explainable in terms of the essences of its tropes.
    An unintelligible entity however has no essence of any sort. -/
def ientity.unint (e : Ω.ientity) : Prop :=
  e.qunint ∧ ∀ t : Ω.ientity, t.trope → t ⇔ e → t.qunint

/-- An entity is said to be **partially intelligible** if it is not unintelligible. -/
def ientity.pint (e : Ω.ientity) : Prop := ¬ e.unint

/-- An entity is said to be **bare** if it is not a member of any genus.
    In this case, it either has no univocal essence, or at least its essence cannot be explained by
    resemblance nominalism, but only by trope-resemblance nominalism. -/
def ientity.bare (e : Ω.ientity) : Prop := e.genera = ∅

/-- An entity is said to be **fully bare** if it is
    bare and is not existentially equivalent to any non-bare tropes.
    If it were equivalent to some non-bare tropes, i.e. if it had *essential* tropes,
    its essence might be explainable in terms of the essences of its tropes.
    A fully bare entity however has no univocal essence of any sort (other than its haecceity). -/
def ientity.fbare (e : Ω.ientity) : Prop :=
  e.bare ∧ ∀ t : Ω.ientity, t.trope → t ⇔ e → t.bare

/-- An entity is said to be **normal** if it has a genus. -/
def ientity.normal (e : Ω.ientity) : Prop := e.genera.nonempty

/-- An entity is said to be (fully) **intelligible** if it is
    partially intelligible and normal if it is a trope.
    We should expect all entities to be intelligible. -/
def ientity.int (e : Ω.ientity) : Prop := e.pint ∧ e.trope → e.normal

-- TODO: revise the following two definitions to use genera directly in case they don't
-- define what is intended:

/-- An entity is said to be **generically unclassifiable** if it doesn't have a greatest genus. -/
def ientity.gunclass (e : Ω.ientity) : Prop := ¬ ∃ d ∈ e.dgenera, ∀ d' ∈ e.dgenera, d ≤ d'

/-- An entity is said to be **specifically unclassifiable** if it doesn't have an infima species. -/
def ientity.sunclass (e : Ω.ientity) : Prop := ¬ ∃ d ∈ e.dgenera, ∀ d' ∈ e.dgenera, d' ≤ d

/-- An entity is said to be **partially unclassifiable** if it is either
    specifically or generically unclassifiable. -/
def ientity.punclass (e : Ω.ientity) : Prop := e.gunclass ∨ e.sunclass

/-- An entity is said to be **unclassifiable** if it is both
    specifically or generically unclassifiable. -/
def ientity.unclass (e : Ω.ientity) : Prop := e.gunclass ∧ e.sunclass

/-- An entity is said to be **classifiable** if it is not partially unclassifiable. -/
def ientity.class (e : Ω.ientity) : Prop := ¬ e.punclass

/-- An entity is said to be **partially classifiable** if it is not unclassifiable. -/
def ientity.pclass (e : Ω.ientity) : Prop := ¬ e.unclass

/-- An entity is said to be **fully classifiable** if it is normal and has a finite number of genera.
    It can then be classified taxonomically without appeal to its tropes. -/
def ientity.fclass (e : Ω.ientity) : Prop := e.genera.finite ∧ e.normal

end basic

section principles

variables {Ω : ω.iontology} [sim : Ω.sim]
include sim

def esse_of_possibilia : Prop := ∀ (e₁ e₂ : Ω.ientity), 0 < e₁.sim e₂

end principles

section basic_theorems

variables {Ω : ω.iontology} [sim : Ω.sim]
include sim

/-- **Universal Analogy of Being** -/
lemma uab : ∀ e, ∃ (d : fuzzy) (C : set Ω.ientity), aclique d C ∧ e ∈ C :=
  begin
    intros e, use [0, univ], simp,
    constructor, constructor,
      simp [clique], intros,
        admit,
      intros, apply eq_of_subset_of_subset,
      assumption,
      simp,
    clear e, simp [rclass], intro e,
    suffices c : sdsim e ∅ = 0,
      rw c,
      -- needs appropriate type classes for this to work:
      admit, --exact zero_le (inf_sim univ),
    admit,
  end

-- TODO: It seems that we could prove the following result for acliques,
-- if we assume full blown transitivity of the similarity relation.
-- The principle is that the similarity between x and z, is ≤ to the
-- least of the similarities between x and y, and z and y, for all y. This implies that if
-- the similarities between x and y, and z and y, are the same, then the similarity between x and z
-- should be at least as high. In the second lemma we however know that the similarity between
-- t₁ and t₂ is strictly capped at d, and yet that they should both be at least d-similar to t, which
-- is absurd given transitivity, but not given mere triangularity.

-- TODO: It seems possible that we might also just be able to prove that under transitivity
-- all acliques are sacliques. This remains to be investigated.

-- admits are only due to the type classes problem.
lemma saclique_disjoint : ∀ d (C C' : set Ω.ientity), C ≠ C' → saclique d C → saclique d C' → C ∩ C' = ∅ :=
  begin
    intros d C C' neq h₁ h₂,
    have c₁ : ∃ t₁ ∈ C, t₁ ∉ C',
      by_contradiction contra,
      push_neg at contra,
      replace h₁ := h₁.1.2,
      replace h₂ := h₂.1.1,
      specialize h₁ C' h₂ contra,
      contradiction,
    have c₂ : ∃ t₂ ∈ C', t₂ ∉ C,
      by_contradiction contra,
      push_neg at contra,
      replace h₂ := h₂.1.2,
      replace h₁ := h₁.1.1,
      specialize h₂ C h₁ contra,
      cases h₂, contradiction,
    by_contradiction contra,
    simp [ext_iff] at contra,
    obtain ⟨t, h₁t, h₂t⟩ := contra,
    obtain ⟨t₁, h₁t₁, h₂t₁⟩ := c₁,
    obtain ⟨t₂, h₁t₂, h₂t₂⟩ := c₂,
    replace h₁ := h₁.2, simp [srclass] at h₁,
    specialize h₁ t h₁t,
    replace h₂ := h₂.2, simp [srclass] at h₂,
    specialize h₂ t h₂t,
    have c₁ : t.sim t₂ ≤ sdsim t (-C), admit,
    have c₁' : inf_sim (C) ≤ t.sim t₁, admit,
    have c₁'' : t.sim t₂ < t.sim t₁,
      have := lt_of_le_of_lt c₁ h₁,
      exact lt_of_lt_of_le this c₁',
    have c₂ : t.sim t₁ ≤ sdsim t (-C'), admit,
    have c₂' : inf_sim (C') ≤ t.sim t₂, admit,
    have c₂'' : t.sim t₁ < t.sim t₂,
      have := lt_of_le_of_lt c₂ h₂,
      exact lt_of_lt_of_le this c₂',
    have c₃ := lt_trans c₁'' c₂'',
    simp [lt_irrefl] at c₃,
    contradiction,
  end

lemma saclique_not_subset : ∀ d d' (C C' : set Ω.ientity), C ≠ C' → saclique d C → saclique d' C' → C ∩ C' ≠ ∅ → d ≤ d' → ¬ C ⊆ C' := sorry

lemma saclique_ssubset : ∀ d d' (C C' : set Ω.ientity), saclique d C → saclique d' C' → C ∩ C' ≠ ∅ → d ≤ d' → C' ⊆ C :=
  begin
    intros d d' C C' h₁ h₂ h₃ h₄,
    by_cases h : C = C', cases h, refl,
    have c₁ : ∃ t₁ ∈ C, t₁ ∉ C',
      by_contradiction absurd,
      push_neg at absurd,
      have c := saclique_not_subset d d' C C' h h₁ h₂ h₃ h₄,
      contradiction,
    by_contradiction contra,
    simp [has_subset.subset, set.subset] at contra,
    simp [ext_iff] at h₃,
    obtain ⟨t, h₁t, h₂t⟩ := h₃,
    obtain ⟨t₁, h₁t₁, h₂t₁⟩ := c₁,
    obtain ⟨t₂, h₁t₂, h₂t₂⟩ := contra,
    replace h₁ := h₁.2, simp [srclass] at h₁,
    specialize h₁ t h₁t,
    replace h₂ := h₂.2, simp [srclass] at h₂,
    specialize h₂ t h₂t,
    have c₁ : t.sim t₂ ≤ sdsim t (-C), admit,
    have c₁' : inf_sim (C) ≤ t.sim t₁, admit,
    have c₁'' : t.sim t₂ < t.sim t₁,
      have := lt_of_le_of_lt c₁ h₁,
      exact lt_of_lt_of_le this c₁',
    have c₂ : t.sim t₁ ≤ sdsim t (-C'), admit,
    have c₂' : inf_sim (C') ≤ t.sim t₂, admit,
    have c₂'' : t.sim t₁ < t.sim t₂,
      have := lt_of_le_of_lt c₂ h₂,
      exact lt_of_lt_of_le this c₂',
    have c₃ := lt_trans c₁'' c₂'',
    simp [lt_irrefl] at c₃,
    contradiction,

  end

end basic_theorems

section being

-- We lift tropes to a structure to generate a namespace for dot notation:
structure trope (Ω : ω.iontology) [sim : Ω.sim] :=
  (up : Ω.ientity)
  (p : up.trope)
variables {Ω : ω.iontology} [sim : Ω.sim] (t : Ω.trope)
include sim

/-- A **proper trope** is a normal trope incompatible with any distinct consubstantial trope in the same genus as itself. -/
def trope.proper (t : Ω.trope) : Prop :=
  t.normal ∧ ∀ (C) d ∈ t.genera, ptclique d C t →
  ∀ t' ∈ C, t' ≠ t → t'.up ≈ t.up → ¬⋄(t'.up.exists ∩ t.up.exists)

/-- A **composable trope** is an improper normal trope.
    Composable tropes "compose" to achieve some characteristic rather
    than being singularly responsible for the characteristic.
    A 1kg composable trope, for instance, could be composed with another 1kg composable trope,
    to characterize its object as being 2kg. -/
def trope.composable (t : Ω.trope) : Prop := ¬t.proper ∧ t.normal

/-- A **complemented trope** is a proper trope for which there exists another distinct consubstantial proper trope sharing a genus. -/
def trope.complemented (t : Ω.trope) : Prop :=
  t.proper ∧ ∃ (C : set Ω.trope) d ∈ t.genera, t ∈ C ∧ ptclique d C ∧
  ∃ t' ∈ C, t' ≠ t ∧ t'.up ≈ t.up ∧ t'.proper

/-- An **eminent** trope is a composable trope non-vacuously
    compatible with all complemented tropes in all of its genera.
    Naturally, they are not consubstantial to these complemented tropes.
    Mental tropes are eminent tropes, for consider the trope in virtue of which you are thinking about a square,
    this appears to be composable with a trope in virtue of which you are thinking about a circle,
    since they compose to characterize you as thinking about some square and some circle
    (I do not mean to say you are thinking about a squared-circle). These tropes are members of the
    same genus of "mental geometric figure tropes". Furthermore,
    these tropes are compatible with the existence of extra-mental squares and circles,
    which are objects characterized by complemented "square" and "circular" tropes.
    It is unclear to us whether there are any non-eminent composable tropes, or any non-mental eminent tropes. -/
def trope.eminent (t : Ω.trope) : Prop :=
  t.composable ∧ ∀ (C) d ∈ t.genera, ptclique d C t →
  (∃ (t' : Ω.trope), t' ∈ C ∧ t'.complemented) ∧
  ∀ (t' : Ω.trope), t' ∈ C → t'.complemented → ⋄(t'.up.exists ∩ t.up.exists)

/-- A **formal** trope is a non-eminent normal trope. -/
def trope.formal (t : Ω.trope) : Prop := ¬t.eminent ∧ t.normal

end being

end iontology

end ontology


import category_theory.abelian.homology
import for_mathlib.homotopy_category_pretriangulated
import category_theory.limits.constructions.epi_mono
import for_mathlib.homology_iso
import for_mathlib.homotopy_category_coproducts
import category_theory.abelian.homology

namespace category_theory

open category_theory.limits

universes v u

class AB4 (A : Type u) [category.{v} A] [has_coproducts A] : Prop :=
(cond : ∀ {α : Type v} (X Y : α → A) (f : Π a, X a ⟶ Y a)
  (hf : ∀ a, mono (f a)), mono (sigma.desc $ λ a, f a ≫ sigma.ι Y a))

variables {A : Type u} [category.{v} A]

instance AB4_mono
  [has_coproducts A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : Π a, X a ⟶ Y a)
  [∀ a, mono (f a)] : mono (sigma.desc $ λ a, f a ≫ sigma.ι Y a) :=
begin
  apply AB4.cond, assumption,
end

variable (A)
noncomputable
def sigma_functor
  [has_coproducts A]
  (α : Type v) : (α → A) ⥤ A :=
{ obj := λ X, sigma_obj X,
  map := λ X Y f, sigma.desc $ λ a, f a ≫ sigma.ι _ a } .
variable {A}

instance sigma_functor_preserves_mono
  [has_coproducts A] [AB4 A]
  (α : Type v)
  {X Y : α → A} (f : X ⟶ Y) [∀ a, mono (f a)] :
  mono ((sigma_functor A α).map f) :=
category_theory.AB4_mono X Y f

instance sigma_functor_preserves_epi
  [has_coproducts A]
  (α : Type v)
  {X Y : α → A} (f : X ⟶ Y) [∀ a, epi (f a)] :
  epi ((sigma_functor A α).map f) :=
begin
  constructor, intros Z s t h,
  apply colimit.hom_ext,
  intros a,
  dsimp [sigma_functor] at h,
  apply_fun (λ e, colimit.ι _ a ≫ e) at h,
  simp at h,
  rwa cancel_epi at h,
end

lemma AB4_of_preserves_colimits_of_reflects_limits_of_AB4
  {A B : Type u} [category.{v} A] [category.{v} B]
  [has_coproducts A]
  [has_coproducts B]
  (F : A ⥤ B)
  [preserves_colimits F]
  [creates_limits F]
  [has_limits B]
  [AB4 B] : AB4 A :=
begin
  constructor, introsI a X Y f hf,
  let t := _, change mono t,
  suffices : mono (F.map t),
  { resetI, apply reflects_mono F },
  let eX : F.obj (∐ λ (a : a), X a) ≅ (∐ λ a, F.obj (X a)) :=
    (is_colimit_of_preserves F (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso
      (nat_iso.of_components (λ _, iso.refl _) _),
  swap, { rintro i _ ⟨⟨⟨⟩⟩⟩, dsimp, simp, dsimp, simp },
  let eY : F.obj (∐ λ (a : a), Y a) ≅ (∐ λ a, F.obj (Y a)) :=
    (is_colimit_of_preserves F (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso
      (nat_iso.of_components (λ _, iso.refl _) _),
  swap, { rintro i _ ⟨⟨⟨⟩⟩⟩, dsimp, simp, dsimp, simp },
  let tt : (∐ λ a, F.obj (X a)) ⟶ (∐ λ a, F.obj (Y a)) :=
    sigma.desc (λ a, F.map (f a) ≫ sigma.ι _ a),
  haveI : mono tt,
  { apply AB4.cond, intros a,
    apply category_theory.preserves_mono F },
  suffices : F.map t = eX.hom ≫ tt ≫ eY.inv,
  { rw this, apply mono_comp },
  apply (is_colimit_of_preserves F (colimit.is_colimit _)).hom_ext,
  swap, apply_instance,
  intros i,
  erw [← F.map_comp, colimit.ι_desc, F.map_comp],
  dsimp [eX, tt, t, eY, limits.is_colimit.cocone_point_unique_up_to_iso, is_colimit_of_preserves,
    has_colimit.iso_of_nat_iso, is_colimit.map],
  slice_rhs 0 1
  { erw (is_colimit_of_preserves F (colimit.is_colimit _)).fac },
  slice_rhs 0 1
  { erw colimit.ι_desc },
  dsimp [iso.refl],
  simp,
end

noncomputable
example {X Y Z : A} [abelian A]
  (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0): cokernel (image_to_kernel' f g w) ≅ homology f g w :=
  (homology_iso_cokernel_image_to_kernel' f g w).symm

noncomputable
def coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] (i : M) (X : α → homological_complex A S) :
  (∐ λ (a : α), kernel ((X a).d_from i)) ⟶ kernel ((∐ X).d_from i) :=
sigma.desc $ λ a, kernel.lift _ (kernel.ι _ ≫ (sigma.ι _ a : X a ⟶ ∐ X).f i)
begin
  rw [category.assoc, (sigma.ι X a : X a ⟶ _).comm_from, ← category.assoc, kernel.condition,
    zero_comp],
end

-- This should follow from the AB4 assumption
instance mono_coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i : M) (X : α → homological_complex A S) :
mono (coproduct_kernel_comparison M S α i X) :=
begin
  let ι : kernel ((∐ X).d_from i) ⟶ _ := kernel.ι _,
  let t := _, change (mono t),
  suffices : mono (t ≫ ι),
  { resetI, apply mono_of_mono t ι },
  let F : homological_complex A S ⥤ A := homological_complex.eval _ _ i,
  let E : (∐ X).X i ≅ (∐ λ b, (X b).X i) :=
    (is_colimit_of_preserves F (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  suffices : t ≫ ι = sigma.desc (λ a, kernel.ι _ ≫ (sigma.ι (λ b, (X b).X i) a)) ≫ E.inv,
  { rw this, apply_instance },
  dsimp [t,ι, coproduct_kernel_comparison],
  apply colimit.hom_ext, intros a,
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, kernel.lift_ι, category.assoc,
    has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
    colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
    colimit.cocone_ι, homological_complex.eval_map],
  dsimp, simp only [category.id_comp],
end

lemma eval_next_aux_none
  (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (X : homological_complex A S)
  (i : M) (h : S.next i = none) : is_zero (X.X_next i) :=
begin
  dsimp [homological_complex.X_next],
  simp [h],
  dsimp [homological_complex.X_next._match_1],
  exact is_zero_zero A,
end

noncomputable
def eval_next (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (i : M) :
  homological_complex A S ⥤ A :=
{ obj := λ X, X.X_next i,
  map := λ X Y f, f.next i,
  map_id' := begin
    intros X,
    rcases h : S.next i with _ | ⟨j,w⟩,
    { apply limits.is_zero.eq_of_src, apply eval_next_aux_none, exact h },
    { simp [homological_complex.hom.next_eq _ w], },
  end,
  map_comp' := begin
    intros X Y Z f g,
    rcases h : S.next i with _ | ⟨j,w⟩,
    { apply limits.is_zero.eq_of_src, apply eval_next_aux_none, exact h },
    { simp [homological_complex.hom.next_eq _ w] }
  end }

open_locale zero_object

noncomputable
def preserves_colimits_of_shape_const_zero_aux
  (α : Type v) (M : Type*) (S : complex_shape M)
  [abelian A] [has_coproducts A]
  (K : discrete α ⥤ homological_complex A S) :
  is_colimit (((functor.const _).obj (0 : A)).map_cocone (colimit.cocone K)) :=
{ desc := λ S, 0,
  fac' := λ S j, (is_zero_zero _).eq_of_src _ _,
  uniq' := λ S m hm, (is_zero_zero _).eq_of_src _ _ }

noncomputable
instance preserves_colimits_of_shape_const_zero
  (α : Type v) (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts A] :
  preserves_colimits_of_shape (discrete α)
  ((functor.const _).obj 0 : homological_complex A S ⥤ A) :=
begin
  constructor, intros K,
  apply preserves_colimit_of_preserves_colimit_cocone
    (colimit.is_colimit K),
  apply preserves_colimits_of_shape_const_zero_aux,
end

noncomputable
def eval_next_iso_of_none
  (M : Type*) (S : complex_shape M) [abelian A] (i : M)
  (h : S.next i = none) :
  eval_next A S i ≅ (functor.const _).obj 0 :=
nat_iso.of_components
(λ X, limits.is_zero.iso_zero $ eval_next_aux_none _ _ _ _ h)
begin
  intros X Y f,
  apply is_zero.eq_of_tgt,
  apply is_zero_zero,
end

noncomputable
def eval_next_iso_of_some
  (M : Type*) (S : complex_shape M) [abelian A] (i j : M) (w)
  (h : S.next i = some ⟨j,w⟩) :
  eval_next A S i ≅ homological_complex.eval _ _ j :=
nat_iso.of_components
(λ X, homological_complex.X_next_iso _ w)
begin
  intros X Y f,
  dsimp [eval_next],
  rw homological_complex.hom.next_eq _ w,
  simp,
end

noncomputable
instance eval_next_preserves_coproducts (α : Type v)
  (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts A] (i : M) :
  preserves_colimits_of_shape (discrete α) (eval_next A S i) :=
begin
  rcases h : S.next i with _ | ⟨j,w⟩,
  { apply preserves_colimits_of_shape_of_nat_iso
      (eval_next_iso_of_none M S i h).symm,
    apply_instance },
  { apply preserves_colimits_of_shape_of_nat_iso
      (eval_next_iso_of_some M S i j w h).symm,
    apply_instance }
end

lemma eval_prev_aux_none
  (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (X : homological_complex A S)
  (i : M) (h : S.prev i = none) : is_zero (X.X_prev i) :=
begin
  dsimp [homological_complex.X_prev],
  simp [h],
  dsimp [homological_complex.X_prev._match_1],
  exact is_zero_zero A,
end

noncomputable
def eval_prev (A : Type u) [category.{v} A] [abelian A] {M : Type*}
  (S : complex_shape M) (i : M) :
  homological_complex A S ⥤ A :=
{ obj := λ X, X.X_prev i,
  map := λ X Y f, f.prev i,
  map_id' := begin
    intros X,
    rcases h : S.prev i with _ | ⟨j,w⟩,
    { apply limits.is_zero.eq_of_src, apply eval_prev_aux_none, exact h },
    { simp [homological_complex.hom.prev_eq _ w], },
  end,
  map_comp' := begin
    intros X Y Z f g,
    rcases h : S.prev i with _ | ⟨j,w⟩,
    { apply limits.is_zero.eq_of_src, apply eval_prev_aux_none, exact h },
    { simp [homological_complex.hom.prev_eq _ w] }
  end }

noncomputable
def eval_prev_iso_of_none
  (M : Type*) (S : complex_shape M) [abelian A] (i : M)
  (h : S.prev i = none) :
  eval_prev A S i ≅ (functor.const _).obj 0 :=
nat_iso.of_components
(λ X, limits.is_zero.iso_zero $ eval_prev_aux_none _ _ _ _ h)
begin
  intros X Y f,
  apply is_zero.eq_of_tgt,
  apply is_zero_zero,
end

noncomputable
def eval_prev_iso_of_some
  (M : Type*) (S : complex_shape M) [abelian A] (i j : M) (w)
  (h : S.prev i = some ⟨j,w⟩) :
  eval_prev A S i ≅ homological_complex.eval _ _ j :=
nat_iso.of_components
(λ X, homological_complex.X_prev_iso _ w)
begin
  intros X Y f,
  dsimp [eval_prev],
  rw homological_complex.hom.prev_eq _ w,
  simp,
end

noncomputable
instance eval_prev_preserves_coproducts (α : Type v)
  (M : Type*) (S : complex_shape M) [abelian A] [has_coproducts A] (i : M) :
  preserves_colimits_of_shape (discrete α) (eval_prev A S i) :=
begin
  rcases h : S.prev i with _ | ⟨j,w⟩,
  { apply preserves_colimits_of_shape_of_nat_iso
      (eval_prev_iso_of_none M S i h).symm,
    apply_instance },
  { apply preserves_colimits_of_shape_of_nat_iso
      (eval_prev_iso_of_some M S i j w h).symm,
    apply_instance }
end

lemma exact_iff_exact_cokernel_desc [abelian A] (X Y Z : A)
  (f : X ⟶ Y) (g : Y ⟶ Z) :
  exact f g ↔ ∃ w, mono (cokernel.desc f g w) :=
begin
  split,
  { intros h, refine ⟨h.w, _⟩,
    apply abelian.pseudoelement.mono_of_zero_of_map_zero,
    intros a ha,
    have h' : exact f (cokernel.π f) := abelian.exact_cokernel f,
    replace h' := abelian.pseudoelement.pseudo_exact_of_exact h',
    have hπ := abelian.pseudoelement.pseudo_surjective_of_epi (cokernel.π f),
    obtain ⟨b,rfl⟩ := hπ a,
    rw [← abelian.pseudoelement.comp_apply, cokernel.π_desc] at ha,
    replace h := abelian.pseudoelement.pseudo_exact_of_exact h,
    obtain ⟨b,rfl⟩ := h.2 _ ha,
    rw [← abelian.pseudoelement.comp_apply, cokernel.condition],
    simp only [abelian.pseudoelement.zero_apply] },
  { rintros ⟨w,h⟩, rw abelian.exact_iff, refine ⟨w, _⟩, resetI,
    rw ← cancel_mono (cokernel.desc f g w),
    simp only [category.assoc, cokernel.π_desc, kernel.condition, zero_comp] }
end

lemma exact_iff_exact_of_cofork [abelian A] (X Y Z : A)
  (f : X ⟶ Y) (g : Y ⟶ Z) (T : cokernel_cofork f) (hT : is_colimit T) :
  exact f g ↔ ∃ w : f ≫ g = 0,
  mono (hT.desc (cokernel_cofork.of_π g w)) :=
begin
  let e : T.X ≅ cokernel f :=
    hT.cocone_point_unique_up_to_iso (colimit.is_colimit _),
  rw exact_iff_exact_cokernel_desc,
  apply exists_congr (λ w, _),
  have : hT.desc (cokernel_cofork.of_π g w) =
    e.hom ≫ cokernel.desc f g w,
  { dsimp [e, limits.is_colimit.cocone_point_unique_up_to_iso],
    apply hT.hom_ext, intros i,
    simp only [is_colimit.fac, is_colimit.fac_assoc, colimit.cocone_ι,
      colimit.ι_desc] },
  rw this,
  split,
  { introI _, apply_instance },
  { introI, constructor,
    intros Z a b h,
    rw [← cancel_mono e.inv, ← cancel_mono (e.hom ≫ cokernel.desc f g w)],
    simpa }
end

noncomputable
def sigma_cokernel_cofork [abelian A] [has_coproducts A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : X ⟶ Y) :
  cokernel_cofork ((sigma_functor A α).map f) :=
cokernel_cofork.of_π
(sigma.desc (λ a : α, cokernel.π (f a) ≫ sigma.ι (λ b, cokernel (f b)) a))
begin
  apply colimit.hom_ext,
  intros a,
  dsimp [sigma_functor],
  simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
    colimit.ι_desc, cokernel.condition_assoc, zero_comp,
    comp_zero],
end

noncomputable
def is_colimit_sigma_cokernel_cofork [abelian A] [has_coproducts A] [AB4 A]
  {α : Type v} (X Y : α → A) (f : X ⟶ Y) :
  is_colimit (sigma_cokernel_cofork X Y f) :=
is_colimit_aux _
(λ S, sigma.desc $ λ b, cokernel.desc _ (sigma.ι _ _ ≫ S.π)
  begin
    rw ← category.assoc,
    let t := _, change t ≫ _ = _,
    have ht : t = sigma.ι X b ≫ (sigma_functor A α).map f,
    { dsimp [sigma_functor], simp },
    rw ht, clear ht, clear t,
    rw [category.assoc, S.condition, comp_zero],
  end)
begin
  intros S,
  dsimp [sigma_cokernel_cofork],
  apply colimit.hom_ext,
  simp only [category.assoc, colimit.ι_desc, cofan.mk_ι_app, eq_self_iff_true,
    cokernel_cofork.condition, comp_zero,
    colimit.ι_desc_assoc, cokernel.π_desc, implies_true_iff],
end
begin
  intros S m hm,
  apply colimit.hom_ext, intros a,
  simp only [colimit.ι_desc, cofan.mk_ι_app],
  apply coequalizer.hom_ext, simp only [coequalizer_as_cokernel, cokernel.π_desc],
  simp_rw [← hm, ← category.assoc], congr' 1,
  dsimp [sigma_cokernel_cofork],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
end

lemma exact_coproduct [abelian A] [has_coproducts A] [AB4 A]
  {α : Type v} (X Y Z : α → A) (f : X ⟶ Y) (g : Y ⟶ Z)
  (w : ∀ i, exact (f i) (g i)) :
  exact ((sigma_functor A α).map f) ((sigma_functor A α).map g) :=
begin
  let ι : (λ a : α, cokernel (f a)) ⟶ Z :=
    λ a, (cokernel.desc _ (g a) (w a).w),
  let π : Y ⟶ (λ a : α, cokernel (f a)) :=
    λ a, (cokernel.π _),
  haveI : ∀ a, mono (ι a),
  { intros a,
    suffices : ∃ w, mono (cokernel.desc (f a) (g a) w),
    { obtain ⟨q,h⟩ := this, exact h },
    rw ← exact_iff_exact_cokernel_desc, apply w },
  have : mono ((sigma_functor A α).map ι),
  { apply AB4.cond, assumption },
  -- Now need to show that sigma functor commutes with cokernels
  -- Use the fact that this commutes with cokernels to identify the source
  -- with the cokernel of `f`.
  -- Then use exact_iff_exact_cokernel_desc
  rw exact_iff_exact_of_cofork
    ((sigma_functor A α).obj X)
    ((sigma_functor A α).obj Y)
    ((sigma_functor A α).obj Z)
    ((sigma_functor A α).map f)
    ((sigma_functor A α).map g)
    (sigma_cokernel_cofork _ _ f)
    (is_colimit_sigma_cokernel_cofork _ _ f),
  refine ⟨_,_⟩,
  { apply colimit.hom_ext, intros a,
    dsimp [sigma_functor],
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc, comp_zero],
    rw [← category.assoc, (w a).w, zero_comp] },
  simp only [exact_iff_exact_cokernel_desc] at w,
  choose w₁ w₂ using w,
  convert AB4.cond _ Z ι w₂ using 1,
  apply colimit.hom_ext, intros a,
  dsimp [is_colimit_sigma_cokernel_cofork, is_colimit_aux],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
  apply coequalizer.hom_ext,
  simp only [cokernel.π_desc, cokernel.π_desc_assoc],
  dsimp [sigma_functor],
  simp only [colimit.ι_desc, cofan.mk_ι_app],
end

section
open_locale pseudoelement
instance epi_coproduct_kernel_comparison [has_coproducts A] [AB4 A]
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] (i : M) (X : α → homological_complex A S) :
  epi (coproduct_kernel_comparison M S α i X) :=
begin
  /-
     _ -ι₁-> _ -π₁-> _
     |       |       |
     t     E.inv   Q.inv
     |       |       |
     v       v       v
     _ -ι₂-> _ -π₂-> _

  -/
  let t := _, change epi t,
  let F : homological_complex A S ⥤ A := homological_complex.eval _ _ i,
  let N : homological_complex A S ⥤ A := eval_next _ _ i,
  let E : (∐ X).X i ≅ (∐ λ b, (X b).X i) :=
    (is_colimit_of_preserves F (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  let Q : (∐ X).X_next i ≅ (∐ λ b, (X b).X_next i) :=
    (is_colimit_of_preserves N (colimit.is_colimit
      (discrete.functor X))).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫
      has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  let ι₁ : (∐ λ (a : α), kernel ((X a).d_from i)) ⟶ (∐ λ b, (X b).X i) :=
    sigma.desc (λ a, kernel.ι _ ≫ sigma.ι _ a),
  let π₁ : (∐ λ b, (X b).X i) ⟶ (∐ λ b, (X b).X_next i) :=
    sigma.desc (λ a, (X a).d_from i ≫ sigma.ι _ a),
  let ι₂ : kernel ((∐ X).d_from i) ⟶ (∐ X).X i := kernel.ι _,
  let π₂ : (∐ X).X i ⟶ (∐ X).X_next i := (∐ X).d_from i,
  have sqι : ι₁ ≫ E.inv = t ≫ ι₂,
  { apply colimit.hom_ext, intros a, dsimp [ι₁, E, t, ι₂],
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
      has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
      colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
      colimit.cocone_ι, homological_complex.eval_map],
    dsimp [coproduct_kernel_comparison],
    simp only [category.id_comp, colimit.ι_desc_assoc, cofan.mk_ι_app, kernel.lift_ι] },
  have sqπ : π₁ ≫ Q.inv = E.inv ≫ π₂,
  { dsimp [π₁, Q, E, π₂, coproduct_kernel_comparison], apply colimit.hom_ext, intros a,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc,
      has_colimit.iso_of_nat_iso_ι_inv_assoc, discrete.nat_iso_inv_app,
      colimit.comp_cocone_point_unique_up_to_iso_inv, functor.map_cocone_ι_app,
      colimit.cocone_ι, colimit.comp_cocone_point_unique_up_to_iso_inv_assoc,
      homological_complex.eval_map],
    dsimp,
    simp only [homological_complex.hom.comm_from, category.id_comp],
    erw category.id_comp,
    refl },
  have e1 : exact ι₁ π₁,
  { apply exact_coproduct, intros b, exact exact_kernel_ι },
  have e2 : exact ι₂ π₂ := exact_kernel_ι,
  have hι₂ := abelian.pseudoelement.pseudo_injective_of_mono ι₂,
  replace e1 := abelian.pseudoelement.pseudo_exact_of_exact e1,
  replace e2 := abelian.pseudoelement.pseudo_exact_of_exact e2,
  have hEinv := abelian.pseudoelement.pseudo_surjective_of_epi E.inv,
  have hQinv := abelian.pseudoelement.pseudo_injective_of_mono Q.inv,
  apply abelian.pseudoelement.epi_of_pseudo_surjective,
  -- Now we start the diagram chase.
  intros x,
  let x' := ι₂ x,
  obtain ⟨y,hy⟩ := hEinv x',
  have hy' : π₁ y = 0,
  { apply hQinv,
    simp only [abelian.pseudoelement.apply_zero, ← abelian.pseudoelement.comp_apply, sqπ],
    rw [abelian.pseudoelement.comp_apply, hy],
    dsimp only [x'], rw e2.1 },
  obtain ⟨z,hz⟩ := e1.2 _ hy',
  use z,
  apply hι₂,
  rw [← abelian.pseudoelement.comp_apply, ← sqι, abelian.pseudoelement.comp_apply, hz, hy],
end
end

instance is_iso_coproduct_kernel_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i : M) (X : α → homological_complex A S) :
is_iso (coproduct_kernel_comparison M S α i X) :=
is_iso_of_mono_of_epi _

noncomputable
def coproduct_homology_comparison (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] (i : M) (X : α → homological_complex A S) :
  (∐ λ a : α, (X a).homology i) ⟶ (∐ X).homology i :=
sigma.desc $ λ b, (homology_functor _ _ _).map $ sigma.ι _ _

noncomputable
def coproduct_homology_comparison_inv (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  (∐ X).homology i ⟶ (∐ λ a : α, (X a).homology i) :=
homology.desc' _ _ _ (inv (coproduct_kernel_comparison M S α i X) ≫
  sigma.desc (λ b, homology.π' ((X b).d_to _) ((X b).d_from i)
    (homological_complex.d_to_comp_d_from _ _) ≫ sigma.ι _ b))
begin
  rw ← category.assoc, let t := _, change t ≫ _ = _,
  let e : (∐ X).X_prev i ≅ ∐ (λ a, (X a).X_prev i) :=
    (is_colimit_of_preserves (eval_prev A S i)
      (colimit.is_colimit _)).cocone_point_unique_up_to_iso
      (colimit.is_colimit _) ≪≫ has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ b, iso.refl _),
  have ht : t = e.hom ≫ sigma.desc (λ b, _ ≫ sigma.ι _ b),
  rotate 2,
  { refine kernel.lift _ _ _, exact (X b).d_to i,
    exact (X b).d_to_comp_d_from i },
  { dsimp [t, e, limits.is_colimit.cocone_point_unique_up_to_iso,
      has_colimit.iso_of_nat_iso, is_colimit.map, coproduct_kernel_comparison],
    rw is_iso.comp_inv_eq,
    apply (is_colimit_of_preserves (eval_prev A S i)
      (colimit.is_colimit (discrete.functor X))).hom_ext,
    intros j,
    apply equalizer.hom_ext,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι,
      equalizer_as_kernel, category.assoc, kernel.lift_ι],
    slice_rhs 1 2
    { erw (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).fac },
    dsimp [eval_prev],
    simp only [homological_complex.hom.comm_to, colimit.ι_desc, cocones.precompose_obj_ι,
      nat_trans.comp_app, discrete.nat_iso_hom_app, colimit.cocone_ι, category.assoc,
      cofan.mk_ι_app, kernel.lift_ι, kernel.lift_ι_assoc],
    dsimp, simp only [category.id_comp] },
  { rw ht,
    dsimp [e, limits.is_colimit.cocone_point_unique_up_to_iso],
    apply (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).hom_ext,
    intros j,
    simp only [functor.map_cocone_ι_app, colimit.cocone_ι, category.assoc,
      has_colimit.iso_of_nat_iso_hom_desc, comp_zero],
    slice_lhs 1 2
    { erw (is_colimit_of_preserves (eval_prev A S i) (colimit.is_colimit (discrete.functor X))).fac },
    simp only [colimit.cocone_ι, colimit.ι_desc, cocones.precompose_obj_ι, nat_trans.comp_app,
      cofan.mk_ι_app, category.assoc, homology.condition_π'_assoc, zero_comp, comp_zero] }
end

noncomputable
def coproduct_homology_iso
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  (∐ λ a : α, (X a).homology i) ≅ (∐ X).homology i :=
{ hom := coproduct_homology_comparison _ _ _ _ _,
  inv := coproduct_homology_comparison_inv _ _ _ _ _,
  hom_inv_id' := begin
    dsimp [coproduct_homology_comparison, coproduct_homology_comparison_inv],
    apply colimit.hom_ext, intros a,
    dsimp,
    simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, category.comp_id],
    apply homology.hom_from_ext,
    rw homology.map_eq_desc'_lift_left,
    simp only [homological_complex.hom.sq_from_left, homology.π'_desc'_assoc],
    let t := _, change t ≫ _ = _,
    have ht : t = kernel.lift _ (kernel.ι _ ≫ _) _ ≫ homology.π' _ _ _,
    rotate 2,
    { let e : X a ⟶ ∐ X := sigma.ι _ a, exact e.f i },
    { dsimp,
      rw [category.assoc, (sigma.ι X a : X a ⟶ ∐ X).comm_from, ← category.assoc,
        kernel.condition, zero_comp] },
    { dsimp [t], apply homology.hom_to_ext,
      simp only [category.assoc, homology.lift_ι, homological_complex.homology.π'_ι,
        kernel.lift_ι_assoc] },
    { rw ht, clear ht, clear t,
      rw [category.assoc, homology.π'_desc', ← category.assoc],
      let t := _, change t ≫ _ = _,
      have ht : t = sigma.ι _ a,
      { dsimp [t], rw is_iso.comp_inv_eq,
        apply equalizer.hom_ext,
        dsimp [coproduct_kernel_comparison],
        simp only [category.assoc, kernel.lift_ι],
        erw colimit.ι_desc_assoc,
        dsimp,
        simp only [kernel.lift_ι] },
      rw ht, clear ht, clear t,
      erw colimit.ι_desc,
      refl }
  end,
  inv_hom_id' := begin
    dsimp [coproduct_homology_comparison, coproduct_homology_comparison_inv],
    apply homology.hom_from_ext,
    simp only [homology.π'_desc'_assoc, category.assoc, category.comp_id,
      is_iso.inv_comp_eq],
    apply colimit.hom_ext, intros a,
    dsimp,
    simp only [homological_complex.hom.sq_from_right, homological_complex.hom.sq_to_right,
      colimit.ι_desc_assoc, cofan.mk_ι_app, category.assoc, colimit.ι_desc, homology.π'_map],
    erw colimit.ι_desc_assoc, refl,
  end }

noncomputable
def is_colimit_homology_map_cocone  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i : M) (X : α → homological_complex A S) :
  is_colimit ((homology_functor A S i).map_cocone (colimit.cocone (discrete.functor X))) :=
{ desc := λ E, (coproduct_homology_iso _ _ _ _ _).inv ≫ sigma.desc (λ a, E.ι.app _),
  fac' := begin
    intros E j,
    dsimp [coproduct_homology_comparison_inv, coproduct_homology_iso],
    apply homology.hom_from_ext,
    rw homology.map_eq_desc'_lift_left,
    simp only [homological_complex.hom.sq_from_left, homology.π'_desc'_assoc],
    let t := _, change t ≫ _ = _,
    have ht : t = kernel.lift _ (kernel.ι _ ≫ _) _ ≫ homology.π' _ _ _,
    rotate 2,
    { let e := (sigma.ι X j), exact e.f i },
    { dsimp, rw [category.assoc],
      erw (sigma.ι X j : X j ⟶ ∐ X).comm_from,
      rw [← category.assoc, kernel.condition, zero_comp] },
    { dsimp [t],
      apply homology.hom_to_ext,
      simp only [category.assoc, homology.lift_ι, homological_complex.homology.π'_ι,
        kernel.lift_ι_assoc] },
    rw ht, clear ht, clear t,
    simp only [category.assoc, homology.π'_desc'_assoc],
    simp only [← category.assoc],
    let t := _, change (t ≫ _) ≫ _ = _,
    have ht : t = sigma.ι _ j,
    { dsimp [t], rw [is_iso.comp_inv_eq],
      dsimp [coproduct_kernel_comparison],
      erw colimit.ι_desc, refl },
    rw ht, clear ht, clear t,
    simp only [category.assoc], erw [colimit.ι_desc_assoc], dsimp,
    rw [category.assoc, colimit.ι_desc], refl,
  end,
  uniq' := begin
    intros E m hm,
    rw iso.eq_inv_comp, dsimp [coproduct_homology_comparison, coproduct_homology_iso],
    apply colimit.hom_ext, intros j, specialize hm j,
    simpa only [←hm, colimit.ι_desc_assoc, cofan.mk_ι_app, colimit.ι_desc,
      functor.map_cocone_ι_app, colimit.cocone_ι,
      homology_functor_map],
  end }

noncomputable
instance homology_functor_preserves_coproducts
  (M : Type*) (S : complex_shape M) (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i) :
  preserves_colimits_of_shape (discrete α)
  (homology_functor A S i) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor K.obj := discrete.nat_iso (λ i, iso.refl _),
  suffices : preserves_colimit (discrete.functor K.obj) (homology_functor A _ i),
  { apply preserves_colimit_of_iso_diagram _ E.symm, assumption },
  apply preserves_colimit_of_preserves_colimit_cocone
    (colimit.is_colimit (discrete.functor K.obj)),
  apply is_colimit_homology_map_cocone,
end

noncomputable
def is_colimit_homotopy_category_homology_functor_map_cocone
  {α : Type v} [abelian A] [has_coproducts A] [AB4 A] (i)
  (K : α → homotopy_category A (complex_shape.up ℤ)) :
  is_colimit
  ((homotopy_category.homology_functor A (complex_shape.up ℤ) i).map_cocone
    (homotopy_category.colimit_cofan K)) :=
{ desc := λ S,
    (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
    (colimit.is_colimit $ discrete.functor $ λ i, (K i).as)).desc ⟨S.X,
    discrete.nat_trans $ λ i, S.ι.app i⟩,
  fac' := begin
    intros S j, dsimp,
    erw (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).fac,
    refl,
  end,
  uniq' := begin
    intros S m hm,
    apply (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).hom_ext,
    intros j,
    erw (is_colimit_of_preserves (homology_functor A (complex_shape.up ℤ) i)
      (colimit.is_colimit (discrete.functor (λ (i : α), (K i).as)))).fac,
    dsimp, rw ← hm, refl,
  end }

noncomputable
instance homotopy_category_homology_functor_preserves_coproducts
  (α : Type v)
  [abelian A] [has_coproducts A] [AB4 A] (i) :
  preserves_colimits_of_shape (discrete α)
  (homotopy_category.homology_functor A (complex_shape.up ℤ) i) :=
begin
  constructor, intros K,
  let E : K ≅ discrete.functor K.obj := discrete.nat_iso (λ i, iso.refl _),
  suffices : preserves_colimit (discrete.functor K.obj) (homotopy_category.homology_functor A _ i),
  { apply preserves_colimit_of_iso_diagram _ E.symm, assumption },
  apply preserves_colimit_of_preserves_colimit_cocone
    (homotopy_category.is_colimit_cofan K.obj),
  apply is_colimit_homotopy_category_homology_functor_map_cocone,
end

end category_theory


import complexity_class.tactic

open tencodable (encode decode)
open function

variables {C : complexity_class} {α β γ δ ε : Type} [tencodable α]
  [tencodable β] [tencodable γ] [tencodable δ] [tencodable ε]

namespace complexity_class
open_locale complexity_class
open_locale tree

@[complexity] lemma prod_mk : @prod.mk α β ∈ₑ C := C.id'
@[complexity] lemma cons : @list.cons α ∈ₑ C := C.id'
@[complexity] protected lemma encode : @encode α _ ∈ₑ C := C.id'
@[complexity] lemma sigma_mk : @complexity_class.mem _ _ (α → β → (Σ _ : α, β)) _ _ _ sigma.mk C := C.id'

lemma mem_iff_comp_encode {f : α → β} :
  f ∈ₑ C ↔ (λ x, encode (f x)) ∈ₑ C := iff.rfl

lemma mem_iff_comp_encode' {C : complexity_class} {β γ : Type} [tencodable γ] {f : β → α} {finv : α → option β} {linv : ∀ b, finv (f b) = some b}
  {g : γ → β} : by haveI : tencodable β := tencodable.of_left_injection f finv linv; exact
  g ∈ₑ C ↔ (λ x, f (g x)) ∈ₑ C := iff.rfl

@[complexity] lemma tree_left : @tree.left unit ∈ₑ C :=
⟨_, C.left, λ _, rfl⟩

@[complexity] lemma tree_right : @tree.right unit ∈ₑ C :=
⟨_, C.right, λ _, rfl⟩

@[complexity] lemma tree_node : (tree.node ()) ∈ₑ C :=
⟨_, C.id, λ _, rfl⟩

@[complexity] lemma unit_rec {f : α → unit} {g : α → β} (hg : g ∈ₑ C) :
  @complexity_class.mem _ _ (α → β) _ _ _ (λ x : α, @punit.rec (λ _, β) (g x) (f x)) C :=
by { convert hg, ext x, cases f x, refl, }

private lemma eq_nil_aux : (=@tree.nil unit) ∈ₚ C :=
⟨_, C.ite' C.id (C.prop_const $ encode tt)
  (C.prop_const $ encode ff), λ x, by cases x; simp [has_uncurry.uncurry]⟩

@[complexity] lemma coe_sort : (λ b : bool, (b : Prop)) ∈ₚ C :=
⟨_, C.id, λ _, by simp [has_uncurry.uncurry]⟩

@[complexity] lemma to_bool {P : α → Prop} [decidable_pred P] (hP : P ∈ₚ C) :
  C.mem (λ x, to_bool (P x)) :=
by { convert hP, ext, congr, }

@[complexity] protected lemma band : C.mem (&&) :=
by { complexity using (λ (b₁ b₂ : bool), if b₁ then b₂ else ff), cases b₁; simp, }

@[complexity] protected lemma bnot : C.mem bnot :=
by { complexity using (λ b, if b then ff else tt), cases b; refl, }

/-- Complexity classes are closed under intersection -/
@[complexity] protected lemma and {P₁ P₂ : α → Prop} (h₁ : P₁ ∈ₚ C) (h₂ : P₂ ∈ₚ C) :
  (λ x, (P₁ x) ∧ (P₂ x)) ∈ₚ C :=
by { classical, simp [← mem_iff_mem_pred], complexity, }

/-- Complexity classes are closed under complementation -/
@[complexity] protected lemma not {P : α → Prop} (h : P ∈ₚ C) : C.mem_pred (λ x, ¬(P x)) :=
by { classical, simp [← mem_iff_mem_pred], complexity, }

@[complexity] lemma eq_const_aux : ∀ (x : tree unit), (=x) ∈ₚ C
| tree.nil := eq_nil_aux
| (a △ b) :=
begin
  have := (eq_const_aux a).comp tree_left, have := (eq_const_aux b).comp tree_right, have := @eq_nil_aux C,
  complexity using (λ y, ¬(y = tree.nil) ∧ y.left = a ∧ y.right = b),
  cases y; simp,
end

@[complexity] lemma eq_const {f : α → β} (hf : f ∈ₑ C) (y : β) :
  C.mem_pred (λ x, (f x) = y) :=
by simpa using (eq_const_aux (encode y)).comp hf

@[complexity] lemma list_empty : @list.empty α ∈ₑ C :=
by { classical, complexity using λ l, l = [], cases l; simp, }

@[complexity] lemma option_is_none : @option.is_none α ∈ₑ C :=
by { classical, complexity using λ x, x = none, cases x; simp, }

@[complexity] lemma option_is_some : @option.is_some α ∈ₑ C :=
by { complexity using λ x, !x.is_none, cases x; simp, }

@[complexity] lemma tree_cases {f : α → tree unit} {g : α → β}
  {h : α → unit → tree unit → tree unit → β} (hf : f ∈ₑ C) (hg : g ∈ₑ C) (hh : h ∈ₑ C) :
  @complexity_class.mem α β (α → β) _ _ _ (λ x, @tree.cases_on unit (λ _, β) (f x) (g x) (h x)) C :=
begin
  complexity using (λ x, if f x = tree.nil then g x else h x () (f x).left (f x).right),
  rcases f x with (_|⟨⟨⟩, _, _⟩); simp,
end

lemma of_fin_cases [nonempty γ] (S : finset α)
  {f : α → β → γ} (hf : ∀ {x}, x ∈ S → f x ∈ₑ C) :
  ∃ f' : α → β → γ, f' ∈ₑ C ∧ ∀ {x}, x ∈ S → f x = f' x :=
begin
  classical, inhabit γ,
  induction S using finset.induction with x xs x_nmem ih,
  { refine ⟨λ _ _, default, by complexity, _⟩, simp, },
  rcases ih (λ _ h, hf (finset.mem_insert.mpr (or.inr h))) with ⟨f', pf, hf'⟩,
  set g := f x, have : g ∈ₑ C := by { apply hf, simp, },
  refine ⟨λ x' y, if x' = x then g y else f' x' y, by complexity, _⟩,
  intro x', split_ifs with H, { simp [H], }, { simpa [H] using hf', },
end

@[complexity] lemma of_to_empty [H : is_empty β] (f : α → β) : f ∈ₑ C :=
⟨_, C.nil, λ x, H.elim' (f x)⟩

/-- A function on a `fintype` is in the complexity class iff each function is (i.e. we can always do
  a finite amount of casework) -/
lemma of_from_fintype [fintype α] {f : α → β → γ} (hf : ∀ x, f x ∈ₑ C) : f ∈ₑ C :=
begin
  casesI is_empty_or_nonempty γ,
  { apply of_to_empty, },
  obtain ⟨f', pf, hf'⟩ := of_fin_cases (@finset.univ α _) (λ x _, hf x),
  convert pf, apply funext, simpa using @hf',
end

lemma iff_fintype [fintype α] {f : α → β → γ} :
  f ∈ₑ C ↔ ∀ x, f x ∈ₑ C :=
⟨λ h x, h.comp₂ (C.const x) C.id', of_from_fintype⟩

lemma of_from_fintype' [fintype α] (f : α → β) : f ∈ₑ C :=
let H : C.mem (λ x (_ : unit), f x) := of_from_fintype (λ x, C.const _)
 in H.comp₂ C.id' (C.const ())

@[complexity] protected lemma bor : bor ∈ₑ C := of_from_fintype' _

/-- Complexity classes are closed under union -/
@[primrec] protected lemma or {P Q : α → Prop} (hP : P ∈ₚ C) (hQ : Q ∈ₚ C) :
  C.mem_pred (λ x, (P x) ∨ (Q x)) :=
by { classical, simp [← mem_iff_mem_pred], complexity, }

section option

@[complexity] lemma option_elim {f : α → option β} {g : α → γ} {h : α → β → γ} :
  f ∈ₑ C → g ∈ₑ C → h ∈ₑ C → C.mem (λ x, (f x).elim (g x) (h x)) :=
begin
  rintros ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ ⟨h', ph, hh⟩, replace hh := λ x₁ x₂, hh (x₁, x₂),
  refine ⟨λ x, if f' x = tree.nil then g' x else h' (x △ (f' x).right), _, _⟩,
  { complexity, },
  intro x,
  simp only [hf, hg], dsimp [has_uncurry.uncurry],
  cases f x,
  { simp [encode], },
  { simpa [encode] using hh _ _, },
end

@[complexity] lemma option_rec {f : α → option β} {g : α → γ} {h : α → β → γ} (hf : f ∈ₑ C)
  (hg : g ∈ₑ C) (hh : h ∈ₑ C) :
  @complexity_class.mem α γ (α → γ) _ _ _ (λ x : α, @option.rec β (λ _, γ) (g x) (h x) (f x)) C :=
by { convert option_elim hf hg hh, ext x, cases f x; refl, }

@[complexity] protected lemma some : @option.some α ∈ₑ C :=
⟨_, C.pair C.nil C.id, λ _, rfl⟩

@[complexity] lemma succ : nat.succ ∈ₑ C := complexity_class.some

lemma of_some {f : α → β} : f ∈ₑ C ↔ C.mem (λ x, some (f x)) :=
⟨λ hf, by complexity, λ ⟨f', pf, hf⟩, ⟨_, C.comp C.right pf, λ _, by { simp [hf], refl, }⟩⟩

@[complexity] lemma option_bind {f : α → option β} {g : α → β → option γ} (hf : f ∈ₑ C)
  (hg : g ∈ₑ C) : C.mem (λ x, (f x).bind (g x)) :=
by { delta option.bind, clean_target, complexity, }

@[complexity] lemma option_map {f : α → option β} {g : α → β → γ} (hf : f ∈ₑ C) (hg : g ∈ₑ C) :
  C.mem (λ x, (f x).map (g x)) :=
by { delta option.map, complexity, }

def mem' {γ : Type} [has_uncurry γ α β] (f : γ) (C : complexity_class) : Prop :=
C.prop (λ x, encode $ (decode α x).map ↿f)

localized "infix ` ∈ₛ `:50 := complexity_class.mem'" in complexity_class

lemma mem_of_mem' {γ : Type} [has_uncurry γ α β] {f : γ} {C : complexity_class}
  (hf : f ∈ₛ C) : f ∈ₑ C := ⟨_, C.comp C.right hf, by simp [encode]⟩

lemma mem'_iff_mem_decode {γ : Type} [has_uncurry γ α β] {f : γ} {C : complexity_class} (h : decode α ∈ₑ C) :
  f ∈ₛ C ↔ f ∈ₑ C := ⟨mem_of_mem', λ H, by { dsimp only [mem'], complexity, }⟩

protected lemma decode : decode (tree unit) ∈ₑ C := complexity_class.some

lemma option_decode (h : decode α ∈ₑ C) : decode (option α) ∈ₑ C :=
by { simp only [decode], delta tencodable.to_option, clean_target, complexity, }

end option

section sum

@[complexity] lemma sum_elim {f : α → β ⊕ γ} {g : α → β → δ} {h : α → γ → δ} :
  f ∈ₑ C → g ∈ₑ C → h ∈ₑ C → C.mem (λ x, (f x).elim (g x) (h x)) :=
begin
  rintros ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ ⟨h', ph, hh⟩, simp only [prod.forall] at hg hh,
  refine ⟨λ x, if (f' x).left = tree.nil then g' (x △ (f' x).right)
               else h' (x △ (f' x).right), _, _⟩,
  { complexity, },
  intro x,
  simp only [hf, encode, tencodable.of_sum, tencodable.to_sum, has_uncurry.uncurry, id_def],
  cases f x,
  { simpa using hg _ _, },
  { simpa using hh _ _, }
end

@[complexity] lemma sum_inl : @sum.inl α β ∈ₑ C :=
⟨_, C.pair C.nil C.id, by simp [encode, has_uncurry.uncurry]⟩

@[complexity] lemma sum_inr : @sum.inr α β ∈ₑ C :=
⟨_, C.pair (C.prop_const tencodable.non_nil) C.id, by simp [encode, has_uncurry.uncurry]⟩

@[complexity] lemma sum_rec {f : α → β ⊕ γ} {g : α → β → δ} {h : α → γ → δ} (hf : f ∈ₑ C)
  (hg : g ∈ₑ C) (hh : h ∈ₑ C) :
  @complexity_class.mem α δ (α → δ) _ _ _ (λ x, @sum.rec β γ (λ _, δ) (g x) (h x) (f x)) C := sum_elim hf hg hh

-- TODO: some kind of derive handler for these things which are easy
@[complexity] lemma sum_get_right : @sum.get_right α β ∈ₑ C :=
by { delta sum.get_right, clean_target, complexity, }

lemma sum_decode (h₁ : decode α ∈ₑ C) (h₂ : decode β ∈ₑ C) : decode (α ⊕ β) ∈ₑ C :=
by { dsimp [decode], delta tencodable.to_sum, complexity, }

end sum

section prod

lemma prod_decode (h₁ : decode α ∈ₑ C) (h₂ : decode β ∈ₑ C) : decode (α × β) ∈ₑ C :=
by { dsimp [decode], complexity, }

@[complexity] lemma prod_rec {f : α → β × γ} {g : α → β → γ → δ} (hf : f ∈ₑ C) (hg : g ∈ₑ C) :
  @complexity_class.mem α δ (α → δ) _ _ _ (λ x, @prod.rec β γ (λ _, δ) (g x) (f x)) C :=
by { complexity using (λ x, g x (f x).1 (f x).2), cases f x; refl, }

end prod

section ordering

@[complexity] lemma ordering_swap : ordering.swap ∈ₑ C := of_from_fintype' _

@[complexity] lemma ordering_or_else : ordering.or_else ∈ₑ C := of_from_fintype' _

end ordering

section list

@[complexity] lemma list_cases {f : α → list β} {g : α → γ} {h : α → β → list β → γ} :
  f ∈ₑ C → g ∈ₑ C → h ∈ₑ C →
  @complexity_class.mem α γ (α → γ) _ _ _ (λ x, @list.cases_on β (λ _, γ) (f x) (g x) (h x)) C :=
begin
  rintros ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ ⟨h', ph, hh⟩, replace hh := λ x₁ x₂ x₃, hh (x₁, x₂, x₃),
  use λ x, if f' x = tree.nil then g' x else h' (encode (x, (f' x).left, (f' x).right)),
  split, { complexity, },
  intro x, simp only [hf, hg], dsimp [has_uncurry.uncurry, id],
  cases f x, { simp [encode], }, { simpa [encode] using hh _ _ _, },
end

@[complexity] lemma head' : (@list.head' α) ∈ₑ C :=
by { delta list.head', clean_target, complexity, }

@[complexity] lemma head [inhabited α] : (@list.head α _) ∈ₑ C :=
by { delta list.head, clean_target, complexity, }

@[complexity] lemma tail : (@list.tail α) ∈ₑ C :=
by { delta list.tail, clean_target, complexity, }

@[complexity] lemma pred : nat.pred ∈ₑ C :=
⟨_, C.right, λ n, by cases n; simp [has_uncurry.uncurry, encode]⟩

@[complexity] protected lemma equiv_list : ⇑tencodable.equiv_list ∈ₑ C :=
⟨_, C.id, λ x, by simp [encode, has_uncurry.uncurry]⟩

@[complexity] protected lemma equiv_list_symm : ⇑tencodable.equiv_list.symm ∈ₑ C :=
⟨_, C.id, λ x, by simp [encode, has_uncurry.uncurry]⟩

lemma const_list_nth (n : ℕ) : (λ l : list α, l.nth n) ∈ₑ C :=
begin
  induction n with n ih, { convert head', ext x : 1, cases x; refl, },
  have : (λ l : list α, l.tail.nth n) ∈ₑ C := ih.comp tail,
  complexity using λ l, if l.empty then none else l.tail.nth n,
  cases l; simp,
end

end list

section equiv

lemma encode_of_left_injection  {β : Type} {f : β → α} {finv : α → option β} {linv : ∀ b, finv (f b) = some b} :
  by haveI : tencodable β := tencodable.of_left_injection f finv linv; exact f ∈ₑ C :=
⟨_, C.id, λ x, rfl⟩

lemma decode_of_left_injection  {β : Type} {f : β → α} {finv : α → option β} {linv : ∀ b, finv (f b) = some b}
  (hd : decode α ∈ₑ C) (hf : by haveI : tencodable β := tencodable.of_left_injection f finv linv; exact finv ∈ₑ C) :
  by haveI : tencodable β := tencodable.of_left_injection f finv linv; exact decode β ∈ₑ C :=
by { letI : tencodable β := tencodable.of_left_injection f finv linv, refine option_bind hd _, complexity, }

lemma encode_of_equiv {C : complexity_class} {β : Type} {e : β ≃ α} :
  by haveI : tencodable β := tencodable.of_equiv _ e; exact ⇑e ∈ₑ C := encode_of_left_injection

lemma decode_of_equiv {C : complexity_class} {β : Type} {e : β ≃ α} :
  by haveI : tencodable β := tencodable.of_equiv _ e; exact ⇑e.symm ∈ₑ C :=
⟨_, C.id, λ x, congr_arg encode (e.apply_symm_apply x).symm⟩

lemma decodable_of_equiv {C : complexity_class} {β : Type} {e : β ≃ α} (hd : decode α ∈ₑ C) :
  by haveI : tencodable β := tencodable.of_equiv _ e; exact decode β ∈ₑ C :=
by letI : tencodable β := tencodable.of_equiv _ e; exact decode_of_left_injection hd (mem.comp complexity_class.some decode_of_equiv)

end equiv

section subtype

@[complexity] lemma subtype_coe {P : α → Prop} [decidable_pred P] : (coe : {x // P x} → α) ∈ₑ C :=
encode_of_left_injection

@[complexity] lemma subtype_val {P : α → Prop} [decidable_pred P] : (subtype.val : {x // P x} → α) ∈ₑ C :=
subtype_coe

@[complexity] lemma subtype_rec {P : α → Prop} [decidable_pred P]
  {f : β → {x // P x}} {g : β → ∀ x, P x → γ} :
  f ∈ₑ C → (λ (a : β) (b : {x // P x}), g a b b.prop) ∈ₑ C →
  @complexity_class.mem _ _ (β → γ) _ _ _ (λ x, @subtype.rec _ _ (λ _, γ) (g x) (f x)) C
| ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ := ⟨λ x, g' (x △ (f' x)), by complexity, λ x, begin
  dsimp [has_uncurry.uncurry] at hg hf ⊢,
  simp [tencodable.encode_prod] at hg,
  simp [hf, hg], cases f x, refl,
end⟩

@[complexity] lemma of_subtype_coe {P : α → Prop} [decidable_pred P] {f : β → {x // P x}} :
  f ∈ₑ C ↔ (λ x, (f x : α)) ∈ₑ C := iff.rfl

@[complexity] lemma subtype_mk {f : α → β} {P : β → Prop} [decidable_pred P] (hP : ∀ x, P (f x))
  (hf : f ∈ₑ C) : (λ x, subtype.mk (f x) (hP x)) ∈ₑ C := hf

@[complexity] protected lemma dite {P : α → Prop} [decidable_pred P] {f : ∀ (x : α), P x → β}
  {g : ∀ (x : α), ¬P x → β} : P ∈ₚ C → (λ x : {a // P a}, f x x.prop) ∈ₑ C →
  (λ x : {a // ¬P a}, g x x.prop) ∈ₑ C → (λ x, if H : P x then f x H else g x H) ∈ₑ C
| ⟨P', pP, hP⟩ ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ :=
⟨λ x, if P' x = encode tt then f' x else g' x, by complexity,
begin
  intro x,
  simp only [hP, has_uncurry.uncurry, tencodable.encode_inj], dsimp, simp only [to_bool_iff],
  split_ifs with H,
  { simp [tencodable.subtype_encode] at hf, simp [hf, H], refl, },
  { simp [tencodable.subtype_encode] at hg, simp [hg, H], refl, }
end⟩

lemma subtype_decode {P : α → Prop} [decidable_pred P] (hd : decode α ∈ₑ C)
  (hP : P ∈ₚ C) : decode {x // P x} ∈ₑ C :=
decode_of_left_injection hd (by complexity)

@[complexity] lemma fin_mk {n} {f : α → ℕ} (P : ∀ x, f x < n) (hf : f ∈ₑ C) :
  (λ x, (⟨f x, P x⟩ : fin n)) ∈ₑ C := hf

@[complexity] lemma fin_coe {n} : (coe : fin n → ℕ) ∈ₑ C :=
⟨_, C.id, λ _, rfl⟩

@[complexity] lemma fin_val {n} : (fin.val : fin n → ℕ) ∈ₑ C := fin_coe

@[complexity] lemma fin_rec {n : ℕ} {f : α → fin n} {g : α → ∀ (x : ℕ), x < n → β} :
  f ∈ₑ C → (λ (a : α) (b : {x // x < n}), g a b b.prop) ∈ₑ C →
  @complexity_class.mem _ _ (α → β) _ _ _ (λ x, @fin.rec n (λ _, β) (g x) (f x)) C
| ⟨f', pf, hf⟩ ⟨g', pg, hg⟩ := ⟨λ x, g' (x △ (f' x)), by complexity, λ x, begin
  dsimp [has_uncurry.uncurry] at hg hf ⊢,
  cases H : f x with v hv, specialize hg (x, ⟨v, hv⟩),
  simp [tencodable.encode_prod] at hg,
  simpa [hf, H] using hg,
end⟩

@[complexity] lemma vector_to_list {n} : (vector.to_list : vector α n → list α) ∈ₑ C :=
subtype_coe

@[complexity] lemma vector_head {n} : (@vector.head α n) ∈ₑ C :=
by { rw of_some, simp_rw ← vector.head'_to_list, complexity, }

@[complexity] lemma vector_tail {n} : (@vector.tail α n) ∈ₑ C :=
by { complexity using λ l, subtype.mk l.to_list.tail (by simp), rcases l with ⟨_|_, _⟩; refl, }

@[complexity] lemma vector_cons {n} : (@vector.cons α n) ∈ₑ C :=
by { complexity using λ x v, ⟨x :: v.to_list, by simp⟩, cases v, refl, }

@[complexity] lemma vector_nth {n} : (@vector.nth α n) ∈ₑ C :=
begin
  rw [mem.swap_args₂, iff_fintype],
  intro i, rw of_some,
  convert (const_list_nth i).comp vector_to_list,
  ext x : 1, simp [flip, vector.nth_eq_nth_le,  list.some_nth_le_eq],
end

@[complexity] lemma of_fn {n : ℕ} {f : fin n → α → β} (hf : ∀ i, (f i) ∈ₑ C) :
  (λ x, vector.of_fn (λ i, f i x)) ∈ₑ C :=
begin
  induction n with n ih, { exact C.const vector.nil, },
  exact vector_cons.comp₂ (hf 0) (ih $ λ i, hf i.succ),
end

end subtype

section setoid
variables [h : setoid α] {out : quotient h → α} {hout : function.left_inverse quotient.mk out}

include h out hout C

lemma setoid_out : by haveI : tencodable (quotient h) := setoid.tencodable h out hout; exact out ∈ₑ C :=
⟨_, C.id, λ x, rfl⟩

lemma decodable_of_quotient_mk (hd : decode α ∈ₑ C) (hq : by haveI : tencodable (quotient h) := setoid.tencodable h out hout; exact @quotient.mk _ h ∈ₑ C) :
  by haveI : tencodable (quotient h) := setoid.tencodable h out hout; exact (decode (quotient h)) ∈ₑ C :=
by { letI : tencodable (quotient h) := setoid.tencodable h out hout, refine decode_of_left_injection hd (mem.comp complexity_class.some hq), }

lemma quotient_lift {f : α → β} {pf : ∀ (a b : α), a ≈ b → f a = f b}
  (hf : f ∈ₑ C) : by haveI : tencodable (quotient h) := setoid.tencodable h out hout; exact
  (quotient.lift f pf) ∈ₑ C :=
begin
  letI : tencodable (quotient h) := setoid.tencodable h out hout,
  convert hf.comp setoid_out, ext x,
  refine quotient.induction_on x (λ x, pf _ _ (quotient.exact _)),
  rw hout,
end

end setoid

section multiset

@[complexity] lemma multiset_sort : multiset.sort (@tencodable.lift_le α _) ∈ₑ C := setoid_out

end multiset

section sigma

@[complexity] lemma sigma_fst {β : α → Type} [∀ i, tencodable (β i)] :
  (@sigma.fst α β) ∈ₑ C :=
⟨_, C.left, λ x, rfl⟩

@[complexity] lemma sigma_snd : @complexity_class.mem _ _ ((Σ _ : α, β) → β) _ _ _ sigma.snd C :=
⟨_, C.right, λ x, rfl⟩

end sigma

section finmap

@[complexity] lemma finmap_entries [decidable_eq α] : (@finmap.entries α (λ _, β)) ∈ₑ C := C.id'

@[complexity] lemma finmap_decode [decidable_eq α] (hd : decode (multiset (Σ _ : α, β)) ∈ₑ C)
  (H : @multiset.nodupkeys α (λ _, β) ∈ₚ C) :
  decode (@finmap α (λ _, β)) ∈ₑ C :=
decodable_of_equiv $ subtype_decode hd H

end finmap

end complexity_class


import .phrase
import .type_system
import .semantics
import .lemmata.structural_subtyping
import .lemmata.phrase_partial_order
import .lemmata.type_soundness

/- -----------------------------------------------------------------------------
 ------------------------------------ Demo ------------------------------------
----------------------------------------------------------------------------- -/

/- -----------------------------------------------------------------------------
 --------------------------------- First case study, Data Types vs Phrase Types

 Which type is required by this rule? (type system, page 4, 7 and 8)

 λ ⊢ e : τ var,
 λ ⊢ e' : τ
 --------------
 λ ⊢ e := e' : τ cmd

 This rule doesn't tell us precisely which type is typing e'
 1) e' is typed by the phrase type τ (called 'phrase.base τ' in Lean),
    so, e' is of phrase
 2) e' is directly typed by the data type τ
    so, e' is of security_class

 The "e" letter tell us a place for expressions, so if we type the first
 hypothesis with a phrase type also the second must be a phrase type.
 So we type e' as a phrase.

 ------------------------------------------------------------------------------

 And what about this case?
 λ ⊢ l : τ var, if λ(l) = τ

 is τ intended as a data type or the data type wrapped by a phrase?
 In this case is directly a data type (security_class in Lean)

 This is specified in the paper (at the end of page 7), but this is not a
 general rule because it doesn't hold everywhere

 ------------------------------------------------------------------------------

 In conclusion, we can't code directly a paper into Lean, without thinking to
 the details too much.
 We need to be able to formalize every details in a rigorous way.
 A lot of works need to be done before start coding a paper into Lean.

----------------------------------------------------------------------------- -/

#print flow_analysis.security_class
#print flow_analysis.phrase

/- -----------------------------------------------------------------------------
 ---------------------------------------------- Second case study, short proofs

 Regarding Lemma 4.1, every line of paper proof corresponds at almost 7 lines
 in Lean. In Lemma 4.2, this value increases up to 25 lines.
----------------------------------------------------------------------------- -/

#check flow_analysis.structural_subtyping
#check flow_analysis.phrase_partial_order

/- -----------------------------------------------------------------------------
 ------ Third case study, rules and systems need to be splitted to work in Lean

 Deep embedding of expressions need to split every type system into two blocks,
 in the paper they just put expressions and programs all together in the same
 system, Lean doesn't allow this.

 Also to avoid non-determinism some rules need to be splitted in two new rules
----------------------------------------------------------------------------- -/

#check flow_analysis.type_system.program_typing

#check flow_analysis.base_expr
#check flow_analysis.program

/- -----------------------------------------------------------------------------
 ---------------------------- Fourth case study, Rigorous proof vs Formal proof

 In Lemma 6.4 they use induction on the structure of the program,
 this for the letvar case means: (λ, γ ⊢ let x := e in c : τ cmd)
   if I had "λ, γ ⊢ c : τ cmd" I would be able to conclude this case using
   the inductive hypothesis.
   (conclusion coincides because letvar cannot build new locations)
 now "λ, γ ⊢ let x := e in c : τ cmd" tell us two things:
 1) λ, γ ⊢ e : τ, and
 2) λ, γ[x : τ var] ⊢ c : τ cmd
 I can't use the first one to prove "λ, γ ⊢ c : τ cmd" for obviously reasons
 But I can't also use the second one!
 from "λ, γ[x : τ var] ⊢ c : τ cmd" I cannot prove "λ, γ ⊢ c : τ cmd",

 This is very easy to see, just replace c with this simple program "x := 0"
 from an empty context:
   "∅, ∅[x : τ var] ⊢ x := 0 : τ cmd" holds and "∅, ∅ ⊢ x := 0 : τ cmd" does not
   , because it has no information about the x type

 ------------------------------------------------------------------------------

 In conclusion, the lemma holds but the proof isn't totally correct

----------------------------------------------------------------------------- -/

#check flow_analysis.confinement
#check flow_analysis.confinement.exists_variant

-- or with generalizing the context in induction
#check flow_analysis.confinement.generalizing


import category_theory.closed.monoidal
import category_theory.monoidal.braided
import tactic

namespace category_theory.monoidal

open category_theory
open category_theory.monoidal_category

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

class right_closed (X : C) :=
(is_adj : is_left_adjoint (tensor_right X))

attribute [instance, priority 100] right_closed.is_adj

variable (C)

class monoidal_closed_right :=
(closed : Π (X : C), right_closed X)

attribute [instance, priority 100] monoidal_closed_right.closed

variable [monoidal_closed_right.{v} C]

variable {C}

def internal_hom (X Y : C) : C :=
(right_adjoint (tensor_right X)).obj Y

def internal_hom_equiv (X Y Z : C) :
  (X ⊗ Y ⟶ Z) ≃ (X ⟶ internal_hom Y Z) :=
(adjunction.of_left_adjoint (tensor_right Y)).hom_equiv X Z

def internal_hom_postcompose (X : C) {Y₁ Y₂ : C} (f : Y₁ ⟶ Y₂) :
  internal_hom X Y₁ ⟶ internal_hom X Y₂ :=
(right_adjoint (tensor_right X)).map f

@[simp]
lemma internal_hom_postcompose_id (X Y : C) :
  internal_hom_postcompose X (𝟙 Y) = 𝟙 _ :=
(right_adjoint (tensor_right X)).map_id _

@[simp]
lemma internal_hom_postcompose_comp (X : C) {Y₁ Y₂ Y₃ : C} (f₁ : Y₁ ⟶ Y₂) (f₂ : Y₂ ⟶ Y₃) :
  internal_hom_postcompose X (f₁ ≫ f₂) =
  internal_hom_postcompose X f₁ ≫ internal_hom_postcompose X f₂ :=
(right_adjoint (tensor_right X)).map_comp _ _

def internal_hom_precompose {X₁ X₂ : C} (f : X₁ ⟶ X₂) (Y : C) :
  internal_hom X₂ Y ⟶ internal_hom X₁ Y :=
(internal_hom_equiv _ _ _) $ (tensor_hom (𝟙 _) f ≫ (internal_hom_equiv _ _ _).symm (𝟙 _))

lemma split_left {A₁ A₂ B₁ B₂ : C} (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) :
  (f ⊗ g) = (f ⊗ 𝟙 _) ≫ (𝟙 _ ⊗ g) := by simp

lemma split_right {A₁ A₂ B₁ B₂ : C} (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) :
  (f ⊗ g) = (𝟙 _ ⊗ g) ≫ (f ⊗ 𝟙 _) := by simp

lemma internal_hom_equiv_tensor_right {X Y₁ Y₂ Z : C} (f : Y₁ ⟶ Y₂) (g : X ⊗ Y₂ ⟶ Z) :
  internal_hom_equiv _ _ _ ((𝟙 _ ⊗ f) ≫ g)  =
  internal_hom_equiv _ _ _ g ≫ internal_hom_precompose f _ :=
begin
  apply_fun (internal_hom_equiv _ _ _).symm,
  simp,
  dsimp [internal_hom_precompose, internal_hom_equiv, internal_hom],
  simp only [adjunction.hom_equiv_unit, adjunction.hom_equiv_counit, tensor_right_map,
    tensor_id,  adjunction.hom_equiv_naturality_right, functor.map_comp,
    category_theory.functor.map_id, category.id_comp, category.assoc,
    adjunction.hom_equiv_naturality_left_symm, adjunction.hom_equiv_naturality_right_symm],
  simp only [← tensor_right_map],
  rw (adjunction.of_left_adjoint (tensor_right Y₁)).counit_naturality_assoc,
  rw (adjunction.of_left_adjoint (tensor_right Y₁)).left_triangle_components_assoc,
  dsimp,
  simp only [← category.assoc, ← tensor_comp, category.id_comp, category.comp_id],
  conv_rhs { rw [split_right _ f, category.assoc] },
  rw ← tensor_right_map,
  simp only [functor.map_comp, category.assoc],
  rw (adjunction.of_left_adjoint (tensor_right Y₂)).counit_naturality,
  erw (adjunction.of_left_adjoint (tensor_right Y₂)).left_triangle_components_assoc,
end

@[simp]
lemma internal_hom_precompose_id (X Y : C) :
  internal_hom_precompose (𝟙 X) Y = 𝟙 _ :=
by { dsimp [internal_hom_precompose, internal_hom_equiv, internal_hom], simp, dsimp, simp }

@[simp]
lemma internal_hom_precompose_comp {X₁ X₂ X₃ : C} (f₁ : X₁ ⟶ X₂) (f₂ : X₂ ⟶ X₃) (Y : C) :
  internal_hom_precompose (f₁ ≫ f₂) Y =
  internal_hom_precompose f₂ Y ≫ internal_hom_precompose f₁ Y :=
begin
  change _ = internal_hom_equiv _ _ _ _ ≫ _,
  rw [← internal_hom_equiv_tensor_right, ← category.assoc, ← tensor_comp, category.id_comp],
  refl,
end

@[simp]
lemma internal_hom_postcompose_comp_precompose {A₁ A₂ B₁ B₂ : C}
  (f : A₁ ⟶ A₂) (g : B₁ ⟶ B₂) :
  internal_hom_postcompose _ f ≫ internal_hom_precompose g _ =
  internal_hom_precompose g _ ≫ internal_hom_postcompose _ f :=
begin
  apply_fun (internal_hom_equiv _ _ _).symm,
  dsimp [internal_hom_precompose, internal_hom_postcompose, internal_hom_equiv, internal_hom],
  simp only [adjunction.hom_equiv_counit, tensor_right_map, tensor_id,
    adjunction.hom_equiv_naturality_right, adjunction.hom_equiv_unit, functor.map_comp,
    category_theory.functor.map_id, category.id_comp, category.assoc,
    adjunction.hom_equiv_naturality_left_symm, adjunction.hom_equiv_naturality_right_symm],
  simp only [← tensor_right_map, adjunction.counit_naturality, adjunction.counit_naturality_assoc,
    functor.map_comp, adjunction.left_triangle_components, adjunction.right_triangle_components,
    adjunction.left_triangle_components_assoc, adjunction.right_triangle_components_assoc],
  dsimp,
  simp only [← category.assoc, ← tensor_comp, category.id_comp, category.comp_id],
  rw [split_right _ g, category.assoc, ← tensor_right_map, adjunction.counit_naturality,
    category.assoc],
end

@[simps]
def internal_hom_functor : Cᵒᵖ ⥤ C ⥤ C :=
{ obj := λ X,
  { obj := λ Y, internal_hom X.unop Y,
    map := λ Y₁ Y₂, internal_hom_postcompose _ },
  map := λ X₁ X₂ f,
  { app := λ Y, internal_hom_precompose f.unop _ } }

end category_theory.monoidal


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.buffer.parser
import tactic.doc_commands

open lean.parser tactic interactive parser

/--
`restate_axiom` takes a structure field, and makes a new, definitionally simplified copy of it.
If the existing field name ends with a `'`, the new field just has the prime removed. Otherwise,
we append `_lemma`.
The main application is to provide clean versions of structure fields that have been tagged with
an auto_param.
-/
meta def restate_axiom (d : declaration) (new_name : name) : tactic unit :=
do (levels, type, value, reducibility, trusted) ← pure (match d.to_definition with
  | declaration.defn name levels type value reducibility trusted :=
    (levels, type, value, reducibility, trusted)
  | _ := undefined
  end),
  (s, u) ← mk_simp_set ff [] [],
  new_type ← (s.dsimplify [] type) <|> pure (type),
  prop ← is_prop new_type,
  let new_decl := if prop then
      declaration.thm new_name levels new_type (task.pure value)
    else
      declaration.defn new_name levels new_type value reducibility trusted,
  updateex_env $ λ env, env.add new_decl

private meta def name_lemma (old : name) (new : option name := none) : tactic name :=
match new with
| none :=
  match old.components.reverse with
  | last :: most := (do let last := last.to_string,
                       let last := if last.to_list.ilast = ''' then
                                     (last.to_list.reverse.drop 1).reverse.as_string
                                   else last ++ "_lemma",
                       return (mk_str_name old.get_prefix last)) <|> failed
  | nil          := undefined
  end
| (some new) := return (mk_str_name old.get_prefix new.to_string)
end

/--
`restate_axiom` makes a new copy of a structure field, first definitionally simplifying the type.
This is useful to remove `auto_param` or `opt_param` from the statement.

As an example, we have:
```lean
structure A :=
(x : ℕ)
(a' : x = 1 . skip)

example (z : A) : z.x = 1 := by rw A.a' -- rewrite tactic failed, lemma is not an equality nor a iff

restate_axiom A.a'
example (z : A) : z.x = 1 := by rw A.a
```

By default, `restate_axiom` names the new lemma by removing a trailing `'`, or otherwise appending
`_lemma` if there is no trailing `'`. You can also give `restate_axiom` a second argument to
specify the new name, as in
```lean
restate_axiom A.a f
example (z : A) : z.x = 1 := by rw A.f
```
-/
@[user_command] meta def restate_axiom_cmd (_ : parse $ tk "restate_axiom") : lean.parser unit :=
do from_lemma ← ident,
   new_name ← optional ident,
   from_lemma_fully_qualified ← resolve_constant from_lemma,
  d ← get_decl from_lemma_fully_qualified <|>
    fail ("declaration " ++ to_string from_lemma ++ " not found"),
  do {
    new_name ← name_lemma from_lemma_fully_qualified new_name,
    restate_axiom d new_name
  }

add_tactic_doc
{ name                     := "restate_axiom",
  category                 := doc_category.cmd,
  decl_names               := [`restate_axiom_cmd],
  tags                     := ["renaming", "environment"] }


import Qq
open Lean Qq

def bar {α : Q(Type u)} (a : Q($α)) : Q(Prop) := q($a = $a)
def bar2 {α : Q(Sort u)} (a : Q($α)) : Q($a = $a) := q(by simp)

def baz (u : Level) : Type := Q(Sort u)

#eval bar2 q([1,2, 4])

#check q(∀ x, x = x + 0)

example {α : Q(Type u)} (inst : Q(Inhabited $α)) : Q(∃ x : $α, x = x) :=
  q(⟨default, by rfl⟩)

example : Q(let x := 5; x = x) := q(by simp)

#eval show Q(∀ n : UInt64, n.val = n.val) from q(fun _ => by simp)

def foo' (n : Nat) : Q(Q($($n) = $($n))) := q(q(by simp))
#eval foo' 3


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

import order.omega_complete_partial_order
import order.category.Preorder
import category_theory.limits.shapes.products
import category_theory.limits.shapes.equalizers
import category_theory.limits.constructions.limits_of_products_and_equalizers

/-!
# Category of types with a omega complete partial order

In this file, we bundle the class `omega_complete_partial_order` into a
concrete category and prove that continuous functions also form
a `omega_complete_partial_order`.

## Main definitions

 * `ωCPO`
   * an instance of `category` and `concrete_category`

 -/

open category_theory

universes u v

/-- The category of types with a omega complete partial order. -/
def ωCPO : Type (u+1) := bundled omega_complete_partial_order

namespace ωCPO

open omega_complete_partial_order

instance : bundled_hom @continuous_hom :=
{ to_fun := @continuous_hom.simps.apply,
  id := @continuous_hom.id,
  comp := @continuous_hom.comp,
  hom_ext := @continuous_hom.coe_inj }

attribute [derive [large_category, concrete_category]] ωCPO

instance : has_coe_to_sort ωCPO Type* := bundled.has_coe_to_sort

/-- Construct a bundled ωCPO from the underlying type and typeclass. -/
def of (α : Type*) [omega_complete_partial_order α] : ωCPO := bundled.of α

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

instance : inhabited ωCPO := ⟨of punit⟩

instance (α : ωCPO) : omega_complete_partial_order α := α.str

section

open category_theory.limits

namespace has_products

/-- The pi-type gives a cone for a product. -/
def product {J : Type v} (f : J → ωCPO.{v}) : fan f :=
fan.mk (of (Π j, f j)) (λ j, continuous_hom.of_mono (pi.eval_order_hom j) (λ c, rfl))

/-- The pi-type is a limit cone for the product. -/
def is_product (J : Type v) (f : J → ωCPO) : is_limit (product f) :=
{ lift := λ s,
    ⟨⟨λ t j, s.π.app ⟨j⟩ t, λ x y h j, (s.π.app ⟨j⟩).monotone h⟩,
     λ x, funext (λ j, (s.π.app ⟨j⟩).continuous x)⟩,
  uniq' := λ s m w,
  begin
    ext t j,
    change m t j = s.π.app ⟨j⟩ t,
    rw ← w ⟨j⟩,
    refl,
  end,
  fac' := λ s j, by { cases j, tidy, } }.

instance (J : Type v) (f : J → ωCPO.{v}) : has_product f :=
has_limit.mk ⟨_, is_product _ f⟩

end has_products

instance omega_complete_partial_order_equalizer
  {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) : omega_complete_partial_order {a : α // f a = g a} :=
omega_complete_partial_order.subtype _ $ λ c hc,
begin
  rw [f.continuous, g.continuous],
  congr' 1,
  ext,
  apply hc _ ⟨_, rfl⟩,
end

namespace has_equalizers

/-- The equalizer inclusion function as a `continuous_hom`. -/
def equalizer_ι {α β : Type*} [omega_complete_partial_order α] [omega_complete_partial_order β]
  (f g : α →𝒄 β) :
  {a : α // f a = g a} →𝒄 α :=
continuous_hom.of_mono (order_hom.subtype.val _) (λ c, rfl)

/-- A construction of the equalizer fork. -/
def equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) :
  fork f g :=
@fork.of_ι _ _ _ _ _ _ (ωCPO.of {a // f a = g a}) (equalizer_ι f g)
  (continuous_hom.ext _ _ (λ x, x.2))

/-- The equalizer fork is a limit. -/
def is_equalizer {X Y : ωCPO.{v}} (f g : X ⟶ Y) : is_limit (equalizer f g) :=
fork.is_limit.mk' _ $ λ s,
⟨{ to_fun := λ x, ⟨s.ι x, by apply continuous_hom.congr_fun s.condition⟩,
    monotone' := λ x y h, s.ι.monotone h,
    cont := λ x, subtype.ext (s.ι.continuous x) },
  by { ext, refl },
  λ m hm,
  begin
    ext,
    apply continuous_hom.congr_fun hm,
  end⟩

end has_equalizers

instance : has_products ωCPO.{v} :=
λ J, { has_limit := λ F, has_limit_of_iso discrete.nat_iso_functor.symm }

instance {X Y : ωCPO.{v}} (f g : X ⟶ Y) : has_limit (parallel_pair f g) :=
has_limit.mk ⟨_, has_equalizers.is_equalizer f g⟩

instance : has_equalizers ωCPO.{v} := has_equalizers_of_has_limit_parallel_pair _

instance : has_limits ωCPO.{v} := limits_from_equalizers_and_products

end

end ωCPO


import data.list.dict
import data.multiset
import data.pfun

namespace multiset
universes u v
variables {α : Type u} {β : α → Type v}

open function list

def nodupkeys (m : multiset (sigma β)) : Prop :=
quotient.lift_on m nodupkeys (λ _ _, propext ∘ perm_nodupkeys)

theorem nodupkeys_coe {l : list (sigma β)} :
  nodupkeys (l : multiset (sigma β)) ↔ l.nodupkeys :=
iff.rfl

theorem nodup_of_nodupkeys {m : multiset (sigma β)} : m.nodupkeys → m.nodup :=
quotient.induction_on m $ λ _, nodup_of_nodupkeys

@[simp] theorem nodupkeys_zero : @nodupkeys _ β 0 :=
pairwise.nil _

theorem nodupkeys_singleton : ∀ (s : sigma β), nodupkeys (s :: 0) :=
nodupkeys_singleton

def krec_on {γ : Sort*} (m : multiset (sigma β))
  (φ : ∀ {l : list (sigma β)}, l.nodupkeys → γ)
  (c : ∀ {l₁ l₂} (p : l₁ ~ l₂) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ = φ d₂) :
  m.nodupkeys → γ :=
@quotient.hrec_on _ _ (λ (m : multiset (sigma β)), m.nodupkeys → γ) m (λ _, φ) $
  λ _ _ p, hfunext (by rw perm_nodupkeys p) $
    λ d₁ d₂ _, heq_of_eq $ c p d₁ d₂

@[simp] theorem krec_on_coe {γ : Sort*} {l : list (sigma β)} (d : l.nodupkeys)
  (φ : ∀ {l : list (sigma β)}, l.nodupkeys → γ)
  (c : ∀ {l₁ l₂} (p : l₁ ~ l₂) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ = φ d₂) :
  krec_on (l : multiset (sigma β)) @φ @c d = φ d :=
rfl

def krec_on₂ {γ : Sort*} (m₁ m₂ : multiset (sigma β))
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (cl : ∀ {l l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (d : l.nodupkeys) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ d = φ d₂ d)
  (cr : ∀ {l l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (d : l.nodupkeys) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d d₁ = φ d d₂) :
  m₁.nodupkeys → m₂.nodupkeys → γ :=
krec_on m₁
  (λ l d, krec_on m₂ (λ l₂ d₂, φ d d₂) (λ l₁ l₂ p d₁ d₂, cr p d d₁ d₂))
  (λ l₁ l₂ p d₁ d₂, by congr; funext l; funext d; exact cl p d d₁ d₂)

@[simp] theorem krec_on₂_coe {γ : Sort*} {l₁ l₂ : list (sigma β)} (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys)
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (cl : ∀ {l l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (d : l.nodupkeys) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ d = φ d₂ d)
  (cr : ∀ {l l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (d : l.nodupkeys) (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d d₁ = φ d d₂) :
  krec_on₂ (l₁ : multiset (sigma β)) (l₂ : multiset (sigma β)) @φ @cl @cr d₁ d₂ = φ d₁ d₂ :=
rfl

def keys : multiset (sigma β) → multiset α :=
map sigma.fst

@[simp] theorem keys_coe (l : list (sigma β)) :
  keys (l : multiset (sigma β)) = (l.keys : multiset α) :=
rfl

theorem mem_keys_of_mem {s : sigma β} {m : multiset (sigma β)} : s ∈ m → s.1 ∈ m.keys :=
mem_map_of_mem sigma.fst

theorem exists_mem_of_mem_keys {a : α} {m : multiset (sigma β)} (h : a ∈ m.keys) :
  ∃ (b : β a), sigma.mk a b ∈ m :=
let ⟨⟨a', b'⟩, m, e⟩ := mem_map.mp h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a : α} {m : multiset (sigma β)} : a ∈ m.keys ↔ ∃ (b : β a), sigma.mk a b ∈ m :=
⟨exists_mem_of_mem_keys, λ ⟨_, h⟩, mem_keys_of_mem h⟩

theorem nodupkeys_iff {m : multiset (sigma β)} : m.keys.nodup ↔ m.nodupkeys :=
quotient.induction_on m $ λ _, list.nodupkeys_iff

section kerase
variables [decidable_eq α]

def kerase {m : multiset (sigma β)} (a : α) : m.nodupkeys → multiset (sigma β) :=
krec_on m (λ l _, (l.kerase a : multiset (sigma β))) $ λ _ _ p d₁ d₂,
  quotient.sound $ perm_kerase d₁ d₂ p

@[simp] theorem kerase_coe {l : list (sigma β)} (d : l.nodupkeys) (a : α) :
  @kerase _ _ _ (l : multiset (sigma β)) a d = (l.kerase a : multiset (sigma β)) :=
rfl

theorem kerase_le {m : multiset (sigma β)} (a : α) : ∀ (nd : m.nodupkeys), kerase a nd ≤ m :=
quotient.induction_on m $ λ l _, subperm_of_sublist (kerase_sublist a l)

@[simp] theorem nodupkeys_kerase {m : multiset (sigma β)} (a : α) :
  ∀ (nd : m.nodupkeys), (kerase a nd).nodupkeys :=
quotient.induction_on m $ λ _, nodupkeys_kerase a

theorem kerase_eq_filter {m : multiset (sigma β)} (a : α) :
  ∀ (nd : m.nodupkeys), kerase a nd = filter (λ x, x.1 ≠ a) m :=
quotient.induction_on m $ λ _, congr_arg coe ∘ nodupkeys_kerase_eq_filter a

@[simp] theorem mem_kerase {m : multiset (sigma β)} {s : sigma β} {a : α}
  (nd : m.nodupkeys) : s ∈ kerase a nd ↔ s.1 ≠ a ∧ s ∈ m :=
by rw kerase_eq_filter a nd; simp [and_comm]

@[simp] theorem mem_keys_kerase {a₁ a₂ : α} {m : multiset (sigma β)} (d : m.nodupkeys) :
  a₁ ∈ (kerase a₂ d).keys ↔ a₁ ≠ a₂ ∧ a₁ ∈ m.keys :=
by simp [keys]

theorem kerase_subset (a : α) {m : multiset (sigma β)} (nd : m.nodupkeys) :
  kerase a nd ⊆ m :=
subset_of_le (kerase_le a nd)

theorem mem_of_mem_kerase {s : sigma β} (a : α) {m : multiset (sigma β)}
  (nd : m.nodupkeys) : s ∈ kerase a nd → s ∈ m :=
mem_of_subset (kerase_subset _ _)

theorem kerase_comm {m : multiset (sigma β)} (a₁ a₂ : α) : ∀ (nd : m.nodupkeys),
  kerase a₂ (nodupkeys_kerase a₁ nd) = kerase a₁ (nodupkeys_kerase a₂ nd) :=
quotient.induction_on m $ λ l _, congr_arg coe $ l.kerase_comm a₁ a₂

theorem kerase_le_kerase {m₁ m₂ : multiset (sigma β)} (a : α) (h : m₁ ≤ m₂) :
  ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys), kerase a d₁ ≤ kerase a d₂ :=
le_induction_on h $ λ _ _ ih _ _, subperm_of_sublist $ kerase_sublist_kerase a ih

end kerase

section kinsert
variables [decidable_eq α] {m : multiset (sigma β)}

def kinsert (s : sigma β) : m.nodupkeys → multiset (sigma β) :=
krec_on m (λ l _, (l.kinsert s : multiset (sigma β))) $ λ _ _ p d₁ d₂,
  quotient.sound $ perm_kinsert d₁ d₂ p

@[simp] theorem kinsert_coe {l : list (sigma β)} (d : l.nodupkeys) (s : sigma β) :
  @kinsert _ _ _ (l : multiset (sigma β)) s d = (l.kinsert s : multiset (sigma β)) :=
rfl

@[simp] theorem nodupkeys_kinsert (s : sigma β) :
  ∀ (d : m.nodupkeys), (kinsert s d).nodupkeys :=
quotient.induction_on m $ λ _, nodupkeys_kinsert s

@[simp] theorem mem_kinsert {m : multiset (sigma β)} {s₁ s₂ : sigma β} :
  ∀ (d : m.nodupkeys), s₁ ∈ kinsert s₂ d ↔ s₁ = s₂ ∨ s₁ ∈ kerase s₂.1 d :=
quotient.induction_on m $ λ _ _, mem_kinsert

@[simp] theorem mem_keys_kinsert {a : α} {s : sigma β}
  {m : multiset (sigma β)} (d : m.nodupkeys) :
  a ∈ (kinsert s d).keys ↔ a = s.1 ∨ a ∈ m.keys :=
by cases s with a' b'; by_cases h' : a = a'; simp [keys, exists_or_distrib, h']

end kinsert

section klookup
variables [decidable_eq α] {m : multiset (sigma β)}

def klookup (a : α) : m.nodupkeys → option (β a) :=
krec_on m (λ l _, l.klookup a) $ λ _ _ p d₁ d₂, perm_klookup d₁ d₂ p

end klookup

section klookup_all
variables [decidable_eq α]

def klookup_all (a : α) (m : multiset (sigma β)) : multiset (β a) :=
quotient.lift_on m
  (λ l, (l.klookup_all a : multiset (β a)))
  (λ _ _, quotient.sound ∘ perm_klookup_all)

end klookup_all

section kreplace
variables [decidable_eq α] {m : multiset (sigma β)}

def kreplace (s : sigma β) : m.nodupkeys → multiset (sigma β) :=
krec_on m (λ l _, (l.kreplace s : multiset (sigma β))) $ λ _ _ p d₁ d₂,
  quotient.sound $ perm_kreplace d₁ d₂ p

@[simp] theorem nodupkeys_kreplace (s : sigma β) :
  ∀ (d : m.nodupkeys), (kreplace s d).nodupkeys :=
quotient.induction_on m $ λ _, nodupkeys_kreplace s

end kreplace

section kunion
variables [decidable_eq α] {a : α} {s : sigma β} {l₁ l₂ : list (sigma β)}
variables {m m₁ m₂ m₃ : multiset (sigma β)}

def kunion : m₁.nodupkeys → m₂.nodupkeys → multiset (sigma β) :=
krec_on₂ m₁ m₂ (λ l₁ l₂ d₁ d₂, (l₁.kunion l₂ : multiset (sigma β)))
  (λ _ _ _ p d _ _, quotient.sound $ perm_kunion d d p (perm.refl _))
  (λ _ _ _ p _ d₁ d₂, quotient.sound $ perm_kunion d₁ d₂ (perm.refl _) p)

local infixr ` k∪ `:67 := kunion

@[simp] theorem kunion_coe
   (d₁ : (l₁ : multiset (sigma β)).nodupkeys) (d₂ : (l₂ : multiset (sigma β)).nodupkeys) :
   d₁ k∪ d₂ = (l₁.kunion l₂ : multiset (sigma β)) :=
rfl

@[simp] theorem nodupkeys_kunion : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  (d₁ k∪ d₂).nodupkeys :=
quotient.induction_on₂ m₁ m₂ $ λ _ _, nodupkeys_kunion

@[simp] theorem zero_kunion : ∀ (d : m.nodupkeys), nodupkeys_zero k∪ d = m :=
quotient.induction_on m $ λ _ _, rfl

@[simp] theorem kunion_zero : ∀ (d : m.nodupkeys), d k∪ nodupkeys_zero = m :=
quotient.induction_on m $ λ _ _, by simp [kunion_coe]

@[simp] theorem kinsert_kunion : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  kunion (nodupkeys_kinsert s d₁) d₂ = kinsert s (nodupkeys_kunion d₁ d₂) :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, by simp [kinsert_kunion]

@[simp] theorem mem_of_mem_kunion : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  s ∈ d₁ k∪ d₂ → s ∈ m₁ ∨ s ∈ m₂ :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, mem_of_mem_kunion

theorem mem_kunion_left : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  s ∈ m₁ → s ∈ d₁ k∪ d₂ :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, mem_kunion_left _

theorem mem_kunion_right : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  s.1 ∉ m₁.keys → s ∈ m₂ → s ∈ d₁ k∪ d₂ :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, mem_kunion_right

theorem mem_kunion_middle : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys) (d₃ : m₃.nodupkeys),
  disjoint (d₁ k∪ d₂).keys m₃.keys → s ∈ d₁ k∪ d₃ → s ∈ (nodupkeys_kunion d₁ d₂) k∪ d₃ :=
quotient.induction_on₃ m₁ m₂ m₃ $ λ _ _ _ _ _ _, mem_kunion_middle

@[simp] theorem mem_kunion : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  disjoint m₁.keys m₂.keys → (s ∈ d₁ k∪ d₂ ↔ s ∈ m₁ ∨ s ∈ m₂) :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, mem_kunion_iff

@[simp] theorem mem_keys_kunion : ∀ (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys),
  a ∈ keys (d₁ k∪ d₂) ↔ a ∈ m₁.keys ∨ a ∈ m₂.keys :=
quotient.induction_on₂ m₁ m₂ $ λ _ _ _ _, mem_keys_kunion

end kunion

section α₁α₂β₁β₂
variables {α₁ α₂ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v}

section map
variables {s : sigma β₁} {f : sigma β₁ → sigma β₂} {m m₁ m₂ : multiset (sigma β₁)}

theorem nodupkeys_map (fi : sigma.fst_injective f) : m.nodupkeys → (m.map f).nodupkeys :=
quotient.induction_on m $ λ _, nodupkeys_map fi

theorem mem_keys_map (ff : sigma.fst_functional f) : s.1 ∈ m.keys → (f s).1 ∈ (m.map f).keys :=
quotient.induction_on m $ λ _, mem_keys_map ff

theorem mem_keys_of_mem_keys_map (fi : sigma.fst_injective f) :
  (f s).1 ∈ (m.map f).keys → s.1 ∈ m.keys :=
quotient.induction_on m $ λ _, mem_keys_of_mem_keys_map fi

theorem mem_keys_map_iff (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  (f s).1 ∈ (m.map f).keys ↔ s.1 ∈ m.keys :=
⟨mem_keys_of_mem_keys_map fi, mem_keys_map ff⟩

theorem map_disjoint_keys (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  disjoint (m₁.map f).keys (m₂.map f).keys ↔ disjoint m₁.keys m₂.keys :=
quotient.induction_on₂ m₁ m₂ $ λ _ _, map_disjoint_keys ff fi

end map

section map_decidable_eq_α₁α₂
variables [decidable_eq α₁] [decidable_eq α₂]
variables {s : sigma β₁} {f : sigma β₁ → sigma β₂} {m : multiset (sigma β₁)}

@[simp] theorem map_kerase (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  ∀ (d : m.nodupkeys), (kerase s.1 d).map f = kerase (f s).1 (nodupkeys_map fi d) :=
quotient.induction_on m $ λ _ _, by simp [ff, fi]

@[simp] theorem map_kinsert (ff : sigma.fst_functional f) (fi : sigma.fst_injective f) :
  ∀ (d : m.nodupkeys), (kinsert s d).map f = kinsert (f s) (nodupkeys_map fi d) :=
quotient.induction_on m $ λ _ _, by simp [ff, fi]

end map_decidable_eq_α₁α₂

end α₁α₂β₁β₂

section map_id
variables {β₁ β₂ : α → Type v} {s : sigma β₁} {m : multiset (sigma β₁)}

@[simp] theorem map_id_keys (f : ∀ a, β₁ a → β₂ a) : (m.map (sigma.map id f)).keys = m.keys :=
by simp [keys]

end map_id

end multiset