/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Std.Classes.LawfulMonad

/-!

# Subregular functors

We say a functor `f : Type u → Type v` is ***subregular*** if it preserves monomorphisms.
Under the existence of a subobject classifier (i.e. `Prop`), this is equivalent to the following: for each type `α : Type u` and each predicate `p : α → Prop`, the image `f (Subtype p)` is a subtype of `f α` with `Functor.map Subtype.val : f (Subtype p) → f α` as the inclusion.
In other words, `f` is subregular if the canonical map

```lean
def f_incl : f (Subtype p) → {x : f α // ∃ (z : f (Subtype p)), f <$> z = x} :=
  λ z => Subtype.mk (f <$> z) ⟨z, rfl⟩
```

is invertible.

-/

universe u v w

--- The predicate transformer classifying the image of `f (Subtype p) → f α` for each predicate `p : α → Type u`.
-- def SatisfiesM {f : Type u → Type v} [Functor f] {α : Type u} (p : α → Prop) : f α → Prop :=
 --  λ x => ∃ (z : f (Subtype p)), Subtype.val <$> z = x

class SubregFunctor (f : Type u → Type v) [Functor f] where
  ensureF {α : Type u} {p : α → Prop} (x : f α) : SatisfiesM p x → f (Subtype p)
  val_ensureF {α : Type u} {p : α → Prop} (x : f α) {h : SatisfiesM p x} : Subtype.val <$> ensureF x h = x
  val_inj {α : Type u} {p : α → Prop} {x y : f (Subtype p)} : Subtype.val <$> x = Subtype.val <$> y → x = y

/-!
## `Id`
-/

namespace Id

instance instSubregFunctorId : SubregFunctor Id where
  ensureF a ha := Subtype.mk a $
    ha.elim (fun x hx => hx ▸ x.property)
  val_ensureF _ := rfl
  val_inj h := Subtype.eq h

end Id

/-!
## `Option`
-/

namespace Option

instance instSubregFunctorOption : SubregFunctor Option where
  ensureF x h := match x with
    | none => none
    | some a => some ⟨a, SatisfiesM_Option_eq.mp h a rfl⟩
  val_ensureF x := by intros; cases x <;> rfl
  val_inj {α} {p} {x} {y} h := match x, y with
    | none, none => rfl
    | some a, some b => Subtype.eq (Option.some.inj h) ▸ rfl

end Option

/-!
## List
-/

namespace List

def forAll {α : Type u} (p : α → Prop) : List α → Prop
| [] => True
| (a::as) => p a ∧ forAll p as

def zipProof {α : Type u} {p : α → Prop} : (as : List α) → as.forAll p → List (Subtype p)
| [], _ => []
| (a::as), And.intro ha has => ⟨a,ha⟩ :: zipProof as has

theorem val_zipProof {α : Type u} {p : α → Prop} (as : List α) {h : as.forAll p} : Subtype.val <$> zipProof as h = as := by
  induction as
  case nil => rfl
  case cons a as h_ind =>
    cases h with | intro ha has =>
    dsimp [Functor.map, zipProof, List.map] at *
    rw [h_ind]

theorem SatisfiesM_List_eq {α : Type u} {p : α → Prop} {as : List α} : SatisfiesM p as ↔ forAll p as where
  mp h := by
    cases h with | intro xs hx =>
    cases hx
    induction xs
    case nil => exact True.intro
    case cons a as h_ind =>
      exact ⟨a.property, h_ind⟩
  mpr h := by
    exists zipProof as h
    exact val_zipProof as

instance instSubregFunctorList : SubregFunctor List where
  ensureF x h := zipProof x (SatisfiesM_List_eq.mp h)
  val_ensureF x := val_zipProof x
  val_inj {_} {p} {as} {bs} h :=
    let rec aux : (as bs : List (Subtype p)) → Subtype.val <$> as = Subtype.val <$> bs → as = bs
    | [], [], _ => rfl
    | (a::as), (b::bs), h => by
      have := List.cons.inj h
      rw [Subtype.eq this.left, aux as bs this.right]
    aux as bs h

end List

/-!
## `ExceptT`
-/

namespace ExceptT

variable {α β ε : Type u} {m : Type u → Type v} [Monad m] [LawfulMonad m] [SubregFunctor m]

def errorOrApply (f : α → β) : Except ε α → Except ε β
| Except.error e => Except.error e
| Except.ok a => Except.ok (f a)

theorem map_eq_map_errorOrApply (f : α → β) (x : ExceptT ε m α) : (Functor.map f x) = errorOrApply f <$> x := by
  rw [Functor.map, Applicative.toFunctor, Monad.toApplicative]
  unfold instMonadExceptT
  simp
  unfold ExceptT.map
  rw [map_eq_pure_bind]
  apply bind_congr
  intro e; cases e <;> rfl

@[reducible]
def ok_implies_true (p : α → Prop) : Except ε α → Prop :=
  λ x => ∀ a, x = Except.ok a → p a

def toSubtype{p : α → Prop} : Except ε (Subtype p) → Subtype (ok_implies_true (ε:=ε) p)
| Except.error e => ⟨Except.error e, by intro _ h; cases h⟩
| Except.ok a => ⟨Except.ok a, λ _ h => Except.ok.inj h ▸ a.property⟩

def fromSubtype {p : α → Prop} : Subtype (ok_implies_true (ε:=ε) p) → Except ε (Subtype p)
| Subtype.mk (Except.error e) _ => Except.error e
| Subtype.mk (Except.ok a) ha => Except.ok ⟨a,ha a rfl⟩

theorem errorOrApply_val {p : α → Prop} : errorOrApply (ε:=ε) (Subtype.val (p:=p)) = Subtype.val ∘ toSubtype (p:=p) := by
  funext x
  cases x <;> rfl

theorem from_toSubtype {p : α → Prop} : fromSubtype (ε:=ε) (p:=p) ∘ toSubtype = id := by
  funext x
  cases x <;> rfl

instance instSubregFunctorExceptT : SubregFunctor (ExceptT ε m) where
  ensureF {α} {p} x hx :=
    Functor.map (f:=m) fromSubtype $
      SubregFunctor.ensureF (f:=m) x (SatisfiesM_ExceptT_eq.mp hx)
  val_ensureF {α} {p} x hx := by
    rw [map_eq_map_errorOrApply]
    rw [←comp_map]
    have : errorOrApply (ε:=ε) (Subtype.val (p:=p)) ∘ fromSubtype = Subtype.val := by
      apply funext
      intro e; cases e with | mk e he =>
      cases e <;> rfl
    rw [this]
    rw [SubregFunctor.val_ensureF (f:=m) x]
  val_inj {_} {p} {x} {y} h := by
    conv at h =>
      rw [map_eq_map_errorOrApply, map_eq_map_errorOrApply]
      rw [errorOrApply_val, comp_map, comp_map]
    have h' := SubregFunctor.val_inj h
    conv =>
      rw [←id_map (f:=m) x, ←id_map (f:=m) y]
      rw [←from_toSubtype (ε:=ε) (p:=p)]
      rw [comp_map, comp_map]
      rw [h']

end ExceptT

/-!
## `ReaderT`
-/

/-- `Classical`-free variant of `SatisfiesM_ReaderT_eq`; This version requires `SubregFunctor m` instead. -/
theorem SatisfiesM_ReaderT_eq' {m : Type u → Type v} [Monad m] [SubregFunctor m] {ρ α : Type u} {p : α → Prop} {x : ReaderT ρ m α} : SatisfiesM (m:=ReaderT ρ m) p x ↔ ∀ s, SatisfiesM p (x s) where
  mp h s := by
    cases h with | intro x h =>
    cases h
    exists x s
  mpr h := by
    exists λ s => SubregFunctor.ensureF (f:=m) (x s) (h s)
    funext s; dsimp [Functor.map]
    rw [SubregFunctor.val_ensureF]

instance instSubregFunctorReaderT (ρ : Type u) (m : Type u → Type v) [Monad m] [SubregFunctor m] : SubregFunctor (ReaderT ρ m) where
  ensureF x h s := SubregFunctor.ensureF (x s) $ SatisfiesM_ReaderT_eq'.mp h s
  val_ensureF {α} {p} x hx := by
    funext _
    cases hx with | intro w hw =>
    cases hw
    dsimp [Functor.map]
    rw [SubregFunctor.val_ensureF]
  val_inj {_} {p} {x} {y} h:= by
    conv at h => dsimp [Functor.map]
    funext s
    apply SubregFunctor.val_inj (f:=m)
    conv =>
      lhs; change (λ r => (Subtype.val <$> x r)) s; rw [h]

/-!
## `StateRefT`
-/

theorem SatisfiesM_StateRefT_eq' {m : Type → Type} [Monad m] [SubregFunctor m] {ω σ α : Type} {p : α → Prop} {x : StateRefT' ω σ m α} : SatisfiesM p x ↔ ∀ (s : ST.Ref ω σ), SatisfiesM p (x s) :=
  SatisfiesM_ReaderT_eq'

instance {ω σ : Type} {m : Type → Type} [Monad m] [SubregFunctor m] : SubregFunctor (StateRefT' ω σ m) :=
  inferInstanceAs (SubregFunctor (ReaderT (ST.Ref ω σ) m))

/-!
## `StateT`
-/

def Prod.fstToSubtype {α σ : Type u} {p : α → Prop} : (Subtype p) × σ → Subtype (α:=α×σ) (p ∘ Prod.fst) :=
  λ x => ⟨⟨x.1.val, x.2⟩, x.1.property⟩

def Prod.fstFromSubtype {α σ : Type u} {p : α → Prop} : Subtype (α:=α×σ) (p ∘ Prod.fst) → Subtype p × σ :=
  λ x => ⟨⟨x.val.1, x.property⟩, x.val.2⟩

theorem Prod.fst_from_to_subtype {α σ : Type u} {p : α → Prop} : Prod.fstFromSubtype (σ:=σ) (p:=p) ∘ Prod.fstToSubtype = id := by
  funext x
  cases x; rfl

theorem Prod.map_val_id {α σ : Type u} {p : α → Prop} : Prod.map (Subtype.val (p:=p)) (id (α:=σ)) = Subtype.val ∘ Prod.fstToSubtype := by
  funext x
  cases x; rfl

theorem SatisfiesM_StateT_eq' {m : Type u → Type v} [Monad m] [LawfulMonad m] [SubregFunctor m] {α ρ : Type u} {p : α → Prop} {x : StateT ρ m α} : SatisfiesM p x ↔ ∀ (s : ρ), SatisfiesM (fun x => p x.fst) (x s) where
  mp h s := by
    cases h with | intro w hw =>
    cases hw
    exists Prod.fstToSubtype (p:=p) <$> w s
    dsimp [Functor.map, StateT.map]
    rw [←comp_map, ←map_eq_pure_bind]
    apply map_congr
    intro x; rfl
  mpr h := by
    exists fun s => Prod.fstFromSubtype <$> SubregFunctor.ensureF (x s) (h s)
    apply funext; intro s
    dsimp [Functor.map, StateT.map]
    rw [←map_eq_pure_bind, ←comp_map]
    conv =>
      lhs; lhs; ext as; dsimp [Prod.map]; change as.val
    conv => lhs; lhs; change Subtype.val
    rw [SubregFunctor.val_ensureF (x s)]

instance instSubregFunctorStateT {m : Type u → Type v} [Monad m] [LawfulMonad m] [SubregFunctor m] {σ : Type u} : SubregFunctor (StateT σ m) where
  ensureF x hx s := Prod.fstFromSubtype <$> SubregFunctor.ensureF (x s) (SatisfiesM_StateT_eq'.mp hx s)
  val_ensureF x hx := by
    funext s
    dsimp [Functor.map, StateT.map]
    rw [←map_eq_pure_bind, ←comp_map]
    exact SubregFunctor.val_ensureF _
  val_inj {_} {p} {x y} h := by
    funext s
    rw [←id_map (f:=m) (x s), ←id_map (f:=m) (y s)]
    rw [←Prod.fst_from_to_subtype]
    rw [comp_map, comp_map]
    have h' := congrFun h
    conv at h' =>
      ext s
      dsimp [Functor.map, StateT.map]
      rw [←map_eq_pure_bind, ←map_eq_pure_bind]
      change (Subtype.val ∘ Prod.fstToSubtype) <$> x s = (Subtype.val ∘ Prod.fstToSubtype) <$> y s
      rw [comp_map, comp_map]
    rw [SubregFunctor.val_inj (h' s)]

/-!
## `EStateM`
-/

namespace EStateM

variable {ε σ : Type u}

namespace Result

def map {α β : Type u} (f : α → β) : Result ε σ α → Result ε σ β
| ok a s => ok (f a) s
| error err s => error err s

@[reducible, inline]
def okThenTrue {α : Type u} (p : α → Prop) : Result ε σ α → Prop :=
  λ x => ∀ a s, x = Result.ok a s → p a

def zipProof {α : Type u} {p : α → Prop} : (x : Result ε σ α) → okThenTrue (ε:=ε) (σ:=σ) p x → Result ε σ (Subtype p)
| ok a s, h => ok ⟨a,h _ _ rfl⟩ s
| error e s, _ => error e s

theorem map_val_zipProof {α : Type u} {p : α → Prop} : ∀ (x : Result ε σ α) {h : okThenTrue (ε:=ε) (σ:=σ) p x}, map Subtype.val (zipProof x h) = x
| ok _ _, _ => rfl
| error _ _, _ => rfl

end Result

theorem SatisfiesM_EStateM_eq {α : Type u} {p : α → Prop} {x : EStateM ε σ α} : (SatisfiesM p x) ↔ (∀ s a s', (x s) = Result.ok a s' → p a) where
  mp hx s a _ := by
    cases hx with | intro w hw =>
    cases hw
    dsimp [Functor.map, EStateM.map]
    cases w s <;> intro h
    case ok a s' => exact (Result.ok.inj h).left ▸ a.property
    case error e s' => cases h
  mpr h := by
    exists λ s => (x s).zipProof (h s)
    funext s
    dsimp [Functor.map, EStateM.map]
    conv =>
      lhs; change Result.map (Subtype.val (p:=p)) ((x s).zipProof (h s))
      rw [Result.map_val_zipProof]

instance instSubregFunctorEStateM : SubregFunctor (EStateM ε σ) where
  ensureF x hx s := (x s).zipProof (SatisfiesM_EStateM_eq.mp hx s)
  val_ensureF {_} {p} x hx := by
    funext s
    conv =>
      lhs; change Result.map Subtype.val ((x s).zipProof (SatisfiesM_EStateM_eq.mp hx s))
      rw [Result.map_val_zipProof]
  val_inj {_} {p} {x y} h := by
    funext s
    have hs := congrFun h s
    conv at hs =>
      dsimp [Functor.map, EStateM.map]
    cases hx : x s
      <;> cases hy : y s
      <;> conv at hs => rw [hx, hy]; dsimp [Result.map]
    case h.ok.ok a sa b sb =>
      have := Result.ok.inj hs
      rw [Subtype.eq this.left, this.right]
    case h.error.error ea sa eb sb =>
      have := Result.error.inj hs
      rw [this.left, this.right]
    all_goals {cases hs}

end EStateM


/-
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 order.filter.filter_product
import analysis.specific_limits.basic

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

open filter filter.germ
open_locale topology classical

/-- Hyperreal numbers on the ultrafilter extending the cofinite filter -/
@[derive [linear_ordered_field, inhabited]]
def hyperreal : Type := germ (hyperfilter ℕ : filter ℕ) ℝ

namespace hyperreal

notation `ℝ*` := hyperreal

noncomputable instance : has_coe_t ℝ ℝ* := ⟨λ x, (↑x : germ _ _)⟩

@[simp, norm_cast] lemma coe_eq_coe {x y : ℝ} : (x : ℝ*) = y ↔ x = y := germ.const_inj
lemma coe_ne_coe {x y : ℝ} : (x : ℝ*) ≠ y ↔ x ≠ y := coe_eq_coe.not

@[simp, norm_cast] lemma coe_eq_zero {x : ℝ} : (x : ℝ*) = 0 ↔ x = 0 := coe_eq_coe
@[simp, norm_cast] lemma coe_eq_one {x : ℝ} : (x : ℝ*) = 1 ↔ x = 1 := coe_eq_coe
@[norm_cast] lemma coe_ne_zero {x : ℝ} : (x : ℝ*) ≠ 0 ↔ x ≠ 0 := coe_ne_coe
@[norm_cast] lemma coe_ne_one {x : ℝ} : (x : ℝ*) ≠ 1 ↔ x ≠ 1 := coe_ne_coe

@[simp, norm_cast] lemma coe_one : ↑(1 : ℝ) = (1 : ℝ*) := rfl
@[simp, norm_cast] lemma coe_zero : ↑(0 : ℝ) = (0 : ℝ*) := rfl
@[simp, norm_cast] lemma coe_inv (x : ℝ) : ↑(x⁻¹) = (x⁻¹ : ℝ*) := rfl
@[simp, norm_cast] lemma coe_neg (x : ℝ) : ↑(-x) = (-x : ℝ*) := rfl
@[simp, norm_cast] lemma coe_add (x y : ℝ) : ↑(x + y) = (x + y : ℝ*) := rfl
@[simp, norm_cast] lemma coe_bit0 (x : ℝ) : ↑(bit0 x) = (bit0 x : ℝ*) := rfl
@[simp, norm_cast] lemma coe_bit1 (x : ℝ) : ↑(bit1 x) = (bit1 x : ℝ*) := rfl
@[simp, norm_cast] lemma coe_mul (x y : ℝ) : ↑(x * y) = (x * y : ℝ*) := rfl
@[simp, norm_cast] lemma coe_div (x y : ℝ) : ↑(x / y) = (x / y : ℝ*) := rfl
@[simp, norm_cast] lemma coe_sub (x y : ℝ) : ↑(x - y) = (x - y : ℝ*) := rfl

@[simp, norm_cast] lemma coe_le_coe {x y : ℝ} : (x : ℝ*) ≤ y ↔ x ≤ y := germ.const_le_iff
@[simp, norm_cast] lemma coe_lt_coe {x y : ℝ} : (x : ℝ*) < y ↔ x < y := germ.const_lt_iff
@[simp, norm_cast] lemma coe_nonneg {x : ℝ} : 0 ≤ (x : ℝ*) ↔ 0 ≤ x := coe_le_coe
@[simp, norm_cast] lemma coe_pos {x : ℝ} : 0 < (x : ℝ*) ↔ 0 < x := coe_lt_coe
@[simp, norm_cast] lemma coe_abs (x : ℝ) : ((|x| : ℝ) : ℝ*) = |x| := const_abs x
@[simp, norm_cast] lemma coe_max (x y : ℝ) : ((max x y : ℝ) : ℝ*) = max x y := germ.const_max _ _
@[simp, norm_cast] lemma coe_min (x y : ℝ) : ((min x y : ℝ) : ℝ*) = min x y := germ.const_min _ _

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

/-- A sample infinitesimal hyperreal-/
noncomputable def epsilon : ℝ* := of_seq $ λ n, n⁻¹

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

localized "notation (name := hyperreal.epsilon) `ε` := hyperreal.epsilon" in hyperreal
localized "notation (name := hyperreal.omega) `ω` := hyperreal.omega" in hyperreal

@[simp] lemma inv_omega : ω⁻¹ = ε := rfl
@[simp] lemma inv_epsilon : ε⁻¹ = ω := @inv_inv _ _ ω

lemma omega_pos : 0 < ω := germ.coe_pos.2 $ mem_hyperfilter_of_finite_compl $ begin
  convert set.finite_singleton 0,
  simp [set.eq_singleton_iff_unique_mem],
end

lemma epsilon_pos : 0 < ε := inv_pos_of_pos omega_pos

lemma epsilon_ne_zero : ε ≠ 0 := epsilon_pos.ne'
lemma omega_ne_zero : ω ≠ 0 := omega_pos.ne'

theorem epsilon_mul_omega : ε * ω = 1 := @inv_mul_cancel _ _ ω omega_ne_zero

lemma lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : tendsto f at_top (𝓝 0)) :
  ∀ {r : ℝ}, 0 < r → of_seq f < (r : ℝ*) :=
begin
  simp only [metric.tendsto_at_top, real.dist_eq, sub_zero, lt_def] at hf ⊢,
  intros r hr, cases hf r hr with N hf',
  have hs : {i : ℕ | f i < r}ᶜ ⊆ {i : ℕ | i ≤ N} :=
    λ i hi1, le_of_lt (by simp only [lt_iff_not_ge];
    exact λ hi2, hi1 (lt_of_le_of_lt (le_abs_self _) (hf' i hi2)) : i < N),
  exact mem_hyperfilter_of_finite_compl
    ((set.finite_le_nat N).subset hs)
end

lemma neg_lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : tendsto f at_top (𝓝 0)) :
  ∀ {r : ℝ}, 0 < r → (-r : ℝ*) < of_seq f :=
λ r hr, have hg : _ := hf.neg,
neg_lt_of_neg_lt (by rw [neg_zero] at hg; exact lt_of_tendsto_zero_of_pos hg hr)

lemma gt_of_tendsto_zero_of_neg {f : ℕ → ℝ} (hf : tendsto f at_top (𝓝 0)) :
  ∀ {r : ℝ}, r < 0 → (r : ℝ*) < of_seq f :=
λ r hr, by rw [←neg_neg r, coe_neg];
exact neg_lt_of_tendsto_zero_of_pos hf (neg_pos.mpr hr)

lemma epsilon_lt_pos (x : ℝ) : 0 < x → ε < 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 ℤ -/
noncomputable def st : ℝ* → ℝ :=
λ x, if h : ∃ r, is_st x r then classical.some h else 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`
-/

private lemma is_st_unique' (x : ℝ*) (r s : ℝ) (hr : is_st x r) (hs : is_st x s) (hrs : r < s) :
  false :=
have hrs' : _ := half_pos $ sub_pos_of_lt hrs,
have hr' : _ := (hr _ hrs').2,
have hs' : _ := (hs _ hrs').1,
have h : s - ((s - r) / 2) = r + (s - r) / 2 := by linarith,
begin
  norm_cast at *,
  rw h at hs',
  exact not_lt_of_lt hs' hr'
end

theorem is_st_unique {x : ℝ*} {r s : ℝ} (hr : is_st x r) (hs : is_st x s) : r = s :=
begin
  rcases lt_trichotomy r s with h | h | h,
  { exact false.elim (is_st_unique' x r s hr hs h) },
  { exact h },
  { exact false.elim (is_st_unique' x s r hs hr h) }
end

theorem not_infinite_of_exists_st {x : ℝ*} : (∃ r : ℝ, is_st x r) → ¬ infinite x :=
λ he hi, Exists.dcases_on he $ λ r hr, hi.elim
   (λ hip, not_lt_of_lt (hr 2 zero_lt_two).2 (hip $ r + 2))
   (λ hin, not_lt_of_lt (hr 2 zero_lt_two).1 (hin $ r - 2))

theorem is_st_Sup {x : ℝ*} (hni : ¬ infinite x) : is_st x (Sup {y : ℝ | (y : ℝ*) < x}) :=
let S : set ℝ := {y : ℝ | (y : ℝ*) < x} in
let R : _ := Sup S in
have hnile : _ := not_forall.mp (not_or_distrib.mp hni).1,
have hnige : _ := not_forall.mp (not_or_distrib.mp hni).2,
Exists.dcases_on hnile $ Exists.dcases_on hnige $ λ r₁ hr₁ r₂ hr₂,
have HR₁ : S.nonempty :=
  ⟨r₁ - 1, lt_of_lt_of_le (coe_lt_coe.2 $ sub_one_lt _) (not_lt.mp hr₁) ⟩,
have HR₂ : bdd_above S :=
  ⟨ r₂, λ y hy, le_of_lt (coe_lt_coe.1 (lt_of_lt_of_le hy (not_lt.mp hr₂))) ⟩,
λ δ hδ,
  ⟨ lt_of_not_le $ λ c,
      have hc : ∀ y ∈ S, y ≤ R - δ := λ y hy, coe_le_coe.1 $ le_of_lt $ lt_of_lt_of_le hy c,
      not_lt_of_le (cSup_le HR₁ hc) $ sub_lt_self R hδ,
    lt_of_not_le $ λ c,
      have hc : ↑(R + δ / 2) < x :=
        lt_of_lt_of_le (add_lt_add_left (coe_lt_coe.2 (half_lt_self hδ)) R) c,
      not_lt_of_le (le_cSup HR₂ hc) $ (lt_add_iff_pos_right _).mpr $ half_pos hδ⟩

theorem exists_st_of_not_infinite {x : ℝ*} (hni : ¬ infinite x) : ∃ r : ℝ, is_st x r :=
⟨Sup {y : ℝ | (y : ℝ*) < x}, is_st_Sup hni⟩

theorem st_eq_Sup {x : ℝ*} : st x = Sup {y : ℝ | (y : ℝ*) < x} :=
begin
unfold st, split_ifs,
{ exact is_st_unique (classical.some_spec h) (is_st_Sup (not_infinite_of_exists_st h)) },
{ cases not_imp_comm.mp exists_st_of_not_infinite h with H H,
  { rw (set.ext (λ i, ⟨λ hi, set.mem_univ i, λ hi, H i⟩) : {y : ℝ | (y : ℝ*) < x} = set.univ),
    exact real.Sup_univ.symm },
  { rw (set.ext (λ i, ⟨λ hi, false.elim (not_lt_of_lt (H i) hi),
    λ hi, false.elim (set.not_mem_empty i hi)⟩) : {y : ℝ | (y : ℝ*) < x} = ∅),
    exact real.Sup_empty.symm } }
end

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

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

theorem st_infinite {x : ℝ*} (hi : infinite x) : st x = 0 :=
begin
  unfold st, split_ifs,
  { exact false.elim ((infinite_iff_not_exists_st.mp hi) h) },
  { refl }
end

lemma st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : st x = r :=
begin
  unfold st, split_ifs,
  { exact is_st_unique (classical.some_spec h) hxr },
  { exact false.elim (h ⟨r, hxr⟩) }
end

lemma is_st_st_of_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st x (st x) :=
by rwa [st_of_is_st hxr]

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

lemma is_st_st {x : ℝ*} (hx : st x ≠ 0) : is_st x (st x) :=
begin
  unfold st, split_ifs,
  { exact classical.some_spec h },
  { exact false.elim (hx (by unfold st; split_ifs; refl)) }
end

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

lemma is_st_refl_real (r : ℝ) : is_st r r :=
λ δ hδ, ⟨ sub_lt_self _ (coe_lt_coe.2 hδ), (lt_add_of_pos_right _ (coe_lt_coe.2 hδ)) ⟩

lemma st_id_real (r : ℝ) : st r = r := st_of_is_st (is_st_refl_real r)

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

lemma is_st_real_iff_eq {r s : ℝ} : is_st r s ↔ r = s :=
⟨eq_of_is_st_real, λ hrs, by rw [hrs]; exact is_st_refl_real s⟩

lemma is_st_symm_real {r s : ℝ} : is_st r s ↔ is_st s r :=
by rw [is_st_real_iff_eq, is_st_real_iff_eq, eq_comm]

lemma is_st_trans_real {r s t : ℝ} : is_st r s → is_st s t → is_st r t :=
by rw [is_st_real_iff_eq, is_st_real_iff_eq, is_st_real_iff_eq]; exact eq.trans

lemma 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_of_is_st_real h2).symm

lemma is_st_iff_abs_sub_lt_delta {x : ℝ*} {r : ℝ} :
  is_st x r ↔ ∀ (δ : ℝ), 0 < δ → |x - r| < δ :=
by simp only [abs_sub_lt_iff, sub_lt_iff_lt_add, is_st, and_comm, add_comm]

lemma is_st_add {x y : ℝ*} {r s : ℝ} : is_st x r → is_st y s → is_st (x + y) (r + s) :=
λ hxr hys d hd,
have hxr' : _ := hxr (d / 2) (half_pos hd),
have hys' : _ := hys (d / 2) (half_pos hd),
⟨by convert add_lt_add hxr'.1 hys'.1 using 1; norm_cast; linarith,
 by convert add_lt_add hxr'.2 hys'.2 using 1; norm_cast; linarith⟩

lemma is_st_neg {x : ℝ*} {r : ℝ} (hxr : is_st x r) : is_st (-x) (-r) :=
λ d hd, show -(r : ℝ*) - d < -x ∧ -x < -r + d, by cases (hxr d hd); split; linarith

lemma is_st_sub {x y : ℝ*} {r s : ℝ} : is_st x r → is_st y s → is_st (x - y) (r - s) :=
λ hxr hys, by rw [sub_eq_add_neg, sub_eq_add_neg]; exact is_st_add hxr (is_st_neg hys)

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

lemma lt_of_is_st_lt {x y : ℝ*} {r s : ℝ} (hxr : is_st x r) (hys : is_st y s) :
  r < s → x < y :=
λ hrs, have hrs' : 0 < (s - r) / 2 := half_pos (sub_pos.mpr hrs),
have hxr' : _ := (hxr _ hrs').2, have hys' : _ := (hys _ hrs').1,
have H1 : r + ((s - r) / 2) = (r + s) / 2 := by linarith,
have H2 : s - ((s - r) / 2) = (r + s) / 2 := by linarith,
begin
  norm_cast at *,
  rw H1 at hxr',
  rw H2 at hys',
  exact lt_trans hxr' hys'
end

lemma is_st_le_of_le {x y : ℝ*} {r s : ℝ} (hrx : is_st x r) (hsy : is_st y s) :
  x ≤ y → r ≤ s := by rw [←not_lt, ←not_lt, not_imp_not]; exact lt_of_is_st_lt hsy hrx

lemma st_le_of_le {x y : ℝ*} (hix : ¬ infinite x) (hiy : ¬ infinite y) :
  x ≤ y → st x ≤ st y :=
have hx' : _ := is_st_st' hix, have hy' : _ := is_st_st' hiy,
is_st_le_of_le hx' hy'

lemma lt_of_st_lt {x y : ℝ*} (hix : ¬ infinite x) (hiy : ¬ infinite y) :
  st x < st y → x < y :=
have hx' : _ := is_st_st' hix, have hy' : _ := is_st_st' hiy,
lt_of_is_st_lt hx' hy'

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

lemma infinite_pos_def {x : ℝ*} : infinite_pos x ↔ ∀ r : ℝ, ↑r < x := by rw iff_eq_eq; refl

lemma infinite_neg_def {x : ℝ*} : infinite_neg x ↔ ∀ r : ℝ, x < r := by rw iff_eq_eq; refl

lemma ne_zero_of_infinite {x : ℝ*} : infinite x → x ≠ 0 :=
λ hI h0, or.cases_on hI
  (λ hip, lt_irrefl (0 : ℝ*) ((by rwa ←h0 : infinite_pos 0) 0))
  (λ hin, lt_irrefl (0 : ℝ*) ((by rwa ←h0 : infinite_neg 0) 0))

lemma not_infinite_zero : ¬ infinite 0 := λ hI, ne_zero_of_infinite hI rfl

lemma pos_of_infinite_pos {x : ℝ*} : infinite_pos x → 0 < x := λ hip, hip 0

lemma neg_of_infinite_neg {x : ℝ*} : infinite_neg x → x < 0 := λ hin, hin 0

lemma not_infinite_pos_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬ infinite_pos x :=
λ hn hp, not_lt_of_lt (hn 1) (hp 1)

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

lemma infinite_neg_neg_of_infinite_pos {x : ℝ*} : infinite_pos x → infinite_neg (-x) :=
λ hp r, neg_lt.mp (hp (-r))

lemma infinite_pos_neg_of_infinite_neg {x : ℝ*} : infinite_neg x → infinite_pos (-x) :=
λ hp r, lt_neg.mp (hp (-r))

lemma infinite_pos_iff_infinite_neg_neg {x : ℝ*} : infinite_pos x ↔ infinite_neg (-x) :=
⟨ infinite_neg_neg_of_infinite_pos, λ hin, neg_neg x ▸ infinite_pos_neg_of_infinite_neg hin ⟩

lemma infinite_neg_iff_infinite_pos_neg {x : ℝ*} : infinite_neg x ↔ infinite_pos (-x) :=
⟨ infinite_pos_neg_of_infinite_neg, λ hin, neg_neg x ▸ infinite_neg_neg_of_infinite_pos hin ⟩

lemma infinite_iff_infinite_neg {x : ℝ*} : infinite x ↔ infinite (-x) :=
⟨ λ hi, or.cases_on hi
  (λ hip, or.inr (infinite_neg_neg_of_infinite_pos hip))
  (λ hin, or.inl (infinite_pos_neg_of_infinite_neg hin)),
 λ hi, or.cases_on hi
  (λ hipn, or.inr (infinite_neg_iff_infinite_pos_neg.mpr hipn))
  (λ hinp, or.inl (infinite_pos_iff_infinite_neg_neg.mpr hinp))⟩

lemma not_infinite_of_infinitesimal {x : ℝ*} : infinitesimal x → ¬ infinite x :=
λ hi hI, have hi' : _ := (hi 2 zero_lt_two), or.dcases_on hI
  (λ hip, have hip' : _ := hip 2, not_lt_of_lt hip' (by convert hi'.2; exact (zero_add 2).symm))
  (λ hin, have hin' : _ := hin (-2), not_lt_of_lt hin' (by convert hi'.1; exact (zero_sub 2).symm))

lemma not_infinitesimal_of_infinite_pos {x : ℝ*} : infinite_pos x → ¬ infinitesimal x :=
λ hp, not_infinitesimal_of_infinite (or.inl hp)

lemma not_infinitesimal_of_infinite_neg {x : ℝ*} : infinite_neg x → ¬ infinitesimal x :=
λ hn, not_infinitesimal_of_infinite (or.inr hn)

lemma infinite_pos_iff_infinite_and_pos {x : ℝ*} : infinite_pos x ↔ (infinite x ∧ 0 < x) :=
⟨ λ hip, ⟨or.inl hip, hip 0⟩,
  λ ⟨hi, hp⟩, hi.cases_on (λ hip, hip) (λ hin, false.elim (not_lt_of_lt hp (hin 0))) ⟩

lemma infinite_neg_iff_infinite_and_neg {x : ℝ*} : infinite_neg x ↔ (infinite x ∧ x < 0) :=
⟨ λ hip, ⟨or.inr hip, hip 0⟩,
  λ ⟨hi, hp⟩, hi.cases_on (λ hin, false.elim (not_lt_of_lt hp (hin 0))) (λ hip, hip) ⟩

lemma infinite_pos_iff_infinite_of_pos {x : ℝ*} (hp : 0 < x) : infinite_pos x ↔ infinite x :=
by rw [infinite_pos_iff_infinite_and_pos]; exact ⟨λ hI, hI.1, λ hI, ⟨hI, hp⟩⟩

lemma infinite_pos_iff_infinite_of_nonneg {x : ℝ*} (hp : 0 ≤ x) : infinite_pos x ↔ infinite x :=
or.cases_on (lt_or_eq_of_le hp) (infinite_pos_iff_infinite_of_pos)
  (λ h, by rw h.symm; exact
  ⟨λ hIP, false.elim (not_infinite_zero (or.inl hIP)), λ hI, false.elim (not_infinite_zero hI)⟩)

lemma infinite_neg_iff_infinite_of_neg {x : ℝ*} (hn : x < 0) : infinite_neg x ↔ infinite x :=
by rw [infinite_neg_iff_infinite_and_neg]; exact ⟨λ hI, hI.1, λ hI, ⟨hI, hn⟩⟩

lemma infinite_pos_abs_iff_infinite_abs {x : ℝ*} : infinite_pos (|x|) ↔ infinite (|x|) :=
infinite_pos_iff_infinite_of_nonneg (abs_nonneg _)

lemma infinite_iff_infinite_pos_abs {x : ℝ*} : infinite x ↔ infinite_pos (|x|) :=
⟨ λ hi d, or.cases_on hi
   (λ hip, by rw [abs_of_pos (hip 0)]; exact hip d)
   (λ hin, by rw [abs_of_neg (hin 0)]; exact lt_neg.mp (hin (-d))),
  λ hipa, by { rcases (lt_trichotomy x 0) with h | h | h,
    { exact or.inr (infinite_neg_iff_infinite_pos_neg.mpr (by rwa abs_of_neg h at hipa)) },
    { exact false.elim (ne_zero_of_infinite (or.inl (by rw [h]; rwa [h, abs_zero] at hipa)) h) },
    { exact or.inl (by rwa abs_of_pos h at hipa) } } ⟩

lemma infinite_iff_infinite_abs {x : ℝ*} : infinite x ↔ infinite (|x|) :=
by rw [←infinite_pos_iff_infinite_of_nonneg (abs_nonneg _), infinite_iff_infinite_pos_abs]

lemma infinite_iff_abs_lt_abs {x : ℝ*} : infinite x ↔ ∀ r : ℝ, (|r| : ℝ*) < |x| :=
⟨ λ hI r, (coe_abs r) ▸ infinite_iff_infinite_pos_abs.mp hI (|r|),
  λ hR, or.cases_on (max_choice x (-x))
  (λ h, or.inl $ λ r, lt_of_le_of_lt (le_abs_self _) (h ▸ (hR r)))
  (λ h, or.inr $ λ r, neg_lt_neg_iff.mp $ lt_of_le_of_lt (neg_le_abs_self _) (h ▸ (hR r)))⟩

lemma infinite_pos_add_not_infinite_neg {x y : ℝ*} :
  infinite_pos x → ¬ infinite_neg y → infinite_pos (x + y) :=
begin
  intros hip hnin r,
  cases not_forall.mp hnin with r₂ hr₂,
  convert add_lt_add_of_lt_of_le (hip (r + -r₂)) (not_lt.mp hr₂) using 1,
  simp
end

lemma not_infinite_neg_add_infinite_pos {x y : ℝ*} :
  ¬ infinite_neg x → infinite_pos y → infinite_pos (x + y) :=
λ hx hy, by rw [add_comm]; exact infinite_pos_add_not_infinite_neg hy hx

lemma infinite_neg_add_not_infinite_pos {x y : ℝ*} :
  infinite_neg x → ¬ infinite_pos y → infinite_neg (x + y) :=
by rw [@infinite_neg_iff_infinite_pos_neg x, @infinite_pos_iff_infinite_neg_neg y,
       @infinite_neg_iff_infinite_pos_neg (x + y), neg_add];
exact infinite_pos_add_not_infinite_neg

lemma not_infinite_pos_add_infinite_neg {x y : ℝ*} :
  ¬ infinite_pos x → infinite_neg y → infinite_neg (x + y) :=
λ hx hy, by rw [add_comm]; exact infinite_neg_add_not_infinite_pos hy hx

lemma infinite_pos_add_infinite_pos {x y : ℝ*} :
  infinite_pos x → infinite_pos y → infinite_pos (x + y) :=
λ hx hy, infinite_pos_add_not_infinite_neg hx (not_infinite_neg_of_infinite_pos hy)

lemma infinite_neg_add_infinite_neg {x y : ℝ*} :
  infinite_neg x → infinite_neg y → infinite_neg (x + y) :=
λ hx hy, infinite_neg_add_not_infinite_pos hx (not_infinite_pos_of_infinite_neg hy)

lemma infinite_pos_add_not_infinite {x y : ℝ*} :
  infinite_pos x → ¬ infinite y → infinite_pos (x + y) :=
λ hx hy, infinite_pos_add_not_infinite_neg hx (not_or_distrib.mp hy).2

lemma infinite_neg_add_not_infinite {x y : ℝ*} :
  infinite_neg x → ¬ infinite y → infinite_neg (x + y) :=
λ hx hy, infinite_neg_add_not_infinite_pos hx (not_or_distrib.mp hy).1

theorem infinite_pos_of_tendsto_top {f : ℕ → ℝ} (hf : tendsto f at_top at_top) :
  infinite_pos (of_seq f) :=
λ r, have hf' : _ := tendsto_at_top_at_top.mp hf,
Exists.cases_on (hf' (r + 1)) $ λ i hi,
  have hi' : ∀ (a : ℕ), f a < (r + 1) → a < i :=
    λ a, by rw [←not_le, ←not_le]; exact not_imp_not.mpr (hi a),
  have hS : {a : ℕ | r < f a}ᶜ ⊆ {a : ℕ | a ≤ i} :=
    by simp only [set.compl_set_of, not_lt];
    exact λ a har, le_of_lt (hi' a (lt_of_le_of_lt har (lt_add_one _))),
  germ.coe_lt.2 $ mem_hyperfilter_of_finite_compl $
  (set.finite_le_nat _).subset hS

theorem infinite_neg_of_tendsto_bot {f : ℕ → ℝ} (hf : tendsto f at_top at_bot) :
  infinite_neg (of_seq f) :=
λ r, have hf' : _ := tendsto_at_top_at_bot.mp hf,
Exists.cases_on (hf' (r - 1)) $ λ i hi,
  have hi' : ∀ (a : ℕ), r - 1 < f a → a < i :=
    λ a, by rw [←not_le, ←not_le]; exact not_imp_not.mpr (hi a),
  have hS : {a : ℕ | f a < r}ᶜ ⊆ {a : ℕ | a ≤ i} :=
    by simp only [set.compl_set_of, not_lt];
    exact λ a har, le_of_lt (hi' a (lt_of_lt_of_le (sub_one_lt _) har)),
  germ.coe_lt.2 $ mem_hyperfilter_of_finite_compl $
  (set.finite_le_nat _).subset hS

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

lemma not_infinite_add {x y : ℝ*} (hx : ¬ infinite x) (hy : ¬ infinite y) :
  ¬ infinite (x + y) :=
have hx' : _ := exists_st_of_not_infinite hx, have hy' : _ := exists_st_of_not_infinite hy,
Exists.cases_on hx' $ Exists.cases_on hy' $
λ r hr s hs, not_infinite_of_exists_st $ ⟨s + r, is_st_add hs hr⟩

theorem not_infinite_iff_exist_lt_gt {x : ℝ*} : ¬ infinite x ↔ ∃ r s : ℝ, (r : ℝ*) < x ∧ x < s :=
⟨ λ hni,
Exists.dcases_on (not_forall.mp (not_or_distrib.mp hni).1) $
Exists.dcases_on (not_forall.mp (not_or_distrib.mp hni).2) $ λ r hr s hs,
by rw [not_lt] at hr hs; exact ⟨r - 1, s + 1,
  ⟨ lt_of_lt_of_le (by rw sub_eq_add_neg; norm_num) hr,
    lt_of_le_of_lt hs (by norm_num)⟩ ⟩,
λ hrs, Exists.dcases_on hrs $ λ r hr, Exists.dcases_on hr $ λ s hs,
  not_or_distrib.mpr ⟨not_forall.mpr ⟨s, lt_asymm (hs.2)⟩, not_forall.mpr ⟨r, lt_asymm (hs.1) ⟩⟩⟩

theorem not_infinite_real (r : ℝ) : ¬ infinite r := by rw not_infinite_iff_exist_lt_gt; exact
⟨ r - 1, r + 1, coe_lt_coe.2 $ sub_one_lt r, coe_lt_coe.2 $ lt_add_one r⟩

theorem not_real_of_infinite {x : ℝ*} : infinite x → ∀ r : ℝ, x ≠ r :=
λ hi r hr,  not_infinite_real r $ @eq.subst _ infinite _ _ hr hi

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

private lemma is_st_mul' {x y : ℝ*} {r s : ℝ} (hxr : is_st x r) (hys : is_st y s) (hs : s ≠ 0) :
  is_st (x * y) (r * s) :=
have hxr' : _ := is_st_iff_abs_sub_lt_delta.mp hxr,
have hys' : _ := is_st_iff_abs_sub_lt_delta.mp hys,
have h : _ := not_infinite_iff_exist_lt_gt.mp $ not_imp_not.mpr infinite_iff_infinite_abs.mpr $
not_infinite_of_exists_st ⟨r, hxr⟩,
Exists.cases_on h $ λ u h', Exists.cases_on h' $ λ t ⟨hu, ht⟩,
is_st_iff_abs_sub_lt_delta.mpr $ λ d hd,
   calc |x * y - r * s|
      = |x * (y - s) + (x - r) * s| :
        by rw [mul_sub, sub_mul, add_sub, sub_add_cancel]
  ... ≤ |x * (y - s)| + |(x - r) * s| : abs_add _ _
  ... ≤ |x| * |y - s| + |x - r| * |s| : by simp only [abs_mul]
  ... ≤ |x| * ((d / t) / 2 : ℝ) + ((d / |s|) / 2 : ℝ) * |s| : add_le_add
        (mul_le_mul_of_nonneg_left (le_of_lt $ hys' _ $ half_pos $ div_pos hd $
          coe_pos.1 $ lt_of_le_of_lt (abs_nonneg x) ht) $ abs_nonneg _)
        (mul_le_mul_of_nonneg_right (le_of_lt $ hxr' _ $ half_pos $ div_pos hd $
          abs_pos.2 hs) $ abs_nonneg _)
  ... = (d / 2 * (|x| / t) + d / 2 : ℝ*) : by
      { push_cast [-filter.germ.const_div], -- TODO: Why wasn't `hyperreal.coe_div` used?
        have : (|s| : ℝ*) ≠ 0, by simpa,
        have : (2 : ℝ*) ≠ 0 := two_ne_zero,
        field_simp [*, add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm] }
  ... < (d / 2 * 1 + d / 2 : ℝ*) :
        add_lt_add_right (mul_lt_mul_of_pos_left
        ((div_lt_one $ lt_of_le_of_lt (abs_nonneg x) ht).mpr ht) $
        half_pos $ coe_pos.2 hd) _
  ... = (d : ℝ*) : by rw [mul_one, add_halves]

lemma is_st_mul {x y : ℝ*} {r s : ℝ} (hxr : is_st x r) (hys : is_st y s) :
  is_st (x * y) (r * s) :=
have h : _ := not_infinite_iff_exist_lt_gt.mp $
  not_imp_not.mpr infinite_iff_infinite_abs.mpr $ not_infinite_of_exists_st ⟨r, hxr⟩,
Exists.cases_on h $ λ u h', Exists.cases_on h' $ λ t ⟨hu, ht⟩,
begin
  by_cases hs : s = 0,
  { apply is_st_iff_abs_sub_lt_delta.mpr, intros d hd,
    have hys' : _ := is_st_iff_abs_sub_lt_delta.mp hys (d / t)
      (div_pos hd (coe_pos.1 (lt_of_le_of_lt (abs_nonneg x) ht))),
    rw [hs, coe_zero, sub_zero] at hys',
    rw [hs, mul_zero, coe_zero, sub_zero, abs_mul, mul_comm,
        ←div_mul_cancel (d : ℝ*) (ne_of_gt (lt_of_le_of_lt (abs_nonneg x) ht)),
        ←coe_div],
    exact mul_lt_mul'' hys' ht (abs_nonneg _) (abs_nonneg _) },
  exact is_st_mul' hxr hys hs,
end

--AN INFINITE LEMMA THAT REQUIRES SOME MORE ST MACHINERY
lemma not_infinite_mul {x y : ℝ*} (hx : ¬ infinite x) (hy : ¬ infinite y) :
  ¬ infinite (x * y) :=
have hx' : _ := exists_st_of_not_infinite hx, have hy' : _ := exists_st_of_not_infinite hy,
Exists.cases_on hx' $ Exists.cases_on hy' $ λ r hr s hs, not_infinite_of_exists_st $
⟨s * r, is_st_mul hs hr⟩
---

lemma st_add {x y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x + y) = st x + st y :=
have hx' : _ := is_st_st' hx,
have hy' : _ := is_st_st' hy,
have hxy : _ := is_st_st' (not_infinite_add hx hy),
have hxy' : _ := is_st_add hx' hy',
is_st_unique hxy hxy'

lemma st_neg (x : ℝ*) : st (-x) = - st x :=
if h : infinite x
then by rw [st_infinite h, st_infinite (infinite_iff_infinite_neg.mp h), neg_zero]
else is_st_unique (is_st_st' (not_infinite_neg h)) (is_st_neg (is_st_st' h))

lemma st_mul {x y : ℝ*} (hx : ¬infinite x) (hy : ¬infinite y) : st (x * y) = (st x) * (st y) :=
have hx' : _ := is_st_st' hx,
have hy' : _ := is_st_st' hy,
have hxy : _ := is_st_st' (not_infinite_mul hx hy),
have hxy' : _ := is_st_mul hx' hy',
is_st_unique hxy hxy'

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

theorem infinitesimal_def {x : ℝ*} :
  infinitesimal x ↔ (∀ r : ℝ, 0 < r → -(r : ℝ*) < x ∧ x < r) :=
⟨ λ hi r hr, by { convert (hi r hr); simp },
  λ hi d hd, by { convert (hi d hd); simp } ⟩

theorem lt_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ r : ℝ, 0 < r → x < r :=
λ hi r hr, ((infinitesimal_def.mp hi) r hr).2

theorem lt_neg_of_pos_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ r : ℝ, 0 < r → -↑r < x :=
λ hi r hr, ((infinitesimal_def.mp hi) r hr).1

theorem gt_of_neg_of_infinitesimal {x : ℝ*} : infinitesimal x → ∀ r : ℝ, r < 0 → ↑r < x :=
λ hi r hr, by convert ((infinitesimal_def.mp hi) (-r) (neg_pos.mpr hr)).1;
exact (neg_neg ↑r).symm

theorem abs_lt_real_iff_infinitesimal {x : ℝ*} :
  infinitesimal x ↔ ∀ r : ℝ, r ≠ 0 → |x| < |r| :=
⟨ λ hi r hr, abs_lt.mpr (by rw ←coe_abs;
  exact infinitesimal_def.mp hi (|r|) (abs_pos.2 hr)),
  λ hR, infinitesimal_def.mpr $ λ r hr, abs_lt.mp $
  (abs_of_pos $ coe_pos.2 hr) ▸ hR r $ ne_of_gt hr ⟩

lemma infinitesimal_zero : infinitesimal 0 := is_st_refl_real 0

lemma zero_of_infinitesimal_real {r : ℝ} : infinitesimal r → r = 0 := eq_of_is_st_real

lemma zero_iff_infinitesimal_real {r : ℝ} : infinitesimal r ↔ r = 0 :=
⟨zero_of_infinitesimal_real, λ hr, by rw hr; exact infinitesimal_zero⟩

lemma infinitesimal_add {x y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) :
  infinitesimal (x + y) :=
by simpa only [add_zero] using is_st_add hx hy

lemma infinitesimal_neg {x : ℝ*} (hx : infinitesimal x) : infinitesimal (-x) :=
by simpa only [neg_zero] using is_st_neg hx

lemma infinitesimal_neg_iff {x : ℝ*} : infinitesimal x ↔ infinitesimal (-x) :=
⟨infinitesimal_neg, λ h, (neg_neg x) ▸ @infinitesimal_neg (-x) h⟩

lemma infinitesimal_mul {x y : ℝ*} (hx : infinitesimal x) (hy : infinitesimal y) :
  infinitesimal (x * y) :=
by simpa only [mul_zero] using is_st_mul hx hy

theorem infinitesimal_of_tendsto_zero {f : ℕ → ℝ} :
  tendsto f at_top (𝓝 0) → infinitesimal (of_seq f) :=
λ hf d hd, by rw [sub_eq_add_neg, ←coe_neg, ←coe_add, ←coe_add, zero_add, zero_add];
exact ⟨neg_lt_of_tendsto_zero_of_pos hf hd, lt_of_tendsto_zero_of_pos hf hd⟩

theorem infinitesimal_epsilon : infinitesimal ε :=
infinitesimal_of_tendsto_zero tendsto_inverse_at_top_nhds_0_nat

lemma not_real_of_infinitesimal_ne_zero (x : ℝ*) :
  infinitesimal x → x ≠ 0 → ∀ r : ℝ, x ≠ r :=
λ hi hx r hr, hx $ hr.trans $ coe_eq_zero.2 $
is_st_unique (hr.symm ▸ is_st_refl_real r : is_st x r) hi

theorem infinitesimal_sub_is_st {x : ℝ*} {r : ℝ} (hxr : is_st x r) : infinitesimal (x - r) :=
show is_st (x - r) 0,
by { rw [sub_eq_add_neg, ← add_neg_self r], exact is_st_add hxr (is_st_refl_real (-r)) }

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

lemma infinite_pos_iff_infinitesimal_inv_pos {x : ℝ*} :
  infinite_pos x ↔ (infinitesimal x⁻¹ ∧ 0 < x⁻¹) :=
⟨ λ hip, ⟨ infinitesimal_def.mpr $ λ r hr,
  ⟨ lt_trans (coe_lt_coe.2 (neg_neg_of_pos hr)) (inv_pos.2 (hip 0)),
    (inv_lt (coe_lt_coe.2 hr) (hip 0)).mp (by convert hip r⁻¹) ⟩,
  inv_pos.2 $ hip 0 ⟩,
  λ ⟨hi, hp⟩ r, @classical.by_cases (r = 0) (↑r < x) (λ h, eq.substr h (inv_pos.mp hp)) $
  λ h, lt_of_le_of_lt (coe_le_coe.2 (le_abs_self r))
  ((inv_lt_inv (inv_pos.mp hp) (coe_lt_coe.2 (abs_pos.2 h))).mp
  ((infinitesimal_def.mp hi) ((|r|)⁻¹) (inv_pos.2 (abs_pos.2 h))).2) ⟩

lemma infinite_neg_iff_infinitesimal_inv_neg {x : ℝ*} :
  infinite_neg x ↔ (infinitesimal x⁻¹ ∧ x⁻¹ < 0) :=
⟨ λ hin, have hin' : _ := infinite_pos_iff_infinitesimal_inv_pos.mp
  (infinite_pos_neg_of_infinite_neg hin),
  by rwa [infinitesimal_neg_iff, ←neg_pos, neg_inv],
  λ hin, by rwa [←neg_pos, infinitesimal_neg_iff, neg_inv,
    ←infinite_pos_iff_infinitesimal_inv_pos, ←infinite_neg_iff_infinite_pos_neg] at hin ⟩

theorem infinitesimal_inv_of_infinite {x : ℝ*} : infinite x → infinitesimal x⁻¹ :=
λ hi, or.cases_on hi
 (λ hip, (infinite_pos_iff_infinitesimal_inv_pos.mp hip).1)
 (λ hin, (infinite_neg_iff_infinitesimal_inv_neg.mp hin).1)

theorem infinite_of_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) (hi : infinitesimal x⁻¹ ) :
  infinite x :=
begin
  cases (lt_or_gt_of_ne h0) with hn hp,
  { exact or.inr (infinite_neg_iff_infinitesimal_inv_neg.mpr ⟨hi, inv_lt_zero.mpr hn⟩) },
  { exact or.inl (infinite_pos_iff_infinitesimal_inv_pos.mpr ⟨hi, inv_pos.mpr hp⟩) }
end

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

lemma infinitesimal_pos_iff_infinite_pos_inv {x : ℝ*} :
  infinite_pos x⁻¹ ↔ (infinitesimal x ∧ 0 < x) :=
by convert infinite_pos_iff_infinitesimal_inv_pos; simp only [inv_inv]

lemma infinitesimal_neg_iff_infinite_neg_inv {x : ℝ*} :
  infinite_neg x⁻¹ ↔ (infinitesimal x ∧ x < 0) :=
by convert infinite_neg_iff_infinitesimal_inv_neg; simp only [inv_inv]

theorem infinitesimal_iff_infinite_inv {x : ℝ*} (h : x ≠ 0) : infinitesimal x ↔ infinite x⁻¹ :=
by convert (infinite_iff_infinitesimal_inv (inv_ne_zero h)).symm; simp only [inv_inv]

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

theorem is_st_of_tendsto {f : ℕ → ℝ} {r : ℝ} (hf : tendsto f at_top (𝓝 r)) :
  is_st (of_seq f) r :=
have hg : tendsto (λ n, f n - r) at_top (𝓝 0) :=
  (sub_self r) ▸ (hf.sub tendsto_const_nhds),
by rw [←(zero_add r), ←(sub_add_cancel f (λ n, r))];
exact is_st_add (infinitesimal_of_tendsto_zero hg) (is_st_refl_real r)

lemma is_st_inv {x : ℝ*} {r : ℝ} (hi : ¬ infinitesimal x) : is_st x r → is_st x⁻¹ r⁻¹ :=
λ hxr, have h : x ≠ 0 := (λ h, hi (h.symm ▸ infinitesimal_zero)),
have H : _ := exists_st_of_not_infinite $ not_imp_not.mpr (infinitesimal_iff_infinite_inv h).mpr hi,
Exists.cases_on H $ λ s hs,
have H' : is_st 1 (r * s) := mul_inv_cancel h ▸ is_st_mul hxr hs,
have H'' : s = r⁻¹ := one_div r ▸ eq_one_div_of_mul_eq_one_right (eq_of_is_st_real H').symm,
H'' ▸ hs

lemma st_inv (x : ℝ*) : st x⁻¹ = (st x)⁻¹ :=
begin
  by_cases h0 : x = 0,
  rw [h0, inv_zero, ←coe_zero, st_id_real, inv_zero],
  by_cases h1 : infinitesimal x,
  rw [st_infinite ((infinitesimal_iff_infinite_inv h0).mp h1), st_of_is_st h1, inv_zero],
  by_cases h2 : infinite x,
  rw [st_of_is_st (infinitesimal_inv_of_infinite h2), st_infinite h2, inv_zero],
  exact st_of_is_st (is_st_inv h1 (is_st_st' h2)),
end

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

lemma infinite_pos_omega : infinite_pos ω :=
infinite_pos_iff_infinitesimal_inv_pos.mpr ⟨infinitesimal_epsilon, epsilon_pos⟩

lemma infinite_omega : infinite ω :=
(infinite_iff_infinitesimal_inv omega_ne_zero).mpr infinitesimal_epsilon

lemma infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos {x y : ℝ*} :
  infinite_pos x → ¬ infinitesimal y → 0 < y → infinite_pos (x * y) :=
λ hx hy₁ hy₂ r, have hy₁' : _ := not_forall.mp (by rw infinitesimal_def at hy₁; exact hy₁),
Exists.dcases_on hy₁' $ λ r₁ hy₁'',
have hyr : _ := by rw [not_imp, ←abs_lt, not_lt, abs_of_pos hy₂] at hy₁''; exact hy₁'',
by rw [←div_mul_cancel r (ne_of_gt hyr.1), coe_mul];
exact mul_lt_mul (hx (r / r₁)) hyr.2 (coe_lt_coe.2 hyr.1) (le_of_lt (hx 0))

lemma infinite_pos_mul_of_not_infinitesimal_pos_infinite_pos {x y : ℝ*} :
  ¬ infinitesimal x → 0 < x → infinite_pos y → infinite_pos (x * y) :=
λ hx hp hy, by rw mul_comm; exact infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hy hx hp

lemma infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg {x y : ℝ*} :
  infinite_neg x → ¬ infinitesimal y → y < 0 → infinite_pos (x * y) :=
by rw [infinite_neg_iff_infinite_pos_neg, ←neg_pos, ←neg_mul_neg, infinitesimal_neg_iff];
exact infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos

lemma infinite_pos_mul_of_not_infinitesimal_neg_infinite_neg {x y : ℝ*} :
  ¬ infinitesimal x → x < 0 → infinite_neg y → infinite_pos (x * y) :=
λ hx hp hy, by rw mul_comm; exact infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hy hx hp

lemma infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg {x y : ℝ*} :
  infinite_pos x → ¬ infinitesimal y → y < 0 → infinite_neg (x * y) :=
by rw [infinite_neg_iff_infinite_pos_neg, ←neg_pos, neg_mul_eq_mul_neg, infinitesimal_neg_iff];
exact infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos

lemma infinite_neg_mul_of_not_infinitesimal_neg_infinite_pos {x y : ℝ*} :
  ¬ infinitesimal x → x < 0 → infinite_pos y → infinite_neg (x * y) :=
λ hx hp hy, by rw mul_comm; exact infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hy hx hp

lemma infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos {x y : ℝ*} :
  infinite_neg x → ¬ infinitesimal y → 0 < y → infinite_neg (x * y) :=
by rw [infinite_neg_iff_infinite_pos_neg, infinite_neg_iff_infinite_pos_neg, neg_mul_eq_neg_mul];
exact infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos

lemma infinite_neg_mul_of_not_infinitesimal_pos_infinite_neg {x y : ℝ*} :
  ¬ infinitesimal x → 0 < x → infinite_neg y → infinite_neg (x * y) :=
λ hx hp hy, by rw mul_comm; exact infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hy hx hp

lemma infinite_pos_mul_infinite_pos {x y : ℝ*} :
  infinite_pos x → infinite_pos y → infinite_pos (x * y) :=
λ hx hy, infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos
hx (not_infinitesimal_of_infinite_pos hy) (hy 0)

lemma infinite_neg_mul_infinite_neg {x y : ℝ*} :
  infinite_neg x → infinite_neg y → infinite_pos (x * y) :=
λ hx hy, infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg
hx (not_infinitesimal_of_infinite_neg hy) (hy 0)

lemma infinite_pos_mul_infinite_neg {x y : ℝ*} :
  infinite_pos x → infinite_neg y → infinite_neg (x * y) :=
λ hx hy, infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg
hx (not_infinitesimal_of_infinite_neg hy) (hy 0)

lemma infinite_neg_mul_infinite_pos {x y : ℝ*} :
  infinite_neg x → infinite_pos y → infinite_neg (x * y) :=
λ hx hy, infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos
hx (not_infinitesimal_of_infinite_pos hy) (hy 0)

lemma infinite_mul_of_infinite_not_infinitesimal {x y : ℝ*} :
  infinite x → ¬ infinitesimal y → infinite (x * y) :=
λ hx hy, have h0 : y < 0 ∨ 0 < y := lt_or_gt_of_ne (λ H0, hy (eq.substr H0 (is_st_refl_real 0))),
or.dcases_on hx
  (or.dcases_on h0
    (λ H0 Hx, or.inr (infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg Hx hy H0))
    (λ H0 Hx, or.inl (infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos Hx hy H0)))
  (or.dcases_on h0
    (λ H0 Hx, or.inl (infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg Hx hy H0))
    (λ H0 Hx, or.inr (infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos Hx hy H0)))

lemma infinite_mul_of_not_infinitesimal_infinite {x y : ℝ*} :
  ¬ infinitesimal x → infinite y → infinite (x * y) :=
λ hx hy, by rw [mul_comm]; exact infinite_mul_of_infinite_not_infinitesimal hy hx

lemma infinite.mul {x y : ℝ*} : infinite x → infinite y → infinite (x * y) :=
λ hx hy, infinite_mul_of_infinite_not_infinitesimal hx (not_infinitesimal_of_infinite hy)

end hyperreal

namespace tactic
open positivity

private lemma hyperreal_coe_ne_zero {r : ℝ} : r ≠ 0 → (r : ℝ*) ≠ 0 := hyperreal.coe_ne_zero.2
private lemma hyperreal_coe_nonneg {r : ℝ} : 0 ≤ r → 0 ≤ (r : ℝ*) := hyperreal.coe_nonneg.2
private lemma hyperreal_coe_pos {r : ℝ} : 0 < r → 0 < (r : ℝ*) := hyperreal.coe_pos.2

/-- Extension for the `positivity` tactic: cast from `ℝ` to `ℝ*`. -/
@[positivity]
meta def positivity_coe_real_hyperreal : expr → tactic strictness
| `(@coe _ _ %%inst %%a) := do
  unify inst `(@coe_to_lift _ _ hyperreal.has_coe_t),
  strictness_a ← core a,
  match strictness_a with
  | positive p := positive <$> mk_app ``hyperreal_coe_pos [p]
  | nonnegative p := nonnegative <$> mk_app ``hyperreal_coe_nonneg [p]
  | nonzero p := nonzero <$> mk_app ``hyperreal_coe_ne_zero [p]
  end
| e := pp e >>= fail ∘ format.bracket "The expression " " is not of the form `(r : ℝ*)` for `r : ℝ`"

end tactic


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández

! This file was ported from Lean 3 source module ring_theory.dedekind_domain.finite_adele_ring
! leanprover-community/mathlib commit a8e7ac804fc39df0340c64906075787e0c90fa60
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.DedekindDomain.AdicValuation
import Mathbin.Topology.Algebra.UniformRing

/-!
# The finite adèle ring of a Dedekind domain
We define the ring of finite adèles of a Dedekind domain `R`.

## Main definitions
- `dedekind_domain.finite_integral_adeles` : product of `adic_completion_integers`, where `v`
  runs over all maximal ideals of `R`.
- `dedekind_domain.prod_adic_completions` : the product of `adic_completion`, where `v` runs over
  all maximal ideals of `R`.
- `dedekind_domain.finite_adele_ring` : The finite adèle ring of `R`, defined as the
  restricted product `Π'_v K_v`.

## Implementation notes
We are only interested on Dedekind domains of Krull dimension 1 (i.e., not fields). If `R` is a
field, its finite adèle ring is just defined to be the trivial ring.

## References
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]

## Tags
finite adèle ring, dedekind domain
-/

noncomputable section

open Function Set IsDedekindDomain IsDedekindDomain.HeightOneSpectrum

namespace DedekindDomain

variable (R K : Type _) [CommRing R] [IsDomain R] [IsDedekindDomain R] [Field K] [Algebra R K]
  [IsFractionRing R K] (v : HeightOneSpectrum R)

/-- The product of all `adic_completion_integers`, where `v` runs over the maximal ideals of `R`. -/
def FiniteIntegralAdeles : Type _ :=
  ∀ v : HeightOneSpectrum R, v.adicCompletionIntegers K deriving CommRing, TopologicalSpace,
  Inhabited
#align dedekind_domain.finite_integral_adeles DedekindDomain.FiniteIntegralAdeles

-- mathport name: exprR_hat
local notation "R_hat" => FiniteIntegralAdeles

/-- The product of all `adic_completion`, where `v` runs over the maximal ideals of `R`. -/
def ProdAdicCompletions :=
  ∀ v : HeightOneSpectrum R, v.adicCompletion K deriving NonUnitalNonAssocRing, TopologicalSpace,
  TopologicalRing, CommRing, Inhabited
#align dedekind_domain.prod_adic_completions DedekindDomain.ProdAdicCompletions

-- mathport name: exprK_hat
local notation "K_hat" => ProdAdicCompletions

namespace FiniteIntegralAdeles

noncomputable instance : Coe (R_hat R K) (K_hat R K) where coe x v := x v

theorem coe_apply (x : R_hat R K) (v : HeightOneSpectrum R) : (x : K_hat R K) v = ↑(x v) :=
  rfl
#align dedekind_domain.finite_integral_adeles.coe_apply DedekindDomain.FiniteIntegralAdeles.coe_apply

/-- The inclusion of `R_hat` in `K_hat` as a homomorphism of additive monoids. -/
@[simps]
def Coe.addMonoidHom : AddMonoidHom (R_hat R K) (K_hat R K)
    where
  toFun := coe
  map_zero' := rfl
  map_add' x y := by
    ext v
    simp only [coe_apply, Pi.add_apply, Subring.coe_add]
#align dedekind_domain.finite_integral_adeles.coe.add_monoid_hom DedekindDomain.FiniteIntegralAdeles.Coe.addMonoidHom

/-- The inclusion of `R_hat` in `K_hat` as a ring homomorphism. -/
@[simps]
def Coe.ringHom : RingHom (R_hat R K) (K_hat R K) :=
  { Coe.addMonoidHom R K with
    toFun := coe
    map_one' := rfl
    map_mul' := fun x y => by
      ext p
      simp only [Pi.mul_apply, Subring.coe_mul]
      rfl }
#align dedekind_domain.finite_integral_adeles.coe.ring_hom DedekindDomain.FiniteIntegralAdeles.Coe.ringHom

end FiniteIntegralAdeles

section AlgebraInstances

instance : Algebra K (K_hat R K) :=
  (by infer_instance : Algebra K <| ∀ v : HeightOneSpectrum R, v.adicCompletion K)

instance ProdAdicCompletions.algebra' : Algebra R (K_hat R K) :=
  (by infer_instance : Algebra R <| ∀ v : HeightOneSpectrum R, v.adicCompletion K)
#align dedekind_domain.prod_adic_completions.algebra' DedekindDomain.ProdAdicCompletions.algebra'

instance : IsScalarTower R K (K_hat R K) :=
  (by infer_instance : IsScalarTower R K <| ∀ v : HeightOneSpectrum R, v.adicCompletion K)

instance : Algebra R (R_hat R K) :=
  (by infer_instance : Algebra R <| ∀ v : HeightOneSpectrum R, v.adicCompletionIntegers K)

instance ProdAdicCompletions.algebraCompletions : Algebra (R_hat R K) (K_hat R K) :=
  (FiniteIntegralAdeles.Coe.ringHom R K).toAlgebra
#align dedekind_domain.prod_adic_completions.algebra_completions DedekindDomain.ProdAdicCompletions.algebraCompletions

instance ProdAdicCompletions.isScalarTower_completions : IsScalarTower R (R_hat R K) (K_hat R K) :=
  (by infer_instance :
    IsScalarTower R (∀ v : HeightOneSpectrum R, v.adicCompletionIntegers K) <|
      ∀ v : HeightOneSpectrum R, v.adicCompletion K)
#align dedekind_domain.prod_adic_completions.is_scalar_tower_completions DedekindDomain.ProdAdicCompletions.isScalarTower_completions

end AlgebraInstances

namespace FiniteIntegralAdeles

/-- The inclusion of `R_hat` in `K_hat` as an algebra homomorphism. -/
def Coe.algHom : AlgHom R (R_hat R K) (K_hat R K) :=
  { Coe.ringHom R K with
    toFun := coe
    commutes' := fun r => rfl }
#align dedekind_domain.finite_integral_adeles.coe.alg_hom DedekindDomain.FiniteIntegralAdeles.Coe.algHom

theorem Coe.algHom_apply (x : R_hat R K) (v : HeightOneSpectrum R) : (Coe.algHom R K) x v = x v :=
  rfl
#align dedekind_domain.finite_integral_adeles.coe.alg_hom_apply DedekindDomain.FiniteIntegralAdeles.Coe.algHom_apply

end FiniteIntegralAdeles

/-! ### The finite adèle ring of a Dedekind domain
We define the finite adèle ring of `R` as the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`. We prove that it is a commutative
ring. TODO: show that it is a topological ring with the restricted product topology. -/

namespace ProdAdicCompletions

variable {R K}

/-- An element `x : K_hat R K` is a finite adèle if for all but finitely many height one ideals
  `v`, the component `x v` is a `v`-adic integer. -/
def IsFiniteAdele (x : K_hat R K) :=
  ∀ᶠ v : HeightOneSpectrum R in Filter.cofinite, x v ∈ v.adicCompletionIntegers K
#align dedekind_domain.prod_adic_completions.is_finite_adele DedekindDomain.ProdAdicCompletions.IsFiniteAdele

namespace IsFiniteAdele

/-- The sum of two finite adèles is a finite adèle. -/
theorem add {x y : K_hat R K} (hx : x.IsFiniteAdele) (hy : y.IsFiniteAdele) :
    (x + y).IsFiniteAdele :=
  by
  rw [is_finite_adele, Filter.eventually_cofinite] at hx hy⊢
  have h_subset :
    { v : height_one_spectrum R | ¬(x + y) v ∈ v.adicCompletionIntegers K } ⊆
      { v : height_one_spectrum R | ¬x v ∈ v.adicCompletionIntegers K } ∪
        { v : height_one_spectrum R | ¬y v ∈ v.adicCompletionIntegers K } :=
    by
    intro v hv
    rw [mem_union, mem_set_of_eq, mem_set_of_eq]
    rw [mem_set_of_eq] at hv
    contrapose! hv
    rw [mem_adic_completion_integers, mem_adic_completion_integers, ← max_le_iff] at hv
    rw [mem_adic_completion_integers, Pi.add_apply]
    exact le_trans (valued.v.map_add_le_max' (x v) (y v)) hv
  exact (hx.union hy).Subset h_subset
#align dedekind_domain.prod_adic_completions.is_finite_adele.add DedekindDomain.ProdAdicCompletions.IsFiniteAdele.add

/-- The tuple `(0)_v` is a finite adèle. -/
theorem zero : (0 : K_hat R K).IsFiniteAdele :=
  by
  rw [is_finite_adele, Filter.eventually_cofinite]
  have h_empty :
    { v : height_one_spectrum R | ¬(0 : v.adicCompletion K) ∈ v.adicCompletionIntegers K } = ∅ :=
    by
    ext v
    rw [mem_empty_iff_false, iff_false_iff]
    intro hv
    rw [mem_set_of_eq] at hv
    apply hv
    rw [mem_adic_completion_integers]
    have h_zero : (Valued.v (0 : v.adic_completion K) : WithZero (Multiplicative ℤ)) = 0 :=
      valued.v.map_zero'
    rw [h_zero]
    exact zero_le_one' _
  simp_rw [Pi.zero_apply, h_empty]
  exact finite_empty
#align dedekind_domain.prod_adic_completions.is_finite_adele.zero DedekindDomain.ProdAdicCompletions.IsFiniteAdele.zero

/-- The negative of a finite adèle is a finite adèle. -/
theorem neg {x : K_hat R K} (hx : x.IsFiniteAdele) : (-x).IsFiniteAdele :=
  by
  rw [is_finite_adele] at hx⊢
  have h :
    ∀ v : height_one_spectrum R,
      -x v ∈ v.adicCompletionIntegers K ↔ x v ∈ v.adicCompletionIntegers K :=
    by
    intro v
    rw [mem_adic_completion_integers, mem_adic_completion_integers, Valuation.map_neg]
  simpa only [Pi.neg_apply, h] using hx
#align dedekind_domain.prod_adic_completions.is_finite_adele.neg DedekindDomain.ProdAdicCompletions.IsFiniteAdele.neg

/-- The product of two finite adèles is a finite adèle. -/
theorem mul {x y : K_hat R K} (hx : x.IsFiniteAdele) (hy : y.IsFiniteAdele) :
    (x * y).IsFiniteAdele :=
  by
  rw [is_finite_adele, Filter.eventually_cofinite] at hx hy⊢
  have h_subset :
    { v : height_one_spectrum R | ¬(x * y) v ∈ v.adicCompletionIntegers K } ⊆
      { v : height_one_spectrum R | ¬x v ∈ v.adicCompletionIntegers K } ∪
        { v : height_one_spectrum R | ¬y v ∈ v.adicCompletionIntegers K } :=
    by
    intro v hv
    rw [mem_union, mem_set_of_eq, mem_set_of_eq]
    rw [mem_set_of_eq] at hv
    contrapose! hv
    rw [mem_adic_completion_integers, mem_adic_completion_integers] at hv
    have h_mul : Valued.v (x v * y v) = Valued.v (x v) * Valued.v (y v) :=
      Valued.v.map_mul' (x v) (y v)
    rw [mem_adic_completion_integers, Pi.mul_apply, h_mul]
    exact
      @mul_le_one' (WithZero (Multiplicative ℤ)) _ _ (OrderedCommMonoid.to_covariantClass_left _) _
        _ hv.left hv.right
  exact (hx.union hy).Subset h_subset
#align dedekind_domain.prod_adic_completions.is_finite_adele.mul DedekindDomain.ProdAdicCompletions.IsFiniteAdele.mul

/-- The tuple `(1)_v` is a finite adèle. -/
theorem one : (1 : K_hat R K).IsFiniteAdele :=
  by
  rw [is_finite_adele, Filter.eventually_cofinite]
  have h_empty :
    { v : height_one_spectrum R | ¬(1 : v.adicCompletion K) ∈ v.adicCompletionIntegers K } = ∅ :=
    by
    ext v
    rw [mem_empty_iff_false, iff_false_iff]
    intro hv
    rw [mem_set_of_eq] at hv
    apply hv
    rw [mem_adic_completion_integers]
    exact le_of_eq valued.v.map_one'
  simp_rw [Pi.one_apply, h_empty]
  exact finite_empty
#align dedekind_domain.prod_adic_completions.is_finite_adele.one DedekindDomain.ProdAdicCompletions.IsFiniteAdele.one

end IsFiniteAdele

end ProdAdicCompletions

open ProdAdicCompletions.IsFiniteAdele

variable (R K)

/-- The finite adèle ring of `R` is the restricted product over all maximal ideals `v` of `R`
of `adic_completion` with respect to `adic_completion_integers`. -/
noncomputable def finiteAdeleRing : Subring (K_hat R K)
    where
  carrier := { x : K_hat R K | x.IsFiniteAdele }
  mul_mem' _ _ hx hy := mul hx hy
  one_mem' := one
  add_mem' _ _ hx hy := add hx hy
  zero_mem' := zero
  neg_mem' _ hx := neg hx
#align dedekind_domain.finite_adele_ring DedekindDomain.finiteAdeleRing

variable {R K}

@[simp]
theorem mem_finiteAdeleRing_iff (x : K_hat R K) : x ∈ finiteAdeleRing R K ↔ x.IsFiniteAdele :=
  Iff.rfl
#align dedekind_domain.mem_finite_adele_ring_iff DedekindDomain.mem_finiteAdeleRing_iff

end DedekindDomain


import game.world_05_function
namespace mynat

example (P Q : Prop) (p : P) (h : P → Q) : Q := begin[nat_num_game]
  exact h p,
end

lemma imp_self (P : Prop) : P → P := begin[nat_num_game]
  intro p,
  exact p,
end

lemma maze (P Q R S T U: Prop) (p : P) (h : P → Q) (i : Q → R) (j : Q → T) (k : S → T) (l : T → U) : U := begin[nat_num_game]
  apply l ∘ j ∘ h,
  exact p,
end

example (P Q : Prop) : P → (Q → P) := begin[nat_num_game]
  intros p _,
  exact p,
end

example (P Q R : Prop) : (P → (Q → R)) → ((P → Q) → (P → R)) := begin[nat_num_game]
  intros f g p,
  apply f p,
  apply g p,
end

lemma imp_trans (P Q R : Prop) : (P → Q) → ((Q → R) → (P → R)) := begin[nat_num_game]
  intros fpq fqr,
  apply fqr ∘ fpq,
end

lemma contrapositive (P Q : Prop) : (P → Q) → (¬ Q → ¬ P) := begin[nat_num_game]
  intros pq nq,
  apply nq ∘ pq,
end

example (A B C D E F G H I J K L : Prop)
    (f1 : A → B) (f2 : B → E) (f3 : E → D) (f4 : D → A) (f5 : E → F) (f6 : F → C) (f7 : B → C) (f8 : F → G)
    (f9 : G → J) (f10 : I → J) (f11 : J → I) (f12 : I → H) (f13 : E → H) (f14 : H → K) (f15 : I → L)
    : A → L := begin[nat_num_game]
  apply f15 ∘ f11 ∘ f9 ∘ f8 ∘ f5 ∘ f2 ∘ f1,
end

end mynat


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.polynomial.derivative
import Mathlib.tactic.ring
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Chebyshev polynomials

The Chebyshev polynomials are two families of polynomials indexed by `ℕ`,
with integral coefficients.

See the file `ring_theory.polynomial.chebyshev.basic` for more properties.

## Main definitions

* `polynomial.chebyshev₁`: the Chebyshev polynomials of the first kind.
* `polynomial.chebyshev₂`: the Chebyshev polynomials of the second kind.
* `polynomial.lambdashev`: a variant on the Chebyshev polynomials that define a Lambda structure
  on `polynomial ℤ`.

## Main statements

* The formal derivative of the Chebyshev polynomials of the first kind is a scalar multiple of the
  Chebyshev polynomials of the second kind.

## Implementation details

In this file we only give definitions and some very elementary simp-lemmas.
This way, we can import this file in `analysis.special_functions.trigonometric`,
and import that file in turn, in `ring_theory.polynomial.chebyshev.basic`.

## References

[Lionel Ponton, _Roots of the Chebyshev polynomials: A purely algebraic approach_]
[ponton2020chebyshev]

## TODO

* Redefine and/or relate the definition of Chebyshev polynomials to `linear_recurrence`.
* Add explicit formula involving square roots for Chebyshev polynomials
  `ring_theory.polynomial.chebyshev.basic`.
* Compute zeroes and extrema of Chebyshev polynomials.
* Prove that the roots of the Chebyshev polynomials (except 0) are irrational.
* Prove minimax properties of Chebyshev polynomials.
* Define a variant of Chebyshev polynomials of the second kind removing the 2
  (sometimes Dickson polynomials of the second kind) or even more general Dickson polynomials.
* Prove that the adjacency matrices of simply laced Dynkin diagrams are precisely the adjacency
  matrices of simple connected graphs which annihilate the Dickson polynomials.
-/

namespace polynomial

/-- `chebyshev₁ n` is the `n`-th Chebyshev polynomial of the first kind -/
def chebyshev₁ (R : Type u_1) [comm_ring R] : ℕ → polynomial R :=
  sorry

@[simp] theorem chebyshev₁_zero (R : Type u_1) [comm_ring R] : chebyshev₁ R 0 = 1 :=
  rfl

@[simp] theorem chebyshev₁_one (R : Type u_1) [comm_ring R] : chebyshev₁ R 1 = X :=
  rfl

theorem chebyshev₁_two (R : Type u_1) [comm_ring R] : chebyshev₁ R (bit0 1) = bit0 1 * X ^ bit0 1 - 1 := sorry

@[simp] theorem chebyshev₁_add_two (R : Type u_1) [comm_ring R] (n : ℕ) : chebyshev₁ R (n + bit0 1) = bit0 1 * X * chebyshev₁ R (n + 1) - chebyshev₁ R n := sorry

theorem chebyshev₁_of_two_le (R : Type u_1) [comm_ring R] (n : ℕ) (h : bit0 1 ≤ n) : chebyshev₁ R n = bit0 1 * X * chebyshev₁ R (n - 1) - chebyshev₁ R (n - bit0 1) := sorry

theorem map_chebyshev₁ {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] (f : R →+* S) (n : ℕ) : map f (chebyshev₁ R n) = chebyshev₁ S n := sorry

/-- `lambdashev R n` is equal to `2 * (chebyshev₁ R n).comp (X / 2)`.
It is a family of polynomials that satisfies
`lambdashev (zmod p) p = X ^ p`, and therefore defines a Lambda structure on `polynomial ℤ`. -/
def lambdashev (R : Type u_1) [comm_ring R] : ℕ → polynomial R :=
  sorry

@[simp] theorem lambdashev_zero (R : Type u_1) [comm_ring R] : lambdashev R 0 = bit0 1 :=
  rfl

@[simp] theorem lambdashev_one (R : Type u_1) [comm_ring R] : lambdashev R 1 = X :=
  rfl

theorem lambdashev_two (R : Type u_1) [comm_ring R] : lambdashev R (bit0 1) = X ^ bit0 1 - bit0 1 := sorry

@[simp] theorem lambdashev_add_two (R : Type u_1) [comm_ring R] (n : ℕ) : lambdashev R (n + bit0 1) = X * lambdashev R (n + 1) - lambdashev R n := sorry

theorem lambdashev_eq_two_le (R : Type u_1) [comm_ring R] (n : ℕ) (h : bit0 1 ≤ n) : lambdashev R n = X * lambdashev R (n - 1) - lambdashev R (n - bit0 1) := sorry

theorem map_lambdashev {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] (f : R →+* S) (n : ℕ) : map f (lambdashev R n) = lambdashev S n := sorry

end polynomial

namespace polynomial

/-- `chebyshev₂ n` is the `n`-th Chebyshev polynomial of the second kind -/
def chebyshev₂ (R : Type u_1) [comm_ring R] : ℕ → polynomial R :=
  sorry

@[simp] theorem chebyshev₂_zero (R : Type u_1) [comm_ring R] : chebyshev₂ R 0 = 1 :=
  rfl

@[simp] theorem chebyshev₂_one (R : Type u_1) [comm_ring R] : chebyshev₂ R 1 = bit0 1 * X :=
  rfl

theorem chebyshev₂_two (R : Type u_1) [comm_ring R] : chebyshev₂ R (bit0 1) = bit0 (bit0 1) * X ^ bit0 1 - 1 := sorry

@[simp] theorem chebyshev₂_add_two (R : Type u_1) [comm_ring R] (n : ℕ) : chebyshev₂ R (n + bit0 1) = bit0 1 * X * chebyshev₂ R (n + 1) - chebyshev₂ R n := sorry

theorem chebyshev₂_of_two_le (R : Type u_1) [comm_ring R] (n : ℕ) (h : bit0 1 ≤ n) : chebyshev₂ R n = bit0 1 * X * chebyshev₂ R (n - 1) - chebyshev₂ R (n - bit0 1) := sorry

theorem chebyshev₂_eq_X_mul_chebyshev₂_add_chebyshev₁ (R : Type u_1) [comm_ring R] (n : ℕ) : chebyshev₂ R (n + 1) = X * chebyshev₂ R n + chebyshev₁ R (n + 1) := sorry

theorem chebyshev₁_eq_chebyshev₂_sub_X_mul_chebyshev₂ (R : Type u_1) [comm_ring R] (n : ℕ) : chebyshev₁ R (n + 1) = chebyshev₂ R (n + 1) - X * chebyshev₂ R n := sorry

theorem chebyshev₁_eq_X_mul_chebyshev₁_sub_pol_chebyshev₂ (R : Type u_1) [comm_ring R] (n : ℕ) : chebyshev₁ R (n + bit0 1) = X * chebyshev₁ R (n + 1) - (1 - X ^ bit0 1) * chebyshev₂ R n := sorry

theorem one_sub_X_pow_two_mul_chebyshev₂_eq_pol_in_chebyshev₁ (R : Type u_1) [comm_ring R] (n : ℕ) : (1 - X ^ bit0 1) * chebyshev₂ R n = X * chebyshev₁ R (n + 1) - chebyshev₁ R (n + bit0 1) := sorry

@[simp] theorem map_chebyshev₂ {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] (f : R →+* S) (n : ℕ) : map f (chebyshev₂ R n) = chebyshev₂ S n := sorry

theorem chebyshev₁_derivative_eq_chebyshev₂ {R : Type u_1} [comm_ring R] (n : ℕ) : coe_fn derivative (chebyshev₁ R (n + 1)) = (↑n + 1) * chebyshev₂ R n := sorry

theorem one_sub_X_pow_two_mul_derivative_chebyshev₁_eq_poly_in_chebyshev₁ {R : Type u_1} [comm_ring R] (n : ℕ) : (1 - X ^ bit0 1) * coe_fn derivative (chebyshev₁ R (n + 1)) = (↑n + 1) * (chebyshev₁ R n - X * chebyshev₁ R (n + 1)) := sorry

theorem add_one_mul_chebyshev₁_eq_poly_in_chebyshev₂ {R : Type u_1} [comm_ring R] (n : ℕ) : (↑n + 1) * chebyshev₁ R (n + 1) = X * chebyshev₂ R n - (1 - X ^ bit0 1) * coe_fn derivative (chebyshev₂ R n) := sorry


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

! This file was ported from Lean 3 source module algebra.category.Module.colimits
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Module.Basic
import Mathbin.CategoryTheory.ConcreteCategory.Elementwise

/-!
# The category of R-modules has all colimits.

This file uses a "pre-automated" approach, just as for `Mon/colimits.lean`.

Note that finite colimits can already be obtained from the instance `abelian (Module R)`.

TODO:
In fact, in `Module R` there is a much nicer model of colimits as quotients
of finitely supported functions, and we really should implement this as well (or instead).
-/

universe u v w

open CategoryTheory

open CategoryTheory.Limits

variable {R : Type u} [Ring R]

-- [ROBOT VOICE]:
-- You should pretend for now that this file was automatically generated.
-- It follows the same template as colimits in Mon.
namespace ModuleCat.Colimits

/-!
We build the colimit of a diagram in `Module` by constructing the
free group on the disjoint union of all the abelian groups in the diagram,
then taking the quotient by the abelian group laws within each abelian group,
and the identifications given by the morphisms in the diagram.
-/

variable {J : Type w} [Category.{v} J] (F : J ⥤ ModuleCat.{max u v w} R)

/-- An inductive type representing all module expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
inductive Prequotient-- There's always `of`

  | of : ∀ (j : J) (x : F.obj j), prequotient-- Then one generator for each operation

  | zero : prequotient
  | neg : prequotient → prequotient
  | add : prequotient → prequotient → prequotient
  | smul : R → prequotient → prequotient
#align Module.colimits.prequotient ModuleCat.Colimits.Prequotient

instance : Inhabited (Prequotient F) :=
  ⟨Prequotient.zero⟩

open Prequotient

/-- The relation on `prequotient` saying when two expressions are equal
because of the module laws, or
because one element is mapped to another by a morphism in the diagram.
-/
inductive Relation : Prequotient F → Prequotient F → Prop-- Make it an equivalence relation:

  | refl : ∀ x, relation x x
  | symm : ∀ (x y) (h : relation x y), relation y x
  |
  trans :
    ∀ (x y z) (h : relation x y) (k : relation y z), relation x z-- There's always a `map` relation

  |
  map :
    ∀ (j j' : J) (f : j ⟶ j') (x : F.obj j),
      relation (of j' (F.map f x))
        (of j x)-- Then one relation per operation, describing the interaction with `of`

  | zero : ∀ j, relation (of j 0) zero
  | neg : ∀ (j) (x : F.obj j), relation (of j (-x)) (neg (of j x))
  | add : ∀ (j) (x y : F.obj j), relation (of j (x + y)) (add (of j x) (of j y))
  |
  smul :
    ∀ (j) (s) (x : F.obj j),
      relation (of j (s • x)) (smul s (of j x))-- Then one relation per argument of each operation

  | neg_1 : ∀ (x x') (r : relation x x'), relation (neg x) (neg x')
  | add_1 : ∀ (x x' y) (r : relation x x'), relation (add x y) (add x' y)
  | add_2 : ∀ (x y y') (r : relation y y'), relation (add x y) (add x y')
  |
  smul_1 :
    ∀ (s) (x x') (r : relation x x'), relation (smul s x) (smul s x')-- And one relation per axiom

  | zero_add : ∀ x, relation (add zero x) x
  | add_zero : ∀ x, relation (add x zero) x
  | add_left_neg : ∀ x, relation (add (neg x) x) zero
  | add_comm : ∀ x y, relation (add x y) (add y x)
  | add_assoc : ∀ x y z, relation (add (add x y) z) (add x (add y z))
  | one_smul : ∀ x, relation (smul 1 x) x
  | mul_smul : ∀ s t x, relation (smul (s * t) x) (smul s (smul t x))
  | smul_add : ∀ s x y, relation (smul s (add x y)) (add (smul s x) (smul s y))
  | smul_zero : ∀ s, relation (smul s zero) zero
  | add_smul : ∀ s t x, relation (smul (s + t) x) (add (smul s x) (smul t x))
  | zero_smul : ∀ x, relation (smul 0 x) zero
#align Module.colimits.relation ModuleCat.Colimits.Relation

/-- The setoid corresponding to module expressions modulo module relations and identifications.
-/
def colimitSetoid : Setoid (Prequotient F)
    where
  R := Relation F
  iseqv := ⟨Relation.refl, Relation.symm, Relation.trans⟩
#align Module.colimits.colimit_setoid ModuleCat.Colimits.colimitSetoid

attribute [instance] colimit_setoid

/-- The underlying type of the colimit of a diagram in `Module R`.
-/
def ColimitType : Type max u v w :=
  Quotient (colimitSetoid F)deriving Inhabited
#align Module.colimits.colimit_type ModuleCat.Colimits.ColimitType

instance : AddCommGroup (ColimitType F)
    where
  zero := Quot.mk _ zero
  neg := by
    fapply @Quot.lift
    · intro x
      exact Quot.mk _ (neg x)
    · intro x x' r
      apply Quot.sound
      exact relation.neg_1 _ _ r
  add := by
    fapply @Quot.lift _ _ (colimit_type F → colimit_type F)
    · intro x
      fapply @Quot.lift
      · intro y
        exact Quot.mk _ (add x y)
      · intro y y' r
        apply Quot.sound
        exact relation.add_2 _ _ _ r
    · intro x x' r
      funext y
      induction y
      dsimp
      apply Quot.sound
      · exact relation.add_1 _ _ _ r
      · rfl
  zero_add x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.zero_add
    rfl
  add_zero x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.add_zero
    rfl
  add_left_neg x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.add_left_neg
    rfl
  add_comm x y := by
    induction x
    induction y
    dsimp
    apply Quot.sound
    apply relation.add_comm
    rfl
    rfl
  add_assoc x y z := by
    induction x
    induction y
    induction z
    dsimp
    apply Quot.sound
    apply relation.add_assoc
    rfl
    rfl
    rfl

instance : Module R (ColimitType F)
    where
  smul s := by
    fapply @Quot.lift
    · intro x
      exact Quot.mk _ (smul s x)
    · intro x x' r
      apply Quot.sound
      exact relation.smul_1 s _ _ r
  one_smul x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.one_smul
    rfl
  mul_smul s t x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.mul_smul
    rfl
  smul_add s x y := by
    induction x
    induction y
    dsimp
    apply Quot.sound
    apply relation.smul_add
    rfl
    rfl
  smul_zero s := by apply Quot.sound; apply relation.smul_zero
  add_smul s t x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.add_smul
    rfl
  zero_smul x := by
    induction x
    dsimp
    apply Quot.sound
    apply relation.zero_smul
    rfl

@[simp]
theorem quot_zero : Quot.mk Setoid.r zero = (0 : ColimitType F) :=
  rfl
#align Module.colimits.quot_zero ModuleCat.Colimits.quot_zero

@[simp]
theorem quot_neg (x) : Quot.mk Setoid.r (neg x) = (-Quot.mk Setoid.r x : ColimitType F) :=
  rfl
#align Module.colimits.quot_neg ModuleCat.Colimits.quot_neg

@[simp]
theorem quot_add (x y) :
    Quot.mk Setoid.r (add x y) = (Quot.mk Setoid.r x + Quot.mk Setoid.r y : ColimitType F) :=
  rfl
#align Module.colimits.quot_add ModuleCat.Colimits.quot_add

@[simp]
theorem quot_smul (s x) : Quot.mk Setoid.r (smul s x) = (s • Quot.mk Setoid.r x : ColimitType F) :=
  rfl
#align Module.colimits.quot_smul ModuleCat.Colimits.quot_smul

/-- The bundled module giving the colimit of a diagram. -/
def colimit : ModuleCat R :=
  ModuleCat.of R (ColimitType F)
#align Module.colimits.colimit ModuleCat.Colimits.colimit

/-- The function from a given module in the diagram to the colimit module. -/
def coconeFun (j : J) (x : F.obj j) : ColimitType F :=
  Quot.mk _ (of j x)
#align Module.colimits.cocone_fun ModuleCat.Colimits.coconeFun

/-- The group homomorphism from a given module in the diagram to the colimit module. -/
def coconeMorphism (j : J) : F.obj j ⟶ colimit F
    where
  toFun := coconeFun F j
  map_smul' := by
    intros
    apply Quot.sound
    apply relation.smul
  map_add' := by intros <;> apply Quot.sound <;> apply relation.add
#align Module.colimits.cocone_morphism ModuleCat.Colimits.coconeMorphism

@[simp]
theorem cocone_naturality {j j' : J} (f : j ⟶ j') :
    F.map f ≫ coconeMorphism F j' = coconeMorphism F j :=
  by
  ext
  apply Quot.sound
  apply Relation.Map
#align Module.colimits.cocone_naturality ModuleCat.Colimits.cocone_naturality

@[simp]
theorem cocone_naturality_components (j j' : J) (f : j ⟶ j') (x : F.obj j) :
    (coconeMorphism F j') (F.map f x) = (coconeMorphism F j) x :=
  by
  rw [← cocone_naturality F f]
  rfl
#align Module.colimits.cocone_naturality_components ModuleCat.Colimits.cocone_naturality_components

/-- The cocone over the proposed colimit module. -/
def colimitCocone : Cocone F where
  pt := colimit F
  ι := { app := coconeMorphism F }
#align Module.colimits.colimit_cocone ModuleCat.Colimits.colimitCocone

/-- The function from the free module on the diagram to the cone point of any other cocone. -/
@[simp]
def descFunLift (s : Cocone F) : Prequotient F → s.pt
  | of j x => (s.ι.app j) x
  | zero => 0
  | neg x => -desc_fun_lift x
  | add x y => desc_fun_lift x + desc_fun_lift y
  | smul s x => s • desc_fun_lift x
#align Module.colimits.desc_fun_lift ModuleCat.Colimits.descFunLift

/-- The function from the colimit module to the cone point of any other cocone. -/
def descFun (s : Cocone F) : ColimitType F → s.pt :=
  by
  fapply Quot.lift
  · exact desc_fun_lift F s
  · intro x y r
    induction r <;> try dsimp
    -- refl
    · rfl
    -- symm
    · exact r_ih.symm
    -- trans
    · exact Eq.trans r_ih_h r_ih_k
    -- map
    · simp
    -- zero
    · simp
    -- neg
    · simp
    -- add
    · simp
    -- smul,
    · simp
    -- neg_1
    · rw [r_ih]
    -- add_1
    · rw [r_ih]
    -- add_2
    · rw [r_ih]
    -- smul_1
    · rw [r_ih]
    -- zero_add
    · rw [zero_add]
    -- add_zero
    · rw [add_zero]
    -- add_left_neg
    · rw [add_left_neg]
    -- add_comm
    · rw [add_comm]
    -- add_assoc
    · rw [add_assoc]
    -- one_smul
    · rw [one_smul]
    -- mul_smul
    · rw [mul_smul]
    -- smul_add
    · rw [smul_add]
    -- smul_zero
    · rw [smul_zero]
    -- add_smul
    · rw [add_smul]
    -- zero_smul
    · rw [zero_smul]
#align Module.colimits.desc_fun ModuleCat.Colimits.descFun

/-- The group homomorphism from the colimit module to the cone point of any other cocone. -/
def descMorphism (s : Cocone F) : colimit F ⟶ s.pt
    where
  toFun := descFun F s
  map_smul' s x := by induction x <;> rfl
  map_add' x y := by induction x <;> induction y <;> rfl
#align Module.colimits.desc_morphism ModuleCat.Colimits.descMorphism

/-- Evidence that the proposed colimit is the colimit. -/
def colimitCoconeIsColimit : IsColimit (colimitCocone F)
    where
  desc s := descMorphism F s
  uniq s m w := by
    ext
    induction x
    induction x
    · have w' :=
        congr_fun (congr_arg (fun f : F.obj x_j ⟶ s.X => (f : F.obj x_j → s.X)) (w x_j)) x_x
      erw [w']
      rfl
    · simp [*]
    · simp [*]
    · simp [*]
    · simp [*]
    rfl
#align Module.colimits.colimit_cocone_is_colimit ModuleCat.Colimits.colimitCoconeIsColimit

instance hasColimits_moduleCat : HasColimits (ModuleCat.{max v u} R)
    where HasColimitsOfShape J 𝒥 :=
    {
      HasColimit := fun F =>
        has_colimit.mk
          { Cocone := colimit_cocone F
            IsColimit := colimit_cocone_is_colimit F } }
#align Module.colimits.has_colimits_Module ModuleCat.Colimits.hasColimits_moduleCat

-- We manually add a `has_colimits` instance with universe parameters swapped, for otherwise
-- the instance is not found by typeclass search.
instance hasColimits_Module' (R : Type u) [Ring R] : HasColimits (ModuleCat.{max u v} R) :=
  ModuleCat.Colimits.hasColimits_moduleCat.{u, v}
#align Module.colimits.has_colimits_Module' ModuleCat.Colimits.hasColimits_Module'

-- We manually add a `has_colimits` instance with equal universe parameters, for otherwise
-- the instance is not found by typeclass search.
instance hasColimits_Module'' (R : Type u) [Ring R] : HasColimits (ModuleCat.{u} R) :=
  ModuleCat.Colimits.hasColimits_moduleCat.{u, u}
#align Module.colimits.has_colimits_Module'' ModuleCat.Colimits.hasColimits_Module''

-- Sanity checks, just to make sure typeclass search can find the instances we want.
example (R : Type u) [Ring R] : HasColimits (ModuleCat.{max v u} R) :=
  inferInstance

example (R : Type u) [Ring R] : HasColimits (ModuleCat.{max u v} R) :=
  inferInstance

example (R : Type u) [Ring R] : HasColimits (ModuleCat.{u} R) :=
  inferInstance

end ModuleCat.Colimits


example (P Q R : Prop) : (P → (Q → R)) → ((P → Q) → (P → R)) :=
begin
intros f g p,
apply f,
exact p,
exact g(p),
end


def g (x : Nat) : List (Nat × List Nat) :=
[(x, [x, x]), (x, [])]

def h (x : Nat) : List (Nat × List Nat) :=
g x |>.filter fun ⟨_, xs⟩ => xs.isEmpty

theorem ex1 : g 10 = [(10, [10, 10]), (10, [])] :=
rfl

theorem ex2 : h 10 = [(10, [])] :=
rfl


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad
-/

/-!
# booleans

This file proves various trivial lemmas about booleans and their
relation to decidable propositions.

## Notations

This file introduces the notation `!b` for `bnot b`, the boolean "not".

## Tags
bool, boolean, De Morgan
-/

prefix `!`:90 := bnot

namespace bool

-- TODO: duplicate of a lemma in core
theorem coe_sort_tt : coe_sort.{1 1} tt = true := coe_sort_tt

-- TODO: duplicate of a lemma in core
theorem coe_sort_ff : coe_sort.{1 1} ff = false := coe_sort_ff

-- TODO: duplicate of a lemma in core
theorem to_bool_true {h} : @to_bool true h = tt :=
to_bool_true_eq_tt h

-- TODO: duplicate of a lemma in core
theorem to_bool_false {h} : @to_bool false h = ff :=
to_bool_false_eq_ff h

@[simp] theorem to_bool_coe (b:bool) {h} : @to_bool b h = b :=
(show _ = to_bool b, by congr).trans (by cases b; refl)

theorem coe_to_bool (p : Prop) [decidable p] : to_bool p ↔ p := to_bool_iff _

@[simp] lemma of_to_bool_iff {p : Prop} [decidable p] : to_bool p ↔ p :=
⟨of_to_bool_true, _root_.to_bool_true⟩

@[simp] lemma tt_eq_to_bool_iff {p : Prop} [decidable p] : tt = to_bool p ↔ p :=
eq_comm.trans of_to_bool_iff

@[simp] lemma ff_eq_to_bool_iff {p : Prop} [decidable p] : ff = to_bool p ↔ ¬ p :=
eq_comm.trans (to_bool_ff_iff _)

@[simp] theorem to_bool_not (p : Prop) [decidable p] : to_bool (¬ p) = bnot (to_bool p) :=
by by_cases p; simp *

@[simp] theorem to_bool_and (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∧ q) = p && q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_or (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∨ q) = p || q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_eq {p q : Prop} [decidable p] [decidable q] :
  to_bool p = to_bool q ↔ (p ↔ q) :=
⟨λ h, (coe_to_bool p).symm.trans $ by simp [h], to_bool_congr⟩

lemma not_ff : ¬ ff := by simp

@[simp] theorem default_bool : default bool = ff := rfl

theorem dichotomy (b : bool) : b = ff ∨ b = tt :=
by cases b; simp

@[simp] theorem forall_bool {p : bool → Prop} : (∀ b, p b) ↔ p ff ∧ p tt :=
⟨λ h, by simp [h], λ ⟨h₁, h₂⟩ b, by cases b; assumption⟩

@[simp] theorem exists_bool {p : bool → Prop} : (∃ b, p b) ↔ p ff ∨ p tt :=
⟨λ ⟨b, h⟩, by cases b; [exact or.inl h, exact or.inr h],
 λ h, by cases h; exact ⟨_, h⟩⟩

/-- If `p b` is decidable for all `b : bool`, then `∀ b, p b` is decidable -/
instance decidable_forall_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∀ b, p b) :=
decidable_of_decidable_of_iff and.decidable forall_bool.symm

/-- If `p b` is decidable for all `b : bool`, then `∃ b, p b` is decidable -/
instance decidable_exists_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∃ b, p b) :=
decidable_of_decidable_of_iff or.decidable exists_bool.symm

@[simp] theorem cond_ff {α} (t e : α) : cond ff t e = e := rfl

@[simp] theorem cond_tt {α} (t e : α) : cond tt t e = t := rfl

@[simp] theorem cond_to_bool {α} (p : Prop) [decidable p] (t e : α) :
  cond (to_bool p) t e = if p then t else e :=
by by_cases p; simp *

theorem coe_bool_iff : ∀ {a b : bool}, (a ↔ b) ↔ a = b := dec_trivial

theorem eq_tt_of_ne_ff : ∀ {a : bool}, a ≠ ff → a = tt := dec_trivial

theorem eq_ff_of_ne_tt : ∀ {a : bool}, a ≠ tt → a = ff := dec_trivial

theorem bor_comm : ∀ a b, a || b = b || a := dec_trivial

@[simp] theorem bor_assoc : ∀ a b c, (a || b) || c = a || (b || c) := dec_trivial

theorem bor_left_comm : ∀ a b c, a || (b || c) = b || (a || c) := dec_trivial

theorem bor_inl {a b : bool} (H : a) : a || b :=
by simp [H]

theorem bor_inr {a b : bool} (H : b) : a || b :=
by simp [H]

theorem band_comm : ∀ a b, a && b = b && a := dec_trivial

@[simp] theorem band_assoc : ∀ a b c, (a && b) && c = a && (b && c) := dec_trivial

theorem band_left_comm : ∀ a b c, a && (b && c) = b && (a && c) := dec_trivial

theorem band_elim_left : ∀ {a b : bool}, a && b → a := dec_trivial

theorem band_intro : ∀ {a b : bool}, a → b → a && b := dec_trivial

theorem band_elim_right : ∀ {a b : bool}, a && b → b := dec_trivial

@[simp] theorem bnot_false : bnot ff = tt := rfl

@[simp] theorem bnot_true : bnot tt = ff := rfl

theorem eq_tt_of_bnot_eq_ff : ∀ {a : bool}, bnot a = ff → a = tt := dec_trivial

theorem eq_ff_of_bnot_eq_tt : ∀ {a : bool}, bnot a = tt → a = ff := dec_trivial

theorem bxor_comm : ∀ a b, bxor a b = bxor b a := dec_trivial
@[simp] theorem bxor_assoc : ∀ a b c, bxor (bxor a b) c = bxor a (bxor b c) := dec_trivial
theorem bxor_left_comm : ∀ a b c, bxor a (bxor b c) = bxor b (bxor a c) := dec_trivial
@[simp] theorem bxor_bnot_left : ∀ a, bxor (!a) a = tt := dec_trivial
@[simp] theorem bxor_bnot_right : ∀ a, bxor a (!a) = tt := dec_trivial
@[simp] theorem bxor_bnot_bnot : ∀ a b, bxor (!a) (!b) = bxor a b := dec_trivial
@[simp] theorem bxor_ff_left : ∀ a, bxor ff a = a := dec_trivial
@[simp] theorem bxor_ff_right : ∀ a, bxor a ff = a := dec_trivial

lemma bxor_iff_ne : ∀ {x y : bool}, bxor x y = tt ↔ x ≠ y := dec_trivial

/-! ### De Morgan's laws for booleans-/
@[simp] lemma bnot_band : ∀ (a b : bool), !(a && b) = !a || !b := dec_trivial
@[simp] lemma bnot_bor : ∀ (a b : bool), !(a || b) = !a && !b := dec_trivial

lemma bnot_inj : ∀ {a b : bool}, !a = !b → a = b := dec_trivial

end bool

instance : linear_order bool :=
{ le := λ a b, a = ff ∨ b = tt,
  le_refl := dec_trivial,
  le_trans := dec_trivial,
  le_antisymm := dec_trivial,
  le_total := dec_trivial,
  decidable_le := infer_instance,
  decidable_eq := infer_instance,
  decidable_lt := infer_instance }

namespace bool

@[simp] lemma ff_le {x : bool} : ff ≤ x := or.intro_left _ rfl

@[simp] lemma le_tt {x : bool} : x ≤ tt := or.intro_right _ rfl

@[simp] lemma ff_lt_tt : ff < tt := lt_of_le_of_ne ff_le ff_ne_tt

/-- convert a `bool` to a `ℕ`, `false -> 0`, `true -> 1` -/
def to_nat (b : bool) : ℕ :=
cond b 1 0

/-- convert a `ℕ` to a `bool`, `0 -> false`, everything else -> `true` -/
def of_nat (n : ℕ) : bool :=
to_bool (n ≠ 0)

lemma of_nat_le_of_nat {n m : ℕ} (h : n ≤ m) : of_nat n ≤ of_nat m :=
begin
  simp [of_nat];
    cases nat.decidable_eq n 0;
    cases nat.decidable_eq m 0;
    simp only [to_bool],
  { subst m, have h := le_antisymm h (nat.zero_le _),
    contradiction },
  { left, refl }
end

lemma to_nat_le_to_nat {b₀ b₁ : bool} (h : b₀ ≤ b₁) : to_nat b₀ ≤ to_nat b₁ :=
by cases h; subst h; [cases b₁, cases b₀]; simp [to_nat,nat.zero_le]

lemma of_nat_to_nat (b : bool) : of_nat (to_nat b) = b :=
by cases b; simp only [of_nat,to_nat]; exact dec_trivial

end bool


import tactic
import data.int.parity
import data.int.modeq
import data.nat.factorization.basic
import number_theory.legendre_symbol.quadratic_reciprocity

import Mordell.CongruencesMod4

lemma useful_lemma (x y : ℤ)
  (p : ℕ)
  (hp : nat.prime p)
  (h8 : p ≡ 3 [MOD 4])
  (h9 : ↑p ∣ y ^ 2 + 16)
  [fact (nat.prime p)] :
  let yp : zmod p := ↑y
  in yp = ↑y → yp ^ 2 = -16 → (-16 : zmod p) / 16 = -1 :=
begin
  intros yp hyp0 hyp,
  have hpne2 : p ≠ 2,
  { unfreezingI {rintro rfl},
    delta nat.modeq at h8,
    norm_num at h8, },
  have hp : (4 : zmod p) ≠ 0,
  { intro h,
    have h2 : ((4 : ℕ) : zmod p) = 0,
      assumption_mod_cast,
    have h3 : p ∣ 4,
      exact (zmod.nat_coe_zmod_eq_zero_iff_dvd 4 p).mp h2,
    have h37 : 0 < 4 := by norm_num,
    have h4 : p ≤ 4 := nat.le_of_dvd h37 h3,
    have h5 : p = 3,
    { apply nat.modeq.eq_of_modeq_of_abs_lt h8,
      norm_num,
      rw abs_lt,
      norm_cast,
      split; linarith,
    },
    unfreezingI {subst h5},
    norm_num at h3, },
  have hi : (4^2 :  zmod p) = (16 : zmod p) := by norm_num,
  rw ← hi,
  simp [hp],
end

lemma int.exists_nat_of_nonneg {z : ℤ} (hz : 0 ≤ z) : ∃ n : ℕ,
  (n : ℤ) = z :=
begin
  use z.nat_abs,
  exact int.nat_abs_of_nonneg hz,
end

lemma prime_factor_congr_3_mod_4 (x : ℤ) (h : x^2 - 3*x + 9 ≡ 3 [ZMOD 4]) :
  ∃ (p : ℕ), p.prime ∧ (p : int) ∣ (x^2 - 3*x + 9)  ∧ p ≡ 3 [MOD 4] :=
begin
  have h1 : ((x^2 - 3*x + 9): ℚ) = (x - 3/2)^2 + 27/4:= by ring,
  have h2 : 0 ≤ x^2 - 3*x + 9,
  { nlinarith, },
  obtain ⟨n, hn⟩  := int.exists_nat_of_nonneg h2,
  rw ← hn at h,
  have h3 : n ≡ 3 [MOD 4],
  unfold int.modeq at h,
  unfold nat.modeq,
  assumption_mod_cast,
  obtain ⟨p, hp1, hp2, hp3⟩ := three_modulo_four_prime_factor n h3,
  refine ⟨p, hp1, _, hp3⟩,
  rwa [← hn, int.coe_nat_dvd],
end

lemma x_eq_1_zmod4 (x y : ℤ) (h : y^2 ≡ x^3 + 11 [ZMOD 4]) :
  (x ≡ 1 [ZMOD 4]) :=
begin
  change _ ≡ _ [ZMOD (4 : ℕ)] at h,
  change _ ≡ _ [ZMOD (4 : ℕ)],
  rw ← zmod.int_coe_eq_int_coe_iff at h ⊢,
  push_cast at h ⊢,
  revert h,
  generalize : (↑x : zmod 4) = xbar,
  generalize : (↑y : zmod 4) = ybar,
  intro h,
  dec_trivial!,
end

example (x y : ℤ) : y^2 ≠ x^3 + 11 :=
begin
  intro heq,
  have oddx: odd x,
    { apply int.odd_iff_not_even.2,
      intro h,
      rw even_iff_two_dvd at h,
      have h3: 0 < 3:= by norm_num,
      rw ← int.pow_dvd_pow_iff h3 at h,
      norm_num at h,
      rw ← int.modeq_zero_iff_dvd at h,
      have h2 := int.modeq.add_right 11 h,
      rw ← heq at h2,
      norm_num at h2,
      have h4:= int.square_ne_three_mod_four y,
      apply h4,
      clear h4,
      have h6: (4 : ℤ ) ∣ 8:= by norm_num,
      have h5:= int.modeq.modeq_of_dvd h6 h2,
      unfold int.modeq at h5 ⊢,
      rw h5,
      norm_num,
  },
  have hxy : y^2 ≡  x^3 + 11 [ZMOD 4],
  { rw heq,},
  have hx : x ≡ 1 [ZMOD 4],
    { have htemp := x_eq_1_zmod4,
      exact htemp x y hxy,},
  have h1 := x_eq_1_zmod4,
  have h2 : y^2 + 16 ≡ (x+3)*(x^2 - 3*x + 9) [ZMOD 4],
    { rw heq,
      ring_nf,},
    have h6 : x^2 - 3*x + 9 ≡  3 [ZMOD 4],
      { have hx2 : x^2 ≡ 1 [ZMOD 4],
        { exact int.square_eq_one_mod_four_of_odd x oddx, },
        have h3x : 3*x ≡ 3 [ZMOD 4],
        { unfold int.modeq at hx ⊢,
          norm_num at hx ⊢,
          rw int.mul_mod,
          rw hx,
          norm_num,},
        have hx2px : x^2 - 3*x ≡ -2 [ZMOD 4],
        { unfold int.modeq at hx2 hx h3x ⊢,
          norm_num at hx2 h3x hx ⊢,
          rw int.sub_mod,
          rw h3x,
          rw hx2,
          norm_num,},
        unfold int.modeq at hx2 hx hx2px ⊢,
        norm_num at hx2 hx hx2px ⊢,
        rw int.add_mod,
        rw hx2px,
        norm_num,},
  obtain ⟨p, hp, hpd, h8⟩  := prime_factor_congr_3_mod_4 x h6,
  have h9 : ↑p∣y^2 + 16,
  { have h3 : y^2 + 16 = (x + 3)*(x^2 - 3*x + 9),
    { rw heq,
      ring,},
    rw h3,
    exact dvd_mul_of_dvd_right hpd (x + 3), },
  haveI : fact (nat.prime p) := ⟨hp⟩,
  set yp : zmod p := y with hyp0,
  have hyp : yp^2 = -16,
  { rw ← zmod.int_coe_zmod_eq_zero_iff_dvd at h9,
    push_cast at h9,
    linear_combination h9, },
  have hypdiv4 : (yp/4)^2 = -1,
  { norm_num,
    rw hyp,
    apply useful_lemma; try {assumption}, },
  apply zmod.mod_four_ne_three_of_sq_eq_neg_one hypdiv4,
  rw nat.modeq at h8,
  norm_num at h8,
  assumption,
end


import category_theory.limits.filtered_colimit_commutes_finite_limit
import for_mathlib.preserves_finite_limits

import for_mathlib.AddCommGroup.tensor
import for_mathlib.AddCommGroup
import for_mathlib.preserves_exact

noncomputable theory

universes u
open_locale tensor_product

open category_theory

namespace AddCommGroup

variables (A : AddCommGroup)

variables [no_zero_smul_divisors ℤ A]

instance tensor_functor_preserves_finite_limits :
  limits.preserves_finite_limits (tensor_functor.obj A) :=
preserves_finite_limits_of_preserves_mono_preserves_finite_colimits _ $
λ X Y f hf, by { resetI, apply_instance }

lemma tensor_short_exact {X Y Z : AddCommGroup}
  (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : short_exact f g) :
  short_exact (map_tensor (𝟙 A) f) (map_tensor (𝟙 A) g) :=
(tensor_functor.obj A).map_short_exact f g hfg

end AddCommGroup


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import geometry.manifold.derivation_bundle

/-!

# Left invariant derivations

In this file we define the concept of left invariant derivation for a Lie group. The concept is
analogous to the more classical concept of left invariant vector fields, and it holds that the
derivation associated to a vector field is left invariant iff the field is.

Moreover we prove that `left_invariant_derivation I G` has the structure of a Lie algebra, hence
implementing one of the possible definitions of the Lie algebra attached to a Lie group.

-/

noncomputable theory

open_locale lie_group manifold derivation

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
{E : Type*} [normed_group E] [normed_space 𝕜 E]
{H : Type*} [topological_space H] (I : model_with_corners 𝕜 E H)
(G : Type*) [topological_space G] [charted_space H G] [monoid G] [has_smooth_mul I G] (g h : G)

-- Generate trivial has_sizeof instance. It prevents weird type class inference timeout problems
local attribute [nolint instance_priority, instance, priority 10000]
private def disable_has_sizeof {α} : has_sizeof α := ⟨λ _, 0⟩

/--
Left-invariant global derivations.

A global derivation is left-invariant if it is equal to its pullback along left multiplication by
an arbitrary element of `G`.
-/
structure left_invariant_derivation extends derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯ :=
(left_invariant'' : ∀ g, 𝒅ₕ(smooth_left_mul_one I g) (derivation.eval_at 1 to_derivation) =
  derivation.eval_at g to_derivation)

variables {I G}

namespace left_invariant_derivation

instance : has_coe (left_invariant_derivation I G) (derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) :=
⟨λ X, X.to_derivation⟩

instance : has_coe_to_fun (left_invariant_derivation I G) (λ _, C^∞⟮I, G; 𝕜⟯ → C^∞⟮I, G; 𝕜⟯) :=
⟨λ X, X.to_derivation.to_fun⟩

variables
{M : Type*} [topological_space M] [charted_space H M] {x : M} {r : 𝕜}
{X Y : left_invariant_derivation I G} {f f' : C^∞⟮I, G; 𝕜⟯}

lemma to_fun_eq_coe : X.to_fun = ⇑X := rfl
lemma coe_to_linear_map : ⇑(X : C^∞⟮I, G; 𝕜⟯ →ₗ[𝕜] C^∞⟮I, G; 𝕜⟯) = X := rfl
@[simp] lemma to_derivation_eq_coe : X.to_derivation = X := rfl

lemma coe_injective :
  @function.injective (left_invariant_derivation I G) (_ → C^⊤⟮I, G; 𝕜⟯) coe_fn :=
λ X Y h, by { cases X, cases Y, congr', exact derivation.coe_injective h }

@[ext] theorem ext (h : ∀ f, X f = Y f) : X = Y :=
coe_injective $ funext h

variables (X Y f)

lemma coe_derivation_injective : function.injective
  (coe : left_invariant_derivation I G → derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) :=
λ X Y h, by { cases X, cases Y, congr, exact h }

/-- Premature version of the lemma. Prefer using `left_invariant` instead. -/
lemma left_invariant' :
  𝒅ₕ(smooth_left_mul_one I g) (derivation.eval_at (1 : G) ↑X) = derivation.eval_at g ↑X :=
by rw [←to_derivation_eq_coe]; exact left_invariant'' X g

@[simp] lemma map_add : X (f + f') = X f + X f' := derivation.map_add X f f'
@[simp] lemma map_zero : X 0 = 0 := derivation.map_zero X
@[simp] lemma map_neg : X (-f) = -X f := derivation.map_neg X f
@[simp] lemma map_sub : X (f - f') = X f - X f' := derivation.map_sub X f f'
@[simp] lemma map_smul : X (r • f) = r • X f := derivation.map_smul X r f
@[simp] lemma leibniz : X (f * f') = f • X f' + f' • X f := X.leibniz' _ _

instance : has_zero (left_invariant_derivation I G) :=
⟨⟨0, λ g, by simp only [linear_map.map_zero, derivation.coe_zero]⟩⟩

instance : inhabited (left_invariant_derivation I G) := ⟨0⟩

instance : has_add (left_invariant_derivation I G) :=
{ add := λ X Y, ⟨X + Y, λ g, by simp only [linear_map.map_add, derivation.coe_add,
    left_invariant', pi.add_apply]⟩ }

instance : has_neg (left_invariant_derivation I G) :=
{ neg := λ X, ⟨-X, λ g, by simp only [linear_map.map_neg, derivation.coe_neg, left_invariant',
    pi.neg_apply]⟩ }

instance : has_sub (left_invariant_derivation I G) :=
{ sub := λ X Y, ⟨X - Y, λ g, by simp only [linear_map.map_sub, derivation.coe_sub,
    left_invariant', pi.sub_apply]⟩ }

@[simp] lemma coe_add : ⇑(X + Y) = X + Y := rfl
@[simp] lemma coe_zero : ⇑(0 : left_invariant_derivation I G) = 0 := rfl
@[simp] lemma coe_neg : ⇑(-X) = -X := rfl
@[simp] lemma coe_sub : ⇑(X - Y) = X - Y := rfl
@[simp, norm_cast] lemma lift_add :
  (↑(X + Y) : derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = X + Y := rfl
@[simp, norm_cast] lemma lift_zero :
  (↑(0 : left_invariant_derivation I G) : derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = 0 := rfl

instance : add_comm_group (left_invariant_derivation I G) :=
coe_injective.add_comm_group _ coe_zero coe_add coe_neg coe_sub

instance : has_scalar 𝕜 (left_invariant_derivation I G) :=
{ smul := λ r X, ⟨r • X, λ g, by simp only [derivation.Rsmul_apply, algebra.id.smul_eq_mul,
            mul_eq_mul_left_iff, linear_map.map_smul, left_invariant']⟩ }

variables (r X)

@[simp] lemma coe_smul : ⇑(r • X) = r • X := rfl
@[simp] lemma lift_smul (k : 𝕜) : (↑(k • X) : derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) = k • X := rfl

variables (I G)

/-- The coercion to function is a monoid homomorphism. -/
@[simps] def coe_fn_add_monoid_hom :
  (left_invariant_derivation I G) →+ (C^∞⟮I, G; 𝕜⟯ → C^∞⟮I, G; 𝕜⟯) :=
⟨λ X, X.to_derivation.to_fun, coe_zero, coe_add⟩

variables {I G}

instance : module 𝕜 (left_invariant_derivation I G) :=
coe_injective.module _ (coe_fn_add_monoid_hom I G) coe_smul

/-- Evaluation at a point for left invariant derivation. Same thing as for generic global
derivations (`derivation.eval_at`). -/
def eval_at : (left_invariant_derivation I G) →ₗ[𝕜] (point_derivation I g) :=
{ to_fun := λ X, derivation.eval_at g ↑X,
  map_add' := λ X Y, rfl,
  map_smul' := λ k X, rfl }

lemma eval_at_apply : eval_at g X f = (X f) g := rfl

@[simp] lemma eval_at_coe : derivation.eval_at g ↑X = eval_at g X := rfl

lemma left_invariant : 𝒅ₕ(smooth_left_mul_one I g) (eval_at (1 : G) X) = eval_at g X :=
(X.left_invariant'' g)

lemma eval_at_mul : eval_at (g * h) X = 𝒅ₕ(L_apply I g h) (eval_at h X) :=
by { ext f, rw [←left_invariant, apply_hfdifferential, apply_hfdifferential, L_mul,
  fdifferential_comp, apply_fdifferential, linear_map.comp_apply, apply_fdifferential,
  ←apply_hfdifferential, left_invariant] }

lemma comp_L : (X f).comp (𝑳 I g) = X (f.comp (𝑳 I g)) :=
by ext h; rw [times_cont_mdiff_map.comp_apply, L_apply, ←eval_at_apply, eval_at_mul,
  apply_hfdifferential, apply_fdifferential, eval_at_apply]

instance : has_bracket (left_invariant_derivation I G) (left_invariant_derivation I G) :=
{ bracket := λ X Y, ⟨⁅(X : derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯), Y⁆, λ g, begin
    ext f,
    have hX := derivation.congr_fun (left_invariant' g X) (Y f),
    have hY := derivation.congr_fun (left_invariant' g Y) (X f),
    rw [apply_hfdifferential, apply_fdifferential, derivation.eval_at_apply] at hX hY ⊢,
    rw comp_L at hX hY,
    rw [derivation.commutator_apply, smooth_map.coe_sub, pi.sub_apply, coe_derivation],
    rw coe_derivation at hX hY ⊢,
    rw [hX, hY],
    refl
  end⟩ }

@[simp] lemma commutator_coe_derivation :
  ⇑⁅X, Y⁆ = (⁅(X : derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯), Y⁆ :
  derivation 𝕜 C^∞⟮I, G; 𝕜⟯ C^∞⟮I, G; 𝕜⟯) := rfl

lemma commutator_apply : ⁅X, Y⁆ f = X (Y f) - Y (X f) := rfl

instance : lie_ring (left_invariant_derivation I G) :=
{ add_lie := λ X Y Z, by { ext1, simp only [commutator_apply, coe_add, pi.add_apply,
              linear_map.map_add, left_invariant_derivation.map_add], ring },
  lie_add := λ X Y Z, by { ext1, simp only [commutator_apply, coe_add, pi.add_apply,
              linear_map.map_add, left_invariant_derivation.map_add], ring },
  lie_self := λ X, by { ext1, simp only [commutator_apply, sub_self], refl },
  leibniz_lie := λ X Y Z, by { ext1, simp only [commutator_apply, coe_add, coe_sub, map_sub,
              pi.add_apply], ring, } }

instance : lie_algebra 𝕜 (left_invariant_derivation I G) :=
{ lie_smul := λ r Y Z, by { ext1, simp only [commutator_apply, map_smul, smul_sub, coe_smul,
              pi.smul_apply] } }

end left_invariant_derivation