/-

  In this file we provide some goodies for Prod

  Namely
    1. index access:
       `(42, 1.0, "hello").get 2 == "hello"`
    2. index set:
       `(42,3.14159,"hello").set 2 "world" = (42,3.14159,"world")`
    3. curry function:
       `curryN 3 (λ ((i,j,k) : Nat×Nat×Nat) => i + j) = (λ i j k => i + j)`
    4. uncurry function
       `uncurryN 3 (λ i j k : Nat => i + j) = λ (i,j,k) => i + j`
 -/

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

class Prod.Size (α : Type) where
  size : Nat

class Prod.SizeFlat (α : Type) where
  sizeFlat : Nat

instance (priority := low) (α) : Prod.Size α where
  size := 1

instance (priority := low) (α) : Prod.SizeFlat α where
  sizeFlat := 1

instance (α β) [sb : Prod.Size β] : Prod.Size (α×β) where
  size := 1 + sb.size

instance (α β) [sa : Prod.SizeFlat α] [sb : Prod.SizeFlat β] : Prod.SizeFlat (α×β) where
  sizeFlat := sa.sizeFlat + sb.sizeFlat

/-- Size of a product type

Counts types only at the top level, so `A×B` and `(A×B)×C` have both size 2 but `A×B×C` has size 3.
 -/
@[reducible]
def Prod.size {α β : Type} [Prod.Size β] (_ : α × β) : Nat := Prod.Size.size (α × β)

/-- Size of a product type

Counts all types, so `A×B` has flat size 2 and `(A×B)×C` have both `A×B×C` flat size 3.
 -/
@[reducible]
def Prod.sizeFlat {α β : Type} [Prod.SizeFlat α] [Prod.SizeFlat β]
  (_ : α × β) : Nat := Prod.SizeFlat.sizeFlat (α × β)

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

class Prod.Get (X : Type) (i : Nat) where
  {type : Type}
  get : X → type

attribute [reducible] Prod.Get.type Prod.Get.get

@[reducible]
instance (priority := low) : Prod.Get X 0 := ⟨λ x => x⟩

@[reducible]
instance : Prod.Get (X×Y) 0 := ⟨λ x => x.fst⟩

@[reducible]
instance [pg : Prod.Get Y n] : Prod.Get (X×Y) (n+1) := ⟨λ x => pg.get x.snd⟩

abbrev Prod.get {X Y} (i : Nat) [pg : Prod.Get (X×Y) i] (x : X×Y) := pg.get x

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

class Prod.Set (X : Type) (i : Nat) (T : outParam Type) where
  seti : X → T → X

attribute [reducible] Prod.Set.seti

@[reducible]
instance (priority := low) : Prod.Set X 0 X := ⟨λ x x₀ => x₀⟩

@[reducible]
instance : Prod.Set (X×Y) 0 X := ⟨λ (x,y) x₀ => (x₀,y)⟩

@[reducible]
instance {X Y : Type} {Yₙ : outParam Type} [pg : Prod.Set Y n Yₙ]
  : Prod.Set (X×Y) (n+1) Yₙ := ⟨λ (x,y) y₀ => (x, pg.seti (i:=n) y y₀)⟩

abbrev Prod.set {X Xs : Type} {Xᵢ : outParam Type}
  (i : Nat) [pg : Prod.Set (X×Xs) i Xᵢ] (x : X×Xs) (xi) := pg.seti (i:=i) x xi

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

class Prod.Uncurry (n : Nat) (F : Type) (Xs : outParam Type) (Y : outParam Type) where
  uncurry : F → Xs → Y

attribute [reducible] Prod.Uncurry.uncurry

@[reducible]
instance (priority := low) {X Y : Type} : Prod.Uncurry 1 (X→Y) X Y where
  uncurry := λ (f : X → Y) (x : X) => f x

@[reducible]
instance {X Y : Type} {Xs' Y' : outParam Type} [c : Prod.Uncurry n Y Xs' Y']
  : Prod.Uncurry (n+1) (X→Y) (X×Xs') Y' where
  uncurry := λ (f : X → Y) ((x,xs) : X×Xs') => c.uncurry (n:=n) (f x) xs

abbrev uncurryN {F : Type} {Xs Y : outParam Type}
  (n : Nat) (f : F) [Prod.Uncurry n F Xs Y]
  := Prod.Uncurry.uncurry (n:=n) f

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

class Prod.Curry (n : Nat) (Xs : Type) (Y : Type) (F : outParam Type) where
  curry : (Xs → Y) → F

attribute [reducible] Prod.Curry.curry

@[reducible]
instance (priority := low) : Prod.Curry 1 X Y (X→Y) where
  curry := λ (f : X → Y) => f

@[reducible]
instance {X Xs Y : Type} {F : outParam Type} [c : outParam $ Prod.Curry n Xs Y F]
  : Prod.Curry (n+1) (X×Xs) Y (X→F) where
  curry := λ (f : X×Xs → Y) => (λ (x : X) => c.curry (n:=n) (λ y => f (x,y)))

abbrev curryN {Xs Y : outParam $ Type} {F : outParam Type}
  (n : Nat) (f : Xs → Y) [outParam $ Prod.Curry n Xs Y F] := Prod.Curry.curry n f

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

section Tests

  example : (42,3.14159,"hello").get 0 = 42 := by rfl
  example : (42,3.14159,"hello").get 1 = 3.14159 := by rfl
  example : (42,3.14159,"hello").get 2 = "hello" := by rfl
  example : ("hello", (42, 3.14159), "world").get 1 = (42,3.14159) := by rfl

  -- Product is right associative and we respect it
  example : (42,3.14159,"hello").size = 3 := by rfl
  example : (42,(3.14159,"hello")).size = 3 := by rfl
  example : ((42,3.14159),"hello").size = 2 := by rfl
  example : ((42,3.14159),"hello").sizeFlat = 3 := by rfl
  example : ((42,3.14159),("hello","world")).size = 3 := by rfl
  example : ((42,3.14159),("hello","world")).sizeFlat = 4 := by rfl

  example : (42,3.14159,"hello").set 2 "world" = (42,3.14159,"world") := by rfl

  example : uncurryN 3 (λ i j k : Nat => i + j) = λ (i,j,k) => i + j := by rfl
  example : uncurryN 2 (λ i j k : Nat => i + j) = λ (i,j) k => i + j := by rfl

  example : curryN 3 (λ ((i,j,k) : Nat×Nat×Nat) => i + j) = (λ i j k : Nat  => i + j) := by rfl
  -- example : curryN 2 (λ ((i,j,k) : Nat×Nat×Nat) => i + j) = (λ (i : Nat) ((j,k) : Nat×Nat) => i + j) := by rfl

end Tests


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

Extends the theory on functors, applicatives and monads.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.PostPort

universes u v u_1 u_2 u_3 w l

namespace Mathlib

theorem functor.map_map {α : Type u} {β : Type u} {γ : Type u} {f : Type u → Type v} [Functor f]
    [is_lawful_functor f] (m : α → β) (g : β → γ) (x : f α) : g <$> m <$> x = (g ∘ m) <$> x :=
  Eq.symm (comp_map m g x)

@[simp] theorem id_map' {α : Type u} {f : Type u → Type v} [Functor f] [is_lawful_functor f]
    (x : f α) : (fun (a : α) => a) <$> x = x :=
  id_map x

def mzip_with {F : Type u → Type v} [Applicative F] {α₁ : Type u} {α₂ : Type u} {φ : Type u}
    (f : α₁ → α₂ → F φ) (ma₁ : List α₁) (ma₂ : List α₂) : F (List φ) :=
  sorry

def mzip_with' {α : Type u} {β : Type u} {γ : Type u} {F : Type u → Type v} [Applicative F]
    (f : α → β → F γ) : List α → List β → F PUnit :=
  sorry

@[simp] theorem pure_id'_seq {α : Type u} {F : Type u → Type v} [Applicative F]
    [is_lawful_applicative F] (x : F α) : (pure fun (x : α) => x) <*> x = x :=
  pure_id_seq x

theorem seq_map_assoc {α : Type u} {β : Type u} {γ : Type u} {F : Type u → Type v} [Applicative F]
    [is_lawful_applicative F] (x : F (α → β)) (f : γ → α) (y : F γ) :
    x <*> f <$> y = (fun (m : α → β) => m ∘ f) <$> x <*> y :=
  sorry

theorem map_seq {α : Type u} {β : Type u} {γ : Type u} {F : Type u → Type v} [Applicative F]
    [is_lawful_applicative F] (f : β → γ) (x : F (α → β)) (y : F α) :
    f <$> (x <*> y) = function.comp f <$> x <*> y :=
  sorry

-- TODO: setup `functor_norm` for `monad` laws

def list.mpartition {f : Type → Type} [Monad f] {α : Type} (p : α → f Bool) :
    List α → f (List α × List α) :=
  sorry

theorem map_bind {α : Type u} {β : Type u} {γ : Type u} {m : Type u → Type v} [Monad m]
    [is_lawful_monad m] (x : m α) {g : α → m β} {f : β → γ} :
    f <$> (x >>= g) =
        do
          let a ← x
          f <$> g a :=
  sorry

theorem seq_bind_eq {α : Type u} {β : Type u} {γ : Type u} {m : Type u → Type v} [Monad m]
    [is_lawful_monad m] (x : m α) {g : β → m γ} {f : α → β} : f <$> x >>= g = x >>= g ∘ f :=
  sorry

theorem seq_eq_bind_map {α : Type u} {β : Type u} {m : Type u → Type v} [Monad m]
    [is_lawful_monad m] {x : m α} {f : m (α → β)} :
    f <*> x =
        do
          let _x ← f
          _x <$> x :=
  Eq.symm (bind_map_eq_seq f x)

/-- This is the Kleisli composition -/
def fish {m : Type u_1 → Type u_2} [Monad m] {α : Sort u_3} {β : Type u_1} {γ : Type u_1}
    (f : α → m β) (g : β → m γ) (x : α) : m γ :=
  f x >>= g

infixl:55 " >=> " => Mathlib.fish

-- >=> is already defined in the core library but it is unusable

-- because of its precedence (it is defined with precedence 2) and

-- because it is defined as a lambda instead of having a named

-- function

theorem fish_pure {m : Type u → Type v} [Monad m] [is_lawful_monad m] {α : Sort u_1} {β : Type u}
    (f : α → m β) : f >=> pure = f :=
  sorry

theorem fish_pipe {m : Type u → Type v} [Monad m] [is_lawful_monad m] {α : Type u} {β : Type u}
    (f : α → m β) : pure >=> f = f :=
  sorry

theorem fish_assoc {m : Type u → Type v} [Monad m] [is_lawful_monad m] {α : Sort u_1} {β : Type u}
    {γ : Type u} {φ : Type u} (f : α → m β) (g : β → m γ) (h : γ → m φ) :
    f >=> g >=> h = f >=> (g >=> h) :=
  sorry

def list.mmap_accumr {α : Type u} {β' : Type v} {γ' : Type v} {m' : Type v → Type w} [Monad m']
    (f : α → β' → m' (β' × γ')) : β' → List α → m' (β' × List γ') :=
  sorry

def list.mmap_accuml {α : Type u} {β' : Type v} {γ' : Type v} {m' : Type v → Type w} [Monad m']
    (f : β' → α → m' (β' × γ')) : β' → List α → m' (β' × List γ') :=
  sorry

theorem mjoin_map_map {m : Type u → Type u} [Monad m] [is_lawful_monad m] {α : Type u} {β : Type u}
    (f : α → β) (a : m (m α)) : mjoin (Functor.map f <$> a) = f <$> mjoin a :=
  sorry

theorem mjoin_map_mjoin {m : Type u → Type u} [Monad m] [is_lawful_monad m] {α : Type u}
    (a : m (m (m α))) : mjoin (mjoin <$> a) = mjoin (mjoin a) :=
  sorry

@[simp] theorem mjoin_map_pure {m : Type u → Type u} [Monad m] [is_lawful_monad m] {α : Type u}
    (a : m α) : mjoin (pure <$> a) = a :=
  sorry

@[simp] theorem mjoin_pure {m : Type u → Type u} [Monad m] [is_lawful_monad m] {α : Type u}
    (a : m α) : mjoin (pure a) = a :=
  pure_bind a id

def succeeds {F : Type → Type v} [alternative F] {α : Type} (x : F α) : F Bool :=
  x $> tt <|> pure false

def mtry {F : Type → Type v} [alternative F] {α : Type} (x : F α) : F Unit :=
  x $> Unit.unit <|> pure Unit.unit

@[simp] theorem guard_true {F : Type → Type v} [alternative F] {h : Decidable True} :
    guard True = pure Unit.unit :=
  sorry

@[simp] theorem guard_false {F : Type → Type v} [alternative F] {h : Decidable False} :
    guard False = failure :=
  sorry

namespace sum

protected def bind {e : Type v} {α : Type u_1} {β : Type u_2} : e ⊕ α → (α → e ⊕ β) → e ⊕ β := sorry

protected instance monad {e : Type v} : Monad (sum e) := sorry

protected instance is_lawful_functor {e : Type v} : is_lawful_functor (sum e) :=
  is_lawful_functor.mk
    (fun (α : Type u) (x : e ⊕ α) =>
      sum.cases_on x (fun (x : e) => Eq.refl (id <$> inl x)) fun (x : α) => Eq.refl (id <$> inr x))
    fun (α β γ : Type u) (g : α → β) (h : β → γ) (x : e ⊕ α) =>
      sum.cases_on x (fun (x : e) => Eq.refl ((h ∘ g) <$> inl x))
        fun (x : α) => Eq.refl ((h ∘ g) <$> inr x)

protected instance is_lawful_monad {e : Type v} : is_lawful_monad (sum e) :=
  is_lawful_monad.mk (fun (α β : Type u) (x : α) (f : α → e ⊕ β) => Eq.refl (pure x >>= f))
    fun (α β γ : Type u) (x : e ⊕ α) (f : α → e ⊕ β) (g : β → e ⊕ γ) =>
      sum.cases_on x (fun (x : e) => Eq.refl (inl x >>= f >>= g))
        fun (x : α) => Eq.refl (inr x >>= f >>= g)

end sum

class is_comm_applicative (m : Type u_1 → Type u_2) [Applicative m] extends is_lawful_applicative m
    where
  commutative_prod :
    ∀ {α β : Type u_1} (a : m α) (b : m β),
      Prod.mk <$> a <*> b = (fun (b : β) (a : α) => (a, b)) <$> b <*> a

theorem is_comm_applicative.commutative_map {m : Type u_1 → Type u_2} [Applicative m]
    [is_comm_applicative m] {α : Type u_1} {β : Type u_1} {γ : Type u_1} (a : m α) (b : m β)
    {f : α → β → γ} : f <$> a <*> b = flip f <$> b <*> a :=
  sorry

end Mathlib


import category_theory.lifting_properties.basic
import category_theory.limits.shapes.comm_sq
import for_mathlib.category_theory.morphism_property_misc

noncomputable theory

open category_theory category_theory.category category_theory.limits

namespace category_theory

variables {C : Type*} [category C]
namespace comm_sq.lift_struct
attribute [reassoc] fac_left
attribute [reassoc] fac_right
end comm_sq.lift_struct

namespace is_pullback

/-

A     X'     X

B     Y'     Y
-/

section

variables {A B X Y Z : C}
  {i : A ⟶ B} {f' : A ⟶ X} {f : B ⟶ Y} {p : X ⟶ Y}
  (h : is_pullback f' i p f) (f₁ : Z ⟶ X) (f₂ : Z ⟶ B)
  (fac : f₁ ≫ p = f₂ ≫ f)

def lift : Z ⟶ A := (pullback_cone.is_limit.lift' h.is_limit f₁ f₂ fac).1

@[simp, reassoc]
lemma lift_fst : h.lift f₁ f₂ fac ≫ f' = f₁ :=
(pullback_cone.is_limit.lift' h.is_limit f₁ f₂ fac).2.1

@[simp, reassoc]
lemma lift_snd : h.lift f₁ f₂ fac ≫ i = f₂ :=
(pullback_cone.is_limit.lift' h.is_limit f₁ f₂ fac).2.2

include h
def hom_ext {l₁ l₂ : Z ⟶ A} (h₁ : l₁ ≫ f' = l₂ ≫ f')
  (h₂ : l₁ ≫ i = l₂ ≫ i) : l₁ = l₂ :=
pullback_cone.is_limit.hom_ext h.is_limit h₁ h₂

end

section

variables
{A B X X' Y Y' : C}
  {i : A ⟶ B} {f : B ⟶ Y'} {f' : A ⟶ X'}
  {p : X ⟶ Y} {g : Y' ⟶ Y} {p' : X' ⟶ Y'} {g' : X' ⟶ X}
  {fg : B ⟶ Y} {fg' : A ⟶ X}
  (sq₂ : is_pullback g' p' p g) (sq₁ : comm_sq f' i p' f)
  (sq₁₂ : comm_sq fg' i p fg)
  (hfg : fg = f ≫ g) (hfg' : fg' = f' ≫ g')

include hfg hfg'

def lift_struct_equiv : sq₁.lift_struct ≃ sq₁₂.lift_struct :=
{ to_fun := λ l,
  { l := l.l ≫ g',
    fac_left' := by rw [hfg', l.fac_left_assoc],
    fac_right' := by rw [assoc, sq₂.w, l.fac_right_assoc, hfg], },
  inv_fun := λ l,
  { l := sq₂.lift l.l f (by rw [l.fac_right, hfg]),
    fac_left' := sq₂.hom_ext (by rw [assoc, lift_fst, l.fac_left, hfg'])
      (by rw [assoc, lift_snd, sq₁.w]),
    fac_right' := by rw [lift_snd], },
  left_inv := λ l, by { ext, exact sq₂.hom_ext (by rw lift_fst) (by rw [lift_snd, l.fac_right]), },
  right_inv := λ l, by { ext, simp only [lift_fst], }, }

include sq₂
def has_lift_iff : sq₁.has_lift ↔ sq₁₂.has_lift :=
begin
  split,
  { intro h₁,
    exact comm_sq.has_lift.mk'
      ((sq₂.lift_struct_equiv sq₁ sq₁₂ hfg hfg').to_fun h₁.exists_lift.some), },
  { intro h₁₂,
    exact comm_sq.has_lift.mk'
      ((sq₂.lift_struct_equiv sq₁ sq₁₂ hfg hfg').inv_fun h₁₂.exists_lift.some), },
end

end

lemma has_lifting_property_imp {A B X Y X' Y' : C} {p : X ⟶ Y} {p' : X' ⟶ Y'}
  {g : Y' ⟶ Y} {g' : X' ⟶ X} (sq₂ : is_pullback g' p' p g) (i : A ⟶ B)
  (hip : has_lifting_property i p) : has_lifting_property i p' :=
⟨λ f' f sq₁, begin
  have sq₁₂ : comm_sq (f' ≫ g') i p (f ≫ g) := comm_sq.mk (by rw [assoc, sq₂.w, sq₁.w_assoc]),
  rw sq₂.has_lift_iff sq₁ sq₁₂ rfl rfl,
  haveI := hip,
  apply_instance,
end⟩

end is_pullback

namespace is_pushout

section

variables {A B X Y Z : C}
  {i : A ⟶ B} {f' : A ⟶ X} {f : B ⟶ Y} {p : X ⟶ Y}
  (h : is_pushout f' i p f) (f₁ : X ⟶ Z) (f₂ : B ⟶ Z)
  (fac : f' ≫ f₁ = i ≫ f₂)

def desc : Y ⟶ Z := (pushout_cocone.is_colimit.desc' h.is_colimit f₁ f₂ fac).1

@[simp, reassoc]
lemma inl_desc : p ≫ h.desc f₁ f₂ fac = f₁ :=
(pushout_cocone.is_colimit.desc' h.is_colimit f₁ f₂ fac).2.1

@[simp, reassoc]
lemma lift_snd : f ≫ h.desc f₁ f₂ fac = f₂ :=
(pushout_cocone.is_colimit.desc' h.is_colimit f₁ f₂ fac).2.2

include h
def hom_ext {l₁ l₂ : Y ⟶ Z} (h₁ : p ≫ l₁ = p ≫ l₂)
  (h₂ : f ≫ l₁ = f ≫ l₂) : l₁ = l₂ :=
pushout_cocone.is_colimit.hom_ext h.is_colimit h₁ h₂

end

section

variables
  {A B A' B' X Y : C}
  {f : A ⟶ A'} {i : A ⟶ B} {f' : B ⟶ B'} {i' : A' ⟶ B'}
  {g : A' ⟶ X} {g' : B' ⟶ Y} {p : X ⟶ Y}
  {fg : A ⟶ X} {fg' : B ⟶ Y}
  (sq₁ : is_pushout f i i' f') (sq₂ : comm_sq g i' p g')
  (sq₁₂ : comm_sq fg i p fg')
  (hfg : fg = f ≫ g) (hfg' : fg' = f' ≫ g')

include hfg hfg'

def lift_struct_equiv : sq₂.lift_struct ≃ sq₁₂.lift_struct :=
{ to_fun := λ l,
  { l := f' ≫ l.l,
    fac_left' := by rw [← sq₁.to_comm_sq.w_assoc, l.fac_left, hfg],
    fac_right' := by rw [assoc, l.fac_right, hfg'], },
  inv_fun := λ l,
  { l := sq₁.desc g l.l (by rw [l.fac_left, hfg]),
    fac_left' := by simp only [inl_desc],
    fac_right' := sq₁.hom_ext (by simp only [inl_desc_assoc, sq₂.w])
        (by simp only [lift_snd_assoc, l.fac_right, hfg']), },
  left_inv := λ l, by { ext, exact sq₁.hom_ext (by simp only [l.fac_left, inl_desc])
    (by simp only [lift_snd]), },
  right_inv := λ l, by { ext, simp only [lift_snd], }, }

include sq₁
def has_lift_iff : sq₂.has_lift ↔ sq₁₂.has_lift :=
begin
  split,
  { intro h₁,
    exact comm_sq.has_lift.mk'
      ((sq₁.lift_struct_equiv sq₂ sq₁₂ hfg hfg').to_fun h₁.exists_lift.some), },
  { intro h₁₂,
    exact comm_sq.has_lift.mk'
      ((sq₁.lift_struct_equiv sq₂ sq₁₂ hfg hfg').inv_fun h₁₂.exists_lift.some), },
end

end

lemma has_lifting_property_imp {A B A' B' X Y : C} {f : A ⟶ A'} {i : A ⟶ B}
  {f' : B ⟶ B'} {i' : A' ⟶ B'} (sq₁ : is_pushout f i i' f') (p : X ⟶ Y)
  (hip : has_lifting_property i p) : has_lifting_property i' p :=
⟨λ g g' sq₂, begin
  have sq₁₂ : comm_sq (f ≫ g) i p (f' ≫ g') := comm_sq.mk
    (by rw [assoc, sq₂.w, sq₁.to_comm_sq.w_assoc]),
  rw sq₁.has_lift_iff sq₂ sq₁₂ rfl rfl,
  haveI := hip,
  apply_instance,
end⟩

end is_pushout

end category_theory


import for_mathlib.abelian_sheaves.main
import category_theory.abelian.exact
import category_theory.abelian.homology
import category_theory.sites.left_exact
import for_mathlib.chain_complex_exact
import for_mathlib.homology_iso
import for_mathlib.exact_functor

universes w v u

open category_theory
open category_theory.limits

variables {C : Type (max v u)} [category.{v} C] {J : grothendieck_topology C}
variables {A : Type w} [category.{max v u} A] [abelian A]
variables [concrete_category.{max v u} A]
variables [∀ (P : Cᵒᵖ ⥤ A) (X : C) (S : J.cover X), limits.has_multiequalizer (S.index P)]
variables [limits.preserves_limits (forget A)]
variables [∀ (X : C), limits.has_colimits_of_shape (J.cover X)ᵒᵖ A]
variables [∀ (X : C), limits.preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget A)]
variables [reflects_isomorphisms (forget A)]

noncomputable theory

-- Just checking...
example : abelian (Sheaf J A) := infer_instance
example : preserves_finite_limits (presheaf_to_Sheaf J A) := infer_instance
example : functor.preserves_zero_morphisms (presheaf_to_Sheaf J A) :=
  infer_instance

-- Missing
instance : preserves_colimits (presheaf_to_Sheaf J A) :=
(sheafification_adjunction J A).left_adjoint_preserves_colimits

.

namespace category_theory.Sheaf

theorem exact_of_exact (X Y Z : Cᵒᵖ ⥤ A) (f : X ⟶ Y) (g : Y ⟶ Z)
  (e : exact f g) :
  exact ((presheaf_to_Sheaf J A).map f) ((presheaf_to_Sheaf J A).map g) :=
begin
  rw abelian.exact_iff at *,
  split,
  { rw [← functor.map_comp, e.1], simp, },
  { let K := kernel g,
    let Q := cokernel f,
    let P := presheaf_to_Sheaf J A,
    let eK : P.obj K ≅ kernel (P.map g) :=
      preserves_kernel.iso _ _,
    let eQ : P.obj Q ≅ cokernel (P.map f) :=
      preserves_cokernel.iso _ _,
    have : kernel.ι (P.map g) =
      eK.inv ≫ P.map (kernel.ι g),
    { dsimp [eK],
      rw iso.eq_inv_comp,
      simp only [preserves_kernel.iso_hom, kernel_comparison_comp_ι] },
    rw this, clear this,
    have : cokernel.π (P.map f) =
      P.map (cokernel.π f) ≫ eQ.hom,
    { dsimp [eQ], rw ← iso.comp_inv_eq,
      simp only [preserves_cokernel.iso_inv, π_comp_cokernel_comparison] },
    rw this, clear this,
    simp only [category.assoc, e.2, ← P.map_comp_assoc,
      P.map_zero, zero_comp, comp_zero] }
end

instance presheaf_to_Sheaf_additive :
  functor.additive (presheaf_to_Sheaf J A) :=
begin
  apply_with functor.additive_of_preserves_binary_biproducts { instances := ff },
  apply_with has_binary_biproducts_of_finite_biproducts { instances := ff },
  apply_instance,
  apply preserves_binary_biproducts_of_preserves_binary_coproducts,
  apply_instance,
end

lemma map_presheaf_to_Sheaf_homology_zero_of_homology_zero
  (D : chain_complex (Cᵒᵖ ⥤ A) ℕ)
  (h : ∀ i : ℕ, is_zero (D.homology i)) :
  ∀ i : ℕ, is_zero
    ((((presheaf_to_Sheaf J A).map_homological_complex _).obj D).homology i) :=
begin
  rw ← chain_complex.epi_and_exact_iff_zero_homology' at *,
  split,
  { haveI := h.1, apply preserves_epi_of_preserves_colimit },
  { intros i,
    apply exact_of_exact,
    apply h.2 },
end

lemma sheafification_exact : functor.exact (presheaf_to_Sheaf J A) :=
λ X Y Z f g h, exact_of_exact _ _ _ _ _ h

end category_theory.Sheaf

namespace category_theory

instance evaluation_additive (X : C) : functor.additive ((evaluation C A).obj X) :=
⟨λ F G η γ, rfl⟩

def evaluation_homology_iso (X Y Z : C ⥤ A) (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) (t : C) :
  (homology f g w).obj t ≅ (homology (f.app t) (g.app t) $
    by { rw [← nat_trans.comp_app, w], simp, }) :=
{ hom := homology.lift _ _ _
    ((homology.ι f g w).app t ≫ (nat_trans.cokernel_obj_iso f t).hom) begin
      rw category.assoc, let e := _, change _ ≫ e = _,
      have he : e = (cokernel.desc f g w).app t,
      { dsimp [e],
        rw ← iso.eq_inv_comp,
        ext,
        simp },
      rw [he, ← nat_trans.comp_app],
      simp only [homology.condition_ι, nat_trans.app_zero],
    end,
  inv := homology.desc' _ _ _
    ((nat_trans.kernel_obj_iso g t).inv ≫ (homology.π' f g w).app t) begin
      rw ← category.assoc, let e := _, change e ≫ _ = _,
      have he : e = (kernel.lift g f w).app t,
      { dsimp [e], rw iso.comp_inv_eq,
        ext,
        simp },
      rw [he, ← nat_trans.comp_app],
      simp only [homology.condition_π', nat_trans.app_zero],
    end,
  hom_inv_id' := begin
    let a := _, change a ≫ _ = _,
    haveI : epi ((homology.π' f g w).app t),
    { rw abelian.epi_iff_cokernel_π_eq_zero,
      let b := homology.π' f g w,
      have : cokernel.π (b.app t) = (cokernel.π b).app t ≫
        (nat_trans.cokernel_obj_iso b _).hom,
      { simp },
      rw [this, ← iso.eq_comp_inv, zero_comp],
      suffices : cokernel.π b = 0,
      { simp [this], },
      rw ← abelian.epi_iff_cokernel_π_eq_zero,
      dsimp [b, homology.π'],
      apply epi_comp },
    rw ← cancel_epi ((homology.π' f g w).app t),
    have ha : ((homology.π' f g w).app t ≫ a) =
      (nat_trans.kernel_obj_iso _ _).hom ≫ homology.π' _ _ _,
    { dsimp [a],
      apply homology.hom_to_ext,
      simp only [category.assoc, homology.lift_ι, homology.π'_ι,
        nat_trans.kernel_obj_iso_hom_ι_assoc],
      rw [← category.assoc, ← iso.eq_comp_inv],
      simp only [category.assoc, nat_trans.cokernel_obj_iso_π_inv],
      rw [← nat_trans.comp_app, homology.π'_ι, nat_trans.comp_app] },
    rw reassoc_of ha,
    simp only [homology.π'_desc', iso.hom_inv_id_assoc, category.comp_id],
  end,
  inv_hom_id' := begin
    apply homology.hom_from_ext, apply homology.hom_to_ext,
    simp only [category.assoc, homology.π'_desc'_assoc, homology.lift_ι,
      category.comp_id, homology.π'_ι],
    rw [iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv,
      ← nat_trans.comp_app, homology.π'_ι],
    simp,
  end }

-- Homology of functors is computed pointwise...
lemma homology_zero_of_eval
  (D : chain_complex (C ⥤ A) ℕ)
  (h : ∀ (X : C) (i : ℕ), is_zero
    (((((evaluation C A).obj X).map_homological_complex _).obj D).homology i)) :
  ∀ i : ℕ, is_zero (D.homology i) :=
begin
  rw ← chain_complex.epi_and_exact_iff_zero_homology',
  split,
  { apply_with nat_trans.epi_of_epi_app { instances := ff },
    intros X,
    specialize h X,
    rw ← chain_complex.epi_and_exact_iff_zero_homology' at h,
    exact h.1 },
  { intros i, rw preadditive.exact_iff_homology_zero,
    refine ⟨_,_⟩,
    { ext X, specialize h X,
      rw ← chain_complex.epi_and_exact_iff_zero_homology' at h, replace h := h.2 i,
      rw preadditive.exact_iff_homology_zero at h,
      obtain ⟨w,hw⟩ := h, exact w },
    { refine ⟨is_zero.iso_zero _⟩,
      apply functor.is_zero,
      intros X,
      specialize h X (i+1),
      refine is_zero.of_iso _ (evaluation_homology_iso _ _ _ _ _ _ _),
      apply is_zero.of_iso h,
      symmetry, apply homology_iso; exact rfl } }
end

end category_theory


import order.filter.germ
import topology.constructions

import topology.connected
import topology.separation

import to_mathlib.topology.nhds_set

open_locale topology
open filter set

/-- The value associated to a germ at a point. This is the common value
shared by all representatives at the given point. -/
def filter.germ.value {X α : Type*} [topological_space X] {x : X} (φ : germ (𝓝 x) α) : α :=
quotient.lift_on' φ (λ f, f x) (λ f g h, by { dsimp only, rw eventually.self_of_nhds h })

/-- Given a predicate on germs `P : Π x : X, germ (𝓝 x) Y → Prop` and `A : set X`,
build a new predicate on germs `restrict_germ_predicate P A` such that
`(∀ x, restrict_germ_predicate P A x f) ↔ ∀ᶠ x near A, P x f`, see
`forall_restrict_germ_predicate_iff` for this equivalence. -/
def restrict_germ_predicate {X Y : Type*} [topological_space X]
  (P : Π x : X, germ (𝓝 x) Y → Prop) (A : set X) : Π x : X, germ (𝓝 x) Y → Prop :=
λ x φ, quotient.lift_on' φ (λ f, x ∈ A → ∀ᶠ y in 𝓝 x, P y f) begin
  have : ∀ f f' : X → Y, f =ᶠ[𝓝 x] f' → (∀ᶠ y in 𝓝 x, P y f) → ∀ᶠ y in 𝓝 x, P y f',
  { intros f f' hff' hf,
    apply (hf.and $ eventually.eventually_nhds hff').mono,
    rintros y ⟨hy, hy'⟩,
    rwa germ.coe_eq.mpr (eventually_eq.symm hy') },
  exact λ f f' hff', propext $ forall_congr $ λ _, ⟨this f f' hff', this f' f hff'.symm⟩,
end

lemma filter.eventually.germ_congr {X Y : Type*} [topological_space X]
  {P : Π x : X, germ (𝓝 x) Y → Prop} {A : set X} {f g : X → Y}
  (hf : ∀ᶠ x in 𝓝ˢ A, P x f) (h : ∀ᶠ z in 𝓝ˢ A, g z = f z) : ∀ᶠ x in 𝓝ˢ A, P x g :=
begin
  rw eventually_nhds_set_iff at *,
  intros x hx,
  apply ((hf x hx).and (h x hx).eventually_nhds).mono,
  intros y hy,
  convert hy.1 using 1,
  apply quotient.sound,
  exact hy.2
end

lemma restrict_germ_predicate_congr {X Y : Type*} [topological_space X]
  {P : Π x : X, germ (𝓝 x) Y → Prop} {A : set X} {f g : X → Y} {x : X}
  (hf : restrict_germ_predicate P A x f) (h : ∀ᶠ z in 𝓝ˢ A, g z = f z) :
  restrict_germ_predicate P A x g :=
begin
  intros hx,
  apply ((hf hx).and $ eventually_nhds_set_iff.mp h x hx).eventually_nhds.mono,
  intros y hy,
  rw eventually_and at hy,
  convert hy.1.self_of_nhds using 1,
  apply quotient.sound,
  exact hy.2,
end

lemma forall_restrict_germ_predicate_iff {X Y : Type*} [topological_space X]
  {P : Π x : X, germ (𝓝 x) Y → Prop} {A : set X} {f : X → Y} :
  (∀ x, restrict_germ_predicate P A x f) ↔ ∀ᶠ x in 𝓝ˢ A, P x f :=
by { rw eventually_nhds_set_iff, exact iff.rfl }

lemma  forall_restrict_germ_predicate_of_forall {X Y : Type*} [topological_space X]
  {P : Π x : X, germ (𝓝 x) Y → Prop} {A : set X} {f : X → Y} (h : ∀ x, P x f) :
  ∀ x, restrict_germ_predicate P A x f :=
forall_restrict_germ_predicate_iff.mpr (eventually_of_forall h)

lemma filter.eventually_eq.comp_fun {α β γ : Type*} {f g : β → γ} {l : filter α} {l' : filter β}
  (h : f =ᶠ[l'] g) {φ : α → β} (hφ : tendsto φ l l') : f ∘ φ =ᶠ[l] g ∘ φ :=
hφ h

def filter.germ.slice_left {X Y Z : Type*} [topological_space X] [topological_space Y] {p : X × Y}
  (P : germ (𝓝 p) Z) : germ (𝓝 p.1) Z :=
P.lift_on (λ f, ((λ x', f (x', p.2)) : germ (𝓝 p.1) Z))
  (λ f g hfg, @quotient.sound _ ((𝓝 p.1).germ_setoid Z) _ _
     (hfg.comp_fun begin
       rw ← (prod.mk.eta : (p.1, p.2) = p),
       exact (continuous.prod.mk_left p.2).continuous_at,
     end))

def filter.germ.slice_right {X Y Z : Type*} [topological_space X] [topological_space Y] {p : X × Y}
  (P : germ (𝓝 p) Z) : germ (𝓝 p.2) Z :=
P.lift_on (λ f, ((λ y, f (p.1, y)) : germ (𝓝 p.2) Z))
  (λ f g hfg, @quotient.sound _ ((𝓝 p.2).germ_setoid Z) _ _
     (hfg.comp_fun begin
       rw ← (prod.mk.eta : (p.1, p.2) = p),
       exact (continuous.prod.mk p.1).continuous_at,
     end))

def filter.germ.is_constant {X Y : Type*} [topological_space X] {x} (P : germ (𝓝 x) Y) : Prop :=
P.lift_on (λ f, ∀ᶠ x' in 𝓝 x, f x' = f x) begin
  suffices : ∀ (f g : X → Y), f =ᶠ[𝓝 x] g →
     (∀ᶠ x' in 𝓝 x, f x' = f x) → ∀ᶠ x' in 𝓝 x, g x' = g x,
  from λ f g hfg, propext ⟨λ h, this f g hfg h, λ h, this g f hfg.symm h⟩,
  rintros f g hfg hf,
  apply (hf.and hfg).mono (λ x' hx', _),
  rw [← hx'.2, hx'.1, hfg.eq_of_nhds],
end

lemma eq_of_germ_is_constant {X Y : Type*} [topological_space X] [preconnected_space X]
  {f : X → Y} (h : ∀ x : X, (f : germ (𝓝 x) Y).is_constant) (x x' : X) : f x = f x' :=
begin
  revert x,
  erw ← eq_univ_iff_forall,
  apply is_clopen.eq_univ _ (⟨x', rfl⟩ : {x | f x = f x'}.nonempty),
  refine ⟨is_open_iff_eventually.mpr (λ x hx, hx ▸ h x), _⟩,
  rw is_closed_iff_frequently,
  rintros x hx,
  rcases (eventually.and_frequently (h x) hx).exists with ⟨x'', H⟩,
  exact H.1.symm.trans H.2
end

lemma eq_of_germ_is_constant_on {X Y : Type*} [topological_space X]
  {f : X → Y} {s : set X} (h : ∀ x ∈ s, (f : germ (𝓝 x) Y).is_constant)
  (hs : is_preconnected s) {x x' : X} (x_in : x ∈ s) (x'_in : x' ∈ s) : f x = f x' :=
begin
  haveI := is_preconnected_iff_preconnected_space.mp hs,
  let F : s → Y := f ∘ coe,
  change F ⟨x, x_in⟩ = F ⟨x', x'_in⟩,
  apply eq_of_germ_is_constant,
  rintros ⟨x, hx⟩,
  have : continuous_at (coe : s → X) ⟨x, hx⟩,
  exact continuous_at_subtype_coe,
  exact this (h x hx)
end


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

/-!
# Binary disjoint unions of categories

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

We define the category instance on `C ⊕ D` when `C` and `D` are categories.

We define:
* `inl_`      : the functor `C ⥤ C ⊕ D`
* `inr_`      : the functor `D ⥤ C ⊕ D`
* `swap`      : the functor `C ⊕ D ⥤ D ⊕ C`
    (and the fact this is an equivalence)

We further define sums of functors and natural transformations, written `F.sum G` and `α.sum β`.
-/

namespace category_theory

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

open sum

section
variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]

/--
`sum C D` gives the direct sum of two categories.
-/
instance sum : category.{v₁} (C ⊕ D) :=
{ hom :=
    λ X Y, match X, Y with
    | inl X, inl Y := X ⟶ Y
    | inl X, inr Y := pempty
    | inr X, inl Y := pempty
    | inr X, inr Y := X ⟶ Y
    end,
  id :=
    λ X, match X with
    | inl X := 𝟙 X
    | inr X := 𝟙 X
    end,
  comp :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := f ≫ g
    | inr X, inr Y, inr Z, f, g := f ≫ g
    end }

@[simp] lemma sum_comp_inl {P Q R : C} (f : (inl P : C ⊕ D) ⟶ inl Q)
  (g : (inl Q : C ⊕ D) ⟶ inl R) :
  @category_struct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
  @category_struct.comp _ _ (inl P) (inl Q) (inl R) (f : P ⟶ Q) (g : Q ⟶ R) := rfl
@[simp] lemma sum_comp_inr {P Q R : D} (f : (inr P : C ⊕ D) ⟶ inr Q)
  (g : (inr Q : C ⊕ D) ⟶ inr R) :
  @category_struct.comp _ _ P Q R (f : P ⟶ Q) (g : Q ⟶ R) =
  @category_struct.comp _ _ (inr P) (inr Q) (inr R) (f : P ⟶ Q) (g : Q ⟶ R) := rfl
end

namespace sum

variables (C : Type u₁) [category.{v₁} C] (D : Type u₁) [category.{v₁} D]

/-- `inl_` is the functor `X ↦ inl X`. -/
-- Unfortunate naming here, suggestions welcome.
@[simps] def inl_ : C ⥤ C ⊕ D :=
{ obj := λ X, inl X,
  map := λ X Y f, f }

/-- `inr_` is the functor `X ↦ inr X`. -/
@[simps] def inr_ : D ⥤ C ⊕ D :=
{ obj := λ X, inr X,
  map := λ X Y f, f }

/-- The functor exchanging two direct summand categories. -/
def swap : C ⊕ D ⥤ D ⊕ C :=
{ obj :=
    λ X, match X with
    | inl X := inr X
    | inr X := inl X
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := f
    | inr X, inr Y, f := f
    end }

@[simp] lemma swap_obj_inl (X : C) : (swap C D).obj (inl X) = inr X := rfl
@[simp] lemma swap_obj_inr (X : D) : (swap C D).obj (inr X) = inl X := rfl
@[simp] lemma swap_map_inl {X Y : C} {f : inl X ⟶ inl Y} : (swap C D).map f = f := rfl
@[simp]

namespace swap

/-- `swap` gives an equivalence between `C ⊕ D` and `D ⊕ C`. -/
def equivalence : C ⊕ D ≌ D ⊕ C :=
equivalence.mk (swap C D) (swap D C)
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))
  (nat_iso.of_components (λ X, eq_to_iso (by { cases X; refl })) (by tidy))

instance is_equivalence : is_equivalence (swap C D) :=
(by apply_instance : is_equivalence (equivalence C D).functor)

/-- The double swap on `C ⊕ D` is naturally isomorphic to the identity functor. -/
def symmetry : swap C D ⋙ swap D C ≅ 𝟭 (C ⊕ D) :=
(equivalence C D).unit_iso.symm

end swap

end sum

variables {A : Type u₁} [category.{v₁} A]
          {B : Type u₁} [category.{v₁} B]
          {C : Type u₁} [category.{v₁} C]
          {D : Type u₁} [category.{v₁} D]

namespace functor

/-- The sum of two functors. -/
def sum (F : A ⥤ B) (G : C ⥤ D) : A ⊕ C ⥤ B ⊕ D :=
{ obj :=
    λ X, match X with
    | inl X := inl (F.obj X)
    | inr X := inr (G.obj X)
    end,
  map :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := F.map f
    | inr X, inr Y, f := G.map f
    end,
  map_id' := λ X, begin cases X; unfold_aux, erw F.map_id, refl, erw G.map_id, refl end,
  map_comp' :=
    λ X Y Z f g, match X, Y, Z, f, g with
    | inl X, inl Y, inl Z, f, g := by { unfold_aux, erw F.map_comp, refl }
    | inr X, inr Y, inr Z, f, g := by { unfold_aux, erw G.map_comp, refl }
    end }

@[simp] lemma sum_obj_inl (F : A ⥤ B) (G : C ⥤ D) (a : A) :
  (F.sum G).obj (inl a) = inl (F.obj a) := rfl
@[simp] lemma sum_obj_inr (F : A ⥤ B) (G : C ⥤ D) (c : C) :
  (F.sum G).obj (inr c) = inr (G.obj c) := rfl
@[simp] lemma sum_map_inl (F : A ⥤ B) (G : C ⥤ D) {a a' : A} (f : inl a ⟶ inl a') :
  (F.sum G).map f = F.map f := rfl
@[simp] lemma sum_map_inr (F : A ⥤ B) (G : C ⥤ D) {c c' : C} (f : inr c ⟶ inr c') :
  (F.sum G).map f = G.map f := rfl
end functor

namespace nat_trans

/-- The sum of two natural transformations. -/
def sum {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) : F.sum H ⟶ G.sum I :=
{ app         :=
    λ X, match X with
    | inl X := α.app X
    | inr X := β.app X
    end,
  naturality' :=
    λ X Y f, match X, Y, f with
    | inl X, inl Y, f := begin unfold_aux, erw α.naturality, refl, end
    | inr X, inr Y, f := begin unfold_aux, erw β.naturality, refl, end
    end }

@[simp] lemma sum_app_inl {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (a : A) :
  (sum α β).app (inl a) = α.app a := rfl
@[simp] lemma sum_app_inr {F G : A ⥤ B} {H I : C ⥤ D} (α : F ⟶ G) (β : H ⟶ I) (c : C) :
  (sum α β).app (inr c) = β.app c := rfl
end nat_trans

end category_theory


import Lean
set_option pp.analyze false

def p (x y : Nat) := x = y

example (x y : Nat) : p (x + y) (y + x + 0) := by
  conv =>
    trace_state
    whnf
    tactic' => trace_state
    trace_state
    congr
    next => rfl
    any_goals whnf; rfl
  conv' =>
    trace_state
    apply id ?x
  conv =>
    fail_if_success case x => whnf
  trace_state
  rw [Nat.add_comm]
  rfl

def foo (x y : Nat) : Nat := x + y

example : foo (0 + a) (b + 0) = a + b := by
  conv =>
    apply id
    lhs
    trace_state
    congr
    trace_state
    case x =>
      simp
      trace_state
    fail_if_success case x => skip
    case' y => skip
    case y => skip
    done

example : foo (0 + a) (b + 0) = a + b := by
  conv =>
    lhs
    conv =>
      congr
      trace_state
      focus
        trace_state
      tactic => simp
      trace_state
      all_goals dsimp (config := {}) []
    simp [foo]
    trace_state

example : foo (0 + a) (b + 0) = a + b := by
  conv =>
    lhs
    congr <;> simp
    fail_if_success lhs
    try lhs
    trace_state

example (x y : Nat) : p (x + y) (y + x + 0) := by
  conv =>
    whnf
    rhs
    whnf
  trace_state
  rw [Nat.add_comm]
  rfl

example (x y : Nat) : p (x + y) (y + x + 0) := by
  conv =>
    whnf
    lhs
    whnf
  conv =>
    rhs
    whnf
  trace_state
  apply Nat.add_comm x y

def f (x y z : Nat) : Nat :=
  y

example (x y : Nat) : f x (x + y + 0) y = y + x := by
  conv =>
    lhs
    arg 2
    whnf
  trace_state
  simp [f]
  apply Nat.add_comm

example (x y : Nat) : f x (x + y + 0) y = y + x := by
  conv =>
    lhs
    arg 2
    change x + y
    trace_state
    rw [Nat.add_comm]

example : id (fun x y => 0 + x + y) = Nat.add := by
  conv =>
    lhs
    arg 1
    ext a b
    trace_state
    rw [Nat.zero_add]
    trace_state

example : id (fun x y => 0 + x + y) = Nat.add := by
  conv =>
    lhs
    arg 1
    intro a b
    rw [Nat.zero_add]

example : id (fun x y => 0 + x + y) = Nat.add := by
  conv =>
    enter [1, 1, a, b]
    trace_state
    rw [Nat.zero_add]

example (p : Nat → Prop) (h : ∀ a, p a) : ∀ a, p (id (0 + a)) := by
  conv =>
    intro x
    trace_state
    arg 1
    trace_state
    simp only [id]
    trace_state
    rw [Nat.zero_add]
  exact h

example (p : Prop) (x : Nat) : (x = x → p) → p := by
  conv =>
    congr
    . trace_state
      congr
      . simp
  trace_state
  conv =>
    lhs
    simp
  intros
  assumption

example : (fun x => 0 + x) = id := by
  conv =>
    lhs
    tactic => funext x
    trace_state
    rw [Nat.zero_add]

example (p : Prop) (x : Nat) : (x = x → p) → p := by
  conv =>
    apply implies_congr
    . apply implies_congr
      simp
  trace_state
  conv =>
    lhs
    simp
  intros; assumption

example (x y : Nat) (f : Nat → Nat → Nat) (g : Nat → Nat) (h₁ : ∀ z, f z z = z) (h₂ : ∀ x y, f (g x) (g y) = y) : f (g (0 + y)) (f (g x) (g (0 + x))) = x := by
  conv =>
    pattern _ + _
    apply Nat.zero_add
  trace_state
  conv =>
    pattern 0 + _
    apply Nat.zero_add
  trace_state
  simp [h₁, h₂]

example (x y : Nat) (h : y = 0) : x + ((y + x) + x) = x + (x + x) := by
  conv =>
    lhs
    rhs
    lhs
    trace_state
    rw [h, Nat.zero_add]

example (p : Nat → Prop) (x y : Nat) (h1 : y = 0) (h2 : p x) : p (y + x) := by
  conv =>
    rhs
    trace_state
    rw [h1]
    apply Nat.zero_add
  exact h2

example (p : (n : Nat) → Fin n → Prop) (i : Fin 5) (hp : p 5 i) (hi : j = i) : p 5 j := by
  conv =>
    arg 2
    trace_state
    rw [hi]
  exact hp

example (p : {_ : Nat} → Nat → Prop) (x y : Nat) (h1 : y = 0) (h2 : @p x x) : @p (y + x) (y + x) := by
  conv =>
    enter [@1, 1]
    trace_state
    rw [h1]
  conv =>
    enter [@2, 1]
    trace_state
    rw [h1]
  rw [Nat.zero_add]
  exact h2

example (p : Nat → Prop) (x y : Nat) (h : y = 0) : p (y + x) := by
  conv => lhs

example (p : Nat → Prop) (x y : Nat) (h : y = 0) : p (y + x) := by
  conv => arg 2

example (p : Prop) : p := by
  conv => rhs

example (p : (n : Nat) → Fin n → Prop) (i : Fin 5) (hp : p 5 i) : p 5 j := by
  conv => arg 1

-- repeated `zeta`
example : let a := 0; let b := a; b = 0 := by
  intros
  conv =>
    zeta
    trace_state

example : ((x + y) + z : Nat) = x + (y + z) := by
  conv in _ + _ => trace_state
  conv in (occs := *) _ + _ => trace_state
  conv in (occs := 1 3) _ + _ => trace_state
  conv in (occs := 3 1) _ + _ => trace_state
  conv in (occs := 2 3) _ + _ => trace_state
  conv in (occs := 2 4) _ + _ => trace_state
  apply Nat.add_assoc

example : ((x + y) + z : Nat) = x + (y + z) := by conv => pattern (occs := 5) _ + _
example : ((x + y) + z : Nat) = x + (y + z) := by conv => pattern (occs := 2 5) _ + _
example : ((x + y) + z : Nat) = x + (y + z) := by conv => pattern (occs := 1 5) _ + _
example : ((x + y) + z : Nat) = x + (y + z) := by conv => pattern (occs := 1 2 5) _ + _

macro "bla" : term => `(?a)
example : 1 = 1 := by conv => apply bla; congr

example (h : a = a') (H : a + a' = 0) : a + a = 0 := by
  conv in (occs := 2) a => rw [h]
  apply H


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Instances on punit.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

namespace punit

protected instance comm_group : comm_group PUnit :=
  comm_group.mk (fun (_x _x : PUnit) => PUnit.unit) sorry PUnit.unit sorry sorry
    (fun (_x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => PUnit.unit) sorry sorry

protected instance comm_ring : comm_ring PUnit :=
  comm_ring.mk add_comm_group.add add_comm_group.add_assoc add_comm_group.zero
    add_comm_group.zero_add add_comm_group.add_zero add_comm_group.neg add_comm_group.sub
    add_comm_group.add_left_neg add_comm_group.add_comm comm_group.mul comm_group.mul_assoc
    comm_group.one comm_group.one_mul comm_group.mul_one sorry sorry comm_group.mul_comm

protected instance complete_boolean_algebra : complete_boolean_algebra PUnit :=
  complete_boolean_algebra.mk (fun (_x _x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => True)
    (fun (_x _x : PUnit) => False) sorry sorry sorry sorry sorry sorry
    (fun (_x _x : PUnit) => PUnit.unit) sorry sorry sorry sorry PUnit.unit sorry PUnit.unit sorry
    (fun (_x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => PUnit.unit) sorry sorry sorry
    (fun (_x : set PUnit) => PUnit.unit) (fun (_x : set PUnit) => PUnit.unit) sorry sorry sorry
    sorry sorry sorry

protected instance canonically_ordered_add_monoid : canonically_ordered_add_monoid PUnit :=
  canonically_ordered_add_monoid.mk comm_ring.add comm_ring.add_assoc comm_ring.zero
    comm_ring.zero_add comm_ring.add_zero comm_ring.add_comm complete_boolean_algebra.le
    complete_boolean_algebra.lt complete_boolean_algebra.le_refl complete_boolean_algebra.le_trans
    complete_boolean_algebra.le_antisymm sorry sorry complete_boolean_algebra.bot
    complete_boolean_algebra.bot_le sorry

protected instance linear_ordered_cancel_add_comm_monoid :
    linear_ordered_cancel_add_comm_monoid PUnit :=
  linear_ordered_cancel_add_comm_monoid.mk canonically_ordered_add_monoid.add
    canonically_ordered_add_monoid.add_assoc sorry canonically_ordered_add_monoid.zero
    canonically_ordered_add_monoid.zero_add canonically_ordered_add_monoid.add_zero
    canonically_ordered_add_monoid.add_comm sorry canonically_ordered_add_monoid.le
    canonically_ordered_add_monoid.lt canonically_ordered_add_monoid.le_refl
    canonically_ordered_add_monoid.le_trans canonically_ordered_add_monoid.le_antisymm
    canonically_ordered_add_monoid.add_le_add_left sorry sorry
    (fun (_x _x : PUnit) => decidable.true) punit.decidable_eq
    fun (_x _x : PUnit) => decidable.false

protected instance semimodule (R : Type u) [semiring R] : semimodule R PUnit :=
  semimodule.of_core
    (semimodule.core.mk (has_scalar.mk fun (_x : R) (_x : PUnit) => PUnit.unit) sorry sorry sorry
      sorry)

@[simp] theorem zero_eq : 0 = PUnit.unit := rfl

@[simp] theorem one_eq : 1 = PUnit.unit := rfl

@[simp] theorem add_eq (x : PUnit) (y : PUnit) : x + y = PUnit.unit := rfl

@[simp] theorem mul_eq (x : PUnit) (y : PUnit) : x * y = PUnit.unit := rfl

@[simp] theorem sub_eq (x : PUnit) (y : PUnit) : x - y = PUnit.unit := rfl

@[simp] theorem neg_eq (x : PUnit) : -x = PUnit.unit := rfl

@[simp] theorem inv_eq (x : PUnit) : x⁻¹ = PUnit.unit := rfl

theorem smul_eq (x : PUnit) (y : PUnit) : x • y = PUnit.unit := rfl

@[simp] theorem top_eq : ⊤ = PUnit.unit := rfl

@[simp] theorem bot_eq : ⊥ = PUnit.unit := rfl

@[simp] theorem sup_eq (x : PUnit) (y : PUnit) : x ⊔ y = PUnit.unit := rfl

@[simp] theorem inf_eq (x : PUnit) (y : PUnit) : x ⊓ y = PUnit.unit := rfl

@[simp] theorem Sup_eq (s : set PUnit) : Sup s = PUnit.unit := rfl

@[simp] theorem Inf_eq (s : set PUnit) : Inf s = PUnit.unit := rfl

@[simp] protected theorem le (x : PUnit) (y : PUnit) : x ≤ y := trivial

@[simp] theorem not_lt (x : PUnit) (y : PUnit) : ¬x < y := not_false

end Mathlib


/-
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 order.category.BoundedLattice
import order.category.DistribLattice

/-!
# The category of bounded distributive lattices

This defines `BoundedDistribLattice`, the category of bounded distributive lattices.

Note that this category is sometimes called [`DistLat`](https://ncatlab.org/nlab/show/DistLat) when
being a lattice is understood to entail having a bottom and a top element.
-/

universes u

open category_theory

/-- The category of bounded distributive lattices with bounded lattice morphisms. -/
structure BoundedDistribLattice :=
(to_DistribLattice : DistribLattice)
[is_bounded_order : bounded_order to_DistribLattice]

namespace BoundedDistribLattice

instance : has_coe_to_sort BoundedDistribLattice Type* := ⟨λ X, X.to_DistribLattice⟩
instance (X : BoundedDistribLattice) : distrib_lattice X := X.to_DistribLattice.str

attribute [instance] BoundedDistribLattice.is_bounded_order

/-- Construct a bundled `BoundedDistribLattice` from a `bounded_order` `distrib_lattice`. -/
def of (α : Type*) [distrib_lattice α] [bounded_order α] : BoundedDistribLattice := ⟨⟨α⟩⟩

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

instance : inhabited BoundedDistribLattice := ⟨of punit⟩

/-- Turn a `BoundedDistribLattice` into a `BoundedLattice` by forgetting it is distributive. -/
def to_BoundedLattice (X : BoundedDistribLattice) : BoundedLattice := BoundedLattice.of X

@[simp] lemma coe_to_BoundedLattice (X : BoundedDistribLattice) : ↥X.to_BoundedLattice = ↥X := rfl

instance : large_category.{u} BoundedDistribLattice := induced_category.category to_BoundedLattice

instance : concrete_category BoundedDistribLattice :=
induced_category.concrete_category to_BoundedLattice

instance has_forget_to_DistribLattice : has_forget₂ BoundedDistribLattice DistribLattice :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_lattice_hom } }

instance has_forget_to_BoundedLattice : has_forget₂ BoundedDistribLattice BoundedLattice :=
induced_category.has_forget₂ to_BoundedLattice

lemma forget_BoundedLattice_Lattice_eq_forget_DistribLattice_Lattice :
  forget₂ BoundedDistribLattice BoundedLattice ⋙ forget₂ BoundedLattice Lattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ forget₂ DistribLattice Lattice := rfl

/-- Constructs an equivalence between bounded distributive lattices from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BoundedDistribLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoundedDistribLattice ⥤ BoundedDistribLattice :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `BoundedDistribLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoundedDistribLattice ≌ BoundedDistribLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoundedDistribLattice

lemma BoundedDistribLattice_dual_comp_forget_to_DistribLattice :
  BoundedDistribLattice.dual ⋙ forget₂ BoundedDistribLattice DistribLattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ DistribLattice.dual := rfl


import tactic

class myclass (X : Type) :=
(op : (X → X) → X)

variables (X Y Z : Type) [myclass X] [myclass Y] [myclass Z]

namespace myclass

structure hom :=
(f : X → Y)
(map' : ∀ (a : X → X) (b : Y → Y), (∀ x, f (a x) = b (f x)) → f (op a) = op b)

structure edge :=
(R : X → Y → Prop)
(h : ∀ (a : X → X) (b : Y → Y), (∀ x y, R x y → R (a x) (b y)) → R (op a) (op b))

def diag : edge X X :=
{ R := eq,
  h := begin
    intros a b h,
    congr,
    ext,
    apply h,
    refl,
  end }

example (e : edge X Y) : myclass (Σ' x y, e.R x y) :=
⟨λ a, begin
  cases e, dsimp at *,
end⟩

structure hom2 :=
(f : X → Y)
(f2 : (X → X) → (Y → Y))
(hf2 : ∀ (a : X → X) (b : Y → Y), (∀ x, f (a x) = b (f x)) ↔ f2 a = b)
(map : ∀ (a : X → X), f (op a) = op (f2 a))

example {X Y : Type} (f : X → Y)
  (f2 : (X → X) → (Y → Y))
  (hf2 : ∀ (a : X → X) (b : Y → Y), (∀ x, f (a x) = b (f x)) ↔ f2 a = b) :
  function.bijective f ∨ (∀ x y : Y, x = y) :=
begin
  rw [or_iff_not_imp_right],
  intro h,
  push_neg at h,
  rcases h with ⟨y₁, y₂, hy⟩,
  classical,
  split,
  intros x₁ x₂ h,
  have := hf2 id (equiv.swap y₁ y₂),
  dsimp at this,
end

lemma lemma1 {X Y : Type} (f : X → Y)
  (hf : function.has_right_inverse f) :
  ∃ f2 : (X → X) → (Y → Y),
  (∀ (a : X → X) (b : Y → Y), (∀ x, f (a x) = b (f x)) ↔ f2 a = b) :=
begin
  cases hf with g hg,
  refine ⟨λ a, f ∘ a ∘ g, _⟩,
  intros a b,
  simp only [function.funext_iff, function.comp_app],
  split,
  { assume h y,
    rw [← hg y, h, hg y, hg y] },
  { assume h x,
    rw [← h],
    delta function.right_inverse function.left_inverse at hg,

     }
end

-- example : false := begin
--    have := h (@empty.elim unit) (λ _, id) _ (),
--    cases this,
--    cases this_w,
--    intros,simp,
-- end

def hom2_to_edge (f : hom2 X Y) : edge X Y :=
{ R := λ x y, f.f x = y,
  h := λ a b h, begin
    rw [f.map],

  end }

def comp2 (f : hom2 X Y) (g : hom2 Y Z) : hom2 X Z :=
{ f := λ x, g.f (f.f x),
  f2 := λ a, g.f2 (f.f2 a),
  hf2 := λ a c, begin
    split,
    { have hg2 := g.hf2,
      have hf2 := f.hf2,
      intros h,
      rw [(hg2 _ _).1],
      clear hg2,
      intro y,
      have := f.hf2 a (λ _, f.f2 a y),
      simp only [function.funext_iff] at this,
      rw ← this.2,
      rw h,

       },
    { intros h x,
      have := (f.hf2 a _).2 rfl,
      rw [this, (g.hf2 _ _).2],
      rw h }
  end,
  map := λ a, by rw [f.map, g.map] }

instance : has_coe_to_fun (hom X Y) (λ _, X → Y) :=
{ coe := hom.f }

def id : hom X X :=
{ f := id,
  map' := λ a b h, have h : a = b, from funext h, by rw h; refl }

variables {X Y Z}

lemma hom.map (f : hom X Y) :
  ∀ (a : X → X) (b : Y → Y), (∀ x, f (a x) = b (f x)) → f (op a) = op b := f.map'

def comp (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ f := λ x, g (f x),
  map' := λ a c h, begin
    cases f with f hf, cases g with g hg,
    unfold_coes at *,
    dsimp at *,

  end }

def to_functor {X : Type} (f : (X → X) → X) : (X → X → Type) → X → Type :=
λ R x, Σ g : {g : X → X // f g = x}, ∀ a b, g.1 x = b → R a b

def to_functor_map {X : Type} (f : (X → X) → X) (R₁ R₂ : (X → X → Type))
  (i : Π x y, R₁ x y → R₂ x y) : Π x, to_functor f R₁ x → to_functor f R₂ x :=
λ x g, ⟨g.1, λ a b h, i _ _ (g.2 _ _ h)⟩

variables (X Y)
def hom₃ := Σ f : X → Y, Π (i : Y → Y → Type) (x : X),
  to_functor op (λ x y : X, i (f x) (f y)) x → to_functor op i (f x)

end myclass


import algebra.homology.homotopy

import pseudo_normed_group.system_of_complexes
import rescale.Tinv

/-!

*TODO*: find someone who can explain what is going on in this file.

-/

noncomputable theory

universe variables u

open_locale nnreal

open category_theory homological_complex

namespace breen_deligne

variables {BD BD₁ BD₂ : breen_deligne.data} (f g : BD₂ ⟶ BD₁)
variables (h : homotopy f g)

variables (κ c_₁ c_₂ : ℕ → ℝ≥0)
variables [BD.suitable κ] [BD₁.suitable c_₁] [BD₂.suitable c_₂]
variables (r : ℝ≥0) (V : SemiNormedGroup) [normed_with_aut r V] [fact (0 < r)]
variables {r' : ℝ≥0} [fact (0 < r')] [fact (r' ≤ 1)] (c : ℝ≥0)

section homotopy

variables (M : (ProFiltPseuNormGrpWithTinv.{u} r')ᵒᵖ)

open homological_complex

@[simps app_f]
def BD_map₂ (a₁ a₂ b₁ b₂ : ℕ → ℝ≥0)
  [∀ (i : ℕ), fact (b₁ i ≤ r' * a₁ i)] [∀ (i : ℕ), fact (b₂ i ≤ r' * a₂ i)]
  [BD₁.suitable a₁] [BD₂.suitable a₂] [BD₁.suitable b₁] [BD₂.suitable b₂]
  [∀ i, (f.f i).suitable (a₂ i) (a₁ i)]
  [∀ i, (f.f i).suitable (b₂ i) (b₁ i)] :
  BD₁.complex₂ r V r' a₁ b₁ ⟶ BD₂.complex₂ r V r' a₂ b₂ :=
{ app := λ M,
  { f := λ i, ((f.f i).eval_CLCFPTinv₂ r V r' (a₁ i) (b₁ i) (a₂ i) (b₂ i)).app M,
    comm' := begin
      intros i j _,
      dsimp [data.complex₂_obj_d, data.complex₂_d],
      have : f.f j ≫ BD₁.d j i = BD₂.d j i ≫ f.f i := f.comm j i,
      simp only [← nat_trans.comp_app, ← universal_map.eval_CLCFPTinv₂_comp r V r', this],
    end },
  naturality' := by { intros M₁ M₂ g, ext i : 2,
    exact ((f.f i).eval_CLCFPTinv₂ r V r' (a₁ i) (b₁ i) (a₂ i) (b₂ i)).naturality g, } }
.

@[simps app_f]
def BD_map [∀ i, (f.f i).suitable (c_₂ i) (c_₁ i)] :
  BD₁.complex c_₁ r V r' c ⟶ BD₂.complex c_₂ r V r' c :=
BD_map₂ f r V _ _ _ _
.

-- @[simp] lemma BD_map_app_f [∀ i, (f.f i).suitable (c_₂ i) (c_₁ i)] (i : ℕ)
--   (M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ) :
--   ((BD_map f c_₁ c_₂ r V c).app M).f i =
--     ((f.f i).eval_CLCFPTinv r V r' (c_₁ i) (c_₂ i)).app M := _

open opposite

@[simps app_app]
def BD_system_map [∀ i, (f.f i).suitable (c_₂ i) (c_₁ i)] :
  BD₁.system c_₁ r V r' ⟶ BD₂.system c_₂ r V r' :=
{ app := λ M,
  { app := λ c, (BD_map f c_₁ c_₂ r V c.unop).app M,
    naturality' := λ x y hxy,
    begin
      ext i : 2,
      erw [comp_f, comp_f],
      dsimp only [data.system_obj, BD_map, BD_map₂_app_f],
      haveI : fact (y.unop ≤ x.unop) := ⟨le_of_hom hxy.unop⟩,
      exact nat_trans.congr_app
        (universal_map.res_comp_eval_CLCFPTinv₂ r V r' _ _ _ _ _ _ _ _ _) M,
    end },
  naturality' := λ M₁ M₂ g,
  begin
    ext c : 2,
    exact (BD_map f c_₁ c_₂ r V c.unop).naturality _
  end }
.

end homotopy

end breen_deligne


import implementation.model.predicate
import implementation.model.sys_state
import implementation.spec.main
import implementation.proof.misc

-- This file contains proofs about proposers (or what can be associated with
-- them in our co-located Paxos implementation).
--
-- NOTE(gnanabit): comments are omitted for facts that are "obvious" or not
-- particularly revealing about paxos.

variables {pid_t : Type} [linear_order pid_t] [fintype pid_t] {value_t : Type}
          {is_quorum : finset pid_t → Prop} [decidable_pred is_quorum]
          [quorum_assumption is_quorum] {vals : pid_t → value_t}

-- The ballot b has been proposed with value v if there is a server who has sent
-- a p2a with this proposal.
def proposed
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (b : ballot pid_t) (v : value_t) :=
  ∃ (proposer : pid_t) (e ∈ s.network proposer),
    (envelope.msg e) = message.p2a {bal := b, val := v}

lemma proposed_stable (b : ballot pid_t) (v : value_t) : predicate.stable
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    proposed s b v) :=
begin
intros u w holds_at_u u_pn_w,
rcases holds_at_u with ⟨proposer, proposal_env, sent_by_proposer, is_proposal⟩,
exact ⟨proposer, proposal_env, sys_state.ntwk_subset sent_by_proposer u_pn_w, is_proposal⟩,
end

def proposed_by
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (b : ballot pid_t) (proposer : pid_t) :=
  ∃ (v : value_t) (e ∈ s.network proposer),
    (envelope.msg e) = message.p2a {bal := b, val := v}

lemma none_proposed_at_init
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (hs : s.is_initial) : ∀ (b : ballot pid_t) (p : pid_t), ¬proposed_by s b p :=
begin
intros b p,
rintros ⟨v, e, he, e_is_proposal⟩,
specialize hs p,
unfold protocol.init at hs,
injection hs with unused key, clear unused,
rw ← key at he,
cases he,
{ rw he at e_is_proposal, injection e_is_proposal },
rw set.mem_singleton_iff at he,
rw he at e_is_proposal,
injection e_is_proposal
end

-- If a proposer p proposed ballot b, then p is the address of b.
lemma proposer_is_ballot_address : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (p : pid_t), proposed_by s b p → b.address = p) :=
begin
suffices key : predicate.inductive_invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (p : pid_t), proposed_by s b p → b.address = p),
by { exact predicate.ind_inv_is_inv key },
split,
{ intros s hs b p wrong,
  exact (none_proposed_at_init s hs b p wrong).elim },
intros u w hu,
rintros ⟨receiver, sender, e, _h1, _h2, _h3, w_receiver, _h4, w_not_receiver⟩,
clear_,
unfold proposed_by,
intros b p,
cases decidable.em (p = receiver),
swap,
{ rw w_not_receiver p h,
  intro hyp,
  exact hu b p hyp },
cases e with msg __;
unfold envelope.msg at w_receiver,
clear __,
rintros ⟨v, e, he, e_is_proposal⟩,
rw h at he,
rw w_receiver at he,
cases he,
{ apply hu,
  rw h,
  unfold proposed_by,
  use [v, e, he, e_is_proposal] },
rw h,
rcases p2a_emitted e_is_proposal he with ⟨p_or, __, receiver_ballot_address, __, __, e_is⟩,
clear_,
rw e_is at e_is_proposal,
injection e_is_proposal with proposals_match,
injection proposals_match with ballots_match,
rw ballots_match at receiver_ballot_address,
exact receiver_ballot_address
end

private lemma proposer_sends_to_all_but_self : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (proposer : pid_t) (e ∈ s.network proposer)
      (v : value_t),
      (envelope.msg e) = message.p2a {bal := b, val := v} →
        e.sent_to = target.exclude proposer) :=
begin
suffices key : predicate.inductive_invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (proposer : pid_t) (e ∈ s.network proposer)
      (v : value_t),
        (envelope.msg e) = message.p2a {bal := b, val := v} →
          e.sent_to = target.exclude proposer),
by { exact predicate.ind_inv_is_inv key },
split,
{ intros s hs b proposer e he v e_msg_eq,
  exact (none_proposed_at_init s hs b proposer ⟨v, e, he, e_msg_eq⟩).elim },
intros u w hu u_pn_w b proposer e he v e_msg_eq,
rcases u_pn_w with ⟨receiver, sender, e', he', deliverable, proc_change, ntwk_change, rest_same⟩,
cases decidable.em (proposer = receiver),
swap,
{ rw rest_same.right proposer h at he,
  exact hu b proposer e he v e_msg_eq },
clear rest_same proc_change,
rw h at he ⊢,
clear h proposer,
rw ntwk_change at he, clear ntwk_change,
cases he,
{ exact hu b receiver e he v e_msg_eq },
rcases p2a_emitted e_msg_eq he with ⟨_, _, _, _, _, key⟩,
rw key
end

-- If a process p proposed ballot b, then p's current ballot is at least as
-- large as b.
lemma proposer_ballot_ge : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (p : pid_t), proposed_by s b p → b ≤ (s.procs p).curr) :=
begin
suffices key : predicate.inductive_invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (p : pid_t), proposed_by s b p → b ≤ (s.procs p).curr),
by { exact predicate.ind_inv_is_inv key },
split,
{ intros s hs b p wrong,
  exact (none_proposed_at_init s hs b p wrong).elim },
intros u w inv_u u_pn_w,
intros b p,
have ballot_le := ballot_nondecreasing p u_pn_w,
rcases u_pn_w with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, proc_same, ntwk_same⟩,
rintros ⟨v, e_del, he_del, e_del_is_vote⟩,
cases decidable.em (p = receiver),
swap,
{ rw ntwk_same p h at he_del,
  unfold proposed_by at inv_u,
  calc b ≤ (u.procs p).curr : inv_u b p ⟨v, e_del, he_del, e_del_is_vote⟩
     ... ≤ (w.procs p).curr : ballot_le },
rw h at he_del ballot_le ⊢,
clear h p,
rw ntwk_change at he_del,
cases he_del,
{ calc b ≤ (u.procs receiver).curr : inv_u b receiver ⟨v, e_del, he_del, e_del_is_vote⟩
     ... ≤ (w.procs receiver).curr : ballot_le },
rcases p2a_emitted e_del_is_vote he_del with ⟨p_or, _, _, _, _, key⟩,
rw key at e_del_is_vote,
injection e_del_is_vote with contents_same,
injection contents_same with ballots_same,
calc b = (u.procs receiver).curr : eq.symm ballots_same
   ... ≤ (w.procs receiver).curr : ballot_le
end

private lemma not_proposed_without_quorum : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (p : pid_t), ¬is_quorum (s.procs p).followers → ¬proposed_by s (s.procs p).curr p) :=
begin
rw predicate.use_any_invariant,
split,
{ intros s hs p unimportant wrong,
  exact (none_proposed_at_init s hs (s.procs p).curr p wrong).elim },
intros u w u_reachable not_proposed_wo_quorum_at_u,
rintros ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, rest_same⟩,
intro w_reachable,
have ballot_le := ballot_nondecreasing receiver
                  ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, rest_same⟩,
have proposed_le_at_u := proposer_ballot_ge u u_reachable,
intro p,
cases decidable.em (p = receiver),
swap,
{ rw rest_same.left p h,
  unfold proposed_by,
  rw rest_same.right p h,
  exact not_proposed_wo_quorum_at_u p },
clear rest_same,
rw h,
clear h p,
intro hyp,
rintros ⟨v, e', he', e'_msg_eq⟩,
rw ntwk_change at he', clear ntwk_change,
rw le_iff_lt_or_eq at ballot_le,
cases ballot_le with ballot_lt ballot_eq,
{ have key : ¬proposed_by u (w.procs receiver).curr receiver,
  by { intro wrong,
      exact not_lt_of_ge (proposed_le_at_u (w.procs receiver).curr receiver wrong) ballot_lt },
  cases he',
  { exact key ⟨v, e', he', e'_msg_eq⟩ },
  clear key,
  have key := network_change receiver (u.procs receiver) e.msg sender e' he',
  cases e.msg,
    case p1a : mb {
      cases key;
      rw key.right at e'_msg_eq;
      injection e'_msg_eq
    },
    case p1b : mb p_or {
      cases key.right.right.right.right with e'_eq e'_eq,
      { clear key,
        rw e'_eq at e'_msg_eq,
        injection e'_msg_eq with props_same,
        injection props_same with ballots_same,
        exact ne_of_lt ballot_lt ballots_same },
      rw e'_eq at e'_msg_eq,
      injection e'_msg_eq
    },
    case p2a : p {
      cases key;
      rw key.right at e'_msg_eq;
      injection e'_msg_eq
    },
    case p2b : mb acc {
      exact key.elim
    },
    case preempt : {
      rw key.right at e'_msg_eq,
      injection e'_msg_eq
    }
  },
rw ← ballot_eq at e'_msg_eq,
cases he',
{ suffices cond : ¬is_quorum (u.procs receiver).followers,
  by {
    apply not_proposed_wo_quorum_at_u receiver cond,
    exact ⟨v, e', he', e'_msg_eq⟩ },
  have key := state_change receiver (u.procs receiver) e.msg sender,
  cases key,
  { rw key at proc_change,
    rw proc_change at hyp,
    exact hyp },
  cases e,
  cases e_msg,
    case p1a : b {
      cases key with ballot_increased made_larger,
      rw made_larger at proc_change,
      rw proc_change at ballot_eq,
      exact (ne_of_lt ballot_increased ballot_eq).elim,
    },
    case p1b : b p_or {
      cases key,
      { cases key with ballot_increased made_larger,
        rw made_larger at proc_change,
        rw proc_change at ballot_eq,
        exact (ne_of_lt ballot_increased ballot_eq).elim },
      cases key;
      exact key.right.right.left
    },
    case p2a : p {
      cases key with ballot_ge made_larger,
      clear ballot_ge,
      have p_bal_eq : p.bal = (u.procs receiver).curr,
      by {
        rw made_larger at proc_change,
        rw proc_change at ballot_eq,
        exact eq.symm ballot_eq
      },
      have p_bal_addr_ne_receiver: p.bal.address ≠ receiver,
      by {
        have ballot_address_is_sender : p.bal.address = sender,
        by {
          apply proposer_is_ballot_address u u_reachable p.bal sender,
          exact ⟨p.val, {msg := message.p2a p, sent_to := e_sent_to}, he,
          by { cases p, refl }⟩,
        },
        suffices key : sender ≠ receiver,
        by {
          rw ballot_address_is_sender,
          exact key
        },
        suffices key : e_sent_to = target.exclude sender,
        by { rw key at deliverable, exact deliverable },
        apply proposer_sends_to_all_but_self u u_reachable p.bal sender
              {msg := message.p2a p, sent_to := e_sent_to} he p.val,
        cases p, refl
      },
      have p_bal_addr_eq_receiver := proposer_is_ballot_address u u_reachable
                                     (u.procs receiver).curr receiver ⟨v, e', he', e'_msg_eq⟩,
      rw ← p_bal_eq at p_bal_addr_eq_receiver,
      exact (p_bal_addr_ne_receiver p_bal_addr_eq_receiver).elim
    },
    case p2b : mb acc {
      cases key with ballot_gt updated,
      rw updated at proc_change,
      rw proc_change at ballot_eq,
      exact (ne_of_lt ballot_gt ballot_eq).elim
    },
    case preempt : {
      rw key.right at proc_change,
      clear key,
      rw proc_change at ballot_eq,
      exact (ne_of_lt (ballot.next_larger receiver (u.procs receiver).curr) ballot_eq).elim
    }
  },
rcases p2a_emitted e'_msg_eq he' with
  ⟨p_or, e_msg_is, receiver_still_leader, began_wo_quorum, ended_w_quorum, emitted_just⟩,
suffices key : (w.procs receiver).followers = (u.procs receiver).followers ∪ {sender},
by { rw key at hyp, exact hyp ended_w_quorum },
rw proc_change,
rw e_msg_is,
unfold protocol.handler server.handle_p1b,
rw if_neg (lt_irrefl _),
rw if_neg (not_not.mpr receiver_still_leader),
rw if_neg (lt_irrefl _),
rw if_neg (show ¬(is_quorum (u.procs receiver).followers ∨
                  sender ∈ (u.procs receiver).followers), by {
  intro cond,
  cases cond with cond cond,
  { exact began_wo_quorum cond },
  have key : (u.procs receiver).followers ∪ {sender} = (u.procs receiver).followers,
  by {
    rw finset.union_eq_left_iff_subset,
    rw finset.singleton_subset_iff,
    exact cond
  },
  rw key at ended_w_quorum,
  exact began_wo_quorum ended_w_quorum
}),
rw if_pos ended_w_quorum
end

-- If two proposals have the same ballot, they have the same value.
--
-- The proof is by induction using predicates we've already proven.
--
-- Nothing is proposed at the initial state.
--
-- If the fact holds at u and two values are proposed with b at some state w
-- following from u, then the proposals are issued by the same proposer. Either
-- the proposer issued both proposals in u, in which case we apply the inductive
-- hypothesis, or one proposal was issued in u and the other was just issued in
-- the step (there are two ways in which that might happen, and they're
-- symmetric), or both proposals were issued in the last step.
--
-- * In the case that one proposal was issued at u and the other was only issued
-- as a result of the last step, it should be impossible, because when a server
-- proposes a value in a step, it has no quorum before it sends the proposal,
-- and therefore it could not have sent a proposal in step u under the required
-- ballot.
--
-- * In the case that both proposals were issued in the last step, only one
-- proposal is issued at a time, so both are the same proposal.
theorem proposals_unique : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (b : ballot pid_t) (v₁ v₂ : value_t), proposed s b v₁ → proposed s b v₂ → v₁ = v₂) :=
begin
rw predicate.use_any_invariant,
split,
{ intros s hs b v _ proposed_at_initial,
  rcases proposed_at_initial with ⟨proposer, e, he, e_is_proposal⟩,
  exfalso, apply none_proposed_at_init s hs b proposer,
  exact ⟨v, e, he, e_is_proposal⟩ },
intros u w u_reachable unique_at_u u_pn_w w_reachable b v₁ v₂ hp₁ hp₂,
specialize unique_at_u b v₁ v₂,
rcases u_pn_w with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, rest_same⟩,
cases hp₁ with proposer₁ hp₁,
cases hp₂ with proposer₂ hp₂,
have prop₁_eq := proposer_is_ballot_address w w_reachable b proposer₁ ⟨v₁, hp₁⟩,
rw ← prop₁_eq at hp₁,
have prop₂_eq := proposer_is_ballot_address w w_reachable b proposer₂ ⟨v₂, hp₂⟩,
rw ← prop₂_eq at hp₂,
clear prop₁_eq prop₂_eq proposer₁ proposer₂,
cases decidable.em (b.address = receiver),
swap,
{ rw rest_same.right b.address h at hp₁ hp₂,
  exact unique_at_u ⟨b.address, hp₁⟩ ⟨b.address, hp₂⟩ },
clear rest_same,
rw h at hp₁ hp₂, clear h,
rcases hp₁ with ⟨e₁, he₁, e₁_msg_eq⟩,
rcases hp₂ with ⟨e₂, he₂, e₂_msg_eq⟩,
rw ntwk_change at he₁ he₂,
cases he₁; cases he₂,
{ exact unique_at_u ⟨receiver, e₁, he₁, e₁_msg_eq⟩ ⟨receiver, e₂, he₂, e₂_msg_eq⟩ },
{ rcases p2a_emitted e₂_msg_eq he₂ with ⟨_, _, _, no_quorum, _, e₂_is⟩,
  have ballots_match : (u.procs receiver).curr = b,
  by { rw e₂_is at e₂_msg_eq, injection e₂_msg_eq with key, injection key },
  clear e₂_is e₂_msg_eq he₂ e₂,
  rw ← ballots_match at e₁_msg_eq,
  exfalso,
  apply not_proposed_without_quorum u u_reachable receiver no_quorum,
  exact ⟨v₁, e₁, he₁, e₁_msg_eq⟩ },
{ rcases p2a_emitted e₁_msg_eq he₁ with ⟨_, _, _, no_quorum, _, e₁_is⟩,
  have ballots_match : (u.procs receiver).curr = b,
  by { rw e₁_is at e₁_msg_eq, injection e₁_msg_eq with key, injection key },
  clear e₁_is e₁_msg_eq he₁ e₁,
  rw ← ballots_match at e₂_msg_eq,
  exfalso,
  apply not_proposed_without_quorum u u_reachable receiver no_quorum,
  exact ⟨v₂, e₂, he₂, e₂_msg_eq⟩ },
rcases p2a_emitted e₁_msg_eq he₁ with ⟨p₁, e_has_p₁, __, __, __, key₁⟩,
rcases p2a_emitted e₂_msg_eq he₂ with ⟨p₂, e_has_p₂, __, __, __, key₂⟩,
clear_,
have proposals_match : p₁ = p₂,
by { injection eq.trans (eq.symm e_has_p₁) e_has_p₂ },
have val₁ : v₁ = proposal.value_or_default (proposal.merge (u.procs receiver).accepted p₁)
                                           (vals receiver),
by {
  rw key₁ at e₁_msg_eq,
  injection e₁_msg_eq with fact,
  injection fact with _ goal,
  exact eq.symm goal },
have val₂ : v₂ = proposal.value_or_default (proposal.merge (u.procs receiver).accepted p₂)
                                           (vals receiver),
by {
  rw key₂ at e₂_msg_eq,
  injection e₂_msg_eq with fact,
  injection fact with _ goal,
  exact eq.symm goal },
rw val₁,
rw val₂,
rw proposals_match
end


import order.with_bot

open function

namespace with_bot
variables {α : Type*} {C : with_bot α → Sort*} (h₁ : C ⊥) (h₂ : Π a : α, C ↑a)

lemma coe_ne_coe {a b : α} : (a : with_bot α) ≠ b ↔ a ≠ b := coe_eq_coe.not

instance [has_lt α] [is_well_order α (<)] : is_strict_total_order (with_bot α) (<) :=
begin
  classical,
  letI : linear_order α := linear_order_of_STO (<),
  apply_instance
end

instance [preorder α] [is_well_order α (<)] : is_well_order (with_bot α) (<) := {}

end with_bot


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.repr
import Mathlib.Lean3Lib.init.data.prod
import Mathlib.Lean3Lib.init.data.sum.basic

universes l u

namespace Mathlib

inductive ordering where
| lt : ordering
| eq : ordering
| gt : ordering

protected instance ordering.has_repr : has_repr ordering := has_repr.mk fun (s : ordering) => sorry

namespace ordering

def swap : ordering → ordering := sorry

def or_else : ordering → ordering → ordering := sorry

theorem swap_swap (o : ordering) : swap (swap o) = o :=
  ordering.cases_on o (idRhs (swap (swap lt) = swap (swap lt)) rfl)
    (idRhs (swap (swap eq) = swap (swap eq)) rfl) (idRhs (swap (swap gt) = swap (swap gt)) rfl)

end ordering

def cmp_using {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (a : α) (b : α) : ordering :=
  ite (lt a b) ordering.lt (ite (lt b a) ordering.gt ordering.eq)

def cmp {α : Type u} [HasLess α] [DecidableRel Less] (a : α) (b : α) : ordering :=
  cmp_using Less a b

protected instance ordering.decidable_eq : DecidableEq ordering := fun (a b : ordering) => sorry

end Mathlib


import order.complete_lattice
import set_theory.ordinal

universes u v

variables (A : Type u) (B : Type v) [partial_order A] [partial_order B]

structure sup_hom : Type (max u v) :=
(to_fun : A → B)
(monotone : monotone to_fun)
(sup : ∀ (s : set A) (a : A), is_lub s a → is_lub (to_fun '' s) (to_fun a))

/-- Aiming to construct a cocompletion of `B` that preserves all sups in `A`.
  So if we have a partial order `C` a monotone function `B -> C` and a `sup_hom`
  from `A -> C` that commute with `f` there is a unique cocontinuous map from
  the cocompletion to `C` such that everything commutes. -/

def presheaf : Type* :=
{ s : B → Prop // ∀ a b, a ≤ b → s b → s a }

variables {A B}

namespace presheaf

instance : has_coe_to_fun (presheaf B) (λ _, B → Prop) :=
⟨subtype.val⟩

@[simp] lemma coe_mk (s : B → Prop) (hs : ∀ a b, a ≤ b → s b → s a) :
  @coe_fn (presheaf B) _ _ (⟨s, hs⟩ : presheaf B) = s := rfl

instance : partial_order (presheaf B) :=
{ le := λ a b, ∀ x, a x → b x,
  le_trans := λ a b c hab hbc x hax, hbc _ (hab _ hax),
  le_refl := λ _ _, id,
  le_antisymm := λ a b hab hba, subtype.val_injective (funext $ λ x, propext ⟨hab _, hba _⟩) }

lemma le_def {a b : presheaf B} : a ≤ b = ∀ x, a x → b x := rfl

instance : has_Inf (presheaf B) :=
{ Inf := λ s, ⟨λ p, ∀ B : presheaf B, B ∈ s → B p,
     λ a b hab h B hBs, B.2 _ _ hab (h _ hBs)⟩ }

instance : complete_lattice (presheaf B) :=
complete_lattice_of_Inf _
  (λ s, begin
    split,
    { dsimp [Inf, lower_bounds],
      intros B hBs p h,
      apply h,
      exact hBs },
    { dsimp [Inf, upper_bounds, lower_bounds],
      intros B h p hBp B hBs,
      apply h,
      exact hBs,
      exact hBp }
  end)

lemma infi_def {ι : Sort*} (a : ι → presheaf B) :
  infi a = ⟨λ p, ∀ i, a i p, λ x y hxy h i, (a i).2 _ y hxy (h i)⟩ :=
le_antisymm
  (infi_le_iff.2 (λ B h p hBp i, h i _ hBp))
  (le_infi (λ i p h, h _))

lemma supr_def {ι : Sort*} (a : ι → presheaf B) :
  supr a = ⟨λ p, ∃ i, a i p, λ x y hxy ⟨i, hi⟩, ⟨i, (a i).2 x y hxy hi⟩⟩ :=
le_antisymm
  (supr_le_iff.2 (λ i p h, ⟨i, h⟩))
  (le_supr_iff.2 (λ B h p ⟨i, hi⟩, h i _ hi))

def yoneda (a : B) : presheaf B :=
⟨λ b, b ≤ a, λ b c, le_trans⟩

def yoneda_le_iff (a : presheaf B) (p : B) : yoneda p ≤ a ↔ a p :=
begin
  simp [yoneda, presheaf.le_def],
  split,
  { intro h, apply h, exact le_rfl },
  { intros h x hxp,
    apply a.2,
    apply hxp,
    exact h }
end

lemma yoneda_mono {a b : B} : yoneda a ≤ yoneda b ↔ a ≤ b :=
begin
  rw yoneda_le_iff, refl,
end

lemma eq_supr {a : presheaf B} : a = ⨆ (p : B) (h : a p), yoneda p :=
begin
  apply le_antisymm; simp only [le_supr_iff, supr_le_iff, yoneda_le_iff],
  { intros B hB p,
    exact hB p },
  { exact λ _, id }
end

def restrict (f : sup_hom A B) (a : presheaf B) : presheaf A :=
⟨λ x, a.1 (f.1 x), λ x y hxy h, a.2 _ _ (f.monotone hxy) h⟩

end presheaf

variable (B)

def copresheaf : Type* :=
{ s : B → Prop // ∀ a b, a ≤ b → s a → s b }

variable {B}

namespace copresheaf

instance : has_coe_to_fun (copresheaf B) (λ _, B → Prop) :=
⟨subtype.val⟩

@[simp] lemma coe_mk (s : B → Prop) (hs : ∀ a b, a ≤ b → s a → s b) :
  @coe_fn (copresheaf B) _ _ (⟨s, hs⟩ : copresheaf B) = s := rfl

instance : partial_order (copresheaf B) :=
{ le := λ a b, ∀ x, b x → a x,
  le_trans := λ a b c hab hbc x hcx, hab _ (hbc _ hcx),
  le_refl := λ _ _, id,
  le_antisymm := λ a b hab hba, subtype.val_injective (funext $ λ x, propext ⟨hba _, hab _⟩) }

lemma le_def {a b : copresheaf B} : a ≤ b = ∀ x, b x → a x := rfl

instance : has_Sup (copresheaf B) :=
{ Sup := λ s, ⟨λ p, ∀ B : copresheaf B, B ∈ s → B p,
     λ a b hab h B hBs, B.2 _ _ hab (h _ hBs)⟩ }

instance : complete_lattice (copresheaf B) :=
complete_lattice_of_Sup _
  (λ s, begin
    split,
    { dsimp [Sup, upper_bounds],
      intros B hBs p h,
      apply h,
      exact hBs },
    { dsimp [Inf, upper_bounds, lower_bounds],
      intros B h p hBp B hBs,
      apply h,
      exact hBs,
      exact hBp }
  end)

lemma infi_def {ι : Sort*} (a : ι → copresheaf B) :
  infi a = ⟨λ p, ∃ i, a i p, λ x y hxy ⟨i, hi⟩, ⟨i, (a i).2 x y hxy hi⟩⟩ :=
le_antisymm
  (infi_le_iff.2 (λ B h p ⟨i, hi⟩, h i _ hi))
  (le_infi_iff.2 (λ i p h, ⟨i, h⟩))

lemma supr_def {ι : Sort*} (a : ι → copresheaf B) :
  supr a = ⟨λ p, ∀ i, a i p, λ x y hxy h i, (a i).2 _ y hxy (h i)⟩ :=
le_antisymm
  (supr_le_iff.2 (λ i p h, h _))
  (le_supr_iff.2 (λ B h p hBp i, h i _ hBp))

def coyoneda (a : B) : copresheaf B :=
⟨λ b, a ≤ b, λ b c, function.swap le_trans⟩

def le_coyoneda_iff (a : copresheaf B) (p : B) : a ≤ coyoneda p ↔ a p :=
begin
  simp [copresheaf.coyoneda, copresheaf.le_def],
  split,
  { intro h, apply h, exact le_rfl },
  { intros h x hxp,
    apply a.2,
    apply hxp,
    exact h }
end

lemma eq_infi {a : copresheaf B} : a = ⨅ (p : B) (h : a p), coyoneda p :=
begin
  apply le_antisymm; simp only [le_infi_iff, infi_le_iff, le_coyoneda_iff],
  { exact λ _, id },
  { intros B hB p,
    exact hB p },
end

end copresheaf

open presheaf copresheaf

namespace presheaf

def u (f : A →o B) (a : presheaf B) : copresheaf B :=
⟨λ p, Π (x : B), a x → x ≤ p, λ a b hab h x hxA, le_trans (h _ hxA) hab⟩

lemma u_mono {f : A →o B} : monotone (u f):=
λ A B h p hp q hAq, hp _ (h _ hAq)

end presheaf

namespace copresheaf

def d (f : A →o B) (a : copresheaf B) : presheaf B :=
⟨λ q, Π (x : A), a (f x) → q ≤ f x, λ a b hab h x hxA, le_trans hab (h _ hxA)⟩

lemma d_mono {f : A →o B} : monotone (d f) :=
λ A B h p hp q hAq, hp _ (h _ hAq)

end copresheaf

def gc {f : A →o B} : galois_connection (presheaf.u f) (copresheaf.d f) :=
begin
  intros A B,
  dsimp [presheaf.u, copresheaf.d],
  split,
  { intros h x hxA y hyB,
    dsimp [copresheaf.le_def] at h,
    apply h,
    assumption,
    assumption,
     },
  { intros h x hxA y hyB,
    dsimp [presheaf.le_def] at *,
    apply h,
    assumption,
    assumption }
end

namespace presheaf

open copresheaf

lemma le_d_u (a : presheaf B) : a ≤ d (u a) := gc.le_u_l a

@[simp] lemma u_d_u (a : presheaf B) : (u (d (u a))) = u a :=
le_antisymm
  begin
    dsimp [d, u],
    intros p hp,
    dsimp [yoneda, coyoneda, presheaf.le_def] at *,
    intros q h,
    apply h,
    apply hp
  end
  (gc.monotone_l (le_d_u _))

@[simp] lemma u_yoneda (p : B) : u (yoneda p) = coyoneda p :=
begin
  rw [u],
  conv_lhs {dsimp [coyoneda]},
  simp only [yoneda_le_iff],
  refl
end

end presheaf

namespace copresheaf

open presheaf

lemma u_d_le (a : copresheaf B) : u (d a) ≤ a := gc.l_u_le a

@[simp] lemma d_u_d (a : copresheaf B) : d (u (d a)) = d a :=
le_antisymm
  (gc.monotone_u (u_d_le _))
  begin
    dsimp [d, u],
    intros p hp,
    dsimp [yoneda, coyoneda, presheaf.le_def] at *,
    intros q h,
    apply h,
    apply hp
  end

@[simp] lemma d_coyoneda (p : B) : d (coyoneda p) = yoneda p :=
begin
  rw [d],
  conv_lhs {dsimp only [yoneda]},
  simp only [le_coyoneda_iff],
  refl
end

end copresheaf

open presheaf copresheaf

structure cocompletion (f : sup_hom A B) : Type (max u v) :=
( to_presheaf : presheaf B )
( fixed : d (u (restrict f to_presheaf)) = _ )

variables {f : sup_hom A B}

namespace cocompletion

instance : partial_order (cocompletion f) :=
partial_order.lift cocompletion.to_presheaf
  begin
    rintros ⟨_, _⟩ ⟨_, _⟩,
    simp
  end

lemma le_def {a b : cocompletion f} : a ≤ b ↔ a.to_presheaf ≤ b.to_presheaf := iff.rfl

instance : has_Inf (cocompletion f) :=
⟨λ s, ⟨⨅ (a : cocompletion f) (h : a ∈ s), a.to_presheaf, begin
  dsimp [restrict,u, d, yoneda, coyoneda],
  apply subtype.ext,
  dsimp,
  funext x,
  simp only [presheaf.infi_def],
  simp only [copresheaf.le_def, presheaf.le_def],
  dsimp,
  ext,
  split,
  { intros, }

end⟩⟩

end cocompletion


import tactic.lint

def f : ℕ → ℕ := default _
def c : ℕ := default _
def d : ℕ := default _

@[simp] lemma c_eq_d : c = d := rfl

-- The following lemma never applies when using simp, because c is first rewritten to d
@[simp] lemma f_c : f c = 0 := rfl

example : f c = 0 :=
begin
  simp,
  guard_target f d = 0, -- does not apply f_c
  refl
end

open tactic
run_cmd do
decl ← get_decl ``f_c,
res ← linter.simp_nf.test decl,
-- linter complains
guard $ res.is_some

-- also works with `coe_to_fun`

structure morphism :=
(f : ℕ → ℕ)

instance : has_coe_to_fun morphism (λ _, ℕ → ℕ):=
⟨morphism.f⟩

def h : morphism := ⟨default _⟩

-- Also never applies
@[simp] lemma h_c : h c = 0 := rfl

example : h c = 0 :=
begin
  simp,
  guard_target h d = 0, -- does not apply h_c
  refl
end

open tactic
run_cmd do
decl ← get_decl ``h_c,
res ← linter.simp_nf.test decl,
-- linter complains
guard $ res.is_some