/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl, Damiano Testa,
Yuyang Zhao
-/
import algebra.covariant_and_contravariant
import order.monotone

/-!
# Ordered monoids

This file develops the basics of ordered monoids.

## Implementation details

Unfortunately, the number of `'` appended to lemmas in this file
may differ between the multiplicative and the additive version of a lemma.
The reason is that we did not want to change existing names in the library.

## Remark

Almost no monoid is actually present in this file: most assumptions have been generalized to
`has_mul` or `mul_one_class`.

-/

-- TODO: If possible, uniformize lemma names, taking special care of `'`,
-- after the `ordered`-refactor is done.

open function

variables {α β : Type*}

section has_mul
variables [has_mul α]

section has_le
variables [has_le α]

/- The prime on this lemma is present only on the multiplicative version.  The unprimed version
is taken by the analogous lemma for semiring, with an extra non-negativity assumption. -/
@[to_additive add_le_add_left]
lemma mul_le_mul_left' [covariant_class α α (*) (≤)]
  {b c : α} (bc : b ≤ c) (a : α) :
  a * b ≤ a * c :=
covariant_class.elim _ bc

@[to_additive le_of_add_le_add_left]
lemma le_of_mul_le_mul_left' [contravariant_class α α (*) (≤)]
  {a b c : α} (bc : a * b ≤ a * c) :
  b ≤ c :=
contravariant_class.elim _ bc

/- The prime on this lemma is present only on the multiplicative version.  The unprimed version
is taken by the analogous lemma for semiring, with an extra non-negativity assumption. -/
@[to_additive add_le_add_right]
lemma mul_le_mul_right' [covariant_class α α (swap (*)) (≤)]
  {b c : α} (bc : b ≤ c) (a : α) :
  b * a ≤ c * a :=
covariant_class.elim a bc

@[to_additive le_of_add_le_add_right]
lemma le_of_mul_le_mul_right' [contravariant_class α α (swap (*)) (≤)]
  {a b c : α} (bc : b * a ≤ c * a) :
  b ≤ c :=
contravariant_class.elim a bc

@[simp, to_additive]
lemma mul_le_mul_iff_left [covariant_class α α (*) (≤)] [contravariant_class α α (*) (≤)]
  (a : α) {b c : α} :
  a * b ≤ a * c ↔ b ≤ c :=
rel_iff_cov α α (*) (≤) a

@[simp, to_additive]
lemma mul_le_mul_iff_right
  [covariant_class α α (swap (*)) (≤)] [contravariant_class α α (swap (*)) (≤)]
  (a : α) {b c : α} :
  b * a ≤ c * a ↔ b ≤ c :=
rel_iff_cov α α (swap (*)) (≤) a

end has_le

section has_lt
variables [has_lt α]

@[simp, to_additive]
lemma mul_lt_mul_iff_left [covariant_class α α (*) (<)] [contravariant_class α α (*) (<)]
  (a : α) {b c : α} :
  a * b < a * c ↔ b < c :=
rel_iff_cov α α (*) (<) a

@[simp, to_additive]
lemma mul_lt_mul_iff_right
  [covariant_class α α (swap (*)) (<)] [contravariant_class α α (swap (*)) (<)]
  (a : α) {b c : α} :
  b * a < c * a ↔ b < c :=
rel_iff_cov α α (swap (*)) (<) a

@[to_additive add_lt_add_left]
lemma mul_lt_mul_left' [covariant_class α α (*) (<)]
  {b c : α} (bc : b < c) (a : α) :
  a * b < a * c :=
covariant_class.elim _ bc

@[to_additive lt_of_add_lt_add_left]
lemma lt_of_mul_lt_mul_left' [contravariant_class α α (*) (<)]
  {a b c : α} (bc : a * b < a * c) :
  b < c :=
contravariant_class.elim _ bc

@[to_additive add_lt_add_right]
lemma mul_lt_mul_right' [covariant_class α α (swap (*)) (<)]
  {b c : α} (bc : b < c) (a : α) :
  b * a < c * a :=
covariant_class.elim a bc

@[to_additive lt_of_add_lt_add_right]
lemma lt_of_mul_lt_mul_right' [contravariant_class α α (swap (*)) (<)]
  {a b c : α} (bc : b * a < c * a) :
  b < c :=
contravariant_class.elim a bc

end has_lt

section preorder
variables [preorder α]

@[to_additive]
lemma mul_lt_mul_of_lt_of_lt [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (<)]
  {a b c d : α} (h₁ : a < b) (h₂ : c < d) : a * c < b * d :=
calc  a * c < a * d : mul_lt_mul_left' h₂ a
        ... < b * d : mul_lt_mul_right' h₁ d

alias add_lt_add_of_lt_of_lt ← add_lt_add

@[to_additive]
lemma mul_lt_mul_of_le_of_lt [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h₁ : a ≤ b) (h₂ : c < d) : a * c < b * d :=
(mul_le_mul_right' h₁ _).trans_lt (mul_lt_mul_left' h₂ b)

@[to_additive]
lemma mul_lt_mul_of_lt_of_le [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (<)]
  {a b c d : α} (h₁ : a < b) (h₂ : c ≤ d) : a * c < b * d :=
(mul_le_mul_left' h₂ _).trans_lt (mul_lt_mul_right' h₁ d)

/-- Only assumes left strict covariance. -/
@[to_additive "Only assumes left strict covariance"]
lemma left.mul_lt_mul [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h₁ : a < b) (h₂ : c < d) : a * c < b * d :=
mul_lt_mul_of_le_of_lt h₁.le h₂

/-- Only assumes right strict covariance. -/
@[to_additive "Only assumes right strict covariance"]
lemma right.mul_lt_mul [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (<)]
  {a b c d : α} (h₁ : a < b) (h₂ : c < d) : a * c < b * d :=
mul_lt_mul_of_lt_of_le h₁ h₂.le

@[to_additive add_le_add]
lemma mul_le_mul' [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h₁ : a ≤ b) (h₂ : c ≤ d) : a * c ≤ b * d :=
(mul_le_mul_left' h₂ _).trans (mul_le_mul_right' h₁ d)

@[to_additive]
lemma mul_le_mul_three [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (≤)]
  {a b c d e f : α} (h₁ : a ≤ d) (h₂ : b ≤ e) (h₃ : c ≤ f) :
  a * b * c ≤ d * e * f :=
mul_le_mul' (mul_le_mul' h₁ h₂) h₃

@[to_additive]
lemma mul_lt_of_mul_lt_left [covariant_class α α (*) (≤)]
  {a b c d : α} (h : a * b < c) (hle : d ≤ b) :
  a * d < c :=
(mul_le_mul_left' hle a).trans_lt h

@[to_additive]
lemma mul_le_of_mul_le_left [covariant_class α α (*) (≤)]
  {a b c d : α} (h : a * b ≤ c) (hle : d ≤ b) :
  a * d ≤ c :=
@act_rel_of_rel_of_act_rel _ _ _ (≤) _ ⟨λ _ _ _, le_trans⟩ a _ _ _ hle h

@[to_additive]
lemma mul_lt_of_mul_lt_right [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h : a * b < c) (hle : d ≤ a) :
  d * b < c :=
(mul_le_mul_right' hle b).trans_lt h

@[to_additive]
lemma mul_le_of_mul_le_right [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h : a * b ≤ c) (hle : d ≤ a) :
  d * b ≤ c :=
(mul_le_mul_right' hle b).trans h

@[to_additive]
lemma lt_mul_of_lt_mul_left [covariant_class α α (*) (≤)]
  {a b c d : α} (h : a < b * c) (hle : c ≤ d) :
  a < b * d :=
h.trans_le (mul_le_mul_left' hle b)

@[to_additive]
lemma le_mul_of_le_mul_left [covariant_class α α (*) (≤)]
  {a b c d : α} (h : a ≤ b * c) (hle : c ≤ d) :
  a ≤ b * d :=
@rel_act_of_rel_of_rel_act _ _ _ (≤) _ ⟨λ _ _ _, le_trans⟩ b _ _ _ hle h

@[to_additive]
lemma lt_mul_of_lt_mul_right [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h : a < b * c) (hle : b ≤ d) :
  a < d * c :=
h.trans_le (mul_le_mul_right' hle c)

@[to_additive]
lemma le_mul_of_le_mul_right [covariant_class α α (swap (*)) (≤)]
  {a b c d : α} (h : a ≤ b * c) (hle : b ≤ d) :
  a ≤ d * c :=
h.trans (mul_le_mul_right' hle c)

end preorder

section partial_order
variables [partial_order α]

@[to_additive]
lemma mul_left_cancel'' [contravariant_class α α (*) (≤)]
  {a b c : α} (h : a * b = a * c) :
  b = c :=
(le_of_mul_le_mul_left' h.le).antisymm (le_of_mul_le_mul_left' h.ge)

@[to_additive]
lemma mul_right_cancel'' [contravariant_class α α (swap (*)) (≤)]
  {a b c : α} (h : a * b = c * b) :
  a = c :=
le_antisymm (le_of_mul_le_mul_right' h.le) (le_of_mul_le_mul_right' h.ge)

end partial_order

end has_mul

-- using one
section mul_one_class
variables [mul_one_class α]

section has_le
variables [has_le α]

@[to_additive le_add_of_nonneg_right]
lemma le_mul_of_one_le_right' [covariant_class α α (*) (≤)]
  {a b : α} (h : 1 ≤ b) :
  a ≤ a * b :=
calc  a = a * 1  : (mul_one a).symm
    ... ≤ a * b  : mul_le_mul_left' h a

@[to_additive add_le_of_nonpos_right]
lemma mul_le_of_le_one_right' [covariant_class α α (*) (≤)]
  {a b : α} (h : b ≤ 1) :
  a * b ≤ a :=
calc  a * b ≤ a * 1 : mul_le_mul_left' h a
        ... = a     : mul_one a

@[to_additive le_add_of_nonneg_left]
lemma le_mul_of_one_le_left' [covariant_class α α (swap (*)) (≤)]
  {a b : α} (h : 1 ≤ b) :
  a ≤ b * a :=
calc  a = 1 * a  : (one_mul a).symm
    ... ≤ b * a  : mul_le_mul_right' h a

@[to_additive add_le_of_nonpos_left]
lemma mul_le_of_le_one_left' [covariant_class α α (swap (*)) (≤)]
  {a b : α} (h : b ≤ 1) :
  b * a ≤ a :=
calc  b * a ≤ 1 * a : mul_le_mul_right' h a
        ... = a     : one_mul a

@[simp, to_additive le_add_iff_nonneg_right]
lemma le_mul_iff_one_le_right'
  [covariant_class α α (*) (≤)] [contravariant_class α α (*) (≤)]
  (a : α) {b : α} :
  a ≤ a * b ↔ 1 ≤ b :=
iff.trans (by rw [mul_one]) (mul_le_mul_iff_left a)

@[simp, to_additive le_add_iff_nonneg_left]
lemma le_mul_iff_one_le_left'
  [covariant_class α α (swap (*)) (≤)] [contravariant_class α α (swap (*)) (≤)]
  (a : α) {b : α} :
  a ≤ b * a ↔ 1 ≤ b :=
iff.trans (by rw one_mul) (mul_le_mul_iff_right a)

@[simp, to_additive add_le_iff_nonpos_right]
lemma mul_le_iff_le_one_right'
  [covariant_class α α (*) (≤)] [contravariant_class α α (*) (≤)]
  (a : α) {b : α} :
  a * b ≤ a ↔ b ≤ 1 :=
iff.trans (by rw [mul_one]) (mul_le_mul_iff_left a)

@[simp, to_additive add_le_iff_nonpos_left]
lemma mul_le_iff_le_one_left'
  [covariant_class α α (swap (*)) (≤)] [contravariant_class α α (swap (*)) (≤)]
  {a b : α} :
  a * b ≤ b ↔ a ≤ 1 :=
iff.trans (by rw one_mul) (mul_le_mul_iff_right b)

end has_le

section has_lt
variable [has_lt α]

@[to_additive lt_add_of_pos_right]
lemma lt_mul_of_one_lt_right' [covariant_class α α (*) (<)]
  (a : α) {b : α} (h : 1 < b) :
  a < a * b :=
calc  a = a * 1  : (mul_one a).symm
    ... < a * b  : mul_lt_mul_left' h a

@[to_additive add_lt_of_neg_right]
lemma mul_lt_of_lt_one_right' [covariant_class α α (*) (<)]
  (a : α) {b : α} (h : b < 1) :
  a * b < a :=
calc  a * b < a * 1 : mul_lt_mul_left' h a
        ... = a     : mul_one a

@[to_additive lt_add_of_pos_left]
lemma lt_mul_of_one_lt_left' [covariant_class α α (swap (*)) (<)]
  (a : α) {b : α} (h : 1 < b) :
  a < b * a :=
calc  a = 1 * a  : (one_mul a).symm
    ... < b * a  : mul_lt_mul_right' h a

@[to_additive add_lt_of_neg_left]
lemma mul_lt_of_lt_one_left' [covariant_class α α (swap (*)) (<)]
  (a : α) {b : α} (h : b < 1) :
  b * a < a :=
calc  b * a < 1 * a : mul_lt_mul_right' h a
        ... = a     : one_mul a

@[simp, to_additive lt_add_iff_pos_right]
lemma lt_mul_iff_one_lt_right'
  [covariant_class α α (*) (<)] [contravariant_class α α (*) (<)]
  (a : α) {b : α} :
  a < a * b ↔ 1 < b :=
iff.trans (by rw mul_one) (mul_lt_mul_iff_left a)

@[simp, to_additive lt_add_iff_pos_left]
lemma lt_mul_iff_one_lt_left'
  [covariant_class α α (swap (*)) (<)] [contravariant_class α α (swap (*)) (<)]
  (a : α) {b : α} :
  a < b * a ↔ 1 < b :=
iff.trans (by rw one_mul) (mul_lt_mul_iff_right a)

@[simp, to_additive add_lt_iff_neg_left]
lemma mul_lt_iff_lt_one_left'
  [covariant_class α α (*) (<)] [contravariant_class α α (*) (<)]
  {a b : α} :
  a * b < a ↔ b < 1 :=
iff.trans (by rw mul_one) (mul_lt_mul_iff_left a)

@[simp, to_additive add_lt_iff_neg_right]
lemma mul_lt_iff_lt_one_right'
  [covariant_class α α (swap (*)) (<)] [contravariant_class α α (swap (*)) (<)]
  {a : α} (b : α) :
  a * b < b ↔ a < 1 :=
iff.trans (by rw one_mul) (mul_lt_mul_iff_right b)

end has_lt

section preorder
variable [preorder α]

/-! Lemmas of the form `b ≤ c → a ≤ 1 → b * a ≤ c`,
which assume left covariance. -/

@[to_additive]
lemma mul_le_of_le_of_le_one [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b ≤ c) (ha : a ≤ 1) : b * a ≤ c :=
calc  b * a ≤ b * 1 : mul_le_mul_left' ha b
        ... = b     : mul_one b
        ... ≤ c     : hbc

@[to_additive]
lemma mul_lt_of_le_of_lt_one [covariant_class α α (*) (<)]
  {a b c : α} (hbc : b ≤ c) (ha : a < 1) : b * a < c :=
calc  b * a < b * 1 : mul_lt_mul_left' ha b
        ... = b     : mul_one b
        ... ≤ c     : hbc

@[to_additive]
lemma mul_lt_of_lt_of_le_one [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b < c) (ha : a ≤ 1) : b * a < c :=
calc  b * a ≤ b * 1 : mul_le_mul_left' ha b
        ... = b     : mul_one b
        ... < c     : hbc

@[to_additive]
lemma mul_lt_of_lt_of_lt_one [covariant_class α α (*) (<)]
  {a b c : α} (hbc : b < c) (ha : a < 1) : b * a < c :=
calc  b * a < b * 1 : mul_lt_mul_left' ha b
        ... = b     : mul_one b
        ... < c     : hbc

@[to_additive]
lemma mul_lt_of_lt_of_lt_one' [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b < c) (ha : a < 1) : b * a < c :=
mul_lt_of_lt_of_le_one hbc ha.le

/-- Assumes left covariance.
The lemma assuming right covariance is `right.mul_le_one`. -/
@[to_additive "Assumes left covariance.
The lemma assuming right covariance is `right.add_nonpos`."]
lemma left.mul_le_one [covariant_class α α (*) (≤)]
  {a b : α} (ha : a ≤ 1) (hb : b ≤ 1) : a * b ≤ 1 :=
mul_le_of_le_of_le_one ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.mul_lt_one_of_le_of_lt`. -/
@[to_additive left.add_neg_of_nonpos_of_neg "Assumes left covariance.
The lemma assuming right covariance is `right.add_neg_of_nonpos_of_neg`."]
lemma left.mul_lt_one_of_le_of_lt [covariant_class α α (*) (<)]
  {a b : α} (ha : a ≤ 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_le_of_lt_one ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.mul_lt_one_of_lt_of_le`. -/
@[to_additive left.add_neg_of_neg_of_nonpos "Assumes left covariance.
The lemma assuming right covariance is `right.add_neg_of_neg_of_nonpos`."]
lemma left.mul_lt_one_of_lt_of_le [covariant_class α α (*) (≤)]
  {a b : α} (ha : a < 1) (hb : b ≤ 1) : a * b < 1 :=
mul_lt_of_lt_of_le_one ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.mul_lt_one`. -/
@[to_additive "Assumes left covariance.
The lemma assuming right covariance is `right.add_neg`."]
lemma left.mul_lt_one [covariant_class α α (*) (<)]
  {a b : α} (ha : a < 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_lt_of_lt_one ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.mul_lt_one'`. -/
@[to_additive "Assumes left covariance.
The lemma assuming right covariance is `right.add_neg'`."]
lemma left.mul_lt_one' [covariant_class α α (*) (≤)]
  {a b : α} (ha : a < 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_lt_of_lt_one' ha hb

/-! Lemmas of the form `b ≤ c → 1 ≤ a → b ≤ c * a`,
which assume left covariance. -/

@[to_additive]
lemma le_mul_of_le_of_one_le [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b ≤ c) (ha : 1 ≤ a) : b ≤ c * a :=
calc  b ≤ c     : hbc
    ... = c * 1 : (mul_one c).symm
    ... ≤ c * a : mul_le_mul_left' ha c

@[to_additive]
lemma lt_mul_of_le_of_one_lt [covariant_class α α (*) (<)]
  {a b c : α} (hbc : b ≤ c) (ha : 1 < a) : b < c * a :=
calc  b ≤ c     : hbc
    ... = c * 1 : (mul_one c).symm
    ... < c * a : mul_lt_mul_left' ha c

@[to_additive]
lemma lt_mul_of_lt_of_one_le [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b < c) (ha : 1 ≤ a) : b < c * a :=
calc  b < c     : hbc
    ... = c * 1 : (mul_one c).symm
    ... ≤ c * a : mul_le_mul_left' ha c

@[to_additive]
lemma lt_mul_of_lt_of_one_lt [covariant_class α α (*) (<)]
  {a b c : α} (hbc : b < c) (ha : 1 < a) : b < c * a :=
calc  b < c     : hbc
    ... = c * 1 : (mul_one c).symm
    ... < c * a : mul_lt_mul_left' ha c

@[to_additive]
lemma lt_mul_of_lt_of_one_lt' [covariant_class α α (*) (≤)]
  {a b c : α} (hbc : b < c) (ha : 1 < a) : b < c * a :=
lt_mul_of_lt_of_one_le hbc ha.le

/-- Assumes left covariance.
The lemma assuming right covariance is `right.one_le_mul`. -/
@[to_additive left.add_nonneg "Assumes left covariance.
The lemma assuming right covariance is `right.add_nonneg`."]
lemma left.one_le_mul [covariant_class α α (*) (≤)]
  {a b : α} (ha : 1 ≤ a) (hb : 1 ≤ b) : 1 ≤ a * b :=
le_mul_of_le_of_one_le ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.one_lt_mul_of_le_of_lt`. -/
@[to_additive left.add_pos_of_nonneg_of_pos "Assumes left covariance.
The lemma assuming right covariance is `right.add_pos_of_nonneg_of_pos`."]
lemma left.one_lt_mul_of_le_of_lt [covariant_class α α (*) (<)]
  {a b : α} (ha : 1 ≤ a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_le_of_one_lt ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.one_lt_mul_of_lt_of_le`. -/
@[to_additive left.add_pos_of_pos_of_nonneg "Assumes left covariance.
The lemma assuming right covariance is `right.add_pos_of_pos_of_nonneg`."]
lemma left.one_lt_mul_of_lt_of_le [covariant_class α α (*) (≤)]
  {a b : α} (ha : 1 < a) (hb : 1 ≤ b) : 1 < a * b :=
lt_mul_of_lt_of_one_le ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.one_lt_mul`. -/
@[to_additive left.add_pos "Assumes left covariance.
The lemma assuming right covariance is `right.add_pos`."]
lemma left.one_lt_mul [covariant_class α α (*) (<)]
  {a b : α} (ha : 1 < a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_lt_of_one_lt ha hb

/-- Assumes left covariance.
The lemma assuming right covariance is `right.one_lt_mul'`. -/
@[to_additive left.add_pos' "Assumes left covariance.
The lemma assuming right covariance is `right.add_pos'`."]
lemma left.one_lt_mul' [covariant_class α α (*) (≤)]
  {a b : α} (ha : 1 < a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_lt_of_one_lt' ha hb

/-! Lemmas of the form `a ≤ 1 → b ≤ c → a * b ≤ c`,
which assume right covariance. -/

@[to_additive]
lemma mul_le_of_le_one_of_le [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : a ≤ 1) (hbc : b ≤ c) : a * b ≤ c :=
calc  a * b ≤ 1 * b : mul_le_mul_right' ha b
        ... = b     : one_mul b
        ... ≤ c     : hbc

@[to_additive]
lemma mul_lt_of_lt_one_of_le [covariant_class α α (swap (*)) (<)]
  {a b c : α} (ha : a < 1) (hbc : b ≤ c) : a * b < c :=
calc  a * b < 1 * b : mul_lt_mul_right' ha b
        ... = b     : one_mul b
        ... ≤ c     : hbc

@[to_additive]
lemma mul_lt_of_le_one_of_lt [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : a ≤ 1) (hb : b < c) : a * b < c :=
calc  a * b ≤ 1 * b : mul_le_mul_right' ha b
        ... = b     : one_mul b
        ... < c     : hb

@[to_additive]
lemma mul_lt_of_lt_one_of_lt [covariant_class α α (swap (*)) (<)]
  {a b c : α} (ha : a < 1) (hb : b < c) : a * b < c :=
calc  a * b < 1 * b : mul_lt_mul_right' ha b
        ... = b     : one_mul b
        ... < c     : hb

@[to_additive]
lemma mul_lt_of_lt_one_of_lt' [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : a < 1) (hbc : b < c) : a * b < c :=
mul_lt_of_le_one_of_lt ha.le hbc

/-- Assumes right covariance.
The lemma assuming left covariance is `left.mul_le_one`. -/
@[to_additive "Assumes right covariance.
The lemma assuming left covariance is `left.add_nonpos`."]
lemma right.mul_le_one [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : a ≤ 1) (hb : b ≤ 1) : a * b ≤ 1 :=
mul_le_of_le_one_of_le ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.mul_lt_one_of_lt_of_le`. -/
@[to_additive right.add_neg_of_neg_of_nonpos "Assumes right covariance.
The lemma assuming left covariance is `left.add_neg_of_neg_of_nonpos`."]
lemma right.mul_lt_one_of_lt_of_le [covariant_class α α (swap (*)) (<)]
  {a b : α} (ha : a < 1) (hb : b ≤ 1) : a * b < 1 :=
mul_lt_of_lt_one_of_le ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.mul_lt_one_of_le_of_lt`. -/
@[to_additive right.add_neg_of_nonpos_of_neg "Assumes right covariance.
The lemma assuming left covariance is `left.add_neg_of_nonpos_of_neg`."]
lemma right.mul_lt_one_of_le_of_lt [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : a ≤ 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_le_one_of_lt ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.mul_lt_one`. -/
@[to_additive "Assumes right covariance.
The lemma assuming left covariance is `left.add_neg`."]
lemma right.mul_lt_one [covariant_class α α (swap (*)) (<)]
  {a b : α} (ha : a < 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_lt_one_of_lt ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.mul_lt_one'`. -/
@[to_additive "Assumes right covariance.
The lemma assuming left covariance is `left.add_neg'`."]
lemma right.mul_lt_one' [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : a < 1) (hb : b < 1) : a * b < 1 :=
mul_lt_of_lt_one_of_lt' ha hb

/-! Lemmas of the form `1 ≤ a → b ≤ c → b ≤ a * c`,
which assume right covariance. -/

@[to_additive]
lemma le_mul_of_one_le_of_le [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : 1 ≤ a) (hbc : b ≤ c) : b ≤ a * c :=
calc  b ≤ c     : hbc
    ... = 1 * c : (one_mul c).symm
    ... ≤ a * c : mul_le_mul_right' ha c

@[to_additive]
lemma lt_mul_of_one_lt_of_le [covariant_class α α (swap (*)) (<)]
  {a b c : α} (ha : 1 < a) (hbc : b ≤ c) : b < a * c :=
calc  b ≤ c     : hbc
    ... = 1 * c : (one_mul c).symm
    ... < a * c : mul_lt_mul_right' ha c

@[to_additive]
lemma lt_mul_of_one_le_of_lt [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : 1 ≤ a) (hbc : b < c) : b < a * c :=
calc  b < c     : hbc
    ... = 1 * c : (one_mul c).symm
    ... ≤ a * c : mul_le_mul_right' ha c

@[to_additive]
lemma lt_mul_of_one_lt_of_lt [covariant_class α α (swap (*)) (<)]
  {a b c : α} (ha : 1 < a) (hbc : b < c) : b < a * c :=
calc  b < c     : hbc
    ... = 1 * c : (one_mul c).symm
    ... < a * c : mul_lt_mul_right' ha c

@[to_additive]
lemma lt_mul_of_one_lt_of_lt' [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (ha : 1 < a) (hbc : b < c) : b < a * c :=
lt_mul_of_one_le_of_lt ha.le hbc

/-- Assumes right covariance.
The lemma assuming left covariance is `left.one_le_mul`. -/
@[to_additive right.add_nonneg "Assumes right covariance.
The lemma assuming left covariance is `left.add_nonneg`."]
lemma right.one_le_mul [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : 1 ≤ a) (hb : 1 ≤ b) : 1 ≤ a * b :=
le_mul_of_one_le_of_le ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.one_lt_mul_of_lt_of_le`. -/
@[to_additive right.add_pos_of_pos_of_nonneg "Assumes right covariance.
The lemma assuming left covariance is `left.add_pos_of_pos_of_nonneg`."]
lemma right.one_lt_mul_of_lt_of_le [covariant_class α α (swap (*)) (<)]
  {a b : α} (ha : 1 < a) (hb : 1 ≤ b) : 1 < a * b :=
lt_mul_of_one_lt_of_le ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.one_lt_mul_of_le_of_lt`. -/
@[to_additive right.add_pos_of_nonneg_of_pos "Assumes right covariance.
The lemma assuming left covariance is `left.add_pos_of_nonneg_of_pos`."]
lemma right.one_lt_mul_of_le_of_lt [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : 1 ≤ a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_one_le_of_lt ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.one_lt_mul`. -/
@[to_additive right.add_pos "Assumes right covariance.
The lemma assuming left covariance is `left.add_pos`."]
lemma right.one_lt_mul [covariant_class α α (swap (*)) (<)]
  {a b : α} (ha : 1 < a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_one_lt_of_lt ha hb

/-- Assumes right covariance.
The lemma assuming left covariance is `left.one_lt_mul'`. -/
@[to_additive right.add_pos' "Assumes right covariance.
The lemma assuming left covariance is `left.add_pos'`."]
lemma right.one_lt_mul' [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : 1 < a) (hb : 1 < b) : 1 < a * b :=
lt_mul_of_one_lt_of_lt' ha hb

alias left.mul_le_one             ← mul_le_one'
alias left.mul_lt_one_of_le_of_lt ← mul_lt_one_of_le_of_lt
alias left.mul_lt_one_of_lt_of_le ← mul_lt_one_of_lt_of_le
alias left.mul_lt_one             ← mul_lt_one
alias left.mul_lt_one'            ← mul_lt_one'
attribute [to_additive add_nonpos "**Alias** of `left.add_nonpos`."]
mul_le_one'
attribute [to_additive add_neg_of_nonpos_of_neg "**Alias** of `left.add_neg_of_nonpos_of_neg`."]
mul_lt_one_of_le_of_lt
attribute [to_additive add_neg_of_neg_of_nonpos "**Alias** of `left.add_neg_of_neg_of_nonpos`."]
mul_lt_one_of_lt_of_le
attribute [to_additive "**Alias** of `left.add_neg`."]
mul_lt_one
attribute [to_additive "**Alias** of `left.add_neg'`."]
mul_lt_one'

alias left.one_le_mul             ← one_le_mul
alias left.one_lt_mul_of_le_of_lt ← one_lt_mul_of_le_of_lt'
alias left.one_lt_mul_of_lt_of_le ← one_lt_mul_of_lt_of_le'
alias left.one_lt_mul             ← one_lt_mul'
alias left.one_lt_mul'            ← one_lt_mul''
attribute [to_additive add_nonneg "**Alias** of `left.add_nonneg`."]
one_le_mul
attribute [to_additive add_pos_of_nonneg_of_pos "**Alias** of `left.add_pos_of_nonneg_of_pos`."]
one_lt_mul_of_le_of_lt'
attribute [to_additive add_pos_of_pos_of_nonneg "**Alias** of `left.add_pos_of_pos_of_nonneg`."]
one_lt_mul_of_lt_of_le'
attribute [to_additive add_pos "**Alias** of `left.add_pos`."]
one_lt_mul'
attribute [to_additive add_pos' "**Alias** of `left.add_pos'`."]
one_lt_mul''

@[to_additive]
lemma lt_of_mul_lt_of_one_le_left [covariant_class α α (*) (≤)]
  {a b c : α} (h : a * b < c) (hle : 1 ≤ b) : a < c :=
(le_mul_of_one_le_right' hle).trans_lt h

@[to_additive]
lemma le_of_mul_le_of_one_le_left [covariant_class α α (*) (≤)]
  {a b c : α} (h : a * b ≤ c) (hle : 1 ≤ b) : a ≤ c :=
(le_mul_of_one_le_right' hle).trans h

@[to_additive]
lemma lt_of_lt_mul_of_le_one_left [covariant_class α α (*) (≤)]
  {a b c : α} (h : a < b * c) (hle : c ≤ 1) : a < b :=
h.trans_le (mul_le_of_le_one_right' hle)

@[to_additive]
lemma le_of_le_mul_of_le_one_left [covariant_class α α (*) (≤)]
  {a b c : α} (h : a ≤ b * c) (hle : c ≤ 1) : a ≤ b :=
h.trans (mul_le_of_le_one_right' hle)

@[to_additive]
lemma lt_of_mul_lt_of_one_le_right [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (h : a * b < c) (hle : 1 ≤ a) : b < c :=
(le_mul_of_one_le_left' hle).trans_lt h

@[to_additive]
lemma le_of_mul_le_of_one_le_right [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (h : a * b ≤ c) (hle : 1 ≤ a) : b ≤ c :=
(le_mul_of_one_le_left' hle).trans h

@[to_additive]
lemma lt_of_lt_mul_of_le_one_right [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (h : a < b * c) (hle : b ≤ 1) : a < c :=
h.trans_le (mul_le_of_le_one_left' hle)

@[to_additive]
lemma le_of_le_mul_of_le_one_right [covariant_class α α (swap (*)) (≤)]
  {a b c : α} (h : a ≤ b * c) (hle : b ≤ 1) : a ≤ c :=
h.trans (mul_le_of_le_one_left' hle)

end preorder

section partial_order
variables [partial_order α]

@[to_additive]
lemma mul_eq_one_iff' [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (≤)]
  {a b : α} (ha : 1 ≤ a) (hb : 1 ≤ b) : a * b = 1 ↔ a = 1 ∧ b = 1 :=
iff.intro
  (assume hab : a * b = 1,
   have a ≤ 1, from hab ▸ le_mul_of_le_of_one_le le_rfl hb,
   have a = 1, from le_antisymm this ha,
   have b ≤ 1, from hab ▸ le_mul_of_one_le_of_le ha le_rfl,
   have b = 1, from le_antisymm this hb,
   and.intro ‹a = 1› ‹b = 1›)
  (assume ⟨ha', hb'⟩, by rw [ha', hb', mul_one])

end partial_order

section linear_order
variables [linear_order α]

lemma exists_square_le [covariant_class α α (*) (<)]
  (a : α) : ∃ (b : α), b * b ≤ a :=
begin
  by_cases h : a < 1,
  { use a,
    have : a*a < a*1,
    exact mul_lt_mul_left' h a,
    rw mul_one at this,
    exact le_of_lt this },
  { use 1,
    push_neg at h,
    rwa mul_one }
end

end linear_order

end mul_one_class

section semigroup
variables [semigroup α]

section partial_order
variables [partial_order α]

/- This is not instance, since we want to have an instance from `left_cancel_semigroup`s
to the appropriate `covariant_class`. -/
/--  A semigroup with a partial order and satisfying `left_cancel_semigroup`
(i.e. `a * c < b * c → a < b`) is a `left_cancel semigroup`. -/
@[to_additive
"An additive semigroup with a partial order and satisfying `left_cancel_add_semigroup`
(i.e. `c + a < c + b → a < b`) is a `left_cancel add_semigroup`."]
def contravariant.to_left_cancel_semigroup
  [contravariant_class α α (*) (≤)] :
  left_cancel_semigroup α :=
{ mul_left_cancel := λ a b c, mul_left_cancel''
  ..‹semigroup α› }

/- This is not instance, since we want to have an instance from `right_cancel_semigroup`s
to the appropriate `covariant_class`. -/
/--  A semigroup with a partial order and satisfying `right_cancel_semigroup`
(i.e. `a * c < b * c → a < b`) is a `right_cancel semigroup`. -/
@[to_additive
"An additive semigroup with a partial order and satisfying `right_cancel_add_semigroup`
(`a + c < b + c → a < b`) is a `right_cancel add_semigroup`."]
def contravariant.to_right_cancel_semigroup
  [contravariant_class α α (swap (*)) (≤)] :
  right_cancel_semigroup α :=
{ mul_right_cancel := λ a b c, mul_right_cancel''
  ..‹semigroup α› }

@[to_additive] lemma left.mul_eq_mul_iff_eq_and_eq
  [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (≤)]
  [contravariant_class α α (*) (≤)] [contravariant_class α α (swap (*)) (≤)]
  {a b c d : α} (hac : a ≤ c) (hbd : b ≤ d) : a * b = c * d ↔ a = c ∧ b = d :=
begin
  refine ⟨λ h, _, λ h, congr_arg2 (*) h.1 h.2⟩,
  rcases hac.eq_or_lt with rfl | hac,
  { exact ⟨rfl, mul_left_cancel'' h⟩ },
  rcases eq_or_lt_of_le hbd with rfl | hbd,
  { exact ⟨mul_right_cancel'' h, rfl⟩ },
  exact ((left.mul_lt_mul hac hbd).ne h).elim,
end

@[to_additive] lemma right.mul_eq_mul_iff_eq_and_eq
  [covariant_class α α (*) (≤)] [contravariant_class α α (*) (≤)]
  [covariant_class α α (swap (*)) (<)] [contravariant_class α α (swap (*)) (≤)]
  {a b c d : α} (hac : a ≤ c) (hbd : b ≤ d) : a * b = c * d ↔ a = c ∧ b = d :=
begin
  refine ⟨λ h, _, λ h, congr_arg2 (*) h.1 h.2⟩,
  rcases hac.eq_or_lt with rfl | hac,
  { exact ⟨rfl, mul_left_cancel'' h⟩ },
  rcases eq_or_lt_of_le hbd with rfl | hbd,
  { exact ⟨mul_right_cancel'' h, rfl⟩ },
  exact ((right.mul_lt_mul hac hbd).ne h).elim,
end

alias left.mul_eq_mul_iff_eq_and_eq ← mul_eq_mul_iff_eq_and_eq
attribute [to_additive] mul_eq_mul_iff_eq_and_eq

end partial_order

end semigroup

section mono
variables [has_mul α] [preorder α] [preorder β] {f g : β → α}

@[to_additive monotone.const_add]
lemma monotone.const_mul' [covariant_class α α (*) (≤)] (hf : monotone f) (a : α) :
  monotone (λ x, a * f x) :=
λ x y h, mul_le_mul_left' (hf h) a

@[to_additive monotone.add_const]
lemma monotone.mul_const' [covariant_class α α (swap (*)) (≤)]
  (hf : monotone f) (a : α) : monotone (λ x, f x * a) :=
λ x y h, mul_le_mul_right' (hf h) a

/--  The product of two monotone functions is monotone. -/
@[to_additive monotone.add "The sum of two monotone functions is monotone."]
lemma monotone.mul' [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (≤)]
  (hf : monotone f) (hg : monotone g) : monotone (λ x, f x * g x) :=
λ x y h, mul_le_mul' (hf h) (hg h)

section left
variables [covariant_class α α (*) (<)]

@[to_additive strict_mono.const_add]
lemma strict_mono.const_mul' (hf : strict_mono f) (c : α) :
  strict_mono (λ x, c * f x) :=
λ a b ab, mul_lt_mul_left' (hf ab) c

end left

section right
variables [covariant_class α α (swap (*)) (<)]

@[to_additive strict_mono.add_const]
lemma strict_mono.mul_const' (hf : strict_mono f) (c : α) :
  strict_mono (λ x, f x * c) :=
λ a b ab, mul_lt_mul_right' (hf ab) c

end right

/--  The product of two strictly monotone functions is strictly monotone. -/
@[to_additive strict_mono.add
"The sum of two strictly monotone functions is strictly monotone."]
lemma strict_mono.mul' [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (<)]
  (hf : strict_mono f) (hg : strict_mono g) :
  strict_mono (λ x, f x * g x) :=
λ a b ab, mul_lt_mul_of_lt_of_lt (hf ab) (hg ab)

/--  The product of a monotone function and a strictly monotone function is strictly monotone. -/
@[to_additive monotone.add_strict_mono
"The sum of a monotone function and a strictly monotone function is strictly monotone."]
lemma monotone.mul_strict_mono' [covariant_class α α (*) (<)] [covariant_class α α (swap (*)) (≤)]
  {f g : β → α} (hf : monotone f) (hg : strict_mono g) :
  strict_mono (λ x, f x * g x) :=
λ x y h, mul_lt_mul_of_le_of_lt (hf h.le) (hg h)

variables [covariant_class α α (*) (≤)] [covariant_class α α (swap (*)) (<)]

/--  The product of a strictly monotone function and a monotone function is strictly monotone. -/
@[to_additive strict_mono.add_monotone
"The sum of a strictly monotone function and a monotone function is strictly monotone."]
lemma strict_mono.mul_monotone' (hf : strict_mono f) (hg : monotone g) :
  strict_mono (λ x, f x * g x) :=
λ x y h, mul_lt_mul_of_lt_of_le (hf h) (hg h.le)

end mono

/--
An element `a : α` is `mul_le_cancellable` if `x ↦ a * x` is order-reflecting.
We will make a separate version of many lemmas that require `[contravariant_class α α (*) (≤)]` with
`mul_le_cancellable` assumptions instead. These lemmas can then be instantiated to specific types,
like `ennreal`, where we can replace the assumption `add_le_cancellable x` by `x ≠ ∞`.
-/
@[to_additive /-" An element `a : α` is `add_le_cancellable` if `x ↦ a + x` is order-reflecting.
We will make a separate version of many lemmas that require `[contravariant_class α α (+) (≤)]` with
`mul_le_cancellable` assumptions instead. These lemmas can then be instantiated to specific types,
like `ennreal`, where we can replace the assumption `add_le_cancellable x` by `x ≠ ∞`. "-/
]
def mul_le_cancellable [has_mul α] [has_le α] (a : α) : Prop :=
∀ ⦃b c⦄, a * b ≤ a * c → b ≤ c

@[to_additive]
lemma contravariant.mul_le_cancellable [has_mul α] [has_le α] [contravariant_class α α (*) (≤)]
  {a : α} : mul_le_cancellable a :=
λ b c, le_of_mul_le_mul_left'

namespace mul_le_cancellable

@[to_additive]
protected lemma injective [has_mul α] [partial_order α] {a : α} (ha : mul_le_cancellable a) :
  injective ((*) a) :=
λ b c h, le_antisymm (ha h.le) (ha h.ge)

@[to_additive]
protected lemma inj [has_mul α] [partial_order α] {a b c : α} (ha : mul_le_cancellable a) :
  a * b = a * c ↔ b = c :=
ha.injective.eq_iff

@[to_additive]
protected lemma injective_left [comm_semigroup α] [partial_order α] {a : α}
  (ha : mul_le_cancellable a) : injective (* a) :=
λ b c h, ha.injective $ by rwa [mul_comm a, mul_comm a]

@[to_additive]
protected lemma inj_left [comm_semigroup α] [partial_order α] {a b c : α}
  (hc : mul_le_cancellable c) : a * c = b * c ↔ a = b :=
hc.injective_left.eq_iff

variable [has_le α]

@[to_additive]
protected lemma mul_le_mul_iff_left [has_mul α] [covariant_class α α (*) (≤)]
  {a b c : α} (ha : mul_le_cancellable a) : a * b ≤ a * c ↔ b ≤ c :=
⟨λ h, ha h, λ h, mul_le_mul_left' h a⟩

@[to_additive]
protected lemma mul_le_mul_iff_right [comm_semigroup α] [covariant_class α α (*) (≤)]
  {a b c : α} (ha : mul_le_cancellable a) : b * a ≤ c * a ↔ b ≤ c :=
by rw [mul_comm b, mul_comm c, ha.mul_le_mul_iff_left]

@[to_additive]
protected lemma le_mul_iff_one_le_right [mul_one_class α] [covariant_class α α (*) (≤)]
  {a b : α} (ha : mul_le_cancellable a) : a ≤ a * b ↔ 1 ≤ b :=
iff.trans (by rw [mul_one]) ha.mul_le_mul_iff_left

@[to_additive]
protected lemma mul_le_iff_le_one_right [mul_one_class α] [covariant_class α α (*) (≤)]
  {a b : α} (ha : mul_le_cancellable a) : a * b ≤ a ↔ b ≤ 1 :=
iff.trans (by rw [mul_one]) ha.mul_le_mul_iff_left

@[to_additive]
protected lemma le_mul_iff_one_le_left [comm_monoid α] [covariant_class α α (*) (≤)]
  {a b : α} (ha : mul_le_cancellable a) : a ≤ b * a ↔ 1 ≤ b :=
by rw [mul_comm, ha.le_mul_iff_one_le_right]

@[to_additive]
protected lemma mul_le_iff_le_one_left [comm_monoid α] [covariant_class α α (*) (≤)]
  {a b : α} (ha : mul_le_cancellable a) : b * a ≤ a ↔ b ≤ 1 :=
by rw [mul_comm, ha.mul_le_iff_le_one_right]

end mul_le_cancellable


/-
Copyright (c) 2022 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : Julian Kuelshammer
-/

import easy_mode.sheet04

/-! Linear maps

In this section, we give the definition of a linear map, show that a 2x2-matrix gives rise to a linear map,
and that every linear map from ℝ² to ℝ² is given by a matrix.
-/

/-- `linear_map V W` is the type of linear maps from `V` to `W`. -/
@[ext] structure linear_map (V W : Type) [real_vector_space V] [real_vector_space W] :=
(to_fun : V → W)
(map_add' (v v' : V) : to_fun (v + v') = to_fun v + to_fun v')
(map_smul' (a : ℝ) (v : V) : to_fun (a • v) = a • to_fun v)

namespace linear_map

-- throughout this sheet, `V` and `W` will be real vector spaces.
variables {V W : Type} [real_vector_space V] [real_vector_space W]

-- We use notation `V →ₗᵢₙ H` for the type of linear maps from `V` to `W`.
notation V ` →ₗᵢₙ ` W := linear_map V W

-- A linear map is a function, and so we set up a "coercion"
-- so that a linear map can be regarded as a function (even
-- though it's actually a pair consisting of a function and two axioms)
instance : has_coe_to_fun (V →ₗᵢₙ W) (λ _, V → W) :=
{ coe := linear_map.to_fun }

@[simp] lemma simplify_coercion (f : V →ₗᵢₙ W) (v : V) : f.to_fun v = f v := rfl

-- Notice that we can now write `f (v + v')` and `f (a • v)` even though `f` isn't actually a
-- function, it's a pair consisting of a function `f.to_fun` and the axioms `f.map_add'` and `f.map_smul`.
-- The below lemma is how we want to use it as mathematicians though.
lemma map_add (f : V →ₗᵢₙ W) (v v' : V) :
  f (v + v') = f v + f v' :=
begin
  -- the point is that f.map_add and f.map_add' are *definitionally equal*
  -- but *syntactically different*, and the primed version looks uglier.
  -- The point of this lemma is that `f.map_add` looks nicer.
  exact f.map_add' v v'
end

lemma map_smul (f : V →ₗᵢₙ W) (a : ℝ) (v : V) :
  f (a • v) = a • f v :=
begin
  sorry
end

@[simp] lemma map_zero (f : V →ₗᵢₙ W) : f 0 = 0 :=
begin
  sorry
end

/- The following could be important later on. See if you use it. -/
lemma expand_two_linear (f : ℝ² →ₗᵢₙ ℝ²) (v : ℝ²) : (f v) = v.x • f ⟨1,0⟩ + v.y • f ⟨0,1⟩ :=
begin
  sorry
end

end linear_map

def two_matrix.to_linear_map (A : Mat₂) : ℝ² →ₗᵢₙ ℝ² :=
{ to_fun := λ v, ⟨v.1 * A.fst_row.1 + v.2 * A.fst_row.2, v.1 * A.snd_row.1 + v.2 * A.snd_row.2⟩,
  map_add' := sorry,
  map_smul' := sorry, }

instance : has_coe_to_fun (two_matrix) (λ _, ℝ² → ℝ²) :=
{ coe := λ A, (A.to_linear_map).to_fun }

/- The following seems self-evident if you think what it means, but it is not immediately
  clear to the simplifyer. If you want, you can comment it out and see what stops working
  in later proofs. -/
@[simp] lemma to_linear_map_to_fun_eq_to_fun  (A : Mat₂) (v : ℝ²) :
A.to_linear_map v = A v := rfl

/- Now an expression like the following makes sense.-/
#check two_matrix.zero_matrix plane.zero_vector

/- Or even the following, which might seem a bit confusing.-/
#check (0 : two_matrix) 0 = 0

/- The following two simp-lemmas will help us actually prove such statements. -/
@[simp] lemma matrix_multiplication_x (A : Mat₂) (v : ℝ²) :
(A v).1 = v.1 * A.fst_row.1 + v.2 * A.fst_row.2 := sorry

@[simp] lemma matrix_multiplication_y (A : Mat₂) (v : ℝ²) :
(A v).2 = v.1 * A.snd_row.1 + v.2 * A.snd_row.2 := sorry

/- The zero matrix applied to the zero vector is equal to zero ...amazing.-/
example : (0 : two_matrix) 0 = 0 :=
begin
  sorry
end

/- Let's generalise this to the zero matrix applied to an arbitrary vector.-/
lemma zero_matrix_apply (v : ℝ²) : (0 : two_matrix) v = 0 :=
begin
  sorry
end

/- The other way round. -/
lemma matrix_apply_zero_vector (A : Mat₂) : A 0 = 0 :=
begin
  sorry
end

/- Now the other way round, associating a matrix to a linear map. -/
def linear_map.to_two_matrix (f : ℝ² →ₗᵢₙ ℝ²) : Mat₂ :=
{ fst_row := ⟨(f ⟨1,0⟩).1, (f ⟨0,1⟩).1⟩,
  snd_row := ⟨(f ⟨1,0⟩).2, (f ⟨0,1⟩).2⟩ }

@[simp] lemma linear_map.to_two_matrix_fst_row_x (f : ℝ² →ₗᵢₙ ℝ²) : f.to_two_matrix.fst_row.x = (f ⟨1,0⟩).1 := sorry
@[simp] lemma linear_map.to_two_matrix_fst_row_y  (f : ℝ² →ₗᵢₙ ℝ²) : f.to_two_matrix.fst_row.y = (f ⟨0,1⟩).1 := sorry
@[simp] lemma linear_map.to_two_matrix_snd_row_x (f : ℝ² →ₗᵢₙ ℝ²) : f.to_two_matrix.snd_row.x = (f ⟨1,0⟩).2 := sorry
@[simp] lemma linear_map.to_two_matrix_snd_row_y  (f : ℝ² →ₗᵢₙ ℝ²) : f.to_two_matrix.snd_row.y = (f ⟨0,1⟩).2 := sorry

@[simp] lemma to_two_matrix_to_fun_eq_to_fun (f : ℝ² →ₗᵢₙ ℝ²) (v : ℝ²) : f.to_two_matrix v = f.to_fun v :=
begin
  sorry
end

/- And now we show that there is a 1-1 correspondence between 2x2-matrices and linear maps from the plane to itself. -/
def matrix_linear_correspondence : (ℝ² →ₗᵢₙ ℝ²) ≃ Mat₂ :=
{ to_fun := linear_map.to_two_matrix,
  inv_fun := two_matrix.to_linear_map,
  left_inv := sorry,
  right_inv := sorry,
}

/- As a bonus you could even think about putting a vector space structure on (ℝ² →ₗᵢₙ ℝ²) and proving that it is
  linearly isomorphic to Mat₂. -/


-- vim: ts=2 sw=0 sts=-1 et ai tw=70

-- Defining some operations on integers, thought of as pairs of
-- natural numbers (a, b), representing a - b.

-- Modelled heavily after frac from our myrat

import ..logic
import ..mynat.basic
import ..mynat.lt

namespace hidden
open mynat
namespace int_pair

-- the pair (a, b) represents the integer a - b
structure int_pair := (a b: mynat)

instance: has_zero int_pair := ⟨⟨0, 0⟩⟩
instance: has_one int_pair := ⟨⟨1, 0⟩⟩

@[simp] theorem zero_def: (0: int_pair) = ⟨0, 0⟩ := rfl
@[simp] theorem one_def: (1: int_pair) = ⟨1, 0⟩ := rfl

theorem eq_iff_split (n m: int_pair):
n = m ↔ n.a = m.a ∧ n.b = m.b :=
begin
  cases n with na nb,
  cases m with ma mb,
  simp,
end

-- establishing the equivalence relation

def int_pair_eq (n m: int_pair): Prop :=
n.a + m.b = m.a + n.b

theorem int_pair_eq_refl: reflexive int_pair_eq :=
begin
  intro n,
  unfold int_pair_eq,
end

theorem int_pair_eq_symm: symmetric int_pair_eq :=
begin
  intros n m,
  unfold int_pair_eq,
  from eq.symm,
end

theorem int_pair_eq_trans: transitive int_pair_eq :=
begin
  intros n m k,
  unfold int_pair_eq,
  assume hnm hmk,
  apply @mynat.add_cancel _ _ (m.a + m.b),
  conv {
    congr,
    rw mynat.add_assoc,
    congr, skip,
    rw ←mynat.add_assoc,
    congr,
    rw mynat.add_comm,
    rw hnm,
    skip, skip,
    rw mynat.add_assoc,
    congr, skip,
    rw ←mynat.add_assoc,
    congr,
    rw mynat.add_comm,
    rw ←hmk,
  },
  ac_refl,
end

instance int_pair.setoid : setoid int_pair :=
⟨int_pair_eq, ⟨int_pair_eq_refl, int_pair_eq_symm, int_pair_eq_trans⟩⟩

theorem setoid_equiv (x y : int_pair) :
x ≈ y ↔ x.a + y.b = y.a + x.b := iff.rfl

theorem sound_exact_iff (x y: int_pair):
⟦x⟧ = ⟦y⟧ ↔ x ≈ y := iff.intro quotient.exact quotient.sound

instance int_pair_eq_decidable: ∀ n m: int_pair, decidable (n ≈ m) :=
begin
  intros n m,
  rw setoid_equiv,
  from mynat.decidable_eq _ _,
end

-- definitions and definitional equalities

def neg (n: int_pair): int_pair := ⟨n.b, n.a⟩

instance: has_neg int_pair := ⟨neg⟩

@[simp] theorem neg_is_neg {n: int_pair}: neg n = -n := rfl

@[simp] theorem neg_a {n: int_pair}: (-n).a = n.b := rfl
@[simp] theorem neg_b {n: int_pair}: (-n).b = n.a := rfl

theorem neg_well_defined (n m: int_pair):
n ≈ m → ⟦-n⟧ = ⟦-m⟧ :=
begin
  assume hnm,
  apply quotient.sound,
  rw setoid_equiv at *,
  simp,
  rw add_comm,
  rw ←hnm,
  rw add_comm,
end

def add (n m: int_pair): int_pair := ⟨n.a + m.a, n.b + m.b⟩

instance: has_add int_pair := ⟨add⟩

@[simp]
theorem add_add {n m: int_pair}: add n m = n + m := rfl

@[simp] theorem add_a {n m: int_pair}: (n + m).a = n.a + m.a := rfl

@[simp] theorem add_b {n m: int_pair}: (n + m).b = n.b + m.b := rfl

theorem add_well_defined (n m x y: int_pair):
n ≈ x → m ≈ y → ⟦n + m⟧ = ⟦x + y⟧ :=
begin
  assume hnx hmy,
  apply quotient.sound,
  rw setoid_equiv at *,
  simp,
  conv {
    to_lhs,
    rw mynat.add_assoc,
    rw mynat.add_comm m.a,
    rw ←mynat.add_assoc,
    rw ←mynat.add_assoc,
    rw hnx,
    rw mynat.add_assoc,
    rw mynat.add_comm y.b,
    rw hmy,
  },
  ac_refl,
end

def sub (n m: int_pair): int_pair := n + (-m)

instance: has_sub int_pair := ⟨sub⟩

@[simp]
theorem sub_sub (n m: int_pair): sub n m = n - m := rfl

def le (n m: int_pair): Prop := n.a + m.b ≤ m.a + n.b

instance: has_le int_pair := ⟨le⟩

@[simp]
theorem le_le (n m: int_pair): le n m ↔ n ≤ m := iff.rfl

@[simp]
theorem le_def (n m: int_pair): n ≤ m ↔ n.a + m.b ≤ m.a + n.b
:= iff.rfl

instance decidable_le: ∀ n m: int_pair, decidable (n ≤ m) :=
λ m n, mynat.decidable_le _ _

private theorem le_well_defined_right (n x m y: int_pair):
n ≈ x → m ≈ y → (n ≤ m → x ≤ y) :=
begin
  assume hnx hmy,
  rw setoid_equiv at *,
  repeat {rw le_def},
  assume hnm,
  apply @mynat.le_cancel _ _ (n.b + m.a),
  conv {
    congr,
    rw mynat.add_assoc,
    rw mynat.add_comm y.b,
    rw mynat.add_assoc,
    rw ←mynat.add_assoc,
    rw ←hnx,
    rw hmy,
  },
  have: n.a + x.b + (y.a + m.b) = n.a + m.b + (y.a + x.b) := by ac_refl,
  rw this, clear this,
  have: y.a + x.b + (n.b + m.a) = m.a + n.b + (y.a + x.b) := by ac_refl,
  rw this,
  apply mynat.le_add,
  assumption,
end

theorem le_well_defined (n m x y: int_pair):
n ≈ x → m ≈ y → ((n ≤ m) = (x ≤ y)) :=
begin
  assume hnx hmy,
  apply propext,
  from iff.intro (le_well_defined_right _ _ _ _ hnx hmy)
                 (le_well_defined_right _ _ _ _ hnx.symm hmy.symm),
end

def mul (n m: int_pair): int_pair := ⟨n.a * m.a + n.b * m.b, n.a * m.b + n.b * m.a⟩

instance: has_mul int_pair := ⟨mul⟩

@[simp]
theorem mul_def {n m: int_pair}: add n m = n + m := rfl

@[simp]
theorem mul_a {n m: int_pair}:
(n * m).a = n.a * m.a + n.b * m.b := rfl

-- one of the lesser known Spice Girls
@[simp]
theorem mul_b {n m: int_pair}:
(n * m).b = n.a * m.b + n.b * m.a := rfl

-- it's very hard to prove multiplication is well defined
-- in both arguments at once
private lemma mul_half_defined (n m x: int_pair):
n ≈ m → ⟦n * x⟧ = ⟦m * x⟧ :=
begin
  assume hnm,
  apply quotient.sound,
  rw setoid_equiv at *,
  simp,
  have:
    n.a * x.a + n.b * x.b + (m.a * x.b + m.b * x.a) =
      (n.a + m.b) * x.a + (n.b  + m.a) * x.b, {
    repeat {rw mul_add <|> rw add_mul},
    ac_refl,
  },
  rw this,
  conv {
    congr,
    congr,
    congr,
    rw hnm,
    skip, skip,
    congr,
    rw add_comm,
    rw ←hnm,
  },
  repeat {rw mul_add <|> rw add_mul},
  ac_refl,
end

theorem mul_comm {n m: int_pair}: n * m = m * n :=
begin
  rw eq_iff_split,
  simp,
  split; ac_refl,
end

theorem mul_well_defined (n m x y: int_pair):
n ≈ x → m ≈ y → ⟦n * m⟧ = ⟦x * y⟧ :=
begin
  assume hnx hmy,
  transitivity ⟦x * m⟧, {
    from mul_half_defined n x m hnx,
  }, {
    repeat {rw @mul_comm x},
    from mul_half_defined m y x hmy,
  },
end

variables {n m k: int_pair}

theorem add_comm: n + m = m + n :=
begin
  rw eq_iff_split,
  simp,
  split; ac_refl,
end

theorem add_assoc: n + m + k = n + (m + k) :=
begin
  rw eq_iff_split,
  simp,
  split; ac_refl,
end

@[simp]
theorem neg_neg: - -n = n :=
begin
  rw eq_iff_split,
  simp,
end

end int_pair
end hidden


/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Sébastien Gouëzel
-/
import measure_theory.measure.lebesgue
import measure_theory.measure.haar
import linear_algebra.finite_dimensional
import analysis.normed_space.pointwise
import measure_theory.group.pointwise

/-!
# Relationship between the Haar and Lebesgue measures

We prove that the Haar measure and Lebesgue measure are equal on `ℝ` and on `ℝ^ι`, in
`measure_theory.add_haar_measure_eq_volume` and `measure_theory.add_haar_measure_eq_volume_pi`.

We deduce basic properties of any Haar measure on a finite dimensional real vector space:
* `map_linear_map_add_haar_eq_smul_add_haar`: a linear map rescales the Haar measure by the
  absolute value of its determinant.
* `add_haar_preimage_linear_map` : when `f` is a linear map with nonzero determinant, the measure
  of `f ⁻¹' s` is the measure of `s` multiplied by the absolute value of the inverse of the
  determinant of `f`.
* `add_haar_image_linear_map` :  when `f` is a linear map, the measure of `f '' s` is the
  measure of `s` multiplied by the absolute value of the determinant of `f`.
* `add_haar_submodule` : a strict submodule has measure `0`.
* `add_haar_smul` : the measure of `r • s` is `|r| ^ dim * μ s`.
* `add_haar_ball`: the measure of `ball x r` is `r ^ dim * μ (ball 0 1)`.
* `add_haar_closed_ball`: the measure of `closed_ball x r` is `r ^ dim * μ (ball 0 1)`.
* `add_haar_sphere`: spheres have zero measure.

We also show that a Lebesgue density point `x` of a set `s` (with respect to closed balls) has
density one for the rescaled copies `{x} + r • t` of a given set `t` with positive measure, in
`tendsto_add_haar_inter_smul_one_of_density_one`. In particular, `s` intersects `{x} + r • t` for
small `r`, see `eventually_nonempty_inter_smul_of_density_one`.
-/

open topological_space set filter metric
open_locale ennreal pointwise topological_space

/-- The interval `[0,1]` as a compact set with non-empty interior. -/
def topological_space.positive_compacts.Icc01 : positive_compacts ℝ :=
⟨Icc 0 1, is_compact_Icc, by simp_rw [interior_Icc, nonempty_Ioo, zero_lt_one]⟩

universe u

/-- The set `[0,1]^ι` as a compact set with non-empty interior. -/
def topological_space.positive_compacts.pi_Icc01 (ι : Type*) [fintype ι] :
  positive_compacts (ι → ℝ) :=
⟨set.pi set.univ (λ i, Icc 0 1), is_compact_univ_pi (λ i, is_compact_Icc),
by simp only [interior_pi_set, finite.of_fintype, interior_Icc, univ_pi_nonempty_iff, nonempty_Ioo,
  implies_true_iff, zero_lt_one]⟩

namespace measure_theory

open measure topological_space.positive_compacts finite_dimensional

/-!
### The Lebesgue measure is a Haar measure on `ℝ` and on `ℝ^ι`.
-/

instance is_add_left_invariant_real_volume :
  is_add_left_invariant (volume : measure ℝ) :=
⟨by simp [real.map_volume_add_left]⟩

/-- The Haar measure equals the Lebesgue measure on `ℝ`. -/
lemma add_haar_measure_eq_volume : add_haar_measure Icc01 = volume :=
by { convert (add_haar_measure_unique volume Icc01).symm, simp [Icc01] }

instance : is_add_haar_measure (volume : measure ℝ) :=
by { rw ← add_haar_measure_eq_volume, apply_instance }

instance is_add_left_invariant_real_volume_pi (ι : Type*) [fintype ι] :
  is_add_left_invariant (volume : measure (ι → ℝ)) :=
⟨by simp [real.map_volume_pi_add_left]⟩

/-- The Haar measure equals the Lebesgue measure on `ℝ^ι`. -/
lemma add_haar_measure_eq_volume_pi (ι : Type*) [fintype ι] :
  add_haar_measure (pi_Icc01 ι) = volume :=
begin
  convert (add_haar_measure_unique volume (pi_Icc01 ι)).symm,
  simp only [pi_Icc01, volume_pi_pi (λ i, Icc (0 : ℝ) 1),
    finset.prod_const_one, ennreal.of_real_one, real.volume_Icc, one_smul, sub_zero]
end

instance is_add_haar_measure_volume_pi (ι : Type*) [fintype ι] :
  is_add_haar_measure (volume : measure (ι → ℝ)) :=
by { rw ← add_haar_measure_eq_volume_pi, apply_instance }

namespace measure

/-!
### Strict subspaces have zero measure
-/

/-- If a set is disjoint of its translates by infinitely many bounded vectors, then it has measure
zero. This auxiliary lemma proves this assuming additionally that the set is bounded. -/
lemma add_haar_eq_zero_of_disjoint_translates_aux
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  {s : set E} (u : ℕ → E) (sb : bounded s) (hu : bounded (range u))
  (hs : pairwise (disjoint on (λ n, {u n} + s))) (h's : measurable_set s) :
  μ s = 0 :=
begin
  by_contra h,
  apply lt_irrefl ∞,
  calc
  ∞ = ∑' (n : ℕ), μ s : (ennreal.tsum_const_eq_top_of_ne_zero h).symm
  ... = ∑' (n : ℕ), μ ({u n} + s) :
    by { congr' 1, ext1 n, simp only [image_add_left, measure_preimage_add, singleton_add] }
  ... = μ (⋃ n, {u n} + s) :
    by rw measure_Union hs
      (λ n, by simpa only [image_add_left, singleton_add] using measurable_id.const_add _ h's)
  ... = μ (range u + s) : by rw [← Union_add, Union_singleton_eq_range]
  ... < ∞ : bounded.measure_lt_top (hu.add sb)
end

/-- If a set is disjoint of its translates by infinitely many bounded vectors, then it has measure
zero. -/
lemma add_haar_eq_zero_of_disjoint_translates
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  {s : set E} (u : ℕ → E) (hu : bounded (range u))
  (hs : pairwise (disjoint on (λ n, {u n} + s))) (h's : measurable_set s) :
  μ s = 0 :=
begin
  suffices H : ∀ R, μ (s ∩ closed_ball 0 R) = 0,
  { apply le_antisymm _ (zero_le _),
    calc μ s ≤ ∑' (n : ℕ), μ (s ∩ closed_ball 0 n) :
      by { conv_lhs { rw ← Union_inter_closed_ball_nat s 0 }, exact measure_Union_le _ }
    ... = 0 : by simp only [H, tsum_zero] },
  assume R,
  apply add_haar_eq_zero_of_disjoint_translates_aux μ u
    (bounded.mono (inter_subset_right _ _) bounded_closed_ball) hu _
    (h's.inter (measurable_set_closed_ball)),
  apply pairwise_disjoint.mono hs (λ n, _),
  exact add_subset_add (subset.refl _) (inter_subset_left _ _)
end

/-- A strict vector subspace has measure zero. -/
lemma add_haar_submodule
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (s : submodule ℝ E) (hs : s ≠ ⊤) : μ s = 0 :=
begin
  obtain ⟨x, hx⟩ : ∃ x, x ∉ s,
    by simpa only [submodule.eq_top_iff', not_exists, ne.def, not_forall] using hs,
  obtain ⟨c, cpos, cone⟩ : ∃ (c : ℝ), 0 < c ∧ c < 1 := ⟨1/2, by norm_num, by norm_num⟩,
  have A : bounded (range (λ (n : ℕ), (c ^ n) • x)),
  { have : tendsto (λ (n : ℕ), (c ^ n) • x) at_top (𝓝 ((0 : ℝ) • x)) :=
      (tendsto_pow_at_top_nhds_0_of_lt_1 cpos.le cone).smul_const x,
    exact bounded_range_of_tendsto _ this },
  apply add_haar_eq_zero_of_disjoint_translates μ _ A _
    (submodule.closed_of_finite_dimensional s).measurable_set,
  assume m n hmn,
  simp only [function.on_fun, image_add_left, singleton_add, disjoint_left, mem_preimage,
             set_like.mem_coe],
  assume y hym hyn,
  have A : (c ^ n - c ^ m) • x ∈ s,
  { convert s.sub_mem hym hyn,
    simp only [sub_smul, neg_sub_neg, add_sub_add_right_eq_sub] },
  have H : c ^ n - c ^ m ≠ 0,
    by simpa only [sub_eq_zero, ne.def] using (strict_anti_pow cpos cone).injective.ne hmn.symm,
  have : x ∈ s,
  { convert s.smul_mem (c ^ n - c ^ m)⁻¹ A,
    rw [smul_smul, inv_mul_cancel H, one_smul] },
  exact hx this
end

/-!
### Applying a linear map rescales Haar measure by the determinant

We first prove this on `ι → ℝ`, using that this is already known for the product Lebesgue
measure (thanks to matrices computations). Then, we extend this to any finite-dimensional real
vector space by using a linear equiv with a space of the form `ι → ℝ`, and arguing that such a
linear equiv maps Haar measure to Haar measure.
-/

lemma map_linear_map_add_haar_pi_eq_smul_add_haar
  {ι : Type*} [fintype ι] {f : (ι → ℝ) →ₗ[ℝ] (ι → ℝ)} (hf : f.det ≠ 0)
  (μ : measure (ι → ℝ)) [is_add_haar_measure μ] :
  measure.map f μ = ennreal.of_real (abs (f.det)⁻¹) • μ :=
begin
  /- We have already proved the result for the Lebesgue product measure, using matrices.
  We deduce it for any Haar measure by uniqueness (up to scalar multiplication). -/
  have := add_haar_measure_unique μ (pi_Icc01 ι),
  rw this,
  simp [add_haar_measure_eq_volume_pi, real.map_linear_map_volume_pi_eq_smul_volume_pi hf,
    smul_smul, mul_comm],
end

lemma map_linear_map_add_haar_eq_smul_add_haar
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  {f : E →ₗ[ℝ] E} (hf : f.det ≠ 0) :
  measure.map f μ = ennreal.of_real (abs (f.det)⁻¹) • μ :=
begin
  -- we reduce to the case of `E = ι → ℝ`, for which we have already proved the result using
  -- matrices in `map_linear_map_add_haar_pi_eq_smul_add_haar`.
  let ι := fin (finrank ℝ E),
  haveI : finite_dimensional ℝ (ι → ℝ) := by apply_instance,
  have : finrank ℝ E = finrank ℝ (ι → ℝ), by simp,
  have e : E ≃ₗ[ℝ] ι → ℝ := linear_equiv.of_finrank_eq E (ι → ℝ) this,
  -- next line is to avoid `g` getting reduced by `simp`.
  obtain ⟨g, hg⟩ : ∃ g, g = (e : E →ₗ[ℝ] (ι → ℝ)).comp (f.comp (e.symm : (ι → ℝ) →ₗ[ℝ] E)) :=
    ⟨_, rfl⟩,
  have gdet : g.det = f.det, by { rw [hg], exact linear_map.det_conj f e },
  rw ← gdet at hf ⊢,
  have fg : f = (e.symm : (ι → ℝ) →ₗ[ℝ] E).comp (g.comp (e : E →ₗ[ℝ] (ι → ℝ))),
  { ext x,
    simp only [linear_equiv.coe_coe, function.comp_app, linear_map.coe_comp,
      linear_equiv.symm_apply_apply, hg] },
  simp only [fg, linear_equiv.coe_coe, linear_map.coe_comp],
  have Ce : continuous e := (e : E →ₗ[ℝ] (ι → ℝ)).continuous_of_finite_dimensional,
  have Cg : continuous g := linear_map.continuous_of_finite_dimensional g,
  have Cesymm : continuous e.symm := (e.symm : (ι → ℝ) →ₗ[ℝ] E).continuous_of_finite_dimensional,
  rw [← map_map Cesymm.measurable (Cg.comp Ce).measurable, ← map_map Cg.measurable Ce.measurable],
  haveI : is_add_haar_measure (map e μ) := is_add_haar_measure_map μ e.to_add_equiv Ce Cesymm,
  have ecomp : (e.symm) ∘ e = id,
    by { ext x, simp only [id.def, function.comp_app, linear_equiv.symm_apply_apply] },
  rw [map_linear_map_add_haar_pi_eq_smul_add_haar hf (map e μ), linear_map.map_smul,
    map_map Cesymm.measurable Ce.measurable, ecomp, measure.map_id]
end

/-- The preimage of a set `s` under a linear map `f` with nonzero determinant has measure
equal to `μ s` times the absolute value of the inverse of the determinant of `f`. -/
@[simp] lemma add_haar_preimage_linear_map
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  {f : E →ₗ[ℝ] E} (hf : f.det ≠ 0) (s : set E) :
  μ (f ⁻¹' s) = ennreal.of_real (abs (f.det)⁻¹) * μ s :=
calc μ (f ⁻¹' s) = measure.map f μ s :
  ((f.equiv_of_det_ne_zero hf).to_continuous_linear_equiv.to_homeomorph
    .to_measurable_equiv.map_apply s).symm
... = ennreal.of_real (abs (f.det)⁻¹) * μ s :
  by { rw map_linear_map_add_haar_eq_smul_add_haar μ hf, refl }

/-- The preimage of a set `s` under a continuous linear map `f` with nonzero determinant has measure
equal to `μ s` times the absolute value of the inverse of the determinant of `f`. -/
@[simp] lemma add_haar_preimage_continuous_linear_map
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  {f : E →L[ℝ] E} (hf : linear_map.det (f : E →ₗ[ℝ] E) ≠ 0) (s : set E) :
  μ (f ⁻¹' s) = ennreal.of_real (abs (linear_map.det (f : E →ₗ[ℝ] E))⁻¹) * μ s :=
add_haar_preimage_linear_map μ hf s

/-- The preimage of a set `s` under a linear equiv `f` has measure
equal to `μ s` times the absolute value of the inverse of the determinant of `f`. -/
@[simp] lemma add_haar_preimage_linear_equiv
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (f : E ≃ₗ[ℝ] E) (s : set E) :
  μ (f ⁻¹' s) = ennreal.of_real (abs (f.symm : E →ₗ[ℝ] E).det) * μ s :=
begin
  have A : (f : E →ₗ[ℝ] E).det ≠ 0 := (linear_equiv.is_unit_det' f).ne_zero,
  convert add_haar_preimage_linear_map μ A s,
  simp only [linear_equiv.det_coe_symm]
end

/-- The preimage of a set `s` under a continuous linear equiv `f` has measure
equal to `μ s` times the absolute value of the inverse of the determinant of `f`. -/
@[simp] lemma add_haar_preimage_continuous_linear_equiv
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (f : E ≃L[ℝ] E) (s : set E) :
  μ (f ⁻¹' s) = ennreal.of_real (abs (f.symm : E →ₗ[ℝ] E).det) * μ s :=
add_haar_preimage_linear_equiv μ _ s

/-- The image of a set `s` under a linear map `f` has measure
equal to `μ s` times the absolute value of the determinant of `f`. -/
@[simp] lemma add_haar_image_linear_map
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (f : E →ₗ[ℝ] E) (s : set E) :
  μ (f '' s) = ennreal.of_real (abs f.det) * μ s :=
begin
  rcases ne_or_eq f.det 0 with hf|hf,
  { let g := (f.equiv_of_det_ne_zero hf).to_continuous_linear_equiv,
    change μ (g '' s) = _,
    rw [continuous_linear_equiv.image_eq_preimage g s, add_haar_preimage_continuous_linear_equiv],
    congr,
    ext x,
    simp only [linear_equiv.coe_to_continuous_linear_equiv, linear_equiv.of_is_unit_det_apply,
               linear_equiv.coe_coe, continuous_linear_equiv.symm_symm], },
  { simp only [hf, zero_mul, ennreal.of_real_zero, abs_zero],
    have : μ f.range = 0 :=
      add_haar_submodule μ _ (linear_map.range_lt_top_of_det_eq_zero hf).ne,
    exact le_antisymm (le_trans (measure_mono (image_subset_range _ _)) this.le) (zero_le _) }
end

/-- The image of a set `s` under a continuous linear map `f` has measure
equal to `μ s` times the absolute value of the determinant of `f`. -/
@[simp] lemma add_haar_image_continuous_linear_map
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (f : E →L[ℝ] E) (s : set E) :
  μ (f '' s) = ennreal.of_real (abs (f : E →ₗ[ℝ] E).det) * μ s :=
add_haar_image_linear_map μ _ s

/-- The image of a set `s` under a continuous linear equiv `f` has measure
equal to `μ s` times the absolute value of the determinant of `f`. -/
@[simp] lemma add_haar_image_continuous_linear_equiv
  {E : Type*} [normed_group E] [normed_space ℝ E] [measurable_space E] [borel_space E]
  [finite_dimensional ℝ E] (μ : measure E) [is_add_haar_measure μ]
  (f : E ≃L[ℝ] E) (s : set E) :
  μ (f '' s) = ennreal.of_real (abs (f : E →ₗ[ℝ] E).det) * μ s :=
add_haar_image_linear_map μ _ s

/-!
### Basic properties of Haar measures on real vector spaces
-/

variables {E : Type*} [normed_group E] [measurable_space E] [normed_space ℝ E]
  [finite_dimensional ℝ E] [borel_space E] (μ : measure E) [is_add_haar_measure μ]

lemma map_add_haar_smul {r : ℝ} (hr : r ≠ 0) :
  measure.map ((•) r) μ = ennreal.of_real (abs (r ^ (finrank ℝ E))⁻¹) • μ :=
begin
  let f : E →ₗ[ℝ] E := r • 1,
  change measure.map f μ = _,
  have hf : f.det ≠ 0,
  { simp only [mul_one, linear_map.det_smul, ne.def, monoid_hom.map_one],
    assume h,
    exact hr (pow_eq_zero h) },
  simp only [map_linear_map_add_haar_eq_smul_add_haar μ hf, mul_one, linear_map.det_smul,
    monoid_hom.map_one],
end

@[simp] lemma add_haar_preimage_smul {r : ℝ} (hr : r ≠ 0) (s : set E) :
  μ (((•) r) ⁻¹' s) = ennreal.of_real (abs (r ^ (finrank ℝ E))⁻¹) * μ s :=
calc μ (((•) r) ⁻¹' s) = measure.map ((•) r) μ s :
  ((homeomorph.smul (is_unit_iff_ne_zero.2 hr).unit).to_measurable_equiv.map_apply s).symm
... = ennreal.of_real (abs (r^(finrank ℝ E))⁻¹) * μ s : by { rw map_add_haar_smul μ hr, refl }

/-- Rescaling a set by a factor `r` multiplies its measure by `abs (r ^ dim)`. -/
@[simp] lemma add_haar_smul (r : ℝ) (s : set E) :
  μ (r • s) = ennreal.of_real (abs (r ^ (finrank ℝ E))) * μ s :=
begin
  rcases ne_or_eq r 0 with h|rfl,
  { rw [← preimage_smul_inv₀ h, add_haar_preimage_smul μ (inv_ne_zero h), inv_pow₀, inv_inv₀] },
  rcases eq_empty_or_nonempty s with rfl|hs,
  { simp only [measure_empty, mul_zero, smul_set_empty] },
  rw [zero_smul_set hs, ← singleton_zero],
  by_cases h : finrank ℝ E = 0,
  { haveI : subsingleton E := finrank_zero_iff.1 h,
    simp only [h, one_mul, ennreal.of_real_one, abs_one, subsingleton.eq_univ_of_nonempty hs,
      pow_zero, subsingleton.eq_univ_of_nonempty (singleton_nonempty (0 : E))] },
  { haveI : nontrivial E := nontrivial_of_finrank_pos (bot_lt_iff_ne_bot.2 h),
    simp only [h, zero_mul, ennreal.of_real_zero, abs_zero, ne.def, not_false_iff, zero_pow',
      measure_singleton] }
end

/-! We don't need to state `map_add_haar_neg` here, because it has already been proved for
general Haar measures on general commutative groups. -/

/-! ### Measure of balls -/

lemma add_haar_ball_center
  {E : Type*} [normed_group E] [measurable_space E]
  [borel_space E] (μ : measure E) [is_add_haar_measure μ] (x : E) (r : ℝ) :
  μ (ball x r) = μ (ball (0 : E) r) :=
begin
  have : ball (0 : E) r = ((+) x) ⁻¹' (ball x r), by simp [preimage_add_ball],
  rw [this, measure_preimage_add]
end

lemma add_haar_closed_ball_center
  {E : Type*} [normed_group E] [measurable_space E]
  [borel_space E] (μ : measure E) [is_add_haar_measure μ] (x : E) (r : ℝ) :
  μ (closed_ball x r) = μ (closed_ball (0 : E) r) :=
begin
  have : closed_ball (0 : E) r = ((+) x) ⁻¹' (closed_ball x r), by simp [preimage_add_closed_ball],
  rw [this, measure_preimage_add]
end

lemma add_haar_ball_mul_of_pos (x : E) {r : ℝ} (hr : 0 < r) (s : ℝ) :
  μ (ball x (r * s)) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (ball 0 s) :=
begin
  have : ball (0 : E) (r * s) = r • ball 0 s,
    by simp only [smul_ball hr.ne' (0 : E) s, real.norm_eq_abs, abs_of_nonneg hr.le, smul_zero],
  simp only [this, add_haar_smul, abs_of_nonneg hr.le, add_haar_ball_center, abs_pow],
end

lemma add_haar_ball_of_pos (x : E) {r : ℝ} (hr : 0 < r) :
  μ (ball x r) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (ball 0 1) :=
by rw [← add_haar_ball_mul_of_pos μ x hr, mul_one]

lemma add_haar_ball_mul [nontrivial E] (x : E) {r : ℝ} (hr : 0 ≤ r) (s : ℝ) :
  μ (ball x (r * s)) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (ball 0 s) :=
begin
  rcases has_le.le.eq_or_lt hr with h|h,
  { simp only [← h, zero_pow finrank_pos, measure_empty, zero_mul, ennreal.of_real_zero,
               ball_zero] },
  { exact add_haar_ball_mul_of_pos μ x h s }
end

lemma add_haar_ball [nontrivial E] (x : E) {r : ℝ} (hr : 0 ≤ r) :
  μ (ball x r) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (ball 0 1) :=
by rw [← add_haar_ball_mul μ x hr, mul_one]

lemma add_haar_closed_ball_mul_of_pos (x : E) {r : ℝ} (hr : 0 < r) (s : ℝ) :
  μ (closed_ball x (r * s)) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (closed_ball 0 s) :=
begin
  have : closed_ball (0 : E) (r * s) = r • closed_ball 0 s,
    by simp [smul_closed_ball' hr.ne' (0 : E), real.norm_eq_abs, abs_of_nonneg hr.le],
  simp only [this, add_haar_smul, abs_of_nonneg hr.le, add_haar_closed_ball_center, abs_pow],
end

lemma add_haar_closed_ball_mul (x : E) {r : ℝ} (hr : 0 ≤ r) {s : ℝ} (hs : 0 ≤ s) :
  μ (closed_ball x (r * s)) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (closed_ball 0 s) :=
begin
  have : closed_ball (0 : E) (r * s) = r • closed_ball 0 s,
    by simp [smul_closed_ball r (0 : E) hs, real.norm_eq_abs, abs_of_nonneg hr],
  simp only [this, add_haar_smul, abs_of_nonneg hr, add_haar_closed_ball_center, abs_pow],
end

/-- The measure of a closed ball can be expressed in terms of the measure of the closed unit ball.
Use instead `add_haar_closed_ball`, which uses the measure of the open unit ball as a standard
form. -/

lemma add_haar_closed_unit_ball_eq_add_haar_unit_ball :
  μ (closed_ball (0 : E) 1) = μ (ball 0 1) :=
begin
  apply le_antisymm _ (measure_mono ball_subset_closed_ball),
  have A : tendsto (λ (r : ℝ), ennreal.of_real (r ^ (finrank ℝ E)) * μ (closed_ball (0 : E) 1))
    (𝓝[<] 1) (𝓝 (ennreal.of_real (1 ^ (finrank ℝ E)) * μ (closed_ball (0 : E) 1))),
  { refine ennreal.tendsto.mul _ (by simp) tendsto_const_nhds (by simp),
    exact ennreal.tendsto_of_real ((tendsto_id' nhds_within_le_nhds).pow _) },
  simp only [one_pow, one_mul, ennreal.of_real_one] at A,
  refine le_of_tendsto A _,
  refine mem_nhds_within_Iio_iff_exists_Ioo_subset.2 ⟨(0 : ℝ), by simp, λ r hr, _⟩,
  dsimp,
  rw ← add_haar_closed_ball' μ (0 : E) hr.1.le,
  exact measure_mono (closed_ball_subset_ball hr.2)
end

lemma add_haar_closed_ball (x : E) {r : ℝ} (hr : 0 ≤ r) :
  μ (closed_ball x r) = ennreal.of_real (r ^ (finrank ℝ E)) * μ (ball 0 1) :=
by rw [add_haar_closed_ball' μ x hr, add_haar_closed_unit_ball_eq_add_haar_unit_ball]

lemma add_haar_sphere_of_ne_zero (x : E) {r : ℝ} (hr : r ≠ 0) :
  μ (sphere x r) = 0 :=
begin
  rcases hr.lt_or_lt with h|h,
  { simp only [empty_diff, measure_empty, ← closed_ball_diff_ball, closed_ball_eq_empty.2 h] },
  { rw [← closed_ball_diff_ball,
        measure_diff ball_subset_closed_ball measurable_set_ball measure_ball_lt_top.ne,
        add_haar_ball_of_pos μ _ h, add_haar_closed_ball μ _ h.le, tsub_self];
    apply_instance }
end

lemma add_haar_sphere [nontrivial E] (x : E) (r : ℝ) :
  μ (sphere x r) = 0 :=
begin
  rcases eq_or_ne r 0 with rfl|h,
  { rw [sphere_zero, measure_singleton] },
  { exact add_haar_sphere_of_ne_zero μ x h }
end

lemma add_haar_singleton_add_smul_div_singleton_add_smul
  {r : ℝ} (hr : r ≠ 0) (x y : E) (s t : set E) :
  μ ({x} + r • s) / μ ({y} + r • t) = μ s / μ t :=
calc
μ ({x} + r • s) / μ ({y} + r • t)
    = ennreal.of_real (|r| ^ finrank ℝ E) * μ s * (ennreal.of_real (|r| ^ finrank ℝ E) * μ t)⁻¹ :
  by simp only [div_eq_mul_inv, add_haar_smul, image_add_left, measure_preimage_add, abs_pow,
    singleton_add]
... = ennreal.of_real (|r| ^ finrank ℝ E) * (ennreal.of_real (|r| ^ finrank ℝ E))⁻¹ *
        (μ s * (μ t)⁻¹) :
  begin
    rw ennreal.mul_inv,
    { ring },
    { simp only [pow_pos (abs_pos.mpr hr), ennreal.of_real_eq_zero, not_le, ne.def, true_or] },
    { simp only [ennreal.of_real_ne_top, true_or, ne.def, not_false_iff] },
  end
... = μ s / μ t :
  begin
    rw [ennreal.mul_inv_cancel, one_mul, div_eq_mul_inv],
    { simp only [pow_pos (abs_pos.mpr hr), ennreal.of_real_eq_zero, not_le, ne.def], },
    { simp only [ennreal.of_real_ne_top, ne.def, not_false_iff] }
  end

/-!
### Density points

Besicovitch covering theorem ensures that, for any locally finite measure on a finite-dimensional
real vector space, almost every point of a set `s` is a density point, i.e.,
`μ (s ∩ closed_ball x r) / μ (closed_ball x r)` tends to `1` as `r` tends to `0`
(see `besicovitch.ae_tendsto_measure_inter_div`).
When `μ` is a Haar measure, one can deduce the same property for any rescaling sequence of sets,
of the form `{x} + r • t` where `t` is a set with positive finite measure, instead of the sequence
of closed balls.

We argue first for the dual property, i.e., if `s` has density `0` at `x`, then
`μ (s ∩ ({x} + r • t)) / μ ({x} + r • t)` tends to `0`. First when `t` is contained in the ball
of radius `1`, in `tendsto_add_haar_inter_smul_zero_of_density_zero_aux1`,
(by arguing by inclusion). Then when `t` is bounded, reducing to the previous one by rescaling, in
`tendsto_add_haar_inter_smul_zero_of_density_zero_aux2`.
Then for a general set `t`, by cutting it into a bounded part and a part with small measure, in
`tendsto_add_haar_inter_smul_zero_of_density_zero`.
Going to the complement, one obtains the desired property at points of density `1`, first when
`s` is measurable in `tendsto_add_haar_inter_smul_one_of_density_one_aux`, and then without this
assumption in `tendsto_add_haar_inter_smul_one_of_density_one` by applying the previous lemma to
the measurable hull `to_measurable μ s`
-/

lemma tendsto_add_haar_inter_smul_zero_of_density_zero_aux1
  (s : set E) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 0))
  (t : set E) (u : set E) (h'u : μ u ≠ 0) (t_bound : t ⊆ closed_ball 0 1) :
  tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ ({x} + r • u)) (𝓝[>] 0) (𝓝 0) :=
begin
  have A : tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 0),
  { apply tendsto_of_tendsto_of_tendsto_of_le_of_le' tendsto_const_nhds h
      (eventually_of_forall (λ b, zero_le _)),
    filter_upwards [self_mem_nhds_within],
    rintros r (rpos : 0 < r),
    apply ennreal.mul_le_mul (measure_mono (inter_subset_inter_right _ _)) le_rfl,
    assume y hy,
    have : y - x ∈ r • closed_ball (0 : E) 1,
    { apply smul_set_mono t_bound,
      simpa [neg_add_eq_sub] using hy },
    simpa only [smul_closed_ball _ _ zero_le_one, real.norm_of_nonneg rpos.le,
      mem_closed_ball_iff_norm, mul_one, sub_zero, smul_zero] },
  have B : tendsto (λ (r : ℝ), μ (closed_ball x r) / μ ({x} + r • u)) (𝓝[>] 0)
    (𝓝 (μ (closed_ball x 1) / μ ({x} + u))),
  { apply tendsto_const_nhds.congr' _,
    filter_upwards [self_mem_nhds_within],
    rintros r (rpos : 0 < r),
    have : closed_ball x r = {x} + r • closed_ball 0 1,
      by simp only [smul_closed_ball, real.norm_of_nonneg rpos.le, zero_le_one, add_zero, mul_one,
        singleton_add_closed_ball, smul_zero],
    simp only [this, add_haar_singleton_add_smul_div_singleton_add_smul μ rpos.ne'],
    simp only [add_haar_closed_ball_center, image_add_left, measure_preimage_add, singleton_add] },
  have C : tendsto (λ (r : ℝ),
    (μ (s ∩ ({x} + r • t)) / μ (closed_ball x r)) * (μ (closed_ball x r) / μ ({x} + r • u)))
    (𝓝[>] 0) (𝓝 (0 * (μ (closed_ball x 1) / μ ({x} + u)))),
  { apply ennreal.tendsto.mul A _ B (or.inr ennreal.zero_ne_top),
    simp only [ennreal.div_eq_top, h'u, measure_closed_ball_lt_top.ne, false_or, image_add_left,
      eq_self_iff_true, not_true, ne.def, not_false_iff, measure_preimage_add, singleton_add,
      and_false, false_and] },
  simp only [zero_mul] at C,
  apply C.congr' _,
  filter_upwards [self_mem_nhds_within],
  rintros r (rpos : 0 < r),
  calc μ (s ∩ ({x} + r • t)) / μ (closed_ball x r) * (μ (closed_ball x r) / μ ({x} + r • u))
    = (μ (closed_ball x r) * (μ (closed_ball x r))⁻¹) * (μ (s ∩ ({x} + r • t)) / μ ({x} + r • u)) :
      by { simp only [div_eq_mul_inv], ring }
    ... = μ (s ∩ ({x} + r • t)) / μ ({x} + r • u) :
      by rw [ennreal.mul_inv_cancel (measure_closed_ball_pos μ x rpos).ne'
          measure_closed_ball_lt_top.ne, one_mul],
end

lemma tendsto_add_haar_inter_smul_zero_of_density_zero_aux2
  (s : set E) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 0))
  (t : set E) (u : set E) (h'u : μ u ≠ 0)
  (R : ℝ) (Rpos : 0 < R) (t_bound : t ⊆ closed_ball 0 R) :
  tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ ({x} + r • u)) (𝓝[>] 0) (𝓝 0) :=
begin
  set t' := R⁻¹ • t with ht',
  set u' := R⁻¹ • u with hu',
  have A : tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t')) / μ ({x} + r • u')) (𝓝[>] 0) (𝓝 0),
  { apply tendsto_add_haar_inter_smul_zero_of_density_zero_aux1 μ s x h
      t' u',
    { simp only [h'u, (pow_pos Rpos _).ne', abs_nonpos_iff, add_haar_smul, not_false_iff,
        ennreal.of_real_eq_zero, inv_eq_zero, inv_pow₀, ne.def, or_self, mul_eq_zero] },
    { convert smul_set_mono t_bound,
      rw [smul_closed_ball _ _ Rpos.le, smul_zero, real.norm_of_nonneg (inv_nonneg.2 Rpos.le),
        inv_mul_cancel Rpos.ne'] } },
  have B : tendsto (λ (r : ℝ), R * r) (𝓝[>] 0) (𝓝[>] (R * 0)),
  { apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within,
    { exact (tendsto_const_nhds.mul tendsto_id).mono_left nhds_within_le_nhds },
    { filter_upwards [self_mem_nhds_within],
      assume r rpos,
      rw mul_zero,
      exact mul_pos Rpos rpos } },
  rw mul_zero at B,
  apply (A.comp B).congr' _,
  filter_upwards [self_mem_nhds_within],
  rintros r (rpos : 0 < r),
  have T : (R * r) • t' = r • t,
    by rw [mul_comm, ht', smul_smul, mul_assoc, mul_inv_cancel Rpos.ne', mul_one],
  have U : (R * r) • u' = r • u,
    by rw [mul_comm, hu', smul_smul, mul_assoc, mul_inv_cancel Rpos.ne', mul_one],
  dsimp,
  rw [T, U],
end

/-- Consider a point `x` at which a set `s` has density zero, with respect to closed balls. Then it
also has density zero with respect to any measurable set `t`: the proportion of points in `s`
belonging to a rescaled copy `{x} + r • t` of `t` tends to zero as `r` tends to zero. -/
lemma tendsto_add_haar_inter_smul_zero_of_density_zero
  (s : set E) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 0))
  (t : set E) (ht : measurable_set t) (h''t : μ t ≠ ∞) :
  tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ ({x} + r • t)) (𝓝[>] 0) (𝓝 0) :=
begin
  refine tendsto_order.2 ⟨λ a' ha', (ennreal.not_lt_zero ha').elim, λ ε (εpos : 0 < ε), _⟩,
  rcases eq_or_ne (μ t) 0 with h't|h't,
  { apply eventually_of_forall (λ r, _),
    suffices H : μ (s ∩ ({x} + r • t)) = 0,
      by { rw H, simpa only [ennreal.zero_div] using εpos },
    apply le_antisymm _ (zero_le _),
    calc μ (s ∩ ({x} + r • t)) ≤ μ ({x} + r • t) : measure_mono (inter_subset_right _ _)
    ... = 0 : by simp only [h't, add_haar_smul, image_add_left, measure_preimage_add,
      singleton_add, mul_zero] },
  obtain ⟨n, npos, hn⟩ : ∃ (n : ℕ), 0 < n ∧ μ (t \ closed_ball 0 n) < (ε / 2) * μ t,
  { have A : tendsto (λ (n : ℕ), μ (t \ closed_ball 0 n)) at_top
      (𝓝 (μ (⋂ (n : ℕ), t \ closed_ball 0 n))),
    { have N : ∃ (n : ℕ), μ (t \ closed_ball 0 n) ≠ ∞ :=
        ⟨0, ((measure_mono (diff_subset t _)).trans_lt h''t.lt_top).ne⟩,
      refine tendsto_measure_Inter (λ n, ht.diff measurable_set_closed_ball) (λ m n hmn, _) N,
      exact diff_subset_diff subset.rfl (closed_ball_subset_closed_ball (nat.cast_le.2 hmn)) },
    have : (⋂ (n : ℕ), t \ closed_ball 0 n) = ∅,
      by simp_rw [diff_eq, ← inter_Inter, Inter_eq_compl_Union_compl, compl_compl,
          Union_closed_ball_nat, compl_univ, inter_empty],
    simp only [this, measure_empty] at A,
    have I : 0 < (ε / 2) * μ t := ennreal.mul_pos (ennreal.half_pos εpos.ne').ne' h't,
    exact (eventually.and (Ioi_mem_at_top 0) ((tendsto_order.1 A).2 _ I)).exists },
  have L : tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • (t ∩ closed_ball 0 n))) / μ ({x} + r • t))
    (𝓝[>] 0) (𝓝 0) :=
      tendsto_add_haar_inter_smul_zero_of_density_zero_aux2 μ s x h
        _ t h't n (nat.cast_pos.2 npos) (inter_subset_right _ _),
  filter_upwards [(tendsto_order.1 L).2 _ (ennreal.half_pos εpos.ne'), self_mem_nhds_within],
  rintros r hr (rpos : 0 < r),
  have I : μ (s ∩ ({x} + r • t)) ≤
    μ (s ∩ ({x} + r • (t ∩ closed_ball 0 n))) + μ ({x} + r • (t \ closed_ball 0 n)) := calc
  μ (s ∩ ({x} + r • t))
      = μ ((s ∩ ({x} + r • (t ∩ closed_ball 0 n))) ∪ (s ∩ ({x} + r • (t \ closed_ball 0 n)))) :
    by rw [← inter_union_distrib_left, ← add_union, ← smul_set_union, inter_union_diff]
  ... ≤ μ (s ∩ ({x} + r • (t ∩ closed_ball 0 n))) + μ (s ∩ ({x} + r • (t \ closed_ball 0 n))) :
    measure_union_le _ _
  ... ≤ μ (s ∩ ({x} + r • (t ∩ closed_ball 0 n))) + μ ({x} + r • (t \ closed_ball 0 n)) :
    add_le_add le_rfl (measure_mono (inter_subset_right _ _)),
  calc μ (s ∩ ({x} + r • t)) / μ ({x} + r • t)
  ≤ (μ (s ∩ ({x} + r • (t ∩ closed_ball 0 n))) + μ ({x} + r • (t \ closed_ball 0 n))) /
      μ ({x} + r • t) : ennreal.mul_le_mul I le_rfl
  ... < ε / 2 + ε / 2 :
    begin
      rw ennreal.add_div,
      apply ennreal.add_lt_add hr _,
      rwa [add_haar_singleton_add_smul_div_singleton_add_smul μ rpos.ne',
           ennreal.div_lt_iff (or.inl h't) (or.inl h''t)],
    end
  ... = ε : ennreal.add_halves _
end

lemma tendsto_add_haar_inter_smul_one_of_density_one_aux
  (s : set E) (hs : measurable_set s) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 1))
  (t : set E) (ht : measurable_set t) (h't : μ t ≠ 0) (h''t : μ t ≠ ∞) :
  tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ ({x} + r • t)) (𝓝[>] 0) (𝓝 1) :=
begin
  have I : ∀ u v, μ u ≠ 0 → μ u ≠ ∞ → measurable_set v →
    μ u / μ u - μ (vᶜ ∩ u) / μ u = μ (v ∩ u) / μ u,
  { assume u v uzero utop vmeas,
    simp_rw [div_eq_mul_inv],
    rw ← ennreal.sub_mul, swap,
    { simp only [uzero, ennreal.inv_eq_top, implies_true_iff, ne.def, not_false_iff] },
    congr' 1,
    apply ennreal.sub_eq_of_add_eq
      (ne_top_of_le_ne_top utop (measure_mono (inter_subset_right _ _))),
    rw [inter_comm _ u, inter_comm _ u],
    exact measure_inter_add_diff u vmeas },
  have L : tendsto (λ r, μ (sᶜ ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 0),
  { have A : tendsto (λ r, μ (closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 1),
    { apply tendsto_const_nhds.congr' _,
      filter_upwards [self_mem_nhds_within],
      assume r hr,
      rw [div_eq_mul_inv, ennreal.mul_inv_cancel],
      { exact (measure_closed_ball_pos μ _ hr).ne' },
      { exact measure_closed_ball_lt_top.ne } },
    have B := ennreal.tendsto.sub A h (or.inl ennreal.one_ne_top),
    simp only [tsub_self] at B,
    apply B.congr' _,
    filter_upwards [self_mem_nhds_within],
    rintros r (rpos : 0 < r),
    convert I (closed_ball x r) sᶜ (measure_closed_ball_pos μ _ rpos).ne'
      (measure_closed_ball_lt_top).ne hs.compl,
    rw compl_compl },
  have L' : tendsto (λ (r : ℝ), μ (sᶜ ∩ ({x} + r • t)) / μ ({x} + r • t)) (𝓝[>] 0) (𝓝 0) :=
    tendsto_add_haar_inter_smul_zero_of_density_zero μ sᶜ x L t ht h''t,
  have L'' : tendsto (λ (r : ℝ), μ ({x} + r • t) / μ ({x} + r • t)) (𝓝[>] 0) (𝓝 1),
  { apply tendsto_const_nhds.congr' _,
    filter_upwards [self_mem_nhds_within],
    rintros r (rpos : 0 < r),
    rw [add_haar_singleton_add_smul_div_singleton_add_smul μ rpos.ne', ennreal.div_self h't h''t] },
  have := ennreal.tendsto.sub L'' L' (or.inl ennreal.one_ne_top),
  simp only [tsub_zero] at this,
  apply this.congr' _,
  filter_upwards [self_mem_nhds_within],
  rintros r (rpos : 0 < r),
  refine I ({x} + r • t) s _ _ hs,
  { simp only [h't, abs_of_nonneg rpos.le, pow_pos rpos, add_haar_smul, image_add_left,
      ennreal.of_real_eq_zero, not_le, or_false, ne.def, measure_preimage_add, abs_pow,
      singleton_add, mul_eq_zero] },
  { simp only [h''t, ennreal.of_real_ne_top, add_haar_smul, image_add_left, with_top.mul_eq_top_iff,
      ne.def, not_false_iff, measure_preimage_add, singleton_add, and_false, false_and, or_self] }
end

/-- Consider a point `x` at which a set `s` has density one, with respect to closed balls (i.e.,
a Lebesgue density point of `s`). Then `s` has also density one at `x` with respect to any
measurable set `t`: the proportion of points in `s` belonging to a rescaled copy `{x} + r • t`
of `t` tends to one as `r` tends to zero. -/
lemma tendsto_add_haar_inter_smul_one_of_density_one
  (s : set E) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 1))
  (t : set E) (ht : measurable_set t) (h't : μ t ≠ 0) (h''t : μ t ≠ ∞) :
  tendsto (λ (r : ℝ), μ (s ∩ ({x} + r • t)) / μ ({x} + r • t)) (𝓝[>] 0) (𝓝 1) :=
begin
  have : tendsto (λ (r : ℝ), μ (to_measurable μ s ∩ ({x} + r • t)) / μ ({x} + r • t))
    (𝓝[>] 0) (𝓝 1),
  { apply tendsto_add_haar_inter_smul_one_of_density_one_aux μ _
      (measurable_set_to_measurable _ _) _ _ t ht h't h''t,
    apply tendsto_of_tendsto_of_tendsto_of_le_of_le' h tendsto_const_nhds,
    { apply eventually_of_forall (λ r, _),
      apply ennreal.mul_le_mul _ le_rfl,
      exact measure_mono (inter_subset_inter_left _ (subset_to_measurable _ _)) },
    { filter_upwards [self_mem_nhds_within],
      rintros r (rpos : 0 < r),
      apply ennreal.div_le_of_le_mul,
      rw one_mul,
      exact measure_mono (inter_subset_right _ _) } },
  apply this.congr (λ r, _),
  congr' 1,
  apply measure_to_measurable_inter_of_sigma_finite,
  simp only [image_add_left, singleton_add],
  apply (continuous_add_left (-x)).measurable (ht.const_smul₀ r)
end

/-- Consider a point `x` at which a set `s` has density one, with respect to closed balls (i.e.,
a Lebesgue density point of `s`). Then `s` intersects the rescaled copies `{x} + r • t` of a given
set `t` with positive measure, for any small enough `r`. -/
lemma eventually_nonempty_inter_smul_of_density_one (s : set E) (x : E)
  (h : tendsto (λ r, μ (s ∩ closed_ball x r) / μ (closed_ball x r)) (𝓝[>] 0) (𝓝 1))
  (t : set E) (ht : measurable_set t) (h't : μ t ≠ 0) :
  ∀ᶠ r in 𝓝[>] (0 : ℝ), (s ∩ ({x} + r • t)).nonempty :=
begin
  obtain ⟨t', t'_meas, t't, t'pos, t'top⟩ :
    ∃ t', measurable_set t' ∧ t' ⊆ t ∧ 0 < μ t' ∧ μ t' < ⊤ :=
      exists_subset_measure_lt_top ht h't.bot_lt,
  filter_upwards [(tendsto_order.1
    (tendsto_add_haar_inter_smul_one_of_density_one μ s x h t'
      t'_meas t'pos.ne' t'top.ne)).1 0 ennreal.zero_lt_one],
  assume r hr,
  have : μ (s ∩ ({x} + r • t')) ≠ 0 :=
    λ h', by simpa only [ennreal.not_lt_zero, ennreal.zero_div, h'] using hr,
  have : (s ∩ ({x} + r • t')).nonempty := nonempty_of_measure_ne_zero this,
  apply this.mono (inter_subset_inter subset.rfl _),
  exact add_subset_add subset.rfl (smul_set_mono t't),
end

end measure

end measure_theory


/-
Copyright (c) 2020 Fox Thomson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Fox Thomson
-/
import algebra.hom.ring
import algebra.order.kleene
import data.list.join
import data.set.lattice

/-!
# Languages

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

This file contains the definition and operations on formal languages over an alphabet. Note strings
are implemented as lists over the alphabet.
The operations in this file define a [Kleene algebra](https://en.wikipedia.org/wiki/Kleene_algebra)
over the languages.
-/

open list set
open_locale computability

universes v

variables {α β γ : Type*}

/-- A language is a set of strings over an alphabet. -/
@[derive [has_mem (list α), has_singleton (list α), has_insert (list α), complete_boolean_algebra]]
def language (α) := set (list α)

namespace language
variables {l m : language α} {a b x : list α}

local attribute [reducible] language

/-- Zero language has no elements. -/
instance : has_zero (language α) := ⟨(∅ : set _)⟩
/-- `1 : language α` contains only one element `[]`. -/
instance : has_one (language α) := ⟨{[]}⟩

instance : inhabited (language α) := ⟨0⟩

/-- The sum of two languages is their union. -/
instance : has_add (language α) := ⟨(∪)⟩

/-- The product of two languages `l` and `m` is the language made of the strings `x ++ y` where
`x ∈ l` and `y ∈ m`. -/
instance : has_mul (language α) := ⟨image2 (++)⟩

lemma zero_def : (0 : language α) = (∅ : set _) := rfl
lemma one_def : (1 : language α) = {[]} := rfl

lemma add_def (l m : language α) : l + m = l ∪ m := rfl
lemma mul_def (l m : language α) : l * m = image2 (++) l m := rfl

/-- The Kleene star of a language `L` is the set of all strings which can be written by
concatenating strings from `L`. -/
instance : has_kstar (language α) := ⟨λ l, {x | ∃ L : list (list α), x = L.join ∧ ∀ y ∈ L, y ∈ l}⟩

lemma kstar_def (l : language α) : l∗ =  {x | ∃ L : list (list α), x = L.join ∧ ∀ y ∈ L, y ∈ l} :=
rfl

@[simp] lemma not_mem_zero (x : list α) : x ∉ (0 : language α) := id
@[simp] lemma mem_one (x : list α) : x ∈ (1 : language α) ↔ x = [] := by refl
lemma nil_mem_one : [] ∈ (1 : language α) := set.mem_singleton _
lemma mem_add (l m : language α) (x : list α) : x ∈ l + m ↔ x ∈ l ∨ x ∈ m := iff.rfl
lemma mem_mul : x ∈ l * m ↔ ∃ a b, a ∈ l ∧ b ∈ m ∧ a ++ b = x := mem_image2
lemma append_mem_mul : a ∈ l → b ∈ m → a ++ b ∈ l * m := mem_image2_of_mem
lemma mem_kstar : x ∈ l∗ ↔ ∃ L : list (list α), x = L.join ∧ ∀ y ∈ L, y ∈ l := iff.rfl
lemma join_mem_kstar {L : list (list α)} (h : ∀ y ∈ L, y ∈ l) : L.join ∈ l∗ := ⟨L, rfl, h⟩
lemma nil_mem_kstar (l : language α) : [] ∈ l∗ := ⟨[], rfl, λ _, false.elim⟩

instance : semiring (language α) :=
{ add := (+),
  add_assoc := union_assoc,
  zero := 0,
  zero_add := empty_union,
  add_zero := union_empty,
  add_comm := union_comm,
  mul := (*),
  mul_assoc := λ _ _ _, image2_assoc append_assoc,
  zero_mul := λ _, image2_empty_left,
  mul_zero := λ _, image2_empty_right,
  one := 1,
  one_mul := λ l, by simp [mul_def, one_def],
  mul_one := λ l, by simp [mul_def, one_def],
  nat_cast := λ n, if n = 0 then 0 else 1,
  nat_cast_zero := rfl,
  nat_cast_succ := λ n, by cases n; simp [nat.cast, add_def, zero_def],
  left_distrib := λ _ _ _, image2_union_right,
  right_distrib := λ _ _ _, image2_union_left }

@[simp] lemma add_self (l : language α) : l + l = l := sup_idem

/-- Maps the alphabet of a language. -/
def map (f : α → β) : language α →+* language β :=
{ to_fun := image (list.map f),
  map_zero' := image_empty _,
  map_one' := image_singleton,
  map_add' := image_union _,
  map_mul' := λ _ _, image_image2_distrib $ map_append _ }

@[simp] lemma map_id (l : language α) : map id l = l := by simp [map]
@[simp] lemma map_map (g : β → γ) (f : α → β) (l : language α) : map g (map f l) = map (g ∘ f) l :=
by simp [map, image_image]

lemma kstar_def_nonempty (l : language α) :
  l∗ = {x | ∃ S : list (list α), x = S.join ∧ ∀ y ∈ S, y ∈ l ∧ y ≠ []} :=
begin
  ext x,
  split,
  { rintro ⟨S, rfl, h⟩,
    refine ⟨S.filter (λ l, ¬list.empty l), by simp, λ y hy, _⟩,
    rw [mem_filter, empty_iff_eq_nil] at hy,
    exact ⟨h y hy.1, hy.2⟩ },
  { rintro ⟨S, hx, h⟩,
    exact ⟨S, hx, λ y hy, (h y hy).1⟩ }
end

lemma le_mul_congr {l₁ l₂ m₁ m₂ : language α} : l₁ ≤ m₁ → l₂ ≤ m₂ → l₁ * l₂ ≤ m₁ * m₂ :=
begin
  intros h₁ h₂ x hx,
  simp only [mul_def, exists_and_distrib_left, mem_image2, image_prod] at hx ⊢,
  tauto
end

lemma le_add_congr {l₁ l₂ m₁ m₂ : language α} : l₁ ≤ m₁ → l₂ ≤ m₂ → l₁ + l₂ ≤ m₁ + m₂ := sup_le_sup

lemma mem_supr {ι : Sort v} {l : ι → language α} {x : list α} :
  x ∈ (⨆ i, l i) ↔ ∃ i, x ∈ l i :=
mem_Union

lemma supr_mul {ι : Sort v} (l : ι → language α) (m : language α) :
  (⨆ i, l i) * m = ⨆ i, l i * m :=
image2_Union_left _ _ _

lemma mul_supr {ι : Sort v} (l : ι → language α) (m : language α) :
  m * (⨆ i, l i) = ⨆ i, m * l i :=
image2_Union_right _ _ _

lemma supr_add {ι : Sort v} [nonempty ι] (l : ι → language α) (m : language α) :
  (⨆ i, l i) + m = ⨆ i, l i + m := supr_sup

lemma add_supr {ι : Sort v} [nonempty ι] (l : ι → language α) (m : language α) :
  m + (⨆ i, l i) = ⨆ i, m + l i := sup_supr

lemma mem_pow {l : language α} {x : list α} {n : ℕ} :
  x ∈ l ^ n ↔ ∃ S : list (list α), x = S.join ∧ S.length = n ∧ ∀ y ∈ S, y ∈ l :=
begin
  induction n with n ihn generalizing x,
  { simp only [mem_one, pow_zero, length_eq_zero],
    split,
    { rintro rfl, exact ⟨[], rfl, rfl, λ y h, h.elim⟩ },
    { rintro ⟨_, rfl, rfl, _⟩, refl } },
  { simp only [pow_succ, mem_mul, ihn],
    split,
    { rintro ⟨a, b, ha, ⟨S, rfl, rfl, hS⟩, rfl⟩,
      exact ⟨a :: S, rfl, rfl, forall_mem_cons.2 ⟨ha, hS⟩⟩ },
    { rintro ⟨_|⟨a, S⟩, rfl, hn, hS⟩; cases hn,
      rw forall_mem_cons at hS,
      exact ⟨a, _, hS.1, ⟨S, rfl, rfl, hS.2⟩, rfl⟩ } }
end

lemma kstar_eq_supr_pow (l : language α) : l∗ = ⨆ i : ℕ, l ^ i :=
begin
  ext x,
  simp only [mem_kstar, mem_supr, mem_pow],
  split,
  { rintro ⟨S, rfl, hS⟩, exact ⟨_, S, rfl, rfl, hS⟩ },
  { rintro ⟨_, S, rfl, rfl, hS⟩, exact ⟨S, rfl, hS⟩ }
end

@[simp] lemma map_kstar (f : α → β) (l : language α) : map f l∗ = (map f l)∗ :=
begin
  rw [kstar_eq_supr_pow, kstar_eq_supr_pow],
  simp_rw ←map_pow,
  exact image_Union,
end

lemma mul_self_kstar_comm (l : language α) : l∗ * l = l * l∗ :=
by simp only [kstar_eq_supr_pow, mul_supr, supr_mul, ← pow_succ, ← pow_succ']

@[simp] lemma one_add_self_mul_kstar_eq_kstar (l : language α) : 1 + l * l∗ = l∗ :=
begin
  simp only [kstar_eq_supr_pow, mul_supr, ← pow_succ, ← pow_zero l],
  exact sup_supr_nat_succ _
end

@[simp] lemma one_add_kstar_mul_self_eq_kstar (l : language α) : 1 + l∗ * l = l∗ :=
by rw [mul_self_kstar_comm, one_add_self_mul_kstar_eq_kstar]

instance : kleene_algebra (language α) :=
{ one_le_kstar := λ a l hl, ⟨[], hl, by simp⟩,
  mul_kstar_le_kstar := λ a, (one_add_self_mul_kstar_eq_kstar a).le.trans' le_sup_right,
  kstar_mul_le_kstar := λ a, (one_add_kstar_mul_self_eq_kstar a).le.trans' le_sup_right,
  kstar_mul_le_self := λ l m h, begin
    rw [kstar_eq_supr_pow, supr_mul],
    refine supr_le (λ n, _),
    induction n with n ih,
    { simp },
    rw [pow_succ', mul_assoc (l^n) l m],
    exact le_trans (le_mul_congr le_rfl h) ih,
  end,
  mul_kstar_le_self := λ l m h, begin
    rw [kstar_eq_supr_pow, mul_supr],
    refine supr_le (λ n, _),
    induction n with n ih,
    { simp },
    rw [pow_succ, ←mul_assoc m l (l^n)],
    exact le_trans (le_mul_congr h le_rfl) ih,
    end,
  ..language.semiring, ..set.complete_boolean_algebra, ..language.has_kstar }

end language


/-
Copyright (c) 2015 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura

Naive sort for lists
-/
import data.list.comb data.list.set data.list.perm data.list.sorted logic.connectives algebra.order

namespace list
open decidable nat

variables  {B A : Type}
variable  (R : A → A → Prop)
variable  [decR : decidable_rel R]
include decR

definition min_core : list A → A → A
| []     a := a
| (b::l) a := if R b a then min_core l b else min_core l a

definition min : Π (l : list A), l ≠ nil → A
| []     h := absurd rfl h
| (a::l) h := min_core R l a

variable  [decA : decidable_eq A]
include decA

variable {R}
variables (to : total R) (tr : transitive R) (rf : reflexive R)

lemma min_core_lemma : ∀ {b l} a, b ∈ l ∨ b = a → R (min_core R l a) b
| b []     a h := or.elim h
  (suppose b ∈ [], absurd this !not_mem_nil)
  (suppose b = a,
    have R a a, from rf a,
    begin subst b, unfold min_core, assumption end)
| b (c::l) a h := or.elim h
  (suppose b ∈ c :: l, or.elim (eq_or_mem_of_mem_cons this)
    (suppose b = c,
      or.elim (em (R c a))
        (suppose R c a,
          have R (min_core R l b) b, from min_core_lemma _ (or.inr rfl),
          begin unfold min_core, rewrite [if_pos `R c a`], subst c, assumption end)
        (suppose ¬ R c a,
          have R a c, from or_resolve_right (to c a) this,
          have R (min_core R l a) a, from min_core_lemma _ (or.inr rfl),
          have R (min_core R l a) c, from tr this `R a c`,
          begin unfold min_core, rewrite [if_neg `¬ R c a`], subst b, exact `R (min_core R l a) c` end))
    (suppose b ∈ l,
      or.elim (em (R c a))
        (suppose R c a,
          have R (min_core R l c) b, from min_core_lemma _ (or.inl `b ∈ l`),
          begin unfold min_core, rewrite [if_pos `R c a`], assumption end)
        (suppose ¬ R c a,
          have R (min_core R l a) b, from min_core_lemma _ (or.inl `b ∈ l`),
          begin unfold min_core, rewrite [if_neg `¬ R c a`], assumption end)))
  (suppose b = a,
    have R (min_core R l a) b, from min_core_lemma _ (or.inr this),
    or.elim (em (R c a))
       (suppose R c a,
         have R (min_core R l c) c, from min_core_lemma _ (or.inr rfl),
         have R (min_core R l c) a, from tr this `R c a`,
         begin unfold min_core, rewrite [if_pos `R c a`], subst b, exact `R (min_core R l c) a` end)
       (suppose ¬ R c a, begin unfold min_core, rewrite [if_neg `¬ R c a`], assumption end))

lemma min_core_le_of_mem {b : A} {l : list A} (a : A) : b ∈ l → R (min_core R l a) b :=
assume h : b ∈ l, min_core_lemma to tr rf a (or.inl h)

lemma min_core_le {l : list A} (a : A) : R (min_core R l a) a :=
min_core_lemma to tr rf a (or.inr rfl)

lemma min_lemma : ∀ {l} (h : l ≠ nil), all l (R (min R l h))
| []     h := absurd rfl h
| (b::l) h :=
  all_of_forall (take x, suppose x ∈ b::l,
   or.elim (eq_or_mem_of_mem_cons this)
     (suppose x = b,
       have R (min_core R l b) b, from min_core_le to tr rf b,
       begin subst x, unfold min, assumption end)
     (suppose x ∈ l,
       have R (min_core R l b) x, from min_core_le_of_mem to tr rf _ this,
       begin unfold min, assumption end))

variable (R)

lemma min_core_mem : ∀ l a, min_core R l a ∈ l ∨ min_core R l a = a
| []     a := or.inr rfl
| (b::l) a := or.elim (em (R b a))
  (suppose R b a,
    begin
      unfold min_core, rewrite [if_pos `R b a`],
      apply  or.elim (min_core_mem l b),
      suppose min_core R l b ∈ l, or.inl (mem_cons_of_mem _ this),
      suppose min_core R l b = b, by rewrite this; exact or.inl !mem_cons
    end)
  (suppose ¬ R b a,
    begin
      unfold min_core, rewrite [if_neg `¬ R b a`],
      apply  or.elim (min_core_mem l a),
      suppose min_core R l a ∈ l, or.inl (mem_cons_of_mem _ this),
      suppose min_core R l a = a, or.inr this
    end)

lemma min_mem : ∀ (l : list A) (h : l ≠ nil), min R l h ∈ l
| []     h := absurd rfl h
| (a::l) h :=
  begin
    unfold min,
    apply or.elim (min_core_mem R l a),
    suppose min_core R l a ∈ l, mem_cons_of_mem _ this,
    suppose min_core R l a = a, by rewrite this; apply mem_cons
  end

lemma min_map (f : B → A) {l : list B} (h : l ≠ nil) :
      all l (λ b, (R (min R (map f l) (map_ne_nil_of_ne_nil _ h))) (f b)):=
  using to tr rf,
  begin
    apply all_of_forall,
    intro b Hb,
    have Hfa : all (map f l) (R (min R (map f l) (map_ne_nil_of_ne_nil _ h))), from min_lemma to tr rf _,
    have Hfb : f b ∈ map f l, from mem_map _ Hb,
    exact of_mem_of_all Hfb Hfa
  end

lemma min_map_all (f : B → A) {l : list B} (h : l ≠ nil) {b : B} (Hb : b ∈ l) :
      R (min R (map f l) ((map_ne_nil_of_ne_nil _ h))) (f b) :=
  of_mem_of_all Hb (min_map _ to tr rf f h)

omit decR
private lemma ne_nil {l : list A} {n : nat} : length l = succ n → l ≠ nil :=
assume h₁ h₂, by rewrite h₂ at h₁; contradiction

include decR
lemma sort_aux_lemma {l n} (h : length l = succ n) : length (erase (min R l (ne_nil h)) l) = n :=
have min R l _ ∈ l, from min_mem R l (ne_nil h),
have length (erase (min R l  _) l) = pred (length l), from length_erase_of_mem this,
by rewrite h at this; exact this

definition sort_aux : Π (n : nat) (l : list A), length l = n → list A
| 0        l h := []
| (succ n) l h :=
  let m  := min R l (ne_nil h) in
  let l₁ := erase m l in
  m :: sort_aux n l₁ (sort_aux_lemma R h)

definition sort (l : list A) : list A :=
sort_aux R (length l) l rfl

open perm

lemma sort_aux_perm : ∀ {n : nat} {l : list A} (h : length l = n), sort_aux R n l h ~ l
| 0        l h := by rewrite [↑sort_aux, eq_nil_of_length_eq_zero h]
| (succ n) l h :=
  let m := min R l (ne_nil h) in
  have leq : length (erase m l) = n, from sort_aux_lemma R h,
  calc m :: sort_aux R n (erase m l) leq
         ~ m :: erase m l                   : perm.skip m (sort_aux_perm leq)
     ... ~ l                                : perm_erase (min_mem _ _ _)

lemma sort_perm (l : list A) : sort R l ~ l :=
sort_aux_perm R rfl

lemma strongly_sorted_sort_aux : ∀ {n : nat} {l : list A} (h : length l = n), strongly_sorted R (sort_aux R n l h)
| 0        l h := !strongly_sorted.base
| (succ n) l h :=
  let m := min R l (ne_nil h) in
  have leq    : length (erase m l) = n,                       from sort_aux_lemma R h,
  have ss : strongly_sorted R (sort_aux R n (erase m l) leq), from strongly_sorted_sort_aux leq,
  have all l (R m),                                           from min_lemma to tr rf (ne_nil h),
  have hall : all (sort_aux R n (erase m l) leq) (R m),       from
    all_of_forall (take x,
      suppose x ∈ sort_aux R n (erase m l) leq,
      have x ∈ erase m l, from mem_perm (sort_aux_perm R leq) this,
      have x ∈ l,         from mem_of_mem_erase this,
      show R m x,         from of_mem_of_all this `all l (R m)`),
  strongly_sorted.step hall ss

variable {R}

lemma strongly_sorted_sort_core (to : total R) (tr : transitive R) (rf : reflexive R) (l : list A) : strongly_sorted R (sort R l) :=
@strongly_sorted_sort_aux _ _ _ _ to tr rf (length l) l rfl

lemma sort_eq_of_perm_core {l₁ l₂ : list A} (to : total R) (tr : transitive R) (rf : reflexive R) (asy : anti_symmetric R) (h : l₁ ~ l₂) : sort R l₁ = sort R l₂ :=
have s₁ : sorted R (sort R l₁),  from sorted_of_strongly_sorted (strongly_sorted_sort_core to tr rf l₁),
have s₂ : sorted R (sort R l₂),  from sorted_of_strongly_sorted (strongly_sorted_sort_core to tr rf l₂),
have p  : sort R l₁ ~ sort R l₂, from calc
  sort R l₁ ~ l₁        : sort_perm
    ...     ~ l₂        : h
    ...     ~ sort R l₂ : sort_perm,
eq_of_sorted_of_perm tr asy p s₁ s₂

section
omit decR
lemma strongly_sorted_sort [decidable_linear_order A] (l : list A) : strongly_sorted le (sort le l) :=
strongly_sorted_sort_core le.total (@le.trans A _) le.refl l

lemma sort_eq_of_perm {l₁ l₂ : list A} [decidable_linear_order A] (h : l₁ ~ l₂) : sort le l₁ = sort le l₂ :=
sort_eq_of_perm_core le.total (@le.trans A _) le.refl (@le.antisymm A _) h
end
end list