import tactic

open tactic.interactive
open interactive.types

open interactive

open lean.parser

def mylist : list nat := [0,1]

#check pexpr
#check tactic.interactive.apply

meta def tactic.interactive.apply_at  (h : parse texpr) (f : parse (tk "using" *> texpr)) : tactic unit :=
do
  h' ← tactic.i_to_expr_for_apply h,
  tactic.interactive.replace (expr.local_pp_name h') none (f h)

#check interaction_monad_orelse

meta def my_orelse {α : Type*} (t₁ t₂ : tactic α) : tactic α :=
λ s, interaction_monad.result.cases_on (t₁ s)
  interaction_monad.result.success
  (λ e₁ ref₁ s', interaction_monad.result.cases_on ((trace ((e₁.get_or_else sorry) ()) >> t₂) s)
     interaction_monad.result.success
     interaction_monad.result.exception)

infix `<||>` : 2 := my_orelse

namespace transfer

meta def transfer1 (surjectivemap : pexpr) (operations : list pexpr) (finishing : list pexpr) : tactic unit :=
do
-- move things to assumptions
  tactic.intros,

-- get axioms from arguments?
  -- proof of surjection

--in some order:
  -- find variables
  l ← tactic.local_context,
 -- l.mmap' (λ h, do tactic.trace "Name:", tactic.trace h, tactic.trace "Type:", tactic.infer_type h >>= tactic.trace),
  l.mmap' (λ h, tactic.try (tactic.interactive.rw (rw_rules_t.mk [(rw_rule.mk ⟨0,0⟩ tt ``(classical.some_spec (%%surjectivemap %%h)))] none) interactive.loc.wildcard)),

  -- tactic.interactive.rw (rw_rules_t.mk [(rw_rule.mk ⟨0,0⟩ tt ``(operations))] none) interactive.loc.wildcard
  -- find and transfer the operations in the goal

  --(option.cases_on (operations.nth 0) (tactic.fail "fail") (tactic.i_to_expr_for_apply >=> tactic.apply) : tactic (list (name × expr))),
  --skip
  --,

  trace_state,

  tactic.repeat (
    operations.foldr (
      λ op rest,
        rest
        <||>
        (tactic.i_to_expr_for_apply >=> tactic.apply) op >> skip
        <||>
        tactic.interactive.rw (rw_rules_t.mk [(rw_rule.mk ⟨0,0⟩ tt op)] none) interactive.loc.wildcard
        <||>
        ( do
        l2 ← tactic.local_context,

        l2.foldr (λ h rest2, rest2 <||> tactic.interactive.apply_at (to_pexpr h) op) (tactic.fail "foldr2 fail"),

        skip
        )
    ) (tactic.fail "oeps")
  <||> tactic.fail "exit repeat"),

  trace_state,

  -- skip

  tactic.interactive.finish [] finishing,

  skip

  --tactic.repeat (
  --operations.mmap' (λ h, tactic.try
  --  (
      --(tactic.applyc `h)
      --<|>
  --    (tactic.interactive.rw (rw_rules_t.mk [(rw_rule.mk ⟨0,0⟩ tt ``(classical.some_spec (%%surjectivemap %%h)))] none) interactive.loc.wildcard)
  --  )
  --)
  --)
  --,

--apply the theorem

--finish
--skip
end transfer

--open parser

--meta def tactic.interactive.apply_at  (h : parse ident) (f : parse texpr) : tactic unit :=
--do
--  tactic.interactive.replace h none (f ( h))

--name naar tactic.expr = get_local in tactic.lean

-- theorem test (a b : Type) (ha : a) (hab : a → b) : b :=
-- begin
--   --apply_at ha using hab,
--   apply_at hab ha using id,
--   assumption,
--   -- assumption, --finding ha_1
-- end

-- def N : Type := sorry
-- def ordern : N → N → Prop := sorry
-- def nto : N → nat := sorry
-- def nof : nat → N := sorry

-- axiom nto_surj : function.surjective nto
-- axiom nof_surj : function.surjective nof
-- axiom le_ordern_nof : ∀ m n : nat, m <= n → ordern (nof m) (nof n)
-- -- axiom le_ordern_nof_iff : ∀ m n : nat,  m <= n ↔ ordern (nof m) (nof n) --temp hack
-- axiom ordern_nof_le : ∀ m n : nat, ordern (nof m) (nof n) → m <= n

-- theorem transitiveorder_nat : ∀ x y z : nat, x <= y → y <= z → x <= z := sorry

-- theorem transitiveorder_N : ∀ x y z : N, ordern x y → ordern y z → ordern x z :=
-- begin
--   -- intros,
--   -- rw [← classical.some_spec (nof_surj x)] at *,
--   -- rw [← classical.some_spec (nof_surj y)] at *,
--   -- rw [← classical.some_spec (nof_surj z)] at *,

--   -- apply_at a using ordern_nof_le _ _,
--   -- apply_at a_1 using ordern_nof_le _ _,

--   -- apply le_ordern_nof,
--   -- finish using [transitiveorder_nat],

--   transfer.transfer1 ``(nof_surj) [``(ordern_nof_le _ _)] [``(le_ordern_nof), ``(transitiveorder_nat)],

--   --``(le_ordern_nof_iff)

--   --have b := ordern_nof_le _ _ a,
--   --have b_1 := ordern_nof_le _ _ a_1,

--   --apply le_ordern_nof,
--   --finish using transitiveorder_nat,
-- end

-- -- EXAMPLE 2: transfer the theorem that odd+odd=even from z to z mod 2 and back.
-- namespace example2

-- definition even (n : int) : Prop := n % 2 = 0

-- -- a custom type Z/2Z, with operation add and predicate even
-- inductive Z2 : Type
-- | zero : Z2
-- | one : Z2

-- open Z2

-- def Z2.add : Z2 → Z2 → Z2
-- | zero y := y
-- | one zero := one
-- | one one := zero

-- inductive Z2.even : Z2 → Prop
-- | zeroiseven : Z2.even zero

-- -- mapping from int to Z2 (no inverse mapping)
-- def ztoz2 : int → Z2 := λ n, if n % 2 = 0 then zero else one

-- -- axioms needed for transfer:
-- -- mapping is surjective
-- axiom surjectivemap : function.surjective ztoz2
-- -- mapping respects add and even (there must be transfer axioms for every operation and predicate in the theorem)
-- axiom transfer_add : ∀ m n : int, (ztoz2 m).add (ztoz2 n) = ztoz2(m + n)
-- axiom transfer_add' : ∀ m n : int, ztoz2(m + n) = (ztoz2 m).add (ztoz2 n) -- >:(

-- axiom eventoz2 : ∀ n : int, even n → Z2.even (ztoz2 n)
-- axiom evenfromz2 : ∀ n : int, Z2.even (ztoz2 n) → even n  -- specific wording of the axioms makes the proof go nicely

-- -- theorem about adding two odd integers, now we want the same result in Z2
-- theorem thetheoremforint : ∀ m n : int, ¬ even m → ¬ even n → even (m + n) := sorry

-- theorem thetheoremforZ2 : ∀ x y : Z2, ¬ Z2.even x → ¬ Z2.even y → Z2.even (Z2.add x y) :=
-- begin
--   intros,
--   --rw [← classical.some_spec (surjectivemap x)] at *,
--   --rw [← classical.some_spec (surjectivemap y)] at *,
--   --rw transfer_add,
--   transfer.transfer1 ``(surjectivemap) [``(transfer_add'), ``(eventoz2)] [``(thetheoremforint), ``(eventoz2)],

--   --rw transfer_add, THIS WORKS MANUALLY, transfer needs the reverse rewrite though...

--   -- TODO apply met not

--   -- intros,
--   -- rw [← classical.some_spec (surjectivemap x)] at *,
--   -- rw [← classical.some_spec (surjectivemap y)] at *,
--   -- rw transfer_add,
--   -- apply eventoz2,
--   -- apply thetheoremforint;
--   -- finish using [eventoz2]
-- end

-- -- the other direction can also be shown
-- theorem thetheoremforint' : ∀ x y : int, ¬ even x → ¬ even y → even (x + y) :=
-- begin
--   intros,
--   apply evenfromz2,
--   rw← transfer_add,
--   apply thetheoremforZ2;
--   finish using [evenfromz2]
-- end

-- end example2


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

import algebra.group_power
import control.uliftable
import control.monad.basic

import data.bitvec.basic
import data.list.basic
import data.set.intervals.basic
import data.stream.basic
import data.fin

import tactic.cache
import tactic.interactive
import tactic.norm_num

import system.io
import system.random

/-!
# Rand Monad and Random Class

This module provides tools for formulating computations guided by randomness and for
defining objects that can be created randomly.

## Main definitions
  * `rand` monad for computations guided by randomness;
  * `random` class for objects that can be generated randomly;
    * `random` to generate one object;
    * `random_r` to generate one object inside a range;
    * `random_series` to generate an infinite series of objects;
    * `random_series_r` to generate an infinite series of objects inside a range;
  * `io.mk_generator` to create a new random number generator;
  * `io.run_rand` to run a randomized computation inside the `io` monad;
  * `tactic.run_rand` to run a randomized computation inside the `tactic` monad

## Local notation

 * `i .. j` : `Icc i j`, the set of values between `i` and `j` inclusively;

## Tags

random monad io

## References

  * Similar library in Haskell: https://hackage.haskell.org/package/MonadRandom

-/

open list io applicative

universes u v w

/-- A monad to generate random objects using the generator type `g` -/
@[reducible]
def rand_g (g : Type) (α : Type u) : Type u := state (ulift.{u} g) α

/-- A monad to generate random objects using the generator type `std_gen` -/
@[reducible]
def rand := rand_g std_gen

instance (g : Type) : uliftable (rand_g.{u} g) (rand_g.{v} g) :=
@state_t.uliftable' _ _ _ _ _ (equiv.ulift.trans.{u u u u u} equiv.ulift.symm)

open ulift (hiding inhabited)

/-- Generate one more `ℕ` -/
def rand_g.next {g : Type} [random_gen g] : rand_g g ℕ :=
⟨ prod.map id up ∘ random_gen.next ∘ down ⟩

local infix ` .. `:41 := set.Icc

open stream

/-- `bounded_random α` gives us machinery to generate values of type `α` between certain bounds -/
class bounded_random (α : Type u) [preorder α] :=
(random_r : Π g [random_gen g] (x y : α),
              (x ≤ y) → rand_g g (x .. y))

/-- `random α` gives us machinery to generate values of type `α` -/
class random (α : Type u) :=
(random [] : Π (g : Type) [random_gen g], rand_g g α)

/-- shift_31_left = 2^31; multiplying by it shifts the binary
representation of a number left by 31 bits, dividing by it shifts it
right by 31 bits -/
def shift_31_left : ℕ :=
by apply_normed 2^31

namespace rand

open stream

variables (α : Type u)
variables (g : Type) [random_gen g]

/-- create a new random number generator distinct from the one stored in the state -/
def split : rand_g g g := ⟨ prod.map id up ∘ random_gen.split ∘ down ⟩

variables {g}

section random
variables [random α]

export random (random)

/-- Generate a random value of type `α`. -/
def random : rand_g g α :=
random.random α g

/-- generate an infinite series of random values of type `α` -/
def random_series : rand_g g (stream α) :=
do gen ← uliftable.up (split g),
   pure $ stream.corec_state (random.random α g) gen

end random

variables {α}

/-- Generate a random value between `x` and `y` inclusive. -/
def random_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) : rand_g g (x .. y) :=
bounded_random.random_r g x y h

/-- generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
def random_series_r [preorder α] [bounded_random α] (x y : α) (h : x ≤ y) :
  rand_g g (stream (x .. y)) :=
do gen ← uliftable.up (split g),
   pure $ corec_state (bounded_random.random_r g x y h) gen

end rand

namespace io

private def accum_char (w : ℕ) (c : char) : ℕ :=
c.to_nat + 256 * w

/-- create and a seed a random number generator -/
def mk_generator : io std_gen := do
seed ← io.rand 0 shift_31_left,
return $ mk_std_gen seed

variables {α : Type}

/-- Run `cmd` using a randomly seeded random number generator -/
def run_rand (cmd : _root_.rand α) : io α :=
do g ← io.mk_generator,
   return $ (cmd.run ⟨g⟩).1

/-- Run `cmd` using the provided seed. -/
def run_rand_with (seed : ℕ) (cmd : _root_.rand α) : io α :=
return $ (cmd.run ⟨mk_std_gen seed⟩).1

section random
variables [random α]

/-- randomly generate a value of type α -/
def random : io α :=
io.run_rand (rand.random α)

/-- randomly generate an infinite series of value of type α -/
def random_series : io (stream α) :=
io.run_rand (rand.random_series α)

end random

section bounded_random
variables [preorder α] [bounded_random α]

/-- randomly generate a value of type α between `x` and `y` -/
def random_r (x y : α) (p : x ≤ y) : io (x .. y) :=
io.run_rand (bounded_random.random_r _ x y p)

/-- randomly generate an infinite series of value of type α between `x` and `y` -/
def random_series_r (x y : α) (h : x ≤ y) : io (stream $ x .. y) :=
io.run_rand (rand.random_series_r x y h)

end bounded_random

end io

namespace tactic

/-- create a seeded random number generator in the `tactic` monad -/
meta def mk_generator : tactic std_gen := do
tactic.unsafe_run_io @io.mk_generator

/-- run `cmd` using the a randomly seeded random number generator
in the tactic monad -/
meta def run_rand {α : Type u} (cmd : rand α) : tactic α := do
⟨g⟩ ← tactic.up mk_generator,
return (cmd.run ⟨g⟩).1

variables {α : Type u}

section bounded_random
variables [preorder α] [bounded_random α]

/-- Generate a random value between `x` and `y` inclusive. -/
meta def random_r (x y : α) (h : x ≤ y) : tactic (x .. y) :=
run_rand (rand.random_r x y h)

/-- Generate an infinite series of random values of type `α` between `x` and `y` inclusive. -/
meta def random_series_r (x y : α) (h : x ≤ y) : tactic (stream $ x .. y) :=
run_rand (rand.random_series_r x y h)

end bounded_random

section random

variables [random α]

/-- randomly generate a value of type α -/
meta def random : tactic α :=
run_rand (rand.random α)

 /-- randomly generate an infinite series of value of type α -/
meta def random_series : tactic (stream α) :=
run_rand (rand.random_series α)

end random

end tactic

open nat (succ one_add mod_eq_of_lt zero_lt_succ add_one succ_le_succ)

variables {g : Type} [random_gen g]

open nat

namespace fin
variables {n : ℕ} [fact (0 < n)]

/-- generate a `fin` randomly -/
protected def random : rand_g g (fin n) :=
⟨ λ ⟨g⟩, prod.map of_nat' up $ rand_nat g 0 n ⟩

end fin

open nat

instance nat_bounded_random : bounded_random ℕ :=
{ random_r := λ g inst x y hxy,
  do z ← @fin.random g inst (succ $ y - x) _,
     pure ⟨z.val + x, nat.le_add_left _ _,
       by rw ← nat.le_sub_right_iff_add_le hxy; apply le_of_succ_le_succ z.is_lt⟩ }

/-- This `bounded_random` interval generates integers between `x` and
`y` by first generating a natural number between `0` and `y - x` and
shifting the result appropriately. -/
instance int_bounded_random : bounded_random ℤ :=
{ random_r := λ g inst x y hxy,
  do ⟨z,h₀,h₁⟩ ← @bounded_random.random_r ℕ _ _ g inst 0 (int.nat_abs $ y - x) dec_trivial,
     pure ⟨z + x,
       int.le_add_of_nonneg_left (int.coe_nat_nonneg _),
       int.add_le_of_le_sub_right $ le_trans
         (int.coe_nat_le_coe_nat_of_le h₁)
         (le_of_eq $ int.of_nat_nat_abs_eq_of_nonneg (int.sub_nonneg_of_le hxy)) ⟩ }

instance fin_random (n : ℕ) [fact (0 < n)] : random (fin n) :=
{ random := λ g inst, @fin.random g inst _ _ }

instance fin_bounded_random (n : ℕ) : bounded_random (fin n) :=
{ random_r := λ g inst (x y : fin n) p,
    do ⟨r, h, h'⟩ ← @rand.random_r ℕ g inst _ _ x.val y.val p,
       pure ⟨⟨r,lt_of_le_of_lt h' y.is_lt⟩, h, h'⟩ }

/-- A shortcut for creating a `random (fin n)` instance from
a proof that `0 < n` rather than on matching on `fin (succ n)`  -/
def random_fin_of_pos : ∀ {n : ℕ} (h : 0 < n), random (fin n)
| (succ n) _ := fin_random _
| 0 h := false.elim (not_lt_zero _ h)

lemma bool_of_nat_mem_Icc_of_mem_Icc_to_nat (x y : bool) (n : ℕ) :
  n ∈ (x.to_nat .. y.to_nat) → bool.of_nat n ∈ (x .. y) :=
begin
  simp only [and_imp, set.mem_Icc], intros h₀ h₁,
  split;
    [ have h₂ := bool.of_nat_le_of_nat h₀, have h₂ := bool.of_nat_le_of_nat h₁ ];
    rw bool.of_nat_to_nat at h₂; exact h₂,
end

instance : random bool :=
{ random   := λ g inst,
  (bool.of_nat ∘ subtype.val) <$> @bounded_random.random_r ℕ _ _ g inst 0 1 (nat.zero_le _) }

instance : bounded_random bool :=
{ random_r := λ g _inst x y p,
  subtype.map bool.of_nat (bool_of_nat_mem_Icc_of_mem_Icc_to_nat x y) <$>
    @bounded_random.random_r ℕ _ _ g _inst x.to_nat y.to_nat (bool.to_nat_le_to_nat p) }

open_locale fin_fact

/-- generate a random bit vector of length `n` -/
def bitvec.random (n : ℕ) : rand_g g (bitvec n) :=
bitvec.of_fin <$> rand.random (fin $ 2^n)

/-- generate a random bit vector of length `n` -/
def bitvec.random_r {n : ℕ} (x y : bitvec n) (h : x ≤ y) : rand_g g (x .. y) :=
have h' : ∀ (a : fin (2 ^ n)), a ∈ (x.to_fin .. y.to_fin) → bitvec.of_fin a ∈ (x .. y),
begin
  simp only [and_imp, set.mem_Icc], intros z h₀ h₁,
  replace h₀ := bitvec.of_fin_le_of_fin_of_le h₀,
  replace h₁ := bitvec.of_fin_le_of_fin_of_le h₁,
  rw bitvec.of_fin_to_fin at h₀ h₁, split; assumption,
end,
subtype.map bitvec.of_fin h' <$> rand.random_r x.to_fin y.to_fin (bitvec.to_fin_le_to_fin_of_le h)

open nat

instance random_bitvec (n : ℕ) : random (bitvec n) :=
{ random := λ _ inst, @bitvec.random _ inst n }

instance bounded_random_bitvec (n : ℕ) : bounded_random (bitvec n) :=
{ random_r := λ _ inst x y p, @bitvec.random_r _ inst _ _ _ p }


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homology

/-!
# Quasi-isomorphisms

A chain map is a quasi-isomorphism if it induces isomorphisms on homology.

## Future work

Define the derived category as the localization at quasi-isomorphisms?
-/

open category_theory
open category_theory.limits

universes v u

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [has_zero_morphisms V] [has_zero_object V]
variables [has_equalizers V] [has_images V] [has_image_maps V] [has_cokernels V]
variables {c : complex_shape ι} {C D E : homological_complex V c}

/--
A chain map is a quasi-isomorphism if it induces isomorphisms on homology.
-/
class quasi_iso (f : C ⟶ D) : Prop :=
(is_iso : ∀ i, is_iso ((homology_functor V c i).map f))

attribute [instance] quasi_iso.is_iso

@[priority 100]
instance quasi_iso_of_iso (f : C ⟶ D) [is_iso f] : quasi_iso f :=
{ is_iso := λ i, begin
    change is_iso (((homology_functor V c i).map_iso (as_iso f)).hom),
    apply_instance,
  end }

instance quasi_iso_comp (f : C ⟶ D) [quasi_iso f] (g : D ⟶ E) [quasi_iso g] : quasi_iso (f ≫ g) :=
{ is_iso := λ i, begin
    rw functor.map_comp,
    apply_instance,
  end }

lemma quasi_iso_of_comp_left (f : C ⟶ D) [quasi_iso f] (g : D ⟶ E) [quasi_iso (f ≫ g)] :
  quasi_iso g :=
{ is_iso := λ i, is_iso.of_is_iso_fac_left ((homology_functor V c i).map_comp f g).symm }

lemma quasi_iso_of_comp_right (f : C ⟶ D) (g : D ⟶ E) [quasi_iso g] [quasi_iso (f ≫ g)] :
  quasi_iso f :=
{ is_iso := λ i, is_iso.of_is_iso_fac_right ((homology_functor V c i).map_comp f g).symm }


-- import topology.Top.presheaf
-- import category_theory.tactics.obviously

-- open category_theory
-- open category_theory.examples

-- universes u v

-- open category_theory.presheaves
-- open topological_space

-- namespace category_theory

-- /- `Presheaf` is a 2-functor CAT ⥤₂ CAT, but we're not going to prove all of that yet. -/

-- attribute [simp] set.preimage_id -- mathlib??

-- section
-- variables {C : Type u} [𝒞 : category.{u v} C] {D : Type u} [𝒟 : category.{u v} D]
-- include 𝒞 𝒟

-- set_option trace.tidy true

-- def functor.map_presheaf (F : C ⥤ D) : Presheaf.{u v} C ⥤ Presheaf.{u v} D :=
-- { obj := λ X, { X := X.X, 𝒪 := X.𝒪 ⋙ F },
--   map := λ X Y f, { f := f.f, c := whisker_right f.c F },
--   map_id' :=
--   begin
--     intros X,
--     ext1,
--     swap,
--     refl,
--     ext1, -- check the equality of natural transformations componentwise
--     dsimp at *,
--     erw functor.map_id,
--     erw functor.map_id,
--     simp,
--   end,
--   map_comp' :=
--   begin
--     intros X Y Z f g,
--     ext1,
--     swap,
--     refl,
--     tidy,
--     dsimp [opens.map_iso, nat_iso.of_components, opens.map],
--     erw functor.map_id,
--     erw functor.map_id,
--     simp,
--   end }.

-- def nat_trans.map_presheaf {F G : C ⥤ D} (α : F ⟹ G) : (G.map_presheaf) ⟹ (F.map_presheaf) :=
-- { app := λ ℱ,
--   { f := 𝟙 ℱ.X,
--     c := { app := λ U, (α.app _) ≫ G.map (ℱ.𝒪.map ((opens.map_id ℱ.X).hom.app U)),
--            naturality' := sorry }
--   },
--   naturality' := sorry }

-- lemma map₂_id {F : C ⥤ D} : (nat_trans.id F).map_presheaf = nat_trans.id (F.map_presheaf) :=
-- sorry
-- lemma map₂_vcomp {F G H : C ⥤ D} (α : F ⟹ G) (β : G ⟹ H) : β.map_presheaf ⊟ α.map_presheaf =
-- (α ⊟ β).map_presheaf := sorry
-- end

-- section
-- variables (C : Type u) [𝒞 : category.{u v} C]
-- include 𝒞
-- def presheaves.map_presheaf_id : ((functor.id C).map_presheaf) ≅ functor.id (Presheaf.{u v} C) :=
-- sorry
-- end

-- section
-- variables {C : Type u} [𝒞 : category.{u v} C]
--           {D : Type u} [𝒟 : category.{u v} D]
--           {E : Type u} [ℰ : category.{u v} E]
-- include 𝒞 𝒟 ℰ
-- def presheaves.map_presheaf_comp (F : C ⥤ D) (G : D ⥤ E) :
--   (F.map_presheaf) ⋙ (G.map_presheaf) ≅ (F ⋙ G).map_presheaf :=
-- { hom := sorry,
--   inv := sorry,
--   hom_inv_id' := sorry,
--   inv_hom_id' := sorry }

-- lemma nat_trans.map_presheaf_hcomp {F G : C ⥤ D} {H K : D ⥤ E} (α : F ⟹ G) (β : H ⟹ K) :
--   ((α.map_presheaf ◫ β.map_presheaf) ⊟ (presheaves.map_presheaf_comp F H).hom) =
--   ((presheaves.map_presheaf_comp G K).hom ⊟ ((α ◫ β).map_presheaf)) :=
-- sorry
-- end

-- end category_theory


/-
Copyright (c) 2020 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.basic
import data.fintype.basic

/-!
# Derive handler for `fintype` instances

This file introduces a derive handler to automatically generate `fintype`
instances for structures and inductives.

## Implementation notes

To construct a fintype instance, we need 3 things:

  1. A list `l` of elements
  2. A proof that `l` has no duplicates
  3. A proof that every element in the type is in `l`

Now fintype is defined as a finset which enumerates all elements, so steps (1) and (2) are
bundled together. It is possible to use finset operations that remove duplicates to avoid the need
to prove (2), but this adds unnecessary functions to the constructed term, which makes it more
expensive to compute the list, and it also adds a dependence on decidable equality for the type,
which we want to avoid.

Because we will rely on fintype instances for constructor arguments, we can't actually build a list
directly, so (1) and (2) are necessarily somewhat intertwined. The inductive types we will be
proving instances for look something like this:

```
@[derive fintype]
inductive foo
| zero : foo
| one : bool → foo
| two : ∀ x : fin 3, bar x → foo
```

The list of elements that we generate is
```
{foo.zero}
∪ (finset.univ : bool).map (λ b, finset.one b)
∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
except that instead of `∪`, that is `finset.union`, we use `finset.disj_union` which doesn't
require any deduplication, but does require a proof that the two parts of the union are disjoint.
We use `finset.cons` to append singletons like `foo.zero`.

The proofs of disjointness would be somewhat expensive since there are quadratically many of them,
so instead we use a "discriminant" function. Essentially, we define
```
def foo.enum : foo → ℕ
| foo.zero := 0
| (foo.one _) := 1
| (foo.two _ _) := 2
```
and now the existence of this function implies that foo.zero is not foo.two and so on because they
map to different natural numbers. We can prove that sets of natural numbers are mutually disjoint
more easily because they have a linear order: `0 < 1 < 2` so `0 ≠ 2`.

To package this argument up, we define `finset_above foo foo.enum n` to be a finset `s` together
with a proof that all elements `a ∈ s` have `n ≤ enum a`. Now we only have to prove that
`enum foo.zero = 0`, `enum (foo.one _) = 1`, etc. (linearly many proofs, all `rfl`) in order to
prove that all variants are mutually distinct.

We mirror the `finset.cons` and `finset.disj_union` functions into `finset_above.cons` and
`finset_above.union`, and this forms the main part of the finset construction.

This only handles distinguishing variants of a finset. Now we must enumerate the elements of a
variant, for example `{foo.one ff, foo.one tt}`, while at the same time proving that all these
elements have discriminant `1` in this case. To do that, we use the `finset_in` type, which
is a finset satisfying a property `P`, here `λ a, foo.enum a = 1`.

We could use `finset.bind` many times to construct the finset but it turns out to be somewhat
complicated to get good side goals for a naturally nodup version of `finset.bind` in the same way
as we did with `finset.cons` and `finset.union`. Instead, we tuple up all arguments into one type,
leveraging the `fintype` instance on `psigma`, and then define a map from this type to the
inductive type that untuples them and applies the constructor. The injectivity property of the
constructor ensures that this function is injective, so we can use `finset.map` to apply it. This
is the content of the constructor `finset_in.mk`.

That completes the proofs of (1) and (2). To prove (3), we perform one case analysis over the
inductive type, proving theorems like
```
foo.one a ∈ {foo.zero}
  ∪ (finset.univ : bool).map (λ b, finset.one b)
  ∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
by seeking to the relevant disjunct and then supplying the constructor arguments. This part of the
proof is quadratic, but quite simple. (We could do it in `O(n log n)` if we used a balanced tree
for the unions.)

The tactics perform the following parts of this proof scheme:
* `mk_sigma` constructs the type `Γ` in `finset_in.mk`
* `mk_sigma_elim` constructs the function `f` in `finset_in.mk`
* `mk_sigma_elim_inj` proves that `f` is injective
* `mk_sigma_elim_eq` proves that `∀ a, enum (f a) = k`
* `mk_finset` constructs the finset `S = {foo.zero} ∪ ...` by recursion on the variants
* `mk_finset_total` constructs the proof `|- foo.zero ∈ S; |- foo.one a ∈ S; |- foo.two a b ∈ S`
  by recursion on the subgoals coming out of the initial `cases`
* `mk_fintype_instance` puts it all together to produce a proof of `fintype foo`.
  The construction of `foo.enum` is also done in this function.

-/

namespace derive_fintype

/-- A step in the construction of `finset.univ` for a finite inductive type.
We will set `enum` to the discriminant of the inductive type, so a `finset_above`
represents a finset that enumerates all elements in a tail of the constructor list. -/
def finset_above (α) (enum : α → ℕ) (n : ℕ) :=
{s : finset α // ∀ x ∈ s, n ≤ enum x}

/-- Construct a fintype instance from a completed `finset_above`. -/
def mk_fintype {α} (enum : α → ℕ) (s : finset_above α enum 0) (H : ∀ x, x ∈ s.1) :
  fintype α := ⟨s.1, H⟩

/-- This is the case for a simple variant (no arguments) in an inductive type. -/
def finset_above.cons {α} {enum : α → ℕ} (n)
  (a : α) (h : enum a = n) (s : finset_above α enum (n+1)) : finset_above α enum n :=
begin
  refine ⟨finset.cons a s.1 _, _⟩,
  { intro h',
    have := s.2 _ h', rw h at this,
    exact nat.not_succ_le_self n this },
  { intros x h', rcases finset.mem_cons.1 h' with rfl | h',
    { exact ge_of_eq h },
    { exact nat.le_of_succ_le (s.2 _ h') } }
end

theorem finset_above.mem_cons_self {α} {enum : α → ℕ} {n a h s} :
  a ∈ (@finset_above.cons α enum n a h s).1 := multiset.mem_cons_self _ _

theorem finset_above.mem_cons_of_mem {α} {enum : α → ℕ} {n a h s b} :
  b ∈ (s : finset_above _ _ _).1 → b ∈ (@finset_above.cons α enum n a h s).1 :=
multiset.mem_cons_of_mem

/-- The base case is when we run out of variants; we just put an empty finset at the end. -/
def finset_above.nil {α} {enum : α → ℕ} (n) : finset_above α enum n := ⟨∅, by rintro _ ⟨⟩⟩

instance (α enum n) : inhabited (finset_above α enum n) := ⟨finset_above.nil _⟩

/-- This is a finset covering a nontrivial variant (with one or more constructor arguments).
The property `P` here is `λ a, enum a = n` where `n` is the discriminant for the current
variant. -/
@[nolint has_inhabited_instance]
def finset_in {α} (P : α → Prop) := {s : finset α // ∀ x ∈ s, P x}

/-- To construct the finset, we use an injective map from the type `Γ`, which will be the
sigma over all constructor arguments. We use sigma instances and existing fintype instances
to prove that `Γ` is a fintype, and construct the function `f` that maps `⟨a, b, c, ...⟩`
to `C_n a b c ...` where `C_n` is the nth constructor, and `mem` asserts
`enum (C_n a b c ...) = n`. -/
def finset_in.mk {α} {P : α → Prop} (Γ) [fintype Γ]
  (f : Γ → α) (inj : function.injective f) (mem : ∀ x, P (f x)) : finset_in P :=
⟨finset.univ.map ⟨f, inj⟩,
 λ x h, by rcases finset.mem_map.1 h with ⟨x, _, rfl⟩; exact mem x⟩

theorem finset_in.mem_mk {α} {P : α → Prop} {Γ} {s : fintype Γ} {f : Γ → α} {inj mem a}
  (b) (H : f b = a) : a ∈ (@finset_in.mk α P Γ s f inj mem).1 :=
finset.mem_map.2 ⟨_, finset.mem_univ _, H⟩

/-- For nontrivial variants, we split the constructor list into a `finset_in` component for the
current constructor and a `finset_above` for the rest. -/
def finset_above.union {α} {enum : α → ℕ} (n)
  (s : finset_in (λ a, enum a = n)) (t : finset_above α enum (n+1)) : finset_above α enum n :=
begin
  refine ⟨finset.disj_union s.1 t.1 _, _⟩,
  { intros a hs ht,
    have := t.2 _ ht, rw s.2 _ hs at this,
    exact nat.not_succ_le_self n this },
  { intros x h', rcases finset.mem_disj_union.1 h' with h' | h',
    { exact ge_of_eq (s.2 _ h') },
    { exact nat.le_of_succ_le (t.2 _ h') } }
end

theorem finset_above.mem_union_left {α} {enum : α → ℕ} {n s t a}
  (H : a ∈ (s : finset_in _).1) : a ∈ (@finset_above.union α enum n s t).1 :=
multiset.mem_add.2 (or.inl H)

theorem finset_above.mem_union_right {α} {enum : α → ℕ} {n s t a}
  (H : a ∈ (t : finset_above _ _ _).1) : a ∈ (@finset_above.union α enum n s t).1 :=
multiset.mem_add.2 (or.inr H)

end derive_fintype

namespace tactic

open derive_fintype tactic expr

namespace derive_fintype

/-- Construct the term `Σ' (a:A) (b:B a) (c:C a b), unit` from
`Π (a:A) (b:B a), C a b → T` (the type of a constructor). -/
meta def mk_sigma : expr → tactic expr
| (expr.pi n bi d b) := do
  p ← mk_local' n bi d,
  e ← mk_sigma (expr.instantiate_var b p),
  tactic.mk_app ``psigma [d, bind_lambda e p]
| _ := pure `(unit)

/-- Prove the goal `(Σ' (a:A) (b:B a) (c:C a b), unit) → T`
(this is the function `f` in `finset_in.mk`) using recursive `psigma.elim`,
finishing with the constructor. The two arguments are the type of the constructor,
and the constructor term itself; as we recurse we add arguments
to the constructor application and destructure the pi type of the constructor. We return the number
of `psigma.elim` applications constructed, which is the number of constructor arguments. -/
meta def mk_sigma_elim : expr → expr → tactic ℕ
| (expr.pi n bi d b) c := do
  refine ``(@psigma.elim %%d _ _ _),
  i ← intro_fresh n,
  (+ 1) <$> mk_sigma_elim (expr.instantiate_var b i) (c i)
| _ c := do intro1, exact c $> 0

/-- Prove the goal `a, b |- f a = f b → g a = g b` where `f` is the function we constructed in
`mk_sigma_elim`, and `g` is some other term that gets built up and eventually closed by
reflexivity. Here `a` and `b` have sigma types so the proof approach is to case on `a` and `b`
until the goal reduces to `C_n a1 ... am = C_n b1 ... bm → ⟨a1, ..., am⟩ = ⟨b1, ..., bm⟩`, at which
point cases on the equality reduces the problem to reflexivity.

The arguments are the number `m` returned from `mk_sigma_elim`, and the hypotheses `a,b` that we
need to case on. -/
meta def mk_sigma_elim_inj : ℕ → expr → expr → tactic unit
| (m+1) x y := do
  [(_, [x1, x2])] ← cases x,
  [(_, [y1, y2])] ← cases y,
  mk_sigma_elim_inj m x2 y2
| 0 x y := do
  cases x, cases y,
  is ← intro1 >>= injection,
  is.mmap' cases,
  reflexivity

/-- Prove the goal `a |- enum (f a) = n`, where `f` is the function constructed in `mk_sigma_elim`,
and `enum` is a function that reduces to `n` on the constructor `C_n`. Here we just have to case on
`a` `m` times, and then `reflexivity` finishes the proof. -/
meta def mk_sigma_elim_eq : ℕ → expr → tactic unit
| (n+1) x := do
  [(_, [x1, x2])] ← cases x,
  mk_sigma_elim_eq n x2
| 0 x := reflexivity

/-- Prove the goal `|- finset_above T enum k`, where `T` is the inductive type and `enum` is the
discriminant function. The arguments are `args`, the parameters to the inductive type (and all
constructors), `k`, the index of the current variant, and `cs`, the list of constructor names.
This uses `finset_above.cons` for basic variants and `finset_above.union` for variants with
arguments, using the auxiliary functions `mk_sigma`, `mk_sigma_elim`, `mk_sigma_elim_inj`,
`mk_sigma_elim_eq` to close subgoals. -/
meta def mk_finset (args : list expr) : ℕ → list name → tactic unit
| k (c::cs) := do
  e ← mk_const c,
  let e := e.mk_app args,
  t ← infer_type e,
  if is_pi t then do
    to_expr ``(finset_above.union %%(reflect k)) tt ff >>=
      (λ c, apply c {new_goals := new_goals.all}),
    Γ ← mk_sigma t,
    to_expr ``(finset_in.mk %%Γ) tt ff >>= (λ c, apply c {new_goals := new_goals.all}),
    n ← mk_sigma_elim t e,
    intro1 >>= (λ x, intro1 >>= mk_sigma_elim_inj n x),
    intro1 >>= mk_sigma_elim_eq n,
    mk_finset (k+1) cs
  else do
    c ← to_expr ``(finset_above.cons %%(reflect k) %%e) tt ff,
    apply c {new_goals := new_goals.all}, reflexivity,
    mk_finset (k+1) cs
| k [] := applyc ``finset_above.nil

/-- Prove the goal `|- Σ' (a:A) (b: B a) (c:C a b), unit` given a list of terms `a, b, c`. -/
meta def mk_sigma_mem : list expr → tactic unit
| (x::xs) := fconstructor >> exact x >> mk_sigma_mem xs
| [] := fconstructor $> ()

/-- This function is called to prove `a : T |- a ∈ S.1` where `S` is the `finset_above` constructed
by `mk_finset`, after the initial cases on `a : T`, producing a list of subgoals. For each case,
we have to navigate past all the variants that don't apply (which is what the `tac` input tactic
does), and then call either `finset_above.mem_cons_self` for trivial variants or
`finset_above.mem_union_left` and `finset_in.mem_mk` for nontrivial variants. Either way the proof
is quite simple. -/
meta def mk_finset_total : tactic unit → list (name × list expr) → tactic unit
| tac [] := done
| tac ((_, xs) :: gs) := do
  tac,
  b ← succeeds (applyc ``finset_above.mem_cons_self),
  if b then
    mk_finset_total (tac >> applyc ``finset_above.mem_cons_of_mem) gs
  else do
    applyc ``finset_above.mem_union_left,
    applyc ``finset_in.mem_mk {new_goals := new_goals.all},
    mk_sigma_mem xs,
    reflexivity,
    mk_finset_total (tac >> applyc ``finset_above.mem_union_right) gs

end derive_fintype

open tactic.derive_fintype

/-- Proves `|- fintype T` where `T` is a non-recursive inductive type with no indices,
where all arguments to all constructors are fintypes. -/
meta def mk_fintype_instance : tactic unit :=
do
  intros,
  `(fintype %%e) ← target >>= whnf,
  (const I ls, args) ← pure (get_app_fn_args e),
  env ← get_env,
  let cs := env.constructors_of I,
  guard (env.inductive_num_indices I = 0) <|>
    fail "@[derive fintype]: inductive indices are not supported",
  guard (¬ env.is_recursive I) <|>
    fail ("@[derive fintype]: recursive inductive types are " ++
          "not supported (they are also usually infinite)"),
  applyc ``mk_fintype {new_goals := new_goals.all},
  intro1 >>= cases >>= (λ gs,
    gs.enum.mmap' $ λ ⟨i, _⟩, exact (reflect i)),
  mk_finset args 0 cs,
  intro1 >>= cases >>= mk_finset_total skip

/--
Tries to derive a `fintype` instance for inductives and structures.

For example:
```
@[derive fintype]
inductive foo (n m : ℕ)
| zero : foo
| one : bool → foo
| two : fin n → fin m → foo
```
Here, `@[derive fintype]` adds the instance `foo.fintype`. The underlying finset
definitionally unfolds to a list that enumerates the elements of the inductive in
lexicographic order.

If the structure/inductive has a type parameter `α`, then the generated instance will have an
argument `fintype α`, even if it is not used.  (This is due to the implementation using
`instance_derive_handler`.)
-/
@[derive_handler] meta def fintype_instance : derive_handler :=
instance_derive_handler ``fintype mk_fintype_instance

end tactic


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.distribution_semantics.monad

/-!
# Miscellaneous Lemmas About Distribution Semantics

This file contains lemmas about `eval_dist` and `prob_event` that don't fit anywhere else.
Ideally these lemmas should eventually be ported to a more dedicated file,
but this is meant as a temprorary location for specific lemmas without a fleshed out background.
-/

namespace oracle_comp

open oracle_spec
open_locale big_operators ennreal

variables {α β γ : Type} {spec spec' : oracle_spec}

/-- Right the `eval_dist` of bind as a sum over another type,
using a map that is both injective and surjective on corresponding supports,
although it may not actually be bijective on the entire spaces. -/
lemma helper {oa : oracle_comp spec α}
  {ob : α → oracle_comp spec β} {b : β} (g : γ → α)
  (h : ∀ x ∈ oa.support, b ∈ (ob x).support → x ∈ set.range g)
  (hg : ∀ x y, g x = g y → g x ∈ oa.support → b ∈ (ob (g x)).support → x = y) :
  ⁅oa >>= ob⁆ b = ∑' (c : γ), ⁅oa⁆ (g c) * ⁅ob (g c)⁆ b :=
begin
  rw [eval_dist_bind_apply_eq_tsum],
  refine tsum_eq_tsum_of_ne_zero_bij (g ∘ coe) _ _ (λ _, rfl),
  { intros x y h,
    have := x.2,
    simp only [subtype.val_eq_coe, function.support_mul, set.mem_inter_iff, function.mem_support,
      ne.def, eval_dist_eq_zero_iff, set.not_not_mem] at this,
    refine hg ↑x ↑y h this.1 this.2 },
  { intros x hx,
    simp only [function.support_mul, set.mem_inter_iff, function.mem_support, ne.def,
      eval_dist_eq_zero_iff, set.not_not_mem] at hx,
    specialize h x hx.1 hx.2,
    rw [set.mem_range] at h,
    obtain ⟨y, hy⟩ := h,
    rw [← hy, set.range_comp, set.mem_image],
    refine ⟨y, _, rfl⟩,
    rw [subtype.range_coe_subtype],
    simp only [hy, hx, function.support_mul, set.mem_inter_iff, function.mem_support,
      ne.def, eval_dist_eq_zero_iff, set.not_not_mem, set.mem_set_of_eq, true_and] }
end

end oracle_comp


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.strong_epi

/-!
# Categorical images

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

We define the categorical image of `f` as a factorisation `f = e ≫ m` through a monomorphism `m`,
so that `m` factors through the `m'` in any other such factorisation.

## Main definitions

* A `mono_factorisation` is a factorisation `f = e ≫ m`, where `m` is a monomorphism
* `is_image F` means that a given mono factorisation `F` has the universal property of the image.
* `has_image f` means that there is some image factorization for the morphism `f : X ⟶ Y`.
  * In this case, `image f` is some image object (selected with choice), `image.ι f : image f ⟶ Y`
    is the monomorphism `m` of the factorisation and `factor_thru_image f : X ⟶ image f` is the
    morphism `e`.
* `has_images C` means that every morphism in `C` has an image.
* Let `f : X ⟶ Y` and `g : P ⟶ Q` be morphisms in `C`, which we will represent as objects of the
  arrow category `arrow C`. Then `sq : f ⟶ g` is a commutative square in `C`. If `f` and `g` have
  images, then `has_image_map sq` represents the fact that there is a morphism
  `i : image f ⟶ image g` making the diagram

  X ----→ image f ----→ Y
  |         |           |
  |         |           |
  ↓         ↓           ↓
  P ----→ image g ----→ Q

  commute, where the top row is the image factorisation of `f`, the bottom row is the image
  factorisation of `g`, and the outer rectangle is the commutative square `sq`.
* If a category `has_images`, then `has_image_maps` means that every commutative square admits an
  image map.
* If a category `has_images`, then `has_strong_epi_images` means that the morphism to the image is
  always a strong epimorphism.

## Main statements

* When `C` has equalizers, the morphism `e` appearing in an image factorisation is an epimorphism.
* When `C` has strong epi images, then these images admit image maps.

## Future work
* TODO: coimages, and abelian categories.
* TODO: connect this with existing working in the group theory and ring theory libraries.

-/

noncomputable theory

universes v u

open category_theory
open category_theory.limits.walking_parallel_pair

namespace category_theory.limits

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

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

/-- A factorisation of a morphism `f = e ≫ m`, with `m` monic. -/
structure mono_factorisation (f : X ⟶ Y) :=
(I : C)
(m : I ⟶ Y)
[m_mono : mono m]
(e : X ⟶ I)
(fac' : e ≫ m = f . obviously)

restate_axiom mono_factorisation.fac'
attribute [simp, reassoc] mono_factorisation.fac
attribute [instance] mono_factorisation.m_mono

attribute [instance] mono_factorisation.m_mono

namespace mono_factorisation

/-- The obvious factorisation of a monomorphism through itself. -/
def self [mono f] : mono_factorisation f :=
{ I := X,
  m := f,
  e := 𝟙 X }

-- I'm not sure we really need this, but the linter says that an inhabited instance
-- ought to exist...
instance [mono f] : inhabited (mono_factorisation f) := ⟨self f⟩

variables {f}

/-- The morphism `m` in a factorisation `f = e ≫ m` through a monomorphism is uniquely
determined. -/
@[ext]
lemma ext
  {F F' : mono_factorisation f} (hI : F.I = F'.I) (hm : F.m = (eq_to_hom hI) ≫ F'.m) : F = F' :=
begin
  cases F, cases F',
  cases hI,
  simp at hm,
  dsimp at F_fac' F'_fac',
  congr,
  { assumption },
  { resetI, apply (cancel_mono F_m).1,
    rw [F_fac', hm, F'_fac'], }
end

/-- Any mono factorisation of `f` gives a mono factorisation of `f ≫ g` when `g` is a mono. -/
@[simps]
def comp_mono (F : mono_factorisation f) {Y' : C} (g : Y ⟶ Y') [mono g] :
  mono_factorisation (f ≫ g) :=
{ I := F.I,
  m := F.m ≫ g,
  m_mono := mono_comp _ _,
  e := F.e, }

/-- A mono factorisation of `f ≫ g`, where `g` is an isomorphism,
gives a mono factorisation of `f`. -/
@[simps]
def of_comp_iso {Y' : C} {g : Y ⟶ Y'} [is_iso g] (F : mono_factorisation (f ≫ g)) :
  mono_factorisation f :=
{ I := F.I,
  m := F.m ≫ (inv g),
  m_mono := mono_comp _ _,
  e := F.e, }

/-- Any mono factorisation of `f` gives a mono factorisation of `g ≫ f`. -/
@[simps]
def iso_comp (F : mono_factorisation f) {X' : C} (g : X' ⟶ X) :
  mono_factorisation (g ≫ f) :=
{ I := F.I,
  m := F.m,
  e := g ≫ F.e, }

/-- A mono factorisation of `g ≫ f`, where `g` is an isomorphism,
gives a mono factorisation of `f`. -/
@[simps]
def of_iso_comp {X' : C} (g : X' ⟶ X) [is_iso g] (F : mono_factorisation (g ≫ f)) :
  mono_factorisation f :=
{ I := F.I,
  m := F.m,
  e := inv g ≫ F.e, }

/-- If `f` and `g` are isomorphic arrows, then a mono factorisation of `f`
gives a mono factorisation of `g` -/
@[simps]
def of_arrow_iso {f g : arrow C} (F : mono_factorisation f.hom) (sq : f ⟶ g) [is_iso sq] :
  mono_factorisation g.hom :=
{ I := F.I,
  m := F.m ≫ sq.right,
  e := inv sq.left ≫ F.e,
  m_mono := mono_comp _ _,
  fac' := by simp only [fac_assoc, arrow.w, is_iso.inv_comp_eq, category.assoc] }

end mono_factorisation

variable {f}

/-- Data exhibiting that a given factorisation through a mono is initial. -/
structure is_image (F : mono_factorisation f) :=
(lift : Π (F' : mono_factorisation f), F.I ⟶ F'.I)
(lift_fac' : Π (F' : mono_factorisation f), lift F' ≫ F'.m = F.m . obviously)

restate_axiom is_image.lift_fac'
attribute [simp, reassoc] is_image.lift_fac

namespace is_image

@[simp, reassoc] lemma fac_lift {F : mono_factorisation f} (hF : is_image F)
  (F' : mono_factorisation f) : F.e ≫ hF.lift F' = F'.e :=
(cancel_mono F'.m).1 $ by simp

variable (f)

/-- The trivial factorisation of a monomorphism satisfies the universal property. -/
@[simps]
def self [mono f] : is_image (mono_factorisation.self f) :=
{ lift := λ F', F'.e }

instance [mono f] : inhabited (is_image (mono_factorisation.self f)) :=
⟨self f⟩

variable {f}

/-- Two factorisations through monomorphisms satisfying the universal property
must factor through isomorphic objects. -/
-- TODO this is another good candidate for a future `unique_up_to_canonical_iso`.
@[simps]
def iso_ext {F F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') : F.I ≅ F'.I :=
{ hom := hF.lift F',
  inv := hF'.lift F,
  hom_inv_id' := (cancel_mono F.m).1 (by simp),
  inv_hom_id' := (cancel_mono F'.m).1 (by simp) }

variables {F F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F')

lemma iso_ext_hom_m : (iso_ext hF hF').hom ≫ F'.m = F.m := by simp
lemma iso_ext_inv_m : (iso_ext hF hF').inv ≫ F.m = F'.m := by simp
lemma e_iso_ext_hom : F.e ≫ (iso_ext hF hF').hom = F'.e := by simp
lemma e_iso_ext_inv : F'.e ≫ (iso_ext hF hF').inv = F.e := by simp

/-- If `f` and `g` are isomorphic arrows, then a mono factorisation of `f` that is an image
gives a mono factorisation of `g` that is an image -/
@[simps]
def of_arrow_iso {f g : arrow C} {F : mono_factorisation f.hom} (hF : is_image F)
  (sq : f ⟶ g) [is_iso sq] :
  is_image (F.of_arrow_iso sq) :=
{ lift := λ F', hF.lift (F'.of_arrow_iso (inv sq)),
  lift_fac' := λ F', by simpa only [mono_factorisation.of_arrow_iso_m, arrow.inv_right,
    ← category.assoc, is_iso.comp_inv_eq] using hF.lift_fac (F'.of_arrow_iso (inv sq)) }

end is_image

variable (f)

/-- Data exhibiting that a morphism `f` has an image. -/
structure image_factorisation (f : X ⟶ Y) :=
(F : mono_factorisation f)
(is_image : is_image F)

namespace image_factorisation

instance [mono f] : inhabited (image_factorisation f) :=
⟨⟨_, is_image.self f⟩⟩

/-- If `f` and `g` are isomorphic arrows, then an image factorisation of `f`
gives an image factorisation of `g` -/
@[simps]
def of_arrow_iso {f g : arrow C} (F : image_factorisation f.hom) (sq : f ⟶ g) [is_iso sq] :
  image_factorisation g.hom :=
{ F := F.F.of_arrow_iso sq,
  is_image := F.is_image.of_arrow_iso sq }

end image_factorisation

/-- `has_image f` means that there exists an image factorisation of `f`. -/
class has_image (f : X ⟶ Y) : Prop :=
mk' :: (exists_image : nonempty (image_factorisation f))

lemma has_image.mk {f : X ⟶ Y} (F : image_factorisation f) : has_image f :=
⟨nonempty.intro F⟩

lemma has_image.of_arrow_iso {f g : arrow C} [h : has_image f.hom] (sq : f ⟶ g) [is_iso sq] :
  has_image g.hom :=
⟨⟨h.exists_image.some.of_arrow_iso sq⟩⟩

@[priority 100]
instance mono_has_image (f : X ⟶ Y) [mono f] : has_image f :=
has_image.mk ⟨_, is_image.self f⟩

section
variable [has_image f]

/-- Some factorisation of `f` through a monomorphism (selected with choice). -/
def image.mono_factorisation : mono_factorisation f :=
(classical.choice (has_image.exists_image)).F

/-- The witness of the universal property for the chosen factorisation of `f` through
a monomorphism. -/
def image.is_image : is_image (image.mono_factorisation f) :=
(classical.choice (has_image.exists_image)).is_image

/-- The categorical image of a morphism. -/
def image : C := (image.mono_factorisation f).I
/-- The inclusion of the image of a morphism into the target. -/
def image.ι : image f ⟶ Y := (image.mono_factorisation f).m
@[simp] lemma image.as_ι : (image.mono_factorisation f).m = image.ι f := rfl
instance : mono (image.ι f) := (image.mono_factorisation f).m_mono

/-- The map from the source to the image of a morphism. -/
def factor_thru_image : X ⟶ image f := (image.mono_factorisation f).e
/-- Rewrite in terms of the `factor_thru_image` interface. -/
@[simp]
lemma as_factor_thru_image : (image.mono_factorisation f).e = factor_thru_image f := rfl
@[simp, reassoc]
lemma image.fac : factor_thru_image f ≫ image.ι f = f := (image.mono_factorisation f).fac'

variable {f}

/-- Any other factorisation of the morphism `f` through a monomorphism receives a map from the
image. -/
def image.lift (F' : mono_factorisation f) : image f ⟶ F'.I := (image.is_image f).lift F'
@[simp, reassoc]
lemma image.lift_fac (F' : mono_factorisation f) : image.lift F' ≫ F'.m = image.ι f :=
(image.is_image f).lift_fac' F'
@[simp, reassoc]
lemma image.fac_lift (F' : mono_factorisation f) : factor_thru_image f ≫ image.lift F' = F'.e :=
(image.is_image f).fac_lift F'
@[simp]
lemma image.is_image_lift (F : mono_factorisation f) :
  (image.is_image f).lift F = image.lift F :=
rfl

@[simp, reassoc]
lemma is_image.lift_ι {F : mono_factorisation f} (hF : is_image F) :
  hF.lift (image.mono_factorisation f) ≫ image.ι f = F.m :=
hF.lift_fac _

-- TODO we could put a category structure on `mono_factorisation f`,
-- with the morphisms being `g : I ⟶ I'` commuting with the `m`s
-- (they then automatically commute with the `e`s)
-- and show that an `image_of f` gives an initial object there
-- (uniqueness of the lift comes for free).

instance image.lift_mono (F' : mono_factorisation f) : mono (image.lift F') :=
by { apply mono_of_mono _ F'.m, simpa using mono_factorisation.m_mono _ }

lemma has_image.uniq
  (F' : mono_factorisation f) (l : image f ⟶ F'.I) (w : l ≫ F'.m = image.ι f) :
  l = image.lift F' :=
(cancel_mono F'.m).1 (by simp [w])

/-- If `has_image g`, then `has_image (f ≫ g)` when `f` is an isomorphism. -/
instance {X Y Z : C} (f : X ⟶ Y) [is_iso f] (g : Y ⟶ Z) [has_image g] : has_image (f ≫ g) :=
{ exists_image := ⟨
{ F :=
  { I := image g,
    m := image.ι g,
    e := f ≫ factor_thru_image g, },
  is_image := { lift := λ F', image.lift { I := F'.I, m := F'.m, e := inv f ≫ F'.e, }, }, }⟩ }

end

section
variables (C)

/-- `has_images` asserts that every morphism has an image. -/
class has_images : Prop :=
(has_image : Π {X Y : C} (f : X ⟶ Y), has_image f)

attribute [instance, priority 100] has_images.has_image
end

section
variables (f)
/-- The image of a monomorphism is isomorphic to the source. -/
def image_mono_iso_source [mono f] : image f ≅ X :=
is_image.iso_ext (image.is_image f) (is_image.self f)

@[simp, reassoc]
lemma image_mono_iso_source_inv_ι [mono f] : (image_mono_iso_source f).inv ≫ image.ι f = f :=
by simp [image_mono_iso_source]
@[simp, reassoc]
lemma image_mono_iso_source_hom_self [mono f] : (image_mono_iso_source f).hom ≫ f = image.ι f :=
begin
  conv { to_lhs, congr, skip, rw ←image_mono_iso_source_inv_ι f, },
  rw [←category.assoc, iso.hom_inv_id, category.id_comp],
end

-- This is the proof that `factor_thru_image f` is an epimorphism
-- from https://en.wikipedia.org/wiki/Image_%28category_theory%29, which is in turn taken from:
-- Mitchell, Barry (1965), Theory of categories, MR 0202787, p.12, Proposition 10.1
@[ext]
lemma image.ext [has_image f] {W : C} {g h : image f ⟶ W} [has_limit (parallel_pair g h)]
  (w : factor_thru_image f ≫ g = factor_thru_image f ≫ h) :
  g = h :=
begin
  let q := equalizer.ι g h,
  let e' := equalizer.lift _ w,
  let F' : mono_factorisation f :=
  { I := equalizer g h,
    m := q ≫ image.ι f,
    m_mono := by apply mono_comp,
    e := e' },
  let v := image.lift F',
  have t₀ : v ≫ q ≫ image.ι f = image.ι f := image.lift_fac F',
  have t : v ≫ q = 𝟙 (image f) :=
    (cancel_mono_id (image.ι f)).1 (by { convert t₀ using 1, rw category.assoc }),
  -- The proof from wikipedia next proves `q ≫ v = 𝟙 _`,
  -- and concludes that `equalizer g h ≅ image f`,
  -- but this isn't necessary.
  calc g = 𝟙 (image f) ≫ g : by rw [category.id_comp]
     ... = v ≫ q ≫ g       : by rw [←t, category.assoc]
     ... = v ≫ q ≫ h       : by rw [equalizer.condition g h]
     ... = 𝟙 (image f) ≫ h : by rw [←category.assoc, t]
     ... = h                : by rw [category.id_comp]
end

instance [has_image f] [Π {Z : C} (g h : image f ⟶ Z), has_limit (parallel_pair g h)] :
  epi (factor_thru_image f) :=
⟨λ Z g h w, image.ext f w⟩

lemma epi_image_of_epi {X Y : C} (f : X ⟶ Y) [has_image f] [E : epi f] : epi (image.ι f) :=
begin
  rw ←image.fac f at E,
  resetI,
  exact epi_of_epi (factor_thru_image f) (image.ι f),
end

lemma epi_of_epi_image {X Y : C} (f : X ⟶ Y) [has_image f]
  [epi (image.ι f)] [epi (factor_thru_image f)] : epi f :=
by { rw [←image.fac f], apply epi_comp, }

end

section
variables {f} {f' : X ⟶ Y} [has_image f] [has_image f']

/--
An equation between morphisms gives a comparison map between the images
(which momentarily we prove is an iso).
-/
def image.eq_to_hom (h : f = f') : image f ⟶ image f' :=
image.lift
{ I := image f',
  m := image.ι f',
  e := factor_thru_image f', }.

instance (h : f = f') : is_iso (image.eq_to_hom h) :=
⟨⟨image.eq_to_hom h.symm,
  ⟨(cancel_mono (image.ι f)).1 (by simp [image.eq_to_hom]),
   (cancel_mono (image.ι f')).1 (by simp [image.eq_to_hom])⟩⟩⟩

/-- An equation between morphisms gives an isomorphism between the images. -/
def image.eq_to_iso (h : f = f') : image f ≅ image f' := as_iso (image.eq_to_hom h)

/--
As long as the category has equalizers,
the image inclusion maps commute with `image.eq_to_iso`.
-/
lemma image.eq_fac [has_equalizers C] (h : f = f') :
  image.ι f = (image.eq_to_iso h).hom ≫ image.ι f' :=
by { ext, simp [image.eq_to_iso, image.eq_to_hom], }

end

section
variables {Z : C} (g : Y ⟶ Z)

/-- The comparison map `image (f ≫ g) ⟶ image g`. -/
def image.pre_comp [has_image g] [has_image (f ≫ g)] : image (f ≫ g) ⟶ image g :=
image.lift
{ I := image g,
  m := image.ι g,
  e := f ≫ factor_thru_image g }

@[simp, reassoc]
lemma image.pre_comp_ι [has_image g] [has_image (f ≫ g)] :
  image.pre_comp f g ≫ image.ι g = image.ι (f ≫ g) :=
by simp [image.pre_comp]

@[simp, reassoc]
lemma image.factor_thru_image_pre_comp [has_image g] [has_image (f ≫ g)] :
  factor_thru_image (f ≫ g) ≫ image.pre_comp f g = f ≫ factor_thru_image g :=
by simp [image.pre_comp]

/--
`image.pre_comp f g` is a monomorphism.
-/
instance image.pre_comp_mono [has_image g] [has_image (f ≫ g)] : mono (image.pre_comp f g) :=
begin
  apply mono_of_mono _ (image.ι g),
  simp only [image.pre_comp_ι],
  apply_instance,
end

/--
The two step comparison map
  `image (f ≫ (g ≫ h)) ⟶ image (g ≫ h) ⟶ image h`
agrees with the one step comparison map
  `image (f ≫ (g ≫ h)) ≅ image ((f ≫ g) ≫ h) ⟶ image h`.
 -/
lemma image.pre_comp_comp {W : C} (h : Z ⟶ W)
  [has_image (g ≫ h)] [has_image (f ≫ g ≫ h)]
  [has_image h] [has_image ((f ≫ g) ≫ h)] :
  image.pre_comp f (g ≫ h) ≫ image.pre_comp g h =
    image.eq_to_hom (category.assoc f g h).symm ≫ (image.pre_comp (f ≫ g) h) :=
begin
  apply (cancel_mono (image.ι h)).1,
  simp [image.pre_comp, image.eq_to_hom],
end

variables [has_equalizers C]

/--
`image.pre_comp f g` is an epimorphism when `f` is an epimorphism
(we need `C` to have equalizers to prove this).
-/
instance image.pre_comp_epi_of_epi [has_image g] [has_image (f ≫ g)] [epi f] :
  epi (image.pre_comp f g) :=
begin
  apply epi_of_epi_fac (image.factor_thru_image_pre_comp _ _),
  exact epi_comp _ _
end

instance has_image_iso_comp [is_iso f] [has_image g] : has_image (f ≫ g) :=
has_image.mk
{ F := (image.mono_factorisation g).iso_comp f,
  is_image := { lift := λ F', image.lift (F'.of_iso_comp f) }, }

/--
`image.pre_comp f g` is an isomorphism when `f` is an isomorphism
(we need `C` to have equalizers to prove this).
-/
instance image.is_iso_precomp_iso (f : X ⟶ Y) [is_iso f] [has_image g] :
  is_iso (image.pre_comp f g) :=
⟨⟨image.lift
  { I := image (f ≫ g),
    m := image.ι (f ≫ g),
    e := inv f ≫ factor_thru_image (f ≫ g) },
  ⟨by { ext, simp [image.pre_comp], }, by { ext, simp [image.pre_comp], }⟩⟩⟩

-- Note that in general we don't have the other comparison map you might expect
-- `image f ⟶ image (f ≫ g)`.

instance has_image_comp_iso [has_image f] [is_iso g] : has_image (f ≫ g) :=
has_image.mk
{ F := (image.mono_factorisation f).comp_mono g,
  is_image := { lift := λ F', image.lift F'.of_comp_iso }, }

/-- Postcomposing by an isomorphism induces an isomorphism on the image. -/
def image.comp_iso [has_image f] [is_iso g] :
  image f ≅ image (f ≫ g) :=
{ hom := image.lift (image.mono_factorisation (f ≫ g)).of_comp_iso,
  inv := image.lift ((image.mono_factorisation f).comp_mono g) }

@[simp, reassoc] lemma image.comp_iso_hom_comp_image_ι [has_image f] [is_iso g] :
  (image.comp_iso f g).hom ≫ image.ι (f ≫ g) = image.ι f ≫ g :=
by { ext, simp [image.comp_iso] }

@[simp, reassoc] lemma image.comp_iso_inv_comp_image_ι [has_image f] [is_iso g] :
  (image.comp_iso f g).inv ≫ image.ι f = image.ι (f ≫ g) ≫ inv g :=
by { ext, simp [image.comp_iso] }

end

end category_theory.limits

namespace category_theory.limits

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

section

instance {X Y : C} (f : X ⟶ Y) [has_image f] : has_image (arrow.mk f).hom :=
show has_image f, by apply_instance

end

section has_image_map

/-- An image map is a morphism `image f → image g` fitting into a commutative square and satisfying
    the obvious commutativity conditions. -/
structure image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g) :=
(map : image f.hom ⟶ image g.hom)
(map_ι' : map ≫ image.ι g.hom = image.ι f.hom ≫ sq.right . obviously)

instance inhabited_image_map {f : arrow C} [has_image f.hom] : inhabited (image_map (𝟙 f)) :=
⟨⟨𝟙 _, by tidy⟩⟩

restate_axiom image_map.map_ι'
attribute [simp, reassoc] image_map.map_ι

@[simp, reassoc]
lemma image_map.factor_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (m : image_map sq) :
  factor_thru_image f.hom ≫ m.map = sq.left ≫ factor_thru_image g.hom :=
(cancel_mono (image.ι g.hom)).1 $ by simp

/-- To give an image map for a commutative square with `f` at the top and `g` at the bottom, it
    suffices to give a map between any mono factorisation of `f` and any image factorisation of
    `g`. -/
def image_map.transport {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (F : mono_factorisation f.hom) {F' : mono_factorisation g.hom} (hF' : is_image F')
  {map : F.I ⟶ F'.I} (map_ι : map ≫ F'.m = F.m ≫ sq.right) : image_map sq :=
{ map := image.lift F ≫ map ≫ hF'.lift (image.mono_factorisation g.hom),
  map_ι' := by simp [map_ι] }

/-- `has_image_map sq` means that there is an `image_map` for the square `sq`. -/
class has_image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g) : Prop :=
mk' :: (has_image_map : nonempty (image_map sq))

lemma has_image_map.mk {f g : arrow C} [has_image f.hom] [has_image g.hom] {sq : f ⟶ g}
  (m : image_map sq) : has_image_map sq :=
⟨nonempty.intro m⟩

lemma has_image_map.transport {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (F : mono_factorisation f.hom) {F' : mono_factorisation g.hom} (hF' : is_image F')
  (map : F.I ⟶ F'.I) (map_ι : map ≫ F'.m = F.m ≫ sq.right) : has_image_map sq :=
has_image_map.mk $ image_map.transport sq F hF' map_ι

/-- Obtain an `image_map` from a `has_image_map` instance. -/
def has_image_map.image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  [has_image_map sq] : image_map sq :=
classical.choice $ @has_image_map.has_image_map _ _ _ _ _ _ sq _

@[priority 100] -- see Note [lower instance priority]
instance has_image_map_of_is_iso {f g : arrow C} [has_image f.hom] [has_image g.hom]
  (sq : f ⟶ g) [is_iso sq] :
  has_image_map sq :=
has_image_map.mk
{ map := image.lift ((image.mono_factorisation g.hom).of_arrow_iso (inv sq)),
  map_ι' := begin
    erw [← cancel_mono (inv sq).right, category.assoc, ← mono_factorisation.of_arrow_iso_m,
      image.lift_fac, category.assoc, ← comma.comp_right, is_iso.hom_inv_id,
      comma.id_right, category.comp_id],
  end }

instance has_image_map.comp {f g h : arrow C} [has_image f.hom] [has_image g.hom] [has_image h.hom]
  (sq1 : f ⟶ g) (sq2 : g ⟶ h) [has_image_map sq1] [has_image_map sq2] :
  has_image_map (sq1 ≫ sq2) :=
has_image_map.mk
{ map := (has_image_map.image_map sq1).map ≫ (has_image_map.image_map sq2).map,
  map_ι' :=
  by simp only [image_map.map_ι, image_map.map_ι_assoc, comma.comp_right, category.assoc] }

variables {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)

section
local attribute [ext] image_map

instance : subsingleton (image_map sq) :=
subsingleton.intro $ λ a b, image_map.ext a b $ (cancel_mono (image.ι g.hom)).1 $
  by simp only [image_map.map_ι]

end

variable [has_image_map sq]

/-- The map on images induced by a commutative square. -/
abbreviation image.map : image f.hom ⟶ image g.hom :=
(has_image_map.image_map sq).map

lemma image.factor_map :
  factor_thru_image f.hom ≫ image.map sq = sq.left ≫ factor_thru_image g.hom :=
by simp
lemma image.map_ι : image.map sq ≫ image.ι g.hom = image.ι f.hom ≫ sq.right :=
by simp
lemma image.map_hom_mk'_ι {X Y P Q : C} {k : X ⟶ Y} [has_image k] {l : P ⟶ Q} [has_image l]
  {m : X ⟶ P} {n : Y ⟶ Q} (w : m ≫ l = k ≫ n) [has_image_map (arrow.hom_mk' w)] :
  image.map (arrow.hom_mk' w) ≫ image.ι l = image.ι k ≫ n :=
image.map_ι _

section
variables {h : arrow C} [has_image h.hom] (sq' : g ⟶ h)
variables [has_image_map sq']

/-- Image maps for composable commutative squares induce an image map in the composite square. -/
def image_map_comp : image_map (sq ≫ sq') :=
{ map := image.map sq ≫ image.map sq' }

@[simp]
lemma image.map_comp [has_image_map (sq ≫ sq')] :
  image.map (sq ≫ sq') = image.map sq ≫ image.map sq' :=
show (has_image_map.image_map (sq ≫ sq')).map = (image_map_comp sq sq').map, by congr

end

section
variables (f)

/-- The identity `image f ⟶ image f` fits into the commutative square represented by the identity
    morphism `𝟙 f` in the arrow category. -/
def image_map_id : image_map (𝟙 f) :=
{ map := 𝟙 (image f.hom) }

@[simp]
lemma image.map_id [has_image_map (𝟙 f)] : image.map (𝟙 f) = 𝟙 (image f.hom) :=
show (has_image_map.image_map (𝟙 f)).map = (image_map_id f).map, by congr

end

end has_image_map

section
variables (C) [has_images C]

/-- If a category `has_image_maps`, then all commutative squares induce morphisms on images. -/
class has_image_maps :=
(has_image_map : Π {f g : arrow C} (st : f ⟶ g), has_image_map st)

attribute [instance, priority 100] has_image_maps.has_image_map

end

section has_image_maps
variables [has_images C] [has_image_maps C]

/-- The functor from the arrow category of `C` to `C` itself that maps a morphism to its image
    and a commutative square to the induced morphism on images. -/
@[simps]
def im : arrow C ⥤ C :=
{ obj := λ f, image f.hom,
  map := λ _ _ st, image.map st }

end has_image_maps

section strong_epi_mono_factorisation

/-- A strong epi-mono factorisation is a decomposition `f = e ≫ m` with `e` a strong epimorphism
    and `m` a monomorphism. -/
structure strong_epi_mono_factorisation {X Y : C} (f : X ⟶ Y) extends mono_factorisation f :=
[e_strong_epi : strong_epi e]

attribute [instance] strong_epi_mono_factorisation.e_strong_epi

/-- Satisfying the inhabited linter -/
instance strong_epi_mono_factorisation_inhabited {X Y : C} (f : X ⟶ Y) [strong_epi f] :
  inhabited (strong_epi_mono_factorisation f) :=
⟨⟨⟨Y, 𝟙 Y, f, by simp⟩⟩⟩

/-- A mono factorisation coming from a strong epi-mono factorisation always has the universal
    property of the image. -/
def strong_epi_mono_factorisation.to_mono_is_image {X Y : C} {f : X ⟶ Y}
  (F : strong_epi_mono_factorisation f) : is_image F.to_mono_factorisation :=
{ lift := λ G, (comm_sq.mk (show G.e ≫ G.m = F.e ≫ F.m,
    by rw [F.to_mono_factorisation.fac, G.fac])).lift, }

variable (C)

/-- A category has strong epi-mono factorisations if every morphism admits a strong epi-mono
    factorisation. -/
class has_strong_epi_mono_factorisations : Prop :=
mk' :: (has_fac : Π {X Y : C} (f : X ⟶ Y), nonempty (strong_epi_mono_factorisation f))

variable {C}

lemma has_strong_epi_mono_factorisations.mk
  (d : Π {X Y : C} (f : X ⟶ Y), strong_epi_mono_factorisation f) :
  has_strong_epi_mono_factorisations C :=
⟨λ X Y f, nonempty.intro $ d f⟩

@[priority 100]
instance has_images_of_has_strong_epi_mono_factorisations
  [has_strong_epi_mono_factorisations C] : has_images C :=
{ has_image := λ X Y f,
  let F' := classical.choice (has_strong_epi_mono_factorisations.has_fac f) in
  has_image.mk { F := F'.to_mono_factorisation,
                 is_image := F'.to_mono_is_image } }

end strong_epi_mono_factorisation

section has_strong_epi_images
variables (C) [has_images C]

/-- A category has strong epi images if it has all images and `factor_thru_image f` is a strong
    epimorphism for all `f`. -/
class has_strong_epi_images : Prop :=
(strong_factor_thru_image : Π {X Y : C} (f : X ⟶ Y), strong_epi (factor_thru_image f))

attribute [instance] has_strong_epi_images.strong_factor_thru_image
end has_strong_epi_images

section has_strong_epi_images

/-- If there is a single strong epi-mono factorisation of `f`, then every image factorisation is a
    strong epi-mono factorisation. -/
lemma strong_epi_of_strong_epi_mono_factorisation {X Y : C} {f : X ⟶ Y}
  (F : strong_epi_mono_factorisation f) {F' : mono_factorisation f} (hF' : is_image F') :
  strong_epi F'.e :=
by { rw ←is_image.e_iso_ext_hom F.to_mono_is_image hF', apply strong_epi_comp }

lemma strong_epi_factor_thru_image_of_strong_epi_mono_factorisation {X Y : C} {f : X ⟶ Y}
  [has_image f] (F : strong_epi_mono_factorisation f) : strong_epi (factor_thru_image f) :=
strong_epi_of_strong_epi_mono_factorisation F $ image.is_image f

/-- If we constructed our images from strong epi-mono factorisations, then these images are
    strong epi images. -/
@[priority 100]
instance has_strong_epi_images_of_has_strong_epi_mono_factorisations
  [has_strong_epi_mono_factorisations C] : has_strong_epi_images C :=
{ strong_factor_thru_image := λ X Y f,
    strong_epi_factor_thru_image_of_strong_epi_mono_factorisation $
      classical.choice $ has_strong_epi_mono_factorisations.has_fac f }

end has_strong_epi_images

section has_strong_epi_images
variables [has_images C]

/-- A category with strong epi images has image maps. -/
@[priority 100]
instance has_image_maps_of_has_strong_epi_images [has_strong_epi_images C] :
  has_image_maps C :=
{ has_image_map := λ f g st, has_image_map.mk
  { map := (comm_sq.mk (show (st.left ≫ factor_thru_image g.hom) ≫ image.ι g.hom =
      factor_thru_image f.hom ≫ (image.ι f.hom ≫ st.right), by simp)).lift, }, }

/-- If a category has images, equalizers and pullbacks, then images are automatically strong epi
    images. -/
@[priority 100]
instance has_strong_epi_images_of_has_pullbacks_of_has_equalizers [has_pullbacks C]
  [has_equalizers C] : has_strong_epi_images C :=
{ strong_factor_thru_image := λ X Y f, strong_epi.mk'
  (λ A B h h_mono x y sq, comm_sq.has_lift.mk'
    { l := image.lift
        { I := pullback h y,
          m := pullback.snd ≫ image.ι f,
          m_mono := by exactI mono_comp _ _,
          e := pullback.lift _ _ sq.w } ≫ pullback.fst,
      fac_left' := by simp only [image.fac_lift_assoc, pullback.lift_fst],
      fac_right' := by { ext, simp only [sq.w, category.assoc,
        image.fac_lift_assoc, pullback.lift_fst_assoc], }, }) }

end has_strong_epi_images

variables [has_strong_epi_mono_factorisations C]
variables {X Y : C} {f : X ⟶ Y}

/--
If `C` has strong epi mono factorisations, then the image is unique up to isomorphism, in that if
`f` factors as a strong epi followed by a mono, this factorisation is essentially the image
factorisation.
-/
def image.iso_strong_epi_mono {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f) [strong_epi e]
  [mono m] :
  I' ≅ image f :=
is_image.iso_ext {strong_epi_mono_factorisation . I := I', m := m, e := e}.to_mono_is_image $
  image.is_image f

@[simp]
lemma image.iso_strong_epi_mono_hom_comp_ι {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f)
  [strong_epi e] [mono m] :
  (image.iso_strong_epi_mono e m comm).hom ≫ image.ι f = m :=
is_image.lift_fac _ _

@[simp]
lemma image.iso_strong_epi_mono_inv_comp_mono {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f)
  [strong_epi e] [mono m] :
  (image.iso_strong_epi_mono e m comm).inv ≫ m = image.ι f :=
image.lift_fac _

end category_theory.limits

namespace category_theory.functor

open category_theory.limits

variables {C D : Type*} [category C] [category D]

lemma has_strong_epi_mono_factorisations_imp_of_is_equivalence (F : C ⥤ D) [is_equivalence F]
  [h : has_strong_epi_mono_factorisations C] :
  has_strong_epi_mono_factorisations D :=
⟨λ X Y f, begin
  let em : strong_epi_mono_factorisation (F.inv.map f) :=
    (has_strong_epi_mono_factorisations.has_fac (F.inv.map f)).some,
  haveI : mono (F.map em.m ≫ F.as_equivalence.counit_iso.hom.app Y) := mono_comp _ _,
  haveI : strong_epi (F.as_equivalence.counit_iso.inv.app X ≫ F.map em.e) := strong_epi_comp _ _,
  exact nonempty.intro
  { I := F.obj em.I,
    e := F.as_equivalence.counit_iso.inv.app X ≫ F.map em.e,
    m := F.map em.m ≫ F.as_equivalence.counit_iso.hom.app Y,
    fac' := by simpa only [category.assoc, ← F.map_comp_assoc, em.fac',
      is_equivalence.fun_inv_map, iso.inv_hom_id_app, iso.inv_hom_id_app_assoc]
        using category.comp_id _, },
end⟩

end category_theory.functor


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Markus Himmel
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.strong_epi

/-!
# Categorical images

We define the categorical image of `f` as a factorisation `f = e ≫ m` through a monomorphism `m`,
so that `m` factors through the `m'` in any other such factorisation.

## Main definitions

* A `mono_factorisation` is a factorisation `f = e ≫ m`, where `m` is a monomorphism
* `is_image F` means that a given mono factorisation `F` has the universal property of the image.
* `has_image f` means that there is some image factorization for the morphism `f : X ⟶ Y`.
  * In this case, `image f` is some image object (selected with choice), `image.ι f : image f ⟶ Y`
    is the monomorphism `m` of the factorisation and `factor_thru_image f : X ⟶ image f` is the
    morphism `e`.
* `has_images C` means that every morphism in `C` has an image.
* Let `f : X ⟶ Y` and `g : P ⟶ Q` be morphisms in `C`, which we will represent as objects of the
  arrow category `arrow C`. Then `sq : f ⟶ g` is a commutative square in `C`. If `f` and `g` have
  images, then `has_image_map sq` represents the fact that there is a morphism
  `i : image f ⟶ image g` making the diagram

  X ----→ image f ----→ Y
  |         |           |
  |         |           |
  ↓         ↓           ↓
  P ----→ image g ----→ Q

  commute, where the top row is the image factorisation of `f`, the bottom row is the image
  factorisation of `g`, and the outer rectangle is the commutative square `sq`.
* If a category `has_images`, then `has_image_maps` means that every commutative square admits an
  image map.
* If a category `has_images`, then `has_strong_epi_images` means that the morphism to the image is
  always a strong epimorphism.

## Main statements

* When `C` has equalizers, the morphism `e` appearing in an image factorisation is an epimorphism.
* When `C` has strong epi images, then these images admit image maps.

## Future work
* TODO: coimages, and abelian categories.
* TODO: connect this with existing working in the group theory and ring theory libraries.

-/

noncomputable theory

universes v u

open category_theory
open category_theory.limits.walking_parallel_pair

namespace category_theory.limits

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

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

/-- A factorisation of a morphism `f = e ≫ m`, with `m` monic. -/
structure mono_factorisation (f : X ⟶ Y) :=
(I : C)
(m : I ⟶ Y)
[m_mono : mono m]
(e : X ⟶ I)
(fac' : e ≫ m = f . obviously)

restate_axiom mono_factorisation.fac'
attribute [simp, reassoc] mono_factorisation.fac
attribute [instance] mono_factorisation.m_mono

attribute [instance] mono_factorisation.m_mono

namespace mono_factorisation

/-- The obvious factorisation of a monomorphism through itself. -/
def self [mono f] : mono_factorisation f :=
{ I := X,
  m := f,
  e := 𝟙 X }

-- I'm not sure we really need this, but the linter says that an inhabited instance
-- ought to exist...
instance [mono f] : inhabited (mono_factorisation f) := ⟨self f⟩

variables {f}

/-- The morphism `m` in a factorisation `f = e ≫ m` through a monomorphism is uniquely
determined. -/
@[ext]
lemma ext
  {F F' : mono_factorisation f} (hI : F.I = F'.I) (hm : F.m = (eq_to_hom hI) ≫ F'.m) : F = F' :=
begin
  cases F, cases F',
  cases hI,
  simp at hm,
  dsimp at F_fac' F'_fac',
  congr,
  { assumption },
  { resetI, apply (cancel_mono F_m).1,
    rw [F_fac', hm, F'_fac'], }
end

/-- Any mono factorisation of `f` gives a mono factorisation of `f ≫ g` when `g` is a mono. -/
@[simps]
def comp_mono (F : mono_factorisation f) {Y' : C} (g : Y ⟶ Y') [mono g] :
  mono_factorisation (f ≫ g) :=
{ I := F.I,
  m := F.m ≫ g,
  m_mono := mono_comp _ _,
  e := F.e, }

/-- A mono factorisation of `f ≫ g`, where `g` is an isomorphism,
gives a mono factorisation of `f`. -/
@[simps]
def of_comp_iso {Y' : C} {g : Y ⟶ Y'} [is_iso g] (F : mono_factorisation (f ≫ g)) :
  mono_factorisation f :=
{ I := F.I,
  m := F.m ≫ (inv g),
  m_mono := mono_comp _ _,
  e := F.e, }

/-- Any mono factorisation of `f` gives a mono factorisation of `g ≫ f`. -/
@[simps]
def iso_comp (F : mono_factorisation f) {X' : C} (g : X' ⟶ X) :
  mono_factorisation (g ≫ f) :=
{ I := F.I,
  m := F.m,
  e := g ≫ F.e, }

/-- A mono factorisation of `g ≫ f`, where `g` is an isomorphism,
gives a mono factorisation of `f`. -/
@[simps]
def of_iso_comp {X' : C} (g : X' ⟶ X) [is_iso g] (F : mono_factorisation (g ≫ f)) :
  mono_factorisation f :=
{ I := F.I,
  m := F.m,
  e := inv g ≫ F.e, }

/-- If `f` and `g` are isomorphic arrows, then a mono factorisation of `f`
gives a mono factorisation of `g` -/
@[simps]
def of_arrow_iso {f g : arrow C} (F : mono_factorisation f.hom) (sq : f ⟶ g) [is_iso sq] :
  mono_factorisation g.hom :=
{ I := F.I,
  m := F.m ≫ sq.right,
  e := inv sq.left ≫ F.e,
  m_mono := mono_comp _ _,
  fac' := by simp only [fac_assoc, arrow.w, is_iso.inv_comp_eq, category.assoc] }

end mono_factorisation

variable {f}

/-- Data exhibiting that a given factorisation through a mono is initial. -/
structure is_image (F : mono_factorisation f) :=
(lift : Π (F' : mono_factorisation f), F.I ⟶ F'.I)
(lift_fac' : Π (F' : mono_factorisation f), lift F' ≫ F'.m = F.m . obviously)

restate_axiom is_image.lift_fac'
attribute [simp, reassoc] is_image.lift_fac

namespace is_image

@[simp, reassoc] lemma fac_lift {F : mono_factorisation f} (hF : is_image F)
  (F' : mono_factorisation f) : F.e ≫ hF.lift F' = F'.e :=
(cancel_mono F'.m).1 $ by simp

variable (f)

/-- The trivial factorisation of a monomorphism satisfies the universal property. -/
@[simps]
def self [mono f] : is_image (mono_factorisation.self f) :=
{ lift := λ F', F'.e }

instance [mono f] : inhabited (is_image (mono_factorisation.self f)) :=
⟨self f⟩

variable {f}

/-- Two factorisations through monomorphisms satisfying the universal property
must factor through isomorphic objects. -/
-- TODO this is another good candidate for a future `unique_up_to_canonical_iso`.
@[simps]
def iso_ext {F F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F') : F.I ≅ F'.I :=
{ hom := hF.lift F',
  inv := hF'.lift F,
  hom_inv_id' := (cancel_mono F.m).1 (by simp),
  inv_hom_id' := (cancel_mono F'.m).1 (by simp) }

variables {F F' : mono_factorisation f} (hF : is_image F) (hF' : is_image F')

lemma iso_ext_hom_m : (iso_ext hF hF').hom ≫ F'.m = F.m := by simp
lemma iso_ext_inv_m : (iso_ext hF hF').inv ≫ F.m = F'.m := by simp
lemma e_iso_ext_hom : F.e ≫ (iso_ext hF hF').hom = F'.e := by simp
lemma e_iso_ext_inv : F'.e ≫ (iso_ext hF hF').inv = F.e := by simp

/-- If `f` and `g` are isomorphic arrows, then a mono factorisation of `f` that is an image
gives a mono factorisation of `g` that is an image -/
@[simps]
def of_arrow_iso {f g : arrow C} {F : mono_factorisation f.hom} (hF : is_image F)
  (sq : f ⟶ g) [is_iso sq] :
  is_image (F.of_arrow_iso sq) :=
{ lift := λ F', hF.lift (F'.of_arrow_iso (inv sq)),
  lift_fac' := λ F', by simpa only [mono_factorisation.of_arrow_iso_m, arrow.inv_right,
    ← category.assoc, is_iso.comp_inv_eq] using hF.lift_fac (F'.of_arrow_iso (inv sq)) }

end is_image

variable (f)

/-- Data exhibiting that a morphism `f` has an image. -/
structure image_factorisation (f : X ⟶ Y) :=
(F : mono_factorisation f)
(is_image : is_image F)

namespace image_factorisation

instance [mono f] : inhabited (image_factorisation f) :=
⟨⟨_, is_image.self f⟩⟩

/-- If `f` and `g` are isomorphic arrows, then an image factorisation of `f`
gives an image factorisation of `g` -/
@[simps]
def of_arrow_iso {f g : arrow C} (F : image_factorisation f.hom) (sq : f ⟶ g) [is_iso sq] :
  image_factorisation g.hom :=
{ F := F.F.of_arrow_iso sq,
  is_image := F.is_image.of_arrow_iso sq }

end image_factorisation

/-- `has_image f` means that there exists an image factorisation of `f`. -/
class has_image (f : X ⟶ Y) : Prop :=
mk' :: (exists_image : nonempty (image_factorisation f))

lemma has_image.mk {f : X ⟶ Y} (F : image_factorisation f) : has_image f :=
⟨nonempty.intro F⟩

lemma has_image.of_arrow_iso {f g : arrow C} [h : has_image f.hom] (sq : f ⟶ g) [is_iso sq] :
  has_image g.hom :=
⟨⟨h.exists_image.some.of_arrow_iso sq⟩⟩

section
variable [has_image f]

/-- Some factorisation of `f` through a monomorphism (selected with choice). -/
def image.mono_factorisation : mono_factorisation f :=
(classical.choice (has_image.exists_image)).F

/-- The witness of the universal property for the chosen factorisation of `f` through
a monomorphism. -/
def image.is_image : is_image (image.mono_factorisation f) :=
(classical.choice (has_image.exists_image)).is_image

/-- The categorical image of a morphism. -/
def image : C := (image.mono_factorisation f).I
/-- The inclusion of the image of a morphism into the target. -/
def image.ι : image f ⟶ Y := (image.mono_factorisation f).m
@[simp] lemma image.as_ι : (image.mono_factorisation f).m = image.ι f := rfl
instance : mono (image.ι f) := (image.mono_factorisation f).m_mono

/-- The map from the source to the image of a morphism. -/
def factor_thru_image : X ⟶ image f := (image.mono_factorisation f).e
/-- Rewrite in terms of the `factor_thru_image` interface. -/
@[simp]
lemma as_factor_thru_image : (image.mono_factorisation f).e = factor_thru_image f := rfl
@[simp, reassoc]
lemma image.fac : factor_thru_image f ≫ image.ι f = f := (image.mono_factorisation f).fac'

variable {f}

/-- Any other factorisation of the morphism `f` through a monomorphism receives a map from the
image. -/
def image.lift (F' : mono_factorisation f) : image f ⟶ F'.I := (image.is_image f).lift F'
@[simp, reassoc]
lemma image.lift_fac (F' : mono_factorisation f) : image.lift F' ≫ F'.m = image.ι f :=
(image.is_image f).lift_fac' F'
@[simp, reassoc]
lemma image.fac_lift (F' : mono_factorisation f) : factor_thru_image f ≫ image.lift F' = F'.e :=
(image.is_image f).fac_lift F'

@[simp, reassoc]
lemma is_image.lift_ι {F : mono_factorisation f} (hF : is_image F) :
  hF.lift (image.mono_factorisation f) ≫ image.ι f = F.m :=
hF.lift_fac _

-- TODO we could put a category structure on `mono_factorisation f`,
-- with the morphisms being `g : I ⟶ I'` commuting with the `m`s
-- (they then automatically commute with the `e`s)
-- and show that an `image_of f` gives an initial object there
-- (uniqueness of the lift comes for free).

instance image.lift_mono (F' : mono_factorisation f) : mono (image.lift F') :=
by { apply mono_of_mono _ F'.m, simpa using mono_factorisation.m_mono _ }

lemma has_image.uniq
  (F' : mono_factorisation f) (l : image f ⟶ F'.I) (w : l ≫ F'.m = image.ι f) :
  l = image.lift F' :=
(cancel_mono F'.m).1 (by simp [w])

/-- If `has_image g`, then `has_image (f ≫ g)` when `f` is an isomorphism. -/
instance {X Y Z : C} (f : X ⟶ Y) [is_iso f] (g : Y ⟶ Z) [has_image g] : has_image (f ≫ g) :=
{ exists_image := ⟨
{ F :=
  { I := image g,
    m := image.ι g,
    e := f ≫ factor_thru_image g, },
  is_image := { lift := λ F', image.lift { I := F'.I, m := F'.m, e := inv f ≫ F'.e, }, }, }⟩ }

end

section
variables (C)

/-- `has_images` asserts that every morphism has an image. -/
class has_images : Prop :=
(has_image : Π {X Y : C} (f : X ⟶ Y), has_image f)

attribute [instance, priority 100] has_images.has_image
end

section
variables (f) [has_image f]
/-- The image of a monomorphism is isomorphic to the source. -/
def image_mono_iso_source [mono f] : image f ≅ X :=
is_image.iso_ext (image.is_image f) (is_image.self f)

@[simp, reassoc]
lemma image_mono_iso_source_inv_ι [mono f] : (image_mono_iso_source f).inv ≫ image.ι f = f :=
by simp [image_mono_iso_source]
@[simp, reassoc]
lemma image_mono_iso_source_hom_self [mono f] : (image_mono_iso_source f).hom ≫ f = image.ι f :=
begin
  conv { to_lhs, congr, skip, rw ←image_mono_iso_source_inv_ι f, },
  rw [←category.assoc, iso.hom_inv_id, category.id_comp],
end

-- This is the proof that `factor_thru_image f` is an epimorphism
-- from https://en.wikipedia.org/wiki/Image_%28category_theory%29, which is in turn taken from:
-- Mitchell, Barry (1965), Theory of categories, MR 0202787, p.12, Proposition 10.1
@[ext]
lemma image.ext {W : C} {g h : image f ⟶ W} [has_limit (parallel_pair g h)]
  (w : factor_thru_image f ≫ g = factor_thru_image f ≫ h) :
  g = h :=
begin
  let q := equalizer.ι g h,
  let e' := equalizer.lift _ w,
  let F' : mono_factorisation f :=
  { I := equalizer g h,
    m := q ≫ image.ι f,
    m_mono := by apply mono_comp,
    e := e' },
  let v := image.lift F',
  have t₀ : v ≫ q ≫ image.ι f = image.ι f := image.lift_fac F',
  have t : v ≫ q = 𝟙 (image f) :=
    (cancel_mono_id (image.ι f)).1 (by { convert t₀ using 1, rw category.assoc }),
  -- The proof from wikipedia next proves `q ≫ v = 𝟙 _`,
  -- and concludes that `equalizer g h ≅ image f`,
  -- but this isn't necessary.
  calc g = 𝟙 (image f) ≫ g : by rw [category.id_comp]
     ... = v ≫ q ≫ g       : by rw [←t, category.assoc]
     ... = v ≫ q ≫ h       : by rw [equalizer.condition g h]
     ... = 𝟙 (image f) ≫ h : by rw [←category.assoc, t]
     ... = h                : by rw [category.id_comp]
end

instance [Π {Z : C} (g h : image f ⟶ Z), has_limit (parallel_pair g h)] :
  epi (factor_thru_image f) :=
⟨λ Z g h w, image.ext f w⟩

lemma epi_image_of_epi {X Y : C} (f : X ⟶ Y) [has_image f] [E : epi f] : epi (image.ι f) :=
begin
  rw ←image.fac f at E,
  resetI,
  exact epi_of_epi (factor_thru_image f) (image.ι f),
end

lemma epi_of_epi_image {X Y : C} (f : X ⟶ Y) [has_image f]
  [epi (image.ι f)] [epi (factor_thru_image f)] : epi f :=
by { rw [←image.fac f], apply epi_comp, }

end

section
variables {f} {f' : X ⟶ Y} [has_image f] [has_image f']

/--
An equation between morphisms gives a comparison map between the images
(which momentarily we prove is an iso).
-/
def image.eq_to_hom (h : f = f') : image f ⟶ image f' :=
image.lift
{ I := image f',
  m := image.ι f',
  e := factor_thru_image f', }.

instance (h : f = f') : is_iso (image.eq_to_hom h) :=
⟨⟨image.eq_to_hom h.symm,
  ⟨(cancel_mono (image.ι f)).1 (by simp [image.eq_to_hom]),
   (cancel_mono (image.ι f')).1 (by simp [image.eq_to_hom])⟩⟩⟩

/-- An equation between morphisms gives an isomorphism between the images. -/
def image.eq_to_iso (h : f = f') : image f ≅ image f' := as_iso (image.eq_to_hom h)

/--
As long as the category has equalizers,
the image inclusion maps commute with `image.eq_to_iso`.
-/
lemma image.eq_fac [has_equalizers C] (h : f = f') :
  image.ι f = (image.eq_to_iso h).hom ≫ image.ι f' :=
by { ext, simp [image.eq_to_iso, image.eq_to_hom], }

end

section
variables {Z : C} (g : Y ⟶ Z)

/-- The comparison map `image (f ≫ g) ⟶ image g`. -/
def image.pre_comp [has_image g] [has_image (f ≫ g)] : image (f ≫ g) ⟶ image g :=
image.lift
{ I := image g,
  m := image.ι g,
  e := f ≫ factor_thru_image g }

@[simp, reassoc]
lemma image.pre_comp_ι [has_image g] [has_image (f ≫ g)] :
  image.pre_comp f g ≫ image.ι g = image.ι (f ≫ g) :=
by simp [image.pre_comp]

@[simp, reassoc]
lemma image.factor_thru_image_pre_comp [has_image g] [has_image (f ≫ g)] :
  factor_thru_image (f ≫ g) ≫ image.pre_comp f g = f ≫ factor_thru_image g :=
by simp [image.pre_comp]

/--
`image.pre_comp f g` is a monomorphism.
-/
instance image.pre_comp_mono [has_image g] [has_image (f ≫ g)] : mono (image.pre_comp f g) :=
begin
  apply mono_of_mono _ (image.ι g),
  simp only [image.pre_comp_ι],
  apply_instance,
end

/--
The two step comparison map
  `image (f ≫ (g ≫ h)) ⟶ image (g ≫ h) ⟶ image h`
agrees with the one step comparison map
  `image (f ≫ (g ≫ h)) ≅ image ((f ≫ g) ≫ h) ⟶ image h`.
 -/
lemma image.pre_comp_comp {W : C} (h : Z ⟶ W)
  [has_image (g ≫ h)] [has_image (f ≫ g ≫ h)]
  [has_image h] [has_image ((f ≫ g) ≫ h)] :
  image.pre_comp f (g ≫ h) ≫ image.pre_comp g h =
    image.eq_to_hom (category.assoc f g h).symm ≫ (image.pre_comp (f ≫ g) h) :=
begin
  apply (cancel_mono (image.ι h)).1,
  simp [image.pre_comp, image.eq_to_hom],
end

variables [has_equalizers C]

/--
`image.pre_comp f g` is an epimorphism when `f` is an epimorphism
(we need `C` to have equalizers to prove this).
-/
instance image.pre_comp_epi_of_epi [has_image g] [has_image (f ≫ g)] [epi f] :
  epi (image.pre_comp f g) :=
begin
  apply epi_of_epi_fac (image.factor_thru_image_pre_comp _ _),
  exact epi_comp _ _
end

instance has_image_iso_comp [is_iso f] [has_image g] : has_image (f ≫ g) :=
has_image.mk
{ F := (image.mono_factorisation g).iso_comp f,
  is_image := { lift := λ F', image.lift (F'.of_iso_comp f) }, }

/--
`image.pre_comp f g` is an isomorphism when `f` is an isomorphism
(we need `C` to have equalizers to prove this).
-/
instance image.is_iso_precomp_iso (f : X ⟶ Y) [is_iso f] [has_image g] :
  is_iso (image.pre_comp f g) :=
⟨⟨image.lift
  { I := image (f ≫ g),
    m := image.ι (f ≫ g),
    e := inv f ≫ factor_thru_image (f ≫ g) },
  ⟨by { ext, simp [image.pre_comp], }, by { ext, simp [image.pre_comp], }⟩⟩⟩

-- Note that in general we don't have the other comparison map you might expect
-- `image f ⟶ image (f ≫ g)`.

instance has_image_comp_iso [has_image f] [is_iso g] : has_image (f ≫ g) :=
has_image.mk
{ F := (image.mono_factorisation f).comp_mono g,
  is_image := { lift := λ F', image.lift F'.of_comp_iso }, }

/-- Postcomposing by an isomorphism induces an isomorphism on the image. -/
def image.comp_iso [has_image f] [is_iso g] :
  image f ≅ image (f ≫ g) :=
{ hom := image.lift (image.mono_factorisation (f ≫ g)).of_comp_iso,
  inv := image.lift ((image.mono_factorisation f).comp_mono g) }

@[simp, reassoc] lemma image.comp_iso_hom_comp_image_ι [has_image f] [is_iso g] :
  (image.comp_iso f g).hom ≫ image.ι (f ≫ g) = image.ι f ≫ g :=
by { ext, simp [image.comp_iso] }

@[simp, reassoc] lemma image.comp_iso_inv_comp_image_ι [has_image f] [is_iso g] :
  (image.comp_iso f g).inv ≫ image.ι f = image.ι (f ≫ g) ≫ inv g :=
by { ext, simp [image.comp_iso] }

end

end category_theory.limits

namespace category_theory.limits

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

section

instance {X Y : C} (f : X ⟶ Y) [has_image f] : has_image (arrow.mk f).hom :=
show has_image f, by apply_instance

end

section has_image_map

/-- An image map is a morphism `image f → image g` fitting into a commutative square and satisfying
    the obvious commutativity conditions. -/
structure image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g) :=
(map : image f.hom ⟶ image g.hom)
(map_ι' : map ≫ image.ι g.hom = image.ι f.hom ≫ sq.right . obviously)

instance inhabited_image_map {f : arrow C} [has_image f.hom] : inhabited (image_map (𝟙 f)) :=
⟨⟨𝟙 _, by tidy⟩⟩

restate_axiom image_map.map_ι'
attribute [simp, reassoc] image_map.map_ι

@[simp, reassoc]
lemma image_map.factor_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (m : image_map sq) :
  factor_thru_image f.hom ≫ m.map = sq.left ≫ factor_thru_image g.hom :=
(cancel_mono (image.ι g.hom)).1 $ by simp

/-- To give an image map for a commutative square with `f` at the top and `g` at the bottom, it
    suffices to give a map between any mono factorisation of `f` and any image factorisation of
    `g`. -/
def image_map.transport {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (F : mono_factorisation f.hom) {F' : mono_factorisation g.hom} (hF' : is_image F')
  {map : F.I ⟶ F'.I} (map_ι : map ≫ F'.m = F.m ≫ sq.right) : image_map sq :=
{ map := image.lift F ≫ map ≫ hF'.lift (image.mono_factorisation g.hom),
  map_ι' := by simp [map_ι] }

/-- `has_image_map sq` means that there is an `image_map` for the square `sq`. -/
class has_image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g) : Prop :=
mk' :: (has_image_map : nonempty (image_map sq))

lemma has_image_map.mk {f g : arrow C} [has_image f.hom] [has_image g.hom] {sq : f ⟶ g}
  (m : image_map sq) : has_image_map sq :=
⟨nonempty.intro m⟩

lemma has_image_map.transport {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  (F : mono_factorisation f.hom) {F' : mono_factorisation g.hom} (hF' : is_image F')
  (map : F.I ⟶ F'.I) (map_ι : map ≫ F'.m = F.m ≫ sq.right) : has_image_map sq :=
has_image_map.mk $ image_map.transport sq F hF' map_ι

/-- Obtain an `image_map` from a `has_image_map` instance. -/
def has_image_map.image_map {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)
  [has_image_map sq] : image_map sq :=
classical.choice $ @has_image_map.has_image_map _ _ _ _ _ _ sq _

@[priority 100] -- see Note [lower instance priority]
instance has_image_map_of_is_iso {f g : arrow C} [has_image f.hom] [has_image g.hom]
  (sq : f ⟶ g) [is_iso sq] :
  has_image_map sq :=
has_image_map.mk
{ map := image.lift ((image.mono_factorisation g.hom).of_arrow_iso (inv sq)),
  map_ι' := begin
    erw [← cancel_mono (inv sq).right, category.assoc, ← mono_factorisation.of_arrow_iso_m,
      image.lift_fac, category.assoc, ← comma.comp_right, is_iso.hom_inv_id,
      comma.id_right, category.comp_id],
  end }

instance has_image_map.comp {f g h : arrow C} [has_image f.hom] [has_image g.hom] [has_image h.hom]
  (sq1 : f ⟶ g) (sq2 : g ⟶ h) [has_image_map sq1] [has_image_map sq2] :
  has_image_map (sq1 ≫ sq2) :=
has_image_map.mk
{ map := (has_image_map.image_map sq1).map ≫ (has_image_map.image_map sq2).map,
  map_ι' :=
  by simp only [image_map.map_ι, image_map.map_ι_assoc, comma.comp_right, category.assoc] }

variables {f g : arrow C} [has_image f.hom] [has_image g.hom] (sq : f ⟶ g)

section
local attribute [ext] image_map

instance : subsingleton (image_map sq) :=
subsingleton.intro $ λ a b, image_map.ext a b $ (cancel_mono (image.ι g.hom)).1 $
  by simp only [image_map.map_ι]

end

variable [has_image_map sq]

/-- The map on images induced by a commutative square. -/
abbreviation image.map : image f.hom ⟶ image g.hom :=
(has_image_map.image_map sq).map

lemma image.factor_map :
  factor_thru_image f.hom ≫ image.map sq = sq.left ≫ factor_thru_image g.hom :=
by simp
lemma image.map_ι : image.map sq ≫ image.ι g.hom = image.ι f.hom ≫ sq.right :=
by simp
lemma image.map_hom_mk'_ι {X Y P Q : C} {k : X ⟶ Y} [has_image k] {l : P ⟶ Q} [has_image l]
  {m : X ⟶ P} {n : Y ⟶ Q} (w : m ≫ l = k ≫ n) [has_image_map (arrow.hom_mk' w)] :
  image.map (arrow.hom_mk' w) ≫ image.ι l = image.ι k ≫ n :=
image.map_ι _

section
variables {h : arrow C} [has_image h.hom] (sq' : g ⟶ h)
variables [has_image_map sq']

/-- Image maps for composable commutative squares induce an image map in the composite square. -/
def image_map_comp : image_map (sq ≫ sq') :=
{ map := image.map sq ≫ image.map sq' }

@[simp]
lemma image.map_comp [has_image_map (sq ≫ sq')] :
  image.map (sq ≫ sq') = image.map sq ≫ image.map sq' :=
show (has_image_map.image_map (sq ≫ sq')).map = (image_map_comp sq sq').map, by congr

end

section
variables (f)

/-- The identity `image f ⟶ image f` fits into the commutative square represented by the identity
    morphism `𝟙 f` in the arrow category. -/
def image_map_id : image_map (𝟙 f) :=
{ map := 𝟙 (image f.hom) }

@[simp]
lemma image.map_id [has_image_map (𝟙 f)] : image.map (𝟙 f) = 𝟙 (image f.hom) :=
show (has_image_map.image_map (𝟙 f)).map = (image_map_id f).map, by congr

end

end has_image_map

section
variables (C) [has_images C]

/-- If a category `has_image_maps`, then all commutative squares induce morphisms on images. -/
class has_image_maps :=
(has_image_map : Π {f g : arrow C} (st : f ⟶ g), has_image_map st)

attribute [instance, priority 100] has_image_maps.has_image_map

end

section has_image_maps
variables [has_images C] [has_image_maps C]

/-- The functor from the arrow category of `C` to `C` itself that maps a morphism to its image
    and a commutative square to the induced morphism on images. -/
@[simps]
def im : arrow C ⥤ C :=
{ obj := λ f, image f.hom,
  map := λ _ _ st, image.map st }

end has_image_maps

section strong_epi_mono_factorisation

/-- A strong epi-mono factorisation is a decomposition `f = e ≫ m` with `e` a strong epimorphism
    and `m` a monomorphism. -/
structure strong_epi_mono_factorisation {X Y : C} (f : X ⟶ Y) extends mono_factorisation f :=
[e_strong_epi : strong_epi e]

attribute [instance] strong_epi_mono_factorisation.e_strong_epi

/-- Satisfying the inhabited linter -/
instance strong_epi_mono_factorisation_inhabited {X Y : C} (f : X ⟶ Y) [strong_epi f] :
  inhabited (strong_epi_mono_factorisation f) :=
⟨⟨⟨Y, 𝟙 Y, f, by simp⟩⟩⟩

/-- A mono factorisation coming from a strong epi-mono factorisation always has the universal
    property of the image. -/
def strong_epi_mono_factorisation.to_mono_is_image {X Y : C} {f : X ⟶ Y}
  (F : strong_epi_mono_factorisation f) : is_image F.to_mono_factorisation :=
{ lift := λ G, arrow.lift $ arrow.hom_mk' $
    show G.e ≫ G.m = F.e ≫ F.m, by rw [F.to_mono_factorisation.fac, G.fac] }

variable (C)

/-- A category has strong epi-mono factorisations if every morphism admits a strong epi-mono
    factorisation. -/
class has_strong_epi_mono_factorisations : Prop :=
mk' :: (has_fac : Π {X Y : C} (f : X ⟶ Y), nonempty (strong_epi_mono_factorisation f))

variable {C}

lemma has_strong_epi_mono_factorisations.mk
  (d : Π {X Y : C} (f : X ⟶ Y), strong_epi_mono_factorisation f) :
  has_strong_epi_mono_factorisations C :=
⟨λ X Y f, nonempty.intro $ d f⟩

@[priority 100]
instance has_images_of_has_strong_epi_mono_factorisations
  [has_strong_epi_mono_factorisations C] : has_images C :=
{ has_image := λ X Y f,
  let F' := classical.choice (has_strong_epi_mono_factorisations.has_fac f) in
  has_image.mk { F := F'.to_mono_factorisation,
                 is_image := F'.to_mono_is_image } }

end strong_epi_mono_factorisation

section has_strong_epi_images
variables (C) [has_images C]

/-- A category has strong epi images if it has all images and `factor_thru_image f` is a strong
    epimorphism for all `f`. -/
class has_strong_epi_images : Prop :=
(strong_factor_thru_image : Π {X Y : C} (f : X ⟶ Y), strong_epi (factor_thru_image f))

attribute [instance] has_strong_epi_images.strong_factor_thru_image
end has_strong_epi_images

section has_strong_epi_images

/-- If there is a single strong epi-mono factorisation of `f`, then every image factorisation is a
    strong epi-mono factorisation. -/
lemma strong_epi_of_strong_epi_mono_factorisation {X Y : C} {f : X ⟶ Y}
  (F : strong_epi_mono_factorisation f) {F' : mono_factorisation f} (hF' : is_image F') :
  strong_epi F'.e :=
by { rw ←is_image.e_iso_ext_hom F.to_mono_is_image hF', apply strong_epi_comp }

lemma strong_epi_factor_thru_image_of_strong_epi_mono_factorisation {X Y : C} {f : X ⟶ Y}
  [has_image f] (F : strong_epi_mono_factorisation f) : strong_epi (factor_thru_image f) :=
strong_epi_of_strong_epi_mono_factorisation F $ image.is_image f

/-- If we constructed our images from strong epi-mono factorisations, then these images are
    strong epi images. -/
@[priority 100]
instance has_strong_epi_images_of_has_strong_epi_mono_factorisations
  [has_strong_epi_mono_factorisations C] : has_strong_epi_images C :=
{ strong_factor_thru_image := λ X Y f,
    strong_epi_factor_thru_image_of_strong_epi_mono_factorisation $
      classical.choice $ has_strong_epi_mono_factorisations.has_fac f }

end has_strong_epi_images

section has_strong_epi_images
variables [has_images C]

/-- A category with strong epi images has image maps. -/
@[priority 100]
instance has_image_maps_of_has_strong_epi_images [has_strong_epi_images C] :
  has_image_maps C :=
{ has_image_map := λ f g st, has_image_map.mk
  { map := arrow.lift $ arrow.hom_mk' $ show (st.left ≫ factor_thru_image g.hom) ≫ image.ι g.hom =
      factor_thru_image f.hom ≫ (image.ι f.hom ≫ st.right), by simp } }

/-- If a category has images, equalizers and pullbacks, then images are automatically strong epi
    images. -/
@[priority 100]
instance has_strong_epi_images_of_has_pullbacks_of_has_equalizers [has_pullbacks C]
  [has_equalizers C] : has_strong_epi_images C :=
{ strong_factor_thru_image := λ X Y f,
  { epi := by apply_instance,
    has_lift := λ A B x y h h_mono w, arrow.has_lift.mk
    { lift := image.lift
      { I := pullback h y,
        m := pullback.snd ≫ image.ι f,
        m_mono := by exactI mono_comp _ _,
        e := pullback.lift _ _ w } ≫ pullback.fst } } }

end has_strong_epi_images

variables [has_strong_epi_mono_factorisations.{v} C]
variables {X Y : C} {f : X ⟶ Y}

/--
If `C` has strong epi mono factorisations, then the image is unique up to isomorphism, in that if
`f` factors as a strong epi followed by a mono, this factorisation is essentially the image
factorisation.
-/
def image.iso_strong_epi_mono {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f) [strong_epi e]
  [mono m] :
  I' ≅ image f :=
is_image.iso_ext {strong_epi_mono_factorisation . I := I', m := m, e := e}.to_mono_is_image $
  image.is_image f

@[simp]
lemma image.iso_strong_epi_mono_hom_comp_ι {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f)
  [strong_epi e] [mono m] :
  (image.iso_strong_epi_mono e m comm).hom ≫ image.ι f = m :=
is_image.lift_fac _ _

@[simp]
lemma image.iso_strong_epi_mono_inv_comp_mono {I' : C} (e : X ⟶ I') (m : I' ⟶ Y) (comm : e ≫ m = f)
  [strong_epi e] [mono m] :
  (image.iso_strong_epi_mono e m comm).inv ≫ m = image.ι f :=
image.lift_fac _

end category_theory.limits