/-
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

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

open filter filter.germ
open_locale topological_space 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

@[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

@[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_lt_coe {x y : ℝ} : (x : ℝ*) < y ↔ x < y := germ.const_lt
@[simp, norm_cast] lemma coe_pos {x : ℝ} : 0 < (x : ℝ*) ↔ 0 < x :=
coe_lt_coe
@[simp, norm_cast] lemma coe_le_coe {x y : ℝ} : (x : ℝ*) ≤ y ↔ x ≤ y := germ.const_le_iff
@[simp, norm_cast] lemma coe_abs (x : ℝ) : ((abs x : ℝ) : ℝ*) = abs x := germ.const_abs _
@[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 `ε` := hyperreal.epsilon" in hyperreal
localized "notation `ω` := hyperreal.omega" in hyperreal

lemma epsilon_eq_inv_omega : ε = ω⁻¹ := rfl

lemma inv_epsilon_eq_omega : ε⁻¹ = ω := @inv_inv' _ _ ω

lemma epsilon_pos : 0 < ε :=
suffices ∀ᶠ i in hyperfilter ℕ, (0 : ℝ) < (i : ℕ)⁻¹, by rwa lt_def,
have h0' : {n : ℕ | ¬ 0 < n} = {0} :=
by simp only [not_lt, (set.set_of_eq_eq_singleton).symm]; ext; exact nat.le_zero_iff,
begin
  simp only [inv_pos, nat.cast_pos],
  exact mem_hyperfilter_of_finite_compl (by convert set.finite_singleton _),
end

lemma epsilon_ne_zero : ε ≠ 0 := ne_of_gt epsilon_pos

lemma omega_pos : 0 < ω := by rw ←inv_epsilon_eq_omega; exact inv_pos.2 epsilon_pos

lemma omega_ne_zero : ω ≠ 0 := ne_of_gt omega_pos

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, dist_zero_right, norm, 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₁ : ∃ y : ℝ, y ∈ S :=
  ⟨r₁ - 1, lt_of_lt_of_le (coe_lt_coe.2 $ sub_one_lt _) (not_lt.mp hr₁) ⟩,
have HR₂ : ∃ z : ℝ, ∀ y ∈ S, y ≤ z :=
  ⟨ r₂, λ y hy, le_of_lt (coe_lt_coe.1 (lt_of_lt_of_le hy (not_lt.mp hr₂))) ⟩,
λ δ hδ,
  ⟨ lt_of_not_ge' $ λ 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 ((real.Sup_le _ HR₁ HR₂).mpr hc) $ sub_lt_self R hδ,
    lt_of_not_ge' $ λ 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 (real.le_Sup _ 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 < δ → abs (x - r) < δ :=
by simp only [abs_sub_lt_iff, @sub_lt _ _ (r : ℝ*) x _,
    @sub_lt_iff_lt_add' _ _ x (r : ℝ*) _, and_comm]; refl

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, by show -(r : ℝ*) - d < -x ∧ -x < -r + d; 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 (abs x) ↔ infinite (abs x) :=
infinite_pos_iff_infinite_of_nonneg (abs_nonneg _)

lemma infinite_iff_infinite_pos_abs {x : ℝ*} : infinite x ↔ infinite_pos (abs 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 (abs 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 : ℝ, (abs r : ℝ*) < abs x :=
⟨ λ hI r, (coe_abs r) ▸ infinite_iff_infinite_pos_abs.mp hI (abs 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 abs (x * y - r * s)
      = abs (x * (y - s) + (x - r) * s) :
        by rw [mul_sub, sub_mul, add_sub, sub_add_cancel]
  ... ≤ abs (x * (y - s)) + abs ((x - r) * s) : abs_add _ _
  ... ≤ abs x * abs (y - s) + abs (x - r) * abs s : by simp only [abs_mul]
  ... ≤ abs x * ((d / t) / 2 : ℝ) + ((d / abs s) / 2 : ℝ) * abs 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 * (abs x / t) + d / 2 : ℝ*) : by
      { push_cast [-filter.germ.const_div], -- TODO: Why wasn't `hyperreal.coe_div` used?
        have : (abs 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 → abs x < abs r :=
⟨ λ hi r hr, abs_lt.mpr (by rw ←coe_abs;
  exact infinitesimal_def.mp hi (abs 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) ((abs 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 (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_infinite {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


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

Multivariate Polynomial
-/
import algebra.ring
import data.finsupp data.polynomial data.equiv.algebra

open set function finsupp lattice

universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

/-- Multivariate polynomial, where `σ` is the index set of the variables and
  `α` is the coefficient ring -/
def mv_polynomial (σ : Type*) (α : Type*) [comm_semiring α] := (σ →₀ ℕ) →₀ α

namespace mv_polynomial
variables {σ : Type*} {a a' a₁ a₂ : α} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}
variables [decidable_eq σ] [decidable_eq α]

section comm_semiring
variables [comm_semiring α] {p q : mv_polynomial σ α}

instance : decidable_eq (mv_polynomial σ α) := finsupp.decidable_eq
instance : has_zero (mv_polynomial σ α) := finsupp.has_zero
instance : has_one (mv_polynomial σ α) := finsupp.has_one
instance : has_add (mv_polynomial σ α) := finsupp.has_add
instance : has_mul (mv_polynomial σ α) := finsupp.has_mul
instance : comm_semiring (mv_polynomial σ α) := finsupp.to_comm_semiring

/-- `monomial s a` is the monomial `a * X^s` -/
def monomial (s : σ →₀ ℕ) (a : α) : mv_polynomial σ α := single s a

/-- `C a` is the constant polynomial with value `a` -/
def C (a : α) : mv_polynomial σ α := monomial 0 a

/-- `X n` is the polynomial with value X_n -/
def X (n : σ) : mv_polynomial σ α := monomial (single n 1) 1

@[simp] lemma C_0 : C 0 = (0 : mv_polynomial σ α) := by simp [C, monomial]; refl

@[simp] lemma C_1 : C 1 = (1 : mv_polynomial σ α) := rfl

lemma C_mul_monomial : C a * monomial s a' = monomial s (a * a') :=
by simp [C, monomial, single_mul_single]

@[simp] lemma C_add : (C (a + a') : mv_polynomial σ α) = C a + C a' := single_add

@[simp] lemma C_mul : (C (a * a') : mv_polynomial σ α) = C a * C a' := C_mul_monomial.symm

instance : is_semiring_hom (C : α → mv_polynomial σ α) :=
{ map_zero := C_0,
  map_one := C_1,
  map_add := λ a a', C_add,
  map_mul := λ a a', C_mul }

lemma X_pow_eq_single : X n ^ e = monomial (single n e) (1 : α) :=
begin
  induction e,
  { simp [X], refl },
  { simp [pow_succ, e_ih],
    simp [X, monomial, single_mul_single, nat.succ_eq_add_one] }
end

lemma monomial_add_single : monomial (s + single n e) a = (monomial s a * X n ^ e):=
by rw [X_pow_eq_single, monomial, monomial, monomial, single_mul_single]; simp

lemma monomial_single_add : monomial (single n e + s) a = (X n ^ e * monomial s a):=
by rw [X_pow_eq_single, monomial, monomial, monomial, single_mul_single]; simp

lemma monomial_eq : monomial s a = C a * (s.prod $ λn e, X n ^ e : mv_polynomial σ α) :=
begin
  apply @finsupp.induction σ ℕ _ _ _ _ s,
  { simp [C, prod_zero_index]; exact (mul_one _).symm },
  { assume n e s hns he ih,
    simp [prod_add_index, prod_single_index, pow_zero, pow_add, (mul_assoc _ _ _).symm, ih.symm,
      monomial_add_single] }
end

@[recursor 7]
lemma induction_on {M : mv_polynomial σ α → Prop} (p : mv_polynomial σ α)
  (h_C : ∀a, M (C a)) (h_add : ∀p q, M p → M q → M (p + q)) (h_X : ∀p n, M p → M (p * X n)) :
  M p :=
have ∀s a, M (monomial s a),
begin
  assume s a,
  apply @finsupp.induction σ ℕ _ _ _ _ s,
  { show M (monomial 0 a), from h_C a, },
  { assume n e p hpn he ih,
    have : ∀e:ℕ, M (monomial p a * X n ^ e),
    { intro e,
      induction e,
      { simp [ih] },
      { simp [ih, pow_succ', (mul_assoc _ _ _).symm, h_X, e_ih] } },
    simp [monomial_add_single, this] }
end,
finsupp.induction p
  (by have : M (C 0) := h_C 0; rwa [C_0] at this)
  (assume s a p hsp ha hp, h_add _ _ (this s a) hp)

lemma hom_eq_hom [semiring γ]
  (f g : mv_polynomial σ α → γ) (hf : is_semiring_hom f) (hg : is_semiring_hom g)
  (hC : ∀a:α, f (C a) = g (C a)) (hX : ∀n:σ, f (X n) = g (X n)) (p : mv_polynomial σ α) :
  f p = g p :=
mv_polynomial.induction_on p hC
  begin assume p q hp hq, rw [is_semiring_hom.map_add f, is_semiring_hom.map_add g, hp, hq] end
  begin assume p n hp, rw [is_semiring_hom.map_mul f, is_semiring_hom.map_mul g, hp, hX] end

lemma is_id (f : mv_polynomial σ α → mv_polynomial σ α) (hf : is_semiring_hom f)
  (hC : ∀a:α, f (C a) = (C a)) (hX : ∀n:σ, f (X n) = (X n)) (p : mv_polynomial σ α) :
  f p = p :=
hom_eq_hom f id hf is_semiring_hom.id hC hX p

section eval₂
variables [comm_semiring β]
variables (f : α → β) (g : σ → β)

/-- Evaluate a polynomial `p` given a valuation `g` of all the variables
  and a ring hom `f` from the scalar ring to the target -/
def eval₂ (p : mv_polynomial σ α) : β :=
p.sum (λs a, f a * s.prod (λn e, g n ^ e))

@[simp] lemma eval₂_zero : (0 : mv_polynomial σ α).eval₂ f g = 0 :=
finsupp.sum_zero_index

variables [is_semiring_hom f]

@[simp] lemma eval₂_add : (p + q).eval₂ f g = p.eval₂ f g + q.eval₂ f g :=
finsupp.sum_add_index
  (by simp [is_semiring_hom.map_zero f])
  (by simp [add_mul, is_semiring_hom.map_add f])

@[simp] lemma eval₂_monomial : (monomial s a).eval₂ f g = f a * s.prod (λn e, g n ^ e) :=
finsupp.sum_single_index (by simp [is_semiring_hom.map_zero f])

@[simp] lemma eval₂_C (a) : (C a).eval₂ f g = f a :=
by simp [eval₂_monomial, C, prod_zero_index]

@[simp] lemma eval₂_one : (1 : mv_polynomial σ α).eval₂ f g = 1 :=
(eval₂_C _ _ _).trans (is_semiring_hom.map_one f)

@[simp] lemma eval₂_X (n) : (X n).eval₂ f g = g n :=
by simp [eval₂_monomial,
  is_semiring_hom.map_one f, X, prod_single_index, pow_one]

lemma eval₂_mul_monomial :
  ∀{s a}, (p * monomial s a).eval₂ f g = p.eval₂ f g * f a * s.prod (λn e, g n ^ e) :=
begin
  apply mv_polynomial.induction_on p,
  { assume a' s a,
    simp [C_mul_monomial, eval₂_monomial, is_semiring_hom.map_mul f] },
  { assume p q ih_p ih_q, simp [add_mul, eval₂_add, ih_p, ih_q] },
  { assume p n ih s a,
    from calc (p * X n * monomial s a).eval₂ f g = (p * monomial (single n 1 + s) a).eval₂ f g :
        by simp [monomial_single_add, -add_comm, pow_one, mul_assoc]
      ... = (p * monomial (single n 1) 1).eval₂ f g * f a * s.prod (λn e, g n ^ e) :
        by simp [ih, prod_single_index, prod_add_index, pow_one, pow_add, mul_assoc, mul_left_comm,
          is_semiring_hom.map_one f, -add_comm] }
end

lemma eval₂_mul : ∀{p}, (p * q).eval₂ f g = p.eval₂ f g * q.eval₂ f g :=
begin
  apply mv_polynomial.induction_on q,
  { simp [C, eval₂_monomial, eval₂_mul_monomial, prod_zero_index] },
  { simp [mul_add, eval₂_add] {contextual := tt} },
  { simp [X, eval₂_monomial, eval₂_mul_monomial, (mul_assoc _ _ _).symm] { contextual := tt} }
end

lemma eval₂_pow {p:mv_polynomial σ α} : ∀{n:ℕ}, (p ^ n).eval₂ f g = (p.eval₂ f g)^n
| 0       := eval₂_one _ _
| (n + 1) := by rw [pow_add, pow_one, pow_add, pow_one, eval₂_mul, eval₂_pow]

instance eval₂.is_semiring_hom : is_semiring_hom (eval₂ f g) :=
{ map_zero := eval₂_zero _ _,
  map_one := eval₂_one _ _,
  map_add := λ p q, eval₂_add _ _,
  map_mul := λ p q, eval₂_mul _ _ }

lemma eval₂_comp_left {γ} [comm_semiring γ]
  (k : β → γ) [is_semiring_hom k]
  (f : α → β) [is_semiring_hom f] (g : σ → β)
  (p) : k (eval₂ f g p) = eval₂ (k ∘ f) (k ∘ g) p :=
by apply mv_polynomial.induction_on p; simp [
  eval₂_add, is_semiring_hom.map_add k,
  eval₂_mul, is_semiring_hom.map_mul k] {contextual := tt}

lemma eval₂_eta (p : mv_polynomial σ α) : eval₂ C X p = p :=
by apply mv_polynomial.induction_on p;
   simp [eval₂_add, eval₂_mul] {contextual := tt}

end eval₂

section eval
variables {f : σ → α}

/-- Evaluate a polynomial `p` given a valuation `f` of all the variables -/
def eval (f : σ → α) : mv_polynomial σ α → α := eval₂ id f

@[simp] lemma eval_zero : (0 : mv_polynomial σ α).eval f = 0 := eval₂_zero _ _

@[simp] lemma eval_add : (p + q).eval f = p.eval f + q.eval f := eval₂_add _ _

lemma eval_monomial : (monomial s a).eval f = a * s.prod (λn e, f n ^ e) :=
eval₂_monomial _ _

@[simp] lemma eval_C : ∀ a, (C a).eval f = a := eval₂_C _ _

@[simp] lemma eval_X : ∀ n, (X n).eval f = f n := eval₂_X _ _

@[simp] lemma eval_mul : (p * q).eval f = p.eval f * q.eval f := eval₂_mul _ _

instance eval.is_semiring_hom : is_semiring_hom (eval f) :=
eval₂.is_semiring_hom _ _

theorem eval_assoc {τ} [decidable_eq τ]
  (f : σ → mv_polynomial τ α) (g : τ → α)
  (p : mv_polynomial σ α) :
  p.eval (eval g ∘ f) = (eval₂ C f p).eval g :=
begin
  rw eval₂_comp_left (eval g),
  unfold eval, congr; funext a; simp
end

end eval

section map
variables [comm_semiring β] [decidable_eq β]
variables (f : α → β) [is_semiring_hom f]

/-- `map f p` maps a polynomial `p` across a ring hom `f` -/
def map : mv_polynomial σ α → mv_polynomial σ β := eval₂ (C ∘ f) X

@[simp] theorem map_monomial (s : σ →₀ ℕ) (a : α) : map f (monomial s a) = monomial s (f a) :=
(eval₂_monomial _ _).trans monomial_eq.symm

@[simp] theorem map_C : ∀ (a : α), map f (C a : mv_polynomial σ α) = C (f a) := map_monomial _ _

@[simp] theorem map_X : ∀ (n : σ), map f (X n : mv_polynomial σ α) = X n := eval₂_X _ _

@[simp] theorem map_one : map f (1 : mv_polynomial σ α) = 1 := eval₂_one _ _

@[simp] theorem map_add (p q : mv_polynomial σ α) :
  map f (p + q) = map f p + map f q := eval₂_add _ _

@[simp] theorem map_mul (p q : mv_polynomial σ α) :
  map f (p * q) = map f p * map f q := eval₂_mul _ _

instance map.is_semiring_hom :
  is_semiring_hom (map f : mv_polynomial σ α → mv_polynomial σ β) :=
eval₂.is_semiring_hom _ _

theorem map_id : ∀ (p : mv_polynomial σ α), map id p = p := eval₂_eta

theorem map_map [comm_semiring γ] [decidable_eq γ]
  (g : β → γ) [is_semiring_hom g]
  (p : mv_polynomial σ α) :
  map g (map f p) = map (g ∘ f) p :=
(eval₂_comp_left (map g) (C ∘ f) X p).trans $
by congr; funext a; simp

theorem eval₂_eq_eval_map (g : σ → β) (p : mv_polynomial σ α) :
  p.eval₂ f g = (map f p).eval g :=
begin
  unfold map eval,
  rw eval₂_comp_left (eval₂ id g),
  congr; funext a; simp
end

end map

section degrees

section comm_semiring

def degrees (p : mv_polynomial σ α) : multiset σ :=
p.support.sup (λs:σ →₀ ℕ, s.to_multiset)

lemma degrees_monomial (s : σ →₀ ℕ) (a : α) : degrees (monomial s a) ≤ s.to_multiset :=
finset.sup_le $ assume t h,
begin
  have := finsupp.support_single_subset h,
  rw [finset.singleton_eq_singleton, finset.mem_singleton] at this,
  rw this
end

lemma degrees_monomial_eq (s : σ →₀ ℕ) (a : α) (ha : a ≠ 0) :
  degrees (monomial s a) = s.to_multiset :=
le_antisymm (degrees_monomial s a) $ finset.le_sup $
  by rw [monomial, finsupp.support_single_ne_zero ha,
    finset.singleton_eq_singleton, finset.mem_singleton]

lemma degrees_C (a : α) : degrees (C a : mv_polynomial σ α) = 0 :=
multiset.le_zero.1 $ degrees_monomial _ _

lemma degrees_X (n : σ) : degrees (X n : mv_polynomial σ α) ≤ {n} :=
le_trans (degrees_monomial _ _) $ le_of_eq $ to_multiset_single _ _

lemma degrees_zero : degrees (0 : mv_polynomial σ α) = 0 := degrees_C 0

lemma degrees_one : degrees (1 : mv_polynomial σ α) = 0 := degrees_C 1

lemma degrees_add (p q : mv_polynomial σ α) : (p + q).degrees ≤ p.degrees ⊔ q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  cases finset.mem_union.1 (finsupp.support_add hb),
  { exact le_sup_left_of_le (finset.le_sup h) },
  { exact le_sup_right_of_le (finset.le_sup h) },
end

lemma degrees_sum {ι : Type*} [decidable_eq ι] (s : finset ι) (f : ι → mv_polynomial σ α) :
  (s.sum f).degrees ≤ s.sup (λi, (f i).degrees) :=
begin
  refine s.induction _ _,
  { simp only [finset.sum_empty, finset.sup_empty, degrees_zero], exact le_refl _ },
  { assume i s his ih,
    rw [finset.sup_insert, finset.sum_insert his],
    exact le_trans (degrees_add _ _) (sup_le_sup_left ih _) }
end

lemma degrees_mul (p q : mv_polynomial σ α) : (p * q).degrees ≤ p.degrees + q.degrees :=
begin
  refine finset.sup_le (assume b hb, _),
  have := support_mul p q hb,
  simp only [finset.mem_bind, finset.singleton_eq_singleton, finset.mem_singleton] at this,
  rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
  rw [finsupp.to_multiset_add],
  exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂)
end

lemma degrees_prod {ι : Type*} [decidable_eq ι] (s : finset ι) (f : ι → mv_polynomial σ α) :
  (s.prod f).degrees ≤ s.sum (λi, (f i).degrees) :=
begin
  refine s.induction _ _,
  { simp only [finset.prod_empty, finset.sum_empty, degrees_one] },
  { assume i s his ih,
    rw [finset.prod_insert his, finset.sum_insert his],
    exact le_trans (degrees_mul _ _) (add_le_add_left ih _) }
end

lemma degrees_pow (p : mv_polynomial σ α) :
  ∀(n : ℕ), (p^n).degrees ≤ add_monoid.smul n p.degrees
| 0       := begin rw [pow_zero, degrees_one], exact multiset.zero_le _ end
| (n + 1) := le_trans (degrees_mul _ _) (add_le_add_left (degrees_pow n) _)

end comm_semiring

end degrees

section vars

/-- `vars p` is the set of variables appearing in the polynomial `p` -/
def vars (p : mv_polynomial σ α) : finset σ := p.degrees.to_finset

@[simp] lemma vars_0 : (0 : mv_polynomial σ α).vars = ∅ :=
by rw [vars, degrees_zero, multiset.to_finset_zero]

@[simp] lemma vars_monomial (h : a ≠ 0) : (monomial s a).vars = s.support :=
by rw [vars, degrees_monomial_eq _ _ h, finsupp.to_finset_to_multiset]

@[simp] lemma vars_C : (C a : mv_polynomial σ α).vars = ∅ :=
by rw [vars, degrees_C, multiset.to_finset_zero]

@[simp] lemma vars_X (h : 0 ≠ (1 : α)) : (X n : mv_polynomial σ α).vars = {n} :=
by rw [X, vars_monomial h.symm, finsupp.support_single_ne_zero zero_ne_one.symm]

end vars

section degree_of

/-- `degree_of n p` gives the highest power of X_n that appears in `p` -/
def degree_of (n : σ) (p : mv_polynomial σ α) : ℕ := p.degrees.count n

end degree_of

section total_degree
/-- `total_degree p` gives the maximum |s| over the monomials X^s in `p` -/
def total_degree (p : mv_polynomial σ α) : ℕ := p.support.sup (λs, s.sum $ λn e, e)

lemma total_degree_eq (p : mv_polynomial σ α) :
  p.total_degree = p.support.sup (λm, m.to_multiset.card) :=
begin
  rw [total_degree],
  congr, funext m,
  exact (finsupp.card_to_multiset _).symm
end

lemma total_degree_le_degrees_card (p : mv_polynomial σ α) :
  p.total_degree ≤ p.degrees.card :=
begin
  rw [total_degree_eq],
  exact finset.sup_le (assume s hs, multiset.card_le_of_le $ finset.le_sup hs)
end

lemma total_degree_C (a : α) : (C a : mv_polynomial σ α).total_degree = 0 :=
nat.eq_zero_of_le_zero $ finset.sup_le $ assume n hn,
  have _ := finsupp.support_single_subset hn,
  begin
    rw [finset.singleton_eq_singleton, finset.mem_singleton] at this,
    subst this,
    exact le_refl _
  end

lemma total_degree_zero : (0 : mv_polynomial σ α).total_degree = 0 :=
by rw [← C_0]; exact total_degree_C (0 : α)

lemma total_degree_one : (1 : mv_polynomial σ α).total_degree = 0 :=
total_degree_C (1 : α)

lemma total_degree_add (a b : mv_polynomial σ α) :
  (a + b).total_degree ≤ max a.total_degree b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := finsupp.support_add hn,
  begin
    rcases finset.mem_union.1 this,
    { exact le_max_left_of_le (finset.le_sup h) },
    { exact le_max_right_of_le (finset.le_sup h) }
  end

lemma total_degree_mul (a b : mv_polynomial σ α) :
  (a * b).total_degree ≤ a.total_degree + b.total_degree :=
finset.sup_le $ assume n hn,
  have _ := finsupp.support_mul a b hn,
  begin
    simp only [finset.mem_bind, finset.mem_singleton, finset.singleton_eq_singleton] at this,
    rcases this with ⟨a₁, h₁, a₂, h₂, rfl⟩,
    rw [finsupp.sum_add_index],
    { exact add_le_add (finset.le_sup h₁) (finset.le_sup h₂) },
    { assume a, refl },
    { assume a b₁ b₂, refl }
  end

lemma total_degree_list_prod :
  ∀(s : list (mv_polynomial σ α)), s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum
| []        := by rw [@list.prod_nil (mv_polynomial σ α) _, total_degree_one]; refl
| (p :: ps) :=
  begin
    rw [@list.prod_cons (mv_polynomial σ α) _, list.map, list.sum_cons],
    exact le_trans (total_degree_mul _ _) (add_le_add_left (total_degree_list_prod ps) _)
  end

lemma total_degree_multiset_prod (s : multiset (mv_polynomial σ α)) :
  s.prod.total_degree ≤ (s.map mv_polynomial.total_degree).sum :=
begin
  refine quotient.induction_on s (assume l, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod, multiset.coe_map, multiset.coe_sum],
  exact total_degree_list_prod l
end

lemma total_degree_finset_prod {ι : Type*}
  (s : finset ι) (f : ι → mv_polynomial σ α) :
  (s.prod f).total_degree ≤ s.sum (λi, (f i).total_degree) :=
begin
  refine le_trans (total_degree_multiset_prod _) _,
  rw [multiset.map_map],
  refl
end

end total_degree

end comm_semiring

section comm_ring
variable [comm_ring α]
variables {p q : mv_polynomial σ α}

instance : ring (mv_polynomial σ α) := finsupp.to_ring
instance : comm_ring (mv_polynomial σ α) := finsupp.to_comm_ring
instance : has_scalar α (mv_polynomial σ α) := finsupp.to_has_scalar
instance : module α (mv_polynomial σ α) := finsupp.to_module _ α

instance C.is_ring_hom : is_ring_hom (C : α → mv_polynomial σ α) :=
by apply is_ring_hom.of_semiring

variables (σ a a')
lemma C_sub : (C (a - a') : mv_polynomial σ α) = C a - C a' := is_ring_hom.map_sub _

@[simp] lemma C_neg : (C (-a) : mv_polynomial σ α) = -C a := is_ring_hom.map_neg _

variables {σ} (p)
theorem C_mul' : mv_polynomial.C a * p = a • p :=
begin
  apply finsupp.induction p,
  { exact (mul_zero $ mv_polynomial.C a).trans (@smul_zero α (mv_polynomial σ α) _ _ _ a).symm },
  intros p b f haf hb0 ih,
  rw [mul_add, ih, @smul_add α (mv_polynomial σ α) _ _ _ a], congr' 1,
  rw [finsupp.mul_def, finsupp.smul_single, mv_polynomial.C, mv_polynomial.monomial],
  rw [finsupp.sum_single_index, finsupp.sum_single_index, zero_add, smul_eq_mul],
  { rw [mul_zero, finsupp.single_zero] },
  { rw finsupp.sum_single_index,
    all_goals { rw [zero_mul, finsupp.single_zero] } }
end

lemma smul_eq_C_mul (p : mv_polynomial σ α) (a : α) : a • p = C a * p :=
begin
  rw [← finsupp.sum_single p, @finsupp.smul_sum (σ →₀ ℕ) α α, finsupp.mul_sum],
  refine finset.sum_congr rfl (assume n _, _),
  simp only [finsupp.smul_single],
  exact C_mul_monomial.symm
end

@[simp] lemma smul_eval (x) (p : mv_polynomial σ α) (s) : (s • p).eval x = s * p.eval x :=
by rw [smul_eq_C_mul, eval_mul, eval_C]

section degrees

lemma degrees_neg [comm_ring α] (p : mv_polynomial σ α) : (- p).degrees = p.degrees :=
by rw [degrees, finsupp.support_neg]; refl

lemma degrees_sub [comm_ring α] (p q : mv_polynomial σ α) :
  (p - q).degrees ≤ p.degrees ⊔ q.degrees :=
le_trans (degrees_add p (-q)) $ by rw [degrees_neg]

end degrees

section eval₂

variables [comm_ring β]
variables (f : α → β) [is_ring_hom f] (g : σ → β)

instance eval₂.is_ring_hom : is_ring_hom (eval₂ f g) :=
by apply is_ring_hom.of_semiring

lemma eval₂_sub : (p - q).eval₂ f g = p.eval₂ f g - q.eval₂ f g := is_ring_hom.map_sub _

@[simp] lemma eval₂_neg : (-p).eval₂ f g = -(p.eval₂ f g) := is_ring_hom.map_neg _

end eval₂

section eval

variables (f : σ → α)

instance eval.is_ring_hom : is_ring_hom (eval f) := eval₂.is_ring_hom _ _

lemma eval_sub : (p - q).eval f = p.eval f - q.eval f := is_ring_hom.map_sub _

@[simp] lemma eval_neg : (-p).eval f = -(p.eval f) := is_ring_hom.map_neg _

end eval

section map

variables [decidable_eq β] [comm_ring β]
variables (f : α → β) [is_ring_hom f]

instance map.is_ring_hom : is_ring_hom (map f : mv_polynomial σ α → mv_polynomial σ β) :=
eval₂.is_ring_hom _ _

lemma map_sub : (p - q).map f = p.map f - q.map f := is_ring_hom.map_sub _

@[simp] lemma map_neg : (-p).map f = -(p.map f) := is_ring_hom.map_neg _

end map

end comm_ring

section rename
variables {α} [comm_semiring α] [decidable_eq α] [decidable_eq β] [decidable_eq γ] [decidable_eq δ]

def rename (f : β → γ) : mv_polynomial β α → mv_polynomial γ α :=
eval₂ C (X ∘ f)

instance rename.is_semiring_hom (f : β → γ) :
  is_semiring_hom (rename f : mv_polynomial β α → mv_polynomial γ α) :=
by unfold rename; apply_instance

@[simp] lemma rename_C (f : β → γ) (a : α) : rename f (C a) = C a :=
eval₂_C _ _ _

@[simp] lemma rename_X (f : β → γ) (b : β) : rename f (X b : mv_polynomial β α) = X (f b) :=
eval₂_X _ _ _

lemma rename_rename (f : β → γ) (g : γ → δ) (p : mv_polynomial β α) :
  rename g (rename f p) = rename (g ∘ f) p :=
show rename g (eval₂ C (X ∘ f) p) = _,
  by simp only [eval₂_comp_left (rename g) C (X ∘ f) p, (∘), rename_C, rename_X]; refl

lemma rename_id (p : mv_polynomial β α) : rename id p = p :=
eval₂_eta p

lemma rename_monomial (f : β → γ) (p : β →₀ ℕ) (a : α) :
  rename f (monomial p a) = monomial (p.map_domain f) a :=
begin
  rw [rename, eval₂_monomial, monomial_eq, finsupp.prod_map_domain_index],
  { exact assume n, pow_zero _ },
  { exact assume n i₁ i₂, pow_add _ _ _ }
end

lemma rename_eq (f : β → γ) (p : mv_polynomial β α) :
  rename f p = finsupp.map_domain (finsupp.map_domain f) p :=
begin
  simp only [rename, eval₂, finsupp.map_domain],
  congr, ext s a : 2,
  rw [← monomial, monomial_eq, finsupp.prod_sum_index],
  congr, ext n i : 2,
  rw [finsupp.prod_single_index],
  exact pow_zero _,
  exact assume a, pow_zero _,
  exact assume a b c, pow_add _ _ _
end

lemma injective_rename (f : β → γ) (hf : function.injective f) :
  function.injective (rename f : mv_polynomial β α → mv_polynomial γ α) :=
have (rename f : mv_polynomial β α → mv_polynomial γ α) =
  finsupp.map_domain (finsupp.map_domain f) := funext (rename_eq f),
begin
  rw this,
  exact finsupp.injective_map_domain (finsupp.injective_map_domain hf)
end

lemma total_degree_rename_le (f : β → γ) (p : mv_polynomial β α) :
  (p.rename f).total_degree ≤ p.total_degree :=
finset.sup_le $ assume b,
  begin
    assume h,
    rw rename_eq at h,
    have h' := finsupp.map_domain_support h,
    rcases finset.mem_image.1 h' with ⟨s, hs, rfl⟩,
    rw finsupp.sum_map_domain_index,
    exact le_trans (le_refl _) (finset.le_sup hs),
    exact assume _, rfl,
    exact assume _ _ _, rfl
  end

end rename

instance rename.is_ring_hom
  {α} [comm_ring α] [decidable_eq α] [decidable_eq β] [decidable_eq γ] (f : β → γ) :
  is_ring_hom (rename f : mv_polynomial β α → mv_polynomial γ α) :=
@is_ring_hom.of_semiring (mv_polynomial β α) (mv_polynomial γ α) _ _ (rename f)
  (rename.is_semiring_hom f)

section equiv

variables (α) [comm_ring α]
variables [decidable_eq β] [decidable_eq γ] [decidable_eq δ]

def pempty_ring_equiv : mv_polynomial pempty α ≃r α :=
{ to_fun    := mv_polynomial.eval₂ id $ pempty.elim,
  inv_fun   := C,
  left_inv  := is_id _ (by apply_instance) (assume a, by rw [eval₂_C]; refl) (assume a, a.elim),
  right_inv := λ r, eval₂_C _ _ _,
  hom       := eval₂.is_ring_hom _ _ }

def punit_ring_equiv : mv_polynomial punit α ≃r polynomial α :=
{ to_fun    := eval₂ polynomial.C (λu:punit, polynomial.X),
  inv_fun   := polynomial.eval₂ mv_polynomial.C (X punit.star),
  left_inv  :=
    begin
      refine is_id _ _ _ _,
      apply is_semiring_hom.comp (eval₂ polynomial.C (λu:punit, polynomial.X)) _; apply_instance,
      { assume a, rw [eval₂_C, polynomial.eval₂_C] },
      { rintros ⟨⟩, rw [eval₂_X, polynomial.eval₂_X] }
    end,
  right_inv := assume p, polynomial.induction_on p
    (assume a, by rw [polynomial.eval₂_C, mv_polynomial.eval₂_C])
    (assume p q hp hq, by rw [polynomial.eval₂_add, mv_polynomial.eval₂_add, hp, hq])
    (assume p n hp,
      by rw [polynomial.eval₂_mul, polynomial.eval₂_pow, polynomial.eval₂_X, polynomial.eval₂_C,
        eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]),
  hom       := eval₂.is_ring_hom _ _ }

def ring_equiv_of_equiv (e : β ≃ γ) : mv_polynomial β α ≃r mv_polynomial γ α :=
{ to_fun    := rename e,
  inv_fun   := rename e.symm,
  left_inv  := λ p, by simp only [rename_rename, (∘), e.symm_apply_apply]; exact rename_id p,
  right_inv := λ p, by simp only [rename_rename, (∘), e.apply_symm_apply]; exact rename_id p,
  hom       := rename.is_ring_hom e }

def ring_equiv_congr [comm_ring γ] (e : α ≃r γ) : mv_polynomial β α ≃r mv_polynomial β γ :=
{ to_fun    := map e.to_fun,
  inv_fun   := map e.symm.to_fun,
  left_inv  := assume p,
    have (e.symm.to_equiv.to_fun ∘ e.to_equiv.to_fun) = id,
    { ext a, exact e.to_equiv.symm_apply_apply a },
    by simp only [map_map, this, map_id],
  right_inv := assume p,
    have (e.to_equiv.to_fun ∘ e.symm.to_equiv.to_fun) = id,
    { ext a, exact e.to_equiv.apply_symm_apply a },
    by simp only [map_map, this, map_id],
  hom       := map.is_ring_hom e.to_fun }

section
variables (β γ δ)

instance ring_on_sum : ring (mv_polynomial (β ⊕ γ) α) := by apply_instance
instance ring_on_iter : ring (mv_polynomial β (mv_polynomial γ α)) := by apply_instance

def sum_to_iter : mv_polynomial (β ⊕ γ) α → mv_polynomial β (mv_polynomial γ α) :=
eval₂ (C ∘ C) (λbc, sum.rec_on bc X (C ∘ X))

instance is_semiring_hom_C_C :
  is_semiring_hom (C ∘ C : α → mv_polynomial β (mv_polynomial γ α)) :=
@is_semiring_hom.comp _ _ _ _ C mv_polynomial.is_semiring_hom _ _ C mv_polynomial.is_semiring_hom

instance is_semiring_hom_sum_to_iter : is_semiring_hom (sum_to_iter α β γ) :=
eval₂.is_semiring_hom _ _

lemma sum_to_iter_C (a : α) : sum_to_iter α β γ (C a) = C (C a) :=
eval₂_C _ _ a

lemma sum_to_iter_Xl (b : β) : sum_to_iter α β γ (X (sum.inl b)) = X b :=
eval₂_X _ _ (sum.inl b)

lemma sum_to_iter_Xr (c : γ) : sum_to_iter α β γ (X (sum.inr c)) = C (X c) :=
eval₂_X _ _ (sum.inr c)

def iter_to_sum : mv_polynomial β (mv_polynomial γ α) → mv_polynomial (β ⊕ γ) α :=
eval₂ (eval₂ C (X ∘ sum.inr)) (X ∘ sum.inl)

section

instance is_semiring_hom_iter_to_sum : is_semiring_hom (iter_to_sum α β γ) :=
eval₂.is_semiring_hom _ _

end

lemma iter_to_sum_C_C (a : α) : iter_to_sum α β γ (C (C a)) = C a :=
eq.trans (eval₂_C _ _ (C a)) (eval₂_C _ _ _)

lemma iter_to_sum_X (b : β) : iter_to_sum α β γ (X b) = X (sum.inl b) :=
eval₂_X _ _ _

lemma iter_to_sum_C_X (c : γ) : iter_to_sum α β γ (C (X c)) = X (sum.inr c) :=
eq.trans (eval₂_C _ _ (X c)) (eval₂_X _ _ _)

def mv_polynomial_equiv_mv_polynomial [comm_ring δ]
  (f : mv_polynomial β α → mv_polynomial γ δ) (hf : is_semiring_hom f)
  (g : mv_polynomial γ δ → mv_polynomial β α) (hg : is_semiring_hom g)
  (hfgC : ∀a, f (g (C a)) = C a)
  (hfgX : ∀n, f (g (X n)) = X n)
  (hgfC : ∀a, g (f (C a)) = C a)
  (hgfX : ∀n, g (f (X n)) = X n) :
  mv_polynomial β α ≃r mv_polynomial γ δ :=
{ to_fun    := f, inv_fun := g,
  left_inv  := is_id _ (is_semiring_hom.comp _ _) hgfC hgfX,
  right_inv := is_id _ (is_semiring_hom.comp _ _) hfgC hfgX,
  hom       := is_ring_hom.of_semiring f }

def sum_ring_equiv : mv_polynomial (β ⊕ γ) α ≃r mv_polynomial β (mv_polynomial γ α) :=
begin
  apply @mv_polynomial_equiv_mv_polynomial α (β ⊕ γ) _ _ _ _ _ _ _ _
    (sum_to_iter α β γ) _ (iter_to_sum α β γ) _,
  { assume p,
    apply @hom_eq_hom _ _ _ _ _ _ _ _ _ _ _ _ _ p,
    apply_instance,
    { apply @is_semiring_hom.comp _ _ _ _ _ _ _ _ _ _,
      apply_instance,
      apply @is_semiring_hom.comp _ _ _ _ _ _ _ _ _ _,
      apply_instance,
      { apply @mv_polynomial.is_semiring_hom },
      { apply mv_polynomial.is_semiring_hom_iter_to_sum α β γ },
      { apply mv_polynomial.is_semiring_hom_sum_to_iter α β γ } },
    { apply mv_polynomial.is_semiring_hom },
    { assume a, rw [iter_to_sum_C_C α β γ, sum_to_iter_C α β γ] },
    { assume c, rw [iter_to_sum_C_X α β γ, sum_to_iter_Xr α β γ] } },
  { assume b, rw [iter_to_sum_X α β γ, sum_to_iter_Xl α β γ] },
  { assume a, rw [sum_to_iter_C α β γ, iter_to_sum_C_C α β γ] },
  { assume n, cases n with b c,
    { rw [sum_to_iter_Xl, iter_to_sum_X] },
    { rw [sum_to_iter_Xr, iter_to_sum_C_X] } },
  { apply mv_polynomial.is_semiring_hom_sum_to_iter α β γ },
  { apply mv_polynomial.is_semiring_hom_iter_to_sum α β γ }
end

instance option_ring : ring (mv_polynomial (option β) α) :=
mv_polynomial.ring

instance polynomial_ring : ring (polynomial (mv_polynomial β α)) :=
@comm_ring.to_ring _ polynomial.comm_ring

instance polynomial_ring2 : ring (mv_polynomial β (polynomial α)) :=
by apply_instance

def option_equiv_left : mv_polynomial (option β) α ≃r polynomial (mv_polynomial β α) :=
(ring_equiv_of_equiv α $ (equiv.option_equiv_sum_punit β).trans (equiv.sum_comm _ _)).trans $
(sum_ring_equiv α _ _).trans $
punit_ring_equiv _

def option_equiv_right : mv_polynomial (option β) α ≃r mv_polynomial β (polynomial α) :=
(ring_equiv_of_equiv α $ equiv.option_equiv_sum_punit.{0} β).trans $
(sum_ring_equiv α β unit).trans $
ring_equiv_congr (mv_polynomial unit α) (punit_ring_equiv α)

end

end equiv

end mv_polynomial


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.terminal
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.category_theory.limits.shapes.binary_products
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Constructing binary product from pullbacks and terminal object.

If a category has pullbacks and a terminal object, then it has binary products.

TODO: provide the dual result.
-/

/-- Any category with pullbacks and terminal object has binary products. -/
-- This is not an instance, as it is not always how one wants to construct binary products!

theorem has_binary_products_of_terminal_and_pullbacks (C : Type u) [𝒞 : category_theory.category C]
    [category_theory.limits.has_terminal C] [category_theory.limits.has_pullbacks C] :
    category_theory.limits.has_binary_products C :=
  sorry

end Mathlib


/-
The organization of information in the memory.
-/
import starkware.cairo.lean.semantics.air_encoding.memory_aux
import starkware.cairo.lean.semantics.air_encoding.constraints

noncomputable theory
open_locale classical
open_locale big_operators

/- the data -/

variables {F : Type*}

variable  {T : ℕ}    -- the number of steps in the execution

variable  {rc_len : ℕ}  -- the number of range-checked elements for the range-check builtin

variables {pc       inst
           dst_addr dst
           op0_addr op0
           op1_addr op1  : fin T → F}

variables {rc_addr rc_val : fin rc_len → F}

variables {mem_star : F → option F}

variables {n : ℕ}

variables {a v a' v' p   : fin (n + 1) → F}

variables {embed_inst
           embed_dst
           embed_op0
           embed_op1     : fin T → fin (n + 1)}

variables {embed_rc      : fin rc_len → fin (n + 1)}

variables {embed_mem     : mem_dom mem_star → fin (n + 1)}

variables {alpha z : F}

/- the assumptions and constraints -/

variables [field F] [fintype F]

variable h_continuity :
  ∀ i : fin n, (a' i.succ - a' i.cast_succ) * (a' i.succ - a' i.cast_succ - 1) = 0

variable h_single_valued :
  ∀ i : fin n, (v' i.succ - v' i.cast_succ) * (a' i.succ - a' i.cast_succ - 1) = 0

variable h_initial : (z - (a' 0 + alpha * v' 0)) * p 0 = z - (a 0 + alpha * v 0)

variable h_cumulative : ∀ i : fin n, (z - (a' i.succ + alpha * v' i.succ)) * p i.succ =
                                       (z - (a i.succ + alpha * v i.succ)) * p i.cast_succ

variable h_final : p (fin.last n) * ∏ a : mem_dom mem_star, (z - (a.val + alpha * mem_val a)) =
    z^(fintype.card (mem_dom mem_star))

variable h_embed_pc       : ∀ i, a (embed_inst i) = pc i
variable h_embed_inst     : ∀ i, v (embed_inst i) = inst i
variable h_embed_dst_addr : ∀ i, a (embed_dst i)  = dst_addr i
variable h_embed_dst      : ∀ i, v (embed_dst i)  = dst i
variable h_embed_op0_addr : ∀ i, a (embed_op0 i)  = op0_addr i
variable h_embed_op0      : ∀ i, v (embed_op0 i)  = op0 i
variable h_embed_op1_addr : ∀ i, a (embed_op1 i)  = op1_addr i
variable h_embed_op1      : ∀ i, v (embed_op1 i)  = op1 i

variable h_embed_rc_addr  : ∀ i, a (embed_rc i)   = rc_addr i
variable h_embed_rc_val   : ∀ i, v (embed_rc i)   = rc_val i

variable h_embed_dom      : ∀ i, a (embed_mem i) = 0
variable h_embed_val      : ∀ i, v (embed_mem i) = 0

variable h_embed_mem_inj       : function.injective embed_mem
variable h_embed_mem_disj_inst : ∀ i j, embed_mem i ≠ embed_inst j
variable h_embed_mem_disj_dst  : ∀ i j, embed_mem i ≠ embed_dst j
variable h_embed_mem_disj_op0  : ∀ i j, embed_mem i ≠ embed_op0 j
variable h_embed_mem_disj_op1  : ∀ i j, embed_mem i ≠ embed_op1 j
variable h_embed_mem_disj_rc   : ∀ i j, embed_mem i ≠ embed_rc j

/-
The memory.
-/

def mem (a' v' : fin (n + 1) → F) : F → F :=
λ addr, if h : ∃ i, a' i = addr then v' (classical.some h) else 0

/-
Recovering the real a and v arrays from mem_star and the trace version in which
those values have been replaced by (0, 0) pairs.
-/

def real_a (mem_star : F → option F) (a : fin (n + 1) → F)
    (embed_mem : mem_dom mem_star → fin (n + 1)) :
  fin (n + 1) → F :=
λ i, if h : ∃ addr, embed_mem addr = i then (classical.some h).val else a i

def real_v (mem_star : F → option F) (v : fin (n + 1) → F)
    (embed_mem : mem_dom mem_star → fin (n + 1)) :
  fin (n + 1) → F :=
λ i, if h : ∃ addr, embed_mem addr = i then mem_val (classical.some h) else v i

/-
Requires messing around with finite products. Needs the fact that `embed_mem` is injective.
-/

section
include h_embed_mem_inj h_embed_dom h_embed_val

lemma real_prod_eq :
  let ra := real_a mem_star a embed_mem,
      rv := real_v mem_star v embed_mem in
  (∏ i, (z - (ra i + alpha * rv i))) * z^(fintype.card (mem_dom mem_star)) =
    (∏ i, (z - (a i + alpha * v i))) *
      ∏ a : mem_dom mem_star, (z - (a.val + alpha * mem_val a)) :=
begin
  dsimp,
  let s := finset.image embed_mem finset.univ,
  rw [←finset.prod_sdiff (finset.subset_univ s), ←finset.prod_sdiff (finset.subset_univ s),
        mul_right_comm _ _ (z ^ _)],
  congr' 2,
  { apply finset.prod_congr rfl,
    intro i, rw finset.mem_sdiff, rintros ⟨_, nsi⟩,
    simp [-not_exists, finset.mem_image] at nsi,
    rw [real_a, real_v], dsimp, rw [dif_neg nsi, dif_neg nsi] },
  { rw [finset.prod_image (λ x _ y _ h, @h_embed_mem_inj x y h), fintype.card, ←finset.prod_const],
    apply finset.prod_congr rfl,
    intros i _, dsimp,
    rw [h_embed_dom, h_embed_val, zero_add, mul_zero, sub_zero] },
  rw [finset.prod_image (λ x _ y _ h, @h_embed_mem_inj x y h)],
  apply finset.prod_congr rfl,
  intros i _, dsimp,
  have h : ∃ addr, embed_mem addr = embed_mem i := ⟨i, rfl⟩,
  have h' : classical.some h = i := h_embed_mem_inj (classical.some_spec h),
  rw [real_a, real_v], dsimp, rw [dif_pos h, dif_pos h, mem_val],
  congr; exact h'
end
end

/-
Moving from `a`, `v` to `real_a`, `real_v` preserves the pairs we care about.
-/

section
include h_embed_pc h_embed_mem_disj_inst

lemma real_a_embed_inst (i : fin T) : real_a mem_star a embed_mem (embed_inst i) = pc i :=
begin
  rw [real_a], dsimp, rw [dif_neg, h_embed_pc],
  apply not_exists_of_forall_not, intro j,
  apply h_embed_mem_disj_inst
end

end

section
include h_embed_inst h_embed_mem_disj_inst

lemma real_v_embed_inst (i : fin T) : real_v mem_star v embed_mem (embed_inst i) = inst i :=
begin
  rw [real_v], dsimp, rw [dif_neg, h_embed_inst],
  apply not_exists_of_forall_not, intro j,
  apply h_embed_mem_disj_inst
end

end

-- because these are so uniform, we can use the same proofs

lemma real_a_embed_dst (i : fin T) : real_a mem_star a embed_mem (embed_dst i) = dst_addr i :=
real_a_embed_inst h_embed_dst_addr h_embed_mem_disj_dst i

lemma real_v_embed_dst (i : fin T) : real_v mem_star v embed_mem (embed_dst i) = dst i :=
real_v_embed_inst h_embed_dst h_embed_mem_disj_dst i

lemma real_a_embed_op0 (i : fin T) : real_a mem_star a embed_mem (embed_op0 i) = op0_addr i :=
real_a_embed_inst h_embed_op0_addr h_embed_mem_disj_op0 i

lemma real_v_embed_op0 (i : fin T) : real_v mem_star v embed_mem (embed_op0 i) = op0 i :=
real_v_embed_inst h_embed_op0 h_embed_mem_disj_op0 i

lemma real_a_embed_op1 (i : fin T) : real_a mem_star a embed_mem (embed_op1 i) = op1_addr i :=
real_a_embed_inst h_embed_op1_addr h_embed_mem_disj_op1 i

lemma real_v_embed_op1 (i : fin T) : real_v mem_star v embed_mem (embed_op1 i) = op1 i :=
real_v_embed_inst h_embed_op1 h_embed_mem_disj_op1 i

section
include h_embed_rc_addr h_embed_mem_disj_rc

lemma real_a_embed_rc (i : fin rc_len) :
  real_a mem_star a embed_mem (embed_rc i) = rc_addr i :=
begin
  rw [real_a], dsimp, rw [dif_neg, h_embed_rc_addr],
  apply not_exists_of_forall_not, intro j,
  apply h_embed_mem_disj_rc
end

end

section
include h_embed_rc_val h_embed_mem_disj_rc

lemma real_v_embed_rc (i : fin rc_len) : real_v mem_star v embed_mem (embed_rc i) = rc_val i :=
begin
  rw [real_v], dsimp, rw [dif_neg, h_embed_rc_val],
  apply not_exists_of_forall_not, intro j,
  apply h_embed_mem_disj_rc
end

end

section

variable h_z_ne_zero : z ≠ 0

include h_initial h_cumulative h_final h_embed_mem_inj h_embed_dom h_embed_val h_z_ne_zero

lemma real_permutation_prod_eq :
  let ra := real_a mem_star a embed_mem,
      rv := real_v mem_star v embed_mem in
  (∏ i, (z - (ra i + alpha * rv i))) = (∏ i, (z - (a' i + alpha * v' i))) :=
begin
  let ra := real_a mem_star a embed_mem,
  let rv := real_v mem_star v embed_mem,
  suffices : (∏ i, (z - (ra i + alpha * rv i))) * z^(fintype.card (mem_dom mem_star)) =
               (∏ i, (z - (a' i + alpha * v' i))) * z^(fintype.card (mem_dom mem_star)),
    from mul_right_cancel₀ (pow_ne_zero _ h_z_ne_zero) this,
  have := real_prod_eq h_embed_dom h_embed_val h_embed_mem_inj ,
  dsimp [-subtype.val_eq_coe] at this, rw this,
  rw [←fin.range_last, ←fin.succ_last, permutation_aux h_initial h_cumulative,
    mul_assoc, h_final]
end

variable hprob₁ : alpha ∉
  bad_set_1 (real_a mem_star a embed_mem) (real_v mem_star v embed_mem) a' v'

variable hprob₂ : z ∉
  bad_set_2 (real_a mem_star a embed_mem) (real_v mem_star v embed_mem) a' v' alpha

lemma real_perm :
  ∀ i, ∃ j, real_v mem_star v embed_mem i = v' j ∧
            real_a mem_star a embed_mem i = a' j :=
let ra := real_a mem_star a embed_mem,
    rv := real_v mem_star v embed_mem in
have h : ∏ (i : fin (n + 1)), (z - (ra i + alpha * rv i)) =
          ∏ (i : fin (n + 1)), (z - (a' i + alpha * v' i)) :=
    real_permutation_prod_eq h_initial h_cumulative h_final h_embed_dom h_embed_val h_embed_mem_inj
      h_z_ne_zero,
permutation hprob₁ hprob₂ h

lemma real_perm' :
  ∀ i, ∃ j, v' i = real_v mem_star v embed_mem j ∧
            a' i = real_a mem_star a embed_mem j :=
let ra := real_a mem_star a embed_mem,
    rv := real_v mem_star v embed_mem in
have h : ∏ (i : fin (n + 1)), (z - (ra i + alpha * rv i)) =
          ∏ (i : fin (n + 1)), (z - (a' i + alpha * v' i)) :=
    real_permutation_prod_eq h_initial h_cumulative h_final h_embed_dom h_embed_val h_embed_mem_inj
      h_z_ne_zero,
permutation' hprob₁ hprob₂ h

variable h_char_lt : n < ring_char F

include h_continuity h_single_valued hprob₁ hprob₂ h_char_lt

lemma real_a_single_valued :
  let ra := real_a mem_star a embed_mem,
      rv := real_v mem_star v embed_mem in
  ∀ i i', ra i = ra i' → rv i = rv i' :=
begin
  dsimp,
  intros i i' aieq,
  let ra := real_a mem_star a embed_mem,
  let rv := real_v mem_star v embed_mem,
  have h : ∏ (i : fin (n + 1)), (z - (ra i + alpha * rv i)) =
             ∏ (i : fin (n + 1)), (z - (a' i + alpha * v' i)) :=
    real_permutation_prod_eq h_initial h_cumulative h_final h_embed_dom h_embed_val h_embed_mem_inj
      h_z_ne_zero,
  have perm := permutation hprob₁ hprob₂ h,
  rcases perm i with ⟨j, veq, aeq⟩,
  rcases perm i' with ⟨j', veq', aeq'⟩,
  rw [veq, veq'],
  apply a'_single_valued h_continuity h_single_valued h_char_lt,
  rw [←aeq, ←aeq', aieq]
end

lemma mem_unique (i : fin (n + 1)) :
  mem a' v' (real_a mem_star a embed_mem i) = real_v mem_star v embed_mem i :=
begin
  have perm := real_perm h_initial h_cumulative h_final h_embed_dom h_embed_val h_embed_mem_inj
    h_z_ne_zero hprob₁ hprob₂,
  rcases perm i with ⟨i', v'eq, a'eq⟩,
  have h : ∃ i', a' i' = real_a mem_star a embed_mem i := ⟨i', a'eq.symm⟩,
  rw [mem], dsimp, rw [dif_pos h],
  rw v'eq,
  apply a'_single_valued h_continuity h_single_valued h_char_lt,
  exact (classical.some_spec h).trans a'eq
end

section
include h_embed_pc h_embed_inst h_embed_mem_disj_inst

theorem mem_pc (i : fin T) : mem a' v' (pc i) = inst i :=
begin
  rw [←@real_a_embed_inst _ T pc mem_star _ a embed_inst embed_mem _ _ h_embed_pc
          h_embed_mem_disj_inst],
  rw [←@real_v_embed_inst _ T inst mem_star _ v embed_inst embed_mem _ _
          h_embed_inst h_embed_mem_disj_inst],
  apply mem_unique h_continuity h_single_valued h_initial h_cumulative h_final h_embed_dom
    h_embed_val h_embed_mem_inj h_z_ne_zero hprob₁ hprob₂ h_char_lt
end
end

theorem mem_dst_addr (i : fin T) : mem a' v' (dst_addr i) = dst i :=
mem_pc h_continuity h_single_valued h_initial h_cumulative h_final h_embed_dst_addr h_embed_dst
  h_embed_dom h_embed_val h_embed_mem_inj h_embed_mem_disj_dst h_z_ne_zero hprob₁ hprob₂ h_char_lt i

theorem mem_op0_addr (i : fin T) : mem a' v' (op0_addr i) = op0 i :=
mem_pc h_continuity h_single_valued h_initial h_cumulative h_final h_embed_op0_addr h_embed_op0
  h_embed_dom h_embed_val h_embed_mem_inj h_embed_mem_disj_op0 h_z_ne_zero hprob₁ hprob₂ h_char_lt i

theorem mem_op1_addr (i : fin T) : mem a' v' (op1_addr i) = op1 i :=
mem_pc h_continuity h_single_valued h_initial h_cumulative h_final h_embed_op1_addr h_embed_op1
  h_embed_dom h_embed_val h_embed_mem_inj h_embed_mem_disj_op1 h_z_ne_zero hprob₁ hprob₂ h_char_lt i

section
include h_embed_rc_addr h_embed_rc_val h_embed_mem_disj_rc

theorem mem_rc_addr (i : fin rc_len) : mem a' v' (rc_addr i) = rc_val i :=
begin
  rw [←@real_a_embed_rc _ _ rc_addr mem_star _ a embed_rc embed_mem _ _ h_embed_rc_addr
          h_embed_mem_disj_rc],
  rw [←@real_v_embed_inst _ _ rc_val mem_star _ v embed_rc embed_mem _ _
          h_embed_rc_val h_embed_mem_disj_rc],
  apply mem_unique h_continuity h_single_valued h_initial h_cumulative h_final h_embed_dom
    h_embed_val h_embed_mem_inj h_z_ne_zero hprob₁ hprob₂ h_char_lt
end
end

theorem mem_extends : option.fn_extends (mem a' v') mem_star :=
begin
  intro addr,
  cases h : (mem_star addr) with val; simp only [option.agrees],
  have h' : (option.is_some (mem_star addr) : Prop), by { rw h, simp },
  let aelt : mem_dom mem_star := ⟨addr, h'⟩,
  have h₀ : ∃ i, embed_mem i = embed_mem aelt := ⟨aelt, rfl⟩,
  have h₁ : classical.some h₀ = aelt,
  { apply h_embed_mem_inj, apply classical.some_spec h₀ },
  have h₂ : real_a mem_star a embed_mem (embed_mem aelt) = addr,
  { rw real_a, dsimp, rw [dif_pos h₀, h₁], refl },
  have h₃ : real_v mem_star v embed_mem (embed_mem aelt) = val,
  { rw real_v, dsimp, rw [dif_pos h₀, h₁],
    apply option.some_inj.mp,
    rw [←h, mem_val, option.some_get] },
  rw [←h₂, ←h₃], symmetry,
  dsimp [aelt],
  exact mem_unique h_continuity h_single_valued h_initial h_cumulative h_final h_embed_dom
    h_embed_val h_embed_mem_inj h_z_ne_zero hprob₁ hprob₂ h_char_lt (embed_mem ⟨addr, h'⟩)
end

end


import tactic.slim_check
import .mk_slim_check_test

example : true :=
begin
  have : ∀ i j : ℕ, i < j → j < i,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
  "
===================
Found problems!

i := 0
j := 1
guard: 0 < 1 (by construction)
issue: 1 < 0 does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial
end

example : true :=
begin
  have : (∀ x : ℕ, 2 ∣ x → x < 100),
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
  "
===================
Found problems!

x := 104
issue: 104 < 100 does not hold
(2 shrinks)
-------------------
",
  admit,
  trivial
end

example (xs : list ℕ) (w : ∃ x ∈ xs, x < 3) : true :=
begin
  have : ∀ y ∈ xs, y < 5,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

xs := [5, 5, 0, 1]
x := 0
y := 5
issue: 5 < 5 does not hold
(5 shrinks)
-------------------
",
  admit,
  trivial
end

example (x : ℕ) (h : 2 ∣ x) : true :=
begin
  have : x < 100,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := 104
issue: 104 < 100 does not hold
(2 shrinks)
-------------------
",
  admit,
  trivial
end

example (α : Type) (xs ys : list α) : true :=
begin
  have : xs ++ ys = ys ++ xs,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

α := ℤ
xs := [0]
ys := [1]
issue: [0, 1] = [1, 0] does not hold
(4 shrinks)
-------------------
",
  admit,
  trivial
end

example : true :=
begin
  have : ∀ x ∈ [1,2,3], x < 4,
  slim_check { random_seed := some 257, quiet := tt },
    -- success
  trivial,
end

open function slim_check

example (f : ℤ → ℤ) (h : injective f) : true :=
begin
  have : monotone (f ∘ small.mk),
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

f := [2 ↦ 3, 3 ↦ 9, 4 ↦ 6, 5 ↦ 4, 6 ↦ 2, 8 ↦ 5, 9 ↦ 8, x ↦ x]
x := 3
y := 4
guard: 3 ≤ 4 (by construction)
issue: 9 ≤ 6 does not hold
(5 shrinks)
-------------------
",
  admit,
  trivial,
end

example (f : ℤ → ℤ) (h : injective f) (g : ℤ → ℤ) (h : injective g) (i) : true :=
begin
  have : f i = g i,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

f := [x ↦ x]
g := [1 ↦ 2, 2 ↦ 1, x ↦ x]
i := 1
issue: 1 = 2 does not hold
(5 shrinks)
-------------------
",
  admit,
  trivial,
end

example (f : ℤ → ℤ) (h : injective f) : true :=
begin
  have : monotone f,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

f := [2 ↦ 3, 3 ↦ 9, 4 ↦ 6, 5 ↦ 4, 6 ↦ 2, 8 ↦ 5, 9 ↦ 8, x ↦ x]
x := 3
y := 4
guard: 3 ≤ 4 (by construction)
issue: 9 ≤ 6 does not hold
(5 shrinks)
-------------------
",
  admit,
  trivial,
end

example (f : ℤ → ℤ) : true :=
begin
  have : injective f,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

f := [_ ↦ 0]
x := 0
y := -1
guard: 0 = 0
issue: 0 = -1 does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end

example (f : ℤ → ℤ) : true :=
begin
  have : monotone f,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

f := [-6 ↦ 97, 0 ↦ 0, _ ↦ 4]
x := -6
y := -2
guard: -6 ≤ -2 (by construction)
issue: 97 ≤ 4 does not hold
(5 shrinks)
-------------------
",
  admit,
  trivial,
end
example (xs ys : list ℤ) (h : xs ~ ys) : true :=
begin
  have : list.qsort (λ x y, x ≠ y) xs = list.qsort (λ x y, x ≠ y) ys,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

xs := [0, 1]
ys := [1, 0]
guard: [0, 1] ~ [1, 0] (by construction)
issue: [0, 1] = [1, 0] does not hold
(4 shrinks)
-------------------
",
  admit,
  trivial
end

example (x y : ℕ) : true :=
begin
  have : y ≤ x → x + y < 100,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := 59
y := 41
guard: 41 ≤ 59 (by construction)
issue: 100 < 100 does not hold
(8 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x : ℤ) : true :=
begin
  have : x ≤ 3 → 3 ≤ x,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := 2
guard: 2 ≤ 3 (by construction)
issue: 3 ≤ 2 does not hold
(1 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : ℤ) : true :=
begin
  have : y ≤ x → x + y < 100,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := 52
y := 52
guard: 52 ≤ 52 (by construction)
issue: 104 < 100 does not hold
(4 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : Prop) : true :=
begin
  have : x ∨ y → y ∧ x,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := tt
y := ff
guard: (true ∨ false)
issue: false does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : Prop) : true :=
begin
  have : (¬x ↔ y) → y ∧ x,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := tt
y := ff
guard: (¬ true ↔ false)
issue: false does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : Prop) : true :=
begin
  -- deterministic
  have : (x ↔ y) → y ∨ x,
  success_if_fail_with_msg
  { slim_check }
"
===================
Found problems!

x := ff
y := ff
guard: (false ↔ false)
issue: false does not hold
issue: false does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : Prop) : true :=
begin
  -- deterministic
  have : y ∨ x,
  success_if_fail_with_msg
  { slim_check }
"
===================
Found problems!

x := ff
y := ff
issue: false does not hold
issue: false does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end

example (x y : Prop) : true :=
begin
  have : x ↔ y,
  success_if_fail_with_msg
  { slim_check { random_seed := some 257 } }
"
===================
Found problems!

x := tt
y := ff
issue: false does not hold
issue: ¬ true does not hold
(0 shrinks)
-------------------
",
  admit,
  trivial,
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Module.monoidal
import Mathlib.algebra.category.Algebra.basic
import Mathlib.category_theory.monoidal.Mon_
import Mathlib.PostPort

universes u

namespace Mathlib

/-!
# `Mon_ (Module R) ≌ Algebra R`

The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.

Moreover, this equivalence is compatible with the forgetful functors to `Module R`.
-/

namespace Module

namespace Mon_Module_equivalence_Algebra

@[simp] theorem Mon_.X.ring_zero {R : Type u} [comm_ring R] (A : Mon_ (Module R)) :
    0 = add_comm_group.zero :=
  Eq.refl 0

protected instance Mon_.X.algebra {R : Type u} [comm_ring R] (A : Mon_ (Module R)) :
    algebra R ↥(Mon_.X A) :=
  algebra.mk (ring_hom.mk (linear_map.to_fun (Mon_.one A)) sorry sorry sorry sorry) sorry sorry

@[simp] theorem algebra_map {R : Type u} [comm_ring R] (A : Mon_ (Module R)) (r : R) :
    coe_fn (algebra_map R ↥(Mon_.X A)) r = coe_fn (Mon_.one A) r :=
  rfl

/--
Converting a monoid object in `Module R` to a bundled algebra.
-/
@[simp] theorem functor_obj {R : Type u} [comm_ring R] (A : Mon_ (Module R)) :
    category_theory.functor.obj functor A = Algebra.of R ↥(Mon_.X A) :=
  Eq.refl (category_theory.functor.obj functor A)

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
def inverse_obj {R : Type u} [comm_ring R] (A : Algebra R) : Mon_ (Module R) :=
  Mon_.mk (of R ↥A) (algebra.linear_map R ↥A) (algebra.lmul' R)

/--
Converting a bundled algebra to a monoid object in `Module R`.
-/
@[simp] theorem inverse_map_hom {R : Type u} [comm_ring R] (A : Algebra R) (B : Algebra R)
    (f : A ⟶ B) : Mon_.hom.hom (category_theory.functor.map inverse f) = alg_hom.to_linear_map f :=
  Eq.refl (Mon_.hom.hom (category_theory.functor.map inverse f))

end Mon_Module_equivalence_Algebra

/--
The category of internal monoid objects in `Module R`
is equivalent to the category of "native" bundled `R`-algebras.
-/
def Mon_Module_equivalence_Algebra {R : Type u} [comm_ring R] : Mon_ (Module R) ≌ Algebra R :=
  category_theory.equivalence.mk' sorry sorry
    (category_theory.nat_iso.of_components
      (fun (A : Mon_ (Module R)) =>
        category_theory.iso.mk (Mon_.hom.mk (linear_map.mk id sorry sorry))
          (Mon_.hom.mk (linear_map.mk id sorry sorry)))
      sorry)
    (category_theory.nat_iso.of_components
      (fun (A : Algebra R) =>
        category_theory.iso.mk (alg_hom.mk id sorry sorry sorry sorry sorry)
          (alg_hom.mk id sorry sorry sorry sorry sorry))
      sorry)

/--
The equivalence `Mon_ (Module R) ≌ Algebra R`
is naturally compatible with the forgetful functors to `Module R`.
-/
def Mon_Module_equivalence_Algebra_forget {R : Type u} [comm_ring R] :
    Mon_Module_equivalence_Algebra.functor ⋙ category_theory.forget₂ (Algebra R) (Module R) ≅
        Mon_.forget (Module R) :=
  category_theory.nat_iso.of_components
    (fun (A : Mon_ (Module R)) =>
      category_theory.iso.mk (linear_map.mk id sorry sorry) (linear_map.mk id sorry sorry))
    sorry

end Mathlib


import .WhileSyntax
open whileSyntax
open whileSyntax.configExpr
open whileSyntax.wExpr
open whileSyntax.wComm
open whileSyntax.wBool

namespace semantics

def a := num 1
def b := num 2
def c := num 3
def d := ident("x")
def f : string → ℕ
| "x" := 4
| _   := 0
def exampleConfig := (configE(a + b + (c * d), f))

def oneSmallStepExpr : configExpr → configExpr
| (configE (num a, state)) := configE (num a, state)
| (configE (ident x, state)) := configE (num (state x), state)
| (configE (num a + num b, state)) := configE (num (a + b), state)
| (configE (num a * num b, state)) := configE (num (a * b), state)
| (configE (num a + exp2, state)) := let (configE (exp2', state')) := oneSmallStepExpr (configE (exp2, state)) in
                                       configE (num a + exp2', state')
| (configE (num a * exp2, state)) := let (configE (exp2', state')) := oneSmallStepExpr (configE (exp2, state)) in
                                       configE (num a * exp2', state')
| (configE (exp1 + exp2, state)) := let (configE (exp1', state')) := oneSmallStepExpr (configE (exp1, state)) in
                                      configE (exp1' + exp2, state')
| (configE (exp1 * exp2, state)) := let (configE (exp1', state')) := oneSmallStepExpr (configE (exp1, state)) in
                                      configE (exp1' * exp2, state')

def smallStepExpr : configExpr → configExpr
| (configE (num a, state)) := configE (num a, state)
| a := have sizeof (oneSmallStepExpr a) < sizeof a, from sorry,
       smallStepExpr $ oneSmallStepExpr a

def bigStepExpr : configExpr → configExpr
| (configE (num a, state)) := configE (num a, state)
| (configE (ident x, state)) := configE (num (state x), state)
| (configE (num a + num b, state)) := configE (num (a + b), state)
| (configE (num a * num b, state)) := configE (num (a * b), state)
| (configE (exp1 + exp2, state)) := let (configE (exp1', state')) := bigStepExpr (configE (exp1, state)),
                                        (configE (exp2', state'')) := bigStepExpr (configE (exp2, state')) in
                                      have sizeof exp2' + sizeof exp1' < sizeof exp2 + sizeof exp1, from sorry,
                                      bigStepExpr $ configE (exp1' + exp2', state'')
| (configE (exp1 * exp2, state)) := let (configE (exp1', state')) := bigStepExpr (configE (exp1, state)),
                                        (configE (exp2', state'')) := bigStepExpr (configE (exp2, state')) in
                                      have sizeof exp2' * sizeof exp1' < sizeof exp2 * sizeof exp1, from sorry,
                                      bigStepExpr $ configE (exp1' * exp2', state'')

theorem normal_forms (e : configExpr) : (∃ n : ℕ, ∃ f : string → ℕ, smallStepExpr e = configE (num n, f) ) :=
begin
admit
end

def g := let (configE (a, _)) := smallStepExpr (configE (num 7 + num 6, f)) in a
def h := let (configE (a, _)) := bigStepExpr (configE (num 7 + ident "x", f)) in a
def i := let (configE (a, _)) := bigStepExpr exampleConfig in a
def j := let (configE (a, _)) := smallStepExpr exampleConfig in a

#eval i
#eval j

end semantics


import temporal_logic

open temporal predicate

local infix ` ≃ ` := v_eq

section
variable α : Type

variables Γ p q r : cpred
variables v₀ v₁ : tvar α
variables f : pred' α
variables h₀ : Γ ⊢ p ≡ q
include h₀
example : Γ ⊢ p ⋀ r ≡ q ⋀ r :=
begin [temporal]
  rw h₀,
end

example : Γ ⊢ p ⋀ r →  Γ ⊢ q ⋀ r :=
assume _,
begin [temporal]
  rw ← h₀,
end

variables h₁ : Γ ⊢ ◻(p ≡ q)
omit h₀
include h₁
example : Γ ⊢ ◻◇p ≡ ◻◇q :=
begin [temporal]
  rw h₁,
end

variables h₂ : Γ ⊢ ◻(v₀ ≃ v₁)
include h₂
example (h : Γ ⊢ ◇(◻(f ! v₀ ≡ q) ⋀ p))
: Γ ⊢ ◇(◻(f ! v₁ ≡ q) ⋀ p) :=
begin [temporal]
  rw ← h₂,
end

example (h : Γ ⊢ ◇(◻(f ! v₀ ≡ q) ⋀ p))
: Γ ⊢ ◇(◻(f ! v₁ ≡ q) ⋀ p) :=
begin [temporal]
  rw h₂ at h,
end
end

inductive nat.even : ℕ → Prop
 | zero : nat.even 0
 | succ_succ (n) : nat.even n → nat.even (nat.succ (nat.succ n))

section
open nat
lemma even_succ_succ (n : ℕ)
: nat.even (nat.succ $ nat.succ n) ↔ nat.even n :=
sorry
end
abbreviation succ : var ℕ ℕ := ⟨ nat.succ ⟩
abbreviation even : var ℕ Prop := ⟨ nat.even ⟩

variables Γ : cpred

example (x y : tvar ℕ)
(h₀ : Γ ⊢ ◻(⊙x ≃ succ!succ!x))
(h₁ : Γ ⊢ ◻(⊙y ≃ y))
(h₂ : Γ ⊢ even!x ≡ even!y)
: Γ ⊢ ◻(even!x ≡ even!y) :=
begin [temporal]
  apply induct _ _ _ _,
-- h₀ : ◻(⊙x ≃ succ ! succ ! x),
-- h₁ : ◻(⊙y ≃ y),
-- h₂ : even ! x ≡ even ! y
-- ⊢ ◻((even ! x ≡ even ! y) ⟶ ⊙(even ! x ≡ even ! y))
  { clear h₂,
    henceforth at ⊢ h₀ h₁,
-- _inst_1 : persistent Γ,
-- h₁ : ⊙y ≃ y,
-- h₀ : ⊙x ≃ succ ! succ ! x
-- ⊢ (even ! x ≡ even ! y) ⟶ ⊙(even ! x ≡ even ! y)
    intros h₃,
-- h₁ : ⊙y ≃ y,
-- h₀ : ⊙x ≃ succ ! succ ! x,
-- h₃ : even ! x ≡ even ! y
-- ⊢ ⊙(even ! x ≡ even ! y)
    explicit' with h₀ h₁ h₃
-- x x' y y' : ℕ,
-- h₃ : nat.even x ↔ nat.even y,
-- h₀ : x' = nat.succ (nat.succ x),
-- h₁ : y' = y
-- ⊢ nat.even x' ↔ nat.even y'
    { have := even_succ_succ x,
-- x x' y y' : ℕ,
-- h₃ : nat.even x ↔ nat.even y,
-- h₀ : x' = nat.succ (nat.succ x),
-- h₁ : y' = y,
-- this : nat.even (nat.succ (nat.succ x)) ↔ nat.even x
-- ⊢ nat.even x' ↔ nat.even y'
      guard_hyp h₀ := x' = nat.succ (nat.succ x),
      guard_target (nat.even x' ↔ nat.even y'),
      cc, } },
-- h₀ : ◻(⊙x ≃ succ ! succ ! x),
-- h₁ : ◻(⊙y ≃ y),
-- h₂ : even ! x ≡ even ! y
-- ⊢ even ! x ≡ even ! y
  { assumption },
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.pi_instances
import Mathlib.algebra.group.pi
import Mathlib.algebra.ring.basic
import Mathlib.PostPort

universes u v w u_1 u_2

namespace Mathlib

/-!
# Pi instances for ring

This file defines instances for ring, semiring and related structures on Pi Types
-/

namespace pi

protected instance distrib {I : Type u} {f : I → Type v} [(i : I) → distrib (f i)] :
    distrib ((i : I) → f i) :=
  distrib.mk Mul.mul Add.add sorry sorry

protected instance semiring {I : Type u} {f : I → Type v} [(i : I) → semiring (f i)] :
    semiring ((i : I) → f i) :=
  semiring.mk Add.add sorry 0 sorry sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry sorry sorry

protected instance comm_semiring {I : Type u} {f : I → Type v} [(i : I) → comm_semiring (f i)] :
    comm_semiring ((i : I) → f i) :=
  comm_semiring.mk Add.add sorry 0 sorry sorry sorry Mul.mul sorry 1 sorry sorry sorry sorry sorry
    sorry sorry

protected instance ring {I : Type u} {f : I → Type v} [(i : I) → ring (f i)] :
    ring ((i : I) → f i) :=
  ring.mk Add.add sorry 0 sorry sorry Neg.neg
    (fun (ᾰ ᾰ_1 : (i : I) → f i) (i : I) => ring.sub (ᾰ i) (ᾰ_1 i)) sorry sorry Mul.mul sorry 1
    sorry sorry sorry sorry

protected instance comm_ring {I : Type u} {f : I → Type v} [(i : I) → comm_ring (f i)] :
    comm_ring ((i : I) → f i) :=
  comm_ring.mk Add.add sorry 0 sorry sorry Neg.neg
    (fun (ᾰ ᾰ_1 : (i : I) → f i) (i : I) => comm_ring.sub (ᾰ i) (ᾰ_1 i)) sorry sorry Mul.mul sorry 1
    sorry sorry sorry sorry sorry

/-- A family of ring homomorphisms `f a : γ →+* β a` defines a ring homomorphism
`pi.ring_hom f : γ →+* Π a, β a` given by `pi.ring_hom f x b = f b x`. -/
protected def ring_hom {α : Type u} {β : α → Type v} [R : (a : α) → semiring (β a)] {γ : Type w}
    [semiring γ] (f : (a : α) → γ →+* β a) : γ →+* (a : α) → β a :=
  ring_hom.mk (fun (x : γ) (b : α) => coe_fn (f b) x) sorry sorry sorry sorry

@[simp] theorem ring_hom_apply {α : Type u} {β : α → Type v} [R : (a : α) → semiring (β a)]
    {γ : Type w} [semiring γ] (f : (a : α) → γ →+* β a) (g : γ) (a : α) :
    coe_fn (pi.ring_hom f) g a = coe_fn (f a) g :=
  rfl

end pi

/-- Evaluation of functions into an indexed collection of monoids at a point is a monoid
homomorphism. -/
def ring_hom.apply {I : Type u_1} (f : I → Type u_2) [(i : I) → semiring (f i)] (i : I) :
    ((i : I) → f i) →+* f i :=
  ring_hom.mk (monoid_hom.to_fun (monoid_hom.apply f i)) sorry sorry sorry sorry

@[simp] theorem ring_hom.apply_apply {I : Type u_1} (f : I → Type u_2) [(i : I) → semiring (f i)]
    (i : I) (g : (i : I) → f i) : coe_fn (ring_hom.apply f i) g = g i :=
  rfl

end Mathlib


inductive MyBool :=
  | MyTrue
  | MyFalse

inductive T :=
  | mk (b: MyBool) (u: Unit)

inductive isTrue: T → Type :=
  | intro: isTrue (.mk .MyTrue ())

example {τ: T} (h: isTrue τ): Unit :=
  match τ, h with
  | .mk .MyTrue (), .intro => ()