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

! This file was ported from Lean 3 source module data.real.hyperreal
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Filter.FilterProduct
import Mathbin.Analysis.SpecificLimits.Basic

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

open Filter Filter.Germ

open Topology Classical

/-- Hyperreal numbers on the ultrafilter extending the cofinite filter -/
def Hyperreal : Type :=
  Germ (hyperfilter ℕ : Filter ℕ) ℝ deriving LinearOrderedField, Inhabited
#align hyperreal Hyperreal

namespace Hyperreal

-- mathport name: «exprℝ*»
notation "ℝ*" => Hyperreal

noncomputable instance : CoeTC ℝ ℝ* :=
  ⟨fun x => (↑x : Germ _ _)⟩

@[simp, norm_cast]
theorem coe_eq_coe {x y : ℝ} : (x : ℝ*) = y ↔ x = y :=
  Germ.const_inj
#align hyperreal.coe_eq_coe Hyperreal.coe_eq_coe

theorem coe_ne_coe {x y : ℝ} : (x : ℝ*) ≠ y ↔ x ≠ y :=
  coe_eq_coe.Not
#align hyperreal.coe_ne_coe Hyperreal.coe_ne_coe

@[simp, norm_cast]
theorem coe_eq_zero {x : ℝ} : (x : ℝ*) = 0 ↔ x = 0 :=
  coe_eq_coe
#align hyperreal.coe_eq_zero Hyperreal.coe_eq_zero

@[simp, norm_cast]
theorem coe_eq_one {x : ℝ} : (x : ℝ*) = 1 ↔ x = 1 :=
  coe_eq_coe
#align hyperreal.coe_eq_one Hyperreal.coe_eq_one

@[norm_cast]
theorem coe_ne_zero {x : ℝ} : (x : ℝ*) ≠ 0 ↔ x ≠ 0 :=
  coe_ne_coe
#align hyperreal.coe_ne_zero Hyperreal.coe_ne_zero

@[norm_cast]
theorem coe_ne_one {x : ℝ} : (x : ℝ*) ≠ 1 ↔ x ≠ 1 :=
  coe_ne_coe
#align hyperreal.coe_ne_one Hyperreal.coe_ne_one

@[simp, norm_cast]
theorem coe_one : ↑(1 : ℝ) = (1 : ℝ*) :=
  rfl
#align hyperreal.coe_one Hyperreal.coe_one

@[simp, norm_cast]
theorem coe_zero : ↑(0 : ℝ) = (0 : ℝ*) :=
  rfl
#align hyperreal.coe_zero Hyperreal.coe_zero

@[simp, norm_cast]
theorem coe_inv (x : ℝ) : ↑x⁻¹ = (x⁻¹ : ℝ*) :=
  rfl
#align hyperreal.coe_inv Hyperreal.coe_inv

@[simp, norm_cast]
theorem coe_neg (x : ℝ) : ↑(-x) = (-x : ℝ*) :=
  rfl
#align hyperreal.coe_neg Hyperreal.coe_neg

@[simp, norm_cast]
theorem coe_add (x y : ℝ) : ↑(x + y) = (x + y : ℝ*) :=
  rfl
#align hyperreal.coe_add Hyperreal.coe_add

@[simp, norm_cast]
theorem coe_bit0 (x : ℝ) : ↑(bit0 x) = (bit0 x : ℝ*) :=
  rfl
#align hyperreal.coe_bit0 Hyperreal.coe_bit0

@[simp, norm_cast]
theorem coe_bit1 (x : ℝ) : ↑(bit1 x) = (bit1 x : ℝ*) :=
  rfl
#align hyperreal.coe_bit1 Hyperreal.coe_bit1

@[simp, norm_cast]
theorem coe_mul (x y : ℝ) : ↑(x * y) = (x * y : ℝ*) :=
  rfl
#align hyperreal.coe_mul Hyperreal.coe_mul

@[simp, norm_cast]
theorem coe_div (x y : ℝ) : ↑(x / y) = (x / y : ℝ*) :=
  rfl
#align hyperreal.coe_div Hyperreal.coe_div

@[simp, norm_cast]
theorem coe_sub (x y : ℝ) : ↑(x - y) = (x - y : ℝ*) :=
  rfl
#align hyperreal.coe_sub Hyperreal.coe_sub

@[simp, norm_cast]
theorem coe_le_coe {x y : ℝ} : (x : ℝ*) ≤ y ↔ x ≤ y :=
  Germ.const_le_iff
#align hyperreal.coe_le_coe Hyperreal.coe_le_coe

@[simp, norm_cast]
theorem coe_lt_coe {x y : ℝ} : (x : ℝ*) < y ↔ x < y :=
  Germ.const_lt_iff
#align hyperreal.coe_lt_coe Hyperreal.coe_lt_coe

@[simp, norm_cast]
theorem coe_nonneg {x : ℝ} : 0 ≤ (x : ℝ*) ↔ 0 ≤ x :=
  coe_le_coe
#align hyperreal.coe_nonneg Hyperreal.coe_nonneg

@[simp, norm_cast]
theorem coe_pos {x : ℝ} : 0 < (x : ℝ*) ↔ 0 < x :=
  coe_lt_coe
#align hyperreal.coe_pos Hyperreal.coe_pos

@[simp, norm_cast]
theorem coe_abs (x : ℝ) : ((|x| : ℝ) : ℝ*) = |x| :=
  const_abs x
#align hyperreal.coe_abs Hyperreal.coe_abs

@[simp, norm_cast]
theorem coe_max (x y : ℝ) : ((max x y : ℝ) : ℝ*) = max x y :=
  Germ.const_max _ _
#align hyperreal.coe_max Hyperreal.coe_max

@[simp, norm_cast]
theorem coe_min (x y : ℝ) : ((min x y : ℝ) : ℝ*) = min x y :=
  Germ.const_min _ _
#align hyperreal.coe_min Hyperreal.coe_min

/-- Construct a hyperreal number from a sequence of real numbers. -/
noncomputable def ofSeq (f : ℕ → ℝ) : ℝ* :=
  (↑f : Germ (hyperfilter ℕ : Filter ℕ) ℝ)
#align hyperreal.of_seq Hyperreal.ofSeq

/-- A sample infinitesimal hyperreal-/
noncomputable def epsilon : ℝ* :=
  ofSeq fun n => n⁻¹
#align hyperreal.epsilon Hyperreal.epsilon

/-- A sample infinite hyperreal-/
noncomputable def omega : ℝ* :=
  ofSeq coe
#align hyperreal.omega Hyperreal.omega

-- mathport name: hyperreal.epsilon
scoped notation "ε" => Hyperreal.epsilon

-- mathport name: hyperreal.omega
scoped notation "ω" => Hyperreal.omega

@[simp]
theorem inv_omega : ω⁻¹ = ε :=
  rfl
#align hyperreal.inv_omega Hyperreal.inv_omega

@[simp]
theorem inv_epsilon : ε⁻¹ = ω :=
  @inv_inv _ _ ω
#align hyperreal.inv_epsilon Hyperreal.inv_epsilon

theorem omega_pos : 0 < ω :=
  Germ.coe_pos.2 <|
    mem_hyperfilter_of_finite_compl <|
      by
      convert Set.finite_singleton 0
      simp [Set.eq_singleton_iff_unique_mem]
#align hyperreal.omega_pos Hyperreal.omega_pos

theorem epsilon_pos : 0 < ε :=
  inv_pos_of_pos omega_pos
#align hyperreal.epsilon_pos Hyperreal.epsilon_pos

theorem epsilon_ne_zero : ε ≠ 0 :=
  epsilon_pos.ne'
#align hyperreal.epsilon_ne_zero Hyperreal.epsilon_ne_zero

theorem omega_ne_zero : ω ≠ 0 :=
  omega_pos.ne'
#align hyperreal.omega_ne_zero Hyperreal.omega_ne_zero

theorem epsilon_mul_omega : ε * ω = 1 :=
  @inv_mul_cancel _ _ ω omega_ne_zero
#align hyperreal.epsilon_mul_omega Hyperreal.epsilon_mul_omega

theorem lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : Tendsto f atTop (𝓝 0)) :
    ∀ {r : ℝ}, 0 < r → ofSeq f < (r : ℝ*) :=
  by
  simp only [Metric.tendsto_atTop, Real.dist_eq, sub_zero, lt_def] at hf⊢
  intro r hr; cases' hf r hr with N hf'
  have hs : { i : ℕ | f i < r }ᶜ ⊆ { i : ℕ | i ≤ N } := fun i hi1 =>
    le_of_lt
      (by
        simp only [lt_iff_not_ge] <;>
          exact fun 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)
#align hyperreal.lt_of_tendsto_zero_of_pos Hyperreal.lt_of_tendsto_zero_of_pos

theorem neg_lt_of_tendsto_zero_of_pos {f : ℕ → ℝ} (hf : Tendsto f atTop (𝓝 0)) :
    ∀ {r : ℝ}, 0 < r → (-r : ℝ*) < ofSeq f := fun 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)
#align hyperreal.neg_lt_of_tendsto_zero_of_pos Hyperreal.neg_lt_of_tendsto_zero_of_pos

theorem gt_of_tendsto_zero_of_neg {f : ℕ → ℝ} (hf : Tendsto f atTop (𝓝 0)) :
    ∀ {r : ℝ}, r < 0 → (r : ℝ*) < ofSeq f := fun r hr => by
  rw [← neg_neg r, coe_neg] <;> exact neg_lt_of_tendsto_zero_of_pos hf (neg_pos.mpr hr)
#align hyperreal.gt_of_tendsto_zero_of_neg Hyperreal.gt_of_tendsto_zero_of_neg

theorem epsilon_lt_pos (x : ℝ) : 0 < x → ε < x :=
  lt_of_tendsto_zero_of_pos tendsto_inverse_atTop_nhds_0_nat
#align hyperreal.epsilon_lt_pos Hyperreal.epsilon_lt_pos

/-- Standard part predicate -/
def IsSt (x : ℝ*) (r : ℝ) :=
  ∀ δ : ℝ, 0 < δ → (r - δ : ℝ*) < x ∧ x < r + δ
#align hyperreal.is_st Hyperreal.IsSt

/-- Standard part function: like a "round" to ℝ instead of ℤ -/
noncomputable def st : ℝ* → ℝ := fun x => if h : ∃ r, IsSt x r then Classical.choose h else 0
#align hyperreal.st Hyperreal.st

/-- A hyperreal number is infinitesimal if its standard part is 0 -/
def Infinitesimal (x : ℝ*) :=
  IsSt x 0
#align hyperreal.infinitesimal Hyperreal.Infinitesimal

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

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

/-- A hyperreal number is infinite if it is infinite positive or infinite negative -/
def Infinite (x : ℝ*) :=
  InfinitePos x ∨ InfiniteNeg x
#align hyperreal.infinite Hyperreal.Infinite

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

private theorem is_st_unique' (x : ℝ*) (r s : ℝ) (hr : IsSt x r) (hs : IsSt x s) (hrs : r < s) :
    False := by
  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
  norm_cast  at *
  rw [h] at hs'
  exact not_lt_of_lt hs' hr'
#align hyperreal.is_st_unique' hyperreal.is_st_unique'

theorem isSt_unique {x : ℝ*} {r s : ℝ} (hr : IsSt x r) (hs : IsSt x s) : r = s :=
  by
  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)
#align hyperreal.is_st_unique Hyperreal.isSt_unique

theorem not_infinite_of_exists_st {x : ℝ*} : (∃ r : ℝ, IsSt x r) → ¬Infinite x := fun he hi =>
  Exists.dcases_on he fun r hr =>
    hi.elim (fun hip => not_lt_of_lt (hr 2 zero_lt_two).2 (hip <| r + 2)) fun hin =>
      not_lt_of_lt (hr 2 zero_lt_two).1 (hin <| r - 2)
#align hyperreal.not_infinite_of_exists_st Hyperreal.not_infinite_of_exists_st

theorem isSt_supₛ {x : ℝ*} (hni : ¬Infinite x) : IsSt x (supₛ { y : ℝ | (y : ℝ*) < x }) :=
  let S : Set ℝ := { y : ℝ | (y : ℝ*) < x }
  let R : _ := supₛ S
  have hnile := not_forall.mp (not_or.mp hni).1
  have hnige := not_forall.mp (not_or.mp hni).2
  Exists.dcases_on hnile <|
    Exists.dcases_on hnige fun r₁ hr₁ r₂ hr₂ =>
      have HR₁ : S.Nonempty :=
        ⟨r₁ - 1, lt_of_lt_of_le (coe_lt_coe.2 <| sub_one_lt _) (not_lt.mp hr₁)⟩
      have HR₂ : BddAbove S :=
        ⟨r₂, fun y hy => le_of_lt (coe_lt_coe.1 (lt_of_lt_of_le hy (not_lt.mp hr₂)))⟩
      fun δ hδ =>
      ⟨lt_of_not_le fun c =>
          have hc : ∀ y ∈ S, y ≤ R - δ := fun y hy =>
            coe_le_coe.1 <| le_of_lt <| lt_of_lt_of_le hy c
          not_lt_of_le (csupₛ_le HR₁ hc) <| sub_lt_self R hδ,
        lt_of_not_le fun c =>
          have hc : ↑(R + δ / 2) < x :=
            lt_of_lt_of_le (add_lt_add_left (coe_lt_coe.2 (half_lt_self hδ)) R) c
          not_lt_of_le (le_csupₛ HR₂ hc) <| (lt_add_iff_pos_right _).mpr <| half_pos hδ⟩
#align hyperreal.is_st_Sup Hyperreal.isSt_supₛ

theorem exists_st_of_not_infinite {x : ℝ*} (hni : ¬Infinite x) : ∃ r : ℝ, IsSt x r :=
  ⟨supₛ { y : ℝ | (y : ℝ*) < x }, isSt_supₛ hni⟩
#align hyperreal.exists_st_of_not_infinite Hyperreal.exists_st_of_not_infinite

theorem st_eq_supₛ {x : ℝ*} : st x = supₛ { y : ℝ | (y : ℝ*) < x } :=
  by
  unfold st; split_ifs
  · exact is_st_unique (Classical.choose_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 fun i => ⟨fun hi => Set.mem_univ i, fun hi => H i⟩ :
          { y : ℝ | (y : ℝ*) < x } = Set.univ)]
      exact real.Sup_univ.symm
    · rw [(Set.ext fun i =>
            ⟨fun hi => False.elim (not_lt_of_lt (H i) hi), fun hi =>
              False.elim (Set.not_mem_empty i hi)⟩ :
          { y : ℝ | (y : ℝ*) < x } = ∅)]
      exact real.Sup_empty.symm
#align hyperreal.st_eq_Sup Hyperreal.st_eq_supₛ

theorem exists_st_iff_not_infinite {x : ℝ*} : (∃ r : ℝ, IsSt x r) ↔ ¬Infinite x :=
  ⟨not_infinite_of_exists_st, exists_st_of_not_infinite⟩
#align hyperreal.exists_st_iff_not_infinite Hyperreal.exists_st_iff_not_infinite

theorem infinite_iff_not_exists_st {x : ℝ*} : Infinite x ↔ ¬∃ r : ℝ, IsSt x r :=
  iff_not_comm.mp exists_st_iff_not_infinite
#align hyperreal.infinite_iff_not_exists_st Hyperreal.infinite_iff_not_exists_st

theorem st_infinite {x : ℝ*} (hi : Infinite x) : st x = 0 :=
  by
  unfold st; split_ifs
  · exact False.elim ((infinite_iff_not_exists_st.mp hi) h)
  · rfl
#align hyperreal.st_infinite Hyperreal.st_infinite

theorem st_of_isSt {x : ℝ*} {r : ℝ} (hxr : IsSt x r) : st x = r :=
  by
  unfold st; split_ifs
  · exact is_st_unique (Classical.choose_spec h) hxr
  · exact False.elim (h ⟨r, hxr⟩)
#align hyperreal.st_of_is_st Hyperreal.st_of_isSt

theorem isSt_st_of_isSt {x : ℝ*} {r : ℝ} (hxr : IsSt x r) : IsSt x (st x) := by
  rwa [st_of_is_st hxr]
#align hyperreal.is_st_st_of_is_st Hyperreal.isSt_st_of_isSt

theorem isSt_st_of_exists_st {x : ℝ*} (hx : ∃ r : ℝ, IsSt x r) : IsSt x (st x) :=
  Exists.dcases_on hx fun r => isSt_st_of_isSt
#align hyperreal.is_st_st_of_exists_st Hyperreal.isSt_st_of_exists_st

theorem isSt_st {x : ℝ*} (hx : st x ≠ 0) : IsSt x (st x) :=
  by
  unfold st; split_ifs
  · exact Classical.choose_spec h
  · exact False.elim (hx (by unfold st <;> split_ifs <;> rfl))
#align hyperreal.is_st_st Hyperreal.isSt_st

theorem isSt_st' {x : ℝ*} (hx : ¬Infinite x) : IsSt x (st x) :=
  isSt_st_of_exists_st <| exists_st_of_not_infinite hx
#align hyperreal.is_st_st' Hyperreal.isSt_st'

theorem isSt_refl_real (r : ℝ) : IsSt r r := fun δ hδ =>
  ⟨sub_lt_self _ (coe_lt_coe.2 hδ), lt_add_of_pos_right _ (coe_lt_coe.2 hδ)⟩
#align hyperreal.is_st_refl_real Hyperreal.isSt_refl_real

theorem st_id_real (r : ℝ) : st r = r :=
  st_of_isSt (isSt_refl_real r)
#align hyperreal.st_id_real Hyperreal.st_id_real

theorem eq_of_isSt_real {r s : ℝ} : IsSt r s → r = s :=
  isSt_unique (isSt_refl_real r)
#align hyperreal.eq_of_is_st_real Hyperreal.eq_of_isSt_real

theorem isSt_real_iff_eq {r s : ℝ} : IsSt r s ↔ r = s :=
  ⟨eq_of_isSt_real, fun hrs => by rw [hrs] <;> exact is_st_refl_real s⟩
#align hyperreal.is_st_real_iff_eq Hyperreal.isSt_real_iff_eq

theorem isSt_symm_real {r s : ℝ} : IsSt r s ↔ IsSt s r := by
  rw [is_st_real_iff_eq, is_st_real_iff_eq, eq_comm]
#align hyperreal.is_st_symm_real Hyperreal.isSt_symm_real

theorem isSt_trans_real {r s t : ℝ} : IsSt r s → IsSt s t → IsSt r t := by
  rw [is_st_real_iff_eq, is_st_real_iff_eq, is_st_real_iff_eq] <;> exact Eq.trans
#align hyperreal.is_st_trans_real Hyperreal.isSt_trans_real

theorem isSt_inj_real {r₁ r₂ s : ℝ} (h1 : IsSt r₁ s) (h2 : IsSt r₂ s) : r₁ = r₂ :=
  Eq.trans (eq_of_isSt_real h1) (eq_of_isSt_real h2).symm
#align hyperreal.is_st_inj_real Hyperreal.isSt_inj_real

theorem isSt_iff_abs_sub_lt_delta {x : ℝ*} {r : ℝ} : IsSt x r ↔ ∀ δ : ℝ, 0 < δ → |x - r| < δ := by
  simp only [abs_sub_lt_iff, sub_lt_iff_lt_add, is_st, and_comm', add_comm]
#align hyperreal.is_st_iff_abs_sub_lt_delta Hyperreal.isSt_iff_abs_sub_lt_delta

theorem isSt_add {x y : ℝ*} {r s : ℝ} : IsSt x r → IsSt y s → IsSt (x + y) (r + s) :=
  fun 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⟩
#align hyperreal.is_st_add Hyperreal.isSt_add

theorem isSt_neg {x : ℝ*} {r : ℝ} (hxr : IsSt x r) : IsSt (-x) (-r) := fun d hd =>
  show -(r : ℝ*) - d < -x ∧ -x < -r + d by cases hxr d hd <;> constructor <;> linarith
#align hyperreal.is_st_neg Hyperreal.isSt_neg

theorem isSt_sub {x y : ℝ*} {r s : ℝ} : IsSt x r → IsSt y s → IsSt (x - y) (r - s) := fun hxr hys =>
  by rw [sub_eq_add_neg, sub_eq_add_neg] <;> exact is_st_add hxr (is_st_neg hys)
#align hyperreal.is_st_sub Hyperreal.isSt_sub

-- (st x < st y) → (x < y) → (x ≤ y) → (st x ≤ st y)
theorem lt_of_isSt_lt {x y : ℝ*} {r s : ℝ} (hxr : IsSt x r) (hys : IsSt y s) : r < s → x < y :=
  fun hrs => by
  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
  norm_cast  at *
  rw [H1] at hxr'
  rw [H2] at hys'
  exact lt_trans hxr' hys'
#align hyperreal.lt_of_is_st_lt Hyperreal.lt_of_isSt_lt

theorem isSt_le_of_le {x y : ℝ*} {r s : ℝ} (hrx : IsSt x r) (hsy : IsSt y s) : x ≤ y → r ≤ s := by
  rw [← not_lt, ← not_lt, not_imp_not] <;> exact lt_of_is_st_lt hsy hrx
#align hyperreal.is_st_le_of_le Hyperreal.isSt_le_of_le

theorem st_le_of_le {x y : ℝ*} (hix : ¬Infinite x) (hiy : ¬Infinite y) : x ≤ y → st x ≤ st y :=
  have hx' := isSt_st' hix
  have hy' := isSt_st' hiy
  isSt_le_of_le hx' hy'
#align hyperreal.st_le_of_le Hyperreal.st_le_of_le

theorem lt_of_st_lt {x y : ℝ*} (hix : ¬Infinite x) (hiy : ¬Infinite y) : st x < st y → x < y :=
  have hx' := isSt_st' hix
  have hy' := isSt_st' hiy
  lt_of_isSt_lt hx' hy'
#align hyperreal.lt_of_st_lt Hyperreal.lt_of_st_lt

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

theorem infinitePos_def {x : ℝ*} : InfinitePos x ↔ ∀ r : ℝ, ↑r < x := by rw [iff_eq_eq] <;> rfl
#align hyperreal.infinite_pos_def Hyperreal.infinitePos_def

theorem infiniteNeg_def {x : ℝ*} : InfiniteNeg x ↔ ∀ r : ℝ, x < r := by rw [iff_eq_eq] <;> rfl
#align hyperreal.infinite_neg_def Hyperreal.infiniteNeg_def

theorem ne_zero_of_infinite {x : ℝ*} : Infinite x → x ≠ 0 := fun hI h0 =>
  Or.cases_on hI (fun hip => lt_irrefl (0 : ℝ*) ((by rwa [← h0] : InfinitePos 0) 0)) fun hin =>
    lt_irrefl (0 : ℝ*) ((by rwa [← h0] : InfiniteNeg 0) 0)
#align hyperreal.ne_zero_of_infinite Hyperreal.ne_zero_of_infinite

theorem not_infinite_zero : ¬Infinite 0 := fun hI => ne_zero_of_infinite hI rfl
#align hyperreal.not_infinite_zero Hyperreal.not_infinite_zero

theorem pos_of_infinitePos {x : ℝ*} : InfinitePos x → 0 < x := fun hip => hip 0
#align hyperreal.pos_of_infinite_pos Hyperreal.pos_of_infinitePos

theorem neg_of_infiniteNeg {x : ℝ*} : InfiniteNeg x → x < 0 := fun hin => hin 0
#align hyperreal.neg_of_infinite_neg Hyperreal.neg_of_infiniteNeg

theorem not_infinitePos_of_infiniteNeg {x : ℝ*} : InfiniteNeg x → ¬InfinitePos x := fun hn hp =>
  not_lt_of_lt (hn 1) (hp 1)
#align hyperreal.not_infinite_pos_of_infinite_neg Hyperreal.not_infinitePos_of_infiniteNeg

theorem not_infiniteNeg_of_infinitePos {x : ℝ*} : InfinitePos x → ¬InfiniteNeg x :=
  imp_not_comm.mp not_infinitePos_of_infiniteNeg
#align hyperreal.not_infinite_neg_of_infinite_pos Hyperreal.not_infiniteNeg_of_infinitePos

theorem infiniteNeg_neg_of_infinitePos {x : ℝ*} : InfinitePos x → InfiniteNeg (-x) := fun hp r =>
  neg_lt.mp (hp (-r))
#align hyperreal.infinite_neg_neg_of_infinite_pos Hyperreal.infiniteNeg_neg_of_infinitePos

theorem infinitePos_neg_of_infiniteNeg {x : ℝ*} : InfiniteNeg x → InfinitePos (-x) := fun hp r =>
  lt_neg.mp (hp (-r))
#align hyperreal.infinite_pos_neg_of_infinite_neg Hyperreal.infinitePos_neg_of_infiniteNeg

theorem infinitePos_iff_infiniteNeg_neg {x : ℝ*} : InfinitePos x ↔ InfiniteNeg (-x) :=
  ⟨infiniteNeg_neg_of_infinitePos, fun hin => neg_neg x ▸ infinitePos_neg_of_infiniteNeg hin⟩
#align hyperreal.infinite_pos_iff_infinite_neg_neg Hyperreal.infinitePos_iff_infiniteNeg_neg

theorem infiniteNeg_iff_infinitePos_neg {x : ℝ*} : InfiniteNeg x ↔ InfinitePos (-x) :=
  ⟨infinitePos_neg_of_infiniteNeg, fun hin => neg_neg x ▸ infiniteNeg_neg_of_infinitePos hin⟩
#align hyperreal.infinite_neg_iff_infinite_pos_neg Hyperreal.infiniteNeg_iff_infinitePos_neg

theorem infinite_iff_infinite_neg {x : ℝ*} : Infinite x ↔ Infinite (-x) :=
  ⟨fun hi =>
    Or.cases_on hi (fun hip => Or.inr (infiniteNeg_neg_of_infinitePos hip)) fun hin =>
      Or.inl (infinitePos_neg_of_infiniteNeg hin),
    fun hi =>
    Or.cases_on hi (fun hipn => Or.inr (infiniteNeg_iff_infinitePos_neg.mpr hipn)) fun hinp =>
      Or.inl (infinitePos_iff_infiniteNeg_neg.mpr hinp)⟩
#align hyperreal.infinite_iff_infinite_neg Hyperreal.infinite_iff_infinite_neg

theorem not_infinite_of_infinitesimal {x : ℝ*} : Infinitesimal x → ¬Infinite x := fun hi hI =>
  have hi' := hi 2 zero_lt_two
  Or.dcases_on hI
    (fun hip =>
      have hip' := hip 2
      not_lt_of_lt hip' (by convert hi'.2 <;> exact (zero_add 2).symm))
    fun hin =>
    have hin' := hin (-2)
    not_lt_of_lt hin' (by convert hi'.1 <;> exact (zero_sub 2).symm)
#align hyperreal.not_infinite_of_infinitesimal Hyperreal.not_infinite_of_infinitesimal

theorem not_infinitesimal_of_infinite {x : ℝ*} : Infinite x → ¬Infinitesimal x :=
  imp_not_comm.mp not_infinite_of_infinitesimal
#align hyperreal.not_infinitesimal_of_infinite Hyperreal.not_infinitesimal_of_infinite

theorem not_infinitesimal_of_infinitePos {x : ℝ*} : InfinitePos x → ¬Infinitesimal x := fun hp =>
  not_infinitesimal_of_infinite (Or.inl hp)
#align hyperreal.not_infinitesimal_of_infinite_pos Hyperreal.not_infinitesimal_of_infinitePos

theorem not_infinitesimal_of_infiniteNeg {x : ℝ*} : InfiniteNeg x → ¬Infinitesimal x := fun hn =>
  not_infinitesimal_of_infinite (Or.inr hn)
#align hyperreal.not_infinitesimal_of_infinite_neg Hyperreal.not_infinitesimal_of_infiniteNeg

theorem infinitePos_iff_infinite_and_pos {x : ℝ*} : InfinitePos x ↔ Infinite x ∧ 0 < x :=
  ⟨fun hip => ⟨Or.inl hip, hip 0⟩, fun ⟨hi, hp⟩ =>
    hi.casesOn (fun hip => hip) fun hin => False.elim (not_lt_of_lt hp (hin 0))⟩
#align hyperreal.infinite_pos_iff_infinite_and_pos Hyperreal.infinitePos_iff_infinite_and_pos

theorem infiniteNeg_iff_infinite_and_neg {x : ℝ*} : InfiniteNeg x ↔ Infinite x ∧ x < 0 :=
  ⟨fun hip => ⟨Or.inr hip, hip 0⟩, fun ⟨hi, hp⟩ =>
    hi.casesOn (fun hin => False.elim (not_lt_of_lt hp (hin 0))) fun hip => hip⟩
#align hyperreal.infinite_neg_iff_infinite_and_neg Hyperreal.infiniteNeg_iff_infinite_and_neg

theorem infinitePos_iff_infinite_of_pos {x : ℝ*} (hp : 0 < x) : InfinitePos x ↔ Infinite x := by
  rw [infinite_pos_iff_infinite_and_pos] <;> exact ⟨fun hI => hI.1, fun hI => ⟨hI, hp⟩⟩
#align hyperreal.infinite_pos_iff_infinite_of_pos Hyperreal.infinitePos_iff_infinite_of_pos

theorem infinitePos_iff_infinite_of_nonneg {x : ℝ*} (hp : 0 ≤ x) : InfinitePos x ↔ Infinite x :=
  Or.cases_on (lt_or_eq_of_le hp) infinitePos_iff_infinite_of_pos fun h => by
    rw [h.symm] <;>
      exact
        ⟨fun hIP => False.elim (not_infinite_zero (Or.inl hIP)), fun hI =>
          False.elim (not_infinite_zero hI)⟩
#align hyperreal.infinite_pos_iff_infinite_of_nonneg Hyperreal.infinitePos_iff_infinite_of_nonneg

theorem infiniteNeg_iff_infinite_of_neg {x : ℝ*} (hn : x < 0) : InfiniteNeg x ↔ Infinite x := by
  rw [infinite_neg_iff_infinite_and_neg] <;> exact ⟨fun hI => hI.1, fun hI => ⟨hI, hn⟩⟩
#align hyperreal.infinite_neg_iff_infinite_of_neg Hyperreal.infiniteNeg_iff_infinite_of_neg

theorem infinitePos_abs_iff_infinite_abs {x : ℝ*} : InfinitePos (|x|) ↔ Infinite (|x|) :=
  infinitePos_iff_infinite_of_nonneg (abs_nonneg _)
#align hyperreal.infinite_pos_abs_iff_infinite_abs Hyperreal.infinitePos_abs_iff_infinite_abs

theorem infinite_iff_infinitePos_abs {x : ℝ*} : Infinite x ↔ InfinitePos (|x|) :=
  ⟨fun hi d =>
    Or.cases_on hi (fun hip => by rw [abs_of_pos (hip 0)] <;> exact hip d) fun hin => by
      rw [abs_of_neg (hin 0)] <;> exact lt_neg.mp (hin (-d)),
    fun 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)⟩
#align hyperreal.infinite_iff_infinite_pos_abs Hyperreal.infinite_iff_infinitePos_abs

theorem infinite_iff_infinite_abs {x : ℝ*} : Infinite x ↔ Infinite (|x|) := by
  rw [← infinite_pos_iff_infinite_of_nonneg (abs_nonneg _), infinite_iff_infinite_pos_abs]
#align hyperreal.infinite_iff_infinite_abs Hyperreal.infinite_iff_infinite_abs

theorem infinite_iff_abs_lt_abs {x : ℝ*} : Infinite x ↔ ∀ r : ℝ, (|r| : ℝ*) < |x| :=
  ⟨fun hI r => coe_abs r ▸ infinite_iff_infinitePos_abs.mp hI (|r|), fun hR =>
    Or.cases_on (max_choice x (-x))
      (fun h => Or.inl fun r => lt_of_le_of_lt (le_abs_self _) (h ▸ hR r)) fun h =>
      Or.inr fun r => neg_lt_neg_iff.mp <| lt_of_le_of_lt (neg_le_abs_self _) (h ▸ hR r)⟩
#align hyperreal.infinite_iff_abs_lt_abs Hyperreal.infinite_iff_abs_lt_abs

theorem infinitePos_add_not_infiniteNeg {x y : ℝ*} :
    InfinitePos x → ¬InfiniteNeg y → InfinitePos (x + y) :=
  by
  intro 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
#align hyperreal.infinite_pos_add_not_infinite_neg Hyperreal.infinitePos_add_not_infiniteNeg

theorem not_infiniteNeg_add_infinitePos {x y : ℝ*} :
    ¬InfiniteNeg x → InfinitePos y → InfinitePos (x + y) := fun hx hy => by
  rw [add_comm] <;> exact infinite_pos_add_not_infinite_neg hy hx
#align hyperreal.not_infinite_neg_add_infinite_pos Hyperreal.not_infiniteNeg_add_infinitePos

theorem infiniteNeg_add_not_infinitePos {x y : ℝ*} :
    InfiniteNeg x → ¬InfinitePos y → InfiniteNeg (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
#align hyperreal.infinite_neg_add_not_infinite_pos Hyperreal.infiniteNeg_add_not_infinitePos

theorem not_infinitePos_add_infiniteNeg {x y : ℝ*} :
    ¬InfinitePos x → InfiniteNeg y → InfiniteNeg (x + y) := fun hx hy => by
  rw [add_comm] <;> exact infinite_neg_add_not_infinite_pos hy hx
#align hyperreal.not_infinite_pos_add_infinite_neg Hyperreal.not_infinitePos_add_infiniteNeg

theorem infinitePos_add_infinitePos {x y : ℝ*} :
    InfinitePos x → InfinitePos y → InfinitePos (x + y) := fun hx hy =>
  infinitePos_add_not_infiniteNeg hx (not_infiniteNeg_of_infinitePos hy)
#align hyperreal.infinite_pos_add_infinite_pos Hyperreal.infinitePos_add_infinitePos

theorem infiniteNeg_add_infiniteNeg {x y : ℝ*} :
    InfiniteNeg x → InfiniteNeg y → InfiniteNeg (x + y) := fun hx hy =>
  infiniteNeg_add_not_infinitePos hx (not_infinitePos_of_infiniteNeg hy)
#align hyperreal.infinite_neg_add_infinite_neg Hyperreal.infiniteNeg_add_infiniteNeg

theorem infinitePos_add_not_infinite {x y : ℝ*} :
    InfinitePos x → ¬Infinite y → InfinitePos (x + y) := fun hx hy =>
  infinitePos_add_not_infiniteNeg hx (not_or.mp hy).2
#align hyperreal.infinite_pos_add_not_infinite Hyperreal.infinitePos_add_not_infinite

theorem infiniteNeg_add_not_infinite {x y : ℝ*} :
    InfiniteNeg x → ¬Infinite y → InfiniteNeg (x + y) := fun hx hy =>
  infiniteNeg_add_not_infinitePos hx (not_or.mp hy).1
#align hyperreal.infinite_neg_add_not_infinite Hyperreal.infiniteNeg_add_not_infinite

theorem infinitePos_of_tendsto_top {f : ℕ → ℝ} (hf : Tendsto f atTop atTop) :
    InfinitePos (ofSeq f) := fun r =>
  have hf' := tendsto_atTop_atTop.mp hf
  Exists.cases_on (hf' (r + 1)) fun i hi =>
    have hi' : ∀ a : ℕ, f a < r + 1 → a < i := fun 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_setOf, not_lt] <;>
        exact fun 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
#align hyperreal.infinite_pos_of_tendsto_top Hyperreal.infinitePos_of_tendsto_top

theorem infiniteNeg_of_tendsto_bot {f : ℕ → ℝ} (hf : Tendsto f atTop atBot) :
    InfiniteNeg (ofSeq f) := fun r =>
  have hf' := tendsto_atTop_atBot.mp hf
  Exists.cases_on (hf' (r - 1)) fun i hi =>
    have hi' : ∀ a : ℕ, r - 1 < f a → a < i := fun 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_setOf, not_lt] <;>
        exact fun 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
#align hyperreal.infinite_neg_of_tendsto_bot Hyperreal.infiniteNeg_of_tendsto_bot

theorem not_infinite_neg {x : ℝ*} : ¬Infinite x → ¬Infinite (-x) :=
  not_imp_not.mpr infinite_iff_infinite_neg.mpr
#align hyperreal.not_infinite_neg Hyperreal.not_infinite_neg

theorem 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' fun r hr s hs => not_infinite_of_exists_st <| ⟨s + r, isSt_add hs hr⟩
#align hyperreal.not_infinite_add Hyperreal.not_infinite_add

theorem not_infinite_iff_exist_lt_gt {x : ℝ*} : ¬Infinite x ↔ ∃ r s : ℝ, (r : ℝ*) < x ∧ x < s :=
  ⟨fun hni =>
    Exists.dcases_on (not_forall.mp (not_or.mp hni).1) <|
      Exists.dcases_on (not_forall.mp (not_or.mp hni).2) fun 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)⟩⟩,
    fun hrs =>
    Exists.dcases_on hrs fun r hr =>
      Exists.dcases_on hr fun s hs =>
        not_or.mpr ⟨not_forall.mpr ⟨s, lt_asymm hs.2⟩, not_forall.mpr ⟨r, lt_asymm hs.1⟩⟩⟩
#align hyperreal.not_infinite_iff_exist_lt_gt Hyperreal.not_infinite_iff_exist_lt_gt

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⟩
#align hyperreal.not_infinite_real Hyperreal.not_infinite_real

theorem not_real_of_infinite {x : ℝ*} : Infinite x → ∀ r : ℝ, x ≠ r := fun hi r hr =>
  not_infinite_real r <| @Eq.subst _ Infinite _ _ hr hi
#align hyperreal.not_real_of_infinite Hyperreal.not_real_of_infinite

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

private theorem is_st_mul' {x y : ℝ*} {r s : ℝ} (hxr : IsSt x r) (hys : IsSt y s) (hs : s ≠ 0) :
    IsSt (x * y) (r * s) :=
  have hxr' := isSt_iff_abs_sub_lt_delta.mp hxr
  have hys' := isSt_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 fun u h' =>
    Exists.cases_on h' fun t ⟨hu, ht⟩ =>
      isSt_iff_abs_sub_lt_delta.mpr fun d hd =>
        calc
          |x * y - r * s| = |x * (y - s) + (x - r) * s| := by
            rw [mul_sub, sub_mul, add_sub, sub_add_cancel]
          _ ≤ |x * (y - s)| + |(x - r) * s| := (abs_add _ _)
          _ ≤ |x| * |y - s| + |x - r| * |s| := by simp only [abs_mul]
          _ ≤ |x| * (d / t / 2 : ℝ) + (d / |s| / 2 : ℝ) * |s| :=
            (add_le_add
              (mul_le_mul_of_nonneg_left
                  (le_of_lt <|
                    hys' _ <|
                      half_pos <| div_pos hd <| coe_pos.1 <| lt_of_le_of_lt (abs_nonneg x) ht) <|
                abs_nonneg _)
              (mul_le_mul_of_nonneg_right
                  (le_of_lt <| hxr' _ <| half_pos <| div_pos hd <| abs_pos.2 hs) <|
                abs_nonneg _))
          _ = (d / 2 * (|x| / t) + d / 2 : ℝ*) :=
            by
            push_cast [-Filter.Germ.const_div]
            -- TODO: Why wasn't `hyperreal.coe_div` used?
            have : (|s| : ℝ*) ≠ 0 := by simpa
            have : (2 : ℝ*) ≠ 0 := two_ne_zero
            field_simp [*, add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm]
          _ < (d / 2 * 1 + d / 2 : ℝ*) :=
            (add_lt_add_right
              (mul_lt_mul_of_pos_left ((div_lt_one <| lt_of_le_of_lt (abs_nonneg x) ht).mpr ht) <|
                half_pos <| coe_pos.2 hd)
              _)
          _ = (d : ℝ*) := by rw [mul_one, add_halves]

#align hyperreal.is_st_mul' hyperreal.is_st_mul'

theorem isSt_mul {x y : ℝ*} {r s : ℝ} (hxr : IsSt x r) (hys : IsSt y s) : IsSt (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 fun u h' =>
    Exists.cases_on h' fun t ⟨hu, ht⟩ => by
      by_cases hs : s = 0
      · apply is_st_iff_abs_sub_lt_delta.mpr
        intro 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, MulZeroClass.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
#align hyperreal.is_st_mul Hyperreal.isSt_mul

--AN INFINITE LEMMA THAT REQUIRES SOME MORE ST MACHINERY
theorem 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' fun r hr s hs => not_infinite_of_exists_st <| ⟨s * r, isSt_mul hs hr⟩
#align hyperreal.not_infinite_mul Hyperreal.not_infinite_mul

---
theorem st_add {x y : ℝ*} (hx : ¬Infinite x) (hy : ¬Infinite y) : st (x + y) = st x + st y :=
  have hx' := isSt_st' hx
  have hy' := isSt_st' hy
  have hxy := isSt_st' (not_infinite_add hx hy)
  have hxy' := isSt_add hx' hy'
  isSt_unique hxy hxy'
#align hyperreal.st_add Hyperreal.st_add

theorem 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 isSt_unique (isSt_st' (not_infinite_neg h)) (isSt_neg (isSt_st' h))
#align hyperreal.st_neg Hyperreal.st_neg

theorem st_mul {x y : ℝ*} (hx : ¬Infinite x) (hy : ¬Infinite y) : st (x * y) = st x * st y :=
  have hx' := isSt_st' hx
  have hy' := isSt_st' hy
  have hxy := isSt_st' (not_infinite_mul hx hy)
  have hxy' := isSt_mul hx' hy'
  isSt_unique hxy hxy'
#align hyperreal.st_mul Hyperreal.st_mul

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

theorem infinitesimal_def {x : ℝ*} : Infinitesimal x ↔ ∀ r : ℝ, 0 < r → -(r : ℝ*) < x ∧ x < r :=
  ⟨fun hi r hr => by convert hi r hr <;> simp, fun hi d hd => by convert hi d hd <;> simp⟩
#align hyperreal.infinitesimal_def Hyperreal.infinitesimal_def

theorem lt_of_pos_of_infinitesimal {x : ℝ*} : Infinitesimal x → ∀ r : ℝ, 0 < r → x < r :=
  fun hi r hr => ((infinitesimal_def.mp hi) r hr).2
#align hyperreal.lt_of_pos_of_infinitesimal Hyperreal.lt_of_pos_of_infinitesimal

theorem lt_neg_of_pos_of_infinitesimal {x : ℝ*} : Infinitesimal x → ∀ r : ℝ, 0 < r → -↑r < x :=
  fun hi r hr => ((infinitesimal_def.mp hi) r hr).1
#align hyperreal.lt_neg_of_pos_of_infinitesimal Hyperreal.lt_neg_of_pos_of_infinitesimal

theorem gt_of_neg_of_infinitesimal {x : ℝ*} : Infinitesimal x → ∀ r : ℝ, r < 0 → ↑r < x :=
  fun hi r hr => by
  convert((infinitesimal_def.mp hi) (-r) (neg_pos.mpr hr)).1 <;> exact (neg_neg ↑r).symm
#align hyperreal.gt_of_neg_of_infinitesimal Hyperreal.gt_of_neg_of_infinitesimal

theorem abs_lt_real_iff_infinitesimal {x : ℝ*} : Infinitesimal x ↔ ∀ r : ℝ, r ≠ 0 → |x| < |r| :=
  ⟨fun hi r hr =>
    abs_lt.mpr (by rw [← coe_abs] <;> exact infinitesimal_def.mp hi (|r|) (abs_pos.2 hr)), fun hR =>
    infinitesimal_def.mpr fun r hr =>
      abs_lt.mp <| (abs_of_pos <| coe_pos.2 hr) ▸ hR r <| ne_of_gt hr⟩
#align hyperreal.abs_lt_real_iff_infinitesimal Hyperreal.abs_lt_real_iff_infinitesimal

theorem infinitesimal_zero : Infinitesimal 0 :=
  isSt_refl_real 0
#align hyperreal.infinitesimal_zero Hyperreal.infinitesimal_zero

theorem zero_of_infinitesimal_real {r : ℝ} : Infinitesimal r → r = 0 :=
  eq_of_isSt_real
#align hyperreal.zero_of_infinitesimal_real Hyperreal.zero_of_infinitesimal_real

theorem zero_iff_infinitesimal_real {r : ℝ} : Infinitesimal r ↔ r = 0 :=
  ⟨zero_of_infinitesimal_real, fun hr => by rw [hr] <;> exact infinitesimal_zero⟩
#align hyperreal.zero_iff_infinitesimal_real Hyperreal.zero_iff_infinitesimal_real

theorem infinitesimal_add {x y : ℝ*} (hx : Infinitesimal x) (hy : Infinitesimal y) :
    Infinitesimal (x + y) := by simpa only [add_zero] using is_st_add hx hy
#align hyperreal.infinitesimal_add Hyperreal.infinitesimal_add

theorem infinitesimal_neg {x : ℝ*} (hx : Infinitesimal x) : Infinitesimal (-x) := by
  simpa only [neg_zero] using is_st_neg hx
#align hyperreal.infinitesimal_neg Hyperreal.infinitesimal_neg

theorem infinitesimal_neg_iff {x : ℝ*} : Infinitesimal x ↔ Infinitesimal (-x) :=
  ⟨infinitesimal_neg, fun h => neg_neg x ▸ @infinitesimal_neg (-x) h⟩
#align hyperreal.infinitesimal_neg_iff Hyperreal.infinitesimal_neg_iff

theorem infinitesimal_mul {x y : ℝ*} (hx : Infinitesimal x) (hy : Infinitesimal y) :
    Infinitesimal (x * y) := by simpa only [MulZeroClass.mul_zero] using is_st_mul hx hy
#align hyperreal.infinitesimal_mul Hyperreal.infinitesimal_mul

theorem infinitesimal_of_tendsto_zero {f : ℕ → ℝ} :
    Tendsto f atTop (𝓝 0) → Infinitesimal (ofSeq f) := fun 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⟩
#align hyperreal.infinitesimal_of_tendsto_zero Hyperreal.infinitesimal_of_tendsto_zero

theorem infinitesimal_epsilon : Infinitesimal ε :=
  infinitesimal_of_tendsto_zero tendsto_inverse_atTop_nhds_0_nat
#align hyperreal.infinitesimal_epsilon Hyperreal.infinitesimal_epsilon

theorem not_real_of_infinitesimal_ne_zero (x : ℝ*) : Infinitesimal x → x ≠ 0 → ∀ r : ℝ, x ≠ r :=
  fun hi hx r hr =>
  hx <| hr.trans <| coe_eq_zero.2 <| isSt_unique (hr.symm ▸ isSt_refl_real r : IsSt x r) hi
#align hyperreal.not_real_of_infinitesimal_ne_zero Hyperreal.not_real_of_infinitesimal_ne_zero

theorem infinitesimal_sub_isSt {x : ℝ*} {r : ℝ} (hxr : IsSt x r) : Infinitesimal (x - r) :=
  show IsSt (x - r) 0 by
    rw [sub_eq_add_neg, ← add_neg_self r]
    exact is_st_add hxr (is_st_refl_real (-r))
#align hyperreal.infinitesimal_sub_is_st Hyperreal.infinitesimal_sub_isSt

theorem infinitesimal_sub_st {x : ℝ*} (hx : ¬Infinite x) : Infinitesimal (x - st x) :=
  infinitesimal_sub_isSt <| isSt_st' hx
#align hyperreal.infinitesimal_sub_st Hyperreal.infinitesimal_sub_st

theorem infinitePos_iff_infinitesimal_inv_pos {x : ℝ*} :
    InfinitePos x ↔ Infinitesimal x⁻¹ ∧ 0 < x⁻¹ :=
  ⟨fun hip =>
    ⟨infinitesimal_def.mpr fun 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⟩,
    fun ⟨hi, hp⟩ r =>
    @by_cases (r = 0) (↑r < x) (fun h => Eq.substr h (inv_pos.mp hp)) fun h =>
      lt_of_le_of_lt (coe_le_coe.2 (le_abs_self r))
        ((inv_lt_inv (inv_pos.mp hp) (coe_lt_coe.2 (abs_pos.2 h))).mp
          ((infinitesimal_def.mp hi) (|r|)⁻¹ (inv_pos.2 (abs_pos.2 h))).2)⟩
#align hyperreal.infinite_pos_iff_infinitesimal_inv_pos Hyperreal.infinitePos_iff_infinitesimal_inv_pos

theorem infiniteNeg_iff_infinitesimal_inv_neg {x : ℝ*} :
    InfiniteNeg x ↔ Infinitesimal x⁻¹ ∧ x⁻¹ < 0 :=
  ⟨fun hin =>
    by
    have hin' := infinitePos_iff_infinitesimal_inv_pos.mp (infinitePos_neg_of_infiniteNeg hin)
    rwa [infinitesimal_neg_iff, ← neg_pos, neg_inv], fun hin => by
    rwa [← neg_pos, infinitesimal_neg_iff, neg_inv, ← infinite_pos_iff_infinitesimal_inv_pos, ←
      infinite_neg_iff_infinite_pos_neg] at hin⟩
#align hyperreal.infinite_neg_iff_infinitesimal_inv_neg Hyperreal.infiniteNeg_iff_infinitesimal_inv_neg

theorem infinitesimal_inv_of_infinite {x : ℝ*} : Infinite x → Infinitesimal x⁻¹ := fun hi =>
  Or.cases_on hi (fun hip => (infinitePos_iff_infinitesimal_inv_pos.mp hip).1) fun hin =>
    (infiniteNeg_iff_infinitesimal_inv_neg.mp hin).1
#align hyperreal.infinitesimal_inv_of_infinite Hyperreal.infinitesimal_inv_of_infinite

theorem infinite_of_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) (hi : Infinitesimal x⁻¹) : Infinite x :=
  by
  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⟩)
#align hyperreal.infinite_of_infinitesimal_inv Hyperreal.infinite_of_infinitesimal_inv

theorem infinite_iff_infinitesimal_inv {x : ℝ*} (h0 : x ≠ 0) : Infinite x ↔ Infinitesimal x⁻¹ :=
  ⟨infinitesimal_inv_of_infinite, infinite_of_infinitesimal_inv h0⟩
#align hyperreal.infinite_iff_infinitesimal_inv Hyperreal.infinite_iff_infinitesimal_inv

theorem infinitesimal_pos_iff_infinitePos_inv {x : ℝ*} :
    InfinitePos x⁻¹ ↔ Infinitesimal x ∧ 0 < x := by
  convert infinite_pos_iff_infinitesimal_inv_pos <;> simp only [inv_inv]
#align hyperreal.infinitesimal_pos_iff_infinite_pos_inv Hyperreal.infinitesimal_pos_iff_infinitePos_inv

theorem infinitesimal_neg_iff_infiniteNeg_inv {x : ℝ*} :
    InfiniteNeg x⁻¹ ↔ Infinitesimal x ∧ x < 0 := by
  convert infinite_neg_iff_infinitesimal_inv_neg <;> simp only [inv_inv]
#align hyperreal.infinitesimal_neg_iff_infinite_neg_inv Hyperreal.infinitesimal_neg_iff_infiniteNeg_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]
#align hyperreal.infinitesimal_iff_infinite_inv Hyperreal.infinitesimal_iff_infinite_inv

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

theorem isSt_of_tendsto {f : ℕ → ℝ} {r : ℝ} (hf : Tendsto f atTop (𝓝 r)) : IsSt (ofSeq f) r :=
  by
  have hg : Tendsto (fun n => f n - r) atTop (𝓝 0) := sub_self r ▸ hf.sub tendsto_const_nhds
  rw [← zero_add r, ← sub_add_cancel f fun n => r] <;>
    exact is_st_add (infinitesimal_of_tendsto_zero hg) (is_st_refl_real r)
#align hyperreal.is_st_of_tendsto Hyperreal.isSt_of_tendsto

theorem isSt_inv {x : ℝ*} {r : ℝ} (hi : ¬Infinitesimal x) : IsSt x r → IsSt x⁻¹ r⁻¹ := fun hxr =>
  have h : x ≠ 0 := fun 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 fun s hs =>
    have H' : IsSt 1 (r * s) := mul_inv_cancel h ▸ isSt_mul hxr hs
    have H'' : s = r⁻¹ := one_div r ▸ eq_one_div_of_mul_eq_one_right (eq_of_isSt_real H').symm
    H'' ▸ hs
#align hyperreal.is_st_inv Hyperreal.isSt_inv

theorem st_inv (x : ℝ*) : st x⁻¹ = (st x)⁻¹ :=
  by
  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))
#align hyperreal.st_inv Hyperreal.st_inv

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

theorem infinitePos_omega : InfinitePos ω :=
  infinitePos_iff_infinitesimal_inv_pos.mpr ⟨infinitesimal_epsilon, epsilon_pos⟩
#align hyperreal.infinite_pos_omega Hyperreal.infinitePos_omega

theorem infinite_omega : Infinite ω :=
  (infinite_iff_infinitesimal_inv omega_ne_zero).mpr infinitesimal_epsilon
#align hyperreal.infinite_omega Hyperreal.infinite_omega

theorem infinitePos_mul_of_infinitePos_not_infinitesimal_pos {x y : ℝ*} :
    InfinitePos x → ¬Infinitesimal y → 0 < y → InfinitePos (x * y) := fun hx hy₁ hy₂ r =>
  have hy₁' := not_forall.mp (by rw [infinitesimal_def] at hy₁ <;> exact hy₁)
  Exists.dcases_on hy₁' fun r₁ hy₁'' =>
    by
    have hyr := by rw [not_imp, ← abs_lt, not_lt, abs_of_pos hy₂] at hy₁'' <;> exact hy₁''
    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))
#align hyperreal.infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos Hyperreal.infinitePos_mul_of_infinitePos_not_infinitesimal_pos

theorem infinitePos_mul_of_not_infinitesimal_pos_infinitePos {x y : ℝ*} :
    ¬Infinitesimal x → 0 < x → InfinitePos y → InfinitePos (x * y) := fun hx hp hy => by
  rw [mul_comm] <;> exact infinite_pos_mul_of_infinite_pos_not_infinitesimal_pos hy hx hp
#align hyperreal.infinite_pos_mul_of_not_infinitesimal_pos_infinite_pos Hyperreal.infinitePos_mul_of_not_infinitesimal_pos_infinitePos

theorem infinitePos_mul_of_infiniteNeg_not_infinitesimal_neg {x y : ℝ*} :
    InfiniteNeg x → ¬Infinitesimal y → y < 0 → InfinitePos (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
#align hyperreal.infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg Hyperreal.infinitePos_mul_of_infiniteNeg_not_infinitesimal_neg

theorem infinitePos_mul_of_not_infinitesimal_neg_infiniteNeg {x y : ℝ*} :
    ¬Infinitesimal x → x < 0 → InfiniteNeg y → InfinitePos (x * y) := fun hx hp hy => by
  rw [mul_comm] <;> exact infinite_pos_mul_of_infinite_neg_not_infinitesimal_neg hy hx hp
#align hyperreal.infinite_pos_mul_of_not_infinitesimal_neg_infinite_neg Hyperreal.infinitePos_mul_of_not_infinitesimal_neg_infiniteNeg

theorem infiniteNeg_mul_of_infinitePos_not_infinitesimal_neg {x y : ℝ*} :
    InfinitePos x → ¬Infinitesimal y → y < 0 → InfiniteNeg (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
#align hyperreal.infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg Hyperreal.infiniteNeg_mul_of_infinitePos_not_infinitesimal_neg

theorem infiniteNeg_mul_of_not_infinitesimal_neg_infinitePos {x y : ℝ*} :
    ¬Infinitesimal x → x < 0 → InfinitePos y → InfiniteNeg (x * y) := fun hx hp hy => by
  rw [mul_comm] <;> exact infinite_neg_mul_of_infinite_pos_not_infinitesimal_neg hy hx hp
#align hyperreal.infinite_neg_mul_of_not_infinitesimal_neg_infinite_pos Hyperreal.infiniteNeg_mul_of_not_infinitesimal_neg_infinitePos

theorem infiniteNeg_mul_of_infiniteNeg_not_infinitesimal_pos {x y : ℝ*} :
    InfiniteNeg x → ¬Infinitesimal y → 0 < y → InfiniteNeg (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
#align hyperreal.infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos Hyperreal.infiniteNeg_mul_of_infiniteNeg_not_infinitesimal_pos

theorem infiniteNeg_mul_of_not_infinitesimal_pos_infiniteNeg {x y : ℝ*} :
    ¬Infinitesimal x → 0 < x → InfiniteNeg y → InfiniteNeg (x * y) := fun hx hp hy => by
  rw [mul_comm] <;> exact infinite_neg_mul_of_infinite_neg_not_infinitesimal_pos hy hx hp
#align hyperreal.infinite_neg_mul_of_not_infinitesimal_pos_infinite_neg Hyperreal.infiniteNeg_mul_of_not_infinitesimal_pos_infiniteNeg

theorem infinitePos_mul_infinitePos {x y : ℝ*} :
    InfinitePos x → InfinitePos y → InfinitePos (x * y) := fun hx hy =>
  infinitePos_mul_of_infinitePos_not_infinitesimal_pos hx (not_infinitesimal_of_infinitePos hy)
    (hy 0)
#align hyperreal.infinite_pos_mul_infinite_pos Hyperreal.infinitePos_mul_infinitePos

theorem infiniteNeg_mul_infiniteNeg {x y : ℝ*} :
    InfiniteNeg x → InfiniteNeg y → InfinitePos (x * y) := fun hx hy =>
  infinitePos_mul_of_infiniteNeg_not_infinitesimal_neg hx (not_infinitesimal_of_infiniteNeg hy)
    (hy 0)
#align hyperreal.infinite_neg_mul_infinite_neg Hyperreal.infiniteNeg_mul_infiniteNeg

theorem infinitePos_mul_infiniteNeg {x y : ℝ*} :
    InfinitePos x → InfiniteNeg y → InfiniteNeg (x * y) := fun hx hy =>
  infiniteNeg_mul_of_infinitePos_not_infinitesimal_neg hx (not_infinitesimal_of_infiniteNeg hy)
    (hy 0)
#align hyperreal.infinite_pos_mul_infinite_neg Hyperreal.infinitePos_mul_infiniteNeg

theorem infiniteNeg_mul_infinitePos {x y : ℝ*} :
    InfiniteNeg x → InfinitePos y → InfiniteNeg (x * y) := fun hx hy =>
  infiniteNeg_mul_of_infiniteNeg_not_infinitesimal_pos hx (not_infinitesimal_of_infinitePos hy)
    (hy 0)
#align hyperreal.infinite_neg_mul_infinite_pos Hyperreal.infiniteNeg_mul_infinitePos

theorem infinite_mul_of_infinite_not_infinitesimal {x y : ℝ*} :
    Infinite x → ¬Infinitesimal y → Infinite (x * y) := fun hx hy =>
  have h0 : y < 0 ∨ 0 < y := lt_or_gt_of_ne fun H0 => hy (Eq.substr H0 (isSt_refl_real 0))
  Or.dcases_on hx
    (Or.dcases_on h0
      (fun H0 Hx => Or.inr (infiniteNeg_mul_of_infinitePos_not_infinitesimal_neg Hx hy H0))
      fun H0 Hx => Or.inl (infinitePos_mul_of_infinitePos_not_infinitesimal_pos Hx hy H0))
    (Or.dcases_on h0
      (fun H0 Hx => Or.inl (infinitePos_mul_of_infiniteNeg_not_infinitesimal_neg Hx hy H0))
      fun H0 Hx => Or.inr (infiniteNeg_mul_of_infiniteNeg_not_infinitesimal_pos Hx hy H0))
#align hyperreal.infinite_mul_of_infinite_not_infinitesimal Hyperreal.infinite_mul_of_infinite_not_infinitesimal

theorem infinite_mul_of_not_infinitesimal_infinite {x y : ℝ*} :
    ¬Infinitesimal x → Infinite y → Infinite (x * y) := fun hx hy => by
  rw [mul_comm] <;> exact infinite_mul_of_infinite_not_infinitesimal hy hx
#align hyperreal.infinite_mul_of_not_infinitesimal_infinite Hyperreal.infinite_mul_of_not_infinitesimal_infinite

theorem Infinite.mul {x y : ℝ*} : Infinite x → Infinite y → Infinite (x * y) := fun hx hy =>
  infinite_mul_of_infinite_not_infinitesimal hx (not_infinitesimal_of_infinite hy)
#align hyperreal.infinite.mul Hyperreal.Infinite.mul

end Hyperreal

namespace Tactic

open Positivity

private theorem hyperreal_coe_ne_zero {r : ℝ} : r ≠ 0 → (r : ℝ*) ≠ 0 :=
  Hyperreal.coe_ne_zero.2
#align tactic.hyperreal_coe_ne_zero tactic.hyperreal_coe_ne_zero

private theorem hyperreal_coe_nonneg {r : ℝ} : 0 ≤ r → 0 ≤ (r : ℝ*) :=
  Hyperreal.coe_nonneg.2
#align tactic.hyperreal_coe_nonneg tactic.hyperreal_coe_nonneg

private theorem hyperreal_coe_pos {r : ℝ} : 0 < r → 0 < (r : ℝ*) :=
  Hyperreal.coe_pos.2
#align tactic.hyperreal_coe_pos tactic.hyperreal_coe_pos

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

end Tactic


import .love08_operational_semantics_demo

/- # LoVe Demo 9: Hoare Logic

We review a second way to specify the semantics of a programming language: Hoare
logic. If operational semantics corresponds to an idealized interpreter,
__Hoare logic__ (also called __axiomatic semantics__) corresponds to a verifier.
Hoare logic is particularly convenient to reason about concrete programs. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

-- def stupid : Π (a : ℕ), ℕ :=
--     λ a, a + 1
-- #check stupid

-- theorem t1 : Π (p q : Prop) (hp: p) (hq: q), p :=
-- λ (p q : Prop) (hp : p) (hq : q), hp
-- #check t1
-- #print t1

/- ## First Things First: Formalization Projects

Instead of two of the homework sheets, you can do a verification project, worth
20 points. If you choose to do so, please send your lecturer a message by email
by the end of the week. For a fully successful project, we expect about 200 (or
more) lines of Lean, including definitions and proofs.

Some ideas for projects follow.

Computer science:

* extended WHILE language with static arrays or other features;
* functional data structures (e.g., balanced trees);
* functional algorithms (e.g., bubble sort, merge sort, Tarjan's algorithm);
* compiler from expressions or imperative programs to, e.g., stack machine;
* type systems (e.g., Benjamin Pierce's __Types and Programming Languages__);
* security properties (e.g., Volpano–Smith-style noninterference analysis);
* theory of first-order terms, including matching, term rewriting;
* automata theory;
* normalization of context-free grammars or regular expressions;
* process algebras and bisimilarity;
* soundness and possibly completeness of proof systems (e.g., Genzen's sequent
  calculus, natural deduction, tableaux);
* separation logic;
* verified program using Hoare logic.

Mathematics:

* graphs;
* combinatorics;
* number theory.

Evaluation from 2018–2019:

Q: How did you find the project?

A: Enjoyable.

A: Fun and hard.

A: Good, I think the format was excellent in a way that it gave people the
   chance to do challenging exercises and hand them in incomplete.

A: I really really liked it. I think it's a great way of learning—find
   something you like, dig in it a little, get stuck, ask for help. I wish I
   could do more of that!

A: It was great to have some time to try to work out some stuff you find
   interesting yourself.

A: lots of fun actually!!!

A: Very helpful. It gave the opportunity to spend some more time on a
   particular aspect of the course.

## Hoare Triples

The basic judgments of Hoare logic are often called __Hoare triples__. They have
the form

    `{P} S {Q}`

where `S` is a statement, and `P` and `Q` (called __precondition__ and
__postcondition__) are logical formulas over the state variables.

Intended meaning:

    If `P` holds before `S` is executed and the execution terminates normally,
    `Q` holds at termination.

This is a __partial correctness__ statement: The program is correct if it
terminates normally (i.e., no run-time error, no infinite loop or divergence).

All of these Hoare triples are valid (with respect to the intended meaning):

    `{true} b := 4 {b = 4}`
    `{a = 2} b := 2 * a {a = 2 ∧ b = 4}`
    `{b ≥ 5} b := b + 1 {b ≥ 6}`
    `{false} skip {b = 100}`
    `{true} while i ≠ 100 do i := i + 1 {i = 100}`

## Hoare Rules

The following is a complete set of rules for reasoning about WHILE programs:

    ———————————— Skip
    {P} skip {P}

    ——————————————————— Asn
    {Q[a/x]} x := a {Q}

    {P} S {R}   {R} S' {Q}
    —————————————————————— Seq
    {P} S; S' {Q}

    {P ∧ b} S {Q}   {P ∧ ¬b} S' {Q}
    ——————————————————————————————— If
    {P} if b then S else S' {Q}

    {I ∧ b} S {I}
    ————————————————————————— While
    {I} while b do S {I ∧ ¬b}

    P' → P   {P} S {Q}   Q → Q'
    ——————————————————————————— Conseq
    {P'} S {Q'}

`Q[a/x]` denotes `Q` with `x` replaced by `a`.

In the `While` rule, `I` is called an __invariant__.

Except for `Conseq`, the rules are syntax-driven: by looking at a program, we
see immediately which rule to apply.

Example derivations:

    —————————————————————— Asn   —————————————————————— Asn
    {a = 2} b := a {b = 2}       {b = 2} c := b {c = 2}
    ——————————————————————————————————————————————————— Seq
    {a = 2} b := a; c := b {c = 2}

                     —————————————————————— Asn
    x > 10 → x > 5   {x > 5} y := x {y > 5}   y > 5 → y > 0
    ——————————————————————————————————————————————————————— Conseq
    {x > 10} y := x {y > 0}

Various __derived rules__ can be proved to be correct in terms of the standard
rules. For example, we can derive bidirectional rules for `skip`, `:=`, and
`while`:

    P → Q
    ———————————— Skip'
    {P} skip {Q}

    P → Q[a/x]
    —————————————— Asn'
    {P} x := a {Q}

    {P ∧ b} S {P}   P ∧ ¬b → Q
    —————————————————————————— While'
    {P} while b do S {Q}

## A Semantic Approach to Hoare Logic

We can, and will, define Hoare triples **semantically** in Lean.

We will use predicates on states (`state → Prop`) to represent pre- and
postconditions, following the shallow embedding style. -/

def partial_hoare (P : state → Prop) (S : stmt)
  (Q : state → Prop) : Prop :=
∀s t, P s → (S, s) ⟹ t → Q t

notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` :=
partial_hoare P S Q

namespace partial_hoare

lemma skip_intro {P} :
  {* P *} stmt.skip {* P *} :=
begin
  intros s t hs hst,
  cases hst,
  assumption
end

lemma assign_intro (P : state → Prop) {x} {a : state → ℕ} :
  {* λs, P (s{x ↦ a s}) *} stmt.assign x a {* P *} :=
begin
  intros s t P hst,
  cases hst,
  assumption
end

lemma seq_intro {P Q R S T} (hS : {* P *} S {* Q *})
    (hT : {* Q *} T {* R *}) :
  {* P *} S ;; T {* R *} :=
begin
  intros s t hs hst,
  cases hst,
  apply hT,
  { apply hS,
    { exact hs },
    { assumption } },
  { assumption }
end

lemma ite_intro {b P Q : state → Prop} {S T}
    (hS : {* λs, P s ∧ b s *} S {* Q *})
    (hT : {* λs, P s ∧ ¬ b s *} T {* Q *}) :
  {* P *} stmt.ite b S T {* Q *} :=
begin
  intros s t hs hst,
  cases hst,
  { apply hS,
    exact and.intro hs hst_hcond,
    assumption },
  { apply hT,
    exact and.intro hs hst_hcond,
    assumption }
end

lemma while_intro (P : state → Prop) {b : state → Prop} {S}
    (h : {* λs, P s ∧ b s *} S {* P *}) :
  {* P *} stmt.while b S {* λs, P s ∧ ¬ b s *} :=
begin
  intros s t hs hst,
  induction hst,
  case while_true {
    apply ih_hst_1 P h,
    exact h _ _ (and.intro hs hcond) hst },
  case while_false {
    exact and.intro hs hcond }
end

lemma consequence {P P' Q Q' : state → Prop} {S}
    (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s)
    (hq : ∀s, Q s → Q' s) :
  {* P' *} S {* Q' *} :=
fix s t,
assume hs : P' s,
assume hst : (S, s) ⟹ t,
show Q' t, from
  hq _ (h s t (hp s hs) hst)

lemma consequence_left (P' : state → Prop) {P Q S}
    (h : {* P *} S {* Q *}) (hp : ∀s, P' s → P s) :
  {* P' *} S {* Q *} :=
consequence h hp (by cc)

lemma consequence_right (Q) {Q' : state → Prop} {P S}
    (h : {* P *} S {* Q *}) (hq : ∀s, Q s → Q' s) :
  {* P *} S {* Q' *} :=
consequence h (by cc) hq

lemma skip_intro' {P Q : state → Prop} (h : ∀s, P s → Q s) :
  {* P *} stmt.skip {* Q *} :=
consequence skip_intro h (by cc)

lemma assign_intro' {P Q : state → Prop} {x} {a : state → ℕ}
    (h : ∀s, P s → Q (s{x ↦ a s})):
  {* P *} stmt.assign x a {* Q *} :=
consequence (assign_intro Q) h (by cc)

lemma seq_intro' {P Q R S T} (hT : {* Q *} T {* R *})
    (hS : {* P *} S {* Q *}) :
  {* P *} S ;; T {* R *} :=
seq_intro hS hT

lemma while_intro' {b P Q : state → Prop} {S}
    (I : state → Prop)
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hP : ∀s, P s → I s)
    (hQ : ∀s, ¬ b s → I s → Q s) :
  {* P *} stmt.while b S {* Q *} :=
consequence (while_intro I hS) hP (by finish)

/- `finish` applies a combination of techniques, including normalization of
logical connectives and quantifiers, simplification, congruence closure, and
quantifier instantiation. It either fully succeeds or fails. -/

lemma assign_intro_forward (P) {x a} :
  {* P *}
  stmt.assign x a
  {* λs, ∃n₀, P (s{x ↦ n₀}) ∧ s x = a (s{x ↦ n₀}) *} :=
begin
  apply assign_intro',
  intros s hP,
  apply exists.intro (s x),
  simp [*]
end

lemma assign_intro_backward (Q : state → Prop) {x}
    {a : state → ℕ} :
  {* λs, ∃n', Q (s{x ↦ n'}) ∧ n' = a s *}
  stmt.assign x a
  {* Q *} :=
begin
  apply assign_intro',
  intros s hP,
  cases hP,
  cc
end

end partial_hoare

/- ## First Program: Exchanging Two Variables -/

def SWAP : stmt :=
stmt.assign "t" (λs, s "a") ;;
stmt.assign "a" (λs, s "b") ;;
stmt.assign "b" (λs, s "t")

lemma SWAP_correct (a₀ b₀ : ℕ) :
  {* λs, s "a" = a₀ ∧ s "b" = b₀ *}
  SWAP
  {* λs, s "a" = b₀ ∧ s "b" = a₀ *} :=
begin
  apply partial_hoare.seq_intro',
  apply partial_hoare.seq_intro',
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro,
  apply partial_hoare.assign_intro',
  simp { contextual := tt }
end

lemma SWAP_correct₂ (a₀ b₀ : ℕ) :
  {* λs, s "a" = a₀ ∧ s "b" = b₀ *}
  SWAP
  {* λs, s "a" = b₀ ∧ s "b" = a₀ *} :=
begin
  intros s t hP hstep,
  cases hstep,
  cases hP,
  cases hstep_hS,
  cases hstep_hT,
  finish
end

/- ## Second Program: Adding Two Numbers -/

def ADD : stmt :=
stmt.while (λs, s "n" ≠ 0)
  (stmt.assign "n" (λs, s "n" - 1) ;;
   stmt.assign "m" (λs, s "m" + 1))

lemma ADD_correct (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
  ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
partial_hoare.while_intro' (λs, s "n" + s "m" = n₀ + m₀)
  begin
    apply partial_hoare.seq_intro',
    { apply partial_hoare.assign_intro },
    { apply partial_hoare.assign_intro',
      simp,
      intros s hnm hnz,
      rw ←hnm,
      cases s "n",
      { finish },
      { simp [nat.succ_eq_add_one],
        linarith } }
  end
  (by simp { contextual := true })
  (by simp { contextual := true })

/- ## A Verification Condition Generator

__Verification condition generators__ (VCGs) are programs that apply Hoare rules
automatically, producing __verification conditions__ that must be proved by the
user. The user must usually also provide strong enough loop invariants, as an
annotation in their programs.

We can use Lean's metaprogramming framework to define a simple VCG.

Hundreds if not thousands of program verification tools are based on these
principles. Often these are based on an extension called separation logic.

VCGs typically work backwards from the postcondition, using backward rules
(rules stated to have an arbitrary `Q` as their postcondition). This works well
because `Asn` is backward. -/

def stmt.while_inv (I b : state → Prop) (S : stmt) : stmt :=
stmt.while b S

namespace partial_hoare

lemma while_inv_intro {b I Q : state → Prop} {S}
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hQ : ∀s, ¬ b s → I s → Q s) :
  {* I *} stmt.while_inv I b S {* Q *} :=
while_intro' I hS (by cc) hQ

lemma while_inv_intro' {b I P Q : state → Prop} {S}
    (hS : {* λs, I s ∧ b s *} S {* I *})
    (hP : ∀s, P s → I s) (hQ : ∀s, ¬ b s → I s → Q s) :
  {* P *} stmt.while_inv I b S {* Q *} :=
while_intro' I hS hP hQ

end partial_hoare

meta def vcg : tactic unit :=
do
  t ← tactic.target,
  match t with
  | `({* %%P *} %%S {* _ *}) :=
    match S with
    | `(stmt.skip)            :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.skip_intro
         else ``partial_hoare.skip_intro')
    | `(stmt.assign _ _)      :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.assign_intro
         else ``partial_hoare.assign_intro')
    | `(stmt.seq _ _)         :=
      tactic.applyc ``partial_hoare.seq_intro'; vcg
    | `(stmt.ite _ _ _)       :=
      tactic.applyc ``partial_hoare.ite_intro; vcg
    | `(stmt.while_inv _ _ _) :=
      tactic.applyc
        (if expr.is_mvar P then ``partial_hoare.while_inv_intro
         else ``partial_hoare.while_inv_intro');
        vcg
    | _                       :=
      tactic.fail (to_fmt "cannot analyze " ++ to_fmt S)
    end
  | _                        := pure ()
  end

end LoVe

/- Register `vcg` as a proper tactic: -/

meta def tactic.interactive.vcg : tactic unit :=
LoVe.vcg

namespace LoVe

/- ## Second Program Revisited: Adding Two Numbers -/

lemma ADD_correct₂ (n₀ m₀ : ℕ) :
  {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
  ADD
  {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *} :=
show {* λs, s "n" = n₀ ∧ s "m" = m₀ *}
     stmt.while_inv (λs, s "n" + s "m" = n₀ + m₀)
       (λs, s "n" ≠ 0)
       (stmt.assign "n" (λs, s "n" - 1) ;;
        stmt.assign "m" (λs, s "m" + 1))
     {* λs, s "n" = 0 ∧ s "m" = n₀ + m₀ *}, from
  begin
    vcg; simp { contextual := tt },
    intros s hnm hnz,
    rw ←hnm,
    cases s "n",
    { finish },
    { simp [nat.succ_eq_add_one],
      linarith }
  end

/- ## Hoare Triples for Total Correctness

__Total correctness__ asserts that the program not only is partially correct but
also that it always terminates normally. Hoare triples for total correctness
have the form

    [P] S [Q]

Intended meaning:

    If `P` holds before `S` is executed, the execution terminates normally and
    `Q` holds in the final state.

For deterministic programs, an equivalent formulation is as follows:

    If `P` holds before `S` is executed, there exists a state in which execution
    terminates normally and `Q` holds in that state.

Example:

    `[i ≤ 100] while i ≠ 100 do i := i + 1 [i = 100]`

In our WHILE language, this only affects while loops, which must now be
annotated by a __variant__ `V` (a natural number that decreases with each
iteration):

    [I ∧ b ∧ V = v₀] S [I ∧ V < v₀]
    ——————————————————————————————— While-Var
    [I] while b do S [I ∧ ¬b]

What is a suitable variant for the example above? -/

end LoVe


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Simon Hudon, Thomas Murrills
-/
import Lean
import Mathlib.Tactic.Have
import Mathlib.Tactic.SolveByElim
import Mathlib.Data.List.TFAE
import Qq

/-!
# The Following Are Equivalent (TFAE)

This file provides the tactics `tfae_have` and `tfae_finish` for proving goals of the form
`TFAE [P₁, P₂, ...]`.
-/

open List Lean Meta Expr Elab.Term Elab.Tactic Mathlib.Tactic Qq

namespace Mathlib.Tactic.TFAE

/-- An arrow of the form `←`, `→`, or `↔`. -/
syntax impArrow := " → " <|> " ↔ " <|> " ← "

/--
`tfae_have` introduces hypotheses for proving goals of the form `TFAE [P₁, P₂, ...]`. Specifically,
`tfae_have i arrow j` introduces a hypothesis of type `Pᵢ arrow Pⱼ` to the local context,
where `arrow` can be `→`, `←`, or `↔`. Note that `i` and `j` are natural number indices (beginning
at 1) used to specify the propositions `P₁, P₂, ...` that appear in the `TFAE` goal list. A proof
is required afterward, typically via a tactic block.

```lean
example (h : P → R) : TFAE [P, Q, R] := by
  tfae_have 1 → 3
  { exact h }
  ...
```
The resulting context now includes `tfae_1_to_3 : P → R`.

The introduced hypothesis can be given a custom name, in analogy to `have` syntax:
```lean
tfae_have h : 2 ↔ 3
```

Once sufficient hypotheses have been introduced by `tfae_have`, `tfae_finish` can be used to close
the goal.

```lean
example : TFAE [P, Q, R] := by
  tfae_have 1 → 2
  { /- proof of P → Q -/ }
  tfae_have 2 → 1
  { /- proof of Q → P -/ }
  tfae_have 2 ↔ 3
  { /- proof of Q ↔ R -/ }
  tfae_finish
```
-/
syntax (name := tfaeHave) "tfae_have " (ident " : ")? num impArrow num : tactic

/--
`tfae_finish` is used to close goals of the form `TFAE [P₁, P₂, ...]` once a sufficient collection
of hypotheses of the form `Pᵢ → Pⱼ` or `Pᵢ ↔ Pⱼ` have been introduced to the local context.

`tfae_have` can be used to conveniently introduce these hypotheses; see `tfae_have`.

Example:
```lean
example : TFAE [P, Q, R] := by
  tfae_have 1 → 2
  { /- proof of P → Q -/ }
  tfae_have 2 → 1
  { /- proof of Q → P -/ }
  tfae_have 2 ↔ 3
  { /- proof of Q ↔ R -/ }
  tfae_finish
```
-/
syntax (name := tfaeFinish) "tfae_finish" : tactic

/-! # Setup -/

/-- Extract a list of `Prop` expressions from an expression of the form `TFAE [P₁, P₂, ...]` as
long as `[P₁, P₂, ...]` is an explicit list. -/
partial def getTFAEList (t : Expr) : MetaM (List Q(Prop)) := do
  let .app tfae (l : Q(List Prop)) ← whnfR t |
    throwError "goal must be of the form TFAE [P₁, P₂, ...]"
  unless (← withNewMCtxDepth <| isDefEq tfae q(TFAE)) do
    throwError "goal must be of the form TFAE [P₁, P₂, ...]"
  let rec getExplicitList (l : Expr) : MetaM (List Expr) := do
    have l : Q(List Prop) := l
    match l with
    | ~q([]) => return ([] : List Expr)
    | ~q($a :: $l') => return (q($a) :: (← getExplicitList l'))
    | e => throwError "{e} must be an explicit list of propositions"
  getExplicitList l

/-- Convert an expression representing an explicit list into a list of expressions. -/
add_decl_doc getTFAEList.getExplicitList

/-- Extract the expression `[P₁, P₂, ...]` from an expression of the form `TFAE [P₁, P₂, ...]` as
long as `[P₁, P₂, ...]` is an explicit list. -/
partial def getTFAEListQ (t : Expr) : MetaM Q(List Prop) := do
  let .app tfae (l : Q(List Prop)) ← whnfR t |
    throwError "goal must be of the form TFAE [P₁, P₂, ...]"
  unless (← withNewMCtxDepth <| isDefEq tfae q(TFAE)) do
    throwError "goal must be of the form TFAE [P₁, P₂, ...]"
  let rec guardExplicitList (l : Q(List Prop)) : MetaM Unit := do
    match l with
    | ~q([]) => return ()
    | ~q(_ :: $l') => guardExplicitList l'
    | e => throwError "{e} must be an explicit list of propositions"
  guardExplicitList l
  return l

/-- Check that an expression representing a list is explicit. -/
add_decl_doc getTFAEListQ.guardExplicitList

/-! # Proof construction -/

/-- Prove an implication via solve_by_elim. -/
def proveImpl (P P' : Q(Prop)) : TacticM Q($P → $P') := do
  let t ← mkFreshExprMVar q($P → $P')
  try
    let [] ← run t.mvarId! <| evalTactic (← `(tactic| intro; solve_by_elim [Iff.mp, Iff.mpr])) |
      failure
  catch _ =>
    throwError "couldn't prove {P} → {P'}"
  instantiateMVars t

/-- Generate a proof of `Chain (· → ·) P l`. We assume `P : Prop` and `l : List Prop`, and that `l`
is an explicit list. -/
partial def proveChain (P : Q(Prop)) (l : Q(List Prop)) :
    TacticM Q(Chain (· → ·) $P $l) := do
  match l with
  | ~q([]) => return q(Chain.nil)
  | ~q($P' :: $l') =>
    have cl' : Q(Chain (· → ·) $P' $l') := ← proveChain q($P') q($l')
    let p ← proveImpl P P'
    return q(Chain.cons $p $cl')

/-- Attempt to prove `ilast' P' l → P` given an explicit list `l`. -/
partial def proveILast'Impl (P P' : Q(Prop)) (l : Q(List Prop)) :
    TacticM Q(ilast' $P' $l → $P) := do
  match l with
  | ~q([]) => proveImpl P' P
  | ~q($P'' :: $l') => proveILast'Impl P P'' l'

/-- Attempt to prove a statement of the form `TFAE [P₁, P₂, ...]`. -/
def proveTFAE (l : Q(List Prop)) : TacticM Q(TFAE $l) := do
  match l with
  | ~q([]) => return q(tfae_nil)
  | ~q([$P]) => return q(tfae_singleton $P)
  | ~q($P :: $P' :: $l') =>
    let c ← proveChain P q($P' :: $l')
    let il ← proveILast'Impl P P' l'
    return q(tfae_of_cycle $c $il)

/-! # `tfae_have` components -/

/-- Construct a name for a hypothesis introduced by `tfae_have`. -/
def mkTFAEHypName (i j : TSyntax `num) (arr : TSyntax ``impArrow) : TermElabM Name := do
  let arr ← match arr with
  | `(impArrow| ← ) => pure "from"
  | `(impArrow| → ) => pure "to"
  | `(impArrow| ↔ ) => pure "iff"
  | _ => throwErrorAt arr "expected '←', '→', or '↔'"
  return String.intercalate "_" ["tfae", s!"{i.getNat}", arr, s!"{j.getNat}"]

open Elab in
/-- The core of `tfae_have`, which behaves like `haveLetCore` in `Mathlib.Tactic.Have`. -/
def tfaeHaveCore (goal : MVarId) (name : Option (TSyntax `ident)) (i j : TSyntax `num)
    (arrow : TSyntax ``impArrow) (t : Expr) : TermElabM (MVarId × MVarId) :=
  goal.withContext do
    let n := (Syntax.getId <$> name).getD <|← mkTFAEHypName i j arrow
    let (goal1, t, p) ← do
      let p ← mkFreshExprMVar t MetavarKind.syntheticOpaque n
      pure (p.mvarId!, t, p)
    let (fv, goal2) ← (← MVarId.assert goal n t p).intro1P
    if let some stx := name then
      goal2.withContext do
        Term.addTermInfo' (isBinder := true) stx (mkFVar fv)
    pure (goal1, goal2)

/-- Turn syntax for a given index into a natural number, as long as it lies between `1` and
`maxIndex`. -/
def elabIndex (i : TSyntax `num) (maxIndex : ℕ) : TacticM ℕ := do
  let i' := i.getNat
  unless Nat.ble 1 i' && Nat.ble i' maxIndex do
    throwError "{i} must be between 1 and {maxIndex}"
  return i'

/-- Construct an expression for the type `Pj → Pi`, `Pi → Pj`, or `Pi ↔ Pj` given expressions
`Pi Pj : Q(Prop)` and `impArrow` syntax `arr`, depending on whether `arr` is `←`, `→`, or `↔`
respectively. -/
def mkImplType (Pi : Q(Prop)) (arr : TSyntax ``impArrow) (Pj : Q(Prop)) : TacticM Q(Prop) := do
  match arr with
  | `(impArrow| ← ) => pure q($Pj → $Pi)
  | `(impArrow| → ) => pure q($Pi → $Pj)
  | `(impArrow| ↔ ) => pure q($Pi ↔ $Pj)
  | _ => throwErrorAt arr "expected '←', '→', or '↔'"

/-! # Tactic implementation -/

elab_rules : tactic
| `(tactic| tfae_have $[$h:ident : ]? $i:num $arr:impArrow $j:num) => do
  let goal ← getMainGoal
  let tfaeList ← getTFAEList (← goal.getType)
  let l₀ := tfaeList.length
  let i' ← elabIndex i l₀
  let j' ← elabIndex j l₀
  let Pi := tfaeList.get! (i'-1)
  let Pj := tfaeList.get! (j'-1)
  let type ← mkImplType Pi arr Pj
  let (goal1, goal2) ← tfaeHaveCore goal h i j arr type
  replaceMainGoal [goal1, goal2]

elab_rules : tactic
| `(tactic| tfae_finish) => do
  let goal ← getMainGoal
  let tfaeListQ ← getTFAEListQ (← goal.getType)
  goal.withContext do
    closeMainGoal (← proveTFAE tfaeListQ)


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group.inj_surj
import algebra.group.commute
import algebra.opposites
import data.equiv.mul_add

/-!
# Group structures on the multiplicative and additive opposites
-/
universes u v
variables (α : Type u)

namespace mul_opposite

/-!
### Additive structures on `αᵐᵒᵖ`
-/

instance [add_semigroup α] : add_semigroup (αᵐᵒᵖ) :=
unop_injective.add_semigroup _ (λ x y, rfl)

instance [add_left_cancel_semigroup α] : add_left_cancel_semigroup αᵐᵒᵖ :=
unop_injective.add_left_cancel_semigroup _ (λ x y, rfl)

instance [add_right_cancel_semigroup α] : add_right_cancel_semigroup αᵐᵒᵖ :=
unop_injective.add_right_cancel_semigroup _ (λ x y, rfl)

instance [add_comm_semigroup α] : add_comm_semigroup αᵐᵒᵖ :=
{ add_comm := λ x y, unop_injective $ add_comm (unop x) (unop y),
  .. mul_opposite.add_semigroup α }

instance [add_zero_class α] : add_zero_class αᵐᵒᵖ :=
unop_injective.add_zero_class _ rfl (λ x y, rfl)

instance [add_monoid α] : add_monoid αᵐᵒᵖ :=
unop_injective.add_monoid_smul _ rfl (λ _ _, rfl) (λ _ _, rfl)

instance [add_comm_monoid α] : add_comm_monoid αᵐᵒᵖ :=
{ .. mul_opposite.add_monoid α, .. mul_opposite.add_comm_semigroup α }

instance [sub_neg_monoid α] : sub_neg_monoid αᵐᵒᵖ :=
unop_injective.sub_neg_monoid_smul _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance [add_group α] : add_group αᵐᵒᵖ :=
unop_injective.add_group_smul _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance [add_comm_group α] : add_comm_group αᵐᵒᵖ :=
{ .. mul_opposite.add_group α, .. mul_opposite.add_comm_monoid α }

/-!
### Multiplicative structures on `αᵐᵒᵖ`

We also generate additive structures on `αᵃᵒᵖ` using `to_additive`
-/

@[to_additive] instance [semigroup α] : semigroup αᵐᵒᵖ :=
{ mul_assoc := λ x y z, unop_injective $ eq.symm $ mul_assoc (unop z) (unop y) (unop x),
  .. mul_opposite.has_mul α }

@[to_additive] instance [right_cancel_semigroup α] : left_cancel_semigroup αᵐᵒᵖ :=
{ mul_left_cancel := λ x y z H, unop_injective $ mul_right_cancel $ op_injective H,
  .. mul_opposite.semigroup α }

@[to_additive] instance [left_cancel_semigroup α] : right_cancel_semigroup αᵐᵒᵖ :=
{ mul_right_cancel := λ x y z H, unop_injective $ mul_left_cancel $ op_injective H,
  .. mul_opposite.semigroup α }

@[to_additive] instance [comm_semigroup α] : comm_semigroup αᵐᵒᵖ :=
{ mul_comm := λ x y, unop_injective $ mul_comm (unop y) (unop x),
  .. mul_opposite.semigroup α }

@[to_additive] instance [mul_one_class α] : mul_one_class αᵐᵒᵖ :=
{ one_mul := λ x, unop_injective $ mul_one $ unop x,
  mul_one := λ x, unop_injective $ one_mul $ unop x,
  .. mul_opposite.has_mul α, .. mul_opposite.has_one α }

@[to_additive] instance [monoid α] : monoid αᵐᵒᵖ :=
{ npow := λ n x, op $ x.unop ^ n,
  npow_zero' := λ x, unop_injective $ monoid.npow_zero' x.unop,
  npow_succ' := λ n x, unop_injective $ pow_succ' x.unop n,
  .. mul_opposite.semigroup α, .. mul_opposite.mul_one_class α }

@[to_additive] instance [right_cancel_monoid α] : left_cancel_monoid αᵐᵒᵖ :=
{ .. mul_opposite.left_cancel_semigroup α, .. mul_opposite.monoid α }

@[to_additive] instance [left_cancel_monoid α] : right_cancel_monoid αᵐᵒᵖ :=
{ .. mul_opposite.right_cancel_semigroup α, .. mul_opposite.monoid α }

@[to_additive] instance [cancel_monoid α] : cancel_monoid αᵐᵒᵖ :=
{ .. mul_opposite.right_cancel_monoid α, .. mul_opposite.left_cancel_monoid α }

@[to_additive] instance [comm_monoid α] : comm_monoid αᵐᵒᵖ :=
{ .. mul_opposite.monoid α, .. mul_opposite.comm_semigroup α }

@[to_additive] instance [cancel_comm_monoid α] : cancel_comm_monoid αᵐᵒᵖ :=
{ .. mul_opposite.cancel_monoid α, .. mul_opposite.comm_monoid α }

@[to_additive] instance [div_inv_monoid α] : div_inv_monoid αᵐᵒᵖ :=
{ zpow := λ n x, op $ x.unop ^ n,
  zpow_zero' := λ x, unop_injective $ div_inv_monoid.zpow_zero' x.unop,
  zpow_succ' := λ n x, unop_injective $
    by rw [unop_op, zpow_of_nat, zpow_of_nat, pow_succ', unop_mul, unop_op],
  zpow_neg' := λ z x, unop_injective $ div_inv_monoid.zpow_neg' z x.unop,
  .. mul_opposite.monoid α, .. mul_opposite.has_inv α }

@[to_additive] instance [group α] : group αᵐᵒᵖ :=
{ mul_left_inv := λ x, unop_injective $ mul_inv_self $ unop x,
  .. mul_opposite.div_inv_monoid α, }

@[to_additive] instance [comm_group α] : comm_group αᵐᵒᵖ :=
{ .. mul_opposite.group α, .. mul_opposite.comm_monoid α }

variable {α}

@[simp, to_additive] lemma semiconj_by_op [has_mul α] {a x y : α} :
  semiconj_by (op a) (op y) (op x) ↔ semiconj_by a x y :=
by simp only [semiconj_by, ← op_mul, op_inj, eq_comm]

@[simp, to_additive] lemma semiconj_by_unop [has_mul α] {a x y : αᵐᵒᵖ} :
  semiconj_by (unop a) (unop y) (unop x) ↔ semiconj_by a x y :=
by conv_rhs { rw [← op_unop a, ← op_unop x, ← op_unop y, semiconj_by_op] }

@[to_additive] lemma _root_.semiconj_by.op [has_mul α] {a x y : α} (h : semiconj_by a x y) :
  semiconj_by (op a) (op y) (op x) :=
semiconj_by_op.2 h

@[to_additive] lemma _root_.semiconj_by.unop [has_mul α] {a x y : αᵐᵒᵖ} (h : semiconj_by a x y) :
  semiconj_by (unop a) (unop y) (unop x) :=
semiconj_by_unop.2 h

@[to_additive] lemma _root_.commute.op [has_mul α] {x y : α} (h : commute x y) :
  commute (op x) (op y) := h.op

@[to_additive] lemma commute.unop [has_mul α] {x y : αᵐᵒᵖ} (h : commute x y) :
  commute (unop x) (unop y) := h.unop

@[simp, to_additive] lemma commute_op [has_mul α] {x y : α} :
  commute (op x) (op y) ↔ commute x y :=
semiconj_by_op

@[simp, to_additive] lemma commute_unop [has_mul α] {x y : αᵐᵒᵖ} :
  commute (unop x) (unop y) ↔ commute x y :=
semiconj_by_unop

/-- The function `mul_opposite.op` is an additive equivalence. -/
@[simps { fully_applied := ff, simp_rhs := tt }]
def op_add_equiv [has_add α] : α ≃+ αᵐᵒᵖ :=
{ map_add' := λ a b, rfl, .. op_equiv }

@[simp] lemma op_add_equiv_to_equiv [has_add α] :
  (op_add_equiv : α ≃+ αᵐᵒᵖ).to_equiv = op_equiv :=
rfl

end mul_opposite

/-!
### Multiplicative structures on `αᵃᵒᵖ`
-/

namespace add_opposite

instance [semigroup α] : semigroup (αᵃᵒᵖ) :=
unop_injective.semigroup _ (λ x y, rfl)

instance [left_cancel_semigroup α] : left_cancel_semigroup αᵃᵒᵖ :=
unop_injective.left_cancel_semigroup _ (λ x y, rfl)

instance [right_cancel_semigroup α] : right_cancel_semigroup αᵃᵒᵖ :=
unop_injective.right_cancel_semigroup _ (λ x y, rfl)

instance [comm_semigroup α] : comm_semigroup αᵃᵒᵖ :=
{ mul_comm := λ x y, unop_injective $ mul_comm (unop x) (unop y),
  .. add_opposite.semigroup α }

instance [mul_one_class α] : mul_one_class αᵃᵒᵖ :=
unop_injective.mul_one_class _ rfl (λ x y, rfl)

instance {β} [has_pow α β] : has_pow αᵃᵒᵖ β := { pow := λ a b, op (unop a ^ b) }

@[simp] lemma op_pow {β} [has_pow α β] (a : α) (b : β) : op (a ^ b) = op a ^ b := rfl
@[simp] lemma unop_pow {β} [has_pow α β] (a : αᵃᵒᵖ) (b : β) : unop (a ^ b) = unop a ^ b := rfl

instance [monoid α] : monoid αᵃᵒᵖ :=
unop_injective.monoid_pow _ rfl (λ _ _, rfl) (λ _ _, rfl)

instance [comm_monoid α] : comm_monoid αᵃᵒᵖ :=
{ .. add_opposite.monoid α, .. add_opposite.comm_semigroup α }

instance [div_inv_monoid α] : div_inv_monoid αᵃᵒᵖ :=
unop_injective.div_inv_monoid_pow _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance [group α] : group αᵃᵒᵖ :=
unop_injective.group_pow _ rfl (λ _ _, rfl) (λ _, rfl)
  (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance [comm_group α] : comm_group αᵃᵒᵖ :=
{ .. add_opposite.group α, .. add_opposite.comm_monoid α }

variable {α}

/-- The function `add_opposite.op` is a multiplicative equivalence. -/
@[simps { fully_applied := ff, simp_rhs := tt }]
def op_mul_equiv [has_mul α] : α ≃* αᵃᵒᵖ :=
{ map_mul' := λ a b, rfl, .. op_equiv }

@[simp] lemma op_mul_equiv_to_equiv [has_mul α] :
  (op_mul_equiv : α ≃* αᵃᵒᵖ).to_equiv = op_equiv :=
rfl

end add_opposite

open mul_opposite

/-- Inversion on a group is a `mul_equiv` to the opposite group. When `G` is commutative, there is
`mul_equiv.inv`. -/
@[to_additive "Negation on an additive group is an `add_equiv` to the opposite group. When `G`
is commutative, there is `add_equiv.inv`.", simps { fully_applied := ff, simp_rhs := tt }]
def mul_equiv.inv' (G : Type*) [group G] : G ≃* Gᵐᵒᵖ :=
{ map_mul' := λ x y, unop_injective $ mul_inv_rev x y,
  .. (equiv.inv G).trans op_equiv }

/-- A monoid homomorphism `f : M →* N` such that `f x` commutes with `f y` for all `x, y` defines
a monoid homomorphism to `Nᵐᵒᵖ`. -/
@[to_additive "An additive monoid homomorphism `f : M →+ N` such that `f x` additively commutes
with `f y` for all `x, y` defines an additive monoid homomorphism to `Sᵃᵒᵖ`.",
  simps {fully_applied := ff}]
def monoid_hom.to_opposite {M N : Type*} [mul_one_class M] [mul_one_class N] (f : M →* N)
  (hf : ∀ x y, commute (f x) (f y)) : M →* Nᵐᵒᵖ :=
{ to_fun := mul_opposite.op ∘ f,
  map_one' := congr_arg op f.map_one,
  map_mul' := λ x y, by simp [(hf x y).eq] }

/-- A monoid homomorphism `f : M →* N` such that `f x` commutes with `f y` for all `x, y` defines
a monoid homomorphism from `Mᵐᵒᵖ`. -/
@[to_additive "An additive monoid homomorphism `f : M →+ N` such that `f x` additively commutes
with `f y` for all `x`, `y` defines an additive monoid homomorphism from `Mᵃᵒᵖ`.",
  simps {fully_applied := ff}]
def monoid_hom.from_opposite {M N : Type*} [mul_one_class M] [mul_one_class N] (f : M →* N)
  (hf : ∀ x y, commute (f x) (f y)) : Mᵐᵒᵖ →* N :=
{ to_fun := f ∘ mul_opposite.unop,
  map_one' := f.map_one,
  map_mul' := λ x y, (f.map_mul _ _).trans (hf _ _).eq }

/-- The units of the opposites are equivalent to the opposites of the units. -/
@[to_additive "The additive units of the additive opposites are equivalent to the additive opposites
of the additive units."]
def units.op_equiv {M} [monoid M] : (Mᵐᵒᵖ)ˣ ≃* (Mˣ)ᵐᵒᵖ :=
{ to_fun := λ u, op ⟨unop u, unop ↑(u⁻¹), op_injective u.4, op_injective u.3⟩,
  inv_fun := mul_opposite.rec $ λ u, ⟨op ↑(u), op ↑(u⁻¹), unop_injective $ u.4, unop_injective u.3⟩,
  map_mul' := λ x y, unop_injective $ units.ext $ rfl,
  left_inv := λ x, units.ext $ by simp,
  right_inv := λ x, unop_injective $ units.ext $ rfl }

@[simp, to_additive]
lemma units.coe_unop_op_equiv {M} [monoid M] (u : (Mᵐᵒᵖ)ˣ) :
  ((units.op_equiv u).unop : M) = unop (u : Mᵐᵒᵖ) :=
rfl

@[simp, to_additive]
lemma units.coe_op_equiv_symm {M} [monoid M] (u : (Mˣ)ᵐᵒᵖ) :
  (units.op_equiv.symm u : Mᵐᵒᵖ) = op (u.unop : M) :=
rfl

/-- A monoid homomorphism `M →* N` can equivalently be viewed as a monoid homomorphism
`Mᵐᵒᵖ →* Nᵐᵒᵖ`. This is the action of the (fully faithful) `ᵐᵒᵖ`-functor on morphisms. -/
@[to_additive "An additive monoid homomorphism `M →+ N` can equivalently be viewed as an
additive monoid homomorphism `Mᵃᵒᵖ →+ Nᵃᵒᵖ`. This is the action of the (fully faithful)
`ᵃᵒᵖ`-functor on morphisms.", simps]
def monoid_hom.op {M N} [mul_one_class M] [mul_one_class N] :
  (M →* N) ≃ (Mᵐᵒᵖ →* Nᵐᵒᵖ) :=
{ to_fun    := λ f, { to_fun   := op ∘ f ∘ unop,
                      map_one' := congr_arg op f.map_one,
                      map_mul' := λ x y, unop_injective (f.map_mul y.unop x.unop) },
  inv_fun   := λ f, { to_fun   := unop ∘ f ∘ op,
                      map_one' := congr_arg unop f.map_one,
                      map_mul' := λ x y, congr_arg unop (f.map_mul (op y) (op x)) },
  left_inv  := λ f, by { ext, refl },
  right_inv := λ f, by { ext x, simp } }

/-- The 'unopposite' of a monoid homomorphism `Mᵐᵒᵖ →* Nᵐᵒᵖ`. Inverse to `monoid_hom.op`. -/
@[simp, to_additive "The 'unopposite' of an additive monoid homomorphism `Mᵃᵒᵖ →+ Nᵃᵒᵖ`. Inverse to
`add_monoid_hom.op`."]
def monoid_hom.unop {M N} [mul_one_class M] [mul_one_class N] :
  (Mᵐᵒᵖ →* Nᵐᵒᵖ) ≃ (M →* N) := monoid_hom.op.symm

/-- An additive homomorphism `M →+ N` can equivalently be viewed as an additive homomorphism
`Mᵐᵒᵖ →+ Nᵐᵒᵖ`. This is the action of the (fully faithful) `ᵐᵒᵖ`-functor on morphisms. -/
@[simps]
def add_monoid_hom.mul_op {M N} [add_zero_class M] [add_zero_class N] :
  (M →+ N) ≃ (Mᵐᵒᵖ →+ Nᵐᵒᵖ) :=
{ to_fun    := λ f, { to_fun    := op ∘ f ∘ unop,
                      map_zero' := unop_injective f.map_zero,
                      map_add'  := λ x y, unop_injective (f.map_add x.unop y.unop) },
  inv_fun   := λ f, { to_fun    := unop ∘ f ∘ op,
                      map_zero' := congr_arg unop f.map_zero,
                      map_add'  := λ x y, congr_arg unop (f.map_add (op x) (op y)) },
  left_inv  := λ f, by { ext, refl },
  right_inv := λ f, by { ext, simp } }

/-- The 'unopposite' of an additive monoid hom `αᵐᵒᵖ →+ βᵐᵒᵖ`. Inverse to
`add_monoid_hom.mul_op`. -/
@[simp] def add_monoid_hom.mul_unop {α β} [add_zero_class α] [add_zero_class β] :
  (αᵐᵒᵖ →+ βᵐᵒᵖ) ≃ (α →+ β) := add_monoid_hom.mul_op.symm

/-- A iso `α ≃+ β` can equivalently be viewed as an iso `αᵐᵒᵖ ≃+ βᵐᵒᵖ`. -/
@[simps]
def add_equiv.mul_op {α β} [has_add α] [has_add β] :
  (α ≃+ β) ≃ (αᵐᵒᵖ ≃+ βᵐᵒᵖ) :=
{ to_fun    := λ f, op_add_equiv.symm.trans (f.trans op_add_equiv),
  inv_fun   := λ f, op_add_equiv.trans (f.trans op_add_equiv.symm),
  left_inv  := λ f, by { ext, refl },
  right_inv := λ f, by { ext, simp } }

/-- The 'unopposite' of an iso `αᵐᵒᵖ ≃+ βᵐᵒᵖ`. Inverse to `add_equiv.mul_op`. -/
@[simp] def add_equiv.mul_unop {α β} [has_add α] [has_add β] :
  (αᵐᵒᵖ ≃+ βᵐᵒᵖ) ≃ (α ≃+ β) := add_equiv.mul_op.symm

/-- A iso `α ≃* β` can equivalently be viewed as an iso `αᵐᵒᵖ ≃* βᵐᵒᵖ`. -/
@[to_additive "A iso `α ≃+ β` can equivalently be viewed as an iso `αᵃᵒᵖ ≃+ βᵃᵒᵖ`.", simps]
def mul_equiv.op {α β} [has_mul α] [has_mul β] :
  (α ≃* β) ≃ (αᵐᵒᵖ ≃* βᵐᵒᵖ) :=
{ to_fun    := λ f, { to_fun   := op ∘ f ∘ unop,
                      inv_fun  := op ∘ f.symm ∘ unop,
                      left_inv := λ x, unop_injective (f.symm_apply_apply x.unop),
                      right_inv := λ x, unop_injective (f.apply_symm_apply x.unop),
                      map_mul' := λ x y, unop_injective (f.map_mul y.unop x.unop) },
  inv_fun   := λ f, { to_fun   := unop ∘ f ∘ op,
                      inv_fun  := unop ∘ f.symm ∘ op,
                      left_inv := λ x, by simp,
                      right_inv := λ x, by simp,
                      map_mul' := λ x y, congr_arg unop (f.map_mul (op y) (op x)) },
  left_inv  := λ f, by { ext, refl },
  right_inv := λ f, by { ext, simp } }

/-- The 'unopposite' of an iso `αᵐᵒᵖ ≃* βᵐᵒᵖ`. Inverse to `mul_equiv.op`. -/
@[simp, to_additive "The 'unopposite' of an iso `αᵃᵒᵖ ≃+ βᵃᵒᵖ`. Inverse to `add_equiv.op`."]
def mul_equiv.unop {α β} [has_mul α] [has_mul β] :
  (αᵐᵒᵖ ≃* βᵐᵒᵖ) ≃ (α ≃* β) := mul_equiv.op.symm

section ext

/-- This ext lemma change equalities on `αᵐᵒᵖ →+ β` to equalities on `α →+ β`.
This is useful because there are often ext lemmas for specific `α`s that will apply
to an equality of `α →+ β` such as `finsupp.add_hom_ext'`. -/
@[ext]
lemma add_monoid_hom.mul_op_ext {α β} [add_zero_class α] [add_zero_class β]
  (f g : αᵐᵒᵖ →+ β)
  (h : f.comp (op_add_equiv : α ≃+ αᵐᵒᵖ).to_add_monoid_hom =
       g.comp (op_add_equiv : α ≃+ αᵐᵒᵖ).to_add_monoid_hom) : f = g :=
add_monoid_hom.ext $ mul_opposite.rec $ λ x, (add_monoid_hom.congr_fun h : _) x

end ext


import .lptree_to_tree

universes u

namespace binary_tree

section paths

parameter A : Type
/-- We use lr to denote a direction a path follows from the root-/
inductive lr : Type
| left
| right

/-- A path through a tree is a left or right direction, and the siblings that
    weren't visited-/
@[reducible]
def path := list (lr × A)

parameter {link : Type}
parameter mk_link : lr → A → A → link

def all_paths_core : tree A -> list link -> list (list link)
| (tree.node i l r) path :=
                 all_paths_core r ((mk_link lr.left (root l) (root r)) ::path)
              ++ all_paths_core l ((mk_link lr.right (root l) (root r)) ::path)
| (tree.leaf i) path := [path]

/-- get all paths (in order left to right) from root to leaf
    these paths start with leafs, and are meant to be followed
    up the tree in order to reconstruct a root in log(n) operations
 -/
def all_paths (tr : tree A): list (list link) :=
              all_paths_core tr []

def all_paths' : tree A -> list (list link)
| (tree.leaf i) := [[]]
| (tree.node i l r) :=
     list.map (λ p, p ++ [mk_link lr.left (root l) (root r)]) (all_paths' r)
  ++ list.map (λ p, p ++ [mk_link lr.right (root l) (root r)]) (all_paths' l)

/-- Get all paths, but this time the paths give the direction
    to follow from the root to the leaf. Finally, we also return the
    leaf element that the path leads to.
-/

def all_paths_rev : tree A -> list (list link)
| (tree.leaf i) := [[]]
| (tree.node i l r) :=
     list.map (list.cons (mk_link lr.left (root l) (root r))) (all_paths_rev r)
  ++ list.map (list.cons (mk_link lr.right (root l) (root r))) (all_paths_rev l)

lemma all_paths_rev_height (t : tree A)
  : list.Forall (λ ls : list link, ls.length ≤ t.height) (all_paths_rev t)
:= begin
induction t; dsimp [all_paths_rev, tree.height],
{ constructor, apply le_refl, constructor },
{ apply list.concat_Forall; apply list.map_Forall;
  apply list.impl_Forall; try { assumption },
  { intros x H,
    dsimp [list.length], apply nat.add_le_add_right,
    apply le_trans, assumption, apply le_max_right,
  },
  { intros x H,
    dsimp [list.length], apply nat.add_le_add_right,
    apply le_trans, assumption, apply le_max_left, }
}
end

def all_paths_rev_option : option (tree A) → list (list link)
| none := []
| (some t) := all_paths_rev t

lemma all_paths_core_app (t : tree A) (p p' : list link)
  : all_paths_core t (p ++ p') =
    list.map (λ z, z ++ p') (all_paths_core t p)
:= begin
revert p p',
induction t; intros,
{ reflexivity },
{ dsimp [all_paths_core],
  repeat { rw ← list.cons_append },
  rw [ih_1, ih_2],
  rw list.map_append,
}
end

lemma all_paths_same_core (t : tree A) (p : list link)
  : all_paths_core t p = list.map (λ z, z ++ p) (all_paths' t)
:=
begin
revert p,
induction t; intros,
{ reflexivity },
{ simp [all_paths_core, all_paths'],
  f_equal,
  { rw ih_2,
    f_equal, apply funext,
    intros x,
    dsimp [function.comp],
    rw list.append_assoc,
    reflexivity, },
  { rw ih_1,
    f_equal, apply funext,
    intros x,
    dsimp [function.comp],
    rw list.append_assoc,
    reflexivity, }
}
end

lemma all_paths_same (t : tree A)
  : all_paths t = all_paths' t
:= begin
unfold all_paths,
rw all_paths_same_core,
apply list.map_id',
intros x, simp,
end

/-- Indeed, `all_paths` and `all_paths` are the same, except one
    gives paths in the reverse order compared to the other
-/
lemma all_paths_reverse (t : tree A)
  : list.map (list.reverse) (all_paths_rev t) = all_paths' t
:=
begin
induction t,
{ reflexivity },
{ simp [all_paths_rev, all_paths'],
  f_equal,
  { rw <- ih_2,
    rw <- list.map_compose,
    f_equal, apply funext,
    intros x,
    simp [function.comp], },
  { rw <- ih_1,
    rw <- list.map_compose,
    f_equal, apply funext,
    intros x,
    simp [function.comp]  }
}
end

protected def right_core : tree A -> path -> path
| (tree.node i l r) path :=
                  right_core r ((lr.right, root l) ::path)
| (tree.leaf i) path := path

/-- get only the rightmost path of a tree (all directions will be lr.right) -/
def right_path (tr : tree A) : path :=
              right_core tr []

/-- given a path (in reverse order from the paths obtained by right_path and all_paths!!)
    follow that path from the root and return the tree at that point-/
def tree_at_path : tree A -> path -> option (tree A)
| t [] := some t
| (tree.node i l r) (h :: t) := match h with
                                | (lr.left, _) := tree_at_path l t
                                | (lr.right, _) := tree_at_path r t
                                end
| (tree.leaf _) _ := none

parameter (compute_parent : link → A → A)

def reconstruct_root (xs : list link) (x : A) : A
  := xs.foldr compute_parent x

def reconstruct_items_rev : list link → A → list A
| [] lf := []
| (x :: xs) lf := reconstruct_root (x :: xs) lf :: reconstruct_items_rev xs lf

/-- Rebuilds all of the items in a path given the combination function, a
    path, and an initial value, path moves towards the root-/
def reconstruct_items (node_combine : A -> A -> A) : path → A → list A
| [] _ := []
| ((lr.left, i) :: t) last_item := let new_item := node_combine last_item i in
                                    new_item :: (reconstruct_items t new_item)
| ((lr.right, i) :: t) last_item := let new_item := node_combine i last_item in
                                    new_item :: (reconstruct_items t new_item)

/-- Given
    a prospective leaf item `lf`,
    a path `p` that is supposed to lead to that leaf item,
    and a tree `t`, this predicate indicates that indeed
    following the path `p` along the tree `t` leads to the leaf `lf`.
-/
inductive path_in_tree_rev : A -> list A -> tree A -> Prop
| leaf : ∀ lf : A, path_in_tree_rev lf [] (tree.leaf lf)
| left : ∀ lf x xs l r,
         path_in_tree_rev lf xs l -> path_in_tree_rev lf (x :: xs) (tree.node x l r)
| right : ∀ lf x xs l r,
         path_in_tree_rev lf xs r -> path_in_tree_rev lf (x :: xs) (tree.node x l r)

parameter combine_data : A → A → A
def compute_parent_correct := forall (left right : A) dir,
  compute_parent (mk_link dir left right) (match dir with
                  | lr.left := right
                  | lr.right := left end)
    = combine_data left right

lemma tree_leaves_all_paths_rev_len (x : tree A)
  : x.leaves.length = (all_paths_rev x).length
:= begin
induction x; dsimp [tree.leaves, all_paths_rev, list.length],
{ reflexivity },
{ repeat { rw list.length_append },
  repeat { rw list.length_map },
  f_equal; assumption,
}
end

lemma tree_leaves_all_paths_rev {X : Type u} (l r : tree A) (f g : list link → X) :
  (list.zip (r.leaves ++ l.leaves)
       (list.map f (all_paths_rev r) ++ list.map g (all_paths_rev l)))
  =
  list.zip r.leaves (list.map f (all_paths_rev r))
  ++ list.zip l.leaves (list.map g (all_paths_rev l))
:= begin
apply list.zip_same_length, rw list.length_map,
apply tree_leaves_all_paths_rev_len,
end

/-- If we compute the list of paths to all leaves in a tree
    where the internal nodes are all the result of applying
    and then use those paths and the leaves they point to
    to try to

-/
lemma reconstruct_root_correct
  (t : tree A)
  (H : internal_nodes_ok combine_data t)
  (comp_par_corr : compute_parent_correct)
  : list.Forall (λ p : A × list link,
    reconstruct_root p.snd p.fst = root t) (list.zip t.leaves (all_paths_rev t))
:= begin
induction H,
{ simp [all_paths_rev], constructor,
  { dsimp, simp [reconstruct_root], reflexivity },
  { constructor }
},
{ dsimp [all_paths_rev, tree.leaves],
  rw tree_leaves_all_paths_rev,
  apply list.concat_Forall,
  { clear ih_1, rw list.zip_map_r, apply list.map_Forall,
    apply list.impl_Forall, apply ih_2,
    clear ih_2 a a_1,
    simp [root],
    intros lf p,
    subst x,
    intros H,
    dsimp [second],
    dsimp [reconstruct_root],
    have H' := comp_par_corr (root l) (root r) lr.left,
    simp [compute_parent_correct] at H',
    dsimp [reconstruct_root] at H,
    rw H, apply H', },
  { clear ih_2, rw list.zip_map_r, apply list.map_Forall,
    apply list.impl_Forall, apply ih_1,
    clear ih_1 a a_1,
    simp [root],
    intros lf p,
    subst x,
    intros H,
    simp only [second],
    simp only [reconstruct_root],
    have H' := comp_par_corr (root l) (root r) lr.right,
    simp only [compute_parent_correct] at H',
    dsimp [reconstruct_root] at H,
    dsimp [list.foldr],
    rw H, apply H', }
}
end

lemma reconstruct_items_correct
  (comp_par_corr : compute_parent_correct)
  (t : tree A)
  : internal_nodes_ok combine_data t
  -> list.Forall (λ p : A × list link, let (lf, pth) := p in
      path_in_tree_rev lf (reconstruct_items_rev pth lf) t)
        (list.zip t.leaves (all_paths_rev t))
:= begin
intros H, induction H,
{ dsimp [all_paths_rev],
  constructor, dsimp, constructor, constructor },
{ dsimp at ih_1 ih_2,
  dsimp, dsimp [all_paths_rev, tree.leaves],
  rw tree_leaves_all_paths_rev,
  apply list.concat_Forall,
  { rw list.zip_map_r, apply list.map_Forall,
    apply_in a_1 (reconstruct_root_correct),
    apply comp_par_corr,
    apply list.impl_Forall2, apply a_1, apply ih_2,
    intros p H H', induction p with lf pth,
    dsimp at H H', dsimp [second],
    dsimp [reconstruct_items_rev],
    dsimp [reconstruct_root],
    dsimp [reconstruct_root] at H, rw H,
    have H2 := comp_par_corr (root l) (root r) lr.left,
    dsimp [compute_parent_correct] at H2,
    rw H2,
    rw ← a_2, apply path_in_tree_rev.right, assumption,
  },
  { rw list.zip_map_r, apply list.map_Forall,
    apply_in a reconstruct_root_correct,
    apply comp_par_corr,
    apply list.impl_Forall2, apply a, apply ih_1,
    intros p H H', induction p with lf pth,
    dsimp at H H', dsimp [second],
    simp [reconstruct_items_rev],
    simp [reconstruct_root],
    dsimp [reconstruct_root] at H, rw H,
    have H2 := comp_par_corr (root l) (root r) lr.right,
    dsimp [compute_parent_correct] at H2,
    rw H2,
    rw ← a_2, apply path_in_tree_rev.left, assumption, }
}
end

theorem end_to_end_height (xs : list A)
  (f : A → A → A)
  : list.Forall (λ ls : list link, ls.length ≤ log2 (xs.length + 1)) $
      all_paths_rev_option (lptree_to_tree f (list_to_lptree xs))
:= begin
destruct (lptree_to_tree f (list_to_lptree xs)),
{ intros Hnone, rw Hnone, constructor, },
{ intros t Ht, rw Ht, dsimp [all_paths_rev_option],
  apply list.impl_Forall, apply all_paths_rev_height,
  intros, apply le_trans, assumption,
  clear a x,
  rw ← lptree_to_tree_option_equiv at Ht,
  have H2 := lptree_to_tree_option_height f (list_to_lptree xs),
  rw Ht at H2, dsimp at H2,
  apply le_trans, apply H2, clear H2,
  rw list_to_lptree_height' xs,
 }
end

end paths

end binary_tree