/-
Copyright (c) 2022 Vincent Beffara. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Vincent Beffara
-/
import analysis.analytic.isolated_zeros
import analysis.complex.cauchy_integral
import analysis.complex.abs_max

/-!
# The open mapping theorem for holomorphic functions

This file proves the open mapping theorem for holomorphic functions, namely that an analytic
function on a preconnected set of the complex plane is either constant or open. The main step is to
show a local version of the theorem that states that if `f` is analytic at a point `z₀`, then either
it is constant in a neighborhood of `z₀` or it maps any neighborhood of `z₀` to a neighborhood of
its image `f z₀`. The results extend in higher dimension to `g : E → ℂ`.

The proof of the local version on `ℂ` goes through two main steps: first, assuming that the function
is not constant around `z₀`, use the isolated zero principle to show that `‖f z‖` is bounded below
on a small `sphere z₀ r` around `z₀`, and then use the maximum principle applied to the auxiliary
function `(λ z, ‖f z - v‖)` to show that any `v` close enough to `f z₀` is in `f '' ball z₀ r`. That
second step is implemented in `diff_cont_on_cl.ball_subset_image_closed_ball`.

## Main results

* `analytic_at.eventually_constant_or_nhds_le_map_nhds` is the local version of the open mapping
  theorem around a point;
* `analytic_on.is_constant_or_is_open` is the open mapping theorem on a connected open set.
-/

open set filter metric complex
open_locale topology

variables {E : Type*} [normed_add_comm_group E] [normed_space ℂ E] {U : set E}
  {f : ℂ → ℂ} {g : E → ℂ} {z₀ w : ℂ} {ε r m : ℝ}

/-- If the modulus of a holomorphic function `f` is bounded below by `ε` on a circle, then its range
contains a disk of radius `ε / 2`. -/
lemma diff_cont_on_cl.ball_subset_image_closed_ball (h : diff_cont_on_cl ℂ f (ball z₀ r))
  (hr : 0 < r) (hf : ∀ z ∈ sphere z₀ r, ε ≤ ‖f z - f z₀‖) (hz₀ : ∃ᶠ z in 𝓝 z₀, f z ≠ f z₀) :
  ball (f z₀) (ε / 2) ⊆ f '' closed_ball z₀ r :=
begin
  /- This is a direct application of the maximum principle. Pick `v` close to `f z₀`, and look at
  the function `λ z, ‖f z - v‖`: it is bounded below on the circle, and takes a small value at `z₀`
  so it is not constant on the disk, which implies that its infimum is equal to `0` and hence that
  `v` is in the range of `f`. -/
  rintro v hv,
  have h1 : diff_cont_on_cl ℂ (λ z, f z - v) (ball z₀ r) := h.sub_const v,
  have h2 : continuous_on (λ z, ‖f z - v‖) (closed_ball z₀ r),
    from continuous_norm.comp_continuous_on (closure_ball z₀ hr.ne.symm ▸ h1.continuous_on),
  have h3 : analytic_on ℂ f (ball z₀ r) := h.differentiable_on.analytic_on is_open_ball,
  have h4 : ∀ z ∈ sphere z₀ r, ε / 2 ≤ ‖f z - v‖,
    from λ z hz, by linarith [hf z hz, (show ‖v - f z₀‖ < ε / 2, from mem_ball.mp hv),
      norm_sub_sub_norm_sub_le_norm_sub (f z) v (f z₀)],
  have h5 : ‖f z₀ - v‖ < ε / 2 := by simpa [← dist_eq_norm, dist_comm] using mem_ball.mp hv,
  obtain ⟨z, hz1, hz2⟩ : ∃ z ∈ ball z₀ r, is_local_min (λ z, ‖f z - v‖) z,
    from exists_local_min_mem_ball h2 (mem_closed_ball_self hr.le) (λ z hz, h5.trans_le (h4 z hz)),
  refine ⟨z, ball_subset_closed_ball hz1, sub_eq_zero.mp _⟩,
  have h6 := h1.differentiable_on.eventually_differentiable_at (is_open_ball.mem_nhds hz1),
  refine (eventually_eq_or_eq_zero_of_is_local_min_norm h6 hz2).resolve_left (λ key, _),
  have h7 : ∀ᶠ w in 𝓝 z, f w = f z := by { filter_upwards [key] with h; field_simp },
  replace h7 : ∃ᶠ w in 𝓝[≠] z, f w = f z := (h7.filter_mono nhds_within_le_nhds).frequently,
  have h8 : is_preconnected (ball z₀ r) := (convex_ball z₀ r).is_preconnected,
  have h9 := h3.eq_on_of_preconnected_of_frequently_eq analytic_on_const h8 hz1 h7,
  have h10 : f z = f z₀ := (h9 (mem_ball_self hr)).symm,
  exact not_eventually.mpr hz₀ (mem_of_superset (ball_mem_nhds z₀ hr) (h10 ▸ h9))
end

/-- A function `f : ℂ → ℂ` which is analytic at a point `z₀` is either constant in a neighborhood
of `z₀`, or behaves locally like an open function (in the sense that the image of every neighborhood
of `z₀` is a neighborhood of `f z₀`, as in `is_open_map_iff_nhds_le`). For a function `f : E → ℂ`
the same result holds, see `analytic_at.eventually_constant_or_nhds_le_map_nhds`. -/
lemma analytic_at.eventually_constant_or_nhds_le_map_nhds_aux (hf : analytic_at ℂ f z₀) :
  (∀ᶠ z in 𝓝 z₀, f z = f z₀) ∨ (𝓝 (f z₀) ≤ map f (𝓝 z₀)) :=
begin
  /- The function `f` is analytic in a neighborhood of `z₀`; by the isolated zeros principle, if `f`
  is not constant in a neighborhood of `z₀`, then it is nonzero, and therefore bounded below, on
  every small enough circle around `z₀` and then `diff_cont_on_cl.ball_subset_image_closed_ball`
  provides an explicit ball centered at `f z₀` contained in the range of `f`. -/
  refine or_iff_not_imp_left.mpr (λ h, _),
  refine (nhds_basis_ball.le_basis_iff (nhds_basis_closed_ball.map f)).mpr (λ R hR, _),
  have h1 := (hf.eventually_eq_or_eventually_ne analytic_at_const).resolve_left h,
  have h2 : ∀ᶠ z in 𝓝 z₀, analytic_at ℂ f z := (is_open_analytic_at ℂ f).eventually_mem hf,
  obtain ⟨ρ, hρ, h3, h4⟩ : ∃ ρ > 0, analytic_on ℂ f (closed_ball z₀ ρ) ∧
      ∀ z ∈ closed_ball z₀ ρ, z ≠ z₀ → f z ≠ f z₀,
    by simpa only [set_of_and, subset_inter_iff] using
      nhds_basis_closed_ball.mem_iff.mp (h2.and (eventually_nhds_within_iff.mp h1)),
  replace h3 : diff_cont_on_cl ℂ f (ball z₀ ρ),
    from ⟨h3.differentiable_on.mono ball_subset_closed_ball,
      (closure_ball z₀ hρ.lt.ne.symm).symm ▸ h3.continuous_on⟩,
  let r := ρ ⊓ R,
  have hr : 0 < r := lt_inf_iff.mpr ⟨hρ, hR⟩,
  have h5 : closed_ball z₀ r ⊆ closed_ball z₀ ρ := closed_ball_subset_closed_ball inf_le_left,
  have h6 : diff_cont_on_cl ℂ f (ball z₀ r) := h3.mono (ball_subset_ball inf_le_left),
  have h7 : ∀ z ∈ sphere z₀ r, f z ≠ f z₀,
    from λ z hz, h4 z (h5 (sphere_subset_closed_ball hz)) (ne_of_mem_sphere hz hr.ne.symm),
  have h8 : (sphere z₀ r).nonempty := normed_space.sphere_nonempty.mpr hr.le,
  have h9 : continuous_on (λ x, ‖f x - f z₀‖) (sphere z₀ r),
    from continuous_norm.comp_continuous_on
      ((h6.sub_const (f z₀)).continuous_on_ball.mono sphere_subset_closed_ball),
  obtain ⟨x, hx, hfx⟩ := (is_compact_sphere z₀ r).exists_forall_le h8 h9,
  refine ⟨‖f x - f z₀‖ / 2, half_pos (norm_sub_pos_iff.mpr (h7 x hx)), _⟩,
  exact (h6.ball_subset_image_closed_ball hr (λ z hz, hfx z hz) (not_eventually.mp h)).trans
    (image_subset f (closed_ball_subset_closed_ball inf_le_right))
end

/-- The *open mapping theorem* for holomorphic functions, local version: is a function `g : E → ℂ`
is analytic at a point `z₀`, then either it is constant in a neighborhood of `z₀`, or it maps every
neighborhood of `z₀` to a neighborhood of `z₀`. For the particular case of a holomorphic function on
`ℂ`, see `analytic_at.eventually_constant_or_nhds_le_map_nhds_aux`. -/
lemma analytic_at.eventually_constant_or_nhds_le_map_nhds {z₀ : E} (hg : analytic_at ℂ g z₀) :
  (∀ᶠ z in 𝓝 z₀, g z = g z₀) ∨ (𝓝 (g z₀) ≤ map g (𝓝 z₀)) :=
begin
  /- The idea of the proof is to use the one-dimensional version applied to the restriction of `g`
  to lines going through `z₀` (indexed by `sphere (0 : E) 1`). If the restriction is eventually
  constant along each of these lines, then the identity theorem implies that `g` is constant on any
  ball centered at `z₀` on which it is analytic, and in particular `g` is eventually constant. If on
  the other hand there is one line along which `g` is not eventually constant, then the
  one-dimensional version of the open mapping theorem can be used to conclude. -/
  let ray : E → ℂ → E := λ z t, z₀ + t • z,
  let gray : E → ℂ → ℂ := λ z, (g ∘ ray z),
  obtain ⟨r, hr, hgr⟩ := is_open_iff.mp (is_open_analytic_at ℂ g) z₀ hg,
  have h1 : ∀ z ∈ sphere (0 : E) 1, analytic_on ℂ (gray z) (ball 0 r),
  { refine λ z hz t ht, analytic_at.comp _ _,
    { exact hgr (by simpa [ray, norm_smul, mem_sphere_zero_iff_norm.mp hz] using ht) },
    { exact analytic_at_const.add
      ((continuous_linear_map.smul_right (continuous_linear_map.id ℂ ℂ) z).analytic_at t) } },
  by_cases (∀ z ∈ sphere (0 : E) 1, ∀ᶠ t in 𝓝 0, gray z t = gray z 0),
  { left, -- If g is eventually constant along every direction, then it is eventually constant
    refine eventually_of_mem (ball_mem_nhds z₀ hr) (λ z hz, _),
    refine (eq_or_ne z z₀).cases_on (congr_arg g) (λ h', _),
    replace h' : ‖z - z₀‖ ≠ 0 := by simpa only [ne.def, norm_eq_zero, sub_eq_zero],
    let w : E := ‖z - z₀‖⁻¹ • (z - z₀),
    have h3 : ∀ t ∈ ball (0 : ℂ) r, gray w t = g z₀,
    { have e1 : is_preconnected (ball (0 : ℂ) r) := (convex_ball 0 r).is_preconnected,
      have e2 : w ∈ sphere (0 : E) 1 := by simp [w, norm_smul, h'],
      specialize h1 w e2,
      apply h1.eq_on_of_preconnected_of_eventually_eq analytic_on_const e1 (mem_ball_self hr),
      simpa [gray, ray] using h w e2 },
    have h4 : ‖z - z₀‖ < r := by simpa [dist_eq_norm] using mem_ball.mp hz,
    replace h4 : ↑‖z - z₀‖ ∈ ball (0 : ℂ) r := by simpa only [mem_ball_zero_iff, norm_eq_abs,
      abs_of_real, abs_norm_eq_norm],
    simpa only [gray, ray, smul_smul, mul_inv_cancel h', one_smul, add_sub_cancel'_right,
      function.comp_app, coe_smul] using h3 ↑‖z - z₀‖ h4 },
  { right, -- Otherwise, it is open along at least one direction and that implies the result
    push_neg at h,
    obtain ⟨z, hz, hrz⟩ := h,
    specialize h1 z hz 0 (mem_ball_self hr),
    have h7 := h1.eventually_constant_or_nhds_le_map_nhds_aux.resolve_left hrz,
    rw [show gray z 0 = g z₀, by simp [gray, ray], ← map_compose] at h7,
    refine h7.trans (map_mono _),
    have h10 : continuous (λ (t : ℂ), z₀ + t • z),
      from continuous_const.add (continuous_id'.smul continuous_const),
    simpa using h10.tendsto 0 }
end

/-- The *open mapping theorem* for holomorphic functions, global version: if a function `g : E → ℂ`
is analytic on a connected set `U`, then either it is constant on `U`, or it is open on `U` (in the
sense that it maps any open set contained in `U` to an open set in `ℂ`). -/
theorem analytic_on.is_constant_or_is_open (hg : analytic_on ℂ g U) (hU : is_preconnected U) :
  (∃ w, ∀ z ∈ U, g z = w) ∨ (∀ s ⊆ U, is_open s → is_open (g '' s)) :=
begin
  by_cases ∃ z₀ ∈ U, ∀ᶠ z in 𝓝 z₀, g z = g z₀,
  { obtain ⟨z₀, hz₀, h⟩ := h,
    exact or.inl ⟨g z₀, hg.eq_on_of_preconnected_of_eventually_eq analytic_on_const hU hz₀ h⟩ },
  { push_neg at h,
    refine or.inr (λ s hs1 hs2, is_open_iff_mem_nhds.mpr _),
    rintro z ⟨w, hw1, rfl⟩,
    exact (hg w (hs1 hw1)).eventually_constant_or_nhds_le_map_nhds.resolve_left (h w (hs1 hw1))
      (image_mem_map (hs2.mem_nhds hw1)) }
end


import ..dual

/-
Basic matroid constructions; free/loopy matroids, truncation, dual, etc.
-/
open_locale classical

open set
namespace matroid

noncomputable theory

section free_loopy

variables {E : Type*} {X I B : set E} {r s t : ℕ} [finite E] {M : matroid E}

/-- The matroid whose only basis is the whole ground set -/
def free_on (E : Type*) : matroid E :=
⟨λ B, B = univ, ⟨_,rfl⟩, λ B B' hB hB' a ha, (ha.2 (by convert mem_univ a)).elim⟩

/-- The matroid whose only basis is empty -/
def loopy_on (E : Type*) : matroid E :=
⟨λ B, B = ∅, ⟨_,rfl⟩, λ B B' hB hB' a ha, by {rw hB at ha, exact (not_mem_empty _ ha.1).elim}⟩

lemma free_indep (I : set E) :
  (free_on E).indep I  :=
⟨univ, rfl, subset_univ _⟩

lemma univ_indep_iff_free {M : matroid E} :
   indep M univ ↔ M = free_on E :=
begin
  simp_rw [matroid.ext_iff, free_on, indep, univ_subset_iff, exists_eq_right],
  rw [function.funext_iff],
  simp_rw [eq_iff_iff],
  exact ⟨λ h a, ⟨λ ha, ha.eq_of_subset_base h (subset_univ _), λ ha, by rwa ha⟩, λ h, by rw h⟩,
end

@[simp] lemma free_r (X : set E) :
  (free_on E).r X = X.ncard :=
by {rw ← indep_iff_r_eq_card, apply free_indep}

@[simp] lemma loopy_on_base_iff_empty :
  (loopy_on E).base X ↔ X = ∅ :=
iff.rfl

lemma loopy_on.empty_base (E : Type*) :
  (loopy_on E).base ∅ :=
@rfl _ ∅

@[simp] lemma loopy_on_indep_iff_empty :
  (loopy_on E).indep X ↔ X = ∅ :=
by simp only [indep_iff_subset_base, loopy_on_base_iff_empty, exists_eq_left, subset_empty_iff]

@[simp] lemma loopy_matroid_indep_iff_empty :
  (loopy_on E).indep X ↔ X = ∅ :=
by simp only [loopy_on, indep, exists_eq_left, subset_empty_iff]

@[simp] lemma empty_base_iff_loopy_on :
  M.base ∅ ↔ M = loopy_on E :=
begin
  refine ⟨λ h, _, by {rintro rfl, rw loopy_on_base_iff_empty}⟩,
  ext B,
  refine ⟨λ hB, (h.eq_of_subset_base hB (empty_subset _)).symm, λ hB, _⟩,
  rwa ←(loopy_on.empty_base E).eq_of_subset_base hB (empty_subset _),
end

lemma univ_loops_iff_loopy_on :
  M = loopy_on E ↔ M.cl ∅ = univ :=
begin
  simp_rw [←empty_base_iff_loopy_on, set.ext_iff, ←loop_iff_mem_cl_empty, mem_univ, iff_true,
    loop_iff_dep],
  refine ⟨λ hB x hx, singleton_ne_empty x (hB.eq_of_subset_indep hx (empty_subset _)).symm, λ h, _⟩,
  obtain ⟨B, hB⟩ := M.exists_base,
  convert hB,
  rw [eq_comm, eq_empty_iff_forall_not_mem],
  exact λ x hxB, h x (hB.indep.subset (singleton_subset_iff.mpr hxB)),
end

lemma loopy_iff_univ_r_zero :
  M = loopy_on E ↔ M.r univ = 0 :=
begin
  rw univ_loops_iff_loopy_on,
  refine ⟨λ h, by {rw ← h, simp}, λ h, _⟩,
  rwa [r_zero_iff_subset_loops, univ_subset_iff] at h,
end

end free_loopy

section truncation

variables {E : Type*} [finite E] {s t : ℕ} {I : set E} {M : matroid E}

/-- Truncate a matroid to rank `t`. Every rank above `t` drops to `t`. -/
def tr (M : matroid E) (t : ℕ) :=
  matroid_of_r (λ X, min t (M.r X))
  (λ X, (min_le_right _ _).trans (M.r_le_card _))
  (λ X Y hXY, le_min (min_le_left _ _) ((min_le_right _ _).trans (M.r_mono hXY)))
  (λ X Y,
  (begin
    wlog hXY : M.r X ≤ M.r Y generalizing X Y,
    { obtain (h | h) := le_or_lt (M.r X) (M.r Y),
      { exact this _ _ h},
      rw [add_comm (min t (M.r X)), inter_comm, union_comm],
      exact this _ _ h.le},
    cases le_or_lt t (M.r Y) with ht ht,
    { rw [min_eq_left ht, min_eq_left (ht.trans (M.r_le_r_union_right _ _))],
      linarith [min_le_min (rfl.le : t ≤ t) (M.r_inter_left_le_r X Y)]},
    rw [min_eq_right_of_lt ht, min_eq_right (hXY.trans ht.le)],
    linarith [min_le_right t (M.r (X ∩ Y)), min_le_right t (M.r (X ∪ Y)), M.r_submod X Y],
  end))

@[simp] lemma tr_r (t : ℕ) (X : set E) :
  (M.tr t).r X = min t (M.r X) :=
by simp only [tr, matroid_of_r_apply]

@[simp] lemma tr_indep_iff :
  (M.tr t).indep I ↔ M.indep I ∧ I.ncard ≤ t :=
begin
  simp_rw [indep_iff_r_eq_card, tr_r],
  obtain (hle | hlt) := le_or_lt t (M.r I),
  { rw [min_eq_left hle],
    exact ⟨by {rintro rfl, exact ⟨hle.antisymm' (M.r_le_card _), rfl.le⟩},
      λ h, (hle.trans_eq h.1).antisymm h.2⟩},
  rw [min_eq_right hlt.le],
  simp only [iff_self_and],
  exact λ h, h.symm.trans_le hlt.le,
end

end truncation

section uniform

variables {E : Type*} [finite E] {s t r : ℕ} {M : matroid E}

/-- The matroid whose bases are the `r`-sets. If `E` is smaller than `r`, then this is the free
  matroid. TODO : define without rank  -/
def unif (E : Type*) [finite E] (r : ℕ) : matroid E :=
  tr (free_on E) r

/-- the rank-a uniform matroid on b elements with ground set `fin' b`. Free if `b ≤ a`. -/
def canonical_unif (a b : ℕ) :
  matroid (fin b) :=
unif (fin b) a

@[simp] lemma unif_r (X : set E) :
  (unif E r).r X = min r (X.ncard) :=
by rw [unif, tr_r r, free_r]

lemma unif_rk (hr : r ≤ nat.card E) :
  (unif E r).rk = r :=
by rw [rk, unif_r univ, ncard_univ, min_eq_left hr]

@[simp] lemma unif_indep_iff {I : set E}:
  (unif E r).indep I ↔ I.ncard ≤ r :=
by rw [indep_iff_r_eq_card, unif_r, min_eq_right_iff]

lemma unif_free_iff_card_le_r :
  nat.card E ≤ r ↔ unif E r = free_on E :=
by rw [←univ_indep_iff_free, unif_indep_iff, ncard_univ]

lemma unif_base_iff {B : set E} (hr : r ≤ nat.card E):
  (unif E r).base B ↔ B.ncard = r :=
begin
  simp_rw [base_iff_maximal_indep, unif_indep_iff],
  rw [←ncard_univ] at hr,
  refine ⟨λ h, h.1.antisymm _, _⟩,
  { obtain ⟨Y, hXY, - ,rfl⟩ := exists_intermediate_set' h.1 hr (subset_univ _),
    rw h.2 Y rfl.le hXY},
  rintro rfl,
  exact ⟨rfl.le, λ I hIX hXI, eq_of_subset_of_ncard_le hXI hIX⟩,
end

@[simp] lemma unif_circuit_iff {C : set E}:
  (unif E r).circuit C ↔ C.ncard = r + 1 :=
begin
  simp_rw [circuit_def, unif_indep_iff, not_le],
  refine ⟨λ h, _,λ h, _⟩,
  { obtain ⟨e,he⟩ := nonempty_of_ncard_ne_zero (ne_zero_of_lt h.1),
    have hCe := h.2 (C \ {e}) (diff_singleton_ssubset he),
    rw [←add_le_add_iff_right 1, ncard_diff_singleton_add_one he] at hCe,
    exact hCe.antisymm (nat.add_one_le_iff.mpr h.1)},
  refine ⟨by linarith, λ I hIC, (add_le_add_iff_right 1).mp _⟩,
  rw [←h, ←nat.lt_iff_add_one_le],
  exact ncard_lt_ncard hIC,
end

@[simp] lemma unif_flat_iff {F : set E} :
  (unif E r).flat F ↔ F = univ ∨ F.ncard < r :=
begin
  simp_rw [flat_iff_forall_circuit, unif_circuit_iff],
  refine ⟨λ h, (lt_or_le F.ncard r).elim or.inr (λ hle, or.inl _),_⟩,
  { obtain ⟨X,hXF,rfl⟩ := exists_smaller_set F r hle,
    refine eq_univ_of_forall (λ x, (em (x ∈ X)).elim (λ h', hXF h') (λ hxF, _)),
    refine h (insert x X) x (by rw [ncard_insert_of_not_mem hxF]) (mem_insert _ _) _,
    simp only [insert_diff_of_mem, mem_singleton, diff_singleton_subset_iff],
    exact hXF.trans (subset_insert _ _)},
  rintro (rfl | hlt),
  { exact λ _ _ _ _ _, mem_univ _},
  refine λ C e hcard heC hCF, _,
  have hlt' := (ncard_le_of_subset hCF).trans_lt hlt,
  rw [nat.lt_iff_add_one_le, ncard_diff_singleton_add_one heC, hcard] at hlt',
  simpa using hlt',
end

lemma unif_dual (E : Type*) [finite E] {r₁ r₂ : ℕ} (h : r₁ + r₂ = nat.card E) :
  (unif E r₁).dual = unif E r₂ :=
begin
  ext X,
  rw [unif_base_iff (le_of_add_le_right h.le), dual_base_iff,
    unif_base_iff (le_of_add_le_left h.le)],
  zify at *, split;
  { intro h, linarith [ncard_add_ncard_compl X]},
end

end uniform

end matroid

/-def dual (M : matroid E) : matroid E :=
{ base := λ X, M.base (univ \ X) ,
  exists_base' :=
    begin
      cases M.exists_base' with B hB,
      use (univ \ B),
      simp,
      exact hB,
    end,
  base_exchange' := λ X Y hX hY a ha,
    begin
      have h3 : a ∈ univ \ Y \ (univ \ X),
      { simp only [mem_diff, mem_univ, true_and, not_not_mem],
        refine ⟨ha.2, ha.1⟩ },
      have h2 := M.base_exchange' (univ \ Y) (univ \ X) hY hX a h3,
      simp at *,
      rcases h2 with ⟨b, ⟨hb1, hb2⟩⟩,
      use b,
      refine ⟨⟨hb1.2, hb1.1⟩, _⟩,
      have h4 := M.base_exchange' (univ \ X) (univ \ Y) hX hY b,
      have h5 : b ∈ univ \ X \ (univ \ Y),
      { simp,
        exact hb1 },
      specialize h4 h5,
      rcases h4 with ⟨x, ⟨hx1, hx2⟩⟩,
      simp at hx1,

      sorry,
    end }

lemma unif_dual {r : ℕ} (hr : 0 ≤ r) (hrn : r ≤ nat.card (univ : set E)) :
  dual (unif E r)
  = unif E (nat.card (univ : set E) - r) :=
begin
  ext X,
  rw [dual_r, unif_r hr, unif_r hr,
      unif_r (_ : 0 ≤ nat.card univ - r), min_eq_left hrn,
      compl_size, ← min_add_add_left, ← min_sub_sub_right, min_comm],
  congr,
  all_goals {linarith},
end

def circuit_matroid_on (E : Type*) [fintype E]: matroid E :=
  unif E (type_size E - 1)

@[simp] lemma circuit_matroid_r (hE : nonempty E) (X : set E) :
  (circuit_matroid_on E).r X = min (nat.card (univ : set E) - 1) (nat.card X) :=
by {convert unif_r  _ X, linarith [one_le_type_size_of_nonempty hE]}

lemma circuit_matroid_iff_univ_circuit (hE : nonempty E){M : matroid E} :
  M = circuit_matroid_on E ↔ is_circuit M univ :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  rw [circuit_iff_r, h],
  simp_rw circuit_matroid_r hE,
  from ⟨min_eq_left (by linarith), λ Y hY, min_eq_right (by linarith [size_strict_monotone hY])⟩,
  ext X, rw circuit_matroid_r hE,
  rw circuit_iff_r at h,
  have h' : X ⊂ univ ∨ X = univ := _ ,
  rcases h' with (h' | rfl ),
  { rw [h.2 X h', eq_comm], from min_eq_right (by linarith [size_strict_monotone h'])},
  { rw [h.1, eq_comm], from min_eq_left (by linarith)},
  from subset_ssubset_or_eq (subset_univ _),
end

lemma unif_simple_iff (E : Type*)[fintype E] (hE : 2 ≤ type_size E){r : ℕ} (hr : 0 ≤ r) :
  (unif.unif E r).is_simple ↔ 2 ≤ r :=
begin
  rw type_size_eq at hE,
  refine ⟨λ h, by_contra (λ hn, _), λ h, _⟩,
  { push_neg at hn,
    obtain ⟨X,hX⟩ := has_set_of_size  (by norm_num : (0 : ℤ) ≤ 2) hE,
    have h' := (h X (subset_univ X) (le_of_eq hX)),
    rw [indep_iff_r, hX] at h',
    have h'' := rank_le_univ (unif E r) X,

    rw [h', unif_r hr, min_eq_left] at h'';
    linarith},
  rintros X - hX,
  rw [indep_iff_r, unif_r hr, min_eq_right],
  -- linarith fails here - why???
  exact le_trans hX h,
end

lemma unif_loopless_iff (E : Type*) [fintype E] {r : ℕ} (hr : 0 ≤ r)
(hE : 1 ≤ type_size E):
  (unif.unif E r).is_loopless ↔ 1 ≤ r :=
begin
  simp_rw [loopless_iff_all_nonloops, nonloop_iff_r],
  by_cases (r ≤ 0),
  { rw [le_antisymm h hr],
    norm_num,
    obtain ⟨e⟩ :=  nonempty_of_type_size_pos hE,
    exact ⟨e, by {rw [unif_r, min_eq_left (size_nonneg _)]; norm_num,  }⟩},
  have : 1 ≤ r, rwa not_le at h,
  convert (iff_true _).mpr _, simpa only [iff_true, eq_iff_iff],
  intro e,
  rw unif_r hr,
  rw [size_singleton, min_eq_right this],
end

lemma unif_simple_of_two_le_r (E : Type*)[fintype E] {r : ℕ} (hr : 2 ≤ r) :
  (unif.unif E r).is_simple :=
begin
  rintros X - hX,
  rw [indep_iff_r, unif_r (by linarith : 0 ≤ r), min_eq_right],
  exact le_trans hX hr,
end
-/

/-!
  The canonical uniform matroid is defined to have a fixed ground set.
-/

/-lemma canonical_unif_simple_iff (ha : 0 ≤ a) (hb : 2 ≤ b) :
  (canonical_unif a b).is_simple ↔ 2 ≤ a :=
begin
 convert unif.unif_simple_iff (fin' b) _ ha,
 rwa size_fin' b (by linarith : 0 ≤ b),
end

lemma canonical_unif_loopless_iff (ha : 0 ≤ a) (hb : 1 ≤ b):
  (canonical_unif a b).loopless ↔ 1 ≤ a :=
begin
  convert unif.unif_loopless_iff (fin' b) _ _,
  assumption,
  convert hb, rw size_fin' b (by linarith : 0 ≤ b),
end
lemma canonical_unif_simple_of_two_le_r (ha : 2 ≤ a) :
  (canonical_unif a b).is_simple :=
unif.unif_simple_of_two_le_r _ ha-/

-- @[simp] lemma canonical_unif_r (ha : 0 ≤ a) (X : set (fin b)) :
--   (canonical_unif a b).r X = min a (X.ncard) :=
-- unif.unif_r ha _


import game.limits.L01defs
import game.limits.seq_limSeqSub

open real

namespace xena -- hide

notation `|` x `|` := abs x -- hide

/-
Use previous results to obtain the limit of a product in the general case.
Work in progress.
-/

/- Lemma
If $\lim_{n \to \infty} a_n = \alpha$ and $\lim_{n \to \infty} b_n = \beta$, then
$\lim_{n \to \infty} (a_n * b_n) = \alpha * \beta$
-/
lemma lim_prod (a : ℕ → ℝ) (b : ℕ → ℝ) (α β : ℝ)
    (ha : is_limit a α) (hb : is_limit b β) :
    is_limit ( λ n, (a n) * (b n) ) (α * β) :=
begin
    have Ha := lim_seq_sub_const a α α ha,
    rw [sub_self α] at Ha,
    have Hb := lim_seq_sub_const b β β hb,
    rw [sub_self β] at Hb,
    have G := lim_zero_prod (λ n, a n - α) (λ n, b n - β) Ha Hb,
    have g1 := lim_times_const a α β ha,
    have g2 := lim_times_const b β α hb,
    -- becomes ugly, need to improve notation
    have G1 := lim_linear (λ (n : ℕ),
        (λ (n : ℕ), a n - α) n * (λ (n : ℕ), b n - β) n) a 0 α 1 β G ha,
    have h1 : (1:ℝ) * 0 + β * α = β * α , norm_num,
    rw h1 at G1,
    have G2 := lim_linear (λ (n : ℕ),
        1 * (λ (n : ℕ), (λ (n : ℕ), a n - α) n * (λ (n : ℕ), b n - β) n) n + β * a n) b
        (β * α) β 1 α G1 hb,
    -- to get rid of these non-terminal `simp`
    simp at G2,
    have h2 : β * α + α * β = 2 * α * β,
        rw mul_comm β α, norm_num,
        have h21 := mul_two (α * β), rw ← h21,
        rw mul_assoc α β 2, rw mul_comm β _, rw ← mul_assoc,
        rw mul_comm α 2,
    rw h2 at G2,
    have G3 := lim_seq_sub_const
        (λ (n : ℕ), (a n - α) * (b n - β) + (β * a n + α * b n)) (2 * α * β) (α * β) _,
    simp at G3,
    have h3 : 2 * α * β - α * β = α * β,
        have h31 : (2:ℝ) * α * β - α * β = (2:ℝ) * α * β + (-1:ℝ) * α * β, ring,
        --rw ← add_mul (2:ℝ) (-1:ℝ) (α * β) at h31,
        rw h31, norm_cast, norm_num, ring,
    rw h3 at G3,
    intros ε hε,
    have G4 := G3 ε hε, cases G4 with N hN,
    use N,
    intros n hn,
    have G5 := hN n hn,
    simp at G5, simp,
    have h4 : (a n - α) * (b n - β) = (a n) * (b n) - α * (b n) - β * (a n) + α * β, ring,
    rw h4 at G5,
    have h5 : a n * b n - α * b n - β * a n + α * β + (β * a n + α * b n) - α * β - α * β =
        a n * b n - α * β, ring,
    rw h5 at G5, exact G5, convert G2, ext, ring, done
end

end xena -- hide


import .love03_forward_proofs_demo

/- # LoVe Exercise 4: Functional Programming -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Question 1: Reverse of a List

We define a new accumulator-based version of `reverse`. The first argument,
`as`, serves as the accumulator. This definition is __tail-recursive__, meaning
that compilers and interpreters can easily optimize the recursion away,
resulting in more efficient code. -/

def accurev {α : Type} : list α → list α → list α
| as []        := as
| as (x :: xs) := accurev (x :: as) xs

/- 1.1. Our intention is that `accurev [] xs` should be equal to `reverse xs`.
But if we start an induction, we quickly see that the induction hypothesis is
not strong enough. Start by proving the following generalization (using the
`induction'` tactic or pattern matching): -/

lemma accurev_eq_reverse_append {α : Type} :
  ∀as xs : list α, accurev as xs = reverse xs ++ as :=
sorry

/- 1.2. Derive the desired equation. -/

lemma accurev_eq_reverse {α : Type} (xs : list α) :
  accurev [] xs = reverse xs :=
sorry

/- 1.3. Prove the following property.

Hint: A one-line inductionless proof is possible. -/

lemma accurev_accurev {α : Type} (xs : list α) :
  accurev [] (accurev [] xs) = xs :=
sorry

/- 1.4. Prove the following lemma by structural induction, as a "paper" proof.
This is a good exercise to develop a deeper understanding of how structural
induction works (and is good practice for the final exam).

    lemma accurev_eq_reverse_append {α : Type} :
      ∀as xs : list α, accurev as xs = reverse xs ++ as

Guidelines for paper proofs:

We expect detailed, rigorous, mathematical proofs. You are welcome to use
standard mathematical notation or Lean structured commands (e.g., `assume`,
`have`, `show`, `calc`). You can also use tactical proofs (e.g., `intro`,
`apply`), but then please indicate some of the intermediate goals, so that we
can follow the chain of reasoning.

Major proof steps, including applications of induction and invocation of the
induction hypothesis, must be stated explicitly. For each case of a proof by
induction, you must list the inductive hypotheses assumed (if any) and the goal
to be proved. Minor proof steps corresponding to `refl`, `simp`, or `cc` need
not be justified if you think they are obvious (to humans), but you should say
which key lemmas they depend on. You should be explicit whenever you use a
function definition or an introduction rule for an inductive predicate. -/

-- enter your paper proof here

/- ## Question 2: Drop and Take

The `drop` function removes the first `n` elements from the front of a list. -/

def drop {α : Type} : ℕ → list α → list α
| 0       xs        := xs
| (_ + 1) []        := []
| (m + 1) (x :: xs) := drop m xs

/- Its relative `take` returns a list consisting of the the first `n` elements
at the front of a list.

2.1. Define `take`.

To avoid unpleasant surprises in the proofs, we recommend that you follow the
same recursion pattern as for `drop` above. -/

def take {α : Type} : ℕ → list α → list α :=
sorry

#eval take 0 [3, 7, 11]   -- expected: []
#eval take 1 [3, 7, 11]   -- expected: [3]
#eval take 2 [3, 7, 11]   -- expected: [3, 7]
#eval take 3 [3, 7, 11]   -- expected: [3, 7, 11]
#eval take 4 [3, 7, 11]   -- expected: [3, 7, 11]

#eval take 2 ["a", "b", "c"]   -- expected: ["a", "b"]

/- 2.2. Prove the following lemmas, using `induction'` or pattern matching.
Notice that they are registered as simplification rules thanks to the `@[simp]`
attribute. -/

@[simp] lemma drop_nil {α : Type} :
  ∀n : ℕ, drop n ([] : list α) = [] :=
sorry

@[simp] lemma take_nil {α : Type} :
  ∀n : ℕ, take n ([] : list α) = [] :=
sorry

/- 2.3. Follow the recursion pattern of `drop` and `take` to prove the
following lemmas. In other words, for each lemma, there should be three cases,
and the third case will need to invoke the induction hypothesis.

The first case is shown for `drop_drop`. Beware of the fact that there are three
variables in the `drop_drop` lemma (but only two arguments to `drop`).

Hint: The `refl` tactic might be useful in the third case of `drop_drop`. -/

lemma drop_drop {α : Type} :
  ∀(m n : ℕ) (xs : list α), drop n (drop m xs) = drop (n + m) xs
| 0       n xs        := by refl
-- supply the two missing cases here

lemma take_take {α : Type} :
  ∀(m : ℕ) (xs : list α), take m (take m xs) = take m xs :=
sorry

lemma take_drop {α : Type} :
  ∀(n : ℕ) (xs : list α), take n xs ++ drop n xs = xs :=
sorry

/- ## Question 3: A Type of λ-Terms

3.1. Define an inductive type corresponding to the untyped λ-terms, as given
by the following context-free grammar:

    term ::= 'var' string        -- variable (e.g., `x`)
           | 'lam' string term   -- λ-expression (e.g., `λx, t`)
           | 'app' term term     -- application (e.g., `t u`) -/

-- enter your definition here

/- 3.2. Register a textual representation of the type `term` as an instance of
the `has_repr` type class. Make sure to supply enough parentheses to guarantee
that the output is unambiguous. -/

def term.repr : term → string
-- enter your answer here

@[instance] def term.has_repr : has_repr term :=
{ repr := term.repr }

/- 3.3. Test your textual representation: -/

#eval (term.lam "x" (term.app (term.app (term.var "y") (term.var "x"))
    (term.var "x")))
  -- should print something like `(λx, ((y x) x))`

end LoVe


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Yury Kudryashov, Neil Strickland
-/
import algebra.group.basic
import algebra.group_with_zero.defs
import data.int.cast.defs

/-!
# Semirings and rings

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

This file defines semirings, rings and domains. This is analogous to `algebra.group.defs` and
`algebra.group.basic`, the difference being that the former is about `+` and `*` separately, while
the present file is about their interaction.

## Main definitions

* `distrib`: Typeclass for distributivity of multiplication over addition.
* `has_distrib_neg`: Typeclass for commutativity of negation and multiplication. This is useful when
  dealing with multiplicative submonoids which are closed under negation without being closed under
  addition, for example `units`.
* `(non_unital_)(non_assoc_)(semi)ring`: Typeclasses for possibly non-unital or non-associative
  rings and semirings. Some combinations are not defined yet because they haven't found use.

## Tags

`semiring`, `comm_semiring`, `ring`, `comm_ring`, `domain`, `is_domain`, `nonzero`, `units`
-/
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {R : Type x}

set_option old_structure_cmd true
open function

/-!
### `distrib` class
-/

/-- A typeclass stating that multiplication is left and right distributive
over addition. -/
@[protect_proj, ancestor has_mul has_add]
class distrib (R : Type*) extends has_mul R, has_add R :=
(left_distrib : ∀ a b c : R, a * (b + c) = a * b + a * c)
(right_distrib : ∀ a b c : R, (a + b) * c = a * c + b * c)

/-- A typeclass stating that multiplication is left distributive over addition. -/
@[protect_proj]
class left_distrib_class (R : Type*) [has_mul R] [has_add R] :=
(left_distrib : ∀ a b c : R, a * (b + c) = a * b + a * c)

/-- A typeclass stating that multiplication is right distributive over addition. -/
@[protect_proj]
class right_distrib_class (R : Type*) [has_mul R] [has_add R] :=
(right_distrib : ∀ a b c : R, (a + b) * c = a * c + b * c)

@[priority 100] -- see Note [lower instance priority]
instance distrib.left_distrib_class (R : Type*) [distrib R] : left_distrib_class R :=
⟨distrib.left_distrib⟩

@[priority 100] -- see Note [lower instance priority]
instance distrib.right_distrib_class (R : Type*) [distrib R] : right_distrib_class R :=
⟨distrib.right_distrib⟩

lemma left_distrib [has_mul R] [has_add R] [left_distrib_class R] (a b c : R) :
  a * (b + c) = a * b + a * c :=
left_distrib_class.left_distrib a b c

alias left_distrib ← mul_add

lemma right_distrib [has_mul R] [has_add R] [right_distrib_class R] (a b c : R) :
  (a + b) * c = a * c + b * c :=
right_distrib_class.right_distrib a b c

alias right_distrib ← add_mul

lemma distrib_three_right [has_mul R] [has_add R] [right_distrib_class R] (a b c d : R) :
  (a + b + c) * d = a * d + b * d + c * d :=
by simp [right_distrib]

/-!
### Semirings
-/

/-- A not-necessarily-unital, not-necessarily-associative semiring. -/
@[protect_proj, ancestor add_comm_monoid distrib mul_zero_class]
class non_unital_non_assoc_semiring (α : Type u) extends
  add_comm_monoid α, distrib α, mul_zero_class α

/-- An associative but not-necessarily unital semiring. -/
@[protect_proj, ancestor non_unital_non_assoc_semiring semigroup_with_zero]
class non_unital_semiring (α : Type u) extends
  non_unital_non_assoc_semiring α, semigroup_with_zero α

/-- A unital but not-necessarily-associative semiring. -/
@[protect_proj, ancestor non_unital_non_assoc_semiring mul_zero_one_class]
class non_assoc_semiring (α : Type u) extends
  non_unital_non_assoc_semiring α, mul_zero_one_class α, add_comm_monoid_with_one α

/-- A semiring is a type with the following structures: additive commutative monoid
(`add_comm_monoid`), multiplicative monoid (`monoid`), distributive laws (`distrib`), and
multiplication by zero law (`mul_zero_class`). The actual definition extends `monoid_with_zero`
instead of `monoid` and `mul_zero_class`. -/
@[protect_proj, ancestor non_unital_semiring non_assoc_semiring monoid_with_zero]
class semiring (α : Type u) extends non_unital_semiring α, non_assoc_semiring α, monoid_with_zero α

section has_one_has_add

variables [has_one α] [has_add α]

lemma one_add_one_eq_two : 1 + 1 = (2 : α) := rfl

end has_one_has_add

section distrib_mul_one_class
variables [has_add α] [mul_one_class α]

lemma add_one_mul [right_distrib_class α] (a b : α) : (a + 1) * b = a * b + b :=
by rw [add_mul, one_mul]
lemma mul_add_one [left_distrib_class α] (a b : α) : a * (b + 1) = a * b + a :=
by rw [mul_add, mul_one]
lemma one_add_mul [right_distrib_class α] (a b : α) : (1 + a) * b = b + a * b :=
by rw [add_mul, one_mul]
lemma mul_one_add [left_distrib_class α] (a b : α) : a * (1 + b) = a + a * b :=
by rw [mul_add, mul_one]

theorem two_mul [right_distrib_class α] (n : α) : 2 * n = n + n :=
eq.trans (right_distrib 1 1 n) (by simp)

theorem bit0_eq_two_mul [right_distrib_class α] (n : α) : bit0 n = 2 * n :=
(two_mul _).symm

theorem mul_two [left_distrib_class α] (n : α) : n * 2 = n + n :=
(left_distrib n 1 1).trans (by simp)

end distrib_mul_one_class

section semiring
variables [semiring α]

@[to_additive] lemma mul_ite {α} [has_mul α] (P : Prop) [decidable P] (a b c : α) :
  a * (if P then b else c) = if P then a * b else a * c :=
by split_ifs; refl

@[to_additive] lemma ite_mul {α} [has_mul α] (P : Prop) [decidable P] (a b c : α) :
  (if P then a else b) * c = if P then a * c else b * c :=
by split_ifs; refl

-- We make `mul_ite` and `ite_mul` simp lemmas,
-- but not `add_ite` or `ite_add`.
-- The problem we're trying to avoid is dealing with
-- summations of the form `∑ x in s, (f x + ite P 1 0)`,
-- in which `add_ite` followed by `sum_ite` would needlessly slice up
-- the `f x` terms according to whether `P` holds at `x`.
-- There doesn't appear to be a corresponding difficulty so far with
-- `mul_ite` and `ite_mul`.
attribute [simp] mul_ite ite_mul

@[simp] lemma mul_boole {α} [mul_zero_one_class α] (P : Prop) [decidable P] (a : α) :
  a * (if P then 1 else 0) = if P then a else 0 :=
by simp

@[simp] lemma boole_mul {α} [mul_zero_one_class α] (P : Prop) [decidable P] (a : α) :
  (if P then 1 else 0) * a = if P then a else 0 :=
by simp

lemma ite_mul_zero_left {α : Type*} [mul_zero_class α] (P : Prop) [decidable P] (a b : α) :
  ite P (a * b) 0 = ite P a 0 * b :=
by { by_cases h : P; simp [h], }

lemma ite_mul_zero_right {α : Type*} [mul_zero_class α] (P : Prop) [decidable P] (a b : α) :
  ite P (a * b) 0 = a * ite P b 0 :=
by { by_cases h : P; simp [h], }

lemma ite_and_mul_zero {α : Type*} [mul_zero_class α]
  (P Q : Prop) [decidable P] [decidable Q] (a b : α) :
  ite (P ∧ Q) (a * b) 0 = ite P a 0 * ite Q b 0 :=
by simp only [←ite_and, ite_mul, mul_ite, mul_zero, zero_mul, and_comm]

end semiring

/-- A non-unital commutative semiring is a `non_unital_semiring` with commutative multiplication.
In other words, it is a type with the following structures: additive commutative monoid
(`add_comm_monoid`), commutative semigroup (`comm_semigroup`), distributive laws (`distrib`), and
multiplication by zero law (`mul_zero_class`). -/
@[protect_proj, ancestor non_unital_semiring comm_semigroup]
class non_unital_comm_semiring (α : Type u) extends non_unital_semiring α, comm_semigroup α

/-- A commutative semiring is a `semiring` with commutative multiplication. In other words, it is a
type with the following structures: additive commutative monoid (`add_comm_monoid`), multiplicative
commutative monoid (`comm_monoid`), distributive laws (`distrib`), and multiplication by zero law
(`mul_zero_class`). -/
@[protect_proj, ancestor semiring comm_monoid]
class comm_semiring (α : Type u) extends semiring α, comm_monoid α

@[priority 100] -- see Note [lower instance priority]
instance comm_semiring.to_non_unital_comm_semiring [comm_semiring α] : non_unital_comm_semiring α :=
{ .. comm_semiring.to_comm_monoid α, .. comm_semiring.to_semiring α }

@[priority 100] -- see Note [lower instance priority]
instance comm_semiring.to_comm_monoid_with_zero [comm_semiring α] : comm_monoid_with_zero α :=
{ .. comm_semiring.to_comm_monoid α, .. comm_semiring.to_semiring α }

section comm_semiring
variables [comm_semiring α] {a b c : α}

lemma add_mul_self_eq (a b : α) : (a + b) * (a + b) = a*a + 2*a*b + b*b :=
by simp only [two_mul, add_mul, mul_add, add_assoc, mul_comm b]

end comm_semiring

section has_distrib_neg

/-- Typeclass for a negation operator that distributes across multiplication.

This is useful for dealing with submonoids of a ring that contain `-1` without having to duplicate
lemmas. -/
class has_distrib_neg (α : Type*) [has_mul α] extends has_involutive_neg α :=
(neg_mul : ∀ x y : α, -x * y = -(x * y))
(mul_neg : ∀ x y : α, x * -y = -(x * y))

section has_mul
variables [has_mul α] [has_distrib_neg α]

@[simp] lemma neg_mul (a b : α) : - a * b = - (a * b) :=
has_distrib_neg.neg_mul _ _

@[simp] lemma mul_neg (a b : α) : a * - b = - (a * b) :=
has_distrib_neg.mul_neg _ _

lemma neg_mul_neg (a b : α) : -a * -b = a * b :=
by simp

lemma neg_mul_eq_neg_mul (a b : α) : -(a * b) = -a * b :=
(neg_mul _ _).symm

lemma neg_mul_eq_mul_neg (a b : α) : -(a * b) = a * -b :=
(mul_neg _ _).symm

lemma neg_mul_comm (a b : α) : -a * b = a * -b :=
by simp

end has_mul

section mul_one_class
variables [mul_one_class α] [has_distrib_neg α]

theorem neg_eq_neg_one_mul (a : α) : -a = -1 * a :=
by simp

/-- An element of a ring multiplied by the additive inverse of one is the element's additive
  inverse. -/
lemma mul_neg_one (a : α) : a * -1 = -a := by simp

/-- The additive inverse of one multiplied by an element of a ring is the element's additive
  inverse. -/
lemma neg_one_mul (a : α) : -1 * a = -a := by simp

end mul_one_class

section mul_zero_class
variables [mul_zero_class α] [has_distrib_neg α]

@[priority 100]
instance mul_zero_class.neg_zero_class : neg_zero_class α :=
{ neg_zero := by rw [←zero_mul (0 : α), ←neg_mul, mul_zero, mul_zero],
  ..mul_zero_class.to_has_zero α,
  ..has_distrib_neg.to_has_involutive_neg α }

end mul_zero_class

end has_distrib_neg

/-!
### Rings
-/

/-- A not-necessarily-unital, not-necessarily-associative ring. -/
@[protect_proj, ancestor add_comm_group non_unital_non_assoc_semiring]
class non_unital_non_assoc_ring (α : Type u) extends
  add_comm_group α, non_unital_non_assoc_semiring α

-- We defer the instance `non_unital_non_assoc_ring.to_has_distrib_neg` to `algebra.ring.basic`
-- as it relies on the lemma `eq_neg_of_add_eq_zero_left`.

/-- An associative but not-necessarily unital ring. -/
@[protect_proj, ancestor non_unital_non_assoc_ring non_unital_semiring]
class non_unital_ring (α : Type*) extends
  non_unital_non_assoc_ring α, non_unital_semiring α

/-- A unital but not-necessarily-associative ring. -/
@[protect_proj, ancestor non_unital_non_assoc_ring non_assoc_semiring add_comm_group_with_one]
class non_assoc_ring (α : Type*) extends
  non_unital_non_assoc_ring α, non_assoc_semiring α, add_comm_group_with_one α

/-- A ring is a type with the following structures: additive commutative group (`add_comm_group`),
multiplicative monoid (`monoid`), and distributive laws (`distrib`).  Equivalently, a ring is a
`semiring` with a negation operation making it an additive group.  -/
@[protect_proj, ancestor add_comm_group monoid distrib]
class ring (α : Type u) extends add_comm_group_with_one α, monoid α, distrib α

section non_unital_non_assoc_ring
variables [non_unital_non_assoc_ring α]

@[priority 100]
instance non_unital_non_assoc_ring.to_has_distrib_neg : has_distrib_neg α :=
{ neg := has_neg.neg,
  neg_neg := neg_neg,
  neg_mul := λ a b, eq_neg_of_add_eq_zero_left $ by rw [←right_distrib, add_left_neg, zero_mul],
  mul_neg := λ a b, eq_neg_of_add_eq_zero_left $ by rw [←left_distrib, add_left_neg, mul_zero] }

lemma mul_sub_left_distrib (a b c : α) : a * (b - c) = a * b - a * c :=
by simpa only [sub_eq_add_neg, neg_mul_eq_mul_neg] using mul_add a b (-c)

alias mul_sub_left_distrib ← mul_sub

lemma mul_sub_right_distrib (a b c : α) : (a - b) * c = a * c - b * c :=
by simpa only [sub_eq_add_neg, neg_mul_eq_neg_mul] using add_mul a (-b) c

alias mul_sub_right_distrib ← sub_mul

variables {a b c d e : α}

/-- An iff statement following from right distributivity in rings and the definition
  of subtraction. -/
theorem mul_add_eq_mul_add_iff_sub_mul_add_eq : a * e + c = b * e + d ↔ (a - b) * e + c = d :=
calc
  a * e + c = b * e + d ↔ a * e + c = d + b * e : by simp [add_comm]
    ... ↔ a * e + c - b * e = d : iff.intro (λ h, begin rw h, simp end) (λ h,
                                                  begin rw ← h, simp end)
    ... ↔ (a - b) * e + c = d   : begin simp [sub_mul, sub_add_eq_add_sub] end

/-- A simplification of one side of an equation exploiting right distributivity in rings
  and the definition of subtraction. -/
theorem sub_mul_add_eq_of_mul_add_eq_mul_add : a * e + c = b * e + d → (a - b) * e + c = d :=
assume h,
calc
  (a - b) * e + c = (a * e + c) - b * e : begin simp [sub_mul, sub_add_eq_add_sub] end
              ... = d                   : begin rw h, simp [@add_sub_cancel α] end

end non_unital_non_assoc_ring

section non_assoc_ring
variables [non_assoc_ring α]

lemma sub_one_mul (a b : α) : (a - 1) * b = a * b - b :=
by rw [sub_mul, one_mul]
lemma mul_sub_one (a b : α) : a * (b - 1) = a * b - a :=
by rw [mul_sub, mul_one]
lemma one_sub_mul (a b : α) : (1 - a) * b = b - a * b :=
by rw [sub_mul, one_mul]
lemma mul_one_sub (a b : α) : a * (1 - b) = a - a * b :=
by rw [mul_sub, mul_one]

end non_assoc_ring

section ring
variables [ring α] {a b c d e : α}

/- A (unital, associative) ring is a not-necessarily-unital ring -/
@[priority 100] -- see Note [lower instance priority]
instance ring.to_non_unital_ring :
  non_unital_ring α :=
{ zero_mul := λ a, add_left_cancel $ show 0 * a + 0 * a = 0 * a + 0,
    by rw [← add_mul, zero_add, add_zero],
  mul_zero := λ a, add_left_cancel $ show a * 0 + a * 0 = a * 0 + 0,
    by rw [← mul_add, add_zero, add_zero],
  ..‹ring α› }

/- A (unital, associative) ring is a not-necessarily-associative ring -/
@[priority 100] -- see Note [lower instance priority]
instance ring.to_non_assoc_ring :
  non_assoc_ring α :=
{ zero_mul := λ a, add_left_cancel $ show 0 * a + 0 * a = 0 * a + 0,
    by rw [← add_mul, zero_add, add_zero],
  mul_zero := λ a, add_left_cancel $ show a * 0 + a * 0 = a * 0 + 0,
    by rw [← mul_add, add_zero, add_zero],
  ..‹ring α› }

/- The instance from `ring` to `semiring` happens often in linear algebra, for which all the basic
definitions are given in terms of semirings, but many applications use rings or fields. We increase
a little bit its priority above 100 to try it quickly, but remaining below the default 1000 so that
more specific instances are tried first. -/
@[priority 200]
instance ring.to_semiring : semiring α :=
{ ..‹ring α›, .. ring.to_non_unital_ring }

end ring

/-- A non-unital commutative ring is a `non_unital_ring` with commutative multiplication. -/
@[protect_proj, ancestor non_unital_ring comm_semigroup]
class non_unital_comm_ring (α : Type u) extends non_unital_ring α, comm_semigroup α

@[priority 100] -- see Note [lower instance priority]
instance non_unital_comm_ring.to_non_unital_comm_semiring [s : non_unital_comm_ring α] :
  non_unital_comm_semiring α :=
{ ..s }

/-- A commutative ring is a `ring` with commutative multiplication. -/
@[protect_proj, ancestor ring comm_semigroup]
class comm_ring (α : Type u) extends ring α, comm_monoid α

@[priority 100] -- see Note [lower instance priority]
instance comm_ring.to_comm_semiring [s : comm_ring α] : comm_semiring α :=
{ mul_zero := mul_zero, zero_mul := zero_mul, ..s }

@[priority 100] -- see Note [lower instance priority]
instance comm_ring.to_non_unital_comm_ring [s : comm_ring α] : non_unital_comm_ring α :=
{ mul_zero := mul_zero, zero_mul := zero_mul, ..s }

/-- A domain is a nontrivial semiring such multiplication by a non zero element is cancellative,
  on both sides. In other words, a nontrivial semiring `R` satisfying
  `∀ {a b c : R}, a ≠ 0 → a * b = a * c → b = c` and
  `∀ {a b c : R}, b ≠ 0 → a * b = c * b → a = c`.

  This is implemented as a mixin for `semiring α`.
  To obtain an integral domain use `[comm_ring α] [is_domain α]`. -/
@[protect_proj, ancestor is_cancel_mul_zero nontrivial]
class is_domain (α : Type u) [semiring α] extends is_cancel_mul_zero α, nontrivial α : Prop


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.bitvec.core
import data.fin.basic
import tactic.norm_num
import tactic.monotonicity

namespace bitvec

instance (n : ℕ) : preorder (bitvec n) :=
preorder.lift bitvec.to_nat

/-- convert `fin` to `bitvec` -/
def of_fin {n : ℕ} (i : fin $ 2^n) : bitvec n :=
bitvec.of_nat _ i.val

lemma of_fin_val {n : ℕ} (i : fin $ 2^n) : (of_fin i).to_nat = i.val :=
by rw [of_fin,to_nat_of_nat,nat.mod_eq_of_lt]; apply i.is_lt

/-- convert `bitvec` to `fin` -/
def to_fin {n : ℕ} (i : bitvec n) : fin $ 2^n :=
@fin.of_nat' _ ⟨pow_pos (by norm_num) _⟩ i.to_nat

lemma add_lsb_eq_twice_add_one {x b} :
  add_lsb x b = 2 * x + cond b 1 0 :=
by simp [add_lsb,two_mul]

lemma to_nat_eq_foldr_reverse {n : ℕ} (v : bitvec n) :
  v.to_nat = v.to_list.reverse.foldr (flip add_lsb) 0 :=
by rw [list.foldr_reverse, flip]; refl

lemma to_nat_lt {n : ℕ} (v : bitvec n) : v.to_nat < 2^n :=
begin
  suffices : v.to_nat + 1 ≤ 2 ^ n, { simpa },
  rw to_nat_eq_foldr_reverse,
  cases v with xs h,
  dsimp [bitvec.to_nat,bits_to_nat],
  rw ← list.length_reverse at h,
  generalize_hyp : xs.reverse = ys at ⊢ h, clear xs,
  induction ys generalizing n,
  { simp [← h] },
  { simp only [←h, pow_add, flip, list.length, list.foldr, pow_one],
    rw [add_lsb_eq_twice_add_one],
    transitivity 2 * list.foldr (λ (x : bool) (y : ℕ), add_lsb y x) 0 ys_tl + 2 * 1,
    { ac_mono, rw two_mul, mono, cases ys_hd; simp },
    { rw ← left_distrib, ac_mono, norm_num,
      apply ys_ih, refl } },
end

lemma add_lsb_div_two {x b} : add_lsb x b / 2 = x :=
by cases b; simp only [nat.add_mul_div_left, add_lsb, ←two_mul, add_comm, nat.succ_pos',
                       nat.mul_div_right, gt_iff_lt, zero_add, cond]; norm_num

lemma to_bool_add_lsb_mod_two {x b} : to_bool (add_lsb x b % 2 = 1) = b :=
by cases b; simp only [to_bool_iff, nat.add_mul_mod_self_left, add_lsb, ←two_mul, add_comm,
                       bool.to_bool_false, nat.mul_mod_right, zero_add, cond, zero_ne_one]; norm_num

lemma of_nat_to_nat  {n : ℕ} (v : bitvec n) : bitvec.of_nat _ v.to_nat = v :=
begin
  cases v with xs h,
  ext1,
  change vector.to_list _ = xs,
  dsimp [bitvec.to_nat,bits_to_nat],
  rw ← list.length_reverse at h,
  rw [← list.reverse_reverse xs,list.foldl_reverse],
  generalize_hyp : xs.reverse = ys at ⊢ h, clear xs,
  induction ys generalizing n,
  { cases h, simp [bitvec.of_nat] },
  { simp only [←nat.succ_eq_add_one, list.length] at h, subst n,
    simp only [bitvec.of_nat, vector.to_list_cons, vector.to_list_nil, list.reverse_cons,
      vector.to_list_append, list.foldr],
    erw [add_lsb_div_two, to_bool_add_lsb_mod_two],
    congr, apply ys_ih, refl }
end

lemma to_fin_val {n : ℕ} (v : bitvec n) : (to_fin v : ℕ) = v.to_nat :=
by rw [to_fin, fin.coe_of_nat_eq_mod', nat.mod_eq_of_lt]; apply to_nat_lt

lemma to_fin_le_to_fin_of_le {n} {v₀ v₁ : bitvec n} (h : v₀ ≤ v₁) : v₀.to_fin ≤ v₁.to_fin :=
show (v₀.to_fin : ℕ) ≤ v₁.to_fin,
by rw [to_fin_val,to_fin_val]; exact h

lemma of_fin_le_of_fin_of_le {n : ℕ} {i j : fin (2^n)} (h : i ≤ j) : of_fin i ≤ of_fin j :=
show (bitvec.of_nat n i).to_nat ≤ (bitvec.of_nat n j).to_nat,
by { simp only [to_nat_of_nat, nat.mod_eq_of_lt, fin.is_lt], exact h }

lemma to_fin_of_fin {n} (i : fin $ 2^n) : (of_fin i).to_fin = i :=
fin.eq_of_veq (by simp [to_fin_val, of_fin, to_nat_of_nat, nat.mod_eq_of_lt, i.is_lt])

lemma of_fin_to_fin {n} (v : bitvec n) : of_fin (to_fin v) = v :=
by dsimp [of_fin]; rw [to_fin_val, of_nat_to_nat]

end bitvec


import utilities

open list
open multiset
open set
open nat

set_option trace.simplify.rewrite true

variable {α : Type*}
variable r: α → α → Prop
variable x: α
variables xs ys: list α

/-
# Top-Down Merge Sort

The function merge from __Functional Algorithms, Verified!__ is defined in Lean as merge and is reused.
The function msort is defined as merge_sort in Lean but in a different way.
Therefore, it is defined below in the same way as in __Functional Algorithms, Verified!__,
making use of the length of the list and drop/take functions in order to follow the book's proof structure.
-/

def msort [decidable_rel r]: list α → list α
| xs := begin
  let n := xs.length,
  apply if h: 0 < n/2 then
  have (take (n / 2) xs).length < n, from
    begin
      simp,
      calc
        n/2 < n /2 + n/ 2  : nat.lt_add_of_pos_left h
        ... =  (n / 2) * 2 : by ring
        ... <=  n : by apply nat.div_mul_le_self,
    end,
  have (drop (n / 2) xs).length < n, from
    begin
      simp,
      have h1: 0 < n, from calc
        0 < n/2 : h
        ... <= n : nat.div_le_self' n 2,
      exact nat.sub_lt h1 h
    end,
  merge r (msort (take (n/2) xs)) (msort (drop (n/2) xs))
  else xs
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

/-
## Functional Correctness
 -/

lemma mset_merge [d: decidable_rel r]:
  (↑ (merge r xs ys): multiset α)  = ↑ xs + ↑ ys :=
begin
  simp,
  induction' xs,
  { cases ys,
    repeat { simp [merge] }},
  induction' ys,
  repeat { simp [merge] },
  split_ifs,
  { simp [ih] },
  simp only [← list.cons_append, list.perm_cons_append_cons hd_1 (@ih_ys _ _ _ _ ih)]
end

lemma set_merge [decidable_rel r]:
  (merge r xs ys).to_set = xs.to_set ∪ ys.to_set :=
begin
  simp [← set_mset_mset, mset_merge, multiset.to_set],
  refl
end

/-
Lemma 2.2 from __Functional Algorithms, Verified!__
-/
lemma mset_msort [decidable_rel r]:
  ∀ xs: list α, (↑ (msort r xs):multiset α) = ↑ xs
| xs := begin -- This syntax generalises the list in the IH in order for a proof by induction on the computation of msort.
  rw msort, -- Don't use simp here, because it will keep looping.
  let n:= xs.length,
  simp only *,
  split_ifs,
  { have h1: (take (n / 2) xs).length < n ∧ (drop (n / 2) xs).length < n, from
    begin
      apply and.intro,
      { simp,
        calc
          n / 2 < n / 2 + n / 2  : nat.lt_add_of_pos_left h
          ... =  (n / 2) * 2 : by ring
          ... <=  n : by apply nat.div_mul_le_self },
      simp,
      have h1: 0 < n, from calc
        0 < n / 2 : h
        ... <= n : nat.div_le_self' xs.length 2,
      exact nat.sub_lt h1 h,
    end,
    rw mset_merge,
    cases h1, -- This is needed to have h1_left and h1_right seen by Lean in using_well_founded recursion.
    simp only [mset_msort (take (n / 2) xs)],
    simp  [mset_msort (drop (n / 2) xs)] },
  refl,
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

lemma sorted_merge [decidable_rel r] [is_linear_order α r]:
  sorted' r (merge r xs ys) ↔ sorted' r xs ∧ sorted' r ys :=
begin
  induction' xs,
  { cases ys,
    repeat { simp [merge, sorted'] } },
  induction' ys fixing *,
  repeat { simp [merge, sorted'], },
  split_ifs,
  { simp  [sorted', ih, set_merge, and_assoc],
    intros h1 h2 h3,
    apply iff.intro,
    { intros h4 y H,
      exact h4 y (or.inl H)},
    intros h4 y H,
    apply or.elim H,
    { exact h4 y },
    intro h5,
    simp [list.to_set] at h5,
    apply or.elim h5,
    { intro h6,
      exact eq.subst h6.symm h },
    intro h6,
    exact trans h (h2 y h6)},
  simp [sorted', ih_ys, and.assoc, set_merge, and.comm],
  simp [and_comm (sorted' r ys), and.assoc ],
  intros h1 h2 h3,
  apply iff.intro,
  { intros h4 _ _,
    exact h4 y (or.inr H)},
  intros h4 _ _,
  apply or.elim H,
  { simp [list.to_set],
    intro h5,
    have h6: r hd_1 y ∨ r y hd_1, from total_of r hd_1 y,
    apply or.elim h5,
    { intro h7,
      apply or.resolve_right h6,
      exact eq.subst h7.symm h},
    intro h7,
    have h8: r hd_1 hd ∨ r hd hd_1, from total_of r hd_1 hd,
    exact trans (or.resolve_right h8 h) (h2 y h7)},
  exact h4 y,
end

/-
This lemma is used in sorted_msort.
-/
lemma div_two_eq_zero_or_one {n: ℕ } (h: n/2 = 0): n = 0 ∨ n = 1 :=
begin
  apply classical.by_contradiction,
  intro h1,
  have h2: ¬ n = 0, from (iff.elim_left not_or_distrib h1).left,
  have h3: ¬ n = 1, from (iff.elim_left not_or_distrib h1).right,
  have h4: 0 < 2, by simp,
  have h5: n/2 = 0 ↔ n <= 1, by calc
    n / 2 = 0 ↔ n < 2 : nat.div_eq_zero_iff h4
    ... ↔  n + 1 <= 1 + 1 : by ring
    ... ↔  n <= 1 : by simp,
  have h6: n <=1, from iff.elim_left h5 h,
  have h7: n < 1, from nat.lt_of_le_and_ne h6 h3,
  simp at *,
  contradiction,
end

/-
Lemma 2.3 from __Functional Algorithms, Verified!__
-/
lemma sorted_msort [decidable_rel r] [is_linear_order α r]:
  ∀ xs: list α, sorted' r (msort r xs)
| xs := begin -- This syntax generalises the list in the IH in order for a proof by induction on the computation of msort.
  let n:= xs.length,
  let ys := take (n / 2) xs,
  let zs := drop (n / 2) xs,
  rw msort, -- Don't use simp here, because it will keep looping.
  simp only *,
  split_ifs,
  { have h1: ys.length < n ∧ zs.length < n, from begin
      apply and.intro,
      { simp,
        calc
          n / 2 < n / 2 + n / 2  : nat.lt_add_of_pos_left h
          ... =  (n / 2) * 2 : by ring
          ... <=  n : by apply nat.div_mul_le_self },
      simp,
      have h1: 0 < n, from calc
        0 < n /2 : h
        ... <= n : nat.div_le_self' n 2,
      exact nat.sub_lt h1 h,
    end,
    cases h1, -- This is needed to have h1_left and h1_right seen by Lean in using_well_founded recursion.
    simp [sorted_merge, sorted_msort ys, sorted_msort zs] },
  have h2: 0 = n / 2 ∨ n / 2 < 0 , from nat.eq_or_lt_of_not_lt h,
  simp at h2,
  have h1: n = 0 ∨ n = 1, from div_two_eq_zero_or_one h2.symm,
  apply or.elim h1,
  { intro h2,
    have h3: xs = list.nil, from list.eq_nil_of_length_eq_zero h2,
    simp [h3] },
  intro h2,
  have h3: ∃ (a : α), xs = [a], from iff.elim_left list.length_eq_one h2,
  apply exists.elim h3,
  intros a h4,
  simp [h4, sorted'],
  intros,
  simp [list.to_set] at H,
  exact false.elim H
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

/-
## Time Complexity
We only count the number of comparisons between list elements.
-/

def C_merge [decidable_rel r] : list α → list α → nat
| [] _ := 0
| _ [] := 0
| (x::xs) (y::ys) := 1 + (if r x y then C_merge xs (y::ys) else C_merge (x::xs) ys)

def C_msort [decidable_rel r]: list α → ℕ
| xs := begin
  apply if h: 0 < xs.length / 2 then
  have (take (xs.length / 2) xs).length < xs.length, from
    begin
      simp,
      calc
        xs.length/2 < xs.length /2 + xs.length/ 2  : nat.lt_add_of_pos_left h
        ... =  (xs.length / 2) * 2 : by ring
        ... <=  xs.length : by apply nat.div_mul_le_self,
    end,
  have (drop (xs.length /2) xs).length < xs.length, from
    begin
      simp,
      have h1: 0 < xs.length, from calc
        0 < xs.length/2 : h
        ... <= xs.length : nat.div_le_self' xs.length 2,
      exact nat.sub_lt h1 h
    end,
  C_msort (take (xs.length / 2) xs) + C_msort (drop (xs.length /2) xs) + C_merge r (msort r (take (xs.length / 2) xs)) (msort r (drop (xs.length /2) xs))
  else 0
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

lemma length_merge [decidable_rel r] :
  (merge r xs ys).length = xs.length + ys.length :=
begin
  induction' xs,
  { induction' ys,
    repeat { simp [merge], } },
  induction' ys,
  repeat { simp [merge]} ,
  split_ifs,
  repeat { simp *, cc },
end

lemma length_msort [decidable_rel r]:
  ∀ xs, (msort r xs).length = xs.length
| xs := begin
  let n:= xs.length,
  let ys := take (n / 2) xs,
  let zs := drop (n / 2) xs,
  rw msort,
  simp only *,
  split_ifs,
  { have h1: ys.length < n ∧ zs.length < n, from begin
      apply and.intro,
      { simp,
        calc
          n / 2 < n / 2 + n / 2  : nat.lt_add_of_pos_left h
          ... =  (n / 2) * 2 : by ring
          ... <=  n : by apply nat.div_mul_le_self },
      simp,
      have h1: 0 < n, from calc
        0 < n / 2 : h
        ... <= n : nat.div_le_self' n 2,
      exact nat.sub_lt h1 h,
    end,
    cases h1,
    simp [length_merge, length_msort ys, length_msort zs, *] at *,
    have h2: n / 2 <= n, by linarith,
    simp [*, ← nat.add_sub_assoc h2], },
  refl,
end
using_well_founded {
  rel_tac := λ_ _, `[exact ⟨_, inv_image.wf length nat.lt_wf⟩],
  dec_tac := tactic.assumption }

lemma C_merge_ub [d: decidable_rel r] : C_merge r xs ys <= xs.length + ys.length :=
begin
  induction' xs,
  { cases ys,
    repeat { simp [C_merge]} },
  induction' ys fixing *,
  repeat { simp [C_merge]},
  split_ifs,
  { have ih': C_merge r xs (hd_1::ys) ≤ xs.length + (hd_1::ys).length, from ih r (hd_1::ys),
    simp at *,
    calc
      1 + C_merge r xs (hd_1 :: ys) = C_merge r xs (hd_1 :: ys) + 1 : by simp [add_comm]
      ... <= xs.length + (ys.length + 1) + 1 : by simp [ih']
      ... = xs.length + 1 + (ys.length + 1) : by simp [add_assoc, add_comm]},
  simp at *,
  calc
    1 + C_merge r (hd :: xs) ys = C_merge r (hd :: xs) ys + 1 : by ring
    ... <= xs.length + 1 + ys.length + 1 : by simp [ih_ys]
    ... = xs.length + 1 + (ys.length + 1) : by ring,
end

lemma take_drop_eq_length (n: ℕ ) : (take n xs).length + (drop n xs).length = xs.length:=
begin
  simp,
  have h1: n <= xs.length ∨ ¬ n <= xs.length, from classical.em (n <= xs.length),
  cases h1,
  { simp [*, ← nat.add_sub_assoc h1], },
  have h2: xs.length <= n, by linarith,
  simp *,
end

/-
Lemma 2.4 from __Functional Algorithms, Verified!__
-/
lemma C_msort_le [decidable_rel r] (k: ℕ ) : xs.length = 2^k → C_msort r xs <= k * 2^k :=
begin
  let ys := take (xs.length /2) xs,
  let zs := drop (xs.length / 2) xs,
  induction k with k ih generalizing xs,
  { simp,
    intro h,
    have h1: ¬  0 < xs.length / 2, by
    { simp *,
      ring },
    rw [C_msort, if_neg h1] },
  intro h,
  rw C_msort,
  split_ifs,
  { have h1: 2^k.succ /2 <= 2 ^k.succ, from nat.div_le_self' (2^k.succ) 2,
    have h2: ys.length = 2 ^ k, from begin
      simp *,
      calc
        2 ^ k.succ / 2 = 2^ k * 2 / 2 : by ring
        ... = 2 ^ k : by simp,
    end,
    have h3: zs.length = 2 ^ k, from begin
      simp *,
      calc
        2 ^ k.succ - 2 ^ k.succ / 2 = 2^k + 2^k - 2^k * 2 /2 : by ring
        ... = 2 ^ k : by simp,
    end,
    have h4: C_msort r ys ≤ k * 2 ^ k, from ih ys h2,
    have h5: C_msort r zs ≤ k * 2 ^ k, from ih zs h3,
    calc
    C_msort r ys + C_msort r zs + C_merge r (msort r ys) (msort r zs) <=  C_msort r ys + C_msort r zs + (msort r ys).length + (msort r zs).length : by simp [add_assoc, C_merge_ub ]
    ... = C_msort r ys + C_msort r zs + ys.length + zs.length : by simp only [length_msort]
    ... <= k * 2^k + k * 2^k + ys.length + zs.length : by linarith
    ... = k * 2^k + k * 2^k + 2^k.succ : by simp [*, add_assoc, take_drop_eq_length]
    ... = ( k + 1) * 2^k.succ : by ring
    ... = k.succ * 2^k.succ : by simp, },
  simp,
end