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

Measurable spaces -- σ-algberas
-/
import data.set.disjointed data.finset order.galois_connection data.set.countable
open set lattice encodable
local attribute [instance] classical.prop_decidable

universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x} {ι : Sort x}
  {s t u : set α}

structure measurable_space (α : Type u) :=
(is_measurable : set α → Prop)
(is_measurable_empty : is_measurable ∅)
(is_measurable_compl : ∀s, is_measurable s → is_measurable (- s))
(is_measurable_Union : ∀f:ℕ → set α, (∀i, is_measurable (f i)) → is_measurable (⋃i, f i))

attribute [class] measurable_space

section
variable [measurable_space α]

/-- `is_measurable s` means that `s` is measurable (in the ambient measure space on `α`) -/
def is_measurable : set α → Prop := ‹measurable_space α›.is_measurable

lemma is_measurable.empty : is_measurable (∅ : set α) :=
‹measurable_space α›.is_measurable_empty

lemma is_measurable.compl : is_measurable s → is_measurable (-s) :=
‹measurable_space α›.is_measurable_compl s

lemma is_measurable.compl_iff : is_measurable (-s) ↔ is_measurable s :=
⟨λ h, by simpa using h.compl, is_measurable.compl⟩

lemma is_measurable.univ : is_measurable (univ : set α) :=
by simpa using (@is_measurable.empty α _).compl

lemma encodable.Union_decode2 {α} [encodable β] (f : β → set α) :
  (⋃ b, f b) = ⋃ (i : ℕ) (b ∈ decode2 β i), f b :=
ext $ by simp [mem_decode2, exists_swap]

@[elab_as_eliminator] lemma encodable.Union_decode2_cases
  {α} [encodable β] {f : β → set α} {C : set α → Prop}
  (H0 : C ∅) (H1 : ∀ b, C (f b)) {n} :
  C (⋃ b ∈ decode2 β n, f b) :=
match decode2 β n with
| none := by simp; apply H0
| (some b) := by convert H1 b; simp [ext_iff]
end

lemma is_measurable.Union [encodable β] {f : β → set α} (h : ∀b, is_measurable (f b)) :
  is_measurable (⋃b, f b) :=
by rw encodable.Union_decode2; exact
‹measurable_space α›.is_measurable_Union
  (λ n, ⋃ b ∈ decode2 β n, f b)
  (λ n, encodable.Union_decode2_cases is_measurable.empty h)

lemma is_measurable.bUnion {f : β → set α} {s : set β} (hs : countable s)
  (h : ∀b∈s, is_measurable (f b)) : is_measurable (⋃b∈s, f b) :=
begin
  rw bUnion_eq_Union,
  haveI := hs.to_encodable,
  exact is_measurable.Union (by simpa using h)
end

lemma is_measurable.sUnion {s : set (set α)} (hs : countable s) (h : ∀t∈s, is_measurable t) :
  is_measurable (⋃₀ s) :=
by rw sUnion_eq_bUnion; exact is_measurable.bUnion hs h

lemma is_measurable.Union_Prop {p : Prop} {f : p → set α} (hf : ∀b, is_measurable (f b)) :
  is_measurable (⋃b, f b) :=
by by_cases p; simp [h, hf, is_measurable.empty]

lemma is_measurable.Inter [encodable β] {f : β → set α} (h : ∀b, is_measurable (f b)) :
  is_measurable (⋂b, f b) :=
is_measurable.compl_iff.1 $
by rw compl_Inter; exact is_measurable.Union (λ b, (h b).compl)

lemma is_measurable.bInter {f : β → set α} {s : set β} (hs : countable s)
  (h : ∀b∈s, is_measurable (f b)) : is_measurable (⋂b∈s, f b) :=
is_measurable.compl_iff.1 $
by rw compl_bInter; exact is_measurable.bUnion hs (λ b hb, (h b hb).compl)

lemma is_measurable.sInter {s : set (set α)} (hs : countable s) (h : ∀t∈s, is_measurable t) :
  is_measurable (⋂₀ s) :=
by rw sInter_eq_bInter; exact is_measurable.bInter hs h

lemma is_measurable.Inter_Prop {p : Prop} {f : p → set α} (hf : ∀b, is_measurable (f b)) :
  is_measurable (⋂b, f b) :=
by by_cases p; simp [h, hf, is_measurable.univ]

lemma is_measurable.union {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ ∪ s₂) :=
by rw union_eq_Union; exact
is_measurable.Union (bool.forall_bool.2 ⟨h₂, h₁⟩)

lemma is_measurable.inter {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ ∩ s₂) :=
by rw inter_eq_compl_compl_union_compl; exact
(h₁.compl.union h₂.compl).compl

lemma is_measurable.diff {s₁ s₂ : set α}
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) : is_measurable (s₁ \ s₂) :=
h₁.inter h₂.compl

lemma is_measurable.sub {s₁ s₂ : set α} :
  is_measurable s₁ → is_measurable s₂ → is_measurable (s₁ - s₂) :=
is_measurable.diff

lemma is_measurable.disjointed {f : ℕ → set α} (h : ∀i, is_measurable (f i)) (n) :
  is_measurable (disjointed f n) :=
disjointed_induct (h n) (assume t i ht, is_measurable.diff ht $ h _)

lemma is_measurable.const (p : Prop) : is_measurable {a : α | p} :=
by by_cases p; simp [h, is_measurable.empty]; apply is_measurable.univ

end

@[extensionality] lemma measurable_space.ext :
  ∀{m₁ m₂ : measurable_space α}, (∀s:set α, m₁.is_measurable s ↔ m₂.is_measurable s) → m₁ = m₂
| ⟨s₁, _, _, _⟩ ⟨s₂, _, _, _⟩ h :=
  have s₁ = s₂, from funext $ assume x, propext $ h x,
  by subst this

namespace measurable_space

section complete_lattice

instance : partial_order (measurable_space α) :=
{ le          := λm₁ m₂, m₁.is_measurable ≤ m₂.is_measurable,
  le_refl     := assume a b, le_refl _,
  le_trans    := assume a b c, le_trans,
  le_antisymm := assume a b h₁ h₂, measurable_space.ext $ assume s, ⟨h₁ s, h₂ s⟩ }

/-- The smallest σ-algebra containing a collection `s` of basic sets -/
inductive generate_measurable (s : set (set α)) : set α → Prop
| basic : ∀u∈s, generate_measurable u
| empty : generate_measurable ∅
| compl : ∀s, generate_measurable s → generate_measurable (-s)
| union : ∀f:ℕ → set α, (∀n, generate_measurable (f n)) → generate_measurable (⋃i, f i)

/-- Construct the smallest measure space containing a collection of basic sets -/
def generate_from (s : set (set α)) : measurable_space α :=
{ is_measurable       := generate_measurable s,
  is_measurable_empty := generate_measurable.empty s,
  is_measurable_compl := generate_measurable.compl,
  is_measurable_Union := generate_measurable.union }

lemma is_measurable_generate_from {s : set (set α)} {t : set α} (ht : t ∈ s) :
  (generate_from s).is_measurable t :=
generate_measurable.basic t ht

lemma generate_from_le {s : set (set α)} {m : measurable_space α} (h : ∀t∈s, m.is_measurable t) :
  generate_from s ≤ m :=
assume t (ht : generate_measurable s t), ht.rec_on h
  (is_measurable_empty m)
  (assume s _ hs, is_measurable_compl m s hs)
  (assume f _ hf, is_measurable_Union m f hf)

lemma generate_from_le_iff {s : set (set α)} {m : measurable_space α} :
  generate_from s ≤ m ↔ s ⊆ {t | m.is_measurable t} :=
iff.intro
  (assume h u hu, h _ $ is_measurable_generate_from hu)
  (assume h, generate_from_le h)

protected def mk_of_closure (g : set (set α)) (hg : {t | (generate_from g).is_measurable t} = g) :
  measurable_space α :=
{ is_measurable := λs, s ∈ g,
  is_measurable_empty := hg ▸ is_measurable_empty _,
  is_measurable_compl := hg ▸ is_measurable_compl _,
  is_measurable_Union := hg ▸ is_measurable_Union _ }

lemma mk_of_closure_sets {s : set (set α)}
  {hs : {t | (generate_from s).is_measurable t} = s} :
  measurable_space.mk_of_closure s hs = generate_from s :=
measurable_space.ext $ assume t, show t ∈ s ↔ _, by rw [← hs] {occs := occurrences.pos [1] }; refl

def gi_generate_from : galois_insertion (@generate_from α) (λm, {t | @is_measurable α m t}) :=
{ gc        := assume s m, generate_from_le_iff,
  le_l_u    := assume m s, is_measurable_generate_from,
  choice    :=
    λg hg, measurable_space.mk_of_closure g $ le_antisymm hg $ generate_from_le_iff.1 $ le_refl _,
  choice_eq := assume g hg, mk_of_closure_sets }

instance : complete_lattice (measurable_space α) :=
gi_generate_from.lift_complete_lattice

instance : inhabited (measurable_space α) := ⟨⊤⟩

lemma is_measurable_bot_iff {s : set α} : @is_measurable α ⊥ s ↔ (s = ∅ ∨ s = univ) :=
let b : measurable_space α :=
{ is_measurable       := λs, s = ∅ ∨ s = univ,
  is_measurable_empty := or.inl rfl,
  is_measurable_compl := by simp [or_imp_distrib] {contextual := tt},
  is_measurable_Union := assume f hf, classical.by_cases
    (assume h : ∃i, f i = univ,
      let ⟨i, hi⟩ := h in
      or.inr $ eq_univ_of_univ_subset $ hi ▸ le_supr f i)
    (assume h : ¬ ∃i, f i = univ,
      or.inl $ eq_empty_of_subset_empty $ Union_subset $ assume i,
        (hf i).elim (by simp {contextual := tt}) (assume hi, false.elim $ h ⟨i, hi⟩)) } in
have b = ⊥, from bot_unique $ assume s hs,
  hs.elim (assume s, s.symm ▸ @is_measurable_empty _ ⊥) (assume s, s.symm ▸ @is_measurable.univ _ ⊥),
this ▸ iff.refl _

@[simp] theorem is_measurable_top {s : set α} : @is_measurable _ ⊤ s := trivial

@[simp] theorem is_measurable_inf {m₁ m₂ : measurable_space α} {s : set α} :
  @is_measurable _ (m₁ ⊓ m₂) s ↔ @is_measurable _ m₁ s ∧ @is_measurable _ m₂ s :=
iff.rfl

@[simp] theorem is_measurable_Inf {ms : set (measurable_space α)} {s : set α} :
  @is_measurable _ (Inf ms) s ↔ ∀ m ∈ ms, @is_measurable _ m s :=
show s ∈ (⋂m∈ms, {t | @is_measurable _ m t }) ↔ _, by simp

@[simp] theorem is_measurable_infi {ι} {m : ι → measurable_space α} {s : set α} :
  @is_measurable _ (infi m) s ↔ ∀ i, @is_measurable _ (m i) s :=
show s ∈ (λm, {s | @is_measurable _ m s }) (infi m) ↔ _, by rw (@gi_generate_from α).gc.u_infi; simp; refl

end complete_lattice

section functors
variables {m m₁ m₂ : measurable_space α} {m' : measurable_space β} {f : α → β} {g : β → α}

/-- The forward image of a measure space under a function. `map f m` contains the sets `s : set β`
  whose preimage under `f` is measurable. -/
protected def map (f : α → β) (m : measurable_space α) : measurable_space β :=
{ is_measurable       := λs, m.is_measurable $ f ⁻¹' s,
  is_measurable_empty := m.is_measurable_empty,
  is_measurable_compl := assume s hs, m.is_measurable_compl _ hs,
  is_measurable_Union := assume f hf, by rw [preimage_Union]; exact m.is_measurable_Union _ hf }

@[simp] lemma map_id : m.map id = m :=
measurable_space.ext $ assume s, iff.rfl

@[simp] lemma map_comp {f : α → β} {g : β → γ} : (m.map f).map g = m.map (g ∘ f) :=
measurable_space.ext $ assume s, iff.rfl

/-- The reverse image of a measure space under a function. `comap f m` contains the sets `s : set α`
  such that `s` is the `f`-preimage of a measurable set in `β`. -/
protected def comap (f : α → β) (m : measurable_space β) : measurable_space α :=
{ is_measurable       := λs, ∃s', m.is_measurable s' ∧ f ⁻¹' s' = s,
  is_measurable_empty := ⟨∅, m.is_measurable_empty, rfl⟩,
  is_measurable_compl := assume s ⟨s', h₁, h₂⟩, ⟨-s', m.is_measurable_compl _ h₁, h₂ ▸ rfl⟩,
  is_measurable_Union := assume s hs,
    let ⟨s', hs'⟩ := classical.axiom_of_choice hs in
    ⟨⋃i, s' i, m.is_measurable_Union _ (λi, (hs' i).left), by simp [hs'] ⟩ }

@[simp] lemma comap_id : m.comap id = m :=
measurable_space.ext $ assume s, ⟨assume ⟨s', hs', h⟩, h ▸ hs', assume h, ⟨s, h, rfl⟩⟩

@[simp] lemma comap_comp {f : β → α} {g : γ → β} : (m.comap f).comap g = m.comap (f ∘ g) :=
measurable_space.ext $ assume s,
  ⟨assume ⟨t, ⟨u, h, hu⟩, ht⟩, ⟨u, h, ht ▸ hu ▸ rfl⟩, assume ⟨t, h, ht⟩, ⟨f ⁻¹' t, ⟨_, h, rfl⟩, ht⟩⟩

lemma comap_le_iff_le_map {f : α → β} : m'.comap f ≤ m ↔ m' ≤ m.map f :=
⟨assume h s hs, h _ ⟨_, hs, rfl⟩, assume h s ⟨t, ht, heq⟩, heq ▸ h _ ht⟩

lemma gc_comap_map (f : α → β) :
  galois_connection (measurable_space.comap f) (measurable_space.map f) :=
assume f g, comap_le_iff_le_map

lemma map_mono (h : m₁ ≤ m₂) : m₁.map f ≤ m₂.map f := (gc_comap_map f).monotone_u h
lemma monotone_map : monotone (measurable_space.map f) := assume a b h, map_mono h
lemma comap_mono (h : m₁ ≤ m₂) : m₁.comap g ≤ m₂.comap g := (gc_comap_map g).monotone_l h
lemma monotone_comap : monotone (measurable_space.comap g) := assume a b h, comap_mono h

@[simp] lemma comap_bot : (⊥:measurable_space α).comap g = ⊥ := (gc_comap_map g).l_bot
@[simp] lemma comap_sup : (m₁ ⊔ m₂).comap g = m₁.comap g ⊔ m₂.comap g := (gc_comap_map g).l_sup
@[simp] lemma comap_supr {m : ι → measurable_space α} :(⨆i, m i).comap g = (⨆i, (m i).comap g) :=
(gc_comap_map g).l_supr

@[simp] lemma map_top : (⊤:measurable_space α).map f = ⊤ := (gc_comap_map f).u_top
@[simp] lemma map_inf : (m₁ ⊓ m₂).map f = m₁.map f ⊓ m₂.map f := (gc_comap_map f).u_inf
@[simp] lemma map_infi {m : ι → measurable_space α} : (⨅i, m i).map f = (⨅i, (m i).map f) :=
(gc_comap_map f).u_infi

lemma comap_map_le : (m.map f).comap f ≤ m := (gc_comap_map f).l_u_le _
lemma le_map_comap : m ≤ (m.comap g).map g := (gc_comap_map g).le_u_l _

end functors

lemma generate_from_le_generate_from {s t : set (set α)} (h : s ⊆ t) :
  generate_from s ≤ generate_from t :=
gi_generate_from.gc.monotone_l h

lemma generate_from_sup_generate_from {s t : set (set α)} :
  generate_from s ⊔ generate_from t = generate_from (s ∪ t) :=
(@gi_generate_from α).gc.l_sup.symm

lemma comap_generate_from {f : α → β} {s : set (set β)} :
  (generate_from s).comap f = generate_from (preimage f '' s) :=
le_antisymm
  (comap_le_iff_le_map.2 $ generate_from_le $ assume t hts,
    generate_measurable.basic _ $ mem_image_of_mem _ $ hts)
  (generate_from_le $ assume t ⟨u, hu, eq⟩, eq ▸ ⟨u, generate_measurable.basic _ hu, rfl⟩)

end measurable_space

section measurable_functions
open measurable_space

/-- A function `f` between measurable spaces is measurable if the preimage of every
  measurable set is measurable. -/
def measurable [m₁ : measurable_space α] [m₂ : measurable_space β] (f : α → β) : Prop :=
m₂ ≤ m₁.map f

lemma measurable_id [measurable_space α] : measurable (@id α) := le_refl _

lemma measurable.preimage [measurable_space α] [measurable_space β]
  {f : α → β} (hf : measurable f) {s : set β} : is_measurable s → is_measurable (f ⁻¹' s) := hf _

lemma measurable.comp [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β} {g : β → γ} (hf : measurable f) (hg : measurable g) : measurable (g ∘ f) :=
le_trans hg $ map_mono hf

lemma measurable_generate_from [measurable_space α] {s : set (set β)} {f : α → β}
  (h : ∀t∈s, is_measurable (f ⁻¹' t)) : @measurable _ _ _ (generate_from s) f :=
generate_from_le h

lemma measurable.if [measurable_space α] [measurable_space β]
  {p : α → Prop} {h : decidable_pred p} {f g : α → β}
  (hp : is_measurable {a | p a}) (hf : measurable f) (hg : measurable g) :
  measurable (λa, if p a then f a else g a) :=
λ s hs, show is_measurable {a | (if p a then f a else g a) ∈ s},
begin
  convert (hp.inter $ hf s hs).union (hp.compl.inter $ hg s hs),
  exact ext (λ a, by by_cases p a; simp [h, mem_def])
end

lemma measurable_const {α β} [measurable_space α] [measurable_space β] {a : α} : measurable (λb:β, a) :=
assume s hs, show is_measurable {b : β | a ∈ s}, from
  classical.by_cases
    (assume h : a ∈ s, by simp [h]; from is_measurable.univ)
    (assume h : a ∉ s, by simp [h]; from is_measurable.empty)

end measurable_functions

section constructions

instance : measurable_space empty := ⊤
instance : measurable_space unit := ⊤
instance : measurable_space bool := ⊤
instance : measurable_space ℕ := ⊤
instance : measurable_space ℤ := ⊤

lemma measurable_unit [measurable_space α] (f : unit → α) : measurable f :=
have f = (λu, f ()) := funext $ assume ⟨⟩, rfl,
by rw this; exact measurable_const

section subtype

instance {p : α → Prop} [m : measurable_space α] : measurable_space (subtype p) :=
m.comap subtype.val

lemma measurable_subtype_val [measurable_space α] [measurable_space β] {p : β → Prop}
  {f : α → subtype p} (hf : measurable f) : measurable (λa:α, (f a).val) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_refl _

lemma measurable_subtype_mk [measurable_space α] [measurable_space β] {p : β → Prop}
  {f : α → subtype p} (hf : measurable (λa, (f a).val)) : measurable f :=
measurable_space.comap_le_iff_le_map.mpr $ by rw [measurable_space.map_comp]; exact hf

lemma is_measurable_subtype_image [measurable_space α] {s : set α} {t : set s}
  (hs : is_measurable s) : is_measurable t → is_measurable ((coe : s → α) '' t)
| ⟨u, (hu : is_measurable u), (eq : coe ⁻¹' u = t)⟩ :=
  begin
    rw [← eq, image_preimage_eq_inter_range, range_coe_subtype],
    exact is_measurable.inter hu hs
  end

lemma measurable_of_measurable_union_cover
  [measurable_space α] [measurable_space β]
  {f : α → β} (s t : set α) (hs : is_measurable s) (ht : is_measurable t) (h : univ ⊆ s ∪ t)
  (hc : measurable (λa:s, f a)) (hd : measurable (λa:t, f a)) :
  measurable f :=
assume u (hu : is_measurable u), show is_measurable (f ⁻¹' u), from
begin
  rw show f ⁻¹' u = coe '' (coe ⁻¹' (f ⁻¹' u) : set s) ∪ coe '' (coe ⁻¹' (f ⁻¹' u) : set t),
    by rw [image_preimage_eq_inter_range, image_preimage_eq_inter_range, range_coe_subtype, range_coe_subtype, ← inter_distrib_left, univ_subset_iff.1 h, inter_univ],
  exact is_measurable.union
    (is_measurable_subtype_image hs (hc _ hu))
    (is_measurable_subtype_image ht (hd _ hu))
end

end subtype

section prod

instance [m₁ : measurable_space α] [m₂ : measurable_space β] : measurable_space (α × β) :=
m₁.comap prod.fst ⊔ m₂.comap prod.snd

lemma measurable_fst [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf : measurable f) : measurable (λa:α, (f a).1) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_sup_left

lemma measurable_snd [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf : measurable f) : measurable (λa:α, (f a).2) :=
hf.comp $ measurable_space.comap_le_iff_le_map.mp $ le_sup_right

lemma measurable.prod [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β × γ} (hf₁ : measurable (λa, (f a).1)) (hf₂ : measurable (λa, (f a).2)) :
  measurable f :=
sup_le
  (by rw [measurable_space.comap_le_iff_le_map, measurable_space.map_comp]; exact hf₁)
  (by rw [measurable_space.comap_le_iff_le_map, measurable_space.map_comp]; exact hf₂)

lemma measurable_prod_mk [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : α → β} {g : α → γ} (hf : measurable f) (hg : measurable g) : measurable (λa:α, (f a, g a)) :=
measurable.prod hf hg

lemma is_measurable_set_prod [measurable_space α] [measurable_space β] {s : set α} {t : set β}
  (hs : is_measurable s) (ht : is_measurable t) : is_measurable (set.prod s t) :=
is_measurable.inter (measurable_fst measurable_id _ hs) (measurable_snd measurable_id _ ht)

end prod

instance [m₁ : measurable_space α] [m₂ : measurable_space β] : measurable_space (α ⊕ β) :=
m₁.map sum.inl ⊓ m₂.map sum.inr

section sum
variables [measurable_space α] [measurable_space β] [measurable_space γ]

lemma measurable_inl : measurable (@sum.inl α β) := inf_le_left

lemma measurable_inr : measurable (@sum.inr α β) := inf_le_right

lemma measurable_sum {f : α ⊕ β → γ}
  (hl : measurable (f ∘ sum.inl)) (hr : measurable (f ∘ sum.inr)) : measurable f :=
measurable_space.comap_le_iff_le_map.1 $ le_inf
  (measurable_space.comap_le_iff_le_map.2 $ hl)
  (measurable_space.comap_le_iff_le_map.2 $ hr)

lemma measurable_sum_rec {f : α → γ} {g : β → γ}
  (hf : measurable f) (hg : measurable g) : @measurable (α ⊕ β) γ _ _ (@sum.rec α β (λ_, γ) f g) :=
measurable_sum hf hg

lemma is_measurable_inl_image [measurable_space α] [measurable_space β] {s : set α}
  (hs : is_measurable s) : is_measurable (sum.inl '' s : set (α ⊕ β)) :=
⟨show is_measurable (sum.inl ⁻¹' _), by rwa [preimage_image_eq]; exact (assume a b, sum.inl.inj),
  have sum.inr ⁻¹' (sum.inl '' s : set (α ⊕ β)) = ∅ :=
    eq_empty_of_subset_empty $ assume x ⟨y, hy, eq⟩, by contradiction,
  show is_measurable (sum.inr ⁻¹' _), by rw [this]; exact is_measurable.empty⟩

lemma is_measurable_range_inl [measurable_space α] [measurable_space β] :
  is_measurable (range sum.inl : set (α ⊕ β)) :=
by rw [← image_univ]; exact is_measurable_inl_image is_measurable.univ

lemma is_measurable_inr_image [measurable_space α] [measurable_space β] {s : set β}
  (hs : is_measurable s) : is_measurable (sum.inr '' s : set (α ⊕ β)) :=
⟨ have sum.inl ⁻¹' (sum.inr '' s : set (α ⊕ β)) = ∅ :=
    eq_empty_of_subset_empty $ assume x ⟨y, hy, eq⟩, by contradiction,
  show is_measurable (sum.inl ⁻¹' _), by rw [this]; exact is_measurable.empty,
  show is_measurable (sum.inr ⁻¹' _), by rwa [preimage_image_eq]; exact (assume a b, sum.inr.inj)⟩

lemma is_measurable_range_inr [measurable_space α] [measurable_space β] :
  is_measurable (range sum.inr : set (α ⊕ β)) :=
by rw [← image_univ]; exact is_measurable_inr_image is_measurable.univ

end sum

instance {β : α → Type v} [m : Πa, measurable_space (β a)] : measurable_space (sigma β) :=
⨅a, (m a).map (sigma.mk a)

end constructions

/-- Equivalences between measurable spaces. Main application is the simplification of measurability
statements along measurable equivalences. -/
structure measurable_equiv (α β : Type*) [measurable_space α] [measurable_space β] extends α ≃ β :=
(measurable_to_fun : measurable to_fun)
(measurable_inv_fun : measurable inv_fun)

namespace measurable_equiv

instance (α β) [measurable_space α] [measurable_space β] : has_coe_to_fun (measurable_equiv α β) :=
⟨λ_, α → β, λe, e.to_equiv⟩

lemma coe_eq {α β} [measurable_space α] [measurable_space β] (e : measurable_equiv α β) :
  (e : α → β) = e.to_equiv := rfl

def refl (α : Type*) [measurable_space α] : measurable_equiv α α :=
{ to_equiv := equiv.refl α,
  measurable_to_fun := measurable_id, measurable_inv_fun := measurable_id }

def trans [measurable_space α] [measurable_space β] [measurable_space γ]
  (ab : measurable_equiv α β) (bc : measurable_equiv β γ) :
  measurable_equiv α γ :=
{ to_equiv := ab.to_equiv.trans bc.to_equiv,
  measurable_to_fun := ab.measurable_to_fun.comp bc.measurable_to_fun,
  measurable_inv_fun := bc.measurable_inv_fun.comp ab.measurable_inv_fun }

lemma trans_to_equiv {α β} [measurable_space α] [measurable_space β] [measurable_space γ]
  (e : measurable_equiv α β) (f : measurable_equiv β γ) :
  (e.trans f).to_equiv = e.to_equiv.trans f.to_equiv := rfl

def symm [measurable_space α] [measurable_space β] (ab : measurable_equiv α β) :
  measurable_equiv β α :=
{ to_equiv := ab.to_equiv.symm,
  measurable_to_fun := ab.measurable_inv_fun,
  measurable_inv_fun := ab.measurable_to_fun }

lemma symm_to_equiv {α β} [measurable_space α] [measurable_space β] (e : measurable_equiv α β) :
  e.symm.to_equiv = e.to_equiv.symm := rfl

protected def cast {α β} [i₁ : measurable_space α] [i₂ : measurable_space β]
  (h : α = β) (hi : i₁ == i₂) : measurable_equiv α β :=
{ to_equiv := equiv.cast h,
  measurable_to_fun  := by unfreezeI; subst h; subst hi; exact measurable_id,
  measurable_inv_fun := by unfreezeI; subst h; subst hi; exact measurable_id }

protected lemma measurable {α β} [measurable_space α] [measurable_space β]
  (e : measurable_equiv α β) : measurable (e : α → β) :=
e.measurable_to_fun

protected lemma measurable_coe_iff {α β γ} [measurable_space α] [measurable_space β] [measurable_space γ]
  {f : β → γ} (e : measurable_equiv α β) : measurable (f ∘ e) ↔ measurable f :=
iff.intro
  (assume hfe,
    have measurable (f ∘ (e.symm.trans e).to_equiv) := e.symm.measurable.comp hfe,
    by rwa [trans_to_equiv, symm_to_equiv, equiv.symm_trans] at this)
  (e.measurable.comp)

def prod_congr [measurable_space α] [measurable_space β] [measurable_space γ] [measurable_space δ]
  (ab : measurable_equiv α β) (cd : measurable_equiv γ δ) :
  measurable_equiv (α × γ) (β × δ) :=
{ to_equiv := equiv.prod_congr ab.to_equiv cd.to_equiv,
  measurable_to_fun := measurable_prod_mk
    ((measurable_fst measurable_id).comp ab.measurable_to_fun)
    ((measurable_snd measurable_id).comp cd.measurable_to_fun),
  measurable_inv_fun := measurable_prod_mk
    ((measurable_fst measurable_id).comp ab.measurable_inv_fun)
    ((measurable_snd measurable_id).comp cd.measurable_inv_fun) }

def prod_comm [measurable_space α] [measurable_space β] : measurable_equiv (α × β) (β × α) :=
{ to_equiv := equiv.prod_comm α β,
  measurable_to_fun  := measurable_prod_mk (measurable_snd measurable_id) (measurable_fst measurable_id),
  measurable_inv_fun := measurable_prod_mk (measurable_snd measurable_id) (measurable_fst measurable_id) }

def sum_congr [measurable_space α] [measurable_space β] [measurable_space γ] [measurable_space δ]
  (ab : measurable_equiv α β) (cd : measurable_equiv γ δ) :
  measurable_equiv (α ⊕ γ) (β ⊕ δ) :=
{ to_equiv := equiv.sum_congr ab.to_equiv cd.to_equiv,
  measurable_to_fun :=
    begin
      cases ab with ab' abm, cases ab', cases cd with cd' cdm, cases cd',
      refine measurable_sum (abm.comp measurable_inl) (cdm.comp measurable_inr)
    end,
  measurable_inv_fun :=
    begin
      cases ab with ab' _ abm, cases ab', cases cd with cd' _ cdm, cases cd',
      refine measurable_sum (abm.comp measurable_inl) (cdm.comp measurable_inr)
    end }

def set.prod [measurable_space α] [measurable_space β] (s : set α) (t : set β) :
  measurable_equiv (set.prod s t) (s × t) :=
{ to_equiv := equiv.set.prod s t,
  measurable_to_fun := measurable_prod_mk
    (measurable_subtype_mk $ measurable_fst $ measurable_subtype_val $ measurable_id)
    (measurable_subtype_mk $ measurable_snd $ measurable_subtype_val $ measurable_id),
  measurable_inv_fun := measurable_subtype_mk $ measurable_prod_mk
    (measurable_subtype_val $ measurable_fst $ measurable_id)
    (measurable_subtype_val $ measurable_snd $ measurable_id) }

def set.univ (α : Type*) [measurable_space α] : measurable_equiv (univ : set α) α :=
{ to_equiv := equiv.set.univ α,
  measurable_to_fun := measurable_subtype_val measurable_id,
  measurable_inv_fun := measurable_subtype_mk measurable_id }

def set.singleton [measurable_space α] (a:α) : measurable_equiv ({a} : set α) unit :=
{ to_equiv := equiv.set.singleton a,
  measurable_to_fun := measurable_const,
  measurable_inv_fun := measurable_subtype_mk $ show measurable (λu:unit, a), from
    measurable_const }

noncomputable def set.image [measurable_space α] [measurable_space β]
  (f : α → β) (s : set α)
  (hf : function.injective f)
  (hfm : measurable f) (hfi : ∀s, is_measurable s → is_measurable (f '' s)) :
  measurable_equiv s (f '' s) :=
{ to_equiv := equiv.set.image f s hf,
  measurable_to_fun  :=
  begin
    have : measurable (λa:s, f a) := (measurable_subtype_val measurable_id).comp hfm,
    refine measurable_subtype_mk _,
    convert this,
    ext ⟨a, h⟩, refl
  end,
  measurable_inv_fun :=
    assume t ⟨u, (hu : is_measurable u), eq⟩,
    begin
      clear_, subst eq,
      show is_measurable {x : f '' s | ((equiv.set.image f s hf).inv_fun x).val ∈ u},
      have : ∀(a ∈ s) (h : ∃a', a' ∈ s ∧ a' = a), classical.some h = a :=
        λa ha h, (classical.some_spec h).2,
      rw show {x:f '' s | ((equiv.set.image f s hf).inv_fun x).val ∈ u} = subtype.val ⁻¹' (f '' u),
        by ext ⟨b, a, hbs, rfl⟩; simp [equiv.set.image, hf, this _ hbs],
      exact (measurable_subtype_val measurable_id) (f '' u) (hfi u hu)
    end }

noncomputable def set.range [measurable_space α] [measurable_space β]
  (f : α → β) (hf : function.injective f) (hfm : measurable f)
  (hfi : ∀s, is_measurable s → is_measurable (f '' s)) :
  measurable_equiv α (range f) :=
(measurable_equiv.set.univ _).symm.trans $
  (measurable_equiv.set.image f univ hf hfm hfi).trans $
  measurable_equiv.cast (by rw image_univ) (by rw image_univ)

def set.range_inl [measurable_space α] [measurable_space β] :
  measurable_equiv (range sum.inl : set (α ⊕ β)) α :=
{ to_fun    := λab, match ab with
    | ⟨sum.inl a, _⟩ := a
    | ⟨sum.inr b, p⟩ := have false, by cases p; contradiction, this.elim
    end,
  inv_fun   := λa, ⟨sum.inl a, a, rfl⟩,
  left_inv  := assume ⟨ab, a, eq⟩, by subst eq; refl,
  right_inv := assume a, rfl,
  measurable_to_fun  := assume s (hs : is_measurable s),
    begin
      refine ⟨_, is_measurable_inl_image hs, set.ext _⟩,
      rintros ⟨ab, a, rfl⟩,
      simp [set.range_inl._match_1]
    end,
  measurable_inv_fun := measurable_subtype_mk measurable_inl }

def set.range_inr [measurable_space α] [measurable_space β] :
  measurable_equiv (range sum.inr : set (α ⊕ β)) β :=
{ to_fun    := λab, match ab with
    | ⟨sum.inr b, _⟩ := b
    | ⟨sum.inl a, p⟩ := have false, by cases p; contradiction, this.elim
    end,
  inv_fun   := λb, ⟨sum.inr b, b, rfl⟩,
  left_inv  := assume ⟨ab, b, eq⟩, by subst eq; refl,
  right_inv := assume b, rfl,
  measurable_to_fun  := assume s (hs : is_measurable s),
    begin
      refine ⟨_, is_measurable_inr_image hs, set.ext _⟩,
      rintros ⟨ab, b, rfl⟩,
      simp [set.range_inr._match_1]
    end,
  measurable_inv_fun := measurable_subtype_mk measurable_inr }

def sum_prod_distrib (α β γ) [measurable_space α] [measurable_space β] [measurable_space γ] :
  measurable_equiv ((α ⊕ β) × γ) ((α × γ) ⊕ (β × γ)) :=
{ to_equiv := equiv.sum_prod_distrib α β γ,
  measurable_to_fun  :=
  begin
    refine measurable_of_measurable_union_cover
      ((range sum.inl).prod univ)
      ((range sum.inr).prod univ)
      (is_measurable_set_prod is_measurable_range_inl is_measurable.univ)
      (is_measurable_set_prod is_measurable_range_inr is_measurable.univ)
      (assume ⟨ab, c⟩ s, by cases ab; simp [set.prod_eq])
      _
      _,
    { refine (set.prod (range sum.inl) univ).symm.measurable_coe_iff.1 _,
      refine (prod_congr set.range_inl (set.univ _)).symm.measurable_coe_iff.1 _,
      dsimp [(∘)],
      convert measurable_inl,
      ext ⟨a, c⟩, refl },
    { refine (set.prod (range sum.inr) univ).symm.measurable_coe_iff.1 _,
      refine (prod_congr set.range_inr (set.univ _)).symm.measurable_coe_iff.1 _,
      dsimp [(∘)],
      convert measurable_inr,
      ext ⟨b, c⟩, refl }
  end,
  measurable_inv_fun :=
    begin
      refine measurable_sum _ _,
      { convert measurable_prod_mk
          ((measurable_fst measurable_id).comp (measurable_inl)) (measurable_snd measurable_id),
        ext ⟨a, c⟩; refl },
      { convert measurable_prod_mk
          ((measurable_fst measurable_id).comp (measurable_inr)) (measurable_snd measurable_id),
        ext ⟨b, c⟩; refl }
    end }

def prod_sum_distrib (α β γ) [measurable_space α] [measurable_space β] [measurable_space γ] :
  measurable_equiv (α × (β ⊕ γ)) ((α × β) ⊕ (α × γ)) :=
prod_comm.trans $ (sum_prod_distrib _ _ _).trans $ sum_congr prod_comm prod_comm

def sum_prod_sum (α β γ δ)
  [measurable_space α] [measurable_space β] [measurable_space γ] [measurable_space δ] :
  measurable_equiv ((α ⊕ β) × (γ ⊕ δ)) (((α × γ) ⊕ (α × δ)) ⊕ ((β × γ) ⊕ (β × δ))) :=
(sum_prod_distrib _ _ _).trans $ sum_congr (prod_sum_distrib _ _ _) (prod_sum_distrib _ _ _)

end measurable_equiv

namespace measurable_equiv

end measurable_equiv

namespace measurable_space

/-- Dynkin systems
The main purpose of Dynkin systems is to provide a powerful induction rule for σ-algebras generated
by intersection stable set systems.
-/
structure dynkin_system (α : Type*) :=
(has : set α → Prop)
(has_empty : has ∅)
(has_compl : ∀{a}, has a → has (-a))
(has_Union_nat : ∀{f:ℕ → set α}, pairwise (disjoint on f) → (∀i, has (f i)) → has (⋃i, f i))

theorem Union_decode2_disjoint_on
  {β} [encodable β] {f : β → set α} (hd : pairwise (disjoint on f)) :
  pairwise (disjoint on λ i, ⋃ b ∈ decode2 β i, f b) :=
begin
  rintro i j ij x ⟨h₁, h₂⟩,
  revert h₁ h₂,
  simp, intros b₁ e₁ h₁ b₂ e₂ h₂,
  refine hd _ _ _ ⟨h₁, h₂⟩,
  cases encodable.mem_decode2.1 e₁,
  cases encodable.mem_decode2.1 e₂,
  exact mt (congr_arg _) ij
end

namespace dynkin_system

@[extensionality] lemma ext :
  ∀{d₁ d₂ : dynkin_system α}, (∀s:set α, d₁.has s ↔ d₂.has s) → d₁ = d₂
| ⟨s₁, _, _, _⟩ ⟨s₂, _, _, _⟩ h :=
  have s₁ = s₂, from funext $ assume x, propext $ h x,
  by subst this

variable (d : dynkin_system α)

lemma has_compl_iff {a} : d.has (-a) ↔ d.has a :=
⟨λ h, by simpa using d.has_compl h, λ h, d.has_compl h⟩

lemma has_univ : d.has univ :=
by simpa using d.has_compl d.has_empty

theorem has_Union {β} [encodable β] {f : β → set α}
  (hd : pairwise (disjoint on f)) (h : ∀i, d.has (f i)) : d.has (⋃i, f i) :=
by rw encodable.Union_decode2; exact
d.has_Union_nat (Union_decode2_disjoint_on hd)
  (λ n, encodable.Union_decode2_cases d.has_empty h)

theorem has_union {s₁ s₂ : set α}
  (h₁ : d.has s₁) (h₂ : d.has s₂) (h : s₁ ∩ s₂ ⊆ ∅) : d.has (s₁ ∪ s₂) :=
by rw union_eq_Union; exact
d.has_Union (pairwise_disjoint_on_bool.2 h)
  (bool.forall_bool.2 ⟨h₂, h₁⟩)

lemma has_diff {s₁ s₂ : set α} (h₁ : d.has s₁) (h₂ : d.has s₂) (h : s₂ ⊆ s₁) : d.has (s₁ \ s₂) :=
d.has_compl_iff.1 begin
  simp [diff_eq, compl_inter],
  exact d.has_union (d.has_compl h₁) h₂ (λ x ⟨h₁, h₂⟩, h₁ (h h₂)),
end

instance : partial_order (dynkin_system α) :=
{ le          := λm₁ m₂, m₁.has ≤ m₂.has,
  le_refl     := assume a b, le_refl _,
  le_trans    := assume a b c, le_trans,
  le_antisymm := assume a b h₁ h₂, ext $ assume s, ⟨h₁ s, h₂ s⟩ }

def of_measurable_space (m : measurable_space α) : dynkin_system α :=
{ has       := m.is_measurable,
  has_empty := m.is_measurable_empty,
  has_compl := m.is_measurable_compl,
  has_Union_nat := assume f _ hf, m.is_measurable_Union f hf }

lemma of_measurable_space_le_of_measurable_space_iff {m₁ m₂ : measurable_space α} :
  of_measurable_space m₁ ≤ of_measurable_space m₂ ↔ m₁ ≤ m₂ :=
iff.rfl

/-- The least Dynkin system containing a collection of basic sets. -/
inductive generate_has (s : set (set α)) : set α → Prop
| basic : ∀t∈s, generate_has t
| empty : generate_has ∅
| compl : ∀{a}, generate_has a → generate_has (-a)
| Union : ∀{f:ℕ → set α}, pairwise (disjoint on f) →
    (∀i, generate_has (f i)) → generate_has (⋃i, f i)

def generate (s : set (set α)) : dynkin_system α :=
{ has := generate_has s,
  has_empty := generate_has.empty s,
  has_compl := assume a, generate_has.compl,
  has_Union_nat := assume f, generate_has.Union }

def to_measurable_space (h_inter : ∀s₁ s₂, d.has s₁ → d.has s₂ → d.has (s₁ ∩ s₂)) :=
{ measurable_space .
  is_measurable := d.has,
  is_measurable_empty := d.has_empty,
  is_measurable_compl := assume s h, d.has_compl h,
  is_measurable_Union := assume f hf,
    have ∀n, d.has (disjointed f n),
      from assume n, disjointed_induct (hf n)
        (assume t i h, h_inter _ _ h $ d.has_compl $ hf i),
    have d.has (⋃n, disjointed f n), from d.has_Union disjoint_disjointed this,
    by rwa [Union_disjointed] at this }

lemma of_measurable_space_to_measurable_space
  (h_inter : ∀s₁ s₂, d.has s₁ → d.has s₂ → d.has (s₁ ∩ s₂)) :
  of_measurable_space (d.to_measurable_space h_inter) = d :=
ext $ assume s, iff.rfl

def restrict_on {s : set α} (h : d.has s) : dynkin_system α :=
{ has       := λt, d.has (t ∩ s),
  has_empty := by simp [d.has_empty],
  has_compl := assume t hts,
    have -t ∩ s = (- (t ∩ s)) \ -s,
      from set.ext $ assume x, by by_cases x ∈ s; simp [h],
    by rw [this]; from d.has_diff (d.has_compl hts) (d.has_compl h)
      (compl_subset_compl.mpr $ inter_subset_right _ _),
  has_Union_nat := assume f hd hf,
    begin
      rw [inter_comm, inter_Union_left],
      apply d.has_Union_nat,
      { exact λ i j h x ⟨⟨_, h₁⟩, _, h₂⟩, hd i j h ⟨h₁, h₂⟩ },
      { simpa [inter_comm] using hf },
    end }

lemma generate_le {s : set (set α)} (h : ∀t∈s, d.has t) : generate s ≤ d :=
λ t ht, ht.rec_on h d.has_empty
  (assume a _ h, d.has_compl h)
  (assume f hd _ hf, d.has_Union hd hf)

lemma generate_inter {s : set (set α)}
  (hs : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s) {t₁ t₂ : set α}
  (ht₁ : (generate s).has t₁) (ht₂ : (generate s).has t₂) : (generate s).has (t₁ ∩ t₂) :=
have generate s ≤ (generate s).restrict_on ht₂,
  from generate_le _ $ assume s₁ hs₁,
  have (generate s).has s₁, from generate_has.basic s₁ hs₁,
  have generate s ≤ (generate s).restrict_on this,
    from generate_le _ $ assume s₂ hs₂,
      show (generate s).has (s₂ ∩ s₁), from
        if h : s₂ ∩ s₁ = ∅ then by rw [h]; exact generate_has.empty _
        else generate_has.basic _ (hs _ _ hs₂ hs₁ h),
  have (generate s).has (t₂ ∩ s₁), from this _ ht₂,
  show (generate s).has (s₁ ∩ t₂), by rwa [inter_comm],
this _ ht₁

lemma generate_from_eq {s : set (set α)}
  (hs : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s) :
generate_from s = (generate s).to_measurable_space (assume t₁ t₂, generate_inter hs) :=
le_antisymm
  (generate_from_le $ assume t ht, generate_has.basic t ht)
  (of_measurable_space_le_of_measurable_space_iff.mp $
    by rw [of_measurable_space_to_measurable_space];
    from (generate_le _ $ assume t ht, is_measurable_generate_from ht))

end dynkin_system

lemma induction_on_inter {C : set α → Prop} {s : set (set α)} {m : measurable_space α}
  (h_eq : m = generate_from s)
  (h_inter : ∀t₁ t₂, t₁ ∈ s → t₂ ∈ s → t₁ ∩ t₂ ≠ ∅ → t₁ ∩ t₂ ∈ s)
  (h_empty : C ∅) (h_basic : ∀t∈s, C t) (h_compl : ∀t, m.is_measurable t → C t → C (- t))
  (h_union : ∀f:ℕ → set α, (∀i j, i ≠ j → f i ∩ f j ⊆ ∅) →
    (∀i, m.is_measurable (f i)) → (∀i, C (f i)) → C (⋃i, f i)) :
  ∀{t}, m.is_measurable t → C t :=
have eq : m.is_measurable = dynkin_system.generate_has s,
  by rw [h_eq, dynkin_system.generate_from_eq h_inter]; refl,
assume t ht,
have dynkin_system.generate_has s t, by rwa [eq] at ht,
this.rec_on h_basic h_empty
  (assume t ht, h_compl t $ by rw [eq]; exact ht)
  (assume f hf ht, h_union f hf $ assume i, by rw [eq]; exact ht _)

end measurable_space


/-
Copyright (c) 2019 Abhimanyu Pallavi Sudhir. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abhimanyu Pallavi Sudhir
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.order.filter.filter_product
import Mathlib.analysis.specific_limits
import Mathlib.PostPort

namespace Mathlib

/-!
# Construction of the hyperreal numbers as an ultraproduct of real sequences.
-/

/-- Hyperreal numbers on the ultrafilter extending the cofinite filter -/
def hyperreal := filter.germ ↑(filter.hyperfilter ℕ) ℝ

notation:1024 "ℝ*" => Mathlib.hyperreal

namespace hyperreal

protected instance has_coe_t : has_coe_t ℝ ℝ* := has_coe_t.mk fun (x : ℝ) => ↑x

@[simp] theorem coe_eq_coe {x : ℝ} {y : ℝ} : ↑x = ↑y ↔ x = y := filter.germ.const_inj

@[simp] theorem coe_eq_zero {x : ℝ} : ↑x = 0 ↔ x = 0 := coe_eq_coe

@[simp] theorem coe_eq_one {x : ℝ} : ↑x = 1 ↔ x = 1 := coe_eq_coe

@[simp] theorem coe_one : ↑1 = 1 := rfl

@[simp] theorem coe_zero : ↑0 = 0 := rfl

@[simp] theorem coe_inv (x : ℝ) : ↑(x⁻¹) = (↑x⁻¹) := rfl

@[simp] theorem coe_neg (x : ℝ) : ↑(-x) = -↑x := rfl

@[simp] theorem coe_add (x : ℝ) (y : ℝ) : ↑(x + y) = ↑x + ↑y := rfl

@[simp] theorem coe_bit0 (x : ℝ) : ↑(bit0 x) = bit0 ↑x := rfl

@[simp] theorem coe_bit1 (x : ℝ) : ↑(bit1 x) = bit1 ↑x := rfl

@[simp] theorem coe_mul (x : ℝ) (y : ℝ) : ↑(x * y) = ↑x * ↑y := rfl

@[simp] theorem coe_div (x : ℝ) (y : ℝ) : ↑(x / y) = ↑x / ↑y := rfl

@[simp] theorem coe_sub (x : ℝ) (y : ℝ) : ↑(x - y) = ↑x - ↑y := rfl

@[simp] theorem coe_lt_coe {x : ℝ} {y : ℝ} : ↑x < ↑y ↔ x < y := filter.germ.const_lt

@[simp] theorem coe_pos {x : ℝ} : 0 < ↑x ↔ 0 < x := coe_lt_coe

@[simp] theorem coe_le_coe {x : ℝ} {y : ℝ} : ↑x ≤ ↑y ↔ x ≤ y := filter.germ.const_le_iff

@[simp] theorem coe_abs (x : ℝ) : ↑(abs x) = abs ↑x := filter.germ.const_abs x

@[simp] theorem coe_max (x : ℝ) (y : ℝ) : ↑(max x y) = max ↑x ↑y := filter.germ.const_max x y

@[simp] theorem coe_min (x : ℝ) (y : ℝ) : ↑(min x y) = min ↑x ↑y := filter.germ.const_min x y

/-- Construct a hyperreal number from a sequence of real numbers. -/
def of_seq (f : ℕ → ℝ) : ℝ* := ↑f

/-- A sample infinitesimal hyperreal-/
def epsilon : ℝ* := of_seq fun (n : ℕ) => ↑n⁻¹

/-- A sample infinite hyperreal-/
def omega : ℝ* := of_seq coe

theorem epsilon_eq_inv_omega : epsilon = (omega⁻¹) := rfl

theorem inv_epsilon_eq_omega : epsilon⁻¹ = omega := inv_inv' omega

theorem epsilon_pos : 0 < epsilon := sorry

theorem epsilon_ne_zero : epsilon ≠ 0 := ne_of_gt epsilon_pos

theorem omega_pos : 0 < omega :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < omega)) (Eq.symm inv_epsilon_eq_omega)))
    (iff.mpr inv_pos epsilon_pos)

theorem omega_ne_zero : omega ≠ 0 := ne_of_gt omega_pos

theorem epsilon_mul_omega : epsilon * omega = 1 := inv_mul_cancel omega_ne_zero

theorem lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0))
    {r : ℝ} : 0 < r → of_seq f < ↑r :=
  sorry

theorem neg_lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0))
    {r : ℝ} : 0 < r → -↑r < of_seq f :=
  sorry

theorem gt_of_tendsto_zero_of_neg {f : ℕ → ℝ} (hf : filter.tendsto f filter.at_top (nhds 0))
    {r : ℝ} : r < 0 → ↑r < of_seq f :=
  sorry

theorem epsilon_lt_pos (x : ℝ) : 0 < x → epsilon < ↑x :=
  lt_of_tendsto_zero_of_pos tendsto_inverse_at_top_nhds_0_nat

/-- Standard part predicate -/
def is_st (x : ℝ*) (r : ℝ) := ∀ (δ : ℝ), 0 < δ → ↑r - ↑δ < x ∧ x < ↑r + ↑δ

/-- Standard part function: like a "round" to ℝ instead of ℤ -/
def st : ℝ* → ℝ :=
  fun (x : ℝ*) =>
    dite (∃ (r : ℝ), is_st x r) (fun (h : ∃ (r : ℝ), is_st x r) => classical.some h)
      fun (h : ¬∃ (r : ℝ), is_st x r) => 0

/-- A hyperreal number is infinitesimal if its standard part is 0 -/
def infinitesimal (x : ℝ*) := is_st x 0

/-- A hyperreal number is positive infinite if it is larger than all real numbers -/
def infinite_pos (x : ℝ*) := ∀ (r : ℝ), ↑r < x

/-- A hyperreal number is negative infinite if it is smaller than all real numbers -/
def infinite_neg (x : ℝ*) := ∀ (r : ℝ), x < ↑r

/-- A hyperreal number is infinite if it is infinite positive or infinite negative -/
def infinite (x : ℝ*) := infinite_pos x ∨ infinite_neg x

/-!
### Some facts about `st`
-/

theorem is_st_unique {x : ℝ*} {r : ℝ} {s : ℝ} (hr : is_st x r) (hs : is_st x s) : r = s :=
  or.dcases_on (lt_trichotomy r s) (fun (h : r < s) => false.elim (is_st_unique' x r s hr hs h))
    fun (h : r = s ∨ s < r) =>
      or.dcases_on h (fun (h : r = s) => h)
        fun (h : s < r) => false.elim (is_st_unique' x s r hs hr h)

theorem not_infinite_of_exists_st {x : ℝ*} : (∃ (r : ℝ), is_st x r) → ¬infinite x := sorry

theorem is_st_Sup {x : ℝ*} (hni : ¬infinite x) : is_st x (Sup (set_of fun (y : ℝ) => ↑y < x)) :=
  sorry

theorem exists_st_of_not_infinite {x : ℝ*} (hni : ¬infinite x) : ∃ (r : ℝ), is_st x r :=
  Exists.intro (Sup (set_of fun (y : ℝ) => ↑y < x)) (is_st_Sup hni)

theorem st_eq_Sup {x : ℝ*} : st x = Sup (set_of fun (y : ℝ) => ↑y < x) := sorry

theorem exists_st_iff_not_infinite {x : ℝ*} : (∃ (r : ℝ), is_st x r) ↔ ¬infinite x :=
  { mp := not_infinite_of_exists_st, mpr := exists_st_of_not_infinite }

theorem infinite_iff_not_exists_st {x : ℝ*} : infinite x ↔ ¬∃ (r : ℝ), is_st x r :=
  iff.mp iff_not_comm exists_st_iff_not_infinite

theorem st_infinite {x : ℝ*} (hi : infinite x) : st x = 0 := sorry

theorem st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : st x = r := sorry

theorem is_st_st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st x (st x) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_st x (st x))) (st_of_is_st hxr))) hxr

theorem is_st_st_of_exists_st {x : ℝ*} (hx : ∃ (r : ℝ), is_st x r) : is_st x (st x) :=
  Exists.dcases_on hx fun (r : ℝ) => is_st_st_of_is_st

theorem is_st_st {x : ℝ*} (hx : st x ≠ 0) : is_st x (st x) := sorry

theorem is_st_st' {x : ℝ*} (hx : ¬infinite x) : is_st x (st x) :=
  is_st_st_of_exists_st (exists_st_of_not_infinite hx)

theorem is_st_refl_real (r : ℝ) : is_st (↑r) r :=
  fun (δ : ℝ) (hδ : 0 < δ) =>
    { left := sub_lt_self (↑r) (iff.mpr coe_lt_coe hδ),
      right := lt_add_of_pos_right (↑r) (iff.mpr coe_lt_coe hδ) }

theorem st_id_real (r : ℝ) : st ↑r = r := st_of_is_st (is_st_refl_real r)

theorem eq_of_is_st_real {r : ℝ} {s : ℝ} : is_st (↑r) s → r = s := is_st_unique (is_st_refl_real r)

theorem is_st_real_iff_eq {r : ℝ} {s : ℝ} : is_st (↑r) s ↔ r = s :=
  { mp := eq_of_is_st_real,
    mpr :=
      fun (hrs : r = s) =>
        eq.mpr (id (Eq._oldrec (Eq.refl (is_st (↑r) s)) hrs)) (is_st_refl_real s) }

theorem is_st_symm_real {r : ℝ} {s : ℝ} : is_st (↑r) s ↔ is_st (↑s) r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_st (↑r) s ↔ is_st (↑s) r)) (propext is_st_real_iff_eq)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (r = s ↔ is_st (↑s) r)) (propext is_st_real_iff_eq)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r = s ↔ s = r)) (propext eq_comm))) (iff.refl (s = r))))

theorem is_st_trans_real {r : ℝ} {s : ℝ} {t : ℝ} : is_st (↑r) s → is_st (↑s) t → is_st (↑r) t :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (is_st (↑r) s → is_st (↑s) t → is_st (↑r) t))
        (propext is_st_real_iff_eq)))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (r = s → is_st (↑s) t → is_st (↑r) t)) (propext is_st_real_iff_eq)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r = s → s = t → is_st (↑r) t)) (propext is_st_real_iff_eq)))
        Eq.trans))

theorem is_st_inj_real {r₁ : ℝ} {r₂ : ℝ} {s : ℝ} (h1 : is_st (↑r₁) s) (h2 : is_st (↑r₂) s) :
    r₁ = r₂ :=
  Eq.trans (eq_of_is_st_real h1) (Eq.symm (eq_of_is_st_real h2))

theorem is_st_iff_abs_sub_lt_delta {x : ℝ*} {r : ℝ} :
    is_st x r ↔ ∀ (δ : ℝ), 0 < δ → abs (x - ↑r) < ↑δ :=
  sorry

theorem is_st_add {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} :
    is_st x r → is_st y s → is_st (x + y) (r + s) :=
  sorry

theorem is_st_neg {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st (-x) (-r) := sorry

theorem is_st_sub {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} :
    is_st x r → is_st y s → is_st (x - y) (r - s) :=
  fun (hxr : is_st x r) (hys : is_st y s) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (is_st (x - y) (r - s))) (sub_eq_add_neg x y)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (is_st (x + -y) (r - s))) (sub_eq_add_neg r s)))
        (is_st_add hxr (is_st_neg hys)))

/- (st x < st y) → (x < y) → (x ≤ y) → (st x ≤ st y) -/

theorem lt_of_is_st_lt {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hxr : is_st x r) (hys : is_st y s) :
    r < s → x < y :=
  sorry

theorem is_st_le_of_le {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hrx : is_st x r) (hsy : is_st y s) :
    x ≤ y → r ≤ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x ≤ y → r ≤ s)) (Eq.symm (propext not_lt))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (¬y < x → r ≤ s)) (Eq.symm (propext not_lt))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (¬y < x → ¬s < r)) (propext not_imp_not)))
        (lt_of_is_st_lt hsy hrx)))

theorem st_le_of_le {x : ℝ*} {y : ℝ*} (hix : ¬infinite x) (hiy : ¬infinite y) :
    x ≤ y → st x ≤ st y :=
  (fun (hx' : is_st x (st x)) =>
      (fun (hy' : is_st y (st y)) => is_st_le_of_le hx' hy') (is_st_st' hiy))
    (is_st_st' hix)

theorem lt_of_st_lt {x : ℝ*} {y : ℝ*} (hix : ¬infinite x) (hiy : ¬infinite y) :
    st x < st y → x < y :=
  (fun (hx' : is_st x (st x)) =>
      (fun (hy' : is_st y (st y)) => lt_of_is_st_lt hx' hy') (is_st_st' hiy))
    (is_st_st' hix)

/-!
### Basic lemmas about infinite
-/

theorem infinite_pos_def {x : ℝ*} : infinite_pos x ↔ ∀ (r : ℝ), ↑r < x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos x ↔ ∀ (r : ℝ), ↑r < x)) iff_eq_eq))
    (Eq.refl (infinite_pos x))

theorem infinite_neg_def {x : ℝ*} : infinite_neg x ↔ ∀ (r : ℝ), x < ↑r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg x ↔ ∀ (r : ℝ), x < ↑r)) iff_eq_eq))
    (Eq.refl (infinite_neg x))

theorem ne_zero_of_infinite {x : ℝ*} : infinite x → x ≠ 0 := sorry

theorem not_infinite_zero : ¬infinite 0 := fun (hI : infinite 0) => ne_zero_of_infinite hI rfl

theorem pos_of_infinite_pos {x : ℝ*} : infinite_pos x → 0 < x := fun (hip : infinite_pos x) => hip 0

theorem neg_of_infinite_neg {x : ℝ*} : infinite_neg x → x < 0 := fun (hin : infinite_neg x) => hin 0

theorem not_infinite_pos_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬infinite_pos x :=
  fun (hn : infinite_neg x) (hp : infinite_pos x) => not_lt_of_lt (hn 1) (hp 1)

theorem not_infinite_neg_of_infinite_pos {x : ℝ*} : infinite_pos x → ¬infinite_neg x :=
  iff.mp imp_not_comm not_infinite_pos_of_infinite_neg

theorem infinite_neg_neg_of_infinite_pos {x : ℝ*} : infinite_pos x → infinite_neg (-x) :=
  fun (hp : infinite_pos x) (r : ℝ) => iff.mp neg_lt (hp (-r))

theorem infinite_pos_neg_of_infinite_neg {x : ℝ*} : infinite_neg x → infinite_pos (-x) :=
  fun (hp : infinite_neg x) (r : ℝ) => iff.mp lt_neg (hp (-r))

theorem infinite_pos_iff_infinite_neg_neg {x : ℝ*} : infinite_pos x ↔ infinite_neg (-x) :=
  { mp := infinite_neg_neg_of_infinite_pos,
    mpr := fun (hin : infinite_neg (-x)) => neg_neg x ▸ infinite_pos_neg_of_infinite_neg hin }

theorem infinite_neg_iff_infinite_pos_neg {x : ℝ*} : infinite_neg x ↔ infinite_pos (-x) :=
  { mp := infinite_pos_neg_of_infinite_neg,
    mpr := fun (hin : infinite_pos (-x)) => neg_neg x ▸ infinite_neg_neg_of_infinite_pos hin }

theorem infinite_iff_infinite_neg {x : ℝ*} : infinite x ↔ infinite (-x) := sorry

theorem not_infinite_of_infinitesimal {x : ℝ*} : infinitesimal x → ¬infinite x := sorry

theorem not_infinitesimal_of_infinite {x : ℝ*} : infinite x → ¬infinitesimal x :=
  iff.mp imp_not_comm not_infinite_of_infinitesimal

theorem not_infinitesimal_of_infinite_pos {x : ℝ*} : infinite_pos x → ¬infinitesimal x :=
  fun (hp : infinite_pos x) => not_infinitesimal_of_infinite (Or.inl hp)

theorem not_infinitesimal_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬infinitesimal x :=
  fun (hn : infinite_neg x) => not_infinitesimal_of_infinite (Or.inr hn)

theorem infinite_pos_iff_infinite_and_pos {x : ℝ*} : infinite_pos x ↔ infinite x ∧ 0 < x := sorry

theorem infinite_neg_iff_infinite_and_neg {x : ℝ*} : infinite_neg x ↔ infinite x ∧ x < 0 := sorry

theorem infinite_pos_iff_infinite_of_pos {x : ℝ*} (hp : 0 < x) : infinite_pos x ↔ infinite x :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (infinite_pos x ↔ infinite x))
        (propext infinite_pos_iff_infinite_and_pos)))
    { mp := fun (hI : infinite x ∧ 0 < x) => and.left hI,
      mpr := fun (hI : infinite x) => { left := hI, right := hp } }

theorem infinite_pos_iff_infinite_of_nonneg {x : ℝ*} (hp : 0 ≤ x) : infinite_pos x ↔ infinite x :=
  sorry

theorem infinite_neg_iff_infinite_of_neg {x : ℝ*} (hn : x < 0) : infinite_neg x ↔ infinite x :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (infinite_neg x ↔ infinite x))
        (propext infinite_neg_iff_infinite_and_neg)))
    { mp := fun (hI : infinite x ∧ x < 0) => and.left hI,
      mpr := fun (hI : infinite x) => { left := hI, right := hn } }

theorem infinite_pos_abs_iff_infinite_abs {x : ℝ*} : infinite_pos (abs x) ↔ infinite (abs x) :=
  infinite_pos_iff_infinite_of_nonneg (abs_nonneg x)

theorem infinite_iff_infinite_pos_abs {x : ℝ*} : infinite x ↔ infinite_pos (abs x) := sorry

theorem infinite_iff_infinite_abs {x : ℝ*} : infinite x ↔ infinite (abs x) := sorry

theorem infinite_iff_abs_lt_abs {x : ℝ*} : infinite x ↔ ∀ (r : ℝ), abs ↑r < abs x := sorry

theorem infinite_pos_add_not_infinite_neg {x : ℝ*} {y : ℝ*} :
    infinite_pos x → ¬infinite_neg y → infinite_pos (x + y) :=
  sorry

theorem not_infinite_neg_add_infinite_pos {x : ℝ*} {y : ℝ*} :
    ¬infinite_neg x → infinite_pos y → infinite_pos (x + y) :=
  fun (hx : ¬infinite_neg x) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x + y))) (add_comm x y)))
      (infinite_pos_add_not_infinite_neg hy hx)

theorem infinite_neg_add_not_infinite_pos {x : ℝ*} {y : ℝ*} :
    infinite_neg x → ¬infinite_pos y → infinite_neg (x + y) :=
  sorry

theorem not_infinite_pos_add_infinite_neg {x : ℝ*} {y : ℝ*} :
    ¬infinite_pos x → infinite_neg y → infinite_neg (x + y) :=
  fun (hx : ¬infinite_pos x) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x + y))) (add_comm x y)))
      (infinite_neg_add_not_infinite_pos hy hx)

theorem infinite_pos_add_infinite_pos {x : ℝ*} {y : ℝ*} :
    infinite_pos x → infinite_pos y → infinite_pos (x + y) :=
  fun (hx : infinite_pos x) (hy : infinite_pos y) =>
    infinite_pos_add_not_infinite_neg hx (not_infinite_neg_of_infinite_pos hy)

theorem infinite_neg_add_infinite_neg {x : ℝ*} {y : ℝ*} :
    infinite_neg x → infinite_neg y → infinite_neg (x + y) :=
  fun (hx : infinite_neg x) (hy : infinite_neg y) =>
    infinite_neg_add_not_infinite_pos hx (not_infinite_pos_of_infinite_neg hy)

theorem infinite_pos_add_not_infinite {x : ℝ*} {y : ℝ*} :
    infinite_pos x → ¬infinite y → infinite_pos (x + y) :=
  fun (hx : infinite_pos x) (hy : ¬infinite y) =>
    infinite_pos_add_not_infinite_neg hx (and.right (iff.mp not_or_distrib hy))

theorem infinite_neg_add_not_infinite {x : ℝ*} {y : ℝ*} :
    infinite_neg x → ¬infinite y → infinite_neg (x + y) :=
  fun (hx : infinite_neg x) (hy : ¬infinite y) =>
    infinite_neg_add_not_infinite_pos hx (and.left (iff.mp not_or_distrib hy))

theorem infinite_pos_of_tendsto_top {f : ℕ → ℝ}
    (hf : filter.tendsto f filter.at_top filter.at_top) : infinite_pos (of_seq f) :=
  sorry

theorem infinite_neg_of_tendsto_bot {f : ℕ → ℝ}
    (hf : filter.tendsto f filter.at_top filter.at_bot) : infinite_neg (of_seq f) :=
  sorry

theorem not_infinite_neg {x : ℝ*} : ¬infinite x → ¬infinite (-x) :=
  iff.mpr not_imp_not (iff.mpr infinite_iff_infinite_neg)

theorem not_infinite_add {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) :
    ¬infinite (x + y) :=
  sorry

theorem not_infinite_iff_exist_lt_gt {x : ℝ*} :
    ¬infinite x ↔ ∃ (r : ℝ), ∃ (s : ℝ), ↑r < x ∧ x < ↑s :=
  sorry

theorem not_infinite_real (r : ℝ) : ¬infinite ↑r :=
  eq.mpr (id (Eq._oldrec (Eq.refl (¬infinite ↑r)) (propext not_infinite_iff_exist_lt_gt)))
    (Exists.intro (r - 1)
      (Exists.intro (r + 1)
        { left := iff.mpr coe_lt_coe (sub_one_lt r), right := iff.mpr coe_lt_coe (lt_add_one r) }))

theorem not_real_of_infinite {x : ℝ*} : infinite x → ∀ (r : ℝ), x ≠ ↑r :=
  fun (hi : infinite x) (r : ℝ) (hr : x = ↑r) => not_infinite_real r (hr ▸ hi)

/-!
### Facts about `st` that require some infinite machinery
-/

theorem is_st_mul {x : ℝ*} {y : ℝ*} {r : ℝ} {s : ℝ} (hxr : is_st x r) (hys : is_st y s) :
    is_st (x * y) (r * s) :=
  sorry

--AN INFINITE LEMMA THAT REQUIRES SOME MORE ST MACHINERY

theorem not_infinite_mul {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) :
    ¬infinite (x * y) :=
  sorry

---

theorem st_add {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x + y) = st x + st y :=
  sorry

theorem st_neg (x : ℝ*) : st (-x) = -st x := sorry

theorem st_mul {x : ℝ*} {y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x * y) = st x * st y :=
  sorry

/-!
### Basic lemmas about infinitesimal
-/

theorem infinitesimal_def {x : ℝ*} : infinitesimal x ↔ ∀ (r : ℝ), 0 < r → -↑r < x ∧ x < ↑r := sorry

theorem lt_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), 0 < r → x < ↑r :=
  fun (hi : infinitesimal x) (r : ℝ) (hr : 0 < r) => and.right (iff.mp infinitesimal_def hi r hr)

theorem lt_neg_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), 0 < r → -↑r < x :=
  fun (hi : infinitesimal x) (r : ℝ) (hr : 0 < r) => and.left (iff.mp infinitesimal_def hi r hr)

theorem gt_of_neg_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ (r : ℝ), r < 0 → ↑r < x := sorry

theorem abs_lt_real_iff_infinitesimal {x : ℝ*} :
    infinitesimal x ↔ ∀ (r : ℝ), r ≠ 0 → abs x < abs ↑r :=
  sorry

theorem infinitesimal_zero : infinitesimal 0 := is_st_refl_real 0

theorem zero_of_infinitesimal_real {r : ℝ} : infinitesimal ↑r → r = 0 := eq_of_is_st_real

theorem zero_iff_infinitesimal_real {r : ℝ} : infinitesimal ↑r ↔ r = 0 :=
  { mp := zero_of_infinitesimal_real,
    mpr :=
      fun (hr : r = 0) =>
        eq.mpr (id (Eq._oldrec (Eq.refl (infinitesimal ↑r)) hr)) infinitesimal_zero }

theorem infinitesimal_add {x : ℝ*} {y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) :
    infinitesimal (x + y) :=
  sorry

theorem infinitesimal_neg {x : ℝ*} (hx : infinitesimal x) : infinitesimal (-x) := sorry

theorem infinitesimal_neg_iff {x : ℝ*} : infinitesimal x ↔ infinitesimal (-x) :=
  { mp := infinitesimal_neg,
    mpr := fun (h : infinitesimal (-x)) => neg_neg x ▸ infinitesimal_neg h }

theorem infinitesimal_mul {x : ℝ*} {y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) :
    infinitesimal (x * y) :=
  sorry

theorem infinitesimal_of_tendsto_zero {f : ℕ → ℝ} :
    filter.tendsto f filter.at_top (nhds 0) → infinitesimal (of_seq f) :=
  sorry

theorem infinitesimal_epsilon : infinitesimal epsilon :=
  infinitesimal_of_tendsto_zero tendsto_inverse_at_top_nhds_0_nat

theorem not_real_of_infinitesimal_ne_zero (x : ℝ*) : infinitesimal x → x ≠ 0 → ∀ (r : ℝ), x ≠ ↑r :=
  fun (hi : infinitesimal x) (hx : x ≠ 0) (r : ℝ) (hr : x = ↑r) =>
    hx (Eq.trans hr (iff.mpr coe_eq_zero (is_st_unique (Eq.symm hr ▸ is_st_refl_real r) hi)))

theorem infinitesimal_sub_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : infinitesimal (x - ↑r) := sorry

theorem infinitesimal_sub_st {x : ℝ*} (hx : ¬infinite x) : infinitesimal (x - ↑(st x)) :=
  infinitesimal_sub_is_st (is_st_st' hx)

theorem infinite_pos_iff_infinitesimal_inv_pos {x : ℝ*} :
    infinite_pos x ↔ infinitesimal (x⁻¹) ∧ 0 < (x⁻¹) :=
  sorry

theorem infinite_neg_iff_infinitesimal_inv_neg {x : ℝ*} :
    infinite_neg x ↔ infinitesimal (x⁻¹) ∧ x⁻¹ < 0 :=
  sorry

theorem infinitesimal_inv_of_infinite {x : ℝ*} : infinite x → infinitesimal (x⁻¹) :=
  fun (hi : infinite x) =>
    or.cases_on hi
      (fun (hip : infinite_pos x) => and.left (iff.mp infinite_pos_iff_infinitesimal_inv_pos hip))
      fun (hin : infinite_neg x) => and.left (iff.mp infinite_neg_iff_infinitesimal_inv_neg hin)

theorem infinite_of_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) (hi : infinitesimal (x⁻¹)) :
    infinite x :=
  sorry

theorem infinite_iff_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) : infinite x ↔ infinitesimal (x⁻¹) :=
  { mp := infinitesimal_inv_of_infinite, mpr := infinite_of_infinitesimal_inv h0 }

theorem infinitesimal_pos_iff_infinite_pos_inv {x : ℝ*} :
    infinite_pos (x⁻¹) ↔ infinitesimal x ∧ 0 < x :=
  sorry

theorem infinitesimal_neg_iff_infinite_neg_inv {x : ℝ*} :
    infinite_neg (x⁻¹) ↔ infinitesimal x ∧ x < 0 :=
  sorry

theorem infinitesimal_iff_infinite_inv {x : ℝ*} (h : x ≠ 0) : infinitesimal x ↔ infinite (x⁻¹) :=
  sorry

/-!
### `st` stuff that requires infinitesimal machinery
-/

theorem is_st_of_tendsto {f : ℕ → ℝ} {r : ℝ} (hf : filter.tendsto f filter.at_top (nhds r)) :
    is_st (of_seq f) r :=
  sorry

theorem is_st_inv {x : ℝ*} {r : ℝ} (hi : ¬infinitesimal x) : is_st x r → is_st (x⁻¹) (r⁻¹) := sorry

theorem st_inv (x : ℝ*) : st (x⁻¹) = (st x⁻¹) := sorry

/-!
### Infinite stuff that requires infinitesimal machinery
-/

theorem infinite_pos_omega : infinite_pos omega :=
  iff.mpr infinite_pos_iff_infinitesimal_inv_pos
    { left := infinitesimal_epsilon, right := epsilon_pos }

theorem infinite_omega : infinite omega :=
  iff.mpr (infinite_iff_infinitesimal_inv omega_ne_zero) infinitesimal_epsilon

theorem infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos {x : ℝ*} {y : ℝ*} :
    infinite_pos x → ¬infinitesimal y → 0 < y → infinite_pos (x * y) :=
  sorry

theorem infinite_pos_mul_of_not_infinitesimal_pos_infinite_pos {x : ℝ*} {y : ℝ*} :
    ¬infinitesimal x → 0 < x → infinite_pos y → infinite_pos (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : 0 < x) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x * y))) (mul_comm x y)))
      (infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hy hx hp)

theorem infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg {x : ℝ*} {y : ℝ*} :
    infinite_neg x → ¬infinitesimal y → y < 0 → infinite_pos (x * y) :=
  sorry

theorem infinite_pos_mul_of_not_infinitesimal_neg_infinite_neg {x : ℝ*} {y : ℝ*} :
    ¬infinitesimal x → x < 0 → infinite_neg y → infinite_pos (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : x < 0) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_pos (x * y))) (mul_comm x y)))
      (infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hy hx hp)

theorem infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg {x : ℝ*} {y : ℝ*} :
    infinite_pos x → ¬infinitesimal y → y < 0 → infinite_neg (x * y) :=
  sorry

theorem infinite_neg_mul_of_not_infinitesimal_neg_infinite_pos {x : ℝ*} {y : ℝ*} :
    ¬infinitesimal x → x < 0 → infinite_pos y → infinite_neg (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : x < 0) (hy : infinite_pos y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x * y))) (mul_comm x y)))
      (infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hy hx hp)

theorem infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos {x : ℝ*} {y : ℝ*} :
    infinite_neg x → ¬infinitesimal y → 0 < y → infinite_neg (x * y) :=
  sorry

theorem infinite_neg_mul_of_not_infinitesimal_pos_infinite_neg {x : ℝ*} {y : ℝ*} :
    ¬infinitesimal x → 0 < x → infinite_neg y → infinite_neg (x * y) :=
  fun (hx : ¬infinitesimal x) (hp : 0 < x) (hy : infinite_neg y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite_neg (x * y))) (mul_comm x y)))
      (infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hy hx hp)

theorem infinite_pos_mul_infinite_pos {x : ℝ*} {y : ℝ*} :
    infinite_pos x → infinite_pos y → infinite_pos (x * y) :=
  fun (hx : infinite_pos x) (hy : infinite_pos y) =>
    infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hx (not_infinitesimal_of_infinite_pos hy)
      (hy 0)

theorem infinite_neg_mul_infinite_neg {x : ℝ*} {y : ℝ*} :
    infinite_neg x → infinite_neg y → infinite_pos (x * y) :=
  fun (hx : infinite_neg x) (hy : infinite_neg y) =>
    infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hx (not_infinitesimal_of_infinite_neg hy)
      (hy 0)

theorem infinite_pos_mul_infinite_neg {x : ℝ*} {y : ℝ*} :
    infinite_pos x → infinite_neg y → infinite_neg (x * y) :=
  fun (hx : infinite_pos x) (hy : infinite_neg y) =>
    infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hx (not_infinitesimal_of_infinite_neg hy)
      (hy 0)

theorem infinite_neg_mul_infinite_pos {x : ℝ*} {y : ℝ*} :
    infinite_neg x → infinite_pos y → infinite_neg (x * y) :=
  fun (hx : infinite_neg x) (hy : infinite_pos y) =>
    infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hx (not_infinitesimal_of_infinite_pos hy)
      (hy 0)

theorem infinite_mul_of_infinite_not_infinitesimal {x : ℝ*} {y : ℝ*} :
    infinite x → ¬infinitesimal y → infinite (x * y) :=
  sorry

theorem infinite_mul_of_not_infinitesimal_infinite {x : ℝ*} {y : ℝ*} :
    ¬infinitesimal x → infinite y → infinite (x * y) :=
  fun (hx : ¬infinitesimal x) (hy : infinite y) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (infinite (x * y))) (mul_comm x y)))
      (infinite_mul_of_infinite_not_infinitesimal hy hx)

theorem infinite_mul_infinite {x : ℝ*} {y : ℝ*} : infinite x → infinite y → infinite (x * y) :=
  fun (hx : infinite x) (hy : infinite y) =>
    infinite_mul_of_infinite_not_infinitesimal hx (not_infinitesimal_of_infinite hy)

end Mathlib


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import topology.constructions
import topology.algebra.monoid
/-!
# Topology on lists and vectors

-/
open topological_space set filter
open_locale topological_space filter

variables {α : Type*} {β : Type*} [topological_space α] [topological_space β]

instance : topological_space (list α) :=
topological_space.mk_of_nhds (traverse nhds)

lemma nhds_list (as : list α) : 𝓝 as = traverse 𝓝 as :=
begin
  refine nhds_mk_of_nhds _ _ _ _,
  { assume l, induction l,
    case list.nil { exact le_refl _ },
    case list.cons : a l ih
    { suffices : list.cons <$> pure a <*> pure l ≤ list.cons <$> 𝓝 a <*> traverse 𝓝 l,
      { simpa only [] with functor_norm using this },
      exact filter.seq_mono (filter.map_mono $ pure_le_nhds a) ih } },
  { assume l s hs,
    rcases (mem_traverse_iff _ _).1 hs with ⟨u, hu, hus⟩, clear as hs,
    have : ∃v:list (set α), l.forall₂ (λa s, is_open s ∧ a ∈ s) v ∧ sequence v ⊆ s,
    { induction hu generalizing s,
      case list.forall₂.nil : hs this
        { existsi [], simpa only [list.forall₂_nil_left_iff, exists_eq_left] },
      case list.forall₂.cons : a s as ss ht h ih t hts
      { rcases mem_nhds_iff.1 ht with ⟨u, hut, hu⟩,
        rcases ih (subset.refl _) with ⟨v, hv, hvss⟩,
        exact ⟨u::v, list.forall₂.cons hu hv,
          subset.trans (set.seq_mono (set.image_subset _ hut) hvss) hts⟩ } },
    rcases this with ⟨v, hv, hvs⟩,
    refine ⟨sequence v, mem_traverse _ _ _, hvs, _⟩,
    { exact hv.imp (assume a s ⟨hs, ha⟩, is_open.mem_nhds hs ha) },
    { assume u hu,
      have hu := (list.mem_traverse _ _).1 hu,
      have : list.forall₂ (λa s, is_open s ∧ a ∈ s) u v,
      { refine list.forall₂.flip _,
        replace hv := hv.flip,
        simp only [list.forall₂_and_left, flip] at ⊢ hv,
        exact ⟨hv.1, hu.flip⟩ },
      refine mem_of_superset _ hvs,
      exact mem_traverse _ _ (this.imp $ assume a s ⟨hs, ha⟩, is_open.mem_nhds hs ha) } }
end

@[simp] lemma nhds_nil : 𝓝 ([] : list α) = pure [] :=
by rw [nhds_list, list.traverse_nil _]; apply_instance

lemma nhds_cons (a : α) (l : list α) :
  𝓝 (a :: l) = list.cons <$> 𝓝 a <*> 𝓝 l  :=
by rw [nhds_list, list.traverse_cons _, ← nhds_list]; apply_instance

lemma list.tendsto_cons {a : α} {l : list α} :
  tendsto (λp:α×list α, list.cons p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (a :: l)) :=
by rw [nhds_cons, tendsto, map_prod]; exact le_refl _

lemma filter.tendsto.cons {α : Type*} {f : α → β} {g : α → list β}
  {a : _root_.filter α} {b : β} {l : list β} (hf : tendsto f a (𝓝 b)) (hg : tendsto g a (𝓝 l)) :
  tendsto (λa, list.cons (f a) (g a)) a (𝓝 (b :: l)) :=
list.tendsto_cons.comp (tendsto.prod_mk hf hg)

namespace list

lemma tendsto_cons_iff {β : Type*} {f : list α → β} {b : _root_.filter β} {a : α} {l : list α} :
  tendsto f (𝓝 (a :: l)) b ↔ tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) b :=
have 𝓝 (a :: l) = (𝓝 a ×ᶠ 𝓝 l).map (λp:α×list α, (p.1 :: p.2)),
begin
  simp only
    [nhds_cons, filter.prod_eq, (filter.map_def _ _).symm, (filter.seq_eq_filter_seq _ _).symm],
  simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm,
end,
by rw [this, filter.tendsto_map'_iff]

lemma continuous_cons : continuous (λ x : α × list α, (x.1 :: x.2 : list α)) :=
continuous_iff_continuous_at.mpr $ λ ⟨x, y⟩, continuous_at_fst.cons continuous_at_snd

lemma tendsto_nhds {β : Type*} {f : list α → β} {r : list α → _root_.filter β}
  (h_nil : tendsto f (pure []) (r []))
  (h_cons : ∀l a, tendsto f (𝓝 l) (r l) →
    tendsto (λp:α×list α, f (p.1 :: p.2)) (𝓝 a ×ᶠ 𝓝 l) (r (a::l))) :
  ∀l, tendsto f (𝓝 l) (r l)
| []     := by rwa [nhds_nil]
| (a::l) := by rw [tendsto_cons_iff]; exact h_cons l a (tendsto_nhds l)

lemma continuous_at_length :
  ∀(l : list α), continuous_at list.length l :=
begin
  simp only [continuous_at, nhds_discrete],
  refine tendsto_nhds _ _,
  { exact tendsto_pure_pure _ _ },
  { assume l a ih,
    dsimp only [list.length],
    refine tendsto.comp (tendsto_pure_pure (λx, x + 1) _) _,
    refine tendsto.comp ih tendsto_snd }
end

lemma tendsto_insert_nth' {a : α} : ∀{n : ℕ} {l : list α},
  tendsto (λp:α×list α, insert_nth n p.1 p.2) (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth n a l))
| 0     l  := tendsto_cons
| (n+1) [] := by simp
| (n+1) (a'::l) :=
  have 𝓝 a ×ᶠ 𝓝 (a' :: l) =
    (𝓝 a ×ᶠ (𝓝 a' ×ᶠ 𝓝 l)).map (λp:α×α×list α, (p.1, p.2.1 :: p.2.2)),
  begin
    simp only [nhds_cons, filter.prod_eq, ← filter.map_def, ← filter.seq_eq_filter_seq],
    simp [-filter.seq_eq_filter_seq, -filter.map_def, (∘)] with functor_norm
  end,
  begin
    rw [this, tendsto_map'_iff],
    exact (tendsto_fst.comp tendsto_snd).cons
      ((@tendsto_insert_nth' n l).comp $ tendsto_fst.prod_mk $ tendsto_snd.comp tendsto_snd)
  end

lemma tendsto_insert_nth {β} {n : ℕ} {a : α} {l : list α} {f : β → α} {g : β → list α}
  {b : _root_.filter β} (hf : tendsto f b (𝓝 a)) (hg : tendsto g b (𝓝 l)) :
  tendsto (λb:β, insert_nth n (f b) (g b)) b (𝓝 (insert_nth n a l)) :=
tendsto_insert_nth'.comp (tendsto.prod_mk hf hg)

lemma continuous_insert_nth {n : ℕ} : continuous (λp:α×list α, insert_nth n p.1 p.2) :=
continuous_iff_continuous_at.mpr $
  assume ⟨a, l⟩, by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth'

lemma tendsto_remove_nth : ∀{n : ℕ} {l : list α},
  tendsto (λl, remove_nth l n) (𝓝 l) (𝓝 (remove_nth l n))
| _ []      := by rw [nhds_nil]; exact tendsto_pure_nhds _ _
| 0 (a::l) := by rw [tendsto_cons_iff]; exact tendsto_snd
| (n+1) (a::l) :=
  begin
    rw [tendsto_cons_iff],
    dsimp [remove_nth],
    exact tendsto_fst.cons ((@tendsto_remove_nth n l).comp tendsto_snd)
  end

lemma continuous_remove_nth {n : ℕ} : continuous (λl : list α, remove_nth l n) :=
continuous_iff_continuous_at.mpr $ assume a, tendsto_remove_nth

@[to_additive]
lemma tendsto_prod [monoid α] [has_continuous_mul α] {l : list α} :
  tendsto list.prod (𝓝 l) (𝓝 l.prod) :=
begin
  induction l with x l ih,
  { simp [nhds_nil, mem_of_mem_nhds, tendsto_pure_left] {contextual := tt} },
  simp_rw [tendsto_cons_iff, prod_cons],
  have := continuous_iff_continuous_at.mp continuous_mul (x, l.prod),
  rw [continuous_at, nhds_prod_eq] at this,
  exact this.comp (tendsto_id.prod_map ih)
end

@[to_additive]
lemma continuous_prod [monoid α] [has_continuous_mul α] : continuous (prod : list α → α) :=
continuous_iff_continuous_at.mpr $ λ l, tendsto_prod

end list

namespace vector
open list

instance (n : ℕ) : topological_space (vector α n) :=
by unfold vector; apply_instance

lemma tendsto_insert_nth
  {n : ℕ} {i : fin (n+1)} {a:α} :
  ∀{l:vector α n}, tendsto (λp:α×vector α n, insert_nth p.1 i p.2)
    (𝓝 a ×ᶠ 𝓝 l) (𝓝 (insert_nth a i l))
| ⟨l, hl⟩ :=
begin
  rw [insert_nth, tendsto_subtype_rng],
  simp [insert_nth_val],
  exact list.tendsto_insert_nth tendsto_fst (tendsto.comp continuous_at_subtype_coe tendsto_snd : _)
end

lemma continuous_insert_nth' {n : ℕ} {i : fin (n+1)} :
  continuous (λp:α×vector α n, insert_nth p.1 i p.2) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩,
  by rw [continuous_at, nhds_prod_eq]; exact tendsto_insert_nth

lemma continuous_insert_nth {n : ℕ} {i : fin (n+1)}
  {f : β → α} {g : β → vector α n} (hf : continuous f) (hg : continuous g) :
  continuous (λb, insert_nth (f b) i (g b)) :=
continuous_insert_nth'.comp (hf.prod_mk hg : _)

lemma continuous_at_remove_nth {n : ℕ} {i : fin (n+1)} :
  ∀{l:vector α (n+1)}, continuous_at (remove_nth i) l
| ⟨l, hl⟩ :=
--  ∀{l:vector α (n+1)}, tendsto (remove_nth i) (𝓝 l) (𝓝 (remove_nth i l))
--| ⟨l, hl⟩ :=
begin
  rw [continuous_at, remove_nth, tendsto_subtype_rng],
  simp only [← subtype.val_eq_coe, vector.remove_nth_val],
  exact tendsto.comp list.tendsto_remove_nth continuous_at_subtype_coe,
end

lemma continuous_remove_nth {n : ℕ} {i : fin (n+1)} :
  continuous (remove_nth i : vector α (n+1) → vector α n) :=
continuous_iff_continuous_at.mpr $ assume ⟨a, l⟩, continuous_at_remove_nth

end vector


import definitions tactic.linarith tactic.omega
set_option pp.generalized_field_notation false

universe u

open btree

variables {α : Type u}

/- # Simple reflexive lemmas # -/

/- If we lookup empty btree then return none -/
lemma lookup_empty (k : nat) :
  lookup k (@empty_tree α) = none := by refl

/- If you check if a key is bound on an empty tree, bound will return false -/
lemma bound_empty (k : nat) :
  bound k (@empty_tree α) = ff := by refl

/- If you insert into an empty tree, then you just have one node -/
lemma insert_empty (k : nat) (v : α) :
  insert k v (@empty_tree α) = btree.node btree.empty k v btree.empty := by refl

/- # Bound and lookup correctness # -/

/- If bound returns false, then the key is not in the tree therefore
  The lookup will return none -/
lemma bound_false (k : nat) (t : btree α) :
  bound k t = ff → lookup k t = none :=
begin
  intro h₁,
  induction t,
  case empty {
    apply refl,
  },
  case node : tl tk ta tr ihl ihr {
    simp [lookup],
    simp [bound] at h₁,
    by_cases c₁ : (k < tk),
    { simp only [if_pos c₁],
      apply ihl,
      apply and.left (and.right h₁),
    },
    { simp only [if_neg c₁],
      by_cases c₂ : (tk < k),
      { simp only [if_pos c₂],
        apply ihr,
        apply and.right (and.right h₁),
      },
      { simp only [if_neg c₂],
        cases_matching* (_ ∧ _),
        have h : k = tk := by linarith,
        have h₂ : k ≠ tk := by omega,
        contradiction,
      },
    },
  },
end

/- If a key is bound to a tree, then lookup will in result in some result -/
lemma bound_lookup (t : btree α) (k : nat) :
  ordered t → bound k t = tt → ∃ (v : α), lookup k t = some v :=
begin
  intros h₁ h₂,
  induction t,
  case empty {
    simp [bound] at h₂,
    contradiction,
  },
  case node : tl tk ta tr ihl ihr {
    rw ordered at h₁,
    cases_matching* (_ ∧ _),
    simp only [lookup],
    simp [bound] at h₂,
    by_cases c₁ : (k < tk),
    { simp only [if_pos c₁],
      apply ihl,
      { assumption, },
      { cases_matching* (_ ∨ _),
        { exfalso, linarith, },
        { assumption, },
        { unfold forall_keys at h₁_right_right_right,
          specialize h₁_right_right_right k h₂,
          exfalso, linarith,
        },
      },
    },
    { simp only [if_neg c₁],
      by_cases c₂ : (k > tk),
      { simp only [if_pos c₂],
        apply ihr,
        { assumption, },
        { cases_matching* (_ ∨ _),
          { exfalso, linarith, },
          { unfold forall_keys at h₁_right_right_left,
            specialize h₁_right_right_left k h₂,
            exfalso, linarith,
          },
          { assumption, },
        },
      },
      { simp only [if_neg c₂],
        existsi ta,
        refl,
      },
    },
  },
end


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

! This file was ported from Lean 3 source module category_theory.limits.constructions.pullbacks
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Shapes.Equalizers
import Mathbin.CategoryTheory.Limits.Shapes.Pullbacks

/-!
# Constructing pullbacks from binary products and equalizers

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

If a category as binary products and equalizers, then it has pullbacks.
Also, if a category has binary coproducts and coequalizers, then it has pushouts
-/

universe v u

open CategoryTheory

namespace CategoryTheory.Limits

#print CategoryTheory.Limits.hasLimit_cospan_of_hasLimit_pair_of_hasLimit_parallelPair /-
/-- If the product `X ⨯ Y` and the equalizer of `π₁ ≫ f` and `π₂ ≫ g` exist, then the
    pullback of `f` and `g` exists: It is given by composing the equalizer with the projections. -/
theorem hasLimit_cospan_of_hasLimit_pair_of_hasLimit_parallelPair {C : Type u} [𝒞 : Category.{v} C]
    {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [HasLimit (pair X Y)]
    [HasLimit (parallelPair (prod.fst ≫ f) (prod.snd ≫ g))] : HasLimit (cospan f g) :=
  let π₁ : X ⨯ Y ⟶ X := prod.fst
  let π₂ : X ⨯ Y ⟶ Y := prod.snd
  let e := equalizer.ι (π₁ ≫ f) (π₂ ≫ g)
  HasLimit.mk
    { Cone :=
        PullbackCone.mk (e ≫ π₁) (e ≫ π₂) <| by simp only [category.assoc, equalizer.condition]
      IsLimit :=
        PullbackCone.IsLimit.mk _
          (fun s =>
            equalizer.lift (prod.lift (s.π.app WalkingCospan.left) (s.π.app WalkingCospan.right)) <|
              by
              rw [← category.assoc, limit.lift_π, ← category.assoc, limit.lift_π] <;>
                exact pullback_cone.condition _)
          (by simp) (by simp) fun s m h₁ h₂ => by
          ext
          · simpa using h₁
          · simpa using h₂ }
#align category_theory.limits.has_limit_cospan_of_has_limit_pair_of_has_limit_parallel_pair CategoryTheory.Limits.hasLimit_cospan_of_hasLimit_pair_of_hasLimit_parallelPair
-/

section

attribute [local instance] has_limit_cospan_of_has_limit_pair_of_has_limit_parallel_pair

#print CategoryTheory.Limits.hasPullbacks_of_hasBinaryProducts_of_hasEqualizers /-
/-- If a category has all binary products and all equalizers, then it also has all pullbacks.
    As usual, this is not an instance, since there may be a more direct way to construct
    pullbacks. -/
theorem hasPullbacks_of_hasBinaryProducts_of_hasEqualizers (C : Type u) [𝒞 : Category.{v} C]
    [HasBinaryProducts C] [HasEqualizers C] : HasPullbacks C :=
  { HasLimit := fun F => hasLimitOfIso (diagramIsoCospan F).symm }
#align category_theory.limits.has_pullbacks_of_has_binary_products_of_has_equalizers CategoryTheory.Limits.hasPullbacks_of_hasBinaryProducts_of_hasEqualizers
-/

end

#print CategoryTheory.Limits.hasColimit_span_of_hasColimit_pair_of_hasColimit_parallelPair /-
/-- If the coproduct `Y ⨿ Z` and the coequalizer of `f ≫ ι₁` and `g ≫ ι₂` exist, then the
    pushout of `f` and `g` exists: It is given by composing the inclusions with the coequalizer. -/
theorem hasColimit_span_of_hasColimit_pair_of_hasColimit_parallelPair {C : Type u}
    [𝒞 : Category.{v} C] {X Y Z : C} (f : X ⟶ Y) (g : X ⟶ Z) [HasColimit (pair Y Z)]
    [HasColimit (parallelPair (f ≫ coprod.inl) (g ≫ coprod.inr))] : HasColimit (span f g) :=
  let ι₁ : Y ⟶ Y ⨿ Z := coprod.inl
  let ι₂ : Z ⟶ Y ⨿ Z := coprod.inr
  let c := coequalizer.π (f ≫ ι₁) (g ≫ ι₂)
  HasColimit.mk
    { Cocone :=
        PushoutCocone.mk (ι₁ ≫ c) (ι₂ ≫ c) <| by
          rw [← category.assoc, ← category.assoc, coequalizer.condition]
      IsColimit :=
        PushoutCocone.IsColimit.mk _
          (fun s =>
            coequalizer.desc (coprod.desc (s.ι.app WalkingSpan.left) (s.ι.app WalkingSpan.right)) <|
              by
              rw [category.assoc, colimit.ι_desc, category.assoc, colimit.ι_desc] <;>
                exact pushout_cocone.condition _)
          (by simp) (by simp) fun s m h₁ h₂ => by
          ext
          · simpa using h₁
          · simpa using h₂ }
#align category_theory.limits.has_colimit_span_of_has_colimit_pair_of_has_colimit_parallel_pair CategoryTheory.Limits.hasColimit_span_of_hasColimit_pair_of_hasColimit_parallelPair
-/

section

attribute [local instance] has_colimit_span_of_has_colimit_pair_of_has_colimit_parallel_pair

#print CategoryTheory.Limits.hasPushouts_of_hasBinaryCoproducts_of_hasCoequalizers /-
/-- If a category has all binary coproducts and all coequalizers, then it also has all pushouts.
    As usual, this is not an instance, since there may be a more direct way to construct
    pushouts. -/
theorem hasPushouts_of_hasBinaryCoproducts_of_hasCoequalizers (C : Type u) [𝒞 : Category.{v} C]
    [HasBinaryCoproducts C] [HasCoequalizers C] : HasPushouts C :=
  hasPushouts_of_hasColimit_span C
#align category_theory.limits.has_pushouts_of_has_binary_coproducts_of_has_coequalizers CategoryTheory.Limits.hasPushouts_of_hasBinaryCoproducts_of_hasCoequalizers
-/

end

end CategoryTheory.Limits


import tactic.solve_by_elim
import tactic.nth_rewrite
import tactic.show_term
import tactic.suggest

-- solve_by_elim find shortest proof using given lemmas?

open tactic

lemma ex1 (x y z : ℕ) : x + y + z = x + z + y :=
begin
  show_term { nth_rewrite 0 add_assoc, },
  -- nth_rewrite 0 add_assoc,
  -- show_term {solve_by_elim [add_comm, add_assoc, eq.mpr, eq.rec],},
  -- solve_by_elim try to depth first search and it's not optimal and long time search
  sorry,
end

example (n) : n < 1 → n = 0 := nat.sub_eq_zero_of_le

axiom lt_base (n : ℕ) : nat.lt n n.succ
axiom lt_branch (n m : ℕ) : n < m.succ → n < m ∨ n = m

example (n) : n < 2 → n = 0 ∨ n = 1 :=
begin
  assume h,
  have h₂ := (lt_branch n 1) h,
  cases h₂,
  swap,
  right; assumption,
  left,
  -- have h₃ := nat.sub_eq_zero_of_le h₂,
  -- exact h₃,
  show_term {
    solve_by_elim [nat.sub_eq_zero_of_le h₂] {max_depth := 1},
  },
end

example (n) : n < 2 → n = 0 ∨ n = 1 :=
begin
  assume h,
  have h₂ := (lt_branch n 1) h,
  cases h₂,
  swap,
  solve_by_elim [nat.sub_eq_zero_of_le, lt_base, lt_branch, or.inr],
  clear h,
  left,
  have h₃ : n < 1 → n = 0 := nat.sub_eq_zero_of_le,
  show_term {solve_by_elim [nat.sub_eq_zero_of_le, lt_base, lt_branch, or.inr, or.inl],} -- h₃ h₂
  -- nat.sub_eq_zero_of_le not works in solve_by_elim
  -- h₃ h₂
end

example (a b : Prop) : a → b → a :=
begin
  -- solve_by_elim, -- fails
  show_term { intros a b, exact a, },
end

example (a b : Prop) : a → b → a :=
begin
  -- source: tactics/equiv_rw.lean
  -- exact function.const b, -- OK
  -- exact imp_intro, -- OK
  solve_by_elim [function.const, imp_intro] {pre_apply := tactic.intros >> skip},
  -- solve_by_elim {pre_apply := try tactic.intros >> skip},
end

#print ex1

#print pnat