import ..common.ldeq

variables {α β : Type}

class dlo (α : Type) extends decidable_linear_order α :=
(inh : α)
(btw : ∀ {x z : α}, x < z → ∃ (y : α), x < y ∧ y < z)
(blw : ∀ (y : α), ∃ (x : α), x < y)
(abv : ∀ (x : α), ∃ (y : α), x < y)

open dlo

inductive adlo : Type
| lt : nat → nat → adlo
| eq : nat → nat → adlo

notation x `<'` y := adlo.lt x y
notation x `='` y := adlo.eq x y

meta def adlo_to_format : adlo → format
| (x <' y) := "(" ++ to_fmt x ++ "<" ++ to_fmt y ++ ")"
| (x =' y) := "(" ++ to_fmt x ++ "=" ++ to_fmt y ++ ")"

meta instance : has_to_format adlo := ⟨adlo_to_format⟩

def tval [H : dlo β] (n) (bs : list β) := list.nth_dft (@dlo.inh _ H) bs n

def dlo_val [H : dlo β] (bs : list β) : adlo → Prop
| (adlo.lt m n) := tval m bs < tval n bs
| (adlo.eq m n) := tval m bs = tval n bs

def dlo_neg : adlo → fm adlo
| (adlo.lt m n) := (A' (adlo.eq m n)) ∨' (A' (adlo.lt n m))
| (adlo.eq m n) := (A' (adlo.lt m n)) ∨' (A' (adlo.lt n m))

lemma dlo_neg_nqfree : ∀ (d : adlo), nqfree (dlo_neg d)
| (adlo.lt m n) := and.intro trivial trivial
| (adlo.eq m n) := and.intro trivial trivial

lemma dlo_neg_prsv [dlo β] : ∀ (d : adlo) (l : list β),
  interp dlo_val l (dlo_neg d) ↔ interp dlo_val l (¬' A' d)
| (adlo.lt m n) l :=
  begin
    unfold dlo_neg, unfold interp,
    unfold dlo_val,
    apply iff.intro,
    intro H, apply not_lt_of_ge,
    apply le_of_lt_or_eq,
    cases H with H H, apply or.inr,
    apply eq.symm H, apply or.inl, apply H,
    intro H, apply eq_or_lt_of_not_lt,
    apply H
  end
| (adlo.eq m n) l :=
  begin
    unfold dlo_neg, unfold interp, unfold dlo_val,
    apply iff.intro, intro H, cases H with H H,
    apply ne_of_lt H, apply ne_of_gt H,
    intro H, apply lt_or_gt_of_ne H
  end

def dlo_dep0 : adlo → Prop
| (adlo.lt m n) := m = 0 ∨ n = 0
| (adlo.eq m n) := m = 0 ∨ n = 0

def adlo_dec_dep0 : decidable_pred dlo_dep0
| (adlo.lt 0 n) := decidable.is_true (or.inl (eq.refl _))
| (adlo.lt m 0) := decidable.is_true (or.inr (eq.refl _))
| (adlo.lt (m+1) (n+1)) :=
 decidable.is_false
  (begin
    intro H, cases H with H H,
    cases H, cases H
   end)
| (adlo.eq 0 n) := decidable.is_true (or.inl (eq.refl _))
| (adlo.eq m 0) := decidable.is_true (or.inr (eq.refl _))
| (adlo.eq (m+1) (n+1)) :=
 decidable.is_false
  (begin
    intro H, cases H with H H,
    cases H, cases H
   end)

def dlo_decr : adlo → adlo
| (adlo.lt m n) := (adlo.lt (m-1) (n-1))
| (adlo.eq m n) := (adlo.eq (m-1) (n-1))

def pos_of_not_dep0_lt (m n) (H : ¬ dlo_dep0 (m <' n)) : (m > 0 ∧ n > 0) :=
begin
  cases m, apply absurd _ H,
  apply or.inl, refl,
  cases n, apply absurd _ H,
  apply or.inr, refl,
  apply and.intro,
  apply nat.zero_lt_succ,
  apply nat.zero_lt_succ,
end

def pos_of_not_dep0_eq (m n) (H : ¬ dlo_dep0 (m =' n)) : (m > 0 ∧ n > 0) :=
begin
  cases m, apply absurd _ H,
  apply or.inl, refl,
  cases n, apply absurd _ H,
  apply or.inr, refl,
  apply and.intro,
  apply nat.zero_lt_succ,
  apply nat.zero_lt_succ,
end

def dlo_decr_prsv [dlo β] :
  ∀ (a : adlo), ¬dlo_dep0 a → ∀ (b : β) (bs : list β), dlo_val bs (dlo_decr a) ↔ dlo_val (b :: bs) a :=
begin
  intros a Ha b bs,
  cases a with m n m n,
  unfold dlo_decr,
  repeat {unfold dlo_val}, unfold tval,
  repeat {rewrite nth_dft_pred},
  apply (pos_of_not_dep0_lt m n Ha)^.elim_right,
  apply (pos_of_not_dep0_lt m n Ha)^.elim_left,
  unfold dlo_decr,
  repeat {unfold dlo_val}, unfold tval,
  repeat {rewrite nth_dft_pred},
  repeat {rewrite nth_dft_pred},
  apply (pos_of_not_dep0_eq m n Ha)^.elim_right,
  apply (pos_of_not_dep0_eq m n Ha)^.elim_left,
end

instance dlo_atom [dlo β] : atom_type adlo β :=
{ val := dlo_val,
  neg := dlo_neg,
  neg_nqfree := dlo_neg_nqfree,
  neg_prsv := dlo_neg_prsv,
  dep0 := dlo_dep0,
  dec_dep0 := adlo_dec_dep0,
  decr := dlo_decr,
  decr_prsv := dlo_decr_prsv,
  inh := dlo.inh β,
  dec_eq := by tactic.mk_dec_eq_instance,
  normal := λ _, false,
  dec_normal := _,
  neg_prsv_normal := λ _ h, by cases h,
  decr_prsv_normal := λ _ h, by cases h, }

def dlt [dlo β] (m n) (bs : list β) := tval m bs < tval n bs
def deq [dlo β] (m n) (bs : list β) := tval m bs = tval n bs
def dle [dlo β] (m n) (bs : list β) := tval m bs ≤ tval n bs

lemma exp_val_lt [H : dlo β] {m n} {bs} :
@atom_type.val adlo β dlo_atom (adlo.lt m n) bs
  ↔ ((list.nth_dft (@dlo.inh _ H) bs m) < (list.nth_dft (@dlo.inh _ H) bs n)) :=
begin apply iff.refl end

def exp_decr_lt [dlo β] (m n) : @atom_type.decr adlo β dlo_atom (m <' n) = (m-1 <' n-1) := rfl

def dlo_solv0 : adlo → Prop
| (adlo.lt m n) := false
| (adlo.eq m n) := m = 0 ∨ n = 0

def dlo_dec_solv0 : decidable_pred dlo_solv0
| (adlo.lt m n) := is_false (λ H, by cases H)
| (adlo.eq m n) :=
  begin
    cases m with m m, apply is_true, apply or.inl, refl,
    cases n with n n, apply is_true, apply or.inr, refl,
    apply is_false, intro H, cases H with H H,
    cases H, cases H
  end

def dlo_dest_solv0 : ∀ (a : adlo) (H : dlo_solv0 a), nat
| (adlo.lt m n) H := by cases H
| (adlo.eq 0 n) _ := n
| (adlo.eq (m+1) 0) _ := m+1
| (adlo.eq (m+1) (n+1)) H :=
  begin exfalso, cases H with H H; cases H end

lemma exp_dlo_dest_solv0_0n (n : nat) (H : dlo_solv0 (0 ='n)) :
  dlo_dest_solv0 (0 =' n) H = n := by refl

lemma exp_dlo_dest_solv0_m0 (m : nat) (H : dlo_solv0 ((m+1) =' 0)) :
  dlo_dest_solv0 ((m+1) =' 0) H = m+1 := by refl

lemma dlo_solv0_eq [dlo β] : ∀ {e : adlo} (He : dlo_solv0 e) {b} {bs}, dlo_val e (b::bs)
  → list.nth_dft (dlo.inh β) (b::bs) (dlo_dest_solv0 e He) = b
| (adlo.lt m n) He _ _ _ := by cases He
| (adlo.eq 0 n) He b bs HI :=
  begin
    cases n; unfold dlo_dest_solv0, refl,
    unfold dlo_val at HI, apply eq.symm HI
  end
| (adlo.eq m 0) He b bs HI :=
  begin
    cases m with m; unfold dlo_dest_solv0, refl,
    unfold dlo_val at HI, apply HI
  end
| (adlo.eq (m+1) (n+1)) He _ _ _ :=
  begin cases He with He He; cases He end

def dlo_triv : adlo → Prop
| (adlo.lt m n) := false
| (adlo.eq m n) := m = n

def dlo_dec_triv : decidable_pred dlo_triv
| (adlo.lt m n) := begin apply is_false, apply id end
| (adlo.eq m n) :=
  begin
    cases (nat.decidable_eq m n) with HD HD,
    apply is_false, intro HC, apply HD HC,
    apply is_true, apply HD
  end

lemma dlo_true_triv [dlo β] : ∀ a, dlo_triv a → ∀ (bs : list β), dlo_val a bs
| (adlo.lt m n) HT := by cases HT
| (adlo.eq m n) HT :=
  begin
    intro bs, unfold dlo_triv at HT,
    rewrite HT, unfold dlo_val
  end

def dlo_subst0 : adlo → adlo → adlo
| (i =' j) (m <' n) := subst_eqn i j m <' subst_eqn i j n
| (i =' j) (m =' n) := subst_eqn i j m =' subst_eqn i j n
| _        a        := a

lemma dlo_true_subst [dlo β] : ∀ e, dlo_solv0 e
  → ∀ (bs : list β), dlo_val (dlo_subst0 e e) bs
| (adlo.lt m n) HT := by cases HT
| (adlo.eq m n) HT :=
  begin
    intro bs, cases HT with HT HT,
    subst HT, unfold dlo_subst0,
    cases n with n,
    repeat {unfold subst_eqn},
    unfold dlo_val,
    repeat {unfold subst_eqn},
    unfold dlo_val, refl,
    rewrite HT, unfold dlo_subst0,
    cases m with m, unfold dlo_val,
    repeat {unfold subst_eqn},
    unfold dlo_val, refl
  end

lemma dlo_subst_prsv_aux_0n [dlo β] (n x) (bs) (H) : list.nth_dft (inh β) bs (subst_eqn 0 n x)
  = list.nth_dft (inh β) (list.nth_dft (inh β) bs (dlo_dest_solv0 (0 =' n) H - 1) :: bs) x :=
begin
  cases x with x, unfold subst_eqn,
  rewrite exp_dlo_dest_solv0_0n,
  rewrite nth_dft_head, refl
end

lemma dlo_subst_prsv_aux_m0 [dlo β] (m x) (bs) (H) : list.nth_dft (inh β) bs (subst_eqn m 0 x)
  = list.nth_dft (inh β) (list.nth_dft (inh β) bs (dlo_dest_solv0 (m =' 0) H - 1) :: bs) x :=
begin
  cases m with m, apply dlo_subst_prsv_aux_0n,
  cases x with x, unfold subst_eqn,
  rewrite exp_dlo_dest_solv0_m0,
  rewrite nth_dft_head, refl, refl
end

lemma dlo_subst_prsv [dlo β] : ∀ {e : adlo} (He : dlo_solv0 e) {a : adlo} {bs : list β},
  dlo_val (dlo_subst0 e a) bs ↔ dlo_val a ((list.nth_dft (dlo.inh β) bs (dlo_dest_solv0 e He - 1))::bs)
| (adlo.lt m n) H _ := by cases H
| (adlo.eq 0 n) _ (x <' y) :=
  begin
    intro bs, unfold dlo_subst0,
    repeat {unfold dlo_val}, unfold tval,
    repeat {rewrite dlo_subst_prsv_aux_0n}
  end
| (adlo.eq 0 n) _ (x =' y) :=
  begin
    intro bs, unfold dlo_subst0,
    repeat {unfold dlo_val}, unfold tval,
    repeat {rewrite dlo_subst_prsv_aux_0n}
  end
| (adlo.eq m 0) _ (x <' y) :=
  begin
    intro bs, unfold dlo_subst0,
    repeat {unfold dlo_val}, unfold tval,
    repeat {rewrite dlo_subst_prsv_aux_m0}
  end
| (adlo.eq m 0) _ (x =' y) :=
  begin
    intro bs, unfold dlo_subst0,
    repeat {unfold dlo_val}, unfold tval,
    repeat {rewrite dlo_subst_prsv_aux_m0}
  end
| (adlo.eq (m+1) (n+1)) H _ := by cases H with H H ; cases H

lemma dlo_dest_pos : ∀ {a} {Ha : dlo_solv0 a}, ¬ dlo_triv a → dlo_dest_solv0 a Ha > 0 :=
begin
  intros a Ha HT, cases a with m n m n,
  cases Ha, cases m ; cases n,
  exfalso, apply HT, unfold dlo_triv,
  unfold dlo_dest_solv0, apply nat.zero_lt_succ,
  unfold dlo_dest_solv0, apply nat.zero_lt_succ,
  unfold dlo_solv0 at Ha, cases Ha with Ha Ha ;
  cases Ha
end

instance : decidable_eq adlo := by tactic.mk_dec_eq_instance

instance dlo_atomeq [H : dlo β] : atom_eq_type adlo β :=
{ dlo_atom with   solv0 := dlo_solv0,
  dec_solv0 := dlo_dec_solv0,
  dest_solv0 := dlo_dest_solv0,
  solv0_eq := @dlo_solv0_eq β _,
  trivial := dlo_triv,
  dec_triv := dlo_dec_triv,
  true_triv := dlo_true_triv,
  subst0 := dlo_subst0,
  true_subst := dlo_true_subst,
  subst_prsv := @dlo_subst_prsv β _,
  dest_pos := @dlo_dest_pos }

def is_b_atm (a : adlo) :=
  ∃ n, (a = (n+1 <' 0)) ∨ (a = (0 <' n+1))

def is_lb_atm (a : adlo) := ∃ n, (a = (n+1 <' 0))

instance : decidable_pred is_b_atm
| (m+1 <' 0) := decidable.is_true
  begin existsi m, apply or.inl rfl end
| (0 <' n+1) := decidable.is_true
  begin existsi n, apply or.inr rfl end
| (m =' n) :=
  begin
    apply decidable.is_false, intro h,
    cases h with h h ; cases h with h h ; cases h
  end
| (0 <' 0) :=
  begin
    apply decidable.is_false, intro h,
    cases h with h h ; cases h with h h ; cases h
  end
| (m+1 <' n+1) :=
  begin
    apply decidable.is_false, intro h,
    cases h with h h ; cases h with h h ; cases h
  end

lemma dlo_dec_mem : ∀ (a : adlo) (as : list adlo), decidable (a ∈ as) :=
list.decidable_mem

def get_lb : adlo → option nat
| (m+1 <' 0) := some m
| _ := none

def get_ub : adlo → option nat
| (0 <' n+1) := some n
| _ := none

def is_lb (m) (as : list adlo) := (m+1 <' 0) ∈ as

def is_ub (n) (as : list adlo) := (0 <' n+1) ∈ as

def dlo_qe_lbs  (as : list adlo) : list nat :=
list.omap get_lb as

lemma exp_plus_one {n : nat} : n + 1 = nat.succ n := rfl

lemma is_lb_of_mem_lbs {m} {as} :
  m ∈ dlo_qe_lbs as → is_lb m as :=
begin
  unfold dlo_qe_lbs, intro h,
  rewrite exp_mem_omap at h,
  cases h with a h, cases h with h1 h2,
  cases a with x y, cases x with x ; cases y with y,
  cases h2, cases h2, cases h2, apply h1, cases h2,
  cases h2
end

lemma mem_lbs_of_is_lb {m} {as} :
 is_lb m as → m ∈ dlo_qe_lbs as :=
begin
  intro h, unfold dlo_qe_lbs, rewrite exp_mem_omap,
  existsi (m+1 <' 0), apply and.intro, apply h, refl
end

lemma lbs_eq_nil_of_none_is_lb {as} :
  ¬ (∃ m, is_lb m as) → dlo_qe_lbs as = [] :=
begin
  intro h, cases (dest_list $ dlo_qe_lbs as) with he he,
  apply he, exfalso, apply h, cases he with m he,
  cases he with ms hm, existsi m,
  apply is_lb_of_mem_lbs, rewrite hm,
  apply or.inl rfl
end

def dlo_qe_ubs  (as : list adlo) : list nat :=
list.omap get_ub as

lemma is_ub_of_mem_ubs {n} {as} : n ∈ dlo_qe_ubs as → is_ub n as :=
begin
  unfold dlo_qe_ubs, intro h,
  rewrite exp_mem_omap at h,
  cases h with a h, cases h with h1 h2,
  cases a with x y, cases x with x ; cases y with y,
  cases h2, cases h2, apply h1, repeat {cases h2}
end

lemma mem_ubs_of_is_ub {n} {as} :
 is_ub n as → n ∈ dlo_qe_ubs as :=
begin
  intro h, unfold dlo_qe_ubs, rewrite exp_mem_omap,
  existsi (0 <' n+1), apply and.intro, apply h, refl
end

lemma ubs_eq_nil_of_none_is_ub {as} :
  ¬ (∃ n, is_ub n as) → dlo_qe_ubs as = [] :=
begin
  intro h, cases (dest_list $ dlo_qe_ubs as) with he he,
  apply he, exfalso, apply h, cases he with m he,
  cases he with ms hm, existsi m,
  apply is_ub_of_mem_ubs, rewrite hm,
  apply or.inl rfl
end

-- def dlo_qelim [atom adlo β] : fm adlo → fm adlo :=
-- @lift_nnf_qe _ β _ dlo_qe
--
-- lemma dlo_qe_qfree : ∀ (p : fm adlo), nqfree p → qfree (dlo_qe p) := sorry
--
-- lemma dlo_qe_prsv [atom adlo β] : ∀ (p : fm adlo) (xs : list β), I (dlo_qe p) xs = ∃ x, I p (x::xs) := sorry
--
-- theorem dlo_qelim_prsv [atom adlo β] :
  -- ∀ (p : fm adlo) (xs : list β), I (@dlo_qelim β _ p) xs = I p xs :=
-- lnq_prsv dlo_qe dlo_qe_qfree dlo_qe_prsv


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Bhavik Mehta

! This file was ported from Lean 3 source module topology.category.CompHaus.basic
! leanprover-community/mathlib commit bcfa726826abd57587355b4b5b7e78ad6527b7e4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Adjunction.Reflective
import Mathbin.Topology.StoneCech
import Mathbin.CategoryTheory.Monad.Limits
import Mathbin.Topology.UrysohnsLemma
import Mathbin.Topology.Category.Top.Limits

/-!
# The category of Compact Hausdorff Spaces

We construct the category of compact Hausdorff spaces.
The type of compact Hausdorff spaces is denoted `CompHaus`, and it is endowed with a category
instance making it a full subcategory of `Top`.
The fully faithful functor `CompHaus ⥤ Top` is denoted `CompHaus_to_Top`.

**Note:** The file `topology/category/Compactum.lean` provides the equivalence between `Compactum`,
which is defined as the category of algebras for the ultrafilter monad, and `CompHaus`.
`Compactum_to_CompHaus` is the functor from `Compactum` to `CompHaus` which is proven to be an
equivalence of categories in `Compactum_to_CompHaus.is_equivalence`.
See `topology/category/Compactum.lean` for a more detailed discussion where these definitions are
introduced.

-/

universe v u

open CategoryTheory

/-- The type of Compact Hausdorff topological spaces. -/
structure CompHaus where
  toTop : TopCat
  [IsCompact : CompactSpace to_Top]
  [is_hausdorff : T2Space to_Top]
#align CompHaus CompHaus

namespace CompHaus

instance : Inhabited CompHaus :=
  ⟨{ toTop := { α := PEmpty } }⟩

instance : CoeSort CompHaus (Type _) :=
  ⟨fun X => X.toTop⟩

instance {X : CompHaus} : CompactSpace X :=
  X.IsCompact

instance {X : CompHaus} : T2Space X :=
  X.is_hausdorff

instance category : Category CompHaus :=
  InducedCategory.category toTop
#align CompHaus.category CompHaus.category

instance concreteCategory : ConcreteCategory CompHaus :=
  InducedCategory.concreteCategory _
#align CompHaus.concrete_category CompHaus.concreteCategory

@[simp]
theorem coe_toTop {X : CompHaus} : (X.toTop : Type _) = X :=
  rfl
#align CompHaus.coe_to_Top CompHaus.coe_toTop

variable (X : Type _) [TopologicalSpace X] [CompactSpace X] [T2Space X]

/-- A constructor for objects of the category `CompHaus`,
taking a type, and bundling the compact Hausdorff topology
found by typeclass inference. -/
def of : CompHaus where
  toTop := TopCat.of X
  IsCompact := ‹_›
  is_hausdorff := ‹_›
#align CompHaus.of CompHaus.of

@[simp]
theorem coe_of : (CompHaus.of X : Type _) = X :=
  rfl
#align CompHaus.coe_of CompHaus.coe_of

/-- Any continuous function on compact Hausdorff spaces is a closed map. -/
theorem isClosedMap {X Y : CompHaus.{u}} (f : X ⟶ Y) : IsClosedMap f := fun C hC =>
  (hC.IsCompact.image f.Continuous).IsClosed
#align CompHaus.is_closed_map CompHaus.isClosedMap

/-- Any continuous bijection of compact Hausdorff spaces is an isomorphism. -/
theorem isIso_of_bijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : Function.Bijective f) :
    IsIso f := by
  let E := Equiv.ofBijective _ bij
  have hE : Continuous E.symm := by
    rw [continuous_iff_isClosed]
    intro S hS
    rw [← E.image_eq_preimage]
    exact IsClosedMap f S hS
  refine' ⟨⟨⟨E.symm, hE⟩, _, _⟩⟩
  · ext x
    apply E.symm_apply_apply
  · ext x
    apply E.apply_symm_apply
#align CompHaus.is_iso_of_bijective CompHaus.isIso_of_bijective

/-- Any continuous bijection of compact Hausdorff spaces induces an isomorphism. -/
noncomputable def isoOfBijective {X Y : CompHaus.{u}} (f : X ⟶ Y) (bij : Function.Bijective f) :
    X ≅ Y :=
  letI := is_iso_of_bijective _ bij
  as_iso f
#align CompHaus.iso_of_bijective CompHaus.isoOfBijective

end CompHaus

/-- The fully faithful embedding of `CompHaus` in `Top`. -/
@[simps (config := { rhsMd := semireducible })]
def compHausToTop : CompHaus.{u} ⥤ TopCat.{u} :=
  inducedFunctor _ deriving Full, Faithful
#align CompHaus_to_Top compHausToTop

instance CompHaus.forget_reflectsIsomorphisms : ReflectsIsomorphisms (forget CompHaus.{u}) :=
  ⟨by intro A B f hf <;> exact CompHaus.isIso_of_bijective _ ((is_iso_iff_bijective f).mp hf)⟩
#align CompHaus.forget_reflects_isomorphisms CompHaus.forget_reflectsIsomorphisms

/-- (Implementation) The object part of the compactification functor from topological spaces to
compact Hausdorff spaces.
-/
@[simps]
def stoneCechObj (X : TopCat) : CompHaus :=
  CompHaus.of (StoneCech X)
#align StoneCech_obj stoneCechObj

/-- (Implementation) The bijection of homsets to establish the reflective adjunction of compact
Hausdorff spaces in topological spaces.
-/
noncomputable def stoneCechEquivalence (X : TopCat.{u}) (Y : CompHaus.{u}) :
    (stoneCechObj X ⟶ Y) ≃ (X ⟶ compHausToTop.obj Y)
    where
  toFun f :=
    { toFun := f ∘ stoneCechUnit
      continuous_toFun := f.2.comp (@continuous_stoneCechUnit X _) }
  invFun f :=
    { toFun := stoneCechExtend f.2
      continuous_toFun := continuous_stoneCechExtend f.2 }
  left_inv := by
    rintro ⟨f : StoneCech X ⟶ Y, hf : Continuous f⟩
    ext (x : StoneCech X)
    refine' congr_fun _ x
    apply Continuous.ext_on denseRange_stoneCechUnit (continuous_stoneCechExtend _) hf
    rintro _ ⟨y, rfl⟩
    apply congr_fun (stoneCechExtend_extends (hf.comp _)) y
  right_inv := by
    rintro ⟨f : (X : Type _) ⟶ Y, hf : Continuous f⟩
    ext
    exact congr_fun (stoneCechExtend_extends hf) _
#align stone_cech_equivalence stoneCechEquivalence

/-- The Stone-Cech compactification functor from topological spaces to compact Hausdorff spaces,
left adjoint to the inclusion functor.
-/
noncomputable def topToCompHaus : TopCat.{u} ⥤ CompHaus.{u} :=
  Adjunction.leftAdjointOfEquiv stoneCechEquivalence.{u} fun _ _ _ _ _ => rfl
#align Top_to_CompHaus topToCompHaus

theorem topToCompHaus_obj (X : TopCat) : ↥(topToCompHaus.obj X) = StoneCech X :=
  rfl
#align Top_to_CompHaus_obj topToCompHaus_obj

/-- The category of compact Hausdorff spaces is reflective in the category of topological spaces.
-/
noncomputable instance compHausToTop.reflective : Reflective compHausToTop
    where toIsRightAdjoint := ⟨topToCompHaus, Adjunction.adjunctionOfEquivLeft _ _⟩
#align CompHaus_to_Top.reflective compHausToTop.reflective

noncomputable instance compHausToTop.createsLimits : CreatesLimits compHausToTop :=
  monadicCreatesLimits _
#align CompHaus_to_Top.creates_limits compHausToTop.createsLimits

instance CompHaus.hasLimits : Limits.HasLimits CompHaus :=
  has_limits_of_has_limits_creates_limits compHausToTop
#align CompHaus.has_limits CompHaus.hasLimits

instance CompHaus.hasColimits : Limits.HasColimits CompHaus :=
  has_colimits_of_reflective compHausToTop
#align CompHaus.has_colimits CompHaus.hasColimits

namespace CompHaus

/- ./././Mathport/Syntax/Translate/Expr.lean:107:6: warning: expanding binder group (i j) -/
/-- An explicit limit cone for a functor `F : J ⥤ CompHaus`, defined in terms of
`Top.limit_cone`. -/
def limitCone {J : Type v} [SmallCategory J] (F : J ⥤ CompHaus.{max v u}) : Limits.Cone F
    where
  pt :=
    { toTop := (TopCat.limitCone (F ⋙ compHausToTop)).pt
      IsCompact :=
        by
        show CompactSpace ↥{ u : ∀ j, F.obj j | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j }
        rw [← isCompact_iff_compactSpace]
        apply IsClosed.isCompact
        have :
          { u : ∀ j, F.obj j | ∀ {i j : J} (f : i ⟶ j), F.map f (u i) = u j } =
            ⋂ (i : J) (j : J) (f : i ⟶ j), { u | F.map f (u i) = u j } :=
          by
          ext1
          simp only [Set.mem_interᵢ, Set.mem_setOf_eq]
        rw [this]
        apply isClosed_interᵢ
        intro i
        apply isClosed_interᵢ
        intro j
        apply isClosed_interᵢ
        intro f
        apply isClosed_eq
        · exact (ContinuousMap.continuous (F.map f)).comp (continuous_apply i)
        · exact continuous_apply j
      is_hausdorff :=
        show T2Space ↥{ u : ∀ j, F.obj j | ∀ {i j : J} (f : i ⟶ j), (F.map f) (u i) = u j } from
          inferInstance }
  π :=
    { app := fun j => (TopCat.limitCone (F ⋙ compHausToTop)).π.app j
      naturality' := by
        intro _ _ _
        ext ⟨x, hx⟩
        simp only [comp_apply, functor.const_obj_map, id_apply]
        exact (hx f).symm }
#align CompHaus.limit_cone CompHaus.limitCone

/-- The limit cone `CompHaus.limit_cone F` is indeed a limit cone. -/
def limitConeIsLimit {J : Type v} [SmallCategory J] (F : J ⥤ CompHaus.{max v u}) :
    Limits.IsLimit (limitCone F)
    where
  lift S := (TopCat.limitConeIsLimit (F ⋙ compHausToTop)).lift (compHausToTop.mapCone S)
  uniq S m h := (TopCat.limitConeIsLimit _).uniq (compHausToTop.mapCone S) _ h
#align CompHaus.limit_cone_is_limit CompHaus.limitConeIsLimit

theorem epi_iff_surjective {X Y : CompHaus.{u}} (f : X ⟶ Y) : Epi f ↔ Function.Surjective f :=
  by
  constructor
  · contrapose!
    rintro ⟨y, hy⟩ hf
    let C := Set.range f
    have hC : IsClosed C := (isCompact_range f.continuous).IsClosed
    let D := {y}
    have hD : IsClosed D := isClosed_singleton
    have hCD : Disjoint C D := by
      rw [Set.disjoint_singleton_right]
      rintro ⟨y', hy'⟩
      exact hy y' hy'
    haveI : NormalSpace ↥Y.to_Top := normalOfCompactT2
    obtain ⟨φ, hφ0, hφ1, hφ01⟩ := exists_continuous_zero_one_of_closed hC hD hCD
    haveI : CompactSpace (ULift.{u} <| Set.Icc (0 : ℝ) 1) := homeomorph.ulift.symm.compact_space
    haveI : T2Space (ULift.{u} <| Set.Icc (0 : ℝ) 1) := homeomorph.ulift.symm.t2_space
    let Z := of (ULift.{u} <| Set.Icc (0 : ℝ) 1)
    let g : Y ⟶ Z :=
      ⟨fun y' => ⟨⟨φ y', hφ01 y'⟩⟩,
        continuous_ulift_up.comp (φ.continuous.subtype_mk fun y' => hφ01 y')⟩
    let h : Y ⟶ Z := ⟨fun _ => ⟨⟨0, set.left_mem_Icc.mpr zero_le_one⟩⟩, continuous_const⟩
    have H : h = g := by
      rw [← cancel_epi f]
      ext x
      dsimp
      simp only [comp_apply, ContinuousMap.coe_mk, Subtype.coe_mk, hφ0 (Set.mem_range_self x),
        Pi.zero_apply]
    apply_fun fun e => (e y).down  at H
    dsimp at H
    simp only [Subtype.mk_eq_mk, hφ1 (Set.mem_singleton y), Pi.one_apply] at H
    exact zero_ne_one H
  · rw [← CategoryTheory.epi_iff_surjective]
    apply (forget CompHaus).epi_of_epi_map
#align CompHaus.epi_iff_surjective CompHaus.epi_iff_surjective

theorem mono_iff_injective {X Y : CompHaus.{u}} (f : X ⟶ Y) : Mono f ↔ Function.Injective f :=
  by
  constructor
  · intro hf x₁ x₂ h
    let g₁ : of PUnit ⟶ X := ⟨fun _ => x₁, continuous_const⟩
    let g₂ : of PUnit ⟶ X := ⟨fun _ => x₂, continuous_const⟩
    have : g₁ ≫ f = g₂ ≫ f := by
      ext
      exact h
    rw [cancel_mono] at this
    apply_fun fun e => e PUnit.unit  at this
    exact this
  · rw [← CategoryTheory.mono_iff_injective]
    apply (forget CompHaus).mono_of_mono_map
#align CompHaus.mono_iff_injective CompHaus.mono_iff_injective

end CompHaus


/-
Copyright (c) 2019 Lucas Allen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison
-/
import data.bool
import data.mllist
import tactic.solve_by_elim

/-!
# `suggest` and `library_search`

`suggest` and `library_search` are a pair of tactics for applying lemmas from the library to the
current goal.

* `suggest` prints a list of `exact ...` or `refine ...` statements, which may produce new goals
* `library_search` prints a single `exact ...` which closes the goal, or fails
-/

namespace tactic

open native

namespace suggest

open solve_by_elim

/-- Map a name (typically a head symbol) to a "canonical" definitional synonym.
Given a name `n`, we want a name `n'` such that a sufficiently applied
expression with head symbol `n` is always definitionally equal to an expression
with head symbol `n'`.
Thus, we can search through all lemmas with a result type of `n'`
to solve a goal with head symbol `n`.

For example, `>` is mapped to `<` because `a > b` is definitionally equal to `b < a`,
and `not` is mapped to `false` because `¬ a` is definitionally equal to `p → false`
The default is that the original argument is returned, so `<` is just mapped to `<`.

`normalize_synonym` is called for every lemma in the library, so it needs to be fast.
-/
-- TODO this is a hack; if you suspect more cases here would help, please report them
meta def normalize_synonym : name → name
| `gt := `has_lt.lt
| `ge := `has_le.le
| `monotone := `has_le.le
| `not := `false
| n   := n

/--
Compute the head symbol of an expression, then normalise synonyms.

This is only used when analysing the goal, so it is okay to do more expensive analysis here.
-/
-- We may want to tweak this further?
meta def allowed_head_symbols : expr → list name
-- We first have a various "customisations":
--   Because in `ℕ` `a.succ ≤ b` is definitionally `a < b`,
--   we add some special cases to allow looking for `<` lemmas even when the goal has a `≤`.
--   Note we only do this in the `ℕ` case, for performance.
| `(@has_le.le ℕ _ (nat.succ _) _) := [`has_le.le, `has_lt.lt]
| `(@ge ℕ _ _ (nat.succ _)) := [`has_le.le, `has_lt.lt]
| `(@has_le.le ℕ _ 1 _) := [`has_le.le, `has_lt.lt]
| `(@ge ℕ _ _ 1) := [`has_le.le, `has_lt.lt]

-- And then the generic cases:
| (expr.pi _ _ _ t) := allowed_head_symbols t
| (expr.app f _) := allowed_head_symbols f
| (expr.const n _) := [normalize_synonym n]
| _ := [`_]
.

/--
A declaration can match the head symbol of the current goal in four possible ways:
* `ex`  : an exact match
* `mp`  : the declaration returns an `iff`, and the right hand side matches the goal
* `mpr` : the declaration returns an `iff`, and the left hand side matches the goal
* `both`: the declaration returns an `iff`, and the both sides match the goal
-/
@[derive decidable_eq, derive inhabited]
inductive head_symbol_match
| ex | mp | mpr | both

open head_symbol_match

/-- a textual representation of a `head_symbol_match`, for trace debugging. -/
def head_symbol_match.to_string : head_symbol_match → string
| ex   := "exact"
| mp   := "iff.mp"
| mpr  := "iff.mpr"
| both := "iff.mp and iff.mpr"

/-- Determine if, and in which way, a given expression matches the specified head symbol. -/
meta def match_head_symbol (hs : name_set) : expr → option head_symbol_match
| (expr.pi _ _ _ t) := match_head_symbol t
| `(%%a ↔ %%b)      := if hs.contains `iff then some ex else
                       match (match_head_symbol a, match_head_symbol b) with
                       | (some ex, some ex) :=
                           some both
                       | (some ex, _) := some mpr
                       | (_, some ex) := some mp
                       | _ := none
                       end
| (expr.app f _)    := match_head_symbol f
| (expr.const n _)  := if hs.contains (normalize_synonym n) then some ex else none
| _ := if hs.contains `_ then some ex else none

/-- A package of `declaration` metadata, including the way in which its type matches the head symbol
which we are searching for. -/
meta structure decl_data :=
(d : declaration)
(n : name)
(m : head_symbol_match)
(l : ℕ) -- cached length of name

/--
Generate a `decl_data` from the given declaration if
it matches the head symbol `hs` for the current goal.
-/
-- We used to check here for private declarations, or declarations with certain suffixes.
-- It turns out `apply` is so fast, it's better to just try them all.
meta def process_declaration (hs : name_set) (d : declaration) : option decl_data :=
let n := d.to_name in
if !d.is_trusted || n.is_internal then
  none
else
  (λ m, ⟨d, n, m, n.length⟩) <$> match_head_symbol hs d.type

/-- Retrieve all library definitions with a given head symbol. -/
meta def library_defs (hs : name_set) : tactic (list decl_data) :=
do trace_if_enabled `suggest format!"Looking for lemmas with head symbols {hs}.",
   env ← get_env,
   let defs := env.decl_filter_map (process_declaration hs),
   -- Sort by length; people like short proofs
   let defs := defs.qsort(λ d₁ d₂, d₁.l ≤ d₂.l),
   trace_if_enabled `suggest format!"Found {defs.length} relevant lemmas:",
   trace_if_enabled `suggest $ defs.map (λ ⟨d, n, m, l⟩, (n, m.to_string)),
   return defs

/--
We unpack any element of a list of `decl_data` corresponding to an `↔` statement that could apply
in both directions into two separate elements.

This ensures that both directions can be independently returned by `suggest`,
and avoids a problem where the application of one direction prevents
the application of the other direction. (See `exp_le_exp` in the tests.)
-/
meta def unpack_iff_both : list decl_data → list decl_data
| []                     := []
| (⟨d, n, both, l⟩ :: L) := ⟨d, n, mp, l⟩ :: ⟨d, n, mpr, l⟩ :: unpack_iff_both L
| (⟨d, n, m, l⟩ :: L)    := ⟨d, n, m, l⟩ :: unpack_iff_both L

/-- An extension to the option structure for `solve_by_elim`.
* `compulsory_hyps` specifies a list of local hypotheses which must appear in any solution.
  These are useful for constraining the results from `library_search` and `suggest`.
* `try_this` is a flag (default: `tt`) that controls whether a "Try this:"-line should be traced.
-/
meta structure suggest_opt extends opt :=
(compulsory_hyps : list expr := [])
(try_this : bool := tt)

/--
Convert a `suggest_opt` structure to a `opt` structure suitable for `solve_by_elim`,
by setting the `accept` parameter to require that all complete solutions
use everything in `compulsory_hyps`.
-/
meta def suggest_opt.mk_accept (o : suggest_opt) : opt :=
{ accept := λ gs, o.accept gs >>
    (guard $ o.compulsory_hyps.all (λ h, gs.any (λ g, g.contains_expr_or_mvar h))),
  ..o }

/--
Apply the lemma `e`, then attempt to close all goals using
`solve_by_elim opt`, failing if `close_goals = tt`
and there are any goals remaining.

Returns the number of subgoals which were closed using `solve_by_elim`.
-/
-- Implementation note: as this is used by both `library_search` and `suggest`,
-- we first run `solve_by_elim` separately on the independent goals,
-- whether or not `close_goals` is set,
-- and then run `solve_by_elim { all_goals := tt }`,
-- requiring that it succeeds if `close_goals = tt`.
meta def apply_and_solve (close_goals : bool) (opt : suggest_opt := { }) (e : expr) : tactic ℕ :=
do
  trace_if_enabled `suggest format!"Trying to apply lemma: {e}",
  apply e opt.to_apply_cfg,
  trace_if_enabled `suggest format!"Applied lemma: {e}",
  ng ← num_goals,
  -- Phase 1
  -- Run `solve_by_elim` on each "safe" goal separately, not worrying about failures.
  -- (We only attempt the "safe" goals in this way in Phase 1.
  -- In Phase 2 we will do backtracking search across all goals,
  -- allowing us to guess solutions that involve data or unify metavariables,
  -- but only as long as we can finish all goals.)
  -- If `compulsory_hyps` is non-empty, we skip this phase and defer to phase 2.
  try (guard (opt.compulsory_hyps = []) >>
    any_goals (independent_goal >> solve_by_elim opt.to_opt)),
  -- Phase 2
  (done >> return ng) <|> (do
    -- If there were any goals that we did not attempt solving in the first phase
    -- (because they weren't propositional, or contained a metavariable)
    -- as a second phase we attempt to solve all remaining goals at once
    -- (with backtracking across goals).
    ((guard (opt.compulsory_hyps ≠ []) <|> any_goals (success_if_fail independent_goal) >> skip) >>
      solve_by_elim { backtrack_all_goals := tt, ..opt.mk_accept }) <|>
    -- and fail unless `close_goals = ff`
    guard ¬ close_goals,
    ng' ← num_goals,
    return (ng - ng'))

/--
Apply the declaration `d` (or the forward and backward implications separately, if it is an `iff`),
and then attempt to solve the subgoal using `apply_and_solve`.

Returns the number of subgoals successfully closed.
-/
meta def apply_declaration (close_goals : bool) (opt : suggest_opt := { }) (d : decl_data) :
  tactic ℕ :=
let tac := apply_and_solve close_goals opt in
do (e, t) ← decl_mk_const d.d,
   match d.m with
   | ex   := tac e
   | mp   := do l ← iff_mp_core e t, tac l
   | mpr  := do l ← iff_mpr_core e t, tac l
   | both := undefined -- we use `unpack_iff_both` to ensure this isn't reachable
   end

/-- An `application` records the result of a successful application of a library lemma. -/
meta structure application :=
(state     : tactic_state)
(script    : string)
(decl      : option declaration)
(num_goals : ℕ)
(hyps_used : list expr)

end suggest

open solve_by_elim
open suggest

declare_trace suggest         -- Trace a list of all relevant lemmas

-- Call `apply_declaration`, then prepare the tactic script and
-- count the number of local hypotheses used.
private meta def apply_declaration_script
  (g : expr) (hyps : list expr)
  (opt : suggest_opt := { })
  (d : decl_data) :
  tactic application :=
-- (This tactic block is only executed when we evaluate the mllist,
-- so we need to do the `focus1` here.)
retrieve $ focus1 $ do
  apply_declaration ff opt d,
  -- This `instantiate_mvars` is necessary so that we count used hypotheses correctly.
  g ← instantiate_mvars g,
  guard $ (opt.compulsory_hyps.all (λ h, h.occurs g)),
  ng ← num_goals,
  s ← read,
  m ← tactic_statement g,
  return
  { application .
    state := s,
    decl := d.d,
    script := m,
    num_goals := ng,
    hyps_used := hyps.filter (λ h, h.occurs g) }

-- implementation note: we produce a `tactic (mllist tactic application)` first,
-- because it's easier to work in the tactic monad, but in a moment we squash this
-- down to an `mllist tactic application`.
private meta def suggest_core' (opt : suggest_opt := { }) :
  tactic (mllist tactic application) :=
do g :: _ ← get_goals,
   hyps ← local_context,

   -- Check if `solve_by_elim` can solve the goal immediately:
   (retrieve (do
     focus1 $ solve_by_elim opt.mk_accept,
     s ← read,
     m ← tactic_statement g,
     -- This `instantiate_mvars` is necessary so that we count used hypotheses correctly.
     g ← instantiate_mvars g,
     guard (opt.compulsory_hyps.all (λ h, h.occurs g)),
     return $ mllist.of_list [⟨s, m, none, 0, hyps.filter (λ h, h.occurs g)⟩])) <|>
   -- Otherwise, let's actually try applying library lemmas.
   (do
   -- Collect all definitions with the correct head symbol
   t ← infer_type g,
   defs ← unpack_iff_both <$> library_defs (name_set.of_list $ allowed_head_symbols t),

   let defs : mllist tactic _ := mllist.of_list defs,

   -- Try applying each lemma against the goal,
   -- recording the tactic script as a string,
   -- the number of remaining goals,
   -- and number of local hypotheses used.
   let results := defs.mfilter_map (apply_declaration_script g hyps opt),
   -- Now call `symmetry` and try again.
   -- (Because we are using `mllist`, this is essentially free if we've already found a lemma.)
   symm_state ← retrieve $ try_core $ symmetry >> read,
   let results_symm := match symm_state with
   | (some s) :=
     defs.mfilter_map (λ d, retrieve $ set_state s >> apply_declaration_script g hyps opt d)
   | none := mllist.nil
   end,
  return (results.append results_symm))

/--
The core `suggest` tactic.
It attempts to apply a declaration from the library,
then solve new goals using `solve_by_elim`.

It returns a list of `application`s consisting of fields:
* `state`, a tactic state resulting from the successful application of a declaration from
  the library,
* `script`, a string of the form `Try this: refine ...` or `Try this: exact ...` which will
  reproduce that tactic state,
* `decl`, an `option declaration` indicating the declaration that was applied
  (or none, if `solve_by_elim` succeeded),
* `num_goals`, the number of remaining goals, and
* `hyps_used`, the number of local hypotheses used in the solution.
-/
meta def suggest_core (opt : suggest_opt := { }) : mllist tactic application :=
(mllist.monad_lift (suggest_core' opt)).join

/--
See `suggest_core`.

Returns a list of at most `limit` `application`s,
sorted by number of goals, and then (reverse) number of hypotheses used.
-/
meta def suggest (limit : option ℕ := none) (opt : suggest_opt := { }) :
  tactic (list application) :=
do let results := suggest_core opt,
   -- Get the first n elements of the successful lemmas
   L ← if h : limit.is_some then results.take (option.get h) else results.force,
   -- Sort by number of remaining goals, then by number of hypotheses used.
   return $ L.qsort (λ d₁ d₂, d₁.num_goals < d₂.num_goals ∨
    (d₁.num_goals = d₂.num_goals ∧ d₁.hyps_used.length ≥ d₂.hyps_used.length))

/--
Returns a list of at most `limit` strings, of the form `Try this: exact ...` or
`Try this: refine ...`, which make progress on the current goal using a declaration
from the library.
-/
meta def suggest_scripts
  (limit : option ℕ := none) (opt : suggest_opt := { }) :
  tactic (list string) :=
do L ← suggest limit opt,
   return $ L.map application.script

/--
Returns a string of the form `Try this: exact ...`, which closes the current goal.
-/
meta def library_search (opt : suggest_opt := { }) : tactic string :=
(suggest_core opt).mfirst (λ a, do
  guard (a.num_goals = 0),
  write a.state,
  return a.script)

namespace interactive
setup_tactic_parser

open solve_by_elim

declare_trace silence_suggest -- Turn off `Try this: exact/refine ...` trace messages for `suggest`

/--
`suggest` tries to apply suitable theorems/defs from the library, and generates
a list of `exact ...` or `refine ...` scripts that could be used at this step.
It leaves the tactic state unchanged. It is intended as a complement of the search
function in your editor, the `#find` tactic, and `library_search`.

`suggest` takes an optional natural number `num` as input and returns the first `num`
(or less, if all possibilities are exhausted) possibilities ordered by length of lemma names.
The default for `num` is `50`.
For performance reasons `suggest` uses monadic lazy lists (`mllist`). This means that
`suggest` might miss some results if `num` is not large enough. However, because
`suggest` uses monadic lazy lists, smaller values of `num` run faster than larger values.

You can add additional lemmas to be used along with local hypotheses
after the application of a library lemma,
using the same syntax as for `solve_by_elim`, e.g.
```
example {a b c d: nat} (h₁ : a < c) (h₂ : b < d) : max (c + d) (a + b) = (c + d) :=
begin
  suggest [add_lt_add], -- Says: `Try this: exact max_eq_left_of_lt (add_lt_add h₁ h₂)`
end
```
You can also use `suggest with attr` to include all lemmas with the attribute `attr`.
-/
meta def suggest (n : parse (with_desc "n" small_nat)?)
  (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
  (use : parse $ (tk "using" *> many ident_) <|> return []) (opt : suggest_opt := { }) :
  tactic unit :=
do (lemma_thunks, ctx_thunk) ← mk_assumption_set ff hs attr_names,
   use ← use.mmap get_local,
   L ← tactic.suggest_scripts (n.get_or_else 50)
     { compulsory_hyps := use,
       lemma_thunks := some lemma_thunks,
       ctx_thunk := ctx_thunk, ..opt },
  if !opt.try_this || is_trace_enabled_for `silence_suggest then
    skip
  else
    if L.length = 0 then
      fail "There are no applicable declarations"
    else
      L.mmap trace >> skip

/--
`suggest` lists possible usages of the `refine` tactic and leaves the tactic state unchanged.
It is intended as a complement of the search function in your editor, the `#find` tactic, and
`library_search`.

`suggest` takes an optional natural number `num` as input and returns the first `num` (or less, if
all possibilities are exhausted) possibilities ordered by length of lemma names.
The default for `num` is `50`.

`suggest using h₁ h₂` will only show solutions that make use of the local hypotheses `h₁` and `h₂`.

For performance reasons `suggest` uses monadic lazy lists (`mllist`). This means that `suggest`
might miss some results if `num` is not large enough. However, because `suggest` uses monadic
lazy lists, smaller values of `num` run faster than larger values.

An example of `suggest` in action,

```lean
example (n : nat) : n < n + 1 :=
begin suggest, sorry end
```

prints the list,

```lean
Try this: exact nat.lt.base n
Try this: exact nat.lt_succ_self n
Try this: refine not_le.mp _
Try this: refine gt_iff_lt.mp _
Try this: refine nat.lt.step _
Try this: refine lt_of_not_ge _
...
```
-/
add_tactic_doc
{ name        := "suggest",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.suggest],
  tags        := ["search", "Try this"] }

-- Turn off `Try this: exact ...` trace message for `library_search`
declare_trace silence_library_search

/--
`library_search` is a tactic to identify existing lemmas in the library. It tries to close the
current goal by applying a lemma from the library, then discharging any new goals using
`solve_by_elim`.

If it succeeds, it prints a trace message `exact ...` which can replace the invocation
of `library_search`.

Typical usage is:
```lean
example (n m k : ℕ) : n * (m - k) = n * m - n * k :=
by library_search -- Try this: exact mul_tsub n m k
```

`library_search using h₁ h₂` will only show solutions
that make use of the local hypotheses `h₁` and `h₂`.

By default `library_search` only unfolds `reducible` definitions
when attempting to match lemmas against the goal.
Previously, it would unfold most definitions, sometimes giving surprising answers, or slow answers.
The old behaviour is still available via `library_search!`.

You can add additional lemmas to be used along with local hypotheses
after the application of a library lemma,
using the same syntax as for `solve_by_elim`, e.g.
```
example {a b c d: nat} (h₁ : a < c) (h₂ : b < d) : max (c + d) (a + b) = (c + d) :=
begin
  library_search [add_lt_add], -- Says: `Try this: exact max_eq_left_of_lt (add_lt_add h₁ h₂)`
end
```
You can also use `library_search with attr` to include all lemmas with the attribute `attr`.
-/
meta def library_search (semireducible : parse $ optional (tk "!"))
  (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
  (use : parse $ (tk "using" *> many ident_) <|> return [])
  (opt : suggest_opt := { }) : tactic unit :=
do (lemma_thunks, ctx_thunk) ← mk_assumption_set ff hs attr_names,
   use ← use.mmap get_local,
   (tactic.library_search
     { compulsory_hyps := use,
       backtrack_all_goals := tt,
       lemma_thunks := some lemma_thunks,
       ctx_thunk := ctx_thunk,
       md := if semireducible.is_some then
         tactic.transparency.semireducible else tactic.transparency.reducible,
       ..opt } >>=
   if !opt.try_this || is_trace_enabled_for `silence_library_search then
     (λ _, skip)
   else
     trace) <|>
   fail
"`library_search` failed.
If you aren't sure what to do next, you can also
try `library_search!`, `suggest`, or `hint`.

Possible reasons why `library_search` failed:
* `library_search` will only apply a single lemma from the library,
  and then try to fill in its hypotheses from local hypotheses.
* If you haven't already, try stating the theorem you want in its own lemma.
* Sometimes the library has one version of a lemma
  but not a very similar version obtained by permuting arguments.
  Try replacing `a + b` with `b + a`, or `a - b < c` with `a < b + c`,
  to see if maybe the lemma exists but isn't stated quite the way you would like.
* Make sure that you have all the side conditions for your theorem to be true.
  For example you won't find `a - b + b = a` for natural numbers in the library because it's false!
  Search for `b ≤ a → a - b + b = a` instead.
* If a definition you made is in the goal,
  you won't find any theorems about it in the library.
  Try unfolding the definition using `unfold my_definition`.
* If all else fails, ask on https://leanprover.zulipchat.com/,
  and maybe we can improve the library and/or `library_search` for next time."

add_tactic_doc
{ name        := "library_search",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.library_search],
  tags        := ["search", "Try this"] }

end interactive

/-- Invoking the hole command `library_search` ("Use `library_search` to complete the goal") calls
the tactic `library_search` to produce a proof term with the type of the hole.

Running it on

```lean
example : 0 < 1 :=
{!!}
```

produces

```lean
example : 0 < 1 :=
nat.one_pos
```
-/
@[hole_command] meta def library_search_hole_cmd : hole_command :=
{ name := "library_search",
  descr := "Use `library_search` to complete the goal.",
  action := λ _, do
    script ← library_search,
    -- Is there a better API for dropping the 'Try this: exact ' prefix on this string?
    return [((script.get_rest "Try this: exact ").get_or_else script, "by library_search")] }

add_tactic_doc
{ name        := "library_search",
  category    := doc_category.hole_cmd,
  decl_names  := [`tactic.library_search_hole_cmd],
  tags        := ["search", "Try this"] }

end tactic


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (α * ↑i) - (int.floor (α * ↑i)) = (int.fract (α * ↑i)), from int.fract_eq_of_floor_sub_eq (int.floor_le (α * ↑i)),
    have h2 : (α * ↑j) - (int.floor (α * ↑j)) = (int.fract (α * ↑j)), from int.fract_eq_of_floor_sub_eq (int.floor_le (α * ↑j)),
    have h3 : (α * ↑i) - (int.floor (α * ↑i)) = (α * ↑j) - (int.floor (α * ↑j)), from by rw [h1,h2],
    have h4 : (α * ↑i) - (int.floor (α * ↑i)) = (α * ↑j) - (int.floor (α * ↑j)), from by rw [h1,h2],
    have h5 : α = (int.floor (α * ↑i) - int.floor (α * ↑j)) / (i - j), from by rw [mul_comm α i,mul_comm α j,mul_sub,mul_div_cancel (ne_of_gt (int.cast_pos.2 (int.coe_nat_pos.2 (nat.succ_pos 0)))),mul_comm (i - j) α,h4],
    have h6 : α ∈ ℚ, from by rw [h5],
    have h7 : irrational α, from hα_irrat,
    have h8 : ¬ (α ∈ ℚ), from h7,
    show (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by {apply h8,exact h6},

  have h2 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h3 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h4 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h5 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h6 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h7 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h8 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h9 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h10 : ∀ (i j : ℤ), i ≠ j → (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from
    assume (i j : ℤ) (h : i ≠ j),
    have h1 : (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from by {apply set.mem_cons_of_ne,exact h1 h},
    show (int.fract (α * ↑i)) ∉ (int.fract (α * ↑j)) :: set.univ, from h1,

  have h11 : ∀ (i
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
    assume (i j : ℤ) (h2 : i ≠ j),
    have h3 : α ≠ (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j), from by {
      assume h4 : α = (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j),
      have h5 : (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j) ∈ ℚ, from by {
        rw h4, exact ℚ.coe_nat_rat,
      },
      have h6 : (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j) ∈ ℝ, from by {
        rw h4, exact ℝ.coe_nat_rat,
      },
      have h7 : (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j) ∈ ℝ ∩ ℚ, from by {
        split, exact h6, exact h5,
      },
      have h8 : (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j) ∈ ℝ ∩ ℚ ∩ {x : ℝ | irrational x}, from by {
        split, exact h7, exact hα_irrat,
      },
      have h9 : (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j) ∈ ∅, from by {
        apply set.not_mem_empty, exact h8,
      },
      have h10 : false, from by {
        rw h9,
      },
      exact h10,
    },
    have h11 : int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
      assume h12 : int.fract (α * ↑i) = int.fract (α * ↑j),
      have h13 : α = (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j), from by {
        rw h12, ring,
      },
      exact h3 h13,
    },
    exact h11,

  have h14 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h15 : i ≠ j,
    exact h1 i j h15,
  },
  have h16 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h17 : i ≠ j,
    exact h14 j i (ne.symm h17),
  },
  have h18 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h19 : i ≠ j,
    exact h16 j i (ne.symm h19),
  },
  have h20 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h21 : i ≠ j,
    exact h18 i j h21,
  },
  have h22 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h23 : i ≠ j,
    exact h20 j i (ne.symm h23),
  },
  have h24 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h25 : i ≠ j,
    exact h22 i j h25,
  },
  have h26 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h27 : i ≠ j,
    exact h24 j i (ne.symm h27),
  },
  have h28 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h29 : i ≠ j,
    exact h26 i j h29,
  },
  have h30 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h31 : i ≠ j,
    exact h28 j i (ne.symm h31),
  },
  have h32 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h33 : i ≠ j,
    exact h30 i j h33,
  },
  have h34 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h35 : i ≠ j,
    exact h32 j i (ne.symm h35),
  },
  have h36 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h37 : i ≠ j,
    exact h34 i j h37,
  },
  have h38 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h39 : i ≠ j,
    exact h36 j i (ne.symm h39),
  },
  have h40 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h41 : i ≠ j,
    exact h38 i j h41,
  },
  have h42 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h43 : i ≠ j,
    exact h40 j i (ne.symm h43),
  },
  have h44 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h45 : i ≠ j,
    exact h42 i j h45,
  },
  have h46 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume h47 : i ≠ j,
    exact h44 j i (ne.symm h47),
  },
  have h48 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {
    assume i j,
    assume
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from
    assume (i j : ℤ) (h2 : i ≠ j),
    have h3 : α = (int.fract (α * ↑i) - int.fract (α * ↑j)) / (i - j), from by {
      rw [int.fract_eq_sub_floor, int.fract_eq_sub_floor], ring,
    },
    have h4 : (i - j) ≠ 0, from by {
      assume h5 : (i - j) = 0,
      have h6 : α = 0, from by {rw [h5, sub_eq_zero] at h3, rw [h3, div_zero]},
      have h7 : α ≠ 0, from by {apply hα_irrat.ne,},
      contradiction,
    },
    have h8 : α ∈ ℚ, from by {rw [h3, ← int.coe_nat_eq_coe_int_of_nonneg (int.coe_nat_lt_coe_int_of_lt (int.coe_nat_pos_of_ne_zero h4))], apply_instance},
    have h9 : α ∉ ℚ, from by {apply hα_irrat.ne,},
    contradiction,

  have h10 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) - int.fract (α * ↑j) ≠ 0, from
    assume (i j : ℤ) (h11 : i ≠ j),
    have h12 : int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by {apply h1, exact h11,},
    have h13 : int.fract (α * ↑i) - int.fract (α * ↑j) ≠ 0, from by {apply sub_ne_zero_of_ne, exact h12,},
    show int.fract (α * ↑i) - int.fract (α * ↑j) ≠ 0, from by {apply h13,},

  have h14 : ∀ (i j : ℤ), i ≠ j → int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc 0 1, from
    assume (i j : ℤ) (h15 : i ≠ j),
    have h16 : int.fract (α * ↑i) - int.fract (α * ↑j) ≠ 0, from by {apply h10, exact h15,},
    have h17 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc 0 1, from by {
      have h18 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-1) 1, from by {
        have h19 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-1) 2, from by {
          have h20 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-2) 2, from by {
            have h21 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-2) 3, from by {
              have h22 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-3) 3, from by {
                have h23 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-3) 4, from by {
                  have h24 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-4) 4, from by {
                    have h25 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-4) 5, from by {
                      have h26 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-5) 5, from by {
                        have h27 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-5) 6, from by {
                          have h28 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-6) 6, from by {
                            have h29 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-6) 7, from by {
                              have h30 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-7) 7, from by {
                                have h31 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-7) 8, from by {
                                  have h32 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-8) 8, from by {
                                    have h33 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-8) 9, from by {
                                      have h34 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-9) 9, from by {
                                        have h35 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-9) 10, from by {
                                          have h36 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-10) 10, from by {
                                            have h37 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-10) 11, from by {
                                              have h38 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-11) 11, from by {
                                                have h39 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-11) 12, from by {
                                                  have h40 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-12) 12, from by {
                                                    have h41 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-12) 13, from by {
                                                      have h42 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-13) 13, from by {
                                                        have h43 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-13) 14, from by {
                                                          have h44 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-14) 14, from by {
                                                            have h45 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-14) 15, from by {
                                                              have h46 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-15) 15, from by {
                                                                have h47 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-15) 16, from by {
                                                                  have h48 : int.fract (α * ↑i) - int.fract (α * ↑j) ∈ set.Icc (-16
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by
  {
    intro x0,
    have h6 : |x0 - l| < ε ↔ ((x0 - l) < ε) ∧ ((l - x0) < ε),
    from abs_sub_lt_iff, rw h6,
    split,
    rintro ⟨ S_1, S_2 ⟩,
    split; linarith,
    rintro ⟨ S_3, S_4 ⟩,
    split; linarith,
    },

  assume (h7 : ε > 0),
  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,

  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by {
    assume n h,
    split,
    exact lt_of_le_of_lt (le_max_left N1 N2) h,
    exact lt_of_le_of_lt (le_max_right N1 N2) h,
  },

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by {
    intros n h12,
    split,
    {

      have h13 := (h8 n (h10 n h12).left), rw h5 (y n) at h13,
      split,
      exact h13.left,
      exact (h4 n).left,
    },
    {
      have h14 := (h9 n (h10 n h12).right),rw h5 (z n) at h14,
      split,
      exact (h4 n).right,
      exact h14.right,
    },

  },

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by {
    intros n1 h16, cases (h11 n1 h16);
    split; linarith,
  },

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by {
    intros n h17,
    cases h5 (x n) with h18 h19,
    apply h19, exact h15 n h17,
  },
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


import tactic
import tactic.induction

noncomputable theory
open_locale classical

@[to_additive]
lemma finset_prod_congr_set
  {α : Type*} [comm_monoid α] {β : Type*} [fintype β] (s : set β) (f : β → α) (g : s → α)
  (w : ∀ (x : β) (h : x ∈ s), f x = g ⟨x, h⟩) (w' : ∀ (x : β), x ∉ s → f x = 1) :
  finset.univ.prod f = finset.univ.prod g :=
begin
  by_cases hs : s.nonempty,
  { cases hs with d hd,
    have h : ∀ (fs : finset β), ∃ (fh : β → s),
      (∀ (x : β), x ∈ s → (fh x : s).1 = x) ∧
      fs.prod f = (finset.image fh (fs ∩ s.to_finset)).prod g,
    { rintro fs, apply fs.induction_on; clear fs,
      { fsplit,
        { intro x, apply dite (x ∈ s); intro h,
          { exact ⟨_, h⟩ },
          { exact ⟨_, hd⟩ }},
        { simp, intro x, split_ifs; simp [h] }},
      { rintro x fs h₁ h₂, rcases h₂ with ⟨fh, h₂, h₃⟩, use [fh, h₂],
        rw finset.prod_insert h₁, change _ * fs.prod f = _,
        have hh : ∀ {x y : β}, x ∈ s → y ∈ s → fh x = fh y → x = y,
        { rintro x y hx hy h₄, rw subtype.ext_iff at h₄,
          change (fh x).1 = (fh y).1 at h₄, simp [h₂ _ hx, h₂ _ hy] at h₄,
          exact h₄ },
        by_cases hx : x ∈ s,
        { rw (_ : _ ∩ _ = (insert x (fs ∩ s.to_finset))), swap,
          { apply finset.insert_inter_of_mem, rwa set.mem_to_finset },
          rw [finset.image_insert, finset.prod_insert], swap,
          { intro h₄, rw finset.mem_image at h₄, rcases h₄ with ⟨y, hy, h₄⟩,
            have hy₁ := finset.mem_of_mem_inter_left hy,
            have hy₂ := finset.mem_of_mem_inter_right hy,
            rw set.mem_to_finset at hy₂, replace h₄ := hh hy₂ hx h₄,
            subst h₄, contradiction },
          rw [w _ hx, h₃], congr, ext, simp, exact (h₂ _ hx).symm },
        { rwa [w' _ hx, one_mul, finset.insert_inter_of_not_mem],
          rwa set.mem_to_finset }}},
    obtain ⟨fh, h₁, h₂⟩ := h finset.univ, convert h₂, ext x, simp,
    apply finset.mem_image.mpr, cases x with x hx, simp_rw set.mem_to_finset,
    use [x, hx], ext, simp, exact h₁ _ hx },
  { rw set.not_nonempty_iff_eq_empty at hs, subst s, simp,
    rw finset.prod_eq_one, rintro x hx, apply w', simp },
end


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

import category_theory.sites.sheaf_of_types

/-!
# The canonical topology on a category

We define the finest (largest) Grothendieck topology for which a given presheaf `P` is a sheaf.
This is well defined since if `P` is a sheaf for a topology `J`, then it is a sheaf for any
coarser (smaller) topology. Nonetheless we define the topology explicitly by specifying its sieves:
A sieve `S` on `X` is covering for `finest_topology_single P` iff
  for any `f : Y ⟶ X`, `P` satisfies the sheaf axiom for `S.pullback f`.
Showing that this is a genuine Grothendieck topology (namely that it satisfies the transitivity
axiom) forms the bulk of this file.

This generalises to a set of presheaves, giving the topology `finest_topology Ps` which is the
finest topology for which every presheaf in `Ps` is a sheaf.
Using `Ps` as the set of representable presheaves defines the `canonical_topology`: the finest
topology for which every representable is a sheaf.

A Grothendieck topology is called `subcanonical` if it is smaller than the canonical topology,
equivalently it is subcanonical iff every representable presheaf is a sheaf.

## References
* https://ncatlab.org/nlab/show/canonical+topology
* https://ncatlab.org/nlab/show/subcanonical+coverage
* https://stacks.math.columbia.edu/tag/00Z9
* https://math.stackexchange.com/a/358709/
-/

universes v u
namespace category_theory

open category_theory category limits sieve classical

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

namespace sheaf

variables {P : Cᵒᵖ ⥤ Type v}
variables {X Y : C} {S : sieve X} {R : presieve X}
variables (J J₂ : grothendieck_topology C)

/--
To show `P` is a sheaf for the binding of `U` with `B`, it suffices to show that `P` is a sheaf for
`U`, that `P` is a sheaf for each sieve in `B`, and that it is separated for any pullback of any
sieve in `B`.

This is mostly an auxiliary lemma to show `is_sheaf_for_trans`.
Adapted from [Elephant], Lemma C2.1.7(i) with suggestions as mentioned in
https://math.stackexchange.com/a/358709/
-/
lemma is_sheaf_for_bind (P : Cᵒᵖ ⥤ Type v) (U : sieve X)
  (B : Π ⦃Y⦄ ⦃f : Y ⟶ X⦄, U f → sieve Y)
  (hU : presieve.is_sheaf_for P U)
  (hB : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), presieve.is_sheaf_for P (B hf))
  (hB' : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (h : U f) ⦃Z⦄ (g : Z ⟶ Y),
              presieve.is_separated_for P ((B h).pullback g)) :
  presieve.is_sheaf_for P (sieve.bind U B) :=
begin
  intros s hs,
  let y : Π ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), presieve.family_of_elements P (B hf) :=
    λ Y f hf Z g hg, s _ (presieve.bind_comp _ _ hg),
  have hy : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), (y hf).compatible,
  { intros Y f H Y₁ Y₂ Z g₁ g₂ f₁ f₂ hf₁ hf₂ comm,
    apply hs,
    apply reassoc_of comm },
  let t : presieve.family_of_elements P U := λ Y f hf, (hB hf).amalgamate (y hf) (hy hf),
  have ht : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), (y hf).is_amalgamation (t f hf) :=
    λ Y f hf, (hB hf).is_amalgamation _,
  have hT : t.compatible,
  { rw presieve.compatible_iff_sieve_compatible,
    intros Z W f h hf,
    apply (hB (U.downward_closed hf h)).is_separated_for.ext,
    intros Y l hl,
    apply (hB' hf (l ≫ h)).ext,
    intros M m hm,
    have : bind U B (m ≫ l ≫ h ≫ f),
    { have : bind U B _ := presieve.bind_comp f hf hm,
      simpa using this },
    transitivity s (m ≫ l ≫ h ≫ f) this,
    { have := ht (U.downward_closed hf h) _ ((B _).downward_closed hl m),
      rw [op_comp, functor_to_types.map_comp_apply] at this,
      rw this,
      change s _ _ = s _ _,
      simp },
    { have : s _ _ = _ := (ht hf _ hm).symm,
      simp only [assoc] at this,
      rw this,
      simp } },
  refine ⟨hU.amalgamate t hT, _, _⟩,
  { rintro Z _ ⟨Y, f, g, hg, hf, rfl⟩,
    rw [op_comp, functor_to_types.map_comp_apply, presieve.is_sheaf_for.valid_glue _ _ _ hg],
    apply ht hg _ hf },
  { intros y hy,
    apply hU.is_separated_for.ext,
    intros Y f hf,
    apply (hB hf).is_separated_for.ext,
    intros Z g hg,
    rw [←functor_to_types.map_comp_apply, ←op_comp, hy _ (presieve.bind_comp _ _ hg),
        hU.valid_glue _ _ hf, ht hf _ hg] }
end

/--
Given two sieves `R` and `S`, to show that `P` is a sheaf for `S`, we can show:
* `P` is a sheaf for `R`
* `P` is a sheaf for the pullback of `S` along any arrow in `R`
* `P` is separated for the pullback of `R` along any arrow in `S`.

This is mostly an auxiliary lemma to construct `finest_topology`.
Adapted from [Elephant], Lemma C2.1.7(ii) with suggestions as mentioned in
https://math.stackexchange.com/a/358709
-/
lemma is_sheaf_for_trans (P : Cᵒᵖ ⥤ Type v) (R S : sieve X)
  (hR : presieve.is_sheaf_for P R)
  (hR' : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : S f), presieve.is_separated_for P (R.pullback f))
  (hS : Π ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : R f), presieve.is_sheaf_for P (S.pullback f)) :
  presieve.is_sheaf_for P S :=
begin
  have : (bind R (λ Y f hf, S.pullback f) : presieve X) ≤ S,
  { rintros Z f ⟨W, f, g, hg, (hf : S _), rfl⟩,
    apply hf },
  apply presieve.is_sheaf_for_subsieve_aux P this,
  apply is_sheaf_for_bind _ _ _ hR hS,
  { intros Y f hf Z g,
    dsimp,
    rw ← pullback_comp,
    apply (hS (R.downward_closed hf _)).is_separated_for },
  { intros Y f hf,
    have : (sieve.pullback f (bind R (λ T (k : T ⟶ X) (hf : R k), pullback k S))) = R.pullback f,
    { ext Z g,
      split,
      { rintro ⟨W, k, l, hl, _, comm⟩,
        rw [pullback_apply, ← comm],
        simp [hl] },
      { intro a,
        refine ⟨Z, 𝟙 Z, _, a, _⟩,
        simp [hf] } },
    rw this,
    apply hR' hf },
end

/--
Construct the finest (largest) Grothendieck topology for which the given presheaf is a sheaf.

This is a special case of https://stacks.math.columbia.edu/tag/00Z9, but following a different
proof (see the comments there).
-/
def finest_topology_single (P : Cᵒᵖ ⥤ Type v) : grothendieck_topology C :=
{ sieves := λ X S, ∀ Y (f : Y ⟶ X), presieve.is_sheaf_for P (S.pullback f),
  top_mem' := λ X Y f,
  begin
    rw sieve.pullback_top,
    exact presieve.is_sheaf_for_top_sieve P,
  end,
  pullback_stable' := λ X Y S f hS Z g,
  begin
    rw ← pullback_comp,
    apply hS,
  end,
  transitive' := λ X S hS R hR Z g,
  begin
    -- This is the hard part of the construction, showing that the given set of sieves satisfies
    -- the transitivity axiom.
    refine is_sheaf_for_trans P (pullback g S) _ (hS Z g) _ _,
    { intros Y f hf,
      rw ← pullback_comp,
      apply (hS _ _).is_separated_for },
    { intros Y f hf,
      have := hR hf _ (𝟙 _),
      rw [pullback_id, pullback_comp] at this,
      apply this },
  end }

/--
Construct the finest (largest) Grothendieck topology for which all the given presheaves are sheaves.

This is equal to the construction of <https://stacks.math.columbia.edu/tag/00Z9>.
-/
def finest_topology (Ps : set (Cᵒᵖ ⥤ Type v)) : grothendieck_topology C :=
Inf (finest_topology_single '' Ps)

/-- Check that if `P ∈ Ps`, then `P` is indeed a sheaf for the finest topology on `Ps`. -/
lemma sheaf_for_finest_topology (Ps : set (Cᵒᵖ ⥤ Type v)) (h : P ∈ Ps) :
  presieve.is_sheaf (finest_topology Ps) P :=
λ X S hS, by simpa using hS _ ⟨⟨_, _, ⟨_, h, rfl⟩, rfl⟩, rfl⟩ _ (𝟙 _)

/--
Check that if each `P ∈ Ps` is a sheaf for `J`, then `J` is a subtopology of `finest_topology Ps`.
-/
lemma le_finest_topology (Ps : set (Cᵒᵖ ⥤ Type v)) (J : grothendieck_topology C)
  (hJ : ∀ P ∈ Ps, presieve.is_sheaf J P) : J ≤ finest_topology Ps :=
begin
  rintro X S hS _ ⟨⟨_, _, ⟨P, hP, rfl⟩, rfl⟩, rfl⟩,
  intros Y f, -- this can't be combined with the previous because the `subst` is applied at the end
  exact hJ P hP (S.pullback f) (J.pullback_stable f hS),
end

/--
The `canonical_topology` on a category is the finest (largest) topology for which every
representable presheaf is a sheaf.

See <https://stacks.math.columbia.edu/tag/00ZA>
-/
def canonical_topology (C : Type u) [category.{v} C] : grothendieck_topology C :=
finest_topology (set.range yoneda.obj)

/-- `yoneda.obj X` is a sheaf for the canonical topology. -/
lemma is_sheaf_yoneda_obj (X : C) : presieve.is_sheaf (canonical_topology C) (yoneda.obj X) :=
λ Y S hS, sheaf_for_finest_topology _ (set.mem_range_self _) _ hS

/-- A representable functor is a sheaf for the canonical topology. -/
lemma is_sheaf_of_representable (P : Cᵒᵖ ⥤ Type v) [P.representable] :
  presieve.is_sheaf (canonical_topology C) P :=
presieve.is_sheaf_iso (canonical_topology C) P.repr_w (is_sheaf_yoneda_obj _)

/--
A subcanonical topology is a topology which is smaller than the canonical topology.
Equivalently, a topology is subcanonical iff every representable is a sheaf.
-/
def subcanonical (J : grothendieck_topology C) : Prop :=
J ≤ canonical_topology C

namespace subcanonical

/-- If every functor `yoneda.obj X` is a `J`-sheaf, then `J` is subcanonical. -/
lemma of_yoneda_is_sheaf (J : grothendieck_topology C)
  (h : ∀ X, presieve.is_sheaf J (yoneda.obj X)) :
  subcanonical J :=
le_finest_topology _ _ (by { rintro P ⟨X, rfl⟩, apply h })

/-- If `J` is subcanonical, then any representable is a `J`-sheaf. -/
lemma is_sheaf_of_representable {J : grothendieck_topology C} (hJ : subcanonical J)
  (P : Cᵒᵖ ⥤ Type v) [P.representable] :
  presieve.is_sheaf J P :=
presieve.is_sheaf_of_le _ hJ (is_sheaf_of_representable P)

end subcanonical

end sheaf

end category_theory


import algebra.homology.homotopy_category
import for_mathlib.homological_complex_shift
import for_mathlib.abelian_category

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 ι}

namespace category_theory

namespace quotient

variables {𝒞 : Type*} [category 𝒞] {r : hom_rel 𝒞} [congruence r]
variables {X Y : 𝒞} {f g : X ⟶ Y}

lemma comp_closure.rel (h : comp_closure r f g) : r f g :=
by { cases h, apply congruence.comp_left, apply congruence.comp_right, assumption }

end quotient

end category_theory

namespace homotopy

variables {C D : homological_complex V c} {f f₁ f₂ g g₁ g₂ : C ⟶ D}

@[simps {fully_applied := ff}]
protected def neg (h : homotopy f g) : homotopy (-f) (-g) :=
{ hom := -h.hom,
  zero' := λ i j H, by { dsimp, rw [h.zero i j H, neg_zero] },
  comm := λ i, by simp only [neg_f_apply, add_monoid_hom.map_neg, h.comm, neg_add] }

@[simps {fully_applied := ff}]
def add_left (f : C ⟶ D) (h : homotopy g₁ g₂) : homotopy (f + g₁) (f + g₂) :=
{ comm := λ i, by { simp only [add_f_apply, h.comm], rw [add_comm, add_comm (f.f i), ← add_assoc] },
  .. h }

@[simps {fully_applied := ff}]
def add_right (h : homotopy f₁ f₂) (g : C ⟶ D) : homotopy (f₁ + g) (f₂ + g) :=
{ comm := λ i, by simp only [add_f_apply, h.comm, add_assoc],
  .. h }

@[simps {fully_applied := ff}]
def sub_left (f : C ⟶ D) (h : homotopy g₁ g₂) : homotopy (f - g₁) (f - g₂) :=
{ comm := λ i, by simp only [h.comm, add_f_apply, neg_f_apply, neg_hom, sub_eq_add_neg,
    add_monoid_hom.map_neg, add_comm _ (f.f i), ← add_assoc, neg_add],
  .. h.neg }

@[simps {fully_applied := ff}]
def sub_right (h : homotopy f₁ f₂) (g : C ⟶ D) : homotopy (f₁ - g) (f₂ - g) :=
{ comm := λ i, by simp only [sub_f_apply, h.comm, add_sub],
  .. h }

end homotopy

namespace homotopy_category
/-
Generalize this stuff to suitable quotient categories?
-/

variables (A B : homotopy_category V c)

@[simp] lemma quot_mk {A B : homological_complex V c} (f : A ⟶ B) :
  quot.mk _ f = (quotient V c).map f := rfl

instance : has_zero (A ⟶ B) :=
⟨(quotient V c).map 0⟩

instance : has_neg (A ⟶ B) :=
⟨quot.lift (λ f, (quotient V c).map (-f))
  (λ (f g : A.as ⟶ B.as) (h : quotient.comp_closure (homotopic V c) f g),
    eq_of_homotopy _ _ h.rel.some.neg)⟩

instance : has_add (A ⟶ B) :=
⟨quot.lift₂ (λ f g, (quotient V c).map (f + g))
  (λ (f g₁ g₂ : A.as ⟶ B.as) (h : quotient.comp_closure (homotopic V c) g₁ g₂),
    eq_of_homotopy _ _ (h.rel.some.add_left _))
  (λ (f₁ f₂ g : A.as ⟶ B.as) (h : quotient.comp_closure (homotopic V c) f₁ f₂),
    eq_of_homotopy _ _ (h.rel.some.add_right g))⟩

instance : has_sub (A ⟶ B) :=
⟨quot.lift₂ (λ f g, (quotient V c).map (f - g))
  (λ (f g₁ g₂ : A.as ⟶ B.as) (h : quotient.comp_closure (homotopic V c) g₁ g₂),
    eq_of_homotopy _ _ (h.rel.some.sub_left _))
  (λ (f₁ f₂ g : A.as ⟶ B.as) (h : quotient.comp_closure (homotopic V c) f₁ f₂),
    eq_of_homotopy _ _ (h.rel.some.sub_right g))⟩

instance has_nsmul : has_smul ℕ (A ⟶ B) := ⟨λ n, nsmul_rec n⟩

instance has_zsmul : has_smul ℤ (A ⟶ B) := ⟨λ n, zsmul_rec n⟩

lemma quotient_map_neg {A B : homological_complex V c} (f : A ⟶ B) :
(quotient V c).map (-f) = -(quotient V c).map f := rfl

lemma quotient_map_add {A B : homological_complex V c} (f g : A ⟶ B) :
  (quotient V c).map (f + g) = (quotient V c).map f + (quotient V c).map g := rfl

lemma quotient_map_sub {A B : homological_complex V c} (f g : A ⟶ B) :
  (quotient V c).map (f - g) = (quotient V c).map f - (quotient V c).map g := rfl

lemma quotient_map_nsmul {A B : homological_complex V c} (n : ℕ) (f : A ⟶ B) :
(quotient V c).map (n • f) = n • (quotient V c).map f :=
begin
  induction n with n ih,
  { rw zero_smul, refl },
  { rw [succ_nsmul, quotient_map_add, ih], refl, }
end

lemma quotient_map_zsmul {A B : homological_complex V c} (n : ℤ) (f : A ⟶ B) :
(quotient V c).map (n • f) = n • (quotient V c).map f :=
begin
  cases n,
  { rw [of_nat_zsmul, quotient_map_nsmul], refl },
  { rw [zsmul_neg_succ_of_nat, quotient_map_neg, quotient_map_nsmul], refl, }
end

instance : add_comm_group (A ⟶ B) :=
function.surjective.add_comm_group (λ f, (quotient V c).map f) (surjective_quot_mk _)
  rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)
  (λ f n, quotient_map_nsmul n f) (λ f n, quotient_map_zsmul n f)

instance : preadditive (homotopy_category V c) :=
{ add_comp' := λ X Y Z f₁ f₂ g,
  begin
    apply quot.induction_on₃ f₁ f₂ g, clear f₁ f₂ g,
    intros f₁ f₂ g,
    repeat { erw quot_mk },
    rw [← quotient_map_add],
    calc (quotient V c).map (f₁ + f₂) ≫ (quotient V c).map g
        = (quotient V c).map ((f₁ + f₂) ≫ g) : by rw (quotient V c).map_comp
    ... = (quotient V c).map (f₁ ≫ g + f₂ ≫ g) : by rw preadditive.add_comp
    ... = (quotient V c).map (f₁ ≫ g) + (quotient V c).map (f₂ ≫ g) :
      by rw quotient_map_add,
  end,
  comp_add' := λ X Y Z f g₁ g₂,
  begin
    apply quot.induction_on₃ f g₁ g₂, clear f g₁ g₂,
    intros f g₁ g₂,
    repeat { erw quot_mk },
    rw [← quotient_map_add],
    calc (quotient V c).map f ≫ (quotient V c).map (g₁ + g₂)
        = (quotient V c).map (f ≫ (g₁ + g₂)) : by rw (quotient V c).map_comp
    ... = (quotient V c).map (f ≫ g₁ + f ≫ g₂) : by rw preadditive.comp_add
    ... = (quotient V c).map (f ≫ g₁) + (quotient V c).map (f ≫ g₂) :
      by rw quotient_map_add,
  end }

instance quotient.additive : (quotient V c).additive := {}

attribute[derive [full]] quotient

open_locale zero_object

protected def zero [has_zero_object V] : homotopy_category V c :=
{ as := homological_complex.zero }

protected lemma is_zero_zero [has_zero_object V] :
  is_zero (homotopy_category.zero : homotopy_category V c) :=
begin
  rw [is_zero_iff_id_eq_zero],
  apply eq_of_homotopy,
  apply homotopy.of_eq,
  rw ← is_zero_iff_id_eq_zero,
  exact homological_complex.is_zero_zero,
end

instance [has_zero_object V] : has_zero_object (homotopy_category V c) :=
⟨⟨homotopy_category.zero, homotopy_category.is_zero_zero⟩⟩

instance shift_functor_additive (n : ℤ) :
  (category_theory.shift_functor (homotopy_category V (complex_shape.up ℤ)) n).additive :=
{}

end homotopy_category

namespace category_theory

namespace functor

@[simps]
def map_homotopy_category_comp {W : Type*} [category W] [preadditive W] (F : V ⥤ W)
[functor.additive F] (c : complex_shape ι) :
  F.map_homological_complex c ⋙ homotopy_category.quotient W c ≅
  homotopy_category.quotient V c ⋙ functor.map_homotopy_category c F :=
nat_iso.of_components
(λ X, eq_to_iso (by refl))
(λ X Y f, begin
  simp only [functor.comp_map, eq_to_iso_refl, iso.refl_hom, category.comp_id,
    functor.map_homotopy_category_map, category.id_comp],
  apply category_theory.quotient.sound,
  exact nonempty.intro (F.map_homotopy (homotopy_category.homotopy_out_map f)).symm,
end)

end functor

end category_theory


import Iris.BI
import Iris.Proofmode

namespace Iris.Examples
open Iris.BI

theorem proof_example_1 [BI PROP] (P Q R : PROP) (Φ : α → PROP) :
  P ∗ Q ∗ □ R ⊢ □ (R -∗ ∃ x, Φ x) -∗ ∃ x, Φ x ∗ P ∗ Q
:= by
  iintro ⟨HP, HQ, □HR⟩ □HRΦ
  ispecialize HRΦ HR as HΦ
  icases HΦ with ⟨x, HΦ⟩
  iexists x
  isplit r
  · iassumption
  isplit l [HP]
  · iexact HP
  · iexact HQ

end Iris.Examples


import Mathlib
import Qpf.Util
import Qpf.Macro.Tactic.FinDestr

namespace MvQPF

namespace Arrow

  def ArrowPFunctor (x : Type u) : MvPFunctor.{u} 1
    := ⟨PUnit, fun _ => (![x] : TypeVec 1)⟩

  def QpfArrow' (x : Type _) : TypeFun 1
    := (ArrowPFunctor x).Obj

  /--
    A constructor for arrow types `x → y`, which is functorial in `y`
  -/
  abbrev QpfArrow : CurriedTypeFun 2
    := fun x => (QpfArrow' x).curried

  instance : MvQPF (QpfArrow' x) :=
    by unfold QpfArrow'; infer_instance

  abbrev Arrow (x : Type u) : CurriedTypeFun 1
    := (x → ·)

  abbrev Arrow' (x : Type u) : TypeFun 1
    := TypeFun.ofCurried (Arrow x)

  theorem Arrow.eta {α β : Type u} :
    (α → β) = Arrow α β :=
  rfl

  def box (f : Arrow' α Γ) : (QpfArrow' α Γ)
    := ⟨(), fun | 0 => f⟩

  def unbox : QpfArrow' α Γ → Arrow' α Γ
    | ⟨_, f⟩ => f 0

  theorem box_unbox_id (f : QpfArrow' α Γ) :
    box (unbox f) = f :=
  by
    simp[box, unbox]
    apply congrArg;
    funext i
    fin_destr i;
    rfl

  theorem unbox_box_id (f : Arrow' α Γ) :
    unbox (box f) = f :=
  by
    rfl

  instance : MvQPF (Arrow' x) where
    P           := ArrowPFunctor x
    map f a     := unbox <| (ArrowPFunctor x).map f <| box a
    abs         := @unbox x
    repr        := @box x
    abs_repr    := unbox_box_id
    abs_map     := by intros; rfl

end Arrow

export Arrow (QpfArrow QpfArrow' Arrow Arrow')

end MvQPF