/-
Copyright (c) 2015 Nathaniel Thomas. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nathaniel Thomas, Jeremy Avigad, Johannes Hölzl, Mario Carneiro
-/
import algebra.big_operators.basic
import algebra.smul_with_zero
import group_theory.group_action.group
import tactic.norm_num

/-!
# Modules over a ring

In this file we define

* `module R M` : an additive commutative monoid `M` is a `module` over a
  `semiring R` if for `r : R` and `x : M` their "scalar multiplication `r • x : M` is defined, and
  the operation `•` satisfies some natural associativity and distributivity axioms similar to those
  on a ring.

## Implementation notes

In typical mathematical usage, our definition of `module` corresponds to "semimodule", and the
word "module" is reserved for `module R M` where `R` is a `ring` and `M` an `add_comm_group`.
If `R` is a `field` and `M` an `add_comm_group`, `M` would be called an `R`-vector space.
Since those assumptions can be made by changing the typeclasses applied to `R` and `M`,
without changing the axioms in `module`, mathlib calls everything a `module`.

In older versions of mathlib, we had separate `semimodule` and `vector_space` abbreviations.
This caused inference issues in some cases, while not providing any real advantages, so we decided
to use a canonical `module` typeclass throughout.

## Tags

semimodule, module, vector space
-/

open function
open_locale big_operators

universes u u' v w x y z
variables {R : Type u} {k : Type u'} {S : Type v} {M : Type w} {M₂ : Type x} {M₃ : Type y}
  {ι : Type z}

/-- A module is a generalization of vector spaces to a scalar semiring.
  It consists of a scalar semiring `R` and an additive monoid of "vectors" `M`,
  connected by a "scalar multiplication" operation `r • x : M`
  (where `r : R` and `x : M`) with some natural associativity and
  distributivity axioms similar to those on a ring. -/
@[ext, protect_proj] class module (R : Type u) (M : Type v) [semiring R]
  [add_comm_monoid M] extends distrib_mul_action R M :=
(add_smul : ∀(r s : R) (x : M), (r + s) • x = r • x + s • x)
(zero_smul : ∀x : M, (0 : R) • x = 0)

section add_comm_monoid
variables [semiring R] [add_comm_monoid M] [module R M] (r s : R) (x y : M)

/-- A module over a semiring automatically inherits a `mul_action_with_zero` structure. -/
@[priority 100] -- see Note [lower instance priority]
instance module.to_mul_action_with_zero :
  mul_action_with_zero R M :=
{ smul_zero := smul_zero,
  zero_smul := module.zero_smul,
  ..(infer_instance : mul_action R M) }

instance add_comm_monoid.nat_module : module ℕ M :=
{ one_smul := one_nsmul,
  mul_smul := λ m n a, mul_nsmul a m n,
  smul_add := λ n a b, nsmul_add a b n,
  smul_zero := nsmul_zero,
  zero_smul := zero_nsmul,
  add_smul := λ r s x, add_nsmul x r s }

theorem add_smul : (r + s) • x = r • x + s • x := module.add_smul r s x
variables (R)

theorem two_smul : (2 : R) • x = x + x := by rw [bit0, add_smul, one_smul]

theorem two_smul' : (2 : R) • x = bit0 x := two_smul R x

@[simp] lemma inv_of_two_smul_add_inv_of_two_smul [invertible (2 : R)] (x : M) :
  (⅟2 : R) • x + (⅟2 : R) • x = x :=
by rw [←add_smul, inv_of_two_add_inv_of_two, one_smul]

/-- Pullback a `module` structure along an injective additive monoid homomorphism.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.module [add_comm_monoid M₂] [has_scalar R M₂] (f : M₂ →+ M)
  (hf : injective f) (smul : ∀ (c : R) x, f (c • x) = c • f x) :
  module R M₂ :=
{ smul := (•),
  add_smul := λ c₁ c₂ x, hf $ by simp only [smul, f.map_add, add_smul],
  zero_smul := λ x, hf $ by simp only [smul, zero_smul, f.map_zero],
  .. hf.distrib_mul_action f smul }

/-- Pushforward a `module` structure along a surjective additive monoid homomorphism. -/
protected def function.surjective.module [add_comm_monoid M₂] [has_scalar R M₂] (f : M →+ M₂)
  (hf : surjective f) (smul : ∀ (c : R) x, f (c • x) = c • f x) :
  module R M₂ :=
{ smul := (•),
  add_smul := λ c₁ c₂ x, by { rcases hf x with ⟨x, rfl⟩,
    simp only [add_smul, ← smul, ← f.map_add] },
  zero_smul := λ x, by { rcases hf x with ⟨x, rfl⟩, simp only [← f.map_zero, ← smul, zero_smul] },
  .. hf.distrib_mul_action f smul }

/-- Push forward the action of `R` on `M` along a compatible surjective map `f : R →+* S`.

See also `function.surjective.mul_action_left` and `function.surjective.distrib_mul_action_left`.
-/
@[reducible]
def function.surjective.module_left {R S M : Type*} [semiring R] [add_comm_monoid M]
  [module R M] [semiring S] [has_scalar S M]
  (f : R →+* S) (hf : function.surjective f) (hsmul : ∀ c (x : M), f c • x = c • x) :
  module S M :=
{ smul := (•),
  zero_smul := λ x, by rw [← f.map_zero, hsmul, zero_smul],
  add_smul := hf.forall₂.mpr (λ a b x, by simp only [← f.map_add, hsmul, add_smul]),
  .. hf.distrib_mul_action_left f.to_monoid_hom hsmul }

variables {R} (M)

/-- Compose a `module` with a `ring_hom`, with action `f s • m`.

See note [reducible non-instances]. -/
@[reducible] def module.comp_hom [semiring S] (f : S →+* R) :
  module S M :=
{ smul := has_scalar.comp.smul f,
  add_smul := λ r s x, by simp [add_smul],
  .. mul_action_with_zero.comp_hom M f.to_monoid_with_zero_hom,
  .. distrib_mul_action.comp_hom M (f : S →* R) }

variables (R) (M)

/-- `(•)` as an `add_monoid_hom`.

This is a stronger version of `distrib_mul_action.to_add_monoid_End` -/
@[simps apply_apply]
def module.to_add_monoid_End : R →+* add_monoid.End M :=
{ map_zero' := add_monoid_hom.ext $ λ r, by simp,
  map_add' := λ x y, add_monoid_hom.ext $ λ r, by simp [add_smul],
  ..distrib_mul_action.to_add_monoid_End R M }

/-- A convenience alias for `module.to_add_monoid_End` as an `add_monoid_hom`, usually to allow the
use of `add_monoid_hom.flip`. -/
def smul_add_hom : R →+ M →+ M :=
(module.to_add_monoid_End R M).to_add_monoid_hom

variables {R M}

@[simp] lemma smul_add_hom_apply (r : R) (x : M) :
  smul_add_hom R M r x = r • x := rfl

lemma module.eq_zero_of_zero_eq_one (zero_eq_one : (0 : R) = 1) : x = 0 :=
by rw [←one_smul R x, ←zero_eq_one, zero_smul]

lemma list.sum_smul {l : list R} {x : M} : l.sum • x = (l.map (λ r, r • x)).sum :=
((smul_add_hom R M).flip x).map_list_sum l

lemma multiset.sum_smul {l : multiset R} {x : M} : l.sum • x = (l.map (λ r, r • x)).sum :=
((smul_add_hom R M).flip x).map_multiset_sum l

lemma finset.sum_smul {f : ι → R} {s : finset ι} {x : M} :
  (∑ i in s, f i) • x = (∑ i in s, (f i) • x) :=
((smul_add_hom R M).flip x).map_sum f s

end add_comm_monoid

variables (R)

/-- An `add_comm_monoid` that is a `module` over a `ring` carries a natural `add_comm_group`
structure.
See note [reducible non-instances]. -/
@[reducible]
def module.add_comm_monoid_to_add_comm_group [ring R] [add_comm_monoid M] [module R M] :
  add_comm_group M :=
{ neg          := λ a, (-1 : R) • a,
  add_left_neg := λ a, show (-1 : R) • a + a = 0, by
  { nth_rewrite 1 ← one_smul _ a,
    rw [← add_smul, add_left_neg, zero_smul] },
  ..(infer_instance : add_comm_monoid M), }

variables {R}

section add_comm_group

variables (R M) [semiring R] [add_comm_group M]

instance add_comm_group.int_module : module ℤ M :=
{ one_smul := one_zsmul,
  mul_smul := λ m n a, mul_zsmul a m n,
  smul_add := λ n a b, zsmul_add a b n,
  smul_zero := zsmul_zero,
  zero_smul := zero_zsmul,
  add_smul := λ r s x, add_zsmul x r s }

/-- A structure containing most informations as in a module, except the fields `zero_smul`
and `smul_zero`. As these fields can be deduced from the other ones when `M` is an `add_comm_group`,
this provides a way to construct a module structure by checking less properties, in
`module.of_core`. -/
@[nolint has_inhabited_instance]
structure module.core extends has_scalar R M :=
(smul_add : ∀(r : R) (x y : M), r • (x + y) = r • x + r • y)
(add_smul : ∀(r s : R) (x : M), (r + s) • x = r • x + s • x)
(mul_smul : ∀(r s : R) (x : M), (r * s) • x = r • s • x)
(one_smul : ∀x : M, (1 : R) • x = x)

variables {R M}

/-- Define `module` without proving `zero_smul` and `smul_zero` by using an auxiliary
structure `module.core`, when the underlying space is an `add_comm_group`. -/
def module.of_core (H : module.core R M) : module R M :=
by letI := H.to_has_scalar; exact
{ zero_smul := λ x, (add_monoid_hom.mk' (λ r : R, r • x) (λ r s, H.add_smul r s x)).map_zero,
  smul_zero := λ r, (add_monoid_hom.mk' ((•) r) (H.smul_add r)).map_zero,
  ..H }

end add_comm_group

/-- A variant of `module.ext` that's convenient for term-mode. -/
-- We'll later use this to show `module ℕ M` and `module ℤ M` are subsingletons.
lemma module.ext' {R : Type*} [semiring R] {M : Type*} [add_comm_monoid M] (P Q : module R M)
  (w : ∀ (r : R) (m : M), by { haveI := P, exact r • m } = by { haveI := Q, exact r • m }) :
  P = Q :=
begin
  ext,
  exact w _ _
end

section module
variables [ring R] [add_comm_group M] [module R M] (r s : R) (x y : M)

@[simp] theorem neg_smul : -r • x = - (r • x) :=
eq_neg_of_add_eq_zero (by rw [← add_smul, add_left_neg, zero_smul])

@[simp] lemma neg_smul_neg : -r • -x = r • x :=
by rw [neg_smul, smul_neg, neg_neg]

@[simp] theorem units.neg_smul (u : Rˣ) (x : M) : -u • x = - (u • x) :=
by rw [units.smul_def, units.coe_neg, neg_smul, units.smul_def]

variables (R)
theorem neg_one_smul (x : M) : (-1 : R) • x = -x := by simp
variables {R}

theorem sub_smul (r s : R) (y : M) : (r - s) • y = r • y - s • y :=
by simp [add_smul, sub_eq_add_neg]

end module

/-- A module over a `subsingleton` semiring is a `subsingleton`. We cannot register this
as an instance because Lean has no way to guess `R`. -/
protected theorem module.subsingleton (R M : Type*) [semiring R] [subsingleton R]
  [add_comm_monoid M] [module R M] :
  subsingleton M :=
⟨λ x y, by rw [← one_smul R x, ← one_smul R y, subsingleton.elim (1:R) 0, zero_smul, zero_smul]⟩

/-- A semiring is `nontrivial` provided that there exists a nontrivial module over this semiring. -/
protected theorem module.nontrivial (R M : Type*) [semiring R] [nontrivial M] [add_comm_monoid M]
  [module R M] :
  nontrivial R :=
(subsingleton_or_nontrivial R).resolve_left $ λ hR, not_subsingleton M $
  by exactI module.subsingleton R M

@[priority 910] -- see Note [lower instance priority]
instance semiring.to_module [semiring R] : module R R :=
{ smul_add := mul_add,
  add_smul := add_mul,
  zero_smul := zero_mul,
  smul_zero := mul_zero }

/-- Like `semiring.to_module`, but multiplies on the right. -/
@[priority 910] -- see Note [lower instance priority]
instance semiring.to_opposite_module [semiring R] : module Rᵐᵒᵖ R :=
{ smul_add := λ r x y, add_mul _ _ _,
  add_smul := λ r x y, mul_add _ _ _,
  ..monoid_with_zero.to_opposite_mul_action_with_zero R}

/-- A ring homomorphism `f : R →+* M` defines a module structure by `r • x = f r * x`. -/
def ring_hom.to_module [semiring R] [semiring S] (f : R →+* S) : module R S :=
module.comp_hom S f

/-- The tautological action by `R →+* R` on `R`.

This generalizes `function.End.apply_mul_action`. -/
instance ring_hom.apply_distrib_mul_action [semiring R] : distrib_mul_action (R →+* R) R :=
{ smul := ($),
  smul_zero := ring_hom.map_zero,
  smul_add := ring_hom.map_add,
  one_smul := λ _, rfl,
  mul_smul := λ _ _ _, rfl }

@[simp] protected lemma ring_hom.smul_def [semiring R] (f : R →+* R) (a : R) :
  f • a = f a := rfl

/-- `ring_hom.apply_distrib_mul_action` is faithful. -/
instance ring_hom.apply_has_faithful_scalar [semiring R] : has_faithful_scalar (R →+* R) R :=
⟨ring_hom.ext⟩

section add_comm_monoid

variables [semiring R] [add_comm_monoid M] [module R M]

section
variables (R)
/-- `nsmul` is equal to any other module structure via a cast. -/
lemma nsmul_eq_smul_cast (n : ℕ) (b : M) :
  n • b = (n : R) • b :=
begin
  induction n with n ih,
  { rw [nat.cast_zero, zero_smul, zero_smul] },
  { rw [nat.succ_eq_add_one, nat.cast_succ, add_smul, add_smul, one_smul, ih, one_smul], }
end
end

/-- Convert back any exotic `ℕ`-smul to the canonical instance. This should not be needed since in
mathlib all `add_comm_monoid`s should normally have exactly one `ℕ`-module structure by design.
-/
lemma nat_smul_eq_nsmul (h : module ℕ M) (n : ℕ) (x : M) :
  @has_scalar.smul ℕ M h.to_has_scalar n x = n • x :=
by rw [nsmul_eq_smul_cast ℕ n x, nat.cast_id]

/-- All `ℕ`-module structures are equal. Not an instance since in mathlib all `add_comm_monoid`
should normally have exactly one `ℕ`-module structure by design. -/
def add_comm_monoid.nat_module.unique : unique (module ℕ M) :=
{ default := by apply_instance,
  uniq := λ P, module.ext' P _ $ λ n, nat_smul_eq_nsmul P n }

instance add_comm_monoid.nat_is_scalar_tower :
  is_scalar_tower ℕ R M :=
{ smul_assoc := λ n x y, nat.rec_on n
    (by simp only [zero_smul])
    (λ n ih, by simp only [nat.succ_eq_add_one, add_smul, one_smul, ih]) }

instance add_comm_monoid.nat_smul_comm_class : smul_comm_class ℕ R M :=
{ smul_comm := λ n r m, nat.rec_on n
    (by simp only [zero_smul, smul_zero])
    (λ n ih, by simp only [nat.succ_eq_add_one, add_smul, one_smul, ←ih, smul_add]) }

-- `smul_comm_class.symm` is not registered as an instance, as it would cause a loop
instance add_comm_monoid.nat_smul_comm_class' : smul_comm_class R ℕ M :=
smul_comm_class.symm _ _ _

end add_comm_monoid

section add_comm_group

variables [semiring S] [ring R] [add_comm_group M] [module S M] [module R M]

section
variables (R)
/-- `zsmul` is equal to any other module structure via a cast. -/
lemma zsmul_eq_smul_cast (n : ℤ) (b : M) : n • b = (n : R) • b :=
have (smul_add_hom ℤ M).flip b = ((smul_add_hom R M).flip b).comp (int.cast_add_hom R),
  by { ext, simp },
add_monoid_hom.congr_fun this n
end

/-- Convert back any exotic `ℤ`-smul to the canonical instance. This should not be needed since in
mathlib all `add_comm_group`s should normally have exactly one `ℤ`-module structure by design. -/
lemma int_smul_eq_zsmul (h : module ℤ M) (n : ℤ) (x : M) :
  @has_scalar.smul ℤ M h.to_has_scalar n x = n • x :=
by rw [zsmul_eq_smul_cast ℤ n x, int.cast_id]

/-- All `ℤ`-module structures are equal. Not an instance since in mathlib all `add_comm_group`
should normally have exactly one `ℤ`-module structure by design. -/
def add_comm_group.int_module.unique : unique (module ℤ M) :=
{ default := by apply_instance,
  uniq := λ P, module.ext' P _ $ λ n, int_smul_eq_zsmul P n }

end add_comm_group

namespace add_monoid_hom

lemma map_nat_module_smul [add_monoid M] [add_monoid M₂]
  (f : M →+ M₂) (x : ℕ) (a : M) : f (x • a) = x • f a :=
f.map_nsmul a x

lemma map_int_module_smul [add_group M] [add_group M₂]
  (f : M →+ M₂) (x : ℤ) (a : M) : f (x • a) = x • f a :=
f.map_zsmul a x

lemma map_int_cast_smul [add_comm_group M] [add_comm_group M₂]
  (f : M →+ M₂) (R S : Type*) [ring R] [ring S] [module R M] [module S M₂]
  (x : ℤ) (a : M) : f ((x : R) • a) = (x : S) • f a :=
by simp only [←zsmul_eq_smul_cast, f.map_zsmul]

lemma map_nat_cast_smul [add_comm_monoid M] [add_comm_monoid M₂] (f : M →+ M₂)
  (R S : Type*) [semiring R] [semiring S] [module R M] [module S M₂] (x : ℕ) (a : M) :
  f ((x : R) • a) = (x : S) • f a :=
by simp only [←nsmul_eq_smul_cast, f.map_nsmul]

lemma map_inv_int_cast_smul {E F : Type*} [add_comm_group E] [add_comm_group F] (f : E →+ F)
  (R S : Type*) [division_ring R] [division_ring S] [module R E] [module S F]
  (n : ℤ) (x : E) :
  f ((n⁻¹ : R) • x) = (n⁻¹ : S) • f x :=
begin
  by_cases hR : (n : R) = 0; by_cases hS : (n : S) = 0,
  { simp [hR, hS] },
  { suffices : ∀ y, f y = 0, by simp [this], clear x, intro x,
    rw [← inv_smul_smul₀ hS (f x), ← map_int_cast_smul f R S], simp [hR] },
  { suffices : ∀ y, f y = 0, by simp [this], clear x, intro x,
    rw [← smul_inv_smul₀ hR x, map_int_cast_smul f R S, hS, zero_smul] },
  { rw [← inv_smul_smul₀ hS (f _), ← map_int_cast_smul f R S, smul_inv_smul₀ hR] }
end

lemma map_inv_nat_cast_smul {E F : Type*} [add_comm_group E] [add_comm_group F] (f : E →+ F)
  (R S : Type*) [division_ring R] [division_ring S] [module R E] [module S F]
  (n : ℕ) (x : E) :
  f ((n⁻¹ : R) • x) = (n⁻¹ : S) • f x :=
f.map_inv_int_cast_smul R S n x

lemma map_rat_cast_smul {E F : Type*} [add_comm_group E] [add_comm_group F] (f : E →+ F)
  (R S : Type*) [division_ring R] [division_ring S] [module R E] [module S F]
  (c : ℚ) (x : E) :
  f ((c : R) • x) = (c : S) • f x :=
by rw [rat.cast_def, rat.cast_def, div_eq_mul_inv, div_eq_mul_inv, mul_smul, mul_smul,
  map_int_cast_smul f R S, map_inv_nat_cast_smul f R S]

lemma map_rat_module_smul {E : Type*} [add_comm_group E] [module ℚ E]
  {F : Type*} [add_comm_group F] [module ℚ F] (f : E →+ F) (c : ℚ) (x : E) :
  f (c • x) = c • f x :=
rat.cast_id c ▸ f.map_rat_cast_smul ℚ ℚ c x

end add_monoid_hom

/-- There can be at most one `module ℚ E` structure on an additive commutative group. This is not
an instance because `simp` becomes very slow if we have many `subsingleton` instances,
see [gh-6025]. -/
lemma subsingleton_rat_module (E : Type*) [add_comm_group E] : subsingleton (module ℚ E) :=
⟨λ P Q, module.ext' P Q $ λ r x,
  @add_monoid_hom.map_rat_module_smul E ‹_› P E ‹_› Q (add_monoid_hom.id _) r x⟩

/-- If `E` is a vector space over two division rings `R` and `S`, then scalar multiplications
agree on inverses of integer numbers in `R` and `S`. -/
lemma inv_int_cast_smul_eq {E : Type*} (R S : Type*) [add_comm_group E] [division_ring R]
  [division_ring S] [module R E] [module S E] (n : ℤ) (x : E) :
  (n⁻¹ : R) • x = (n⁻¹ : S) • x :=
(add_monoid_hom.id E).map_inv_int_cast_smul R S n x

/-- If `E` is a vector space over two division rings `R` and `S`, then scalar multiplications
agree on inverses of natural numbers in `R` and `S`. -/
lemma inv_nat_cast_smul_eq {E : Type*} (R S : Type*) [add_comm_group E] [division_ring R]
  [division_ring S] [module R E] [module S E] (n : ℕ) (x : E) :
  (n⁻¹ : R) • x = (n⁻¹ : S) • x :=
(add_monoid_hom.id E).map_inv_nat_cast_smul R S n x

/-- If `E` is a vector space over two division rings `R` and `S`, then scalar multiplications
agree on rational numbers in `R` and `S`. -/
lemma rat_cast_smul_eq {E : Type*} (R S : Type*) [add_comm_group E] [division_ring R]
  [division_ring S] [module R E] [module S E] (r : ℚ) (x : E) :
  (r : R) • x = (r : S) • x :=
(add_monoid_hom.id E).map_rat_cast_smul R S r x

instance add_comm_group.int_is_scalar_tower {R : Type u} {M : Type v} [ring R] [add_comm_group M]
  [module R M]: is_scalar_tower ℤ R M :=
{ smul_assoc := λ n x y, ((smul_add_hom R M).flip y).map_int_module_smul n x }

instance add_comm_group.int_smul_comm_class {S : Type u} {M : Type v} [semiring S]
  [add_comm_group M] [module S M] :
  smul_comm_class ℤ S M :=
{ smul_comm := λ n x y, ((smul_add_hom S M x).map_zsmul y n).symm }

-- `smul_comm_class.symm` is not registered as an instance, as it would cause a loop
instance add_comm_group.int_smul_comm_class' {S : Type u} {M : Type v} [semiring S]
  [add_comm_group M] [module S M] : smul_comm_class S ℤ M :=
smul_comm_class.symm _ _ _

instance is_scalar_tower.rat {R : Type u} {M : Type v} [ring R] [add_comm_group M]
  [module R M] [module ℚ R] [module ℚ M] : is_scalar_tower ℚ R M :=
{ smul_assoc := λ r x y, ((smul_add_hom R M).flip y).map_rat_module_smul r x }

instance smul_comm_class.rat {R : Type u} {M : Type v} [semiring R] [add_comm_group M]
  [module R M] [module ℚ M] : smul_comm_class ℚ R M :=
{ smul_comm := λ r x y, ((smul_add_hom R M x).map_rat_module_smul r y).symm }

instance smul_comm_class.rat' {R : Type u} {M : Type v} [semiring R] [add_comm_group M]
  [module R M] [module ℚ M] : smul_comm_class R ℚ M :=
smul_comm_class.symm _ _ _

section no_zero_smul_divisors
/-! ### `no_zero_smul_divisors`

This section defines the `no_zero_smul_divisors` class, and includes some tests
for the vanishing of elements (especially in modules over division rings).
-/

/-- `no_zero_smul_divisors R M` states that a scalar multiple is `0` only if either argument is `0`.
This a version of saying that `M` is torsion free, without assuming `R` is zero-divisor free.

The main application of `no_zero_smul_divisors R M`, when `M` is a module,
is the result `smul_eq_zero`: a scalar multiple is `0` iff either argument is `0`.

It is a generalization of the `no_zero_divisors` class to heterogeneous multiplication.
-/
class no_zero_smul_divisors (R M : Type*) [has_zero R] [has_zero M] [has_scalar R M] : Prop :=
(eq_zero_or_eq_zero_of_smul_eq_zero : ∀ {c : R} {x : M}, c • x = 0 → c = 0 ∨ x = 0)

export no_zero_smul_divisors (eq_zero_or_eq_zero_of_smul_eq_zero)

/-- Pullback a `no_zero_smul_divisors` instance along an injective function. -/
lemma function.injective.no_zero_smul_divisors {R M N : Type*} [has_zero R] [has_zero M]
  [has_zero N] [has_scalar R M] [has_scalar R N] [no_zero_smul_divisors R N] (f : M → N)
  (hf : function.injective f) (h0 : f 0 = 0) (hs : ∀ (c : R) (x : M), f (c • x) = c • f x) :
  no_zero_smul_divisors R M :=
⟨λ c m h,
  or.imp_right (@hf _ _) $ h0.symm ▸ eq_zero_or_eq_zero_of_smul_eq_zero (by rw [←hs, h, h0])⟩

section module

variables [semiring R] [add_comm_monoid M] [module R M]

instance no_zero_smul_divisors.of_no_zero_divisors [no_zero_divisors R] :
  no_zero_smul_divisors R R :=
⟨λ c x, no_zero_divisors.eq_zero_or_eq_zero_of_mul_eq_zero⟩

@[simp]
theorem smul_eq_zero [no_zero_smul_divisors R M] {c : R} {x : M} :
  c • x = 0 ↔ c = 0 ∨ x = 0 :=
⟨eq_zero_or_eq_zero_of_smul_eq_zero,
 λ h, h.elim (λ h, h.symm ▸ zero_smul R x) (λ h, h.symm ▸ smul_zero c)⟩

theorem smul_ne_zero [no_zero_smul_divisors R M] {c : R} {x : M} :
  c • x ≠ 0 ↔ c ≠ 0 ∧ x ≠ 0 :=
by simp only [ne.def, smul_eq_zero, not_or_distrib]

section nat

variables (R) (M) [no_zero_smul_divisors R M] [char_zero R]
include R

lemma nat.no_zero_smul_divisors : no_zero_smul_divisors ℕ M :=
⟨by { intros c x, rw [nsmul_eq_smul_cast R, smul_eq_zero], simp }⟩

@[simp] lemma two_nsmul_eq_zero {v : M} : 2 • v = 0 ↔ v = 0 :=
by { haveI := nat.no_zero_smul_divisors R M, norm_num [smul_eq_zero] }

end nat

variables (R M)

/-- If `M` is an `R`-module with one and `M` has characteristic zero, then `R` has characteristic
zero as well. Usually `M` is an `R`-algebra. -/
lemma char_zero.of_module [has_one M] [char_zero M] : char_zero R :=
begin
  refine ⟨λ m n h, @nat.cast_injective M _ _ _ _ _ _⟩,
  rw [← nsmul_one, ← nsmul_one, nsmul_eq_smul_cast R m (1 : M), nsmul_eq_smul_cast R n (1 : M), h]
end

end module

section add_comm_group -- `R` can still be a semiring here

variables [semiring R] [add_comm_group M] [module R M]

section smul_injective

variables (M)

lemma smul_right_injective [no_zero_smul_divisors R M] {c : R} (hc : c ≠ 0) :
  function.injective ((•) c : M → M) :=
(smul_add_hom R M c).injective_iff.2 $ λ a ha, (smul_eq_zero.mp ha).resolve_left hc

variables {M}

lemma smul_right_inj [no_zero_smul_divisors R M] {c : R} (hc : c ≠ 0) {x y : M} :
  c • x = c • y ↔ x = y :=
(smul_right_injective M hc).eq_iff

end smul_injective

section nat

variables (R M) [no_zero_smul_divisors R M] [char_zero R]
include R

lemma self_eq_neg {v : M} : v = - v ↔ v = 0 :=
by rw [← two_nsmul_eq_zero R M, two_smul, add_eq_zero_iff_eq_neg]

lemma neg_eq_self {v : M} : - v = v ↔ v = 0 :=
by rw [eq_comm, self_eq_neg R M]

lemma self_ne_neg {v : M} : v ≠ -v ↔ v ≠ 0 :=
(self_eq_neg R M).not

lemma neg_ne_self {v : M} : -v ≠ v ↔ v ≠ 0 :=
(neg_eq_self R M).not

end nat

end add_comm_group

section module

variables [ring R] [add_comm_group M] [module R M] [no_zero_smul_divisors R M]

section smul_injective

variables (R)

lemma smul_left_injective {x : M} (hx : x ≠ 0) :
  function.injective (λ (c : R), c • x) :=
λ c d h, sub_eq_zero.mp ((smul_eq_zero.mp
  (calc (c - d) • x = c • x - d • x : sub_smul c d x
                ... = 0 : sub_eq_zero.mpr h)).resolve_right hx)

end smul_injective

end module

section division_ring

variables [division_ring R] [add_comm_group M] [module R M]

@[priority 100] -- see note [lower instance priority]
instance no_zero_smul_divisors.of_division_ring : no_zero_smul_divisors R M :=
⟨λ c x h, or_iff_not_imp_left.2 $ λ hc, (smul_eq_zero_iff_eq' hc).1 h⟩

end division_ring

end no_zero_smul_divisors

@[simp] lemma nat.smul_one_eq_coe {R : Type*} [semiring R] (m : ℕ) :
  m • (1 : R) = ↑m :=
by rw [nsmul_eq_mul, mul_one]

@[simp] lemma int.smul_one_eq_coe {R : Type*} [ring R] (m : ℤ) :
  m • (1 : R) = ↑m :=
by rw [zsmul_eq_mul, mul_one]


import .hpdefs

open_locale classical
noncomputable theory

open PreHilbertPlane HilbertPlane Segment Ray

variables {Ω : Type*} [HilbertPlane Ω]

variables {A B C : Ω}
variables {ℓ r s : Line Ω}

lemma line_through_left {A B : Ω}: A ∈ line_through A B :=
(line_through_aux A B).2.1

lemma line_through_right {A B : Ω}: B ∈ (line_through A B) :=
(line_through_aux A B).2.2

lemma line_unique {A B : Ω} : A ≠ B → A ∈ ℓ → B ∈ ℓ → ℓ = line_through A B :=
λ ab al bl, I12 ab al bl line_through_left line_through_right

lemma distinct_lines_have_at_most_one_common_point
	(hrs: r ≠ s)
	(hAr: A ∈ r) (hAs: A ∈ s) (hBr: B ∈ r) (hBs: B ∈ s) :
	A = B :=
begin
    by_contradiction hc,
    apply hrs,
    apply I12 hc; assumption,
end

@[simp] lemma between_point_symmetric : (A * B * C) ↔ (C * B * A) :=
begin
    split; exact HilbertPlane.B11,
end

lemma segments_are_symmetric' : pts (A⬝B) ⊆ pts (B⬝A) :=
begin
    intros x hx,
    simp at *,
    tauto,
end

lemma segments_are_symmetric : pts (A⬝B) = B⬝A :=
begin
    apply set.subset.antisymm; exact segments_are_symmetric',
end

@[simp] lemma no_point_between_a_point (A x : Ω) : (A * x * A) ↔ false :=
begin
    split,
    {
        intro h,
        have H := HilbertPlane.B12 h,
        tauto,
    },
    tauto,
end

@[simp] lemma point_is_segment (A : Ω) : pts (A⬝A) = {A} :=
begin
    unfold pts,
    simp,
end

lemma exists_point_on_line (ℓ : Line Ω): ∃ A : Ω, A ∈ ℓ :=
begin
	have I2 := I2 ℓ,
	rcases I2 with ⟨ A, B, hAB, hAℓ, hBℓ⟩,
	exact ⟨A, hAℓ⟩,
end

lemma exists_point_not_on_line (ℓ : Line Ω): ∃ A : Ω, A ∉ ℓ :=
begin
    obtain ⟨A, B, C, ⟨hAB, hAC, hBC, h⟩⟩ := I3,
    specialize h ℓ,
    by_cases hA : A ∈ ℓ,
    {
        by_cases hB : B ∈ ℓ,
        {
            exact ⟨C, h ⟨hA, hB⟩⟩,
        },
        use B,
    },
    use A,
end


/-
Copyright (c) 2022 Paul Reichert. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul Reichert
-/
import linear_algebra.affine_space.affine_subspace

/-!
# Affine map restrictions

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

This file defines restrictions of affine maps.

## Main definitions

* The domain and codomain of an affine map can be restricted using
  `affine_map.restrict`.

## Main theorems

* The associated linear map of the restriction is the restriction of the
  linear map associated to the original affine map.
* The restriction is injective if the original map is injective.
* The restriction in surjective if the codomain is the image of the domain.
-/

variables {k V₁ P₁ V₂ P₂ : Type*} [ring k]
  [add_comm_group V₁] [add_comm_group V₂]
  [module k V₁] [module k V₂]
  [add_torsor V₁ P₁] [add_torsor V₂ P₂]

include V₁ V₂

/- not an instance because it loops with `nonempty` -/
lemma affine_subspace.nonempty_map {E : affine_subspace k P₁} [Ene : nonempty E]
  {φ : P₁ →ᵃ[k] P₂} : nonempty (E.map φ) :=
begin
  obtain ⟨x, hx⟩ := id Ene,
  refine ⟨⟨φ x, affine_subspace.mem_map.mpr ⟨x, hx, rfl⟩⟩⟩,
end

local attribute [instance, nolint fails_quickly] affine_subspace.nonempty_map
local attribute [instance, nolint fails_quickly] affine_subspace.to_add_torsor

/-- Restrict domain and codomain of an affine map to the given subspaces. -/
def affine_map.restrict
  (φ : P₁ →ᵃ[k] P₂) {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  [nonempty E] [nonempty F]
  (hEF : E.map φ ≤ F) : E →ᵃ[k] F :=
begin
  refine ⟨_, _, _⟩,
  { exact λ x, ⟨φ x, hEF $ affine_subspace.mem_map.mpr ⟨x, x.property, rfl⟩⟩ },
  { refine φ.linear.restrict (_ : E.direction ≤ F.direction.comap φ.linear),
    rw [←submodule.map_le_iff_le_comap, ←affine_subspace.map_direction],
    exact affine_subspace.direction_le hEF },
  { intros p v,
    simp only [subtype.ext_iff, subtype.coe_mk, affine_subspace.coe_vadd],
    apply affine_map.map_vadd },
end

lemma affine_map.restrict.coe_apply
  (φ : P₁ →ᵃ[k] P₂) {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  [nonempty E] [nonempty F]
  (hEF : E.map φ ≤ F) (x : E) :
  ↑(φ.restrict hEF x) = φ x := rfl

lemma affine_map.restrict.linear_aux
  {φ : P₁ →ᵃ[k] P₂} {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  (hEF : E.map φ ≤ F) : E.direction ≤ F.direction.comap φ.linear :=
begin
  rw [←submodule.map_le_iff_le_comap, ←affine_subspace.map_direction],
  exact affine_subspace.direction_le hEF,
end

lemma affine_map.restrict.linear
  (φ : P₁ →ᵃ[k] P₂) {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  [nonempty E] [nonempty F]
  (hEF : E.map φ ≤ F) :
  (φ.restrict hEF).linear = φ.linear.restrict (affine_map.restrict.linear_aux hEF) := rfl

lemma affine_map.restrict.injective
  {φ : P₁ →ᵃ[k] P₂}
  (hφ : function.injective φ) {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  [nonempty E] [nonempty F]
  (hEF : E.map φ ≤ F) :
  function.injective (affine_map.restrict φ hEF) :=
begin
  intros x y h,
  simp only [subtype.ext_iff, subtype.coe_mk, affine_map.restrict.coe_apply] at h ⊢,
  exact hφ h,
end

lemma affine_map.restrict.surjective
  (φ : P₁ →ᵃ[k] P₂) {E : affine_subspace k P₁} {F : affine_subspace k P₂}
  [nonempty E] [nonempty F] (h : E.map φ = F) :
  function.surjective (affine_map.restrict φ (le_of_eq h)) :=
begin
  rintro ⟨x, hx : x ∈ F⟩,
  rw [←h, affine_subspace.mem_map] at hx,
  obtain ⟨y, hy, rfl⟩ := hx,
  exact ⟨⟨y, hy⟩, rfl⟩,
end

lemma affine_map.restrict.bijective
  {E : affine_subspace k P₁} [nonempty E]
  {φ : P₁ →ᵃ[k] P₂} (hφ : function.injective φ) :
  function.bijective (φ.restrict (le_refl (E.map φ))) :=
⟨affine_map.restrict.injective hφ _, affine_map.restrict.surjective _ rfl⟩


import data.list tactic.omega defs single height

def left_bintree : list bintree → list bintree
| [] := []
| (t :: l) := ⟦t ∣⟧ :: left_bintree l

def right_bintree : list bintree → list bintree
| [] := []
| (t :: l) := ⟦∣ t⟧ :: right_bintree l

def full_list_bintree (t : bintree) : list bintree → list bintree
| [] := []
| (t' :: l) := ⟦t, t'⟧ :: (full_list_bintree l)

def full_list : list bintree → list bintree → list bintree
| [] := λ l, []
| (t :: l) := λ l', full_list_bintree t l' ++ full_list l l'

lemma left_bintree_correct : ∀ l t, t ∈ l → ⟦t ∣⟧ ∈ left_bintree l :=
begin
  intros l t h,
  induction l,
  cases h, cases h,
  begin unfold left_bintree, rewrite h, apply list.mem_cons_self end,
  begin
    unfold left_bintree, apply list.mem_cons_of_mem, apply l_ih, apply h
  end
end

lemma right_bintree_correct : ∀ l t, t ∈ l → ⟦∣ t⟧ ∈ right_bintree l :=
begin
  intros l t h,
  induction l,
  cases h, cases h,
  begin unfold right_bintree, rewrite h, apply list.mem_cons_self end,
  begin
    unfold right_bintree, apply list.mem_cons_of_mem, apply l_ih, apply h
  end
end

lemma full_list_bintree_correct : ∀ l t t', t' ∈ l → ⟦t, t'⟧ ∈ full_list_bintree t l :=
begin
  intros l,
  induction l,
  begin intros, cases a end,
  begin
    intros t t' h,
    cases h,
    begin rewrite h, unfold full_list_bintree, apply list.mem_cons_self end,
    begin unfold full_list_bintree, apply list.mem_cons_of_mem, apply l_ih, assumption end,
  end
end

lemma full_bintree_correct : ∀ l l' t t', t ∈ l → t' ∈ l' → ⟦t, t'⟧ ∈ full_list l l' :=
begin
  intros l,
  induction l,
  begin
    intros l' t t' h1 h2,
    cases h1
  end,
  begin
    intros l' t t' h1 h2,
    unfold full_list,
    cases h1,
    begin
      rewrite h1, apply list.mem_append_left,
      apply full_list_bintree_correct, assumption
    end,
    begin
      apply list.mem_append_right,
      apply l_ih,
      assumption, assumption
    end
  end
end

lemma cross_product_bintree : ∀ l : list bintree, ∃ l' : list bintree, ∀ t t',
                             t ∈ l → t' ∈ l → ⟦t, t'⟧ ∈ l' ∧ ⟦t ∣⟧ ∈ l' ∧ ⟦∣ t'⟧ ∈ l' :=
begin
  intros l,
  have ht : ∃ l', l' = left_bintree l ++ right_bintree l ++ full_list l l, existsi left_bintree l ++ right_bintree l ++ full_list l l, refl,
  cases ht,
  existsi ht_w,
  intros t t' h1 h2,
  split,
  begin -- full
    rewrite ht_h,
    apply list.mem_append_right,
    apply full_bintree_correct,
    repeat {assumption}
  end,
  split,
  begin -- left
    rewrite ht_h,
    apply list.mem_append_left, apply list.mem_append_left,
    apply left_bintree_correct, assumption
  end,
  begin -- right
    rewrite ht_h,
    apply list.mem_append_left, apply list.mem_append_right,
    apply right_bintree_correct, assumption
  end
end

lemma bounded_height_list : ∀ h : ℕ, ∃ l : list bintree, ∀ t : bintree,
                                        height t ≤ h → t ∈ l :=
begin
  intros h, induction h,
  begin
    existsi list.nil, intros t a,
    simp at a, exfalso, exact a
  end,
  begin
    cases h_n,
    begin -- actuall induction basis
      existsi ([●]),
      intros t h,
      cases t,
      simp,
      repeat { simp at h, exfalso, exact h },
    end,
    begin
      cases h_ih,
      cases (cross_product_bintree h_ih_w),
      existsi (list.cons ● w),
      intros t ht,
      cases t,
      begin apply list.mem_cons_self end,
      repeat {
        apply list.mem_cons_of_mem,
        have hi : ● ∈ h_ih_w, apply h_ih_h, unfold height, omega,
        have hj : t ∈ h_ih_w, apply h_ih_h, unfold height at ht, omega,
        try {exact (and.left (and.right (h t ● hj hi)))},
        try {exact (and.right (and.right (h ● t hi hj)))}
      },
      apply list.mem_cons_of_mem,
      have hm : height t_a ≤ max (height t_a) (height t_a_1), apply le_max_left,
      have hn : height t_a_1 ≤ max (height t_a) (height t_a_1), apply le_max_right,
      have hi : t_a ∈ h_ih_w, apply h_ih_h, unfold height at ht, omega,
      have hj : t_a_1 ∈ h_ih_w, apply h_ih_h, unfold height at ht, omega,
      exact (and.left (h t_a t_a_1 hi hj)),
    end
  end
end


import Mathlib.Data.Nat.Basic

universe u

namespace project

structure HeapNodeAux (α : Type u) (h : Type u) where
  val : α
  rank : Nat
  children : h

-- A `Heap` is a forest of binomial trees.
inductive Heap (α : Type u) : Type u where
  | heap (ns : List (HeapNodeAux α (Heap α))) : Heap α
  deriving Inhabited

open Heap
-- A `BinTree` is a binomial tree. If a `BinTree` has rank `k`, its children
-- have ranks between `0` and `k - 1`. They are ordered by rank. Additionally,
-- the value of each child must be greater than or equal to the value of its
-- parent node.
abbrev BinTree α := HeapNodeAux α (Heap α)

def Heap.nodes : Heap α → List (BinTree α)
  | heap ns => ns

@[simp]
theorem Heap.nodes_def : nodes (heap xs) = xs := rfl

variable {α : Type u}

def hRank : List (BinTree α) → Nat
  | []   => 0
  | h::_ => h.rank

def isEmpty : Heap α → Bool
  | heap [] => true
  | _       => false

def empty : Heap α :=
  heap []

def singleton (a : α) : Heap α :=
  heap [{ val := a, rank := 1, children := heap [] }]

-- Combine two binomial trees of rank `r`, creating a binomial tree of rank
-- `r + 1`.
@[specialize] def combine (le : α → α → Bool) (n₁ n₂ : BinTree α) : BinTree α :=
  if le n₂.val n₁.val then
     { n₂ with rank := n₂.rank + 1, children := heap $ n₂.children.nodes ++ [n₁] }
  else
     { n₁ with rank := n₁.rank + 1, children := heap $ n₁.children.nodes ++ [n₂] }

-- Merge two forests of binomial trees. The forests are assumed to be ordered
-- by rank and `mergeNodes` maintains this invariant.
@[specialize] def mergeNodes (le : α → α → Bool) : List (BinTree α) → List (BinTree α) → List (BinTree α)
  | [], h  => h
  | h,  [] => h
  | f@(h₁ :: t₁), s@(h₂ :: t₂) =>
    if h₁.rank < h₂.rank then h₁ :: mergeNodes le t₁ s
    else if h₂.rank < h₁.rank then h₂ :: mergeNodes le t₂ f
    else
      let merged := combine le h₁ h₂
      let r      := merged.rank
      if r != hRank t₁ then
        if r != hRank t₂ then merged :: mergeNodes le t₁ t₂ else mergeNodes le (merged :: t₁) t₂
      else
        if r != hRank t₂ then mergeNodes le t₁ (merged :: t₂) else merged :: mergeNodes le t₁ t₂
termination_by _ h₁ h₂ => h₁.length + h₂.length
decreasing_by simp_wf; simp_arith [*]

@[specialize] def merge (le : α → α → Bool) : Heap α → Heap α → Heap α
  | heap h₁, heap h₂ => heap (mergeNodes le h₁ h₂)

@[specialize] def head? (le : α → α → Bool) : Heap α → Option α
  | heap []      => none
  | heap (h::hs) => some $
    hs.foldl (init := h.val) fun r n => if le r n.val then r else n.val

@[inline] def head [Inhabited α] (le : α → α → Bool) (h : Heap α) : α :=
  head? le h |>.getD default

@[specialize] def findMin (le : α → α → Bool) : List (BinTree α) → Nat → BinTree α × Nat → BinTree α × Nat
  | [],    _,   r          => r
  | h::hs, idx, (h', idx') => if le h'.val h.val then findMin le hs (idx+1) (h', idx') else findMin le hs (idx+1) (h, idx)
    -- It is important that we check `le h'.val h.val` here, not the other way
    -- around. This ensures that head? and findMin find the same element even
    -- when we have `le h'.val h.val` and `le h.val h'.val` (i.e. le is not
    -- irreflexive).

def deleteMin (le : α → α → Bool) : Heap α → Option (α × Heap α)
  | heap [] => none
  | heap [h] => some (h.val, h.children)
  | heap hhs@(h::hs) =>
    let (min, minIdx) := findMin le hs 1 (h, 0)
    let rest          := hhs.eraseIdx minIdx
    let tail          := merge le (heap rest) min.children
    some (min.val, tail)

@[inline] def tail? (le : α → α → Bool) (h : Heap α) : Option (Heap α) :=
  deleteMin le h |>.map (·.snd)

@[inline] def tail (le : α → α → Bool) (h : Heap α) : Heap α :=
  tail? le h |>.getD empty

partial def toList (le : α → α → Bool) (h : Heap α) : List α :=
  match deleteMin le h with
  | none          => []
  | some (hd, tl) => hd :: toList le tl

partial def toArray (le : α → α → Bool) (h : Heap α) : Array α :=
  go #[] h
  where
    go (acc : Array α) (h : Heap α) : Array α :=
      match deleteMin le h with
      | none => acc
      | some (hd, tl) => go (acc.push hd) tl

partial def toListUnordered : Heap α → List α
  | heap ns => ns.bind fun n => n.val :: toListUnordered n.children

partial def toArrayUnordered (h : Heap α) : Array α :=
  go #[] h
  where
    go (acc : Array α) : Heap α → Array α
      | heap ns => Id.run do
        let mut acc := acc
        for n in ns do
          acc := acc.push n.val
          acc := go acc n.children
        return acc

mutual
  inductive IsBinTree : BinTree α → Prop where
  | mk: IsRankedTree 1 a.rank a.children.nodes → IsBinTree a

  /-IsRankedTree n m ts :<=> the list ts contains the children of the parentnode of a binomial tree, IsRankedTree
  assures that the order of the rank of the children is n, n+1, n+2,.....,m-1 and if n = m, then ts is empty-/
  -- fix me: IsBinForest
  inductive IsRankedTree : Nat → Nat → List (BinTree α)  → Prop where
  | nil : IsRankedTree n n []
  | cons : t.rank = n  → IsRankedTree (n + 1) m ts → IsBinTree t → IsRankedTree n m (t::ts)
end

/-IsHeapForest' rank [t₁,...,tₙ] :<=> Each tree in the list t₁ upto tₙ should have a smaller rank than the tree
that follows so tₙ.rank < tₙ₊₁. Also each tree in the list should be a binomial tree so IsBinTree t should hold for each tree t-/
inductive IsHeapForest' : Nat → List (BinTree α) → Prop where
| nil : IsHeapForest' rank []
| cons : rank < t.rank → IsBinTree t → IsHeapForest' t.rank ts → IsHeapForest' rank (t::ts)

abbrev IsHeapForest : List (BinTree α) → Prop := IsHeapForest' 0

/-IsHeap h calls IsHeapForest with the list of trees extracted from h-/
def IsHeap (h : Heap α): Prop :=
  IsHeapForest h.nodes

mutual
  inductive IsSearchTree (le : α → α → Bool) : BinTree α → Prop where
  | mk : IsMinTree le a.val a.children.nodes → IsSearchTree le a

  /-IsMinHeap le val ns :<=> assures that val(value of parent node) is less or equal than the value
  of the nodes in ns (the children). Maintains minimum heap property-/
  inductive IsMinTree (le : α → α → Bool) : α → List (BinTree α) → Prop where
  | nil : IsMinTree le val []
  | cons : le val n.val → IsMinTree le val ns → IsSearchTree le n → IsMinTree le val (n::ns)
end

/-IsMinHeap le (heap [t₁,...,tₙ]) :<=> IsMinHeap holds if for each tree t in the list t₁ upto tₙ, IsSearchTree le t holds-/
inductive IsMinHeap (le : α → α → Bool) : Heap α → Prop where
| nil : IsMinHeap le (heap [])
| cons : IsSearchTree le n → IsMinHeap le (heap ns) → IsMinHeap le (heap (n::ns))

theorem IsHeap_empty : IsHeap (@empty α) := by
  constructor

theorem IsMinHeap_empty : IsMinHeap le (@empty α) := by
  constructor

theorem singleton_IsHeap : IsHeap (singleton a) := by
  constructor
  . dsimp
    decide
  . constructor
    dsimp
    constructor
  . constructor

theorem singleton_IsMinHeap : IsMinHeap le (singleton a) := by
  constructor
  . constructor
    dsimp
    constructor
  . constructor

theorem IsRankedTree_append (rt : IsRankedTree n m xs) (ha: IsBinTree a) (hrank: a.rank = m) :
  IsRankedTree n (m + 1) (xs ++ [a]) := by
  induction xs generalizing n
  case nil =>
    simp
    cases rt
    constructor
    . assumption
    . constructor
    . assumption
  case cons _ _ ih =>
    cases rt
    constructor
    . assumption
    . apply ih
      assumption
    . assumption

theorem combine_trees_IsBinTree (le : α → α → Bool) (a b : BinTree α) :
  IsBinTree a → IsBinTree b → a.rank = b.rank → IsBinTree (combine le a b) := by
    intros ha hb hab
    constructor
    unfold combine
    split
    . dsimp
      cases hb
      apply IsRankedTree_append
      repeat assumption
    . dsimp
      cases ha
      apply IsRankedTree_append
      repeat assumption
      simp_all

theorem IsMinTree_append (h : IsMinTree le m xs) (ha : IsSearchTree le a) (hba: le m a.val = true) :
  IsMinTree le m (xs ++ [a]) := by
    induction xs with
    | nil =>
      simp
      constructor <;> assumption
    | cons _ _ ih =>
      cases h
      constructor
      . assumption
      . simp
        apply ih
        assumption
      . assumption

variable {le : α → α → Bool} (not_le_le : ∀ x y, ¬ le x y → le y x)
theorem combine_trees_IsSearchTree (a b : BinTree α) :
  IsSearchTree le a → IsSearchTree le b → IsSearchTree le (combine le a b) := by
    intros ha hb
    constructor
    unfold combine
    split
    . dsimp
      cases hb
      apply IsMinTree_append
      repeat assumption
    . dsimp
      cases ha
      apply IsMinTree_append
      repeat assumption
      apply not_le_le
      assumption


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

/-!
# `L^p` distance on finite products of metric spaces
Given finitely many metric spaces, one can put the max distance on their product, but there is also
a whole family of natural distances, indexed by a real parameter `p ∈ [1, ∞)`, that also induce
the product topology. We define them in this file. The distance on `Π i, α i` is given by
$$
d(x, y) = \left(\sum d(x_i, y_i)^p\right)^{1/p}.
$$

We give instances of this construction for emetric spaces, metric spaces, normed groups and normed
spaces.

To avoid conflicting instances, all these are defined on a copy of the original Pi type, named
`pi_Lp p α`. The assumpion `[fact (1 ≤ p)]` is required for the metric and normed space instances.

We ensure that the topology and uniform structure on `pi_Lp p α` are (defeq to) the product
topology and product uniformity, to be able to use freely continuity statements for the coordinate
functions, for instance.

## Implementation notes

We only deal with the `L^p` distance on a product of finitely many metric spaces, which may be
distinct. A closely related construction is the `L^p` norm on the space of
functions from a measure space to a normed space, where the norm is
$$
\left(\int ∥f (x)∥^p dμ\right)^{1/p}.
$$
However, the topology induced by this construction is not the product topology, this only
defines a seminorm (as almost everywhere zero functions have zero `L^p` norm), and some functions
have infinite `L^p` norm. All these subtleties are not present in the case of finitely many
metric spaces (which corresponds to the basis which is a finite space with the counting measure),
hence it is worth devoting a file to this specific case which is particularly well behaved.
The general case is not yet formalized in mathlib.

To prove that the topology (and the uniform structure) on a finite product with the `L^p` distance
are the same as those coming from the `L^∞` distance, we could argue that the `L^p` and `L^∞` norms
are equivalent on `ℝ^n` for abstract (norm equivalence) reasons. Instead, we give a more explicit
(easy) proof which provides a comparison between these two norms with explicit constants.

We also set up the theory for `pseudo_emetric_space` and `pseudo_metric_space`.
-/

open real set filter is_R_or_C
open_locale big_operators uniformity topological_space nnreal ennreal

noncomputable theory

variables {ι : Type*}

/-- A copy of a Pi type, on which we will put the `L^p` distance. Since the Pi type itself is
already endowed with the `L^∞` distance, we need the type synonym to avoid confusing typeclass
resolution. Also, we let it depend on `p`, to get a whole family of type on which we can put
different distances. -/
@[nolint unused_arguments]
def pi_Lp {ι : Type*} (p : ℝ) (α : ι → Type*) : Type* := Π (i : ι), α i

instance {ι : Type*} (p : ℝ) (α : ι → Type*) [∀ i, inhabited (α i)] : inhabited (pi_Lp p α) :=
⟨λ i, default (α i)⟩

lemma fact_one_le_one_real : fact ((1:ℝ) ≤ 1) := ⟨rfl.le⟩
lemma fact_one_le_two_real : fact ((1:ℝ) ≤ 2) := ⟨one_le_two⟩

namespace pi_Lp

variables (p : ℝ) [fact_one_le_p : fact (1 ≤ p)] (α : ι → Type*) (β : ι → Type*)

/-- Canonical bijection between `pi_Lp p α` and the original Pi type. We introduce it to be able
to compare the `L^p` and `L^∞` distances through it. -/
protected def equiv : pi_Lp p α ≃ Π (i : ι), α i :=
equiv.refl _

section
/-!
### The uniformity on finite `L^p` products is the product uniformity

In this section, we put the `L^p` edistance on `pi_Lp p α`, and we check that the uniformity
coming from this edistance coincides with the product uniformity, by showing that the canonical
map to the Pi type (with the `L^∞` distance) is a uniform embedding, as it is both Lipschitz and
antiLipschitz.

We only register this emetric space structure as a temporary instance, as the true instance (to be
registered later) will have as uniformity exactly the product uniformity, instead of the one coming
from the edistance (which is equal to it, but not defeq). See Note [forgetful inheritance]
explaining why having definitionally the right uniformity is often important.
-/

variables [∀ i, emetric_space (α i)] [∀ i, pseudo_emetric_space (β i)] [fintype ι]
include fact_one_le_p

/-- Endowing the space `pi_Lp p β` with the `L^p` pseudoedistance. This definition is not
satisfactory, as it does not register the fact that the topology and the uniform structure coincide
with the product one. Therefore, we do not register it as an instance. Using this as a temporary
pseudoemetric space instance, we will show that the uniform structure is equal (but not defeq) to
the product one, and then register an instance in which we replace the uniform structure by the
product one using this pseudoemetric space and `pseudo_emetric_space.replace_uniformity`. -/
def pseudo_emetric_aux : pseudo_emetric_space (pi_Lp p β) :=
have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
{ edist          := λ f g, (∑ (i : ι), (edist (f i) (g i)) ^ p) ^ (1/p),
  edist_self     := λ f, by simp [edist, ennreal.zero_rpow_of_pos pos,
                                  ennreal.zero_rpow_of_pos (inv_pos.2 pos)],
  edist_comm     := λ f g, by simp [edist, edist_comm],
  edist_triangle := λ f g h, calc
    (∑ (i : ι), edist (f i) (h i) ^ p) ^ (1 / p) ≤
    (∑ (i : ι), (edist (f i) (g i) + edist (g i) (h i)) ^ p) ^ (1 / p) :
    begin
      apply ennreal.rpow_le_rpow _ (one_div_nonneg.2 $ le_of_lt pos),
      refine finset.sum_le_sum (λ i hi, _),
      exact ennreal.rpow_le_rpow (edist_triangle _ _ _) (le_trans zero_le_one fact_one_le_p.out)
    end
    ... ≤
    (∑ (i : ι), edist (f i) (g i) ^ p) ^ (1 / p) + (∑ (i : ι), edist (g i) (h i) ^ p) ^ (1 / p) :
      ennreal.Lp_add_le _ _ _ fact_one_le_p.out }

/-- Endowing the space `pi_Lp p α` with the `L^p` edistance. This definition is not satisfactory,
as it does not register the fact that the topology and the uniform structure coincide with the
product one. Therefore, we do not register it as an instance. Using this as a temporary emetric
space instance, we will show that the uniform structure is equal (but not defeq) to the product
one, and then register an instance in which we replace the uniform structure by the product one
using this emetric space and `emetric_space.replace_uniformity`. -/
def emetric_aux : emetric_space (pi_Lp p α) :=
{ eq_of_edist_eq_zero := λ f g hfg,
  begin
    have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
    letI h := pseudo_emetric_aux p α,
    have h : edist f g = (∑ (i : ι), (edist (f i) (g i)) ^ p) ^ (1/p) := rfl,
    simp [h, ennreal.rpow_eq_zero_iff, pos, asymm pos, finset.sum_eq_zero_iff_of_nonneg] at hfg,
    exact funext hfg
  end,
  ..pseudo_emetric_aux p α }

local attribute [instance] pi_Lp.emetric_aux pi_Lp.pseudo_emetric_aux

lemma lipschitz_with_equiv : lipschitz_with 1 (pi_Lp.equiv p β) :=
begin
  have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
  have cancel : p * (1/p) = 1 := mul_div_cancel' 1 (ne_of_gt pos),
  assume x y,
  simp only [edist, forall_prop_of_true, one_mul, finset.mem_univ, finset.sup_le_iff,
             ennreal.coe_one],
  assume i,
  calc
  edist (x i) (y i) = (edist (x i) (y i) ^ p) ^ (1/p) :
    by simp [← ennreal.rpow_mul, cancel, -one_div]
  ... ≤ (∑ (i : ι), edist (x i) (y i) ^ p) ^ (1 / p) :
  begin
    apply ennreal.rpow_le_rpow _ (one_div_nonneg.2 $ le_of_lt pos),
    exact finset.single_le_sum (λ i hi, (bot_le : (0 : ℝ≥0∞) ≤ _)) (finset.mem_univ i)
  end
end

lemma antilipschitz_with_equiv :
  antilipschitz_with ((fintype.card ι : ℝ≥0) ^ (1/p)) (pi_Lp.equiv p β) :=
begin
  have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
  have nonneg : 0 ≤ 1 / p := one_div_nonneg.2 (le_of_lt pos),
  have cancel : p * (1/p) = 1 := mul_div_cancel' 1 (ne_of_gt pos),
  assume x y,
  simp [edist, -one_div],
  calc (∑ (i : ι), edist (x i) (y i) ^ p) ^ (1 / p) ≤
  (∑ (i : ι), edist (pi_Lp.equiv p β x) (pi_Lp.equiv p β y) ^ p) ^ (1 / p) :
  begin
    apply ennreal.rpow_le_rpow _ nonneg,
    apply finset.sum_le_sum (λ i hi, _),
    apply ennreal.rpow_le_rpow _ (le_of_lt pos),
    exact finset.le_sup (finset.mem_univ i)
  end
  ... = (((fintype.card ι : ℝ≥0)) ^ (1/p) : ℝ≥0) *
    edist (pi_Lp.equiv p β x) (pi_Lp.equiv p β y) :
  begin
    simp only [nsmul_eq_mul, finset.card_univ, ennreal.rpow_one, finset.sum_const,
      ennreal.mul_rpow_of_nonneg _ _ nonneg, ←ennreal.rpow_mul, cancel],
    have : (fintype.card ι : ℝ≥0∞) = (fintype.card ι : ℝ≥0) :=
      (ennreal.coe_nat (fintype.card ι)).symm,
    rw [this, ennreal.coe_rpow_of_nonneg _ nonneg]
  end
end

lemma aux_uniformity_eq :
  𝓤 (pi_Lp p β) = @uniformity _ (Pi.uniform_space _) :=
begin
  have A : uniform_inducing (pi_Lp.equiv p β) :=
    (antilipschitz_with_equiv p β).uniform_inducing
    (lipschitz_with_equiv p β).uniform_continuous,
  have : (λ (x : pi_Lp p β × pi_Lp p β),
    ((pi_Lp.equiv p β) x.fst, (pi_Lp.equiv p β) x.snd)) = id,
    by ext i; refl,
  rw [← A.comap_uniformity, this, comap_id]
end

end

/-! ### Instances on finite `L^p` products -/

instance uniform_space [∀ i, uniform_space (β i)] : uniform_space (pi_Lp p β) :=
Pi.uniform_space _

variable [fintype ι]
include fact_one_le_p

/-- pseudoemetric space instance on the product of finitely many pseudoemetric spaces, using the
`L^p` pseudoedistance, and having as uniformity the product uniformity. -/
instance [∀ i, pseudo_emetric_space (β i)] : pseudo_emetric_space (pi_Lp p β) :=
(pseudo_emetric_aux p β).replace_uniformity (aux_uniformity_eq p β).symm

/-- emetric space instance on the product of finitely many emetric spaces, using the `L^p`
edistance, and having as uniformity the product uniformity. -/
instance [∀ i, emetric_space (α i)] : emetric_space (pi_Lp p α) :=
(emetric_aux p α).replace_uniformity (aux_uniformity_eq p α).symm

omit fact_one_le_p
protected lemma edist {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [∀ i, pseudo_emetric_space (β i)] (x y : pi_Lp p β) :
  edist x y = (∑ (i : ι), (edist (x i) (y i)) ^ p) ^ (1/p) := rfl
include fact_one_le_p

/-- pseudometric space instance on the product of finitely many psuedometric spaces, using the
`L^p` distance, and having as uniformity the product uniformity. -/
instance [∀ i, pseudo_metric_space (β i)] : pseudo_metric_space (pi_Lp p β) :=
begin
  /- we construct the instance from the pseudo emetric space instance to avoid checking again that
  the uniformity is the same as the product uniformity, but we register nevertheless a nice formula
  for the distance -/
  have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
  refine pseudo_emetric_space.to_pseudo_metric_space_of_dist
    (λf g, (∑ (i : ι), (dist (f i) (g i)) ^ p) ^ (1/p)) (λ f g, _) (λ f g, _),
  { simp [pi_Lp.edist, ennreal.rpow_eq_top_iff, asymm pos, pos,
          ennreal.sum_eq_top_iff, edist_ne_top] },
  { have A : ∀ (i : ι), i ∈ (finset.univ : finset ι) → edist (f i) (g i) ^ p ≠ ⊤ :=
      λ i hi, by simp [lt_top_iff_ne_top, edist_ne_top, le_of_lt pos],
    simp [dist, -one_div, pi_Lp.edist, ← ennreal.to_real_rpow,
          ennreal.to_real_sum A, dist_edist] }
end

/-- metric space instance on the product of finitely many metric spaces, using the `L^p` distance,
and having as uniformity the product uniformity. -/
instance [∀ i, metric_space (α i)] : metric_space (pi_Lp p α) :=
begin
  /- we construct the instance from the emetric space instance to avoid checking again that the
  uniformity is the same as the product uniformity, but we register nevertheless a nice formula
  for the distance -/
  have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
  refine emetric_space.to_metric_space_of_dist
    (λf g, (∑ (i : ι), (dist (f i) (g i)) ^ p) ^ (1/p)) (λ f g, _) (λ f g, _),
  { simp [pi_Lp.edist, ennreal.rpow_eq_top_iff, asymm pos, pos,
          ennreal.sum_eq_top_iff, edist_ne_top] },
  { have A : ∀ (i : ι), i ∈ (finset.univ : finset ι) → edist (f i) (g i) ^ p ≠ ⊤ :=
      λ i hi, by simp [edist_ne_top, pos.le],
    simp [dist, -one_div, pi_Lp.edist, ← ennreal.to_real_rpow,
          ennreal.to_real_sum A, dist_edist] }
end

omit fact_one_le_p
protected lemma dist {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [∀ i, pseudo_metric_space (β i)] (x y : pi_Lp p β) :
  dist x y = (∑ (i : ι), (dist (x i) (y i)) ^ p) ^ (1/p) := rfl
include fact_one_le_p

/-- seminormed group instance on the product of finitely many normed groups, using the `L^p`
norm. -/
instance semi_normed_group [∀i, semi_normed_group (β i)] : semi_normed_group (pi_Lp p β) :=
{ norm := λf, (∑ (i : ι), norm (f i) ^ p) ^ (1/p),
  dist_eq := λ x y, by { simp [pi_Lp.dist, dist_eq_norm, sub_eq_add_neg] },
  .. pi.add_comm_group }

/-- normed group instance on the product of finitely many normed groups, using the `L^p` norm. -/
instance normed_group [∀i, normed_group (α i)] : normed_group (pi_Lp p α) :=
{ ..pi_Lp.semi_normed_group p α }

omit fact_one_le_p
lemma norm_eq {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [∀i, semi_normed_group (β i)] (f : pi_Lp p β) :
  ∥f∥ = (∑ (i : ι), ∥f i∥ ^ p) ^ (1/p) := rfl

lemma norm_eq_of_nat {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [∀i, semi_normed_group (β i)] (n : ℕ) (h : p = n) (f : pi_Lp p β) :
  ∥f∥ = (∑ (i : ι), ∥f i∥ ^ n) ^ (1/(n : ℝ)) :=
by simp [norm_eq, h, real.sqrt_eq_rpow, ←real.rpow_nat_cast]
include fact_one_le_p

variables (𝕜 : Type*) [normed_field 𝕜]

/-- The product of finitely many seminormed spaces is a seminormed space, with the `L^p` norm. -/
instance semi_normed_space [∀i, semi_normed_group (β i)] [∀i, semi_normed_space 𝕜 (β i)] :
  semi_normed_space 𝕜 (pi_Lp p β) :=
{ norm_smul_le :=
  begin
    assume c f,
    have : p * (1 / p) = 1 := mul_div_cancel' 1 (lt_of_lt_of_le zero_lt_one fact_one_le_p.out).ne',
    simp only [pi_Lp.norm_eq, norm_smul, mul_rpow, norm_nonneg, ←finset.mul_sum, pi.smul_apply],
    rw [mul_rpow (rpow_nonneg_of_nonneg (norm_nonneg _) _), ← rpow_mul (norm_nonneg _),
        this, rpow_one],
    exact finset.sum_nonneg (λ i hi, rpow_nonneg_of_nonneg (norm_nonneg _) _)
  end,
  .. pi.module ι β 𝕜 }

/-- The product of finitely many normed spaces is a normed space, with the `L^p` norm. -/
instance normed_space [∀i, normed_group (α i)] [∀i, normed_space 𝕜 (α i)] :
  normed_space 𝕜 (pi_Lp p α) :=
{ ..pi_Lp.semi_normed_space p α 𝕜 }

/- Register simplification lemmas for the applications of `pi_Lp` elements, as the usual lemmas
for Pi types will not trigger. -/
variables {𝕜 p α}
[∀i, semi_normed_group (β i)] [∀i, semi_normed_space 𝕜 (β i)] (c : 𝕜) (x y : pi_Lp p β) (i : ι)

@[simp] lemma add_apply : (x + y) i = x i + y i := rfl
@[simp] lemma sub_apply : (x - y) i = x i - y i := rfl
@[simp] lemma smul_apply : (c • x) i = c • x i := rfl
@[simp] lemma neg_apply : (-x) i = - (x i) := rfl

end pi_Lp


/-
Copyright (c) 2020 Bjørn Kjos-Hanssen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Bjørn Kjos-Hanssen.
Zulip chat help from:
Alex J. Best, Johan Commelin, Kyle Miller, Pedro Minicz, Reid Barton, Scott Morrison, Heather Macbeth.
-/
import data.finset  -- finite set
import data.set -- to make backslash work as set difference
import data.finset.basic
import topology.metric_space.basic

import data.real.basic

/-!
# A theorem on metrics based on min and max
In this file we give a formal proof of Theorem 17 from [KNYHLM21].
It asserts that d(X,Y)= m min(|X\Y|, |Y\X|) + M max(|X\Y|, |Y\X|) is a metric
if and only if m ≤ M.
## Main results
- `seventeen`: the proof of Theorem 17.
- `instance jaccard_numerator.metric_space`: the realization as a `metric_space` type.
## Notation
 - `|_|` : Notation for cardinality.
## References
See [KNYHLM21] for the original proof.
-/

open finset

local notation |X| := X.card

-- Kyle Miller (start) although proofs of disj1, disj2 due to K-H

variables {α : Type*} [decidable_eq α]

lemma disj₁ (X Y Z : finset α) : disjoint ((X \ Y) ∪ (Y \ Z)) (Z \ X) := by { rw disjoint_iff, tidy}
lemma disj₂ (X Y Z : finset α) : disjoint (X \ Y) (Y \ Z) := by { rw disjoint_iff, tidy}

lemma union_rot_sdiff (X Y Z : finset α) :
    (X \ Y) ∪ (Y \ Z) ∪ (Z \ X) = (X \ Z) ∪ (Z \ Y) ∪ (Y \ X) :=
    by { tidy, by_cases h: a∈ Z,cc,cc,by_cases h:a ∈ X,cc,cc,by_cases h: a ∈ Y, cc, cc,
    by_cases h: a ∈ Y, cc, cc, by_cases h: a ∈ X, cc, cc, by_cases h: a ∈ Z, cc, cc,
    }
    --by { ext, simp only [mem_union, mem_sdiff, union_assoc], tauto! }

lemma card_rot (X Y Z : finset α) : |X \ Y| + |Y \ Z| + |Z \ X| = |X \ Z| + |Z \ Y| + |Y \ X| := by {
    have key := congr_arg card (union_rot_sdiff X Y Z),

    rwa [
        card_disjoint_union (disj₁ X Y Z), card_disjoint_union (disj₁ X Z Y),
        card_disjoint_union (disj₂ X Y Z), card_disjoint_union (disj₂ X Z Y)
    ] at key,
}

-- Kyle Miller (end)

lemma card_rot_cast (X Y Z : finset α) : ((|X\Y| + |Y\Z| + |Z\X|):ℝ) = ((|X\Z| + |Z\Y| + |Y\X|):ℝ) :=
    have |X\Y| + |Y\Z| + |Z\X| = |X\Z| + |Z\Y| + |Y\X|, from card_rot X Y Z,
    by { norm_cast,exact this }

variables {m M : ℝ}
--set_option profiler true

def δ : ℝ → ℝ → finset α → (finset α → ℝ) :=
    λ m M A B, M * ↑ (max (|A\B|) (|B\A|)) + m * ↑ (min (|A\B|) (|B\A|))

theorem delta_cast {m M:ℝ} {A B : finset α} :
    δ m M A B = M * (max ↑(|A\B|) ↑(|B\A|)) + m * (min ↑(|A\B|) ↑(|B\A|)) := by norm_cast

theorem delta_comm {m M : ℝ} {A B : finset α}: δ m M A B = δ m M B A := -- improved December 25, 2020
    calc δ m M A B = M * ↑ (max (|A\B|) (|B\A|)) + m * ↑ (min (|A\B|) (|B\A|)) : by rw[δ]
               ... = M * max (|A\B|) (|B\A|) + m * min (|A\B|) (|B\A|)         : by norm_cast
               ... = M * max (|B\A|) (|A\B|) + m * min (|B\A|) (|A\B|)         : by rw[max_comm,min_comm]
               ... = M * ↑ (max (|B\A|) (|A\B|)) + m * ↑ (min (|B\A|) (|A\B|)) : by norm_cast
               ... = δ m M B A                                                 : by rw[δ]

lemma card_sdiff_self (X : finset α) : |X \ X| = 0 :=
  calc |X \ X| = |(∅: finset α)|: by rw (sdiff_self X)
           ... = 0: card_empty

theorem delta_self (X : finset α): δ m M X X = 0 := -- improved December 25, 2020
    calc  δ m M X X = M * ((max (|X \ X|) (|X \ X|)):ℝ) + m * ((min (|X \ X|) (|X \ X|)):ℝ) : by norm_cast
                ... = M * ((max 0   0  ):ℝ)             + m * ((min 0   0  ):ℝ)             : by {rw[card_sdiff_self],norm_cast,}
                ... = M * ((max (0:ℝ)   (0:ℝ)  ))       + m * ((min (0:ℝ)   (0:ℝ)  ))       : by norm_cast
                ... = M * (0:ℝ)                         + m * (0:ℝ)                         : by rw[max_self (0:ℝ), min_self (0:ℝ)]
                ... = 0                                                                     : by rw[mul_zero, zero_add,mul_zero]

lemma subseteq_of_card_zero (x y : finset α) : |x \ y| = 0 → x ⊆ y :=
    λ h : |x \ y| = 0,
    have v: x \ y = ∅, from (iff.elim_left (finset.card_eq_zero)) h,
    (iff.elim_left finset.sdiff_eq_empty_iff_subset) v

lemma card_zero_of_not_pos (X : finset α) : ¬ 0 < |X| → |X| = 0 :=
    λ h: ¬ 0 < |X|,
    eq.symm ((iff.elim_right eq_iff_le_not_lt) (and.intro (nat.zero_le (|X|)) h))

lemma eq_zero_of_nonneg_of_nonneg_of_add_zero {a b : ℝ} : 0 ≤ a → 0 ≤ b → 0 = a + b → 0 = a :=
    λ ha: 0 ≤ a, λ hb: 0 ≤ b, λ h: 0 = a + b,
    have h1: ¬ 0 < a, from
        assume h2: 0 < a,
        have h4: 0 < a + b, from lt_add_of_lt_of_nonneg h2 hb,
        have h3: 0 ≤ a + b ∧ ¬ 0 < a + b, from (iff.elim_left eq_iff_le_not_lt) h,
        h3.elim_right h4,
    have h0: 0 ≤ a ∧ ¬ 0 < a, from and.intro ha h1,
    (iff.elim_right eq_iff_le_not_lt) h0

theorem subset_of_delta_eq_zero (hm: 0 < m) (hM: m ≤ M) (X Y : finset α) (h: δ m M X Y = 0) : X ⊆ Y :=
    let x_y := |X \ Y| in let y_x := |Y \ X| in -- improved December 25, 2020
    /- The following interacts poorly with casting
    let maxN := max x_y y_x in let minN := min x_y y_x in
    let maxR := (maxN : ℝ) in let minR := (minN : ℝ) in
    -/
    have δ_0: 0 = M * ((max x_y y_x):ℝ) + m * ((min x_y y_x):ℝ), from calc
              0 = δ m M X Y : by rw h
            ... = M * ((max x_y y_x):ℝ) + m * ((min x_y y_x):ℝ) : by norm_cast,
    have not_pos_δ: ¬ 0 < M * ((max x_y y_x):ℝ) + m * ((min x_y y_x):ℝ), from
        (iff.elim_right (not_lt_iff_eq_or_lt)) (or.inl δ_0),
    have min_nonneg: 0 ≤ ((min x_y y_x):ℝ),
        begin norm_cast, exact (le_min (nat.zero_le x_y) (nat.zero_le y_x)) end,
    have M_pos: 0 < M, from calc
                0 < m : hm
              ... ≤ M : hM,

    have pos_δ_of_pos_x: 0 < x_y → 0 < M * ((max x_y y_x):ℝ) + m * ((min x_y y_x):ℝ), from
        λ h: 0 < x_y,
        have strict_x: 0 <  (max x_y y_x), from
            (iff.elim_right lt_max_iff) (or.inl h),
        have cast_x: 0 <  ((max x_y y_x):ℝ),
            begin norm_cast, exact strict_x end,
        have Mx_pos: 0 < (M * ((max x_y y_x):ℝ)), from
            mul_pos M_pos cast_x,
        lt_add_of_lt_of_nonneg Mx_pos (mul_nonneg (le_of_lt hm) min_nonneg),

    have r0: ¬ 0 < x_y, from λ pos_x, not_pos_δ (pos_δ_of_pos_x pos_x),

    subseteq_of_card_zero X Y (card_zero_of_not_pos (X\Y) r0)

 theorem eq_of_delta_eq_zero (hm: 0 < m) (hM: m ≤ M) (X Y : finset α) (h: δ m M X Y = 0) :
 X = Y :=
    let x_y := |X \ Y| in let y_x := |Y \ X| in
 have g0: X ⊆ Y, from subset_of_delta_eq_zero hm hM X Y h,
 have g: δ m M Y X = 0, from calc δ m M Y X = δ m M X Y: by rw[delta_comm]
 ... = 0: h,
 have g1: Y ⊆ X, from subset_of_delta_eq_zero hm hM Y X g,
     finset.subset.antisymm g0 g1

theorem sdiff_covering {A B C : finset α}: A\C ⊆ (A\B) ∪ (B\C) := by {tidy, by_cases h: a ∈ B,cc,cc,}

theorem sdiff_triangle (A B C: finset α): |A\C| ≤ |A\B| + |B\C| :=
    calc |A\C| ≤ |A\B  ∪ B\C|: finset.card_le_of_subset (sdiff_covering)
           ... = |A\B| + |B\C| : by rw (finset.card_disjoint_union (disj₂ A B C))

lemma venn (X Y : finset α): X = X\Y ∪ (X ∩ Y) := begin ext, simp, tauto! end

lemma venn_card (X Y : finset α): |X| = |X\Y| + |X ∩ Y| :=
    have h: disjoint (X\Y) (X ∩ Y), by tidy,
    calc
    |X| = |X \ Y  ∪  X ∩ Y| : by rw ← (venn X Y)
    ... = |X \ Y| + |X ∩ Y| : finset.card_disjoint_union h

lemma sdiff_card (X Y : finset α): |Y| ≤ |X| → |Y\X| ≤ |X\Y| :=
    assume h: |Y| ≤ |X|,
    have h₀: |Y\X| + |Y ∩ X| ≤ |X\Y| + |X ∩ Y|,
        begin
            rw (venn_card X Y) at h,
            rw (venn_card Y X) at h,
            exact h
        end,
    have h₁: Y ∩ X = X ∩ Y, {tidy},
    have h₂: |Y ∩ X| = |X ∩ Y|, {rw h₁},
    have h₃: |Y\X| + |X ∩ Y| ≤ |X\Y| + |X ∩ Y|,
        begin rw h₂ at h₀, exact h₀ end,
    begin tidy end -- tidy is now able to figure out that a+c ≤ b+c → a ≤ c should be used on h₃

lemma maxmin_1 {X Y : finset α}: |X| ≤ |Y| → δ m M X Y = M * |Y\X| + m * |X\Y| :=
    let x_y := |X\Y| in let y_x := |Y\X| in
    assume h₁: |X| ≤ |Y|,
        have h₂: x_y ≤ y_x, from sdiff_card Y X h₁,
        calc δ m M X Y = M * ↑ (max x_y y_x) + m * ↑(min x_y y_x) : rfl
                   ... = M * ↑ y_x            + m * ↑ x_y : by rw[max_eq_right h₂,min_eq_left h₂]

lemma maxmin_2 {X Y : finset α}: |Y| ≤ |X| → δ m M X Y = M * |X\Y| + m * |Y\X| :=
-- resolve max and min
    let x_y := |X\Y| in let y_x := |Y\X| in
    assume h₁: |Y| ≤ |X|,
        have h₂: y_x ≤ x_y, from sdiff_card X Y h₁,
        calc δ m M X Y = M * ↑ (max x_y y_x) + m * ↑(min x_y y_x) : rfl
                   ... = M * ↑ x_y            + m * ↑y_x : by rw[max_eq_left h₂,min_eq_right h₂]

theorem casting {a b : ℕ}: a ≤ b → (a:ℝ) ≤ (b:ℝ) :=
    begin intro h, norm_cast, exact h end

theorem mul_sdiff_tri (m : ℝ) (hm: 0 ≤ m) (X Y Z : finset α):
    m * ↑ |X\Z| ≤ m * (↑ |X\Y| + ↑ |Y\Z|) :=
    calc m * ↑ (|X\Z|)
       ≤ m * ↑ ((|X\Y|) + (|Y\Z|)) : mul_le_mul_of_nonneg_left (casting(sdiff_triangle X Y Z)) hm
   ... = m * ((|X\Y|:ℝ) + (|Y\Z|:ℝ)): by norm_cast

def triangle_inequality (m M :ℝ) (X Y Z: finset α) : Prop :=
    δ m M X Y ≤ δ m M X Z + δ m M Z Y

lemma seventeen_right_yzx {m M :ℝ} {X Y Z: finset α} :
    0 ≤ m → m ≤ M → |Y| ≤ |Z| ∧ |Z| ≤ |X| → triangle_inequality m M X Y Z
    :=
    let x := |X|, y := |Y|, z := |Z|,
        x_z := |X\Z|, z_x := |Z\X|, y_z := |Y\Z|,
        z_y := |Z\Y|, x_y := |X\Y|, y_x := |Y\X| in
    λ hm : 0 ≤ m, λ h: m ≤ M,
    have hM : 0 ≤ M, from le_trans hm h,
    assume h₀: y ≤ z ∧ z ≤ x,
    have h₂: y ≤ z, from and.elim_left h₀,
    have h₃: z ≤ x, from and.elim_right h₀,
    have h₁: y ≤ x, from le_trans h₂ h₃,
    have dxz: δ m M X Z = M * (x_z) + m * (z_x), from maxmin_2 h₃,
    have dzy: δ m M Z Y = M * (z_y) + m * (y_z), from maxmin_2 h₂,--used implicitly by a tactic

    have mst_yzx: m* ↑ (|Y\X|) ≤ m *  (↑ (y_z) + ↑ (z_x)), from
        mul_sdiff_tri m hm Y Z X,
    have mst_xzy: M* ↑ (x_y) ≤ M *  (↑ (x_z) + ↑ (z_y)), from
        mul_sdiff_tri M hM X Z Y,
    calc
    δ m M X Y = M * (x_y) + m * (|Y\X|)                   : maxmin_2 h₁
          ... ≤ M * (x_y) + m * ((y_z) + (z_x))           : add_le_add_left mst_yzx (M * (x_y))
          ... ≤ M * (x_z + z_y) + m * (y_z + z_x)         : add_le_add_right mst_xzy (m * ((y_z) + (z_x)))
          ... = (M * x_z + m * z_x) + (M * z_y + m * y_z) : by ring
          ... = δ m M X Z                     + δ m M Z Y : by rw[dxz,dzy]

lemma co_sdiff (X Y U : finset α):
X ⊆ U → Y ⊆ U → (U\X)\(U\Y) = Y\X := by tidy

lemma co_sdiff_card (X Y U : finset α):
X ⊆ U → Y ⊆ U → ((U\X)\(U\Y)).card = (Y\X).card :=
    λ hx: X ⊆ U, λ hy: Y ⊆ U,
    by {rw co_sdiff X Y U, exact hx,exact hy,}

lemma co_sdiff_card_max (X Y U : finset α):
X ⊆ U → Y ⊆ U → max (|(U\Y)\(U\X)|) (|(U\X)\(U\Y)|) = max (|X\Y|) (|Y\X|) :=
    λ hx: X ⊆ U, λ hy: Y ⊆ U,
    by {rw[co_sdiff_card X Y U hx hy,co_sdiff_card Y X U hy hx],}

lemma co_sdiff_card_min (X Y U : finset α):
X ⊆ U → Y ⊆ U → min (|(U\Y)\(U\X)|) (|(U\X)\(U\Y)|) = min (|X\Y|) (|Y\X|) :=
    λ hx: X ⊆ U, λ hy: Y ⊆ U,
    by {rw[co_sdiff_card X Y U hx hy,co_sdiff_card Y X U hy hx],}

theorem delta_complement (X Y U : finset α):
    X ⊆ U → Y ⊆ U → δ m M X Y = δ m M (U\Y) (U\X) :=
    λ hx: X ⊆ U, λ hy: Y ⊆ U,
    let Y' := U\Y, X' := U\X in
    have co1: |X'\Y'| = |Y\X|, from co_sdiff_card X Y U hx hy,
    have co2: |Y'\X'| = |X\Y|, from co_sdiff_card Y X U hy hx,
    have co3: max (|Y'\X'|) (|X'\Y'|) = max (|X\Y|) (|Y\X|), from
        co_sdiff_card_max X Y U hx hy,
    have co4: min (|Y'\X'|) (|X'\Y'|) = min (|X\Y|) (|Y\X|), from
        co_sdiff_card_min X Y U hx hy,
    have defi: δ m M Y' X' = M * ↑ (max (|Y'\X'|) (|X'\Y'|)) + m * ↑ (min (|Y'\X'|) (|X'\Y'|)),
    from refl (δ m M Y' X'),
    calc δ m M X Y = M * ↑ (max (|X\Y|) (|Y\X|)) + m * ↑ (min (|X\Y|) (|Y\X|)): refl (δ m M X Y)
    ... = M * ↑ (max (|Y'\X'|) (|X'\Y'|)) + m * ↑ (min (|X\Y|) (|Y\X|)): by rw co3
    ... = M * ↑ (max (|Y'\X'|) (|X'\Y'|)) + m * ↑ (min (|Y'\X'|) (|X'\Y'|)): by rw co4
    ... =  δ m M Y' X': by rw defi

theorem seventeen_right_yxz {X Y Z : finset α}:
    0 ≤ m → m ≤ M → |Y| ≤ |X| ∧ |X| ≤ |Z| → triangle_inequality m M X Y Z :=
    let x := |X| in let y := |Y| in let z := |Z| in
    let x_z := |X\Z| in let z_x := |Z\X| in let y_z := |Y\Z| in
    let z_y := |Z\Y| in let x_y := |X\Y| in let y_x := |Y\X| in
    λ hm: 0 ≤ m, λ h: m ≤ M, λ h₀: y ≤ x ∧ x ≤ z,
    have hyz: y ≤ z, from le_trans (and.elim_left h₀) (and.elim_right h₀),
    have gxz: x_z ≤ z_x, from sdiff_card Z X (and.elim_right h₀),
    have gyz: y_z ≤ z_y, from sdiff_card Z Y hyz,
    have dxy: δ m M X Y = M * x_y + m * y_x, from maxmin_2 (and.elim_left h₀),
    have dzy: δ m M Z Y = M * z_y + m * y_z, from maxmin_2 hyz,
    have dxz: δ m M X Z = M * z_x + m * x_z, from calc
                δ m M X Z = δ m M Z X                 : delta_comm
                    ... = M * (z_x) + m * (x_z) : maxmin_2 (and.elim_right h₀),
    have Mmpos: 0 ≤ M-m, from sub_nonneg_of_le h,
    have h02: 0 ≤ (2:ℝ), by {have zt: 0 ≤ 2, from nat.zero_le 2, norm_cast, exact zt, },
    have h2m: 0 ≤ 2*m, from mul_nonneg h02 hm,
    have tri_1:   2 * m * y_x ≤ 2 * m * (y_z + z_x), from mul_sdiff_tri (2*m) h2m Y Z X,
    have tri_2: (M-m) * x_y ≤ (M-m) * (x_z + z_y), from mul_sdiff_tri (M-m) Mmpos X Z Y,

    have tri_3:  (M-m) * x_z ≤ (M-m) * z_x, from mul_le_mul_of_nonneg_left (casting(gxz)) Mmpos,
    have triangle_add: (δ m M X Y) + (m * y_x) ≤ (δ m M X Z + δ m M Z Y) + (m * y_x), from
        let
            term_1 := (M * x_y),
            term_2 := (m*(x_z+z_y+y_x) + m*(y_z+z_x)),
            term_3 := (m*(x_z +z_y +y_x) + (M-m) * z_y + m*z_x + m*y_z)
        in calc   (δ m M X Y)     + (m * y_x)
            = (M * x_y + m * y_x) + (m * y_x)                             : by rw dxy
        ... = M * x_y + 2 * m * y_x                                       : by ring
        ... ≤ M * x_y + 2 * m * (y_z+z_x)                                 : add_le_add_left tri_1 term_1
        ... = m*(x_y+y_z+z_x) + m*(y_z+z_x) + (M-m)*x_y                   : by ring
        ... = m*(x_z+z_y+y_x) + m*(y_z+z_x) + (M-m)*x_y                   : by rw card_rot_cast
        ... ≤ m*(x_z+z_y+y_x) + m*(y_z+z_x) + (M-m)*(x_z+ z_y)            : add_le_add_left tri_2 term_2
        ... = m*(x_z+z_y+y_x) + (M-m) * z_y + m*z_x + m*y_z + (M-m) * x_z : by ring
        ... ≤ m*(x_z+z_y+y_x) + (M-m) * z_y + m*z_x + m*y_z + (M-m) * z_x : add_le_add_left tri_3 term_3
        ... = (M * z_x + m * x_z)        + (M * z_y + m * y_z) + (m * y_x): by ring
        ... = (δ m M X Z                 +          δ m M Z Y) + (m * y_x): by rw[dxz,dzy],
    le_of_add_le_add_right triangle_add

lemma sdiff_card_le (X Y U : finset α) (hx: X ⊆ U) (hy: Y ⊆ U) (h:|X| ≤ |Y|):
    |U \ Y| ≤ |U \ X| :=
    have hu: |U| - |Y| ≤ |U| - |X|, from nat.sub_le_sub_left (|U|) h,
    calc
        |U \ Y| = |U| - |Y| : card_sdiff hy
            ... ≤ |U| - |X| : hu
            ... = |U \ X|   : by rw[card_sdiff hx]

theorem seventeen_right_zyx{m M : ℝ} {X Y Z : finset α}:
    0 ≤ m → m ≤ M → |Z| ≤ |Y| ∧ |Y| ≤ |X| → triangle_inequality m M X Y Z :=
    λ hm, λ hM, λ h,
    let
        U := X ∪ Y ∪ Z,
        Z' : finset α := (X ∪ Y ∪ Z) \ Z,
        Y' : finset α := (X ∪ Y ∪ Z) \ Y,
        X' : finset α := (X ∪ Y ∪ Z) \ X
    in
    have hx: X ⊆ U, by {tidy,cc},
    have hy: Y ⊆ U, by {tidy,cc},
    have hz: Z ⊆ U, by {tidy,cc},

    have and1: |X'| ≤ |Y'|, from sdiff_card_le Y X U hy hx h.right,
    have and2: |Y'| ≤ |Z'|, from sdiff_card_le Z Y U hz hy h.left,
    have hh: |X'| ≤ |Y'| ∧ |Y'| ≤ |Z'|, from and.intro and1 and2,
    have h1: δ m M X' Z' = δ m M Z X, from (delta_complement Z X U hz hx).symm,
    have h2: δ m M Z' Y' = δ m M Y Z, from (delta_complement Y Z U hy hz).symm,
    have h3: δ m M Y Z = δ m M Z Y, from delta_comm,
    calc δ m M X Y = δ m M Y' X'               : delta_complement X Y U hx hy
               ... ≤ δ m M Y' Z' + δ m M Z' X' : seventeen_right_yxz hm hM hh
               ... = δ m M X' Z' + δ m M Z' Y' : by rw[delta_comm,add_comm,delta_comm]
               ... = δ m M Z  X  + δ m M Z' Y' : by rw[h1]
               ... = δ m M X  Z  + δ m M Z' Y' : by rw[delta_comm]
               ... = δ m M X  Z  + δ m M Y  Z  : by rw[h2]
               ... = δ m M X  Z  + δ m M Z  Y  : by rw[h3]

theorem seventeen_right_zxy {X Y Z : finset α}:
    0 ≤ m → m ≤ M → |Z| ≤ |X| ∧ |X| ≤ |Y| → triangle_inequality m M X Y Z :=
    λ hm: 0 ≤ m, λ h: m ≤ M, λ hyp: |Z| ≤ |X| ∧ |X| ≤ |Y|,
    have hyz: δ m M Y Z = δ m M Z Y, from delta_comm,
    have hzx: δ m M Z X = δ m M X Z, from delta_comm,
    calc
    δ m M X Y = δ m M Y X             : delta_comm
          ... ≤ δ m M Y Z + δ m M Z X : seventeen_right_zyx hm h hyp
          ... = δ m M Z X + δ m M Y Z : add_comm (δ m M Y Z) (δ m M Z X)
          ... = δ m M X Z + δ m M Z Y : by rw[hyz,hzx]

theorem three_places {x y z : ℕ} :
    y ≤ x → (z ≤ y ∧ y ≤ x) ∨ (y ≤ z ∧ z ≤ x) ∨ (y ≤ x ∧ x ≤ z) :=
    assume hyx : y ≤ x,
    (le_total z y).elim(
        assume h: z ≤ y, or.inl (and.intro h hyx)
    )(
        assume h: y ≤ z,
        (le_total z x).elim(
            assume h1: z ≤ x, or.inr (or.inl (and.intro h h1))
        )(
            assume h1: x ≤ z, or.inr (or.inr (and.intro hyx h1))
    ))

theorem seventeen_right_y_le_x {m M : ℝ} {X Y Z : finset α} :
    |Y| ≤ |X| → 0 ≤ m → m ≤ M → triangle_inequality m M X Y Z :=
    let x := |X| in let y := |Y| in let z := |Z| in
    λ h: y ≤ x, λ hm: 0 ≤ m, λ hmM: m ≤ M,
    (three_places h).elim(
        λ h1, seventeen_right_zyx hm hmM h1
    )(
        λ h1: y≤ z ∧ z ≤ x ∨ y ≤ x ∧ x ≤ z,
        h1.elim(
            λ h2, seventeen_right_yzx hm hmM h2
        )(
            λ h2, seventeen_right_yxz hm hmM h2
        )
    )

theorem seventeen_right_x_le_y {m M : ℝ} {X Y Z : finset α} :
    |X| ≤ |Y| → 0 ≤ m → m ≤ M → triangle_inequality m M X Y Z :=
    λ h: |X| ≤ |Y|, λ hm: 0 ≤ m, λ hmM: m ≤ M,
    have hh: δ m M Y Z = δ m M Z Y, from delta_comm,
    have gg: δ m M Z X = δ m M X Z, from delta_comm,
    calc
    δ m M X Y = δ m M Y X : delta_comm
        ... ≤ δ m M Y Z + δ m M Z X : seventeen_right_y_le_x h hm hmM
        ... = δ m M Z X + δ m M Y Z : add_comm (δ m M Y Z) (δ m M Z X)
        ... = δ m M X Z + δ m M Z Y: by rw[hh,gg]

theorem seventeen_right {m M : ℝ} { X Y Z : finset α}:
    0 ≤ m → m ≤ M → triangle_inequality m M X Y Z :=
    λ hm: 0 ≤ m, λ h: m ≤ M,
    (le_total (|X|) (|Y|)).elim (
        λ h1: |X| ≤ |Y|, seventeen_right_x_le_y h1 hm h
    )(
        λ h1: |Y| ≤ |X|, seventeen_right_y_le_x h1 hm h
    )

def s_0 : finset ℕ := ({0}: finset ℕ)
def s_1 : finset ℕ := ({1}: finset ℕ)
def s01 : finset ℕ := ({0,1} : finset ℕ)
theorem seventeen: (∃ x y : α, x ≠ y) →
    0 ≤ m → (m ≤ M ↔ ∀ X Y Z : finset α, triangle_inequality m M X Y Z) :=
    λ typ : ∃ x y : α, x ≠ y,
    λ hm: 0 ≤ m,
    exists.elim typ (
        λ x : α, λ ty : ∃ y : α, x ≠ y,
        exists.elim ty (
            λ y : α, λ t : x ≠ y,
            let s_x : finset α := ({x}: finset α) in
            let s_y : finset α := ({y}: finset α) in
            let sxy : finset α := ({x,y} : finset α) in
            have h₀: m ≤ M → ∀ X Y Z : finset α, triangle_inequality m M X Y Z, from
                λ h: m ≤ M, λ X Y Z, seventeen_right hm h,
            have h₁: (∀ X Y Z : finset α, triangle_inequality m M X Y Z) → m ≤ M, from
                assume hyp: (∀ X Y Z : finset α, triangle_inequality m M X Y Z),
                have hh: δ m M s_x s_y ≤ δ m M s_x sxy + δ m M sxy s_y, from hyp s_x s_y sxy,
                have cyx: (|s_y\s_x|:ℝ) = (1:ℝ), from
                  have g:|s_y\s_x| = |s_y|, from
                    have h:s_y\s_x = s_y, by tidy,
                    congr_arg finset.card h,
                  have h:|s_y| = 1, from by tidy,
                  have i:|s_y\s_x| = 1, from eq.trans g h,
                by {norm_cast, exact i,},

                have cxy: (|s_x\s_y|:ℝ) = (1:ℝ), from
                  have g:|s_x\s_y| = |s_x|, from
                    have h2:s_x\s_y = s_x, from by tidy,
                    congr_arg finset.card h2,
                  have i:|s_x| = 1, from by tidy,
                  have |s_x\s_y| = 1, from eq.trans g i,
                  by {norm_cast,exact this,},

                have cxz: (|s_x\sxy|:ℝ) = (0:ℝ), from
                  have g:|s_x\sxy| =   |(∅:finset α)|, from
                    have h3:s_x\sxy =   ∅, from by tidy,
                    congr_arg finset.card h3,
                  have i:|(∅:finset α)| = 0, from by tidy,
                  have |s_x\sxy| = 0, from eq.trans g i,
                  by {norm_cast,exact this,},

                have czx: (|sxy\s_x|:ℝ) = (1:ℝ), from
                  have g:|sxy\s_x| = |s_y|, from
                    have sxy\s_x = s_y, from by tidy,
                    congr_arg finset.card this,
                  have i:|s_y| = 1, from by tidy,
                  have |sxy\s_x| = 1, from eq.trans g i,
                  by {norm_cast, exact this,},

                have cyz: (|s_y\sxy|:ℝ) = (0:ℝ), from
                  have g:|s_y\sxy| =  |(∅:finset α)| , from
                    have s_y\sxy =  ∅ , from by tidy,
                    congr_arg finset.card this,
                  have i:|(∅:finset α)| = 0, from by tidy,
                  have |s_y\sxy| = 0, from eq.trans g i,
                  by {norm_cast, exact this,},

                have czy: (|sxy\s_y|:ℝ) = (1:ℝ), from
                  have g:|sxy\s_y| = |s_x|, from
                    have sxy\s_y = s_x, from by tidy,
                    congr_arg finset.card this,
                  have i:|s_x| = 1, from by tidy,
                  have |sxy\s_y| = 1, from eq.trans g i,
                  by {norm_cast, exact this,},

                have dxy: δ m M s_x s_y = M + m , from calc
                    δ m M s_x s_y = M * max ↑(|s_x\s_y|) ↑(|s_y\s_x|)
                                + m * min ↑(|s_x\s_y|) ↑(|s_y\s_x|): delta_cast
                            ... = M * max    (1:ℝ)  (1:ℝ)   + m * min (1:ℝ)    (1:ℝ): by rw[cxy,cyx]
                            ... = M + m : by tidy,
                have dxz: δ m M s_x sxy = M, from calc
                        δ m M s_x sxy = M * max (|s_x\sxy|) (|sxy\s_x|)
                                        + m * min (|s_x\sxy|) (|sxy\s_x|): delta_cast
                                    ... = M * max 0 1 + m * min 0 1: by rw[cxz,czx]
                                    ... = M  : by tidy,
                have dzy: δ m M sxy s_y = M, from calc
                        δ m M sxy s_y = M * max (|sxy\s_y|) (|s_y\sxy|)
                                        + m * min (|sxy\s_y|) (|s_y\sxy|): delta_cast
                                    ... = M * max 1 0 + m * min (1) 0: by rw[czy,cyz]
                                    ... = M  : by tidy,
                have add_le_add_left : M + m ≤ M + M, from calc
                    M + m = δ m M s_x s_y : by rw[dxy]
                    ... ≤  δ m M s_x sxy + δ m M sxy s_y: hh
                    ... = M + M: by begin rw[dxz,dzy] end,
                le_of_add_le_add_left
                    add_le_add_left,
            iff.intro h₀ h₁
        )

    )

    def delta_triangle (X Y Z: finset α) (hm: 0 < m) (hM: m ≤ M):
    triangle_inequality m M X Z Y
    --δ m M X Y ≤ δ m M X Z + δ m M Z Y
    := seventeen_right (le_of_lt hm) hM

    section jaccard_numerator
    /-- Instantiate finset ℕ as a metric space. -/

    def protein {m M : ℝ} (hm : 0 < m) (hM : m ≤ M) := finset α

    noncomputable instance jaccard_numerator.metric_space (typ: (∃ x y : α, x ≠ y)) (hm : 0 < m) (hM : m ≤ M): metric_space (protein hm hM) := {
        dist               := λx y, δ m M x y,
        dist_self          := delta_self,
        eq_of_dist_eq_zero := eq_of_delta_eq_zero hm hM,
        dist_comm          := λ x y, delta_comm,
        dist_triangle      := λ x y z, ((iff.elim_left (seventeen typ (le_of_lt hm))) hM) x z y
    }
end jaccard_numerator


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll
-/

import analysis.special_functions.integrals
import analysis.special_functions.pow
import measure_theory.integral.layercake
import tactic.positivity

/-!
# Japanese Bracket

In this file, we show that Japanese bracket $(1 + \|x\|^2)^{1/2}$ can be estimated from above
and below by $1 + \|x\|$.
The functions $(1 + \|x\|^2)^{-r/2}$ and $(1 + |x|)^{-r}$ are integrable provided that `r` is larger
than the dimension.

## Main statements

* `integrable_one_add_norm`: the function $(1 + |x|)^{-r}$ is integrable
* `integrable_jap` the Japanese bracket is integrable

-/

noncomputable theory

open_locale big_operators nnreal filter topology ennreal

open asymptotics filter set real measure_theory finite_dimensional

variables {E : Type*} [normed_add_comm_group E]

lemma sqrt_one_add_norm_sq_le (x : E) : real.sqrt (1 + ‖x‖^2) ≤ 1 + ‖x‖ :=
begin
  refine le_of_pow_le_pow 2 (by positivity) two_pos _,
  simp [sq_sqrt (zero_lt_one_add_norm_sq x).le, add_pow_two],
end

lemma one_add_norm_le_sqrt_two_mul_sqrt (x : E) : 1 + ‖x‖ ≤ (real.sqrt 2) * sqrt (1 + ‖x‖^2) :=
begin
  suffices : (sqrt 2 * sqrt (1 + ‖x‖ ^ 2)) ^ 2 - (1 + ‖x‖) ^ 2 = (1 - ‖x‖) ^2,
  { refine le_of_pow_le_pow 2 (by positivity) (by norm_num) _,
    rw [←sub_nonneg, this],
    positivity, },
  rw [mul_pow, sq_sqrt (zero_lt_one_add_norm_sq x).le, add_pow_two, sub_pow_two],
  norm_num,
  ring,
end

lemma rpow_neg_one_add_norm_sq_le {r : ℝ} (x : E) (hr : 0 < r) :
  (1 + ‖x‖^2)^(-r/2) ≤ 2^(r/2) * (1 + ‖x‖)^(-r) :=
begin
  have h1 : 0 ≤ (2 : ℝ) := by positivity,
  have h3 : 0 < sqrt 2 := by positivity,
  have h4 : 0 < 1 + ‖x‖ := by positivity,
  have h5 : 0 < sqrt (1 + ‖x‖ ^ 2) := by positivity,
  have h6 : 0 < sqrt 2 * sqrt (1 + ‖x‖^2) := mul_pos h3 h5,
  rw [rpow_div_two_eq_sqrt _ h1, rpow_div_two_eq_sqrt _ (zero_lt_one_add_norm_sq x).le,
    ←inv_mul_le_iff (rpow_pos_of_pos h3 _), rpow_neg h4.le, rpow_neg (sqrt_nonneg _), ←mul_inv,
    ←mul_rpow h3.le h5.le, inv_le_inv (rpow_pos_of_pos h6 _) (rpow_pos_of_pos h4 _),
    rpow_le_rpow_iff h4.le h6.le hr],
  exact one_add_norm_le_sqrt_two_mul_sqrt _,
end

lemma le_rpow_one_add_norm_iff_norm_le {r t : ℝ} (hr : 0 < r) (ht : 0 < t) (x : E) :
  t ≤ (1 + ‖x‖) ^ -r ↔ ‖x‖ ≤ t ^ -r⁻¹ - 1 :=
begin
  rw [le_sub_iff_add_le', neg_inv],
  exact (real.le_rpow_inv_iff_of_neg (by positivity) ht (neg_lt_zero.mpr hr)).symm,
end

variables (E)

lemma closed_ball_rpow_sub_one_eq_empty_aux {r t : ℝ} (hr : 0 < r) (ht : 1 < t) :
  metric.closed_ball (0 : E) (t^(-r⁻¹) - 1) = ∅ :=
begin
  rw [metric.closed_ball_eq_empty, sub_neg],
  exact real.rpow_lt_one_of_one_lt_of_neg ht (by simp only [hr, right.neg_neg_iff, inv_pos]),
end

variables [normed_space ℝ E] [finite_dimensional ℝ E]

variables {E}

lemma finite_integral_rpow_sub_one_pow_aux {r : ℝ} (n : ℕ) (hnr : (n : ℝ) < r) :
  ∫⁻ (x : ℝ) in Ioc 0 1, ennreal.of_real ((x ^ -r⁻¹ - 1) ^ n) < ∞ :=
begin
  have hr : 0 < r := lt_of_le_of_lt n.cast_nonneg hnr,
  have h_int : ∀ (x : ℝ) (hx : x ∈ Ioc (0 : ℝ) 1),
    ennreal.of_real ((x ^ -r⁻¹ - 1) ^ n) ≤ ennreal.of_real (x ^ -(r⁻¹ * n)) :=
  begin
    intros x hx,
    have hxr : 0 ≤ x^ -r⁻¹ := rpow_nonneg_of_nonneg hx.1.le _,
    apply ennreal.of_real_le_of_real,
    rw [←neg_mul, rpow_mul hx.1.le, rpow_nat_cast],
    refine pow_le_pow_of_le_left _ (by simp only [sub_le_self_iff, zero_le_one]) n,
    rw [le_sub_iff_add_le', add_zero],
    refine real.one_le_rpow_of_pos_of_le_one_of_nonpos hx.1 hx.2 _,
    rw [right.neg_nonpos_iff, inv_nonneg],
    exact hr.le,
  end,
  refine lt_of_le_of_lt (set_lintegral_mono (by measurability) (by measurability) h_int) _,
  refine integrable_on.set_lintegral_lt_top _,
  rw ←interval_integrable_iff_integrable_Ioc_of_le zero_le_one,
  apply interval_integral.interval_integrable_rpow',
  rwa [neg_lt_neg_iff, inv_mul_lt_iff' hr, one_mul],
end

lemma finite_integral_one_add_norm [measure_space E] [borel_space E]
  [(@volume E _).is_add_haar_measure] {r : ℝ} (hnr : (finrank ℝ E : ℝ) < r) :
  ∫⁻ (x : E), ennreal.of_real ((1 + ‖x‖) ^ -r) < ∞ :=
begin
  have hr : 0 < r := lt_of_le_of_lt (finrank ℝ E).cast_nonneg hnr,

  -- We start by applying the layer cake formula
  have h_meas : measurable (λ (ω : E), (1 + ‖ω‖) ^ -r) := by measurability,
  have h_pos : ∀ x : E, 0 ≤ (1 + ‖x‖) ^ -r :=
  by { intros x, positivity },
  rw lintegral_eq_lintegral_meas_le volume h_pos h_meas,

  -- We use the first transformation of the integrant to show that we only have to integrate from
  -- 0 to 1 and from 1 to ∞
  have h_int : ∀ (t : ℝ) (ht : t ∈ Ioi (0 : ℝ)),
    (volume {a : E | t ≤ (1 + ‖a‖) ^ -r} : ennreal) =
    volume (metric.closed_ball (0 : E) (t^(-r⁻¹) - 1)) :=
  begin
    intros t ht,
    congr' 1,
    ext x,
    simp only [mem_set_of_eq, mem_closed_ball_zero_iff],
    exact le_rpow_one_add_norm_iff_norm_le hr (mem_Ioi.mp ht) x,
  end,
  rw set_lintegral_congr_fun measurable_set_Ioi (ae_of_all volume $ h_int),
  have hIoi_eq : Ioi (0 : ℝ) = Ioc (0 : ℝ) 1 ∪ Ioi 1 := (set.Ioc_union_Ioi_eq_Ioi zero_le_one).symm,
  have hdisjoint : disjoint (Ioc (0 : ℝ) 1) (Ioi 1) := by simp [disjoint_iff],
  rw [hIoi_eq, lintegral_union measurable_set_Ioi hdisjoint, ennreal.add_lt_top],

  have h_int' : ∀ (t : ℝ) (ht : t ∈ Ioc (0 : ℝ) 1),
    (volume (metric.closed_ball (0 : E) (t^(-r⁻¹) - 1)) : ennreal) =
    ennreal.of_real ((t^(-r⁻¹) - 1) ^ finite_dimensional.finrank ℝ E)
      * volume (metric.ball (0:E) 1) :=
  begin
    intros t ht,
    refine volume.add_haar_closed_ball (0 : E) _,
    rw [le_sub_iff_add_le', add_zero],
    exact real.one_le_rpow_of_pos_of_le_one_of_nonpos ht.1 ht.2 (by simp [hr.le]),
  end,
  have h_meas' : measurable (λ (a : ℝ), ennreal.of_real ((a ^ -r⁻¹ - 1) ^ finrank ℝ E)) :=
  by measurability,
  split,
  -- The integral from 0 to 1:
  { rw [set_lintegral_congr_fun measurable_set_Ioc (ae_of_all volume $ h_int'),
      lintegral_mul_const _ h_meas', ennreal.mul_lt_top_iff],
    left,
    -- We calculate the integral
    exact ⟨finite_integral_rpow_sub_one_pow_aux (finrank ℝ E) hnr, measure_ball_lt_top⟩ },

  -- The integral from 1 to ∞ is zero:
  have h_int'' : ∀ (t : ℝ) (ht : t ∈ Ioi (1 : ℝ)),
    (volume (metric.closed_ball (0 : E) (t^(-r⁻¹) - 1)) : ennreal) = 0 :=
  λ t ht, by rw [closed_ball_rpow_sub_one_eq_empty_aux E hr ht, measure_empty],

  -- The integral over the constant zero function is finite:
  rw [set_lintegral_congr_fun measurable_set_Ioi (ae_of_all volume $ h_int''), lintegral_const 0,
    zero_mul],
  exact with_top.zero_lt_top,
end

lemma integrable_one_add_norm [measure_space E] [borel_space E] [(@volume E _).is_add_haar_measure]
  {r : ℝ} (hnr : (finrank ℝ E : ℝ) < r) :
  integrable (λ (x : E), (1 + ‖x‖) ^ -r) :=
begin
  refine ⟨by measurability, _⟩,
  -- Lower Lebesgue integral
  have : ∫⁻ (a : E), ‖(1 + ‖a‖) ^ -r‖₊ = ∫⁻ (a : E), ennreal.of_real ((1 + ‖a‖) ^ -r) :=
  lintegral_nnnorm_eq_of_nonneg (λ _, rpow_nonneg_of_nonneg (by positivity) _),
  rw [has_finite_integral, this],
  exact finite_integral_one_add_norm hnr,
end

lemma integrable_rpow_neg_one_add_norm_sq [measure_space E] [borel_space E]
  [(@volume E _).is_add_haar_measure] {r : ℝ} (hnr : (finrank ℝ E : ℝ) < r) :
  integrable (λ (x : E), (1 + ‖x‖^2) ^ (-r/2)) :=
begin
  have hr : 0 < r := lt_of_le_of_lt (finrank ℝ E).cast_nonneg hnr,
  refine ((integrable_one_add_norm hnr).const_mul $ 2 ^ (r / 2)).mono (by measurability)
    (eventually_of_forall $ λ x, _),
  have h1 : 0 ≤ (1 + ‖x‖ ^ 2) ^ (-r/2) := by positivity,
  have h2 : 0 ≤ (1 + ‖x‖) ^ -r := by positivity,
  have h3 : 0 ≤ (2 : ℝ)^(r/2) := by positivity,
  simp_rw [norm_mul, norm_eq_abs, abs_of_nonneg h1, abs_of_nonneg h2, abs_of_nonneg h3],
  exact rpow_neg_one_add_norm_sq_le _ hr,
end


import data.matrix.basic linear_algebra.matrix data.polynomial linear_algebra.determinant linear_algebra.basic

open_locale classical
noncomputable theory

def sym_matrix {m α : Type*} [fintype m] (M: matrix m m α) : Prop :=
  M = M.transpose

lemma sym_matrix_apply {m α : Type*} [fintype m] {M: matrix m m α} (h : sym_matrix M) (i j : m):
  M i j = M j i:=
by { unfold sym_matrix at h, conv_rhs {rw h}, refl, }

variables (R : Type*) [ring R] -- should be semiring, but trace needs rings now

def matrix_J (m:Type*) [fintype m] : matrix m m R :=
  λ (i j:m), 1

@[simp] lemma matrix_J_apply (m:Type*) [fintype m] {i j : m} : matrix_J R m i j = 1 := rfl

lemma trace_J (m:Type*) [fintype m] :
matrix.trace m R R (matrix_J R m) = fintype.card m :=
begin
  rw matrix.trace,
  rw matrix_J,
  change (finset.univ.sum ∘ ⇑(matrix.diag m R R)) (λ (i j : m), 1) =
    ↑(fintype.card m),
  rw function.comp_apply,
  rw fintype.card,
  simp,
end