/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel

! This file was ported from Lean 3 source module measure_theory.function.jacobian
! leanprover-community/mathlib commit 57ac39bd365c2f80589a700f9fbb664d3a1a30c2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Covering.BesicovitchVectorSpace
import Mathbin.MeasureTheory.Measure.HaarLebesgue
import Mathbin.Analysis.NormedSpace.Pointwise
import Mathbin.MeasureTheory.Constructions.Polish

/-!
# Change of variables in higher-dimensional integrals

Let `μ` be a Lebesgue measure on a finite-dimensional real vector space `E`.
Let `f : E → E` be a function which is injective and differentiable on a measurable set `s`,
with derivative `f'`. Then we prove that `f '' s` is measurable, and
its measure is given by the formula `μ (f '' s) = ∫⁻ x in s, |(f' x).det| ∂μ` (where `(f' x).det`
is almost everywhere measurable, but not Borel-measurable in general). This formula is proved in
`lintegral_abs_det_fderiv_eq_add_haar_image`. We deduce the change of variables
formula for the Lebesgue and Bochner integrals, in `lintegral_image_eq_lintegral_abs_det_fderiv_mul`
and `integral_image_eq_integral_abs_det_fderiv_smul` respectively.

## Main results

* `add_haar_image_eq_zero_of_differentiable_on_of_add_haar_eq_zero`: if `f` is differentiable on a
  set `s` with zero measure, then `f '' s` also has zero measure.
* `add_haar_image_eq_zero_of_det_fderiv_within_eq_zero`: if `f` is differentiable on a set `s`, and
  its derivative is never invertible, then `f '' s` has zero measure (a version of Sard's lemma).
* `ae_measurable_fderiv_within`: if `f` is differentiable on a measurable set `s`, then `f'`
  is almost everywhere measurable on `s`.

For the next statements, `s` is a measurable set and `f` is differentiable on `s`
(with a derivative `f'`) and injective on `s`.

* `measurable_image_of_fderiv_within`: the image `f '' s` is measurable.
* `measurable_embedding_of_fderiv_within`: the function `s.restrict f` is a measurable embedding.
* `lintegral_abs_det_fderiv_eq_add_haar_image`: the image measure is given by
    `μ (f '' s) = ∫⁻ x in s, |(f' x).det| ∂μ`.
* `lintegral_image_eq_lintegral_abs_det_fderiv_mul`: for `g : E → ℝ≥0∞`, one has
    `∫⁻ x in f '' s, g x ∂μ = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) * g (f x) ∂μ`.
* `integral_image_eq_integral_abs_det_fderiv_smul`: for `g : E → F`, one has
    `∫ x in f '' s, g x ∂μ = ∫ x in s, |(f' x).det| • g (f x) ∂μ`.
* `integrable_on_image_iff_integrable_on_abs_det_fderiv_smul`: for `g : E → F`, the function `g` is
  integrable on `f '' s` if and only if `|(f' x).det| • g (f x))` is integrable on `s`.

## Implementation

Typical versions of these results in the literature have much stronger assumptions: `s` would
typically be open, and the derivative `f' x` would depend continuously on `x` and be invertible
everywhere, to have the local inverse theorem at our disposal. The proof strategy under our weaker
assumptions is more involved. We follow [Fremlin, *Measure Theory* (volume 2)][fremlin_vol2].

The first remark is that, if `f` is sufficiently well approximated by a linear map `A` on a set
`s`, then `f` expands the volume of `s` by at least `A.det - ε` and at most `A.det + ε`, where
the closeness condition depends on `A` in a non-explicit way (see `add_haar_image_le_mul_of_det_lt`
and `mul_le_add_haar_image_of_lt_det`). This fact holds for balls by a simple inclusion argument,
and follows for general sets using the Besicovitch covering theorem to cover the set by balls with
measures adding up essentially to `μ s`.

When `f` is differentiable on `s`, one may partition `s` into countably many subsets `s ∩ t n`
(where `t n` is measurable), on each of which `f` is well approximated by a linear map, so that the
above results apply. See `exists_partition_approximates_linear_on_of_has_fderiv_within_at`, which
follows from the pointwise differentiability (in a non-completely trivial way, as one should ensure
a form of uniformity on the sets of the partition).

Combining the above two results would give the conclusion, except for two difficulties: it is not
obvious why `f '' s` and `f'` should be measurable, which prevents us from using countable
additivity for the measure and the integral. It turns out that `f '' s` is indeed measurable,
and that `f'` is almost everywhere measurable, which is enough to recover countable additivity.

The measurability of `f '' s` follows from the deep Lusin-Souslin theorem ensuring that, in a
Polish space, a continuous injective image of a measurable set is measurable.

The key point to check the almost everywhere measurability of `f'` is that, if `f` is approximated
up to `δ` by a linear map on a set `s`, then `f'` is within `δ` of `A` on a full measure subset
of `s` (namely, its density points). With the above approximation argument, it follows that `f'`
is the almost everywhere limit of a sequence of measurable functions (which are constant on the
pieces of the good discretization), and is therefore almost everywhere measurable.

## Tags
Change of variables in integrals

## References
[Fremlin, *Measure Theory* (volume 2)][fremlin_vol2]
-/

open
  MeasureTheory MeasureTheory.Measure Metric Filter Set FiniteDimensional Asymptotics TopologicalSpace

open NNReal ENNReal Topology Pointwise

variable {E F : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
  [NormedAddCommGroup F] [NormedSpace ℝ F] {s : Set E} {f : E → E} {f' : E → E →L[ℝ] E}

/-!
### Decomposition lemmas

We state lemmas ensuring that a differentiable function can be approximated, on countably many
measurable pieces, by linear maps (with a prescribed precision depending on the linear map).
-/

/-- Assume that a function `f` has a derivative at every point of a set `s`. Then one may cover `s`
with countably many closed sets `t n` on which `f` is well approximated by linear maps `A n`. -/
theorem exists_closed_cover_approximatesLinearOn_of_hasFderivWithinAt [SecondCountableTopology F]
    (f : E → F) (s : Set E) (f' : E → E →L[ℝ] F) (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x)
    (r : (E →L[ℝ] F) → ℝ≥0) (rpos : ∀ A, r A ≠ 0) :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] F),
      (∀ n, IsClosed (t n)) ∧
        (s ⊆ ⋃ n, t n) ∧
          (∀ n, ApproximatesLinearOn f (A n) (s ∩ t n) (r (A n))) ∧
            (s.Nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
  by
  /- Choose countably many linear maps `f' z`. For every such map, if `f` has a derivative at `x`
    close enough to `f' z`, then `f y - f x` is well approximated by `f' z (y - x)` for `y` close
    enough to `x`, say on a ball of radius `r` (or even `u n` for some `n`, where `u` is a fixed
    sequence tending to `0`).
    Let `M n z` be the points where this happens. Then this set is relatively closed inside `s`,
    and moreover in every closed ball of radius `u n / 3` inside it the map is well approximated by
    `f' z`. Using countably many closed balls to split `M n z` into small diameter subsets `K n z p`,
    one obtains the desired sets `t q` after reindexing.
    -/
  -- exclude the trivial case where `s` is empty
  rcases eq_empty_or_nonempty s with (rfl | hs)
  · refine' ⟨fun n => ∅, fun n => 0, _, _, _, _⟩ <;> simp
  -- we will use countably many linear maps. Select these from all the derivatives since the
  -- space of linear maps is second-countable
  obtain ⟨T, T_count, hT⟩ :
    ∃ T : Set s,
      T.Countable ∧ (⋃ x ∈ T, ball (f' (x : E)) (r (f' x))) = ⋃ x : s, ball (f' x) (r (f' x)) :=
    TopologicalSpace.isOpen_unionᵢ_countable _ fun x => is_open_ball
  -- fix a sequence `u` of positive reals tending to zero.
  obtain ⟨u, u_anti, u_pos, u_lim⟩ :
    ∃ u : ℕ → ℝ, StrictAnti u ∧ (∀ n : ℕ, 0 < u n) ∧ tendsto u at_top (𝓝 0) :=
    exists_seq_strictAnti_tendsto (0 : ℝ)
  -- `M n z` is the set of points `x` such that `f y - f x` is close to `f' z (y - x)` for `y`
  -- in the ball of radius `u n` around `x`.
  let M : ℕ → T → Set E := fun n z =>
    { x | x ∈ s ∧ ∀ y ∈ s ∩ ball x (u n), ‖f y - f x - f' z (y - x)‖ ≤ r (f' z) * ‖y - x‖ }
  -- As `f` is differentiable everywhere on `s`, the sets `M n z` cover `s` by design.
  have s_subset : ∀ x ∈ s, ∃ (n : ℕ)(z : T), x ∈ M n z :=
    by
    intro x xs
    obtain ⟨z, zT, hz⟩ : ∃ z ∈ T, f' x ∈ ball (f' (z : E)) (r (f' z)) :=
      by
      have : f' x ∈ ⋃ z ∈ T, ball (f' (z : E)) (r (f' z)) :=
        by
        rw [hT]
        refine' mem_Union.2 ⟨⟨x, xs⟩, _⟩
        simpa only [mem_ball, Subtype.coe_mk, dist_self] using (rpos (f' x)).bot_lt
      rwa [mem_Union₂] at this
    obtain ⟨ε, εpos, hε⟩ : ∃ ε : ℝ, 0 < ε ∧ ‖f' x - f' z‖ + ε ≤ r (f' z) :=
      by
      refine' ⟨r (f' z) - ‖f' x - f' z‖, _, le_of_eq (by abel)⟩
      simpa only [sub_pos] using mem_ball_iff_norm.mp hz
    obtain ⟨δ, δpos, hδ⟩ :
      ∃ (δ : ℝ)(H : 0 < δ), ball x δ ∩ s ⊆ { y | ‖f y - f x - (f' x) (y - x)‖ ≤ ε * ‖y - x‖ } :=
      Metric.mem_nhdsWithin_iff.1 (is_o.def (hf' x xs) εpos)
    obtain ⟨n, hn⟩ : ∃ n, u n < δ := ((tendsto_order.1 u_lim).2 _ δpos).exists
    refine' ⟨n, ⟨z, zT⟩, ⟨xs, _⟩⟩
    intro y hy
    calc
      ‖f y - f x - (f' z) (y - x)‖ = ‖f y - f x - (f' x) (y - x) + (f' x - f' z) (y - x)‖ :=
        by
        congr 1
        simp only [ContinuousLinearMap.coe_sub', map_sub, Pi.sub_apply]
        abel
      _ ≤ ‖f y - f x - (f' x) (y - x)‖ + ‖(f' x - f' z) (y - x)‖ := (norm_add_le _ _)
      _ ≤ ε * ‖y - x‖ + ‖f' x - f' z‖ * ‖y - x‖ :=
        by
        refine' add_le_add (hδ _) (ContinuousLinearMap.le_op_norm _ _)
        rw [inter_comm]
        exact inter_subset_inter_right _ (ball_subset_ball hn.le) hy
      _ ≤ r (f' z) * ‖y - x‖ := by
        rw [← add_mul, add_comm]
        exact mul_le_mul_of_nonneg_right hε (norm_nonneg _)

  -- the sets `M n z` are relatively closed in `s`, as all the conditions defining it are clearly
  -- closed
  have closure_M_subset : ∀ n z, s ∩ closure (M n z) ⊆ M n z :=
    by
    rintro n z x ⟨xs, hx⟩
    refine' ⟨xs, fun y hy => _⟩
    obtain ⟨a, aM, a_lim⟩ : ∃ a : ℕ → E, (∀ k, a k ∈ M n z) ∧ tendsto a at_top (𝓝 x) :=
      mem_closure_iff_seq_limit.1 hx
    have L1 :
      tendsto (fun k : ℕ => ‖f y - f (a k) - (f' z) (y - a k)‖) at_top
        (𝓝 ‖f y - f x - (f' z) (y - x)‖) :=
      by
      apply tendsto.norm
      have L : tendsto (fun k => f (a k)) at_top (𝓝 (f x)) :=
        by
        apply (hf' x xs).ContinuousWithinAt.Tendsto.comp
        apply tendsto_nhdsWithin_of_tendsto_nhds_of_eventually_within _ a_lim
        exact eventually_of_forall fun k => (aM k).1
      apply tendsto.sub (tendsto_const_nhds.sub L)
      exact ((f' z).Continuous.Tendsto _).comp (tendsto_const_nhds.sub a_lim)
    have L2 : tendsto (fun k : ℕ => (r (f' z) : ℝ) * ‖y - a k‖) at_top (𝓝 (r (f' z) * ‖y - x‖)) :=
      (tendsto_const_nhds.sub a_lim).norm.const_mul _
    have I : ∀ᶠ k in at_top, ‖f y - f (a k) - (f' z) (y - a k)‖ ≤ r (f' z) * ‖y - a k‖ :=
      by
      have L : tendsto (fun k => dist y (a k)) at_top (𝓝 (dist y x)) :=
        tendsto_const_nhds.dist a_lim
      filter_upwards [(tendsto_order.1 L).2 _ hy.2]
      intro k hk
      exact (aM k).2 y ⟨hy.1, hk⟩
    exact le_of_tendsto_of_tendsto L1 L2 I
  -- choose a dense sequence `d p`
  rcases TopologicalSpace.exists_dense_seq E with ⟨d, hd⟩
  -- split `M n z` into subsets `K n z p` of small diameters by intersecting with the ball
  -- `closed_ball (d p) (u n / 3)`.
  let K : ℕ → T → ℕ → Set E := fun n z p => closure (M n z) ∩ closed_ball (d p) (u n / 3)
  -- on the sets `K n z p`, the map `f` is well approximated by `f' z` by design.
  have K_approx : ∀ (n) (z : T) (p), ApproximatesLinearOn f (f' z) (s ∩ K n z p) (r (f' z)) :=
    by
    intro n z p x hx y hy
    have yM : y ∈ M n z := closure_M_subset _ _ ⟨hy.1, hy.2.1⟩
    refine' yM.2 _ ⟨hx.1, _⟩
    calc
      dist x y ≤ dist x (d p) + dist y (d p) := dist_triangle_right _ _ _
      _ ≤ u n / 3 + u n / 3 := (add_le_add hx.2.2 hy.2.2)
      _ < u n := by linarith [u_pos n]

  -- the sets `K n z p` are also closed, again by design.
  have K_closed : ∀ (n) (z : T) (p), IsClosed (K n z p) := fun n z p =>
    is_closed_closure.inter is_closed_ball
  -- reindex the sets `K n z p`, to let them only depend on an integer parameter `q`.
  obtain ⟨F, hF⟩ : ∃ F : ℕ → ℕ × T × ℕ, Function.Surjective F :=
    by
    haveI : Encodable T := T_count.to_encodable
    have : Nonempty T := by
      rcases eq_empty_or_nonempty T with (rfl | hT)
      · rcases hs with ⟨x, xs⟩
        rcases s_subset x xs with ⟨n, z, hnz⟩
        exact False.elim z.2
      · exact hT.coe_sort
    inhabit ℕ × T × ℕ
    exact ⟨_, Encodable.surjective_decode_iget _⟩
  -- these sets `t q = K n z p` will do
  refine'
    ⟨fun q => K (F q).1 (F q).2.1 (F q).2.2, fun q => f' (F q).2.1, fun n => K_closed _ _ _,
      fun x xs => _, fun q => K_approx _ _ _, fun h's q => ⟨(F q).2.1, (F q).2.1.1.2, rfl⟩⟩
  -- the only fact that needs further checking is that they cover `s`.
  -- we already know that any point `x ∈ s` belongs to a set `M n z`.
  obtain ⟨n, z, hnz⟩ : ∃ (n : ℕ)(z : T), x ∈ M n z := s_subset x xs
  -- by density, it also belongs to a ball `closed_ball (d p) (u n / 3)`.
  obtain ⟨p, hp⟩ : ∃ p : ℕ, x ∈ closed_ball (d p) (u n / 3) :=
    by
    have : Set.Nonempty (ball x (u n / 3)) :=
      by
      simp only [nonempty_ball]
      linarith [u_pos n]
    obtain ⟨p, hp⟩ : ∃ p : ℕ, d p ∈ ball x (u n / 3) := hd.exists_mem_open is_open_ball this
    exact ⟨p, (mem_ball'.1 hp).le⟩
  -- choose `q` for which `t q = K n z p`.
  obtain ⟨q, hq⟩ : ∃ q, F q = (n, z, p) := hF _
  -- then `x` belongs to `t q`.
  apply mem_Union.2 ⟨q, _⟩
  simp only [hq, subset_closure hnz, hp, mem_inter_iff, and_self_iff]
#align exists_closed_cover_approximates_linear_on_of_has_fderiv_within_at exists_closed_cover_approximatesLinearOn_of_hasFderivWithinAt

variable [MeasurableSpace E] [BorelSpace E] (μ : Measure E) [IsAddHaarMeasure μ]

/-- Assume that a function `f` has a derivative at every point of a set `s`. Then one may
partition `s` into countably many disjoint relatively measurable sets (i.e., intersections
of `s` with measurable sets `t n`) on which `f` is well approximated by linear maps `A n`. -/
theorem exists_partition_approximatesLinearOn_of_hasFderivWithinAt [SecondCountableTopology F]
    (f : E → F) (s : Set E) (f' : E → E →L[ℝ] F) (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x)
    (r : (E →L[ℝ] F) → ℝ≥0) (rpos : ∀ A, r A ≠ 0) :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] F),
      Pairwise (Disjoint on t) ∧
        (∀ n, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n, t n) ∧
            (∀ n, ApproximatesLinearOn f (A n) (s ∩ t n) (r (A n))) ∧
              (s.Nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
  by
  rcases exists_closed_cover_approximatesLinearOn_of_hasFderivWithinAt f s f' hf' r rpos with
    ⟨t, A, t_closed, st, t_approx, ht⟩
  refine'
    ⟨disjointed t, A, disjoint_disjointed _,
      MeasurableSet.disjointed fun n => (t_closed n).MeasurableSet, _, _, ht⟩
  · rw [unionᵢ_disjointed]
    exact st
  · intro n
    exact (t_approx n).monoSet (inter_subset_inter_right _ (disjointed_subset _ _))
#align exists_partition_approximates_linear_on_of_has_fderiv_within_at exists_partition_approximatesLinearOn_of_hasFderivWithinAt

namespace MeasureTheory

/-!
### Local lemmas

We check that a function which is well enough approximated by a linear map expands the volume
essentially like this linear map, and that its derivative (if it exists) is almost everywhere close
to the approximating linear map.
-/

/-- Let `f` be a function which is sufficiently close (in the Lipschitz sense) to a given linear
map `A`. Then it expands the volume of any set by at most `m` for any `m > det A`. -/
theorem add_haar_image_le_mul_of_det_lt (A : E →L[ℝ] E) {m : ℝ≥0}
    (hm : ENNReal.ofReal (|A.det|) < m) :
    ∀ᶠ δ in 𝓝[>] (0 : ℝ≥0),
      ∀ (s : Set E) (f : E → E) (hf : ApproximatesLinearOn f A s δ), μ (f '' s) ≤ m * μ s :=
  by
  apply nhdsWithin_le_nhds
  let d := ENNReal.ofReal (|A.det|)
  -- construct a small neighborhood of `A '' (closed_ball 0 1)` with measure comparable to
  -- the determinant of `A`.
  obtain ⟨ε, hε, εpos⟩ :
    ∃ ε : ℝ, μ (closed_ball 0 ε + A '' closed_ball 0 1) < m * μ (closed_ball 0 1) ∧ 0 < ε :=
    by
    have HC : IsCompact (A '' closed_ball 0 1) :=
      (ProperSpace.isCompact_closedBall _ _).image A.continuous
    have L0 :
      tendsto (fun ε => μ (cthickening ε (A '' closed_ball 0 1))) (𝓝[>] 0)
        (𝓝 (μ (A '' closed_ball 0 1))) :=
      by
      apply tendsto.mono_left _ nhdsWithin_le_nhds
      exact tendsto_measure_cthickening_of_isCompact HC
    have L1 :
      tendsto (fun ε => μ (closed_ball 0 ε + A '' closed_ball 0 1)) (𝓝[>] 0)
        (𝓝 (μ (A '' closed_ball 0 1))) :=
      by
      apply L0.congr' _
      filter_upwards [self_mem_nhdsWithin]with r hr
      rw [← HC.add_closed_ball_zero (le_of_lt hr), add_comm]
    have L2 :
      tendsto (fun ε => μ (closed_ball 0 ε + A '' closed_ball 0 1)) (𝓝[>] 0)
        (𝓝 (d * μ (closed_ball 0 1))) :=
      by
      convert L1
      exact (add_haar_image_continuous_linear_map _ _ _).symm
    have I : d * μ (closed_ball 0 1) < m * μ (closed_ball 0 1) :=
      (ENNReal.mul_lt_mul_right (measure_closed_ball_pos μ _ zero_lt_one).ne'
            measure_closed_ball_lt_top.ne).2
        hm
    have H :
      ∀ᶠ b : ℝ in 𝓝[>] 0, μ (closed_ball 0 b + A '' closed_ball 0 1) < m * μ (closed_ball 0 1) :=
      (tendsto_order.1 L2).2 _ I
    exact (H.and self_mem_nhdsWithin).exists
  have : Iio (⟨ε, εpos.le⟩ : ℝ≥0) ∈ 𝓝 (0 : ℝ≥0) :=
    by
    apply Iio_mem_nhds
    exact εpos
  filter_upwards [this]
  -- fix a function `f` which is close enough to `A`.
  intro δ hδ s f hf
  -- This function expands the volume of any ball by at most `m`
  have I : ∀ x r, x ∈ s → 0 ≤ r → μ (f '' (s ∩ closed_ball x r)) ≤ m * μ (closed_ball x r) :=
    by
    intro x r xs r0
    have K : f '' (s ∩ closed_ball x r) ⊆ A '' closed_ball 0 r + closed_ball (f x) (ε * r) :=
      by
      rintro y ⟨z, ⟨zs, zr⟩, rfl⟩
      apply Set.mem_add.2 ⟨A (z - x), f z - f x - A (z - x) + f x, _, _, _⟩
      · apply mem_image_of_mem
        simpa only [dist_eq_norm, mem_closed_ball, mem_closedBall_zero_iff] using zr
      · rw [mem_closedBall_iff_norm, add_sub_cancel]
        calc
          ‖f z - f x - A (z - x)‖ ≤ δ * ‖z - x‖ := hf _ zs _ xs
          _ ≤ ε * r :=
            mul_le_mul (le_of_lt hδ) (mem_closedBall_iff_norm.1 zr) (norm_nonneg _) εpos.le

      · simp only [map_sub, Pi.sub_apply]
        abel
    have :
      A '' closed_ball 0 r + closed_ball (f x) (ε * r) =
        {f x} + r • (A '' closed_ball 0 1 + closed_ball 0 ε) :=
      by
      rw [smul_add, ← add_assoc, add_comm {f x}, add_assoc, smul_closedBall _ _ εpos.le, smul_zero,
        singleton_add_closedBall_zero, ← image_smul_set ℝ E E A, smul_closedBall _ _ zero_le_one,
        smul_zero, Real.norm_eq_abs, abs_of_nonneg r0, mul_one, mul_comm]
    rw [this] at K
    calc
      μ (f '' (s ∩ closed_ball x r)) ≤ μ ({f x} + r • (A '' closed_ball 0 1 + closed_ball 0 ε)) :=
        measure_mono K
      _ = ENNReal.ofReal (r ^ finrank ℝ E) * μ (A '' closed_ball 0 1 + closed_ball 0 ε) := by
        simp only [abs_of_nonneg r0, add_haar_smul, image_add_left, abs_pow, singleton_add,
          measure_preimage_add]
      _ ≤ ENNReal.ofReal (r ^ finrank ℝ E) * (m * μ (closed_ball 0 1)) :=
        by
        rw [add_comm]
        exact mul_le_mul_left' hε.le _
      _ = m * μ (closed_ball x r) :=
        by
        simp only [add_haar_closed_ball' _ _ r0]
        ring

  -- covering `s` by closed balls with total measure very close to `μ s`, one deduces that the
  -- measure of `f '' s` is at most `m * (μ s + a)` for any positive `a`.
  have J : ∀ᶠ a in 𝓝[>] (0 : ℝ≥0∞), μ (f '' s) ≤ m * (μ s + a) :=
    by
    filter_upwards [self_mem_nhdsWithin]with a ha
    change 0 < a at ha
    obtain ⟨t, r, t_count, ts, rpos, st, μt⟩ :
      ∃ (t : Set E)(r : E → ℝ),
        t.Countable ∧
          t ⊆ s ∧
            (∀ x : E, x ∈ t → 0 < r x) ∧
              (s ⊆ ⋃ x ∈ t, closed_ball x (r x)) ∧
                (∑' x : ↥t, μ (closed_ball (↑x) (r ↑x))) ≤ μ s + a :=
      Besicovitch.exists_closedBall_covering_tsum_measure_le μ ha.ne' (fun x => Ioi 0) s
        fun x xs δ δpos => ⟨δ / 2, by simp [half_pos δpos, half_lt_self δpos]⟩
    haveI : Encodable t := t_count.to_encodable
    calc
      μ (f '' s) ≤ μ (⋃ x : t, f '' (s ∩ closed_ball x (r x))) :=
        by
        rw [bUnion_eq_Union] at st
        apply measure_mono
        rw [← image_Union, ← inter_Union]
        exact image_subset _ (subset_inter (subset.refl _) st)
      _ ≤ ∑' x : t, μ (f '' (s ∩ closed_ball x (r x))) := (measure_Union_le _)
      _ ≤ ∑' x : t, m * μ (closed_ball x (r x)) :=
        (ENNReal.tsum_le_tsum fun x => I x (r x) (ts x.2) (rpos x x.2).le)
      _ ≤ m * (μ s + a) := by
        rw [ENNReal.tsum_mul_left]
        exact mul_le_mul_left' μt _

  -- taking the limit in `a`, one obtains the conclusion
  have L : tendsto (fun a => (m : ℝ≥0∞) * (μ s + a)) (𝓝[>] 0) (𝓝 (m * (μ s + 0))) :=
    by
    apply tendsto.mono_left _ nhdsWithin_le_nhds
    apply ENNReal.Tendsto.const_mul (tendsto_const_nhds.add tendsto_id)
    simp only [ENNReal.coe_ne_top, Ne.def, or_true_iff, not_false_iff]
  rw [add_zero] at L
  exact ge_of_tendsto L J
#align measure_theory.add_haar_image_le_mul_of_det_lt MeasureTheory.add_haar_image_le_mul_of_det_lt

/-- Let `f` be a function which is sufficiently close (in the Lipschitz sense) to a given linear
map `A`. Then it expands the volume of any set by at least `m` for any `m < det A`. -/
theorem mul_le_add_haar_image_of_lt_det (A : E →L[ℝ] E) {m : ℝ≥0}
    (hm : (m : ℝ≥0∞) < ENNReal.ofReal (|A.det|)) :
    ∀ᶠ δ in 𝓝[>] (0 : ℝ≥0),
      ∀ (s : Set E) (f : E → E) (hf : ApproximatesLinearOn f A s δ),
        (m : ℝ≥0∞) * μ s ≤ μ (f '' s) :=
  by
  apply nhdsWithin_le_nhds
  -- The assumption `hm` implies that `A` is invertible. If `f` is close enough to `A`, it is also
  -- invertible. One can then pass to the inverses, and deduce the estimate from
  -- `add_haar_image_le_mul_of_det_lt` applied to `f⁻¹` and `A⁻¹`.
  -- exclude first the trivial case where `m = 0`.
  rcases eq_or_lt_of_le (zero_le m) with (rfl | mpos)
  · apply eventually_of_forall
    simp only [forall_const, MulZeroClass.zero_mul, imp_true_iff, zero_le, ENNReal.coe_zero]
  have hA : A.det ≠ 0 := by
    intro h
    simpa only [h, ENNReal.not_lt_zero, ENNReal.ofReal_zero, abs_zero] using hm
  -- let `B` be the continuous linear equiv version of `A`.
  let B := A.to_continuous_linear_equiv_of_det_ne_zero hA
  -- the determinant of `B.symm` is bounded by `m⁻¹`
  have I : ENNReal.ofReal (|(B.symm : E →L[ℝ] E).det|) < (m⁻¹ : ℝ≥0) :=
    by
    simp only [ENNReal.ofReal, abs_inv, Real.toNNReal_inv, ContinuousLinearEquiv.det_coe_symm,
      ContinuousLinearMap.coe_toContinuousLinearEquivOfDetNeZero, ENNReal.coe_lt_coe] at hm⊢
    exact NNReal.inv_lt_inv mpos.ne' hm
  -- therefore, we may apply `add_haar_image_le_mul_of_det_lt` to `B.symm` and `m⁻¹`.
  obtain ⟨δ₀, δ₀pos, hδ₀⟩ :
    ∃ δ : ℝ≥0,
      0 < δ ∧
        ∀ (t : Set E) (g : E → E),
          ApproximatesLinearOn g (B.symm : E →L[ℝ] E) t δ → μ (g '' t) ≤ ↑m⁻¹ * μ t :=
    by
    have :
      ∀ᶠ δ : ℝ≥0 in 𝓝[>] 0,
        ∀ (t : Set E) (g : E → E),
          ApproximatesLinearOn g (B.symm : E →L[ℝ] E) t δ → μ (g '' t) ≤ ↑m⁻¹ * μ t :=
      add_haar_image_le_mul_of_det_lt μ B.symm I
    rcases(this.and self_mem_nhdsWithin).exists with ⟨δ₀, h, h'⟩
    exact ⟨δ₀, h', h⟩
  -- record smallness conditions for `δ` that will be needed to apply `hδ₀` below.
  have L1 : ∀ᶠ δ in 𝓝 (0 : ℝ≥0), Subsingleton E ∨ δ < ‖(B.symm : E →L[ℝ] E)‖₊⁻¹ :=
    by
    by_cases Subsingleton E
    · simp only [h, true_or_iff, eventually_const]
    simp only [h, false_or_iff]
    apply Iio_mem_nhds
    simpa only [h, false_or_iff, inv_pos] using B.subsingleton_or_nnnorm_symm_pos
  have L2 :
    ∀ᶠ δ in 𝓝 (0 : ℝ≥0), ‖(B.symm : E →L[ℝ] E)‖₊ * (‖(B.symm : E →L[ℝ] E)‖₊⁻¹ - δ)⁻¹ * δ < δ₀ :=
    by
    have :
      tendsto (fun δ => ‖(B.symm : E →L[ℝ] E)‖₊ * (‖(B.symm : E →L[ℝ] E)‖₊⁻¹ - δ)⁻¹ * δ) (𝓝 0)
        (𝓝 (‖(B.symm : E →L[ℝ] E)‖₊ * (‖(B.symm : E →L[ℝ] E)‖₊⁻¹ - 0)⁻¹ * 0)) :=
      by
      rcases eq_or_ne ‖(B.symm : E →L[ℝ] E)‖₊ 0 with (H | H)
      · simpa only [H, MulZeroClass.zero_mul] using tendsto_const_nhds
      refine' tendsto.mul (tendsto_const_nhds.mul _) tendsto_id
      refine' (tendsto.sub tendsto_const_nhds tendsto_id).inv₀ _
      simpa only [tsub_zero, inv_eq_zero, Ne.def] using H
    simp only [MulZeroClass.mul_zero] at this
    exact (tendsto_order.1 this).2 δ₀ δ₀pos
  -- let `δ` be small enough, and `f` approximated by `B` up to `δ`.
  filter_upwards [L1, L2]
  intro δ h1δ h2δ s f hf
  have hf' : ApproximatesLinearOn f (B : E →L[ℝ] E) s δ :=
    by
    convert hf
    exact A.coe_to_continuous_linear_equiv_of_det_ne_zero _
  let F := hf'.to_local_equiv h1δ
  -- the condition to be checked can be reformulated in terms of the inverse maps
  suffices H : μ (F.symm '' F.target) ≤ (m⁻¹ : ℝ≥0) * μ F.target
  · change (m : ℝ≥0∞) * μ F.source ≤ μ F.target
    rwa [← F.symm_image_target_eq_source, mul_comm, ← ENNReal.le_div_iff_mul_le, div_eq_mul_inv,
      mul_comm, ← ENNReal.coe_inv mpos.ne']
    · apply Or.inl
      simpa only [ENNReal.coe_eq_zero, Ne.def] using mpos.ne'
    · simp only [ENNReal.coe_ne_top, true_or_iff, Ne.def, not_false_iff]
  -- as `f⁻¹` is well approximated by `B⁻¹`, the conclusion follows from `hδ₀`
  -- and our choice of `δ`.
  exact hδ₀ _ _ ((hf'.to_inv h1δ).mono_num h2δ.le)
#align measure_theory.mul_le_add_haar_image_of_lt_det MeasureTheory.mul_le_add_haar_image_of_lt_det

/-- If a differentiable function `f` is approximated by a linear map `A` on a set `s`, up to `δ`,
then at almost every `x` in `s` one has `‖f' x - A‖ ≤ δ`. -/
theorem ApproximatesLinearOn.norm_fderiv_sub_le {A : E →L[ℝ] E} {δ : ℝ≥0}
    (hf : ApproximatesLinearOn f A s δ) (hs : MeasurableSet s) (f' : E → E →L[ℝ] E)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) : ∀ᵐ x ∂μ.restrict s, ‖f' x - A‖₊ ≤ δ :=
  by
  /- The conclusion will hold at the Lebesgue density points of `s` (which have full measure).
    At such a point `x`, for any `z` and any `ε > 0` one has for small `r`
    that `{x} + r • closed_ball z ε` intersects `s`. At a point `y` in the intersection,
    `f y - f x` is close both to `f' x (r z)` (by differentiability) and to `A (r z)`
    (by linear approximation), so these two quantities are close, i.e., `(f' x - A) z` is small. -/
  filter_upwards [Besicovitch.ae_tendsto_measure_inter_div μ s, ae_restrict_mem hs]
  -- start from a Lebesgue density point `x`, belonging to `s`.
  intro x hx xs
  -- consider an arbitrary vector `z`.
  apply ContinuousLinearMap.op_norm_le_bound _ δ.2 fun z => _
  -- to show that `‖(f' x - A) z‖ ≤ δ ‖z‖`, it suffices to do it up to some error that vanishes
  -- asymptotically in terms of `ε > 0`.
  suffices H : ∀ ε, 0 < ε → ‖(f' x - A) z‖ ≤ (δ + ε) * (‖z‖ + ε) + ‖f' x - A‖ * ε
  · have :
      tendsto (fun ε : ℝ => ((δ : ℝ) + ε) * (‖z‖ + ε) + ‖f' x - A‖ * ε) (𝓝[>] 0)
        (𝓝 ((δ + 0) * (‖z‖ + 0) + ‖f' x - A‖ * 0)) :=
      tendsto.mono_left (Continuous.tendsto (by continuity) 0) nhdsWithin_le_nhds
    simp only [add_zero, MulZeroClass.mul_zero] at this
    apply le_of_tendsto_of_tendsto tendsto_const_nhds this
    filter_upwards [self_mem_nhdsWithin]
    exact H
  -- fix a positive `ε`.
  intro ε εpos
  -- for small enough `r`, the rescaled ball `r • closed_ball z ε` intersects `s`, as `x` is a
  -- density point
  have B₁ : ∀ᶠ r in 𝓝[>] (0 : ℝ), (s ∩ ({x} + r • closed_ball z ε)).Nonempty :=
    eventually_nonempty_inter_smul_of_density_one μ s x hx _ measurableSet_closedBall
      (measure_closed_ball_pos μ z εpos).ne'
  obtain ⟨ρ, ρpos, hρ⟩ :
    ∃ ρ > 0, ball x ρ ∩ s ⊆ { y : E | ‖f y - f x - (f' x) (y - x)‖ ≤ ε * ‖y - x‖ } :=
    mem_nhds_within_iff.1 (is_o.def (hf' x xs) εpos)
  -- for small enough `r`, the rescaled ball `r • closed_ball z ε` is included in the set where
  -- `f y - f x` is well approximated by `f' x (y - x)`.
  have B₂ : ∀ᶠ r in 𝓝[>] (0 : ℝ), {x} + r • closed_ball z ε ⊆ ball x ρ :=
    nhdsWithin_le_nhds
      (eventually_singleton_add_smul_subset bounded_closed_ball (ball_mem_nhds x ρpos))
  -- fix a small positive `r` satisfying the above properties, as well as a corresponding `y`.
  obtain ⟨r, ⟨y, ⟨ys, hy⟩⟩, rρ, rpos⟩ :
    ∃ r : ℝ,
      (s ∩ ({x} + r • closed_ball z ε)).Nonempty ∧ {x} + r • closed_ball z ε ⊆ ball x ρ ∧ 0 < r :=
    (B₁.and (B₂.and self_mem_nhdsWithin)).exists
  -- write `y = x + r a` with `a ∈ closed_ball z ε`.
  obtain ⟨a, az, ya⟩ : ∃ a, a ∈ closed_ball z ε ∧ y = x + r • a :=
    by
    simp only [mem_smul_set, image_add_left, mem_preimage, singleton_add] at hy
    rcases hy with ⟨a, az, ha⟩
    exact ⟨a, az, by simp only [ha, add_neg_cancel_left]⟩
  have norm_a : ‖a‖ ≤ ‖z‖ + ε :=
    calc
      ‖a‖ = ‖z + (a - z)‖ := by simp only [add_sub_cancel'_right]
      _ ≤ ‖z‖ + ‖a - z‖ := (norm_add_le _ _)
      _ ≤ ‖z‖ + ε := add_le_add_left (mem_closedBall_iff_norm.1 az) _

  -- use the approximation properties to control `(f' x - A) a`, and then `(f' x - A) z` as `z` is
  -- close to `a`.
  have I : r * ‖(f' x - A) a‖ ≤ r * (δ + ε) * (‖z‖ + ε) :=
    calc
      r * ‖(f' x - A) a‖ = ‖(f' x - A) (r • a)‖ := by
        simp only [ContinuousLinearMap.map_smul, norm_smul, Real.norm_eq_abs, abs_of_nonneg rpos.le]
      _ = ‖f y - f x - A (y - x) - (f y - f x - (f' x) (y - x))‖ :=
        by
        congr 1
        simp only [ya, add_sub_cancel', sub_sub_sub_cancel_left, ContinuousLinearMap.coe_sub',
          eq_self_iff_true, sub_left_inj, Pi.sub_apply, ContinuousLinearMap.map_smul, smul_sub]
      _ ≤ ‖f y - f x - A (y - x)‖ + ‖f y - f x - (f' x) (y - x)‖ := (norm_sub_le _ _)
      _ ≤ δ * ‖y - x‖ + ε * ‖y - x‖ := (add_le_add (hf _ ys _ xs) (hρ ⟨rρ hy, ys⟩))
      _ = r * (δ + ε) * ‖a‖ :=
        by
        simp only [ya, add_sub_cancel', norm_smul, Real.norm_eq_abs, abs_of_nonneg rpos.le]
        ring
      _ ≤ r * (δ + ε) * (‖z‖ + ε) :=
        mul_le_mul_of_nonneg_left norm_a (mul_nonneg rpos.le (add_nonneg δ.2 εpos.le))

  show ‖(f' x - A) z‖ ≤ (δ + ε) * (‖z‖ + ε) + ‖f' x - A‖ * ε
  exact
    calc
      ‖(f' x - A) z‖ = ‖(f' x - A) a + (f' x - A) (z - a)‖ :=
        by
        congr 1
        simp only [ContinuousLinearMap.coe_sub', map_sub, Pi.sub_apply]
        abel
      _ ≤ ‖(f' x - A) a‖ + ‖(f' x - A) (z - a)‖ := (norm_add_le _ _)
      _ ≤ (δ + ε) * (‖z‖ + ε) + ‖f' x - A‖ * ‖z - a‖ :=
        by
        apply add_le_add
        · rw [mul_assoc] at I
          exact (mul_le_mul_left rpos).1 I
        · apply ContinuousLinearMap.le_op_norm
      _ ≤ (δ + ε) * (‖z‖ + ε) + ‖f' x - A‖ * ε :=
        add_le_add le_rfl
          (mul_le_mul_of_nonneg_left (mem_closedBall_iff_norm'.1 az) (norm_nonneg _))

#align approximates_linear_on.norm_fderiv_sub_le ApproximatesLinearOn.norm_fderiv_sub_le

/-!
### Measure zero of the image, over non-measurable sets

If a set has measure `0`, then its image under a differentiable map has measure zero. This doesn't
require the set to be measurable. In the same way, if `f` is differentiable on a set `s` with
non-invertible derivative everywhere, then `f '' s` has measure `0`, again without measurability
assumptions.
-/

/-- A differentiable function maps sets of measure zero to sets of measure zero. -/
theorem add_haar_image_eq_zero_of_differentiableOn_of_add_haar_eq_zero (hf : DifferentiableOn ℝ f s)
    (hs : μ s = 0) : μ (f '' s) = 0 :=
  by
  refine' le_antisymm _ (zero_le _)
  have :
    ∀ A : E →L[ℝ] E,
      ∃ δ : ℝ≥0,
        0 < δ ∧
          ∀ (t : Set E) (hf : ApproximatesLinearOn f A t δ),
            μ (f '' t) ≤ (Real.toNNReal (|A.det|) + 1 : ℝ≥0) * μ t :=
    by
    intro A
    let m : ℝ≥0 := Real.toNNReal (|A.det|) + 1
    have I : ENNReal.ofReal (|A.det|) < m := by
      simp only [ENNReal.ofReal, m, lt_add_iff_pos_right, zero_lt_one, ENNReal.coe_lt_coe]
    rcases((add_haar_image_le_mul_of_det_lt μ A I).And self_mem_nhdsWithin).exists with ⟨δ, h, h'⟩
    exact ⟨δ, h', fun t ht => h t f ht⟩
  choose δ hδ using this
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] E),
      Pairwise (Disjoint on t) ∧
        (∀ n : ℕ, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n : ℕ, t n) ∧
            (∀ n : ℕ, ApproximatesLinearOn f (A n) (s ∩ t n) (δ (A n))) ∧
              (s.nonempty → ∀ n, ∃ y ∈ s, A n = fderivWithin ℝ f s y) :=
    exists_partition_approximatesLinearOn_of_hasFderivWithinAt f s (fderivWithin ℝ f s)
      (fun x xs => (hf x xs).HasFderivWithinAt) δ fun A => (hδ A).1.ne'
  calc
    μ (f '' s) ≤ μ (⋃ n, f '' (s ∩ t n)) :=
      by
      apply measure_mono
      rw [← image_Union, ← inter_Union]
      exact image_subset f (subset_inter subset.rfl t_cover)
    _ ≤ ∑' n, μ (f '' (s ∩ t n)) := (measure_Union_le _)
    _ ≤ ∑' n, (Real.toNNReal (|(A n).det|) + 1 : ℝ≥0) * μ (s ∩ t n) :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply (hδ (A n)).2
      exact ht n
    _ ≤ ∑' n, (Real.toNNReal (|(A n).det|) + 1 : ℝ≥0) * 0 :=
      by
      refine' ENNReal.tsum_le_tsum fun n => mul_le_mul_left' _ _
      exact le_trans (measure_mono (inter_subset_left _ _)) (le_of_eq hs)
    _ = 0 := by simp only [tsum_zero, MulZeroClass.mul_zero]

#align measure_theory.add_haar_image_eq_zero_of_differentiable_on_of_add_haar_eq_zero MeasureTheory.add_haar_image_eq_zero_of_differentiableOn_of_add_haar_eq_zero

/-- A version of Sard lemma in fixed dimension: given a differentiable function from `E` to `E` and
a set where the differential is not invertible, then the image of this set has zero measure.
Here, we give an auxiliary statement towards this result. -/
theorem add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (R : ℝ) (hs : s ⊆ closedBall 0 R) (ε : ℝ≥0)
    (εpos : 0 < ε) (h'f' : ∀ x ∈ s, (f' x).det = 0) : μ (f '' s) ≤ ε * μ (closedBall 0 R) :=
  by
  rcases eq_empty_or_nonempty s with (rfl | h's)
  · simp only [measure_empty, zero_le, image_empty]
  have :
    ∀ A : E →L[ℝ] E,
      ∃ δ : ℝ≥0,
        0 < δ ∧
          ∀ (t : Set E) (hf : ApproximatesLinearOn f A t δ),
            μ (f '' t) ≤ (Real.toNNReal (|A.det|) + ε : ℝ≥0) * μ t :=
    by
    intro A
    let m : ℝ≥0 := Real.toNNReal (|A.det|) + ε
    have I : ENNReal.ofReal (|A.det|) < m := by
      simp only [ENNReal.ofReal, m, lt_add_iff_pos_right, εpos, ENNReal.coe_lt_coe]
    rcases((add_haar_image_le_mul_of_det_lt μ A I).And self_mem_nhdsWithin).exists with ⟨δ, h, h'⟩
    exact ⟨δ, h', fun t ht => h t f ht⟩
  choose δ hδ using this
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, Af'⟩ :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] E),
      Pairwise (Disjoint on t) ∧
        (∀ n : ℕ, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n : ℕ, t n) ∧
            (∀ n : ℕ, ApproximatesLinearOn f (A n) (s ∩ t n) (δ (A n))) ∧
              (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
    exists_partition_approximatesLinearOn_of_hasFderivWithinAt f s f' hf' δ fun A => (hδ A).1.ne'
  calc
    μ (f '' s) ≤ μ (⋃ n, f '' (s ∩ t n)) :=
      by
      apply measure_mono
      rw [← image_Union, ← inter_Union]
      exact image_subset f (subset_inter subset.rfl t_cover)
    _ ≤ ∑' n, μ (f '' (s ∩ t n)) := (measure_Union_le _)
    _ ≤ ∑' n, (Real.toNNReal (|(A n).det|) + ε : ℝ≥0) * μ (s ∩ t n) :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply (hδ (A n)).2
      exact ht n
    _ = ∑' n, ε * μ (s ∩ t n) := by
      congr with n
      rcases Af' h's n with ⟨y, ys, hy⟩
      simp only [hy, h'f' y ys, Real.toNNReal_zero, abs_zero, zero_add]
    _ ≤ ε * ∑' n, μ (closed_ball 0 R ∩ t n) :=
      by
      rw [ENNReal.tsum_mul_left]
      refine' mul_le_mul_left' (ENNReal.tsum_le_tsum fun n => measure_mono _) _
      exact inter_subset_inter_left _ hs
    _ = ε * μ (⋃ n, closed_ball 0 R ∩ t n) :=
      by
      rw [measure_Union]
      · exact pairwise_disjoint_mono t_disj fun n => inter_subset_right _ _
      · intro n
        exact measurable_set_closed_ball.inter (t_meas n)
    _ ≤ ε * μ (closed_ball 0 R) := by
      rw [← inter_Union]
      exact mul_le_mul_left' (measure_mono (inter_subset_left _ _)) _

#align measure_theory.add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux MeasureTheory.add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux

/-- A version of Sard lemma in fixed dimension: given a differentiable function from `E` to `E` and
a set where the differential is not invertible, then the image of this set has zero measure. -/
theorem add_haar_image_eq_zero_of_det_fderiv_within_eq_zero
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (h'f' : ∀ x ∈ s, (f' x).det = 0) :
    μ (f '' s) = 0 := by
  suffices H : ∀ R, μ (f '' (s ∩ closed_ball 0 R)) = 0
  · apply le_antisymm _ (zero_le _)
    rw [← Union_inter_closed_ball_nat s 0]
    calc
      μ (f '' ⋃ n : ℕ, s ∩ closed_ball 0 n) ≤ ∑' n : ℕ, μ (f '' (s ∩ closed_ball 0 n)) :=
        by
        rw [image_Union]
        exact measure_Union_le _
      _ ≤ 0 := by simp only [H, tsum_zero, nonpos_iff_eq_zero]

  intro R
  have A : ∀ (ε : ℝ≥0) (εpos : 0 < ε), μ (f '' (s ∩ closed_ball 0 R)) ≤ ε * μ (closed_ball 0 R) :=
    fun ε εpos =>
    add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux μ
      (fun x hx => (hf' x hx.1).mono (inter_subset_left _ _)) R (inter_subset_right _ _) ε εpos
      fun x hx => h'f' x hx.1
  have B : tendsto (fun ε : ℝ≥0 => (ε : ℝ≥0∞) * μ (closed_ball 0 R)) (𝓝[>] 0) (𝓝 0) :=
    by
    have :
      tendsto (fun ε : ℝ≥0 => (ε : ℝ≥0∞) * μ (closed_ball 0 R)) (𝓝 0)
        (𝓝 (((0 : ℝ≥0) : ℝ≥0∞) * μ (closed_ball 0 R))) :=
      ENNReal.Tendsto.mul_const (ENNReal.tendsto_coe.2 tendsto_id)
        (Or.inr measure_closed_ball_lt_top.Ne)
    simp only [MulZeroClass.zero_mul, ENNReal.coe_zero] at this
    exact tendsto.mono_left this nhdsWithin_le_nhds
  apply le_antisymm _ (zero_le _)
  apply ge_of_tendsto B
  filter_upwards [self_mem_nhdsWithin]
  exact A
#align measure_theory.add_haar_image_eq_zero_of_det_fderiv_within_eq_zero MeasureTheory.add_haar_image_eq_zero_of_det_fderiv_within_eq_zero

/-!
### Weak measurability statements

We show that the derivative of a function on a set is almost everywhere measurable, and that the
image `f '' s` is measurable if `f` is injective on `s`. The latter statement follows from the
Lusin-Souslin theorem.
-/

/-- The derivative of a function on a measurable set is almost everywhere measurable on this set
with respect to Lebesgue measure. Note that, in general, it is not genuinely measurable there,
as `f'` is not unique (but only on a set of measure `0`, as the argument shows). -/
theorem aeMeasurableFderivWithin (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) : AeMeasurable f' (μ.restrict s) :=
  by
  /- It suffices to show that `f'` can be uniformly approximated by a measurable function.
    Fix `ε > 0`. Thanks to `exists_partition_approximates_linear_on_of_has_fderiv_within_at`, one
    can find a countable measurable partition of `s` into sets `s ∩ t n` on which `f` is well
    approximated by linear maps `A n`. On almost all of `s ∩ t n`, it follows from
    `approximates_linear_on.norm_fderiv_sub_le` that `f'` is uniformly approximated by `A n`, which
    gives the conclusion. -/
  -- fix a precision `ε`
  refine' aeMeasurableOfUnifApprox fun ε εpos => _
  let δ : ℝ≥0 := ⟨ε, le_of_lt εpos⟩
  have δpos : 0 < δ := εpos
  -- partition `s` into sets `s ∩ t n` on which `f` is approximated by linear maps `A n`.
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, Af'⟩ :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] E),
      Pairwise (Disjoint on t) ∧
        (∀ n : ℕ, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n : ℕ, t n) ∧
            (∀ n : ℕ, ApproximatesLinearOn f (A n) (s ∩ t n) δ) ∧
              (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
    exists_partition_approximatesLinearOn_of_hasFderivWithinAt f s f' hf' (fun A => δ) fun A =>
      δpos.ne'
  -- define a measurable function `g` which coincides with `A n` on `t n`.
  obtain ⟨g, g_meas, hg⟩ :
    ∃ g : E → E →L[ℝ] E, Measurable g ∧ ∀ (n : ℕ) (x : E), x ∈ t n → g x = A n :=
    exists_measurable_piecewise_nat t t_meas t_disj (fun n x => A n) fun n => measurable_const
  refine' ⟨g, g_meas.ae_measurable, _⟩
  -- reduce to checking that `f'` and `g` are close on almost all of `s ∩ t n`, for all `n`.
  suffices H : ∀ᵐ x : E ∂Sum fun n => μ.restrict (s ∩ t n), dist (g x) (f' x) ≤ ε
  · have : μ.restrict s ≤ Sum fun n => μ.restrict (s ∩ t n) :=
      by
      have : s = ⋃ n, s ∩ t n := by
        rw [← inter_Union]
        exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _)
      conv_lhs => rw [this]
      exact restrict_Union_le
    exact ae_mono this H
  -- fix such an `n`.
  refine' ae_sum_iff.2 fun n => _
  -- on almost all `s ∩ t n`, `f' x` is close to `A n` thanks to
  -- `approximates_linear_on.norm_fderiv_sub_le`.
  have E₁ : ∀ᵐ x : E ∂μ.restrict (s ∩ t n), ‖f' x - A n‖₊ ≤ δ :=
    (ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f' fun x hx =>
      (hf' x hx.1).mono (inter_subset_left _ _)
  -- moreover, `g x` is equal to `A n` there.
  have E₂ : ∀ᵐ x : E ∂μ.restrict (s ∩ t n), g x = A n :=
    by
    suffices H : ∀ᵐ x : E ∂μ.restrict (t n), g x = A n
    exact ae_mono (restrict_mono (inter_subset_right _ _) le_rfl) H
    filter_upwards [ae_restrict_mem (t_meas n)]
    exact hg n
  -- putting these two properties together gives the conclusion.
  filter_upwards [E₁, E₂]with x hx1 hx2
  rw [← nndist_eq_nnnorm] at hx1
  rw [hx2, dist_comm]
  exact hx1
#align measure_theory.ae_measurable_fderiv_within MeasureTheory.aeMeasurableFderivWithin

theorem aeMeasurableOfRealAbsDetFderivWithin (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) :
    AeMeasurable (fun x => ENNReal.ofReal (|(f' x).det|)) (μ.restrict s) :=
  by
  apply ennreal.measurable_of_real.comp_ae_measurable
  refine' continuous_abs.measurable.comp_ae_measurable _
  refine' continuous_linear_map.continuous_det.measurable.comp_ae_measurable _
  exact ae_measurable_fderiv_within μ hs hf'
#align measure_theory.ae_measurable_of_real_abs_det_fderiv_within MeasureTheory.aeMeasurableOfRealAbsDetFderivWithin

theorem aeMeasurableToNnrealAbsDetFderivWithin (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) :
    AeMeasurable (fun x => |(f' x).det|.toNNReal) (μ.restrict s) :=
  by
  apply measurable_real_to_nnreal.comp_ae_measurable
  refine' continuous_abs.measurable.comp_ae_measurable _
  refine' continuous_linear_map.continuous_det.measurable.comp_ae_measurable _
  exact ae_measurable_fderiv_within μ hs hf'
#align measure_theory.ae_measurable_to_nnreal_abs_det_fderiv_within MeasureTheory.aeMeasurableToNnrealAbsDetFderivWithin

/-- If a function is differentiable and injective on a measurable set,
then the image is measurable.-/
theorem measurable_image_of_fderiv_within (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) : MeasurableSet (f '' s) :=
  haveI : DifferentiableOn ℝ f s := fun x hx => (hf' x hx).DifferentiableWithinAt
  hs.image_of_continuous_on_inj_on (DifferentiableOn.continuousOn this) hf
#align measure_theory.measurable_image_of_fderiv_within MeasureTheory.measurable_image_of_fderiv_within

/-- If a function is differentiable and injective on a measurable set `s`, then its restriction
to `s` is a measurable embedding. -/
theorem measurableEmbedding_of_fderiv_within (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) :
    MeasurableEmbedding (s.restrict f) :=
  haveI : DifferentiableOn ℝ f s := fun x hx => (hf' x hx).DifferentiableWithinAt
  this.continuous_on.measurable_embedding hs hf
#align measure_theory.measurable_embedding_of_fderiv_within MeasureTheory.measurableEmbedding_of_fderiv_within

/-!
### Proving the estimate for the measure of the image

We show the formula `∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ = μ (f '' s)`,
in `lintegral_abs_det_fderiv_eq_add_haar_image`. For this, we show both inequalities in both
directions, first up to controlled errors and then letting these errors tend to `0`.
-/

theorem add_haar_image_le_lintegral_abs_det_fderiv_aux1 (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) {ε : ℝ≥0} (εpos : 0 < ε) :
    μ (f '' s) ≤ (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) + 2 * ε * μ s :=
  by
  /- To bound `μ (f '' s)`, we cover `s` by sets where `f` is well-approximated by linear maps
    `A n` (and where `f'` is almost everywhere close to `A n`), and then use that `f` expands the
    measure of such a set by at most `(A n).det + ε`. -/
  have :
    ∀ A : E →L[ℝ] E,
      ∃ δ : ℝ≥0,
        0 < δ ∧
          (∀ B : E →L[ℝ] E, ‖B - A‖ ≤ δ → |B.det - A.det| ≤ ε) ∧
            ∀ (t : Set E) (g : E → E) (hf : ApproximatesLinearOn g A t δ),
              μ (g '' t) ≤ (ENNReal.ofReal (|A.det|) + ε) * μ t :=
    by
    intro A
    let m : ℝ≥0 := Real.toNNReal (|A.det|) + ε
    have I : ENNReal.ofReal (|A.det|) < m := by
      simp only [ENNReal.ofReal, m, lt_add_iff_pos_right, εpos, ENNReal.coe_lt_coe]
    rcases((add_haar_image_le_mul_of_det_lt μ A I).And self_mem_nhdsWithin).exists with ⟨δ, h, δpos⟩
    obtain ⟨δ', δ'pos, hδ'⟩ : ∃ (δ' : ℝ)(H : 0 < δ'), ∀ B, dist B A < δ' → dist B.det A.det < ↑ε :=
      continuous_at_iff.1 continuous_linear_map.continuous_det.continuous_at ε εpos
    let δ'' : ℝ≥0 := ⟨δ' / 2, (half_pos δ'pos).le⟩
    refine' ⟨min δ δ'', lt_min δpos (half_pos δ'pos), _, _⟩
    · intro B hB
      rw [← Real.dist_eq]
      apply (hδ' B _).le
      rw [dist_eq_norm]
      calc
        ‖B - A‖ ≤ (min δ δ'' : ℝ≥0) := hB
        _ ≤ δ'' := by simp only [le_refl, NNReal.coe_min, min_le_iff, or_true_iff]
        _ < δ' := half_lt_self δ'pos

    · intro t g htg
      exact h t g (htg.mono_num (min_le_left _ _))
  choose δ hδ using this
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] E),
      Pairwise (Disjoint on t) ∧
        (∀ n : ℕ, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n : ℕ, t n) ∧
            (∀ n : ℕ, ApproximatesLinearOn f (A n) (s ∩ t n) (δ (A n))) ∧
              (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
    exists_partition_approximatesLinearOn_of_hasFderivWithinAt f s f' hf' δ fun A => (hδ A).1.ne'
  calc
    μ (f '' s) ≤ μ (⋃ n, f '' (s ∩ t n)) :=
      by
      apply measure_mono
      rw [← image_Union, ← inter_Union]
      exact image_subset f (subset_inter subset.rfl t_cover)
    _ ≤ ∑' n, μ (f '' (s ∩ t n)) := (measure_Union_le _)
    _ ≤ ∑' n, (ENNReal.ofReal (|(A n).det|) + ε) * μ (s ∩ t n) :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply (hδ (A n)).2.2
      exact ht n
    _ = ∑' n, ∫⁻ x in s ∩ t n, ENNReal.ofReal (|(A n).det|) + ε ∂μ := by
      simp only [lintegral_const, MeasurableSet.univ, measure.restrict_apply, univ_inter]
    _ ≤ ∑' n, ∫⁻ x in s ∩ t n, ENNReal.ofReal (|(f' x).det|) + 2 * ε ∂μ :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply lintegral_mono_ae
      filter_upwards [(ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f' fun x hx =>
          (hf' x hx.1).mono (inter_subset_left _ _)]
      intro x hx
      have I : |(A n).det| ≤ |(f' x).det| + ε :=
        calc
          |(A n).det| = |(f' x).det - ((f' x).det - (A n).det)| :=
            by
            congr 1
            abel
          _ ≤ |(f' x).det| + |(f' x).det - (A n).det| := (abs_sub _ _)
          _ ≤ |(f' x).det| + ε := add_le_add le_rfl ((hδ (A n)).2.1 _ hx)

      calc
        ENNReal.ofReal (|(A n).det|) + ε ≤ ENNReal.ofReal (|(f' x).det| + ε) + ε :=
          add_le_add (ENNReal.ofReal_le_ofReal I) le_rfl
        _ = ENNReal.ofReal (|(f' x).det|) + 2 * ε := by
          simp only [ENNReal.ofReal_add, abs_nonneg, two_mul, add_assoc, NNReal.zero_le_coe,
            ENNReal.ofReal_coe_nnreal]

    _ = ∫⁻ x in ⋃ n, s ∩ t n, ENNReal.ofReal (|(f' x).det|) + 2 * ε ∂μ :=
      by
      have M : ∀ n : ℕ, MeasurableSet (s ∩ t n) := fun n => hs.inter (t_meas n)
      rw [lintegral_Union M]
      exact pairwise_disjoint_mono t_disj fun n => inter_subset_right _ _
    _ = ∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) + 2 * ε ∂μ :=
      by
      have : s = ⋃ n, s ∩ t n := by
        rw [← inter_Union]
        exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _)
      rw [← this]
    _ = (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) + 2 * ε * μ s := by
      simp only [lintegral_add_right' _ aeMeasurableConst, set_lintegral_const]

#align measure_theory.add_haar_image_le_lintegral_abs_det_fderiv_aux1 MeasureTheory.add_haar_image_le_lintegral_abs_det_fderiv_aux1

theorem add_haar_image_le_lintegral_abs_det_fderiv_aux2 (hs : MeasurableSet s) (h's : μ s ≠ ∞)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) :
    μ (f '' s) ≤ ∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ :=
  by
  -- We just need to let the error tend to `0` in the previous lemma.
  have :
    tendsto (fun ε : ℝ≥0 => (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) + 2 * ε * μ s) (𝓝[>] 0)
      (𝓝 ((∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) + 2 * (0 : ℝ≥0) * μ s)) :=
    by
    apply tendsto.mono_left _ nhdsWithin_le_nhds
    refine' tendsto_const_nhds.add _
    refine' ENNReal.Tendsto.mul_const _ (Or.inr h's)
    exact ENNReal.Tendsto.const_mul (ENNReal.tendsto_coe.2 tendsto_id) (Or.inr ENNReal.coe_ne_top)
  simp only [add_zero, MulZeroClass.zero_mul, MulZeroClass.mul_zero, ENNReal.coe_zero] at this
  apply ge_of_tendsto this
  filter_upwards [self_mem_nhdsWithin]
  rintro ε (εpos : 0 < ε)
  exact add_haar_image_le_lintegral_abs_det_fderiv_aux1 μ hs hf' εpos
#align measure_theory.add_haar_image_le_lintegral_abs_det_fderiv_aux2 MeasureTheory.add_haar_image_le_lintegral_abs_det_fderiv_aux2

theorem add_haar_image_le_lintegral_abs_det_fderiv (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) :
    μ (f '' s) ≤ ∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ :=
  by
  /- We already know the result for finite-measure sets. We cover `s` by finite-measure sets using
    `spanning_sets μ`, and apply the previous result to each of these parts. -/
  let u n := disjointed (spanning_sets μ) n
  have u_meas : ∀ n, MeasurableSet (u n) := by
    intro n
    apply MeasurableSet.disjointed fun i => _
    exact measurable_spanning_sets μ i
  have A : s = ⋃ n, s ∩ u n := by
    rw [← inter_Union, unionᵢ_disjointed, Union_spanning_sets, inter_univ]
  calc
    μ (f '' s) ≤ ∑' n, μ (f '' (s ∩ u n)) :=
      by
      conv_lhs => rw [A, image_Union]
      exact measure_Union_le _
    _ ≤ ∑' n, ∫⁻ x in s ∩ u n, ENNReal.ofReal (|(f' x).det|) ∂μ :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply
        add_haar_image_le_lintegral_abs_det_fderiv_aux2 μ (hs.inter (u_meas n)) _ fun x hx =>
          (hf' x hx.1).mono (inter_subset_left _ _)
      have : μ (u n) < ∞ :=
        lt_of_le_of_lt (measure_mono (disjointed_subset _ _)) (measure_spanning_sets_lt_top μ n)
      exact ne_of_lt (lt_of_le_of_lt (measure_mono (inter_subset_right _ _)) this)
    _ = ∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ :=
      by
      conv_rhs => rw [A]
      rw [lintegral_Union]
      · intro n
        exact hs.inter (u_meas n)
      · exact pairwise_disjoint_mono (disjoint_disjointed _) fun n => inter_subset_right _ _

#align measure_theory.add_haar_image_le_lintegral_abs_det_fderiv MeasureTheory.add_haar_image_le_lintegral_abs_det_fderiv

theorem lintegral_abs_det_fderiv_le_add_haar_image_aux1 (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) {ε : ℝ≥0} (εpos : 0 < ε) :
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) ≤ μ (f '' s) + 2 * ε * μ s :=
  by
  /- To bound `∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ`, we cover `s` by sets where `f` is
    well-approximated by linear maps `A n` (and where `f'` is almost everywhere close to `A n`),
    and then use that `f` expands the measure of such a set by at least `(A n).det - ε`. -/
  have :
    ∀ A : E →L[ℝ] E,
      ∃ δ : ℝ≥0,
        0 < δ ∧
          (∀ B : E →L[ℝ] E, ‖B - A‖ ≤ δ → |B.det - A.det| ≤ ε) ∧
            ∀ (t : Set E) (g : E → E) (hf : ApproximatesLinearOn g A t δ),
              ENNReal.ofReal (|A.det|) * μ t ≤ μ (g '' t) + ε * μ t :=
    by
    intro A
    obtain ⟨δ', δ'pos, hδ'⟩ : ∃ (δ' : ℝ)(H : 0 < δ'), ∀ B, dist B A < δ' → dist B.det A.det < ↑ε :=
      continuous_at_iff.1 continuous_linear_map.continuous_det.continuous_at ε εpos
    let δ'' : ℝ≥0 := ⟨δ' / 2, (half_pos δ'pos).le⟩
    have I'' : ∀ B : E →L[ℝ] E, ‖B - A‖ ≤ ↑δ'' → |B.det - A.det| ≤ ↑ε :=
      by
      intro B hB
      rw [← Real.dist_eq]
      apply (hδ' B _).le
      rw [dist_eq_norm]
      exact hB.trans_lt (half_lt_self δ'pos)
    rcases eq_or_ne A.det 0 with (hA | hA)
    · refine' ⟨δ'', half_pos δ'pos, I'', _⟩
      simp only [hA, forall_const, MulZeroClass.zero_mul, ENNReal.ofReal_zero, imp_true_iff,
        zero_le, abs_zero]
    let m : ℝ≥0 := Real.toNNReal (|A.det|) - ε
    have I : (m : ℝ≥0∞) < ENNReal.ofReal (|A.det|) :=
      by
      simp only [ENNReal.ofReal, WithTop.coe_sub]
      apply ENNReal.sub_lt_self ENNReal.coe_ne_top
      · simpa only [abs_nonpos_iff, Real.toNNReal_eq_zero, ENNReal.coe_eq_zero, Ne.def] using hA
      · simp only [εpos.ne', ENNReal.coe_eq_zero, Ne.def, not_false_iff]
    rcases((mul_le_add_haar_image_of_lt_det μ A I).And self_mem_nhdsWithin).exists with ⟨δ, h, δpos⟩
    refine' ⟨min δ δ'', lt_min δpos (half_pos δ'pos), _, _⟩
    · intro B hB
      apply I'' _ (hB.trans _)
      simp only [le_refl, NNReal.coe_min, min_le_iff, or_true_iff]
    · intro t g htg
      rcases eq_or_ne (μ t) ∞ with (ht | ht)
      ·
        simp only [ht, εpos.ne', WithTop.mul_top, ENNReal.coe_eq_zero, le_top, Ne.def,
          not_false_iff, _root_.add_top]
      have := h t g (htg.mono_num (min_le_left _ _))
      rwa [WithTop.coe_sub, ENNReal.sub_mul, tsub_le_iff_right] at this
      simp only [ht, imp_true_iff, Ne.def, not_false_iff]
  choose δ hδ using this
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ :
    ∃ (t : ℕ → Set E)(A : ℕ → E →L[ℝ] E),
      Pairwise (Disjoint on t) ∧
        (∀ n : ℕ, MeasurableSet (t n)) ∧
          (s ⊆ ⋃ n : ℕ, t n) ∧
            (∀ n : ℕ, ApproximatesLinearOn f (A n) (s ∩ t n) (δ (A n))) ∧
              (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
    exists_partition_approximatesLinearOn_of_hasFderivWithinAt f s f' hf' δ fun A => (hδ A).1.ne'
  have s_eq : s = ⋃ n, s ∩ t n := by
    rw [← inter_Union]
    exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _)
  calc
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) =
        ∑' n, ∫⁻ x in s ∩ t n, ENNReal.ofReal (|(f' x).det|) ∂μ :=
      by
      conv_lhs => rw [s_eq]
      rw [lintegral_Union]
      · exact fun n => hs.inter (t_meas n)
      · exact pairwise_disjoint_mono t_disj fun n => inter_subset_right _ _
    _ ≤ ∑' n, ∫⁻ x in s ∩ t n, ENNReal.ofReal (|(A n).det|) + ε ∂μ :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply lintegral_mono_ae
      filter_upwards [(ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f' fun x hx =>
          (hf' x hx.1).mono (inter_subset_left _ _)]
      intro x hx
      have I : |(f' x).det| ≤ |(A n).det| + ε :=
        calc
          |(f' x).det| = |(A n).det + ((f' x).det - (A n).det)| :=
            by
            congr 1
            abel
          _ ≤ |(A n).det| + |(f' x).det - (A n).det| := (abs_add _ _)
          _ ≤ |(A n).det| + ε := add_le_add le_rfl ((hδ (A n)).2.1 _ hx)

      calc
        ENNReal.ofReal (|(f' x).det|) ≤ ENNReal.ofReal (|(A n).det| + ε) :=
          ENNReal.ofReal_le_ofReal I
        _ = ENNReal.ofReal (|(A n).det|) + ε := by
          simp only [ENNReal.ofReal_add, abs_nonneg, NNReal.zero_le_coe, ENNReal.ofReal_coe_nnreal]

    _ = ∑' n, ENNReal.ofReal (|(A n).det|) * μ (s ∩ t n) + ε * μ (s ∩ t n) := by
      simp only [set_lintegral_const, lintegral_add_right _ measurable_const]
    _ ≤ ∑' n, μ (f '' (s ∩ t n)) + ε * μ (s ∩ t n) + ε * μ (s ∩ t n) :=
      by
      refine' ENNReal.tsum_le_tsum fun n => add_le_add_right _ _
      exact (hδ (A n)).2.2 _ _ (ht n)
    _ = μ (f '' s) + 2 * ε * μ s := by
      conv_rhs => rw [s_eq]
      rw [image_Union, measure_Union]; rotate_left
      · intro i j hij
        apply Disjoint.image _ hf (inter_subset_left _ _) (inter_subset_left _ _)
        exact Disjoint.mono (inter_subset_right _ _) (inter_subset_right _ _) (t_disj hij)
      · intro i
        exact
          measurable_image_of_fderiv_within (hs.inter (t_meas i))
            (fun x hx => (hf' x hx.1).mono (inter_subset_left _ _))
            (hf.mono (inter_subset_left _ _))
      rw [measure_Union]; rotate_left
      · exact pairwise_disjoint_mono t_disj fun i => inter_subset_right _ _
      · exact fun i => hs.inter (t_meas i)
      rw [← ENNReal.tsum_mul_left, ← ENNReal.tsum_add]
      congr 1
      ext1 i
      rw [mul_assoc, two_mul, add_assoc]

#align measure_theory.lintegral_abs_det_fderiv_le_add_haar_image_aux1 MeasureTheory.lintegral_abs_det_fderiv_le_add_haar_image_aux1

theorem lintegral_abs_det_fderiv_le_add_haar_image_aux2 (hs : MeasurableSet s) (h's : μ s ≠ ∞)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) :
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) ≤ μ (f '' s) :=
  by
  -- We just need to let the error tend to `0` in the previous lemma.
  have :
    tendsto (fun ε : ℝ≥0 => μ (f '' s) + 2 * ε * μ s) (𝓝[>] 0)
      (𝓝 (μ (f '' s) + 2 * (0 : ℝ≥0) * μ s)) :=
    by
    apply tendsto.mono_left _ nhdsWithin_le_nhds
    refine' tendsto_const_nhds.add _
    refine' ENNReal.Tendsto.mul_const _ (Or.inr h's)
    exact ENNReal.Tendsto.const_mul (ENNReal.tendsto_coe.2 tendsto_id) (Or.inr ENNReal.coe_ne_top)
  simp only [add_zero, MulZeroClass.zero_mul, MulZeroClass.mul_zero, ENNReal.coe_zero] at this
  apply ge_of_tendsto this
  filter_upwards [self_mem_nhdsWithin]
  rintro ε (εpos : 0 < ε)
  exact lintegral_abs_det_fderiv_le_add_haar_image_aux1 μ hs hf' hf εpos
#align measure_theory.lintegral_abs_det_fderiv_le_add_haar_image_aux2 MeasureTheory.lintegral_abs_det_fderiv_le_add_haar_image_aux2

theorem lintegral_abs_det_fderiv_le_add_haar_image (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) :
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) ≤ μ (f '' s) :=
  by
  /- We already know the result for finite-measure sets. We cover `s` by finite-measure sets using
    `spanning_sets μ`, and apply the previous result to each of these parts. -/
  let u n := disjointed (spanning_sets μ) n
  have u_meas : ∀ n, MeasurableSet (u n) := by
    intro n
    apply MeasurableSet.disjointed fun i => _
    exact measurable_spanning_sets μ i
  have A : s = ⋃ n, s ∩ u n := by
    rw [← inter_Union, unionᵢ_disjointed, Union_spanning_sets, inter_univ]
  calc
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) =
        ∑' n, ∫⁻ x in s ∩ u n, ENNReal.ofReal (|(f' x).det|) ∂μ :=
      by
      conv_lhs => rw [A]
      rw [lintegral_Union]
      · intro n
        exact hs.inter (u_meas n)
      · exact pairwise_disjoint_mono (disjoint_disjointed _) fun n => inter_subset_right _ _
    _ ≤ ∑' n, μ (f '' (s ∩ u n)) :=
      by
      apply ENNReal.tsum_le_tsum fun n => _
      apply
        lintegral_abs_det_fderiv_le_add_haar_image_aux2 μ (hs.inter (u_meas n)) _
          (fun x hx => (hf' x hx.1).mono (inter_subset_left _ _)) (hf.mono (inter_subset_left _ _))
      have : μ (u n) < ∞ :=
        lt_of_le_of_lt (measure_mono (disjointed_subset _ _)) (measure_spanning_sets_lt_top μ n)
      exact ne_of_lt (lt_of_le_of_lt (measure_mono (inter_subset_right _ _)) this)
    _ = μ (f '' s) := by
      conv_rhs => rw [A, image_Union]
      rw [measure_Union]
      · intro i j hij
        apply Disjoint.image _ hf (inter_subset_left _ _) (inter_subset_left _ _)
        exact
          Disjoint.mono (inter_subset_right _ _) (inter_subset_right _ _)
            (disjoint_disjointed _ hij)
      · intro i
        exact
          measurable_image_of_fderiv_within (hs.inter (u_meas i))
            (fun x hx => (hf' x hx.1).mono (inter_subset_left _ _))
            (hf.mono (inter_subset_left _ _))

#align measure_theory.lintegral_abs_det_fderiv_le_add_haar_image MeasureTheory.lintegral_abs_det_fderiv_le_add_haar_image

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the measure of `f '' s` is given by the
integral of `|(f' x).det|` on `s`.
Note that the measurability of `f '' s` is given by `measurable_image_of_fderiv_within`. -/
theorem lintegral_abs_det_fderiv_eq_add_haar_image (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) :
    (∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) ∂μ) = μ (f '' s) :=
  le_antisymm (lintegral_abs_det_fderiv_le_add_haar_image μ hs hf' hf)
    (add_haar_image_le_lintegral_abs_det_fderiv μ hs hf')
#align measure_theory.lintegral_abs_det_fderiv_eq_add_haar_image MeasureTheory.lintegral_abs_det_fderiv_eq_add_haar_image

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the pushforward of the measure with
density `|(f' x).det|` on `s` is the Lebesgue measure on the image set. This version requires
that `f` is measurable, as otherwise `measure.map f` is zero per our definitions.
For a version without measurability assumption but dealing with the restricted
function `s.restrict f`, see `restrict_map_with_density_abs_det_fderiv_eq_add_haar`.
-/
theorem map_withDensity_abs_det_fderiv_eq_add_haar (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) (h'f : Measurable f) :
    Measure.map f ((μ.restrict s).withDensity fun x => ENNReal.ofReal (|(f' x).det|)) =
      μ.restrict (f '' s) :=
  by
  apply measure.ext fun t ht => _
  rw [map_apply h'f ht, with_density_apply _ (h'f ht), measure.restrict_apply ht,
    restrict_restrict (h'f ht),
    lintegral_abs_det_fderiv_eq_add_haar_image μ ((h'f ht).inter hs)
      (fun x hx => (hf' x hx.2).mono (inter_subset_right _ _)) (hf.mono (inter_subset_right _ _)),
    image_preimage_inter]
#align measure_theory.map_with_density_abs_det_fderiv_eq_add_haar MeasureTheory.map_withDensity_abs_det_fderiv_eq_add_haar

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the pushforward of the measure with
density `|(f' x).det|` on `s` is the Lebesgue measure on the image set. This version is expressed
in terms of the restricted function `s.restrict f`.
For a version for the original function, but with a measurability assumption,
see `map_with_density_abs_det_fderiv_eq_add_haar`.
-/
theorem restrict_map_withDensity_abs_det_fderiv_eq_add_haar (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) :
    Measure.map (s.restrict f) (comap coe (μ.withDensity fun x => ENNReal.ofReal (|(f' x).det|))) =
      μ.restrict (f '' s) :=
  by
  obtain ⟨u, u_meas, uf⟩ : ∃ u, Measurable u ∧ eq_on u f s := by
    classical
      refine' ⟨piecewise s f 0, _, piecewise_eq_on _ _ _⟩
      refine' ContinuousOn.measurable_piecewise _ continuous_zero.continuous_on hs
      have : DifferentiableOn ℝ f s := fun x hx => (hf' x hx).DifferentiableWithinAt
      exact this.continuous_on
  have u' : ∀ x ∈ s, HasFderivWithinAt u (f' x) s x := fun x hx =>
    (hf' x hx).congr (fun y hy => uf hy) (uf hx)
  set F : s → E := u ∘ coe with hF
  have A :
    measure.map F (comap coe (μ.with_density fun x => ENNReal.ofReal (|(f' x).det|))) =
      μ.restrict (u '' s) :=
    by
    rw [hF, ← measure.map_map u_meas measurable_subtype_coe, map_comap_subtype_coe hs,
      restrict_with_density hs]
    exact map_with_density_abs_det_fderiv_eq_add_haar μ hs u' (hf.congr uf.symm) u_meas
  rw [uf.image_eq] at A
  have : F = s.restrict f := by
    ext x
    exact uf x.2
  rwa [this] at A
#align measure_theory.restrict_map_with_density_abs_det_fderiv_eq_add_haar MeasureTheory.restrict_map_withDensity_abs_det_fderiv_eq_add_haar

/-! ### Change of variable formulas in integrals -/

/- Change of variable formula for differentiable functions: if a function `f` is
injective and differentiable on a measurable set `s`, then the Lebesgue integral of a function
`g : E → ℝ≥0∞` on `f '' s` coincides with the integral of `|(f' x).det| * g ∘ f` on `s`.
Note that the measurability of `f '' s` is given by `measurable_image_of_fderiv_within`. -/
theorem lintegral_image_eq_lintegral_abs_det_fderiv_mul (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) (g : E → ℝ≥0∞) :
    (∫⁻ x in f '' s, g x ∂μ) = ∫⁻ x in s, ENNReal.ofReal (|(f' x).det|) * g (f x) ∂μ :=
  by
  rw [← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
    (measurable_embedding_of_fderiv_within hs hf' hf).lintegral_map]
  have : ∀ x : s, g (s.restrict f x) = (g ∘ f) x := fun x => rfl
  simp only [this]
  rw [← (MeasurableEmbedding.subtype_coe hs).lintegral_map, map_comap_subtype_coe hs,
    set_lintegral_with_density_eq_set_lintegral_mul_non_measurable₀ _ _ _ hs]
  · rfl
  · simp only [eventually_true, ENNReal.ofReal_lt_top]
  · exact ae_measurable_of_real_abs_det_fderiv_within μ hs hf'
#align measure_theory.lintegral_image_eq_lintegral_abs_det_fderiv_mul MeasureTheory.lintegral_image_eq_lintegral_abs_det_fderiv_mul

/-- Integrability in the change of variable formula for differentiable functions: if a
function `f` is injective and differentiable on a measurable set `s`, then a function
`g : E → F` is integrable on `f '' s` if and only if `|(f' x).det| • g ∘ f` is
integrable on `s`. -/
theorem integrableOn_image_iff_integrableOn_abs_det_fderiv_smul (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) (g : E → F) :
    IntegrableOn g (f '' s) μ ↔ IntegrableOn (fun x => |(f' x).det| • g (f x)) s μ :=
  by
  rw [integrable_on, ← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
    (measurable_embedding_of_fderiv_within hs hf' hf).integrable_map_iff]
  change integrable ((g ∘ f) ∘ (coe : s → E)) _ ↔ _
  rw [← (MeasurableEmbedding.subtype_coe hs).integrable_map_iff, map_comap_subtype_coe hs]
  simp only [ENNReal.ofReal]
  rw [restrict_with_density hs, integrable_with_density_iff_integrable_coe_smul₀, integrable_on]
  · congr 2 with x
    rw [Real.coe_toNNReal]
    exact abs_nonneg _
  · exact ae_measurable_to_nnreal_abs_det_fderiv_within μ hs hf'
#align measure_theory.integrable_on_image_iff_integrable_on_abs_det_fderiv_smul MeasureTheory.integrableOn_image_iff_integrableOn_abs_det_fderiv_smul

/-- Change of variable formula for differentiable functions: if a function `f` is
injective and differentiable on a measurable set `s`, then the Bochner integral of a function
`g : E → F` on `f '' s` coincides with the integral of `|(f' x).det| • g ∘ f` on `s`. -/
theorem integral_image_eq_integral_abs_det_fderiv_smul [CompleteSpace F] (hs : MeasurableSet s)
    (hf' : ∀ x ∈ s, HasFderivWithinAt f (f' x) s x) (hf : InjOn f s) (g : E → F) :
    (∫ x in f '' s, g x ∂μ) = ∫ x in s, |(f' x).det| • g (f x) ∂μ :=
  by
  rw [← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
    (measurable_embedding_of_fderiv_within hs hf' hf).integral_map]
  have : ∀ x : s, g (s.restrict f x) = (g ∘ f) x := fun x => rfl
  simp only [this, ENNReal.ofReal]
  rw [← (MeasurableEmbedding.subtype_coe hs).integral_map, map_comap_subtype_coe hs,
    set_integral_withDensity_eq_set_integral_smul₀
      (ae_measurable_to_nnreal_abs_det_fderiv_within μ hs hf') _ hs]
  congr with x
  conv_rhs => rw [← Real.coe_toNNReal _ (abs_nonneg (f' x).det)]
  rfl
#align measure_theory.integral_image_eq_integral_abs_det_fderiv_smul MeasureTheory.integral_image_eq_integral_abs_det_fderiv_smul

/-- Change of variable formula for differentiable functions (one-variable version): if a function
`f` is injective and differentiable on a measurable set `s ⊆ ℝ`, then the Bochner integral of a
function `g : ℝ → F` on `f '' s` coincides with the integral of `|(f' x).det| • g ∘ f` on `s`. -/
theorem integral_image_eq_integral_abs_deriv_smul {s : Set ℝ} {f : ℝ → ℝ} {f' : ℝ → ℝ}
    [CompleteSpace F] (hs : MeasurableSet s) (hf' : ∀ x ∈ s, HasDerivWithinAt f (f' x) s x)
    (hf : InjOn f s) (g : ℝ → F) : (∫ x in f '' s, g x) = ∫ x in s, |f' x| • g (f x) :=
  by
  convert integral_image_eq_integral_abs_det_fderiv_smul volume hs
      (fun x hx => (hf' x hx).HasFderivWithinAt) hf g
  ext1 x
  rw [(by
      ext
      simp : (1 : ℝ →L[ℝ] ℝ).smul_right (f' x) = f' x • (1 : ℝ →L[ℝ] ℝ))]
  rw [ContinuousLinearMap.det, ContinuousLinearMap.coe_smul]
  have : ((1 : ℝ →L[ℝ] ℝ) : ℝ →ₗ[ℝ] ℝ) = (1 : ℝ →ₗ[ℝ] ℝ) := by rfl
  rw [this, LinearMap.det_smul, FiniteDimensional.finrank_self]
  suffices (1 : ℝ →ₗ[ℝ] ℝ).det = 1 by
    rw [this]
    simp
  exact LinearMap.det_id
#align measure_theory.integral_image_eq_integral_abs_deriv_smul MeasureTheory.integral_image_eq_integral_abs_deriv_smul

theorem integral_target_eq_integral_abs_det_fderiv_smul [CompleteSpace F] {f : LocalHomeomorph E E}
    (hf' : ∀ x ∈ f.source, HasFderivAt f (f' x) x) (g : E → F) :
    (∫ x in f.target, g x ∂μ) = ∫ x in f.source, |(f' x).det| • g (f x) ∂μ :=
  by
  have : f '' f.source = f.target := LocalEquiv.image_source_eq_target f.to_local_equiv
  rw [← this]
  apply integral_image_eq_integral_abs_det_fderiv_smul μ f.open_source.measurable_set _ f.inj_on
  intro x hx
  exact (hf' x hx).HasFderivWithinAt
#align measure_theory.integral_target_eq_integral_abs_det_fderiv_smul MeasureTheory.integral_target_eq_integral_abs_det_fderiv_smul

end MeasureTheory


import NBG.SetTheory.Defs

-- 1. AxiomExtensionality
axiom AxiomExtensionality :
  ∀X Y: Class, (X＝Y ↔ ∀z, (z ∈ X ↔ z ∈ Y))

def ClassSubset (X Y : Class) : Prop :=
  ∀z:Class, z ∈ X → z ∈ Y
instance : HasSubset Class where
  Subset := ClassSubset
notation:50 X " ⊊ " Y => (ClassSubset X Y) ∧ ¬ (X＝Y)
notation:50 X " ⊄ " Y => ¬ ClassSubset X Y
notation:50 X " ⊈ " Y => ¬ ClassSubset X Y

-- class equality
theorem ClassEq.refl (X : Class):
  X＝X := by {
  rw [AxiomExtensionality];
  intro z;
  exact ⟨fun h => h,fun h => h⟩;
}

theorem ClassEq.symm {X Y : Class}:
  X＝Y → Y＝X := by {
  rw [AxiomExtensionality, AxiomExtensionality];
  intro h;
  exact fun z => (h z).symm;
}

theorem ClassEq.trans {X Y Z : Class}:
  X＝Y → Y＝Z → X＝Z := by {
  rw [AxiomExtensionality,
      AxiomExtensionality,
      AxiomExtensionality];
  intro h1 h2 z;
  rw [h1,h2];
  exact ⟨fun h => h,fun h => h⟩;
}

-- -- class in
-- private theorem EqClassEqIn' {X Y Z: Class}:
--   X ＝ Y → (X ∈ Z → Y ∈ Z) := by {
--   intro h hx;
--   by_cases hy: Y ∈ Z;
--   {exact hy;}
--   {
--     apply False.elim;
--     sorry;
--   }
-- }

-- theorem EqClassEqIn (X Y Z: Class):
--   X ＝ Y → (X ∈ Z ↔ Y ∈ Z) := by {
--   intro h;
--   apply Iff.intro;
--   {exact EqClassEqIn' h;}
--   {exact EqClassEqIn' (ClassEq.symm h);}
-- }

-- class subset
theorem ClassSubset.refl (X : Class):
  X⊂X := fun _ => (fun h => h)

theorem ClassSubsetSymmImplyEq {X Y : Class}:
  X⊂Y → Y⊂X → X＝Y := by {
  rw [AxiomExtensionality];
  exact fun h1 h2 z => ⟨h1 z,h2 z⟩;
}

theorem ClassSubset.trans {X Y Z : Class}:
  X⊂Y → Y⊂Z → X⊂Z :=
fun h1 h2 z h => h2 z (h1 z h)

instance : LE Class where
  le := ClassSubset

example {X Y : Class} : X ≤ Y → Y ≤ Z → X ≤ Z :=
ClassSubset.trans

theorem EqIffSubsetMutually (X Y : Class):
  X＝Y ↔ (X ⊂ Y ∧ Y ⊂ X) := by {
    rw [AxiomExtensionality];
    apply Iff.intro;
    case mp => {
      intro h;
      exact ⟨fun z => (h z).1,fun z => (h z).2⟩
    }
    case mpr => {
      exact fun h z => ⟨h.1 z,h.2 z⟩
    }
}

theorem ClassEqMenberImpMenber {x y z: Class}:
  x ＝ y → y ∈ z → x ∈ z :=
  fun h1 h2 => @RewiteClass (fun x => x ∈ z) x y ⟨h1,h2⟩

def isUnique (p : Class → Prop) :=
  ∀ (X Y : Class), p X → p Y → (X ＝ Y)


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/

import algebra.triv_sq_zero_ext

/-!
# Dual numbers

The dual numbers over `R` are of the form `a + bε`, where `a` and `b` are typically elements of a
commutative ring `R`, and `ε` is a symbol satisfying `ε^2 = 0`. They are a special case of
`triv_sq_zero_ext R M` with `M = R`.

## Notation

In the `dual_number` locale:

* `R[ε]` is a shorthand for `dual_number R`
* `ε` is a shorthand for `dual_number.eps`

## Main definitions

* `dual_number`
* `dual_number.eps`
* `dual_number.lift`

## Implementation notes

Rather than duplicating the API of `triv_sq_zero_ext`, this file reuses the functions there.

## References

* https://en.wikipedia.org/wiki/Dual_number
-/

variables {R : Type*}

/-- The type of dual numbers, numbers of the form $a + bε$ where $ε^2 = 0$.-/
abbreviation dual_number (R : Type*) : Type* := triv_sq_zero_ext R R

/-- The unit element $ε$ that squares to zero. -/
def dual_number.eps [has_zero R] [has_one R] : dual_number R := triv_sq_zero_ext.inr 1

localized "notation `ε` := dual_number.eps" in dual_number
localized "postfix `[ε]`:1025 := dual_number" in dual_number

open_locale dual_number

namespace dual_number

open triv_sq_zero_ext

@[simp]

/-- A version of `triv_sq_zero_ext.snd_mul` with `*` instead of `•`. -/
@[simp] lemma snd_mul [semiring R] (x y : R[ε]) : snd (x * y) = fst x * snd y + fst y * snd x :=
snd_mul _ _

@[simp] lemma eps_mul_eps [semiring R] : (ε * ε : R[ε]) = 0 := inr_mul_inr _ _ _

@[simp] lemma inr_eq_smul_eps [mul_zero_one_class R] (r : R) : inr r = (r • ε : R[ε]) :=
ext (mul_zero r).symm (mul_one r).symm

/-- For two algebra morphisms out of `R[ε]` to agree, it suffices for them to agree on `ε`. -/
@[ext] lemma alg_hom_ext {A} [comm_semiring R] [semiring A] [algebra R A]
  ⦃f g : R[ε] →ₐ[R] A⦄ (h : f ε = g ε) : f = g :=
alg_hom_ext' $ linear_map.ext_ring $ h

variables {A : Type*} [comm_semiring R] [semiring A] [algebra R A]

/-- A universal property of the dual numbers, providing a unique `R[ε] →ₐ[R] A` for every element
of `A` which squares to `0`.

This isomorphism is named to match the very similar `complex.lift`. -/
@[simps {attrs := []}]
def lift : {e : A // e * e = 0} ≃ (R[ε] →ₐ[R] A) :=
equiv.trans
  (show {e : A // e * e = 0} ≃ {f : R →ₗ[R] A // ∀ x y, f x * f y = 0}, from
    (linear_map.ring_lmap_equiv_self R ℕ A).symm.to_equiv.subtype_equiv $ λ a, begin
      dsimp,
      simp_rw smul_mul_smul,
      refine ⟨λ h x y, h.symm ▸ smul_zero _, λ h, by simpa using h 1 1⟩,
    end)
  triv_sq_zero_ext.lift

/- When applied to `ε`, `dual_number.lift` produces the element of `A` that squares to 0. -/
@[simp]
lemma lift_apply_eps (e : {e : A // e * e = 0}) : lift e (ε : R[ε]) = e :=
(triv_sq_zero_ext.lift_aux_apply_inr _ _ _).trans $ one_smul _ _

/- Lifting `dual_number.eps` itself gives the identity. -/
@[simp]
lemma lift_eps : lift ⟨ε, by exact eps_mul_eps⟩ = alg_hom.id R R[ε] :=
alg_hom_ext $ lift_apply_eps _

end dual_number


-- Notes 12/5/2019

/- Talking about logics

We don't have just one logic; we have many
- predicate logic
    - the language of predicate logic: variables, functions,
- propositional logic
- some other logics (temporal logic)

- functions
- inductive types

types we have:
- true
- false
- a = b
    - introduction rule: eq.refl
- P ∧ Q
    - introduction rule: and.intro
- P ∨ Q
    - introduction rule: or.intro_left / or.intro_right
- P → Q
- P ↔ Q
    - introduction rule: iff.intro
- ¬P
- ∀ (p : P), Q
- ∃ (p: P), Q
-/

/-

Sample propositions:

If there's some P everyone likes, then everyone likes some P
-/

inductive Person : Type
inductive Likes : Person → Person → Prop

example : (∃ (p : Person), ∀ (q : Person), Likes q p) → ∀ (q : Person), (∃ (p : Person), Likes q p) :=
begin
    assume someone_everyone_likes,
    assume q,
    apply exists.elim someone_everyone_likes,
    assume a,
    assume hypothesis,
    have q_likes_a := hypothesis q,
    apply exists.intro,
    exact q_likes_a,
end

axiom f : false

example : (∃ (p : Person), ∀ (q : Person), Likes q p) → ∀ (q : Person), (∃ (p : Person), Likes q p) :=
begin
    assume h,
    assume p,
    -- "identify a witness"
    cases h with w pf,
    apply exists.intro w _,
    exact pf p
end

inductive jlist (α : Type) : Type
| nil : jlist
| cons (a : α) (t : jlist) : jlist

def len {α : Type} : jlist α → nat
| (jlist.nil α):= 0
| (jlist.cons a t) := nat.succ (len t)

example : (∃ (p : Person), ∀ (q : Person), Likes q p) → ∀ (q : Person), (∃ (p : Person), Likes q p) :=
begin
    assume h,
    assume p,
    cases h with w pf,
    apply exists.intro w (pf p)
end

-- "Proof of an exists is just a pair"
    -- that pair is "a witness" and "a proof that witness satisfies p"

def even : nat → Prop := λ (q : nat), ∃ (n : nat), n * 2 = q

theorem two_even : even 2 :=
begin
    exact exists.intro 1 (eq.refl _),
end

example : ∀ (b : bool), bor b tt = tt :=
begin
    assume b,
    cases b,

    exact eq.refl tt,
    exact eq.refl tt,
end

example : ∀ (n : ℕ), n = 0 ∨ n ≠ 0 :=
begin
    assume n,
    cases n with p z,
    apply or.inl,
    refl,

    apply or.inr,
    apply not.intro,
    assume ridiculous,
    cases ridiculous,
end

example : ∀ (n : ℕ), n = 0 ∨ n ≠ 0 := λ (n : nat), classical.em _


import algebra.direct_sum.module

-- finset: Defines a type for the finite subsets of α. Constructing a finset requires two pieces of data: val, a multiset α of elements, and nodup, a proof that val has no duplicates.

#check finset ℕ

def empty_fs : finset ℕ := finset.empty
def singleton_fs : finset ℕ := { 0 }
def range_fs : finset ℕ := finset.range 2 -- [0,..,1]
def fs_from_subtype : finset { r : ℕ | r ∈ range_fs } := finset.attach range_fs

-- finset.has_mem: Defines membership a ∈ (s : finset α).

example : 0 ∈ range_fs := sorry

-- finset.has_coe: Provides a coercion s : finset α to s : set α.
-- recall: a set in Lean is represented by its membership predicate
-- KS: it's has_coe_t; it's still applied by the lift operator, ↑.
def set_from_fs : set ℕ := ↑range_fs
#reduce set_from_fs

/-
finset.has_coe_to_sort: Coerce s : finset α to the type of all x ∈ s.
https://leanprover.github.io/theorem_proving_in_lean/type_classes.html
https://leanprover-community.github.io/mathlib_docs/data/subtype.html

notation `↑`:max x:max := coe x
notation `⇑`:max x:max := coe_fn x
notation `↥`:max x:max := coe_sort x
-/

#check {n : ℕ // n ∈ range_fs}    -- subtype (//) of ℕ in range_fs
#reduce {n : ℕ // n ∈ range_fs}   -- expanding membership predicate

def sort_from_fs : Type := @has_coe_to_sort range_fs {n : ℕ // n ∈ range_fs}
#reduce sort_from_fs
example : sort_from_fs := _
-- KS: hmm, instantiate one; ⟨,⟩ doesn't work

-- finset.induction_on:

/-
Induction on finsets. To prove a proposition about an
arbitrary finset α, it suffices to prove it for the empty
finset, and to show that if it holds for some finset α,
then it holds for ANY finset obtained by inserting any
new element into it.
-/

/- finset.choose: Given a proof h of existence and uniqueness
of aN element satisfying a predicate, choose s h returns the
element of s satisfying that predicate.
-/

/-
finsets from functions (predicates)
-/

/-
finset.filter: Given a predicate p : α → Prop, s.filter p
is the finset consisting of the elements in s that satisfy p.
-/
def just_zero_fs := range_fs.filter (λ v, v %2 = 0)
#check just_zero_fs  -- cool
#eval just_zero_fs
-- The data.equiv files describe a general type of equivalence, so look in there for any lemmas. There is some API for rewriting sums and products from s to t given that s ≃ t. TODO: examples

/-
Lattice structure
-/

/-
Operations on two or more finsets
-/

def range_3_fs :finset ℕ :=
  finset.cons
    2
    range_fs
    begin  -- pf 2 ∉ range_fs
      assume h,
      repeat {cases h},
    end

-- KS: finset insert no longer in mathlib?

def range_3_fs' := range_fs ∪ {2}
#eval range_3_fs'

def just_1_fs := range_fs ∩ {1}
#eval just_1_fs

def just_1_fs' := range_fs.erase 0
#eval just_1_fs'
example : just_1_fs = just_1_fs' := rfl

-- finset difference is s \ t

-- finset product

def by_3_3 := range_fs × range_fs
#reduce by_3_3

/-
finset.bUnion: Finite unions of finsets; given an
indexing function f : α → finset β and a s : finset α,
s.bUnion f is the union of all  finsets of the form,
f a, for a ∈ s.
-/

-- contstant map, (_ : fin 2) -> range_fs
def an_f (a : nat) := range_fs

/-
finset.bUnion :
  Π {α : Type}
    {β : Type u_1} [_inst_1 : decidable_eq β],
    finset α →            -- fin nat
    (α → finset β) →      -- nar → finset β
    finset β

-- KS: fix docs re implicit third arg, finset α
-/
def bun := range_fs.bUnion an_f
#reduce bun

/-
Maps constructed using finsets
-/

/-
finset.piecewise: Given two functions f, g,
s.piecewise f g is a function that is equal to
f on s and equal to g on the complement of s
(within its potentially larger element type).
-/

/-
Predicates on finsets

- disjoint
- empty

later.
-/

/-
Equivalences between finsets

The data.equiv files describe a general type of
equivalence, so look in there for any lemmas.
-/

/-
The standard library defines a coercion from subtype
{x : α // p x} to α as follows.

instance coe_subtype {α : Type*} {p : α → Prop} :
  has_coe {x // p x} α := ⟨λ s, subtype.val s⟩.
-/


import MyNat.Definition
import MyNat.Addition
import AdditionWorld.Level4 -- add_comm
import AdvancedAdditionWorld.Level10 -- add_left_eq_zero
namespace MyNat
open MyNat

/-!

# Advanced Addition World

## Level 11: `add_right_eq_zero`

We just proved `add_left_eq_zero (a b : MyNat) : a + b = 0 → b = 0`.
Hopefully `add_right_eq_zero` shouldn't be too hard now.

## Lemma
If `a` and `b` are natural numbers such that if `a + b = 0` then `a = 0`.
-/
lemma add_right_eq_zero {a b : MyNat} : a + b = 0 → a = 0 := by
  intro h
  rw [add_comm] at h
  exact add_left_eq_zero h

/-!
Next up [Level 12](./Level12.lean.md)
-/


/-
Copyright (c) 2022 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.complex.upper_half_plane.topology
import analysis.special_functions.arsinh
import geometry.euclidean.inversion

/-!
# Metric on the upper half-plane

In this file we define a `metric_space` structure on the `upper_half_plane`. We use hyperbolic
(Poincaré) distance given by
`dist z w = 2 * arsinh (dist (z : ℂ) w / (2 * real.sqrt (z.im * w.im)))` instead of the induced
Euclidean distance because the hyperbolic distance is invariant under holomorphic automorphisms of
the upper half-plane. However, we ensure that the projection to `topological_space` is
definitionally equal to the induced topological space structure.

We also prove that a metric ball/closed ball/sphere in Poincaré metric is a Euclidean ball/closed
ball/sphere with another center and radius.

-/

noncomputable theory

open_locale upper_half_plane complex_conjugate nnreal topology matrix_groups
open set metric filter real

variables {z w : ℍ} {r R : ℝ}

namespace upper_half_plane

instance : has_dist ℍ :=
⟨λ z w, 2 * arsinh (dist (z : ℂ) w / (2 * sqrt (z.im * w.im)))⟩

lemma dist_eq (z w : ℍ) : dist z w = 2 * arsinh (dist (z : ℂ) w / (2 * sqrt (z.im * w.im))) :=
rfl

lemma sinh_half_dist (z w : ℍ) :
  sinh (dist z w / 2) = dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) :=
by rw [dist_eq, mul_div_cancel_left (arsinh _) two_ne_zero, sinh_arsinh]

lemma cosh_half_dist (z w : ℍ) :
  cosh (dist z w / 2) = dist (z : ℂ) (conj (w : ℂ)) / (2 * sqrt (z.im * w.im)) :=
begin
  have H₁ : (2 ^ 2 : ℝ) = 4, by norm_num1,
  have H₂ : 0 < z.im * w.im, from mul_pos z.im_pos w.im_pos,
  have H₃ : 0 < 2 * sqrt (z.im * w.im), from mul_pos two_pos (sqrt_pos.2 H₂),
  rw [← sq_eq_sq (cosh_pos _).le (div_nonneg dist_nonneg H₃.le), cosh_sq', sinh_half_dist, div_pow,
    div_pow, one_add_div (pow_ne_zero 2 H₃.ne'), mul_pow, sq_sqrt H₂.le, H₁],
  congr' 1,
  simp only [complex.dist_eq, complex.sq_abs, complex.norm_sq_sub, complex.norm_sq_conj,
    complex.conj_conj, complex.mul_re, complex.conj_re, complex.conj_im, coe_im],
  ring
end

lemma tanh_half_dist (z w : ℍ) :
  tanh (dist z w / 2) = dist (z : ℂ) w / dist (z : ℂ) (conj ↑w) :=
begin
  rw [tanh_eq_sinh_div_cosh, sinh_half_dist, cosh_half_dist, div_div_div_comm, div_self, div_one],
  exact (mul_pos (zero_lt_two' ℝ) (sqrt_pos.2 $ mul_pos z.im_pos w.im_pos)).ne'
end

lemma exp_half_dist (z w : ℍ) :
  exp (dist z w / 2) = (dist (z : ℂ) w + dist (z : ℂ) (conj ↑w)) / (2 * sqrt (z.im * w.im)) :=
by rw [← sinh_add_cosh, sinh_half_dist, cosh_half_dist, add_div]

lemma cosh_dist (z w : ℍ) : cosh (dist z w) = 1 + dist (z : ℂ) w ^ 2 / (2 * z.im * w.im) :=
by rw [dist_eq, cosh_two_mul, cosh_sq', add_assoc, ← two_mul, sinh_arsinh, div_pow, mul_pow,
  sq_sqrt (mul_pos z.im_pos w.im_pos).le, sq (2 : ℝ), mul_assoc, ← mul_div_assoc,
  mul_assoc, mul_div_mul_left _ _ (two_ne_zero' ℝ)]

lemma sinh_half_dist_add_dist (a b c : ℍ) :
  sinh ((dist a b + dist b c) / 2) =
    (dist (a : ℂ) b * dist (c : ℂ) (conj ↑b) + dist (b : ℂ) c * dist (a : ℂ) (conj ↑b)) /
      (2 * sqrt (a.im * c.im) * dist (b : ℂ) (conj ↑b)) :=
begin
  simp only [add_div _ _ (2 : ℝ), sinh_add, sinh_half_dist, cosh_half_dist, div_mul_div_comm],
  rw [← add_div, complex.dist_self_conj, coe_im, abs_of_pos b.im_pos, mul_comm (dist ↑b _),
    dist_comm (b : ℂ), complex.dist_conj_comm, mul_mul_mul_comm, mul_mul_mul_comm _ _ _ b.im],
  congr' 2,
  rw [sqrt_mul, sqrt_mul, sqrt_mul, mul_comm (sqrt a.im), mul_mul_mul_comm, mul_self_sqrt,
    mul_comm]; exact (im_pos _).le
end

protected lemma dist_comm (z w : ℍ) : dist z w = dist w z :=
by simp only [dist_eq, dist_comm (z : ℂ), mul_comm]

lemma dist_le_iff_le_sinh :
  dist z w ≤ r ↔ dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) ≤ sinh (r / 2) :=
by rw [← div_le_div_right (zero_lt_two' ℝ), ← sinh_le_sinh, sinh_half_dist]

lemma dist_eq_iff_eq_sinh :
  dist z w = r ↔ dist (z : ℂ) w / (2 * sqrt (z.im * w.im)) = sinh (r / 2) :=
by rw [← div_left_inj' (two_ne_zero' ℝ), ← sinh_inj, sinh_half_dist]

lemma dist_eq_iff_eq_sq_sinh (hr : 0 ≤ r) :
  dist z w = r ↔ dist (z : ℂ) w ^ 2 / (4 * z.im * w.im) = sinh (r / 2) ^ 2 :=
begin
  rw [dist_eq_iff_eq_sinh, ← sq_eq_sq, div_pow, mul_pow, sq_sqrt, mul_assoc],
  { norm_num },
  { exact (mul_pos z.im_pos w.im_pos).le },
  { exact div_nonneg dist_nonneg (mul_nonneg zero_le_two $ sqrt_nonneg _) },
  { exact sinh_nonneg_iff.2 (div_nonneg hr zero_le_two) }
end

protected lemma dist_triangle (a b c : ℍ) : dist a c ≤ dist a b + dist b c :=
begin
  rw [dist_le_iff_le_sinh, sinh_half_dist_add_dist,
    div_mul_eq_div_div _ _ (dist _ _), le_div_iff, div_mul_eq_mul_div],
  { exact div_le_div_of_le (mul_nonneg zero_le_two (sqrt_nonneg _))
      (euclidean_geometry.mul_dist_le_mul_dist_add_mul_dist (a : ℂ) b c (conj ↑b)) },
  { rw [dist_comm, dist_pos, ne.def, complex.eq_conj_iff_im],
    exact b.im_ne_zero }
end

lemma dist_le_dist_coe_div_sqrt (z w : ℍ) :
  dist z w ≤ dist (z : ℂ) w / sqrt (z.im * w.im) :=
begin
  rw [dist_le_iff_le_sinh, ← div_mul_eq_div_div_swap, self_le_sinh_iff],
  exact div_nonneg dist_nonneg (mul_nonneg zero_le_two (sqrt_nonneg _))
end

/-- An auxiliary `metric_space` instance on the upper half-plane. This instance has bad projection
to `topological_space`. We replace it later. -/
def metric_space_aux : metric_space ℍ :=
{ dist := dist,
  dist_self := λ z, by rw [dist_eq, dist_self, zero_div, arsinh_zero, mul_zero],
  dist_comm := upper_half_plane.dist_comm,
  dist_triangle := upper_half_plane.dist_triangle,
  eq_of_dist_eq_zero := λ z w h,
    by simpa [dist_eq, real.sqrt_eq_zero', (mul_pos z.im_pos w.im_pos).not_le, subtype.coe_inj]
      using h }

open complex

lemma cosh_dist' (z w : ℍ) :
  real.cosh (dist z w) = ((z.re - w.re) ^ 2 + z.im ^ 2 + w.im ^ 2) / (2 * z.im * w.im) :=
have H : 0 < 2 * z.im * w.im, from mul_pos (mul_pos two_pos z.im_pos) w.im_pos,
by { field_simp [cosh_dist, complex.dist_eq, complex.sq_abs, norm_sq_apply, H, H.ne'], ring }

/-- Euclidean center of the circle with center `z` and radius `r` in the hyperbolic metric. -/
def center (z : ℍ) (r : ℝ) : ℍ := ⟨⟨z.re, z.im * cosh r⟩, mul_pos z.im_pos (cosh_pos _)⟩

@[simp] lemma center_re (z r) : (center z r).re = z.re := rfl
@[simp] lemma center_im (z r) : (center z r).im = z.im * cosh r := rfl

@[simp] lemma center_zero (z : ℍ) : center z 0 = z :=
subtype.ext $ ext rfl $ by rw [coe_im, coe_im, center_im, real.cosh_zero, mul_one]

lemma dist_coe_center_sq (z w : ℍ) (r : ℝ) :
  dist (z : ℂ) (w.center r) ^ 2 =
    2 * z.im * w.im * (cosh (dist z w) - cosh r) + (w.im * sinh r) ^ 2 :=
begin
  have H : 2 * z.im * w.im ≠ 0, by apply_rules [mul_ne_zero, two_ne_zero, im_ne_zero],
  simp only [complex.dist_eq, complex.sq_abs, norm_sq_apply, coe_re, coe_im, center_re, center_im,
    cosh_dist', mul_div_cancel' _ H, sub_sq z.im, mul_pow, real.cosh_sq, sub_re, sub_im, mul_sub,
    ← sq],
  ring
end

lemma dist_coe_center (z w : ℍ) (r : ℝ) :
  dist (z : ℂ) (w.center r) =
    sqrt (2 * z.im * w.im * (cosh (dist z w) - cosh r) + (w.im * sinh r) ^ 2) :=
by rw [← sqrt_sq dist_nonneg, dist_coe_center_sq]

lemma cmp_dist_eq_cmp_dist_coe_center (z w : ℍ) (r : ℝ) :
  cmp (dist z w) r = cmp (dist (z : ℂ) (w.center r)) (w.im * sinh r) :=
begin
  letI := metric_space_aux,
  cases lt_or_le r 0 with hr₀ hr₀,
  { transitivity ordering.gt,
    exacts [(hr₀.trans_le dist_nonneg).cmp_eq_gt,
      ((mul_neg_of_pos_of_neg w.im_pos (sinh_neg_iff.2 hr₀)).trans_le
        dist_nonneg).cmp_eq_gt.symm] },
  have hr₀' : 0 ≤ w.im * sinh r, from mul_nonneg w.im_pos.le (sinh_nonneg_iff.2 hr₀),
  have hzw₀ : 0 < 2 * z.im * w.im, from mul_pos (mul_pos two_pos z.im_pos) w.im_pos,
  simp only [← cosh_strict_mono_on.cmp_map_eq dist_nonneg hr₀,
    ← (@strict_mono_on_pow ℝ _ _ two_pos).cmp_map_eq dist_nonneg hr₀', dist_coe_center_sq],
  rw [← cmp_mul_pos_left hzw₀, ← cmp_sub_zero, ← mul_sub, ← cmp_add_right, zero_add],
end

lemma dist_eq_iff_dist_coe_center_eq : dist z w = r ↔ dist (z : ℂ) (w.center r) = w.im * sinh r :=
eq_iff_eq_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)

@[simp] lemma dist_self_center (z : ℍ) (r : ℝ) : dist (z : ℂ) (z.center r) = z.im * (cosh r - 1) :=
begin
  rw [dist_of_re_eq (z.center_re r).symm, dist_comm, real.dist_eq, mul_sub, mul_one],
  exact abs_of_nonneg (sub_nonneg.2 $ le_mul_of_one_le_right z.im_pos.le (one_le_cosh _))
end

@[simp] lemma dist_center_dist (z w : ℍ) :
  dist (z : ℂ) (w.center (dist z w)) = w.im * sinh (dist z w) :=
dist_eq_iff_dist_coe_center_eq.1 rfl

lemma dist_lt_iff_dist_coe_center_lt :
  dist z w < r ↔ dist (z : ℂ) (w.center r) < w.im * sinh r :=
lt_iff_lt_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)

lemma lt_dist_iff_lt_dist_coe_center :
  r < dist z w ↔ w.im * sinh r < dist (z : ℂ) (w.center r) :=
lt_iff_lt_of_cmp_eq_cmp (cmp_eq_cmp_symm.1 $ cmp_dist_eq_cmp_dist_coe_center z w r)

lemma dist_le_iff_dist_coe_center_le :
  dist z w ≤ r ↔ dist (z : ℂ) (w.center r) ≤ w.im * sinh r :=
le_iff_le_of_cmp_eq_cmp (cmp_dist_eq_cmp_dist_coe_center z w r)

lemma le_dist_iff_le_dist_coe_center :
  r < dist z w ↔ w.im * sinh r < dist (z : ℂ) (w.center r) :=
lt_iff_lt_of_cmp_eq_cmp (cmp_eq_cmp_symm.1 $ cmp_dist_eq_cmp_dist_coe_center z w r)

/-- For two points on the same vertical line, the distance is equal to the distance between the
logarithms of their imaginary parts. -/
lemma dist_of_re_eq (h : z.re = w.re) : dist z w = dist (log z.im) (log w.im) :=
begin
  have h₀ : 0 < z.im / w.im, from div_pos z.im_pos w.im_pos,
  rw [dist_eq_iff_dist_coe_center_eq, real.dist_eq, ← abs_sinh, ← log_div z.im_ne_zero w.im_ne_zero,
    sinh_log h₀, dist_of_re_eq, coe_im, coe_im, center_im, cosh_abs, cosh_log h₀, inv_div];
    [skip, exact h],
  nth_rewrite 3 [← abs_of_pos w.im_pos],
  simp only [← _root_.abs_mul, coe_im, real.dist_eq],
  congr' 1,
  field_simp [z.im_pos, w.im_pos, z.im_ne_zero, w.im_ne_zero],
  ring
end

/-- Hyperbolic distance between two points is greater than or equal to the distance between the
logarithms of their imaginary parts. -/
lemma dist_log_im_le (z w : ℍ) : dist (log z.im) (log w.im) ≤ dist z w :=
calc dist (log z.im) (log w.im) = @dist ℍ _ ⟨⟨0, z.im⟩, z.im_pos⟩ ⟨⟨0, w.im⟩, w.im_pos⟩ :
  eq.symm $ @dist_of_re_eq ⟨⟨0, z.im⟩, z.im_pos⟩ ⟨⟨0, w.im⟩, w.im_pos⟩ rfl
... ≤ dist z w :
  mul_le_mul_of_nonneg_left (arsinh_le_arsinh.2 $ div_le_div_of_le
    (mul_nonneg zero_le_two (sqrt_nonneg _)) $
      by simpa [sqrt_sq_eq_abs] using complex.abs_im_le_abs (z - w)) zero_le_two

lemma im_le_im_mul_exp_dist (z w : ℍ) : z.im ≤ w.im * exp (dist z w) :=
begin
  rw [← div_le_iff' w.im_pos, ← exp_log z.im_pos, ← exp_log w.im_pos, ← real.exp_sub, exp_le_exp],
  exact (le_abs_self _).trans (dist_log_im_le z w)
end

/-- An upper estimate on the complex distance between two points in terms of the hyperbolic distance
and the imaginary part of one of the points. -/
lemma dist_coe_le (z w : ℍ) : dist (z : ℂ) w ≤ w.im * (exp (dist z w) - 1) :=
calc dist (z : ℂ) w ≤ dist (z : ℂ) (w.center (dist z w)) + dist (w : ℂ) (w.center (dist z w)) :
  dist_triangle_right _ _ _
... = w.im  * (exp (dist z w) - 1) :
  by rw [dist_center_dist, dist_self_center, ← mul_add, ← add_sub_assoc, real.sinh_add_cosh]

/-- An upper estimate on the complex distance between two points in terms of the hyperbolic distance
and the imaginary part of one of the points. -/
lemma le_dist_coe (z w : ℍ) : w.im * (1 - exp (-dist z w)) ≤ dist (z : ℂ) w :=
calc w.im * (1 - exp (-dist z w))
    = dist (z : ℂ) (w.center (dist z w)) - dist (w : ℂ) (w.center (dist z w)) :
  by { rw [dist_center_dist, dist_self_center, ← real.cosh_sub_sinh], ring }
... ≤ dist (z : ℂ) w : sub_le_iff_le_add.2 $ dist_triangle _ _ _

/-- The hyperbolic metric on the upper half plane. We ensure that the projection to
`topological_space` is definitionally equal to the subtype topology. -/
instance : metric_space ℍ := metric_space_aux.replace_topology $
begin
  refine le_antisymm (continuous_id_iff_le.1 _) _,
  { refine (@continuous_iff_continuous_dist _ _ metric_space_aux.to_pseudo_metric_space _ _).2 _,
    have : ∀ (x : ℍ × ℍ), 2 * real.sqrt (x.1.im * x.2.im) ≠ 0,
      from λ x, mul_ne_zero two_ne_zero (real.sqrt_pos.2 $ mul_pos x.1.im_pos x.2.im_pos).ne',
    -- `continuity` fails to apply `continuous.div`
    apply_rules [continuous.div, continuous.mul, continuous_const, continuous.arsinh,
      continuous.dist, continuous_coe.comp, continuous_fst, continuous_snd,
      real.continuous_sqrt.comp, continuous_im.comp] },
  { letI : metric_space ℍ := metric_space_aux,
    refine le_of_nhds_le_nhds (λ z, _),
    rw [nhds_induced],
    refine (nhds_basis_ball.le_basis_iff (nhds_basis_ball.comap _)).2 (λ R hR, _),
    have h₁ : 1 < R / im z + 1, from lt_add_of_pos_left _ (div_pos hR z.im_pos),
    have h₀ : 0 < R / im z + 1, from one_pos.trans h₁,
    refine ⟨log (R / im z + 1), real.log_pos h₁, _⟩,
    refine λ w hw, (dist_coe_le w z).trans_lt _,
    rwa [← lt_div_iff' z.im_pos, sub_lt_iff_lt_add, ← real.lt_log_iff_exp_lt h₀] }
end

lemma im_pos_of_dist_center_le {z : ℍ} {r : ℝ} {w : ℂ} (h : dist w (center z r) ≤ z.im * sinh r) :
  0 < w.im :=
calc 0 < z.im * (cosh r - sinh r) : mul_pos z.im_pos (sub_pos.2 $ sinh_lt_cosh _)
... = (z.center r).im - z.im * sinh r : mul_sub _ _ _
... ≤ (z.center r).im - dist (z.center r : ℂ) w : sub_le_sub_left (by rwa [dist_comm]) _
... ≤ w.im : sub_le_comm.1 $ (le_abs_self _).trans (abs_im_le_abs $ z.center r - w)

lemma image_coe_closed_ball (z : ℍ) (r : ℝ) :
  (coe : ℍ → ℂ) '' closed_ball z r = closed_ball (z.center r) (z.im * sinh r) :=
begin
  ext w, split,
  { rintro ⟨w, hw, rfl⟩,
    exact dist_le_iff_dist_coe_center_le.1 hw },
  { intro hw,
    lift w to ℍ using im_pos_of_dist_center_le hw,
    exact mem_image_of_mem _ (dist_le_iff_dist_coe_center_le.2 hw) },
end

lemma image_coe_ball (z : ℍ) (r : ℝ) :
  (coe : ℍ → ℂ) '' ball z r = ball (z.center r) (z.im * sinh r) :=
begin
  ext w, split,
  { rintro ⟨w, hw, rfl⟩,
    exact dist_lt_iff_dist_coe_center_lt.1 hw },
  { intro hw,
    lift w to ℍ using im_pos_of_dist_center_le (ball_subset_closed_ball hw),
    exact mem_image_of_mem _ (dist_lt_iff_dist_coe_center_lt.2 hw) },
end

lemma image_coe_sphere (z : ℍ) (r : ℝ) :
  (coe : ℍ → ℂ) '' sphere z r = sphere (z.center r) (z.im * sinh r) :=
begin
  ext w, split,
  { rintro ⟨w, hw, rfl⟩,
    exact dist_eq_iff_dist_coe_center_eq.1 hw },
  { intro hw,
    lift w to ℍ using im_pos_of_dist_center_le (sphere_subset_closed_ball hw),
    exact mem_image_of_mem _ (dist_eq_iff_dist_coe_center_eq.2 hw) },
end

instance : proper_space ℍ :=
begin
  refine ⟨λ z r, _⟩,
  rw [← inducing_coe.is_compact_iff, image_coe_closed_ball],
  apply is_compact_closed_ball
end

lemma isometry_vertical_line (a : ℝ) : isometry (λ y, mk ⟨a, exp y⟩ (exp_pos y)) :=
begin
  refine isometry.of_dist_eq (λ y₁ y₂, _),
  rw [dist_of_re_eq],
  exacts [congr_arg2 _ (log_exp _) (log_exp _), rfl]
end

lemma isometry_real_vadd (a : ℝ) : isometry ((+ᵥ) a : ℍ → ℍ) :=
isometry.of_dist_eq $ λ y₁ y₂, by simp only [dist_eq, coe_vadd, vadd_im, dist_add_left]

lemma isometry_pos_mul (a : {x : ℝ // 0 < x}) : isometry ((•) a : ℍ → ℍ) :=
begin
  refine isometry.of_dist_eq (λ y₁ y₂, _),
  simp only [dist_eq, coe_pos_real_smul, pos_real_im], congr' 2,
  rw [dist_smul₀, mul_mul_mul_comm, real.sqrt_mul (mul_self_nonneg _), real.sqrt_mul_self_eq_abs,
    real.norm_eq_abs, mul_left_comm],
  exact mul_div_mul_left _ _ (mt _root_.abs_eq_zero.1 a.2.ne')
end

/-- `SL(2, ℝ)` acts on the upper half plane as an isometry.-/
instance : has_isometric_smul SL(2, ℝ) ℍ :=
⟨λ g,
begin
  have h₀ : isometry (λ z, modular_group.S • z : ℍ → ℍ) := isometry.of_dist_eq (λ y₁ y₂, by
  { have h₁ : 0 ≤ im y₁ * im y₂ := mul_nonneg y₁.property.le y₂.property.le,
    have h₂ : complex.abs (y₁ * y₂) ≠ 0, { simp [y₁.ne_zero, y₂.ne_zero], },
    simp only [dist_eq, modular_S_smul, inv_neg, neg_div, div_mul_div_comm, coe_mk, mk_im, div_one,
      complex.inv_im, complex.neg_im, coe_im, neg_neg, complex.norm_sq_neg, mul_eq_mul_left_iff,
      real.arsinh_inj, bit0_eq_zero, one_ne_zero, or_false, dist_neg_neg, mul_neg, neg_mul,
      dist_inv_inv₀ y₁.ne_zero y₂.ne_zero, ← absolute_value.map_mul,
      ← complex.norm_sq_mul, real.sqrt_div h₁, ← complex.abs_apply, mul_div (2 : ℝ),
      div_div_div_comm, div_self h₂, complex.norm_eq_abs], }),
  by_cases hc : g 1 0 = 0,
  { obtain ⟨u, v, h⟩ := exists_SL2_smul_eq_of_apply_zero_one_eq_zero g hc,
    rw h,
    exact (isometry_real_vadd v).comp (isometry_pos_mul u), },
  { obtain ⟨u, v, w, h⟩ := exists_SL2_smul_eq_of_apply_zero_one_ne_zero g hc,
    rw h,
    exact (isometry_real_vadd w).comp (h₀.comp $ (isometry_real_vadd v).comp $ isometry_pos_mul u) }
end⟩

end upper_half_plane