import algebra.category.Group.abelian
import algebra.category.Group.limits

import for_mathlib.is_iso_neg
import for_mathlib.homology_iso
import for_mathlib.SemiNormedGroup
import for_mathlib.AddCommGroup.pt

import system_of_complexes.basic
.

noncomputable theory

universe u

open_locale nnreal

open category_theory category_theory.limits opposite

set_option pp.universes true

lemma category_theory.homology.π_eq_zero
  {A B C : Ab.{u}} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) (x)
  (h : ∃ a : A, f a = (kernel_subobject g).arrow x) :
  homology.π f g w x = 0 :=
begin
  rcases h with ⟨a, ha⟩,
  rw [Ab.apply_eq_pt_comp _ a, Ab.apply_eq_pt_comp _ x,
    ← image_subobject_arrow_comp f, ← image_to_kernel_arrow _ _ w,
    ← category.assoc, ← category.assoc] at ha,
  have : (Ab.pt a ≫ factor_thru_image_subobject f) ≫ image_to_kernel f g w = Ab.pt x,
  { rw ← cancel_mono (kernel_subobject g).arrow,
    let e : ℤ ≃+ ulift.{u} ℤ := add_equiv.ulift.symm,
    have he : function.surjective e.to_add_monoid_hom := e.surjective,
    refine (add_monoid_hom.cancel_right he).mp _,
    ext, exact ha, },
  rw [Ab.apply_eq_pt_comp, ← this, category.assoc, homology.condition, comp_zero],
  refl,
end

-- move me, generalize
instance ulift.preorder : preorder (ulift.{u} ℕ) :=
preorder.lift ulift.down

section

variables (C : ℝ≥0ᵒᵖ ⥤ Ab.{u}) (i : ℕ) (f : ulift.{u} ℕ → ℝ≥0)

def shift_sub_id.shift (hf : monotone f) :
  (∏ (λ x, C.obj (op $ f x))) ⟶ (∏ (λ x, C.obj (op $ f x))) :=
pi.lift $ λ x, pi.π _ (⟨x.down+1⟩) ≫ (C.map (hom_of_le $ hf $ by apply nat.le_succ).op)

def shift_sub_id (hf : monotone f) :
  (∏ (λ x, C.obj (op $ f x))) ⟶ (∏ (λ x, C.obj (op $ f x))) :=
shift_sub_id.shift C f hf - 𝟙 _

end

namespace system_of_complexes

variables (C : system_of_complexes.{u}) (i : ℕ) (f : ulift.{u} ℕ → ℝ≥0)

def to_AbH : ℝ≥0ᵒᵖ ⥤ Ab := C.to_Ab ⋙ homology_functor _ _ i

variables [∀ c i, complete_space (C c i)] [∀ c i, separated_space (C c i)]

lemma shift_eq_zero (hf : monotone f) {k K c₀ : ℝ≥0} [fact (1 ≤ k)]
  (hC : C.is_bounded_exact k K i c₀)
  (hc₀ : ∀ j, c₀ ≤ f j) (hk : ∀ j, k * f j ≤ f (j+1)) :
  shift_sub_id.shift (C.to_AbH i) f hf = 0 :=
begin
  apply category_theory.limits.limit.hom_ext, intros j,
  rw [zero_comp, shift_sub_id.shift, to_AbH, limit.lift_π, fan.mk_π_app,
    functor.comp_map, homology_functor_map],
  convert comp_zero using 2,
  apply homology.ext,
  rw [comp_zero, homology.π_map],
  apply AddCommGroup.ext, intros x,
  let d := homological_complex.d_from (C.to_Ab.obj (op (f (j.1 + 1)))) i,
  let x' : C (f (j.1+1)) i := (kernel_subobject d).arrow x,
  have aux : fact (c₀ ≤ f j.1) := ⟨hc₀ _⟩,
  haveI : fact (k * f j.1 ≤ f (j.1+1)) := ⟨hk _⟩,
  obtain ⟨_, _, rfl, rfl, y, hy⟩ := hC (f j.1) aux i le_rfl (res x'),
  have hdx' : C.d i (i+1) x' = 0,
  { show ((kernel_subobject d).arrow ≫ ((C.to_Ab.obj (op (f (j.1+1)))).d i (i+1))) x = 0,
    suffices : (kernel_subobject d).arrow ≫ (C.to_Ab.obj (op (f (j.1+1)))).d i (i+1) = 0,
    { rw this, refl },
    rw [← (C.to_Ab.obj (op (f (j.1+1)))).d_from_comp_X_next_iso, ← category.assoc,
      kernel_subobject_arrow_comp, zero_comp],
    dsimp, refl, },
  rw [res_res, d_res, hdx', map_zero, norm_zero, mul_zero,
    ← coe_nnnorm, ← nnreal.coe_zero, nnreal.coe_le_coe, le_zero_iff,
    nnnorm_eq_zero, sub_eq_zero] at hy,
  apply category_theory.homology.π_eq_zero,
  cases i,
  { refine ⟨0, _⟩,
    rw d_eq_zero at hy, swap, { dec_trivial },
    rw [kernel_subobject_map_arrow_apply, homological_complex.hom.sq_from_left,
      homological_complex.d_to_eq_zero, AddCommGroup.zero_apply],
    { exact hy.symm }, { rw cochain_complex.prev_nat_zero, dsimp, dec_trivial }, },
  { refine ⟨((C.to_Ab.obj (op (f j.1))).X_prev_iso _).inv y, _⟩,
    { dsimp, refl },
    rw [← comp_apply, ← comp_apply, homological_complex.X_prev_iso_comp_d_to,
      kernel_subobject_map_arrow],
    exact hy.symm, },
end

lemma shift_sub_id_is_iso (hf : monotone f) {k K c₀ : ℝ≥0} [fact (1 ≤ k)]
  (hC : C.is_bounded_exact k K i c₀)
  (hc₀ : ∀ j, c₀ ≤ f j) (hk : ∀ j, k * f j ≤ f (j+1)) :
  is_iso (shift_sub_id (C.to_AbH i) f hf) :=
begin
  rw [shift_sub_id, shift_eq_zero C i f hf hC hc₀ hk, zero_sub, is_iso_neg_iff],
  apply_instance
end

end system_of_complexes


import Lean
import IIT.Util

open Lean
open Elab
open Meta

namespace Lean

namespace Meta

def inversion (mVar : MVarId) (fVar : FVarId) (names : Array Name) :
  MetaM (Array Name × Array FVarId × MVarId) :=
withMVarContext mVar do
  checkNotAssigned mVar `inversion
  let target ← getMVarType mVar
  -- Get Prop sorted fields
  let truesgs ← cases (← mkFreshExprMVar $ mkConst `True).mvarId! fVar
  unless truesgs.size == 1 do throwTacticEx `inversion mVar "indices must determine constructor uniquely"
  let trueMVar := truesgs[0].mvarId
  let fields   := truesgs[0].fields
  let fields ← withMVarContext trueMVar do
    let fields ← fields.mapM fun fv => do
       let fv ← whnf fv
       inferType fv
    fields.filterM fun e => do return (← getLevel e).isZero
  -- Prove fields
  let mut mVar       := mVar
  let mut fieldFVars := #[]
  let mut names      := names
  for (e : Expr) in fields do
    let (names',fieldFVar, mVar') ← withMVarContext mVar do
      let fieldMVar ← mkFreshExprMVar e
      let fsgs ← cases fieldMVar.mvarId! fVar
      assumption fsgs[0].mvarId
      let name := if names.size > 0 then names[0] else Name.anonymous
      let fMVar ← mkFreshExprMVar $ mkForall name BinderInfo.default e target
      assignExprMVar mVar $ mkApp fMVar fieldMVar
      let (fieldFVar, mVar') ← intro fMVar.mvarId! name
      pure (names[1:], fieldFVar, mVar')
    names      := names'
    mVar       := mVar'
    fieldFVars := fieldFVars.push fieldFVar
  return (names[1:], fieldFVars, mVar)

end Meta

open Tactic

syntax (name := inversion) "inversion" (colGt ident)+ ("with" (colGt ident)+)? : tactic
@[tactic inversion] def elabInversion : Tactic
| `(tactic|inversion $fVars* with $names*) => do
  let mut names := names.map getNameOfIdent'
  for f in fVars do
    let rnames ← withMainContext do
      let fvarId ← getFVarId f
      let (rnames, _, mVar) ← Meta.inversion (← getMainGoal) (← getFVarId f) names
      replaceMainGoal [mVar]
      pure rnames
    names := rnames
| `(tactic|inversion $fVars*) => do
  forEachVar fVars fun mVar fVar => do
  let (_, _, mVar) ← Meta.inversion mVar fVar #[]
  return mVar
| _ => throwUnsupportedSyntax

end Lean

/-
-- Examples
inductive Foo : Nat → Nat → Prop
| mk1 : Foo 5 3
| mk2 : (y : Foo 9 8) → (z : Foo 13 25) → Foo 1 2

example (n : Nat) (x : Foo 1 n) (A : Type) (p : (y : Foo 9 8) → A) : A := by
  inversion x with y z
  exact p y

example (n : Nat) (x : Foo (2 - 1) n) (A : Type) (p : (y : Foo 9 8) → A) : A := by
  skip
  inversion x
  apply p
  assumption
-/


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.equiv
import Mathlib.data.vector2
import Mathlib.PostPort

universes u u_1 w v

namespace Mathlib

namespace d_array

protected instance inhabited {n : ℕ} {α : fin n → Type u} [(i : fin n) → Inhabited (α i)] : Inhabited (d_array n α) :=
  { default := mk fun (_x : fin n) => Inhabited.default }

end d_array

namespace array

protected instance inhabited {n : ℕ} {α : Type u_1} [Inhabited α] : Inhabited (array n α) :=
  d_array.inhabited

theorem to_list_of_heq {n₁ : ℕ} {n₂ : ℕ} {α : Type u_1} {a₁ : array n₁ α} {a₂ : array n₂ α} (hn : n₁ = n₂) (ha : a₁ == a₂) : to_list a₁ = to_list a₂ := sorry

/- rev_list -/

theorem rev_list_reverse_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i ≤ n) (t : List α) : list.reverse_core (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) t =
  d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h t := sorry

@[simp] theorem rev_list_reverse {n : ℕ} {α : Type u} {a : array n α} : list.reverse (rev_list a) = to_list a :=
  rev_list_reverse_aux n d_array.iterate._proof_1 []

@[simp] theorem to_list_reverse {n : ℕ} {α : Type u} {a : array n α} : list.reverse (to_list a) = rev_list a := sorry

/- mem -/

theorem mem.def {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ a ↔ ∃ (i : fin n), read a i = v :=
  iff.rfl

theorem mem_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} {i : ℕ} (h : i ≤ n) : (∃ (j : fin n), ↑j < i ∧ read a j = v) ↔
  v ∈ d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h [] := sorry

@[simp] theorem mem_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ rev_list a ↔ v ∈ a := sorry

@[simp] theorem mem_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : v ∈ to_list a ↔ v ∈ a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (v ∈ to_list a ↔ v ∈ a)) (Eq.symm rev_list_reverse)))
    (iff.trans list.mem_reverse mem_rev_list)

/- foldr -/

theorem rev_list_foldr_aux {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α} {i : ℕ} (h : i ≤ n) : list.foldr f b (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) =
  d_array.iterate_aux a (fun (_x : fin n) => f) i h b := sorry

theorem rev_list_foldr {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α} : list.foldr f b (rev_list a) = foldl a b f :=
  rev_list_foldr_aux d_array.iterate._proof_1

/- foldl -/

theorem to_list_foldl {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : β → α → β} {a : array n α} : list.foldl f b (to_list a) = foldl a b (function.swap f) := sorry

/- length -/

theorem rev_list_length_aux {n : ℕ} {α : Type u} (a : array n α) (i : ℕ) (h : i ≤ n) : list.length (d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h []) = i := sorry

@[simp] theorem rev_list_length {n : ℕ} {α : Type u} (a : array n α) : list.length (rev_list a) = n :=
  rev_list_length_aux a n d_array.iterate._proof_1

@[simp] theorem to_list_length {n : ℕ} {α : Type u} (a : array n α) : list.length (to_list a) = n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (list.length (to_list a) = n)) (Eq.symm rev_list_reverse)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (list.length (list.reverse (rev_list a)) = n)) (list.length_reverse (rev_list a))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (list.length (rev_list a) = n)) (rev_list_length a))) (Eq.refl n)))

/- nth -/

theorem to_list_nth_le_aux {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (ih : i < n) (j : ℕ) {jh : j ≤ n} {t : List α} {h' : i < list.length (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh t)} : (∀ (k : ℕ) (tl : k < list.length t), j + k = i → list.nth_le t k tl = read a { val := i, property := ih }) →
  list.nth_le (d_array.rev_iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) j jh t) i h' =
    read a { val := i, property := ih } := sorry

theorem to_list_nth_le {n : ℕ} {α : Type u} {a : array n α} (i : ℕ) (h : i < n) (h' : i < list.length (to_list a)) : list.nth_le (to_list a) i h' = read a { val := i, property := h } :=
  to_list_nth_le_aux i h n fun (k : ℕ) (tl : k < list.length []) => absurd tl (nat.not_lt_zero k)

@[simp] theorem to_list_nth_le' {n : ℕ} {α : Type u} (a : array n α) (i : fin n) (h' : ↑i < list.length (to_list a)) : list.nth_le (to_list a) (↑i) h' = read a i := sorry

theorem to_list_nth {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} : list.nth (to_list a) i = some v ↔ ∃ (h : i < n), read a { val := i, property := h } = v := sorry

theorem write_to_list {n : ℕ} {α : Type u} {a : array n α} {i : fin n} {v : α} : to_list (write a i v) = list.update_nth (to_list a) (↑i) v := sorry

/- enum -/

theorem mem_to_list_enum {n : ℕ} {α : Type u} {a : array n α} {i : ℕ} {v : α} : (i, v) ∈ list.enum (to_list a) ↔ ∃ (h : i < n), read a { val := i, property := h } = v := sorry

/- to_array -/

@[simp] theorem to_list_to_array {n : ℕ} {α : Type u} (a : array n α) : list.to_array (to_list a) == a := sorry

@[simp] theorem to_array_to_list {α : Type u} (l : List α) : to_list (list.to_array l) = l :=
  list.ext_le (to_list_length (list.to_array l))
    fun (n : ℕ) (h1 : n < list.length (to_list (list.to_array l))) (h2 : n < list.length l) => to_list_nth_le n h2 h1

/- push_back -/

theorem push_back_rev_list_aux {n : ℕ} {α : Type u} {v : α} {a : array n α} (i : ℕ) (h : i ≤ n + 1) (h' : i ≤ n) : d_array.iterate_aux (push_back a v) (fun (_x : fin (n + 1)) (_x : α) (_y : List α) => _x :: _y) i h [] =
  d_array.iterate_aux a (fun (_x : fin n) (_x : α) (_y : List α) => _x :: _y) i h' [] := sorry

@[simp] theorem push_back_rev_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : rev_list (push_back a v) = v :: rev_list a := sorry

@[simp] theorem push_back_to_list {n : ℕ} {α : Type u} {v : α} {a : array n α} : to_list (push_back a v) = to_list a ++ [v] := sorry

/- foreach -/

@[simp] theorem read_foreach {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : fin n → α → β} {a : array n α} : read (foreach a f) i = f i (read a i) :=
  rfl

/- map -/

theorem read_map {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : α → β} {a : array n α} : read (map a f) i = f (read a i) :=
  read_foreach

/- map₂ -/

@[simp] theorem read_map₂ {n : ℕ} {α : Type u} {i : fin n} {f : α → α → α} {a₁ : array n α} {a₂ : array n α} : read (map₂ f a₁ a₂) i = f (read a₁ i) (read a₂ i) :=
  read_foreach

end array

namespace equiv

/-- The natural equivalence between length-`n` heterogeneous arrays
and dependent functions from `fin n`. -/
def d_array_equiv_fin {n : ℕ} (α : fin n → Type u_1) : d_array n α ≃ ((i : fin n) → α i) :=
  mk d_array.read d_array.mk sorry sorry

/-- The natural equivalence between length-`n` arrays and functions from `fin n`. -/
def array_equiv_fin (n : ℕ) (α : Type u_1) : array n α ≃ (fin n → α) :=
  d_array_equiv_fin fun (_x : fin n) => α

/-- The natural equivalence between length-`n` vectors and functions from `fin n`. -/
def vector_equiv_fin (α : Type u_1) (n : ℕ) : vector α n ≃ (fin n → α) :=
  mk vector.nth vector.of_fn vector.of_fn_nth sorry

/-- The natural equivalence between length-`n` vectors and length-`n` arrays. -/
def vector_equiv_array (α : Type u_1) (n : ℕ) : vector α n ≃ array n α :=
  equiv.trans (vector_equiv_fin α n) (equiv.symm (array_equiv_fin n α))

end equiv

namespace array

protected instance traversable {n : ℕ} : traversable (array n) :=
  equiv.traversable fun (α : Type u_1) => equiv.vector_equiv_array α n

protected instance is_lawful_traversable {n : ℕ} : is_lawful_traversable (array n) :=
  equiv.is_lawful_traversable fun (α : Type u_1) => equiv.vector_equiv_array α n


import .data data.real.basic
import group_theory.subgroup
/-!
This file contains the default class-predicate-collections for the humanproof writeup.

-/

namespace hp.writeup

meta def prop_patterns : tactic (pattern_table Statement) := do
      ps ← list.mmap id [
            pattern_table.entry.of_pexpr ```(λ α β (f : α → β) (A : set α), @set.inj_on α β f A) (λ es, do [α, β, f, A] ← pure es, pure $ Statement.ofRun $ (run.Math f ++ run.Text "is injective on" ++ run.Math A) )
      ],
      pure $ pattern_table.of_list ps

/-- The writeup_table contains all of the information for producing writeup phrases about definitions and propositions.

There are three tables
- `cpct` is the class predicate collection table
- `lct` is the local-constant table. Suppose that `x : G` where `G` is a local constant in the context.
  Then the `lct` is used to determine a class predicate for `x`. An example is that if we have `[group G]`, then
  `x` should be introduced as "let x be an element of G". But if `[metric_space G]`, then we would have "let x be a point in G".
- `pt` is the proposition table. It maps types of expression to Statements. An example is `f is continuous`.

   -/
meta structure writeup_table :=
(cpct : pattern_table (expr → cpc))
(lct : dict name (expr → cp)) -- eg `subgroup ↦ λ x,  "element of " ++ x.type` -
(pt : pattern_table Statement)

namespace writeup_table

  meta def join : writeup_table → writeup_table → writeup_table
  | ⟨c₁,l₁,p₁⟩ ⟨c₂, l₂, p₂⟩ := ⟨c₁ ++ c₂, dict.merge l₁ l₂, p₁ ++ p₂⟩

  meta instance : has_union writeup_table := ⟨join⟩

  meta def of_cpct : pattern_table (expr → cpc) → writeup_table
  | cpct := {cpct := cpct, lct := ∅, pt := ∅}

end writeup_table

meta def cp.relational_noun (singular : string) (plural : option string) (preposition : run) (rhs : expr) :=
  let plural := (singular ++ "s") <| plural in
  cp.ClassNoun
    (run.Text singular ++ preposition ++ run.Math rhs)
    (run.Text plural   ++ preposition ++ run.Math rhs)

/-- Takes an `x : n α` to   -/
meta def mk_adjective (n : name) (text : option string) : tactic (pattern_table.entry (expr → cpc)) := do
  f ← tactic.mk_const n,
  y ← tactic.infer_type f,
  (ps, b) ← pure $ telescope.of_pis y,
  guard (ps.length > 0),
  subject_index ← telescope.find_index (λ b, b.is_explicit) ps,
  pattern ← pure $ to_pexpr $ telescope.reverse_beta ps f,
  text ← pure $ n.to_string <| text,
  pattern_table.entry.of_pexpr pattern $ λ es, do subject ← es.nth subject_index, pure $ λ _, cpc.mk [subject] $ [cp.Adjective text]

meta def mk_classnoun (n : name) (singular plural : option string) : tactic (pattern_table.entry (expr → cpc)) := do
  f ← tactic.mk_const n,
  singular ← pure $ n.to_string <| singular,
  plural ← pure $ (singular ++ "s") <| plural,
  y ← tactic.infer_type f,
  (ps, b) ← pure $ telescope.of_pis y,
  guard (ps.length > 0),
  subject_index ← telescope.find_index (λ b, b.is_explicit) ps,
  pattern ← pure $ to_pexpr $ telescope.reverse_beta ps f,
  pattern_table.entry.of_pexpr pattern $ λ es, do subject ← es.nth subject_index, pure $ λ _, cpc.mk [subject] $ [cp.ClassNoun singular plural]

meta def mk_noun (n : name) (singular plural : option string) : tactic (pattern_table.entry (expr → cpc)):= do
  f ← tactic.mk_const n,
  singular ← pure $ n.to_string <| singular,
  plural ← pure $ (singular ++ "s") <| plural,
  y ← tactic.infer_type f,
  (ps, b) ← pure $ telescope.of_pis y,
  guard (ps.length > 0),
  pattern ← pure $ to_pexpr $ telescope.reverse_beta ps f,
  pattern_table.entry.of_pexpr pattern $ λ es, do pure $ λ x, cpc.mk [x] $ [cp.ClassNoun singular plural]

/-- Takes an `x : n α` to the cpc "let [x] be a [foo] [of] [α]".
Where `foo` is the singular / plural string and `[of]` is the preposition string

For example ``mk_relational_noun `subgroup "subgroup" "subgroups" "of"`` will convert a `H : subgroup G` to "let H be a subgroup of G".
 -/
meta def mk_relational_noun (n : name) (singular plural : option string) (preposition : string) : tactic (pattern_table.entry (expr → cpc)) := do
  f ← tactic.mk_const n,
  singular ← pure $ n.to_string <| singular,
  plural ← pure $ (singular ++ "s") <| plural,
  y ← tactic.infer_type f,
  (ps, b) ← pure $ telescope.of_pis y,
  guard (ps.length > 0),
  object_index ← telescope.find_index (λ b, b.is_explicit) ps,
  pattern ← pure $ to_pexpr $ telescope.reverse_beta ps f,
  pattern_table.entry.of_pexpr pattern $ λ es, do object ← es.nth object_index, pure $ λ subject, cpc.mk [subject] $ [cp.relational_noun singular plural preposition object]

/-- Takes an `_ : n x α` to the cpc "let [x] be a [foo] [of] [α]".
Where `foo` is the singular / plural string and `[of]` is the preposition string
 -/
meta def mk_relational_noun_from_proof (n : name) (singular plural : option string) (preposition : string) : tactic (pattern_table.entry (expr → cpc)) := do
  f ← tactic.mk_const n,
  singular ← pure $ n.to_string <| singular,
  plural ← pure $ (singular ++ "s") <| plural,
  y ← tactic.infer_type f,
  (ps, b) ← pure $ telescope.of_pis y,
  guard (ps.length > 0),
  object_index :: subject_index :: _ ← pure $ telescope.find_indexes (λ b, b.is_explicit) ps,
  pattern ← pure $ to_pexpr $ telescope.reverse_beta ps f,
  pattern_table.entry.of_pexpr pattern $ λ es, do object ← es.nth object_index, subject ← es.nth subject_index, pure $ λ _, cpc.mk [subject] $ [cp.relational_noun singular plural preposition object]

-- def mk_relational_noun_from_proof (n : name) (singular plural : option string) (preposition : string)

meta def default_cpct : list (tactic (pattern_table.entry (expr → cpc))):= [
  -- mk_classnoun `group none none,
  -- mk_classnoun `metric_space (some "metric space") none,
  -- mk_classnoun `met_space (some "metric space") none,
  -- mk_classnoun `monoid none none,
  mk_relational_noun `subgroup none none "of",
  -- pattern_table.entry.of_pexpr ```(λ α [g : group α], @subgroup α g) (λ es, do [α] ← pure es, pure $ λ x, cpc.mk [x] $ [cp.simple_RelationalNoun "subgroup" "of" α]),
  mk_adjective `subgroup.normal (some "normal"),
  -- pattern_table.entry.of_pexpr ```(λ α [g : group α] H, @subgroup.normal α g H) (λ es, do [α, g, H] ← pure es, pure $ λ x, cpc.mk [H] $ [cp.Adjective "normal"]),

  mk_relational_noun `list none none "of",
  -- pattern_table.entry.of_pexpr ```(λ α, list α)   (λ es, do [α] ← pure es, pure $ λ x, cpc.mk [x] $ [cp.simple_RelationalNoun "list" "of" α]),
  mk_relational_noun `set none none "of",
  -- pattern_table.entry.of_pexpr ```(λ α, set α)    (λ es, do [α] ← pure es, pure $ λ x, cpc.mk [x] $ [cp.simple_RelationalNoun "set" "on" α]),
  mk_noun `nat (some "natural number") none,
  -- pattern_table.entry.of_pexpr ```(nat) (λ _, pure $ λ e, cpc.mk [e] [cp.ClassNoun "natural number" "natural numbers"]),
  -- pattern_table.entry.of_pexpr ```(λ (α) (x : α) (X : set α), X x) (λ es, do
  --   [α,x,X] ← pure es,
  --   r : run ← pure $ (run.Text "∈") ++ run.Math X, -- [todo] need a way of printing '∈ X' as an expression.
  --   pure $ λ _, cpc.mk [x] $ [cp.SymbolicPostfix $ r]),
  pattern_table.entry.of_pexpr ```(λ (α β) (x : α) (X : β) (hm: has_mem α β), @has_mem.mem α β hm x X) (λ es, do
    [α,β,x,X,hm] ← pure es,
    r : run ← pure $ (run.Text "∈") ++ run.Math X, -- [todo] need a way of printing '∈ X' as an expression.
    pure $ λ _, cpc.mk [x] $ [cp.SymbolicPostfix $ r]),

  pattern_table.entry.of_pexpr ```(λ (x : ℝ), x > (0 : ℝ)) (λ es, do
    -- tactic.trace "hello this matched",
    [x] ← pure es,
    r : run ← pure $ (run.Text ">") ++ run.Math `(0 : ℝ),
    pure $ λ _, cpc.mk [x] $ [cp.SymbolicPostfix $ r]),
  -- pattern_table.entry.of_pexpr ```(λ α [m : metric_space α] (X : set α), @is_open α m X) (λ es, do [α,ms,  X] ← pure es, pure $ λ x, cpc.mk [X] $ [cp.Adjective "open"]),
  pattern_table.entry.of_pexpr ```(λ α [m : met_space α] (X : set α), @examples.is_open α m X) (λ es, do [α,ms,  X] ← pure es, pure $ λ x, cpc.mk [X] $ [cp.Adjective "open"])
]

meta def default_lct : dict name (expr → cp) :=
dict.insert `semigroup (cp.relational_noun "element" none "of") $ ∅

meta def default_writeup_table : tactic writeup_table := do
  cpctt ← list.achoose id default_cpct, -- [todo] in production make this mcollect.
  cpct ← pure $ pattern_table.of_list cpctt,
  lct ← pure $ default_lct,
  ppt ← prop_patterns,
  pure ⟨cpct, lct, ppt⟩

-- meta def adjectives_from_names : list name → tactic (writeup_table)
-- | ns :=

/- [todo]:
  user should be able to specify their own natural langauge translatoins without having to
  edit the above tables. However I need to think about the cleanest way to do this so that the
  user attributes don't look bad.

  eg something like:
  ```
  @[writeup (f is "injective on" A)]
  def set.inj_on f A : Prop := ...
  ```

  Note that `is` is a special verb object that changes the conjugation
  based on where the statement appears or how many 'f's the system is talking about.
-/

open lean.parser

meta def word : lean.parser string := lean.parser.pexpr >>= λ p, of_tactic $ tactic.eval_pexpr string $ p
@[user_attribute]
meta def writeup_classnoun_attr : user_attribute writeup_table (option string × option string) :=
{ name := `classnoun
, descr := "This will be written as an classnoun in natural language writeups."
, parser := ((pure prod.mk) <*> (optional word) <*> (optional word))
, cache_cfg :=
  { mk_cache := (λ ns, do
    ps ← ns.mmap (λ n, do
      (s,p) ← user_attribute.get_param writeup_classnoun_attr n,
      mk_classnoun n s p
    ),
    pure $ writeup_table.mk (pattern_table.of_list ps) ∅ ∅)
  , dependencies := []
  }
}

@[user_attribute]
meta def writeup_adjective_attr : user_attribute writeup_table (option string) :=
{ name := `adjective
, descr := "Define the given predicate as an adjective. The last argument to the predicate is interpreted as the subject."
, parser := (optional word)
, cache_cfg :=
  { mk_cache := (λ ns, do
    ps ← ns.mmap (λ n, do
      s ← user_attribute.get_param writeup_adjective_attr n,
      mk_adjective n s
    ),
    pure $ writeup_table.mk (pattern_table.of_list ps) ∅ ∅)
  , dependencies := []
  }
}

@[user_attribute]
meta def writeup_relational_noun_attr : user_attribute writeup_table (((option string) × (option string)) × (option string)) :=
{ name := `relational_noun
, descr := "Define the given predicate as an relational_noun. The last argument to the predicate is interpreted as the subject."
, parser := (pure prod.mk) <*> ((pure prod.mk) <*> (optional word) <*> (optional word)) <*> (optional word)
, cache_cfg :=
  { mk_cache := (λ ns, do
    ps ← ns.mmap (λ n, do
      ((s,p), prep) ← user_attribute.get_param writeup_relational_noun_attr n,
      prep ← pure $ "of" <| prep,
      mk_relational_noun n s p prep
    ),
    pure $ writeup_table.mk (pattern_table.of_list ps) ∅ ∅)
  , dependencies := []
  }
}

@[user_attribute]
meta def writeup_relational_noun_predicate_attr : user_attribute writeup_table (((option string) × (option string)) × (option string)) :=
{ name := `relational_noun_predicate
, descr := "Define the given predicate as an relational_noun. The last argument to the predicate is interpreted as the subject."
, parser := (pure prod.mk) <*> ((pure prod.mk) <*> (optional word) <*> (optional word)) <*> (optional word)
, cache_cfg :=
  { mk_cache := (λ ns, do
    ps ← ns.mmap (λ n, do
      ((s,p), prep) ← user_attribute.get_param writeup_relational_noun_predicate_attr n,
      prep ← pure $ "of" <| prep,
      mk_relational_noun_from_proof n s p prep
    ),
    pure $ writeup_table.mk (pattern_table.of_list ps) ∅ ∅)
  , dependencies := []
  }
}

attribute [classnoun "group" "groups"] group
attribute [classnoun "monoid" "monoids"] monoid

meta def get_writeup_table : tactic writeup_table := do
  wt ← default_writeup_table,
  wts ← list.mmap id $ [ user_attribute.get_cache $ writeup_classnoun_attr
                        , user_attribute.get_cache $ writeup_adjective_attr
                        , user_attribute.get_cache $ writeup_relational_noun_attr
                        , user_attribute.get_cache $ writeup_relational_noun_predicate_attr],
  wt ← pure $ list.foldl (∪) wt wts,
  pure $ wt
  -- [todo] optimise by using 'dependencies' of attributes and daisy-chaining together the writeuptable.

meta def get_prop_writeup : expr → tactic Statement | P  := do
  wt ← get_writeup_table,
  as ← wt.pt.get P,
  -- tactic.trace "get_prop_writeup",
  -- tactic.trace wt.pt,
  -- tactic.trace $ Statement.to_string <$> as,
  list.apick pure as

end hp.writeup


example (P Q : Prop) : P → (Q → P) :=
begin
intros p q,
exact p,
end


/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Std.Data.RBMap.WF

/-!
# Path operations; `modify` and `alter`

This develops the necessary theorems to construct the `modify` and `alter` functions on `RBSet`
using path operations for in-place modification of an `RBTree`.
-/

namespace Std

namespace RBNode
open RBColor

attribute [simp] Path.fill

/-! ## path balance -/

/-- Asserts that property `p` holds on the root of the tree, if any. -/
def OnRoot (p : α → Prop) : RBNode α → Prop
  | nil => True
  | node _ _ x _ => p x

/--
Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary.
-/
def setRoot (v : α) : RBNode α → RBNode α
  | nil => node red nil v nil
  | node c a _ b => node c a v b

/--
Auxiliary definition for `zoom_ins`: set the root of the tree to `v`, creating a node if necessary.
-/
def delRoot : RBNode α → RBNode α
  | nil => nil
  | node _ a _ b => a.append b

namespace Path

/-- Same as `fill` but taking its arguments in a pair for easier composition with `zoom`. -/
@[inline] def fill' : RBNode α × Path α → RBNode α := fun (t, path) => path.fill t

theorem zoom_fill' (cut : α → Ordering) (t : RBNode α) (path : Path α) :
    fill' (zoom cut t path) = path.fill t := by
  induction t generalizing path with
  | nil => rfl
  | node _ _ _ _ iha ihb => unfold zoom; split <;> [apply iha, apply ihb, rfl]

theorem zoom_fill (H : zoom cut t path = (t', path')) : path.fill t = path'.fill t' :=
  (H ▸ zoom_fill' cut t path).symm

theorem insertNew_eq_insert (h : zoom (cmp v) t = (nil, path)) :
    path.insertNew v = (t.insert cmp v).setBlack :=
  insert_setBlack .. ▸ (zoom_ins h).symm

theorem zoom_del {t : RBNode α} :
    t.zoom cut path = (t', path') →
    path.del (t.del cut) (match t with | node c .. => c | _ => red) =
    path'.del t'.delRoot (match t' with | node c .. => c | _ => red) := by
  unfold RBNode.del; split <;> simp [zoom]
  · intro | rfl, rfl => rfl
  · next c a y b =>
    split
    · have IH := @zoom_del (t := a)
      match a with
      | nil => intro | rfl => rfl
      | node black .. | node red .. => apply IH
    · have IH := @zoom_del (t := b)
      match b with
      | nil => intro | rfl => rfl
      | node black .. | node red .. => apply IH
    · intro | rfl => rfl

variable (c₀ : RBColor) (n₀ : Nat) in
/--
The balance invariant for a path. `path.Balanced c₀ n₀ c n` means that `path` is a red-black tree
with balance invariant `c₀, n₀`, but it has a "hole" where a tree with balance invariant `c, n`
has been removed. The defining property is `Balanced.fill`: if `path.Balanced c₀ n₀ c n` and you
fill the hole with a tree satisfying `t.Balanced c n`, then `(path.fill t).Balanced c₀ n₀` .
-/
protected inductive Balanced : Path α → RBColor → Nat → Prop where
  /-- The root of the tree is `c₀, n₀`-balanced by assumption. -/
  | protected root : Path.root.Balanced c₀ n₀
  /-- Descend into the left subtree of a red node. -/
  | redL : Balanced y black n → parent.Balanced red n →
    (Path.left red parent v y).Balanced black n
  /-- Descend into the right subtree of a red node. -/
  | redR : Balanced x black n → parent.Balanced red n →
    (Path.right red x v parent).Balanced black n
  /-- Descend into the left subtree of a black node. -/
  | blackL : Balanced y c₂ n → parent.Balanced black (n + 1) →
    (Path.left black parent v y).Balanced c₁ n
  /-- Descend into the right subtree of a black node. -/
  | blackR : Balanced x c₁ n → parent.Balanced black (n + 1) →
    (Path.right black x v parent).Balanced c₂ n

/--
The defining property of a balanced path: If `path` is a `c₀,n₀` tree with a `c,n` hole,
then filling the hole with a `c,n` tree yields a `c₀,n₀` tree.
-/
protected theorem Balanced.fill {path : Path α} {t} :
    path.Balanced c₀ n₀ c n → t.Balanced c n → (path.fill t).Balanced c₀ n₀
  | .root, h => h
  | .redL hb H, ha | .redR ha H, hb => H.fill (.red ha hb)
  | .blackL hb H, ha | .blackR ha H, hb => H.fill (.black ha hb)

protected theorem _root_.Std.RBNode.Balanced.zoom : t.Balanced c n → path.Balanced c₀ n₀ c n →
    zoom cut t path = (t', path') → ∃ c n, t'.Balanced c n ∧ path'.Balanced c₀ n₀ c n
  | .nil, hp => fun e => by cases e; exact ⟨_, _, .nil, hp⟩
  | .red ha hb, hp => by
    unfold zoom; split
    · exact ha.zoom (.redL hb hp)
    · exact hb.zoom (.redR ha hp)
    · intro e; cases e; exact ⟨_, _, .red ha hb, hp⟩
  | .black ha hb, hp => by
    unfold zoom; split
    · exact ha.zoom (.blackL hb hp)
    · exact hb.zoom (.blackR ha hp)
    · intro e; cases e; exact ⟨_, _, .black ha hb, hp⟩

theorem ins_eq_fill {path : Path α} {t : RBNode α} :
    path.Balanced c₀ n₀ c n → t.Balanced c n → path.ins t = (path.fill t).setBlack
  | .root, h => rfl
  | .redL hb H, ha | .redR ha H, hb => by unfold ins; exact ins_eq_fill H (.red ha hb)
  | .blackL hb H, ha => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance1_eq ha]
  | .blackR ha H, hb => by rw [ins, fill, ← ins_eq_fill H (.black ha hb), balance2_eq hb]

protected theorem Balanced.ins {path : Path α}
    (hp : path.Balanced c₀ n₀ c n) (ht : t.RedRed (c = red) n) :
    ∃ n, (path.ins t).Balanced black n := by
  induction hp generalizing t with
  | root => exact ht.setBlack
  | redL hr hp ih => match ht with
    | .balanced .nil => exact ih (.balanced (.red .nil hr))
    | .balanced (.red ha hb) => exact ih (.redred rfl (.red ha hb) hr)
    | .balanced (.black ha hb) => exact ih (.balanced (.red (.black ha hb) hr))
  | redR hl hp ih => match ht with
    | .balanced .nil => exact ih (.balanced (.red hl .nil))
    | .balanced (.red ha hb) => exact ih (.redred rfl hl (.red ha hb))
    | .balanced (.black ha hb) => exact ih (.balanced (.red hl (.black ha hb)))
  | blackL hr hp ih => exact have ⟨c, h⟩ := ht.balance1 hr; ih (.balanced h)
  | blackR hl hp ih => exact have ⟨c, h⟩ := ht.balance2 hl; ih (.balanced h)

protected theorem Balanced.insertNew {path : Path α} (H : path.Balanced c n black 0) :
    ∃ n, (path.insertNew v).Balanced black n := H.ins (.balanced (.red .nil .nil))

protected theorem Balanced.insert {path : Path α} (hp : path.Balanced c₀ n₀ c n) :
    t.Balanced c n → ∃ c n, (path.insert t v).Balanced c n
  | .nil => ⟨_, hp.insertNew⟩
  | .red ha hb => ⟨_, _, hp.fill (.red ha hb)⟩
  | .black ha hb => ⟨_, _, hp.fill (.black ha hb)⟩

theorem zoom_insert {path : Path α} {t : RBNode α} (ht : t.Balanced c n)
    (H : zoom (cmp v) t = (t', path)) :
    (path.insert t' v).setBlack = (t.insert cmp v).setBlack := by
  have ⟨_, _, ht', hp'⟩ := ht.zoom .root H
  cases ht' with simp [insert]
  | nil => simp [insertNew_eq_insert H, setBlack_idem]
  | red hl hr => rw [← ins_eq_fill hp' (.red hl hr), insert_setBlack]; exact (zoom_ins H).symm
  | black hl hr => rw [← ins_eq_fill hp' (.black hl hr), insert_setBlack]; exact (zoom_ins H).symm

protected theorem Balanced.del {path : Path α}
    (hp : path.Balanced c₀ n₀ c n) (ht : t.DelProp c' n) (hc : c = black → c' ≠ red) :
    ∃ n, (path.del t c').Balanced black n := by
  induction hp generalizing t c' with
  | root => match c', ht with
    | red, ⟨_, h⟩ | black, ⟨_, _, h⟩ => exact h.setBlack
  | @redL _ n _ _ hb hp ih => match c', n, ht with
    | red, _, _ => cases hc rfl rfl
    | black, _, ⟨_, rfl, ha⟩ => exact ih ((hb.balLeft ha).of_false (fun.)) (fun.)
  | @redR _ n _ _ ha hp ih => match c', n, ht with
    | red, _, _ => cases hc rfl rfl
    | black, _, ⟨_, rfl, hb⟩ => exact ih ((ha.balRight hb).of_false (fun.)) (fun.)
  | @blackL _ _ n _ _ _ hb hp ih => match c', n, ht with
    | red, _, ⟨_, ha⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ (fun.)
    | black, _, ⟨_, rfl, ha⟩ => exact ih ⟨_, rfl, (hb.balLeft ha).imp fun _ => ⟨⟩⟩ (fun.)
  | @blackR _ _ n _ _ _ ha hp ih =>  match c', n, ht with
    | red, _, ⟨_, hb⟩ => exact ih ⟨_, rfl, .redred ⟨⟩ ha hb⟩ (fun.)
    | black, _, ⟨_, rfl, hb⟩ => exact ih ⟨_, rfl, (ha.balRight hb).imp fun _ => ⟨⟩⟩ (fun.)

/-- Asserts that `p` holds on all elements to the left of the hole. -/
def AllL (p : α → Prop) : Path α → Prop
  | .root => True
  | .left _ parent _ _ => parent.AllL p
  | .right _ a x parent => a.All p ∧ p x ∧ parent.AllL p

/-- Asserts that `p` holds on all elements to the right of the hole. -/
def AllR (p : α → Prop) : Path α → Prop
  | .root => True
  | .left _ parent x b => parent.AllR p ∧ p x ∧ b.All p
  | .right _ _ _ parent => parent.AllR p

/--
The property of a path returned by `t.zoom cut`. Each of the parents visited along the path have
the appropriate ordering relation to the cut.
-/
def Zoomed (cut : α → Ordering) : Path α → Prop
  | .root => True
  | .left _ parent x _ => cut x = .lt ∧ parent.Zoomed cut
  | .right _ _ x parent => cut x = .gt ∧ parent.Zoomed cut

theorem zoom_zoomed₁ (e : zoom cut t path = (t', path')) : t'.OnRoot (cut · = .eq) :=
  match t, e with
  | nil, rfl => trivial
  | node .., e => by
    revert e; unfold zoom; split
    · exact zoom_zoomed₁
    · exact zoom_zoomed₁
    · next H => intro e; cases e; exact H

theorem zoom_zoomed₂ (e : zoom cut t path = (t', path'))
    (hp : path.Zoomed cut) : path'.Zoomed cut :=
  match t, e with
  | nil, rfl => hp
  | node .., e => by
    revert e; unfold zoom; split
    · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩
    · next h => exact fun e => zoom_zoomed₂ e ⟨h, hp⟩
    · intro e; cases e; exact hp

/--
`path.RootOrdered cmp v` is true if `v` would be able to fit into the hole
without violating the ordering invariant.
-/
def RootOrdered (cmp : α → α → Ordering) : Path α → α → Prop
  | .root, _ => True
  | .left _ parent x _, v => cmpLT cmp v x ∧ parent.RootOrdered cmp v
  | .right _ _ x parent, v => cmpLT cmp x v ∧ parent.RootOrdered cmp v

theorem _root_.Std.RBNode.cmpEq.RootOrdered_congr {cmp : α → α → Ordering} (h : cmpEq cmp a b) :
    ∀ {t : Path α}, t.RootOrdered cmp a ↔ t.RootOrdered cmp b
  | .root => .rfl
  | .left .. => and_congr h.lt_congr_left h.RootOrdered_congr
  | .right .. => and_congr h.lt_congr_right h.RootOrdered_congr

theorem Zoomed.toRootOrdered {cmp} :
    ∀ {path : Path α}, path.Zoomed (cmp v) → path.RootOrdered cmp v
  | .root, h => h
  | .left .., ⟨h, hp⟩ => ⟨⟨h⟩, hp.toRootOrdered⟩
  | .right .., ⟨h, hp⟩ => ⟨⟨OrientedCmp.cmp_eq_gt.1 h⟩, hp.toRootOrdered⟩

/-- The ordering invariant for a `Path`. -/
def Ordered (cmp : α → α → Ordering) : Path α → Prop
  | .root => True
  | .left _ parent x b => parent.Ordered cmp ∧
    b.All (cmpLT cmp x ·) ∧ parent.RootOrdered cmp x ∧
    b.All (parent.RootOrdered cmp) ∧ b.Ordered cmp
  | .right _ a x parent => parent.Ordered cmp ∧
    a.All (cmpLT cmp · x) ∧ parent.RootOrdered cmp x ∧
    a.All (parent.RootOrdered cmp) ∧ a.Ordered cmp

protected theorem Ordered.fill : ∀ {path : Path α} {t},
    (path.fill t).Ordered cmp ↔ path.Ordered cmp ∧ t.Ordered cmp ∧ t.All (path.RootOrdered cmp)
  | .root, _ => ⟨fun H => ⟨⟨⟩, H, .trivial ⟨⟩⟩, (·.2.1)⟩
  | .left .., _ => by
    simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and]
    exact ⟨
      fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩,
      fun ⟨⟨hp, xb, xp, bp, hb⟩, ha, ⟨ax, ap⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩
  | .right .., _ => by
    simp [Ordered.fill, RBNode.Ordered, Ordered, RootOrdered, All_and]
    exact ⟨
      fun ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩ => ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩,
      fun ⟨⟨hp, ax, xp, ap, ha⟩, hb, ⟨xb, bp⟩⟩ => ⟨hp, ⟨ax, xb, ha, hb⟩, ⟨xp, ap, bp⟩⟩⟩

theorem _root_.Std.RBNode.Ordered.zoom' {t : RBNode α} {path : Path α}
    (ht : t.Ordered cmp) (hp : path.Ordered cmp) (tp : t.All (path.RootOrdered cmp))
    (pz : path.Zoomed cut) (eq : t.zoom cut path = (t', path')) :
    t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut :=
  have ⟨hp', ht', tp'⟩ := Ordered.fill.1 <| zoom_fill eq ▸ Ordered.fill.2 ⟨hp, ht, tp⟩
  ⟨ht', hp', tp', zoom_zoomed₂ eq pz⟩

theorem _root_.Std.RBNode.Ordered.zoom {t : RBNode α}
    (ht : t.Ordered cmp) (eq : t.zoom cut = (t', path')) :
    t'.Ordered cmp ∧ path'.Ordered cmp ∧ t'.All (path'.RootOrdered cmp) ∧ path'.Zoomed cut :=
  ht.zoom' (path := .root) ⟨⟩ (.trivial ⟨⟩) ⟨⟩ eq

theorem Ordered.ins : ∀ {path : Path α} {t : RBNode α},
    t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.ins t).Ordered cmp
  | .root, t, ht, _, _ => Ordered.setBlack.2 ht
  | .left red parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold ins; have ⟨ax, ap⟩ := All_and.1 H; exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .right red a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold ins; have ⟨xb, bp⟩ := All_and.1 H; exact hp.ins ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .left black parent x b, a, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold ins; have ⟨ax, ap⟩ := All_and.1 H
    exact hp.ins (ha.balance1 ax xb hb) (balance1_All.2 ⟨xp, ap, bp⟩)
  | .right black a x parent, b, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold ins; have ⟨xb, bp⟩ := All_and.1 H
    exact hp.ins (ha.balance2 ax xb hb) (balance2_All.2 ⟨xp, ap, bp⟩)

theorem Ordered.insertNew {path : Path α} (hp : path.Ordered cmp) (vp : path.RootOrdered cmp v) :
    (path.insertNew v).Ordered cmp :=
  hp.ins ⟨⟨⟩, ⟨⟩, ⟨⟩, ⟨⟩⟩ ⟨vp, ⟨⟩, ⟨⟩⟩

theorem Ordered.insert : ∀ {path : Path α} {t : RBNode α},
    path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → path.RootOrdered cmp v →
    t.OnRoot (cmpEq cmp v) → (path.insert t v).Ordered cmp
  | _, nil, hp, _, _, vp, _ => hp.insertNew vp
  | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩, vp, xv => Ordered.fill.2
    ⟨hp, ⟨ax.imp xv.lt_congr_right.2, xb.imp xv.lt_congr_left.2, ha, hb⟩, vp, ap, bp⟩

theorem Ordered.del : ∀ {path : Path α} {t : RBNode α} {c},
    t.Ordered cmp → path.Ordered cmp → t.All (path.RootOrdered cmp) → (path.del t c).Ordered cmp
  | .root, t, _, ht, _, _ => Ordered.setBlack.2 ht
  | .left _ parent x b, a, red, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold del; have ⟨ax, ap⟩ := All_and.1 H; exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .right _ a x parent, b, red, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold del; have ⟨xb, bp⟩ := All_and.1 H; exact hp.del ⟨ax, xb, ha, hb⟩ ⟨xp, ap, bp⟩
  | .left _ parent x b, a, black, ha, ⟨hp, xb, xp, bp, hb⟩, H => by
    unfold del; have ⟨ax, ap⟩ := All_and.1 H
    exact hp.del (ha.balLeft ax xb hb) (ap.balLeft xp bp)
  | .right _ a x parent, b, black, hb, ⟨hp, ax, xp, ap, ha⟩, H => by
    unfold del; have ⟨xb, bp⟩ := All_and.1 H
    exact hp.del (ha.balRight ax xb hb) (ap.balRight xp bp)

theorem Ordered.erase : ∀ {path : Path α} {t : RBNode α},
    path.Ordered cmp → t.Ordered cmp → t.All (path.RootOrdered cmp) → (path.erase t).Ordered cmp
  | _, nil, hp, ht, tp => Ordered.fill.2 ⟨hp, ht, tp⟩
  | _, node .., hp, ⟨ax, xb, ha, hb⟩, ⟨_, ap, bp⟩ => hp.del (ha.append ax xb hb) (ap.append bp)

end Path

/-! ## alter -/

/-- The `alter` function preserves the ordering invariants. -/
protected theorem Ordered.alter {t : RBNode α}
    (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x →
      p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x))
    (h : t.Ordered cmp) : (alter cut f t).Ordered cmp := by
  simp [alter]; split
  · next path eq =>
    have ⟨_, hp, _, _⟩ := h.zoom eq; split
    · exact h
    · next hf => exact hp.insertNew (H eq hf).1
  · next path eq =>
    have ⟨⟨ax, xb, ha, hb⟩, hp, ⟨_, ap, bp⟩, _⟩ := h.zoom eq; split
    · exact hp.del (ha.append ax xb hb) (ap.append bp)
    · next hf =>
      have ⟨yp, xy⟩ := H eq hf
      apply Path.Ordered.fill.2
      exact ⟨hp, ⟨ax.imp xy.lt_congr_right.2, xb.imp xy.lt_congr_left.2, ha, hb⟩, yp, ap, bp⟩

/-- The `alter` function preserves the balance invariants. -/
protected theorem Balanced.alter {t : RBNode α}
    (h : t.Balanced c n) : ∃ c n, (t.alter cut f).Balanced c n := by
  simp [alter]; split
  · next path eq =>
    split
    · exact ⟨_, _, h⟩
    · have ⟨_, _, .nil, h⟩ := h.zoom .root eq
      exact ⟨_, h.insertNew⟩
  · next path eq =>
    have ⟨_, _, h, hp⟩ := h.zoom .root eq
    split
    · match h with
      | .red ha hb => exact ⟨_, hp.del ((ha.append hb).of_false (· rfl rfl)) (fun.)⟩
      | .black ha hb => exact ⟨_, hp.del ⟨_, rfl, (ha.append hb).imp fun _ => ⟨⟩⟩ (fun.)⟩
    · match h with
      | .red ha hb => exact ⟨_, _, hp.fill (.red ha hb)⟩
      | .black ha hb => exact ⟨_, _, hp.fill (.black ha hb)⟩

theorem modify_eq_alter (t : RBNode α) : t.modify cut f = t.alter cut (.map f) := by
  simp [modify, alter]; split <;> simp [Option.map]

/-- The `modify` function preserves the ordering invariants. -/
protected theorem Ordered.modify {t : RBNode α}
    (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x)
    (h : t.Ordered cmp) : (modify cut f t).Ordered cmp :=
  modify_eq_alter _ ▸ h.alter @fun
    | _, .node .., _, eq, rfl => by
      rw [eq] at H; exact ⟨H.RootOrdered_congr.2 (h.zoom eq).2.2.1.1, H⟩

/-- The `modify` function preserves the balance invariants. -/
protected theorem Balanced.modify {t : RBNode α}
    (h : t.Balanced c n) : ∃ c n, (t.modify cut f).Balanced c n := modify_eq_alter _ ▸ h.alter

theorem WF.alter {t : RBNode α}
    (H : ∀ {x t' p}, t.zoom cut = (t', p) → f t'.root? = some x →
      p.RootOrdered cmp x ∧ t'.OnRoot (cmpEq cmp x))
    (h : WF cmp t) : WF cmp (alter cut f t) :=
  let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.alter H, h₂.alter⟩

theorem WF.modify {t : RBNode α}
    (H : (t.zoom cut).1.OnRoot fun x => cmpEq cmp (f x) x)
    (h : WF cmp t) : WF cmp (t.modify cut f) :=
  let ⟨h₁, _, _, h₂⟩ := h.out; WF_iff.2 ⟨h₁.modify H, h₂.modify⟩

theorem find?_eq_zoom : ∀ {t : RBNode α} (p := .root), t.find? cut = (t.zoom cut p).1.root?
  | .nil, _ => rfl
  | .node .., _ => by unfold find? zoom; split <;> [apply find?_eq_zoom, apply find?_eq_zoom, rfl]

end RBNode

namespace RBSet
open RBNode

/--
A sufficient condition for `ModifyWF` is that the new element compares equal to the original.
-/
theorem ModifyWF.of_eq {t : RBSet α cmp}
    (H : ∀ {x}, RBNode.find? cut t.val = some x → cmpEq cmp (f x) x) : ModifyWF t cut f := by
  refine ⟨.modify ?_ t.2⟩
  revert H; rw [find?_eq_zoom]
  (cases (t.1.zoom cut).1 <;> intro H) <;> [trivial, exact H rfl]

end RBSet

namespace RBMap

/--
`O(log n)`. In-place replace the corresponding to key `k`.
This takes the element out of the tree while `f` runs,
so it uses the element linearly if `t` is unshared.
-/
def modify (t : RBMap α β cmp) (k : α) (f : β → β) : RBMap α β cmp :=
  @RBSet.modifyP _ _ t (cmp k ·.1) (fun (a, b) => (a, f b))
    (.of_eq fun _ => ⟨OrientedCmp.cmp_refl (cmp := byKey Prod.fst cmp)⟩)

/-- Auxiliary definition for `alter`. -/
def alter.adapt (k : α) (f : Option β → Option β) : Option (α × β) → Option (α × β)
  | none =>
    match f none with
    | none => none
    | some v => some (k, v)
  | some (k', v') =>
    match f (some v') with
    | none => none
    | some v => some (k', v)

/--
`O(log n)`. `alterP cut f t` simultaneously handles inserting, erasing and replacing an element
using a function `f : Option α → Option α`. It is passed the result of `t.findP? cut`
and can either return `none` to remove the element or `some a` to replace/insert
the element with `a` (which must have the same ordering properties as the original element).

The element is used linearly if `t` is unshared.

The `AlterWF` assumption is required because `f` may change
the ordering properties of the element, which would break the invariants.
-/
@[specialize] def alter
    (t : RBMap α β cmp) (k : α) (f : Option β → Option β) : RBMap α β cmp := by
  refine @RBSet.alterP _ _ t (cmp k ·.1) (alter.adapt k f) ⟨.alter (@fun _ t' p eq => ?_) t.2⟩
  cases t' <;> simp [alter.adapt, RBNode.root?] <;> split <;> intro h <;> cases h
  · exact ⟨(t.2.out.1.zoom eq).2.2.2.toRootOrdered, ⟨⟩⟩
  · refine ⟨(?a).RootOrdered_congr.2 (t.2.out.1.zoom eq).2.2.1.1, ?a⟩
    exact ⟨OrientedCmp.cmp_refl (cmp := byKey Prod.fst cmp)⟩

end RBMap


import o_minimal.sheaf.constants

namespace o_minimal

variables {R : Type*} {S : struc R}
variables {X : Type*} [definable_sheaf S X]
variables {X' : Type*} [definable_sheaf S X']
variables {X'' : Type*} [definable_sheaf S X'']
variables {L K : Def S}

lemma definable_fun {f : X → X'} :
  definable S f ↔
  ∀ (K : Def S) (φ : K → X), definable_sheaf.definable φ → definable_sheaf.definable (f ∘ φ) :=
begin
  -- TODO: Merge with following proof?
  split; intro H,
  { cases H,
    intros K φ hφ,
    exact H K K (λ k, (k, φ k)) ⟨def_fun.id, hφ⟩ },
  { refine ⟨λ M L φ hφ, _⟩,
    exact H _ _ hφ.2 }
end

lemma definable_yoneda {f : K → X} :
  definable S f ↔ definable_sheaf.definable f :=
begin
  split; intro H,
  { cases H,
    -- This proof is a bit mysterious, related to the perhaps
    -- odd definition of `definable S`.
    -- Really we could use any `Def S` as the first argument
    -- to `H`; `K` is just one we have handy here.
    exact H K K (λ k, (k, k)) ⟨def_fun.id, def_fun.id⟩ },
  { refine ⟨λ M L φ hφ, _⟩,
    exact definable_sheaf.definable_precomp ⟨_, hφ.2⟩ f H }
end

lemma Def.definable_iff_def_fun {f : L → K} : definable S f ↔ def_fun S f :=
definable_yoneda

lemma Def.definable_iff_def_set {s : set K} : definable S s ↔ def_set S s :=
definable_yoneda

instance self.definable_sheaf : definable_sheaf S R :=
definable_sheaf.rep

section

variables (S)

class definable_rep (W : Type*) [has_coordinates R W]
  extends is_definable S W, definable_sheaf S W :=
(eq : ∀ (K : Def S) (f : K → W), definable_sheaf.definable f ↔ def_fun S f)

instance self.definable_rep : definable_rep S R := { eq := λ K f, iff.rfl }

instance Def.definable_rep {K : Def S} : definable_rep S K :=
{ eq := λ _ f, iff.rfl }

variables (W : Type*) [has_coordinates R W] [is_definable S W]

def as_Def : Def S :=
{ ambdim := _,
  to_set := coordinate_image R W,
  is_definable := def_fun.coords.range }

-- TODO: Should we adjust the definition of `has_coordinates`
-- to make this computable?
noncomputable def equiv_Def : W ≃ as_Def S W :=
equiv.of_bijective (set.range_factorization (@coords R W _))
⟨λ w₁ w₂ h, @injective_coords R W _ w₁ w₂ (subtype.ext_iff.mp h),
 set.surjective_onto_range⟩

variables {S W}

lemma def_fun_equiv_Def : def_fun S (equiv_Def S W) :=
def_fun_subtype_mk def_fun.coords _

lemma def_fun_equiv_Def_symm : def_fun S (equiv_Def S W).symm :=
begin
  refine def_fun.cancel def_fun_equiv_Def (equiv.injective _) _,
  simpa using def_fun.id
end

end

variables {Y : Type*} [has_coordinates R Y] [definable_rep S Y]
variables {Y' : Type*} [has_coordinates R Y'] [definable_rep S Y']
variables {Z : Type*} [has_coordinates R Z] [definable_rep S Z]

lemma definable_iff_from_Def {f : Y → X} :
  definable S f ↔ definable_sheaf.definable (f ∘ (equiv_Def S Y).symm) :=
begin
  rw definable_fun,
  split; intro H,
  { apply H,
    rw definable_rep.eq,
    apply def_fun_equiv_Def_symm },
  { intros K φ hφ,
    rw definable_rep.eq at hφ,
    have : def_fun S (equiv_Def S Y ∘ φ) := def_fun_equiv_Def.comp hφ,
    convert definable_sheaf.definable_precomp ⟨equiv_Def S Y ∘ φ, this⟩ _ H,
    change φ = ((equiv_Def S Y).symm ∘ equiv_Def S Y) ∘ φ,
    simp }
end

lemma definable_iff_def_fun {f : Y → Z} :
  definable S f ↔ def_fun S f :=
begin
  rw definable_iff_from_Def,
  rw definable_rep.eq,
  split; intro H,
  { convert H.comp def_fun_equiv_Def,
    change f = f ∘ _,
    simp },
  { exact H.comp def_fun_equiv_Def_symm }
end

lemma definable_iff_def_set {s : set Y} :
  definable S s ↔ def_set S s :=
begin
  rw definable_iff_from_Def,
  split; intro H,
  { convert def_fun_equiv_Def.preimage H,
    change s = s ∘ _,
    simp },
  { exact def_fun_equiv_Def_symm.preimage H }
end

-- Yoneda embedding commutes with products
instance prod.definable_rep : definable_rep S (Y × Y') :=
begin
  refine { eq := λ K f, _ },
  change _ ∧ _ ↔ _,
  rw [definable_rep.eq, definable_rep.eq],
  split; intro H,
  { convert def_fun.prod' H.1 H.2,
    ext; refl },
  { exact ⟨def_fun.fst.comp H, def_fun.snd.comp H⟩ }
end

lemma definable_iff_uncurry {f : X → X' → X''} :
  definable S f ↔ definable S (function.uncurry f) :=
⟨λ H, definable.uncurry.app H, λ H, definable.curry.app H⟩

lemma definable_iff_def_fun₂ {f : Y → Y' → Z} :
  definable S f ↔ def_fun S (function.uncurry f) :=
definable_iff_uncurry.trans definable_iff_def_fun

lemma definable_iff_def_rel₂ {s : Y → Y' → Prop} :
  definable S s ↔ def_set S {p : Y × Y' | s p.1 p.2} :=
definable_iff_uncurry.trans definable_iff_def_set

-- TODO: Does this hold more generally than for representable codomains?
lemma definable_of_graph {f : X → Y} (df : definable S {p : X × Y | f p.1 = p.2}) :
  definable S f :=
begin
  rw definable_fun,
  intros K φ hφ,
  rw ←definable_yoneda at hφ,
  rw definable_rep.eq,
  change def_set S ({p : X × Y | f p.1 = p.2} ∘ (λ (q : K × Y), (φ q.1, q.2))),
  rw ←definable_iff_def_set,
  refine df.comp _,
  -- TODO: use more convenient lemmas
  begin [defin]
    intro q,
    app, app, exact definable.prod_mk.definable _,
    app, exact hφ.definable _,
    app, exact definable.fst.definable _, var,
    app, exact definable.snd.definable _, var
  end
end

def subtype.definable_rep {s : set Y} (ds : definable S s) : definable_rep S s :=
{ eq := λ K f, (definable_rep.eq K (subtype.val ∘ f)).trans def_fun_subtype_iff.symm,
  .. is_definable.subtype (definable_iff_def_set.mp ds) }

end o_minimal


def n: ℕ := 1

lemma p: 0 = 0 := eq.refl 0
lemma s: "Hello Lean!" = "Hello Lean!" := eq.refl "Hello Lean!"

lemma s1: tt = tt := eq.refl tt

/-def p' : 0 = 0 := eq.refl 1-/

theorem s' : 0 = 0 := eq.refl 0

lemma oeqo : 1 = 1 := eq.refl 1

lemma teqt: 2 = 1 + 1 := eq.refl (1+1)

lemma h : "Hello" = "He" ++ "llo" := rfl
lemma pp : 3*3 + 4*4 = 5*5 := rfl
lemma tthof : 2 + 3 = 1 + 4 := rfl
lemma hpleqhl : "Hello " ++ "Lean!" = "Hello Lean!" := rfl

#check "Hello" = "Hello"


import algebra.homology.additive
import category_theory.abelian.basic
import category_theory.limits.constructions.epi_mono

open category_theory category_theory.limits

namespace homological_complex

universes w' w v v' u u'

variables {V : Type u} [category.{v} V] {J : Type w} [category.{w'} J]
variables {ι : Type u'} {c : complex_shape ι}

--move this
lemma congr_f [has_zero_morphisms V] {X Y : homological_complex V c} {f g : X ⟶ Y}
  (h : f = g) (x : ι) : f.f x = g.f x := congr_arg _ h

section limits

noncomputable theory

variables [has_zero_morphisms V] (F : J ⥤ homological_complex V c)

include F

@[simps]
def lift_of_is_limit_eval (t : cone F) (h : ∀ i, is_limit $ (eval V c i).map_cone t) (s : cone F) :
  s.X ⟶ t.X :=
begin
  refine ⟨λ i, is_limit.lift (h i) ⟨_, _⟩, _⟩,
  refine ⟨λ x, (s.π.app x).f i, _⟩,
  { intros x y f, dsimp, rw [category.id_comp, ← comp_f], congr, exact (cone.w s f).symm },
  { intros i j r,
    apply (h j).hom_ext,
    intro x,
    dsimp,
    rw [category.assoc, category.assoc],
    erw [← (t.π.app x).comm, (h j).fac _ x, (h i).fac_assoc _ x, (s.π.app x).comm],
    refl }
end
.
/-- `eval` jointly reflects (actually creates) limits -/
def is_limit_of_is_limit_eval (t : cone F) (h : ∀ i, is_limit $ (eval V c i).map_cone t) :
  is_limit t :=
{ lift := lift_of_is_limit_eval F t h,
  fac' := by { intros s j, ext, dsimp, exact (h x).fac _ j },
  uniq' := by { intros s m w, ext, apply (h x).hom_ext,
    intro j, dsimp, erw (h x).fac _ j, exact congr_f (w j) x } }

variables [∀ i : ι, has_limit (F ⋙ eval V c i)]

@[simps]
def limit_complex : homological_complex V c :=
begin
  refine ⟨λ i, limit (F ⋙ eval V c i), λ i j, limit.lift _ ⟨_, _⟩, _, _⟩,
  refine ⟨λ k, limit.π (F ⋙ eval V c i) k ≫ (F.obj k).d i j, _⟩,
  { intros x y f,
    dsimp,
    rw [category.id_comp, category.assoc, ← hom.comm, ← category.assoc],
    congr' 1,
    exact (limit.w _ _).symm },
  { intros i j r,
    ext k,
    rw [limit.lift_π, zero_comp],
    dsimp only,
    rw [(F.obj k).shape _ _ r, comp_zero] },
  { intros i j k r r', ext, simp }
end
.
@[simps]
def limit_complex_cone : cone F :=
{ X := limit_complex F,
  π := { app := λ x, { f := λ i, limit.π (F ⋙ eval V c i) x },
    naturality' := λ X Y f, by { ext, dsimp, rw category.id_comp, exact (limit.w _ _).symm } } }
.
def limit_complex_cone_is_limit : is_limit (limit_complex_cone F) :=
is_limit_of_is_limit_eval _ _
begin
  intro i,
  apply (limit.is_limit _).of_iso_limit,
  exact cones.ext (iso.refl _) (λ _, (category.id_comp _).symm),
end

def eval_map_limit_complex_cone (i : ι) :
  (eval V c i).map_cone (limit_complex_cone F) ≅ (get_limit_cone (F ⋙ eval V c i)).1 :=
cones.ext (iso.refl _) (λ j, by { dsimp, simpa })

instance (i : ι) : preserves_limit F (eval V c i) :=
preserves_limit_of_preserves_limit_cone (limit_complex_cone_is_limit F)
  ((limit.is_limit _).of_iso_limit (eval_map_limit_complex_cone F i).symm)

instance : has_limit F :=
⟨⟨⟨_, limit_complex_cone_is_limit F⟩⟩⟩

omit F

instance [has_limits_of_shape J V] : has_limits_of_shape J (homological_complex V c) := {}
instance [has_limits_of_size.{w' w} V] : has_limits_of_size.{w' w} (homological_complex V c) := ⟨⟩
instance [has_limits_of_shape J V] (i : ι) : preserves_limits_of_shape J (eval V c i) := {}
instance [has_limits_of_size.{w' w} V] (i : ι) : preserves_limits_of_size.{w' w} (eval V c i) := {}

end limits

section colimits

noncomputable theory

variables [has_zero_morphisms V] (F : J ⥤ homological_complex V c)

include F

@[simps]
def desc_of_is_colimit_eval (t : cocone F) (h : ∀ i, is_colimit $ (eval V c i).map_cocone t)
  (s : cocone F) :
  t.X ⟶ s.X :=
begin
  refine ⟨λ i, is_colimit.desc (h i) ⟨_, _⟩, _⟩,
  refine ⟨λ x, (s.ι.app x).f i, _⟩,
  { intros x y f, dsimp, rw [category.comp_id, ← comp_f], congr, exact cocone.w s f },
  { intros i j r,
    apply (h i).hom_ext,
    intro x,
    dsimp,
    erw [(t.ι.app x).comm_assoc, (h j).fac _ x, (h i).fac_assoc _ x, (s.ι.app x).comm] }
end
.
/-- `eval` jointly reflects (actually creates) colimits -/
def is_colimit_of_is_colimit_eval (t : cocone F) (h : ∀ i, is_colimit $ (eval V c i).map_cocone t) :
  is_colimit t :=
{ desc := desc_of_is_colimit_eval F t h,
  fac' := by { intros s j, ext, dsimp, exact (h x).fac _ j },
  uniq' := by { intros s m w, ext, apply (h x).hom_ext,
    intro j, dsimp, erw (h x).fac _ j, exact congr_f (w j) x } }

variable [∀ i : ι, has_colimit (F ⋙ eval V c i)]

@[simps]
def colimit_complex : homological_complex V c :=
begin
  refine ⟨λ i, colimit (F ⋙ eval V c i), λ i j, colimit.desc _ ⟨_, _⟩, _, _⟩,
  refine ⟨λ x, (F.obj x).d i j ≫ colimit.ι (F ⋙ eval V c j) x, _⟩,
  { intros x y f,
    dsimp,
    rw [category.comp_id, hom.comm_assoc],
    congr' 1,
    exact colimit.w (F ⋙ eval V c j) _ },
  { intros i j r,
    ext x,
    rw [colimit.ι_desc, comp_zero],
    dsimp only,
    rw [(F.obj x).shape _ _ r, zero_comp] },
  { intros i j k r r', ext, simp }
end
.
@[simps]
def colimit_complex_cocone : cocone F :=
{ X := colimit_complex F,
  ι := { app := λ x, { f := λ i, colimit.ι (F ⋙ eval V c i) x },
    naturality' := λ X Y f,
      by { ext, dsimp, rw category.comp_id, exact colimit.w (F ⋙ eval V c x) _ } } }
.

def colimit_complex_cocone_is_colimit : is_colimit (colimit_complex_cocone F) :=
is_colimit_of_is_colimit_eval _ _
begin
  intro i,
  apply (colimit.is_colimit _).of_iso_colimit,
  exact cocones.ext (iso.refl _) (λ _, category.comp_id _),
end
.

def eval_map_colimit_complex_cocone (i : ι) :
  (eval V c i).map_cocone (colimit_complex_cocone F) ≅ (get_colimit_cocone (F ⋙ eval V c i)).1 :=
cocones.ext (iso.refl _) (λ j, by { dsimp, simpa })

instance (i : ι) : preserves_colimit F (eval V c i) :=
preserves_colimit_of_preserves_colimit_cocone (colimit_complex_cocone_is_colimit F)
  ((colimit.is_colimit _).of_iso_colimit (eval_map_colimit_complex_cocone F i).symm)

instance : has_colimit F :=
⟨⟨⟨_, colimit_complex_cocone_is_colimit F⟩⟩⟩

omit F

instance [has_colimits_of_shape J V] : has_colimits_of_shape J (homological_complex V c) := {}
instance [has_colimits_of_size.{w' w} V] : has_colimits_of_size.{w' w} (homological_complex V c) :=
{}

instance [has_colimits_of_shape J V] (i : ι) : preserves_colimits_of_shape J (eval V c i) := {}
instance [has_colimits_of_size.{w' w} V] (i : ι) :
  preserves_colimits_of_size.{w' w} (eval V c i) := {}

end colimits

section biproduct

variables [has_zero_morphisms V] [has_binary_biproducts V] {X Y Z : homological_complex V c}

@[simps]
def biproduct (X Y : homological_complex V c) : homological_complex V c :=
{ X := λ i, X.X i ⊞ Y.X i,
  d := λ i j, biprod.map (X.d i j) (Y.d i j),
  shape' := λ i j r, by ext; simp [X.shape _ _ r, Y.shape _ _ r] }
.
@[simps] def biproduct.inl : X ⟶ biproduct X Y := { f := λ i, biprod.inl }
@[simps] def biproduct.inr : Y ⟶ biproduct X Y := { f := λ i, biprod.inr }
@[simps] def biproduct.fst : biproduct X Y ⟶ X := { f := λ i, biprod.fst }
@[simps] def biproduct.snd : biproduct X Y ⟶ Y := { f := λ i, biprod.snd }
@[simps] def biproduct.lift (f : X ⟶ Y) (g : X ⟶ Z) : X ⟶ biproduct Y Z :=
{ f := λ i, biprod.lift (f.f i) (g.f i) }
@[simps] def biproduct.desc (f : X ⟶ Z) (g : Y ⟶ Z) : biproduct X Y ⟶ Z :=
{ f := λ i, biprod.desc (f.f i) (g.f i) }
.
variables (X Y)
@[simps]
def biproduct_bicone : binary_bicone X Y :=
{ X := biproduct X Y,
  fst := biproduct.fst,
  snd := biproduct.snd,
  inl := biproduct.inl,
  inr := biproduct.inr }
.
local attribute [tidy] tactic.case_bash

def biproduct_bicone_is_prod : is_limit (biproduct_bicone X Y).to_cone :=
{ lift := λ (Z : binary_fan _ _), biproduct.lift Z.fst Z.snd,
  uniq' := by { intros, delta binary_fan.fst binary_fan.snd, ext; simp [← w] } }
.
def biproduct_bicone_is_coprod : is_colimit (biproduct_bicone X Y).to_cocone :=
{ desc := λ (Z : binary_cofan _ _), biproduct.desc Z.inl Z.inr,
  uniq' := by { intros, delta binary_cofan.inl binary_cofan.inr, ext; simp [← w] } }
.
def biproduct_is_biprod : binary_biproduct_data X Y :=
{ bicone := biproduct_bicone X Y,
  is_bilimit := ⟨biproduct_bicone_is_prod X Y, biproduct_bicone_is_coprod X Y⟩ }

instance : has_binary_biproducts (homological_complex V c) :=
⟨λ X Y, ⟨⟨biproduct_is_biprod X Y⟩⟩⟩

end biproduct

instance [has_zero_morphisms V] [has_finite_products V] :
  has_finite_products (homological_complex V c) := ⟨λ J _, by exactI infer_instance⟩

-- instance [has_zero_morphisms V] [has_kernels V] : has_kernels (homological_complex V c) :=
-- begin
--   constructor,
--   intros X Y f,
--   apply_with homological_complex.category_theory.limits.has_limit { instances := ff },
--   intro i,
--   let : walking_parallel_pair_op_equiv.{v v}.functor ⋙ walking_parallel_pair_op_equiv.inverse ⋙
--     parallel_pair f 0 ⋙ eval V c i ≅ parallel_pair (f.f i) 0 :=
--     nat_iso.of_components (λ i, eq_to_iso $ by cases i; refl)
--       (by { rintros _ _ (_|_|_); dsimp; simp }),
--   have := has_limit_of_iso this.symm,
--   exact @@has_limit_of_equivalence_comp _ _ _
--     (walking_parallel_pair_op_equiv.{v v}.trans walking_parallel_pair_op_equiv.symm) this
-- end

-- instance [has_zero_morphisms V] [has_cokernels V] :
--   has_cokernels (homological_complex V c) :=
-- begin
--   constructor,
--   intros X Y f,
--   apply_with homological_complex.category_theory.limits.has_colimit { instances := ff },
--   intro i,
--   let : walking_parallel_pair_op_equiv.{v v}.functor ⋙ walking_parallel_pair_op_equiv.inverse ⋙
--     parallel_pair f 0 ⋙ eval V c i ≅ parallel_pair (f.f i) 0 :=
--     nat_iso.of_components (λ i, eq_to_iso $ by cases i; refl)
--       (by { rintros _ _ (_|_|_); dsimp; simp }),
--   have := has_colimit_of_iso this,
--   exact @@has_colimit_of_equivalence_comp _ _ _
--     (walking_parallel_pair_op_equiv.{v v}.trans walking_parallel_pair_op_equiv.symm) this
-- end

section kernel

variables [has_zero_morphisms V] {X Y : homological_complex V c}
variables (f : X ⟶ Y) [∀ i, has_kernel (f.f i)]

@[simps]
def kernel_complex : homological_complex V c :=
{ X := λ i, kernel (f.f i),
  d := λ i j, kernel.map _ _ _ _ (f.comm i j),
  shape' := by { introv r, ext, simp [X.shape _ _ r] } }
.
@[simps]
def kernel_complex_ι : kernel_complex f ⟶ X :=
{ f := λ i, kernel.ι (f.f i) }
.
@[simps]
def kernel_complex_fork : kernel_fork f :=
kernel_fork.of_ι (kernel_complex_ι f) (by { ext, simp })
.
@[simps]
def kernel_complex_lift (s : kernel_fork f) : s.X ⟶ kernel_complex f :=
{ f := λ i, kernel.lift _ (s.ι.f i)
    (by { rw [← comp_f, kernel_fork.condition], refl }) }

def kernel_complex_is_kernel : is_limit (kernel_complex_fork f) :=
begin
  apply is_limit_aux (kernel_complex_fork f) (kernel_complex_lift f),
  { intro s, ext, delta fork.ι, dsimp, simp only [kernel.lift_ι] },
  { intros s m h, ext, apply_fun (λ f, hom.f f x) at h,
    delta fork.ι at h, dsimp at h ⊢, simp [h, kernel.lift_ι] }
end
.
instance : has_kernel f := ⟨⟨⟨_, kernel_complex_is_kernel f⟩⟩⟩
instance [has_kernels V] : has_kernels (homological_complex V c) := {}
.
end kernel

section cokernel

variables [has_zero_morphisms V] {X Y : homological_complex V c}
variables (f : X ⟶ Y) [∀ i, has_cokernel (f.f i)]

@[simps]
def cokernel_complex : homological_complex V c :=
{ X := λ i, cokernel (f.f i),
  d := λ i j, cokernel.map _ _ _ _ (f.comm i j),
  shape' := by { introv r, ext, simp [Y.shape _ _ r] } }
.
@[simps]
def cokernel_complex_π : Y ⟶ cokernel_complex f :=
{ f := λ i, cokernel.π (f.f i) }
.
@[simps]
def cokernel_complex_cofork : cokernel_cofork f :=
cokernel_cofork.of_π (cokernel_complex_π f) (by { ext, simp })
.
@[simps]
def cokernel_complex_desc (s : cokernel_cofork f) : cokernel_complex f ⟶ s.X :=
{ f := λ i, cokernel.desc _ (s.π.f i)
    (by { rw [← comp_f, cokernel_cofork.condition], refl }) }

def cokernel_complex_is_cokernel : is_colimit (cokernel_complex_cofork f) :=
begin
  apply is_colimit_aux (cokernel_complex_cofork f) (cokernel_complex_desc f),
  { intro s, ext, delta cofork.π, dsimp, simp only [cokernel.π_desc] },
  { intros s m h, ext, apply_fun (λ f, hom.f f x) at h,
    delta cofork.π at h, dsimp at h ⊢, simp only [h, cokernel.π_desc] }
end
.
instance : has_cokernel f := ⟨⟨⟨_, cokernel_complex_is_cokernel f⟩⟩⟩
instance [has_cokernels V] : has_cokernels (homological_complex V c) := {}
.
end cokernel

section normal_mono

variables [abelian V] {X Y Z : homological_complex V c}
variables (f : X ⟶ Y)

def is_kernel_of_eval (g : Y ⟶ Z) (w : f ≫ g = 0)
  (h : ∀ i, is_limit (kernel_fork.of_ι (f.f i) (congr_f w i))) :
  is_limit (kernel_fork.of_ι f w) :=
begin
  refine is_limit.of_iso_limit (kernel_complex_is_kernel g) _,
  fapply cones.ext,
  fapply hom.iso_of_components,
  intro i, exact limit.iso_limit_cone ⟨_, h i⟩,
  { intros i j r, dsimp, rw [← iso.comp_inv_eq, category.assoc, ← iso.eq_inv_comp], ext, simp },
  { rintro (_|_),
    { ext, dsimp, rw ← iso.inv_comp_eq, simp },
    { ext, dsimp, simp [(show f.f x ≫ g.f x = _, from congr_f w x)] } }
end

def is_cokernel_of_eval (g : Y ⟶ Z) (w : f ≫ g = 0)
  (h : ∀ i, is_colimit (cokernel_cofork.of_π (g.f i) (congr_f w i))) :
  is_colimit (cokernel_cofork.of_π g w) :=
begin
  refine is_colimit.of_iso_colimit (cokernel_complex_is_cokernel f) _,
  fapply cocones.ext,
  fapply hom.iso_of_components,
  intro i, exact colimit.iso_colimit_cocone ⟨_, h i⟩,
  { intros i j r, ext, dsimp, simp },
  { rintro (_|_),
    { ext, dsimp, simpa using (congr_arg (λ f, hom.f f x) w).symm },
    { ext, dsimp, simp } }
end
.

instance [mono f] (i : ι) : mono (f.f i) :=
begin
  change mono ((eval V c i).map f),
  apply_instance
end

lemma mono_of_eval [∀ i, mono (f.f i)] : mono f :=
begin
  constructor,
  intros Z g h r,
  ext i,
  rw ← cancel_mono (f.f i),
  exact congr_f r i
end

lemma mono_iff_eval : mono f ↔ ∀ i, mono (f.f i) :=
⟨λ _ i, by exactI infer_instance, λ _, by exactI mono_of_eval f⟩

instance [epi f] (i : ι) : epi (f.f i) :=
begin
  change epi ((eval V c i).map f),
  apply_instance
end

lemma epi_of_eval [∀ i, epi (f.f i)] : epi f :=
begin
  constructor,
  intros Z g h r,
  ext i,
  rw ← cancel_epi (f.f i),
  exact congr_f r i
end

lemma epi_iff_eval : epi f ↔ ∀ i, epi (f.f i) :=
⟨λ _ i, by exactI infer_instance, λ _, by exactI epi_of_eval f⟩

def normal_mono [mono f] : normal_mono f :=
{ Z := cokernel_complex f,
  g := cokernel_complex_π f,
  w := by { ext, simp },
  is_limit :=
  begin
    apply is_kernel_of_eval,
    intro i,
    exact abelian.mono_is_kernel_of_cokernel _ (colimit.is_colimit _)
  end }

def normal_epi [epi f] : normal_epi f :=
{ W := kernel_complex f,
  g := kernel_complex_ι f,
  w := by { ext, simp },
  is_colimit :=
  begin
    apply is_cokernel_of_eval,
    intro i,
    exact abelian.epi_is_cokernel_of_kernel _ (limit.is_limit _)
  end }
.

end normal_mono

instance [abelian V] : abelian (homological_complex V c) :=
{ normal_mono_of_mono := λ _ _, normal_mono,
  normal_epi_of_epi := λ _ _, normal_epi }

end homological_complex


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

Transferring `traversable` instances using isomorphisms.
-/
import data.equiv.basic
import control.traversable.lemmas

universes u

namespace equiv

section functor
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [functor t]

open functor

/-- Given a functor `t`, a function `t' : Type u → Type u`, and
equivalences `t α ≃ t' α` for all `α`, then every function `α → β` can
be mapped to a function `t' α → t' β` functorially (see
`equiv.functor`). -/
protected def map {α β : Type u} (f : α → β) (x : t' α) : t' β :=
eqv β $ map f ((eqv α).symm x)

/-- The function `equiv.map` transfers the functoriality of `t` to
`t'` using the equivalences `eqv`.  -/
protected def functor : functor t' :=
{ map := @equiv.map _ }

variables [is_lawful_functor t]

protected lemma id_map {α : Type u} (x : t' α) : equiv.map id x = x :=
by simp [equiv.map, id_map]

protected lemma comp_map {α β γ : Type u} (g : α → β) (h : β → γ) (x : t' α) :
  equiv.map (h ∘ g) x = equiv.map h (equiv.map g x) :=
by simp [equiv.map]; apply comp_map

protected lemma is_lawful_functor : @is_lawful_functor _ equiv.functor :=
{ id_map := @equiv.id_map _ _,
  comp_map := @equiv.comp_map _ _ }

protected lemma is_lawful_functor' [F : _root_.functor t']
  (h₀ : ∀ {α β} (f : α → β), _root_.functor.map f = equiv.map f)
  (h₁ : ∀ {α β} (f : β), _root_.functor.map_const f = (equiv.map ∘ function.const α) f) :
  _root_.is_lawful_functor t' :=
begin
  have : F = equiv.functor,
  { casesI F, dsimp [equiv.functor],
    congr; ext; [rw ← h₀, rw ← h₁] },
  substI this,
  exact equiv.is_lawful_functor
end

end functor

section traversable
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t]
variables {m : Type u → Type u} [applicative m]
variables {α β : Type u}

/-- Like `equiv.map`, a function `t' : Type u → Type u` can be given
the structure of a traversable functor using a traversable functor
`t'` and equivalences `t α ≃ t' α` for all α.  See `equiv.traversable`. -/
protected def traverse (f : α → m β) (x : t' α) : m (t' β) :=
eqv β <$> traverse f ((eqv α).symm x)

/-- The function `equiv.tranverse` transfers a traversable functor
instance across the equivalences `eqv`. -/
protected def traversable : traversable t' :=
{ to_functor := equiv.functor eqv,
  traverse := @equiv.traverse _ }

end traversable

section equiv
parameters {t t' : Type u → Type u}
parameters (eqv : Π α, t α ≃ t' α)
variables [traversable t] [is_lawful_traversable t]
variables {F G : Type u → Type u} [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]
variables (η : applicative_transformation F G)
variables {α β γ : Type u}

open is_lawful_traversable functor

protected lemma id_traverse (x : t' α) :
  equiv.traverse eqv id.mk x = x :=
by simp! [equiv.traverse,id_bind,id_traverse,functor.map] with functor_norm

protected lemma traverse_eq_map_id (f : α → β) (x : t' α) :
  equiv.traverse eqv (id.mk ∘ f) x = id.mk (equiv.map eqv f x) :=
by simp [equiv.traverse, traverse_eq_map_id] with functor_norm; refl

protected lemma comp_traverse (f : β → F γ) (g : α → G β) (x : t' α) :
  equiv.traverse eqv (comp.mk ∘ functor.map f ∘ g) x =
  comp.mk (equiv.traverse eqv f <$> equiv.traverse eqv g x) :=
by simp [equiv.traverse,comp_traverse] with functor_norm; congr; ext; simp

protected lemma naturality (f : α → F β) (x : t' α) :
  η (equiv.traverse eqv f x) = equiv.traverse eqv (@η _ ∘ f) x :=
by simp only [equiv.traverse] with functor_norm

/-- The fact that `t` is a lawful traversable functor carries over the
equivalences to `t'`, with the traversable functor structure given by
`equiv.traversable`. -/
protected def is_lawful_traversable :
  @is_lawful_traversable t' (equiv.traversable eqv) :=
{ to_is_lawful_functor := @equiv.is_lawful_functor _ _ eqv _ _,
  id_traverse := @equiv.id_traverse _ _,
  comp_traverse := @equiv.comp_traverse _ _,
  traverse_eq_map_id := @equiv.traverse_eq_map_id _ _,
  naturality := @equiv.naturality _ _ }

/-- If the `traversable t'` instance has the properties that `map`,
`map_const`, and `traverse` are equal to the ones that come from
carrying the traversable functor structure from `t` over the
equivalences, then the the fact `t` is a lawful traversable functor
carries over as well. -/
protected def is_lawful_traversable' [_i : traversable t']
  (h₀ : ∀ {α β} (f : α → β),
         map f = equiv.map eqv f)
  (h₁ : ∀ {α β} (f : β),
         map_const f = (equiv.map eqv ∘ function.const α) f)
  (h₂ : ∀ {F : Type u → Type u} [applicative F],
        by exactI ∀ [is_lawful_applicative F]
          {α β} (f : α → F β),
         traverse f = equiv.traverse eqv f) :
  _root_.is_lawful_traversable t' :=
begin
    -- we can't use the same approach as for `is_lawful_functor'` because
    -- h₂ needs a `is_lawful_applicative` assumption
  refine {to_is_lawful_functor :=
    equiv.is_lawful_functor' eqv @h₀ @h₁, ..}; introsI,
  { rw [h₂, equiv.id_traverse], apply_instance },
  { rw [h₂, equiv.comp_traverse f g x, h₂], congr,
    rw [h₂], all_goals { apply_instance } },
  { rw [h₂, equiv.traverse_eq_map_id, h₀]; apply_instance },
  { rw [h₂, equiv.naturality, h₂]; apply_instance }
end

end equiv
end equiv


import morphisms.basic
import algebraic_geometry.surjective_on_stalks

/-!

# Locally closed immersions

A morphism of schemes is a closed immersion if the underlying map is a closed embedding, and
the sheaf map is locally surjective.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

variables {X Y Z : Scheme.{u}} (f : X ⟶ Y) (g : Y ⟶ Z)

/-- A morphism `is_preimmersion` if the underlying map is an topological embedding, and
the map on stalks is surjective. -/
@[mk_iff]
class is_preimmersion (f : X ⟶ Y) : Prop :=
(base_embedding [] : embedding f.1.base)
(stalk_map_surjective [] : ∀ x, function.surjective (PresheafedSpace.stalk_map f.1 x))

instance [is_preimmersion f] [is_preimmersion g] : is_preimmersion (f ≫ g) :=
begin
  constructor,
  { exact (is_preimmersion.base_embedding g).comp (is_preimmersion.base_embedding f) },
  { intro x, erw PresheafedSpace.stalk_map.comp f.1 g.1 x,
    exact (is_preimmersion.stalk_map_surjective f _).comp
      (is_preimmersion.stalk_map_surjective g _) }
end

instance is_open_immersion.to_is_preimmersion [is_open_immersion f] : is_preimmersion f :=
begin
  constructor,
  { exact (is_open_immersion.base_open f).to_embedding },
  { exact λ x, (as_iso $ PresheafedSpace.stalk_map f.1 x).CommRing_iso_to_ring_equiv.surjective }
end

lemma is_preimmersion.of_comp [is_preimmersion (f ≫ g)] :
  is_preimmersion f :=
begin
  constructor,
  { exact embedding_of_embedding_compose f.1.base.2 g.1.base.2
      (is_preimmersion.base_embedding $ f ≫ g) },
  { intro x,
    have := (is_preimmersion.stalk_map_surjective $ f ≫ g) x,
    erw PresheafedSpace.stalk_map.comp at this,
    rw coe_comp at this,
    exact function.surjective.of_comp this }
end

universes w v

lemma Top.sheaf.hom_stalk_ext {X : Top.{v}} {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {F G : X.sheaf C}
  (α β : F ⟶ G)
  (h : ∀ x, (Top.presheaf.stalk_functor C x).map α.1 = (Top.presheaf.stalk_functor C x).map β.1) :
  α = β :=
begin
  ext U,
  induction U,
  apply concrete_category.hom_ext,
  intros s,
  apply Top.presheaf.section_ext G U,
  intro x,
  rw [← Top.presheaf.stalk_functor_map_germ_apply, ← Top.presheaf.stalk_functor_map_germ_apply, h],
end

lemma SheafedSpace.hom_stalk_ext {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {X Y : SheafedSpace C}
  (f g : X ⟶ Y)
  (h : f.base = g.base)
  (h' : ∀ x, PresheafedSpace.stalk_map f x =
    Y.presheaf.stalk_specializes (specializes_of_eq $ by rw h) ≫ PresheafedSpace.stalk_map g x) :
  f = g :=
begin
  cases f, cases g,
  obtain (rfl : f_base = g_base) := h,
  suffices : f_c = g_c, { subst this },
  ext U,
  induction U,
  apply concrete_category.hom_ext,
  intros s,
  apply Top.presheaf.section_ext X.sheaf ((opens.map f_base).obj U),
  intro x,
  delta SheafedSpace.sheaf Top.sheaf.presheaf,
  dsimp only,
  erw [← PresheafedSpace.stalk_map_germ_apply ⟨f_base, f_c⟩,
    ← PresheafedSpace.stalk_map_germ_apply ⟨f_base, g_c⟩, h'],
  simp only [Top.presheaf.stalk_specializes_refl, category.id_comp,
    PresheafedSpace.stalk_map_germ_apply],
end

lemma SheafedSpace.mono_of_base_injective_of_stalk_epi
  {C : Type u} [category.{v} C]
  [concrete_category.{v} C] [has_colimits C]
  [preserves_filtered_colimits (forget C)]
  [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]
  {X Y : SheafedSpace C}
  (f : X ⟶ Y)
  (h₁ : function.injective f.base)
  (h₂ : ∀ x, epi (PresheafedSpace.stalk_map f x)) : mono f :=
begin
  constructor,
  introsI Z g h e,
  have : g.base = h.base,
  { rw ← Top.mono_iff_injective at h₁, resetI,
    simp only [← cancel_mono f.base, ← SheafedSpace.comp_base, e] },
  apply SheafedSpace.hom_stalk_ext _ _ this,
  intro x,
  cases g, cases h, obtain (rfl : g_base = h_base) := this,
  rw [← cancel_epi (PresheafedSpace.stalk_map f (g_base x)), Top.presheaf.stalk_specializes_refl,
  category.id_comp],
  rw [← PresheafedSpace.stalk_map.comp ⟨g_base, g_c⟩ f,
    ← PresheafedSpace.stalk_map.comp ⟨g_base, h_c⟩ f],
  congr, exact e,
end

instance is_preimmersion.to_mono [is_preimmersion f] : mono f :=
begin
  refine (Scheme.forget_to_LocallyRingedSpace ⋙
    LocallyRingedSpace.forget_to_SheafedSpace).mono_of_mono_map _,
  apply SheafedSpace.mono_of_base_injective_of_stalk_epi,
  { exact (is_preimmersion.base_embedding f).inj },
  { intro x,
    apply (forget CommRing).epi_of_epi_map,
    rw epi_iff_surjective,
    exact (is_preimmersion.stalk_map_surjective f x : _) }
end

lemma is_preimmersion_stable_under_composition :
  morphism_property.stable_under_composition @is_preimmersion :=
λ _ _ _ _ _ _ _, by exactI infer_instance

lemma is_preimmersion_respects_iso :
  morphism_property.respects_iso @is_preimmersion :=
is_preimmersion_stable_under_composition.respects_iso (λ _ _ _, infer_instance)

lemma is_preimmersion_is_local_at_target :
  property_is_local_at_target @is_preimmersion :=
begin
  constructor,
  { exact is_preimmersion_respects_iso },
  { introsI X Y f U H,
    constructor,
    { rw morphism_restrict_val_base, exact H.1.restrict_preimage U.1 },
    { exact λ x, ((morphism_property.surjective_respects_iso _).arrow_iso_iff
      (morphism_restrict_stalk_map f U x)).mpr (H.2 x.1) } },
  { intros X Y f 𝒰 H,
    constructor,
    { apply (embedding_iff_embedding_of_supr_eq_top
        𝒰.supr_opens_range f.1.base.2).mpr,
      intro i,
      have := ((is_preimmersion_respects_iso.arrow_iso_iff
        (morphism_restrict_opens_range f (𝒰.map i))).mpr (H i)).1,
      rwa [arrow.mk_hom, morphism_restrict_val_base] at this },
    { exact λ x, ((morphism_property.surjective_respects_iso _).arrow_iso_iff
        (morphism_restrict_stalk_map f _ _)).mp
        (((is_preimmersion_respects_iso.arrow_iso_iff (morphism_restrict_opens_range f (𝒰.map _)))
        .mpr (H (𝒰.f $ f.1.base x))).2 ⟨x, 𝒰.covers (f.1.base x)⟩) } }
end

lemma is_preimmersion_open_cover_tfae (f : X ⟶ Y) :
  tfae [is_preimmersion f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      is_preimmersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      is_preimmersion (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), is_preimmersion (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      is_preimmersion (pullback.snd : pullback f g ⟶ U),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤),
      (∀ i, is_preimmersion (f ∣_ (U i)))] :=
is_preimmersion_is_local_at_target.open_cover_tfae f

lemma is_preimmersion_stable_under_base_change :
  morphism_property.stable_under_base_change @is_preimmersion :=
morphism_property.stable_under_base_change.mk is_preimmersion_respects_iso
begin
  intros X Y S f g hg,
  refine ⟨_, pullback_snd_surjective_on_stalks f g hg.2⟩,
  rw ← (pullback_comparison_comp_fst Scheme.forget_to_Top f g).trans (Scheme.forget_to_Top_map' _),
  exact (Top.fst_embedding_of_right_embedding f.1.base hg.1).comp
    (embedding_category_theory_pullback_comparison_of_surjective_on_stalks f g hg.2)
end

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_preimmersion g] :
  is_preimmersion (pullback.fst : pullback f g ⟶ X) :=
is_preimmersion_stable_under_base_change.fst f g infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [is_preimmersion f] :
  is_preimmersion (pullback.snd : pullback f g ⟶ Y) :=
is_preimmersion_stable_under_base_change.snd f g infer_instance

lemma is_preimmersion_Spec_of_exists_eq_div {R S : CommRing} (f : R ⟶ S)
  (hf : ∀ x : S, ∃ a b : R, is_unit (f b) ∧ x * f b = f a) :
  is_preimmersion (Scheme.Spec.map f.op) :=
begin
  constructor,
  { have H : ∀ x : (is_unit.submonoid S).comap f, is_unit (f x) := subtype.prop,
    have : (is_localization.lift H).comp (algebra_map R $ localization $
      (is_unit.submonoid S).comap f) = f := is_localization.lift_comp H,
    rw [Scheme.Spec_map_val_base, ← this, prime_spectrum.comap_comp],
    refine (prime_spectrum.localization_comap_embedding (localization $
      (is_unit.submonoid S).comap f) ((is_unit.submonoid S).comap f)).comp
      (prime_spectrum.closed_embedding_comap_of_surjective _ _ _).to_embedding,
    rintro (x : S),
    obtain ⟨a, b, hb, e⟩ := hf x,
    refine ⟨is_localization.mk' _ a ⟨b, show b ∈ ((is_unit.submonoid S).comap f), from hb⟩, _⟩,
    rwa [is_localization.lift_mk'_spec, subtype.coe_mk, eq_comm, mul_comm] },
  { intro x,
    refine ((morphism_property.surjective_respects_iso CommRing).arrow_mk_iso_iff
      (Spec.stalk_map_iso _ x)).mpr _,
    exact ring_hom.surjective_on_stalks_of_exists_eq_div hf x.as_ideal }
end

attribute [reassoc] Top.presheaf.germ_res

instance (x) : is_preimmersion (X.from_Spec_stalk x) :=
begin
  delta Scheme.from_Spec_stalk is_affine_open.from_Spec_stalk,
  apply is_preimmersion_stable_under_composition,
  { apply is_preimmersion_Spec_of_exists_eq_div,
    rintro (y : X.presheaf.stalk x),
    let R := X.affine_cover_ring x,
    obtain ⟨x' : prime_spectrum R, hx⟩ := X.affine_cover.covers x,
    let e : X.presheaf.stalk x ≅ (Spec.structure_sheaf R).presheaf.stalk x' :=
      X.presheaf.stalk_congr (inseparable.of_eq hx.symm)
        ≪≫ (as_iso $ PresheafedSpace.stalk_map (X.affine_cover.map x).1 x'),
    let e' : R ≅ X.presheaf.obj (op $ (X.affine_cover.map x).opens_range) :=
      (as_iso $ to_Spec_Γ R) ≪≫ (as_iso $ (X.affine_cover.is_open x).inv_app ⊤) ≪≫
        X.presheaf.map_iso (eq_to_iso $ opens.ext $ by exact set.image_univ.symm).op,
    have : e'.hom ≫ X.presheaf.germ ⟨x, X.affine_cover.covers x⟩ ≫ e.hom =
      structure_sheaf.to_stalk R x',
    { simp only [iso.trans_hom, category.assoc, as_iso_hom, functor.map_iso_hom,
        Top.presheaf.stalk_congr_hom, iso.op_hom, Top.presheaf.germ_res_assoc,
        Top.presheaf.germ_stalk_specializes'_assoc, structure_sheaf.to_stalk],
      erw [PresheafedSpace.stalk_map_germ', PresheafedSpace.is_open_immersion.inv_app_app_assoc],
      congr' 1,
      refine (X.affine_cover.obj x).presheaf.germ_res (eq_to_hom _) ⟨_, _⟩,
      exact opens.map_functor_eq' _ (is_open_immersion.base_open _) _ },
    obtain ⟨⟨z, s⟩, hz⟩ := is_localization.surj x'.as_ideal.prime_compl (e.hom y),
    refine ⟨e'.hom z, e'.hom s, _, _⟩,
    { apply is_unit_of_map_unit e.hom, simp only [← comp_apply, category.assoc], erw this,
      exact is_localization.map_units ((Spec.structure_sheaf R).presheaf.stalk x') s },
    { apply (show function.injective e.hom, from e.CommRing_iso_to_ring_equiv.injective),
      simp only [← comp_apply, category.assoc, map_mul, iso.CommRing_iso_to_ring_equiv],
      erw this,
      exact hz } },
  { apply_instance }
end

end algebraic_geometry


import mynat.definition -- imports the natural numbers {0,1,2,3,4,...}.
import mynat.add -- imports definition of addition on the natural numbers.
import mynat.mul -- imports definition of multiplication on the natural numbers.

lemma example1 (x y z : mynat) : x * y + z = x * y + z :=

begin
  refl,
end