/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura

Various multiplicative and additive structures.
-/
import tactic.interactive data.option

section pending_1857

/- Transport multiplicative to additive -/
section transport
open tactic

@[user_attribute]
meta def to_additive_attr : user_attribute (name_map name) name :=
{ name      := `to_additive,
  descr     := "Transport multiplicative to additive",
  cache_cfg := ⟨λ ns, ns.mfoldl (λ dict n, do
    val ← to_additive_attr.get_param n,
    pure $ dict.insert n val) mk_name_map, []⟩,
  parser    := lean.parser.ident,
  after_set := some $ λ src _ _, do
    env ← get_env,
    dict ← to_additive_attr.get_cache,
    tgt ← to_additive_attr.get_param src,
    (get_decl tgt >> skip) <|>
      transport_with_dict dict src tgt }

end transport

/- map operations -/
attribute [to_additive has_add.add] has_mul.mul
attribute [to_additive has_zero.zero] has_one.one
attribute [to_additive has_neg.neg] has_inv.inv
attribute [to_additive has_add] has_mul
attribute [to_additive has_zero] has_one
attribute [to_additive has_neg] has_inv

/- map constructors -/
attribute [to_additive has_add.mk] has_mul.mk
attribute [to_additive has_zero.mk] has_one.mk
attribute [to_additive has_neg.mk] has_inv.mk

/- map structures -/
attribute [to_additive add_semigroup] semigroup
attribute [to_additive add_semigroup.mk] semigroup.mk
attribute [to_additive add_semigroup.to_has_add] semigroup.to_has_mul
attribute [to_additive add_semigroup.add_assoc] semigroup.mul_assoc
attribute [to_additive add_semigroup.add] semigroup.mul

attribute [to_additive add_comm_semigroup] comm_semigroup
attribute [to_additive add_comm_semigroup.mk] comm_semigroup.mk
attribute [to_additive add_comm_semigroup.to_add_semigroup] comm_semigroup.to_semigroup
attribute [to_additive add_comm_semigroup.add_comm] comm_semigroup.mul_comm

attribute [to_additive add_left_cancel_semigroup] left_cancel_semigroup
attribute [to_additive add_left_cancel_semigroup.mk] left_cancel_semigroup.mk
attribute [to_additive add_left_cancel_semigroup.to_add_semigroup] left_cancel_semigroup.to_semigroup
attribute [to_additive add_left_cancel_semigroup.add_left_cancel] left_cancel_semigroup.mul_left_cancel

attribute [to_additive add_right_cancel_semigroup] right_cancel_semigroup
attribute [to_additive add_right_cancel_semigroup.mk] right_cancel_semigroup.mk
attribute [to_additive add_right_cancel_semigroup.to_add_semigroup] right_cancel_semigroup.to_semigroup
attribute [to_additive add_right_cancel_semigroup.add_right_cancel] right_cancel_semigroup.mul_right_cancel

attribute [to_additive add_monoid] monoid
attribute [to_additive add_monoid.mk] monoid.mk
attribute [to_additive add_monoid.to_has_zero] monoid.to_has_one
attribute [to_additive add_monoid.to_add_semigroup] monoid.to_semigroup
attribute [to_additive add_monoid.add] monoid.mul
attribute [to_additive add_monoid.add_assoc] monoid.mul_assoc
attribute [to_additive add_monoid.zero] monoid.one
attribute [to_additive add_monoid.zero_add] monoid.one_mul
attribute [to_additive add_monoid.add_zero] monoid.mul_one

attribute [to_additive add_comm_monoid] comm_monoid
attribute [to_additive add_comm_monoid.mk] comm_monoid.mk
attribute [to_additive add_comm_monoid.to_add_monoid] comm_monoid.to_monoid
attribute [to_additive add_comm_monoid.to_add_comm_semigroup] comm_monoid.to_comm_semigroup

attribute [to_additive add_group] group
attribute [to_additive add_group.mk] group.mk
attribute [to_additive add_group.to_has_neg] group.to_has_inv
attribute [to_additive add_group.to_add_monoid] group.to_monoid
attribute [to_additive add_group.add_left_neg] group.mul_left_inv
attribute [to_additive add_group.add] group.mul
attribute [to_additive add_group.add_assoc] group.mul_assoc
attribute [to_additive add_group.zero] group.one
attribute [to_additive add_group.zero_add] group.one_mul
attribute [to_additive add_group.add_zero] group.mul_one
attribute [to_additive add_group.neg] group.inv

attribute [to_additive add_comm_group] comm_group
attribute [to_additive add_comm_group.mk] comm_group.mk
attribute [to_additive add_comm_group.to_add_group] comm_group.to_group
attribute [to_additive add_comm_group.to_add_comm_monoid] comm_group.to_comm_monoid

/- map theorems -/
attribute [to_additive add_assoc] mul_assoc
attribute [to_additive add_semigroup_to_is_associative] semigroup_to_is_associative
attribute [to_additive add_comm] mul_comm
attribute [to_additive add_comm_semigroup_to_is_commutative] comm_semigroup_to_is_commutative
attribute [to_additive add_left_comm] mul_left_comm
attribute [to_additive add_right_comm] mul_right_comm
attribute [to_additive add_left_cancel] mul_left_cancel
attribute [to_additive add_right_cancel] mul_right_cancel
attribute [to_additive add_left_cancel_iff] mul_left_cancel_iff
attribute [to_additive add_right_cancel_iff] mul_right_cancel_iff
attribute [to_additive zero_add] one_mul
attribute [to_additive add_zero] mul_one
attribute [to_additive add_left_neg] mul_left_inv
attribute [to_additive neg_add_self] inv_mul_self
attribute [to_additive neg_add_cancel_left] inv_mul_cancel_left
attribute [to_additive neg_add_cancel_right] inv_mul_cancel_right
attribute [to_additive neg_eq_of_add_eq_zero] inv_eq_of_mul_eq_one
attribute [to_additive neg_zero] one_inv
attribute [to_additive neg_neg] inv_inv
attribute [to_additive add_right_neg] mul_right_inv
attribute [to_additive add_neg_self] mul_inv_self
attribute [to_additive neg_inj] inv_inj
attribute [to_additive add_group.add_left_cancel] group.mul_left_cancel
attribute [to_additive add_group.add_right_cancel] group.mul_right_cancel
attribute [to_additive add_group.to_left_cancel_add_semigroup] group.to_left_cancel_semigroup
attribute [to_additive add_group.to_right_cancel_add_semigroup] group.to_right_cancel_semigroup
attribute [to_additive add_neg_cancel_left] mul_inv_cancel_left
attribute [to_additive add_neg_cancel_right] mul_inv_cancel_right
attribute [to_additive neg_add_rev] mul_inv_rev
attribute [to_additive eq_neg_of_eq_neg] eq_inv_of_eq_inv
attribute [to_additive eq_neg_of_add_eq_zero] eq_inv_of_mul_eq_one
attribute [to_additive eq_add_neg_of_add_eq] eq_mul_inv_of_mul_eq
attribute [to_additive eq_neg_add_of_add_eq] eq_inv_mul_of_mul_eq
attribute [to_additive neg_add_eq_of_eq_add] inv_mul_eq_of_eq_mul
attribute [to_additive add_neg_eq_of_eq_add] mul_inv_eq_of_eq_mul
attribute [to_additive eq_add_of_add_neg_eq] eq_mul_of_mul_inv_eq
attribute [to_additive eq_add_of_neg_add_eq] eq_mul_of_inv_mul_eq
attribute [to_additive add_eq_of_eq_neg_add] mul_eq_of_eq_inv_mul
attribute [to_additive add_eq_of_eq_add_neg] mul_eq_of_eq_mul_inv
attribute [to_additive neg_add] mul_inv

end pending_1857

universes u v
variables {α : Type u} {β : Type v}

def additive (α : Type*) := α
def multiplicative (α : Type*) := α

instance [semigroup α] : add_semigroup (additive α) :=
{ add := ((*) : α → α → α),
  add_assoc := @mul_assoc _ _ }

instance [add_semigroup α] : semigroup (multiplicative α) :=
{ mul := ((+) : α → α → α),
  mul_assoc := @add_assoc _ _ }

instance [comm_semigroup α] : add_comm_semigroup (additive α) :=
{ add_comm := @mul_comm _ _,
  ..additive.add_semigroup }

instance [add_comm_semigroup α] : comm_semigroup (multiplicative α) :=
{ mul_comm := @add_comm _ _,
  ..multiplicative.semigroup }

instance [left_cancel_semigroup α] : add_left_cancel_semigroup (additive α) :=
{ add_left_cancel := @mul_left_cancel _ _,
  ..additive.add_semigroup }

instance [add_left_cancel_semigroup α] : left_cancel_semigroup (multiplicative α) :=
{ mul_left_cancel := @add_left_cancel _ _,
  ..multiplicative.semigroup }

instance [right_cancel_semigroup α] : add_right_cancel_semigroup (additive α) :=
{ add_right_cancel := @mul_right_cancel _ _,
  ..additive.add_semigroup }

instance [add_right_cancel_semigroup α] : right_cancel_semigroup (multiplicative α) :=
{ mul_right_cancel := @add_right_cancel _ _,
  ..multiplicative.semigroup }

@[simp, to_additive add_left_inj]
theorem mul_left_inj [left_cancel_semigroup α] (a : α) {b c : α} : a * b = a * c ↔ b = c :=
⟨mul_left_cancel, congr_arg _⟩

@[simp, to_additive add_right_inj]
theorem mul_right_inj [right_cancel_semigroup α] (a : α) {b c : α} : b * a = c * a ↔ b = c :=
⟨mul_right_cancel, congr_arg _⟩

structure units (α : Type u) [monoid α] :=
(val : α)
(inv : α)
(val_inv : val * inv = 1)
(inv_val : inv * val = 1)

namespace units
variables [monoid α] {a b c : units α}

instance : has_coe (units α) α := ⟨val⟩

@[extensionality] theorem ext : ∀ {a b : units α}, (a : α) = b → a = b
| ⟨v, i₁, vi₁, iv₁⟩ ⟨v', i₂, vi₂, iv₂⟩ e :=
  by change v = v' at e; subst v'; congr;
      simpa [iv₂, vi₁] using mul_assoc i₂ v i₁

theorem ext_iff {a b : units α} : a = b ↔ (a : α) = b :=
⟨congr_arg _, ext⟩

instance [decidable_eq α] : decidable_eq (units α)
| a b := decidable_of_iff' _ ext_iff

protected def mul (u₁ u₂ : units α) : units α :=
⟨u₁.val * u₂.val, u₂.inv * u₁.inv,
  have u₁.val * (u₂.val * u₂.inv) * u₁.inv = 1,
    by rw [u₂.val_inv]; simp [u₁.val_inv],
  by simpa [mul_comm, mul_assoc],
  have u₂.inv * (u₁.inv * u₁.val) * u₂.val = 1,
    by rw [u₁.inv_val]; simp [u₂.inv_val],
  by simpa [mul_comm, mul_assoc]⟩

protected def inv' (u : units α) : units α :=
⟨u.inv, u.val, u.inv_val, u.val_inv⟩

instance : has_mul (units α) := ⟨units.mul⟩
instance : has_one (units α) := ⟨⟨1, 1, mul_one 1, one_mul 1⟩⟩
instance : has_inv (units α) := ⟨units.inv'⟩

variables (a b)
@[simp] lemma mul_coe : (↑(a * b) : α) = a * b := rfl
@[simp] lemma one_coe : ((1 : units α) : α) = 1 := rfl
lemma val_coe : (↑a : α) = a.val := rfl
lemma inv_coe : ((a⁻¹ : units α) : α) = a.inv := rfl
@[simp] lemma inv_mul : (↑a⁻¹ * a : α) = 1 := inv_val _
@[simp] lemma mul_inv : (a * ↑a⁻¹ : α) = 1 := val_inv _

@[simp] lemma mul_inv_cancel_left (a : units α) (b : α) : (a:α) * (↑a⁻¹ * b) = b :=
by rw [← mul_assoc, mul_inv, one_mul]

@[simp] lemma inv_mul_cancel_left (a : units α) (b : α) : (↑a⁻¹:α) * (a * b) = b :=
by rw [← mul_assoc, inv_mul, one_mul]

@[simp] lemma mul_inv_cancel_right (a : α) (b : units α) : a * b * ↑b⁻¹ = a :=
by rw [mul_assoc, mul_inv, mul_one]

@[simp] lemma inv_mul_cancel_right (a : α) (b : units α) : a * ↑b⁻¹ * b = a :=
by rw [mul_assoc, inv_mul, mul_one]

instance : group (units α) :=
by refine {mul := (*), one := 1, inv := has_inv.inv, ..};
  { intros, apply ext, simp [mul_assoc] }

instance {α} [comm_monoid α] : comm_group (units α) :=
{ mul_comm := λ u₁ u₂, ext $ mul_comm _ _, ..units.group }

instance [has_repr α] : has_repr (units α) := ⟨repr ∘ val⟩

@[simp] theorem mul_left_inj (a : units α) {b c : α} : (a:α) * b = a * c ↔ b = c :=
⟨λ h, by simpa using congr_arg ((*) ↑(a⁻¹ : units α)) h, congr_arg _⟩

@[simp] theorem mul_right_inj (a : units α) {b c : α} : b * a = c * a ↔ b = c :=
⟨λ h, by simpa using congr_arg (* ↑(a⁻¹ : units α)) h, congr_arg _⟩

end units

theorem nat.units_eq_one (u : units ℕ) : u = 1 :=
units.ext begin
  cases nat.eq_zero_or_pos u with h h,
  { simpa [h] using u.inv_mul },
  cases nat.eq_zero_or_pos ↑u⁻¹ with h' h',
  { simpa [h'] using u.inv_mul },
  refine le_antisymm _ h,
  simpa using nat.mul_le_mul_left u h'
end

def units.mk_of_mul_eq_one [comm_monoid α] (a b : α) (hab : a * b = 1) : units α :=
⟨a, b, hab, by rwa mul_comm a b at hab⟩

@[to_additive with_zero]
def with_one (α) := option α

@[to_additive with_zero.has_coe_t]
instance : has_coe_t α (with_one α) := ⟨some⟩

instance [semigroup α] : monoid (with_one α) :=
{ one       := none,
  mul       := option.lift_or_get (*),
  mul_assoc := (option.lift_or_get_assoc _).1,
  one_mul   := (option.lift_or_get_is_left_id _).1,
  mul_one   := (option.lift_or_get_is_right_id _).1 }

attribute [to_additive with_zero.add_monoid._proof_1] with_one.monoid._proof_1
attribute [to_additive with_zero.add_monoid._proof_2] with_one.monoid._proof_2
attribute [to_additive with_zero.add_monoid._proof_3] with_one.monoid._proof_3
attribute [to_additive with_zero.add_monoid] with_one.monoid

instance [semigroup α] : mul_zero_class (with_zero α) :=
{ zero      := none,
  mul       := λ o₁ o₂, o₁.bind (λ a, o₂.map (λ b, a * b)),
  zero_mul  := by simp,
  mul_zero  := λ a, by cases a; simp,
  ..with_zero.add_monoid }

instance [semigroup α] : semigroup (with_zero α) :=
{ mul_assoc := λ a b c, begin
    cases a with a, {refl},
    cases b with b, {refl},
    cases c with c, {refl},
    simp [mul_assoc]
  end,
  ..with_zero.mul_zero_class }

instance [comm_semigroup α] : comm_semigroup (with_zero α) :=
{ mul_comm := λ a b, begin
    cases a with a; cases b with b; try {refl},
    exact congr_arg some (mul_comm _ _)
  end,
  ..with_zero.semigroup }

instance [monoid α] : monoid (with_zero α) :=
{ one := some 1,
  one_mul := λ a, by cases a;
    [refl, exact congr_arg some (one_mul a)],
  mul_one := λ a, by cases a;
    [refl, exact congr_arg some (mul_one a)],
  ..with_zero.semigroup }

instance [comm_monoid α] : comm_monoid (with_zero α) :=
{ ..with_zero.monoid, ..with_zero.comm_semigroup }

instance [monoid α] : add_monoid (additive α) :=
{ zero     := (1 : α),
  zero_add := @one_mul _ _,
  add_zero := @mul_one _ _,
  ..additive.add_semigroup }

instance [add_monoid α] : monoid (multiplicative α) :=
{ one     := (0 : α),
  one_mul := @zero_add _ _,
  mul_one := @add_zero _ _,
  ..multiplicative.semigroup }

section monoid
  variables [monoid α] {a b c : α}

  /-- Partial division. It is defined when the
    second argument is invertible, and unlike the division operator
    in `division_ring` it is not totalized at zero. -/
  def divp (a : α) (u) : α := a * (u⁻¹ : units α)

  infix ` /ₚ `:70 := divp

  @[simp] theorem divp_self (u : units α) : (u : α) /ₚ u = 1 := by simp [divp]

  @[simp] theorem divp_one (a : α) : a /ₚ 1 = a := by simp [divp]

  theorem divp_assoc (a b : α) (u : units α) : a * b /ₚ u = a * (b /ₚ u) :=
  by simp [divp, mul_assoc]

  @[simp] theorem divp_mul_cancel (a : α) (u : units α) : a /ₚ u * u = a :=
  by simp [divp, mul_assoc]

  @[simp] theorem mul_divp_cancel (a : α) (u : units α) : (a * u) /ₚ u = a :=
  by simp [divp, mul_assoc]

  @[simp] theorem divp_right_inj (u : units α) {a b : α} : a /ₚ u = b /ₚ u ↔ a = b :=
  units.mul_right_inj _

  theorem divp_eq_one (a : α) (u : units α) : a /ₚ u = 1 ↔ a = u :=
  (units.mul_right_inj u).symm.trans $ by simp

  @[simp] theorem one_divp (u : units α) : 1 /ₚ u = ↑u⁻¹ :=
  by simp [divp]

end monoid

instance [comm_semigroup α] : comm_monoid (with_one α) :=
{ mul_comm := (option.lift_or_get_comm _).1,
  ..with_one.monoid }

instance [add_comm_semigroup α] : add_comm_monoid (with_zero α) :=
{ add_comm := (option.lift_or_get_comm _).1,
  ..with_zero.add_monoid }
attribute [to_additive with_zero.add_comm_monoid] with_one.comm_monoid

instance [comm_monoid α] : add_comm_monoid (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_monoid }

instance [add_comm_monoid α] : comm_monoid (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.monoid }

instance [group α] : add_group (additive α) :=
{ neg := @has_inv.inv α _,
  add_left_neg := @mul_left_inv _ _,
  ..additive.add_monoid }

instance [add_group α] : group (multiplicative α) :=
{ inv := @has_neg.neg α _,
  mul_left_inv := @add_left_neg _ _,
  ..multiplicative.monoid }

section group
  variables [group α] {a b c : α}

  instance : has_lift α (units α) :=
  ⟨λ a, ⟨a, a⁻¹, mul_inv_self _, inv_mul_self _⟩⟩

  @[simp, to_additive neg_inj']
  theorem inv_inj' : a⁻¹ = b⁻¹ ↔ a = b :=
  ⟨λ h, by rw ← inv_inv a; simp [h], congr_arg _⟩

  @[to_additive eq_of_neg_eq_neg]
  theorem eq_of_inv_eq_inv : a⁻¹ = b⁻¹ → a = b :=
  inv_inj'.1

  @[simp, to_additive add_self_iff_eq_zero]
  theorem mul_self_iff_eq_one : a * a = a ↔ a = 1 :=
  by have := @mul_left_inj _ _ a a 1; rwa mul_one at this

  @[simp, to_additive neg_eq_zero]
  theorem inv_eq_one : a⁻¹ = 1 ↔ a = 1 :=
  by rw [← @inv_inj' _ _ a 1, one_inv]

  @[simp, to_additive neg_ne_zero]
  theorem inv_ne_one : a⁻¹ ≠ 1 ↔ a ≠ 1 :=
  not_congr inv_eq_one

  @[to_additive left_inverse_neg]
  theorem left_inverse_inv (α) [group α] :
    function.left_inverse (λ a : α, a⁻¹) (λ a, a⁻¹) :=
  assume a, inv_inv a

  attribute [simp] mul_inv_cancel_left add_neg_cancel_left
                   mul_inv_cancel_right add_neg_cancel_right

  @[to_additive eq_neg_iff_eq_neg]
  theorem eq_inv_iff_eq_inv : a = b⁻¹ ↔ b = a⁻¹ :=
  ⟨eq_inv_of_eq_inv, eq_inv_of_eq_inv⟩

  @[to_additive neg_eq_iff_neg_eq]
  theorem inv_eq_iff_inv_eq : a⁻¹ = b ↔ b⁻¹ = a :=
  by rw [eq_comm, @eq_comm _ _ a, eq_inv_iff_eq_inv]

  @[to_additive add_eq_zero_iff_eq_neg]
  theorem mul_eq_one_iff_eq_inv : a * b = 1 ↔ a = b⁻¹ :=
  by simpa [mul_left_inv, -mul_right_inj] using @mul_right_inj _ _ b a (b⁻¹)

  @[to_additive add_eq_zero_iff_neg_eq]
  theorem mul_eq_one_iff_inv_eq : a * b = 1 ↔ a⁻¹ = b :=
  by rw [mul_eq_one_iff_eq_inv, eq_inv_iff_eq_inv, eq_comm]

  @[to_additive eq_neg_iff_add_eq_zero]
  theorem eq_inv_iff_mul_eq_one : a = b⁻¹ ↔ a * b = 1 :=
  mul_eq_one_iff_eq_inv.symm

  @[to_additive neg_eq_iff_add_eq_zero]
  theorem inv_eq_iff_mul_eq_one : a⁻¹ = b ↔ a * b = 1 :=
  mul_eq_one_iff_inv_eq.symm

  @[to_additive eq_add_neg_iff_add_eq]
  theorem eq_mul_inv_iff_mul_eq : a = b * c⁻¹ ↔ a * c = b :=
  ⟨λ h, by simp [h], λ h, by simp [h.symm]⟩

  @[to_additive eq_neg_add_iff_add_eq]
  theorem eq_inv_mul_iff_mul_eq : a = b⁻¹ * c ↔ b * a = c :=
  ⟨λ h, by simp [h], λ h, by simp [h.symm]⟩

  @[to_additive neg_add_eq_iff_eq_add]
  theorem inv_mul_eq_iff_eq_mul : a⁻¹ * b = c ↔ b = a * c :=
  ⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

  @[to_additive add_neg_eq_iff_eq_add]
  theorem mul_inv_eq_iff_eq_mul : a * b⁻¹ = c ↔ a = c * b :=
  ⟨λ h, by simp [h.symm], λ h, by simp [h]⟩

  @[to_additive add_neg_eq_zero]
  theorem mul_inv_eq_one {a b : α} : a * b⁻¹ = 1 ↔ a = b :=
  by rw [mul_eq_one_iff_eq_inv, inv_inv]

  @[to_additive neg_comm_of_comm]
  theorem inv_comm_of_comm {a b : α} (H : a * b = b * a) : a⁻¹ * b = b * a⁻¹ :=
  begin
    have : a⁻¹ * (b * a) * a⁻¹ = a⁻¹ * (a * b) * a⁻¹ :=
      congr_arg (λ x:α, a⁻¹ * x * a⁻¹) H.symm,
    rwa [mul_assoc, mul_assoc, mul_inv_self, mul_one,
        ← mul_assoc, inv_mul_self, one_mul] at this; exact h
  end

end group

instance [comm_group α] : add_comm_group (additive α) :=
{ add_comm := @mul_comm α _,
  ..additive.add_group }

instance [add_comm_group α] : comm_group (multiplicative α) :=
{ mul_comm := @add_comm α _,
  ..multiplicative.group }

section add_monoid
  variables [add_monoid α] {a b c : α}

  @[simp] lemma bit0_zero : bit0 (0 : α) = 0 := add_zero _
  @[simp] lemma bit1_zero [has_one α] : bit1 (0 : α) = 1 := by simp [bit1]

end add_monoid

section add_group
  variables [add_group α] {a b c : α}

  local attribute [simp] sub_eq_add_neg

  def sub_sub_cancel := @sub_sub_self

  @[simp] lemma sub_left_inj : a - b = a - c ↔ b = c :=
  (add_left_inj _).trans neg_inj'

  @[simp] lemma sub_right_inj : b - a = c - a ↔ b = c :=
  add_right_inj _

  lemma sub_add_sub_cancel (a b c : α) : (a - b) + (b - c) = a - c :=
  by simp

  lemma sub_sub_sub_cancel_right (a b c : α) : (a - c) - (b - c) = a - b :=
  by simp

  theorem sub_eq_zero : a - b = 0 ↔ a = b :=
  ⟨eq_of_sub_eq_zero, λ h, by simp [h]⟩

  theorem sub_ne_zero : a - b ≠ 0 ↔ a ≠ b :=
  not_congr sub_eq_zero

  theorem eq_sub_iff_add_eq : a = b - c ↔ a + c = b :=
  by split; intro h; simp [h, eq_add_neg_iff_add_eq]

  theorem sub_eq_iff_eq_add : a - b = c ↔ a = c + b :=
  by split; intro h; simp [*, add_neg_eq_iff_eq_add] at *

  theorem eq_iff_eq_of_sub_eq_sub {a b c d : α} (H : a - b = c - d) : a = b ↔ c = d :=
  by rw [← sub_eq_zero, H, sub_eq_zero]

  theorem left_inverse_sub_add_left (c : α) : function.left_inverse (λ x, x - c) (λ x, x + c) :=
  assume x, add_sub_cancel x c

  theorem left_inverse_add_left_sub (c : α) : function.left_inverse (λ x, x + c) (λ x, x - c) :=
  assume x, sub_add_cancel x c

  theorem left_inverse_add_right_neg_add (c : α) :
      function.left_inverse (λ x, c + x) (λ x, - c + x) :=
  assume x, add_neg_cancel_left c x

  theorem left_inverse_neg_add_add_right (c : α) :
      function.left_inverse (λ x, - c + x) (λ x, c + x) :=
  assume x, neg_add_cancel_left c x
end add_group

section add_comm_group
  variables [add_comm_group α] {a b c : α}

  lemma sub_eq_neg_add (a b : α) : a - b = -b + a :=
  by simp

  theorem neg_add' (a b : α) : -(a + b) = -a - b := neg_add a b

  lemma eq_sub_iff_add_eq' : a = b - c ↔ c + a = b :=
  by rw [eq_sub_iff_add_eq, add_comm]

  lemma sub_eq_iff_eq_add' : a - b = c ↔ a = b + c :=
  by rw [sub_eq_iff_eq_add, add_comm]

  lemma add_sub_cancel' (a b : α) : a + b - a = b :=
  by simp

  lemma add_sub_cancel'_right (a b : α) : a + (b - a) = b :=
  by rw [← add_sub_assoc, add_sub_cancel']

  lemma sub_right_comm (a b c : α) : a - b - c = a - c - b :=
  by simp

  lemma sub_add_sub_cancel' (a b c : α) : (a - b) + (c - a) = c - b :=
  by rw add_comm; apply sub_add_sub_cancel

  lemma sub_sub_sub_cancel_left (a b c : α) : (c - a) - (c - b) = b - a :=
  by simp

end add_comm_group

section is_conj
variables [group α] [group β]

def is_conj (a b : α) := ∃ c : α, c * a * c⁻¹ = b

@[refl] lemma is_conj_refl (a : α) : is_conj a a := ⟨1, by simp⟩

@[symm] lemma is_conj_symm (a b : α) : is_conj a b → is_conj b a
| ⟨c, hc⟩ := ⟨c⁻¹, by simp [hc.symm, mul_assoc]⟩

@[trans] lemma is_conj_trans (a b c : α) : is_conj a b → is_conj b c → is_conj a c
| ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ := ⟨c₂ * c₁, by simp [hc₁.symm, hc₂.symm, mul_assoc]⟩

@[simp] lemma is_conj_iff_eq {α : Type*} [comm_group α] {a b : α} : is_conj a b ↔ a = b :=
⟨λ ⟨c, hc⟩, by rw [← hc, mul_right_comm, mul_inv_self, one_mul], λ h, by rw h⟩

end is_conj

class is_monoid_hom [monoid α] [monoid β] (f : α → β) : Prop :=
(map_one : f 1 = 1)
(map_mul : ∀ {x y}, f (x * y) = f x * f y)

class is_add_monoid_hom [add_monoid α] [add_monoid β] (f : α → β) : Prop :=
(map_zero : f 0 = 0)
(map_add : ∀ {x y}, f (x + y) = f x + f y)

attribute [to_additive is_add_monoid_hom] is_monoid_hom
attribute [to_additive is_add_monoid_hom.map_add] is_monoid_hom.map_mul
attribute [to_additive is_add_monoid_hom.mk] is_monoid_hom.mk

namespace is_monoid_hom
variables [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]

@[to_additive is_add_monoid_hom.id]
instance id : is_monoid_hom (@id α) := by refine {..}; intros; refl

@[to_additive is_add_monoid_hom.id]
instance comp {γ} [monoid γ] (g : β → γ) [is_monoid_hom g] :
  is_monoid_hom (g ∘ f) :=
{ map_mul := λ x y, by simp [map_mul f]; rw map_mul g; refl,
  map_one := by simp [map_one f]; exact map_one g }

end is_monoid_hom

-- TODO rename fields of is_group_hom: mul ↝ map_mul?

/-- Predicate for group homomorphism. -/
class is_group_hom [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f a * f b)

class is_add_group_hom [add_group α] [add_group β] (f : α → β) : Prop :=
(add : ∀ a b, f (a + b) = f a + f b)

attribute [to_additive is_add_group_hom] is_group_hom
attribute [to_additive is_add_group_hom.add] is_group_hom.mul
attribute [to_additive is_add_group_hom.mk] is_group_hom.mk

namespace is_group_hom
variables [group α] [group β] (f : α → β) [is_group_hom f]

@[to_additive is_add_group_hom.zero]
theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by simp [(mul f 1 1).symm]

@[to_additive is_add_group_hom.neg]
theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq.symm $ inv_eq_of_mul_eq_one $ by simp [(mul f a a⁻¹).symm, one f]

@[to_additive is_add_group_hom.id]
instance id : is_group_hom (@id α) :=
⟨λ _ _, rfl⟩

@[to_additive is_add_group_hom.comp]
instance comp {γ} [group γ] (g : β → γ) [is_group_hom g] :
  is_group_hom (g ∘ f) :=
⟨λ x y, calc
  g (f (x * y)) = g (f x * f y)       : by rw mul f
  ...           = g (f x) * g (f y)   : by rw mul g⟩

protected lemma is_conj (f : α → β) [is_group_hom f] {a b : α} : is_conj a b → is_conj (f a) (f b)
| ⟨c, hc⟩ := ⟨f c, by rw [← is_group_hom.mul f, ← is_group_hom.inv f, ← is_group_hom.mul f, hc]⟩

end is_group_hom

/-- Predicate for group anti-homomorphism, or a homomorphism
  into the opposite group. -/
class is_group_anti_hom {β : Type*} [group α] [group β] (f : α → β) : Prop :=
(mul : ∀ a b : α, f (a * b) = f b * f a)

namespace is_group_anti_hom
variables [group α] [group β] (f : α → β) [w : is_group_anti_hom f]
include w

theorem one : f 1 = 1 :=
mul_self_iff_eq_one.1 $ by simp [(mul f 1 1).symm]

theorem inv (a : α) : f a⁻¹ = (f a)⁻¹ :=
eq.symm $ inv_eq_of_mul_eq_one $ by simp [(mul f a⁻¹ a).symm, one f]

end is_group_anti_hom

theorem inv_is_group_anti_hom [group α] : is_group_anti_hom (λ x : α, x⁻¹) :=
⟨mul_inv_rev⟩

namespace is_add_group_hom
variables [add_group α] [add_group β] (f : α → β) [is_add_group_hom f]

lemma sub (a b) : f (a - b) = f a - f b :=
calc f (a - b) = f (a + -b)   : rfl
           ... = f a + f (-b) : add f _ _
           ... = f a - f b    : by  simp[neg f]

end is_add_group_hom


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import category_theory.category.Bipointed
import data.two_pointing

/-!
# The category of two-pointed types

This defines `Twop`, the category of two-pointed types.

## References

* [nLab, *coalgebra of the real interval*]
  (https://ncatlab.org/nlab/show/coalgebra+of+the+real+interval)
-/

open category_theory option

universes u
variables {α β : Type*}

/-- The category of two-pointed types. -/
structure Twop : Type.{u+1} :=
(X : Type.{u})
(to_two_pointing : two_pointing X)

namespace Twop

instance : has_coe_to_sort Twop Type* := ⟨X⟩

attribute [protected] Twop.X

/-- Turns a two-pointing into a two-pointed type. -/
def of {X : Type*} (to_two_pointing : two_pointing X) : Twop := ⟨X, to_two_pointing⟩

@[simp] lemma coe_of {X : Type*} (to_two_pointing : two_pointing X) :
  ↥(of to_two_pointing) = X := rfl

alias of ← two_pointing.Twop

instance : inhabited Twop := ⟨of two_pointing.bool⟩

/-- Turns a two-pointed type into a bipointed type, by forgetting that the pointed elements are
distinct. -/
def to_Bipointed (X : Twop) : Bipointed := X.to_two_pointing.to_prod.Bipointed

@[simp] lemma coe_to_Bipointed (X : Twop) : ↥X.to_Bipointed = ↥X := rfl

instance large_category : large_category Twop := induced_category.category to_Bipointed

instance concrete_category : concrete_category Twop :=
induced_category.concrete_category to_Bipointed

instance has_forget_to_Bipointed : has_forget₂ Twop Bipointed :=
induced_category.has_forget₂ to_Bipointed

/-- Swaps the pointed elements of a two-pointed type. `two_pointing.swap` as a functor. -/
@[simps] def swap : Twop ⥤ Twop :=
{ obj := λ X, ⟨X, X.to_two_pointing.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Twop` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Twop ≌ Twop :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Twop

@[simp] lemma Twop_swap_comp_forget_to_Bipointed :
  Twop.swap ⋙ forget₂ Twop Bipointed = forget₂ Twop Bipointed ⋙ Bipointed.swap := rfl

/-- The functor from `Pointed` to `Twop` which adds a second point. -/
@[simps] def Pointed_to_Twop_fst : Pointed.{u} ⥤ Twop :=
{ obj := λ X, ⟨option X, ⟨X.point, none⟩, some_ne_none _⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Twop` which adds a first point. -/
@[simps] def Pointed_to_Twop_snd : Pointed.{u} ⥤ Twop :=
{ obj := λ X, ⟨option X, ⟨none, X.point⟩, (some_ne_none _).symm⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Twop_fst_comp_swap :
  Pointed_to_Twop_fst ⋙ Twop.swap = Pointed_to_Twop_snd := rfl

@[simp] lemma Pointed_to_Twop_snd_comp_swap :
  Pointed_to_Twop_snd ⋙ Twop.swap = Pointed_to_Twop_fst := rfl

@[simp] lemma Pointed_to_Twop_fst_comp_forget_to_Bipointed :
  Pointed_to_Twop_fst ⋙ forget₂ Twop Bipointed = Pointed_to_Bipointed_fst := rfl

@[simp] lemma Pointed_to_Twop_snd_comp_forget_to_Bipointed :
  Pointed_to_Twop_snd ⋙ forget₂ Twop Bipointed = Pointed_to_Bipointed_snd := rfl

/-- Adding a second point is left adjoint to forgetting the second point. -/
def Pointed_to_Twop_fst_forget_comp_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Twop_fst ⊣ forget₂ Twop Bipointed ⋙ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
    inv_fun := λ f, ⟨λ o, o.elim Y.to_two_pointing.to_prod.2 f.to_fun, f.map_point, rfl⟩,
    left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
    right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- Adding a first point is left adjoint to forgetting the first point. -/
def Pointed_to_Twop_snd_forget_comp_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Twop_snd ⊣ forget₂ Twop Bipointed ⋙ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
    inv_fun := λ f, ⟨λ o, o.elim Y.to_two_pointing.to_prod.1 f.to_fun, rfl, f.map_point⟩,
    left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
    right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.functor.currying
import category_theory.limits.over
import category_theory.limits.shapes.images
import category_theory.adjunction.reflective

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
@[derive [category]]
def mono_over (X : C) := {f : over X // mono f.hom}

namespace mono_over

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : mono f] : mono_over X := { val := over.mk f, property := hf }

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : mono_over X ⥤ over X := full_subcategory_inclusion _

instance : has_coe (mono_over X) C :=
{ coe := λ Y, Y.val.left, }

@[simp]
lemma forget_obj_left {f} : ((forget X).obj f).left = (f : C) := rfl

@[simp] lemma mk'_coe' {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f : C) = A := rfl

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbreviation arrow (f : mono_over X) : (f : C) ⟶ X := ((forget X).obj f).hom

@[simp] lemma mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f).arrow = f := rfl

@[simp]
lemma forget_obj_hom {f} : ((forget X).obj f).hom = f.arrow := rfl

instance : full (forget X) := full_subcategory.full _
instance : faithful (forget X) := full_subcategory.faithful _

instance mono (f : mono_over X) : mono f.arrow := f.property

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance is_thin {X : C} (f g : mono_over X) : subsingleton (f ⟶ g) :=
⟨begin
  intros h₁ h₂,
  ext1,
  erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
end⟩

@[reassoc] lemma w {f g : mono_over X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbreviation hom_mk {f g : mono_over X} (h : f.val.left ⟶ g.val.left) (w : h ≫ g.arrow = f.arrow) :
  f ⟶ g :=
over.hom_mk h w

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def iso_mk {f g : mono_over X} (h : f.val.left ≅ g.val.left) (w : h.hom ≫ g.arrow = f.arrow) :
  f ≅ g :=
{ hom := hom_mk h.hom w,
  inv := hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp] def mk'_arrow_iso {X : C} (f : mono_over X) : (mk' f.arrow) ≅ f :=
iso_mk (iso.refl _) (by simp)

/--
Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  mono_over Y ⥤ mono_over X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (mono_over.forget X).preimage ((mono_over.forget Y ⋙ F).map k), }

/--
Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def lift_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  lift F₁ h₁ ≅ lift F₂ h₂ :=
fully_faithful_cancel_right (mono_over.forget X) (iso_whisker_left (mono_over.forget Y) i)

/-- `mono_over.lift` commutes with composition of functors. -/
def lift_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

/-- `mono_over.lift` preserves the identity functor. -/
def lift_id :
  lift (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

@[simp]
lemma lift_comm (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  lift F h ⋙ mono_over.forget X = mono_over.forget Y ⋙ F :=
rfl

@[simp]
lemma lift_obj_arrow {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) (f : mono_over Y) :
  ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).hom :=
rfl

/--
Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : over A} (h₁ h₂) : mono_over f ≌ mono_over f.left :=
{ functor := mono_over.lift f.iterated_slice_equiv.functor h₁,
  inverse := mono_over.lift f.iterated_slice_equiv.inverse h₂,
  unit_iso := mono_over.lift_id.symm ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫
    (mono_over.lift_comp _ _ _ _).symm,
  counit_iso := mono_over.lift_comp _ _ _ _ ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫
    mono_over.lift_id }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : mono_over Y ⥤ mono_over X :=
mono_over.lift (over.pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
lift_iso _ _ (over.pullback_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullback_id : pullback (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.pullback_id ≪≫ lift_id

@[simp] lemma pullback_obj_left (f : X ⟶ Y) (g : mono_over Y) :
  (((pullback f).obj g) : C) = limits.pullback g.arrow f :=
rfl

@[simp] lemma pullback_obj_arrow (f : X ⟶ Y) (g : mono_over Y) :
  ((pullback f).obj g).arrow = pullback.snd :=
rfl

end pullback

section map

attribute [instance] mono_comp

/--
We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y :=
lift (over.map f)
(λ g, by apply mono_comp g.arrow f)

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  map (f ≫ g) ≅ map f ⋙ map g :=
lift_iso _ _ (over.map_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def map_id : map (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.map_id ≪≫ lift_id

@[simp] lemma map_obj_left (f : X ⟶ Y) [mono f] (g : mono_over X) :
  (((map f).obj g) : C) = g.val.left :=
rfl

@[simp]
lemma map_obj_arrow (f : X ⟶ Y) [mono f] (g : mono_over X) :
  ((map f).obj g).arrow = g.arrow ≫ f :=
rfl

instance full_map (f : X ⟶ Y) [mono f] : full (map f) :=
{ preimage := λ g h e,
  begin
    refine hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply w e,
  end }

instance faithful_map (f : X ⟶ Y) [mono f] : faithful (map f) := {}.

/--
Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps] def map_iso {A B : C} (e : A ≅ B) : mono_over A ≌ mono_over B :=
{ functor := map e.hom,
  inverse := map e.inv,
  unit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id).symm,
  counit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id) }

section
variables (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps] def congr (e : C ≌ D) : mono_over X ≌ mono_over (e.functor.obj X) :=
{ functor := lift (over.post e.functor) $ λ f, by { dsimp, apply_instance },
  inverse := (lift (over.post e.inverse) $ λ f, by { dsimp, apply_instance })
    ⋙ (map_iso (e.unit_iso.symm.app X)).functor,
  unit_iso := nat_iso.of_components (λ Y, iso_mk (e.unit_iso.app Y) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ Y, iso_mk (e.counit_iso.app Y) (by tidy)) (by tidy) }

end

section
variable [has_pullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def map_pullback_adj (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
adjunction.restrict_fully_faithful
  (forget X) (forget Y) (over.map_pullback_adj f) (iso.refl _) (iso.refl _)

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullback_map_self (f : X ⟶ Y) [mono f] :
  map f ⋙ pullback f ≅ 𝟭 _ :=
(as_iso (mono_over.map_pullback_adj f).unit).symm

end

end map

section image
variables (f : X ⟶ Y) [has_image f]

/--
The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def image_mono_over (f : X ⟶ Y) [has_image f] : mono_over Y := mono_over.mk' (image.ι f)

@[simp] lemma image_mono_over_arrow (f : X ⟶ Y) [has_image f] :
  (image_mono_over f).arrow = image.ι f :=
rfl

end image

section image

variables [has_images C]

/--
Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : over X ⥤ mono_over X :=
{ obj := λ f, image_mono_over f.hom,
  map := λ f g k,
  begin
    apply (forget X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

/--
`mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def image_forget_adj : image ⊣ forget X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.val.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance : is_right_adjoint (forget X) :=
{ left := image, adj := image_forget_adj }

instance reflective : reflective (forget X) := {}.

/--
Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forget_image : forget X ⋙ image ≅ 𝟭 (mono_over X) :=
as_iso (adjunction.counit image_forget_adj)

end image

section «exists»
variables [has_images C]

/--
In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def «exists» (f : X ⟶ Y) : mono_over X ⥤ mono_over Y :=
forget _ ⋙ over.map f ⋙ image

instance faithful_exists (f : X ⟶ Y) : faithful («exists» f) := {}.

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f ≅ map f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget _).obj ((«exists» f).obj Z) ≅ (forget _).obj ((map f).obj Z),
    apply preimage_iso this,
  apply over.iso_mk _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- `exists` is adjoint to `pullback` when images exist -/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
adjunction.restrict_fully_faithful (forget X) (𝟭 _)
  ((over.map_pullback_adj f).comp _ _ image_forget_adj)
  (iso.refl _)
  (iso.refl _)

end «exists»

end mono_over

end category_theory


import sheaves.sheaf Kenny.sandbox

universes v w u₁ v₁ u

open topological_space lattice

namespace opens

variables {X : Type u} [topological_space X]

theorem Inf_eq (s : set (opens X)) : Inf s = opens.interior (Inf $ subtype.val '' s) :=
le_antisymm
  ((subset_interior_iff_subset_of_open (Inf s).2).2 $ show (Inf s).1 ≤ Inf (subtype.val '' s),
    from le_Inf $ λ t ⟨u, hus, hut⟩, le_trans interior_subset $ Inf_le ⟨u, show Inf (set.range (λ (H : u ∈ s), u.val)) = t,
    from le_antisymm (Inf_le ⟨hus, hut⟩) (le_Inf $ λ b ⟨c, hc⟩, hc ▸ ge_of_eq hut)⟩)
  (le_Inf $ λ U hus, set.subset.trans interior_subset $ show Inf (subtype.val '' s) ≤ U.1,
    from Inf_le $ set.mem_image_of_mem _ hus)

theorem inter_val (U V : opens X) : (U ∩ V).1 = U.1 ∩ V.1 := rfl
theorem inf_val (U V : opens X) : (U ⊓ V).1 = U.1 ∩ V.1 := rfl

theorem inf_Sup (U : opens X) (s : set (opens X)) : U ⊓ Sup s = Sup ((⊓) U '' s) :=
opens.ext $ by rw [inf_val, opens.Sup_s, opens.Sup_s, set.sUnion_eq_Union, set.inter_Union, ← set.image_comp]; exact
set.subset.antisymm
  (set.Union_subset $ λ ⟨t, i, his, hit⟩, set.subset_sUnion_of_mem ⟨i, his, congr_arg ((∩) U.1) hit⟩)
  (set.sUnion_subset $ λ t ⟨i, his, hit⟩, set.subset_sUnion_of_mem ⟨⟨i.1, i, his, rfl⟩, hit⟩)

def covering_inf_left (U V : opens X) (OC : covering U) : covering (V ⊓ U) :=
{ γ := OC.γ,
  Uis := λ i : OC.γ, V ⊓ OC.Uis i,
  Hcov := by conv_rhs { rw ← OC.Hcov }; rw [supr, supr, inf_Sup]; congr' 1; ext x; exact
    ⟨λ ⟨i, hix⟩, ⟨OC.Uis i, ⟨i, rfl⟩, hix⟩, λ ⟨_, ⟨i, rfl⟩, hix⟩, ⟨i, hix⟩⟩ }

def covering_res (U V : opens X) (H : V ⊆ U) (OC : covering U) : covering V :=
{ γ := OC.γ,
  Uis := λ i : OC.γ, V ⊓ OC.Uis i,
  Hcov := by erw [(covering_inf_left U V OC).Hcov, (inf_of_le_left $ show V ≤ U, from H)] }

end opens

def presheaf.covering (X : Type u) [topological_space X] : presheaf.{u (u+1)} X :=
{ F := covering,
  res := opens.covering_res,
  Hid := λ U, funext $ λ OC, by cases OC; dsimp only [opens.covering_res, id]; congr' 1; funext i; apply opens.ext;
    apply set.inter_eq_self_of_subset_right; rw ← OC_Hcov; apply set.subset_sUnion_of_mem; refine ⟨_, ⟨_, rfl⟩, rfl⟩,
  Hcomp := λ U V W HWV HVU, funext $ λ OC, by dsimp only [opens.covering_res, function.comp_apply]; congr' 1; funext i;
    rw [← lattice.inf_assoc, lattice.inf_of_le_left (show W ≤ V, from HWV)] }

def sheaf_on_opens (X : Type u) [topological_space X] (U : opens X) : Type (max u (v+1)) :=
sheaf.{u v} X

namespace sheaf_on_opens

variables {X : Type u} [topological_space X] {U : opens X}

def eval (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) : Type v :=
presheaf.F F.to_presheaf V

def res (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) (W : opens X) (HWU : W ≤ U) (HWV : W ≤ V) : F.eval V HVU → F.eval W HWU :=
presheaf.res _ _ _ HWV

theorem res_self (F : sheaf_on_opens X U) (V HVU HV x) :
  F.res V HVU V HVU HV x = x :=
presheaf.Hid' _ _ _

theorem res_res (F : sheaf_on_opens X U) (V HVU W HWU HWV S HSU HSW x) :
  F.res W HWU S HSU HSW (F.res V HVU W HWU HWV x) = F.res V HVU S HSU (le_trans HSW HWV) x :=
(presheaf.Hcomp' _ _ _ _ _ _ _).symm

theorem locality (F : sheaf_on_opens X U) (V HVU s t) (OC : covering V)
  (H : ∀ i : OC.γ, F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) s =
    F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t) :
  s = t :=
F.locality OC s t H

noncomputable def glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V)
  (s : Π i : OC.γ, F.eval (OC.Uis i) (le_trans (subset_covering i) HVU))
  (H : ∀ i j : OC.γ, F.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_left (s i) =
    F.res _ _ (OC.Uis i ⊓ OC.Uis j) (le_trans inf_le_left (le_trans (subset_covering i) HVU)) inf_le_right (s j)) :
  F.eval V HVU :=
classical.some $ F.gluing OC s H

theorem res_glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V) (s H i) :
  F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) (F.glue V HVU OC s H) = s i :=
classical.some_spec (F.gluing OC s H) i

theorem eq_glue (F : sheaf_on_opens X U) (V HVU) (OC : covering V)
  (s : Π i : OC.γ, F.eval (OC.Uis i) (le_trans (subset_covering i) HVU)) (H t)
  (ht : ∀ i, F.res V HVU (OC.Uis i) (le_trans (subset_covering i) HVU) (subset_covering i) t = s i) :
  F.glue V HVU OC s H = t :=
F.locality V HVU _ _ OC $ λ i, by rw [res_glue, ht]

def res_subset (F : sheaf_on_opens X U) (V : opens X) (HVU : V ≤ U) : sheaf_on_opens X V :=
F

theorem res_res_subset (F : sheaf_on_opens X U) (V HVU S HSV T HTV HTS x) :
  (F.res_subset V HVU).res S HSV T HTV HTS x = F.res S (le_trans HSV HVU) T (le_trans HTV HVU) HTS x :=
rfl

def stalk (F : sheaf_on_opens.{v} X U) (x : X) (hx : x ∈ U) : Type (max u v) :=
stalk F.1 x

def to_stalk (F : sheaf_on_opens X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U) (s : F.eval V HVU) : F.stalk x hx :=
⟦⟨V, hxV, s⟩⟧

@[simp] lemma to_stalk_res (F : sheaf_on_opens X U) (x : X) (hx : x ∈ U) (V : opens X) (hxV : x ∈ V) (HVU : V ≤ U)
  (W : opens X) (hxW : x ∈ W) (HWV : W ≤ V) (s : F.eval V HVU) :
  F.to_stalk x hx W hxW (le_trans HWV HVU) (F.res _ _ _ _ HWV s) = F.to_stalk x hx V hxV HVU s :=
quotient.sound ⟨W, hxW, set.subset.refl W.1, HWV, by dsimp only [res]; rw ← presheaf.Hcomp'; refl⟩

@[elab_as_eliminator] theorem stalk.induction_on {F : sheaf_on_opens X U} {x : X} {hx : x ∈ U}
  {C : F.stalk x hx → Prop} (g : F.stalk x hx)
  (H : ∀ V : opens X, ∀ hxV : x ∈ V, ∀ HVU : V ≤ U, ∀ s : F.eval V HVU, C (F.to_stalk x hx V hxV HVU s)) :
  C g :=
quotient.induction_on g $ λ e,
have (⟦e⟧ : F.stalk x hx) = ⟦⟨e.1 ⊓ U, ⟨e.2, hx⟩, F.to_presheaf.res _ _ (set.inter_subset_left _ _) e.3⟩⟧,
from quotient.sound ⟨e.1 ⊓ U, ⟨e.2, hx⟩, set.inter_subset_left _ _, set.subset.refl _, by dsimp only; rw ← presheaf.Hcomp'; refl⟩,
this.symm ▸ H (e.1 ⊓ U) ⟨e.2, hx⟩ inf_le_right _

structure morphism (F : sheaf_on_opens.{v} X U) (G : sheaf_on_opens.{w} X U) : Type (max u v w) :=
(map : ∀ V ≤ U, F.eval V H → G.eval V H)
(commutes : ∀ (V : opens X) (HV : V ≤ U) (W : opens X) (HW : W ≤ U) (HWV : W ≤ V) (x),
  map W HW (F.res V HV W HW HWV x) = G.res V HV W HW HWV (map V HV x))

namespace morphism

protected def id (F : sheaf_on_opens.{v} X U) : F.morphism F :=
{ map := λ V HV, id,
  commutes := λ V HV W HW HWV x, rfl }

def comp {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) : F.morphism H :=
{ map := λ V HV x, η.map V HV (ξ.map V HV x),
  commutes := λ V HV W HW HWV x, by rw [ξ.commutes, η.commutes] }

@[simp] lemma comp_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V HV s) :
  (η.comp ξ).1 V HV s = η.1 V HV (ξ.1 V HV s) :=
rfl

@[ext] lemma ext {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U}
  {η ξ : F.morphism G} (H : ∀ V HV x, η.map V HV x = ξ.map V HV x) : η = ξ :=
by cases η; cases ξ; congr; ext; apply H

@[simp] lemma id_comp {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) :
  (morphism.id G).comp η = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_id {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) :
  η.comp (morphism.id F) = η :=
ext $ λ V HV x, rfl

@[simp] lemma comp_assoc {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U} {I : sheaf_on_opens.{v₁} X U}
  (η : H.morphism I) (ξ : G.morphism H) (χ : F.morphism G) :
  (η.comp ξ).comp χ = η.comp (ξ.comp χ) :=
rfl

def res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (F.res_subset V HVU).morphism (G.res_subset V HVU) :=
{ map := λ W HWV, η.map W (le_trans HWV HVU),
  commutes := λ S HSV T HTV, η.commutes S (le_trans HSV HVU) T (le_trans HTV HVU) }

@[simp] lemma res_subset_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (V : opens X) (HVU : V ≤ U)
  (W HWV s) : (η.res_subset V HVU).1 W HWV s = η.1 W (le_trans HWV HVU) s :=
rfl

@[simp] lemma comp_res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} {H : sheaf_on_opens.{u₁} X U}
  (η : G.morphism H) (ξ : F.morphism G) (V : opens X) (HVU : V ≤ U) :
  (η.res_subset V HVU).comp (ξ.res_subset V HVU) = (η.comp ξ).res_subset V HVU :=
rfl

@[simp] lemma id_res_subset {F : sheaf_on_opens.{v} X U} (V : opens X) (HVU : V ≤ U) :
  (morphism.id F).res_subset V HVU = morphism.id (F.res_subset V HVU) :=
rfl

def stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (s : F.stalk x hx) : G.stalk x hx :=
quotient.lift_on s (λ g, ⟦(⟨g.1 ⊓ U, (⟨g.2, hx⟩ : x ∈ g.1 ⊓ U),
  η.map _ inf_le_right (presheaf.res F.1 _ _ (set.inter_subset_left _ _) g.3)⟩ : stalk.elem _ _)⟧) $
λ g₁ g₂ ⟨V, hxV, HV1, HV2, hg⟩, quotient.sound ⟨V ⊓ U, ⟨hxV, hx⟩, set.inter_subset_inter_left _ HV1, set.inter_subset_inter_left _ HV2,
calc  G.res _ _ (V ⊓ U) inf_le_right (inf_le_inf HV1 (le_refl _)) (η.map (g₁.U ⊓ U) inf_le_right (F.to_presheaf.res (g₁.U) (g₁.U ⊓ U) (set.inter_subset_left _ _) (g₁.s)))
    = η.map (V ⊓ U) inf_le_right (F.to_presheaf.res V (V ⊓ U) (set.inter_subset_left _ _) (F.to_presheaf.res (g₁.U) V HV1 (g₁.s))) : by rw [← η.2, res, ← presheaf.Hcomp', ← presheaf.Hcomp']
... = G.res _ _ (V ⊓ U) _ _ (η.map (g₂.U ⊓ U) inf_le_right (F.to_presheaf.res (g₂.U) (g₂.U ⊓ U) _ (g₂.s))) : by rw [hg, ← η.2, res, ← presheaf.Hcomp', ← presheaf.Hcomp']⟩

@[simp] lemma stalk_to_stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (η : F.morphism G) (x : X) (hx : x ∈ U)
  (V : opens X) (HVU : V ≤ U) (hxV : x ∈ V) (s : F.eval V HVU) : η.stalk x hx (F.to_stalk x hx V hxV HVU s) = G.to_stalk x hx V hxV HVU (η.map V HVU s) :=
quotient.sound ⟨V, hxV, set.subset_inter (set.subset.refl _) HVU, set.subset.refl _,
calc  G.res (V ⊓ U) inf_le_right V HVU (le_inf (le_refl V) HVU) (η.map (V ⊓ U) inf_le_right (F.res V HVU (V ⊓ U) inf_le_right inf_le_left s))
    = G.res V HVU V HVU (le_refl V) (η.map V HVU s) : by rw [η.2, res_res]⟩

end morphism

structure equiv (F : sheaf_on_opens.{v} X U) (G : sheaf_on_opens.{w} X U) : Type (max u v w) :=
(to_fun : morphism F G)
(inv_fun : morphism G F)
(left_inv : ∀ V HVU s, inv_fun.1 V HVU (to_fun.1 V HVU s) = s)
(right_inv : ∀ V HVU s, to_fun.1 V HVU (inv_fun.1 V HVU s) = s)

namespace equiv

def refl (F : sheaf_on_opens.{v} X U) : equiv F F :=
⟨morphism.id F, morphism.id F, λ _ _ _, rfl, λ _ _ _, rfl⟩

@[simp] lemma refl_apply (F : sheaf_on_opens.{v} X U) (V HV s) :
  (refl F).1.1 V HV s = s := rfl

def symm {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} (e : equiv F G) : equiv G F :=
⟨e.2, e.1, e.4, e.3⟩

def trans {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} {H : sheaf_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) : equiv F H :=
⟨e₂.1.comp e₁.1, e₁.2.comp e₂.2,
λ _ _ _, by rw [morphism.comp_apply, morphism.comp_apply, e₂.3, e₁.3],
λ _ _ _, by rw [morphism.comp_apply, morphism.comp_apply, e₁.4, e₂.4]⟩

@[simp] lemma trans_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{v} X U} {H : sheaf_on_opens.{u₁} X U}
  (e₁ : equiv F G) (e₂ : equiv G H) (V HV s) :
  (e₁.trans e₂).1.1 V HV s = e₂.1.1 V HV (e₁.1.1 V HV s) :=
rfl

def res_subset {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) : equiv (F.res_subset V HVU) (G.res_subset V HVU) :=
⟨e.1.res_subset V HVU, e.2.res_subset V HVU,
λ _ _ _, by rw [morphism.res_subset_apply, morphism.res_subset_apply, e.3],
λ _ _ _, by rw [morphism.res_subset_apply, morphism.res_subset_apply, e.4]⟩

@[simp] lemma res_subset_apply {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G)
  (V : opens X) (HVU : V ≤ U) (W HW s) :
  (e.res_subset V HVU).1.1 W HW s = e.1.1 W (le_trans HW HVU) s :=
rfl

def stalk {F : sheaf_on_opens.{v} X U} {G : sheaf_on_opens.{w} X U} (e : equiv F G) (x : X) (hx : x ∈ U) :
  F.stalk x hx ≃ G.stalk x hx :=
{ to_fun := e.1.stalk x hx,
  inv_fun := e.2.stalk x hx,
  left_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [morphism.stalk_to_stalk, morphism.stalk_to_stalk, e.3],
  right_inv := λ g, stalk.induction_on g $ λ V hxV HVU s, by rw [morphism.stalk_to_stalk, morphism.stalk_to_stalk, e.4] }

end equiv

namespace sheaf_glue

variables {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
variables (φ : Π (i j : I), equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
variables (Hφ1 : ∀ i, φ i i = equiv.refl (res_subset (F i) (S i ⊓ S i) _))
variables (Hφ2 : ∀ i j k,
  ((φ i j).res_subset ((S i) ⊓ (S j) ⊓ (S k)) inf_le_left).trans
    ((φ j k).res_subset ((S i) ⊓ (S j) ⊓ (S k)) (le_inf (le_trans inf_le_left inf_le_right) inf_le_right)) =
  (φ i k).res_subset ((S i) ⊓ (S j) ⊓ (S k)) (le_inf (le_trans inf_le_left inf_le_left) inf_le_right))

@[reducible] def compat (W : opens X) : Type (max u v) :=
{ f : Π i, (F i).eval ((S i) ⊓ W) inf_le_left //
  ∀ i j, (φ i j).1.map ((S i) ⊓ (S j) ⊓ W) inf_le_left
    ((F i).res ((S i) ⊓ W) _ _ (le_trans inf_le_left inf_le_left)
      (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
      (f i)) =
    (F j).res ((S j) ⊓ W) _ _ (le_trans inf_le_left inf_le_right)
      (le_inf (le_trans inf_le_left inf_le_right) inf_le_right)
      (f j) }

def res (U V : opens X) (HVU : V ≤ U) (f : compat S F φ U) : compat S F φ V :=
⟨λ i, (F i).res (S i ⊓ U) _ (S i ⊓ V) _ (inf_le_inf (le_refl _) HVU) (f.1 i), λ i j,
calc  (φ i j).1.map (S i ⊓ S j ⊓ V) inf_le_left
        (res (F i) (S i ⊓ V) inf_le_left (S i ⊓ S j ⊓ V)
          (le_trans inf_le_left inf_le_left)
          (le_inf (le_trans inf_le_left inf_le_left)
              inf_le_right)
          (res (F i) (S i ⊓ U) inf_le_left (S i ⊓ V) inf_le_left
              (inf_le_inf (le_refl _) HVU)
              (f.1 i)) : (F i).eval (S i ⊓ S j ⊓ V) (le_trans _ _))
    = (φ i j).1.map (S i ⊓ S j ⊓ V) inf_le_left
        (res (res_subset (F i) (S i ⊓ S j) inf_le_left) (S i ⊓ S j ⊓ U) inf_le_left
          (S i ⊓ S j ⊓ V)
          inf_le_left
          (inf_le_inf (le_refl _) HVU)
          (res (F i) (S i ⊓ U) inf_le_left (S i ⊓ S j ⊓ U)
            (le_trans inf_le_left inf_le_left)
            (le_inf (le_trans inf_le_left inf_le_left)
                inf_le_right)
            (f.1 i) : (F i).eval (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left))) :
  by rw [res_res_subset, res_res, res_res]
... = (res (F j) (S j ⊓ V) inf_le_left (S i ⊓ S j ⊓ V)
        (le_trans inf_le_left inf_le_right)
        (le_inf (le_trans inf_le_left inf_le_right)
          inf_le_right)
        (res (F j) (S j ⊓ U) inf_le_left (S j ⊓ V) inf_le_left
          (inf_le_inf (le_refl _) HVU)
          (f.1 j)) : (F j).eval (S i ⊓ S j ⊓ V) _) :
  by rw [(φ i j).1.commutes, f.2 i j, res_res_subset, res_res, res_res]⟩

theorem locality (U : opens X) (OC : covering U) (s t : sheaf_glue.compat S F φ U)
  (H : ∀ i : OC.γ, sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) s =
    sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) t) :
  s = t :=
subtype.eq $ funext $ λ i, (F i).locality _ _ _ _ (opens.covering_inf_left U (S i) OC) $ λ j,
by have := H j; simp only [sheaf_glue.res, subtype.mk.inj_eq] at this; exact congr_fun this i

noncomputable def gluing.aux1 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j))
  (i : I) : (F i).eval (S i ⊓ U) inf_le_left :=
(F i).glue _ _ (opens.covering_inf_left U (S i) OC) (λ j, (s j).1 i) $ λ j k,
have h1 : S i ⊓ OC.Uis j ⊓ (S i ⊓ OC.Uis k) ≤ S i ⊓ (OC.Uis j ⊓ OC.Uis k),
by rw [inf_assoc, inf_left_comm (OC.Uis j), ← inf_assoc, inf_idem]; exact le_refl _,
have h2 : S i ⊓ (OC.Uis j ⊓ OC.Uis k) ≤ S i ⊓ OC.Uis j,
from inf_le_inf (le_refl _) inf_le_left,
have h3 : S i ⊓ (OC.Uis j ⊓ OC.Uis k) ≤ S i ⊓ OC.Uis k,
from inf_le_inf (le_refl _) inf_le_right,
have (F i).res (S i ⊓ OC.Uis j) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h2 ((s j).1 i) =
  (F i).res (S i ⊓ OC.Uis k) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h3 ((s k).1 i),
from congr_fun (congr_arg subtype.val (H j k)) i,
calc  _
    = (F i).res (S i ⊓ OC.Uis j) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ _ ((s j).1 i) : rfl
... = (F i).res (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ h1
        ((F i).res (S i ⊓ OC.Uis j) _ (S i ⊓ (OC.Uis j ⊓ OC.Uis k)) inf_le_left h2 ((s j).1 i)) : (res_res _ _ _ _ _ _ _ _ _ _).symm
... = (F i).res (S i ⊓ OC.Uis k) _ ((S i ⊓ OC.Uis j) ⊓ (S i ⊓ OC.Uis k)) _ inf_le_right ((s k).1 i) : by rw [this, res_res]

theorem gluing.aux2 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) (i j : I) :
  (φ i j).1.map (S i ⊓ S j ⊓ U) inf_le_left
      ((F i).res (S i ⊓ U) _ (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_left)
        (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
        (gluing.aux1 S F φ U OC s H i)) =
    (F j).res (S j ⊓ U) _ (S i ⊓ S j ⊓ U) (le_trans inf_le_left inf_le_right)
      (by rw inf_assoc; exact inf_le_right)
      (gluing.aux1 S F φ U OC s H j) :=
(F j).locality _ _ _ _ (opens.covering_inf_left _ _ OC) $ λ k,
calc  ((F j).res_subset (S i ⊓ S j) inf_le_right).res (S i ⊓ S j ⊓ U) inf_le_left ((S i ⊓ S j) ⊓ OC.Uis k) inf_le_left
        (inf_le_inf (le_refl _) (subset_covering k))
        ((φ i j).1.map (S i ⊓ S j ⊓ U) inf_le_left
          ((F i).res (S i ⊓ U) _ (S i ⊓ S j ⊓ U) _
            (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
            (gluing.aux1 S F φ U OC s H i)))
    = (φ i j).1.map (S i ⊓ S j ⊓ OC.Uis k) inf_le_left
        ((F i).res ((opens.covering_inf_left U (S i) OC).Uis k) _ _ (le_trans inf_le_left inf_le_left)
          (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
          ((F i).res (S i ⊓ U) _ ((opens.covering_inf_left U (S i) OC).Uis k) inf_le_left
            (inf_le_inf (le_refl _) (subset_covering k))
            (gluing.aux1 S F φ U OC s H i))) : by rw [← (φ i j).1.commutes, res_res_subset, res_res, res_res]
... = (F j).res ((opens.covering_inf_left U (S j) OC).Uis k) _ ((S i ⊓ S j) ⊓ OC.Uis k) _
        (by rw inf_assoc; exact inf_le_right)
        ((F j).res (S j ⊓ U) _ ((opens.covering_inf_left U (S j) OC).Uis k) inf_le_left
          (inf_le_inf (le_refl _) (subset_covering k))
          (gluing.aux1 S F φ U OC s H j)) : by erw [res_glue, res_glue]; exact (s k).2 i j
... = (F j).res (S i ⊓ S j ⊓ U) _ ((S i ⊓ S j) ⊓ OC.Uis k) _ _
        ((F j).res (S j ⊓ U) _ (S i ⊓ S j ⊓ U) _ _ (gluing.aux1 S F φ U OC s H j)) : by rw [res_res, res_res]; refl

theorem gluing.aux3 (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) (i : OC.γ) :
  sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) ⟨λ i, gluing.aux1 S F φ U OC s H i, gluing.aux2 S F φ U OC s H⟩ = s i :=
subtype.eq $ funext $ λ j, by dsimp only [gluing.aux1, sheaf_glue.res];
change (F j).res _ _ ((opens.covering_inf_left U (S j) OC).Uis i) _ _ _ = _;
erw res_glue

theorem gluing (U : opens X) (OC : covering U) (s : Π i : OC.γ, sheaf_glue.compat S F φ (OC.Uis i))
  (H : ∀ i j : OC.γ, sheaf_glue.res S F φ _ _ inf_le_left (s i) = sheaf_glue.res S F φ _ _ inf_le_right (s j)) :
  ∃ t : sheaf_glue.compat S F φ U, ∀ i : OC.γ, sheaf_glue.res S F φ U (OC.Uis i) (subset_covering i) t = s i :=
⟨⟨λ i, gluing.aux1 S F φ U OC s H i, gluing.aux2 S F φ U OC s H⟩, λ i, gluing.aux3 S F φ U OC s H i⟩

end sheaf_glue

def sheaf_glue {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right)) :
  sheaf_on_opens.{max u v} X (⋃S) :=
{ F := sheaf_glue.compat S F φ,
  res := sheaf_glue.res S F φ,
  Hid := λ U, funext $ λ f, subtype.eq $ funext $ λ i, by dsimp only [sheaf_glue.res, id]; rw res_self,
  Hcomp := λ U V W HWV HVU, funext $ λ f, subtype.eq $ funext $ λ i, by symmetry; apply res_res; exact inf_le_left,
  locality := sheaf_glue.locality S F φ,
  gluing := sheaf_glue.gluing S F φ }

@[simp] lemma sheaf_glue_res_val {I : Type u} (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (U HU V HV HVU s i) : ((sheaf_glue S F φ).res U HU V HV HVU s).1 i = (F i).res _ _ _ _ (inf_le_inf (le_refl _) HVU) (s.1 i) := rfl

def universal_property (I : Type u) (S : I → opens X) (F : Π (i : I), sheaf_on_opens.{v} X (S i))
  (φ : Π i j, equiv ((F i).res_subset ((S i) ⊓ (S j)) inf_le_left) ((F j).res_subset ((S i) ⊓ (S j)) inf_le_right))
  (Hφ1 : ∀ i V HV s, (φ i i).1.1 V HV s = s)
  (Hφ2 : ∀ i j k V HV1 HV2 HV3 s, (φ j k).1.1 V HV1 ((φ i j).1.1 V HV2 s) = (φ i k).1.1 V HV3 s)
  (i : I) :
  equiv (res_subset (sheaf_glue S F φ) (S i) (le_supr S i)) (F i) :=
{ to_fun :=
  { map := λ U H s, (F i).res _ _ _ _ (le_inf H (le_refl _)) (s.1 i),
    commutes := λ U HU V HV HVU s, by rw [res_res, res_res_subset]; dsimp only [res, sheaf_glue, sheaf_glue.res]; rw ← presheaf.Hcomp'; refl },
  inv_fun :=
  { map := λ U H s, ⟨λ j, (φ i j).1.1 (S j ⊓ U) (le_inf (le_trans inf_le_right H) inf_le_left)
        ((F i).res _ _ _ (le_trans inf_le_right H) inf_le_right s),
      λ j k, begin
        have h1 : S j ⊓ S k ⊓ U ≤ S i ⊓ S j := le_inf (le_trans inf_le_right H) (le_trans inf_le_left inf_le_left),
        have h2 : S j ⊓ S k ⊓ U ≤ S i ⊓ S k := le_inf (le_trans inf_le_right H) (le_trans inf_le_left inf_le_right),
        rw [← res_res_subset (F j) _ _ _ _ _ h1, ← (φ i j).1.2, Hφ2 _ _ _ _ _ _ h2, res_res_subset, res_res],
        rw [← res_res_subset (F k) _ _ _ _ _ h2, ← (φ i k).1.2, res_res_subset, res_res],
      end⟩,
    commutes := λ U HU V HV HVU s, subtype.eq $ funext $ λ j, by dsimp only [res_res_subset, sheaf_glue_res_val];
      rw [← res_res_subset (F j), ← (φ i j).1.2, res_res_subset, res_res, res_res] },
  left_inv := λ V HV s, subtype.eq $ funext $ λ j, have _, from s.2 i j, calc
      _ = (φ i j).1.map (S j ⊓ V) (le_inf (le_trans inf_le_right HV) inf_le_left)
            ((F i).res V HV (S j ⊓ V) (le_trans inf_le_right HV) inf_le_right
              ((F i).res (S i ⊓ V) _ V HV (le_inf HV (le_refl _)) (s.1 i))) : rfl
    ... = (φ i j).1.map (S j ⊓ V) _
            ((F i).res (S i ⊓ V) _ (S j ⊓ V) _ _ (s.1 i)) : by rw res_res
    ... = (φ i j).1.map (S j ⊓ V) _
            (((F i).res_subset (S i ⊓ S j) _).res ((S i ⊓ S j) ⊓ V) inf_le_left _ _
              (by rw [inf_assoc, inf_left_comm, inf_of_le_right HV]; exact le_refl _)
              ((F i).res (S i ⊓ V) _ ((S i ⊓ S j) ⊓ V) (le_trans inf_le_left inf_le_left)
                (le_inf (le_trans inf_le_left inf_le_left) inf_le_right)
                (s.1 i))) : by rw [res_res_subset, res_res]
    ... = s.1 j : by rw [(φ i j).1.2, s.2 i j, res_res_subset, res_res, res_self],
  right_inv := λ V HV s, by dsimp only; erw [Hφ1, res_res, res_self] }

end sheaf_on_opens


import pseudo_normed_group.category.ProFiltPseuNormGrpWithTinv

universe variables u

open category_theory
open_locale nnreal

local attribute [instance] type_pow

noncomputable theory

/-- `ProFiltPseuNormGrpWithTinv₁ r` is the bundled category of
`profinitely_filtered_pseudo_normed_group_with_Tinv r`s, with
(this is the `₁`) exhaustive filtrations and strict morphisms.
The objects are filtered abelian groups equipped with an
endomorphism `T⁻¹` with norm at most `r`; see the docstring
of `profinitely_filtered_pseudo_normed_group_with_Tinv` for
more details.
-/
structure ProFiltPseuNormGrpWithTinv₁ (r : ℝ≥0) : Type (u+1) :=
(M : Type u)
[str : profinitely_filtered_pseudo_normed_group_with_Tinv r M]
(exhaustive' : ∀ m : M, ∃ c : ℝ≥0, m ∈ pseudo_normed_group.filtration M c)

namespace ProFiltPseuNormGrpWithTinv₁

variable (r : ℝ≥0)

instance : has_coe_to_sort (ProFiltPseuNormGrpWithTinv₁ r) Type* := ⟨λ M, M.M⟩
instance (M : ProFiltPseuNormGrpWithTinv₁ r) :
  profinitely_filtered_pseudo_normed_group_with_Tinv r M := M.str

lemma exhaustive (M : ProFiltPseuNormGrpWithTinv₁ r) (m : M) : ∃ c : ℝ≥0,
  m ∈ pseudo_normed_group.filtration M c := M.exhaustive' m

instance : large_category (ProFiltPseuNormGrpWithTinv₁.{u} r) :=
{ hom := λ A B, comphaus_filtered_pseudo_normed_group_with_Tinv_hom r A B,
  id := λ A, comphaus_filtered_pseudo_normed_group_with_Tinv_hom.id,
  comp := λ A B C f g, g.comp f } .

def PFPNGT₁_to_PFPNGTₑₗ : (ProFiltPseuNormGrpWithTinv₁.{u} r) ⥤ (ProFiltPseuNormGrpWithTinv.{u} r) :=
{ obj := λ M, ProFiltPseuNormGrpWithTinv.of r M,
  map := λ A B f, f }

instance : concrete_category (ProFiltPseuNormGrpWithTinv₁.{u} r) :=
{ forget :=
  { obj := λ M, M,
    map := λ X Y f, f },
  forget_faithful := ⟨⟩ } .

/-- The "forget the action of T⁻¹" functor on
  profinitely filtered (exhaustive pseudo-)normed groups. -/
def _root_.PFPNGT₁_to_PFPNG₁ₑₗ : (ProFiltPseuNormGrpWithTinv₁.{u} r) ⥤ ProFiltPseuNormGrp₁.{u} :=
{ obj := λ M,
  { M := M,
    exhaustive' := M.exhaustive' },
  map := λ A B f,
  { to_fun := f,
    map_zero' := f.map_zero,
    map_add' := f.map_add,
    strict' := f.strict,
    continuous' := f.continuous' } }

/-- The forgetful functor which takes a profinitely filtered normed group with an action of T⁻¹,
then forgets the action and considered it as a `CompHaus`ly filtered normed group. -/
@[simps]
def _root_.PFPNGT₁_to_CHFPNG₁ₑₗ (r' : ℝ≥0) :
  ProFiltPseuNormGrpWithTinv₁.{u} r' ⥤ CompHausFiltPseuNormGrp₁.{u} :=
PFPNGT₁_to_PFPNG₁ₑₗ r' ⋙ PFPNG₁_to_CHFPNG₁ₑₗ

lemma coe_comp_apply {A B C : ProFiltPseuNormGrpWithTinv₁ r} (f : A ⟶ B) (g : B ⟶ C) (a : A) :
  (f ≫ g) a = g (f a) := rfl

open profinitely_filtered_pseudo_normed_group_with_Tinv

def Tinv_limit_fun_aux {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁ r)
  (x : Σ (c : ℝ≥0), CompHausFiltPseuNormGrp₁.cone_point_type_filt
    ((K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r) ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c) (j : J) :
  (pseudo_normed_group.filtration (K.obj j) x.fst) :=
x.2 j

def Tinv_limit_fun'
  {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r)
  (c : ℝ≥0) (x : CompHausFiltPseuNormGrp₁.cone_point_type_filt
    ((K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r) ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c) :
  (Σ c, CompHausFiltPseuNormGrp₁.cone_point_type_filt
    ((K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r) ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c) :=
⟨r⁻¹ * c, λ j,
  ⟨Tinv (Tinv_limit_fun_aux r K ⟨c,x⟩ j : K.obj j),
    (Tinv_mem_filtration _ _ (Tinv_limit_fun_aux r K ⟨c,x⟩ j).2)⟩,
  begin
    intros i j f,
    ext1,
    show (K.map f) (Tinv _) = Tinv _,
    erw (K.map f).map_Tinv, congr' 1,
    simpa only [functor.comp_map, subtype.val_eq_coe, subtype.ext_iff] using x.2 f,
  end⟩

def Tinv_limit_fun
  {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) :
  ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X) →
    ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X) :=
quotient.map' (λ x, Tinv_limit_fun' r K x.1 x.2)
begin
  rintros x y ⟨c, h₁, h₂, h⟩,
  refine ⟨r⁻¹ * c, mul_le_mul' le_rfl h₁, mul_le_mul' le_rfl h₂, _⟩,
  ext j,
  show Tinv (Tinv_limit_fun_aux r K x j : K.obj j) = Tinv (Tinv_limit_fun_aux r K y j : K.obj j),
  congr' 1,
  rw [subtype.ext_iff, function.funext_iff] at h,
  specialize h j, rwa [subtype.ext_iff] at h,
end

open CompHausFiltPseuNormGrp₁ CompHausFiltPseuNormGrp₁.cone_point_type

lemma Tinv_limit_fun_incl
  {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) (c : ℝ≥0) (x) :
  Tinv_limit_fun r K (incl c x) = incl (r⁻¹ * c) (Tinv_limit_fun' r K c x).2 := rfl

@[simps]
def Tinv_limit_add_monoid_hom
  {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) :
  ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X) →+
    ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X) :=
{ to_fun := Tinv_limit_fun r K,
  map_zero' :=
  begin
    apply quotient.sound',
    dsimp only,
    refine ⟨0, _, le_rfl, _⟩; dsimp only [Tinv_limit_fun'],
    { rw [mul_zero] },
    { ext j, exact Tinv.map_zero }
  end,
  map_add' :=
  begin
    rintros ⟨cx, x⟩ ⟨cy, y⟩,
    show Tinv_limit_fun r K (incl cx x + incl cy y) =
      Tinv_limit_fun r K (incl cx x) + Tinv_limit_fun r K (incl cy y),
    simp only [incl_add_incl, Tinv_limit_fun_incl],
    apply quotient.sound',
    dsimp only,
    refine ⟨_, le_rfl, _, _⟩; simp only [mul_add],
    ext j, refine Tinv.map_add _ _,
  end }

open pseudo_normed_group ProFiltPseuNormGrp₁ CompHausFiltPseuNormGrp₁

lemma Tinv_limit_aux {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r)
  (c : ℝ≥0) (x : ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X))
  (hx : x ∈ filtration (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X c) :
  Tinv_limit_add_monoid_hom r K x ∈
    filtration (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X (r⁻¹ * c) :=
begin
  obtain ⟨x,rfl⟩ := hx,
  dsimp only [Tinv_limit_add_monoid_hom_apply, Tinv_limit_fun_incl],
  exact ⟨_,rfl⟩,
end

-- TODO: break up this proof into pieces.
def Tinv_limit {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) :
  comphaus_filtered_pseudo_normed_group_hom
    ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X)
    ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X) :=
comphaus_filtered_pseudo_normed_group_hom.mk_of_bound (Tinv_limit_add_monoid_hom r K) r⁻¹
begin
  intro c,
  fsplit,
  { apply Tinv_limit_aux },
  { let X := ((ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X),
    let F : filtration X c → filtration X (r⁻¹ * c) := λ x,
      ⟨Tinv_limit_add_monoid_hom r K x, Tinv_limit_aux _ _ _ _ x.2⟩,
    change continuous F,
    let e := filt_homeo (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ _ ⋙ PFPNG₁_to_CHFPNG₁ₑₗ),
    suffices : continuous (e (r⁻¹ * c) ∘ F ∘ (e c).symm), by simpa,
    let I : Π (j : J), comphaus_filtered_pseudo_normed_group_hom (K.obj j) (K.obj j) :=
      λ j, Tinv,
    let G : cone_point_type_filt (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ _ ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c →
      cone_point_type_filt (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ _ ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) (r⁻¹ * c) :=
      λ x, ⟨λ j, ⟨I j (x j).1, _⟩, _⟩,
    rotate,
    { apply Tinv_bound_by, exact (x j).2 },
    { intros i j e,
      have := x.2 e,
      ext,
      dsimp,
      apply_fun (λ e, e.val) at this,
      change _ = I j (x.val j).val,
      rw ← this,
      apply (K.map e).map_Tinv },
    have : continuous G,
    { apply continuous.subtype_mk,
      apply continuous_pi,
      intros i,
      let G1 : cone_point_type_filt (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ _ ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c →
        filtration (K.obj i) c := λ x, x i,
      let G2 : filtration (K.obj i) c → filtration (K.obj i) (r⁻¹ * c) :=
        λ x, ⟨I i x, _⟩,
      swap, { apply Tinv_bound_by, exact x.2 },
      change continuous (G2 ∘ G1),
      apply continuous.comp,
      { apply comphaus_filtered_pseudo_normed_group_hom.continuous, intros x, refl },
      { let G11 : cone_point_type_filt (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ _ ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) c →
          Π j : J, filtration (K.obj j) c := λ x, x,
        let G12 : (Π j : J, filtration (K.obj j) c) → filtration (K.obj i) c := λ x, x i,
        change continuous (G12 ∘ G11),
        apply continuous.comp,
        apply continuous_apply,
        apply continuous_subtype_coe } },
    convert this,
    ext : 1,
    dsimp,
    apply_fun (e (r⁻¹ * c)).symm,
    simp,
    ext, refl },
end

instance {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) :
  profinitely_filtered_pseudo_normed_group_with_Tinv r
    (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X :=
{ Tinv := Tinv_limit r K,
  Tinv_mem_filtration := comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _,
  ..(infer_instance : profinitely_filtered_pseudo_normed_group _) }

def limit_cone {J : Type u} [small_category J] (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) :
  limits.cone K :=
{ X :=
  { M := (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X,
    exhaustive' := (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).X.exhaustive },
  π :=
  { app := λ j,
    { map_Tinv' := begin
        rintro ⟨⟨c,x⟩⟩,
        dsimp [Tinv, Tinv_limit, Tinv_limit_fun, Tinv_limit_fun', Tinv_limit_fun_aux],
        dsimp [ProFiltPseuNormGrp₁.limit_cone, CompHausFiltPseuNormGrp₁.limit_cone],
        change proj (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) j (incl _ _) = _,
        change _ = Tinv (proj _ _ (incl _ _)),
        dsimp [proj],
        simpa,
      end,
      ..(ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).π.app j },
  naturality' := begin
    intros i j e,
    ext1 x,
    have := (ProFiltPseuNormGrp₁.limit_cone (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).π.naturality e,
    apply_fun (λ e, e x) at this,
    exact this,
  end } } .

instance {J : Type u} [small_category J] : creates_limits_of_shape J (PFPNGT₁_to_PFPNG₁ₑₗ r) :=
{ creates_limit := λ K,
  { reflects := λ C hC,
    { lift := λ S,
      { map_Tinv' := begin
          intros x,
          apply ProFiltPseuNormGrp₁.eq_of_π_eq _ hC,
          intros j,
          erw [← ProFiltPseuNormGrp₁.coe_comp_apply, ← ProFiltPseuNormGrp₁.coe_comp_apply,
            hC.fac],
          dsimp,
          change S.π.app _ _ = C.π.app _ _,
          rw [(S.π.app _).map_Tinv, (C.π.app _).map_Tinv],
          congr' 1,
          change _ = ((PFPNGT₁_to_PFPNG₁ₑₗ r).map (C.π.app j)) _,
          erw [← ProFiltPseuNormGrp₁.coe_comp_apply, hC.fac],
          refl,
        end,
        ..hC.lift ((PFPNGT₁_to_PFPNG₁ₑₗ r).map_cone S) },
      fac' := begin
        intros S j,
        ext1 x,
        have := hC.fac ((PFPNGT₁_to_PFPNG₁ₑₗ r).map_cone S) j,
        apply_fun (λ e, e x) at this,
        exact this,
      end,
      uniq' := begin
        intros S m h,
        ext1 x,
        have := hC.uniq ((PFPNGT₁_to_PFPNG₁ₑₗ r).map_cone S) ((PFPNGT₁_to_PFPNG₁ₑₗ r).map m) _,
        apply_fun (λ e, e x) at this,
        exact this,
        { intros j,
          ext y,
          specialize h j,
          apply_fun (λ e, e y) at h,
          exact h },
      end },
    lifts := λ C hC,
    { lifted_cone := limit_cone r K,
      valid_lift :=
        (ProFiltPseuNormGrp₁.limit_cone_is_limit (K ⋙ PFPNGT₁_to_PFPNG₁ₑₗ r)).unique_up_to_iso hC } } }

instance : creates_limits (PFPNGT₁_to_PFPNG₁ₑₗ r) := ⟨⟩

instance (r') : creates_limits (PFPNGT₁_to_CHFPNG₁ₑₗ r') :=
category_theory.comp_creates_limits _ _

def limit_cone_is_limit {J : Type u} [small_category J]
  (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) : limits.is_limit (limit_cone r K) :=
limits.is_limit_of_reflects (PFPNGT₁_to_PFPNG₁ₑₗ r) (ProFiltPseuNormGrp₁.limit_cone_is_limit _)

instance : limits.has_limits (ProFiltPseuNormGrpWithTinv₁.{u} r) :=
has_limits_of_has_limits_creates_limits (PFPNGT₁_to_PFPNG₁ₑₗ r)

lemma is_limit_ext {J : Type u} [small_category J]
  (K : J ⥤ ProFiltPseuNormGrpWithTinv₁.{u} r) (C : limits.cone K)
  (hC : limits.is_limit C) (x y : C.X)
  (h : ∀ j, C.π.app j x = C.π.app j y) : x = y :=
ProFiltPseuNormGrp₁.is_limit_ext _ _ (limits.is_limit_of_preserves (PFPNGT₁_to_PFPNG₁ₑₗ r) hC) _ _ h

section explicit_products

def product {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r) :
  ProFiltPseuNormGrpWithTinv₁.{u} r :=
{ M := Π i, X i,
  -- Why couldn't typeclass inference find this?
  str := profinitely_filtered_pseudo_normed_group_with_Tinv.pi _ _,
  exhaustive' := (ProFiltPseuNormGrp₁.product (λ i, ((PFPNGT₁_to_PFPNG₁ₑₗ r).obj (X i)))).exhaustive' } .

@[simps]
def product.π {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r) (i) :
  product r X ⟶ X i :=
{ map_Tinv' := λ x, rfl,
  ..(ProFiltPseuNormGrp₁.product.π (λ i, (PFPNGT₁_to_PFPNG₁ₑₗ r).obj (X i))) i }

@[simps]
def product.lift {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r)
  (M : ProFiltPseuNormGrpWithTinv₁.{u} r) (f : Π i, M ⟶ X i) : M ⟶ product r X :=
{ map_Tinv' := begin
    intros x,
    ext i,
    change ⇑(product.lift (λ (i : α), (PFPNGT₁_to_PFPNG₁ₑₗ r).obj (X i)) ((PFPNGT₁_to_PFPNG₁ₑₗ r).obj M)
      (λ (i : α), (PFPNGT₁_to_PFPNG₁ₑₗ r).map (f i))) (Tinv x) i = _,
    rw ProFiltPseuNormGrp₁.product.lift_to_fun,
    erw (f i).map_Tinv,
    refl,
  end,
  ..(ProFiltPseuNormGrp₁.product.lift
      (λ i, (PFPNGT₁_to_PFPNG₁ₑₗ r).obj (X i))
      ((PFPNGT₁_to_PFPNG₁ₑₗ r).obj M)
      (λ i, (PFPNGT₁_to_PFPNG₁ₑₗ r).map (f i))) }

@[simp, reassoc]
lemma product.lift_π {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r)
  (M : ProFiltPseuNormGrpWithTinv₁.{u} r) (f : Π i, M ⟶ X i) (i) :
  product.lift r X M f ≫ product.π r X i = f i := by { ext, simpa }

lemma product.lift_unique {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r)
  (M : ProFiltPseuNormGrpWithTinv₁.{u} r) (f : Π i, M ⟶ X i) (g : M ⟶ product r X)
  (hg : ∀ i, g ≫ product.π r X i = f i) : g = product.lift r X M f :=
by { ext, simpa [← hg] }

lemma product.hom_ext {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r)
  (M : ProFiltPseuNormGrpWithTinv₁.{u} r) (g₁ g₂ : M ⟶ product r X)
  (h : ∀ i, g₁ ≫ product.π r X i = g₂ ≫ product.π r X i) : g₁ = g₂ :=
begin
  rw [product.lift_unique r X M _ g₁ (λ i, rfl), product.lift_unique r X M _ g₂ (λ i, rfl)],
  simp [h],
end

def product.fan {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r) :
  limits.fan X := limits.fan.mk (product r X) $ λ b, product.π _ _ _

def product.is_limit {α : Type u} [fintype α] (X : α → ProFiltPseuNormGrpWithTinv₁.{u} r) :
  limits.is_limit (product.fan r X) :=
{ lift := λ M, product.lift _ _ _ $ λ i, M.π.app ⟨i⟩,
  fac' := begin
    rintros S ⟨j⟩,
    dsimp [product.fan],
    simp,
  end,
  uniq' := begin
    intros S m hm,
    apply product.hom_ext,
    intros i,
    dsimp [product.fan] at hm,
    simpa using hm ⟨i⟩,
  end }

end explicit_products

end ProFiltPseuNormGrpWithTinv₁


import homotopy_theory.formal.cofibrations.precofibration_category
import homotopy_theory.formal.cylinder.definitions
import homotopy_theory.formal.cylinder.hep
import homotopy_theory.formal.weak_equivalences.definitions

universes v u

open category_theory
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open homotopy_theory.cylinder

/-

An I-category [Baues, Algebraic homotopy, §I.3] is a precofibration
category C equipped with a cylinder functor satisfying the following
additional axioms.

* C has an initial object and every object of C is cofibrant.

  From the axioms of a precofibration category, it follows that C
  admits coproducts. Because we will need these coproducts in order to
  state a later axiom, we assume that C already comes equipped with a
  choice of coproducts in order to avoid non-definitionally equal
  instances.

* The cylinder functor I preserves pushouts by cofibrations and the
  initial object.

* Cofibrations have the two-sided HEP with respect to the cylinder I.

* The relative cylinder axiom: using the notation ∂I A = A ⊔ A, for
  each cofibration A → X, in the square

    ∂I A → I A
      ↓     ↓
    ∂I X → I X,

  the induced map from the pushout to I X is again a cofibration. (The
  pushout exists because ∂I A → ∂I X is a cofibration.)

* The cylinder I is equipped with an interchange structure.

-/

variables (C : Type u) [category.{v} C] [has_initial_object.{v} C] [has_coproducts.{v} C]

class I_category extends has_cylinder C, preserves_initial_object (I : C ↝ C),
  precofibration_category C, all_objects_cofibrant.{v} C,
  cylinder_has_interchange.{v} C :=
(I_preserves_pushout_by_cof :
  Π {a b a' b'} {f : a ⟶ b} {g : a ⟶ a'} {f' : a' ⟶ b'} {g' : b ⟶ b'},
  is_cof f → Is_pushout f g g' f' → Is_pushout (I &> f) (I &> g) (I &> g') (I &> f'))
(hep_cof : ∀ {a b} (j : a ⟶ b), is_cof j → two_sided_hep j)
(relative_cylinder : ∀ {a b} (j : a ⟶ b) (hj : is_cof j), is_cof $
  (pushout_by_cof (∂I &> j) (ii @> a) (cof_coprod hj hj)).is_pushout.induced
    (ii @> b) (I &> j) (ii.naturality _))

open precofibration_category
open I_category
variables {C}

-- Alternate formulation of the relative cylinder axiom, using an
-- arbitrary pushout rather than the one given by the precofibration
-- category structure.
lemma relative_cylinder' [I_category.{v} C] {a b : C} (j : a ⟶ b) (hj : is_cof j)
  {z} (ii' : ∂I.obj b ⟶ z) (jj' : I.obj a ⟶ z) (po : Is_pushout (∂I &> j) (ii @> a) ii' jj') :
  is_cof (po.induced (ii @> b) (I &> j) (ii.naturality _)) :=
let po' := (pushout_by_cof (∂I &> j) (ii @> a) (cof_coprod hj hj)).is_pushout in
by convert cof_comp (cof_iso (pushout.unique po po')) (relative_cylinder j hj);
   apply po.uniqueness; rw ←category.assoc; simp; refl

end homotopy_theory.cofibrations


/- The aim in this file is to implement a "Maze solver" that, wherever possible,
builds a term of the correct type by composing functions and constants of other types.
Care is taken to avoid infinite loops.
-/
open tactic

meta structure conclusion_and_ingredients :=
(conclusion : expr) (ingredients : list expr)

meta def to_conclusion_and_ingredients : expr → tactic conclusion_and_ingredients
| `(%%a → %%b) := do ci ← to_conclusion_and_ingredients b,
                    return {conclusion := ci.conclusion,
                            ingredients := list.cons a ci.ingredients}
| e            := return {conclusion := e, ingredients := []}

meta def my_tac : expr → expr → tactic unit
| a b := unify a b

meta def my_match_aux (e : expr) : list expr → tactic bool
-- returns whether a given expression unifies with an expression in a list
| []       := return ff
| (a :: l) := (unify a e >> return tt) <|> return ff

meta def my_match : list expr → list expr → tactic bool
-- returns whether a pair of lists contain two expressions which unify
| []        _  := return ff
| (a :: l₁) l₂ := do b₁ ← my_match_aux a l₂,
                    b₂ ← my_match l₁ l₂,
                    return (bor b₁ b₂)

meta def maze_solve : expr → list expr → tactic expr
| goal no_looping :=
  do l ← local_context,
    first $ l.map (λ h,
    do ht ← infer_type h >>= whnf,
      ci ← to_conclusion_and_ingredients ht,
      unify ci.conclusion goal,
      looping ← my_match no_looping ci.ingredients,
      cond looping failed skip,
      list.foldl
        (λ acc e, do acc' ← acc, e' ← e, return (expr.app acc' e'))
        (return h)
        (ci.ingredients.map (λ e,
          maze_solve e (e :: no_looping)))
    )

meta def tactic.interactive.main_tactic : tactic unit :=
do t ← target, solution ← maze_solve t [], exact solution

example {α₁ α₂ : Type} (f : α₁ → α₂) (a : α₁) : α₂ :=
by main_tactic

example {α₁ α₂ α₃ α₄ α₅ : Type}
  (f₁ : α₁ → α₂ → α₅)
  (a₁ : α₁)
  (f₂ : α₃ → α₄ → α₂)
  (a₂ : α₃)
  (f₃ : α₅ → α₃)
  (f₄ : α₂ → α₄)
  (f₅ : α₃ → α₄) : α₅ :=
by main_tactic