/-
Copyright (c) 2022 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import data.set.intervals.group
import analysis.convex.segment
import linear_algebra.affine_space.finite_dimensional
import linear_algebra.affine_space.midpoint_zero
import tactic.field_simp

/-!
# Betweenness in affine spaces

This file defines notions of a point in an affine space being between two given points.

## Main definitions

* `affine_segment R x y`: The segment of points weakly between `x` and `y`.
* `wbtw R x y z`: The point `y` is weakly between `x` and `z`.
* `sbtw R x y z`: The point `y` is strictly between `x` and `z`.

-/

variables (R : Type*) {V V' P P' : Type*}

open affine_equiv affine_map

open_locale big_operators

section ordered_ring

variables [ordered_ring R] [add_comm_group V] [module R V] [add_torsor V P]
variables [add_comm_group V'] [module R V'] [add_torsor V' P']

include V

/-- The segment of points weakly between `x` and `y`. When convexity is refactored to support
abstract affine combination spaces, this will no longer need to be a separate definition from
`segment`. However, lemmas involving `+ᵥ` or `-ᵥ` will still be relevant after such a
refactoring, as distinct from versions involving `+` or `-` in a module. -/
def affine_segment (x y : P) := line_map x y '' (set.Icc (0 : R) 1)

lemma affine_segment_eq_segment (x y : V) : affine_segment R x y = segment R x y :=
by rw [segment_eq_image_line_map, affine_segment]

lemma affine_segment_comm (x y : P) : affine_segment R x y = affine_segment R y x :=
begin
  refine set.ext (λ z, _),
  split;
    { rintro ⟨t, ht, hxy⟩,
      refine ⟨1 - t, _, _⟩,
      { rwa [set.sub_mem_Icc_iff_right, sub_self, sub_zero] },
      { rwa [line_map_apply_one_sub] } },
end

lemma left_mem_affine_segment (x y : P) : x ∈ affine_segment R x y :=
⟨0, set.left_mem_Icc.2 zero_le_one, line_map_apply_zero _ _⟩

lemma right_mem_affine_segment (x y : P) : y ∈ affine_segment R x y :=
⟨1, set.right_mem_Icc.2 zero_le_one, line_map_apply_one _ _⟩

include V'

variables {R}

@[simp] lemma affine_segment_image (f : P →ᵃ[R] P') (x y : P) :
  f '' affine_segment R x y = affine_segment R (f x) (f y) :=
begin
  rw [affine_segment, affine_segment, set.image_image, ←comp_line_map],
  refl
end

omit V'

variables (R)

@[simp] lemma affine_segment_const_vadd_image (x y : P) (v : V) :
  ((+ᵥ) v) '' affine_segment R x y = affine_segment R (v +ᵥ x) (v +ᵥ y) :=
affine_segment_image (affine_equiv.const_vadd R P v : P →ᵃ[R] P) x y

@[simp] lemma affine_segment_vadd_const_image (x y : V) (p : P) :
  (+ᵥ p) '' affine_segment R x y = affine_segment R (x +ᵥ p) (y +ᵥ p) :=
affine_segment_image (affine_equiv.vadd_const R p : V →ᵃ[R] P) x y

@[simp] lemma affine_segment_const_vsub_image (x y p : P) :
  ((-ᵥ) p) '' affine_segment R x y = affine_segment R (p -ᵥ x) (p -ᵥ y) :=
affine_segment_image (affine_equiv.const_vsub R p : P →ᵃ[R] V) x y

@[simp] lemma affine_segment_vsub_const_image (x y p : P) :
  (-ᵥ p) '' affine_segment R x y = affine_segment R (x -ᵥ p) (y -ᵥ p) :=
affine_segment_image ((affine_equiv.vadd_const R p).symm : P →ᵃ[R] V) x y

variables {R}

@[simp] lemma mem_const_vadd_affine_segment {x y z : P} (v : V) :
  v +ᵥ z ∈ affine_segment R (v +ᵥ x) (v +ᵥ y) ↔ z ∈ affine_segment R x y :=
by rw [←affine_segment_const_vadd_image, (add_action.injective v).mem_set_image]

@[simp] lemma mem_vadd_const_affine_segment {x y z : V} (p : P) :
  z +ᵥ p ∈ affine_segment R (x +ᵥ p) (y +ᵥ p) ↔ z ∈ affine_segment R x y :=
by rw [←affine_segment_vadd_const_image, (vadd_right_injective p).mem_set_image]
variables {R}

@[simp] lemma mem_const_vsub_affine_segment {x y z : P} (p : P) :
  p -ᵥ z ∈ affine_segment R (p -ᵥ x) (p -ᵥ y) ↔ z ∈ affine_segment R x y :=
by rw [←affine_segment_const_vsub_image, (vsub_right_injective p).mem_set_image]

@[simp] lemma mem_vsub_const_affine_segment {x y z : P} (p : P) :
  z -ᵥ p ∈ affine_segment R (x -ᵥ p) (y -ᵥ p) ↔ z ∈ affine_segment R x y :=
by rw [←affine_segment_vsub_const_image, (vsub_left_injective p).mem_set_image]

variables (R)

/-- The point `y` is weakly between `x` and `z`. -/
def wbtw (x y z : P) : Prop := y ∈ affine_segment R x z

/-- The point `y` is strictly between `x` and `z`. -/
def sbtw (x y z : P) : Prop := wbtw R x y z ∧ y ≠ x ∧ y ≠ z

variables {R}

include V'

lemma wbtw.map {x y z : P} (h : wbtw R x y z) (f : P →ᵃ[R] P') : wbtw R (f x) (f y) (f z) :=
begin
  rw [wbtw, ←affine_segment_image],
  exact set.mem_image_of_mem _ h
end

lemma function.injective.wbtw_map_iff {x y z : P} {f : P →ᵃ[R] P'} (hf : function.injective f) :
  wbtw R (f x) (f y) (f z) ↔ wbtw R x y z :=
begin
  refine ⟨λ h, _, λ h, h.map _⟩,
  rwa [wbtw, ←affine_segment_image, hf.mem_set_image] at h
end

lemma function.injective.sbtw_map_iff {x y z : P} {f : P →ᵃ[R] P'} (hf : function.injective f) :
  sbtw R (f x) (f y) (f z) ↔ sbtw R x y z :=
by simp_rw [sbtw, hf.wbtw_map_iff, hf.ne_iff]

@[simp] lemma affine_equiv.wbtw_map_iff {x y z : P} (f : P ≃ᵃ[R] P') :
  wbtw R (f x) (f y) (f z) ↔ wbtw R x y z :=
begin
  refine function.injective.wbtw_map_iff (_ : function.injective f.to_affine_map),
  exact f.injective
end

@[simp] lemma affine_equiv.sbtw_map_iff {x y z : P} (f : P ≃ᵃ[R] P') :
  sbtw R (f x) (f y) (f z) ↔ sbtw R x y z :=
begin
  refine function.injective.sbtw_map_iff (_ : function.injective f.to_affine_map),
  exact f.injective
end

omit V'

@[simp] lemma wbtw_const_vadd_iff {x y z : P} (v : V) :
  wbtw R (v +ᵥ x) (v +ᵥ y) (v +ᵥ z) ↔ wbtw R x y z :=
mem_const_vadd_affine_segment _

@[simp] lemma wbtw_vadd_const_iff {x y z : V} (p : P) :
  wbtw R (x +ᵥ p) (y +ᵥ p) (z +ᵥ p) ↔ wbtw R x y z :=
mem_vadd_const_affine_segment _

@[simp] lemma wbtw_const_vsub_iff {x y z : P} (p : P) :
  wbtw R (p -ᵥ x) (p -ᵥ y) (p -ᵥ z) ↔ wbtw R x y z :=
mem_const_vsub_affine_segment _

@[simp] lemma wbtw_vsub_const_iff {x y z : P} (p : P) :
  wbtw R (x -ᵥ p) (y -ᵥ p) (z -ᵥ p) ↔ wbtw R x y z :=
mem_vsub_const_affine_segment _

@[simp] lemma sbtw_const_vadd_iff {x y z : P} (v : V) :
  sbtw R (v +ᵥ x) (v +ᵥ y) (v +ᵥ z) ↔ sbtw R x y z :=
by simp_rw [sbtw, wbtw_const_vadd_iff, (add_action.injective v).ne_iff]

@[simp] lemma sbtw_vadd_const_iff {x y z : V} (p : P) :
  sbtw R (x +ᵥ p) (y +ᵥ p) (z +ᵥ p) ↔ sbtw R x y z :=
by simp_rw [sbtw, wbtw_vadd_const_iff, (vadd_right_injective p).ne_iff]

@[simp] lemma sbtw_const_vsub_iff {x y z : P} (p : P) :
  sbtw R (p -ᵥ x) (p -ᵥ y) (p -ᵥ z) ↔ sbtw R x y z :=
by simp_rw [sbtw, wbtw_const_vsub_iff, (vsub_right_injective p).ne_iff]

@[simp] lemma sbtw_vsub_const_iff {x y z : P} (p : P) :
  sbtw R (x -ᵥ p) (y -ᵥ p) (z -ᵥ p) ↔ sbtw R x y z :=
by simp_rw [sbtw, wbtw_vsub_const_iff, (vsub_left_injective p).ne_iff]

lemma sbtw.wbtw {x y z : P} (h : sbtw R x y z) : wbtw R x y z :=
h.1

lemma sbtw.ne_left {x y z : P} (h : sbtw R x y z) : y ≠ x :=
h.2.1

lemma sbtw.left_ne {x y z : P} (h : sbtw R x y z) : x ≠ y :=
h.2.1.symm

lemma sbtw.ne_right {x y z : P} (h : sbtw R x y z) : y ≠ z :=
h.2.2

lemma sbtw.right_ne {x y z : P} (h : sbtw R x y z) : z ≠ y :=
h.2.2.symm

lemma sbtw.mem_image_Ioo {x y z : P} (h : sbtw R x y z) :
  y ∈ line_map x z '' (set.Ioo (0 : R) 1) :=
begin
  rcases h with ⟨⟨t, ht, rfl⟩, hyx, hyz⟩,
  rcases set.eq_endpoints_or_mem_Ioo_of_mem_Icc ht with rfl|rfl|ho,
  { exfalso, simpa using hyx },
  { exfalso, simpa using hyz },
  { exact ⟨t, ho, rfl⟩ }
end

lemma wbtw.mem_affine_span {x y z : P} (h : wbtw R x y z) : y ∈ line[R, x, z] :=
begin
  rcases h with ⟨r, ⟨-, rfl⟩⟩,
  exact line_map_mem_affine_span_pair _ _ _
end

lemma wbtw_comm {x y z : P} : wbtw R x y z ↔ wbtw R z y x :=
by rw [wbtw, wbtw, affine_segment_comm]

alias wbtw_comm ↔ wbtw.symm _

lemma sbtw_comm {x y z : P} : sbtw R x y z ↔ sbtw R z y x :=
by rw [sbtw, sbtw, wbtw_comm, ←and_assoc, ←and_assoc, and.right_comm]

alias sbtw_comm ↔ sbtw.symm _

variables (R)

@[simp] lemma wbtw_self_left (x y : P) : wbtw R x x y :=
left_mem_affine_segment _ _ _

@[simp] lemma wbtw_self_right (x y : P) : wbtw R x y y :=
right_mem_affine_segment _ _ _

@[simp] lemma wbtw_self_iff {x y : P} : wbtw R x y x ↔ y = x :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { simpa [wbtw, affine_segment] using h },
  { rw h,
    exact wbtw_self_left R x x }
end

@[simp] lemma not_sbtw_self_left (x y : P) : ¬ sbtw R x x y :=
λ h, h.ne_left rfl

@[simp] lemma not_sbtw_self_right (x y : P) : ¬ sbtw R x y y :=
λ h, h.ne_right rfl

variables {R}

lemma wbtw.left_ne_right_of_ne_left {x y z : P} (h : wbtw R x y z) (hne : y ≠ x) : x ≠ z :=
begin
  rintro rfl,
  rw wbtw_self_iff at h,
  exact hne h
end

lemma wbtw.left_ne_right_of_ne_right {x y z : P} (h : wbtw R x y z) (hne : y ≠ z) : x ≠ z :=
begin
  rintro rfl,
  rw wbtw_self_iff at h,
  exact hne h
end

lemma sbtw.left_ne_right {x y z : P} (h : sbtw R x y z) : x ≠ z :=
h.wbtw.left_ne_right_of_ne_left h.2.1

lemma sbtw_iff_mem_image_Ioo_and_ne [no_zero_smul_divisors R V] {x y z : P} :
  sbtw R x y z ↔ y ∈ line_map x z '' (set.Ioo (0 : R) 1) ∧ x ≠ z :=
begin
  refine ⟨λ h, ⟨h.mem_image_Ioo, h.left_ne_right⟩, λ h, _⟩,
  rcases h with ⟨⟨t, ht, rfl⟩, hxz⟩,
  refine ⟨⟨t, set.mem_Icc_of_Ioo ht, rfl⟩, _⟩,
  rw [line_map_apply, ←@vsub_ne_zero V, ←@vsub_ne_zero V _ _ _ _ z, vadd_vsub_assoc,
      vadd_vsub_assoc, ←neg_vsub_eq_vsub_rev z x, ←@neg_one_smul R, ←add_smul,
      ←sub_eq_add_neg],
  simp [smul_ne_zero, hxz.symm, sub_eq_zero, ht.1.ne.symm, ht.2.ne]
end

variables (R)

@[simp] lemma not_sbtw_self (x y : P) : ¬ sbtw R x y x :=
λ h, h.left_ne_right rfl

lemma wbtw_swap_left_iff [no_zero_smul_divisors R V] {x y : P} (z : P) :
  (wbtw R x y z ∧ wbtw R y x z) ↔ x = y :=
begin
  split,
  { rintro ⟨hxyz, hyxz⟩,
    rcases hxyz with ⟨ty, hty, rfl⟩,
    rcases hyxz with ⟨tx, htx, hx⟩,
    simp_rw [line_map_apply, ←add_vadd] at hx,
    rw [←@vsub_eq_zero_iff_eq V, vadd_vsub, vsub_vadd_eq_vsub_sub, smul_sub, smul_smul,
        ←sub_smul, ←add_smul, smul_eq_zero] at hx,
    rcases hx with h|h,
    { nth_rewrite 0 ←mul_one tx at h,
      rw [←mul_sub, add_eq_zero_iff_neg_eq] at h,
      have h' : ty = 0,
      { refine le_antisymm _ hty.1,
        rw [←h, left.neg_nonpos_iff],
        exact mul_nonneg htx.1 (sub_nonneg.2 hty.2) },
      simp [h'] },
    { rw vsub_eq_zero_iff_eq at h,
      simp [h] } },
  { rintro rfl,
    exact ⟨wbtw_self_left _ _ _, wbtw_self_left _ _ _⟩ }
end

lemma wbtw_swap_right_iff [no_zero_smul_divisors R V] (x : P) {y z : P} :
  (wbtw R x y z ∧ wbtw R x z y) ↔ y = z :=
begin
  nth_rewrite 0 wbtw_comm,
  nth_rewrite 1 wbtw_comm,
  rw eq_comm,
  exact wbtw_swap_left_iff R x
end

lemma wbtw_rotate_iff [no_zero_smul_divisors R V] (x : P) {y z : P} :
  (wbtw R x y z ∧ wbtw R z x y) ↔ x = y :=
by rw [wbtw_comm, wbtw_swap_right_iff, eq_comm]

variables {R}

lemma wbtw.swap_left_iff [no_zero_smul_divisors R V] {x y z : P} (h : wbtw R x y z) :
  wbtw R y x z ↔ x = y :=
by rw [←wbtw_swap_left_iff R z, and_iff_right h]

lemma wbtw.swap_right_iff [no_zero_smul_divisors R V] {x y z : P} (h : wbtw R x y z) :
  wbtw R x z y ↔ y = z :=
by rw [←wbtw_swap_right_iff R x, and_iff_right h]

lemma wbtw.rotate_iff [no_zero_smul_divisors R V] {x y z : P} (h : wbtw R x y z) :
  wbtw R z x y ↔ x = y :=
by rw [←wbtw_rotate_iff R x, and_iff_right h]

lemma sbtw.not_swap_left [no_zero_smul_divisors R V] {x y z : P} (h : sbtw R x y z) :
  ¬ wbtw R y x z :=
λ hs, h.left_ne (h.wbtw.swap_left_iff.1 hs)

lemma sbtw.not_swap_right [no_zero_smul_divisors R V] {x y z : P} (h : sbtw R x y z) :
  ¬ wbtw R x z y :=
λ hs, h.ne_right (h.wbtw.swap_right_iff.1 hs)

lemma sbtw.not_rotate [no_zero_smul_divisors R V] {x y z : P} (h : sbtw R x y z) :
  ¬ wbtw R z x y :=
λ hs, h.left_ne (h.wbtw.rotate_iff.1 hs)

@[simp] lemma wbtw_line_map_iff [no_zero_smul_divisors R V] {x y : P} {r : R} :
  wbtw R x (line_map x y r) y ↔ x = y ∨ r ∈ set.Icc (0 : R) 1 :=
begin
  by_cases hxy : x = y, { simp [hxy] },
  rw [or_iff_right hxy, wbtw, affine_segment, (line_map_injective R hxy).mem_set_image]
end

@[simp] lemma sbtw_line_map_iff [no_zero_smul_divisors R V] {x y : P} {r : R} :
  sbtw R x (line_map x y r) y ↔ x ≠ y ∧ r ∈ set.Ioo (0 : R) 1 :=
begin
  rw [sbtw_iff_mem_image_Ioo_and_ne, and_comm, and_congr_right],
  intro hxy,
  rw (line_map_injective R hxy).mem_set_image
end

omit V

@[simp] lemma wbtw_mul_sub_add_iff [no_zero_divisors R] {x y r : R} :
  wbtw R x (r * (y - x) + x) y ↔ x = y ∨ r ∈ set.Icc (0 : R) 1 :=
wbtw_line_map_iff

@[simp] lemma sbtw_mul_sub_add_iff [no_zero_divisors R] {x y r : R} :
  sbtw R x (r * (y - x) + x) y ↔ x ≠ y ∧ r ∈ set.Ioo (0 : R) 1 :=
sbtw_line_map_iff

@[simp] lemma wbtw_zero_one_iff {x : R} : wbtw R 0 x 1 ↔ x ∈ set.Icc (0 : R) 1 :=
begin
  simp_rw [wbtw, affine_segment, set.mem_image, line_map_apply_ring],
  simp
end

@[simp] lemma wbtw_one_zero_iff {x : R} : wbtw R 1 x 0 ↔ x ∈ set.Icc (0 : R) 1 :=
by rw [wbtw_comm, wbtw_zero_one_iff]

@[simp] lemma sbtw_zero_one_iff {x : R} : sbtw R 0 x 1 ↔ x ∈ set.Ioo (0 : R) 1 :=
begin
  rw [sbtw, wbtw_zero_one_iff, set.mem_Icc, set.mem_Ioo],
  exact ⟨λ h, ⟨h.1.1.lt_of_ne (ne.symm h.2.1), h.1.2.lt_of_ne h.2.2⟩,
         λ h, ⟨⟨h.1.le, h.2.le⟩, h.1.ne', h.2.ne⟩⟩
end

@[simp] lemma sbtw_one_zero_iff {x : R} : sbtw R 1 x 0 ↔ x ∈ set.Ioo (0 : R) 1 :=
by rw [sbtw_comm, sbtw_zero_one_iff]

include V

lemma wbtw.trans_left {w x y z : P} (h₁ : wbtw R w y z) (h₂ : wbtw R w x y) : wbtw R w x z :=
begin
  rcases h₁ with ⟨t₁, ht₁, rfl⟩,
  rcases h₂ with ⟨t₂, ht₂, rfl⟩,
  refine ⟨t₂ * t₁, ⟨mul_nonneg ht₂.1 ht₁.1, mul_le_one ht₂.2 ht₁.1 ht₁.2⟩, _⟩,
  simp [line_map_apply, smul_smul]
end

lemma wbtw.trans_right {w x y z : P} (h₁ : wbtw R w x z) (h₂ : wbtw R x y z) : wbtw R w y z :=
begin
  rw wbtw_comm at *,
  exact h₁.trans_left h₂
end

lemma wbtw.trans_sbtw_left [no_zero_smul_divisors R V] {w x y z : P} (h₁ : wbtw R w y z)
  (h₂ : sbtw R w x y) : sbtw R w x z :=
begin
  refine ⟨h₁.trans_left h₂.wbtw, h₂.ne_left, _⟩,
  rintro rfl,
  exact h₂.right_ne ((wbtw_swap_right_iff R w).1 ⟨h₁, h₂.wbtw⟩)
end

lemma wbtw.trans_sbtw_right [no_zero_smul_divisors R V] {w x y z : P} (h₁ : wbtw R w x z)
  (h₂ : sbtw R x y z) : sbtw R w y z :=
begin
  rw wbtw_comm at *,
  rw sbtw_comm at *,
  exact h₁.trans_sbtw_left h₂
end

lemma sbtw.trans_left [no_zero_smul_divisors R V] {w x y z : P} (h₁ : sbtw R w y z)
  (h₂ : sbtw R w x y) : sbtw R w x z :=
h₁.wbtw.trans_sbtw_left h₂

lemma sbtw.trans_right [no_zero_smul_divisors R V] {w x y z : P} (h₁ : sbtw R w x z)
  (h₂ : sbtw R x y z) : sbtw R w y z :=
h₁.wbtw.trans_sbtw_right h₂

lemma wbtw.trans_left_ne [no_zero_smul_divisors R V] {w x y z : P} (h₁ : wbtw R w y z)
  (h₂ : wbtw R w x y) (h : y ≠ z) : x ≠ z :=
begin
  rintro rfl,
  exact h (h₁.swap_right_iff.1 h₂)
end

lemma wbtw.trans_right_ne [no_zero_smul_divisors R V] {w x y z : P} (h₁ : wbtw R w x z)
  (h₂ : wbtw R x y z) (h : w ≠ x) : w ≠ y :=
begin
  rintro rfl,
  exact h (h₁.swap_left_iff.1 h₂)
end

lemma sbtw.trans_wbtw_left_ne [no_zero_smul_divisors R V] {w x y z : P} (h₁ : sbtw R w y z)
  (h₂ : wbtw R w x y) : x ≠ z :=
h₁.wbtw.trans_left_ne h₂ h₁.ne_right

lemma sbtw.trans_wbtw_right_ne [no_zero_smul_divisors R V] {w x y z : P} (h₁ : sbtw R w x z)
  (h₂ : wbtw R x y z) : w ≠ y :=
h₁.wbtw.trans_right_ne h₂ h₁.left_ne

lemma sbtw.affine_combination_of_mem_affine_span_pair [no_zero_divisors R]
  [no_zero_smul_divisors R V] {ι : Type*} {p : ι → P} (ha : affine_independent R p)
  {w w₁ w₂ : ι → R} {s : finset ι} (hw : ∑ i in s, w i = 1) (hw₁ : ∑ i in s, w₁ i = 1)
  (hw₂ : ∑ i in s, w₂ i = 1)
  (h : s.affine_combination R p w ∈
    line[R, s.affine_combination R p w₁, s.affine_combination R p w₂])
  {i : ι} (his : i ∈ s) (hs : sbtw R (w₁ i) (w i) (w₂ i)) :
  sbtw R (s.affine_combination R p w₁) (s.affine_combination R p w) (s.affine_combination R p w₂) :=
begin
  rw affine_combination_mem_affine_span_pair ha hw hw₁ hw₂ at h,
  rcases h with ⟨r, hr⟩,
  dsimp only at hr,
  rw [hr i his, sbtw_mul_sub_add_iff] at hs,
  change ∀ i ∈ s, w i = ((r • (w₂ - w₁) + w₁) i) at hr,
  rw s.affine_combination_congr hr (λ _ _, rfl),
  dsimp only,
  rw [←s.weighted_vsub_vadd_affine_combination, s.weighted_vsub_const_smul,
      ←s.affine_combination_vsub, ←line_map_apply, sbtw_line_map_iff, and_iff_left hs.2,
      ←@vsub_ne_zero V, s.affine_combination_vsub],
  intro hz,
  have hw₁w₂ : ∑ i in s, (w₁ - w₂) i = 0,
  { simp_rw [pi.sub_apply, finset.sum_sub_distrib, hw₁, hw₂, sub_self] },
  refine hs.1 _,
  have ha' := ha s (w₁ - w₂) hw₁w₂ hz i his,
  rwa [pi.sub_apply, sub_eq_zero] at ha'
end

end ordered_ring

section strict_ordered_comm_ring
variables [strict_ordered_comm_ring R] [add_comm_group V] [module R V] [add_torsor V P]

include V

variables {R}

lemma wbtw.same_ray_vsub {x y z : P} (h : wbtw R x y z) : same_ray R (y -ᵥ x) (z -ᵥ y) :=
begin
  rcases h with ⟨t, ⟨ht0, ht1⟩, rfl⟩,
  simp_rw line_map_apply,
  rcases ht0.lt_or_eq with ht0' | rfl, swap, { simp },
  rcases ht1.lt_or_eq with ht1' | rfl, swap, { simp },
  refine or.inr (or.inr ⟨1 - t, t, sub_pos.2 ht1', ht0', _⟩),
  simp [vsub_vadd_eq_vsub_sub, smul_sub, smul_smul, ←sub_smul],
  ring_nf
end

lemma wbtw.same_ray_vsub_left {x y z : P} (h : wbtw R x y z) : same_ray R (y -ᵥ x) (z -ᵥ x) :=
begin
  rcases h with ⟨t, ⟨ht0, ht1⟩, rfl⟩,
  simpa [line_map_apply] using same_ray_nonneg_smul_left (z -ᵥ x) ht0
end

lemma wbtw.same_ray_vsub_right {x y z : P} (h : wbtw R x y z) : same_ray R (z -ᵥ x) (z -ᵥ y) :=
begin
  rcases h with ⟨t, ⟨ht0, ht1⟩, rfl⟩,
  simpa [line_map_apply, vsub_vadd_eq_vsub_sub, sub_smul] using
    same_ray_nonneg_smul_right (z -ᵥ x) (sub_nonneg.2 ht1)
end

end strict_ordered_comm_ring

section linear_ordered_ring

variables [linear_ordered_ring R] [add_comm_group V] [module R V] [add_torsor V P]

include V

variables {R}

/-- Suppose lines from two vertices of a triangle to interior points of the opposite side meet at
`p`. Then `p` lies in the interior of the first (and by symmetry the other) segment from a
vertex to the point on the opposite side. -/
lemma sbtw_of_sbtw_of_sbtw_of_mem_affine_span_pair [no_zero_smul_divisors R V]
  {t : affine.triangle R P} {i₁ i₂ i₃ : fin 3} (h₁₂ : i₁ ≠ i₂) {p₁ p₂ p : P}
  (h₁ : sbtw R (t.points i₂) p₁ (t.points i₃)) (h₂ : sbtw R (t.points i₁) p₂ (t.points i₃))
  (h₁' : p ∈ line[R, t.points i₁, p₁]) (h₂' : p ∈ line[R, t.points i₂, p₂]) :
  sbtw R (t.points i₁) p p₁ :=
begin
  -- Should not be needed; see comments on local instances in `data.sign`.
  letI : decidable_rel ((<) : R → R → Prop) := linear_ordered_ring.decidable_lt,
  have h₁₃ : i₁ ≠ i₃, { rintro rfl, simpa using h₂ },
  have h₂₃ : i₂ ≠ i₃, { rintro rfl, simpa using h₁ },
  have h3 : ∀ i : fin 3, i = i₁ ∨ i = i₂ ∨ i = i₃, { clear h₁ h₂ h₁' h₂', dec_trivial! },
  have hu : (finset.univ : finset (fin 3)) = {i₁, i₂, i₃}, { clear h₁ h₂ h₁' h₂', dec_trivial! },
  have hp : p ∈ affine_span R (set.range t.points),
  { have hle : line[R, t.points i₁, p₁] ≤ affine_span R (set.range t.points),
    { refine affine_span_pair_le_of_mem_of_mem (mem_affine_span _ (set.mem_range_self _)) _,
      have hle : line[R, t.points i₂, t.points i₃] ≤ affine_span R (set.range t.points),
      { refine affine_span_mono _ _, simp [set.insert_subset] },
      rw affine_subspace.le_def' at hle,
      exact hle _ h₁.wbtw.mem_affine_span },
    rw affine_subspace.le_def' at hle,
    exact hle _ h₁' },
  have h₁i := h₁.mem_image_Ioo,
  have h₂i := h₂.mem_image_Ioo,
  rw set.mem_image at h₁i h₂i,
  rcases h₁i with ⟨r₁, ⟨hr₁0, hr₁1⟩, rfl⟩,
  rcases h₂i with ⟨r₂, ⟨hr₂0, hr₂1⟩, rfl⟩,
  rcases eq_affine_combination_of_mem_affine_span_of_fintype hp with ⟨w, hw, rfl⟩,
  have h₁s := sign_eq_of_affine_combination_mem_affine_span_single_line_map t.independent hw
    (finset.mem_univ _) (finset.mem_univ _) (finset.mem_univ _) h₁₂ h₁₃ h₂₃ hr₁0 hr₁1 h₁',
  have h₂s := sign_eq_of_affine_combination_mem_affine_span_single_line_map t.independent hw
    (finset.mem_univ _) (finset.mem_univ _) (finset.mem_univ _) h₁₂.symm h₂₃ h₁₃ hr₂0 hr₂1 h₂',
  dsimp only at h₁s h₂s,
  rw [←finset.univ.affine_combination_affine_combination_single_weights R t.points
        (finset.mem_univ i₁),
      ←finset.univ.affine_combination_affine_combination_line_map_weights t.points
        (finset.mem_univ _) (finset.mem_univ _)] at ⊢ h₁',
  refine sbtw.affine_combination_of_mem_affine_span_pair t.independent hw
    (finset.univ.sum_affine_combination_single_weights R (finset.mem_univ _))
    (finset.univ.sum_affine_combination_line_map_weights (finset.mem_univ _) (finset.mem_univ _) _)
    h₁' (finset.mem_univ i₁) _,
  rw [finset.affine_combination_single_weights_apply_self,
      finset.affine_combination_line_map_weights_apply_of_ne h₁₂ h₁₃, sbtw_one_zero_iff],
  have hs : ∀ i : fin 3, sign (w i) = sign (w i₃),
  { intro i,
    rcases h3 i with rfl | rfl | rfl,
    { exact h₂s },
    { exact h₁s },
    { refl } },
  have hss : sign (∑ i, w i) = 1, { simp [hw] },
  have hs' := sign_sum (finset.univ_nonempty) (sign (w i₃)) (λ i _, hs i),
  rw hs' at hss,
  simp_rw [hss, sign_eq_one_iff] at hs,
  refine ⟨hs i₁, _⟩,
  rw hu at hw,
  rw [finset.sum_insert, finset.sum_insert, finset.sum_singleton] at hw,
  { by_contra hle,
    rw not_lt at hle,
    exact (hle.trans_lt (lt_add_of_pos_right _ (left.add_pos (hs i₂) (hs i₃)))).ne' hw },
  { simp [h₂₃] },
  { simp [h₁₂, h₁₃] }
end

end linear_ordered_ring

section linear_ordered_field

variables [linear_ordered_field R] [add_comm_group V] [module R V] [add_torsor V P]

include V

variables {R}

lemma wbtw_iff_left_eq_or_right_mem_image_Ici {x y z : P} :
  wbtw R x y z ↔ x = y ∨ z ∈ line_map x y '' (set.Ici (1 : R)) :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨r, ⟨hr0, hr1⟩, rfl⟩,
    rcases hr0.lt_or_eq with hr0' | rfl,
    { rw set.mem_image,
      refine or.inr ⟨r⁻¹, one_le_inv hr0' hr1, _⟩,
      simp only [line_map_apply, smul_smul, vadd_vsub],
      rw [inv_mul_cancel hr0'.ne', one_smul, vsub_vadd] },
    { simp } },
  { rcases h with rfl | ⟨r, ⟨hr, rfl⟩⟩,
    { exact wbtw_self_left _ _ _ },
    { rw set.mem_Ici at hr,
      refine ⟨r⁻¹, ⟨inv_nonneg.2 (zero_le_one.trans hr), inv_le_one hr⟩, _⟩,
      simp only [line_map_apply, smul_smul, vadd_vsub],
      rw [inv_mul_cancel (one_pos.trans_le hr).ne', one_smul, vsub_vadd] } }
end

lemma wbtw.right_mem_image_Ici_of_left_ne {x y z : P} (h : wbtw R x y z) (hne : x ≠ y) :
  z ∈ line_map x y '' (set.Ici (1 : R)) :=
(wbtw_iff_left_eq_or_right_mem_image_Ici.1 h).resolve_left hne

lemma wbtw.right_mem_affine_span_of_left_ne {x y z : P} (h : wbtw R x y z) (hne : x ≠ y) :
  z ∈ line[R, x, y] :=
begin
  rcases h.right_mem_image_Ici_of_left_ne hne with ⟨r, ⟨-, rfl⟩⟩,
  exact line_map_mem_affine_span_pair _ _ _
end

lemma sbtw_iff_left_ne_and_right_mem_image_IoI {x y z : P} :
  sbtw R x y z ↔ x ≠ y ∧ z ∈ line_map x y '' (set.Ioi (1 : R)) :=
begin
  refine ⟨λ h, ⟨h.left_ne, _⟩, λ h, _⟩,
  { obtain ⟨r, ⟨hr, rfl⟩⟩ := h.wbtw.right_mem_image_Ici_of_left_ne h.left_ne,
    rw [set.mem_Ici] at hr,
    rcases hr.lt_or_eq with hrlt | rfl,
    { exact set.mem_image_of_mem _ hrlt },
    { exfalso, simpa using h } },
  { rcases h with ⟨hne, r, hr, rfl⟩,
    rw set.mem_Ioi at hr,
    refine ⟨wbtw_iff_left_eq_or_right_mem_image_Ici.2 (or.inr (set.mem_image_of_mem _
      (set.mem_of_mem_of_subset hr set.Ioi_subset_Ici_self))), hne.symm, _⟩,
    rw [line_map_apply, ←@vsub_ne_zero V, vsub_vadd_eq_vsub_sub],
    nth_rewrite 0 ←one_smul R (y -ᵥ x),
    rw [←sub_smul, smul_ne_zero_iff, vsub_ne_zero, sub_ne_zero],
    exact ⟨hr.ne, hne.symm⟩ }
end

lemma sbtw.right_mem_image_Ioi {x y z : P} (h : sbtw R x y z) :
  z ∈ line_map x y '' (set.Ioi (1 : R)) :=
(sbtw_iff_left_ne_and_right_mem_image_IoI.1 h).2

lemma sbtw.right_mem_affine_span {x y z : P} (h : sbtw R x y z) : z ∈ line[R, x, y] :=
h.wbtw.right_mem_affine_span_of_left_ne h.left_ne

lemma wbtw_iff_right_eq_or_left_mem_image_Ici {x y z : P} :
  wbtw R x y z ↔ z = y ∨ x ∈ line_map z y '' (set.Ici (1 : R)) :=
by rw [wbtw_comm, wbtw_iff_left_eq_or_right_mem_image_Ici]

lemma wbtw.left_mem_image_Ici_of_right_ne {x y z : P} (h : wbtw R x y z) (hne : z ≠ y) :
  x ∈ line_map z y '' (set.Ici (1 : R)) :=
h.symm.right_mem_image_Ici_of_left_ne hne

lemma wbtw.left_mem_affine_span_of_right_ne {x y z : P} (h : wbtw R x y z) (hne : z ≠ y) :
  x ∈ line[R, z, y] :=
h.symm.right_mem_affine_span_of_left_ne hne

lemma sbtw_iff_right_ne_and_left_mem_image_IoI {x y z : P} :
  sbtw R x y z ↔ z ≠ y ∧ x ∈ line_map z y '' (set.Ioi (1 : R)) :=
by rw [sbtw_comm, sbtw_iff_left_ne_and_right_mem_image_IoI]

lemma sbtw.left_mem_image_Ioi {x y z : P} (h : sbtw R x y z) :
  x ∈ line_map z y '' (set.Ioi (1 : R)) :=
h.symm.right_mem_image_Ioi

lemma sbtw.left_mem_affine_span {x y z : P} (h : sbtw R x y z) : x ∈ line[R, z, y] :=
h.symm.right_mem_affine_span

lemma wbtw_smul_vadd_smul_vadd_of_nonneg_of_le (x : P) (v : V) {r₁ r₂ : R} (hr₁ : 0 ≤ r₁)
  (hr₂ : r₁ ≤ r₂) : wbtw R x (r₁ • v +ᵥ x) (r₂ • v +ᵥ x) :=
begin
  refine ⟨r₁ / r₂, ⟨div_nonneg hr₁ (hr₁.trans hr₂), div_le_one_of_le hr₂ (hr₁.trans hr₂)⟩, _⟩,
  by_cases h : r₁ = 0, { simp [h] },
  simp [line_map_apply, smul_smul, ((hr₁.lt_of_ne' h).trans_le hr₂).ne.symm]
end

lemma wbtw_or_wbtw_smul_vadd_of_nonneg (x : P) (v : V) {r₁ r₂ : R} (hr₁ : 0 ≤ r₁) (hr₂ : 0 ≤ r₂) :
  wbtw R x (r₁ • v +ᵥ x) (r₂ • v +ᵥ x) ∨ wbtw R x (r₂ • v +ᵥ x) (r₁ • v +ᵥ x) :=
begin
  rcases le_total r₁ r₂ with h|h,
  { exact or.inl (wbtw_smul_vadd_smul_vadd_of_nonneg_of_le x v hr₁ h) },
  { exact or.inr (wbtw_smul_vadd_smul_vadd_of_nonneg_of_le x v hr₂ h) }
end

lemma wbtw_smul_vadd_smul_vadd_of_nonpos_of_le (x : P) (v : V) {r₁ r₂ : R} (hr₁ : r₁ ≤ 0)
  (hr₂ : r₂ ≤ r₁) : wbtw R x (r₁ • v +ᵥ x) (r₂ • v +ᵥ x) :=
begin
  convert wbtw_smul_vadd_smul_vadd_of_nonneg_of_le x (-v) (left.nonneg_neg_iff.2 hr₁)
                                                     (neg_le_neg_iff.2 hr₂) using 1;
    rw neg_smul_neg
end

lemma wbtw_or_wbtw_smul_vadd_of_nonpos (x : P) (v : V) {r₁ r₂ : R} (hr₁ : r₁ ≤ 0) (hr₂ : r₂ ≤ 0) :
  wbtw R x (r₁ • v +ᵥ x) (r₂ • v +ᵥ x) ∨ wbtw R x (r₂ • v +ᵥ x) (r₁ • v +ᵥ x) :=
begin
  rcases le_total r₁ r₂ with h|h,
  { exact or.inr (wbtw_smul_vadd_smul_vadd_of_nonpos_of_le x v hr₂ h) },
  { exact or.inl (wbtw_smul_vadd_smul_vadd_of_nonpos_of_le x v hr₁ h) }
end

lemma wbtw_smul_vadd_smul_vadd_of_nonpos_of_nonneg (x : P) (v : V) {r₁ r₂ : R} (hr₁ : r₁ ≤ 0)
  (hr₂ : 0 ≤ r₂) : wbtw R (r₁ • v +ᵥ x) x (r₂ • v +ᵥ x) :=
begin
  convert wbtw_smul_vadd_smul_vadd_of_nonneg_of_le (r₁ • v +ᵥ x) v (left.nonneg_neg_iff.2 hr₁)
    (neg_le_sub_iff_le_add.2 ((le_add_iff_nonneg_left r₁).2 hr₂)) using 1;
    simp [sub_smul, ←add_vadd]
end

lemma wbtw_smul_vadd_smul_vadd_of_nonneg_of_nonpos (x : P) (v : V) {r₁ r₂ : R} (hr₁ : 0 ≤ r₁)
  (hr₂ : r₂ ≤ 0) : wbtw R (r₁ • v +ᵥ x) x (r₂ • v +ᵥ x) :=
begin
  rw wbtw_comm,
  exact wbtw_smul_vadd_smul_vadd_of_nonpos_of_nonneg x v hr₂ hr₁
end

lemma wbtw.trans_left_right {w x y z : P} (h₁ : wbtw R w y z) (h₂ : wbtw R w x y) : wbtw R x y z :=
begin
  rcases h₁ with ⟨t₁, ht₁, rfl⟩,
  rcases h₂ with ⟨t₂, ht₂, rfl⟩,
  refine ⟨(t₁ - t₂ * t₁) / (1 - t₂ * t₁),
          ⟨div_nonneg (sub_nonneg.2 (mul_le_of_le_one_left ht₁.1 ht₂.2))
                      (sub_nonneg.2 (mul_le_one ht₂.2 ht₁.1 ht₁.2)),
           div_le_one_of_le (sub_le_sub_right ht₁.2 _)
                            (sub_nonneg.2 (mul_le_one ht₂.2 ht₁.1 ht₁.2))⟩, _⟩,
  simp only [line_map_apply, smul_smul, ←add_vadd, vsub_vadd_eq_vsub_sub, smul_sub, ←sub_smul,
             ←add_smul, vadd_vsub, vadd_right_cancel_iff, div_mul_eq_mul_div, div_sub_div_same],
  nth_rewrite 0 [←mul_one (t₁ - t₂ * t₁)],
  rw [←mul_sub, mul_div_assoc],
  by_cases h : 1 - t₂ * t₁ = 0,
  { rw [sub_eq_zero, eq_comm] at h,
    rw h,
    suffices : t₁ = 1, by simp [this],
    exact eq_of_le_of_not_lt ht₁.2
      (λ ht₁lt, (mul_lt_one_of_nonneg_of_lt_one_right ht₂.2 ht₁.1 ht₁lt).ne h) },
  { rw div_self h,
    ring_nf }
end

lemma wbtw.trans_right_left {w x y z : P} (h₁ : wbtw R w x z) (h₂ : wbtw R x y z) : wbtw R w x y :=
begin
  rw wbtw_comm at *,
  exact h₁.trans_left_right h₂
end

lemma sbtw.trans_left_right {w x y z : P} (h₁ : sbtw R w y z) (h₂ : sbtw R w x y) : sbtw R x y z :=
⟨h₁.wbtw.trans_left_right h₂.wbtw, h₂.right_ne, h₁.ne_right⟩

lemma sbtw.trans_right_left {w x y z : P} (h₁ : sbtw R w x z) (h₂ : sbtw R x y z) : sbtw R w x y :=
⟨h₁.wbtw.trans_right_left h₂.wbtw, h₁.ne_left, h₂.left_ne⟩

lemma wbtw.collinear {x y z : P} (h : wbtw R x y z) : collinear R ({x, y, z} : set P) :=
begin
  rw collinear_iff_exists_forall_eq_smul_vadd,
  refine ⟨x, z -ᵥ x, _⟩,
  intros p hp,
  simp_rw [set.mem_insert_iff, set.mem_singleton_iff] at hp,
  rcases hp with rfl|rfl|rfl,
  { refine ⟨0, _⟩, simp },
  { rcases h with ⟨t, -, rfl⟩,
    exact ⟨t, rfl⟩ },
  { refine ⟨1, _⟩, simp }
end

lemma collinear.wbtw_or_wbtw_or_wbtw {x y z : P} (h : collinear R ({x, y, z} : set P)) :
  wbtw R x y z ∨ wbtw R y z x ∨ wbtw R z x y :=
begin
  rw collinear_iff_of_mem (set.mem_insert _ _) at h,
  rcases h with ⟨v, h⟩,
  simp_rw [set.mem_insert_iff, set.mem_singleton_iff] at h,
  have hy := h y (or.inr (or.inl rfl)),
  have hz := h z (or.inr (or.inr rfl)),
  rcases hy with ⟨ty, rfl⟩,
  rcases hz with ⟨tz, rfl⟩,
  rcases lt_trichotomy ty 0 with hy0|rfl|hy0,
  { rcases lt_trichotomy tz 0 with hz0|rfl|hz0,
    { nth_rewrite 1 wbtw_comm,
      rw ←or_assoc,
      exact or.inl (wbtw_or_wbtw_smul_vadd_of_nonpos _ _ hy0.le hz0.le) },
    { simp },
    { exact or.inr (or.inr (wbtw_smul_vadd_smul_vadd_of_nonneg_of_nonpos _ _ hz0.le hy0.le)) } },
  { simp },
  { rcases lt_trichotomy tz 0 with hz0|rfl|hz0,
    { refine or.inr (or.inr (wbtw_smul_vadd_smul_vadd_of_nonpos_of_nonneg _ _ hz0.le hy0.le)) },
    { simp },
    { nth_rewrite 1 wbtw_comm,
      rw ←or_assoc,
      exact or.inl (wbtw_or_wbtw_smul_vadd_of_nonneg _ _ hy0.le hz0.le) } }
end

lemma wbtw_iff_same_ray_vsub {x y z : P} : wbtw R x y z ↔ same_ray R (y -ᵥ x) (z -ᵥ y) :=
begin
  refine ⟨wbtw.same_ray_vsub, λ h, _⟩,
  rcases h with h | h | ⟨r₁, r₂, hr₁, hr₂, h⟩,
  { rw vsub_eq_zero_iff_eq at h, simp [h] },
  { rw vsub_eq_zero_iff_eq at h, simp [h] },
  { refine ⟨r₂ / (r₁ + r₂),
            ⟨div_nonneg hr₂.le (add_nonneg hr₁.le hr₂.le),
             div_le_one_of_le (le_add_of_nonneg_left hr₁.le) (add_nonneg hr₁.le hr₂.le)⟩, _⟩,
    have h' : z = r₂⁻¹ • r₁ • (y -ᵥ x) +ᵥ y, { simp [h, hr₂.ne'] },
    rw eq_comm,
    simp only [line_map_apply, h', vadd_vsub_assoc, smul_smul, ←add_smul, eq_vadd_iff_vsub_eq,
               smul_add],
    convert (one_smul _ _).symm,
    field_simp [(add_pos hr₁ hr₂).ne', hr₂.ne'],
    ring }
end

variables (R)

lemma wbtw_point_reflection (x y : P) : wbtw R y x (point_reflection R x y) :=
begin
  refine ⟨2⁻¹, ⟨by norm_num, by norm_num⟩, _⟩,
  rw [line_map_apply, point_reflection_apply, vadd_vsub_assoc, ←two_smul R (x -ᵥ y)],
  simp
end

lemma sbtw_point_reflection_of_ne {x y : P} (h : x ≠ y) : sbtw R y x (point_reflection R x y) :=
begin
  refine ⟨wbtw_point_reflection _ _ _, h, _⟩,
  nth_rewrite 0 [←point_reflection_self R x],
  exact (point_reflection_involutive R x).injective.ne h
end

lemma wbtw_midpoint (x y : P) : wbtw R x (midpoint R x y) y :=
by { convert wbtw_point_reflection R (midpoint R x y) x, simp }

lemma sbtw_midpoint_of_ne {x y : P} (h : x ≠ y) : sbtw R x (midpoint R x y) y :=
begin
  have h : midpoint R x y ≠ x, { simp [h] },
  convert sbtw_point_reflection_of_ne R h,
  simp
end

end linear_ordered_field


import topology.locally_constant.algebra
import analysis.normed.group.hom

/-!
# Analysis of locally constant maps

This file defines the normed group of locally constant maps from a compact topological
space into a normed group (with the sup norm).

## Main construction

* The instance `locally_constant.normed_group`
* `locally_constant.map_hom`: push-forward of locally constant maps as a normed group hom
* `locally_constant.comap_hom`: pull-back of locally constant maps as a normed group hom
-/

noncomputable theory
open_locale nnreal

open set

-- move this
section for_mathlib

lemma real.Sup_mul (r : ℝ) (s : set ℝ) (hr : 0 < r) :
  Sup ({x | ∃ y ∈ s, r * y = x}) = r * Sup s :=
begin
  by_cases hs : s.nonempty, swap,
  { rw not_nonempty_iff_eq_empty at hs, simp [hs], },
  have H : set.nonempty {x : ℝ | ∃ (y : ℝ) (H : y ∈ s), r * y = x},
  { obtain ⟨x, hx⟩ := hs, from ⟨r * x, x, hx, rfl⟩, },
  have aux : bdd_above {x : ℝ | ∃ (y : ℝ) (H : y ∈ s), r * y = x} ↔ bdd_above s,
  { split; rintro ⟨x, hx⟩,
    { refine ⟨x / r, λ y hy, _⟩,
      rw [le_div_iff' hr],
      exact hx ⟨_, hy, rfl⟩, },
    { refine ⟨r * x, _⟩, rintro _ ⟨y, hy, rfl⟩,
      apply mul_le_mul_of_nonneg_left _ hr.le,
      exact hx hy } },
  by_cases s_bdd : bdd_above s, swap,
  { simp only [real.Sup_of_not_bdd_above s_bdd, mul_zero,
    real.Sup_of_not_bdd_above ((not_iff_not_of_iff aux).mpr s_bdd)], },
  apply le_antisymm,
  { apply cSup_le H,
    rintro _ ⟨x, hx, rfl⟩,
    exact mul_le_mul_of_nonneg_left (le_cSup s_bdd hx) hr.le },
  { rw [← le_div_iff' hr],
    refine cSup_le hs _,
    intros x hx,
    rw le_div_iff' hr,
    exact le_cSup (aux.mpr s_bdd) ⟨_, hx, rfl⟩ }
end

end for_mathlib

open set

namespace locally_constant

variables {X Y Z V V₁ V₂ V₃ : Type*} [topological_space X]

/-- The sup norm on locally constant function -/
protected def has_norm [has_norm Y] : has_norm (locally_constant X Y) :=
{ norm := λ f, ⨆ x, ∥f x∥ }

/-- The sup edist on locally constant function -/
protected def has_edist [has_edist Y] : has_edist (locally_constant X Y) :=
{ edist := λ f g, ⨆ x, edist (f x) (g x) }

/-- The sup edist on locally constant function -/
protected def has_dist [has_dist Y] : has_dist (locally_constant X Y) :=
{ dist := λ f g, ⨆ x, dist (f x) (g x) }

local attribute [instance]
  locally_constant.has_norm
  locally_constant.has_edist
  locally_constant.has_dist

lemma edist_apply_le [has_edist Y] (f g : locally_constant X Y) (x : X) :
  edist (f x) (g x) ≤ edist f g :=
le_Sup (set.mem_range_self x)

lemma norm_def [has_norm Y] (f : locally_constant X Y) : ∥f∥ = ⨆ x, ∥f x∥ := rfl

lemma edist_def [has_edist Y] (f g : locally_constant X Y) :
  edist f g = ⨆ x, edist (f x) (g x) := rfl

lemma dist_def [has_dist Y] (f g : locally_constant X Y) : dist f g = ⨆ x, dist (f x) (g x) := rfl

section compact_domain

variables [compact_space X]

lemma norm_apply_le [has_norm Y] (f : locally_constant X Y) (x : X) :
  ∥f x∥ ≤ ∥f∥ :=
begin
  refine le_cSup _ (set.mem_range_self _),
  apply exists_upper_bound_image,
  rw range_comp,
  exact f.range_finite.image _
end

lemma exists_ub_range_dist [has_dist Y] (f g : locally_constant X Y) :
  ∃ x : ℝ, ∀ y : ℝ, y ∈ set.range (λ (x : X), dist (f x) (g x)) → y ≤ x :=
begin
  apply exists_upper_bound_image,
  simp only [← function.uncurry_apply_pair dist],
  rw range_comp,
  apply finite.image,
  apply (f.range_finite.prod g.range_finite).subset,
  apply range_pair_subset,
end

lemma dist_apply_le [has_dist Y] (f g : locally_constant X Y) (x : X) :
  dist (f x) (g x) ≤ dist f g :=
le_cSup (exists_ub_range_dist _ _) (set.mem_range_self x)

-- consider giving the `edist` and the `uniform_space` explicitly
/-- The metric space on locally constant functions on a compact space, with sup distance. -/
protected def pseudo_metric_space [pseudo_metric_space Y] :
  pseudo_metric_space (locally_constant X Y) :=
{ dist_self := λ f, show (⨆ x, dist (f x) (f x)) = 0,
    begin
      simp only [dist_self, supr],
      casesI is_empty_or_nonempty X,
      { rw [set.range_eq_empty, real.Sup_empty] },
      { simp only [set.range_const, cSup_singleton] },
    end,
  dist_comm := λ f g, show Sup _ = Sup _, by { simp only [dist_comm] },
  dist_triangle :=
  begin
    intros f g h,
    casesI is_empty_or_nonempty X,
    { show Sup _ ≤ Sup _ + Sup _, simp only [set.range_eq_empty, real.Sup_empty, add_zero] },
    refine cSup_le _ _,
    { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
    rintro r ⟨x, rfl⟩,
    calc dist (f x) (h x) ≤ dist (f x) (g x) + dist (g x) (h x) : dist_triangle _ _ _
    ... ≤ dist f g + dist g h : add_le_add (dist_apply_le _ _ _) (dist_apply_le _ _ _)
  end,
  .. locally_constant.has_dist }

-- consider giving the `edist` and the `uniform_space` explicitly
/-- The metric space on locally constant functions on a compact space, with sup distance. -/
protected def metric_space [metric_space Y] : metric_space (locally_constant X Y) :=
{ dist_self := λ f, show (⨆ x, dist (f x) (f x)) = 0,
  begin
    simp only [dist_self, supr],
    casesI is_empty_or_nonempty X,
    { rwa [set.range_eq_empty, real.Sup_empty] },
    { simp only [set.range_const, cSup_singleton] }
  end,
  eq_of_dist_eq_zero :=
  begin
    intros f g h,
    ext x,
    apply eq_of_dist_eq_zero,
    apply le_antisymm _ dist_nonneg,
    rw ← h,
    exact dist_apply_le _ _ _
  end,
  dist_comm := λ f g, show Sup _ = Sup _, by { simp only [dist_comm] },
  dist_triangle :=
  begin
    intros f g h,
    casesI is_empty_or_nonempty X,
    { show Sup _ ≤ Sup _ + Sup _, simp only [set.range_eq_empty, real.Sup_empty, add_zero] },
    refine cSup_le _ _,
    { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
    rintro r ⟨x, rfl⟩,
    calc dist (f x) (h x) ≤ dist (f x) (g x) + dist (g x) (h x) : dist_triangle _ _ _
    ... ≤ dist f g + dist g h : add_le_add (dist_apply_le _ _ _) (dist_apply_le _ _ _)
  end,
  .. locally_constant.has_dist }

/--
The seminormed group of locally constant functions from a compact space to a seminormed group.
-/
protected def semi_normed_group {G : Type*} [semi_normed_group G] :
  semi_normed_group (locally_constant X G) :=
{ dist_eq := λ f g, show Sup _ = Sup _,
  by simp only [semi_normed_group.dist_eq, locally_constant.sub_apply],
  .. locally_constant.has_norm, .. locally_constant.add_comm_group,
  .. locally_constant.pseudo_metric_space }

/-- The normed group of locally constant functions from a compact space to a normed group. -/
protected def normed_group {G : Type*} [normed_group G] : normed_group (locally_constant X G) :=
{ .. locally_constant.semi_normed_group,
  .. locally_constant.metric_space }

local attribute [instance] locally_constant.semi_normed_group

section map_hom

variables [semi_normed_group V] [semi_normed_group V₁] [semi_normed_group V₂] [semi_normed_group V₃]

/-- Push-forward of locally constant maps under a normed group hom, as a normed
group hom between types of locally constant functions. -/
@[simps]
def map_hom (f : normed_group_hom V₁ V₂) :
  normed_group_hom (locally_constant X V₁) (locally_constant X V₂) :=
{ to_fun := locally_constant.map f,
  map_add' := by { intros x y, ext s, apply f.map_add' },
  bound' :=
  begin
    obtain ⟨C, C_pos, hC⟩ := f.bound,
    use C,
    rintro (g : locally_constant _ _),
    calc Sup (set.range (λ x, ∥f (g x)∥))
        ≤ Sup (set.range (λ x, C * ∥g x∥)) : _
    ... = C * Sup (set.range (λ x, ∥g x∥)) : _,
    { casesI is_empty_or_nonempty X,
      { simp only [set.range_eq_empty, real.Sup_empty] },
      refine cSup_le _ _,
      { inhabit X, exact ⟨_, set.mem_range_self default⟩ },
      rintro _ ⟨x, rfl⟩,
      calc ∥f (g x)∥ ≤ C * ∥g x∥ : hC _
      ... ≤ Sup _ : le_cSup _ _,
      { apply exists_upper_bound_image,
        rw [set.range_comp, set.range_comp],
        exact (g.range_finite.image _).image _ },
      { exact set.mem_range_self _ } },
    { convert real.Sup_mul C _ C_pos using 2,
      ext x,
      simp only [set.mem_range, exists_prop, set.set_of_mem_eq, exists_exists_eq_and],
      simp only [set.mem_set_of_eq] }
  end }

@[simp] lemma map_hom_id :
  @map_hom X _ _ _ _ _ _ (@normed_group_hom.id V _) = normed_group_hom.id _ :=
by { ext, refl }

@[simp] lemma map_hom_comp (g : normed_group_hom V₂ V₃) (f : normed_group_hom V₁ V₂) :
  (@map_hom X _ _ _ _ _ _ g).comp (map_hom f) = map_hom (g.comp f) :=
by { ext, refl }

end map_hom

section comap_hom
/-!
### comapping as normed_group_hom
-/

variables [topological_space Y] [compact_space Y] [topological_space Z] [compact_space Z]
variables [semi_normed_group V]

/-- Pull-back of locally constant maps under a normed group hom, as a normed
group hom between types of locally constant functions. -/
@[simps]
def comap_hom (f : X → Y) (hf : continuous f) :
  normed_group_hom (locally_constant Y V) (locally_constant X V) :=
add_monoid_hom.mk_normed_group_hom
  (add_monoid_hom.mk'
    (locally_constant.comap f)
    (by { intros, ext, simp only [hf, add_apply, function.comp_app, coe_comap] }))
  1
  begin
    assume g,
    rw one_mul,
    show Sup _ ≤ Sup _,
    simp only [hf, function.comp_app, coe_comap, add_monoid_hom.mk'_apply],
    casesI is_empty_or_nonempty X,
    { simp only [set.range_eq_empty, real.Sup_empty],
      casesI is_empty_or_nonempty Y,
      { simp only [set.range_eq_empty, real.Sup_empty] },
      inhabit Y,
      calc 0 ≤ ∥g default∥ : norm_nonneg _
         ... ≤ _ : _,
      apply le_cSup,
      { apply exists_upper_bound_image,
        rw set.range_comp,
        exact g.range_finite.image _ },
      { exact set.mem_range_self _ } },
    resetI,
    refine cSup_le (range_nonempty _) _,
    { rintro _ ⟨x, rfl⟩,
      apply le_cSup,
      { apply exists_upper_bound_image,
        rw set.range_comp,
        exact g.range_finite.image _ },
      { exact set.mem_range_self _ } },
  end

@[simp] lemma comap_hom_id : @comap_hom X X V _ _ _ _ _ id continuous_id = normed_group_hom.id _ :=
begin
  ext,
  simp only [comap_id, comap_hom_apply, id.def, normed_group_hom.id_apply,
    add_monoid_hom.to_fun_eq_coe, add_monoid_hom.id_apply]
end

@[simp] lemma comap_hom_comp (f : X → Y) (g : Y → Z) (hf : continuous f) (hg : continuous g) :
  (@comap_hom _ _ V _ _ _ _ _ f hf).comp (comap_hom g hg) = (comap_hom (g ∘ f) (hg.comp hf)) :=
begin
  ext φ x,
  -- `[simps]` is producing bad lemmas... I don't know how to trick it into creating good ones
  -- so we use `show` instead, to get into a defeq shape that is usable
  show (comap_hom f hf) ((comap_hom g hg) φ) x = _,
  simp only [hg.comp hf, hf, hg, comap_hom_apply, coe_comap]
end

lemma comap_hom_norm_noninc (f : X → Y) (hf : continuous f) :
  (@comap_hom _ _ V _ _ _ _ _ f hf).norm_noninc :=
normed_group_hom.norm_noninc.norm_noninc_iff_norm_le_one.2 $
  normed_group_hom.mk_normed_group_hom_norm_le _ (zero_le_one) _

end comap_hom

end compact_domain

end locally_constant

#lint- only unused_arguments def_lemma doc_blame


lemma add_comm (a b : mynat) : a + b = b + a :=
begin
induction a with h hd,
rw zero_add,
rw add_zero,
refl,
rw succ_add,
rw hd,
rw add_succ,
refl,
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Johannes Hölzl, Sander Dahmen

Dimension of modules and vector spaces.
-/
import linear_algebra.basis
import set_theory.ordinal
noncomputable theory

local attribute [instance, priority 0] classical.prop_decidable

universes u v w
variables {α : Type u} {β γ δ ε : Type v}
variables {ι : Type u} {φ : ι → Type u} -- relax these universe constraints

section vector_space
variables [discrete_field α] [add_comm_group β] [vector_space α β]
include α
open submodule lattice function set

variables (α β)
def vector_space.dim : cardinal :=
cardinal.min
  (nonempty_subtype.2 (exists_is_basis α β))
  (λ b, cardinal.mk b.1)
variables {α β}
open vector_space

theorem is_basis.le_span {I J : set β} (hI : is_basis α I) (hJ : span α J = ⊤) : cardinal.mk I ≤ cardinal.mk J :=
begin
  cases le_or_lt cardinal.omega (cardinal.mk J) with oJ oJ,
  { refine le_of_not_lt (λ IJ, _),
    let S : J → set β := λ j, ↑(hI.repr j).support,
    have hs : I ⊆ ⋃ j, S j,
    { intros i hi,
      have : span α J ≤ comap hI.repr (lc.supported α (⋃ j, S j)) :=
        span_le.2 (λ j hj x hx, ⟨_, ⟨⟨j, hj⟩, rfl⟩, hx⟩),
      rw hJ at this, replace : hI.repr i ∈ _ := this trivial,
      rw hI.repr_eq_single hi at this,
      apply this, simp },
    suffices : cardinal.mk (⋃ j, S j) < cardinal.mk I,
      from not_le_of_lt this ⟨set.embedding_of_subset hs⟩,
    refine lt_of_le_of_lt (le_trans cardinal.mk_Union_le_sum_mk
      (cardinal.sum_le_sum _ (λ _, cardinal.omega) _)) _,
    { exact λ j, le_of_lt (cardinal.lt_omega_iff_finite.2 $ finset.finite_to_set _) },
    { rwa [cardinal.sum_const, cardinal.mul_eq_max oJ (le_refl _), max_eq_left oJ] } },
  { rcases exists_finite_card_le_of_finite_of_linear_independent_of_span
      (cardinal.lt_omega_iff_finite.1 oJ) hI.1 _ with ⟨fI, hi⟩,
    { rwa [← cardinal.nat_cast_le, cardinal.finset_card, finset.coe_to_finset,
        cardinal.finset_card, finset.coe_to_finset] at hi },
    { rw hJ, apply set.subset_univ } },
end

/-- dimension theorem -/
theorem mk_eq_mk_of_basis {I J : set β} (hI : is_basis α I) (hJ : is_basis α J) : cardinal.mk I = cardinal.mk J :=
le_antisymm (hI.le_span hJ.2) (hJ.le_span hI.2)

theorem is_basis.mk_eq_dim {b : set β} (h : is_basis α b) : cardinal.mk b = dim α β :=
let ⟨b', e⟩ := show ∃ b', dim α β = _, from cardinal.min_eq _ _ in
mk_eq_mk_of_basis h (subtype.property _)

variables [add_comm_group γ] [vector_space α γ]

theorem linear_equiv.dim_eq (f : β ≃ₗ[α] γ) : dim α β = dim α γ :=
let ⟨b, hb⟩ := exists_is_basis α β in
hb.mk_eq_dim.symm.trans $
  (cardinal.mk_eq_of_injective f.to_equiv.injective).symm.trans $
(f.is_basis hb).mk_eq_dim

lemma dim_bot : dim α (⊥ : submodule α β) = 0 :=
begin
  rw [← (@is_basis_empty_bot α β _ _ _).mk_eq_dim],
  exact cardinal.mk_emptyc (⊥ : submodule α β)
end

lemma dim_of_field (α : Type*) [discrete_field α] : dim α α = 1 :=
by rw [← (is_basis_singleton_one α).mk_eq_dim, cardinal.mk_singleton]

set_option class.instance_max_depth 37
lemma dim_span {s : set β} (hs : linear_independent α s) : dim α ↥(span α s) = cardinal.mk s :=
have (span α s).subtype '' ((span α s).subtype ⁻¹' s) = s :=
  image_preimage_eq_of_subset $ by rw [← linear_map.range_coe, range_subtype]; exact subset_span,
begin
  rw [← (is_basis_span hs).mk_eq_dim],
  calc cardinal.mk ↥((submodule.subtype (span α s) : span α s →ₗ[α] β) ⁻¹' s) =
      cardinal.mk ↥((submodule.subtype (span α s)) '' ((submodule.subtype (span α s)) ⁻¹' s)) :
      (cardinal.mk_eq_of_injective subtype.val_injective).symm
    ... = cardinal.mk ↥s : by rw this
end
set_option class.instance_max_depth 32

lemma dim_span_le (s : set β) : dim α (span α s) ≤ cardinal.mk s :=
let ⟨b, hb, _, hsb, hlib⟩ :=
  exists_linear_independent (@linear_independent_empty α _ _ _ _) (set.empty_subset s) in
have hsab : span α s = span α b, from span_eq_of_le _ hsb (span_le.2 (λ x hx, subset_span (hb hx))),
calc dim α (span α s) = dim α (span α b) : by rw hsab
                  ... = cardinal.mk b : dim_span hlib
                  ... ≤ cardinal.mk s : cardinal.mk_le_mk_of_subset hb

lemma dim_span_of_finset (s : finset β) : dim α (span α (↑s : set β)) < cardinal.omega :=
calc dim α (span α (↑s : set β)) ≤ cardinal.mk (↑s : set β) : dim_span_le ↑s
                             ... = s.card : by rw ←cardinal.finset_card
                             ... < cardinal.omega : cardinal.nat_lt_omega _

theorem dim_prod : dim α (β × γ) = dim α β + dim α γ :=
begin
  rcases exists_is_basis α β with ⟨b, hb⟩,
  rcases exists_is_basis α γ with ⟨c, hc⟩,
  rw [← @is_basis.mk_eq_dim α (β × γ) _ _ _ _ (is_basis_inl_union_inr hb hc),
    ← hb.mk_eq_dim, ← hc.mk_eq_dim, cardinal.mk_union_of_disjoint,
    cardinal.mk_eq_of_injective, cardinal.mk_eq_of_injective],
  { exact prod.injective_inr },
  { exact prod.injective_inl },
  { rintro _ ⟨⟨x, hx, rfl⟩, ⟨y, hy, ⟨⟩⟩⟩,
    exact zero_not_mem_of_linear_independent (@zero_ne_one α _) hb.1 hx }
end

theorem dim_quotient (p : submodule α β) : dim α p.quotient + dim α p = dim α β :=
let ⟨f⟩ := quotient_prod_linear_equiv p in dim_prod.symm.trans f.dim_eq

/-- rank-nullity theorem -/
theorem dim_range_add_dim_ker (f : β →ₗ[α] γ) : dim α f.range + dim α f.ker = dim α β :=
by rw [← f.quot_ker_equiv_range.dim_eq, dim_quotient]

lemma dim_range_le (f : β →ₗ[α] γ) : dim α f.range ≤ dim α β :=
by rw ← dim_range_add_dim_ker f; exact le_add_right (le_refl _)

lemma dim_map_le (f : β →ₗ γ) (p : submodule α β): dim α (p.map f) ≤ dim α p :=
begin
  have h := dim_range_le (f.comp (submodule.subtype p)),
  rwa [linear_map.range_comp, range_subtype] at h,
end

lemma dim_range_of_surjective (f : β →ₗ[α] γ) (h : surjective f) :
  dim α f.range = dim α γ :=
begin
  refine linear_equiv.dim_eq (linear_equiv.of_bijective (submodule.subtype _) _ _),
  exact linear_map.ker_eq_bot.2 subtype.val_injective,
  rwa [range_subtype, linear_map.range_eq_top]
end

lemma dim_eq_surjective (f : β →ₗ[α] γ) (h : surjective f) : dim α β = dim α γ + dim α f.ker :=
by rw [← dim_range_add_dim_ker f, ← dim_range_of_surjective f h]

lemma dim_le_surjective (f : β →ₗ[α] γ) (h : surjective f) : dim α γ ≤ dim α β :=
by rw [dim_eq_surjective f h]; refine le_add_right (le_refl _)

lemma dim_eq_injective (f : β →ₗ[α] γ) (h : injective f) : dim α β = dim α f.range :=
by rw [← dim_range_add_dim_ker f, linear_map.ker_eq_bot.2 h]; simp [dim_bot]

set_option class.instance_max_depth 37
lemma dim_submodule_le (s : submodule α β) : dim α s ≤ dim α β :=
begin
  rcases exists_is_basis α s with ⟨bs, hbs⟩,
  have : linear_independent α (submodule.subtype s '' bs) :=
    hbs.1.image (linear_map.disjoint_ker'.2 $ assume x y _ _ eq, subtype.val_injective eq),
  have : linear_independent α ((coe : s → β) '' bs) := this,
  rcases exists_subset_is_basis this with ⟨b, hbs_b, hb⟩,
  rw [← is_basis.mk_eq_dim hbs, ← is_basis.mk_eq_dim hb],
  calc cardinal.mk ↥bs = cardinal.mk ((coe : s → β) '' bs) :
      (cardinal.mk_eq_of_injective $ subtype.val_injective).symm
    ... ≤ cardinal.mk ↥b :
      nonempty.intro (embedding_of_subset hbs_b)
end
set_option class.instance_max_depth 32

lemma dim_le_injective (f : β →ₗ[α] γ) (h : injective f) : dim α β ≤ dim α γ :=
by rw [dim_eq_injective f h]; exact dim_submodule_le _

lemma dim_le_of_submodule (s t : submodule α β) (h : s ≤ t) : dim α s ≤ dim α t :=
dim_le_injective (of_le h) $ assume ⟨x, hx⟩ ⟨y, hy⟩ eq,
  subtype.eq $ show x = y, from subtype.ext.1 eq

section
variables [add_comm_group δ] [vector_space α δ]
variables [add_comm_group ε] [vector_space α ε]
set_option class.instance_max_depth 70
open linear_map

/-- This is mostly an auxiliary lemma for `dim_sup_add_dim_inf_eq` -/
lemma dim_add_dim_split
  (db : δ →ₗ[α] β) (eb : ε →ₗ[α] β) (cd : γ →ₗ[α] δ) (ce : γ →ₗ[α] ε)
  (hde : ⊤ ≤ db.range ⊔ eb.range)
  (hgd : ker cd = ⊥)
  (eq : db.comp cd = eb.comp ce)
  (eq₂ : ∀d e, db d = eb e → (∃c, cd c = d ∧ ce c = e)) :
  dim α β + dim α γ = dim α δ + dim α ε :=
have hf : surjective (copair db eb),
begin
  refine (range_eq_top.1 $ top_unique $ _),
  rwa [← map_top, ← prod_top, map_copair_prod]
end,
begin
  conv {to_rhs, rw [← dim_prod, dim_eq_surjective _ hf] },
  congr' 1,
  apply linear_equiv.dim_eq,
  fapply linear_equiv.of_bijective,
  { refine cod_restrict _ (pair cd (- ce)) _,
    { assume c,
      simp [add_eq_zero_iff_eq_neg],
      exact linear_map.ext_iff.1 eq c } },
  { rw [ker_cod_restrict, ker_pair, hgd, bot_inf_eq] },
  { rw [eq_top_iff, range_cod_restrict, ← map_le_iff_le_comap, map_top, range_subtype],
    rintros ⟨d, e⟩,
    have h := eq₂ d (-e),
    simp [add_eq_zero_iff_eq_neg] at ⊢ h,
    assume hde,
    rcases h hde with ⟨c, h₁, h₂⟩,
    refine ⟨c, h₁, _⟩,
    rw [h₂, _root_.neg_neg] }
end

lemma dim_sup_add_dim_inf_eq (s t : submodule α β) :
  dim α (s ⊔ t : submodule α β) + dim α (s ⊓ t : submodule α β) = dim α s + dim α t :=
dim_add_dim_split (of_le le_sup_left) (of_le le_sup_right) (of_le inf_le_left) (of_le inf_le_right)
  begin
    rw [← map_le_map_iff (ker_subtype $ s ⊔ t), map_sup, map_top,
      ← linear_map.range_comp, ← linear_map.range_comp, subtype_comp_of_le, subtype_comp_of_le,
      range_subtype, range_subtype, range_subtype],
    exact le_refl _
  end
  (ker_of_le _ _ _)
  begin ext ⟨x, hx⟩, refl end
  begin
    rintros ⟨b₁, hb₁⟩ ⟨b₂, hb₂⟩ eq,
    have : b₁ = b₂ := congr_arg subtype.val eq,
    subst this,
    exact ⟨⟨b₁, hb₁, hb₂⟩, rfl, rfl⟩
  end

lemma dim_add_le_dim_add_dim (s t : submodule α β) :
  dim α (s ⊔ t : submodule α β) ≤ dim α s + dim α t :=
by rw [← dim_sup_add_dim_inf_eq]; exact le_add_right (le_refl _)

end

section fintype
variable [fintype ι]
variables [∀i, add_comm_group (φ i)] [∀i, vector_space α (φ i)]

open linear_map

lemma dim_pi : vector_space.dim α (Πi, φ i) = cardinal.sum (λi, vector_space.dim α (φ i)) :=
begin
  choose b hb using assume i, exists_is_basis α (φ i),
  have : is_basis α (⋃i, std_basis α φ i '' b i) := pi.is_basis_std_basis b hb,
  rw [← this.mk_eq_dim, cardinal.mk_Union_eq_sum_mk],
  { congr, funext i,
    rw [cardinal.mk_eq_of_injective, (hb i).mk_eq_dim],
    exact ker_eq_bot.1 (ker_std_basis α _ i) },
  rintros i j h b ⟨⟨x, hx, rfl⟩, ⟨y, hy, eq⟩⟩,
  replace eq := congr_fun eq i,
  rw [std_basis_same, std_basis_ne α φ _ _ h] at eq,
  subst eq,
  exact (zero_not_mem_of_linear_independent (zero_ne_one : (0:α) ≠ 1) (hb i).1 hx).elim
end

lemma dim_fun {β : Type u} [add_comm_group β] [vector_space α β] :
  vector_space.dim α (ι → β) = fintype.card ι * vector_space.dim α β :=
by rw [dim_pi, cardinal.sum_const, cardinal.fintype_card]

lemma dim_fun' : vector_space.dim α (ι → α) = fintype.card ι :=
by rw [dim_fun, dim_of_field, mul_one]

end fintype

lemma exists_mem_ne_zero_of_ne_bot {s : submodule α β} (h : s ≠ ⊥) : ∃ b : β, b ∈ s ∧ b ≠ 0 :=
begin
  by_contradiction hex,
  have : ∀x∈s, (x:β) = 0, { simpa only [not_exists, not_and, not_not, ne.def] using hex },
  exact (h $ bot_unique $ assume s hs, (submodule.mem_bot α).2 $ this s hs)
end

lemma exists_mem_ne_zero_of_dim_pos {s : submodule α β} (h : vector_space.dim α s > 0) :
  ∃ b : β, b ∈ s ∧ b ≠ 0 :=
exists_mem_ne_zero_of_ne_bot $ assume eq, by rw [(>), eq, dim_bot] at h; exact lt_irrefl _ h

def rank (f : β →ₗ[α] γ) : cardinal := dim α f.range

lemma rank_le_domain (f : β →ₗ[α] γ) : rank f ≤ dim α β :=
by rw [← dim_range_add_dim_ker f]; exact le_add_right (le_refl _)

lemma rank_le_range (f : β →ₗ[α] γ) : rank f ≤ dim α γ :=
dim_submodule_le _

lemma rank_add_le (f g : β →ₗ[α] γ) : rank (f + g) ≤ rank f + rank g :=
calc rank (f + g) ≤ dim α (f.range ⊔ g.range : submodule α γ) :
  begin
    refine dim_le_of_submodule _ _ _,
    exact (linear_map.range_le_iff_comap.2 $ eq_top_iff'.2 $
      assume x, show f x + g x ∈ (f.range ⊔ g.range : submodule α γ), from
        mem_sup.2 ⟨_, mem_image_of_mem _ (mem_univ _), _, mem_image_of_mem _ (mem_univ _), rfl⟩)
  end
  ... ≤ rank f + rank g : dim_add_le_dim_add_dim _ _

@[simp] lemma rank_zero : rank (0 : β →ₗ[α] γ) = 0 :=
by rw [rank, linear_map.range_zero, dim_bot]

lemma rank_finset_sum_le {ι} (s : finset ι) (f : ι → β →ₗ[α] γ) :
  rank (s.sum f) ≤ s.sum (λ d, rank (f d)) :=
begin
  refine @finset.sum_hom_rel _ _ _ _ _ (λa b, rank a ≤ b) _ _ s (le_of_eq _) _,
  { exact rank_zero },
  { assume i g c h, exact le_trans (rank_add_le _ _) (add_le_add_left' h) }
end

variables [add_comm_group δ] [vector_space α δ]

lemma rank_comp_le1 (g : β →ₗ[α] γ) (f : γ →ₗ[α] δ) : rank (f.comp g) ≤ rank f :=
begin
  refine dim_le_of_submodule _ _ _,
  rw [linear_map.range_comp],
  exact image_subset _ (subset_univ _)
end

lemma rank_comp_le2 (g : β →ₗ[α] γ) (f : γ →ₗ δ) : rank (f.comp g) ≤ rank g :=
by rw [rank, rank, linear_map.range_comp]; exact dim_map_le _ _

end vector_space


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

! This file was ported from Lean 3 source module analysis.box_integral.partition.additive
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.BoxIntegral.Partition.Split
import Mathbin.Analysis.NormedSpace.OperatorNorm

/-!
# Box additive functions

We say that a function `f : box ι → M` from boxes in `ℝⁿ` to a commutative additive monoid `M` is
*box additive* on subboxes of `I₀ : with_top (box ι)` if for any box `J`, `↑J ≤ I₀`, and a partition
`π` of `J`, `f J = ∑ J' in π.boxes, f J'`. We use `I₀ : with_top (box ι)` instead of `I₀ : box ι` to
use the same definition for functions box additive on subboxes of a box and for functions box
additive on all boxes.

Examples of box-additive functions include the measure of a box and the integral of a fixed
integrable function over a box.

In this file we define box-additive functions and prove that a function such that
`f J = f (J ∩ {x | x i < y}) + f (J ∩ {x | y ≤ x i})` is box-additive.

### Tags

rectangular box, additive function
-/

noncomputable section

open Classical BigOperators

open Function Set

namespace BoxIntegral

variable {ι M : Type _} {n : ℕ}

/-- A function on `box ι` is called box additive if for every box `J` and a partition `π` of `J`
we have `f J = ∑ Ji in π.boxes, f Ji`. A function is called box additive on subboxes of `I : box ι`
if the same property holds for `J ≤ I`. We formalize these two notions in the same definition
using `I : with_bot (box ι)`: the value `I = ⊤` corresponds to functions box additive on the whole
space.  -/
structure BoxAdditiveMap (ι M : Type _) [AddCommMonoid M] (I : WithTop (Box ι)) where
  toFun : Box ι → M
  sum_partition_boxes' :
    ∀ J : Box ι,
      ↑J ≤ I → ∀ π : Prepartition J, π.IsPartition → (∑ Ji in π.boxes, to_fun Ji) = to_fun J
#align box_integral.box_additive_map BoxIntegral.BoxAdditiveMap

-- mathport name: box_integral.box_additive_map.top
scoped notation:25 ι " →ᵇᵃ " M => BoxIntegral.BoxAdditiveMap ι M ⊤

-- mathport name: box_integral.box_additive_map
scoped notation:25 ι " →ᵇᵃ[" I "] " M => BoxIntegral.BoxAdditiveMap ι M I

namespace BoxAdditiveMap

open Box Prepartition Finset

variable {N : Type _} [AddCommMonoid M] [AddCommMonoid N] {I₀ : WithTop (Box ι)} {I J : Box ι}
  {i : ι}

instance : CoeFun (ι →ᵇᵃ[I₀] M) fun _ => Box ι → M :=
  ⟨toFun⟩

initialize_simps_projections box_integral.box_additive_map (toFun → apply)

@[simp]
theorem toFun_eq_coe (f : ι →ᵇᵃ[I₀] M) : f.toFun = f :=
  rfl
#align box_integral.box_additive_map.to_fun_eq_coe BoxIntegral.BoxAdditiveMap.toFun_eq_coe

@[simp]
theorem coe_mk (f h) : ⇑(mk f h : ι →ᵇᵃ[I₀] M) = f :=
  rfl
#align box_integral.box_additive_map.coe_mk BoxIntegral.BoxAdditiveMap.coe_mk

theorem coe_injective : Injective fun (f : ι →ᵇᵃ[I₀] M) x => f x :=
  by
  rintro ⟨f, hf⟩ ⟨g, hg⟩ (rfl : f = g)
  rfl
#align box_integral.box_additive_map.coe_injective BoxIntegral.BoxAdditiveMap.coe_injective

@[simp]
theorem coe_inj {f g : ι →ᵇᵃ[I₀] M} : (f : Box ι → M) = g ↔ f = g :=
  coe_injective.eq_iff
#align box_integral.box_additive_map.coe_inj BoxIntegral.BoxAdditiveMap.coe_inj

theorem sum_partition_boxes (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) {π : Prepartition I}
    (h : π.IsPartition) : (∑ J in π.boxes, f J) = f I :=
  f.sum_partition_boxes' I hI π h
#align box_integral.box_additive_map.sum_partition_boxes BoxIntegral.BoxAdditiveMap.sum_partition_boxes

@[simps (config := { fullyApplied := false })]
instance : Zero (ι →ᵇᵃ[I₀] M) :=
  ⟨⟨0, fun I hI π hπ => sum_const_zero⟩⟩

instance : Inhabited (ι →ᵇᵃ[I₀] M) :=
  ⟨0⟩

instance : Add (ι →ᵇᵃ[I₀] M) :=
  ⟨fun f g =>
    ⟨f + g, fun I hI π hπ => by
      simp only [Pi.add_apply, sum_add_distrib, sum_partition_boxes _ hI hπ]⟩⟩

instance {R} [Monoid R] [DistribMulAction R M] : SMul R (ι →ᵇᵃ[I₀] M) :=
  ⟨fun r f =>
    ⟨r • f, fun I hI π hπ => by simp only [Pi.smul_apply, ← smul_sum, sum_partition_boxes _ hI hπ]⟩⟩

instance : AddCommMonoid (ι →ᵇᵃ[I₀] M) :=
  Function.Injective.addCommMonoid _ coe_injective rfl (fun _ _ => rfl) fun _ _ => rfl

@[simp]
theorem map_split_add (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) (i : ι) (x : ℝ) :
    (I.splitLower i x).elim 0 f + (I.splitUpper i x).elim 0 f = f I := by
  rw [← f.sum_partition_boxes hI (is_partition_split I i x), sum_split_boxes]
#align box_integral.box_additive_map.map_split_add BoxIntegral.BoxAdditiveMap.map_split_add

/-- If `f` is box-additive on subboxes of `I₀`, then it is box-additive on subboxes of any
`I ≤ I₀`. -/
@[simps]
def restrict (f : ι →ᵇᵃ[I₀] M) (I : WithTop (Box ι)) (hI : I ≤ I₀) : ι →ᵇᵃ[I] M :=
  ⟨f, fun J hJ => f.2 J (hJ.trans hI)⟩
#align box_integral.box_additive_map.restrict BoxIntegral.BoxAdditiveMap.restrict

/-- If `f : box ι → M` is box additive on partitions of the form `split I i x`, then it is box
additive. -/
def ofMapSplitAdd [Fintype ι] (f : Box ι → M) (I₀ : WithTop (Box ι))
    (hf :
      ∀ I : Box ι,
        ↑I ≤ I₀ →
          ∀ {i x},
            x ∈ Ioo (I.lower i) (I.upper i) →
              (I.splitLower i x).elim 0 f + (I.splitUpper i x).elim 0 f = f I) :
    ι →ᵇᵃ[I₀] M := by
  refine' ⟨f, _⟩
  replace hf : ∀ I : box ι, ↑I ≤ I₀ → ∀ s, (∑ J in (split_many I s).boxes, f J) = f I
  · intro I hI s
    induction' s using Finset.induction_on with a s ha ihs
    · simp
    rw [split_many_insert, inf_split, ← ihs, bUnion_boxes, sum_bUnion_boxes]
    refine' Finset.sum_congr rfl fun J' hJ' => _
    by_cases h : a.2 ∈ Ioo (J'.lower a.1) (J'.upper a.1)
    · rw [sum_split_boxes]
      exact hf _ ((WithTop.coe_le_coe.2 <| le_of_mem _ hJ').trans hI) h
    · rw [split_of_not_mem_Ioo h, top_boxes, Finset.sum_singleton]
  intro I hI π hπ
  have Hle : ∀ J ∈ π, ↑J ≤ I₀ := fun J hJ => (WithTop.coe_le_coe.2 <| π.le_of_mem hJ).trans hI
  rcases hπ.exists_split_many_le with ⟨s, hs⟩
  rw [← hf _ hI, ← inf_of_le_right hs, inf_split_many, bUnion_boxes, sum_bUnion_boxes]
  exact Finset.sum_congr rfl fun J hJ => (hf _ (Hle _ hJ) _).symm
#align box_integral.box_additive_map.of_map_split_add BoxIntegral.BoxAdditiveMap.ofMapSplitAdd

/-- If `g : M → N` is an additive map and `f` is a box additive map, then `g ∘ f` is a box additive
map. -/
@[simps (config := { fullyApplied := false })]
def map (f : ι →ᵇᵃ[I₀] M) (g : M →+ N) : ι →ᵇᵃ[I₀] N
    where
  toFun := g ∘ f
  sum_partition_boxes' I hI π hπ := by rw [← g.map_sum, f.sum_partition_boxes hI hπ]
#align box_integral.box_additive_map.map BoxIntegral.BoxAdditiveMap.map

/-- If `f` is a box additive function on subboxes of `I` and `π₁`, `π₂` are two prepartitions of
`I` that cover the same part of `I`, then `∑ J in π₁.boxes, f J = ∑ J in π₂.boxes, f J`. -/
theorem sum_boxes_congr [Finite ι] (f : ι →ᵇᵃ[I₀] M) (hI : ↑I ≤ I₀) {π₁ π₂ : Prepartition I}
    (h : π₁.unionᵢ = π₂.unionᵢ) : (∑ J in π₁.boxes, f J) = ∑ J in π₂.boxes, f J :=
  by
  rcases exists_split_many_inf_eq_filter_of_finite {π₁, π₂} ((finite_singleton _).insert _) with
    ⟨s, hs⟩
  simp only [inf_split_many] at hs
  rcases hs _ (Or.inl rfl), hs _ (Or.inr rfl) with ⟨h₁, h₂⟩; clear hs
  rw [h] at h₁
  calc
    (∑ J in π₁.boxes, f J) = ∑ J in π₁.boxes, ∑ J' in (split_many J s).boxes, f J' :=
      Finset.sum_congr rfl fun J hJ => (f.sum_partition_boxes _ (is_partition_split_many _ _)).symm
    _ = ∑ J in (π₁.bUnion fun J => split_many J s).boxes, f J := (sum_bUnion_boxes _ _ _).symm
    _ = ∑ J in (π₂.bUnion fun J => split_many J s).boxes, f J := by rw [h₁, h₂]
    _ = ∑ J in π₂.boxes, ∑ J' in (split_many J s).boxes, f J' := (sum_bUnion_boxes _ _ _)
    _ = ∑ J in π₂.boxes, f J :=
      Finset.sum_congr rfl fun J hJ => f.sum_partition_boxes _ (is_partition_split_many _ _)

  exacts[(WithTop.coe_le_coe.2 <| π₁.le_of_mem hJ).trans hI,
    (WithTop.coe_le_coe.2 <| π₂.le_of_mem hJ).trans hI]
#align box_integral.box_additive_map.sum_boxes_congr BoxIntegral.BoxAdditiveMap.sum_boxes_congr

section ToSmul

variable {E : Type _} [NormedAddCommGroup E] [NormedSpace ℝ E]

/-- If `f` is a box-additive map, then so is the map sending `I` to the scalar multiplication
by `f I` as a continuous linear map from `E` to itself. -/
def toSmul (f : ι →ᵇᵃ[I₀] ℝ) : ι →ᵇᵃ[I₀] E →L[ℝ] E :=
  f.map (ContinuousLinearMap.lsmul ℝ ℝ).toLinearMap.toAddMonoidHom
#align box_integral.box_additive_map.to_smul BoxIntegral.BoxAdditiveMap.toSmul

@[simp]
theorem toSmul_apply (f : ι →ᵇᵃ[I₀] ℝ) (I : Box ι) (x : E) : f.toSmul I x = f I • x :=
  rfl
#align box_integral.box_additive_map.to_smul_apply BoxIntegral.BoxAdditiveMap.toSmul_apply

end ToSmul

/-- Given a box `I₀` in `ℝⁿ⁺¹`, `f x : box (fin n) → G` is a family of functions indexed by a real
`x` and for `x ∈ [I₀.lower i, I₀.upper i]`, `f x` is box-additive on subboxes of the `i`-th face of
`I₀`, then `λ J, f (J.upper i) (J.face i) - f (J.lower i) (J.face i)` is box-additive on subboxes of
`I₀`. -/
@[simps]
def upperSubLower.{u} {G : Type u} [AddCommGroup G] (I₀ : Box (Fin (n + 1))) (i : Fin (n + 1))
    (f : ℝ → Box (Fin n) → G) (fb : Icc (I₀.lower i) (I₀.upper i) → Fin n →ᵇᵃ[I₀.face i] G)
    (hf : ∀ (x) (hx : x ∈ Icc (I₀.lower i) (I₀.upper i)) (J), f x J = fb ⟨x, hx⟩ J) :
    Fin (n + 1) →ᵇᵃ[I₀] G :=
  ofMapSplitAdd (fun J : Box (Fin (n + 1)) => f (J.upper i) (J.face i) - f (J.lower i) (J.face i))
    I₀
    (by
      intro J hJ j
      rw [WithTop.coe_le_coe] at hJ
      refine' i.succ_above_cases _ _ j
      · intro x hx
        simp only [box.split_lower_def hx, box.split_upper_def hx, update_same, ←
          WithBot.some_eq_coe, Option.elim', box.face, (· ∘ ·), update_noteq (Fin.succAbove_ne _ _)]
        abel
      · clear j
        intro j x hx
        have : (J.face i : WithTop (box (Fin n))) ≤ I₀.face i :=
          WithTop.coe_le_coe.2 (face_mono hJ i)
        rw [le_iff_Icc, @box.Icc_eq_pi _ I₀] at hJ
        rw [hf _ (hJ J.upper_mem_Icc _ trivial), hf _ (hJ J.lower_mem_Icc _ trivial), ←
          (fb _).map_split_add this j x, ← (fb _).map_split_add this j x]
        have hx' : x ∈ Ioo ((J.face i).lower j) ((J.face i).upper j) := hx
        simp only [box.split_lower_def hx, box.split_upper_def hx, box.split_lower_def hx',
          box.split_upper_def hx', ← WithBot.some_eq_coe, Option.elim', box.face_mk,
          update_noteq (Fin.succAbove_ne _ _).symm, sub_add_sub_comm,
          update_comp_eq_of_injective _ i.succ_above.injective j x, ← hf]
        simp only [box.face])
#align box_integral.box_additive_map.upper_sub_lower BoxIntegral.BoxAdditiveMap.upperSubLower

end BoxAdditiveMap

end BoxIntegral


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.category.Top.opens
import Mathlib.category_theory.filtered
import Mathlib.PostPort

universes u

namespace Mathlib

namespace topological_space

def open_nhds {X : Top} (x : ↥X) := Subtype fun (U : opens ↥X) => x ∈ U

namespace open_nhds

protected instance partial_order {X : Top} (x : ↥X) : partial_order (open_nhds x) :=
  partial_order.mk (fun (U V : open_nhds x) => subtype.val U ≤ subtype.val V)
    (preorder.lt._default fun (U V : open_nhds x) => subtype.val U ≤ subtype.val V) sorry sorry
    sorry

protected instance lattice {X : Top} (x : ↥X) : lattice (open_nhds x) :=
  lattice.mk
    (fun (U V : open_nhds x) => { val := subtype.val U ⊔ subtype.val V, property := sorry })
    partial_order.le partial_order.lt sorry sorry sorry sorry sorry sorry
    (fun (U V : open_nhds x) => { val := subtype.val U ⊓ subtype.val V, property := sorry }) sorry
    sorry sorry

protected instance order_top {X : Top} (x : ↥X) : order_top (open_nhds x) :=
  order_top.mk { val := ⊤, property := trivial } partial_order.le partial_order.lt sorry sorry sorry
    sorry

protected instance open_nhds_category {X : Top} (x : ↥X) : category_theory.category (open_nhds x) :=
  eq.mpr sorry (category_theory.full_subcategory fun (U : opens ↥X) => x ∈ U)

protected instance opens_nhds_hom_has_coe_to_fun {X : Top} {x : ↥X} {U : open_nhds x}
    {V : open_nhds x} : has_coe_to_fun (U ⟶ V) :=
  has_coe_to_fun.mk (fun (f : U ⟶ V) => ↥(subtype.val U) → ↥(subtype.val V))
    fun (f : U ⟶ V) (x_1 : ↥(subtype.val U)) => { val := ↑x_1, property := sorry }

/--
The inclusion `U ⊓ V ⟶ U` as a morphism in the category of open sets.
-/
def inf_le_left {X : Top} {x : ↥X} (U : open_nhds x) (V : open_nhds x) : U ⊓ V ⟶ U :=
  category_theory.hom_of_le sorry

/--
The inclusion `U ⊓ V ⟶ V` as a morphism in the category of open sets.
-/
def inf_le_right {X : Top} {x : ↥X} (U : open_nhds x) (V : open_nhds x) : U ⊓ V ⟶ V :=
  category_theory.hom_of_le sorry

def inclusion {X : Top} (x : ↥X) : open_nhds x ⥤ opens ↥X :=
  category_theory.full_subcategory_inclusion fun (U : opens ↥X) => x ∈ U

@[simp] theorem inclusion_obj {X : Top} (x : ↥X) (U : opens ↥X) (p : x ∈ U) :
    category_theory.functor.obj (inclusion x) { val := U, property := p } = U :=
  rfl

protected instance open_nhds_is_filtered {X : Top} (x : ↥X) :
    category_theory.is_filtered (open_nhds xᵒᵖ) :=
  category_theory.is_filtered.mk

def map {X : Top} {Y : Top} (f : X ⟶ Y) (x : ↥X) : open_nhds (coe_fn f x) ⥤ open_nhds x :=
  category_theory.functor.mk
    (fun (U : open_nhds (coe_fn f x)) =>
      { val := category_theory.functor.obj (opens.map f) (subtype.val U), property := sorry })
    fun (U V : open_nhds (coe_fn f x)) (i : U ⟶ V) => category_theory.functor.map (opens.map f) i

@[simp] theorem map_obj {X : Top} {Y : Top} (f : X ⟶ Y) (x : ↥X) (U : opens ↥Y)
    (q : coe_fn f x ∈ U) :
    category_theory.functor.obj (map f x) { val := U, property := q } =
        { val := category_theory.functor.obj (opens.map f) U, property := q } :=
  rfl

@[simp] theorem map_id_obj {X : Top} (x : ↥X) (U : open_nhds (coe_fn 𝟙 x)) :
    category_theory.functor.obj (map 𝟙 x) U = U :=
  sorry

@[simp] theorem map_id_obj' {X : Top} (x : ↥X) (U : set ↥X) (p : is_open U)
    (q : coe_fn 𝟙 x ∈ { val := U, property := p }) :
    category_theory.functor.obj (map 𝟙 x) { val := { val := U, property := p }, property := q } =
        { val := { val := U, property := p }, property := q } :=
  rfl

@[simp] theorem map_id_obj_unop {X : Top} (x : ↥X) (U : open_nhds xᵒᵖ) :
    category_theory.functor.obj (map 𝟙 x) (opposite.unop U) = opposite.unop U :=
  sorry

@[simp] theorem op_map_id_obj {X : Top} (x : ↥X) (U : open_nhds xᵒᵖ) :
    category_theory.functor.obj (category_theory.functor.op (map 𝟙 x)) U = U :=
  sorry

def inclusion_map_iso {X : Top} {Y : Top} (f : X ⟶ Y) (x : ↥X) :
    inclusion (coe_fn f x) ⋙ opens.map f ≅ map f x ⋙ inclusion x :=
  category_theory.nat_iso.of_components
    (fun (U : open_nhds (coe_fn f x)) => category_theory.iso.mk 𝟙 𝟙) sorry

@[simp] theorem inclusion_map_iso_hom {X : Top} {Y : Top} (f : X ⟶ Y) (x : ↥X) :
    category_theory.iso.hom (inclusion_map_iso f x) = 𝟙 :=
  rfl

@[simp] theorem inclusion_map_iso_inv {X : Top} {Y : Top} (f : X ⟶ Y) (x : ↥X) :
    category_theory.iso.inv (inclusion_map_iso f x) = 𝟙 :=
  rfl

end Mathlib


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad
-/

/-!
# booleans

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

This file proves various trivial lemmas about booleans and their
relation to decidable propositions.

## Notations

This file introduces the notation `!b` for `bnot b`, the boolean "not".

## Tags
bool, boolean, De Morgan
-/

prefix `!`:90 := bnot

namespace bool

-- TODO: duplicate of a lemma in core
theorem coe_sort_tt : coe_sort.{1 1} tt = true := coe_sort_tt

-- TODO: duplicate of a lemma in core
theorem coe_sort_ff : coe_sort.{1 1} ff = false := coe_sort_ff

-- TODO: duplicate of a lemma in core
theorem to_bool_true {h} : @to_bool true h = tt :=
to_bool_true_eq_tt h

-- TODO: duplicate of a lemma in core
theorem to_bool_false {h} : @to_bool false h = ff :=
to_bool_false_eq_ff h

@[simp] theorem to_bool_coe (b:bool) {h} : @to_bool b h = b :=
(show _ = to_bool b, by congr).trans (by cases b; refl)

@[simp] lemma of_to_bool_iff {p : Prop} [decidable p] : to_bool p ↔ p :=
⟨of_to_bool_true, _root_.to_bool_true⟩

@[simp] lemma tt_eq_to_bool_iff {p : Prop} [decidable p] : tt = to_bool p ↔ p :=
eq_comm.trans of_to_bool_iff

@[simp] lemma ff_eq_to_bool_iff {p : Prop} [decidable p] : ff = to_bool p ↔ ¬ p :=
eq_comm.trans (to_bool_ff_iff _)

@[simp] theorem to_bool_not (p : Prop) [decidable p] : to_bool (¬ p) = !(to_bool p) :=
by by_cases p; simp *

@[simp] theorem to_bool_and (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∧ q) = p && q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_or (p q : Prop) [decidable p] [decidable q] :
  to_bool (p ∨ q) = p || q :=
by by_cases p; by_cases q; simp *

@[simp] theorem to_bool_eq {p q : Prop} [decidable p] [decidable q] :
  to_bool p = to_bool q ↔ (p ↔ q) :=
⟨λ h, (coe_to_bool p).symm.trans $ by simp [h], to_bool_congr⟩

lemma not_ff : ¬ ff := ff_ne_tt

@[simp] theorem default_bool : default = ff := rfl

theorem dichotomy (b : bool) : b = ff ∨ b = tt :=
by cases b; simp

@[simp] theorem forall_bool {p : bool → Prop} : (∀ b, p b) ↔ p ff ∧ p tt :=
⟨λ h, by simp [h], λ ⟨h₁, h₂⟩ b, by cases b; assumption⟩

@[simp] theorem exists_bool {p : bool → Prop} : (∃ b, p b) ↔ p ff ∨ p tt :=
⟨λ ⟨b, h⟩, by cases b; [exact or.inl h, exact or.inr h],
 λ h, by cases h; exact ⟨_, h⟩⟩

/-- If `p b` is decidable for all `b : bool`, then `∀ b, p b` is decidable -/
instance decidable_forall_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∀ b, p b) :=
decidable_of_decidable_of_iff and.decidable forall_bool.symm

/-- If `p b` is decidable for all `b : bool`, then `∃ b, p b` is decidable -/
instance decidable_exists_bool {p : bool → Prop} [∀ b, decidable (p b)] : decidable (∃ b, p b) :=
decidable_of_decidable_of_iff or.decidable exists_bool.symm

@[simp] theorem cond_ff {α} (t e : α) : cond ff t e = e := rfl

@[simp] theorem cond_tt {α} (t e : α) : cond tt t e = t := rfl

theorem cond_eq_ite {α} (b : bool) (t e : α) : cond b t e = if b then t else e := by cases b; simp

@[simp] theorem cond_to_bool {α} (p : Prop) [decidable p] (t e : α) :
  cond (to_bool p) t e = if p then t else e :=
by simp [cond_eq_ite]

@[simp] theorem cond_bnot {α} (b : bool) (t e : α) : cond (!b) t e = cond b e t :=
by cases b; refl

theorem bnot_ne_id : bnot ≠ id := λ h, ff_ne_tt $ congr_fun h tt

theorem coe_bool_iff : ∀ {a b : bool}, (a ↔ b) ↔ a = b := dec_trivial

theorem eq_tt_of_ne_ff : ∀ {a : bool}, a ≠ ff → a = tt := dec_trivial

theorem eq_ff_of_ne_tt : ∀ {a : bool}, a ≠ tt → a = ff := dec_trivial

theorem bor_comm : ∀ a b, a || b = b || a := dec_trivial

@[simp] theorem bor_assoc : ∀ a b c, (a || b) || c = a || (b || c) := dec_trivial

theorem bor_left_comm : ∀ a b c, a || (b || c) = b || (a || c) := dec_trivial

theorem bor_inl {a b : bool} (H : a) : a || b :=
by simp [H]

theorem bor_inr {a b : bool} (H : b) : a || b :=
by simp [H]

theorem band_comm : ∀ a b, a && b = b && a := dec_trivial

@[simp] theorem band_assoc : ∀ a b c, (a && b) && c = a && (b && c) := dec_trivial

theorem band_left_comm : ∀ a b c, a && (b && c) = b && (a && c) := dec_trivial

theorem band_elim_left : ∀ {a b : bool}, a && b → a := dec_trivial

theorem band_intro : ∀ {a b : bool}, a → b → a && b := dec_trivial

theorem band_elim_right : ∀ {a b : bool}, a && b → b := dec_trivial

lemma band_bor_distrib_left (a b c : bool) : a && (b || c) = a && b || a && c := by cases a; simp
lemma band_bor_distrib_right (a b c : bool) : (a || b) && c = a && c || b && c := by cases c; simp
lemma bor_band_distrib_left (a b c : bool) : a || b && c = (a || b) && (a || c) := by cases a; simp
lemma bor_band_distrib_right (a b c : bool) : a && b || c = (a || c) && (b || c) := by cases c; simp

@[simp] theorem bnot_ff : !ff = tt := rfl

@[simp] theorem bnot_tt : !tt = ff := rfl

lemma eq_bnot_iff : ∀ {a b : bool}, a = !b ↔ a ≠ b := dec_trivial
lemma bnot_eq_iff : ∀ {a b : bool}, !a = b ↔ a ≠ b := dec_trivial

@[simp] lemma not_eq_bnot : ∀ {a b : bool}, ¬a = !b ↔ a = b := dec_trivial
@[simp] lemma bnot_not_eq : ∀ {a b : bool}, ¬!a = b ↔ a = b := dec_trivial

lemma ne_bnot {a b : bool} : a ≠ !b ↔ a = b := not_eq_bnot
lemma bnot_ne {a b : bool} : !a ≠ b ↔ a = b := bnot_not_eq

lemma bnot_ne_self : ∀ b : bool, !b ≠ b := dec_trivial
lemma self_ne_bnot : ∀ b : bool, b ≠ !b := dec_trivial

lemma eq_or_eq_bnot : ∀ a b, a = b ∨ a = !b := dec_trivial

@[simp] theorem bnot_iff_not : ∀ {b : bool}, !b ↔ ¬b := dec_trivial

theorem eq_tt_of_bnot_eq_ff : ∀ {a : bool}, !a = ff → a = tt := dec_trivial

theorem eq_ff_of_bnot_eq_tt : ∀ {a : bool}, !a = tt → a = ff := dec_trivial

@[simp] lemma band_bnot_self : ∀ x, x && !x = ff := dec_trivial
@[simp] lemma bnot_band_self : ∀ x, !x && x = ff := dec_trivial
@[simp] lemma bor_bnot_self : ∀ x, x || !x = tt := dec_trivial
@[simp] lemma bnot_bor_self : ∀ x, !x || x = tt := dec_trivial

theorem bxor_comm : ∀ a b, bxor a b = bxor b a := dec_trivial
@[simp] theorem bxor_assoc : ∀ a b c, bxor (bxor a b) c = bxor a (bxor b c) := dec_trivial
theorem bxor_left_comm : ∀ a b c, bxor a (bxor b c) = bxor b (bxor a c) := dec_trivial
@[simp] theorem bxor_bnot_left : ∀ a, bxor (!a) a = tt := dec_trivial
@[simp] theorem bxor_bnot_right : ∀ a, bxor a (!a) = tt := dec_trivial
@[simp] theorem bxor_bnot_bnot : ∀ a b, bxor (!a) (!b) = bxor a b := dec_trivial
@[simp] theorem bxor_ff_left : ∀ a, bxor ff a = a := dec_trivial
@[simp] theorem bxor_ff_right : ∀ a, bxor a ff = a := dec_trivial

lemma band_bxor_distrib_left (a b c : bool) : a && (bxor b c) = bxor (a && b) (a && c) :=
by cases a; simp
lemma band_bxor_distrib_right (a b c : bool) : (bxor a b) && c = bxor (a && c) (b && c) :=
by cases c; simp

lemma bxor_iff_ne : ∀ {x y : bool}, bxor x y = tt ↔ x ≠ y := dec_trivial

/-! ### De Morgan's laws for booleans-/
@[simp] lemma bnot_band : ∀ (a b : bool), !(a && b) = !a || !b := dec_trivial
@[simp] lemma bnot_bor : ∀ (a b : bool), !(a || b) = !a && !b := dec_trivial

lemma bnot_inj : ∀ {a b : bool}, !a = !b → a = b := dec_trivial

instance : linear_order bool :=
{ le := λ a b, a = ff ∨ b = tt,
  le_refl := dec_trivial,
  le_trans := dec_trivial,
  le_antisymm := dec_trivial,
  le_total := dec_trivial,
  decidable_le := infer_instance,
  decidable_eq := infer_instance,
  max := bor,
  max_def := by { funext x y, revert x y, exact dec_trivial },
  min := band,
  min_def := by { funext x y, revert x y, exact dec_trivial } }

@[simp] lemma ff_le {x : bool} : ff ≤ x := or.intro_left _ rfl

@[simp] lemma le_tt {x : bool} : x ≤ tt := or.intro_right _ rfl

lemma lt_iff : ∀ {x y : bool}, x < y ↔ x = ff ∧ y = tt := dec_trivial

@[simp] lemma ff_lt_tt : ff < tt := lt_iff.2 ⟨rfl, rfl⟩

lemma le_iff_imp : ∀ {x y : bool}, x ≤ y ↔ (x → y) := dec_trivial

lemma band_le_left : ∀ x y : bool, x && y ≤ x := dec_trivial

lemma band_le_right : ∀ x y : bool, x && y ≤ y := dec_trivial

lemma le_band : ∀ {x y z : bool}, x ≤ y → x ≤ z → x ≤ y && z := dec_trivial

lemma left_le_bor : ∀ x y : bool, x ≤ x || y := dec_trivial

lemma right_le_bor : ∀ x y : bool, y ≤ x || y := dec_trivial

lemma bor_le : ∀ {x y z}, x ≤ z → y ≤ z → x || y ≤ z := dec_trivial

/-- convert a `bool` to a `ℕ`, `false -> 0`, `true -> 1` -/
def to_nat (b : bool) : ℕ :=
cond b 1 0

/-- convert a `ℕ` to a `bool`, `0 -> false`, everything else -> `true` -/
def of_nat (n : ℕ) : bool :=
to_bool (n ≠ 0)

lemma of_nat_le_of_nat {n m : ℕ} (h : n ≤ m) : of_nat n ≤ of_nat m :=
begin
  simp [of_nat];
    cases nat.decidable_eq n 0;
    cases nat.decidable_eq m 0;
    simp only [to_bool],
  { subst m, have h := le_antisymm h (nat.zero_le _),
    contradiction },
  { left, refl }
end

lemma to_nat_le_to_nat {b₀ b₁ : bool} (h : b₀ ≤ b₁) : to_nat b₀ ≤ to_nat b₁ :=
by cases h; subst h; [cases b₁, cases b₀]; simp [to_nat,nat.zero_le]

lemma of_nat_to_nat (b : bool) : of_nat (to_nat b) = b :=
by cases b; simp only [of_nat,to_nat]; exact dec_trivial

@[simp] lemma injective_iff {α : Sort*} {f : bool → α} : function.injective f ↔ f ff ≠ f tt :=
⟨λ Hinj Heq, ff_ne_tt (Hinj Heq),
  λ H x y hxy, by { cases x; cases y, exacts [rfl, (H hxy).elim, (H hxy.symm).elim, rfl] }⟩

/-- **Kaminski's Equation** -/
theorem apply_apply_apply (f : bool → bool) (x : bool) : f (f (f x)) = f x :=
by cases x; cases h₁ : f tt; cases h₂ : f ff; simp only [h₁, h₂]

end bool


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

! This file was ported from Lean 3 source module algebraic_topology.dold_kan.normalized
! leanprover-community/mathlib commit d1d69e99ed34c95266668af4e288fc1c598b9a7f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicTopology.DoldKan.FunctorN

/-!

# Comparison with the normalized Moore complex functor

TODO (@joelriou) continue adding the various files referenced below

In this file, we show that when the category `A` is abelian,
there is an isomorphism `N₁_iso_normalized_Moore_complex_comp_to_karoubi` between
the functor `N₁ : simplicial_object A ⥤ karoubi (chain_complex A ℕ)`
defined in `functor_n.lean` and the composition of
`normalized_Moore_complex A` with the inclusion
`chain_complex A ℕ ⥤ karoubi (chain_complex A ℕ)`.

This isomorphism shall be used in `equivalence.lean` in order to obtain
the Dold-Kan equivalence
`category_theory.abelian.dold_kan.equivalence : simplicial_object A ≌ chain_complex A ℕ`
with a functor (definitionally) equal to `normalized_Moore_complex A`.

-/

open
  CategoryTheory CategoryTheory.Category CategoryTheory.Limits CategoryTheory.Subobject CategoryTheory.Idempotents

open DoldKan

noncomputable section

namespace AlgebraicTopology

namespace DoldKan

universe v

variable {A : Type _} [Category A] [Abelian A] {X : SimplicialObject A}

theorem HigherFacesVanish.inclusionOfMooreComplexMap (n : ℕ) :
    HigherFacesVanish (n + 1) ((inclusionOfMooreComplexMap X).f (n + 1)) := fun j hj =>
  by
  dsimp [inclusion_of_Moore_complex_map]
  rw [←
    factor_thru_arrow _ _
      (finset_inf_arrow_factors Finset.univ _ j (by simp only [Finset.mem_univ])),
    assoc, kernel_subobject_arrow_comp, comp_zero]
#align algebraic_topology.dold_kan.higher_faces_vanish.inclusion_of_Moore_complex_map AlgebraicTopology.DoldKan.HigherFacesVanish.inclusionOfMooreComplexMap

theorem factors_normalized_Moore_complex_pInfty (n : ℕ) :
    Subobject.Factors (NormalizedMooreComplex.objX X n) (pInfty.f n) :=
  by
  cases n
  · apply top_factors
  · rw [P_infty_f, normalized_Moore_complex.obj_X, finset_inf_factors]
    intro i hi
    apply kernel_subobject_factors
    exact (higher_faces_vanish.of_P (n + 1) n) i le_add_self
#align algebraic_topology.dold_kan.factors_normalized_Moore_complex_P_infty AlgebraicTopology.DoldKan.factors_normalized_Moore_complex_pInfty

/-- P_infty factors through the normalized Moore complex -/
@[simps]
def pInftyToNormalizedMooreComplex (X : SimplicialObject A) : K[X] ⟶ N[X] :=
  ChainComplex.ofHom _ _ _ _ _ _
    (fun n => factorThru _ _ (factors_normalized_Moore_complex_pInfty n)) fun n =>
    by
    rw [← cancel_mono (normalized_Moore_complex.obj_X X n).arrow, assoc, assoc, factor_thru_arrow, ←
      inclusion_of_Moore_complex_map_f, ← normalized_Moore_complex_obj_d, ←
      (inclusion_of_Moore_complex_map X).comm' (n + 1) n rfl, inclusion_of_Moore_complex_map_f,
      factor_thru_arrow_assoc, ← alternating_face_map_complex_obj_d]
    exact P_infty.comm' (n + 1) n rfl
#align algebraic_topology.dold_kan.P_infty_to_normalized_Moore_complex AlgebraicTopology.DoldKan.pInftyToNormalizedMooreComplex

@[simp, reassoc.1]
theorem pInftyToNormalizedMooreComplex_comp_inclusionOfMooreComplexMap (X : SimplicialObject A) :
    pInftyToNormalizedMooreComplex X ≫ inclusionOfMooreComplexMap X = pInfty := by tidy
#align algebraic_topology.dold_kan.P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map AlgebraicTopology.DoldKan.pInftyToNormalizedMooreComplex_comp_inclusionOfMooreComplexMap

@[simp, reassoc.1]
theorem pInftyToNormalizedMooreComplex_naturality {X Y : SimplicialObject A} (f : X ⟶ Y) :
    AlternatingFaceMapComplex.map f ≫ pInftyToNormalizedMooreComplex Y =
      pInftyToNormalizedMooreComplex X ≫ NormalizedMooreComplex.map f :=
  by tidy
#align algebraic_topology.dold_kan.P_infty_to_normalized_Moore_complex_naturality AlgebraicTopology.DoldKan.pInftyToNormalizedMooreComplex_naturality

@[simp, reassoc.1]
theorem pInfty_comp_pInftyToNormalizedMooreComplex (X : SimplicialObject A) :
    pInfty ≫ pInftyToNormalizedMooreComplex X = pInftyToNormalizedMooreComplex X := by tidy
#align algebraic_topology.dold_kan.P_infty_comp_P_infty_to_normalized_Moore_complex AlgebraicTopology.DoldKan.pInfty_comp_pInftyToNormalizedMooreComplex

@[simp, reassoc.1]
theorem inclusionOfMooreComplexMap_comp_pInfty (X : SimplicialObject A) :
    inclusionOfMooreComplexMap X ≫ pInfty = inclusionOfMooreComplexMap X :=
  by
  ext n
  cases n
  · dsimp
    simp only [comp_id]
  · exact (higher_faces_vanish.inclusion_of_Moore_complex_map n).comp_p_eq_self
#align algebraic_topology.dold_kan.inclusion_of_Moore_complex_map_comp_P_infty AlgebraicTopology.DoldKan.inclusionOfMooreComplexMap_comp_pInfty

instance : Mono (inclusionOfMooreComplexMap X) :=
  ⟨fun Y f₁ f₂ hf => by
    ext n
    exact HomologicalComplex.congr_hom hf n⟩

/-- `inclusion_of_Moore_complex_map X` is a split mono. -/
def splitMonoInclusionOfMooreComplexMap (X : SimplicialObject A) :
    SplitMono (inclusionOfMooreComplexMap X)
    where
  retraction := pInftyToNormalizedMooreComplex X
  id' := by
    simp only [← cancel_mono (inclusion_of_Moore_complex_map X), assoc, id_comp,
      P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
      inclusion_of_Moore_complex_map_comp_P_infty]
#align algebraic_topology.dold_kan.split_mono_inclusion_of_Moore_complex_map AlgebraicTopology.DoldKan.splitMonoInclusionOfMooreComplexMap

variable (A)

/-- When the category `A` is abelian,
the functor `N₁ : simplicial_object A ⥤ karoubi (chain_complex A ℕ)` defined
using `P_infty` identifies to the composition of the normalized Moore complex functor
and the inclusion in the Karoubi envelope. -/
def n₁IsoNormalizedMooreComplexCompToKaroubi : n₁ ≅ normalizedMooreComplex A ⋙ toKaroubi _
    where
  Hom :=
    { app := fun X =>
        { f := pInftyToNormalizedMooreComplex X
          comm := by erw [comp_id, P_infty_comp_P_infty_to_normalized_Moore_complex] }
      naturality' := fun X Y f => by
        simp only [functor.comp_map, normalized_Moore_complex_map,
          P_infty_to_normalized_Moore_complex_naturality, karoubi.hom_ext, karoubi.comp_f, N₁_map_f,
          P_infty_comp_P_infty_to_normalized_Moore_complex_assoc, to_karoubi_map_f, assoc] }
  inv :=
    { app := fun X =>
        { f := inclusionOfMooreComplexMap X
          comm := by erw [inclusion_of_Moore_complex_map_comp_P_infty, id_comp] }
      naturality' := fun X Y f => by
        ext
        simp only [functor.comp_map, normalized_Moore_complex_map, karoubi.comp_f, to_karoubi_map_f,
          HomologicalComplex.comp_f, normalized_Moore_complex.map_f,
          inclusion_of_Moore_complex_map_f, factor_thru_arrow, N₁_map_f,
          inclusion_of_Moore_complex_map_comp_P_infty_assoc, alternating_face_map_complex.map_f] }
  hom_inv_id' := by
    ext X : 3
    simp only [P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
      nat_trans.comp_app, karoubi.comp_f, N₁_obj_p, nat_trans.id_app, karoubi.id_eq]
  inv_hom_id' := by
    ext X : 3
    simp only [← cancel_mono (inclusion_of_Moore_complex_map X), nat_trans.comp_app, karoubi.comp_f,
      assoc, nat_trans.id_app, karoubi.id_eq,
      P_infty_to_normalized_Moore_complex_comp_inclusion_of_Moore_complex_map,
      inclusion_of_Moore_complex_map_comp_P_infty]
    dsimp only [functor.comp_obj, to_karoubi]
    rw [id_comp]
#align algebraic_topology.dold_kan.N₁_iso_normalized_Moore_complex_comp_to_karoubi AlgebraicTopology.DoldKan.n₁IsoNormalizedMooreComplexCompToKaroubi

end DoldKan

end AlgebraicTopology


/-
Copyright (c) 2020 Christopher A. Upshaw. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Christopher A. Upshaw.
-/

import algebra
import data.quot

universe u

/--
# The theory of wheels
As described at https://en.wikipedia.org/wiki/Wheel_theory.

The core idea is alow division by zero by weaking the notion of mutiplicative inverse.
-/

class wheel (w : Type u) extends add_comm_monoid w, comm_monoid w, has_inv w, has_bot w :=
(inv_inv : ∀ x : w, x⁻¹⁻¹ = x)
(mul_inv : ∀ x y : w, (x * y) ⁻¹ = x⁻¹ * y⁻¹)
(add_mul_add_zero_mul : ∀ x y z : w, (x + y) * z + 0 * z = x * z + y * z)
(add_mul_mul_inv : ∀ x y z : w, (x + y * z) * y⁻¹ = x * y⁻¹ + z + 0 * y)
(zero_mul_zero : (0 * 0 : w) = 0)
(add_zero_mul_mul : ∀ x y z : w, (x + 0 * y) * z = x * z + 0 * y)
(zero_mul_zero_inv : (0 * 0⁻¹ : w) = ⊥)
(bot_add : ∀ x : w, ⊥ + x = ⊥)

/--
 If there exists an x s.t. 1 + x = 0, then we can also introduce a subtraction.
 Note however that x - x = 0 is only true when 0 * x * x = 0, i.e. 'finite' values of the wheel.
-/

class sub_wheel (w : Type u) extends wheel w, has_sub w :=
(one_sub_one : (1 - 1 : w) = 0)
(zero_sub : ∀ x : w, 0 - x = (0 - 1) * x )

namespace fraction_wheel

variables (w : Type) [comm_ring w] (s : submonoid w)

/-- Every comm_ring can be extened to a wheel by taking ratios, and quotienting by a multiplicative submonoid (which needs to not include zero for the construction to be non-trivial.) Usually one takes the submonoid of all nonzero values, this gets you the extended rationals from the integers for example. -/

inductive fraction_equiv (l r : w × w) : Prop
| intro : ∀ (sl sr : w) (sl_in_s : sl ∈ s) (sr_in_s : sr ∈ s),
    ∀ (fst_eq : sl * l.fst = sr * r.fst) (snd_eq : sl * l.snd = sr * r.snd),
    fraction_equiv

open fraction_equiv

lemma is_reflexive : reflexive (fraction_equiv w s) :=
λ x, ⟨1, 1, s.one_mem, s.one_mem, rfl, rfl⟩

lemma is_symmetric : symmetric (fraction_equiv w s)
| x y ⟨sl, sr, sl_h, sr_h, fst_eq, snd_eq⟩ := ⟨sr, sl, sr_h, sl_h, fst_eq.symm, snd_eq.symm⟩

lemma is_transitive : transitive (fraction_equiv w s)
| x y z ⟨s1, s2, hs1, hs2, hs3, hs4⟩ ⟨t1, t2, ht1, ht2, ht3, ht4⟩ :=
    ⟨s1 * t1, s2 * t2, s.mul_mem hs1 ht1, s.mul_mem hs2 ht2,
      by rw [mul_right_comm, hs3, mul_right_comm, mul_assoc, ht3, mul_assoc],
      by rw [mul_right_comm, hs4, mul_right_comm, mul_assoc, ht4, mul_assoc]⟩

lemma is_equivalence : equivalence (fraction_equiv w s) :=
⟨is_reflexive w s, is_symmetric w s, is_transitive w s⟩

def fraction_setoid : setoid (w × w) :=
{ r := fraction_equiv w s, iseqv := is_equivalence w s }

def fraction_wheel (w : Type) [comm_ring w] (s : submonoid w) : Type :=
quotient (fraction_setoid w s)

open wheel

def pre_add (x y : w × w) : w × w := (x.1 * y.2 + x.2 * y.1, x.2 * y.2)

local infix `++` := λ x y, pre_add w x y

lemma pre_add_assoc [comm_ring w] (x y z : w × w) : x ++ y ++ z = x ++ (y ++ z) :=
prod.ext
(calc (x.1 * y.2 + x.2 * y.1) * z.2            + x.2 * y.2 * z.1
    = x.1 * y.2 * z.2   +  x.2 * y.1 * z.2     + x.2 * y.2 * z.1    : by rw add_mul
... = x.1 * (y.2 * z.2) +  x.2 * y.1 * z.2     + x.2 * y.2 * z.1    : by rw mul_assoc
... = x.1 * (y.2 * z.2) + (x.2 * y.1 * z.2     + x.2 * y.2 * z.1)   : by rw add_assoc
... = x.1 * (y.2 * z.2) + (x.2 * (y.1 * z.2)   + x.2 * (y.2 * z.1)) : by rw [mul_assoc, mul_assoc]
... = x.1 * (y.2 * z.2) +  x.2 * (y.1 * z.2 + y.2 * z.1)            : by rw mul_add)
(mul_assoc _ _ _)

variables {w}
lemma mul_rearange (a b c d : w) : a * b * (c * d) = a * c * (b * d) :=
by simp_rw [mul_assoc, mul_left_comm b]
variables (w)

def add : fraction_wheel w s → fraction_wheel w s → fraction_wheel w s :=
quotient.map₂' (pre_add w) begin
  intros x₀ x₁ x y₀ y₁ y, cases x, cases y,
  use [x_sl * y_sl, x_sr * y_sr, s.mul_mem ‹_› ‹_›, s.mul_mem ‹_› ‹_›], --use `use`
  -- space after opening curly bracket
  { dsimp only [pre_add], repeat { rw left_distrib }, congr' 1,
    calc  x_sl * y_sl * (x₀.1 * y₀.2) = x_sl * x₀.1 * (y_sl * y₀.2) : mul_rearange _ _ _ _
    ... = x_sr * x₁.1 * (y_sl * y₀.2) : by rw x_fst_eq
    ... = x_sr * x₁.1 * (y_sr * y₁.2) : by rw y_snd_eq
    ... = x_sr * y_sr * (x₁.1 * y₁.2) : mul_rearange _ _ _ _,
    calc  x_sl * y_sl * (x₀.2 * y₀.1) = x_sl * x₀.2 * (y_sl * y₀.1) : mul_rearange _ _ _ _
    ... = x_sr * x₁.2 * (y_sl * y₀.1) : by rw x_snd_eq
    ... = x_sr * x₁.2 * (y_sr * y₁.1) : by rw y_fst_eq
    ... = x_sr * y_sr * (x₁.2 * y₁.1) : mul_rearange _ _ _ _ }, --closing curly bracket on the same line
  { calc  x_sl * y_sl * (x₀.2 * y₀.2) = x_sl * x₀.2 * (y_sl * y₀.2) : mul_rearange _ _ _ _
    ... = x_sr * x₁.2 * (y_sl * y₀.2) : by {rw x_snd_eq}
    ... = x_sr * x₁.2 * (y_sr * y₁.2) : by {rw y_snd_eq}
    ... = x_sr * y_sr * (x₁.2 * y₁.2) : mul_rearange _ _ _ _ },
end

local infix `+'`:65 := add w s

@[simp] def of (x : w) : fraction_wheel w s :=
quotient.mk' (x, 1)

instance : has_coe w (fraction_wheel w s) :=
⟨of w s⟩

instance : has_zero (fraction_wheel w s) :=
⟨(0 : w)⟩

lemma zero_add (x) : 0 +' x = x :=
quotient.induction_on' x $ λ x, congr_arg quotient.mk' $ show (_, _) = _, from prod.ext
  (show 0 * x.2 + 1 * x.1 = x.1, by rw [zero_mul, one_mul, zero_add])
  (one_mul _)

-- arugments before colon
lemma add_comm (x y) : x +' y = y +' x :=
quotient.induction_on₂' x y $ λ x y, congr_arg quotient.mk' $ show (_, _) = (_, _), from prod.ext
  (show _ + _ = _ + _, by rw [mul_comm x.1, mul_comm x.2, add_comm])
  (mul_comm _ _)

lemma add_zero (x) : x +' 0 = x :=
by rw [add_comm, zero_add]

lemma add_assoc (x y z) : x +' y +' z = x +' (y +' z) :=
quotient.induction_on₃' x y z $ λ x y z, congr_arg quotient.mk' $ pre_add_assoc _ _ _ _

instance : has_one (fraction_wheel w s) :=
⟨(1 : w)⟩

instance : add_comm_monoid (fraction_wheel w s) :=
{ add := add w s,
  add_assoc := add_assoc w s,
  zero := 0,
  zero_add := zero_add w s,
  add_zero := add_zero w s,
  add_comm := add_comm w s }

def pre_mul [comm_ring w] (x y : w×w) : w×w
  := ⟨x.1 * y.1, x.2 * y.2⟩

local infix `**`:60 := pre_mul w

lemma pre_mul_assoc [comm_ring w] (x y z: w×w)
  : x ** y ** z = x ** (y ** z) :=
  show (_, _) = (_, _), from prod.ext (mul_assoc _ _ _) (mul_assoc _ _ _)

def mul : fraction_wheel w s → fraction_wheel w s → fraction_wheel w s :=
quotient.map₂' (pre_mul w) $
begin
  intros x₀ x₁ x y₀ y₁ y, obtain := x, obtain := y,
  use [x_sl * y_sl, x_sr * y_sr, s.mul_mem ‹_› ‹_›, s.mul_mem ‹_› ‹_›],
  all_goals
    { obtain := x₀, obtain := y₀, obtain := x₁, obtain := y₁, unfold pre_mul; dsimp only [] },
  {    calc x_sl * y_sl * (x₀_fst * y₀_fst) = x_sl * x₀_fst * (y_sl * y₀_fst) : mul_rearange _ _ _ _
    ... = x_sr * x₁_fst * (y_sl * y₀_fst) : by {rw x_fst_eq}
    ... = x_sr * x₁_fst * (y_sr * y₁_fst) : by {rw y_fst_eq}
    ... = x_sr * y_sr * (x₁_fst * y₁_fst) : mul_rearange _ _ _ _,},
  {    calc x_sl * y_sl * (x₀_snd * y₀_snd) = x_sl * x₀_snd * (y_sl * y₀_snd) : mul_rearange _ _ _ _
    ... = x_sr * x₁_snd * (y_sl * y₀_snd) : by {rw x_snd_eq}
    ... = x_sr * x₁_snd * (y_sr * y₁_snd) : by {rw y_snd_eq}
    ... = x_sr * y_sr * (x₁_snd * y₁_snd) : mul_rearange _ _ _ _,}
end

local infix `*'`:60 := mul w s

lemma one_mul (x) : 1 *' x = x :=
quotient.induction_on' x $ λ x, congr_arg quotient.mk' $
  show (_, _) = _, from prod.ext (one_mul _) (one_mul _)

lemma mul_one (x) : x *' 1 = x :=
  quotient.induction_on' x $ λ x, congr_arg quotient.mk' $
  show (_, _) = _, from prod.ext (mul_one _) (mul_one _)

lemma mul_comm (x y) : x *' y = y *' x :=
  quotient.induction_on₂' x y $ λ x y, congr_arg quotient.mk' $
  show (_, _) = (_, _), from prod.ext (mul_comm _ _) (mul_comm _ _)

lemma mul_assoc (x y z) : x *' y *' z = x *' (y *' z) :=
  quotient.induction_on₃' x y z $ λ x y z, congr_arg quotient.mk' $
  pre_mul_assoc _ _ _ _

instance : comm_monoid (fraction_wheel w s) :=
{ mul := mul w s,
  mul_assoc := mul_assoc w s,
  one := has_one.one,
  one_mul := one_mul w s,
  mul_one := mul_one w s,
  mul_comm := mul_comm w s }

def pre_inv (x : w×w) : w×w := ⟨x.2, x.1⟩

lemma pre_inv_inv : ∀ x, pre_inv w (pre_inv w x) = x
| ⟨l, r⟩ := rfl

def inv : fraction_wheel w s -> fraction_wheel w s :=
  quotient.map' (pre_inv w) $
  begin
  intros x₀ x₁ x, obtain := x₀; obtain := x₁; obtain := x,
  use [x_sl, x_sr]; assumption
  end

instance : has_inv (fraction_wheel w s) := ⟨inv w s⟩

lemma inv_inv (x : fraction_wheel w s) : (x⁻¹)⁻¹ = x :=
  quotient.induction_on' x $ λ x, congr_arg quotient.mk' $
  begin
  unfold pre_inv,
  apply prod.ext; dsimp only [prod.fst, prod.snd]; refl
  end

lemma mul_inv (x y : fraction_wheel w s) : (x * y)⁻¹ = (x⁻¹) * (y⁻¹) :=
  quotient.induction_on₂' x y $ λ x y, congr_arg quotient.mk' rfl

instance : has_bot (fraction_wheel w s) :=
  ⟨quotient.mk' ⟨0,0⟩ ⟩

lemma bot_add (x : fraction_wheel w s) : ⊥ + x = ⊥ :=
  quotient.induction_on' x $ λ x, congr_arg quotient.mk' $
  begin
  unfold pre_add;
  apply prod.ext;
  norm_num
  end

lemma add_mul_add_zero_mul
  (x y z : fraction_wheel w s) : (x + y) * z + 0 * z = x * z + y * z :=
  quotient.induction_on₃' x y z $ λ x y z, congr_arg quotient.mk' $
  begin
  unfold pre_add pre_mul,
  apply prod.ext; norm_num; ring,
  end

lemma add_mul_mul_inv
  (x y z : fraction_wheel w s) : (x + y * z) * (y⁻¹) = x * (y⁻¹) + z + 0 * y :=
  quotient.induction_on₃' x y z $ λ x y z, congr_arg quotient.mk' $
  begin
  unfold pre_add pre_mul,
  apply prod.ext; norm_num; ring,
  end

lemma zero_mul_zero : (0 * 0 : fraction_wheel w s) = 0 :=
  congr_arg quotient.mk' $
  begin
  unfold pre_mul,
  apply prod.ext; dsimp,
  refine mul_zero _,
  ring,
  end

lemma add_zero_mul_mul
  (x y z : fraction_wheel w s) : (x + 0 * y) * z = x * z + 0 * y :=
  quotient.induction_on₃' x y z $ λ x y z, congr_arg quotient.mk' $
  begin
  unfold pre_add pre_mul,
  apply prod.ext; norm_num; ring,
  end

lemma zero_mul_zero_inv : (0 : fraction_wheel w s) * (0⁻¹) = ⊥ :=
 congr_arg quotient.mk' $
  begin
  unfold pre_add pre_mul pre_inv,
  apply prod.ext; norm_num,
  end

instance : inhabited (fraction_wheel w s) := ⟨1⟩

instance : wheel (fraction_wheel w s) :=
{ inv := inv w s,
  inv_inv := inv_inv w s,
  mul_inv := mul_inv w s,
  add_mul_add_zero_mul := add_mul_add_zero_mul w s,
  add_mul_mul_inv := add_mul_mul_inv w s,
  zero_mul_zero := zero_mul_zero w s,
  add_zero_mul_mul := add_zero_mul_mul w s,
  zero_mul_zero_inv := zero_mul_zero_inv w s,
  bot_add := bot_add w s }

end fraction_wheel