import Lean4Axiomatic.AbstractAlgebra
import Lean4Axiomatic.Integer.Sign

/-!
# Integer subtraction
-/

namespace Lean4Axiomatic.Integer

/-!
## Axioms
-/

/--
Definition of subtraction, and properties that it must satisfy.

All other properties of subtraction can be derived from these.
-/
class Subtraction
    {ℕ : outParam Type} [Natural ℕ]
    (ℤ : Type) [Core (ℕ := ℕ) ℤ] [Addition ℤ] [Negation ℤ]
    :=
  /-- Definition of and syntax for subtraction. -/
  subOp : Sub ℤ

  /-- Subtraction of a value is equivalent to adding its negation. -/
  sub_defn {a b : ℤ} : a - b ≃ a + (-b)

attribute [instance] Subtraction.subOp

export Subtraction (sub_defn subOp)

/-!
## Derived properties
-/

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Core ℤ] [Addition ℤ] [Multiplication (ℕ := ℕ) ℤ]
variable [Negation ℤ] [Sign ℤ] [Subtraction ℤ]

/--
Subtraction is left-substitutive.

**Proof intuition**: Trivial; just substitutes on the underlying addition.
-/
theorem sub_substL {a₁ a₂ b : ℤ} : a₁ ≃ a₂ → a₁ - b ≃ a₂ - b := by
  intro (_ : a₁ ≃ a₂)
  show a₁ - b ≃ a₂ - b
  calc
    a₁ - b    ≃ _ := sub_defn
    a₁ + (-b) ≃ _ := AA.substL ‹a₁ ≃ a₂›
    a₂ + (-b) ≃ _ := Rel.symm sub_defn
    a₂ - b    ≃ _ := Rel.refl

def sub_substitutiveL
    : AA.SubstitutiveOn Hand.L (α := ℤ) (· - ·) AA.tc (· ≃ ·) (· ≃ ·)
    := {
  subst₂ := λ (_ : True) => sub_substL
}

/--
Subtraction is right-substitutive.

**Proof intuition**: Trivial; just substitutes on the underlying addition and
negation.
-/
theorem sub_substR {a₁ a₂ b : ℤ} : a₁ ≃ a₂ → b - a₁ ≃ b - a₂ := by
  intro (_ : a₁ ≃ a₂)
  show b - a₁ ≃ b - a₂
  calc
    b - a₁    ≃ _ := sub_defn
    b + (-a₁) ≃ _ := AA.substR (AA.subst₁ ‹a₁ ≃ a₂›)
    b + (-a₂) ≃ _ := Rel.symm sub_defn
    b - a₂    ≃ _ := Rel.refl

def sub_substitutiveR
    : AA.SubstitutiveOn Hand.R (α := ℤ) (· - ·) AA.tc (· ≃ ·) (· ≃ ·)
    := {
  subst₂ := λ (_ : True) => sub_substR
}

instance sub_substitutive
    : AA.Substitutive₂ (α := ℤ) (· - ·) AA.tc (· ≃ ·) (· ≃ ·)
    := {
  substitutiveL := sub_substitutiveL
  substitutiveR := sub_substitutiveR
}

/--
Subtracting an integer from itself yields zero.

**Property and proof intuition**: This is equivalent to the additive inverse
property.
-/
theorem sub_same {a : ℤ} : a - a ≃ 0 := calc
  a - a  ≃ _ := sub_defn
  a + -a ≃ _ := AA.inverseR
  0      ≃ _ := Rel.refl

/--
Equivalent integers are the only ones to differ by zero.

**Proof intuition**: The reverse direction is trivial; the forward direction
uses the additive inverse property and the assumption `a - b ≃ 0` to replace
`a` with `b`.
-/
theorem zero_diff_iff_eqv {a b : ℤ} : a - b ≃ 0 ↔ a ≃ b := by
  apply Iff.intro
  case mp =>
    intro (_ : a - b ≃ 0)
    show a ≃ b
    calc
      a            ≃ _ := Rel.symm AA.identR
      a + 0        ≃ _ := AA.substR (Rel.symm AA.inverseL)
      a + (-b + b) ≃ _ := Rel.symm AA.assoc
      (a + -b) + b ≃ _ := AA.substL (Rel.symm sub_defn)
      (a - b) + b  ≃ _ := AA.substL ‹a - b ≃ 0›
      0 + b        ≃ _ := AA.identL
      b            ≃ _ := Rel.refl
  case mpr =>
    intro (_ : a ≃ b)
    show a - b ≃ 0
    calc
      a - b  ≃ _ := AA.substL ‹a ≃ b›
      b - b  ≃ _ := sub_same
      0      ≃ _ := Rel.refl

/--
The right-hand operand of subtraction can be moved to the left-hand operand of
addition on the other side of an equivalence.

**Property intuition**: This is a very common technique in algebra.

**Proof intuition**: There's no key idea for this proof, other than using
algebra on integers to obtain expressions where assumptions can be used.
-/
theorem subR_move_addL {a b c : ℤ} : a - b ≃ c ↔ a ≃ b + c := by
  apply Iff.intro
  case mp =>
    intro (_ : a - b ≃ c)
    show a ≃ b + c
    calc
      a            ≃ _ := Rel.symm AA.identR
      a + 0        ≃ _ := AA.substR (Rel.symm AA.inverseL)
      a + (-b + b) ≃ _ := Rel.symm AA.assoc
      (a + -b) + b ≃ _ := AA.substL (Rel.symm sub_defn)
      (a - b) + b  ≃ _ := AA.substL ‹a - b ≃ c›
      c + b        ≃ _ := AA.comm
      b + c        ≃ _ := Rel.refl
  case mpr =>
    intro (_ : a ≃ b + c)
    show a - b ≃ c
    calc
      a - b        ≃ _ := AA.substL ‹a ≃ b + c›
      b + c - b    ≃ _ := AA.substL AA.comm
      c + b - b    ≃ _ := sub_defn
      c + b + -b   ≃ _ := AA.assoc
      c + (b + -b) ≃ _ := AA.substR AA.inverseR
      c + 0        ≃ _ := AA.identR
      c            ≃ _ := Rel.refl

/--
Multiplication distributes over subtraction (on the left).

**Property and proof intuition**: This is the same as multiplication
distributing over addition: just expand the definition of subtraction.
-/
theorem mul_distribL_sub {a b c : ℤ} : a * (b - c) ≃ a * b - a * c := calc
  a * (b - c)      ≃ _ := AA.substR sub_defn
  a * (b + -c)     ≃ _ := AA.distribL
  a * b + a * -c   ≃ _ := AA.substR (Rel.symm AA.scompatR)
  a * b + -(a * c) ≃ _ := Rel.symm sub_defn
  a * b - a * c    ≃ _ := Rel.refl

def mul_distributiveL_sub
    : AA.DistributiveOn Hand.L (α := ℤ) (· * ·) (· - ·)
    := {
  distrib := mul_distribL_sub
}

instance mul_distributive_sub : AA.Distributive (α := ℤ) (· * ·) (· - ·) := {
  distributiveL := mul_distributiveL_sub
  distributiveR := AA.distributiveR_from_distributiveL mul_distributiveL_sub
}

/--
When subtracting two sums, if they both have the same right-hand operand, it
can be removed, leaving just the difference of the left-hand operands.

**Intuition**: This follows from the basic algebraic properties of integers.
-/
theorem sub_sums_sameR {a b c : ℤ} : a + c - (b + c) ≃ a - b := calc
  a + c - (b + c)           ≃ _ := sub_defn
  a + c + -(b + c)          ≃ _ := AA.substR (Rel.symm mul_neg_one)
  a + c + -1 * (b + c)      ≃ _ := AA.substR AA.distribL
  a + c + (-1 * b + -1 * c) ≃ _ := AA.expr_xxfxxff_lr_swap_rl
  a + -1 * b + (c + -1 * c) ≃ _ := AA.substR (AA.substR mul_neg_one)
  a + -1 * b + (c + -c)     ≃ _ := AA.substR AA.inverseR
  a + -1 * b + 0            ≃ _ := AA.identR
  a + -1 * b                ≃ _ := AA.substR mul_neg_one
  a + -b                    ≃ _ := Rel.symm sub_defn
  a - b                     ≃ _ := Rel.refl

/--
Multiplication by a nonzero value on the left is injective.

**Property and proof intuition**: Viewing multiplication as a scaling
operation, this says that if two values are equivalent after being scaled by
the same amount, then their unscaled values must have been equivalent as well.
This seems to be consistent with our intuitive understanding of multiplication.
-/
theorem mul_cancelL {a b c : ℤ} : a ≄ 0 → a * b ≃ a * c → b ≃ c := by
  intro (_ : a ≄ 0) (_ : a * b ≃ a * c)
  show b ≃ c
  have : a * b - a * c ≃ 0 := zero_diff_iff_eqv.mpr ‹a * b ≃ a * c›
  have : a * (b - c) ≃ 0 := Rel.trans AA.distribL ‹a * b - a * c ≃ 0›
  have : a ≃ 0 ∨ b - c ≃ 0 := mul_split_zero.mp ‹a * (b - c) ≃ 0›
  match ‹a ≃ 0 ∨ b - c ≃ 0› with
  | Or.inl (_ : a ≃ 0) =>
    show b ≃ c
    exact absurd ‹a ≃ 0› ‹a ≄ 0›
  | Or.inr (_ : b - c ≃ 0) =>
    show b ≃ c
    exact zero_diff_iff_eqv.mp ‹b - c ≃ 0›

def mul_cancellativeL
    : AA.CancellativeOn Hand.L (α := ℤ) (· * ·) (· ≄ 0) (· ≃ ·) (· ≃ ·)
    := {
  cancel := mul_cancelL
}

instance mul_cancellative
    : AA.Cancellative (α := ℤ) (· * ·) (· ≄ 0) (· ≃ ·) (· ≃ ·)
    := {
  cancellativeL := mul_cancellativeL
  cancellativeR := AA.cancelR_from_cancelL mul_cancellativeL
}

/--
Multiplication by a nonzero value on the right is injective.

**Property and proof intuition**: See `mul_cancelL`.
-/
theorem mul_cancelR {a b c : ℤ} : a ≄ 0 → b * a ≃ c * a → b ≃ c :=
  AA.cancelRC (C := (· ≄ 0))

/--
Decidable equivalence for integers.

**Property intuition**: Every integer has a finite value, so it should be
possible for an algorithm to decide if two of them are equivalent.

**Proof intuition**: We already know how to decide if an integer is zero. Use
that on the value `a - b`, then change the result into the desired form.
-/
theorem eqv? (a b : ℤ) : a ≃ b ∨ a ≄ b := by
  have : a - b ≃ 0 ∨ Nonzero (a - b) := (zero? (a - b)).left
  match ‹a - b ≃ 0 ∨ Nonzero (a - b)› with
  | Or.inl (_ : a - b ≃ 0) =>
    have : a ≃ b := zero_diff_iff_eqv.mp ‹a - b ≃ 0›
    exact Or.inl ‹a ≃ b›
  | Or.inr (_ : Nonzero (a - b)) =>
    have : a - b ≄ 0 := nonzero_iff_neqv_zero.mp ‹Nonzero (a - b)›
    have : a ≄ b := mt zero_diff_iff_eqv.mpr ‹a - b ≄ 0›
    exact Or.inr ‹a ≄ b›

/--
Negation of subtraction swaps the operands.

**Property intuition**: The result of subtraction depends on the ordering of
the two operands. Negating the result is equivalent to reversing the operands'
order.

**Proof intuition**: Represent subtraction as addition; the negation operator
distributes to both operands. It undoes the negation of one operand, and adds
negation to the other. With negation swapped, the sum is still equivalent to
subtraction, but in the opposite order.
-/
theorem sub_neg_flip {a b : ℤ} : -(a - b) ≃ b - a := calc
  (-(a - b))   ≃ _ := AA.subst₁ sub_defn
  (-(a + -b))  ≃ _ := neg_compat_add
  (-a) + -(-b) ≃ _ := AA.substR neg_involutive
  (-a) + b     ≃ _ := AA.comm
  b + -a       ≃ _ := Rel.symm sub_defn
  b - a        ≃ _ := Rel.refl

end Lean4Axiomatic.Integer


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.metric_space.metric_separated
import measure_theory.constructions.borel_space
import measure_theory.measure.lebesgue
import analysis.special_functions.pow
import topology.metric_space.holder
import data.equiv.list

/-!
# Hausdorff measure and metric (outer) measures

In this file we define the `d`-dimensional Hausdorff measure on an (extended) metric space `X` and
the Hausdorff dimension of a set in an (extended) metric space. Let `μ d δ` be the maximal outer
measure such that `μ d δ s ≤ (emetric.diam s) ^ d` for every set of diameter less than `δ`. Then
the Hausdorff measure `μH[d] s` of `s` is defined as `⨆ δ > 0, μ d δ s`. By Caratheodory theorem
`measure_theory.outer_measure.is_metric.borel_le_caratheodory`, this is a Borel measure on `X`.

The value of `μH[d]`, `d > 0`, on a set `s` (measurable or not) is given by
```
μH[d] s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, emetric.diam (t n) ≤ r), ∑' n, emetric.diam (t n) ^ d
```

For every set `s` for any `d < d'` we have either `μH[d] s = ∞` or `μH[d'] s = 0`, see
`measure_theory.measure.hausdorff_measure_zero_or_top`. In
`topology.metric_space.hausdorff_dimension` we use this fact to define the Hausdorff dimension
`dimH` of a set in an (extended) metric space.

We also define two generalizations of the Hausdorff measure. In one generalization (see
`measure_theory.measure.mk_metric`) we take any function `m (diam s)` instead of `(diam s) ^ d`. In
an even more general definition (see `measure_theory.measure.mk_metric'`) we use any function
of `m : set X → ℝ≥0∞`. Some authors start with a partial function `m` defined only on some sets
`s : set X` (e.g., only on balls or only on measurable sets). This is equivalent to our definition
applied to `measure_theory.extend m`.

We also define a predicate `measure_theory.outer_measure.is_metric` which says that an outer measure
is additive on metric separated pairs of sets: `μ (s ∪ t) = μ s + μ t` provided that
`⨅ (x ∈ s) (y ∈ t), edist x y ≠ 0`. This is the property required for the Caratheodory theorem
`measure_theory.outer_measure.is_metric.borel_le_caratheodory`, so we prove this theorem for any
metric outer measure, then prove that outer measures constructed using `mk_metric'` are metric outer
measures.

## Main definitions

* `measure_theory.outer_measure.is_metric`: an outer measure `μ` is called *metric* if
  `μ (s ∪ t) = μ s + μ t` for any two metric separated sets `s` and `t`. A metric outer measure in a
  Borel extended metric space is guaranteed to satisfy the Caratheodory condition, see
  `measure_theory.outer_measure.is_metric.borel_le_caratheodory`.
* `measure_theory.outer_measure.mk_metric'` and its particular case
  `measure_theory.outer_measure.mk_metric`: a construction of an outer measure that is guaranteed to
  be metric. Both constructions are generalizations of the Hausdorff measure. The same measures
  interpreted as Borel measures are called `measure_theory.measure.mk_metric'` and
  `measure_theory.measure.mk_metric`.
* `measure_theory.measure.hausdorff_measure` a.k.a. `μH[d]`: the `d`-dimensional Hausdorff measure.
  There are many definitions of the Hausdorff measure that differ from each other by a
  multiplicative constant. We put
  `μH[d] s = ⨆ r > 0, ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n) (ht : ∀ n, emetric.diam (t n) ≤ r),
    ∑' n, ⨆ (ht : ¬set.subsingleton (t n)), (emetric.diam (t n)) ^ d`,
  see `measure_theory.measure.hausdorff_measure_apply'`. In the most interesting case `0 < d` one
  can omit the `⨆ (ht : ¬set.subsingleton (t n))` part.

## Main statements

### Basic properties

* `measure_theory.outer_measure.is_metric.borel_le_caratheodory`: if `μ` is a metric outer measure
  on an extended metric space `X` (that is, it is additive on pairs of metric separated sets), then
  every Borel set is Caratheodory measurable (hence, `μ` defines an actual
  `measure_theory.measure`). See also `measure_theory.measure.mk_metric`.
* `measure_theory.measure.hausdorff_measure_mono`: `μH[d] s` is an antitone function
  of `d`.
* `measure_theory.measure.hausdorff_measure_zero_or_top`: if `d₁ < d₂`, then for any `s`, either
  `μH[d₂] s = 0` or `μH[d₁] s = ∞`. Together with the previous lemma, this means that `μH[d] s` is
  equal to infinity on some ray `(-∞, D)` and is equal to zero on `(D, +∞)`, where `D` is a possibly
  infinite number called the *Hausdorff dimension* of `s`; `μH[D] s` can be zero, infinity, or
  anything in between.
* `measure_theory.measure.no_atoms_hausdorff`: Hausdorff measure has no atoms.

### Hausdorff measure in `ℝⁿ`

* `measure_theory.hausdorff_measure_pi_real`: for a nonempty `ι`, `μH[card ι]` on `ι → ℝ` equals
  Lebesgue measure.

## Notations

We use the following notation localized in `measure_theory`.

- `μH[d]` : `measure_theory.measure.hausdorff_measure d`

## Implementation notes

There are a few similar constructions called the `d`-dimensional Hausdorff measure. E.g., some
sources only allow coverings by balls and use `r ^ d` instead of `(diam s) ^ d`. While these
construction lead to different Hausdorff measures, they lead to the same notion of the Hausdorff
dimension.

Some sources define the `0`-dimensional Hausdorff measure to be the counting measure. We define it
to be zero on subsingletons because this way we can have a
`measure.has_no_atoms (measure.hausdorff_measure d)` instance.

## TODO

* prove that `1`-dimensional Hausdorff measure on `ℝ` equals `volume`;
* prove a similar statement for `ℝ × ℝ`.

## References

* [Herbert Federer, Geometric Measure Theory, Chapter 2.10][Federer1996]

## Tags

Hausdorff measure, measure, metric measure
-/

open_locale nnreal ennreal topological_space big_operators

open emetric set function filter encodable finite_dimensional topological_space

noncomputable theory

variables {ι X Y : Type*} [emetric_space X] [emetric_space Y]

namespace measure_theory

namespace outer_measure

/-!
### Metric outer measures

In this section we define metric outer measures and prove Caratheodory theorem: a metric outer
measure has the Caratheodory property.
-/

/-- We say that an outer measure `μ` in an (e)metric space is *metric* if `μ (s ∪ t) = μ s + μ t`
for any two metric separated sets `s`, `t`. -/
def is_metric (μ : outer_measure X) : Prop :=
∀ (s t : set X), is_metric_separated s t → μ (s ∪ t) = μ s + μ t

namespace is_metric

variables {μ : outer_measure X}

/-- A metric outer measure is additive on a finite set of pairwise metric separated sets. -/
lemma finset_Union_of_pairwise_separated (hm : is_metric μ) {I : finset ι} {s : ι → set X}
  (hI : ∀ (i ∈ I) (j ∈ I), i ≠ j → is_metric_separated (s i) (s j)) :
  μ (⋃ i ∈ I, s i) = ∑ i in I, μ (s i) :=
begin
  classical,
  induction I using finset.induction_on with i I hiI ihI hI, { simp },
  simp only [finset.mem_insert] at hI,
  rw [finset.set_bUnion_insert, hm, ihI, finset.sum_insert hiI],
  exacts [λ i hi j hj hij, (hI i (or.inr hi) j (or.inr hj) hij),
    is_metric_separated.finset_Union_right
      (λ j hj, hI i (or.inl rfl) j (or.inr hj) (ne_of_mem_of_not_mem hj hiI).symm)]
end

/-- Caratheodory theorem. If `m` is a metric outer measure, then every Borel measurable set `t` is
Caratheodory measurable: for any (not necessarily measurable) set `s` we have
`μ (s ∩ t) + μ (s \ t) = μ s`. -/
lemma borel_le_caratheodory (hm : is_metric μ) :
  borel X ≤ μ.caratheodory :=
begin
  rw [borel_eq_generate_from_is_closed],
  refine measurable_space.generate_from_le (λ t ht, μ.is_caratheodory_iff_le.2 $ λ s, _),
  set S : ℕ → set X := λ n, {x ∈ s | (↑n)⁻¹ ≤ inf_edist x t},
  have n0 : ∀ {n : ℕ}, (n⁻¹ : ℝ≥0∞) ≠ 0, from λ n, ennreal.inv_ne_zero.2 ennreal.coe_nat_ne_top,
  have Ssep : ∀ n, is_metric_separated (S n) t,
    from λ n, ⟨n⁻¹, n0, λ x hx y hy, hx.2.trans $ inf_edist_le_edist_of_mem hy⟩,
  have Ssep' : ∀ n, is_metric_separated (S n) (s ∩ t),
    from λ n, (Ssep n).mono subset.rfl (inter_subset_right _ _),
  have S_sub : ∀ n, S n ⊆ s \ t,
    from λ n, subset_inter (inter_subset_left _ _) (Ssep n).subset_compl_right,
  have hSs : ∀ n, μ (s ∩ t) + μ (S n) ≤ μ s, from λ n,
  calc μ (s ∩ t) + μ (S n) = μ (s ∩ t ∪ S n) :
    eq.symm $ hm _ _ $ (Ssep' n).symm
  ... ≤ μ (s ∩ t ∪ s \ t)  : by { mono*, exact le_rfl }
  ... = μ s : by rw [inter_union_diff],
  have Union_S : (⋃ n, S n) = s \ t,
  { refine subset.antisymm (Union_subset S_sub) _,
    rintro x ⟨hxs, hxt⟩,
    rw mem_iff_inf_edist_zero_of_closed ht at hxt,
    rcases ennreal.exists_inv_nat_lt hxt with ⟨n, hn⟩,
    exact mem_Union.2 ⟨n, hxs, hn.le⟩ },
  /- Now we have `∀ n, μ (s ∩ t) + μ (S n) ≤ μ s` and we need to prove
  `μ (s ∩ t) + μ (⋃ n, S n) ≤ μ s`. We can't pass to the limit because
  `μ` is only an outer measure. -/
  by_cases htop : μ (s \ t) = ∞,
  { rw [htop, ennreal.add_top, ← htop],
    exact μ.mono (diff_subset _ _) },
  suffices : μ (⋃ n, S n) ≤ ⨆ n, μ (S n),
  calc μ (s ∩ t) + μ (s \ t) = μ (s ∩ t) + μ (⋃ n, S n) :
    by rw Union_S
  ... ≤ μ (s ∩ t) + ⨆ n, μ (S n) :
    add_le_add le_rfl this
  ... = ⨆ n, μ (s ∩ t) + μ (S n) : ennreal.add_supr
  ... ≤ μ s : supr_le hSs,
  /- It suffices to show that `∑' k, μ (S (k + 1) \ S k) ≠ ∞`. Indeed, if we have this,
  then for all `N` we have `μ (⋃ n, S n) ≤ μ (S N) + ∑' k, m (S (N + k + 1) \ S (N + k))`
  and the second term tends to zero, see `outer_measure.Union_nat_of_monotone_of_tsum_ne_top`
  for details. -/
  have : ∀ n, S n ⊆ S (n + 1), from λ n x hx,
    ⟨hx.1, le_trans (ennreal.inv_le_inv.2 $ ennreal.coe_nat_le_coe_nat.2 n.le_succ) hx.2⟩,
  refine (μ.Union_nat_of_monotone_of_tsum_ne_top this _).le, clear this,
  /- While the sets `S (k + 1) \ S k` are not pairwise metric separated, the sets in each
  subsequence `S (2 * k + 1) \ S (2 * k)` and `S (2 * k + 2) \ S (2 * k)` are metric separated,
  so `m` is additive on each of those sequences. -/
  rw [← tsum_even_add_odd ennreal.summable ennreal.summable, ennreal.add_ne_top],
  suffices : ∀ a, (∑' (k : ℕ), μ (S (2 * k + 1 + a) \ S (2 * k + a))) ≠ ∞,
    from ⟨by simpa using this 0, by simpa using this 1⟩,
  refine λ r, ne_top_of_le_ne_top htop _,
  rw [← Union_S, ennreal.tsum_eq_supr_nat, supr_le_iff],
  intro n,
  rw [← hm.finset_Union_of_pairwise_separated],
  { exact μ.mono (Union_subset $ λ i, Union_subset $ λ hi x hx, mem_Union.2 ⟨_, hx.1⟩) },
  suffices : ∀ i  j, i < j → is_metric_separated (S (2 * i + 1 + r)) (s \ S (2 * j + r)),
    from λ i _ j _ hij, hij.lt_or_lt.elim
      (λ h, (this i j h).mono (inter_subset_left _ _) (λ x hx, ⟨hx.1.1, hx.2⟩))
      (λ h, (this j i h).symm.mono  (λ x hx, ⟨hx.1.1, hx.2⟩) (inter_subset_left _ _)),
  intros i j hj,
  have A : ((↑(2 * j + r))⁻¹ : ℝ≥0∞) < (↑(2 * i + 1 + r))⁻¹,
    by { rw [ennreal.inv_lt_inv, ennreal.coe_nat_lt_coe_nat], linarith },
  refine ⟨(↑(2 * i + 1 + r))⁻¹ - (↑(2 * j + r))⁻¹, by simpa using A, λ x hx y hy, _⟩,
  have : inf_edist y t < (↑(2 * j + r))⁻¹, from not_le.1 (λ hle, hy.2 ⟨hy.1, hle⟩),
  rcases exists_edist_lt_of_inf_edist_lt this with ⟨z, hzt, hyz⟩,
  have hxz : (↑(2 * i + 1 + r))⁻¹ ≤ edist x z, from le_inf_edist.1 hx.2 _ hzt,
  apply ennreal.le_of_add_le_add_right hyz.ne_top,
  refine le_trans _ (edist_triangle _ _ _),
  refine (add_le_add le_rfl hyz.le).trans (eq.trans_le _ hxz),
  rw [tsub_add_cancel_of_le A.le]
end

lemma le_caratheodory [measurable_space X] [borel_space X] (hm : is_metric μ) :
  ‹measurable_space X› ≤ μ.caratheodory :=
by { rw @borel_space.measurable_eq X _ _, exact hm.borel_le_caratheodory }

end is_metric

/-!
### Constructors of metric outer measures

In this section we provide constructors `measure_theory.outer_measure.mk_metric'` and
`measure_theory.outer_measure.mk_metric` and prove that these outer measures are metric outer
measures. We also prove basic lemmas about `map`/`comap` of these measures.
-/

/-- Auxiliary definition for `outer_measure.mk_metric'`: given a function on sets
`m : set X → ℝ≥0∞`, returns the maximal outer measure `μ` such that `μ s ≤ m s`
for any set `s` of diameter at most `r`.-/
def mk_metric'.pre (m : set X → ℝ≥0∞) (r : ℝ≥0∞) :
  outer_measure X :=
bounded_by $ extend (λ s (hs : diam s ≤ r), m s)

/-- Given a function `m : set X → ℝ≥0∞`, `mk_metric' m` is the supremum of `mk_metric'.pre m r`
over `r > 0`. Equivalently, it is the limit of `mk_metric'.pre m r` as `r` tends to zero from
the right. -/
def mk_metric' (m : set X → ℝ≥0∞) :
  outer_measure X :=
⨆ r > 0, mk_metric'.pre m r

/-- Given a function `m : ℝ≥0∞ → ℝ≥0∞` and `r > 0`, let `μ r` be the maximal outer measure such that
`μ s = 0` on subsingletons and `μ s ≤ m (emetric.diam s)` whenever `emetric.diam s < r`. Then
`mk_metric m = ⨆ r > 0, μ r`. We add `⨆ (hs : ¬s.subsingleton)` to ensure that in the case
`m x = x ^ d` the definition gives the expected result for `d = 0`. -/
def mk_metric (m : ℝ≥0∞ → ℝ≥0∞) : outer_measure X :=
mk_metric' (λ s, ⨆ (hs : ¬s.subsingleton), m (diam s))

namespace mk_metric'

variables {m : set X → ℝ≥0∞} {r : ℝ≥0∞} {μ : outer_measure X} {s : set X}

lemma le_pre : μ ≤ pre m r ↔ ∀ s : set X, diam s ≤ r → μ s ≤ m s :=
by simp only [pre, le_bounded_by, extend, le_infi_iff]

lemma pre_le (hs : diam s ≤ r) : pre m r s ≤ m s :=
(bounded_by_le _).trans $ infi_le _ hs

lemma mono_pre (m : set X → ℝ≥0∞) {r r' : ℝ≥0∞} (h : r ≤ r') :
  pre m r' ≤ pre m r :=
le_pre.2 $ λ s hs, pre_le (hs.trans h)

lemma mono_pre_nat (m : set X → ℝ≥0∞) :
  monotone (λ k : ℕ, pre m k⁻¹) :=
λ k l h, le_pre.2 $ λ s hs, pre_le (hs.trans $ by simpa)

lemma tendsto_pre (m : set X → ℝ≥0∞) (s : set X) :
  tendsto (λ r, pre m r s) (𝓝[Ioi 0] 0) (𝓝 $ mk_metric' m s) :=
begin
  rw [← map_coe_Ioi_at_bot, tendsto_map'_iff],
  simp only [mk_metric', outer_measure.supr_apply, supr_subtype'],
  exact tendsto_at_bot_supr (λ r r' hr, mono_pre _ hr _)
end

lemma tendsto_pre_nat (m : set X → ℝ≥0∞) (s : set X) :
  tendsto (λ n : ℕ, pre m n⁻¹ s) at_top (𝓝 $ mk_metric' m s) :=
begin
  refine (tendsto_pre m s).comp (tendsto_inf.2 ⟨ennreal.tendsto_inv_nat_nhds_zero, _⟩),
  refine tendsto_principal.2 (eventually_of_forall $ λ n, _),
  simp
end

lemma eq_supr_nat (m : set X → ℝ≥0∞) :
  mk_metric' m = ⨆ n : ℕ, mk_metric'.pre m n⁻¹ :=
begin
  ext1 s,
  rw supr_apply,
  refine tendsto_nhds_unique (mk_metric'.tendsto_pre_nat m s)
    (tendsto_at_top_supr $ λ k l hkl, mk_metric'.mono_pre_nat m hkl s)
end

/-- `measure_theory.outer_measure.mk_metric'.pre m r` is a trimmed measure provided that
`m (closure s) = m s` for any set `s`. -/
lemma trim_pre [measurable_space X] [opens_measurable_space X]
  (m : set X → ℝ≥0∞) (hcl : ∀ s, m (closure s) = m s) (r : ℝ≥0∞) :
  (pre m r).trim = pre m r :=
begin
  refine le_antisymm (le_pre.2 $ λ s hs, _) (le_trim _),
  rw trim_eq_infi,
  refine (infi_le_of_le (closure s) $ infi_le_of_le subset_closure $
    infi_le_of_le measurable_set_closure ((pre_le _).trans_eq (hcl _))),
  rwa diam_closure
end

end mk_metric'

/-- An outer measure constructed using `outer_measure.mk_metric'` is a metric outer measure. -/
lemma mk_metric'_is_metric (m : set X → ℝ≥0∞) :
  (mk_metric' m).is_metric :=
begin
  rintros s t ⟨r, r0, hr⟩,
  refine tendsto_nhds_unique_of_eventually_eq
    (mk_metric'.tendsto_pre _ _)
    ((mk_metric'.tendsto_pre _ _).add (mk_metric'.tendsto_pre _ _)) _,
  rw [← pos_iff_ne_zero] at r0,
  filter_upwards [Ioo_mem_nhds_within_Ioi ⟨le_rfl, r0⟩],
  rintro ε ⟨ε0, εr⟩,
  refine bounded_by_union_of_top_of_nonempty_inter _,
  rintro u ⟨x, hxs, hxu⟩ ⟨y, hyt, hyu⟩,
  have : ε < diam u, from εr.trans_le ((hr x hxs y hyt).trans $ edist_le_diam_of_mem hxu hyu),
  exact infi_eq_top.2 (λ h, (this.not_le h).elim)
end

/-- If `c ∉ {0, ∞}` and `m₁ d ≤ c * m₂ d` for `0 < d < ε` for some `ε > 0`
(we use `≤ᶠ[𝓝[Ioi 0]]` to state this), then `mk_metric m₁ hm₁ ≤ c • mk_metric m₂ hm₂`. -/
lemma mk_metric_mono_smul {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} {c : ℝ≥0∞} (hc : c ≠ ∞) (h0 : c ≠ 0)
  (hle : m₁ ≤ᶠ[𝓝[Ioi 0] 0] c • m₂) :
  (mk_metric m₁ : outer_measure X) ≤ c • mk_metric m₂ :=
begin
  classical,
  rcases (mem_nhds_within_Ioi_iff_exists_Ioo_subset' ennreal.zero_lt_one).1 hle with ⟨r, hr0, hr⟩,
  refine λ s, le_of_tendsto_of_tendsto (mk_metric'.tendsto_pre _ s)
    (ennreal.tendsto.const_mul (mk_metric'.tendsto_pre _ s) (or.inr hc))
    (mem_of_superset (Ioo_mem_nhds_within_Ioi ⟨le_rfl, hr0⟩) (λ r' hr', _)),
  simp only [mem_set_of_eq, mk_metric'.pre],
  rw [← smul_apply, smul_bounded_by hc],
  refine le_bounded_by.2 (λ t, (bounded_by_le _).trans _) _,
  simp only [smul_eq_mul, pi.smul_apply, extend, infi_eq_if],
  split_ifs with ht ht,
  { refine supr_le (λ ht₁, _),
    rw [supr_eq_if, if_pos ht₁],
    refine hr ⟨_, ht.trans_lt hr'.2⟩,
    exact pos_iff_ne_zero.2 (mt diam_eq_zero_iff.1 ht₁) },
  { simp [h0] }
end

/-- If `m₁ d ≤ m₂ d` for `0 < d < ε` for some `ε > 0` (we use `≤ᶠ[𝓝[Ioi 0]]` to state this), then
`mk_metric m₁ hm₁ ≤ mk_metric m₂ hm₂`-/
lemma mk_metric_mono {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} (hle : m₁ ≤ᶠ[𝓝[Ioi 0] 0] m₂) :
  (mk_metric m₁ : outer_measure X) ≤ mk_metric m₂ :=
by { convert mk_metric_mono_smul ennreal.one_ne_top ennreal.zero_lt_one.ne' _; simp * }

lemma isometry_comap_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) {f : X → Y} (hf : isometry f)
  (H : monotone (λ d : {d : ℝ≥0∞ | d ≠ 0}, m d) ∨ surjective f) :
  comap f (mk_metric m) = mk_metric m :=
begin
  simp only [mk_metric, mk_metric', mk_metric'.pre, induced_outer_measure, comap_supr],
  refine supr_congr id surjective_id (λ ε, supr_congr id surjective_id $ λ hε, _),
  rw comap_bounded_by _ (H.imp (λ h_mono, _) id),
  { congr' with s : 1,
    apply extend_congr,
    { simp [hf.ediam_image] },
    { intros, simp [hf.injective.subsingleton_image_iff, hf.ediam_image] } },
  { refine λ s t hst, infi_le_infi2 (λ ht, ⟨(diam_mono hst).trans ht, supr_le $ λ hs, _⟩),
    have ht : ¬(t : set Y).subsingleton, from λ ht, hs (ht.mono hst),
    refine (@h_mono ⟨_, mt diam_eq_zero_iff.1 hs⟩ ⟨_, mt diam_eq_zero_iff.1 ht⟩
      (diam_mono hst)).trans _,
    exact le_supr (λ h : ¬(t : set Y).subsingleton, m (diam (t : set Y))) ht }
end

lemma isometry_map_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) {f : X → Y} (hf : isometry f)
  (H : monotone (λ d : {d : ℝ≥0∞ | d ≠ 0}, m d) ∨ surjective f) :
  map f (mk_metric m) = restrict (range f) (mk_metric m) :=
by rw [← isometry_comap_mk_metric _ hf H, map_comap]

lemma isometric_comap_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (f : X ≃ᵢ Y) :
  comap f (mk_metric m) = mk_metric m :=
isometry_comap_mk_metric _ f.isometry (or.inr f.surjective)

lemma isometric_map_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (f : X ≃ᵢ Y) :
  map f (mk_metric m) = mk_metric m :=
by rw [← isometric_comap_mk_metric _ f, map_comap_of_surjective f.surjective]

lemma trim_mk_metric [measurable_space X] [borel_space X] (m : ℝ≥0∞ → ℝ≥0∞) :
  (mk_metric m : outer_measure X).trim = mk_metric m :=
begin
  simp only [mk_metric, mk_metric'.eq_supr_nat, trim_supr],
  congr' 1 with n : 1,
  refine mk_metric'.trim_pre _ (λ s, _) _,
  simp
end

lemma le_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (μ : outer_measure X) (hμ : ∀ x, μ {x} = 0)
  (r : ℝ≥0∞) (h0 : 0 < r) (hr : ∀ s, diam s ≤ r → ¬s.subsingleton → μ s ≤ m (diam s)) :
  μ ≤ mk_metric m :=
le_bsupr_of_le r h0 $ mk_metric'.le_pre.2 $ λ s hs,
  begin
    by_cases h : s.subsingleton,
    exacts [h.induction_on (μ.empty'.trans_le (zero_le _)) (λ x, ((hμ x).trans_le (zero_le _))),
      le_supr_of_le h (hr _ hs h)]
  end

end outer_measure

/-!
### Metric measures

In this section we use `measure_theory.outer_measure.to_measure` and theorems about
`measure_theory.outer_measure.mk_metric'`/`measure_theory.outer_measure.mk_metric` to define
`measure_theory.measure.mk_metric'`/`measure_theory.measure.mk_metric`. We also restate some lemmas
about metric outer measures for metric measures.
-/

namespace measure

variables [measurable_space X] [borel_space X]

/-- Given a function `m : set X → ℝ≥0∞`, `mk_metric' m` is the supremum of `μ r`
over `r > 0`, where `μ r` is the maximal outer measure `μ` such that `μ s ≤ m s`
for all `s`. While each `μ r` is an *outer* measure, the supremum is a measure. -/
def mk_metric' (m : set X → ℝ≥0∞) : measure X :=
(outer_measure.mk_metric' m).to_measure (outer_measure.mk_metric'_is_metric _).le_caratheodory

/-- Given a function `m : ℝ≥0∞ → ℝ≥0∞`, `mk_metric m` is the supremum of `μ r` over `r > 0`, where
`μ r` is the maximal outer measure `μ` such that `μ s ≤ m s` for all sets `s` that contain at least
two points. While each `mk_metric'.pre` is an *outer* measure, the supremum is a measure. -/
def mk_metric (m : ℝ≥0∞ → ℝ≥0∞) : measure X :=
(outer_measure.mk_metric m).to_measure (outer_measure.mk_metric'_is_metric _).le_caratheodory

@[simp] lemma mk_metric'_to_outer_measure (m : set X → ℝ≥0∞) :
  (mk_metric' m).to_outer_measure = (outer_measure.mk_metric' m).trim :=
rfl

@[simp] lemma mk_metric_to_outer_measure (m : ℝ≥0∞ → ℝ≥0∞) :
  (mk_metric m : measure X).to_outer_measure = outer_measure.mk_metric m :=
outer_measure.trim_mk_metric m

end measure

lemma outer_measure.coe_mk_metric [measurable_space X] [borel_space X] (m : ℝ≥0∞ → ℝ≥0∞) :
  ⇑(outer_measure.mk_metric m : outer_measure X) = measure.mk_metric m :=
by rw [← measure.mk_metric_to_outer_measure, coe_to_outer_measure]

namespace measure

variables [measurable_space X] [borel_space X]

/-- If `c ∉ {0, ∞}` and `m₁ d ≤ c * m₂ d` for `0 < d < ε` for some `ε > 0`
(we use `≤ᶠ[𝓝[Ioi 0]]` to state this), then `mk_metric m₁ hm₁ ≤ c • mk_metric m₂ hm₂`. -/
lemma mk_metric_mono_smul {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} {c : ℝ≥0∞} (hc : c ≠ ∞) (h0 : c ≠ 0)
  (hle : m₁ ≤ᶠ[𝓝[Ioi 0] 0] c • m₂) :
  (mk_metric m₁ : measure X) ≤ c • mk_metric m₂ :=
begin
  intros s hs,
  rw [← outer_measure.coe_mk_metric, coe_smul, ← outer_measure.coe_mk_metric],
  exact outer_measure.mk_metric_mono_smul hc h0 hle s
end

/-- If `m₁ d ≤ m₂ d` for `0 < d < ε` for some `ε > 0` (we use `≤ᶠ[𝓝[Ioi 0]]` to state this), then
`mk_metric m₁ hm₁ ≤ mk_metric m₂ hm₂`-/
lemma mk_metric_mono {m₁ m₂ : ℝ≥0∞ → ℝ≥0∞} (hle : m₁ ≤ᶠ[𝓝[Ioi 0] 0] m₂) :
  (mk_metric m₁ : measure X) ≤ mk_metric m₂ :=
by { convert mk_metric_mono_smul ennreal.one_ne_top ennreal.zero_lt_one.ne' _; simp * }

/-- A formula for `measure_theory.measure.mk_metric`. -/
lemma mk_metric_apply (m : ℝ≥0∞ → ℝ≥0∞) (s : set X) :
  mk_metric m s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, diam (t n) ≤ r), ∑' n, ⨆ (ht : ¬(t n).subsingleton), m (diam (t n)) :=
begin
  -- We mostly unfold the definitions but we need to switch the order of `∑'` and `⨅`
  -- and merge `(t n).nonempty` with `¬subsingleton (t n)`
  classical,
  simp only [← outer_measure.coe_mk_metric, outer_measure.mk_metric, outer_measure.mk_metric',
    outer_measure.supr_apply, outer_measure.mk_metric'.pre, outer_measure.bounded_by_apply,
    extend],
  refine supr_congr (λ r, r) surjective_id (λ r, supr_congr_Prop iff.rfl $ λ hr,
    infi_congr _ surjective_id $ λ t, infi_congr_Prop iff.rfl $ λ ht, _),
  by_cases htr : ∀ n, diam (t n) ≤ r,
  { rw [infi_eq_if, if_pos htr],
    congr' 1 with n : 1,
    simp only [infi_eq_if, htr n, id, if_true, supr_and'],
    refine supr_congr_Prop (and_iff_right_of_imp $ λ h, _) (λ _, rfl),
    contrapose! h,
    rw [not_nonempty_iff_eq_empty.1 h],
    exact subsingleton_empty },
  { rw [infi_eq_if, if_neg htr],
    push_neg at htr, rcases htr with ⟨n, hn⟩,
    refine ennreal.tsum_eq_top_of_eq_top ⟨n, _⟩,
    rw [supr_eq_if, if_pos, infi_eq_if, if_neg],
    exact hn.not_le,
    rcases diam_pos_iff.1 ((zero_le r).trans_lt hn) with ⟨x, hx, -⟩,
    exact ⟨x, hx⟩ }
end

lemma le_mk_metric (m : ℝ≥0∞ → ℝ≥0∞) (μ : measure X) [has_no_atoms μ] (ε : ℝ≥0∞) (h₀ : 0 < ε)
  (h : ∀ s : set X, diam s ≤ ε → ¬s.subsingleton → μ s ≤ m (diam s)) :
  μ ≤ mk_metric m :=
begin
  rw [← to_outer_measure_le, mk_metric_to_outer_measure],
  exact outer_measure.le_mk_metric m μ.to_outer_measure measure_singleton ε h₀ h
end

/-- To bound the Hausdorff measure (or, more generally, for a measure defined using
`measure_theory.measure.mk_metric`) of a set, one may use coverings with maximum diameter tending to
`0`, indexed by any sequence of encodable types. -/

/-- To bound the Hausdorff measure (or, more generally, for a measure defined using
`measure_theory.measure.mk_metric`) of a set, one may use coverings with maximum diameter tending to
`0`, indexed by any sequence of finite types. -/
lemma mk_metric_le_liminf_sum {β : Type*} {ι : β → Type*} [hι : ∀ n, fintype (ι n)] (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i)
  (m : ℝ≥0∞ → ℝ≥0∞) :
  mk_metric m s ≤ liminf l (λ n, ∑ i, m (diam (t n i))) :=
begin
  haveI : ∀ n, encodable (ι n), from λ n, fintype.encodable _,
  simpa only [tsum_fintype] using mk_metric_le_liminf_tsum s r hr t ht hst m,
end

/-!
### Hausdorff measure and Hausdorff dimension
-/

/-- Hausdorff measure on an (e)metric space. -/
def hausdorff_measure (d : ℝ) : measure X := mk_metric (λ r, r ^ d)

localized "notation `μH[` d `]` := measure_theory.measure.hausdorff_measure d" in measure_theory

lemma le_hausdorff_measure (d : ℝ) (μ : measure X) [has_no_atoms μ] (ε : ℝ≥0∞) (h₀ : 0 < ε)
  (h : ∀ s : set X, diam s ≤ ε → ¬s.subsingleton → μ s ≤ diam s ^ d) :
  μ ≤ μH[d] :=
le_mk_metric _ μ ε h₀ h

/-- A formula for `μH[d] s` that works for all `d`. In case of a positive `d` a simpler formula
is available as `measure_theory.measure.hausdorff_measure_apply`. -/
lemma hausdorff_measure_apply' (d : ℝ) (s : set X) :
  μH[d] s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, diam (t n) ≤ r), ∑' n, ⨆ (ht : ¬(t n).subsingleton), (diam (t n)) ^ d :=
mk_metric_apply _ _

/-- A formula for `μH[d] s` that works for all positive `d`. -/
lemma hausdorff_measure_apply {d : ℝ} (hd : 0 < d) (s : set X) :
  μH[d] s = ⨆ (r : ℝ≥0∞) (hr : 0 < r), ⨅ (t : ℕ → set X) (hts : s ⊆ ⋃ n, t n)
    (ht : ∀ n, diam (t n) ≤ r), ∑' n, diam (t n) ^ d :=
begin
  classical,
  rw hausdorff_measure_apply',
  -- I wish `congr'` was able to generate this
  refine supr_congr id surjective_id (λ r, supr_congr_Prop iff.rfl $ λ hr,
    infi_congr id surjective_id $ λ t, infi_congr_Prop iff.rfl $ λ hts,
    infi_congr_Prop iff.rfl $ λ ht, tsum_congr $ λ n, _),
  rw [supr_eq_if], split_ifs with ht',
  { erw [diam_eq_zero_iff.2 ht', ennreal.zero_rpow_of_pos hd, ennreal.bot_eq_zero] },
  { refl }
end

/-- To bound the Hausdorff measure of a set, one may use coverings with maximum diameter tending
to `0`, indexed by any sequence of encodable types. -/
lemma hausdorff_measure_le_liminf_tsum {β : Type*}  {ι : β → Type*} [hι : ∀ n, encodable (ι n)]
  (d : ℝ) (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i) :
  μH[d] s ≤ liminf l (λ n, ∑' i, diam (t n i) ^ d) :=
mk_metric_le_liminf_tsum s r hr t ht hst _

/-- To bound the Hausdorff measure of a set, one may use coverings with maximum diameter tending
to `0`, indexed by any sequence of finite types. -/
lemma hausdorff_measure_le_liminf_sum {β : Type*}  {ι : β → Type*} [hι : ∀ n, fintype (ι n)]
  (d : ℝ) (s : set X)
  {l : filter β} (r : β → ℝ≥0∞) (hr : tendsto r l (𝓝 0)) (t : Π (n : β), ι n → set X)
  (ht : ∀ᶠ n in l, ∀ i, diam (t n i) ≤ r n) (hst : ∀ᶠ n in l, s ⊆ ⋃ i, t n i) :
  μH[d] s ≤ liminf l (λ n, ∑ i, diam (t n i) ^ d) :=
mk_metric_le_liminf_sum s r hr t ht hst _

/-- If `d₁ < d₂`, then for any set `s` we have either `μH[d₂] s = 0`, or `μH[d₁] s = ∞`. -/
lemma hausdorff_measure_zero_or_top {d₁ d₂ : ℝ} (h : d₁ < d₂) (s : set X) :
  μH[d₂] s = 0 ∨ μH[d₁] s = ∞ :=
begin
  by_contra H, push_neg at H,
  suffices : ∀ (c : ℝ≥0), c ≠ 0 → μH[d₂] s ≤ c * μH[d₁] s,
  { rcases ennreal.exists_nnreal_pos_mul_lt H.2 H.1 with ⟨c, hc0, hc⟩,
    exact hc.not_le (this c (pos_iff_ne_zero.1 hc0)) },
  intros c hc,
  refine le_iff'.1 (mk_metric_mono_smul ennreal.coe_ne_top (by exact_mod_cast hc) _) s,
  have : 0 <  (c ^ (d₂ - d₁)⁻¹ : ℝ≥0∞),
  { rw [ennreal.coe_rpow_of_ne_zero hc, pos_iff_ne_zero, ne.def, ennreal.coe_eq_zero,
      nnreal.rpow_eq_zero_iff],
    exact mt and.left hc },
  filter_upwards [Ioo_mem_nhds_within_Ioi ⟨le_rfl, this⟩],
  rintro r ⟨hr₀, hrc⟩,
  lift r to ℝ≥0 using ne_top_of_lt hrc,
  rw [pi.smul_apply, smul_eq_mul, ← ennreal.div_le_iff_le_mul (or.inr ennreal.coe_ne_top)
    (or.inr $ mt ennreal.coe_eq_zero.1 hc), ← ennreal.rpow_sub _ _ hr₀.ne' ennreal.coe_ne_top],
  refine (ennreal.rpow_lt_rpow hrc (sub_pos.2 h)).le.trans _,
  rw [← ennreal.rpow_mul, inv_mul_cancel (sub_pos.2 h).ne', ennreal.rpow_one],
  exact le_rfl
end

/-- Hausdorff measure `μH[d] s` is monotone in `d`. -/
lemma hausdorff_measure_mono {d₁ d₂ : ℝ} (h : d₁ ≤ d₂) (s : set X) : μH[d₂] s ≤ μH[d₁] s :=
begin
  rcases h.eq_or_lt with rfl|h, { exact le_rfl },
  cases hausdorff_measure_zero_or_top h s with hs hs,
  { rw hs, exact zero_le _ },
  { rw hs, exact le_top }
end

instance no_atoms_hausdorff (d : ℝ) : has_no_atoms (hausdorff_measure d : measure X) :=
begin
  refine ⟨λ x, _⟩,
  rw [← nonpos_iff_eq_zero, hausdorff_measure_apply'],
  refine bsupr_le (λ ε ε0, binfi_le_of_le (λ n, {x}) _ (infi_le_of_le (λ n, _) _)),
  { exact subset_Union (λ n, {x} : ℕ → set X) 0 },
  { simp only [emetric.diam_singleton, zero_le] },
  { simp }
end

end measure

open_locale measure_theory
open measure

/-!
### Hausdorff measure and Lebesgue measure
-/

/-- In the space `ι → ℝ`, Hausdorff measure coincides exactly with Lebesgue measure. -/
@[simp] theorem hausdorff_measure_pi_real {ι : Type*} [fintype ι] [nonempty ι] :
  (μH[fintype.card ι] : measure (ι → ℝ)) = volume :=
begin
  classical,
  -- it suffices to check that the two measures coincide on products of rational intervals
  refine (pi_eq_generate_from (λ i, real.borel_eq_generate_from_Ioo_rat.symm)
    (λ i, real.is_pi_system_Ioo_rat) (λ i, real.finite_spanning_sets_in_Ioo_rat _)
    _).symm,
  simp only [mem_Union, mem_singleton_iff],
  -- fix such a product `s` of rational intervals, of the form `Π (a i, b i)`.
  intros s hs,
  choose a b H using hs,
  obtain rfl : s = λ i, Ioo (a i) (b i), from funext (λ i, (H i).2), replace H := λ i, (H i).1,
  apply le_antisymm _,
  -- first check that `volume s ≤ μH s`
  { have Hle : volume ≤ (μH[fintype.card ι] : measure (ι → ℝ)),
    { refine le_hausdorff_measure _ _ ∞ ennreal.coe_lt_top (λ s h₁ h₂, _),
      rw [ennreal.rpow_nat_cast],
      exact real.volume_pi_le_diam_pow s },
    rw [← volume_pi_pi (λ i, Ioo (a i : ℝ) (b i))],
    exact measure.le_iff'.1 Hle _ },
  /- For the other inequality `μH s ≤ volume s`, we use a covering of `s` by sets of small diameter
  `1/n`, namely cubes with left-most point of the form `a i + f i / n` with `f i` ranging between
  `0` and `⌈(b i - a i) * n⌉`. Their number is asymptotic to `n^d * Π (b i - a i)`. -/
  have I : ∀ i, 0 ≤ (b i : ℝ) - a i := λ i, by simpa only [sub_nonneg, rat.cast_le] using (H i).le,
  let γ := λ (n : ℕ), (Π (i : ι), fin ⌈((b i : ℝ) - a i) * n⌉₊),
  let t : Π (n : ℕ), γ n → set (ι → ℝ) :=
    λ n f, set.pi univ (λ i, Icc (a i + f i / n) (a i + (f i + 1) / n)),
  have A : tendsto (λ (n : ℕ), 1/(n : ℝ≥0∞)) at_top (𝓝 0),
    by simp only [one_div, ennreal.tendsto_inv_nat_nhds_zero],
  have B : ∀ᶠ n in at_top, ∀ (i : γ n), diam (t n i) ≤ 1 / n,
  { apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
    assume f,
    apply diam_pi_le_of_le (λ b, _),
    simp only [real.ediam_Icc, add_div, ennreal.of_real_div_of_pos (nat.cast_pos.mpr hn), le_refl,
      add_sub_add_left_eq_sub, add_sub_cancel', ennreal.of_real_one, ennreal.of_real_coe_nat] },
  have C : ∀ᶠ n in at_top, set.pi univ (λ (i : ι), Ioo (a i : ℝ) (b i)) ⊆ ⋃ (i : γ n), t n i,
  { apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
    have npos : (0 : ℝ) < n := nat.cast_pos.2 hn,
    assume x hx,
    simp only [mem_Ioo, mem_univ_pi] at hx,
    simp only [mem_Union, mem_Ioo, mem_univ_pi, coe_coe],
    let f : γ n := λ i, ⟨⌊(x i - a i) * n⌋₊,
    begin
      apply nat.floor_lt_ceil_of_lt_of_pos,
      { refine (mul_lt_mul_right npos).2 _,
        simp only [(hx i).right, sub_lt_sub_iff_right] },
      { refine mul_pos _ npos,
        simpa only [rat.cast_lt, sub_pos] using H i }
    end⟩,
    refine ⟨f, λ i, ⟨_, _⟩⟩,
    { calc (a i : ℝ) + ⌊(x i - a i) * n⌋₊ / n
      ≤ (a i : ℝ) + ((x i - a i) * n) / n :
          begin
            refine add_le_add le_rfl ((div_le_div_right npos).2 _),
            exact nat.floor_le (mul_nonneg (sub_nonneg.2 (hx i).1.le) npos.le),
          end
      ... = x i : by field_simp [npos.ne'] },
    { calc x i
      = (a i : ℝ) + ((x i - a i) * n) / n : by field_simp [npos.ne']
      ... ≤ (a i : ℝ) + (⌊(x i - a i) * n⌋₊ + 1) / n :
        add_le_add le_rfl ((div_le_div_right npos).2 (nat.lt_floor_add_one _).le) } },
  calc μH[fintype.card ι] (set.pi univ (λ (i : ι), Ioo (a i : ℝ) (b i)))
    ≤ liminf at_top (λ (n : ℕ), ∑ (i : γ n), diam (t n i) ^ ↑(fintype.card ι)) :
      hausdorff_measure_le_liminf_sum _ (set.pi univ (λ i, Ioo (a i : ℝ) (b i)))
        (λ (n : ℕ), 1/(n : ℝ≥0∞)) A t B C
  ... ≤ liminf at_top (λ (n : ℕ), ∑ (i : γ n), (1/n) ^ (fintype.card ι)) :
    begin
      refine liminf_le_liminf _ (by is_bounded_default),
      filter_upwards [B],
      assume n hn,
      apply finset.sum_le_sum (λ i _, _),
      rw ennreal.rpow_nat_cast,
      exact pow_le_pow_of_le_left' (hn i) _,
    end
  ... = liminf at_top (λ (n : ℕ), ∏ (i : ι), (⌈((b i : ℝ) - a i) * n⌉₊ : ℝ≥0∞) / n) :
  begin
    simp only [finset.card_univ, nat.cast_prod, one_mul, fintype.card_fin,
      finset.sum_const, nsmul_eq_mul, fintype.card_pi, div_eq_mul_inv, finset.prod_mul_distrib,
      finset.prod_const]
  end
  ... = ∏ (i : ι), volume (Ioo (a i : ℝ) (b i)) :
  begin
    simp only [real.volume_Ioo],
    apply tendsto.liminf_eq,
    refine ennreal.tendsto_finset_prod_of_ne_top _ (λ i hi, _) (λ i hi, _),
    { apply tendsto.congr' _ ((ennreal.continuous_of_real.tendsto _).comp
        ((tendsto_nat_ceil_mul_div_at_top (I i)).comp tendsto_coe_nat_at_top_at_top)),
      apply eventually_at_top.2 ⟨1, λ n hn, _⟩,
      simp only [ennreal.of_real_div_of_pos (nat.cast_pos.mpr hn), comp_app,
        ennreal.of_real_coe_nat] },
    { simp only [ennreal.of_real_ne_top, ne.def, not_false_iff] }
  end
end

end measure_theory

/-!
### Hausdorff measure, Hausdorff dimension, and Hölder or Lipschitz continuous maps
-/

open_locale measure_theory
open measure_theory measure_theory.measure

variables [measurable_space X] [borel_space X] [measurable_space Y] [borel_space Y]

namespace holder_on_with

variables {C r : ℝ≥0} {f : X → Y} {s t : set X}

/-- If `f : X → Y` is Hölder continuous on `s` with a positive exponent `r`, then
`μH[d] (f '' s) ≤ C ^ d * μH[r * d] s`. -/
lemma hausdorff_measure_image_le (h : holder_on_with C r f s) (hr : 0 < r) {d : ℝ} (hd : 0 ≤ d) :
  μH[d] (f '' s) ≤ C ^ d * μH[r * d] s :=
begin
  -- We start with the trivial case `C = 0`
  rcases (zero_le C).eq_or_lt with rfl|hC0,
  { have : (f '' s).subsingleton, by simpa [diam_eq_zero_iff] using h.ediam_image_le,
    rw this.measure_zero,
    exact zero_le _ },
  { have hCd0 : (C : ℝ≥0∞) ^ d ≠ 0, by simp [hC0.ne'],
    have hCd : (C : ℝ≥0∞) ^ d ≠ ∞, by simp [hd],
    simp only [hausdorff_measure_apply', ennreal.mul_supr, ennreal.mul_infi_of_ne hCd0 hCd,
      ← ennreal.tsum_mul_left],
    refine supr_le (λ R, supr_le $ λ hR, _),
    have : tendsto (λ d : ℝ≥0∞, (C : ℝ≥0∞) * d ^ (r : ℝ)) (𝓝 0) (𝓝 0),
      from ennreal.tendsto_const_mul_rpow_nhds_zero_of_pos ennreal.coe_ne_top hr,
    rcases ennreal.nhds_zero_basis_Iic.eventually_iff.1 (this.eventually (gt_mem_nhds hR))
      with ⟨δ, δ0, H⟩,
    refine le_supr_of_le δ (le_supr_of_le δ0 $ le_binfi $ λ t hst, le_infi $ λ htδ, _),
    refine binfi_le_of_le (λ n, f '' (t n ∩ s)) _ (infi_le_of_le (λ n, _) _),
    { rw [← image_Union, ← Union_inter],
      exact image_subset _ (subset_inter hst subset.rfl) },
    { exact (h.ediam_image_inter_le (t n)).trans (H (htδ n)).le },
    { refine ennreal.tsum_le_tsum (λ n, supr_le $ λ hft,
        le_supr_of_le (λ ht, hft $ (ht.mono (inter_subset_left _ _)).image f) _),
      rw [ennreal.rpow_mul, ← ennreal.mul_rpow_of_nonneg _ _ hd],
      exact ennreal.rpow_le_rpow (h.ediam_image_inter_le _) hd } }
end

end holder_on_with

namespace lipschitz_on_with

variables {K : ℝ≥0} {f : X → Y} {s t : set X}

/-- If `f : X → Y` is `K`-Lipschitz on `s`, then `μH[d] (f '' s) ≤ K ^ d * μH[d] s`. -/
lemma hausdorff_measure_image_le (h : lipschitz_on_with K f s) {d : ℝ} (hd : 0 ≤ d) :
  μH[d] (f '' s) ≤ K ^ d * μH[d] s :=
by simpa only [nnreal.coe_one, one_mul]
  using h.holder_on_with.hausdorff_measure_image_le zero_lt_one hd

end lipschitz_on_with

namespace lipschitz_with

variables {K : ℝ≥0} {f : X → Y}

/-- If `f` is a `K`-Lipschitz map, then it increases the Hausdorff `d`-measures of sets at most
by the factor of `K ^ d`.-/
lemma hausdorff_measure_image_le (h : lipschitz_with K f) {d : ℝ} (hd : 0 ≤ d) (s : set X) :
  μH[d] (f '' s) ≤ K ^ d * μH[d] s :=
(h.lipschitz_on_with s).hausdorff_measure_image_le hd

end lipschitz_with

/-!
### Antilipschitz maps do not decrease Hausdorff measures and dimension
-/

namespace antilipschitz_with

variables {f : X → Y} {K : ℝ≥0} {d : ℝ}

lemma hausdorff_measure_preimage_le (hf : antilipschitz_with K f) (hd : 0 ≤ d) (s : set Y) :
  μH[d] (f ⁻¹' s) ≤ K ^ d * μH[d] s :=
begin
  rcases eq_or_ne K 0 with rfl|h0,
  { haveI : subsingleton X := hf.subsingleton,
    have : (f ⁻¹' s).subsingleton, from subsingleton_univ.mono (subset_univ _),
    rw this.measure_zero,
    exact zero_le _ },
  have hKd0 : (K : ℝ≥0∞) ^ d ≠ 0, by simp [h0],
  have hKd : (K : ℝ≥0∞) ^ d ≠ ∞, by simp [hd],
  simp only [hausdorff_measure_apply', ennreal.mul_supr, ennreal.mul_infi_of_ne hKd0 hKd,
    ← ennreal.tsum_mul_left],
  refine bsupr_le (λ ε ε0, _),
  refine le_bsupr_of_le (ε / K) (by simp [ε0.ne']) _,
  refine le_binfi (λ t hst, le_infi $ λ htε, _),
  replace hst : f ⁻¹' s ⊆ _ := preimage_mono hst, rw preimage_Union at hst,
  refine binfi_le_of_le _ hst (infi_le_of_le (λ n, _) _),
  { exact (hf.ediam_preimage_le _).trans (ennreal.mul_le_of_le_div' $ htε n) },
  { refine ennreal.tsum_le_tsum (λ n, supr_le $
      λ H, le_supr_of_le (λ h, H $ h.preimage hf.injective) _),
    rw [← ennreal.mul_rpow_of_nonneg _ _ hd],
    exact ennreal.rpow_le_rpow (hf.ediam_preimage_le _) hd }
end

lemma le_hausdorff_measure_image (hf : antilipschitz_with K f) (hd : 0 ≤ d) (s : set X) :
  μH[d] s ≤ K ^ d * μH[d] (f '' s) :=
calc μH[d] s ≤ μH[d] (f ⁻¹' (f '' s)) : measure_mono (subset_preimage_image _ _)
         ... ≤ K ^ d * μH[d] (f '' s) : hf.hausdorff_measure_preimage_le hd (f '' s)

end antilipschitz_with

/-!
### Isometries preserve the Hausdorff measure and Hausdorff dimension
-/

namespace isometry

variables {f : X → Y} {d : ℝ}

lemma hausdorff_measure_image (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) (s : set X) :
  μH[d] (f '' s) = μH[d] s :=
begin
  simp only [hausdorff_measure, ← outer_measure.coe_mk_metric, ← outer_measure.comap_apply],
  rw [outer_measure.isometry_comap_mk_metric _ hf (hd.imp_left _)],
  exact λ hd x y hxy, ennreal.rpow_le_rpow hxy hd
end

lemma hausdorff_measure_preimage (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) (s : set Y) :
  μH[d] (f ⁻¹' s) = μH[d] (s ∩ range f) :=
by rw [← hf.hausdorff_measure_image hd, image_preimage_eq_inter_range]

lemma map_hausdorff_measure (hf : isometry f) (hd : 0 ≤ d ∨ surjective f) :
  measure.map f μH[d] = (μH[d]).restrict (range f) :=
begin
  ext1 s hs,
  rw [map_apply hf.continuous.measurable hs, restrict_apply hs, hf.hausdorff_measure_preimage hd]
end

end isometry

namespace isometric

@[simp] lemma hausdorff_measure_image (e : X ≃ᵢ Y) (d : ℝ) (s : set X) :
  μH[d] (e '' s) = μH[d] s :=
e.isometry.hausdorff_measure_image (or.inr e.surjective) s

@[simp] lemma hausdorff_measure_preimage (e : X ≃ᵢ Y) (d : ℝ) (s : set Y) :
  μH[d] (e ⁻¹' s) = μH[d] s :=
by rw [← e.image_symm, e.symm.hausdorff_measure_image]

end isometric


theorem Nat.ne_of_gt {a b : Nat} (h : a < b) : b ≠ a := sorry
theorem Nat.lt_succ_iff {m n : Nat} : m < succ n ↔ m ≤ n := sorry

variable (n v₁ v₂) (hv₁: v₁ < n + 1) (hv₂: v₂ < n + 1)
theorem foo (_: ¬ Fin.mk v₂ hv₂ = Fin.mk v₁ hv₁ ): True := trivial
set_option trace.Meta.Tactic.simp true in
example (hv: v₁ < v₂) : True := foo n v₁ v₂ ‹_› ‹_› (by simp only[hv, Fin.mk.injEq, Nat.ne_of_gt, Nat.lt_succ_iff])

#check Fin.mk.injEq


/-
Copyright (c) 2020 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/
import topology.continuous_function.algebra
import linear_algebra.affine_space.affine_map

/-!
# Topological properties of affine spaces and maps

For now, this contains only a few facts regarding the continuity of affine maps in the special
case when the point space and vector space are the same.
-/

variables {R E F : Type*}
  [ring R]
  [add_comm_group E] [module R E] [topological_space E]
  [add_comm_group F] [module R F] [topological_space F] [topological_add_group F]

namespace affine_map

/-
TODO: Deal with the case where the point spaces are different from the vector spaces.
-/

/-- An affine map is continuous iff its underlying linear map is continuous. -/
lemma continuous_iff {f : E →ᵃ[R] F} :
  continuous f ↔ continuous f.linear :=
begin
  split,
  { intro hc,
    rw decomp' f,
    have := hc.sub continuous_const,
    exact this, },
  { intro hc,
    rw decomp f,
    have := hc.add continuous_const,
    exact this }
end

/-- The line map is continuous. -/
@[continuity]
lemma line_map_continuous [topological_space R] [has_continuous_smul R F] {p v : F} :
  continuous ⇑(line_map p v : R →ᵃ[R] F) :=
continuous_iff.mpr $ (continuous_id.smul continuous_const).add $
  @continuous_const _ _ _ _ (0 : F)

end affine_map


import tactic

-- monoidy a submonoidy : prvy den experimentov
-- ignoroval som vacsinu toho co uz je implementovane

-- skusil som spravit z konkretneho submonoidu neparnych cisel subtyp
-- monoidu (nat,*,1) a potom som na nom implementoval monoidovu strukturu

-- monoid je mnozina vybavena binarnou operaciou, ktora je
-- asociativna a jednotkovym prvkom ; spravim teraz
-- dvojprvkovy polozvaz S2:=({zero,one},one,⊓) holymi rukami

-- dvojprvkovy induktivny typ
inductive S2: Type
  | zero
  | one

--  ⊓   | zero | one  |
-- --------------------
-- zero | zero | zero |
-- one  | zero | one  |

#check S2.zero

-- to, ze je toto nazvane S2.mul je konvencia, nie nevyhnutnost
-- mohlo by sa to volat aj hocijako inak
-- takisto S2.monoid dolu
def S2.mul: S2 → S2 → S2
 | S2.one a := a
 | a S2.one := a
 | S2.zero S2.zero := S2.zero

-- teraz poviem, ze (S2,S2.one,S2.mul) je monoid
-- mechanizmus, ktorym sa to robi je ten,
-- ze dokazem, ze typ S2 je instanciou typeclass monoid

@[instance]
def S2.monoid : monoid S2 :=
{
  mul:= S2.mul,
  one:= S2.one,
  -- tu musim dokazat, ze ta operacia je asociativna
  -- asi by to islo lahsie tak, ze najprv dokazem
  -- jednotkove zakony a potom ich pouzijem
  mul_assoc:=
  begin
    intros a b c,
    cases a,
    cases b,
    cases c,
    refl,
    refl,
    cases c,
    refl,
    refl,
    cases b,
    cases c,
    refl,
    refl,
    cases c,
    refl,
    refl,
  end,
  -- jednotkovy zakon zlava a sprava
  one_mul:=
  begin
      intro a,
      cases a,
      refl,
      refl,
  end,
  mul_one :=
  begin
    intro a,
    cases a,
    refl,
    refl,
  end
}

-- V tomto momente je S2 pouzitelny ako monoid
-- medziinym mame aj nasobenie prvkov cez *
-- kvoli tomu, ze typeclass monoid rozsiruje typeclass has_mul
-- has_mul je typeclass, ktory zavadza binarnu operaciu
-- mul a notaciu _ * _

#check S2.zero*S2.one
#reduce S2.zero*S2.one

-- takisto mame konstantu 1, (typeclass has_one) ktora sa nam prepisuje
-- na spravny prvok typu S2

#check (1:S2)
#reduce (1:S2)

-- takisto mozeme pouzivat asociativny zakon
#check monoid.mul_assoc
#check monoid.mul_assoc S2.zero S2.one S2.zero

-- Teraz idem vyskusat, ako funguju submonoidy
-- ked sa referencuje na ℕ ako monoid, mysli sa nasobenie

-- idem vyrobit submonoid monoidu (ℕ,*,1)
-- pozostavajuci z neparnych cisel

-- submonoid je trojica
--    carrier : podmnozina monoidu
--    one_mem' : dokaz, ze jednotka monoidu patri do monoidu
--    mul_mem' : dokaz, ze submonoid je uzavrety na nasobenie

def odd_nat_submonoid: submonoid ℕ :=
  {
    carrier := {n:ℕ | odd n}, -- mnozina
    one_mem' := -- dokaz, ze jednotka patri do tej mnoziny
    begin
      simp,
      existsi 0,
      simp,
    end,
    mul_mem' := -- dokaz, ze ta mnozina je uzavreta na nasobenie
    begin
      intros a b,
      intro a_odd,
      intro b_odd,
      simp at a_odd,
      simp at b_odd,
      simp,
      cases a_odd with k,
      cases b_odd with l,
      existsi 2*k*l+k+l, -- som musel toto zratat na papieri
      rw a_odd_h,
      rw b_odd_h,
      ring, -- taktika pre okruhy (nasobenie+scitanie), usetri robotu
    end
  }

-- v mathlib je implementovana o submonoidoch cela kopa veci:
-- submonoidy monoidu tvoria poset vzhladom na inkluziu
-- prienik sumbonoidov je submonoid,
-- atd ...

--- ALE!

-- submonoid nie je monoid, nie v leane

-- teraz idem z toho submonoidu neparnych cisel vytvorit monoid

-- vytvorime subtyp (vid subtype v TPiL)

def odd_nat_subtype := {n:ℕ // n ∈ odd_nat_submonoid.carrier}

-- ten subtyp je typ struktur { val:= n:ℕ, prop:= dokaz, ze n je neparne }
-- nie je pravda, ze 3:odd_nat_subtype

-- ideme teraz pre odd_nat_subtype definovat jednotku a nasobenie

-- toto bude jednotka
@[simp]
def one_odd : odd_nat_subtype := {
  val := 1,
  property := begin -- musim dokazat, ze 1 je neparna ale to som uz robil
  exact odd_nat_submonoid.one_mem',
  end
}

-- jednotlive zlozky dvojice
#reduce one_odd.val
#reduce one_odd.property -- hmm

-- chcem este nejaky iny prvok
-- ⟨ ... ⟩ je alternativna (nepomenovana) notacia pre {...} s pomenovanymi
-- zlozkami
def three_odd : odd_nat_subtype :=
⟨ 3,
begin
  change 3∈ { n:ℕ | odd(n)}, -- toto je strasne neobratne, ako to ide lepsie?
  simp,
  existsi 1,
  ring,
end
⟩

-- teraz skusme zadefinovat nasobenie neparnych cisel aj
-- s transformaciou dokazu neparnosti
@[simp] -- zapojime do simp mechanizmu, to sa zide neskor
def odd_mul (a b:odd_nat_subtype) : odd_nat_subtype :=
  ⟨ a.val*b.val,
    begin
      have a_odd := a.property,
      have b_odd := b.property,
      apply odd_nat_submonoid.mul_mem',
      exact a_odd,
      exact b_odd,
    end
  ⟩

lemma one_mul_odd {a :odd_nat_subtype} : odd_mul one_odd a = a :=
  by simp

lemma mul_one_odd {a :odd_nat_subtype} : odd_mul a one_odd = a :=
  by simp

#reduce odd_mul one_odd one_odd
#reduce odd_mul three_odd three_odd
def odd_nine := odd_mul three_odd three_odd

#reduce odd_nine.val -- 9
#reduce odd_nine.property -- tato hodnota je extremne zaujimava ?!ODKIAL?!

-- skusme teraz vyvorit instanciu monoidu z odd_nat_subtype

@[instance] def odd_nat_monoid : monoid odd_nat_subtype :=
{
  mul:=odd_mul,
  one:=one_odd,
  mul_assoc := begin
    finish, -- toto ide kvoli tomu @[simp] atributu vyssie
  end,
  one_mul:= begin
    intro,
    have ha:= @one_mul_odd a,
    exact ha,
  end,
  mul_one:= begin
     intro,
     have ha:= @mul_one_odd a,
     exact ha,
  end
}

#reduce (odd_nine*odd_nine).val -- 81, hura!


/-
Copyright (c) 2021 Jakob von Raumer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jakob von Raumer
-/
import category_theory.monoidal.rigid.basic
import category_theory.monoidal.subcategory
import linear_algebra.tensor_product_basis
import linear_algebra.coevaluation
import algebra.category.Module.monoidal

/-!
# The category of finite dimensional vector spaces

This introduces `FinVect K`, the category of finite dimensional vector spaces over a field `K`.
It is implemented as a full subcategory on a subtype of `Module K`, which inherits monoidal and
symmetric structure as `finite_dimensional K` is a monoidal predicate.
We also provide a right rigid monoidal category instance.
-/
noncomputable theory

open category_theory Module.monoidal_category
open_locale classical big_operators

universes u

variables (K : Type u) [field K]

instance monoidal_predicate_finite_dimensional :
  monoidal_category.monoidal_predicate (λ V : Module.{u} K, finite_dimensional K V) :=
{ prop_id' := finite_dimensional.finite_dimensional_self K,
  prop_tensor' := λ X Y hX hY, by exactI module.finite.tensor_product K X Y }

/-- Define `FinVect` as the subtype of `Module.{u} K` of finite dimensional vector spaces. -/
@[derive [large_category, λ α, has_coe_to_sort α (Sort*), concrete_category, monoidal_category,
  symmetric_category]]
def FinVect := { V : Module.{u} K // finite_dimensional K V }

namespace FinVect

instance finite_dimensional (V : FinVect K) : finite_dimensional K V := V.prop

instance : inhabited (FinVect K) := ⟨⟨Module.of K K, finite_dimensional.finite_dimensional_self K⟩⟩

instance : has_coe (FinVect.{u} K) (Module.{u} K) := { coe := λ V, V.1, }

protected lemma coe_comp {U V W : FinVect K} (f : U ⟶ V) (g : V ⟶ W) :
  ((f ≫ g) : U → W) = (g : V → W) ∘ (f : U → V) := rfl

/-- Lift an unbundled vector space to `FinVect K`. -/
def of (V : Type u) [add_comm_group V] [module K V] [finite_dimensional K V] : FinVect K :=
⟨Module.of K V, by { change finite_dimensional K V, apply_instance }⟩

instance : has_forget₂ (FinVect.{u} K) (Module.{u} K) :=
by { dsimp [FinVect], apply_instance, }

instance : full (forget₂ (FinVect K) (Module.{u} K)) :=
{ preimage := λ X Y f, f, }

variables (V : FinVect K)

/-- The dual module is the dual in the rigid monoidal category `FinVect K`. -/
def FinVect_dual : FinVect K :=
⟨Module.of K (module.dual K V), subspace.module.dual.finite_dimensional⟩

instance : has_coe_to_fun (FinVect_dual K V) (λ _, V → K) :=
{ coe := λ v, by { change V →ₗ[K] K at v, exact v, } }

open category_theory.monoidal_category

/-- The coevaluation map is defined in `linear_algebra.coevaluation`. -/
def FinVect_coevaluation : 𝟙_ (FinVect K) ⟶ V ⊗ (FinVect_dual K V) :=
by apply coevaluation K V

lemma FinVect_coevaluation_apply_one : FinVect_coevaluation K V (1 : K) =
   ∑ (i : basis.of_vector_space_index K V),
    (basis.of_vector_space K V) i ⊗ₜ[K] (basis.of_vector_space K V).coord i :=
by apply coevaluation_apply_one K V

/-- The evaluation morphism is given by the contraction map. -/
def FinVect_evaluation : (FinVect_dual K V) ⊗ V ⟶ 𝟙_ (FinVect K) :=
by apply contract_left K V

@[simp]
lemma FinVect_evaluation_apply (f : (FinVect_dual K V)) (x : V) :
  (FinVect_evaluation K V) (f ⊗ₜ x) = f x :=
by apply contract_left_apply f x

private theorem coevaluation_evaluation :
  let V' : FinVect K := FinVect_dual K V in
  (𝟙 V' ⊗ (FinVect_coevaluation K V)) ≫ (α_ V' V V').inv ≫ (FinVect_evaluation K V ⊗ 𝟙 V')
  = (ρ_ V').hom ≫ (λ_ V').inv :=
by apply contract_left_assoc_coevaluation K V

private theorem evaluation_coevaluation :
  (FinVect_coevaluation K V ⊗ 𝟙 V)
  ≫ (α_ V (FinVect_dual K V) V).hom ≫ (𝟙 V ⊗ FinVect_evaluation K V)
  = (λ_ V).hom ≫ (ρ_ V).inv :=
by apply contract_left_assoc_coevaluation' K V

instance exact_pairing : exact_pairing V (FinVect_dual K V) :=
{ coevaluation := FinVect_coevaluation K V,
  evaluation := FinVect_evaluation K V,
  coevaluation_evaluation' := coevaluation_evaluation K V,
  evaluation_coevaluation' := evaluation_coevaluation K V }

instance right_dual : has_right_dual V := ⟨FinVect_dual K V⟩

instance right_rigid_category : right_rigid_category (FinVect K) := { }

variables {K V} (W : FinVect K)

/-- Converts and isomorphism in the category `FinVect` to a `linear_equiv` between the underlying
vector spaces. -/
def iso_to_linear_equiv {V W : FinVect K} (i : V ≅ W) : V ≃ₗ[K] W :=
  ((forget₂ (FinVect.{u} K) (Module.{u} K)).map_iso i).to_linear_equiv

lemma iso.conj_eq_conj {V W : FinVect K} (i : V ≅ W) (f : End V) :
  iso.conj i f = linear_equiv.conj (iso_to_linear_equiv i) f := rfl

end FinVect

variables {K}

/-- Converts a `linear_equiv` to an isomorphism in the category `FinVect`. -/
@[simps] def linear_equiv.to_FinVect_iso
  {V W : Type u} [add_comm_group V] [module K V] [finite_dimensional K V]
  [add_comm_group W] [module K W] [finite_dimensional K W]
  (e : V ≃ₗ[K] W) :
  FinVect.of K V ≅ FinVect.of K W :=
{ hom := e.to_linear_map,
  inv := e.symm.to_linear_map,
  hom_inv_id' := by {ext, exact e.left_inv x},
  inv_hom_id' := by {ext, exact e.right_inv x} }


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import algebra.algebra.subalgebra.basic
import algebra.monoid_algebra.basic

/-!
# Free Algebras

Given a commutative semiring `R`, and a type `X`, we construct the free unital, associative
`R`-algebra on `X`.

## Notation

1. `free_algebra R X` is the free algebra itself. It is endowed with an `R`-algebra structure.
2. `free_algebra.ι R` is the function `X → free_algebra R X`.
3. Given a function `f : X → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `free_algebra R X → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : free_algebra R X → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.
5. `equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X)`
6. An inductive principle `induction`.

## Implementation details

We construct the free algebra on `X` as a quotient of an inductive type `free_algebra.pre` by an
inductively defined relation `free_algebra.rel`. Explicitly, the construction involves three steps:
1. We construct an inductive type `free_algebra.pre R X`, the terms of which should be thought
  of as representatives for the elements of `free_algebra R X`.
  It is the free type with maps from `R` and `X`, and with two binary operations `add` and `mul`.
2. We construct an inductive relation `free_algebra.rel R X` on `free_algebra.pre R X`.
  This is the smallest relation for which the quotient is an `R`-algebra where addition resp.
  multiplication are induced by `add` resp. `mul` from 1., and for which the map from `R` is the
  structure map for the algebra.
3. The free algebra `free_algebra R X` is the quotient of `free_algebra.pre R X` by
  the relation `free_algebra.rel R X`.
-/

variables (R : Type*) [comm_semiring R]
variables (X : Type*)

namespace free_algebra

/--
This inductive type is used to express representatives of the free algebra.
-/
inductive pre
| of : X → pre
| of_scalar : R → pre
| add : pre → pre → pre
| mul : pre → pre → pre

namespace pre

instance : inhabited (pre R X) := ⟨of_scalar 0⟩

-- Note: These instances are only used to simplify the notation.
/-- Coercion from `X` to `pre R X`. Note: Used for notation only. -/
def has_coe_generator : has_coe X (pre R X) := ⟨of⟩
/-- Coercion from `R` to `pre R X`. Note: Used for notation only. -/
def has_coe_semiring : has_coe R (pre R X) := ⟨of_scalar⟩
/-- Multiplication in `pre R X` defined as `pre.mul`. Note: Used for notation only. -/
def has_mul : has_mul (pre R X) := ⟨mul⟩
/-- Addition in `pre R X` defined as `pre.add`. Note: Used for notation only. -/
def has_add : has_add (pre R X) := ⟨add⟩
/-- Zero in `pre R X` defined as the image of `0` from `R`. Note: Used for notation only. -/
def has_zero : has_zero (pre R X) := ⟨of_scalar 0⟩
/-- One in `pre R X` defined as the image of `1` from `R`. Note: Used for notation only. -/
def has_one : has_one (pre R X) := ⟨of_scalar 1⟩
/--
Scalar multiplication defined as multiplication by the image of elements from `R`.
Note: Used for notation only.
-/
def has_scalar : has_scalar R (pre R X) := ⟨λ r m, mul (of_scalar r) m⟩

end pre

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_scalar

/--
Given a function from `X` to an `R`-algebra `A`, `lift_fun` provides a lift of `f` to a function
from `pre R X` to `A`. This is mainly used in the construction of `free_algebra.lift`.
-/
def lift_fun {A : Type*} [semiring A] [algebra R A] (f : X → A) : pre R X → A :=
  λ t, pre.rec_on t f (algebra_map _ _) (λ _ _, (+)) (λ _ _, (*))

/--
An inductively defined relation on `pre R X` used to force the initial algebra structure on
the associated quotient.
-/
inductive rel : (pre R X) → (pre R X) → Prop
-- force `of_scalar` to be a central semiring morphism
| add_scalar {r s : R} : rel ↑(r + s) (↑r + ↑s)
| mul_scalar {r s : R} : rel ↑(r * s) (↑r * ↑s)
| central_scalar {r : R} {a : pre R X} : rel (r * a) (a * r)
-- commutative additive semigroup
| add_assoc {a b c : pre R X} : rel (a + b + c) (a + (b + c))
| add_comm {a b : pre R X} : rel (a + b) (b + a)
| zero_add {a : pre R X} : rel (0 + a) a
-- multiplicative monoid
| mul_assoc {a b c : pre R X} : rel (a * b * c) (a * (b * c))
| one_mul {a : pre R X} : rel (1 * a) a
| mul_one {a : pre R X} : rel (a * 1) a
-- distributivity
| left_distrib {a b c : pre R X} : rel (a * (b + c)) (a * b + a * c)
| right_distrib {a b c : pre R X} : rel ((a + b) * c) (a * c + b * c)
-- other relations needed for semiring
| zero_mul {a : pre R X} : rel (0 * a) 0
| mul_zero {a : pre R X} : rel (a * 0) 0
-- compatibility
| add_compat_left {a b c : pre R X} : rel a b → rel (a + c) (b + c)
| add_compat_right {a b c : pre R X} : rel a b → rel (c + a) (c + b)
| mul_compat_left {a b c : pre R X} : rel a b → rel (a * c) (b * c)
| mul_compat_right {a b c : pre R X} : rel a b → rel (c * a) (c * b)

end free_algebra

/--
The free algebra for the type `X` over the commutative semiring `R`.
-/
def free_algebra := quot (free_algebra.rel R X)

namespace free_algebra

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_scalar

instance : semiring (free_algebra R X) :=
{ add := quot.map₂ (+) (λ _ _ _, rel.add_compat_right) (λ _ _ _, rel.add_compat_left),
  add_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.add_assoc },
  zero := quot.mk _ 0,
  zero_add := by { rintro ⟨⟩, exact quot.sound rel.zero_add },
  add_zero := begin
    rintros ⟨⟩,
    change quot.mk _ _ = _,
    rw [quot.sound rel.add_comm, quot.sound rel.zero_add],
  end,
  add_comm := by { rintros ⟨⟩ ⟨⟩, exact quot.sound rel.add_comm },
  mul := quot.map₂ (*) (λ _ _ _, rel.mul_compat_right) (λ _ _ _, rel.mul_compat_left),
  mul_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.mul_assoc },
  one := quot.mk _ 1,
  one_mul := by { rintros ⟨⟩, exact quot.sound rel.one_mul },
  mul_one := by { rintros ⟨⟩, exact quot.sound rel.mul_one },
  left_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.left_distrib },
  right_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.right_distrib },
  zero_mul := by { rintros ⟨⟩, exact quot.sound rel.zero_mul },
  mul_zero := by { rintros ⟨⟩, exact quot.sound rel.mul_zero } }

instance : inhabited (free_algebra R X) := ⟨0⟩

instance : has_scalar R (free_algebra R X) :=
{ smul := λ r, quot.map ((*) ↑r) (λ a b, rel.mul_compat_right) }

instance : algebra R (free_algebra R X) :=
{ to_fun := λ r, quot.mk _ r,
  map_one' := rfl,
  map_mul' := λ _ _, quot.sound rel.mul_scalar,
  map_zero' := rfl,
  map_add' := λ _ _, quot.sound rel.add_scalar,
  commutes' := λ _, by { rintros ⟨⟩, exact quot.sound rel.central_scalar },
  smul_def' := λ _ _, rfl }

instance {S : Type*} [comm_ring S] : ring (free_algebra S X) := algebra.semiring_to_ring S

variables {X}

/--
The canonical function `X → free_algebra R X`.
-/
def ι : X → free_algebra R X := λ m, quot.mk _ m

@[simp] lemma quot_mk_eq_ι (m : X) : quot.mk (free_algebra.rel R X) m = ι R m := rfl

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

/-- Internal definition used to define `lift` -/
private def lift_aux (f : X → A) : (free_algebra R X →ₐ[R] A) :=
{ to_fun := λ a, quot.lift_on a (lift_fun _ _ f) $ λ a b h,
  begin
    induction h,
    { exact (algebra_map R A).map_add h_r h_s, },
    { exact (algebra_map R A).map_mul h_r h_s },
    { apply algebra.commutes },
    { change _ + _ + _ = _ + (_ + _),
      rw add_assoc },
    { change _ + _ = _ + _,
      rw add_comm, },
    { change (algebra_map _ _ _) + lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change _ * _ * _ = _ * (_ * _),
      rw mul_assoc },
    { change (algebra_map _ _ _) * lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change lift_fun R X f _ * (algebra_map _ _ _) = lift_fun R X f _,
      simp, },
    { change _ * (_ + _) = _ * _ + _ * _,
      rw left_distrib, },
    { change (_ + _) * _ = _ * _ + _ * _,
      rw right_distrib, },
    { change (algebra_map _ _ _) * _ = algebra_map _ _ _,
      simp },
    { change _ * (algebra_map _ _ _) = algebra_map _ _ _,
      simp },
    repeat { change lift_fun R X f _ + lift_fun R X f _ = _,
      rw h_ih,
      refl, },
    repeat { change lift_fun R X f _ * lift_fun R X f _ = _,
      rw h_ih,
      refl, },
  end,
  map_one' := by { change algebra_map _ _ _ = _, simp },
  map_mul' := by { rintros ⟨⟩ ⟨⟩, refl },
  map_zero' := by { change algebra_map _ _ _ = _, simp },
  map_add' := by { rintros ⟨⟩ ⟨⟩, refl },
  commutes' := by tauto }

/--
Given a function `f : X → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `free_algebra R X → A`.
-/
def lift : (X → A) ≃ (free_algebra R X →ₐ[R] A) :=
{ to_fun := lift_aux R,
  inv_fun := λ F, F ∘ (ι R),
  left_inv := λ f, by {ext, refl},
  right_inv := λ F, by
  { ext x,
    rcases x,
    induction x,
    case pre.of :
    { change ((F : free_algebra R X → A) ∘ (ι R)) _ = _,
      refl },
    case pre.of_scalar :
    { change algebra_map _ _ x = F (algebra_map _ _ x),
      rw alg_hom.commutes F x, },
    case pre.add : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ + quot.mk _ _) = F (quot.mk _ _ + quot.mk _ _),
      rw [alg_hom.map_add, alg_hom.map_add, ha, hb], },
    case pre.mul : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ * quot.mk _ _) = F (quot.mk _ _ * quot.mk _ _),
      rw [alg_hom.map_mul, alg_hom.map_mul, ha, hb], }, }, }

@[simp] lemma lift_aux_eq (f : X → A) : lift_aux R f = lift R f := rfl

@[simp]
lemma lift_symm_apply (F : free_algebra R X →ₐ[R] A) : (lift R).symm F = F ∘ (ι R) := rfl

variables {R X}

@[simp]
theorem ι_comp_lift (f : X → A) :
  (lift R f : free_algebra R X → A) ∘ (ι R) = f := by {ext, refl}

@[simp]
theorem lift_ι_apply (f : X → A) (x) :
  lift R f (ι R x) = f x := rfl

@[simp]
theorem lift_unique (f : X → A) (g : free_algebra R X →ₐ[R] A) :
  (g : free_algebra R X → A) ∘ (ι R) = f ↔ g = lift R f :=
(lift R).symm_apply_eq

/-!
At this stage we set the basic definitions as `@[irreducible]`, so from this point onwards one
should only use the universal properties of the free algebra, and consider the actual implementation
as a quotient of an inductive type as completely hidden.

Of course, one still has the option to locally make these definitions `semireducible` if so desired,
and Lean is still willing in some circumstances to do unification based on the underlying
definition.
-/
attribute [irreducible] ι lift
-- Marking `free_algebra` irreducible makes `ring` instances inaccessible on quotients.
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241
-- For now, we avoid this by not marking it irreducible.

@[simp]
theorem lift_comp_ι (g : free_algebra R X →ₐ[R] A) :
  lift R ((g : free_algebra R X → A) ∘ (ι R)) = g :=
by { rw ←lift_symm_apply, exact (lift R).apply_symm_apply g }

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {f g : free_algebra R X →ₐ[R] A}
  (w : ((f : free_algebra R X → A) ∘ (ι R)) = ((g : free_algebra R X → A) ∘ (ι R))) : f = g :=
begin
  rw [←lift_symm_apply, ←lift_symm_apply] at w,
  exact (lift R).symm.injective w,
end

/--
The free algebra on `X` is "just" the monoid algebra on the free monoid on `X`.

This would be useful when constructing linear maps out of a free algebra,
for example.
-/
noncomputable
def equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X) :=
alg_equiv.of_alg_hom
  (lift R (λ x, (monoid_algebra.of R (free_monoid X)) (free_monoid.of x)))
  ((monoid_algebra.lift R (free_monoid X) (free_algebra R X)) (free_monoid.lift (ι R)))
begin
  apply monoid_algebra.alg_hom_ext, intro x,
  apply free_monoid.rec_on x,
  { simp, refl, },
  { intros x y ih, simp at ih, simp [ih], }
end
(by { ext, simp, })

instance [nontrivial R] : nontrivial (free_algebra R X) :=
equiv_monoid_algebra_free_monoid.surjective.nontrivial

section
open_locale classical

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv : free_algebra R X →ₐ[R] R :=
lift R (0 : X → R)

lemma algebra_map_left_inverse :
  function.left_inverse algebra_map_inv (algebra_map R $ free_algebra R X) :=
λ x, by simp [algebra_map_inv]

@[simp] lemma algebra_map_inj (x y : R) :
  algebra_map R (free_algebra R X) x = algebra_map R (free_algebra R X) y ↔ x = y :=
algebra_map_left_inverse.injective.eq_iff

@[simp] lemma algebra_map_eq_zero_iff (x : R) : algebra_map R (free_algebra R X) x = 0 ↔ x = 0 :=
map_eq_zero_iff (algebra_map _ _) algebra_map_left_inverse.injective

@[simp] lemma algebra_map_eq_one_iff (x : R) : algebra_map R (free_algebra R X) x = 1 ↔ x = 1 :=
map_eq_one_iff (algebra_map _ _) algebra_map_left_inverse.injective

-- this proof is copied from the approach in `free_abelian_group.of_injective`
lemma ι_injective [nontrivial R] : function.injective (ι R : X → free_algebra R X) :=
λ x y hoxy, classical.by_contradiction $ assume hxy : x ≠ y,
  let f : free_algebra R X →ₐ[R] R := lift R (λ z, if x = z then (1 : R) else 0) in
  have hfx1 : f (ι R x) = 1, from (lift_ι_apply _ _).trans $ if_pos rfl,
  have hfy1 : f (ι R y) = 1, from hoxy ▸ hfx1,
  have hfy0 : f (ι R y) = 0, from (lift_ι_apply _ _).trans $ if_neg hxy,
  one_ne_zero $ hfy1.symm.trans hfy0

@[simp] lemma ι_inj [nontrivial R] (x y : X) : ι R x = ι R y ↔ x = y :=
ι_injective.eq_iff

@[simp] lemma ι_ne_algebra_map [nontrivial R] (x : X) (r : R) : ι R x ≠ algebra_map R _ r :=
λ h,
  let f0 : free_algebra R X →ₐ[R] R := lift R 0 in
  let f1 : free_algebra R X →ₐ[R] R := lift R 1 in
  have hf0 : f0 (ι R x) = 0, from lift_ι_apply _ _,
  have hf1 : f1 (ι R x) = 1, from lift_ι_apply _ _,
  begin
    rw [h, f0.commutes, algebra.id.map_eq_self] at hf0,
    rw [h, f1.commutes, algebra.id.map_eq_self] at hf1,
    exact zero_ne_one (hf0.symm.trans hf1),
  end

@[simp] lemma ι_ne_zero [nontrivial R] (x : X) : ι R x ≠ 0 :=
ι_ne_algebra_map x 0

@[simp]

end

end free_algebra

/- There is something weird in the above namespace that breaks the typeclass resolution of
`has_coe_to_sort` below. Closing it and reopening it fixes it... -/
namespace free_algebra

/-- An induction principle for the free algebra.

If `C` holds for the `algebra_map` of `r : R` into `free_algebra R X`, the `ι` of `x : X`, and is
preserved under addition and muliplication, then it holds for all of `free_algebra R X`.
-/
@[elab_as_eliminator]
lemma induction {C : free_algebra R X → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (free_algebra R X) r))
  (h_grade1 : ∀ x, C (ι R x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : free_algebra R X) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from X
  let s : subalgebra R (free_algebra R X) :=
  { carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : X → s := subtype.coind (ι R) h_grade1,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (free_algebra R X) = s.val.comp (lift R of),
  { ext,
    simp [of, subtype.coind], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift R of a),
  simp [alg_hom.ext_iff] at of_id,
  exact of_id a,
end

end free_algebra


section Lukasiewicz

  section Set
    inductive Set (α : Type) where
    | nil : Set α
    | cons : α → Set α → Set α

    def Set.mem {α : Type} (a : α) : Set α → Prop
    | Set.nil => false
    | (Set.cons b l) => a = b ∨ Set.mem a l

    notation x " ∈₁ " xs => Set.mem x xs

    theorem Set.mem_cons_of_mem (α : Type) {a b : α} {l : Set α} (h : a ∈₁ l)
      : a ∈₁ (Set.cons b l) := by
        exact Or.inr h

    theorem Set.mem_cons_self {α : Type} (a : α) (l : Set α)
      : a ∈₁ Set.cons a l := Or.inl rfl

    theorem Set.mem_nil {α : Type} (a : α) : ¬ (Set.mem a Set.nil) := by
      intro h
      trivial

    notation "[]" => Set.nil
    notation x "::" xs => Set.cons x xs

    def Set.append {α : Type} : Set α → Set α → Set α := fun l₁ ys =>
      match l₁ with
    | Set.nil => ys
    | (Set.cons x xs) => Set.cons x (Set.append xs ys)

    notation xs "++" ys => Set.append xs ys
  end Set

  section MVAlgebra

    structure Monoid (α : Type) :=
      (add : α → α → α)
      (zero : α)
      (zero_add : ∀ a : α, add zero a = a)
      (add_zero : ∀ a : α, add a zero = a)
      (add_assoc : ∀ a b c : α, add (add a b) c = add a (add b c))

    structure AbelianMonoid (α : Type) extends Monoid α :=
      (add_comm : ∀ a b : α, add a b = add b a)

    structure MV (α : Type) extends AbelianMonoid α :=
      (neg : α → α)
      (mul : Float → α → α)
      (diff : α → α → α := fun x y => neg (add (neg x) (neg y)))
      (MV₂ : ∀ x : α, neg (neg x) = x)
      (MV₃ : ∀ a : α, add (neg zero) a = neg zero)
      (MV₄ : ∀ x y : α, add (neg (add (neg x) y)) y = add (neg (add (neg y) x)) x)

    example {α : Type} (mv : MV α) : mv.add (mv.zero) (mv.zero) = mv.zero := by
      exact mv.zero_add mv.zero

    set_option checkBinderAnnotations false

    def MV.one {α : Type} [mv : MV α] := mv.neg mv.zero
    def MV.disj {α : Type} [mv : MV α] (x y : α) := mv.add (mv.diff x (mv.neg y)) y
    def MV.conj {α : Type} [mv : MV α] (x y : α) := mv.diff (mv.add x (mv.neg y)) y
    def MV.dist {α : Type} [mv : MV α] (x y : α) := mv.add (mv.diff x (mv.neg y)) (mv.diff y (mv.neg x))
    def MV.mul_zero {α : Type} [mv : MV α] := ∀ x : α, mv.mul 0 x = mv.zero
    def MV.mul_rule {α : Type} [mv : MV α] (n : Float) (x : α) := mv.add x (mv.mul (n - 1) x)

    structure interval01 :=
      (list : List Float)
      (pos : ∀ x : Float, (List.elem x list) → 0 ≤ x)
      (subunit : ∀ x : Float, (List.elem x list) → x ≤ 1)

    #check MV.diff

    structure DMV (α : Type) extends MV α :=
      (r_values : interval01)
      (DMV₁ : ∀ r : Float, ∀ x y : α, List.elem r r_values.list → mul r x = mul r y)
      (DMV₂ : ∀ r q : Float, ∀ x : α, List.elem r r_values.list → List.elem q r_values.list
        → mul (r * (1-q)) x = neg (add (neg (mul r x)) (neg (neg (mul r y)))))
      (DMV₃ : ∀ r q : Float, ∀ x : α, List.elem r r_values.list → List.elem q r_values.list
        → mul r (mul q x) = mul (r * q) x)
      (DMV₄ : ∀ x : α, mul 1 x = x)

  end MVAlgebra

  section LinearAlgebra

    open List

    def Vector (α : Type) (n : Nat) := Fin n → α
    def Matrix (α : Type) (m n : Nat) := Fin m → Vector α n

    def index (v : Vector α n) (i : Nat) --(h : i < n)
      := v ⟨ i, by sorry ⟩

    notation v " [ " i " ] " => index v i

    def elementwiseDiff { α : Type } [HSub α α α] [HAdd α α α] [OfNat α 0]
      (v₁ : Vector α n) (v₂ : Vector α n) : Vector α n := fun i => v₁ [i] - v₂ [i]

    notation v₁ " -V " v₂ => elementwiseDiff v₁ v₂

    def dot_product { α : Type } [HMul α α α] [HAdd α α α] [OfNat α 0]
      (v w : Vector α n) : α :=
      foldr (fun x y => x + y) 0 $
      map (fun (x, y) => x * y)
      (Array.zip
        (map (fun i => v [i]) (range n)).toArray
        (map (fun i => w [i]) (range n)).toArray).toList

    notation v " ⬝ " w => dot_product v w

    def indexes (matrix : Matrix α m n) (i j : Nat) (hi : i < m) (hj : j < n)
      := matrix ⟨ i, by assumption ⟩ ⟨ j, by assumption ⟩

    notation m " [ " i " , " j " ] " => indexes m i j (by simp) (by simp)

    def list_times_vector { α : Type } [HMul α α α] [HAdd α α α] [OfNat α 0] [Inhabited α] { n : Nat }
      (list : List α)
      (vector : Vector α n) : α :=
      foldr (fun x y => x + y) 0 $ map (fun i => list.get! i * vector [i]) (range n)

    def vector_times_list { α : Type } [HMul α α α] [HAdd α α α] [OfNat α 0] [Inhabited α] { n : Nat }
      (vector : Vector α n)
      (list : List α): α := list_times_vector list vector

    notation list " ×LV " vector => list_times_vector list vector
    notation vector " ×VL " list => vector_times_list vector list

    def transpose {α : Type} {m n : Nat} (mat : Matrix α m n) : Matrix α n m :=
      fun i j => mat j i

    notation "T( " matrix " )" => transpose matrix

    def matrix_product {α : Type} [HMul α α α] [HAdd α α α] [OfNat α 0]
      {m n p : Nat}
      (A : Matrix α m n)
      (B : Matrix α n p) : Matrix α m p :=
      fun i => fun j =>
        let row_i := A [i]
        let col_j := (fun k => B k j)
        let dot_prod := row_i ⬝ col_j
        dot_prod

    notation m₁ " ×M " m₂ => matrix_product m₁ m₂

    def mapVector {α β : Type} {n : Nat} (f : α → β) (v : Vector α n) : Vector β n :=
      fun i => f (v i)

    notation f " <$>V " v => mapVector f v

    def mapMatrix {α β : Type} {m n : Nat} (f : α → β)
      (mat : Matrix α m n) : Matrix β m n :=
      fun i j => f (mat i j)

    notation f " <$>M " matrix => mapMatrix f matrix

    def matrix_dot_vector {α : Type} [HMul α α α] [HAdd α α α] [OfNat α 0]
      (matrix : Matrix α m n)
      (vector : Vector α n)
      : Matrix α m 1 := fun i _ => matrix[i] ⬝ vector

    notation matrix " × " vector => matrix_dot_vector matrix vector

    section Example2
      def vector : Vector Float 3 := fun i => match i with
        | ⟨0, _⟩ => 0.4 | ⟨1, _⟩ => 0.5 | ⟨2, _⟩ => 0.6
      #eval vector ⬝ vector

      def vector₂ : Vector Float 3 := fun i => match i with
        | ⟨0, _⟩ => 0.2 | ⟨1, _⟩ => 0.52 | ⟨2, _⟩ => 0.78

      def matrix : Matrix Float 2 3 :=
        fun i => match i with
        | ⟨0, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.1 | ⟨1, _⟩ => 0.2  | ⟨2, _⟩ => 0.3
        | ⟨1, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.4  | ⟨1, _⟩ => 0.5 | ⟨2, _⟩ => 0.6

      #check matrix × vector
      #eval (matrix × vector) [0, 0]

      #check T(matrix)

      #eval ((fun x => x) <$>M (matrix ×M (T(matrix)))) [1,1]

      #eval (foldr (fun x y => x + y) 0 $ map (fun i => (vector [i] - vector₂ [i]) ^ 2) (range 3)) * 1 / 3

      #check [Vector Nat 2, Vector Nat 3]
      #eval List.get! [1,2,3] 1

    end Example2

  end LinearAlgebra

  section MultiLayerPerceptron
    open List

    def layer_activation {α : Type} [HAdd α α α] [HMul α α α] [OfNat α 0]
      (input_lines neuronsCurrent neuronsNew : Nat)
      (Q : Matrix α input_lines neuronsCurrent)
      (W : Matrix α neuronsNew neuronsCurrent)
      (f : α → Float)
      : Matrix Float input_lines neuronsNew :=
        f <$>M (Q ×M T(W))

    def RMSE (input_lines : Nat)
      (test_values : Vector Float input_lines)
      (predicted_values : Vector Float input_lines)
      : Float :=
        (1 / input_lines.toFloat)
        * (foldr (fun x y => x + y) 0
          $ map (fun i => (test_values [i] - predicted_values [i]) ^ 2) (range input_lines))

    def ForwardPropagation
      (Q : Matrix Float input_lines input_size)
      (W : Matrix Float output_size input_size)
      (f : Float → Float) : Matrix Float input_lines output_size :=
      layer_activation input_lines input_size output_size Q W f

    def BackwardPropagation
      (Q : Matrix Float input_lines input_size)
      (W : Matrix Float output_size input_size)
      (f' : Float → Float) : Matrix Float input_size output_size :=
      let delta := (fun z => z * f' z)
        <$>M (layer_activation input_lines input_size output_size Q W f')
      let grad_W := (fun x => 1 / input_lines.toFloat * x) <$>M (T(Q) ×M delta)
      grad_W

  end MultiLayerPerceptron

  section ManySortedHybridLogic

    inductive sort (σ : Nat)
    | atom : Fin σ → sort σ

    notation "#s" s => sort.atom s

    inductive nominal (σ : Nat)
    | atom : Fin σ → nominal σ
    | nominal : Float → nominal σ

    notation "#n" x => nominal.atom x
    notation "#γ" r => nominal.nominal r

    inductive action (σ : Nat)
    | atom : Fin σ → action σ
    | train : Vector Float n → Float → action σ
    | update : Float → List (Vector Float n) → action σ
    | stop : List (Vector Float n) → action σ
    | seq : action σ → action σ → action σ

    notation "#a" a => action.atom a
    notation α " ; " β => action.seq α β

    inductive form (σ : Nat) : Type where
    | atom : Fin σ → form σ
    | nomToForm : nominal σ → form σ
    | neg : form σ → form σ
    | oplus : form σ → form σ → form σ
    | sigma : Set (form σ) → form σ
    | hybrid : nominal σ → sort σ → form σ → form σ
    | nom : nominal σ → form σ → form σ
    | diam : nominal σ → form σ → form σ
    | program : action σ → form σ → form σ
    | list : List (form σ) → form σ

    notation " # " p => form.atom p
    notation " ¬L " p => form.neg p
    notation p " ⊕ " q => form.oplus p q

    notation p " ⊙ " q => ¬L((¬L p) ⊕ (¬L q))
    notation p " →L " q => (¬L p) ⊕ q
    notation p " ⋁ " q => (p ⊙ (¬L q)) ⊕ q
    notation p " ⋀ " q => (p ⊕ (¬L q)) ⊙ q
    notation " ◇ " r " , " p => form.diam r p
    notation " @@ " j " , " s " : " φ => form.hybrid j s φ
    notation " @@ " x " , " φ => form.nom x φ
    notation " [ " α " ] " φ => form.program α φ

    notation " zL " => (form.nomToForm $ #γ 0)

    #check [(#a 1) ; (#a 2)]@@(#n 1),(#s 1):(¬L(#1) →L (#2))

    @[reducible]
    def ctx (σ : Nat) : Type := Set $ form σ

    open action
    open form
    open DMV
    open List

    def vector_product_list { σ : Nat } [Inhabited (form σ)] [OfNat (Fin σ) 0]
      (n : Nat)
      (w : Vector Float n)
      (lform : List (form σ)) : form σ :=
      foldr (fun φ ψ => oplus φ ψ) (atom 0) $ map (fun i => ◇(#γ w [i]), lform.get! i) (range n)

    inductive Proof { σ : Nat } [Inhabited (form σ)] [Inhabited (nominal σ)] [OfNat (Fin σ) 0] : ctx σ → form σ → Prop
    | ax { Γ } { p : form σ } (h : p ∈₁ Γ) : Proof Γ p
    | Ka { Γ } { φ ψ : form σ } { j : nominal σ } { s : sort σ } (h : Proof Γ $ @@j,s:(φ →L ψ))
        : Proof Γ $ @@j,s:φ →L @@j,s:ψ
    | SelfDual₁ { Γ } { φ : form σ } { j : nominal σ } { s : sort σ } (h : Proof Γ $ @@j,s:φ)
        : Proof Γ $ ¬L@@j,s:(¬Lφ)
    | SelfDual₂ { Γ } { φ : form σ } { j : nominal σ } { s : sort σ } (h : Proof Γ $ ¬L@@j,s:(¬Lφ))
        : Proof Γ $ @@j,s:φ
    | Agree₁ { Γ } { φ : form σ } { k j : nominal σ } { t t' : sort σ } (h : Proof Γ $ @@k,t:(@@j,t':φ))
        : Proof Γ $ @@j,t:φ
    | Agree₂ { Γ } { φ : form σ } { k j : nominal σ } { t t' : sort σ } (h : Proof Γ $ @@j,t:φ)
        : Proof Γ $ @@k,t:(@@j,t':φ)
    | NOM₁₁ { Γ } { r : Float } { DMV : DMV Float} (h : Proof Γ $ nomToForm (#γ (DMV.neg r)))
        : Proof Γ $ ¬L (nomToForm (#γ r))
    | NOM₁₂ { Γ } { r : Float } { DMV : DMV Float} (h : Proof Γ $ ¬L (nomToForm (#γ r)))
        : Proof Γ $ nomToForm (#γ (DMV.neg r))
    | NOM₂₁ { Γ } { r q : Float } { DMV : DMV Float } (h : Proof Γ $ nomToForm (#γ (DMV.add r q)))
        : Proof Γ $ (nomToForm (#γ r)) ⊕ (nomToForm (#γ q))
    | NOM₂₂ { Γ } { r q : Float } { DMV : DMV Float } (h : Proof Γ $ (nomToForm (#γ r)) ⊕ (nomToForm (#γ q)))
        : Proof Γ $ nomToForm (#γ (DMV.add r q))
    | NOM₃₁ { Γ } { r q : Float } { DMV : DMV Float } (h : Proof Γ $ nomToForm (#γ (DMV.mul r q)))
        : Proof Γ $ ◇(#γ r), (nomToForm $ #γ q)
    | NOM₃₂ { Γ } { r q : Float } { DMV : DMV Float } (h : Proof Γ $ ◇(#γ r), (nomToForm $ #γ q))
        : Proof Γ $ nomToForm (#γ (DMV.mul r q))
    | MG₁₁ { Γ } { φ ψ χ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,(φ ⊕ (ψ ⊕ χ)))
        : Proof Γ $ @@x,(φ ⊕ (ψ ⊕ χ))
    | MG₁₂ { Γ } { φ ψ χ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,(φ ⊕ (ψ ⊕ χ)))
        : Proof Γ $ @@x,(φ ⊕ (ψ ⊕ χ))
    | MG₂₁ { Γ } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,(φ ⊕ ψ))
        : Proof Γ $ @@x,(ψ ⊕ φ)
    | MG₂₂ { Γ } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,(ψ ⊕ φ))
        : Proof Γ $ @@x,(φ ⊕ ψ)
    | MG₃ { Γ } { φ : form σ } : Proof Γ $ @@(#γ 0),φ
    | MV₁₁ { Γ } { φ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,(¬L (¬L φ)))
        : Proof Γ $ @@x,φ
    | MV₁₂ { Γ } { φ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,φ )
        : Proof Γ $ @@x,(¬L (¬L φ))
    | MV₂₁ { Γ } { φ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,((¬L zL) ⊕ φ))
        : Proof Γ $ @@x, (¬L zL)
    | MV₂₂ { Γ } { φ : form σ } { x : nominal σ } (h : Proof Γ $ @@x, (¬L zL))
        : Proof Γ $ @@x,((¬L zL) ⊕ φ)
    | MV₃₁ { Γ } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x, (¬L((¬L φ) ⊕ ψ)) ⊕ ψ)
        : Proof Γ $ @@x, (¬L((¬L ψ) ⊕ φ)) ⊕ φ
    | MV₃₂ { Γ } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x, (¬L((¬L ψ) ⊕ φ)) ⊕ φ )
        : Proof Γ $ @@x, (¬L((¬L φ) ⊕ ψ)) ⊕ ψ
    | R₁₁ { Γ } { r : Float } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,◇(#γ r), (φ ⊙ (¬L ψ)))
        : Proof Γ $ @@x,((◇(#γ r),φ) ⊙ (¬L (◇(#γ r),ψ)))
    | R₂₁ { Γ } { r : Float } { φ ψ : form σ } { x : nominal σ } (h : Proof Γ $ @@x,((◇(#γ r),φ) ⊙ (¬L (◇(#γ r),ψ))))
        : Proof Γ $  @@x,◇(#γ r), (φ ⊙ (¬L ψ))
    | N₀₁ { Γ } { ν : form σ } { α β : action σ } (h : Proof Γ $ [α ; β]ν) : Proof Γ $ [α][β]ν
    | N₀₂ { Γ } { ν : form σ } { α β : action σ } (h : Proof Γ $ [α][β]ν) : Proof Γ $ [α ; β]ν
    | N₁ { Γ } { n : Nat } { w : Vector Float n } { b : Float } {DMV : DMV Float}
      { lφ : List $ form σ }
      (h : Proof Γ $ [train w b] (list lφ))
        : Proof Γ $ list (map (fun _ => nomToForm (#γ b) ⊕ (vector_product_list n w lφ)) (range n))
    | N₂ { Γ } { n : Nat } { lφ : List (form σ) } { X : List (nominal σ)} { ln : sort σ }
      (h : Proof Γ $ foldr (fun φ ψ => φ ⋀ ψ) (lφ.get! 0) $ map (fun i => @@(X.get! i),ln:lφ.get! i) (range n) )
      : Proof Γ $ list lφ →L list (map (fun i => nomToForm $ X.get! i) (range n))

    notation Γ " ⊢ " p => Proof Γ p

  end ManySortedHybridLogic
    def w1 : Matrix Float 5 3 :=
      fun i => match i with
        | ⟨0, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.9811 | ⟨1, _⟩ => 0.3531 | ⟨2, _⟩ => 0.1121
        | ⟨1, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.4517 | ⟨1, _⟩ => 0.6646 | ⟨2, _⟩ => 0.2132
        | ⟨2, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.5921 | ⟨1, _⟩ => 0.3788 | ⟨2, _⟩ => 0.1211
        | ⟨3, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.1891 | ⟨1, _⟩ => 0.4145 | ⟨2, _⟩ => 0.1213
        | ⟨4, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.6381 | ⟨1, _⟩ => 0.1213 | ⟨2, _⟩ => 0.3121

    def w2 : Matrix Float 2 5 :=
      fun i => match i with
        | ⟨0, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.1424 | ⟨1, _⟩ => 0.2341 | ⟨2, _⟩ => 0.1131 | ⟨3, _⟩ => 0.3122 | ⟨4, _⟩ => 0.5412
        | ⟨1, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0.1212 | ⟨1, _⟩ => 0.5671 | ⟨2, _⟩ => 0.8181 | ⟨3, _⟩ => 0.7671 | ⟨4, _⟩ => 0.3119

    def w3 : Matrix Float 1 2 :=
      fun i => match i with
        | ⟨0, _⟩ => fun j => match j with
            | ⟨0, _⟩ => 0.7172
            | ⟨1, _⟩ => 0.1231

    def Q : Matrix Float 4 3 :=
      fun i => match i with
        | ⟨0, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0 | ⟨1, _⟩ => 0 | ⟨2, _⟩ => 1
        | ⟨1, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 1 | ⟨1, _⟩ => 0 | ⟨2, _⟩ => 1
        | ⟨2, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 0 | ⟨1, _⟩ => 1 | ⟨2, _⟩ => 0
        | ⟨3, _⟩ => fun j => match j with
          | ⟨0, _⟩ => 1 | ⟨1, _⟩ => 1 | ⟨2, _⟩ => 1

    def ReLU₁ (x : Float) : Float := min 1 $ max 0 x
    def ReLU₁' (x : Float) : Float :=
      if x < 0
        then 0
      else if x < 1
          then 1
          else 0

    #check ((fun x => min 1 $ max 0 x) <$>M Q ×M T(w1))
    #check ((fun x => min 1 $ max 0 x) <$>M ((fun x => min 1 $ max 0 x) <$>M Q ×M T(w1)) ×M T(w2))
    #check
      ((fun x => ReLU₁ x) <$>M
        ((fun x => ReLU₁ x) <$>M
          ((fun x => ReLU₁ x) <$>M
            Q
          ×M T(w1))
        ×M T(w2))
      ×M T(w3))

    #eval (BackwardPropagation ((fun x => ReLU₁ x) <$>M
          ((fun x => ReLU₁ x) <$>M
            Q
          ×M T(w1))
        ×M T(w2)) w3 ReLU₁') [1,0]

  section MLPExample

  end MLPExample
end Lukasiewicz


import linear_algebra.finite_dimensional
import field_theory.finite.basic
import ring_theory.polynomial.cyclotomic
import .aux

open ring finite_dimensional fintype mul_action polynomial

open_locale big_operators

variables {A : Type*} [division_ring A] [fintype A] [fintype (subring.center A)]
-- we keep "unnecessary" fintype instances to avoid diamonds

local notation `K` := subring.center A
local notation `q` := card K
local notation `n` := finrank K A

lemma card_ring : card A = q^n := card_eq_pow_finrank

lemma commutative_mul_iff : commutative ((*) : A → A → A) ↔ n = 1 :=
begin
  rw [← subring.center_eq_top_iff, subring.eq_top_iff', finrank_eq_one_iff_of_nonzero' (1 : A) one_ne_zero],
  simp_rw [subring.smul_def, smul_eq_mul, mul_one],
  exact ⟨λ h x, ⟨⟨x, h x⟩, rfl⟩, λ h x, let ⟨c, hc⟩ := h x in hc ▸ c.2⟩
end

local notation `d` := λ (x : A), finrank K (submodule.centralizer x)
local notation `e` := λ (x : A), finrank (subring.centralizer x) A

lemma card_centralizer (x : units A) [fintype (subring.centralizer (x : A))] :
  card (subring.centralizer (x : A)) = q^(d x) :=
card_eq_pow_finrank

lemma card_ring' (x : units A) [fintype (subring.centralizer (x : A))] :
  card A = (q^(d x))^(e x) :=
begin
  rw ← card_centralizer,
  exact card_eq_pow_finrank'
end

lemma finrank_centralizer_dvd_finrank_ring (x : units A) [fintype (subring.centralizer (x : A))] :
  (d x) ∣ n :=
begin
  have := card_ring' x,
  rw [← pow_mul, card_ring, (nat.pow_right_injective one_lt_card).eq_iff] at this,
  exact ⟨_, this⟩,
  apply_instance
end

def conj_action : mul_action (units A) (units A) :=
mul_action.comp_hom (units A) mul_aut.conj

lemma stabilizer_conj_eq_centralizer (x : units A) :
  @stabilizer (units A) (units A) _ conj_action x = subgroup.centralizer x :=
begin
  ext y,
  change y * x * y⁻¹ = x ↔ x * y = y * x,
  split;
  intro h;
  nth_rewrite 0 ← h;
  group
end

def units_subring_centralizer_equiv_subgroup_centralizer (x : units A) :
  units (subring.centralizer (x : A)) ≃ subgroup.centralizer x :=
calc units (subring.centralizer (x : A))
    ≃ {y : units A // (y : A) ∈ subring.centralizer (x : A)} :
      units_submonoid_equiv (subring.centralizer (x : A)).to_submonoid
      begin
        intros y,
        change _ = _  → _ = _,
        norm_cast,
        exact semiconj_by.inv_right
      end
... ≃ subgroup.centralizer x : equiv.set.of_eq
      begin
        ext y,
        rw [set_like.mem_coe, set_like.mem_coe],
        change (↑x * ↑y = ↑y * ↑x) ↔ (x * y = y * x),
        norm_cast
      end

lemma card_stabilizer_conj_eq {x : units A}
  [fintype (@stabilizer (units A) (units A) _ conj_action x)]
  [fintype (subgroup.centralizer x)] [fintype (subring.centralizer (x : A))] :
  card (@stabilizer (units A) (units A) _ conj_action x) = q^(d x) - 1 :=
by rw [card_congr (mul_equiv.subgroup_congr $ stabilizer_conj_eq_centralizer x).to_equiv,
       card_congr (units_subring_centralizer_equiv_subgroup_centralizer x).symm,
       card_units',
       card_centralizer]

local notation `Ω` := (quotient $ @orbit_rel (units A) (units A) _ conj_action)

lemma key₀ [Π (x : units A), decidable_pred (λ u, u ∈ subring.centralizer (x : A))] (ω : Ω) :
  (d ω.out' = n) ↔ (ω.out' : A) ∈ K :=
begin
  rw [← (nat.pow_right_injective (one_lt_card : 1 < q)).eq_iff],
  dsimp only,
  rw [← card_centralizer, ← card_ring],
  change card {x // x ∈ _} = _ ↔ _,
  rw card_subtype_eq_iff A,
  exact forall_congr (λ x, ⟨λ h, eq.symm h, λ h, eq.symm h⟩)
end

#check units_submonoid_equiv

def foo [fintype Ω] :
  units K ≃ {ω : Ω // ¬ d ω.out' < n} :=
{ to_fun := λ k, ⟨@orbit (units A) (units A) _ conj_action (k : units A), _⟩}

lemma key₁ [fintype Ω] :
  ∑ ω in finset.filter (λ (ω : Ω), ¬ d ω.out' < n) finset.univ,
    (q^n - 1) / (q^(d ω.out') - 1) = q - 1 :=
begin
  sorry
end

lemma key₂ [fintype Ω] [Π (x : units A), fintype (@stabilizer _ _ _ conj_action x)]
  [Π (x : units A), fintype (subring.centralizer (x : A))]
  [Π (x : units A), fintype (subgroup.centralizer x)] :
  q^n - 1 = (q - 1) + ∑ ω in finset.filter (λ (ω : Ω), d ω.out' < n) finset.univ,
    (q^n - 1) / (q^(d ω.out') - 1) :=
calc q^n - 1
      = card (units A) : by rw [← card_ring, ← card_units']
  ... = ∑ (ω : Ω), card (units A) / card (@stabilizer _ _ _ conj_action ω.out') :
        @card_eq_sum_card_group_div_card_stabilizer _ _ _ conj_action _ _ _ _
  ... = ∑ (ω : Ω), (q^n - 1) / (q^(d ω.out') - 1) :
        by conv in (_ / _) {rw [card_units', card_ring, card_stabilizer_conj_eq]}
  ... = (∑ ω in finset.filter (λ (ω : Ω), d ω.out' < n) finset.univ,
          (q^n - 1) / (q^(d ω.out') - 1)) +
        (∑ ω in finset.filter (λ (ω : Ω), ¬ d ω.out' < n) finset.univ,
          (q^n - 1) / (q^(d ω.out') - 1)) :
        by rw finset.sum_filter_add_sum_filter_not finset.univ (λ (ω : Ω), (d ω.out') < n) _
  ... = (∑ ω in finset.filter (λ (ω : Ω), d ω.out' < n) finset.univ,
          (q^n - 1) / (q^(d ω.out') - 1)) + (q - 1) :
        by rw key₁
  ... = (q - 1) + ∑ ω in finset.filter (λ (ω : Ω), d ω.out' < n) finset.univ,
          (q^n - 1) / (q^(d ω.out') - 1) : add_comm _ _

lemma key₃ [fintype Ω] [Π (x : units A), fintype (@stabilizer _ _ _ conj_action x)]
  [Π (x : units A), fintype (subring.centralizer (x : A))]
  [Π (x : units A), fintype (subgroup.centralizer x)] :
  (q - 1 : ℤ) = (q^n - 1 : ℤ) + ∑ ω in finset.filter (λ (ω : Ω), d ω.out' < n) finset.univ,
    (q^n - 1) / (q^(d ω.out') - 1) :=
begin

end

lemma key_dvd : (cyclotomic n ℤ).eval (q : ℤ) ∣ q - 1 :=
begin

end

--
--lemma key_divides {x : units A}
--  [fintype (@stabilizer (units A) (units A) _ conj_action x)]
--  [fintype (subgroup.centralizer x)] [fintype (subring.centralizer (x : A))] :
--  q^(d x) - 1 ∣ q^n - 1 :=
--begin
--  rw [← card_stabilizer_conj_eq, ← card_ring, ← card_units'],
--  exact subgroup.card_subgroup_dvd_card _
--end