/-
Copyright (c) 2020 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Floris van Doorn, Yury Kudryashov

! This file was ported from Lean 3 source module data.real.sqrt
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Algebra.Order.MonotoneContinuity
import Mathlib.Topology.Instances.NNReal
import Mathlib.Tactic.Positivity

/-!
# Square root of a real number

In this file we define

* `NNReal.sqrt` to be the square root of a nonnegative real number.
* `Real.sqrt` to be the square root of a real number, defined to be zero on negative numbers.

Then we prove some basic properties of these functions.

## Implementation notes

We define `NNReal.sqrt` as the noncomputable inverse to the function `x ↦ x * x`. We use general
theory of inverses of strictly monotone functions to prove that `NNReal.sqrt x` exists. As a side
effect, `NNReal.sqrt` is a bundled `OrderIso`, so for `NNReal` numbers we get continuity as well as
theorems like `NNReal.sqrt x ≤ y ↔ x ≤ y * y` for free.

Then we define `Real.sqrt x` to be `NNReal.sqrt (Real.toNNReal x)`. We also define a Cauchy sequence
`Real.sqrtAux (f : CauSeq ℚ abs)` which converges to `Real.sqrt (mk f)` but do not prove (yet) that
this sequence actually converges to `Real.sqrt (mk f)`.

## Tags

square root
-/

open Set Filter
open scoped Filter NNReal Topology

namespace NNReal

variable {x y : ℝ≥0}

/-- Square root of a nonnegative real number. -/
-- porting note: was @[pp_nodot]
noncomputable def sqrt : ℝ≥0 ≃o ℝ≥0 :=
  OrderIso.symm <| powOrderIso 2 two_ne_zero
#align nnreal.sqrt NNReal.sqrt

theorem sqrt_le_sqrt_iff : sqrt x ≤ sqrt y ↔ x ≤ y :=
  sqrt.le_iff_le
#align nnreal.sqrt_le_sqrt_iff NNReal.sqrt_le_sqrt_iff

theorem sqrt_lt_sqrt_iff : sqrt x < sqrt y ↔ x < y :=
  sqrt.lt_iff_lt
#align nnreal.sqrt_lt_sqrt_iff NNReal.sqrt_lt_sqrt_iff

theorem sqrt_eq_iff_sq_eq : sqrt x = y ↔ y ^ 2 = x :=
  sqrt.toEquiv.apply_eq_iff_eq_symm_apply.trans eq_comm
#align nnreal.sqrt_eq_iff_sq_eq NNReal.sqrt_eq_iff_sq_eq

theorem sqrt_le_iff : sqrt x ≤ y ↔ x ≤ y ^ 2 :=
  sqrt.to_galoisConnection _ _
#align nnreal.sqrt_le_iff NNReal.sqrt_le_iff

theorem le_sqrt_iff : x ≤ sqrt y ↔ x ^ 2 ≤ y :=
  (sqrt.symm.to_galoisConnection _ _).symm
#align nnreal.le_sqrt_iff NNReal.le_sqrt_iff

@[simp]
theorem sqrt_eq_zero : sqrt x = 0 ↔ x = 0 :=
  sqrt_eq_iff_sq_eq.trans <| by rw [eq_comm, sq, zero_mul]
#align nnreal.sqrt_eq_zero NNReal.sqrt_eq_zero

@[simp]
theorem sqrt_zero : sqrt 0 = 0 :=
  sqrt_eq_zero.2 rfl
#align nnreal.sqrt_zero NNReal.sqrt_zero

@[simp]
theorem sqrt_one : sqrt 1 = 1 :=
  sqrt_eq_iff_sq_eq.2 <| one_pow _
#align nnreal.sqrt_one NNReal.sqrt_one

@[simp]
theorem sq_sqrt (x : ℝ≥0) : sqrt x ^ 2 = x :=
  sqrt.symm_apply_apply x
#align nnreal.sq_sqrt NNReal.sq_sqrt

@[simp]
theorem mul_self_sqrt (x : ℝ≥0) : sqrt x * sqrt x = x := by rw [← sq, sq_sqrt]
#align nnreal.mul_self_sqrt NNReal.mul_self_sqrt

@[simp]
theorem sqrt_sq (x : ℝ≥0) : sqrt (x ^ 2) = x :=
  sqrt.apply_symm_apply x
#align nnreal.sqrt_sq NNReal.sqrt_sq

@[simp]
theorem sqrt_mul_self (x : ℝ≥0) : sqrt (x * x) = x := by rw [← sq, sqrt_sq x]
#align nnreal.sqrt_mul_self NNReal.sqrt_mul_self

theorem sqrt_mul (x y : ℝ≥0) : sqrt (x * y) = sqrt x * sqrt y := by
  rw [sqrt_eq_iff_sq_eq, mul_pow, sq_sqrt, sq_sqrt]
#align nnreal.sqrt_mul NNReal.sqrt_mul

/-- `NNReal.sqrt` as a `MonoidWithZeroHom`. -/
noncomputable def sqrtHom : ℝ≥0 →*₀ ℝ≥0 :=
  ⟨⟨sqrt, sqrt_zero⟩, sqrt_one, sqrt_mul⟩
#align nnreal.sqrt_hom NNReal.sqrtHom

theorem sqrt_inv (x : ℝ≥0) : sqrt x⁻¹ = (sqrt x)⁻¹ :=
  map_inv₀ sqrtHom x
#align nnreal.sqrt_inv NNReal.sqrt_inv

theorem sqrt_div (x y : ℝ≥0) : sqrt (x / y) = sqrt x / sqrt y :=
  map_div₀ sqrtHom x y
#align nnreal.sqrt_div NNReal.sqrt_div

theorem continuous_sqrt : Continuous sqrt := sqrt.continuous
#align nnreal.continuous_sqrt NNReal.continuous_sqrt

end NNReal

namespace Real

/-- An auxiliary sequence of rational numbers that converges to `Real.sqrt (mk f)`.
Currently this sequence is not used in `mathlib`.  -/
def sqrtAux (f : CauSeq ℚ abs) : ℕ → ℚ
  | 0 => mkRat (f 0).num.toNat.sqrt (f 0).den.sqrt
  | n + 1 =>
    let s := sqrtAux f n
    max 0 <| (s + f (n + 1) / s) / 2
#align real.sqrt_aux Real.sqrtAux

theorem sqrtAux_nonneg (f : CauSeq ℚ abs) : ∀ i : ℕ, 0 ≤ sqrtAux f i
  | 0 => by
    rw [sqrtAux, Rat.mkRat_eq, Rat.divInt_eq_div]; apply div_nonneg <;>
      exact Int.cast_nonneg.2 (Int.ofNat_nonneg _)
  | n + 1 => le_max_left _ _
#align real.sqrt_aux_nonneg Real.sqrtAux_nonneg

/- TODO(Mario): finish the proof
theorem sqrt_aux_converges (f : cau_seq ℚ abs) : ∃ h x, 0 ≤ x ∧ x * x = max 0 (mk f) ∧
  mk ⟨sqrt_aux f, h⟩ = x :=
begin
  rcases sqrt_exists (le_max_left 0 (mk f)) with ⟨x, x0, hx⟩,
  suffices : ∃ h, mk ⟨sqrt_aux f, h⟩ = x,
  { exact this.imp (λ h e, ⟨x, x0, hx, e⟩) },
  apply of_near,

  rsuffices ⟨δ, δ0, hδ⟩ : ∃ δ > 0, ∀ i, abs (↑(sqrt_aux f i) - x) < δ / 2 ^ i,
  { intros }
end -/

-- porting note: todo: was @[pp_nodot]
/-- The square root of a real number. This returns 0 for negative inputs. -/
noncomputable def sqrt (x : ℝ) : ℝ :=
  NNReal.sqrt (Real.toNNReal x)
#align real.sqrt Real.sqrt

/-quotient.lift_on x
  (λ f, mk ⟨sqrt_aux f, (sqrt_aux_converges f).fst⟩)
  (λ f g e, begin
    rcases sqrt_aux_converges f with ⟨hf, x, x0, xf, xs⟩,
    rcases sqrt_aux_converges g with ⟨hg, y, y0, yg, ys⟩,
    refine xs.trans (eq.trans _ ys.symm),
    rw [← @mul_self_inj_of_nonneg ℝ _ x y x0 y0, xf, yg],
    congr' 1, exact quotient.sound e
  end)-/
variable {x y : ℝ}

@[simp, norm_cast]
theorem coe_sqrt {x : ℝ≥0} : (NNReal.sqrt x : ℝ) = Real.sqrt x := by
  rw [Real.sqrt, Real.toNNReal_coe]
#align real.coe_sqrt Real.coe_sqrt

@[continuity]
theorem continuous_sqrt : Continuous sqrt :=
  NNReal.continuous_coe.comp <| NNReal.continuous_sqrt.comp continuous_real_toNNReal
#align real.continuous_sqrt Real.continuous_sqrt

theorem sqrt_eq_zero_of_nonpos (h : x ≤ 0) : sqrt x = 0 := by simp [sqrt, Real.toNNReal_eq_zero.2 h]
#align real.sqrt_eq_zero_of_nonpos Real.sqrt_eq_zero_of_nonpos

theorem sqrt_nonneg (x : ℝ) : 0 ≤ sqrt x :=
  NNReal.coe_nonneg _
#align real.sqrt_nonneg Real.sqrt_nonneg

@[simp]
theorem mul_self_sqrt (h : 0 ≤ x) : sqrt x * sqrt x = x := by
  rw [sqrt, ← NNReal.coe_mul, NNReal.mul_self_sqrt, Real.coe_toNNReal _ h]
#align real.mul_self_sqrt Real.mul_self_sqrt

@[simp]
theorem sqrt_mul_self (h : 0 ≤ x) : sqrt (x * x) = x :=
  (mul_self_inj_of_nonneg (sqrt_nonneg _) h).1 (mul_self_sqrt (mul_self_nonneg _))
#align real.sqrt_mul_self Real.sqrt_mul_self

theorem sqrt_eq_cases : sqrt x = y ↔ y * y = x ∧ 0 ≤ y ∨ x < 0 ∧ y = 0 := by
  constructor
  · rintro rfl
    cases' le_or_lt 0 x with hle hlt
    · exact Or.inl ⟨mul_self_sqrt hle, sqrt_nonneg x⟩
    · exact Or.inr ⟨hlt, sqrt_eq_zero_of_nonpos hlt.le⟩
  · rintro (⟨rfl, hy⟩ | ⟨hx, rfl⟩)
    exacts[sqrt_mul_self hy, sqrt_eq_zero_of_nonpos hx.le]
#align real.sqrt_eq_cases Real.sqrt_eq_cases

theorem sqrt_eq_iff_mul_self_eq (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x = y ↔ y * y = x :=
  ⟨fun h => by rw [← h, mul_self_sqrt hx], fun h => by rw [← h, sqrt_mul_self hy]⟩
#align real.sqrt_eq_iff_mul_self_eq Real.sqrt_eq_iff_mul_self_eq

@[simp]
theorem sqrt_eq_one : sqrt x = 1 ↔ x = 1 :=
  calc
    sqrt x = 1 ↔ 1 * 1 = x := sqrt_eq_iff_mul_self_eq_of_pos zero_lt_one
    _ ↔ x = 1 := by rw [eq_comm, mul_one]
#align real.sqrt_eq_one Real.sqrt_eq_one

@[simp]
theorem sq_sqrt (h : 0 ≤ x) : sqrt x ^ 2 = x := by rw [sq, mul_self_sqrt h]
#align real.sq_sqrt Real.sq_sqrt

@[simp]
theorem sqrt_sq (h : 0 ≤ x) : sqrt (x ^ 2) = x := by rw [sq, sqrt_mul_self h]
#align real.sqrt_sq Real.sqrt_sq

theorem sqrt_eq_iff_sq_eq (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x = y ↔ y ^ 2 = x := by
  rw [sq, sqrt_eq_iff_mul_self_eq hx hy]
#align real.sqrt_eq_iff_sq_eq Real.sqrt_eq_iff_sq_eq

theorem sqrt_mul_self_eq_abs (x : ℝ) : sqrt (x * x) = |x| := by
  rw [← abs_mul_abs_self x, sqrt_mul_self (abs_nonneg _)]
#align real.sqrt_mul_self_eq_abs Real.sqrt_mul_self_eq_abs

theorem sqrt_sq_eq_abs (x : ℝ) : sqrt (x ^ 2) = |x| := by rw [sq, sqrt_mul_self_eq_abs]
#align real.sqrt_sq_eq_abs Real.sqrt_sq_eq_abs

@[simp]
theorem sqrt_zero : sqrt 0 = 0 := by simp [sqrt]
#align real.sqrt_zero Real.sqrt_zero

@[simp]
theorem sqrt_one : sqrt 1 = 1 := by simp [sqrt]
#align real.sqrt_one Real.sqrt_one

@[simp]
theorem sqrt_le_sqrt_iff (hy : 0 ≤ y) : sqrt x ≤ sqrt y ↔ x ≤ y := by
  rw [sqrt, sqrt, NNReal.coe_le_coe, NNReal.sqrt_le_sqrt_iff, Real.toNNReal_le_toNNReal_iff hy]
#align real.sqrt_le_sqrt_iff Real.sqrt_le_sqrt_iff

@[simp]
theorem sqrt_lt_sqrt_iff (hx : 0 ≤ x) : sqrt x < sqrt y ↔ x < y :=
  lt_iff_lt_of_le_iff_le (sqrt_le_sqrt_iff hx)
#align real.sqrt_lt_sqrt_iff Real.sqrt_lt_sqrt_iff

theorem sqrt_lt_sqrt_iff_of_pos (hy : 0 < y) : sqrt x < sqrt y ↔ x < y := by
  rw [sqrt, sqrt, NNReal.coe_lt_coe, NNReal.sqrt_lt_sqrt_iff, toNNReal_lt_toNNReal_iff hy]
#align real.sqrt_lt_sqrt_iff_of_pos Real.sqrt_lt_sqrt_iff_of_pos

theorem sqrt_le_sqrt (h : x ≤ y) : sqrt x ≤ sqrt y := by
  rw [sqrt, sqrt, NNReal.coe_le_coe, NNReal.sqrt_le_sqrt_iff]
  exact toNNReal_le_toNNReal h
#align real.sqrt_le_sqrt Real.sqrt_le_sqrt

theorem sqrt_lt_sqrt (hx : 0 ≤ x) (h : x < y) : sqrt x < sqrt y :=
  (sqrt_lt_sqrt_iff hx).2 h
#align real.sqrt_lt_sqrt Real.sqrt_lt_sqrt

theorem sqrt_le_left (hy : 0 ≤ y) : sqrt x ≤ y ↔ x ≤ y ^ 2 := by
  rw [sqrt, ← Real.le_toNNReal_iff_coe_le hy, NNReal.sqrt_le_iff, sq, ← Real.toNNReal_mul hy,
    Real.toNNReal_le_toNNReal_iff (mul_self_nonneg y), sq]
#align real.sqrt_le_left Real.sqrt_le_left

theorem sqrt_le_iff : sqrt x ≤ y ↔ 0 ≤ y ∧ x ≤ y ^ 2 := by
  rw [← and_iff_right_of_imp fun h => (sqrt_nonneg x).trans h, and_congr_right_iff]
  exact sqrt_le_left
#align real.sqrt_le_iff Real.sqrt_le_iff

theorem sqrt_lt (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x < y ↔ x < y ^ 2 := by
  rw [← sqrt_lt_sqrt_iff hx, sqrt_sq hy]
#align real.sqrt_lt Real.sqrt_lt

theorem sqrt_lt' (hy : 0 < y) : sqrt x < y ↔ x < y ^ 2 := by
  rw [← sqrt_lt_sqrt_iff_of_pos (pow_pos hy _), sqrt_sq hy.le]
#align real.sqrt_lt' Real.sqrt_lt'

/-- Note: if you want to conclude `x ≤ Real.sqrt y`, then use `Real.le_sqrt_of_sq_le`.  If you have
`x > 0`, consider using `Real.le_sqrt'` -/
theorem le_sqrt (hx : 0 ≤ x) (hy : 0 ≤ y) : x ≤ sqrt y ↔ x ^ 2 ≤ y :=
  le_iff_le_iff_lt_iff_lt.2 <| sqrt_lt hy hx
#align real.le_sqrt Real.le_sqrt

theorem le_sqrt' (hx : 0 < x) : x ≤ sqrt y ↔ x ^ 2 ≤ y :=
  le_iff_le_iff_lt_iff_lt.2 <| sqrt_lt' hx
#align real.le_sqrt' Real.le_sqrt'

theorem abs_le_sqrt (h : x ^ 2 ≤ y) : |x| ≤ sqrt y := by
  rw [← sqrt_sq_eq_abs]; exact sqrt_le_sqrt h
#align real.abs_le_sqrt Real.abs_le_sqrt

theorem sq_le (h : 0 ≤ y) : x ^ 2 ≤ y ↔ -sqrt y ≤ x ∧ x ≤ sqrt y := by
  constructor
  · simpa only [abs_le] using abs_le_sqrt
  · rw [← abs_le, ← sq_abs]
    exact (le_sqrt (abs_nonneg x) h).mp
#align real.sq_le Real.sq_le

theorem neg_sqrt_le_of_sq_le (h : x ^ 2 ≤ y) : -sqrt y ≤ x :=
  ((sq_le ((sq_nonneg x).trans h)).mp h).1
#align real.neg_sqrt_le_of_sq_le Real.neg_sqrt_le_of_sq_le

theorem le_sqrt_of_sq_le (h : x ^ 2 ≤ y) : x ≤ sqrt y :=
  ((sq_le ((sq_nonneg x).trans h)).mp h).2
#align real.le_sqrt_of_sq_le Real.le_sqrt_of_sq_le

@[simp]
theorem sqrt_inj (hx : 0 ≤ x) (hy : 0 ≤ y) : sqrt x = sqrt y ↔ x = y := by
  simp [le_antisymm_iff, hx, hy]
#align real.sqrt_inj Real.sqrt_inj

@[simp]
theorem sqrt_eq_zero (h : 0 ≤ x) : sqrt x = 0 ↔ x = 0 := by simpa using sqrt_inj h le_rfl
#align real.sqrt_eq_zero Real.sqrt_eq_zero

theorem sqrt_eq_zero' : sqrt x = 0 ↔ x ≤ 0 := by
  rw [sqrt, NNReal.coe_eq_zero, NNReal.sqrt_eq_zero, Real.toNNReal_eq_zero]
#align real.sqrt_eq_zero' Real.sqrt_eq_zero'

theorem sqrt_ne_zero (h : 0 ≤ x) : sqrt x ≠ 0 ↔ x ≠ 0 := by rw [not_iff_not, sqrt_eq_zero h]
#align real.sqrt_ne_zero Real.sqrt_ne_zero

theorem sqrt_ne_zero' : sqrt x ≠ 0 ↔ 0 < x := by rw [← not_le, not_iff_not, sqrt_eq_zero']
#align real.sqrt_ne_zero' Real.sqrt_ne_zero'

@[simp]
theorem sqrt_pos : 0 < sqrt x ↔ 0 < x :=
  lt_iff_lt_of_le_iff_le (Iff.trans (by simp [le_antisymm_iff, sqrt_nonneg]) sqrt_eq_zero')
#align real.sqrt_pos Real.sqrt_pos

alias sqrt_pos ↔ _ sqrt_pos_of_pos
#align real.sqrt_pos_of_pos Real.sqrt_pos_of_pos

/-
section

Porting note: todo: restore positivity plugin
open Tactic Tactic.Positivity

/-- Extension for the `positivity` tactic: a square root is nonnegative, and is strictly positive if
its input is. -/
@[positivity]
unsafe def _root_.tactic.positivity_sqrt : expr → tactic strictness
  | q(Real.sqrt $(a)) => do
    (-- if can prove `0 < a`, report positivity
        do
          let positive pa ← core a
          positive <$> mk_app `` sqrt_pos_of_pos [pa]) <|>
        nonnegative <$> mk_app `` sqrt_nonneg [a]
  |-- else report nonnegativity
    _ =>
    failed
#align tactic.positivity_sqrt tactic.positivity_sqrt

end
-/

@[simp]
theorem sqrt_mul (hx : 0 ≤ x) (y : ℝ) : sqrt (x * y) = sqrt x * sqrt y := by
  simp_rw [sqrt, ← NNReal.coe_mul, NNReal.coe_eq, Real.toNNReal_mul hx, NNReal.sqrt_mul]
#align real.sqrt_mul Real.sqrt_mul

@[simp]
theorem sqrt_mul' (x) {y : ℝ} (hy : 0 ≤ y) : sqrt (x * y) = sqrt x * sqrt y := by
  rw [mul_comm, sqrt_mul hy, mul_comm]
#align real.sqrt_mul' Real.sqrt_mul'

@[simp]
theorem sqrt_inv (x : ℝ) : sqrt x⁻¹ = (sqrt x)⁻¹ := by
  rw [sqrt, Real.toNNReal_inv, NNReal.sqrt_inv, NNReal.coe_inv, sqrt]
#align real.sqrt_inv Real.sqrt_inv

@[simp]
theorem sqrt_div (hx : 0 ≤ x) (y : ℝ) : sqrt (x / y) = sqrt x / sqrt y := by
  rw [division_def, sqrt_mul hx, sqrt_inv, division_def]
#align real.sqrt_div Real.sqrt_div

@[simp]
theorem sqrt_div' (x) {y : ℝ} (hy : 0 ≤ y) : sqrt (x / y) = sqrt x / sqrt y := by
  rw [division_def, sqrt_mul' x (inv_nonneg.2 hy), sqrt_inv, division_def]
#align real.sqrt_div' Real.sqrt_div'

@[simp]
theorem div_sqrt : x / sqrt x = sqrt x := by
  cases' le_or_lt x 0 with h h
  · rw [sqrt_eq_zero'.mpr h, div_zero]
  · rw [div_eq_iff (sqrt_ne_zero'.mpr h), mul_self_sqrt h.le]
#align real.div_sqrt Real.div_sqrt

theorem sqrt_div_self' : sqrt x / x = 1 / sqrt x := by rw [← div_sqrt, one_div_div, div_sqrt]
#align real.sqrt_div_self' Real.sqrt_div_self'

theorem sqrt_div_self : sqrt x / x = (sqrt x)⁻¹ := by rw [sqrt_div_self', one_div]
#align real.sqrt_div_self Real.sqrt_div_self

theorem lt_sqrt (hx : 0 ≤ x) : x < sqrt y ↔ x ^ 2 < y := by
  rw [← sqrt_lt_sqrt_iff (sq_nonneg _), sqrt_sq hx]
#align real.lt_sqrt Real.lt_sqrt

theorem sq_lt : x ^ 2 < y ↔ -sqrt y < x ∧ x < sqrt y := by
  rw [← abs_lt, ← sq_abs, lt_sqrt (abs_nonneg _)]
#align real.sq_lt Real.sq_lt

theorem neg_sqrt_lt_of_sq_lt (h : x ^ 2 < y) : -sqrt y < x :=
  (sq_lt.mp h).1
#align real.neg_sqrt_lt_of_sq_lt Real.neg_sqrt_lt_of_sq_lt

theorem lt_sqrt_of_sq_lt (h : x ^ 2 < y) : x < sqrt y :=
  (sq_lt.mp h).2
#align real.lt_sqrt_of_sq_lt Real.lt_sqrt_of_sq_lt

theorem lt_sq_of_sqrt_lt {x y : ℝ} (h : sqrt x < y) : x < y ^ 2 := by
  have hy := x.sqrt_nonneg.trans_lt h
  rwa [← sqrt_lt_sqrt_iff_of_pos (sq_pos_of_pos hy), sqrt_sq hy.le]
#align real.lt_sq_of_sqrt_lt Real.lt_sq_of_sqrt_lt

/-- The natural square root is at most the real square root -/
theorem nat_sqrt_le_real_sqrt {a : ℕ} : ↑(Nat.sqrt a) ≤ Real.sqrt ↑a := by
  rw [Real.le_sqrt (Nat.cast_nonneg _) (Nat.cast_nonneg _)]
  norm_cast
  exact Nat.sqrt_le' a
#align real.nat_sqrt_le_real_sqrt Real.nat_sqrt_le_real_sqrt

/-- The real square root is at most the natural square root plus one -/
theorem real_sqrt_le_nat_sqrt_succ {a : ℕ} : Real.sqrt ↑a ≤ Nat.sqrt a + 1 := by
  rw [Real.sqrt_le_iff]
  constructor
  · norm_cast
    apply zero_le
  · norm_cast
    exact le_of_lt (Nat.lt_succ_sqrt' a)
#align real.real_sqrt_le_nat_sqrt_succ Real.real_sqrt_le_nat_sqrt_succ

instance : StarOrderedRing ℝ :=
  { Real.orderedAddCommGroup with
    nonneg_iff := fun r => by
      refine ⟨fun hr => ⟨sqrt r, (mul_self_sqrt hr).symm⟩, ?_⟩
      rintro ⟨s, rfl⟩
      exact mul_self_nonneg s }

end Real

open Real

variable {α : Type _}

theorem Filter.Tendsto.sqrt {f : α → ℝ} {l : Filter α} {x : ℝ} (h : Tendsto f l (𝓝 x)) :
    Tendsto (fun x => sqrt (f x)) l (𝓝 (sqrt x)) :=
  (continuous_sqrt.tendsto _).comp h
#align filter.tendsto.sqrt Filter.Tendsto.sqrt

variable [TopologicalSpace α] {f : α → ℝ} {s : Set α} {x : α}

nonrec theorem ContinuousWithinAt.sqrt (h : ContinuousWithinAt f s x) :
    ContinuousWithinAt (fun x => sqrt (f x)) s x :=
  h.sqrt
#align continuous_within_at.sqrt ContinuousWithinAt.sqrt

nonrec theorem ContinuousAt.sqrt (h : ContinuousAt f x) : ContinuousAt (fun x => sqrt (f x)) x :=
  h.sqrt
#align continuous_at.sqrt ContinuousAt.sqrt

theorem ContinuousOn.sqrt (h : ContinuousOn f s) : ContinuousOn (fun x => sqrt (f x)) s :=
  fun x hx => (h x hx).sqrt
#align continuous_on.sqrt ContinuousOn.sqrt

@[continuity]
theorem Continuous.sqrt (h : Continuous f) : Continuous fun x => sqrt (f x) :=
  continuous_sqrt.comp h
#align continuous.sqrt Continuous.sqrt


import algebra.big_operators
import algebra.ordered_ring
import data.int.basic
import data.finset
import data.list
import data.multiset
import data.nat.basic
import data.nat.gcd
import data.nat.prime
import logic.basic
import logic.function
import tactic.find
import tactic.linarith
import tactic.norm_num
import tactic.ring

import divisor
import finset
import nat

open finset (range)
open function (uncurry)
open nat (coprime prime)
open nat.coprime
open nat.divisor

def mersenne : ℕ -> ℕ := λ n, 2^n - 1
@[simp]
lemma mersenne_def {n : ℕ} : mersenne n = 2^n - 1 := refl _

def nat_multiplicative (f : ℕ → ℕ) : Prop := ∀ a b ≥ 1, coprime a b -> f (a * b) = f a * f b

@[simp]
lemma divisor_sum_multiplicative : nat_multiplicative σ := begin
  intros a b a_pos b_pos coprime,
  suffices : finset.is_bijection (uncurry ((*) : ℕ → ℕ → ℕ)) (finset.product (divisors a) (divisors b)) (divisors (a * b)),
  { unfold σ,
    exact calc
      finset.sum (divisors (a * b)) id = finset.sum ((finset.product (divisors a) (divisors b)).image (uncurry (*))) id : by rw [finset.bijection_to_image this]
      ... = finset.sum (finset.product (divisors a) (divisors b)) (uncurry (*)) : finset.sum_image_injection (finset.injection_of_bijection this).2
      ... = finset.sum (finset.product (divisors a) (divisors b)) (uncurry (λ a b, id a * id b)) : by congr
      ... = finset.sum (divisors a) id * finset.sum (divisors b) id : finset.sum_product_is_mul_sum id (divisors a) (divisors b)
  },

  have : a * b > 0 := calc
    a * b > 0 * b : (@mul_lt_mul_right _ _ 0 a b b_pos).2 a_pos
    ... = 0 : by norm_num,

  split,
  { rintros ⟨d, d'⟩ dd'_in_prod,
    rcases (finset.mem_product.1 dd'_in_prod) with ⟨d_div_a, d'_div_b⟩,
    rw [←divisor_iff_dvd] at *,
    have dd'_div_ab := mul_dvd_mul d_div_a d'_div_b,
    repeat {finish} },

  intros y div,
  use ⟨nat.gcd y a, nat.gcd y b⟩,

  replace div := (divisor_iff_dvd (by assumption)).2 div,
  have : nat.gcd y a ∈ divisors a := (divisor_iff_dvd (by assumption)).mp (nat.gcd_dvd_right y a),
  have : nat.gcd y b ∈ divisors b := (divisor_iff_dvd (by assumption)).mp (nat.gcd_dvd_right y b),
  have := nat.prod_coprime_gcd (nat.pos_of_dvd_pos (by assumption) div) coprime,
  split,
  { split, { finish }, exact calc
      nat.gcd y a * nat.gcd y b = nat.gcd y (a * b) : this
      ... = y : nat.gcd_eq_left div
      },
  rintros ⟨y1, y2⟩ ⟨in_div, prod⟩,
  rcases finset.mem_product.mp in_div with ⟨y1_div_a, y2_div_b⟩,
  replace y1_div_a := (divisor_iff_dvd (by assumption)).2 y1_div_a,
  replace y2_div_b := (divisor_iff_dvd (by assumption)).2 y2_div_b,
  simp at prod,
  rw [←prod] at *,

  have y1_coprime_b : nat.coprime y1 b := coprime_dvd_left y1_div_a coprime,
  have y2_coprime_a : nat.coprime y2 a := (coprime_dvd_right y2_div_b coprime).symm,
  have : nat.gcd (y1 * y2) a = y1 := calc
    nat.gcd (y1 * y2) a = nat.gcd y1 a : nat.coprime.gcd_mul_right_cancel y1 y2_coprime_a
    ... = y1 : nat.gcd_eq_left y1_div_a,
  have : nat.gcd (y1 * y2) b = y2 := calc
    nat.gcd (y1 * y2) b = nat.gcd y2 b : nat.coprime.gcd_mul_left_cancel y2 y1_coprime_b
    ... = y2 : nat.gcd_eq_left y2_div_b,
  finish
end

theorem perfect_from_mersenne (n : ℕ) : prime (mersenne (n+1)) -> perfect (2^n * mersenne (n+1)) := begin
  intro pr,
  have : mersenne (n + 1) ≥ 2 := nat.prime.two_le pr,
  have : coprime (2^n) (mersenne (n+1)),
  { apply nat.coprime.pow_left,
    apply (nat.coprime_primes _ _).2,
    { cases n,
      { unfold mersenne, simp, linarith },
      unfold mersenne,
      rw [nat.pow_succ, nat.pow_succ],
      suffices : 2^n * 4 > 3,
      { apply ne_of_lt,
        exact calc 2 = 3 - 1 : by simp
          ... < 2^n * 4 - 1 : nat.lt_pred_iff.2 this
          ... = 2^n * (2 * 2) - 1 : refl _
          ... = 2^n * 2 * 2 - 1 : by rw [mul_assoc]
        },
      have : 2^n ≥ 1 := nat.power_geq_1,
      linarith
    },
    { exact nat.prime_two },
    assumption },
  apply eq.trans (divisor_sum_multiplicative _ _ (nat.power_geq_1) (by linarith) this),
  rw [divisor_sum_prime_power nat.prime_two, divisor_sum_prime pr, finset.geometric_series],
  rw [mul_add, mul_one, nat.mul_sub_right_distrib, one_mul],
  rw [←mersenne_def, nat.pow_succ],
  set x := mersenne (n + 1),
  have : 2^n * 2 * x ≥ x := calc
    2^n * 2 * x = 2^n * (2 * x) : nat.mul_assoc _ _ _
    ... ≥ 1 * (1 * x) : mul_le_mul (nat.power_geq_1) (mul_le_mul (by linarith) (refl x) (by linarith) (by linarith)) (by linarith) (by linarith)
    ... = x : by simp,
  rw [nat.sub_add_from_add_sub (refl x) this, nat.sub_self, nat.zero_add],
  ring
end

theorem mersenne_from_perfect (n : ℕ) : n > 0 -> perfect (2 * n) -> ∃ k, 2 * n = 2^k * mersenne (k + 1) ∧ prime (mersenne (k+1)) := begin
  intros n_pos perfect,
  have pos_2n : 2 * n > 0 := calc
    2 * n > 2 * 0 : (mul_lt_mul_left (by norm_num)).2 n_pos
    ... = 0 : by norm_num,
  rcases divide_out_factors 2 nat.prime_two (2 * n) pos_2n with ⟨k, l, prod, copr⟩,
  use k,

  rw [←prod] at *,
  have k_pos : k > 0 := begin
    cases k,
    { simp at prod, rw [prod] at copr,
      have : 2 = 1 := calc
        2 = nat.gcd 2 (2 * n) : symm (nat.gcd_mul_right_right n 2)
        ... = 1 : copr,
      norm_num at this },
    exact nat.succ_pos k
  end,

  have l_pos : l > 0 := begin cases l, { cases copr }, exact nat.succ_pos _ end,
  have pos_2k : 2^k > 0 := nat.pow_pos (by norm_num) k,
  have pos_mersenne : 2^(k + 1) > 0 := nat.pow_pos (by norm_num) (k+1),
  have coprime_2k_l : coprime (2^k) l := pow_left k copr,

  unfold nat.divisor.perfect at perfect,
  rw [divisor_sum_multiplicative (2 ^ k) l pos_2k l_pos coprime_2k_l, divisor_sum_prime_power nat.prime_two, finset.geometric_series] at perfect,
  have mersenne_dvd_l : mersenne (k + 1) ∣ l := begin
    have : mersenne (k + 1) ∣ 2^(k+1) * l := ⟨σ l, by rw [mersenne, perfect, nat.pow_succ, nat.mul_comm (2^k) 2, nat.mul_assoc]⟩,
    have : coprime (mersenne (k + 1)) (2^(k + 1)) := nat.coprime_sub_one pos_mersenne,
    exact dvd_of_dvd_mul_left (by assumption) (by assumption),
  end,
  rcases mersenne_dvd_l with ⟨m, m_prod⟩,
  rw [m_prod] at *,
  unfold mersenne at *,

  set x := 2^(k + 1) - 1,
  have x_gt_1 : x > 1 := begin
    cases k,
    { linarith },
    have : 2^k * 2 * 2 ≥ 1 + (2 * 2 - 1) := calc
      2^k * 2 * 2 = 2^k * 4 : nat.mul_assoc (2^k) 2 2
      ... ≥ 1 * 4 : @mul_le_mul _ _ 1 4 (2^k) 4 (nat.pow_pos (by norm_num) k) (refl _) (by norm_num) (by norm_num)
      ... = 4 : nat.one_mul _
      ... = 1 + (2 * 2 - 1) : by norm_num,
    exact calc
      x = 2^(k + 2) - 1 : refl _
      ... = 2^k * 2 * 2 - 1 : by rw [nat.pow_succ, nat.pow_succ]
      ... ≥ 1 * 2 * 2 - 1 : nat.le_sub_left_of_add_le this
      ... > 1 : by norm_num
  end,
  have x_pos : x > 0 := by linarith,

  replace perfect := congr_arg (λ n, n / x) perfect,
  simp at perfect,
  have : x ∣ 2^k * x * m := begin
    use 2^k * m,
    rw [←mul_assoc, mul_comm (2^k) x]
  end,
  have : 2^k * x * m / x = 2^k * m := by rw [mul_assoc, mul_comm x m, ←mul_assoc, nat.mul_div_cancel _ x_pos],
  rw [mul_comm x (σ (x * m)), ←mul_assoc (2^k) x m, nat.mul_div_assoc 2 (by assumption), nat.mul_div_cancel _ x_pos, this] at perfect,
  have sigma_l : σ (x * m) = x * m + m := calc
    σ (x * m) = 2 * (2^k * m) : perfect
    ... = 2 * 2^k * m : symm (mul_assoc 2 (2^k) m)
    ... = 2^(k + 1) * m : by rw [mul_comm 2 (2^k), ←nat.pow_succ 2 k]
    ... = (2^(k + 1) - 1 + 1) * m : by rw [@nat.sub_add_cancel (2^(k + 1)) 1 pos_mersenne]
    ... = (x + 1) * m : refl _
    ... = x * m + 1 * m : add_mul (2^(k+1) - 1) 1 m
    ... = x * m + m : by rw [one_mul],
  have m_pos : m > 0 := (mul_lt_mul_left x_pos).mp l_pos,

  have m_is_one : m = 1 := divisor_sum_is_sum x_gt_1 m_pos sigma_l,
  simp [m_is_one] at *,
  exact prime_from_divisor_sum x_gt_1 sigma_l
end


import mynat.definition
import mynat.mul
import world2.level1

namespace mynat

lemma mul_one (m : mynat) : m * 1 = m :=
begin [nat_num_game]
    rw one_eq_succ_zero,
    rw mul_succ,
    rw mul_zero,
    rw zero_add,
    refl,
end

end mynat


variables (men : Type) (barber : men)
variable  (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) :
  false :=
begin
  have hb : shaves barber barber ↔ ¬ shaves barber barber,
    apply h,
  have : ¬ shaves barber barber,
    apply not.intro,
    intro,
    have : ¬ shaves barber barber,
      apply hb.mp,
    assumption,
    contradiction,
  have : shaves barber barber,
    apply hb.mpr,
    assumption,
  contradiction
end


import ..Intuitionism.nat_seq
import ..Intuitionism.reckless
import data.nat.basic

/--
Brouwer's Continuity Principle
If the relation R on 𝒩×ℕ satisfies:
for all infinite sequences α ∈ 𝒩 there is an n ∈ ℕ such that (α R n),
then the relation should be decidable based on an initial part of α
-/
def BCP : Prop := ∀ R : 𝒩 → ℕ → Prop,
    (∀ a : 𝒩, ∃ n : ℕ, R a n) → ∀ a : 𝒩, ∃ m n : ℕ, ∀ b : 𝒩, (∀ i : ℕ, i < m → a i = b i) → R b n

/--
If a sequence of naturals α and a natural number n are given,
we can always create another sequence that starts out the same,
but differs at n
-/
lemma exists_start_eq_ne (a : 𝒩) (n : ℕ) : ∃ b : 𝒩, (∀ i : ℕ, i < n → a i = b i) ∧ a n ≠ b n :=
begin
    set b : 𝒩 := λ i : ℕ, if i < n then a i else a i + 1 with hb,
    use b,
    split,
    {-- need to prove: ∀ i < n, a i = b i
        intros i hi,
        rw hb,
        simp,
        split_ifs,
        refl,
    },
    {-- need to prove: a n ≠ b n
        rw hb,
        simp,
        have h : ¬ n < n, by simp,
        split_ifs,
        intro neq,
        apply nat.succ_ne_self (a n),
        symmetry,
        exact neq,
    }
end

/--
An example to demonstrate the power of BCP
A function f from 𝒩 to ℕ can never be injective
This can be seen as the other side of the coin to nat_seq.uncountable
That theorem showed a function ℕ → 𝒩 can never be surjective, while this one shows
that a function 𝒩 → ℕ can never be injective
-/
theorem strongly_not_injective (f : 𝒩 → ℕ) : BCP → ∀ a : 𝒩, ∃ b : 𝒩, a # b ∧ f a = f b :=
begin
    intros bcp a,
    set R : 𝒩 → ℕ → Prop :=  λ (a : 𝒩) (n : ℕ), f a = n with hr,
    have g₁ : ∀ a : 𝒩, ∃ n : ℕ, R a n,
    {-- proof of ∀ a : 𝒩, ∃ n : ℕ, R a n
        intro a,
        use f a,
        rw hr,
    },
    have bcpa := (bcp R g₁) a, -- we use BCP here
    cases bcpa with m bcpa_m,
    cases bcpa_m with n bcpcon,
    cases exists_start_eq_ne a m with b hb,
    use b,
    split,
    {-- need to prove: a # b
        use m,
        exact hb.elim_right,
    },
    {-- need to prove: f a = f b
        have g₂ : R a n,
        {-- proof of g₂
            apply bcpcon a,
            intros i hi,
            refl,
        },
        have g₃ : R b n,
        {-- proof of g₃
            apply bcpcon b,
            intros i hi,
            exact hb.elim_left i hi,
        },
        rw hr at g₂ g₃,
        rwa [g₂, g₃],
    }
end

/-
The above theorem perhaps isn't how a classical mathematician would define "not injective"
This theorem should remove any doubts that the previous theorem shows
that the function is not injective
-/
theorem not_injective (f : 𝒩 → ℕ) : BCP → ¬(∀ a b : 𝒩, f a = f b → a =' b) :=
begin
    intros bcp h,
    have h0 := h nat_seq.zero,
    cases strongly_not_injective f bcp nat_seq.zero with b hb,
    have hb0 := h0 b hb.elim_right,
    exact (nat_seq.ne_of_apart _ _ hb.elim_left) hb0,
end

lemma grow_tail (a b : 𝒩) (n : ℕ)
    (h₁ : ∀ i : ℕ, i >= nat.succ(n) → a i = b i)
    (h₂ : a n = b n) :
    ∀ i : ℕ, i >= n → a i = b i :=
begin
    intros i hi,
    rwa [ge_iff_le, le_iff_lt_or_eq] at hi,
    cases hi with lti eqi,
    {-- case: n < i
        apply h₁,
        rwa [ge_from_le, nat.succ_le_iff],
    },
    {-- case: n = i
        rw ← eqi,
        exact h₂,
    }
end

-- A lemma needed at the end of the next theorem
lemma tail_equal_not_forall_equal_implies_exists_ne (a b : 𝒩) (n : ℕ)
    (h₁ : ∀ i : ℕ, i >= n → a i = b i)
    (h₂ : ¬ ∀ i : ℕ, a i = b i) :
    ∃ i : ℕ, i < n ∧ a i ≠ b i :=
begin
    induction n with m hm,
    {-- case: m = 0, this is impossible
        exfalso,
        apply h₂,
        intro i,
        have hi := h₁ i,
        apply hi,
        simp,
    },
    {-- case: m → m + 1
        have ambm := lt_trichotomy (a m) (b m),
        rwa [or_comm, or_assoc, ← ne_iff_lt_or_gt] at ambm,
        cases ambm with meq mne,
        {-- case: a m = b m
            have h₂ := grow_tail a b m h₁ meq,
            have h₃ := hm h₂,
            cases h₃ with i hi,
            use i,
            split,
            {-- need to prove: i < succ(m)
                transitivity m,
                exact hi.elim_left,
                exact nat.lt_succ_self m,
            },
            {-- need to prove: a i ≠ b i
                exact hi.elim_right,
            }
        },
        {-- case: a m ≠ b m
            use m,
            split,
            exact nat.lt_succ_self m, -- m < succ(m)
            exact ne.symm mne, -- a m ≠ b m
        }
    }
end

-- simple lemma needed for next theorem
lemma ite_cond_eq (a b d : 𝒩) (n : ℕ) (hd : d =' (λ i, ite (i < n) (b i) (a i))) :
    ∀ (i : ℕ), i ≥ n → d i = a i :=
begin
    intros i hi,
    rw hd,
    simp,
    split_ifs,
    {-- case: i < n
        exfalso,
        exact (not_lt_of_ge hi) h,
    },
    {-- case: i ≥ n
        refl,
    }
end

/--
Another example to demonstrate the power of BCP
If two sequences are apart, then a third sequence cannot be equal to both
(and which sequence it is not equal to can be determined)
-/
theorem apart_iff_forall_ne_or_ne (bcp : BCP) (a b : 𝒩) : a # b ↔ ∀ c : 𝒩, a ≠' c ∨ c ≠' b :=
begin
    split,
    {-- need to prove: a # b → ∀ c : 𝒩, c ≠ a ∨ c ≠ b
        intros h c,
        cases nat_seq.apart_cotrans a b h c with hac hcb,
        {-- case: a # c
            left,
            exact nat_seq.ne_of_apart a c hac,
        },
        {-- case: c # b
            right,
            exact nat_seq.ne_of_apart c b hcb,
        }
    },
    {-- need to prove: (∀ c : 𝒩, c ≠ a ∨ c ≠ b) → a # b, BCP is needed here
        intro h,
        set R : 𝒩 → ℕ → Prop := λ c, λ n, if n = 0 then c ≠' a else c ≠' b with hR,
        have hz : 0 = 0 := rfl,
        have hr : ∀ c : 𝒩, ∃ n : ℕ, R c n, by
        {-- need to prove: ∀ c : 𝒩, ∃ n : ℕ, R c n
            intro c,
            cases h c with hc₁ hc₂,
            {-- case: a ≠ c
                use 0,
                rw hR,
                split_ifs,
                rw nat_seq.ne_symm,
                exact hc₁,
            },
            {-- case: c ≠ b
                use 1,
            }
        },
        have bcpb := (bcp R hr) b,
        cases bcpb with m bcpbm,
        cases bcpbm with n bcpbmn,
        have hb₁ := bcpbmn b,
        have hb₂ : ∀ i : ℕ, i < m → b i = b i, by
        {-- need to prove ∀ i : ℕ, i < m → b i = b
            intros i hi,
            refl,
        },
        have hb := hb₁ hb₂,
        have hn : n = 0, by
        {-- need to prove: n = 0
            cases nat.eq_zero_or_pos n with hn₁ hn₂,
            {-- case: n = 0
                exact hn₁,
            },
            {-- case: n > 0, impossible
                exfalso,
                rw hR at hb,
                have hn₃ := ne_of_gt hn₂,
                rw ne at hn₃,
                split_ifs at hb,
                apply hb,
                refl,
            }
        },
        rw hn at bcpbmn,
        set d : 𝒩 := λ i, if i < m then b i else a i with hd,
        have hd₁ := bcpbmn d,
        have hd₂ : ∀ i : ℕ, i < m → b i = d i, by
        {-- need to prove: ∀ i : ℕ, i < m → b i = d i
            intros i hi,
            rw hd,
            simp,
            split_ifs,
            refl,
        },
        have hd₃ := hd₁ hd₂,
        rw hR at hd₃,
        split_ifs at hd₃,
        rw nat_seq.ne at hd₃,
        rw nat_seq.eq at hd₃,
        rw function.funext_iff at hd,
        have h₀ := ite_cond_eq a b d m hd,
        cases tail_equal_not_forall_equal_implies_exists_ne d a m h₀ hd₃ with j hj,
        use j,
        rw (hd₂ j hj.elim_left),
        symmetry,
        exact hj.elim_right,
    }
end

theorem BCP_implies_not_LPO : BCP → ¬reckless.LPO :=
begin
    intros bcp lpo,
    set R : 𝒩 → ℕ → Prop := λ a, λ i, if i = 0 then ∀ n : ℕ, a n = 0 else ∃ n, a n ≠ 0 with hR,
    have hz : 0 = 0 := rfl,
    have hr : ∀ a : 𝒩, ∃ n : ℕ, R a n, by
    {
        intro a,
        cases lpo a with aeq0 ane0,
        {-- case: ∀ n : ℕ, a n = 0
            use 0,
            rw hR,
            split_ifs, --We only need to consider the case 0 = 0
            exact aeq0,
        },
        {-- case: ∃ n : ℕ, a n ≠ 0
            use 1,
            rw hR,
            split_ifs,
            {-- case: 1 = 0, impossible
                exfalso,
                exact nat.one_ne_zero h,
            },
            {-- case: ¬1 = 0, need to prove: ∃ n : ℕ, a n ≠ 0
                exact ane0,
            }
        }
    },
    have bcp_r_0 := (bcp R hr) nat_seq.zero,
    cases bcp_r_0 with m bcp_r_0₁,
    cases bcp_r_0₁ with n bcp_r_0₂,
    cases nat.eq_zero_or_pos n with hn₁ hn₂,
    {-- case: n = 0
        set b : 𝒩 := λ k, if k < m then 0 else 1 with hb,
        have bstart0 : (∀ (i : ℕ), i < m → nat_seq.zero i = b i), by
        {
            intros i hi,
            simp [nat_seq.zero, hb],
            split_ifs,
            refl,
        },
        have bcp_b := (bcp_r_0₂ b) bstart0,
        rwa [hR, hn₁] at bcp_b,
        split_ifs at bcp_b,
        {-- case: 0 = 0, need to prove: ∀ n : ℕ, b n = 0 leads to a contradiction
            have hm := bcp_b m,
            simp [hb] at hm,
            split_ifs at hm,
            {-- case: m < m, impossible
                revert h,
                exact irrefl m,
            },
            {-- case: ¬ m < m, need to prove: false, we use hm (1 = 0)
                exact nat.one_ne_zero hm,
            }
        },
    },
    {-- case: n > 0
        have h₀ := bcp_r_0₂ nat_seq.zero,
        have h₁ : (∀ i : ℕ, i < m → nat_seq.zero i = nat_seq.zero i), by simp,
        have h₂ := h₀ h₁,
        rw hR at h₂,
        split_ifs at h₂,
        {-- case: n = 0, impossible since we assumed n > 0
            exact (ne_of_gt hn₂) h,
        },
        {-- have: ∃ n, nat_seq.zero n ≠ 0, this is a contradiction with the definition of nat_seq.zero
            cases h₂ with k hk,
            apply hk,
            refl,
        }
    }
end

-- In essence, this is the same proof as the proof of BCP_implies_not_LPO,
-- which becomes unnecessary since we have proven LPO → WLPO
theorem BCP_implies_not_WLPO : BCP → ¬reckless.WLPO :=
begin
    intros bcp wlpo,
    set R : 𝒩 → ℕ → Prop := λ a, λ i, if i = 0 then ∀ n : ℕ, a n = 0 else ¬∀ n : ℕ, a n = 0 with hR,
    have hz : 0 = 0 := rfl,
    have hr : ∀ a : 𝒩, ∃ n : ℕ, R a n, by
    {
        intro a,
        cases wlpo a with aeq0 naeq0,
        {-- case: ∀ n : ℕ, a n = 0
            use 0,
            rw hR,
            split_ifs, --We only need to consider the case 0 = 0
            exact aeq0,
        },
        {-- case: ¬∀ n : ℕ, a n = 0
            use 1,
        }
    },
    have bcp_r_0 := (bcp R hr) nat_seq.zero,
    cases bcp_r_0 with m bcp_r_0₁,
    cases bcp_r_0₁ with n bcp_r_0₂,
    cases nat.eq_zero_or_pos n with hn₁ hn₂,
    {-- case: n = 0
        set b : 𝒩 := λ k, if k < m then 0 else 1 with hb,
        have bstart0 : (∀ (i : ℕ), i < m → nat_seq.zero i = b i), by
        {
            intros i hi,
            simp [nat_seq.zero, hb],
            split_ifs,
            refl,
        },
        have bcp_b := (bcp_r_0₂ b) bstart0,
        rwa [hR, hn₁] at bcp_b,
        split_ifs at bcp_b,
        {-- case: 0 = 0, need to prove: ∀ n : ℕ, b n = 0 leads to a contradiction
            have hm := bcp_b m,
            simp [hb] at hm,
            split_ifs at hm,
            {-- case: m < m, impossible
                revert h,
                exact irrefl m,
            },
            {-- case: ¬ m < m, need to prove: false, we use hm (1 = 0)
                exact nat.one_ne_zero hm,
            }
        },
    },
    {-- case: n > 0
        have h₀ := bcp_r_0₂ nat_seq.zero,
        have h₁ : (∀ i : ℕ, i < m → nat_seq.zero i = nat_seq.zero i), by simp,
        have h₂ := h₀ h₁,
        rw hR at h₂,
        split_ifs at h₂,
        {-- case: n = 0, impossible since we assumed n > 0
            exact (ne_of_gt hn₂) h,
        },
        {-- have: ¬∀ n : ℕ, nat_seq.zero n = 0, this is a contradiction with the definition of nat_seq.zero
            apply h₂,
            intro i,
            refl,
        }
    }
end


import tactic

---------------
-- # Question 1
---------------

namespace coursework.i

inductive loc : Type
| id    : ℕ → loc
| deref : ℕ → loc

inductive exp : Type
| loc    : loc →       exp
| int    : ℤ →         exp -- Normal (answer)
| dderef : ℕ →         exp
| sum    : exp → exp → exp
| prod   : exp → exp → exp

inductive cmd : Type
| skip   :             cmd -- Normal (answer)
| assign : loc → exp → cmd
| seq    : cmd → cmd → cmd
| cond   : loc → cmd → cmd → cmd
| while  : loc → cmd → cmd

-- Notations
instance : has_coe ℕ loc := ⟨loc.id⟩
notation `$`:100 n:100   := loc.deref n

instance name₁ : has_coe loc exp := ⟨exp.loc⟩
instance name₂ : has_coe ℤ exp   := ⟨exp.int⟩
notation `$$`:100 n:100          := exp.dderef n
instance : has_add exp           := ⟨exp.sum⟩
instance : has_mul exp           := ⟨exp.prod⟩

notation `SKIP`                                    := cmd.skip
infixr   ` ::= `:50                                := cmd.assign
infixr   ` ;; `:25                                 := cmd.seq
notation `IF ` c:100 ` THEN ` t:100 ` ELSE ` f:100 := cmd.cond c t f
notation `WHILE ` c:100 ` DO ` b:100               := cmd.while c b

-- Heap defined as a funtion from ℕ to (optional ℤ)
-- This may not be the best for proving theorems, but easily enables computation.
def heap : Type := ℕ → option ℤ
def heap.empty : heap := λ i', none
def heap.set : heap → ℕ → ℤ → heap
| h i x := λ i', if i' = i then x else h i'

def heap.from_list : list (ℕ × ℤ) → heap
| (list.nil)           := λ i', none
| (list.cons ⟨i, x⟩ t) := λ i', if i' = i then x else heap.from_list t i'

meta def heap.to_list : heap → ℕ → ℕ → list (option ℤ)
| h l r := if l = r then [] else list.cons (h l) (heap.to_list h (l + 1) r)

-- Big-step operational semantics (interpreter)
def loc.eval : loc → heap → option ℤ
| (loc.id i)    h := i
| (loc.deref i) h := h i

def exp.eval : exp → heap → option ℤ
| (exp.loc l)    h := loc.eval l h
| (exp.int z)    h := some z
| (exp.dderef i) h := do
  i' <- h i,
  match i' with
  | (int.of_nat i')         := h i'
  | (int.neg_succ_of_nat _) := none
  end
| (exp.sum a b)  h := do a' <- exp.eval a h, b' <- exp.eval b h, some (a' + b')
| (exp.prod a b) h := do a' <- exp.eval a h, b' <- exp.eval b h, some (a' * b')

meta def cmd.exec : cmd → heap → option heap
| (cmd.skip)       h := h
| (cmd.assign i x) h := do
  i' <- loc.eval i h,
  x' <- exp.eval x h,
  match i' with
  | (int.of_nat i')         := heap.set h i' x'
  | (int.neg_succ_of_nat _) := none
  end
| (cmd.seq c₁ c₂) h := do
  h₁ <- cmd.exec c₁ h,
  h₂ <- cmd.exec c₂ h₁,
  some h₂
| (cmd.cond c t f) h := do
  c' <- loc.eval c h,
  if c' > 0 then cmd.exec t h else cmd.exec f h
| (cmd.while c b) h := do
  c' <- loc.eval c h,
  if c' > 0 then cmd.exec (cmd.seq b (cmd.while c b)) h else cmd.exec cmd.skip h

-- Part A
section
  def prog₁ : cmd :=
    ↑1 ::= ↑0;;
    ↑2 ::= ↑1;;
    ↑3 ::= $0

  #eval do
    h <- cmd.exec prog₁ (heap.from_list [(0, 3)]),
    some (heap.to_list h 0 10)
  -- [(some 3), (some 0), (some 1), (some 3), none, none, none, none, none, none]

  def prog₂ : cmd :=
    ↑1 ::= ↑0;;
    ↑2 ::= ↑1;;
    ↑3 ::= $0;;
    WHILE $3 DO (
      ↑2 ::= $2 * $3;;
      ↑3 ::= $3 + ↑(-1:ℤ)
    );;
    ↑1 ::= $2

  #eval do
    h <- cmd.exec prog₂ (heap.from_list [(0, 3)]),
    some (heap.to_list h 0 10)
  -- [(some 3), (some 6), (some 6), (some 0), none, none, none, none, none, none]
end

-- Part B
-- The `loc.eval : loc → heap → option ℤ` is the "auxiliary lookup function for locations".
-- Note that Lean prefers coercions on smallest terms, e.g.
-- `z₁ + z₂` is interpreted as `(expr.int z₁) + (expr.int z₂)` instead of `expr.int (z₁ + z₂)`.
inductive exp_small : exp × heap → exp × heap → Prop
| loc        : ∀ (h : heap) (l : loc) (z : ℤ),    loc.eval l h = some z →         exp_small (l, h) (z, h)
| dderef     : ∀ (h : heap) (n n' : ℕ) (z : ℤ),   h n = some n' → h n' = some z → exp_small ($$n, h) (z, h)
| sum_left   : ∀ (h : heap) (E₁ E₁' E₂ : exp),    exp_small (E₁, h) (E₁', h) →    exp_small (E₁ + E₂, h) (E₁' + E₂, h)
| sum_right  : ∀ (h : heap) (z : ℤ) (E E' : exp), exp_small (E, h) (E', h) →      exp_small (z + E, h) (z + E', h)
| sum_add    : ∀ (h : heap) (z₁ z₂ z : ℤ),        z₁ + z₂ = z →                   exp_small (z₁ + z₂, h) (z, h)
| prod_left  : ∀ (h : heap) (E₁ E₁' E₂ : exp),    exp_small (E₁, h) (E₁', h) →    exp_small (E₁ * E₂, h) (E₁' * E₂, h)
| prod_right : ∀ (h : heap) (z : ℤ) (E E' : exp), exp_small (E, h) (E', h) →      exp_small (z * E, h) (z * E', h)
| prod_mul   : ∀ (h : heap) (z₁ z₂ z : ℤ),        z₁ + z₂ = z →                   exp_small (z₁ * z₂, h) (z, h)

-- Technically speaking, in this problem we cannot make a `cond_left` rule that evaluates the condition only,
-- as the type of the condition is Loc, which could only store a non-negative constant.
inductive cmd_small : cmd × heap → cmd × heap → Prop
| assign_left  : ∀ (h : heap) (l : loc) (n : ℕ) (E : exp),     loc.eval l h = some (int.of_nat n) → cmd_small (l ::= E, h) (n ::= E, h)
| assign_right : ∀ (h : heap) (n : ℕ) (E E' : exp),            exp_small (E, h) (E', h) →           cmd_small (n ::= E, h) (n ::= E', h)
| assign_set   : ∀ (h h' : heap) (n : ℕ) (z : ℤ),              heap.set h n z = h' →                cmd_small (n ::= z, h) (SKIP, h')
| seq_left     : ∀ (h h' : heap) (C₁ C₁' C₂: cmd),             cmd_small (C₁, h) (C₁', h') →        cmd_small (C₁ ;; C₂, h) (C₁' ;; C₂, h')
| seq_skip     : ∀ (h : heap) (C : cmd),                                                            cmd_small (SKIP ;; C, h) (C, h)
| cond_true    : ∀ (h : heap) (l : loc) (z : ℤ) (c₁ c₂ : cmd), loc.eval l h = some z → z > 0 →      cmd_small (IF l THEN c₁ ELSE c₂, h) (c₁, h)
| cond_false   : ∀ (h : heap) (l : loc) (z : ℤ) (c₁ c₂ : cmd), loc.eval l h = some z → z <= 0 →     cmd_small (IF l THEN c₁ ELSE c₂, h) (c₂, h)
| while        : ∀ (h : heap) (l : loc) (c : cmd),                                                  cmd_small (WHILE l DO c, h) (IF l THEN (c ;; WHILE l DO c) ELSE SKIP, h)

notation p₁ ` ~>ᵉ ` p₂ := exp_small p₁ p₂
notation p₁ ` ~>ᶜ ` p₂ := cmd_small p₁ p₂

-- Part C
/-
* Answer configurations: (`SKIP`, h)
* Stuck configurations: (C, h) where C contains any of the following:
  * an Loc `$n`, where `h` is not defined at index `n`;
  * an Exp `$$n`, where `h` is not defined at indices `n` or `$n` (including the case `$n` evaluates to a negative integer);
  * a Cmd `l ::= E`, where `l` (an Loc) evaluates to a negative integer.
* Normal configurations: all of the above.
-/

-- Part D
section
  def add5 : cmd :=
    ↑2 ::= $1;;
    -- Loop invariant: location 2 stores the current pointer
    WHILE $2 DO (
      $2 ::= $$2 + ↑5;;
      ↑2 ::= $2 + ↑1;;
      ↑2 ::= $$2
    )

  #eval do
    h <- cmd.exec add5 (heap.from_list [(1, 15), (12, -25), (13, 17), (15, 4), (16, 12), (17, 28), (18, -111)]),
    some (heap.to_list h 0 20)
  -- [none, (some 15), (some -111), none, none, none, none, none, none, none,
  --  none, none, (some -20), (some 17), none, (some 9), (some 12), (some 33), (some -111), none]
end

end coursework.i

---------------
-- # Question 2
---------------

namespace coursework.ii

inductive exp : Type
| num  : ℕ →         exp
| sum  : exp → exp → exp
| prod : exp → exp → exp

instance : has_coe ℕ exp := ⟨exp.num⟩
instance : has_add exp := ⟨exp.sum⟩
instance : has_mul exp := ⟨exp.prod⟩

inductive small : exp → exp → Prop
| sum1  : ∀ (n₁ n₂ m : ℕ),          n₁ + n₂ = m  → small (n₁ + n₂) m
| sum2  : ∀ (E₁ E₁' E₂ : exp),      small E₁ E₁' → small (E₁ + E₂) (E₁' + E₂)
| sum3  : ∀ (n : ℕ) (E₂ E₂' : exp), small E₂ E₂' → small (n + E₂) (n + E₂')
| prod1 : ∀ (E₁ E₁' E₂ : exp),      small E₁ E₁' → small (E₁ * E₂) (E₁' * E₂)
| prod2 : ∀ (n m : ℕ) (E₂ : exp),   n = m + 1 →    small (n * E₂) (E₂ + (m * E₂))
| prod3 : ∀ (E₂ : exp),                            small (↑0 * E₂) ↑0

notation E₁ ` ~> ` E₂ := small E₁ E₂

-- Part A
section
  variable R : exp → exp → Prop
  #check @small.rec R
  /-
  small.rec :
  (∀ (n₁ n₂ m : ℕ)           n₁ + n₂ = m →            R (↑n₁ + ↑n₂) ↑m          ) →
  (∀ (E₁ E₁' E₂ : exp),      (E₁ ~> E₁') → R E₁ E₁' → R (E₁ + E₂) (E₁' + E₂)    ) →
  (∀ (n : ℕ) (E₂ E₂' : exp), (E₂ ~> E₂') → R E₂ E₂' → R (↑n + E₂) (↑n + E₂')    ) →
  (∀ (E₁ E₁' E₂ : exp),      (E₁ ~> E₁') → R E₁ E₁' → R (E₁ * E₂) (E₁' * E₂)    ) →
  (∀ (n m : ℕ) (E₂ : exp),   n = m + 1 →              R (↑n * E₂) (E₂ + ↑m * E₂)) →
  (∀ (E₂ : exp),                                      R (↑0 * E₂) ↑0            ) →
  ∀ (E₁ E₂ : exp), (E₁ ~> E₂) → R E₁ E₂
  -/
end

-- Part B
def eval : exp → ℕ
| (exp.num n)      := n
| (exp.sum E₁ E₂)  := eval E₁ + eval E₂
| (exp.prod E₁ E₂) := eval E₁ * eval E₂

theorem part_b : ∀ E E' : exp, (E ~> E') → (eval E = eval E') :=
begin
  rintros E E' hs,
  induction hs,
  case sum1  : n₁ n₂ m hsum        { rw ← hsum, refl },
  case sum2  : E₁ E₁' E₂ hsmall ih { change eval E₁ + eval E₂ = eval E₁' + eval E₂ at ⊢, rw ih, },
  case sum3  : n E₂ E₂' hsmall ih  { change n + eval E₂ = n + eval E₂' at ⊢, rw ih, },
  case prod1 : E₁ E₁' E₂ hsmall ih { change eval E₁ * eval E₂ = eval E₁' * eval E₂ at ⊢, rw ih, },
  case prod2 : n m E₂ hsucc        { change n * eval E₂ = eval E₂ + m * eval E₂ at ⊢, rw hsucc, linarith, },
  case prod3 : E₂                  { change 0 * eval E₂ = 0 at ⊢, linarith, },
end

-- Part C
inductive small_star : exp → exp → Prop
| refl : ∀ (E : exp),                                        small_star E E
| tail : ∀ (E₁ E₂ E₃ : exp), small_star E₁ E₂ → (E₂ ~> E₃) → small_star E₁ E₃

notation E₁ ` ~>* ` E₂ := small_star E₁ E₂

section
  variable R : exp → exp → Prop
  #check @small_star.rec R
  /-
  small_star.rec :
  (∀ (E : exp),                                             R E E  ) →
  (∀ (E₁ E₂ E₃ : exp), (E₁ ~>* E₂) → (E₂ ~> E₃) → R E₁ E₂ → R E₁ E₃) →
  ∀ (E₁ E₂ : exp), (E₁ ~>* E₂) → R E₁ E₂
  -/
end

-- Part D
theorem part_d : ∀ E E' : exp, (E ~>* E') → eval E = eval E' :=
begin
  rintros E E' hss,
  induction hss,
  case refl : E { refl, },
  case tail : E₁ E₂ E₃ hss hs ih { rw ih, exact (part_b _ _ hs), },
end

-- Part E
theorem part_e : ∀ E : exp, ∀ n : ℕ, (E ~>* n) → eval E = n :=
begin
  rintros E n hss,
  exact (part_d _ _ hss),
end

end coursework.ii


import GMLInit.Data.Nat.Basic
import GMLInit.Data.Nat.Order

class Infinity (α) where
  infinity : α
notation "∞" => Infinity.infinity

structure ENat where
  isLE : Nat → Bool
  step (x : Nat) : isLE x → isLE (x + 1)

namespace ENat

protected theorem eq : {e₁ e₂ : ENat} → e₁.isLE = e₂.isLE → e₁ = e₂
| ⟨_,_⟩, ⟨_,_⟩, rfl => rfl

protected theorem ext {e₁ e₂ : ENat} : (∀ x, e₁.isLE x = e₂.isLE x) → e₁ = e₂
| h => ENat.eq $ funext h

theorem mono (e : ENat) {x y : Nat} : x ≤ y → e.isLE x → e.isLE y := by
  intro h hx
  match Nat.le.dest h with
  | ⟨z,hz⟩ =>
    cases hz
    induction z with
    | zero => exact hx
    | succ z H =>
      apply e.step
      apply H
      exact Nat.le_add_right x z

protected def zero : ENat where
  isLE _ := true
  step _ := id
instance : OfNat ENat (nat_lit 0) := ⟨ENat.zero⟩

@[simp] theorem isLE_zero (n) : ENat.isLE 0 n = true := rfl

protected def infinity : ENat where
  isLE _ := false
  step _ := Bool.noConfusion
instance : Infinity ENat := ⟨ENat.infinity⟩

@[simp] theorem isLE_infinity (n) : ENat.isLE ∞ n = false := rfl

protected def ofNat (n : Nat) : ENat where
  isLE := Nat.ble n
  step x := by
    intro h
    rw [Nat.ble_eq] at h ⊢
    transitivity x
    · exact h
    · exact Nat.le_add_right ..

instance : Coe Nat ENat := ⟨ENat.ofNat⟩

@[simp] theorem ofNat_isLE_iff_le (n m : Nat) : ENat.isLE n m ↔ n ≤ m := by
  clean unfold ENat.ofNat
  rw [Nat.ble_eq]

theorem ofNat_isLE_self (n : Nat) : ENat.isLE n n := by
  rw [ofNat_isLE_iff_le]
  reflexivity

end ENat


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

import ring_theory.witt_vector.frobenius
import ring_theory.witt_vector.verschiebung
import ring_theory.witt_vector.mul_p

/-!
## Identities between operations on the ring of Witt vectors

In this file we derive common identities between the Frobenius and Verschiebung operators.

## Main declarations

* `frobenius_verschiebung`: the composition of Frobenius and Verschiebung is multiplication by `p`
* `verschiebung_mul_frobenius`: the “projection formula”: `V(x * F y) = V x * y`

## References

* [Hazewinkel, *Witt Vectors*][Haze09]

* [Commelin and Lewis, *Formalizing the Ring of Witt Vectors*][CL21]
-/

namespace witt_vector

variables {p : ℕ} {R : Type*} [fact p.prime] [comm_ring R]
local notation `𝕎` := witt_vector p -- type as `\bbW`

noncomputable theory

/-- The composition of Frobenius and Verschiebung is multiplication by `p`. -/
lemma frobenius_verschiebung (x : 𝕎 R) :
  frobenius (verschiebung x) = x * p :=
by { ghost_calc x, ghost_simp [mul_comm] }

/-- Verschiebung is the same as multiplication by `p` on the ring of Witt vectors of `zmod p`. -/
lemma verschiebung_zmod (x : 𝕎 (zmod p)) :
  verschiebung x = x * p :=
by rw [← frobenius_verschiebung, frobenius_zmodp]

lemma coeff_p_pow [char_p R p] (i : ℕ) : (p ^ i : 𝕎 R).coeff i = 1 :=
begin
  induction i with i h,
  { simp only [one_coeff_zero, ne.def, pow_zero] },
  { rw [pow_succ', ← frobenius_verschiebung, coeff_frobenius_char_p,
        verschiebung_coeff_succ, h, one_pow], }
end

/-- The “projection formula” for Frobenius and Verschiebung. -/
lemma verschiebung_mul_frobenius (x y : 𝕎 R) :
  verschiebung (x * frobenius y) = verschiebung x * y :=
by { ghost_calc x y, rintro ⟨⟩; ghost_simp [mul_assoc] }

end witt_vector


import Lean

section open Lean Elab Term
elab "!" tm:term : term => elabTermEnsuringType tm none end

namespace prover
noncomputable section

def id.{u} {α : Sort u} (x : α) : α := x

infixr:1 (priority := high) " # " => id

-- Definitions

def true : Prop :=
∀ (P : Prop), P → P

def false : Prop :=
∀ (P : Prop), P

def not (P : Prop) : Prop :=
P → false

prefix:40 (priority := high) "¬" => not

def or (P Q : Prop) : Prop :=
¬P → Q

infixr:30 (priority := high) " ∨ " => or

def and (P Q : Prop) : Prop :=
¬(¬P ∨ ¬Q)

infixr:35 (priority := high) " ∧ " => and

def iff (P Q : Prop) : Prop :=
(P → Q) ∧ (Q → P)

infixl:20 (priority := high) " ↔ " => iff

def eq {α : Type} (x y : α) : Prop :=
∀ (P : α → Prop), P x → P y

infixl:50 (priority := high) " = " => eq

def ne {α : Type} (x y : α) : Prop :=
¬(x = y)

infixl:50 (priority := high) " ≠ " => ne

def exi {α : Type} (P : α → Prop) : Prop :=
¬(∀ (x : α), ¬P x)

section open Lean
macro (priority := high) "∃ " xs:explicitBinders ", " b:term : term =>
expandExplicitBinders ``exi xs b end

def exiu {α : Type} (P : α → Prop) : Prop :=
(∃ (x : α), P x) ∧ (∀ (x y : α), P x → P y → x = y)

section open Lean
macro (priority := high) "∃! " xs:explicitBinders ", " b:term : term =>
expandExplicitBinders ``exiu xs b end

-- Axioms

axiom prop_rec (F : Prop → Prop) {P : Prop} : F true → F false → F P
axiom funext {α β : Type} {f g : α → β} : (∀ x, f x = g x) → f = g

-- Theorems

theorem trivial : true :=
λ _ => id

theorem not_false : not false :=
id

theorem not_not_intro {P : Prop} (h : P) : ¬¬P :=
λ h₁ => h₁ h

theorem not_not_elim {P : Prop} (h : ¬¬P) : P :=
prop_rec (λ x => ¬¬x → x) (λ _ => trivial) (λ h₁ => h₁ not_false) h

theorem contra {P : Prop} (h : ¬¬P) : P :=
not_not_elim h

theorem em {P : Prop} : P ∨ ¬P := id

theorem false_elim {P : Prop} (h : false) : P :=
h P

theorem exfalso {P : Prop} (h : false) : P :=
false_elim h

theorem mt {P Q : Prop} (h₁ : P → Q) (h₂ : ¬Q) : ¬P :=
λ h₃ => h₂ # h₁ h₃

theorem or_intro₁ {P Q : Prop} (h : P) : P ∨ Q :=
λ h₁ => false_elim (h₁ h)

theorem or_intro₂ {P Q : Prop} (h : Q) : P ∨ Q :=
λ _ => h

theorem or_elim {P Q R : Prop} (h₁ : P ∨ Q) (h₂ : P → R) (h₃ : Q → R) : R :=
not_not_elim # λ h₄ => h₄ # h₃ # h₁ # mt h₂ h₄

theorem or_inl {P Q : Prop} (h : P) : P ∨ Q :=
or_intro₁ h

theorem or_inr {P Q : Prop} (h : Q) : P ∨ Q :=
or_intro₂ h

theorem and_intro {P Q : Prop} (h₁ : P) (h₂ : Q) : P ∧ Q :=
λ h₃ => or_elim h₃ (λ h₄ => h₄ h₁) (λ h₄ => h₄ h₂)

theorem and_elim₁ {P Q : Prop} (h : P ∧ Q) : P :=
not_not_elim # λ h₁ => h # or_intro₁ h₁

theorem and_elim₂ {P Q : Prop} (h : P ∧ Q) : Q :=
not_not_elim # λ h₁ => h # or_intro₂ h₁

theorem and_left {P Q : Prop} (h : P ∧ Q) : P :=
and_elim₁ h

theorem and_right {P Q : Prop} (h : P ∧ Q) : Q :=
and_elim₂ h

theorem iff_intro {P Q : Prop} (h₁ : P → Q) (h₂ : Q → P) : P ↔ Q :=
and_intro h₁ h₂

theorem iff_elim₁ {P Q : Prop} (h : P ↔ Q) : P → Q :=
and_elim₁ h

theorem iff_elim₂ {P Q : Prop} (h : P ↔ Q) : Q → P :=
and_elim₂ h

theorem mp {P Q : Prop} (h : P ↔ Q) : P → Q :=
iff_elim₁ h

theorem mpr {P Q : Prop} (h : P ↔ Q) : Q → P :=
iff_elim₂ h

theorem true_ne_false : true ≠ false :=
λ h => h id trivial

theorem not_not {P : Prop} : ¬¬P ↔ P :=
iff_intro not_not_elim not_not_intro

theorem iff_rec (F : Prop → Prop) {P Q : Prop} (h₁ : P ↔ Q) (h₂ : F P) : F Q :=
prop_rec (λ x => (x ↔ Q) → F x → F Q)
(prop_rec (λ x => (true ↔ x) → F true → F x) (λ _ => id)
  (λ h₃ => false_elim # mp h₃ trivial))
(prop_rec (λ x => (false ↔ x) → F false → F x)
  (λ h₃ => false_elim # mpr h₃ trivial) (λ _ => id))
h₁ h₂

theorem eq_refl {α : Type} {x : α} : x = x :=
λ _ => id

theorem rfl {α : Type} {x : α} : x = x :=
eq_refl

theorem eq_symm {α : Type} {x y : α} (h : x = y) : y = x :=
not_not_elim # λ h₁ => mt (h (λ z => z = x)) h₁ rfl

theorem eq_iff {α : Type} {x y : α} : x = y ↔ (∀ (P : α → Prop), P x ↔ P y) :=
iff_intro (λ h P => iff_intro (h P) (eq_symm h P)) (λ h => mp (h (λ z => x = z)) rfl)

theorem eq_rec {α : Type} (P : α → Prop) {x y : α} (h₁ : x = y) (h₂ : P x) : P y :=
h₁ P h₂

theorem imp_refl {P : Prop} : P → P :=
id

theorem iff_refl {P : Prop} : P ↔ P :=
iff_intro id id

theorem or_self {P : Prop} : P ∨ P ↔ P :=
iff_intro (λ h => or_elim h id id) (λ h => or_inl h)

theorem and_self {P : Prop} : P ∧ P ↔ P :=
iff_intro and_left (λ h => and_intro h h)

theorem not_or {P Q : Prop} : ¬(P ∨ Q) ↔ ¬P ∧ ¬Q :=
iff_intro
(λ h => and_intro (λ h₁ => h # or_inl h₁) (λ h₁ => h # or_inr h₁))
(λ h h₁ => or_elim h₁ (λ h₂ => and_left h h₂) (λ h₂ => and_right h h₂))

theorem not_and {P Q : Prop} : ¬(P ∧ Q) ↔ ¬P ∨ ¬Q :=
iff_intro
(λ h => not_not_elim # λ h₁ => (λ h₂ => h # and_intro
  (not_not_elim # and_left h₂) (not_not_elim # and_right h₂)) (mp not_or h₁))
(λ h h₁ => or_elim h (λ h₂ => h₂ # and_left h₁) (λ h₂ => h₂ # and_right h₁))

theorem not_iff_not_self {P : Prop} : ¬(P ↔ ¬P) :=
λ h => or_elim em (λ h₁ => mp h h₁ h₁) (λ h₁ => h₁ # mpr h h₁)

theorem or_symm {P Q : Prop} (h : P ∨ Q) : Q ∨ P :=
or_elim h or_inr or_inl

theorem and_symm {P Q : Prop} (h : P ∧ Q) : Q ∧ P :=
and_intro (and_right h) (and_left h)

theorem iff_symm {P Q : Prop} (h : P ↔ Q) : Q ↔ P :=
iff_intro (mpr h) (mp h)

theorem not_iff {P Q : Prop} : ¬(P ↔ Q) ↔ (¬P ↔ Q) :=
iff_intro
(λ h => iff_intro (λ h₁ => not_not_elim # λ h₂ => h # iff_intro
  (λ h₃ => false_elim # h₁ h₃) (λ h₃ => false_elim # h₂ h₃))
  (λ h₁ h₂ => h # iff_intro (λ _ => h₁) (λ _ => h₂)))
(λ h h₁ => not_iff_not_self # iff_symm # iff_rec (λ x => ¬x ↔ Q) h₁ h)

theorem iff_true_intro {P : Prop} (h : P) : P ↔ true :=
iff_intro (λ _ => trivial) (λ _ => h)

theorem iff_true_elim {P : Prop} (h : P ↔ true) : P :=
mpr h trivial

theorem iff_true {P : Prop} : (P ↔ true) ↔ P :=
iff_intro iff_true_elim iff_true_intro

theorem iff_false_intro {P : Prop} (h : ¬P) : P ↔ false :=
iff_intro h false_elim

theorem iff_false_elim {P : Prop} (h : P ↔ false) : ¬P :=
mp h

theorem iff_false {P : Prop} : (P ↔ false) ↔ ¬P :=
iff_intro iff_false_elim iff_false_intro

theorem prop_eq {P Q : Prop} : P = Q ↔ (P ↔ Q) :=
iff_intro
(λ h => eq_rec (λ x => P ↔ x) h iff_refl)
(λ h => iff_rec (λ x => P = x) h rfl)

theorem iff_rec' (F : Prop → Prop) {P Q : Prop} (h₁ : P ↔ Q) (h₂ : F Q) : F P :=
iff_rec F (iff_symm h₁) h₂

theorem eq_rec' {α : Type} (P : α → Prop) {x y : α} (h₁ : x = y) (h₂ : P y) : P x :=
eq_rec P (eq_symm h₁) h₂

theorem eq_true {P : Prop} : P = true ↔ P :=
iff_rec' (λ x => x ↔ P) prop_eq iff_true

theorem eq_false {P : Prop} : P = false ↔ ¬P :=
iff_rec' (λ x => x ↔ ¬P) prop_eq iff_false

theorem eq_true_or_false {P : Prop} : P = true ∨ P = false :=
iff_rec' (λ x => x ∨ P = false) eq_true #
iff_rec' (λ x => P ∨ x) eq_false em

theorem exi_intro {α : Type} {P : α → Prop} (x : α) (h : P x) : ∃ (x : α), P x :=
λ h₁ => h₁ x h

theorem exi_elim {α : Type} {P : α → Prop} {Q : Prop}
  (h₁ : ∃ (x : α), P x) (h₂ : ∀ (x : α), P x → Q) : Q :=
not_not_elim # λ h₃ => h₁ # λ x => mt (h₂ x) h₃

theorem not_forall {α : Type} {P : α → Prop} : ¬(∀ (x : α), P x) ↔ ∃ (x : α), ¬P x :=
iff_intro
(λ h h₁ => h # λ x => not_not_elim # h₁ x)
(λ h h₁ => h # λ x => not_not_intro # h₁ x)

theorem not_exi {α : Type} {P : α → Prop} : ¬(∃ (x : α), P x) ↔ ∀ (x : α), ¬P x :=
iff_intro
(λ h x h₁ => h # exi_intro x h₁)
(λ h h₁ => exi_elim h₁ h)

theorem exiu_intro' {α : Type} {P : α → Prop} (h₁ : ∃ (x : α), P x)
  (h₂ : ∀ (x y : α), P x → P y → x = y) : ∃! (x : α), P x :=
and_intro h₁ h₂

theorem and_elim {P Q R : Prop} (h₁ : P ∧ Q) (h₂ : P → Q → R) : R :=
h₂ (and_left h₁) (and_right h₁)

theorem iff_elim {P Q R : Prop} (h₁ : P ↔ Q) (h₂ : (P → Q) → (Q → P) → R) : R :=
h₂ (mp h₁) (mpr h₁)

theorem exiu_elim {α : Type} {P : α → Prop} {Q : Prop} (h₁ : ∃! (x : α), P x)
  (h₂ : ∀ (x : α), P x → (∀ (y : α), P y → y = x) → Q) : Q :=
and_elim h₁ # λ h₃ h₄ => exi_elim h₃ # λ x h₅ => h₂ x h₅ # λ y h₆ => h₄ y x h₆ h₅

theorem imp_trans {P Q R : Prop} (h₁ : P → Q) (h₂ : Q → R) : P → R :=
λ h => h₂ # h₁ h

theorem or_assoc {P Q R : Prop} : (P ∨ Q) ∨ R ↔ P ∨ (Q ∨ R) :=
iff_intro
(λ h => or_elim h
  (λ h₁ => or_elim h₁ or_inl (λ h₂ => or_inr # or_inl h₂))
  (λ h₁ => or_inr # or_inr h₁))
(λ h => or_elim h
  (λ h₁ => or_inl # or_inl h₁)
  (λ h₁ => or_elim h₁ (λ h₂ => or_inl # or_inr h₂) or_inr))

theorem and_assoc {P Q R : Prop} : (P ∧ Q) ∧ R ↔ P ∧ (Q ∧ R) :=
iff_intro
(λ h => and_elim h # λ h₁ h₂ =>
  and_intro (and_left h₁) (and_intro (and_right h₁) h₂))
(λ h => and_elim h # λ h₁ h₂ =>
  and_intro (and_intro h₁ (and_left h₂)) (and_right h₂))

theorem or_symm' {P Q : Prop} : P ∨ Q ↔ Q ∨ P :=
iff_intro or_symm or_symm

theorem and_symm' {P Q : Prop} : P ∧ Q ↔ Q ∧ P :=
iff_intro and_symm and_symm

theorem iff_symm' {P Q : Prop} : (P ↔ Q) ↔ (Q ↔ P) :=
iff_intro iff_symm iff_symm

theorem eq_symm' {α : Type} {x y : α} : x = y ↔ y = x :=
iff_intro eq_symm eq_symm

theorem iff_iff_cancel {P Q : Prop} (h : (P ↔ Q) ↔ Q) : P :=
contra # λ h₁ => iff_rec (λ x => ¬((x ↔ Q) ↔ Q))
(iff_symm # iff_false_intro h₁)
(λ h₂ => iff_rec (λ x => ¬(x ↔ Q))
  (iff_intro (λ h₃ => iff_symm # iff_false_intro h₃) mpr)
  (λ h₄ => not_iff_not_self # iff_symm h₄) h₂) h

theorem iff_assoc_aux {P Q R : Prop} (h : (P ↔ Q) ↔ R) : P ↔ (Q ↔ R) :=
iff_elim h # λ h₁ h₂ => iff_intro
(λ h₃ => iff_intro
  (λ h₄ => h₁ # iff_intro (λ _ => h₄) (λ _ => h₃))
  (λ h₄ => mp (h₂ h₄) h₃))
(λ h₃ => iff_iff_cancel # iff_rec (λ x => (P ↔ x) ↔ R) h₃ h)

theorem iff_assoc {P Q R : Prop} : ((P ↔ Q) ↔ R) ↔ (P ↔ (Q ↔ R)) :=
iff_intro iff_assoc_aux
(λ h => iff_symm # iff_rec' (λ x => R ↔ x) iff_symm' #
  iff_assoc_aux # iff_rec' (λ x => x ↔ P) iff_symm' # iff_symm h)

theorem and_trans {P Q R : Prop} (h₁ : P ∧ Q) (h₂ : Q ∧ R) : P ∧ R :=
and_intro (and_left h₁) (and_right h₂)

theorem iff_trans {P Q R : Prop} (h₁ : P ↔ Q) (h₂ : Q ↔ R) : P ↔ R :=
iff_intro (λ h₃ => mp h₂ # mp h₁ h₃) (λ h₃ => mpr h₁ # mpr h₂ h₃)

theorem iff_trans' {P Q R : Prop} (h₁ : P ↔ Q) (h₂ : R ↔ Q) : R ↔ P :=
iff_symm # iff_trans h₁ # iff_symm h₂

theorem iff_trans_with (Q : Prop) {P R : Prop} (h₁ : P ↔ Q) (h₂ : Q ↔ R) : P ↔ R :=
iff_trans h₁ h₂

theorem eq_trans {α : Type} {x y z : α} (h₁ : x = y) (h₂ : y = z) : x = z :=
eq_rec' (λ x => x = z) h₁ h₂

theorem eq_trans' {α : Type} {P Q R : α} (h₁ : P = Q) (h₂ : R = Q) : R = P :=
eq_symm # eq_trans h₁ # eq_symm h₂

theorem eq_trans_with {α : Type} (y : α) {x z : α} (h₁ : x = y) (h₂ : y = z) : x = z :=
eq_trans h₁ h₂

theorem exiu_iff {α : Type} {P : α → Prop} :
  (∃! (x : α), P x) ↔ ∃ (x : α), P x ∧ ∀ (y : α), P y → y = x :=
iff_intro
(λ h => exiu_elim h # λ x h₁ h₂ => exi_intro x # and_intro h₁ h₂)
(λ h => exi_elim h # λ x h₁ => exiu_intro' (exi_intro x # and_left h₁)
  (λ y z h₃ h₄ => and_elim h₁ # λ h₅ h₆ => eq_trans (h₆ y h₃) # eq_symm # h₆ z h₄))

theorem exiu_intro {α : Type} {P : α → Prop} (x : α)
  (h₁ : P x) (h₂ : ∀ (y : α), P y → y = x) : ∃! (x : α), P x :=
mpr exiu_iff # exi_intro x # and_intro h₁ h₂

theorem by_cases (P : Prop) {Q : Prop} (h₁ : P → Q) (h₂ : ¬P → Q) : Q :=
or_elim em h₁ h₂

theorem cpos {P Q : Prop} (h₁ : P) (h₂ : ¬Q → ¬P) : Q :=
contra # λ h₃ => h₂ h₃ h₁

theorem cpos' {P Q : Prop} (h₁ : ¬P) (h₂ : Q → P) : ¬Q :=
mt h₂ h₁

theorem ne_symm {α : Type} {x y : α} (h : x ≠ y) : y ≠ x :=
cpos' h eq_symm

theorem ne_symm' {α : Type} {x y : α} : x ≠ y ↔ y ≠ x :=
iff_intro ne_symm ne_symm

theorem cpos_pp {P Q : Prop} (h₁ : P) (h₂ : ¬Q → ¬P) : Q :=
cpos h₁ h₂

theorem cpos_pn {P Q : Prop} (h₁ : P) (h₂ : Q → ¬P) : ¬Q :=
cpos h₁ # λ h₃ => h₂ # not_not_elim h₃

theorem cpos_np {P Q : Prop} (h₁ : ¬P) (h₂ : ¬Q → P) : Q :=
cpos h₁ # λ h₃ => not_not_intro # h₂ h₃

theorem cpos_nn {P Q : Prop} (h₁ : ¬P) (h₂ : Q → P) : ¬Q :=
cpos' h₁ h₂

theorem hv {P Q : Prop} (h₁ : P) (h₂ : P → Q) : Q :=
h₂ h₁

theorem or_iff_or_left {P Q R : Prop} (h : P ↔ Q) : R ∨ P ↔ R ∨ Q :=
iff_rec' (λ x => R ∨ x ↔ _) h iff_refl

theorem or_iff_or_right {P Q R : Prop} (h : P ↔ Q) : P ∨ R ↔ Q ∨ R :=
iff_rec' (λ x => x ∨ R ↔ _) h iff_refl

theorem or_of_and {P Q : Prop} (h : P ∧ Q) : P ∨ Q :=
or_inl # and_left h

theorem congr_fun {α β : Type} {f g : α → β} {a : α} (h : f = g) : f a = g a :=
eq_rec' (λ x => x a = g a) h rfl

theorem congr_arg {α β : Type} {f : α → β} {a b : α} (h : a = b) : f a = f b :=
eq_rec' (λ x => f x = f b) h rfl

theorem congr {α β : Type} {f g : α → β} {a b : α}
  (h₁ : f = g) (h₂ : a = b) : f a = g b :=
eq_trans (congr_fun h₁) # congr_arg h₂


import .love08_operational_semantics_demo

/-! # LoVe Exercise 8: Operational Semantics -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1: Guarded Command Language

In 1976, E. W. Dijkstra introduced the guarded command language (GCL), a
minimalistic imperative language with built-in nondeterminism. A grammar for one
of its variants is given below:

    S  ::=  x := e       -- assignment
         |  assert b     -- assertion
         |  S ; S        -- sequential composition
         |  S | ⋯ | S    -- nondeterministic choice
         |  loop S       -- nondeterministic iteration

Assignment and sequential composition are as in the WHILE language. The other
statements have the following semantics:

* `assert b` aborts if `b` evaluates to false; otherwise, the command is a
  no-op.

* `S | ⋯ | S` chooses any of the branches and executes it, ignoring the other
  branches.

* `loop S` executes `S` any number of times.

In Lean, GCL is captured by the following inductive type: -/

namespace gcl

inductive stmt (σ : Type) : Type
| assign : string → (σ → ℕ) → stmt
| assert : (σ → Prop) → stmt
| seq    : stmt → stmt → stmt
| choice : list stmt → stmt
| loop   : stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/-! The parameter `σ` abstracts over the state type. It is necessary as a work
around for a Lean bug. Below we will take `σ := state`.

1.1. Complete the following big-step semantics, based on the informal
specification of GCL above. -/

inductive big_step : (stmt state × state) → state → Prop
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| assert {b : state → Prop} {s} (hcond : b s) :
  big_step (stmt.assert b, s) s
| seq {S T s t u} (h₁ : big_step (S, s) t) (h₂ : big_step (T, t) u) :
  big_step (S ;; T, s) u
| choice {Ss s t} (i) (hless : i < list.length Ss)
    (hbody : big_step (list.nth_le Ss i hless, s) t) :
  big_step (stmt.choice Ss, s) t
| loop_base {S s} :
  big_step (stmt.loop S, s) s
| loop_step {S s u} (t) (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.loop S, t) u) :
  big_step (stmt.loop S, s) u

infix ` ⟹ ` : 110 := big_step

/-! 1.2. Prove the following inversion rules, as we did in the lecture for the
WHILE language. -/

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro hasn,
    cases' hasn,
    refl },
  { intro heq,
    rw heq,
    exact big_step.assign }
end

@[simp] lemma big_step_assert {b s t} :
  (stmt.assert b, s) ⟹ t ↔ t = s ∧ b s :=
begin
  apply iff.intro,
  { intro hast,
    cases' hast,
    simp * at * },
  { intros hand,
    cases' hand,
    rw left,
    apply big_step.assert right }
end

@[simp] lemma big_step_seq_iff {S₁ S₂ s t} :
  (stmt.seq S₁ S₂, s) ⟹ t ↔ (∃u, (S₁, s) ⟹ u ∧ (S₂, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro hseq,
    cases' hseq,
    apply exists.intro,
    apply and.intro; assumption },
  { intro hseq,
    cases' hseq,
    cases' h,
    apply big_step.seq; assumption }
end

lemma big_step_loop {S s u} :
  (stmt.loop S, s) ⟹ u ↔
  (s = u ∨ (∃t, (S, s) ⟹ t ∧ (stmt.loop S, t) ⟹ u)) :=
begin
  apply iff.intro,
  { intro hloop,
    cases' hloop,
    { apply or.intro_left,
      refl },
    { apply or.intro_right,
      apply exists.intro t,
      cc } },
  { intro hor,
    cases' hor,
    { rw h,
      apply big_step.loop_base },
    { cases' h,
      cases' h,
      apply big_step.loop_step; assumption } }
end

@[simp] lemma big_step_choice {Ss s t} :
  (stmt.choice Ss, s) ⟹ t ↔
  (∃(i : ℕ) (hless : i < list.length Ss),
     (list.nth_le Ss i hless, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro hchoice,
    cases' hchoice,
    apply exists.intro i,
    apply exists.intro hless,
    assumption },
  { intro hex,
    cases' hex with i hex,
    cases' hex with hless hstep,
    apply big_step.choice; assumption }
end

end gcl

/-! 1.3. Complete the translation below of a deterministic program to a GCL
program, by filling in the `sorry` placeholders below. -/

def gcl_of : stmt → gcl.stmt state
| stmt.skip         := gcl.stmt.assert (λ_, true)
| (stmt.assign x a) :=
  gcl.stmt.assign x a
| (S ;; T)          :=
  gcl_of S ;;
  gcl_of T
| (stmt.ite b S T)  :=
  gcl.stmt.choice [
    gcl.stmt.assert b ;; gcl_of S,
    gcl.stmt.assert (λs, ¬ b s) ;; gcl_of T
  ]
| (stmt.while b S)  :=
  gcl.stmt.loop
    (gcl.stmt.assert b ;;
     gcl_of S) ;;
  gcl.stmt.assert (λs, ¬ b s)

/-! 1.4. In the definition of `gcl_of` above, `skip` is translated to
`assert (λ_, true)`. Looking at the big-step semantics of both constructs, we
can convince ourselves that it makes sense. Can you think of other correct ways
to define the `skip` case? -/

/-! Here are two other possibilities:

* `loop (assert (λ_, false))`
* `assign "x" (λs, s "x")`

There are infinitely many variants, e.g., `seq` of the above two solutions. -/

/-! ## Question 2: Program Equivalence

For this question, we introduce the notion of program equivalence: `S₁ ≈ S₂`. -/

def big_step_equiv (S₁ S₂ : stmt) : Prop :=
∀s t, (S₁, s) ⟹ t ↔ (S₂, s) ⟹ t

infix ` ≈ ` := big_step_equiv

/-! Program equivalence is a equivalence relation, i.e., it is reflexive,
symmetric, and transitive. -/

@[refl] lemma big_step_equiv.refl {S : stmt} :
  S ≈ S :=
fix s t,
show (S, s) ⟹ t ↔ (S, s) ⟹ t, from
  by refl

@[symm] lemma big_step_equiv.symm {S₁ S₂ : stmt}:
  S₁ ≈ S₂ → S₂ ≈ S₁ :=
assume h : S₁ ≈ S₂,
fix s t,
show (S₂, s) ⟹ t ↔ (S₁, s) ⟹ t, from
  iff.symm (h s t)

@[trans] lemma big_step_equiv.trans {S₁ S₂ S₃ : stmt} (h₁₂ : S₁ ≈ S₂)
    (h₂₃ : S₂ ≈ S₃) :
  S₁ ≈ S₃ :=
fix s t,
show (S₁, s) ⟹ t ↔ (S₃, s) ⟹ t, from
  iff.trans (h₁₂ s t) (h₂₃ s t)

/-! 2.1. Prove the following program equivalences. -/

lemma big_step_equiv.skip_assign_id {x} :
  stmt.assign x (λs, s x) ≈ stmt.skip :=
begin
  intros s t,
  apply iff.intro,
  { intro hasn,
    cases' hasn,
    simp * at * },
  { intro hskip,
    cases' hskip,
    simp * at * }
end

lemma big_step_equiv.seq_skip_left {S : stmt} :
  stmt.skip ;; S ≈ S :=
begin
  intros s t,
  apply iff.intro,
  { intro h,
    cases' h,
    cases' h_1,
    assumption },
  { intro h,
    exact big_step.seq big_step.skip h }
end

lemma big_step_equiv.seq_skip_right {S : stmt} :
  S ;; stmt.skip ≈ S :=
begin
  intros s t,
  apply iff.intro,
  { intro h,
    cases' h,
    cases' h_1,
    assumption },
  { intro h,
    exact big_step.seq h big_step.skip }
end

lemma big_step_equiv.ite_seq_while {b} {S : stmt} :
  stmt.ite b (S ;; stmt.while b S) stmt.skip ≈ stmt.while b S :=
begin
  intros s t,
  apply iff.intro,
  { intro hite,
    cases' hite,
    { cases' hite,
      apply big_step.while_true; assumption },
    { cases' hite,
      apply big_step.while_false,
      assumption } },
  { intro while,
    cases' while,
    { apply big_step.ite_true hcond,
      apply big_step.seq; assumption },
    { apply big_step.ite_false hcond,
      exact big_step.skip } }
end

/-! 2.2 (**optional**). Program equivalence can be used to replace subprograms
by other subprograms with the same semantics. Prove the following so-called
congruence rules: -/

lemma big_step_equiv.seq_congr {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  S₁ ;; T₁ ≈ S₂ ;; T₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hseq,
    cases' hseq with _ _ _ _ _ _ _ u _ hS₁ hT₁,
    apply big_step.seq,
    { apply iff.elim_left (hS _ _) hS₁ },
    { apply iff.elim_left (hT _ _) hT₁ } },
  { intros hseq,
    cases' hseq with _ _ _ _ _ _ _ u _ hS₂ hT₂,
    apply big_step.seq,
    { exact iff.elim_right (hS _ _) hS₂ },
    { exact iff.elim_right (hT _ _) hT₂ } }
end

lemma big_step_equiv.ite_congr {b} {S₁ S₂ T₁ T₂ : stmt} (hS : S₁ ≈ S₂)
    (hT : T₁ ≈ T₂) :
  stmt.ite b S₁ T₁ ≈ stmt.ite b S₂ T₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hite,
    cases' hite,
    case ite_true : _ _ _ _ _ hcond hbody {
      apply big_step.ite_true hcond,
      exact iff.elim_left (hS _ _) hbody },
    case ite_false : _ _ _ _ _ hcond hbody {
      apply big_step.ite_false hcond,
      exact iff.elim_left (hT _ _) hbody } },
  { intro hite,
    cases' hite,
    case ite_true : _ _ _ _ _ hcond hbody {
      apply big_step.ite_true hcond,
      exact iff.elim_right (hS _ _) hbody },
    case ite_false : _ _ _ _ _ hcond hbody {
      apply big_step.ite_false hcond,
      exact iff.elim_right (hT _ _) hbody } }
end

lemma denote_equiv.while_congr {b} {S₁ S₂ : stmt} (hS : S₁ ≈ S₂) :
  stmt.while b S₁ ≈ stmt.while b S₂ :=
begin
  intros s t,
  apply iff.intro,
  { intro hwhile,
    induction' hwhile,
    case while_true : b S t u v hcond hbody hrest ih_body ih_rest {
      apply big_step.while_true hcond,
      exact iff.elim_left (hS _ _) hbody,
      exact ih_rest hS },
    case while_false {
      exact big_step.while_false hcond } },
  { intro hwhile,
    induction' hwhile,
    case while_true : b S t u v hcond hbody hrest ih_body ih_rest {
      apply big_step.while_true hcond,
      exact iff.elim_right (hS _ _) hbody,
      exact ih_rest hS },
    case while_false {
      exact big_step.while_false hcond } }
end

end LoVe


import .loop

noncomputable theory

open_locale classical

variables {E : Type*} [finite E] {M M₁ M₂ : matroid E} {B B₁ B₂ X Y Z : set E} {e f x y z : E}

open set
namespace matroid

section dual

/-- The dual of a matroid. Its bases are the complements of bases -/
def dual (M : matroid E) : matroid E :=
{ base := λ B, M.base Bᶜ,
  exists_base' := exists.elim M.exists_base (λ B hb, ⟨Bᶜ, by rwa compl_compl⟩),
  base_exchange' :=
  begin
    rintro B₁ B₂ hB₁ hB₂ x ⟨hx₁,hx₂⟩,
    rw [←mem_compl_iff] at hx₂,
    rw [←not_mem_compl_iff] at hx₁,
    obtain ⟨y,hy,hB⟩ := hB₂.rev_exchange hB₁ ⟨hx₂, hx₁⟩,
    rw [diff_eq_compl_inter, compl_compl] at hy,
    refine ⟨y,hy, _⟩,
    rwa [←union_singleton, compl_union, diff_eq_compl_inter, compl_inter, compl_compl,
      singleton_union, inter_comm, ←diff_eq_compl_inter, ←insert_diff_singleton_comm],
    rintro rfl,
    exact hx₁ hy.2,
  end }

@[simp] lemma dual_base_iff :
  M.dual.base B ↔ M.base Bᶜ :=
iff.rfl

@[simp] lemma dual_dual (M : matroid E):
  M.dual.dual = M :=
by {ext, simp}

lemma dual_inj (h : M₁.dual = M₂.dual) :
  M₁ = M₂ :=
by {ext B, rw [←compl_compl B, ←dual_base_iff, h, dual_base_iff]}

@[simp] lemma dual_inj_iff :
  M₁.dual = M₂.dual ↔ M₁ = M₂ :=
⟨dual_inj, congr_arg _⟩

end dual

lemma dual_indep_iff :
  M.dual.indep X ↔ ∃ B, M.base B ∧ disjoint B X :=
begin
  simp_rw [indep_iff_subset_base, dual_base_iff],
  split,
  { rintro ⟨B, hB, hXB⟩,
    exact ⟨_,hB,by rwa [←subset_compl_iff_disjoint_left, compl_compl]⟩},
  rintro ⟨B,hB,hBX⟩,
  exact ⟨Bᶜ,by rwa compl_compl,subset_compl_iff_disjoint_left.mpr hBX⟩,
end

lemma dual_indep_iff_coindep :
  M.dual.indep X ↔ M.coindep X :=
begin
  rw [dual_indep_iff, ←compl_compl X],
  set Y := Xᶜ with hY,
  simp_rw [disjoint_compl_right_iff_subset, coindep, not_exists, cocircuit],
  rw [(by {split, tauto, tauto} : (∃ (B : set E), M.base B ∧ B ⊆ Y) ↔ (∃ B ⊆ Y, M.base B)),
    base_subset_iff_cl_eq_univ],

  split,
  { intros hYcl K hKY hK,
    rw subset_compl_comm at hKY,
    exact ((hYcl.symm.trans_subset (M.cl_mono hKY)).trans_eq
      (hK.flat.cl)).not_ssubset (hK.ssubset_univ)},
  rintro h, by_contra h',
  rw [←ne.def, subset_hyperplane_iff_cl_ne_univ] at h',
  obtain ⟨H, hH, hYH⟩ := h',
  refine h Hᶜ (compl_subset_compl.mpr hYH) (by rwa compl_compl),
end

lemma dual_indep_iff_r :
  M.dual.indep X ↔ M.r Xᶜ = M.rk :=
begin
  rw [dual_indep_iff],
  split,
  { rintros ⟨B,hB,hBX⟩,
    refine le_antisymm (M.r_le_rk _) _,
    rw ←subset_compl_iff_disjoint_right at hBX,
    rw [←hB.r],
    exact M.r_mono hBX},
  intro hr,
  obtain ⟨B, hB⟩ := M.exists_basis Xᶜ,
  refine ⟨B, hB.indep.base_of_rk_le_card _, subset_compl_iff_disjoint_right.mp hB.subset⟩,
  rw [←hB.indep.r, hB.r, hr],
end

lemma loop.dual_coloop (he : M.loop e) :
  M.dual.coloop e :=
begin
  intros B hB,
  rw dual_base_iff at hB,
  simpa using he.not_mem_indep hB.indep,
end

lemma coloop.dual_loop (he : M.coloop e) :
  M.dual.loop e :=
begin
  rw [loop_def, circuit_def, dual_indep_iff],
  simp only [ssubset_singleton_iff, disjoint_singleton_right, not_exists, not_and, not_not_mem,
    forall_eq],
  exact ⟨he, empty_indep _⟩,
end

@[simp] lemma dual_coloop_if_loop :
  M.dual.coloop e ↔ M.loop e :=
⟨λ h, by {rw ← dual_dual M, exact h.dual_loop}, loop.dual_coloop⟩

@[simp] lemma dual_loop_iff_coloop :
  M.dual.loop e ↔ M.coloop e :=
⟨λ h, by {rw ←dual_dual M, exact h.dual_coloop}, coloop.dual_loop⟩

lemma dual_r_add_rk_eq (M : matroid E) (X : set E) :
  M.dual.r X + M.rk = ncard X + M.r Xᶜ  :=
begin
  set r' : set E → ℤ := λ X, X.ncard + M.r Xᶜ - M.rk with hr',

  have hr'_nonneg : ∀ X, 0 ≤ r' X,
  { intro X, simp_rw hr', linarith [M.rk_le_card_add_r_compl X]},
  have hr'_mono : ∀ X Y, X ⊆ Y → r' X ≤ r' Y,
  { intros X Y hXY, simp_rw hr',
    linarith [M.r_add_card_le_r_add_card_of_subset (compl_subset_compl.mpr hXY),
       ncard_add_ncard_compl X, ncard_add_ncard_compl Y]},
  have hr'_le_card : ∀ X, r' X ≤ X.ncard,
  { intros X, simp_rw hr', linarith [M.r_le_rk Xᶜ] },
  have hr'_submod : ∀ X Y, r' (X ∩ Y) + r' (X ∪ Y) ≤ r' X + r' Y,
  { intros X Y, simp_rw [hr', compl_inter, compl_union],
    linarith [ncard_inter_add_ncard_union X Y, M.r_submod Xᶜ Yᶜ]},

  set M' := matroid_of_int_r r' hr'_nonneg hr'_le_card hr'_mono hr'_submod with hM',

  have hM'M : M' = M.dual,
  { refine eq_of_indep_iff_indep_forall (λ I, _),
    rw [indep_iff_r_eq_card, dual_indep_iff_r], zify,
    simp_rw [hM', matroid_of_int_r_apply, hr'],
    refine ⟨λ h, _, λ h, _⟩,
    all_goals { simp only at h, linarith}},

  rw [←hM'M], zify, simp_rw [hM', matroid_of_int_r_apply, hr'],
  ring,
end

lemma dual_rank_cast_eq (M : matroid E) (X : set E) :
  (M.dual.r X : ℤ) = ncard X + M.r Xᶜ - M.rk :=
by linarith [M.dual_r_add_rk_eq X]

section rank

end rank

end matroid


import .bool
import .arith_lang

namespace arith

open arith
open hidden

-- DATA TYPE

/-
inductive bool_var
| X
| Y
| Z
-/

inductive bool_var
| V (n : ℕ)

open bool_var

-- Test
def X := V 0
def Y := V 1
def Z := V 2

inductive bool_lang : Type
| TT : bool_lang
| FF : bool_lang
| var (v : bool_var) : bool_lang
| conj (e1 e2 : bool_lang) : bool_lang
| disj (e1 e2 : bool_lang) : bool_lang
| neg (e : bool_lang)
| eql (e1 e2 : nt_lang)

-- REFACTOR INTO TEST FILE
open bool_lang
def be1 := TT
def be2 := FF
def ve1 := var X
def be3 := conj be1 be2
def be4 := neg be3

def var_interp_1 : bool_var → boo
| v := boo.tt

/-
def var_interp_2 : bool_var → boo
| X := tt
| Y := ff
| Z := tt
-/

def var_interp_2 : bool_var → boo
| (V 0) := tt
| (V 1) := ff
| (V 2) := tt
| _ := tt

-- OPERATIONS
def eval : bool_lang → (bool_var → boo) → boo
| TT _ := tt
| FF _ := ff
| (var v) i := i v
| (conj e1 e2) i := and (eval e1 i) (eval e2 i)
| (disj e1 e2) i := or (eval e1 i) (eval e2 i)
| (neg e) i := not (eval e i)
| (eql e1 e2) := _ -- evaluate e1, e2, and return boo.tt if equal else boo.ff

-- NOTATIONS
notation b1 * b2 := conj b1 b2
notation b1 + b2 := disj b1 b2
prefix ! := neg

-- REFACTOR INTO TEST FILE
#reduce eval be4
#reduce eval (conj (disj be2 be4) be3)
#check X
#check (var X)
#reduce eval ((var X) * (var Y)) var_interp_1
#reduce eval ((var X) * (var Y)) var_interp_2

-- REFACTOR INTO TEST FILE
#reduce eval ((be2 + be4) * be3)

/-
How do we know that eval terminates?
-/

-- Non-terminating functions would be fatal
def bad : ℕ → false
| n := bad n    -- non-terminating recursion
#check (bad 3)  -- Yikes, a proof of false!

-- PROPERTIES?

/-
A property of an expression, e, is that e
evaluates to true. Let's call this property
evaluates_to_true.
-/
def evaluates_to_true : bool_lang → Prop
| e := eval e = boo.tt
/-
This definition broke when we added an interpretation,
i, as a second argument to eval.
-/

example : evaluates_to_true TT :=
begin
  unfold evaluates_to_true,
  trivial,
end
--ditto last comment

example : evaluates_to_true (TT * FF) :=
begin
  unfold evaluates_to_true,
  simp [eval],
  apply rfl,  -- false
end
--ditto last comment

-- Property of an individual expression
example : evaluates_to_true (TT * TT) :=
begin
  unfold evaluates_to_true,
  simp [eval],
  apply rfl,  -- false
end
--ditto last comment

-- Property of the language as a whole:
-- evaluation is deterministic.

-- HOMEWORK

/-
What deterministic means is that if you evaluate the same
expression twice (in the same environment) that you'll get
the same answer. A language with a statement that returns
a truly random number wouldn't have this property. Show that
evaluation is deterministic for our "Bool" language.
-/

def eval_is_deterministic :
  ∀ (e : bool_lang) (i : bool_var → boo) (b1 b2 : boo),
  b1 = (eval e i) →
  b2 = (eval e i) →
  b1 = b2 :=
begin
  intros e i b1 b2 h1 h2,
  rw h1,
  rw h2,
end

def nat_eq : ℕ → ℕ → bool
| nat.zero nat.zero := bool.tt
| nat.zero _ := bool.ff
| _ nat.zero := bool.ff
| (nat.succ n') (nat.succ m') := nat_eq n' m'

#reduce nat_eq 0 0
#reduce nat_eq 0 1
#reduce nat_eq 1 0
#reduce nat_eq 1 1

def var_eq : bool_var → bool_var → bool
| (V n1) (V n2) := nat_eq n1 n2

#reduce var_eq X X
#reduce var_eq X Y
#reduce var_eq X Z
#reduce var_eq Y X
#reduce var_eq Z X
#reduce  var_eq Z Y
#reduce var_eq Z Z

def override : (bool_var → boo) → bool_var → boo → (bool_var → boo) :=
λ i v' b,
  λ v, if (var_eq v v') then b else (i v)

/-
def var_interp_1 : bool_var → boo
| v := boo.tt
-/

def init := var_interp_1

#reduce init X
#reduce init Y
#reduce init Z

def st_1 := override init X ff

#reduce st_1 X
#reduce st_1 Y
#reduce st_1 Z

def st_2 := override (st_1) Z ff

#reduce st_2 X
#reduce st_2 Y
#reduce st_2 Z

end arith