import phase0.litter

open cardinal
open_locale cardinal

universe u

namespace con_nf
variable [params.{u}]

/-- The type of sublitters. -/
structure sublitter : Type u :=
(litter : litter)
(carrier : set atom)
(subset : carrier ⊆ litter_set litter)
(diff_small : small (litter_set litter \ carrier))

namespace sublitter

variables {S S₁ S₂ : sublitter}

/-- Use sublitter.mk_eq_κ instead if possible. -/
lemma mk_S_eq_κ (S : sublitter) : #(S.carrier) = #κ :=
begin
  have := mk_le_mk_of_subset S.subset,
  rw mk_litter_set at this,
  cases lt_or_eq_of_le this,
  { have := mk_diff_add_mk S.subset,
    rw mk_litter_set at this,
    cases (add_lt_of_lt κ_regular.aleph_0_le S.diff_small h).ne this, },
  exact h,
end

instance : set_like sublitter atom :=
{ coe := λ S, S.carrier,
  coe_injective' := begin
    rintro ⟨i, N₁, h₁, h₂⟩ ⟨j, N₂, h₃, h₄⟩ (rfl : N₁ = N₂),
    obtain ⟨e⟩ := cardinal.eq.mp (sublitter.mk_S_eq_κ ⟨i, N₁, h₁, h₂⟩),
    have h₅ := h₁ (e.symm (arbitrary κ)).prop,
    have h₆ := h₃ (e.symm (arbitrary κ)).prop,
    rw mem_litter_set at h₅ h₆,
    rw h₅ at h₆,
    cases h₆,
    refl,
  end }

@[simp] lemma mk_eq_κ (S : sublitter) : #S = #κ := S.mk_S_eq_κ
@[simp] lemma mk_eq_κ' (S : sublitter) : #(S : set atom) = #κ := S.mk_S_eq_κ

@[simp] lemma carrier_eq_coe {S : sublitter} : S.carrier = S := rfl

@[simp] lemma coe_mk (L S subset diff_small) :
  @coe sublitter (set atom) _ ⟨L, S, subset, diff_small⟩ = S := rfl

@[ext] lemma ext (h : (S₁ : set atom) = S₂) : S₁ = S₂ :=
set_like.coe_injective h

lemma fst_eq_of_mem {a : atom} (h : a ∈ S) : a.1 = S.litter := S.subset h
lemma mem_litter_set_of_mem {a : atom} (h : a ∈ S) : a ∈ litter_set S.litter := S.subset h
@[simp] lemma mem_mk {a : atom} {L S subset diff_small} :
  a ∈ (⟨L, S, subset, diff_small⟩ : sublitter) ↔ a ∈ S := iff.rfl

@[simp] lemma litter_diff_eq (S : sublitter) : (S : set atom) \ litter_set S.litter = ∅ :=
set.eq_empty_of_forall_not_mem (λ a ha, ha.2 (S.subset ha.1))

lemma is_near_litter (S : sublitter) : is_near_litter S.litter S :=
begin
  refine small.union S.diff_small _,
  rw litter_diff_eq,
  exact small_empty,
end

def to_near_litter (S : sublitter) : near_litter := ⟨S.litter, S, S.is_near_litter⟩

@[simp] lemma to_near_litter_litter (S : sublitter) : S.to_near_litter.1 = S.litter := rfl
@[simp] lemma coe_to_near_litter (S : sublitter) : (S.to_near_litter : set atom) = S := rfl
@[simp] lemma mem_to_near_litter (a : atom) : a ∈ S.to_near_litter ↔ a ∈ S := iff.rfl

lemma is_near_iff : is_near (S₁ : set atom) S₂ ↔ S₁.litter = S₂.litter :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨f⟩ := is_near.mk_inter h S₁.mk_eq_κ.symm.le,
    rw [← fst_eq_of_mem (f (arbitrary κ)).prop.1, ← fst_eq_of_mem (f (arbitrary κ)).prop.2], },
  { refine S₁.is_near_litter.symm.trans _,
    rw h,
    exact S₂.is_near_litter, },
end

lemma inter_nonempty_iff : (S₁ ∩ S₂ : set atom).nonempty ↔ S₁.litter = S₂.litter :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { obtain ⟨a, ha⟩ := h,
    rw [← fst_eq_of_mem ha.1, fst_eq_of_mem ha.2], },
  { obtain ⟨f⟩ := is_near.mk_inter _ _,
    exact ⟨_, (f (arbitrary κ)).prop⟩,
    rw is_near_iff,
    exact h,
    rw mk_eq_κ', },
end

end sublitter

def litter.to_sublitter (L : litter) : sublitter :=
⟨L, litter_set L, subset_rfl, by rw [sdiff_self]; exact small_empty⟩

@[simp] lemma litter.litter_to_sublitter (L : litter) : L.to_sublitter.litter = L := rfl
@[simp] lemma litter.coe_to_sublitter (L : litter) :
  (L.to_sublitter : set atom) = litter_set L := rfl

namespace sublitter

def rel_embedding (S : sublitter) :
  ((<) : S → S → Prop) ↪r ((<) : (litter_set S.litter) → (litter_set S.litter) → Prop) :=
⟨⟨λ a, ⟨a, S.subset a.prop⟩, λ a b h, subtype.coe_injective (subtype.mk_eq_mk.mp h)⟩,
  λ a b, by simp only [function.embedding.coe_fn_mk, subtype.mk_lt_mk, subtype.coe_lt_coe]⟩

/-- The order type of a sublitter is `κ`. -/
lemma ordinal_type (S : sublitter) : ordinal.type ((<) : S → S → Prop) = (#κ).ord :=
begin
  refine le_antisymm _ _,
  { rw ← S.litter.ordinal_type,
    exact rel_embedding.ordinal_type_le S.rel_embedding, },
  { rw [cardinal.gc_ord_card, ordinal.card_type, mk_eq_κ], },
end

-- TODO: We can probably do this constructively, but this way is easier for now.
noncomputable def order_iso_κ (S : sublitter) : S ≃o κ :=
begin
  refine order_iso.of_rel_iso_lt (nonempty.some _),
  rw [← ordinal.type_eq, ordinal_type, ← κ_ord],
  refl,
end

/-- There is a (unique) order isomorphism between any two sublitters. -/
noncomputable def order_iso (S T : sublitter) : S ≃o T :=
S.order_iso_κ.trans T.order_iso_κ.symm

@[simp] lemma order_iso_apply_mem {S T : sublitter} (a : S) : (S.order_iso T a : atom) ∈ T :=
(S.order_iso T a).prop

@[simp] lemma order_iso_apply_fst_eq {S T : sublitter} (a : S) :
  (S.order_iso T a : atom).1 = T.litter :=
T.subset (S.order_iso T a).prop

lemma order_iso_congr_left {S T U : sublitter} (h : S = T) (a : S) :
  (S.order_iso U a : atom) = T.order_iso U ⟨a, by rw ← h; exact a.2⟩ :=
by cases h; rw subtype.coe_eta

lemma order_iso_congr_right {S T U : sublitter} (h : T = U) (a : S) :
  (S.order_iso T a : atom) = S.order_iso U a :=
by cases h; refl

def order_iso.subtype_iso {α β : Type*} [has_le α] [has_le β] (e : α ≃o β)
  {p : α → Prop} {q : β → Prop} (hpq : ∀ a, p a ↔ q (e a)) :
  {a // p a} ≃o {b // q b} :=
⟨e.subtype_equiv hpq, by simp only [rel_iso.coe_fn_to_equiv, equiv.subtype_equiv_apply,
  subtype.mk_le_mk, order_iso.le_iff_le, subtype.coe_le_coe, iff_self, subtype.forall,
  implies_true_iff]⟩

/-- There is a unique order isomorphism between corresponding subtypes of a well-order.
TODO: Can prove this without specialising to subtypes. -/
lemma order_iso.unique {α β : Type*}
  [linear_order α] [αwf : well_founded ((<) : α → α → Prop)]
  [linear_order β] [βwf : well_founded ((<) : β → β → Prop)]
  (e : α ≃o β) {p : α → Prop} {q : β → Prop}
  (hpq : ∀ a, p a ↔ q (e a)) (e' : {a // p a} ≃o {b // q b}) :
  e' = e.subtype_iso hpq :=
begin
  ext x,
  obtain ⟨x, hx⟩ := x,
  revert hx,
  refine αwf.induction x _,
  intros x ih hx,
  rw subtype.coe_inj,
  refine linarith.eq_of_not_lt_of_not_gt _ _ (λ h, _) (λ h, _),
  { have := ih ((e.subtype_iso hpq).symm (e' ⟨x, hx⟩)) _ _,
    { simp only [subtype.coe_eta, order_iso.apply_symm_apply, subtype.coe_inj,
        order_iso.apply_eq_iff_eq, order_iso.symm_apply_eq] at this,
      exact h.ne this, },
    { refine lt_of_lt_of_eq _ (subtype.coe_mk x hx),
      have := (e.subtype_iso hpq).symm.strict_mono h,
      rw order_iso.symm_apply_apply at this,
      exact this, },
    { exact subtype.coe_prop _, }, },
  { have := ih (e'.symm (e.subtype_iso hpq ⟨x, hx⟩)) _ _,
    { simp only [subtype.coe_eta, order_iso.apply_symm_apply, subtype.coe_inj,
        order_iso.apply_eq_iff_eq, order_iso.symm_apply_eq] at this,
      have := h.trans_eq (congr_arg e' this),
      rw order_iso.apply_symm_apply at this,
      exact this.ne rfl, },
    { refine lt_of_lt_of_eq _ (subtype.coe_mk x hx),
      have := e'.symm.strict_mono h,
      rw order_iso.symm_apply_apply at this,
      exact this, },
    { exact subtype.coe_prop _, }, },
end

/-- The intersection of two sublitters. -/
def meet (S T : sublitter) (h : S.litter = T.litter) : sublitter := {
  litter := S.litter,
  carrier := S ∩ T,
  subset := (set.inter_subset_left _ _).trans S.subset,
  diff_small := by rw set.diff_inter; exact small.union S.diff_small (h.symm ▸ T.diff_small),
}

/-- Transports the meet of sublitters `S` and `U` across the order isomorphism `S ≃o T`. -/
def order_iso_meet (S T U : sublitter) (h : S.litter = U.litter) : sublitter := {
  litter := T.litter,
  carrier := {a | ∃ (ha : a ∈ T), ((S.order_iso T).symm ⟨a, ha⟩ : atom) ∈ U},
  subset := λ a ha, T.subset ha.some,
  diff_small := begin
    suffices : small ((T : set atom) \
      {a | ∃ (ha : a ∈ T), ((S.order_iso T).symm ⟨a, ha⟩ : atom) ∈ U}),
    { refine small.mono (λ a ha, _) (small.union T.diff_small this),
      by_cases a ∈ T,
      exact or.inr ⟨h, ha.2⟩,
      exact or.inl ⟨ha.1, h⟩, },
    refine lt_of_le_of_lt _ U.diff_small,
    refine ⟨⟨λ a, ⟨(S.order_iso T).symm ⟨a, a.prop.1⟩, _, _⟩, λ a b h, _⟩⟩,
    { rw ← h,
      exact S.subset ((S.order_iso T).symm ⟨a, a.prop.1⟩).2, },
    { intro h,
      exact a.prop.2 ⟨a.prop.1, h⟩, },
    { simpa only [subtype.mk_eq_mk, rel_iso.eq_iff_eq, subtype.coe_inj] using h, },
  end,
}

end sublitter

end con_nf


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

/-!
# The homotopy category

`homotopy_category V c` gives the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.limits homological_complex

variables {ι : Type*}
variables (V : Type u) [category.{v} V] [preadditive V]
variables (c : complex_shape ι)

/--
The congruence on `homological_complex V c` given by the existence of a homotopy.
-/
def homotopic : hom_rel (homological_complex V c) := λ C D f g, nonempty (homotopy f g)

instance homotopy_congruence : congruence (homotopic V c) :=
{ is_equiv := λ C D,
  { refl := λ C, ⟨homotopy.refl C⟩,
    symm := λ f g ⟨w⟩, ⟨w.symm⟩,
    trans := λ f g h ⟨w₁⟩ ⟨w₂⟩, ⟨w₁.trans w₂⟩, },
  comp_left := λ E F G m₁ m₂ g ⟨i⟩, ⟨i.comp_left _⟩,
  comp_right := λ E F G f m₁ m₂ ⟨i⟩, ⟨i.comp_right _⟩, }

/-- `homotopy_category V c` is the category of chain complexes of shape `c` in `V`,
with chain maps identified when they are homotopic. -/
@[derive category]
def homotopy_category := category_theory.quotient (homotopic V c)

-- TODO the homotopy_category is preadditive

namespace homotopy_category

/-- The quotient functor from complexes to the homotopy category. -/
def quotient : homological_complex V c ⥤ homotopy_category V c :=
category_theory.quotient.functor _

local attribute [instance] has_zero_object.has_zero

-- TODO upgrade this is to `has_zero_object`, presumably for any `quotient`.
instance [has_zero_object V] : inhabited (homotopy_category V c) := ⟨(quotient V c).obj 0⟩

variables {V c}

@[simp] lemma quotient_obj_as (C : homological_complex V c) :
  ((quotient V c).obj C).as = C := rfl

@[simp] lemma quotient_map_out {C D : homotopy_category V c} (f : C ⟶ D) :
  (quotient V c).map f.out = f :=
quot.out_eq _

lemma eq_of_homotopy {C D : homological_complex V c} (f g : C ⟶ D) (h : homotopy f g) :
  (quotient V c).map f = (quotient V c).map g :=
category_theory.quotient.sound _ ⟨h⟩

/-- If two chain maps become equal in the homotopy category, then they are homotopic. -/
def homotopy_of_eq {C D : homological_complex V c} (f g : C ⟶ D)
  (w : (quotient V c).map f = (quotient V c).map g) : homotopy f g :=
((quotient.functor_map_eq_iff _ _ _).mp w).some

/--
An arbitrarily chosen representation of the image of a chain map in the homotopy category
is homotopic to the original chain map.
-/
def homotopy_out_map {C D : homological_complex V c} (f : C ⟶ D) :
  homotopy ((quotient V c).map f).out f :=
begin
  apply homotopy_of_eq,
  simp,
end

@[simp] lemma quotient_map_out_comp_out {C D E : homotopy_category V c} (f : C ⟶ D) (g : D ⟶ E) :
  (quotient V c).map (quot.out f ≫ quot.out g) = f ≫ g :=
by conv_rhs { erw [←quotient_map_out f, ←quotient_map_out g, ←(quotient V c).map_comp], }

/-- Homotopy equivalent complexes become isomorphic in the homotopy category. -/
@[simps]
def iso_of_homotopy_equiv {C D : homological_complex V c} (f : homotopy_equiv C D) :
  (quotient V c).obj C ≅ (quotient V c).obj D :=
{ hom := (quotient V c).map f.hom,
  inv := (quotient V c).map f.inv,
  hom_inv_id' := begin
    rw [←(quotient V c).map_comp, ←(quotient V c).map_id],
    exact eq_of_homotopy _ _ f.homotopy_hom_inv_id,
  end,
  inv_hom_id' := begin
    rw [←(quotient V c).map_comp, ←(quotient V c).map_id],
    exact eq_of_homotopy _ _ f.homotopy_inv_hom_id,
  end }

/-- If two complexes become isomorphic in the homotopy category,
  then they were homotopy equivalent. -/
def homotopy_equiv_of_iso
  {C D : homological_complex V c} (i : (quotient V c).obj C ≅ (quotient V c).obj D) :
  homotopy_equiv C D :=
{ hom := quot.out i.hom,
  inv := quot.out i.inv,
  homotopy_hom_inv_id := homotopy_of_eq _ _ (by { simp, refl, }),
  homotopy_inv_hom_id := homotopy_of_eq _ _ (by { simp, refl, }), }

variables (V c) [has_zero_object V] [has_equalizers V] [has_images V] [has_image_maps V]
  [has_cokernels V]

/-- The `i`-th homology, as a functor from the homotopy category. -/
def homology_functor (i : ι) : homotopy_category V c ⥤ V :=
category_theory.quotient.lift _ (homology_functor V c i)
  (λ C D f g ⟨h⟩, homology_map_eq_of_homotopy h i)

/-- The homology functor on the homotopy category is just the usual homology functor. -/
def homology_factors (i : ι) :
  quotient V c ⋙ homology_functor V c i ≅ _root_.homology_functor V c i :=
category_theory.quotient.lift.is_lift _ _ _

@[simp] lemma homology_factors_hom_app (i : ι) (C : homological_complex V c) :
  (homology_factors V c i).hom.app C = 𝟙 _ :=
rfl

@[simp] lemma homology_factors_inv_app (i : ι) (C : homological_complex V c) :
  (homology_factors V c i).inv.app C = 𝟙 _ :=
rfl

lemma homology_functor_map_factors (i : ι) {C D : homological_complex V c} (f : C ⟶ D) :
  (_root_.homology_functor V c i).map f =
    ((homology_functor V c i).map ((quotient V c).map f) : _) :=
(category_theory.quotient.lift_map_functor_map _ (_root_.homology_functor V c i) _ f).symm

end homotopy_category

namespace category_theory

variables {V} {W : Type*} [category W] [preadditive W]

/-- An additive functor induces a functor between homotopy categories. -/
@[simps]
def functor.map_homotopy_category (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  homotopy_category V c ⥤ homotopy_category W c :=
{ obj := λ C, (homotopy_category.quotient W c).obj ((F.map_homological_complex c).obj C.as),
  map := λ C D f,
    (homotopy_category.quotient W c).map ((F.map_homological_complex c).map (quot.out f)),
  map_id' := λ C, begin
    rw ←(homotopy_category.quotient W c).map_id,
    apply homotopy_category.eq_of_homotopy,
    rw ←(F.map_homological_complex c).map_id,
    apply F.map_homotopy,
    apply homotopy_category.homotopy_of_eq,
    exact quot.out_eq _,
  end,
  map_comp' := λ C D E f g, begin
    rw ←(homotopy_category.quotient W c).map_comp,
    apply homotopy_category.eq_of_homotopy,
    rw ←(F.map_homological_complex c).map_comp,
    apply F.map_homotopy,
    apply homotopy_category.homotopy_of_eq,
    convert quot.out_eq _,
    exact homotopy_category.quotient_map_out_comp_out _ _,
  end }.

-- TODO `F.map_homotopy_category c` is additive (and linear when `F` is linear).

/-- A natural transformation induces a natural transformation between
  the induced functors on the homotopy category. -/
@[simps]
def nat_trans.map_homotopy_category {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ⟶ G) (c : complex_shape ι) : F.map_homotopy_category c ⟶ G.map_homotopy_category c :=
{ app := λ C,
    (homotopy_category.quotient W c).map ((nat_trans.map_homological_complex α c).app C.as),
  naturality' := λ C D f,
  begin
    dsimp,
    simp only [←functor.map_comp],
    congr' 1,
    ext,
    dsimp,
    simp,
  end }

@[simp] lemma nat_trans.map_homotopy_category_id (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  nat_trans.map_homotopy_category (𝟙 F) c = 𝟙 (F.map_homotopy_category c) :=
by tidy

@[simp] lemma nat_trans.map_homotopy_category_comp (c : complex_shape ι)
  {F G H : V ⥤ W} [F.additive] [G.additive] [H.additive]
  (α : F ⟶ G) (β : G ⟶ H):
  nat_trans.map_homotopy_category (α ≫ β) c =
    nat_trans.map_homotopy_category α c ≫ nat_trans.map_homotopy_category β c :=
by tidy

end category_theory


import order.lattice -- for lattice.semilattice_inf
import order.bounds -- for is_lub
import algebra.ring -- for is_ring_hom
import topology.opens -- only for the conjecture that i need precisely opens α
--import sheaves.sheaf
--  import sheaves.covering.covering
  -- import sheaves.presheaf
import data.equiv.basic

import tactic.where -- cool debugging tool

-- this is the only non-mathlib import. Should that stuff be in mathlib
-- or not? If not then feel free to rewrite the below.
-- In the Xena project this import is in src/
import for_mathlib_complete_lattice

--open lattice

universes v u

open lattice

structure presheaf (α : Type u) [semilattice_inf α] :=
(F     : α → Type v)
(res   : ∀ (U V) (HVU : V ≤ U), F U → F V)
(Hid   : ∀ (U), res U U (le_refl U) = id)
(Hcomp : ∀ (U V W) (HWV : W ≤ V) (HVU : V ≤ U),
  res U W (le_trans HWV HVU) = res V W HWV ∘ res U V HVU)

namespace presheaf

variables {α : Type u} [semilattice_inf α]

instance : has_coe_to_fun (presheaf α) :=
{ F := λ _, α → Type v,
  coe := presheaf.F }

-- Simplification lemmas for Hid and Hcomp.

@[simp] lemma Hcomp' (F : presheaf α) :
∀ (U V W) (HWV : W ≤ V) (HVU : V ≤ U) (s : F U),
  (F.res U W (le_trans HWV HVU)) s =
  (F.res V W HWV) ((F.res U V HVU) s) :=
λ U V W HWV HVU s, by rw F.Hcomp U V W HWV HVU

@[simp] lemma Hid' (F : presheaf α) :
∀ (U) (s : F U),
  (F.res U U (le_refl U)) s = s :=
λ U s, by rw F.Hid U; simp

def total (F : presheaf α) : Type (max u v) := Σ U, F.F U

instance (F : presheaf α) (U : α) : has_coe_t (F U) F.total :=
⟨sigma.mk _⟩

@[elab_as_eliminator]
theorem total.cases_on (F : presheaf α) {C : F.total → Sort*}
  (x) (H : ∀ U (x : F U), C x) : C x :=
by cases x; apply H

def res' (F : presheaf α) (V : α) : F.total → F.total
| ⟨U, x⟩ := F.res U (U ⊓ V) inf_le_left x

theorem res'_def (F : presheaf α) {U V} (x : F U) :
  F.res' V x = F.res U (U ⊓ V) inf_le_left x := rfl

theorem res'_val (F : presheaf α) {U V} (x : F U) (h : V ≤ U) :
  F.res' V x = F.res U V h x :=
have ∀ W (H : W ≤ U), W = V →
  (F.res U W H x : F.total) = F.res U V h x :=
  by rintro _ _ rfl; refl,
this _ _ (inf_of_le_right h)

theorem res'_eq_inf (F : presheaf α) {U V} (x : F U) :
  F.res' V x = F.res' (U ⊓ V) x :=
by rw [res'_def, ← res'_val _ _ inf_le_left]

theorem res'_eq_left (F : presheaf α) {U V W} (x : F U) (H : U ⊓ V = U ⊓ W) :
  F.res' V x = F.res' W x :=
by rw [res'_eq_inf, H, ← res'_eq_inf]

@[simp] theorem res'_id {F : presheaf α} {U} (x : F U) : F.res' U x = x :=
by rw [res'_val _ _ (le_refl U), F.Hid]; refl

@[simp] theorem res'_comp {F : presheaf α} {U V} (x : F.total) :
  F.res' U (F.res' V x) = F.res' (U ⊓ V) x :=
total.cases_on F x $ λ W x,
by rw [res'_def, res'_def, ← F.Hcomp', ← res'_val, res'_eq_left];
   simp [inf_left_comm, inf_comm]

def locality (F : presheaf α) :=
∀ {{U S}}, is_lub S U → ∀ {{s t : F U}},
  (∀ V ∈ S, F.res' V s = F.res' V t) → s = t

def gluing (F : presheaf α) :=
∀ {{U : α}} {{S}}, is_lub S U →
∀ (s : Π V : S, F V),
(∀ V W : S,
  res' F (V ⊓ W) (s V) = res' F (V ⊓ W) (s W)) →
∃ x : F U, ∀ V:S, F.res' V x = s V

end presheaf

--#where

universes w u₁ v₁

/- memo for porting

opens X -> α
top space X -> sdemilattice_inf α
-/

-- open topological_space

structure sheaf (α : Type u) [semilattice_inf α] extends presheaf α :=
(locality : to_presheaf.locality)
(gluing   : to_presheaf.gluing)

structure sheaf_of_rings (α : Type u) [semilattice_inf α] extends sheaf α :=
[ring : ∀ U, ring (F U)]
[ring_hom : ∀ U V h, is_ring_hom (res U V h)]
def sheaf_on_opens (α : Type u) [semilattice_inf α] (U : α) : Type (max u (v+1)) :=
sheaf.{u v} α

namespace sheaf_on_opens

variables {α : Type u} [semilattice_inf α] {U : α}

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

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

theorem res_comp (F : sheaf_on_opens α U) (V1 : α) (HV1 : V1 ≤ U)
  (V2 : α) (HV2 : V2 ≤ U) (V3 : α) (HV3 : V3 ≤ U) (H12 : V2 ≤ V1) (H23 : V3 ≤ V2)
  (f : F.eval V1 HV1) :
  F.res V2 HV2 V3 HV3 H23 (F.res V1 HV1 V2 HV2 H12 f) = F.res V1 HV1 V3 HV3 (le_trans H23 H12) f :=
(F.to_presheaf.Hcomp' _ _ _ _ _ f).symm

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

theorem eval_res_subset (F : sheaf_on_opens α U) (V : α) (HVU : V ≤ U) (W : α) (HWV : W ≤ V) :
  eval (res_subset F V HVU) W HWV = eval F W (le_trans HWV HVU) := rfl

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

namespace morphism

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

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

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

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

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

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

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

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

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

end morphism

#where
structure equiv (F : sheaf_on_opens.{v} α U) (G : sheaf_on_opens.{w} α U) : Type (max u v w) :=
(to_fun : morphism F G)
(inv_fun : morphism G F)
(left_inv : inv_fun.comp to_fun = morphism.id F)
(right_inv : to_fun.comp inv_fun = morphism.id G)

namespace equiv

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

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

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

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

end equiv

end sheaf_on_opens
 /-
** TODO **
#check @lattice.supr
supr : Π {α : Type u_1} {ι : Sort u_2} [_inst_1 : has_Sup α], (ι → α) → α

Why not

supr : Π {α : Type u_1} [_inst_1 : has_Sup α] {ι : Sort u_2}, (ι → α) → α
-/

def complete_lattice.supr (α : Type u) (ι : Sort v) [X : complete_lattice α] :=
  @lattice.supr α ι _ -- Grumpy old mathematician observes that stupid polymorphism
                      -- makes me have to fill in more stuff

theorem complete_lattice.subset_Union (α : Type u) [X : complete_lattice α] {I : Type} (s : I → α) (i : I) :
  s i ≤ supr s :=
lattice.complete_lattice.le_supr s i

--def complete_lattice.Union : Π {I : Type 37}, (I → α) → α
--#check complete_lattice.supr -- fails
/-- thing I need -/

structure thing (α : Type u) extends semilattice_inf α :=
(supr {ι : Sort v} (s : ι → α) : α)
(le_supr {ι : Sort v} : ∀ (s : ι → α) (i : ι), s i ≤ supr s)
/- hey -- that just *forced* me to make `thing.le_supr` have inputs in the following order:

thing.le_supr : ∀ {α : Type u_2} (c : thing α) {ι : Sort u_1} (s : ι → α) (i : ι), s i ≤ c.supr s

But

lattice.le_supr :
  ∀ {α : Type u_1} {ι : Sort u_2} [_inst_1 : lattice.complete_lattice α] (s : ι → α) (i : ι),
    s i ≤ lattice.supr s
-/

namespace thing

instance (α : Type u) (Y : thing α) : semilattice_inf α := thing.to_semilattice_inf Y
-- example (α : Type u) (Y : thing α) : semilattice_inf α := by apply_instance -- fails

-- Debugging starts here.

-- structure thing (α : Type u) extends semilattice_inf α :=

-- #print semilattice_inf
/-
/-- A `semilattice_inf` is a meet-semilattice, that is, a partial order
  with a meet (a.k.a. glb / greatest lower bound, inf / infimum) operation
  `⊓` which is the greatest element smaller than both factors. -/
class semilattice_inf (α : Type u) extends has_inf α, partial_order α :=
(inf_le_left : ∀ a b : α, a ⊓ b ≤ a)
(inf_le_right : ∀ a b : α, a ⊓ b ≤ b)
(le_inf : ∀ a b c : α, a ≤ b → a ≤ c → a ≤ b ⊓ c)

@[class]
structure lattice.semilattice_inf : Type u → Type u
fields: ...
-/

-- #print notation ⊓ -- lattice.has_inf.inf at 70

-- #check semilattice_inf
-- class semilattice_inf (α : Type u) extends has_inf α, partial_order α :=

--#where

/-
structure thing (α : Type u) extends semilattice_inf α :=
(supr {ι : Sort v} (s : ι → α) : α)
(le_supr {ι : Sort v} : ∀ (s : ι → α) (i : ι), s i ≤ supr s)
-/
--#print semilattice_inf
-- it's a class

example (α : Type u) [bounded_lattice α] [has_Sup α] [has_Inf α] [lattice.complete_lattice α] :
  semilattice_inf α := by apply_instance

-- #print lattice.complete_lattice
/-
class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)
-/
set_option pp.structure_instances true
def canonical2.to_fun (α : Type u)
[lattice.complete_lattice α] : thing.{v} α :=
begin
--let this : semilattice_inf α := by apply_instance,
refine { inf := semilattice_inf.inf,
         le := semilattice_inf.le,
         le_refl := semilattice_inf.le_refl,
         le_trans := semilattice_inf.le_trans,
         le_antisymm := semilattice_inf.le_antisymm,
  --       inf_le_inf := semilattice_inf.inf_le_inf,
         inf_le_left := semilattice_inf.inf_le_left,
         inf_le_right := semilattice_inf.inf_le_right,
         le_inf := semilattice_inf.le_inf,
          -- the rest are not from semilattice namespace
         le_supr := λ (ι : Sort v) s, begin convert lattice.complete_lattice.le_supr s, convert rfl end,--convert rfl using 0, congr', ext, convert iff.rfl, ext, convert iff.rfl, ext, convert iff.rfl, sorry end,
         supr := λ ι s, lattice.complete_lattice.supr s,
         },
end

--#check complete_lattice
/-
/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)
-/

-- lattice α, order_top α, order_bot α
--#check lattice

/-
/-- A `semilattice_sup` is a join-semilattice, that is, a partial order
  with a join (a.k.a. lub / least upper bound, sup / supremum) operation
  `⊔` which is the least element larger than both factors. -/
class semilattice_sup (α : Type u) extends has_sup α, partial_order α :=
(le_sup_left : ∀ a b : α, a ≤ a ⊔ b)
(le_sup_right : ∀ a b : α, b ≤ a ⊔ b)
(sup_le : ∀ a b c : α, a ≤ c → b ≤ c → a ⊔ b ≤ c)
-/

--#print has_sup
--#print notation ⊔

inductive ubool : Type u
| tt : ubool
| ff : ubool

-- in thing namespace
--#check @lattice.complete_lattice.sup

-- there might be a universe issue here
def sup {α : Type u} [c : complete_lattice α] (Y : thing α) (a b : α) : α :=
@thing.supr α Y ubool (@ubool.rec (λ _, α) a b)

instance has_sup (α : Type u) [semilattice_inf α] (Y : thing α) : has_sup α :=
{ sup := λ a b, @thing.supr α Y ubool (@ubool.rec (λ _, α) a b)}

example (α : Type u) [semilattice_inf α] (Y : thing α) : partial_order α := by apply_instance

variables (α : Type u) [semilattice_inf α]

--(supr {ι : Sort v} (s : ι → α) : α)
--(le_supr {ι : Sort v} : ∀ (s : ι → α) (i : ι), s i ≤ supr s)

attribute [instance] thing.to_semilattice_inf

theorem le_sup_left (Y : thing α) : begin
-- I need this for the notation
letI : has_sup α := @thing.has_sup α _ Y,
resetI,
exact ∀ (a b : α), a ≤ a ⊔ b end :=
begin
  sorry,
end
--  intros h a b,
--  unfold has_sup.sup,
--  convert Y.le_supr _ _ using 0,
--  convert rfl using 0,
--  sorry,

-- #print semilattice_sup -- it's a class
 /-
 class semilattice_sup (α : Type u) extends has_sup α, partial_order α :=
(le_sup_left : ∀ a b : α, a ≤ a ⊔ b)
(le_sup_right : ∀ a b : α, b ≤ a ⊔ b)
(sup_le : ∀ a b c : α, a ≤ c → b ≤ c → a ⊔ b ≤ c)
-/
instance (α : Type u) [H : semilattice_inf α] (Y : thing α) : semilattice_sup α :=
{ sup := λ a b, @thing.supr α Y bool (@bool.rec (λ _, α) a b),
  le_sup_left := begin sorry end,-- Y.le_sup_left,
  le_sup_right := sorry,
  sup_le := sorry, ..H}

example (α : Type u) [semilattice_inf α] (Y : thing α) : lattice α :=
begin
  sorry
end
#exit
example (α : Type u) [semilattice_inf α] (Y : thing α) : order_top α := by apply_instance
example (α : Type u) [semilattice_inf α] (Y : thing α) : order_bot α := by apply_instance
instance (α : Type u) [semilattice_inf α] (Y : thing α) : bounded_lattice α :=
by apply_instance #exit
lattice.complete_lattice α :=

bounded_lattice α
--class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=

def canonical2.inv_fun (α : Type u) [semilattice_inf α] (Y : thing α) : lattice.complete_lattice α :=
begin

  sorry
end

#exit
begin

  sorry
end
#exit
  apply ..X,
{ supr := λ ι s, lattice.complete_lattice.supr,--∀ {ι : Sort v} (s : ι → α), α := λ ι s, lattice.complete_lattice.supr,
  le_supr {ι : Sort v} : ∀ (s : ι → α) (i : ι), s i ≤ supr s := sorry}

#exit
-- by apply_instance #exit
-- semilattice_inf
begin
  letI : has_inf α := by apply_instance,
  letI : partial_order α := by apply_instance,
  exactI { inf := X.inf,
  le := _,
  le_refl := X.le_refl,
  le_trans := begin convert X.le_trans, ext, convert iff.rfl, ext, sorry end,
  le_antisymm := _,
  -- TODO : convert docstring does not mention
  inf_le_left := begin convert X.inf_le_left, convert rfl, convert rfl, sorry end,
  inf_le_right := _,
  le_inf := _ },
  repeat {sorry}
end
#exit
{ inf := _,
  le := _,
  lt := _,
  le_refl := _,
  le_trans := _,
  lt_iff_le_not_le := _,
  le_antisymm := _,
  inf_le_left := _,
  inf_le_right := _,
  le_inf := _ }
--#where

-- thing is a structure, complete_lattice is a class

--#print lattice.complete_lattice
/-
Mario:
  complete_lattice <- bounded_lattice <- lattice, order_top, order_bot and lattice <- semilattice_sup, semilattice_inf <- partial order
Lean:
  class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=

-/

--def lattice.complete_lattice.supr := sorry
def canonical1.to_fun (α : Type u)
[bounded_lattice α] [has_Sup α] [has_Inf α]
[X : lattice.complete_lattice α] : thing α :=
begin resetI,
  exact { inf := _,
  le := X.le,
  le_refl := X.le_refl,
  le_trans := X.le_trans,
  le_antisymm := X.le_antisymm,
  inf_le_left := X.inf_le_left,
  inf_le_right := X.inf_le_right,
  le_inf := X.le_inf,
  supr := X.supr,
  le_supr := _ },
  repeat {sorry},
  end
#exit
def canonical1 (α : Type u) : _root_.equiv (lattice.complete_lattice α) (thing α) :=
{ to_fun := λ X, {
    inf := _,
    le := X.le,
    le_refl := X.le_refl,
    le_trans := X.le_trans,
    le_antisymm := X.le_antisymm,
    inf_le_left := X.inf_le_left,
    inf_le_right := X.inf_le_right,
    le_inf := X.le_inf,
    supr := λ I, @lattice.supr α I (by resetI; apply_instance), -- bit of an effort!
    le_supr := λ ι, @lattice.complete_lattice.le_supr _ ι (by resetI; apply_instance),--==s i ≤ lattice.supr s@lattice.complete_lattice.le_supr ,--==lattice.complete_lattice.le_supr},--begin sorry, end,
  },inv_fun := λ Y, by exact { sup := _,
  le := Y.le,
  lt := _,
  le_refl := _,
  le_trans := _,
  lt_iff_le_not_le := Y.lt_iff_le_not_le,
  le_antisymm := _,
  le_sup_left := begin convert Y.le_sup_left, sorry end--sorry, -- I hate it when sorry is underlined
  le_sup_right := _,
  sup_le := _,
  inf := _,
  inf_le_left := _,
  inf_le_right := _,
  le_inf := _,
  top := _,
  le_top := _,
  bot := _,
  bot_le := _,
  Sup := _,
  Inf := _,
  le_Sup := _,
  Sup_le := _,
  Inf_le := _,
  le_Inf := _ },
  left_inv := λ X, _,
  right_inv := sorry }
#exit

#print canonical1.le

_root_.equiv (thing α) (topological_space.opens (thing.Union α )) :=
{ to_fun := begin
    rintro ⟨SLIα,U,sU⟩,

  end,
  inv_fun := _,
  left_inv := _,
  right_inv := _ }

-- should be in mathlib

#check semilattice_inf
namespace opens

def Union {I : Type*} (s : I → α) : α :=
⟨set.Union (λ i, (s i).1), is_open_Union (λ i, (s i).2)⟩

variables {I : Type*} (s : I → α)

theorem subset_Union : ∀ (s : I → α) (i : I), s i ≤ Union s :=
-- why does lattice.le_supr need complete lattice?
λ s i x hx, set.mem_Union.2 ⟨i, hx⟩

/- Other things I might need about this Union

@[simp] theorem mem_Union {x : β} {s : ι → set β} : x ∈ Union s ↔ ∃ i, x ∈ s i :=
⟨assume ⟨t, ⟨⟨a, (t_eq : s a = t)⟩, (h : x ∈ t)⟩⟩, ⟨a, t_eq.symm ▸ h⟩,
  assume ⟨a, h⟩, ⟨s a, ⟨⟨a, rfl⟩, h⟩⟩⟩
/- alternative proof: dsimp [Union, supr, Sup]; simp -/
  -- TODO: more rewrite rules wrt forall / existentials and logical connectives
  -- TODO: also eliminate ∃i, ... ∧ i = t ∧ ...

theorem Union_subset {s : ι → set β} {t : set β} (h : ∀ i, s i ⊆ t) : (⋃ i, s i) ⊆ t :=
-- TODO: should be simpler when sets' order is based on lattices
@supr_le (set β) _ set.lattice_set _ _ h

theorem Union_subset_iff {α : Sort u} {s : α → set β} {t : set β} : (⋃ i, s i) ⊆ t ↔ (∀ i, s i ⊆ t):=
⟨assume h i, subset.trans (le_supr s _) h, Union_subset⟩

theorem subset_Union : ∀ (s : ι → set β) (i : ι), s i ⊆ (⋃ i, s i) := le_supr

theorem Union_const [inhabited ι] (s : set β) : (⋃ i:ι, s) = s :=
ext $ by simp

theorem inter_Union_left (s : set β) (t : ι → set β) :
  s ∩ (⋃ i, t i) = ⋃ i, s ∩ t i :=
ext $ by simp

theorem inter_Union_right (s : set β) (t : ι → set β) :
  (⋃ i, t i) ∩ s = ⋃ i, t i ∩ s :=
ext $ by simp

theorem Union_union_distrib (s : ι → set β) (t : ι → set β) :
  (⋃ i, s i ∪ t i) = (⋃ i, s i) ∪ (⋃ i, t i) :=
ext $ by simp [exists_or_distrib]

theorem union_Union_left [inhabited ι] (s : set β) (t : ι → set β) :
  s ∪ (⋃ i, t i) = ⋃ i, s ∪ t i :=
by rw [Union_union_distrib, Union_const]

theorem union_Union_right [inhabited ι] (s : set β) (t : ι → set β) :
  (⋃ i, t i) ∪ s = ⋃ i, t i ∪ s :=
by rw [Union_union_distrib, Union_const]

theorem diff_Union_right (s : set β) (t : ι → set β) :
  (⋃ i, t i) \ s = ⋃ i, t i \ s :=
inter_Union_right _ _

-/

end opens

def glue {I : Type*} (S : I → α) (F : Π (i : I), sheaf_on_opens.{v} α (S i))
  (φ : Π (i j : I),
    equiv ((F i).res_subset ((S i) ∩ (S j)) (set.inter_subset_left _ _)) ((F j).res_subset ((S i) ∩ (S j)) (set.inter_subset_right _ _)))
  (Hφ1 : ∀ i, φ i i = equiv.refl (F i))
  (Hφ2 : ∀ i j k,
    ((φ i j).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.inter_subset_left _ _)).trans
      ((φ j k).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.subset_inter (le_trans (set.inter_subset_left _ _)
       (set.inter_subset_right _ _)) (set.inter_subset_right _ _))) =
    (φ i k).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.subset_inter (le_trans (set.inter_subset_left _ _)
    (set.inter_subset_left _ _)) (set.inter_subset_right _ _))) :
  sheaf_on_opens.{max u v} α (opens.Union S) :=
{ F :=
  { F := λ W, { f : Π i, (F i).eval ((S i) ∩ W) (set.inter_subset_left _ _) //
      ∀ i j, (φ i j).1.map ((S i) ∩ (S j) ∩ W) (set.inter_subset_left _ _)
        ((F i).res ((S i) ∩ W) _ _ (le_trans (set.inter_subset_left _ _) (set.inter_subset_left _ _))
          (set.subset_inter (le_trans (set.inter_subset_left _ _) (set.inter_subset_left _ _)) (set.inter_subset_right _ _))
          (f i)) =
        (F j).res ((S j) ∩ W) _ _ (le_trans (set.inter_subset_left _ _) (set.inter_subset_right _ _))
          (set.subset_inter (le_trans (set.inter_subset_left _ _) (set.inter_subset_right _ _)) (set.inter_subset_right _ _))
          (f j) },
    res := λ U V HUV f, ⟨λ i, (F i).res (S i ∩ U) _ (S i ∩ V) _ (set.inter_subset_inter_right _ HUV) (f.val i),
      begin
        intros i j,
        rw res_comp,
        rw res_comp,
        have answer := congr_arg
        (res (F j)
          (S i ∩ (S j) ∩ U) _
          (S i ∩ (S j) ∩ V) (le_trans (set.inter_subset_left _ _) (set.inter_subset_right _ _)) (set.inter_subset_inter_right _ HUV)
        )
        (f.property i j),
        rw res_comp at answer,
        rw ←answer,
        clear answer,
        convert (φ i j).to_fun.commutes
        (S i ∩ (S j) ∩ U) (set.inter_subset_left _ _)
        (S i ∩ (S j) ∩ V) (set.inter_subset_left _ _) (set.inter_subset_inter_right _ HUV)
        (
          (@sheaf_on_opens.res _ _ (S i ∩ U)
            (F i)
            (S i ∩ U) (by refl)
            (S i ∩ S j ∩ U) (set.inter_subset_inter_left _ (set.inter_subset_left _ _)) (set.inter_subset_inter_left _ (set.inter_subset_left _ _))
            (f.val i)
          )
        ) using 2,
        convert (F i).F.Hcomp' (S i ∩ U) (S i ∩ S j ∩ U) (S i ∩ S j ∩ V) _ _ (f.val i),
      end⟩,
    Hid := begin
      sorry
    end,
    Hcomp := sorry },
  locality := sorry,
  gluing := sorry }

def mario_belief (s : set α) (F : Π (i : I), sheaf_on_opens.{v} α (S i))

def universal_property (I : Type*) (S : I → α) (F : Π (i : I), sheaf_on_opens.{v} α (S i))
  (φ : Π (i j : I),
    equiv ((F i).res_subset ((S i) ∩ (S j)) (set.inter_subset_left _ _)) ((F j).res_subset ((S i) ∩ (S j)) (set.inter_subset_right _ _)))
  (Hφ1 : ∀ i, φ i i = equiv.refl (F i))
  (Hφ2 : ∀ i j k,
    ((φ i j).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.inter_subset_left _ _)).trans
      ((φ j k).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.subset_inter (le_trans (set.inter_subset_left _ _) (set.inter_subset_right _ _)) (set.inter_subset_right _ _))) =
    (φ i k).res_subset ((S i) ∩ (S j) ∩ (S k)) (set.subset_inter (le_trans (set.inter_subset_left _ _) (set.inter_subset_left _ _)) (set.inter_subset_right _ _))) :
∀ i : I, equiv (res_subset (glue S F φ Hφ1 Hφ2) (S i) $ opens.subset_Union S i) (F i) := sorry

/- questions:

1) Can you glue presheaves of types? And prove the universal property for sets?
2) Cah you glue sheaves of types? And prove the universal property for sets?
3) Can you glue sheaves of rings? And prove the universal property for sets?
4) What about proving the universal property for types?
-- You are the winner if you get this far

end sheaf_on_opens


structure A :=
(x y : Nat)

structure B :=
(z : Nat)

structure C extends A, B

def f (c : C) :=
c.x + c.y + c.z

theorem ex1 : f {x := 10, y := 20, z := 30} = 60 :=
rfl

structure D

def g (d : D) : D :=
d

theorem ex2 : g {} = {} :=
rfl

theorem ex3 (d : D) : g d = {} := by
 cases d
 exact rfl


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.compatible_plus

/-!

In this file, we prove that sheafification is compatible with functors which
preserve the correct limits and colimits.

-/

namespace category_theory.grothendieck_topology

open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables (F : D ⥤ E)

noncomputable theory

variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) D]
variables [∀ (α β : Type (max v u)) (fst snd : β → α),
  has_limits_of_shape (walking_multicospan fst snd) E]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ E]
variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
variables [∀ (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D), preserves_limit (W.index P).multicospan F]

variables (P : Cᵒᵖ ⥤ D)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`.

Use the lemmas `whisker_right_to_sheafify_sheafify_comp_iso_hom`,
`to_sheafify_comp_sheafify_comp_iso_inv` and `sheafify_comp_iso_inv_eq_sheafify_lift` to reduce
the components of this isomorphisms to a state that can be handled using the universal property
of sheafification. -/
def sheafify_comp_iso : J.sheafify P ⋙ F ≅ J.sheafify (P ⋙ F) :=
J.plus_comp_iso _ _ ≪≫ (J.plus_functor _).map_iso (J.plus_comp_iso _ _)

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `F`. -/
def sheafification_whisker_left_iso (P : Cᵒᵖ ⥤ D)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (whiskering_left _ _ E).obj (J.sheafify P) ≅
  (whiskering_left _ _ _).obj P ⋙ J.sheafification E :=
begin
  refine J.plus_functor_whisker_left_iso _ ≪≫ _ ≪≫ functor.associator _ _ _,
  refine iso_whisker_right _ _,
  refine J.plus_functor_whisker_left_iso _,
end

@[simp]
lemma sheafification_whisker_left_iso_hom_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).hom.app F = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  rw category.comp_id,
end

@[simp]
lemma sheafification_whisker_left_iso_inv_app (P : Cᵒᵖ ⥤ D) (F : D ⥤ E)
  [∀ (F : D ⥤ E) (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ F]
  [∀ (F : D ⥤ E) (X : C) (W : J.cover X) (P : Cᵒᵖ ⥤ D),
    preserves_limit (W.index P).multicospan F] :
  (sheafification_whisker_left_iso J P).inv.app F = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_left_iso, sheafify_comp_iso],
  erw category.id_comp,
end

/-- The isomorphism between the sheafification of `P` composed with `F` and
the sheafification of `P ⋙ F`, functorially in `P`. -/
def sheafification_whisker_right_iso :
  J.sheafification D ⋙ (whiskering_right _ _ _).obj F ≅
  (whiskering_right _ _ _).obj F ⋙ J.sheafification E :=
begin
  refine functor.associator _ _ _ ≪≫ _,
  refine iso_whisker_left (J.plus_functor D) (J.plus_functor_whisker_right_iso _) ≪≫ _,
  refine _ ≪≫ functor.associator _ _ _,
  refine (functor.associator _ _ _).symm ≪≫ _,
  exact iso_whisker_right (J.plus_functor_whisker_right_iso _) (J.plus_functor E),
end

@[simp]
lemma sheafification_whisker_right_iso_hom_app :
  (J.sheafification_whisker_right_iso F).hom.app P = (J.sheafify_comp_iso F P).hom :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp]
lemma sheafification_whisker_right_iso_inv_app :
  (J.sheafification_whisker_right_iso F).inv.app P = (J.sheafify_comp_iso F P).inv :=
begin
  dsimp [sheafification_whisker_right_iso, sheafify_comp_iso],
  simp only [category.id_comp, category.comp_id],
  erw category.id_comp,
end

@[simp, reassoc]
lemma whisker_right_to_sheafify_sheafify_comp_iso_hom :
  whisker_right (J.to_sheafify _) _ ≫ (J.sheafify_comp_iso F P).hom = J.to_sheafify _ :=
begin
  dsimp [sheafify_comp_iso],
  erw [whisker_right_comp, category.assoc],
  slice_lhs 2 3 { rw plus_comp_iso_whisker_right },
  rw [category.assoc, ← J.plus_map_comp,
    whisker_right_to_plus_comp_plus_comp_iso_hom, ← category.assoc,
    whisker_right_to_plus_comp_plus_comp_iso_hom],
  refl,
end

@[simp, reassoc]
lemma to_sheafify_comp_sheafify_comp_iso_inv :
  J.to_sheafify _ ≫ (J.sheafify_comp_iso F P).inv = whisker_right (J.to_sheafify _) _ :=
by { rw iso.comp_inv_eq, simp }

section

-- We will sheafify `D`-valued presheaves in this section.
variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

@[simp]
lemma sheafify_comp_iso_inv_eq_sheafify_lift : (J.sheafify_comp_iso F P).inv =
  J.sheafify_lift (whisker_right (J.to_sheafify _) _) ((J.sheafify_is_sheaf _).comp _) :=
begin
  apply J.sheafify_lift_unique,
  rw iso.comp_inv_eq,
  simp,
end

end

end category_theory.grothendieck_topology


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury G. Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.monoid
import Mathlib.algebra.group.pi
import Mathlib.PostPort

universes u_1 u_2 u_3 l

namespace Mathlib

/-!
# Topological group with zero

In this file we define `has_continuous_inv'` to be a mixin typeclass a type with `has_inv` and
`has_zero` (e.g., a `group_with_zero`) such that `λ x, x⁻¹` is continuous at all nonzero points. Any
normed (semi)field has this property. Currently the only example of `has_continuous_inv'` in
`mathlib` which is not a normed field is the type `nnnreal` (a.k.a. `ℝ≥0`) of nonnegative real
numbers.

Then we prove lemmas about continuity of `x ↦ x⁻¹` and `f / g` providing dot-style `*.inv'` and
`*.div` operations on `filter.tendsto`, `continuous_at`, `continuous_within_at`, `continuous_on`,
and `continuous`. As a special case, we provide `*.div_const` operations that require only
`group_with_zero` and `has_continuous_mul` instances.

All lemmas about `(⁻¹)` use `inv'` in their names because lemmas without `'` are used for
`topological_group`s. We also use `'` in the typeclass name `has_continuous_inv'` for the sake of
consistency of notation.
-/

/-!
### A group with zero with continuous multiplication

If `G₀` is a group with zero with continuous `(*)`, then `(/y)` is continuous for any `y`. In this
section we prove lemmas that immediately follow from this fact providing `*.div_const` dot-style
operations on `filter.tendsto`, `continuous_at`, `continuous_within_at`, `continuous_on`, and
`continuous`.
-/

theorem filter.tendsto.div_const {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_mul G₀] {f : α → G₀} {l : filter α} {x : G₀} {y : G₀}
    (hf : filter.tendsto f l (nhds x)) : filter.tendsto (fun (a : α) => f a / y) l (nhds (x / y)) :=
  sorry

theorem continuous_at.div_const {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_mul G₀] {f : α → G₀} [topological_space α]
    (hf : continuous f) {y : G₀} : continuous fun (x : α) => f x / y :=
  sorry

theorem continuous_within_at.div_const {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_mul G₀] {f : α → G₀} {s : set α} [topological_space α]
    {a : α} (hf : continuous_within_at f s a) {y : G₀} :
    continuous_within_at (fun (x : α) => f x / y) s a :=
  filter.tendsto.div_const hf

theorem continuous_on.div_const {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_mul G₀] {f : α → G₀} {s : set α} [topological_space α]
    (hf : continuous_on f s) {y : G₀} : continuous_on (fun (x : α) => f x / y) s :=
  sorry

theorem continuous.div_const {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_mul G₀] {f : α → G₀} [topological_space α]
    (hf : continuous f) {y : G₀} : continuous fun (x : α) => f x / y :=
  sorry

/-- A type with `0` and `has_inv` such that `λ x, x⁻¹` is continuous at all nonzero points. Any
normed (semi)field has this property. -/
class has_continuous_inv' (G₀ : Type u_3) [HasZero G₀] [has_inv G₀] [topological_space G₀] where
  continuous_at_inv' : ∀ {x : G₀}, x ≠ 0 → continuous_at has_inv.inv x

/-!
### Continuity of `λ x, x⁻¹` at a non-zero point

We define `topological_group_with_zero` to be a `group_with_zero` such that the operation `x ↦ x⁻¹`
is continuous at all nonzero points. In this section we prove dot-style `*.inv'` lemmas for
`filter.tendsto`, `continuous_at`, `continuous_within_at`, `continuous_on`, and `continuous`.
-/

theorem tendsto_inv' {G₀ : Type u_2} [HasZero G₀] [has_inv G₀] [topological_space G₀]
    [has_continuous_inv' G₀] {x : G₀} (hx : x ≠ 0) :
    filter.tendsto has_inv.inv (nhds x) (nhds (x⁻¹)) :=
  continuous_at_inv' hx

theorem continuous_on_inv' {G₀ : Type u_2} [HasZero G₀] [has_inv G₀] [topological_space G₀]
    [has_continuous_inv' G₀] : continuous_on has_inv.inv (singleton 0ᶜ) :=
  fun (x : G₀) (hx : x ∈ (singleton 0ᶜ)) =>
    continuous_at.continuous_within_at (continuous_at_inv' hx)

/-- If a function converges to a nonzero value, its inverse converges to the inverse of this value.
We use the name `tendsto.inv'` as `tendsto.inv` is already used in multiplicative topological
groups. -/
theorem filter.tendsto.inv' {α : Type u_1} {G₀ : Type u_2} [HasZero G₀] [has_inv G₀]
    [topological_space G₀] [has_continuous_inv' G₀] {l : filter α} {f : α → G₀} {a : G₀}
    (hf : filter.tendsto f l (nhds a)) (ha : a ≠ 0) :
    filter.tendsto (fun (x : α) => f x⁻¹) l (nhds (a⁻¹)) :=
  filter.tendsto.comp (tendsto_inv' ha) hf

theorem continuous_within_at.inv' {α : Type u_1} {G₀ : Type u_2} [HasZero G₀] [has_inv G₀]
    [topological_space G₀] [has_continuous_inv' G₀] {f : α → G₀} {s : set α} {a : α}
    [topological_space α] (hf : continuous_within_at f s a) (ha : f a ≠ 0) :
    continuous_within_at (fun (x : α) => f x⁻¹) s a :=
  filter.tendsto.inv' hf ha

theorem continuous_at.inv' {α : Type u_1} {G₀ : Type u_2} [HasZero G₀] [has_inv G₀]
    [topological_space G₀] [has_continuous_inv' G₀] {f : α → G₀} {a : α} [topological_space α]
    (hf : continuous_at f a) (ha : f a ≠ 0) : continuous_at (fun (x : α) => f x⁻¹) a :=
  filter.tendsto.inv' hf ha

theorem continuous.inv' {α : Type u_1} {G₀ : Type u_2} [HasZero G₀] [has_inv G₀]
    [topological_space G₀] [has_continuous_inv' G₀] {f : α → G₀} [topological_space α]
    (hf : continuous f) (h0 : ∀ (x : α), f x ≠ 0) : continuous fun (x : α) => f x⁻¹ :=
  iff.mpr continuous_iff_continuous_at
    fun (x : α) => filter.tendsto.inv' (continuous.tendsto hf x) (h0 x)

theorem continuous_on.inv' {α : Type u_1} {G₀ : Type u_2} [HasZero G₀] [has_inv G₀]
    [topological_space G₀] [has_continuous_inv' G₀] {f : α → G₀} {s : set α} [topological_space α]
    (hf : continuous_on f s) (h0 : ∀ (x : α), x ∈ s → f x ≠ 0) :
    continuous_on (fun (x : α) => f x⁻¹) s :=
  fun (x : α) (hx : x ∈ s) => continuous_within_at.inv' (hf x hx) (h0 x hx)

/-!
### Continuity of division

If `G₀` is a `group_with_zero` with `x ↦ x⁻¹` continuous at all nonzero points and `(*)`, then
division `(/)` is continuous at any point where the denominator is continuous.
-/

theorem filter.tendsto.div {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_inv' G₀] [has_continuous_mul G₀] {f : α → G₀}
    {g : α → G₀} {l : filter α} {a : G₀} {b : G₀} (hf : filter.tendsto f l (nhds a))
    (hg : filter.tendsto g l (nhds b)) (hy : b ≠ 0) : filter.tendsto (f / g) l (nhds (a / b)) :=
  sorry

theorem continuous_within_at.div {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀]
    [topological_space G₀] [has_continuous_inv' G₀] [has_continuous_mul G₀] {f : α → G₀}
    {g : α → G₀} [topological_space α] {s : set α} {a : α} (hf : continuous_within_at f s a)
    (hg : continuous_within_at g s a) (h₀ : g a ≠ 0) : continuous_within_at (f / g) s a :=
  filter.tendsto.div hf hg h₀

theorem continuous_on.div {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀] [topological_space G₀]
    [has_continuous_inv' G₀] [has_continuous_mul G₀] {f : α → G₀} {g : α → G₀} [topological_space α]
    {s : set α} (hf : continuous_on f s) (hg : continuous_on g s)
    (h₀ : ∀ (x : α), x ∈ s → g x ≠ 0) : continuous_on (f / g) s :=
  fun (x : α) (hx : x ∈ s) => continuous_within_at.div (hf x hx) (hg x hx) (h₀ x hx)

/-- Continuity at a point of the result of dividing two functions continuous at that point, where
the denominator is nonzero. -/
theorem continuous_at.div {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀] [topological_space G₀]
    [has_continuous_inv' G₀] [has_continuous_mul G₀] {f : α → G₀} {g : α → G₀} [topological_space α]
    {a : α} (hf : continuous_at f a) (hg : continuous_at g a) (h₀ : g a ≠ 0) :
    continuous_at (f / g) a :=
  filter.tendsto.div hf hg h₀

theorem continuous.div {α : Type u_1} {G₀ : Type u_2} [group_with_zero G₀] [topological_space G₀]
    [has_continuous_inv' G₀] [has_continuous_mul G₀] {f : α → G₀} {g : α → G₀} [topological_space α]
    (hf : continuous f) (hg : continuous g) (h₀ : ∀ (x : α), g x ≠ 0) : continuous (f / g) :=
  eq.mpr
    (id
      ((fun (f f_1 : α → G₀) (e_3 : f = f_1) => congr_arg continuous e_3) (f / g) (f * (g⁻¹))
        (div_eq_mul_inv f g)))
    (eq.mp (Eq.refl (continuous fun (x : α) => f x * (g x⁻¹)))
      (continuous.mul hf (continuous.inv' hg h₀)))

theorem continuous_on_div {G₀ : Type u_2} [group_with_zero G₀] [topological_space G₀]
    [has_continuous_inv' G₀] [has_continuous_mul G₀] :
    continuous_on (fun (p : G₀ × G₀) => prod.fst p / prod.snd p)
        (set_of fun (p : G₀ × G₀) => prod.snd p ≠ 0) :=
  continuous_on.div continuous_on_fst continuous_on_snd fun (_x : G₀ × G₀) => id

end Mathlib


import for_mathlib.group -- some stupid lemma about units

import Spa.space
import Huber_ring.localization

/-!
# Rational open subsets and their properties

We define a preorder on `rational_open_data` that will be used when
constructing the valuations on the stalks of the structure presheaf.
-/

open_locale classical
local attribute [instance] set.pointwise_mul_comm_semiring
local attribute [instance] set.smul_set_action

local postfix `⁺` : 66 := λ A : Huber_pair, A.plus

namespace spa
open set algebra
variables {A : Huber_pair}

namespace rational_open_data
variables (r : rational_open_data A)

/-- The preorder on rational open data.

Due to limitations in the existing mathematical library,
we cannot work with the “correct” preorder on rational open data.
The “correct” preorder on rational open data would be:

def correct_preorder : preorder (rational_open_data A) :=
{ le := λ r1 r2, rational_open r1 ⊆ rational_open r2,
  le_refl := λ _ _, id,
  le_trans := λ _ _ _, subset.trans }

One can prove (in maths) that r1 ≤ r2 iff there's a continuous R-algebra morphism
of Huber pairs localization r2 → localization r1. I think the ← direction of this
iff is straightforward (but I didn't think about it too carefully). However we
definitely cannot prove the → direction of this iff in this repo yet because we
don't have enough API for cont. Here is an indication
of part of the problem. localization r2 is just A[1/r2.s]. But we cannot prove yet r2.s is
invertible in localization.r1, even though we know it doesn't vanish anywhere on
rational_open r2 and hence on rational_open r1, because the fact that it doesn't vanish anywhere
on rational_open r1 only means that it's not in any prime ideal corresponding
to a *continuous* valuation on localization r1 which is bounded by 1 on some + subring;
one would now need to prove, at least, that every maximal ideal
is the support of a continuous valuation, which is Wedhorn 7.52(2). This is not
too bad -- but it is work that we have not yet done. However this is by no means the whole story;
we would also need that r1.T is power-bounded in localization.r2
and this looks much worse: it's Wedhorn 7.52(1). Everything is do-able, but it's just *long*.
Long as in "thousands more lines of code". We will need a good theory of primary and
secondary specialisation of valuations and so on and so on. None of this is there at
the time of writing, although I see no obstruction to putting it there, other than the
fact that it would take weeks of work.

We have to work with a weaker preorder then, because haven't made a good enough
API for continuous valuations. We basically work with the preorder r1 ≤ r2 iff
there's a continuous R-algebra map localization r2 → localization r1, i.e, we
define our way around the problem. We are fortunate in that we can prove
(in maths) that the projective limit over this preorder agrees with the projective
limit over the correct preorder. -/
instance : preorder (rational_open_data A) :=
{ le := λ r1 r2, ∃ k : A, r1.s * k = r2.s ∧
    ∀ t₁ ∈ r1.T, ∃ t₂ ∈ r2.T, ∃ N : ℕ, r2.s ^ N * t₂ = r2.s ^ N * (t₁ * k),
  le_refl := λ r, ⟨1, mul_one _, λ t ht, ⟨t, ht, 0, by rw mul_one⟩⟩,
  le_trans := λ a b c ⟨k, hk, hab⟩ ⟨l, hl, hbc⟩, ⟨k * l, by rw [←mul_assoc, hk, hl], λ ta hta,
  begin
    rcases hab ta hta with ⟨tb, htb, Nab, h1⟩,
    rcases hbc tb htb with ⟨hc, htc, Nbc, h2⟩,
    refine ⟨hc, htc, (Nab + Nbc), _⟩,
    rw [←mul_assoc, pow_add, mul_assoc, h2, ←hl, mul_pow, mul_pow],
    rw (show b.s ^ Nab * l ^ Nab * (b.s ^ Nbc * l ^ Nbc * (tb * l)) =
      b.s ^ Nab * tb * (l ^ Nab * (b.s ^ Nbc * l ^ Nbc *  l)), by ring),
    rw h1,
    ring
  end⟩ }

lemma le_inter_left (r1 r2 : rational_open_data A) :
  r1 ≤ (inter r1 r2) :=
begin
  refine ⟨r2.s, rfl, _⟩,
  intros t1 ht1,
  refine ⟨t1 * r2.s, ⟨t1, mem_insert_of_mem _ ht1, r2.s, mem_insert_s _, rfl⟩, 0, by simp⟩,
end

lemma le_inter_right (r1 r2 : rational_open_data A) :
  r2 ≤ (inter r1 r2) :=
by { rw inter_symm, apply le_inter_left, }

-- The preorder defined above is weaker than the preorder we're supposed to have but don't.
-- However the projective limit we take over our preorder is provably (in maths) equal to
-- the projective limit that we cannot even formalise. The thing we definitely need
-- is that if r1 ≤ r2 then there's a map localization r1 → localization r2

/-- The localization of a Huber pair A at the rational open subset r = D(T,s) ⊆ spa(A). -/
def localization (r : rational_open_data A) := Huber_ring.away r.T r.s

namespace localization

/-- The ring structure on the localization at the rational open subset r = D(T,s) ⊆ spa(A). -/
instance : comm_ring (localization r) :=
by unfold localization; apply_instance

/-- The basis of open subgroups of the localization
 at the rational open subset r = D(T,s) ⊆ spa(A). -/
instance : subgroups_basis (localization r) :=
Huber_ring.away.top_loc_basis r.T r.s r.Hopen

/-- The topology on the localization at the rational open subset r = D(T,s) ⊆ spa(A). -/
instance : topological_space (localization r) :=
subgroups_basis.topology _

/-- The localization at the rational open subset r = D(T,s) ⊆ spa(A) is a topological ring. -/
instance : topological_ring (localization r) :=
ring_filter_basis.is_topological_ring _ rfl

/-- The uniform structure on the localization at the rational open subset r = D(T,s) ⊆ spa(A). -/
instance (r : rational_open_data A) : uniform_space (rational_open_data.localization r) :=
topological_add_group.to_uniform_space _

/-- The localization at the rational open subset r = D(T,s) ⊆ spa(A) is a uniform additive group. -/
instance (rd : rational_open_data A): uniform_add_group (rational_open_data.localization rd) :=
topological_add_group_is_uniform

/-- The localization at the rational open subset r = D(T,s) ⊆ spa(A) is a an algebra over A. -/
instance : algebra A (localization r) := Huber_ring.away.algebra r.T r.s

/-- The coercion from a Huber pair A
to the localization at the rational open subset r = D(T,s) ⊆ spa(A). -/
instance : has_coe A (localization r) := ⟨λ a, (of_id A (localization r) : A → localization r) a⟩

lemma nonarchimedean (r : rational_open_data A) :
  topological_add_group.nonarchimedean (localization r) :=
subgroups_basis.nonarchimedean

set_option class.instance_max_depth 38

/--If A is a Huber pair, and r = D(T,s) a rational open subset of Spa(A),
and coe is the localization map A → A(T/s),
then `power_bounded_data r` is the set { coe(t)/s | t ∈ T } ⊆ A(T/s).-/
def power_bounded_data (r : rational_open_data A) : set (localization r) :=
let s_inv : localization r :=
  ((localization.to_units ⟨r.s, ⟨1, by simp⟩⟩)⁻¹ : units (localization r)) in
(s_inv • (coe : A → localization r) '' r.T)

theorem power_bounded (r : rational_open_data A) :
  is_power_bounded_subset (power_bounded_data r) :=
begin
  suffices : is_bounded (ring.closure (power_bounded_data r)),
  { exact is_bounded.subset add_group.subset_closure this },
  intros U hU,
  rcases subgroups_basis.mem_nhds_zero.mp hU with ⟨_, ⟨V, rfl⟩, hV⟩,
  refine ⟨_, mem_nhds_sets (subgroups_basis.is_op _ rfl (set.mem_range_self _)) _, _⟩,
  { exact V },
  { erw submodule.mem_coe,
    convert submodule.zero_mem _ },
  { intros v hv b hb,
    apply hV,
    rw [mul_comm, ← smul_eq_mul],
    rw submodule.mem_coe at hv ⊢,
    convert submodule.smul_mem _ _ hv,
    swap, { exact ⟨b, hb⟩ }, { refl } }
end

end localization

/-- This auxilliary function produces r1.s as a unit in localization r2 -/
noncomputable def s_inv_aux (r1 r2 : rational_open_data A) (h : r1 ≤ r2) :
  units (localization r2) :=
@units.unit_of_mul_left_eq_unit _ _
  ((of_id A (localization r2) : A → r2.localization) r1.s)
  ((of_id A (localization r2) : A → r2.localization) (classical.some h))
  (localization.to_units (⟨r2.s, 1, by simp⟩ : powers r2.s))
  begin
    rw [← alg_hom.map_mul, (classical.some_spec h).1],
    refl,
  end

/-- The map A(T1/s1) -> A(T2/s2) coming from the inequality r1 ≤ r2 -/
noncomputable def localization_map {r1 r2 : rational_open_data A} (h : r1 ≤ r2) :
  localization r1 → localization r2 :=
Huber_ring.away.lift r1.T r1.s (of_id A (localization r2)) (s_inv_aux r1 r2 h) rfl

/-- The induced map A(T1/s1) -> A(T2/s2) coming from the inequality r1 ≤ r2
is a ring homomorphism. -/
instance {r1 r2 : rational_open_data A} (h : r1 ≤ r2) : is_ring_hom
(localization_map h) := by delta localization_map; apply_instance

/- To prove continuity of the localisation map coming from r1 ≤ r2 we need to check
that the image of T1/s1 under the localization map is power-bounded in the ring (localization r2).
This is done in the following lemma. -/

local attribute [instance] set.pointwise_mul_comm_semiring
local attribute [instance] set.smul_set_action

set_option class.instance_max_depth 38

lemma localization_map_is_cts_aux {r1 r2 : rational_open_data A} (h : r1 ≤ r2) :
is_power_bounded_subset
  ((s_inv_aux r1 r2 h)⁻¹.val • (λ (x : ↥A), to_fun (localization r2) x) '' r1.T) :=
begin
  refine power_bounded.subset _ (localization.power_bounded r2),
  intros x hx,
  rcases hx with ⟨_, ⟨t₁, ht₁, rfl⟩, rfl⟩,
  let h' := h, -- need it later
  rcases h with ⟨a, ha, h₂⟩,
  rcases h₂ t₁ ht₁ with ⟨t₂, ht₂, N, hN⟩,
  show ↑(s_inv_aux r1 r2 _)⁻¹ * to_fun (localization r2) t₁ ∈
    localization.mk 1 ⟨r2.s, _⟩ • (of_id ↥A (localization r2)).to_fun '' r2.T,
  refine ⟨(of_id ↥A (localization r2)).to_fun t₂, ⟨t₂, ht₂, rfl⟩, _⟩,
  rw [←units.mul_left_inj (s_inv_aux r1 r2 h'), units.mul_inv_cancel_left],
  show to_fun (localization r2) t₁ = to_fun (localization r2) (r1.s) *
    (localization.mk 1 ⟨r2.s, _⟩ * to_fun (localization r2) t₂),
  rw [mul_comm, mul_assoc],
  rw ←units.mul_left_inj (localization.to_units (⟨r2.s, 1, by simp⟩ : powers r2.s)),
  rw ←mul_assoc,
  -- t1=s1*(1/s2 * t2) in r2
  have : ↑(localization.to_units (⟨r2.s, 1, by simp⟩ : powers r2.s)) *
    localization.mk (1 : A) (⟨r2.s, 1, by simp⟩ : powers r2.s) = 1,
  convert units.mul_inv _,
  rw [this, one_mul], clear this,
  show to_fun (localization r2) r2.s * _ = _,
  rw ←units.mul_left_inj (localization.to_units (⟨r2.s ^ N, N, rfl⟩ : powers r2.s)),
  show to_fun (localization r2) (r2.s ^ N) * _ = to_fun (localization r2) (r2.s ^ N) * _,
  have hrh : is_ring_hom (to_fun (localization r2)) := begin
    change is_ring_hom ((of_id ↥A (localization r2)).to_fun),
    apply_instance,
  end,
  rw ←@is_ring_hom.map_mul _ _ _ _ (to_fun (localization r2)) hrh,
  rw ←@is_ring_hom.map_mul _ _ _ _ (to_fun (localization r2)) hrh,
  rw ←@is_ring_hom.map_mul _ _ _ _ (to_fun (localization r2)) hrh,
  rw ←@is_ring_hom.map_mul _ _ _ _ (to_fun (localization r2)) hrh,
  congr' 1,
  rw [←mul_assoc _ t₂, hN],
  rw ←ha, ring,
end

-- Continuity now follows from the universal property.
lemma localization_map_is_cts {r1 r2 : rational_open_data A} (h : r1 ≤ r2) :
  continuous (localization_map h) :=
Huber_ring.away.lift_continuous r1.T r1.s (localization.nonarchimedean r2)
  (Huber_ring.away.of_continuous r2.T r2.s _) _ _ _ (localization_map_is_cts_aux h)

lemma localization_map_is_uniform_continuous {r1 r2 : rational_open_data A} (h : r1 ≤ r2) :
  uniform_continuous (rational_open_data.localization_map h) :=
uniform_continuous_of_continuous (rational_open_data.localization_map_is_cts h)

end rational_open_data -- namespace

end spa


import SciLean.Tactic.CustomSimp.Main
-- import SciLean.Tactic.CustomSimp.AllPrePost
-- import SciLean.Tactic.CustomSimp.DebugSimp

import SciLean.Tactic.AutoDiff.LetDiff
import SciLean.Core.Defs
import SciLean.Core.Attributes

-- import SciLean.AutoImpl
-- import SciLean.Core
-- import SciLean.Functions

-- import Lean.Meta
-- import Lean.Parser
-- import Lean.Elab

-- namespace Lean.Elab.Tactic
open Lean Meta Simp

namespace SciLean

#check Lean.MetaM
partial def autoDiffPre (e : Expr) (rep := false) : SimpM Step := do
  let e := e.headBeta
  trace[Meta.Tactic.simp] s!"Autodiff step on:\n{← Meta.ppExpr e}"

  -- Always use `diff` marked theorems and set them all as `pre` instead of post
  let autodiffExt ← Lean.Meta.getSimpExtension? "diff"
  let mut autodiffThms ← autodiffExt.get!.getTheorems
  autodiffThms := { autodiffThms with pre := autodiffThms.post, post := autodiffThms.pre }

  let allThms := #[autodiffThms].append (← read).simpTheorems

  -- let allThms := (← read).simpTheorems

  for thms in allThms do
    if let some r ← Meta.CustomSimp.rewrite? e thms.pre thms.erased DefaultMethods.discharge? (tag := "pre") (rflOnly := false) then
      trace[Meta.Tactic.simp] s!"Simplified to: {← Meta.ppExpr r.expr}"
      return ← andThen (Step.visit r) (λ e => autoDiffPre e)
  return Step.visit {expr := e}

-- Tactic

open Lean.Parser.Tactic in
syntax (name := autodiff_core) "autodiff_core " (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic

open Lean.Elab.Tactic in
@[tactic autodiff_core] def autoDiffCore : Tactic := fun stx => do
  let { ctx, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  let usedSimps ← dischargeWrapper.with fun discharge? =>
    SciLean.Meta.CustomSimp.simpLocation ctx discharge? (expandOptLocation stx[5]) #[letDiff, autoDiffPre] #[]
  if tactic.simp.trace.get (← getOptions) then
    traceSimpCall stx usedSimps

-- Conv

open Lean.Parser.Tactic in
syntax (name := autodiff_core_conv) "autodiff_core" (config)? (discharger)? (&" only")? (" [" (simpStar <|> simpErase <|> simpLemma),* "]")? : conv

open Lean.Elab.Tactic Lean.Elab.Tactic.Conv in
@[tactic autodiff_core_conv] def autoDiffCoreConv : Tactic := fun stx => withMainContext do
  let { ctx, dischargeWrapper, .. } ← mkSimpContext stx (eraseLocal := false)
  let lhs ← getLhs
  let (result, _) ← dischargeWrapper.with fun d? => SciLean.Meta.CustomSimp.simp lhs ctx (discharge? := d?) #[letDiff, autoDiffPre] #[]
  applySimpResult result

macro "autodiff" : conv =>
  `(conv| (autodiff_core (config := {singlePass := true,  zeta := false, iota := false}) only [/- ↓ autodiff (problem is that ↓ is ignored) ,-/diff_simp];
           try simp (config := {zeta := false}) only [];))
macro "autodiff" : tactic =>
  `(tactic| (autodiff_core (config := {singlePass := true,  zeta := false, iota := false}) only [/- ↓ diff (problem is that ↓ is ignored),-/diff_simp];
             try simp (config := {zeta := false}) only [];))

-- Tactic

open Lean.Parser.Tactic in
syntax (name := symdiff_core) "symdiff_core " (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic

open Lean.Elab.Tactic in
@[tactic symdiff_core] def symDiffCore : Tactic := fun stx => do
  let { ctx, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  let usedSimps ← dischargeWrapper.with fun discharge? =>
    SciLean.Meta.CustomSimp.simpLocation ctx discharge? (expandOptLocation stx[5]) #[autoDiffPre] #[]
  if tactic.simp.trace.get (← getOptions) then
    traceSimpCall stx usedSimps

-- Conv

open Lean.Parser.Tactic in
syntax (name := symdiff_core_conv) "symdiff_core" (config)? (discharger)? (&" only")? (" [" (simpStar <|> simpErase <|> simpLemma),* "]")? : conv

open Lean.Elab.Tactic Lean.Elab.Tactic.Conv in
@[tactic symdiff_core_conv] def symDiffCoreConv : Tactic := fun stx => withMainContext do
  let { ctx, dischargeWrapper, .. } ← mkSimpContext stx (eraseLocal := false)
  let lhs ← getLhs
  let (result, _) ← dischargeWrapper.with fun d? => SciLean.Meta.CustomSimp.simp lhs ctx (discharge? := d?) #[autoDiffPre] #[]
  applySimpResult result

macro "symdiff" : conv =>
  `(conv| (symdiff_core (config := {singlePass := true, zeta := false, iota := false}) only [/- ↓ diff (problem is that ↓ is ignored),-/ diff_simp, SciLean.differentialScalar, SciLean.gradient, SciLean.tangentMap, SciLean.reverseDifferential]
           try simp (config := {zeta := true}) only [diff_simp];))
macro "symdiff" : tactic =>
  `(tactic| (symdiff_core (config := {singlePass := true, zeta := false, iota := false}) only [/- ↓ diff (problem is that ↓ is ignored),-/diff_simp, SciLean.differentialScalar, SciLean.gradient, SciLean.tangentMap, SciLean.reverseDifferential];
             try simp (config := {zeta := true}) only [diff_simp];))

-- set_option trace.Meta.Tactic.simp.rewrite true in
-- -- set_option trace.Meta.Tactic.simp.discharge true in
-- -- set_option trace.Meta.Tactic.simp.unify false in
-- #check (∂ λ (x : ℝ) => let y := x*x; y)
--   rewrite_by
--     -- simp (config := {singlePass := true}) only [↓ diff, tangentMap]
--     symdiff

--     trace_state

-- set_option trace.Meta.Tactic.simp true in
-- set_option trace.Meta.Tactic.simp.rewrite true in
-- set_option trace.Meta.Tactic.simp.discharge true in
-- set_option trace.Meta.Tactic.simp.unify false in
-- #check (∂ λ (x : ℝ) => let y := x*x; let z := x + y*x*x; x + y + z)
--   rewrite_by
--     diff_core (config:={zeta:=false}) only []
--     diff
--     trace_state

-- set_option trace.Meta.Tactic.simp true in
-- set_option trace.Meta.Tactic.simp.rewrite false in
-- set_option trace.Meta.Tactic.simp.unify false in
-- #check (∂ λ (x : ℝ) => let y := x; let z := x + y; y + z)
--   rewrite_by
--     diff
--     trace_state

-- This fails to apply `SciLean.diff_of_comp` because it `foo` can't be proven to be smooth
-- set_option trace.Meta.Tactic.simp.rewrite true in
-- set_option trace.Meta.Tactic.simp.discharge true in
-- #check (∂ λ (x : ℝ) => let z := x^2; let foo := λ y => Math.sin (Math.exp y); foo (Math.cos z))
--   rewrite_by
--     diff
--     trace_state

-- @[irreducible] def foo (a b : Nat) := a + b
-- @[simp] theorem foo_simp (a b : Nat) : foo a b = a + b := by unfold foo; rfl

-- example {X Y Z W} [Vec X] [Vec Y] [Vec Z] [Vec W] (g : W → X) (h : W → Y) (f : W → X → Y → Z) [IsSmooth h] [IsSmooth g] [IsSmooth f] [∀ x, IsSmooth (f x)]  [∀ x y, IsSmooth (f x y)]
--   : (λ n : Nat =>
--     (∂ λ x w : W =>
--       let y := g x
--       let z := h x
--       f x y z))
--     =
--     λ n : Nat =>
--     hold
--     λ x dx w =>
--       let y  := g x
--       let dy := ∂ g x dx
--       let z  := h x
--       let dz := ∂ h x dx
--       ∂ f x dx y z + ∂ (f x) y dy z + ∂ (f x y) z dz
-- := by
--   diff_core (config := {zeta := false, singlePass := true})

--   -- diff_core (config := {zeta := false, singlePass := true})
--   -- diff_core (config := {zeta := false, singlePass := true})
--   -- diff_core (config := {zeta := false, singlePass := true})
--   simp[hold]
--   admit

-- @[simp]
-- theorem diff_at_zero {X Y} [Vec X] [Vec Y] (f : X → Y) [IsSmooth f] (x : X) : ∂ f x 0 = 0 := sorry

-- example {X Y} [Vec X] [Vec Y] (a : α) (g : α → X) (f : X → X → Y) [IsSmooth (λ x => f x (g a))]
--   : (λ n : Nat => (∂ λ x =>
--       let y := g a
--       f x y))
--     =
--     λ n : Nat =>
--     hold
--     λ x dx =>
--       let y := g a
--       ∂ (λ x => f x y) x dx
-- := by
--   diff_core (config := {zeta := false})
--   simp[hold]
--   done

-- example {X Y} [Vec X] [Vec Y] (a : α) (g : α → X) (f : X → X → Y) [IsSmooth (f (g a))]
--   : (∂ λ x =>
--       let y := g a
--       f y x)
--     =
--     hold
--     λ x dx =>
--       let y  := g a
--       ∂ (f y) x dx
-- := by
--   diff_core (config := {zeta := false})
--   simp[hold]
--   done


namespace MWE3

structure State where
  declarations: List String
  aspects: List String
  concepts: List String
deriving Repr

-- the set of declarations must equal to the disjoint union of aspects and concepts.
def State.wff: State → Prop :=
  fun s => ∀ a c,
  (s.aspects.contains a → s.declarations.contains a && ! s.concepts.contains a) &&
  (s.concepts.contains c → s.declarations.contains c && ! s.aspects.contains c)

def State' := { s: State // s.wff }
#print State'
def s1 := State.mk ["a","b","c"] ["a"] ["b","c"]
#eval s1
#check s1.wff
#print s1

def s1' : State' := ⟨ s1, s1.wff ⟩
#print s1'

def s2 := State.mk ["a","b","c"] ["a","b"] ["b","c"]
#eval s2

example : s2.wff = True := by
  sorry

end MWE3


import data.stream

import util.meta.tactic
import util.logic
import util.classical
import util.predicate
import util.meta.tactic.propositional

import tactic

import temporal_logic.tactic

universe variables u u₀ u₁ u₂

variables {α : Sort u₀} {β : Type u₁} {γ : Sort u₂}

namespace temporal
open predicate stream

attribute [predicate] stream.drop pred'.mk
attribute [tl_simp, simp] pred'.mk

lemma henceforth_next (p : cpred)
: ◻p ⟹ ◻⊙p :=
begin [temporal]
  rw henceforth_next_intro p,
  mono, simp,
end

lemma next_henceforth (p : cpred)
: ◻p ⟹ ⊙◻p :=
begin [temporal]
  suffices : ◻◻p ⟶ ⊙◻p,
  { simp at this, apply this },
  intro h, apply h,
end

lemma next_eventually_comm (p : cpred)
: ⊙◇p = ◇⊙p :=
by lifted_pred [next,eventually,nat.succ_add]

lemma holds_next (Γ p : cpred) [persistent Γ]
  (h : Γ ⊢ p)
: Γ ⊢ ⊙p :=
begin [temporal]
  apply persistent_to_henceforth h,
end

/- distributivity -/

lemma eventually_and_entails {p q : cpred}
: ◇(p ⋀ q) ⟹ ◇p ⋀ ◇q :=
begin
  apply entails_p_and_of_entails ; mono ; propositional,
end

lemma entails_henceforth_or {p q : cpred}
: ◻p ⋁ ◻q ⟹ ◻(p ⋁ q) :=
begin [temporal]
  intros h, cases h with h h
  ; henceforth at ⊢ h
  ; [ left , right ]
  ; exact h
end

/- end distributivity -/

lemma eventually_of_leads_to {p q : cpred} {Γ}
  (h : Γ ⊢ p ~> q)
: Γ ⊢ ◇p ⟶ ◇q :=
begin [temporal]
  rw ← eventually_eventually q,
  apply eventually_imp_eventually h,
end

lemma inf_often_of_leads_to {p q : cpred} {Γ}
  (h : Γ ⊢ p ~> q)
: Γ ⊢ ◻◇p ⟶ ◻◇q :=
begin [temporal]
  rw ← eventually_eventually q,
    -- β : Type u₁
    -- p q : cpred
    -- h : p ~> q
    -- ⊢ ◻◇p ⟶ ◻◇◇q
  mono*,
    -- β : Type u₁
    -- p q : cpred
    -- h : p ~> q
    -- ⊢ p ⟶ ◇q
  apply h,
end

lemma leads_to_trans {p q r : cpred} {Γ}
  (Hpq : Γ ⊢ p ~> q)
  (Hqr : Γ ⊢ q ~> r)
: Γ ⊢ p ~> r :=
begin [temporal]
  henceforth,
  intros hp,
  have := Hpq hp, revert this,
  rw ← eventually_eventually r,
  clear hp,
  mono,
  apply Hqr,
end

@[tl_simp, simp]
lemma next_or (p q : cpred)
: ⊙(p ⋁ q) = ⊙p ⋁ ⊙q :=
rfl

@[tl_simp, simp]
lemma next_imp (p q : cpred)
: ⊙(p ⟶ q) = ⊙p ⟶ ⊙q :=
rfl

@[tl_simp, simp]
lemma next_proj (f : var α β) (v : tvar α)
: ⊙(f ! v) = f ! ⊙v :=
by lifted_pred [next]

@[tl_simp, simp]
lemma next_v_eq (p q : tvar α)
: ⊙(p ≃ q) = ⊙p ≃ ⊙q :=
by lifted_pred

open nat

@[tl_simp, simp]
lemma const_action (c : Prop) (v : tvar α)
: ⟦ v | λ _ _ : α, c ⟧ = (c : cpred) :=
by { refl }

-- @[predicate]
lemma action_on  (A : act α) (v : tvar γ) (f : γ → α)
: ⟦ v | A on f ⟧ = ⟦ ⟨f⟩ ! v | A ⟧ :=
by { lifted_pred }

lemma action_on'  (A : act α) (v : tvar γ) (f : γ → α)
: ⟦ v | λ s s', (A on f) s s' ⟧ = ⟦ ⟨f⟩ ! v | A ⟧ :=
by { lifted_pred }

@[predicate]
lemma exists_action  (A : γ → act α) (v : tvar α)
: (∃∃ i, ⟦ v | A i ⟧) = ⟦ v | λ s s', (∃ i, A i s s') ⟧ :=
by { lifted_pred }

instance or_persistent {p q : cpred}
  [persistent p]
  [persistent q]
: persistent (p ⋁ q) :=
begin
  constructor,
  apply mutual_entails,
  apply henceforth_str,
  begin [temporal]
    intro h,
    cases h with h h,
    { rw ← is_persistent p at h,
      revert h,
      mono,
      propositional, },
    { henceforth, right, exact h }
  end
end

instance imp_persistent {p q : cpred}
  [postponable p]
  [persistent q]
: persistent (p ⟶ q) :=
by { simp [p_imp_iff_p_not_p_or], apply_instance }

instance stable_persistent {p : cpred}
: persistent (◇ ◻ p) :=
begin
  constructor,
  apply mutual_entails,
  apply henceforth_str,
  begin [temporal]
    apply induct,
    henceforth,
    rw next_eventually_comm,
    mono,
    apply next_henceforth
  end
end

instance and_postponable {p q : cpred}
  [postponable p]
  [postponable q]
: postponable (p ⋀ q) :=
by { constructor, rw ← p_not_eq_p_not_iff_eq,
     simp only [p_not_p_and,is_persistent] with tl_simp, }

instance inf_often_postponable {p : cpred}
: postponable (◻ ◇ p) :=
begin
  constructor,
  rw ← p_not_eq_p_not_iff_eq,
  simp only [is_persistent] with tl_simp,
end

lemma induct_evt (p q : cpred) {Γ}
  (h : Γ ⊢ ◻ (p ⟶ -q ⟶ ⊙(p ⋁ q)))
: Γ ⊢ (p ⟶ ◇q ⋁ ◻p) :=
begin [temporal]
  apply induct_evt' _ _ h,
end

theorem em (p : cpred) : ⊩ ◇◻p ⋁ ◻◇(- p) :=
begin [temporal]
  rw [← not_henceforth,← not_eventually,p_or_p_not_self]
end

lemma inf_often_of_stable (p : cpred) : (◇◻p) ⟹ (◻◇p) :=
begin [temporal]
  explicit τ
  { simp_intros h i [henceforth],
    cases h with j h,
    unfold eventually,
    existsi j,
    specialize h i,
    simp [drop_drop] at ⊢ h,
    apply h },
end

lemma weak_coincidence {p q : cpred} {Γ}
    (Hp : Γ ⊢ ◻p)
    (Hq : Γ ⊢ ◇q)
: Γ ⊢ ◇(p ⋀ q) :=
begin [temporal]
  explicit τ
  { cases Hq with j Hq,
    specialize Hp j,
    simp [eventually],
    existsi (j),
    exact ⟨Hp,Hq⟩, }
end

lemma eventually_and_eventually (p q : cpred)
: ◇p ⋀ ◇q = ◇(p ⋀ ◇q) ⋁ ◇(◇p ⋀ q) :=
begin
  apply mutual_entails,
  begin [temporal]
    rw [← p_not_p_imp,not_eventually,p_not_p_and,not_eventually],
    intros H₀ H₁,
    cases H₀ with ha hb,
    have h := weak_coincidence H₁ ha,
    rw [p_and_comm,p_or_comm,p_and_p_or_p_not_self] at h,
    explicit τ
    { cases h with j h, cases hb with i ha,
      simp [eventually], existsi i,
      split ; [skip,exact ha],
      cases le_total i j with h' h',
      { existsi (j-i),
        simp [drop_drop,add_sub_of_le h'],
        apply h.left, },
      { exfalso, apply h.right (i-j),
        simp [drop_drop,add_sub_of_le h'],
        apply ha, } },
  end,
  { apply p_or_entails_of_entails
    ; apply entails_p_and_of_entails,
    all_goals {
      transitivity,
      apply eventually_and_entails,
      rw eventually_eventually,
      propositional, }, },
end

lemma event_ordering {Γ p q : cpred}
  (hp : Γ ⊢ ◇p)
  (hq : Γ ⊢ ◇q)
: Γ ⊢ ◇(p ⋀ ◇q) ⋁ ◇(◇p ⋀ q) :=
begin [temporal]
  rw [← eventually_and_eventually],
  split; assumption,
end

section
open tactic tactic.interactive (unfold_coes unfold itactic assert_or_rule)
open interactive interactive.types lean lean.parser
open applicative (mmap₂)
local postfix `?`:9001 := optional

private meta def event : lean.parser (name ⊕ pexpr) :=
(sum.inl <$> ident) <|> (sum.inr <$> brackets "(" ")" texpr)

private meta def event_to_event : name ⊕ pexpr → tactic expr
 | (sum.inl n) := resolve_name n >>= to_expr
 | (sum.inr e) := to_expr e

meta def interactive.event_ordering (aggr : parse $ optional $ tk "!") (e₀ e₁ : parse event)
  (ids : parse with_ident_list) : temporal unit :=
do e₀ ← event_to_event e₀, e₁ ← event_to_event e₁,
   h ← to_expr ``(event_ordering %%e₀ %%e₁) >>= note `h none,
   when e₀.is_local_constant $ tactic.clear e₀,
   when e₁.is_local_constant $ tactic.clear e₁,
   if aggr.is_some then do
     n₀ ← mk_fresh_name,
     n₁ ← mk_fresh_name,
     temporal.interactive.cases (none,to_pexpr h) [n₀,n₁],
     temporal.interactive.eventually n₁ none <|> fail "here",
     e₀ ← get_local n₁, temporal.interactive.cases (none,to_pexpr e₀) ids,
     cleanup,
     tactic.swap,
     temporal.interactive.eventually n₀ none <|> fail "there",
     e₀ ← get_local n₀, temporal.interactive.cases (none,to_pexpr e₀) ids,
     tactic.swap
   else temporal.interactive.cases (none,to_pexpr h) ids,
   return ()

end

lemma stable_and_of_stable_of_stable {p q : cpred} {Γ}
    (Hp : Γ ⊢ ◇◻p)
    (Hq : Γ ⊢ ◇◻q)
: Γ ⊢ ◇◻(p ⋀ q) :=
begin [temporal]
  event_ordering Hp Hq with h h
  ; eventually h
  ; cases h with h₀ h₁
  ; [eventually h₁ ⊢,eventually h₀ ⊢]
  ; henceforth at *
  ; tauto
end

lemma henceforth_delay {p q : cpred} {Γ}
    (Hp : Γ ⊢ ◇p)
    (Hq : Γ ⊢ ◻q)
: Γ ⊢ ◇(p ⋀ ◻q) :=
begin [temporal]
  eventually Hp ⊢,
  split ; assumption
end

@[tl_simp, simp]
lemma eventually_inf_often (p : cpred)
: ◇◻◇p = ◻◇p :=
mutual_entails
begin [temporal]
  intros hp,
  have := inf_often_of_stable (◇p) Γ hp, clear hp,
  rw eventually_eventually at this,
end
(eventually_weaken _)

lemma coincidence {p q : cpred} {Γ}
    (Hp : Γ ⊢ ◇◻p)
    (Hq : Γ ⊢ ◻◇q)
: Γ ⊢ ◻◇(p ⋀ q) :=
begin [temporal]
  rw ← eventually_inf_often,
  eventually Hp |- ,
  henceforth at Hq |-,
  eventually Hq |-,
  split ; assumption,
end

lemma coincidence' {p q : cpred} {Γ}
    (Hp : Γ ⊢ ◻p)
    (Hq : Γ ⊢ ◻◇q)
: Γ ⊢ ◻◇(p ⋀ q) :=
begin [temporal]
  apply coincidence _ Hq,
  assumption
end

lemma inf_often_p_or (p q : cpred)
: ◻◇(p ⋁ q) = ◻◇p ⋁ ◻◇q :=
begin
  refine mutual_entails _ _,
  begin [temporal]
    rw p_or_iff_not_imp (◻◇ p),
    intros h₀ h₁,
    rw [not_henceforth,not_eventually] at h₁,
    have := coincidence h₁ h₀, clear h₀ h₁,
    rw p_not_and_self_or at this,
    revert this, mono*,
    apply p_and_elim_right,
  end,
  refine p_or_entails_of_entails _ _
  ; mono* ; propositional,
end

@[monotonic]
lemma next_imp_next {p q : cpred} (h : p ⟹ q)
: ⊙ p ⟹ ⊙ q :=
by { pointwise h with τ, solve_by_elim }

@[monotonic]
lemma next_tl_imp_next {Γ p q : cpred}
  [persistent Γ]
  (h : ctx_impl Γ p q)
: ctx_impl Γ (⊙ p) (⊙ q) :=
by { rw ← is_persistent Γ at *,
     lifted_pred keep [tl_imp],
     replace h := h.apply (succ σ),
     apply h, clear h,
     intro i, rw [succ_add, ← add_succ],
     apply a (succ i), }

lemma eventually_and {Γ p q : cpred}
   (h₀ : Γ ⊢ ◻p)
   (h₁ : Γ ⊢ ◇q)
: Γ ⊢ ◇(p ⋀ q) :=
begin [temporal]
  eventually h₁ ⊢,
  split ; assumption
end

/- Actions -/

local infix ` <$> ` := fun_app_to_var
local infix ` <*> ` := combine_var

open function

lemma exists_of_eventually
  {p : β → Prop}
  {v : tvar β}
  (h : ⊩ ◇(p <$> v))
: ∃ x, p x :=
begin
  cases v with v,
  replace h := ew_str h 0,
  cases h with i h,
  existsi v i, simp [comp] at h,
  apply h,
end

open function

protected theorem leads_to_of_inf_often (Γ p q : cpred)
  (H : Γ ⊢ ◻◇q)
: Γ ⊢ p ~> q :=
begin [temporal]
  henceforth at H ⊢,
  intro, assumption,
end

protected theorem leads_to_strengthen_rhs (q : cpred) {Γ p r : cpred}
  (H : q ⟹ r)
  (P₀ : Γ ⊢ p ~> q)
: Γ ⊢ p ~> r :=
begin [temporal]
  apply leads_to_trans P₀,
  henceforth,
  intros H',
  apply H Γ H',
end

protected lemma leads_to_cancellation {Γ p q b r : cpred}
    (P₀ : Γ ⊢ p ~> q ⋁ b)
    (P₁ : Γ ⊢ q ~> r)
    : Γ ⊢ p ~> r ⋁ b :=
begin [temporal]
  henceforth,
  intros h,
  have := P₀ h, clear h,
  eventually this,
  rw [eventually_or],
  cases this with h h,
  { left, apply P₁ h },
  { right, assumption },
end

protected lemma leads_to_disj_rng {t : Sort u}
  {p : t → cpred} {Γ q} {r : t → Prop}
  (h : Γ ⊢ ∀∀ i, ↑(r i) ⟶ (p i ~> q))
: Γ ⊢ (∃∃ i, ↑(r i) ⋀ p i) ~> q :=
begin [temporal]
  rw [p_exists_range_subtype,tl_leads_to,p_exists_imp_eq_p_forall_imp],
  rw [henceforth_forall],
  intro i, cases i with i hi,
  apply h i hi,
end

protected theorem leads_to_disj {t}
  {p : t → cpred}
  {q Γ : cpred}
  (P₀ : Γ ⊢ ∀∀ i, p i ~> q)
: Γ ⊢ (∃∃ i, p i) ~> q :=
begin [temporal]
  have P₁ : ∀∀ i : t, ↑true ⟶ (◻(p i ⟶ ◇q)),
  { intros i, intro, apply P₀ i, },
  have P₂ := @temporal.leads_to_disj_rng _ _ _ _ (λ _, true) P₁,
  rw_using : (∃∃ (i : t), ↑((λ _, true) i) ⋀ p i) = (∃∃ i, p i) at P₂,
  { apply p_exists_congr,
    intro,
    apply True_p_and },
end

protected theorem leads_to_disj_gen {t}
  {p q : t → cpred}
  {Γ : cpred}
  (P₀ : Γ ⊢ ∀∀ i, p i ~> q i)
: Γ ⊢ (∃∃ i, p i) ~> (∃∃ i, q i) :=
begin [temporal]
  apply temporal.leads_to_disj _,
  intro j,
  apply temporal.leads_to_strengthen_rhs _ _ (P₀ j),
  apply p_exists_intro
end

section induction

variables {α' : Type u}
variables  {Γ : cpred}
variables  (f : tvar β) (p q : cpred)
variables [has_well_founded β]

protected lemma induction
  (P : Γ ⊢ ∀∀ v : β, p ⋀ (f ≃ v)  ~>  p ⋀ (f ≺≺ v) ⋁ q)
: Γ ⊢ p ~> q :=
begin [temporal]
  have h₂ : ∀∀ V : β, p ⋀ (f ≃ V) ~> q,
  { intro V,
    wf_induction V,
    apply temporal.leads_to_strengthen_rhs (q ⋁ q),
    { simp [or_self], },
    apply temporal.leads_to_cancellation (P _),
    rw_using : (p ⋀ (f ≺≺ x)) = (∃∃v, ↑(v << x) ⋀ (p ⋀ (f ≃ v))),
    { ext1 τ, simp only with predicate, rw exists_one_point (f.apply τ), simp [and_comm],
      intro k, simp, intros, subst k },
    apply @temporal.leads_to_disj_rng _ ,
    apply ih_1, },
  have h₃ := temporal.leads_to_disj h₂,
  rw_using : (∃∃ (i : β), p ⋀ (f ≃ i)) = p at h₃,
  { ext1 j, simp [function.comp,exists_one_point_right ], },
end

end induction

section inf_often_induction'

parameters {α' : Type u}  {β' : Type u₀}
parameters {Γ : cpred} (V : tvar β') (p q : cpred)
parameters [has_well_founded β']

lemma inf_often_induction'
  (S₀ : Γ ⊢ ∀∀ v : β', ◻( V ≃ v ⟶ ◻(V ≃ v) ⋁ ◇(V ≺≺ v ⋁ q)))
  (P₁ : Γ ⊢ ∀∀ v : β', (p ⋀ V ≃ v) ~> (V ≺≺ v ⋁ q))
: Γ ⊢ ◻◇p ⟶ ◻◇q :=
begin [temporal]
  intros Hp,
  unfold henceforth,
  have Hex : ∀∀ (v : β'), V ≃ v ~> q,
  { intro v,
    wf_induction v with v,
    have IH' := temporal.leads_to_disj_rng ih_1, clear ih_1,
    rw_using : (∃∃ (i : β'), ↑(i << v) ⋀ V ≃ i)
             = V ≺≺ v at IH',
    { ext τ,
      simp [flip,function.comp,p_exists], },
    have S₁ : ∀∀ v : β', V ≃ v ~> V ≺≺ v ⋁ q,
    { intro, henceforth!, intros Hv,
      replace S₀ := S₀ _ Hv,
      cases S₀ with S₀ S₀,
      { have H := coincidence' S₀ Hp,
        rw p_and_comm at H,
        henceforth at H, eventually H,
        apply P₁ _ H },
      { apply S₀, } },
    have H₃ := temporal.leads_to_cancellation (S₁ v) IH',
    exact cast (by simp) H₃ },
  replace Hex := temporal.leads_to_disj Hex,
  rw_using : (∃∃ (v : β'), (V ≃ v)) = True at Hex,
  { lifted_pred, existsi σ ⊨ V, refl },
  henceforth, apply Hex, simp,
end

end inf_often_induction'

section prophecy

variable {Γ : cpred}
-- variable [temporal.persistent Γ]
-- variables I N : cpred
variables PI J : tvar (α → Prop)
variables PN : tvar (act α)
variables PSync : cpred
variables h_PSync : Γ ⊢ ◻◇PSync
variables Init : cpred
-- variables h_Init : Γ ⊢ Init
variable h_PI : Γ ⊢ ∀∀ p : α, J p ⟶ PI p
variable h_PN : Γ ⊢ ◻(∀∀ p' : α, J p' ⟶ ∃∃ p : α, PN p p' ⋀ J p)
-- variable h_PSync' : Γ ⊢ PSync ⟶ ∃∃ p : α, J p ⋀ ∀∀ p', J p' ⟶ PN p p'
variable h_PSync' : Γ ⊢ ◻(PSync ⟶ ∃∃ p : α, PI p ⋀ J p)

-- variables (i j : ℕ)

-- def w : ℕ → α

include h_PI h_PN h_PSync h_PSync'
open nat
-- set_option profiler true
-- #check predicate.p_exists_imp_p_exists'
lemma prophecyI
: Γ ⊢ ∃∃ w : tvar α, PI w ⋀ ◻PN w (⊙w) ⋀ ◻J w :=
begin [temporal]
  have : ∃∃ x : α, (True : cpred),
  { henceforth at h_PSync,
    eventually h_PSync,
    have : ∃∃ x : α, PI x ⋀ J x := h_PSync' h_PSync,
    apply predicate.p_exists_entails_p_exists _ _ _ _ this,
    intro, simp },
  nonempty α,
  let x₀ : tvar α := ⟨ λ i, ε x, i ⊨ PI x ∧ i ⊨ J x ⟩,
  let f : tvar (α → α) := ⟨ λ i x', ε x, i ⊨ PN x x' ∧ succ i ⊨ J x' ⟩ ,
  have := back_witness x₀ f h_PSync,
  revert this,
  apply p_exists_p_imp_p_exists,
  intros w h,
  suffices : ◻J w,
  { split, split,
    henceforth at this,
    explicit' with this h_PI
    { solve_by_elim },
    admit, exact this },
  { suffices : ◻(J w ⋁ PSync ⋀ w ≃ x₀),
    { revert this, mono!, intro h',
      cases h' with h₀ h₁, exact h₁,
      henceforth at h_PSync',
      explicit' with h₀ h_PSync'
      { cases h₀,
        suffices : PI w ∧ J w, exact this.right,
        subst w, apply_epsilon_spec, } },
    apply henceforth_until,
    have : ◻◇((PSync ⋀ w ≃ x₀)), admit,
    revert this, mono!,
    apply until_backward_induction _ _,
    -- have : _ ⟶ (-PSync ⋀ J w)  𝒰  (PI w ⋀ J w) := until_backward_induction _ _,
    -- suffices : ◻(J w  𝒰  (PSync ⋀ w ≃ x₀)),
}
end

#check @until_backward_induction

end prophecy

attribute [irreducible] next
section
variables Γ : cpred
variables p q : tvar α
variables p' q' : tvar β
variable f : α → β
variables f₀ f₁ : tvar (α → β)

@[lifted_congr]
lemma lifted_coe_to_fun_arg
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ f₀ p ≃ f₀ q :=
by { lifted_pred using h, simp [h] }

@[lifted_congr]
lemma lifted_coe_to_fun_fun
  (h : Γ ⊢ f₀ ≃ f₁)
: Γ ⊢ f₀ p ≃ f₁ p :=
by { lifted_pred using h, simp [h] }

@[lifted_congr]
lemma lifted_congr₁
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ lifted₁ f p ≃ lifted₁ f q :=
by { lifted_pred using h, simp [h] }

@[lifted_congr]
lemma lifted_congr₂ (g : α → β → γ)
  (h : Γ ⊢ p ≃ q)
  (h' : Γ ⊢ p' ≃ q')
: Γ ⊢ lifted₂ g p p' ≃ lifted₂ g q q' :=
by { lifted_pred using h h', simp [h,h'] }

@[lifted_congr]
lemma lifted_proj (v : var α β)
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ v ! p ≃ v ! q :=
by { lifted_pred using h, simp [h] }

variable [persistent Γ]

@[timeless_congr]
lemma lifted_next (p q : tvar α)
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ ⊙p ≃ ⊙q :=
begin
  lifted_pred keep,
  rw ← is_persistent Γ at a,
  have := h.apply (succ x) (a 1),
  simp at this, exact this,
end

@[timeless_congr]
lemma lifted_henceforth (p q : cpred)
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ ◻p ≃ ◻q :=
begin
  apply mutual_p_imp
  ; change ctx_impl _ _ _
  ; mono
  ; apply p_imp_of_equiv,
  apply h, apply v_eq_symm h
end

@[timeless_congr]
lemma lifted_eventually (p q : cpred)
  (h : Γ ⊢ p ≃ q)
: Γ ⊢ ◇p ≃ ◇q :=
begin
  apply mutual_p_imp
  ; change ctx_impl _ _ _
  ; mono
  ; apply p_imp_of_equiv,
  apply h, apply v_eq_symm h
end

end

end temporal