/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import ring_theory.polynomial.pochhammer

/-!
# Cast of factorials

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

This file allows calculating factorials (including ascending and descending ones) as elements of a
semiring.

This is particularly crucial for `nat.desc_factorial` as subtraction on `ℕ` does **not** correspond
to subtraction on a general semiring. For example, we can't rely on existing cast lemmas to prove
`↑(a.desc_factorial 2) = ↑a * (↑a - 1)`. We must use the fact that, whenever `↑(a - 1)` is not equal
to `↑a - 1`, the other factor is `0` anyway.
-/

open_locale nat

variables (S : Type*)

namespace nat

section semiring
variables [semiring S] (a b : ℕ)

lemma cast_asc_factorial :
  (a.asc_factorial b : S) = (pochhammer S b).eval (a + 1) :=
by rw [←pochhammer_nat_eq_asc_factorial, pochhammer_eval_cast, nat.cast_add, nat.cast_one]

lemma cast_desc_factorial :
  (a.desc_factorial b : S) = (pochhammer S b).eval (a - (b - 1) : ℕ) :=
begin
  rw [←pochhammer_eval_cast, pochhammer_nat_eq_desc_factorial],
  cases b,
  { simp_rw desc_factorial_zero },
  simp_rw [add_succ, succ_sub_one],
  obtain h | h := le_total a b,
  { rw [desc_factorial_of_lt (lt_succ_of_le h), desc_factorial_of_lt (lt_succ_of_le _)],
    rw [tsub_eq_zero_iff_le.mpr h, zero_add] },
  { rw tsub_add_cancel_of_le h }
end

lemma cast_factorial :
  (a! : S) = (pochhammer S a).eval 1 :=
by rw [←zero_asc_factorial, cast_asc_factorial, cast_zero, zero_add]

end semiring

section ring
variables [ring S] (a b : ℕ)

/-- Convenience lemma. The `a - 1` is not using truncated subtraction, as opposed to the definition
of `nat.desc_factorial` as a natural. -/
lemma cast_desc_factorial_two :
  (a.desc_factorial 2 : S) = a * (a - 1) :=
begin
  rw cast_desc_factorial,
  cases a,
  { rw [zero_tsub, cast_zero, pochhammer_ne_zero_eval_zero _ (two_ne_zero), zero_mul] },
  { rw [succ_sub_succ, tsub_zero, cast_succ, add_sub_cancel, pochhammer_succ_right,
      pochhammer_one, polynomial.X_mul, polynomial.eval_mul_X, polynomial.eval_add,
      polynomial.eval_X, cast_one, polynomial.eval_one] }
end

end ring

end nat


/-
Copyright (c) 2021 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth
-/
import analysis.special_functions.exp
import topology.continuous_function.basic
import analysis.normed.field.unit_ball

/-!
# The circle

This file defines `circle` to be the metric sphere (`metric.sphere`) in `ℂ` centred at `0` of
radius `1`.  We equip it with the following structure:

* a submonoid of `ℂ`
* a group
* a topological group

We furthermore define `exp_map_circle` to be the natural map `λ t, exp (t * I)` from `ℝ` to
`circle`, and show that this map is a group homomorphism.

## Implementation notes

Because later (in `geometry.manifold.instances.sphere`) one wants to equip the circle with a smooth
manifold structure borrowed from `metric.sphere`, the underlying set is
`{z : ℂ | abs (z - 0) = 1}`.  This prevents certain algebraic facts from working definitionally --
for example, the circle is not defeq to `{z : ℂ | abs z = 1}`, which is the kernel of `complex.abs`
considered as a homomorphism from `ℂ` to `ℝ`, nor is it defeq to `{z : ℂ | norm_sq z = 1}`, which
is the kernel of the homomorphism `complex.norm_sq` from `ℂ` to `ℝ`.

-/

noncomputable theory

open complex metric
open_locale complex_conjugate

/-- The unit circle in `ℂ`, here given the structure of a submonoid of `ℂ`. -/
def circle : submonoid ℂ := submonoid.unit_sphere ℂ

@[simp] lemma mem_circle_iff_abs {z : ℂ} : z ∈ circle ↔ abs z = 1 := mem_sphere_zero_iff_norm

lemma circle_def : ↑circle = {z : ℂ | abs z = 1} := set.ext $ λ z, mem_circle_iff_abs

@[simp] lemma abs_coe_circle (z : circle) : abs z = 1 :=
mem_circle_iff_abs.mp z.2

lemma mem_circle_iff_norm_sq {z : ℂ} : z ∈ circle ↔ norm_sq z = 1 :=
by rw [mem_circle_iff_abs, complex.abs, real.sqrt_eq_one]

@[simp] lemma norm_sq_eq_of_mem_circle (z : circle) : norm_sq z = 1 := by simp [norm_sq_eq_abs]

lemma ne_zero_of_mem_circle (z : circle) : (z:ℂ) ≠ 0 := ne_zero_of_mem_unit_sphere z

instance : comm_group circle := metric.sphere.comm_group

@[simp] lemma coe_inv_circle (z : circle) : ↑(z⁻¹) = (z : ℂ)⁻¹ := rfl

lemma coe_inv_circle_eq_conj (z : circle) : ↑(z⁻¹) = conj (z : ℂ) :=
by rw [coe_inv_circle, inv_def, norm_sq_eq_of_mem_circle, inv_one, of_real_one, mul_one]

@[simp] lemma coe_div_circle (z w : circle) : ↑(z / w) = (z:ℂ) / w :=
circle.subtype.map_div z w

/-- The elements of the circle embed into the units. -/
@[simps apply] def circle.to_units : circle →* units ℂ := unit_sphere_to_units ℂ

instance : compact_space circle := metric.sphere.compact_space _ _

instance : topological_group circle := metric.sphere.topological_group

/-- If `z` is a nonzero complex number, then `conj z / z` belongs to the unit circle. -/
@[simps] def circle.of_conj_div_self (z : ℂ) (hz : z ≠ 0) : circle :=
⟨conj z / z, mem_circle_iff_abs.2 $ by rw [complex.abs_div, abs_conj, div_self (abs_ne_zero.2 hz)]⟩

/-- The map `λ t, exp (t * I)` from `ℝ` to the unit circle in `ℂ`. -/
def exp_map_circle : C(ℝ, circle) :=
{ to_fun := λ t, ⟨exp (t * I), by simp [exp_mul_I, abs_cos_add_sin_mul_I]⟩ }

@[simp] lemma exp_map_circle_apply (t : ℝ) : ↑(exp_map_circle t) = complex.exp (t * complex.I) :=
rfl

@[simp] lemma exp_map_circle_zero : exp_map_circle 0 = 1 :=
subtype.ext $ by rw [exp_map_circle_apply, of_real_zero, zero_mul, exp_zero, submonoid.coe_one]

@[simp] lemma exp_map_circle_add (x y : ℝ) :
  exp_map_circle (x + y) = exp_map_circle x * exp_map_circle y :=
subtype.ext $ by simp only [exp_map_circle_apply, submonoid.coe_mul, of_real_add, add_mul,
  complex.exp_add]

/-- The map `λ t, exp (t * I)` from `ℝ` to the unit circle in `ℂ`, considered as a homomorphism of
groups. -/
@[simps]
def exp_map_circle_hom : ℝ →+ (additive circle) :=
{ to_fun := additive.of_mul ∘ exp_map_circle,
  map_zero' := exp_map_circle_zero,
  map_add' := exp_map_circle_add }

@[simp] lemma exp_map_circle_sub (x y : ℝ) :
  exp_map_circle (x - y) = exp_map_circle x / exp_map_circle y :=
exp_map_circle_hom.map_sub x y

@[simp] lemma exp_map_circle_neg (x : ℝ) : exp_map_circle (-x) = (exp_map_circle x)⁻¹ :=
exp_map_circle_hom.map_neg x


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

! This file was ported from Lean 3 source module order.circular
! leanprover-community/mathlib commit f2f413b9d4be3a02840d0663dace76e8fe3da053
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Set.Basic

/-!
# Circular order hierarchy

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

This file defines circular preorders, circular partial orders and circular orders.

## Hierarchy

* A ternary "betweenness" relation `btw : α → α → α → Prop` forms a `circular_order` if it is
  - reflexive: `btw a a a`
  - cyclic: `btw a b c → btw b c a`
  - antisymmetric: `btw a b c → btw c b a → a = b ∨ b = c ∨ c = a`
  - total: `btw a b c ∨ btw c b a`
  along with a strict betweenness relation `sbtw : α → α → α → Prop` which respects
  `sbtw a b c ↔ btw a b c ∧ ¬ btw c b a`, analogously to how `<` and `≤` are related, and is
  - transitive: `sbtw a b c → sbtw b d c → sbtw a d c`.
* A `circular_partial_order` drops totality.
* A `circular_preorder` further drops antisymmetry.

The intuition is that a circular order is a circle and `btw a b c` means that going around
clockwise from `a` you reach `b` before `c` (`b` is between `a` and `c` is meaningless on an
unoriented circle). A circular partial order is several, potentially intersecting, circles. A
circular preorder is like a circular partial order, but several points can coexist.

Note that the relations between `circular_preorder`, `circular_partial_order` and `circular_order`
are subtler than between `preorder`, `partial_order`, `linear_order`. In particular, one cannot
simply extend the `btw` of a `circular_partial_order` to make it a `circular_order`.

One can translate from usual orders to circular ones by "closing the necklace at infinity". See
`has_le.to_has_btw` and `has_lt.to_has_sbtw`. Going the other way involves "cutting the necklace" or
"rolling the necklace open".

## Examples

Some concrete circular orders one encounters in the wild are `zmod n` for `0 < n`, `circle`,
`real.angle`...

## Main definitions

* `set.cIcc`: Closed-closed circular interval.
* `set.cIoo`: Open-open circular interval.

## Notes

There's an unsolved diamond on `order_dual α` here. The instances `has_le α → has_btw αᵒᵈ` and
`has_lt α → has_sbtw αᵒᵈ` can each be inferred in two ways:
* `has_le α` → `has_btw α` → `has_btw αᵒᵈ` vs
  `has_le α` → `has_le αᵒᵈ` → `has_btw αᵒᵈ`
* `has_lt α` → `has_sbtw α` → `has_sbtw αᵒᵈ` vs
  `has_lt α` → `has_lt αᵒᵈ` → `has_sbtw αᵒᵈ`
The fields are propeq, but not defeq. It is temporarily fixed by turning the circularizing instances
into definitions.

## TODO

Antisymmetry is quite weak in the sense that there's no way to discriminate which two points are
equal. This prevents defining closed-open intervals `cIco` and `cIoc` in the neat `=`-less way. We
currently haven't defined them at all.

What is the correct generality of "rolling the necklace" open? At least, this works for `α × β` and
`β × α` where `α` is a circular order and `β` is a linear order.

What's next is to define circular groups and provide instances for `zmod n`, the usual circle group
`circle`, `real.angle`, and `roots_of_unity M`. What conditions do we need on `M` for this last one
to work?

We should have circular order homomorphisms. The typical example is
`days_to_month : days_of_the_year →c months_of_the_year` which relates the circular order of days
and the circular order of months. Is `α →c β` a good notation?

## References

* https://en.wikipedia.org/wiki/Cyclic_order
* https://en.wikipedia.org/wiki/Partial_cyclic_order

## Tags

circular order, cyclic order, circularly ordered set, cyclically ordered set
-/

#print Btw /-
/-- Syntax typeclass for a betweenness relation. -/
class Btw (α : Type _) where
  Btw : α → α → α → Prop
#align has_btw Btw
-/

export Btw (Btw)

#print SBtw /-
/-- Syntax typeclass for a strict betweenness relation. -/
class SBtw (α : Type _) where
  Sbtw : α → α → α → Prop
#align has_sbtw SBtw
-/

export SBtw (Sbtw)

#print CircularPreorder /-
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic order_laws_tac -/
/-- A circular preorder is the analogue of a preorder where you can loop around. `≤` and `<` are
replaced by ternary relations `btw` and `sbtw`. `btw` is reflexive and cyclic. `sbtw` is transitive.
-/
class CircularPreorder (α : Type _) extends Btw α, SBtw α where
  btw_refl (a : α) : btw a a a
  btw_cyclic_left {a b c : α} : btw a b c → btw b c a
  Sbtw := fun a b c => btw a b c ∧ ¬btw c b a
  sbtw_iff_btw_not_btw {a b c : α} : sbtw a b c ↔ btw a b c ∧ ¬btw c b a := by
    run_tac
      order_laws_tac
  sbtw_trans_left {a b c d : α} : sbtw a b c → sbtw b d c → sbtw a d c
#align circular_preorder CircularPreorder
-/

export CircularPreorder (btw_refl btw_cyclic_left sbtw_trans_left)

#print CircularPartialOrder /-
/-- A circular partial order is the analogue of a partial order where you can loop around. `≤` and
`<` are replaced by ternary relations `btw` and `sbtw`. `btw` is reflexive, cyclic and
antisymmetric. `sbtw` is transitive. -/
class CircularPartialOrder (α : Type _) extends CircularPreorder α where
  btw_antisymm {a b c : α} : btw a b c → btw c b a → a = b ∨ b = c ∨ c = a
#align circular_partial_order CircularPartialOrder
-/

export CircularPartialOrder (btw_antisymm)

#print CircularOrder /-
/-- A circular order is the analogue of a linear order where you can loop around. `≤` and `<` are
replaced by ternary relations `btw` and `sbtw`. `btw` is reflexive, cyclic, antisymmetric and total.
`sbtw` is transitive. -/
class CircularOrder (α : Type _) extends CircularPartialOrder α where
  btw_total : ∀ a b c : α, btw a b c ∨ btw c b a
#align circular_order CircularOrder
-/

export CircularOrder (btw_total)

/-! ### Circular preorders -/

section CircularPreorder

variable {α : Type _} [CircularPreorder α]

#print btw_rfl /-
theorem btw_rfl {a : α} : Btw a a a :=
  btw_refl _
#align btw_rfl btw_rfl
-/

#print Btw.btw.cyclic_left /-
-- TODO: `alias` creates a def instead of a lemma.
-- alias btw_cyclic_left        ← has_btw.btw.cyclic_left
theorem Btw.btw.cyclic_left {a b c : α} (h : Btw a b c) : Btw b c a :=
  btw_cyclic_left h
#align has_btw.btw.cyclic_left Btw.btw.cyclic_left
-/

#print btw_cyclic_right /-
theorem btw_cyclic_right {a b c : α} (h : Btw a b c) : Btw c a b :=
  h.cyclic_left.cyclic_left
#align btw_cyclic_right btw_cyclic_right
-/

alias btw_cyclic_right ← Btw.btw.cyclic_right
#align has_btw.btw.cyclic_right Btw.btw.cyclic_right

#print btw_cyclic /-
/-- The order of the `↔` has been chosen so that `rw btw_cyclic` cycles to the right while
`rw ←btw_cyclic` cycles to the left (thus following the prepended arrow). -/
theorem btw_cyclic {a b c : α} : Btw a b c ↔ Btw c a b :=
  ⟨btw_cyclic_right, btw_cyclic_left⟩
#align btw_cyclic btw_cyclic
-/

#print sbtw_iff_btw_not_btw /-
theorem sbtw_iff_btw_not_btw {a b c : α} : Sbtw a b c ↔ Btw a b c ∧ ¬Btw c b a :=
  CircularPreorder.sbtw_iff_btw_not_btw
#align sbtw_iff_btw_not_btw sbtw_iff_btw_not_btw
-/

#print btw_of_sbtw /-
theorem btw_of_sbtw {a b c : α} (h : Sbtw a b c) : Btw a b c :=
  (sbtw_iff_btw_not_btw.1 h).1
#align btw_of_sbtw btw_of_sbtw
-/

alias btw_of_sbtw ← SBtw.sbtw.btw
#align has_sbtw.sbtw.btw SBtw.sbtw.btw

#print not_btw_of_sbtw /-
theorem not_btw_of_sbtw {a b c : α} (h : Sbtw a b c) : ¬Btw c b a :=
  (sbtw_iff_btw_not_btw.1 h).2
#align not_btw_of_sbtw not_btw_of_sbtw
-/

alias not_btw_of_sbtw ← SBtw.sbtw.not_btw
#align has_sbtw.sbtw.not_btw SBtw.sbtw.not_btw

#print not_sbtw_of_btw /-
theorem not_sbtw_of_btw {a b c : α} (h : Btw a b c) : ¬Sbtw c b a := fun h' => h'.not_btw h
#align not_sbtw_of_btw not_sbtw_of_btw
-/

alias not_sbtw_of_btw ← Btw.btw.not_sbtw
#align has_btw.btw.not_sbtw Btw.btw.not_sbtw

#print sbtw_of_btw_not_btw /-
theorem sbtw_of_btw_not_btw {a b c : α} (habc : Btw a b c) (hcba : ¬Btw c b a) : Sbtw a b c :=
  sbtw_iff_btw_not_btw.2 ⟨habc, hcba⟩
#align sbtw_of_btw_not_btw sbtw_of_btw_not_btw
-/

alias sbtw_of_btw_not_btw ← Btw.btw.sbtw_of_not_btw
#align has_btw.btw.sbtw_of_not_btw Btw.btw.sbtw_of_not_btw

#print sbtw_cyclic_left /-
theorem sbtw_cyclic_left {a b c : α} (h : Sbtw a b c) : Sbtw b c a :=
  h.Btw.cyclic_left.sbtw_of_not_btw fun h' => h.not_btw h'.cyclic_left
#align sbtw_cyclic_left sbtw_cyclic_left
-/

alias sbtw_cyclic_left ← SBtw.sbtw.cyclic_left
#align has_sbtw.sbtw.cyclic_left SBtw.sbtw.cyclic_left

#print sbtw_cyclic_right /-
theorem sbtw_cyclic_right {a b c : α} (h : Sbtw a b c) : Sbtw c a b :=
  h.cyclic_left.cyclic_left
#align sbtw_cyclic_right sbtw_cyclic_right
-/

alias sbtw_cyclic_right ← SBtw.sbtw.cyclic_right
#align has_sbtw.sbtw.cyclic_right SBtw.sbtw.cyclic_right

#print sbtw_cyclic /-
/-- The order of the `↔` has been chosen so that `rw sbtw_cyclic` cycles to the right while
`rw ←sbtw_cyclic` cycles to the left (thus following the prepended arrow). -/
theorem sbtw_cyclic {a b c : α} : Sbtw a b c ↔ Sbtw c a b :=
  ⟨sbtw_cyclic_right, sbtw_cyclic_left⟩
#align sbtw_cyclic sbtw_cyclic
-/

#print SBtw.sbtw.trans_left /-
-- TODO: `alias` creates a def instead of a lemma.
-- alias btw_trans_left        ← has_btw.btw.trans_left
theorem SBtw.sbtw.trans_left {a b c d : α} (h : Sbtw a b c) : Sbtw b d c → Sbtw a d c :=
  sbtw_trans_left h
#align has_sbtw.sbtw.trans_left SBtw.sbtw.trans_left
-/

#print sbtw_trans_right /-
theorem sbtw_trans_right {a b c d : α} (hbc : Sbtw a b c) (hcd : Sbtw a c d) : Sbtw a b d :=
  (hbc.cyclic_left.trans_left hcd.cyclic_left).cyclic_right
#align sbtw_trans_right sbtw_trans_right
-/

alias sbtw_trans_right ← SBtw.sbtw.trans_right
#align has_sbtw.sbtw.trans_right SBtw.sbtw.trans_right

#print sbtw_asymm /-
theorem sbtw_asymm {a b c : α} (h : Sbtw a b c) : ¬Sbtw c b a :=
  h.Btw.not_sbtw
#align sbtw_asymm sbtw_asymm
-/

alias sbtw_asymm ← SBtw.sbtw.not_sbtw
#align has_sbtw.sbtw.not_sbtw SBtw.sbtw.not_sbtw

#print sbtw_irrefl_left_right /-
theorem sbtw_irrefl_left_right {a b : α} : ¬Sbtw a b a := fun h => h.not_btw h.Btw
#align sbtw_irrefl_left_right sbtw_irrefl_left_right
-/

#print sbtw_irrefl_left /-
theorem sbtw_irrefl_left {a b : α} : ¬Sbtw a a b := fun h => sbtw_irrefl_left_right h.cyclic_left
#align sbtw_irrefl_left sbtw_irrefl_left
-/

#print sbtw_irrefl_right /-
theorem sbtw_irrefl_right {a b : α} : ¬Sbtw a b b := fun h => sbtw_irrefl_left_right h.cyclic_right
#align sbtw_irrefl_right sbtw_irrefl_right
-/

#print sbtw_irrefl /-
theorem sbtw_irrefl (a : α) : ¬Sbtw a a a :=
  sbtw_irrefl_left_right
#align sbtw_irrefl sbtw_irrefl
-/

end CircularPreorder

/-! ### Circular partial orders -/

section CircularPartialOrder

variable {α : Type _} [CircularPartialOrder α]

#print Btw.btw.antisymm /-
-- TODO: `alias` creates a def instead of a lemma.
-- alias btw_antisymm        ← has_btw.btw.antisymm
theorem Btw.btw.antisymm {a b c : α} (h : Btw a b c) : Btw c b a → a = b ∨ b = c ∨ c = a :=
  btw_antisymm h
#align has_btw.btw.antisymm Btw.btw.antisymm
-/

end CircularPartialOrder

/-! ### Circular orders -/

section CircularOrder

variable {α : Type _} [CircularOrder α]

#print btw_refl_left_right /-
theorem btw_refl_left_right (a b : α) : Btw a b a :=
  (or_self_iff _).1 (btw_total a b a)
#align btw_refl_left_right btw_refl_left_right
-/

#print btw_rfl_left_right /-
theorem btw_rfl_left_right {a b : α} : Btw a b a :=
  btw_refl_left_right _ _
#align btw_rfl_left_right btw_rfl_left_right
-/

#print btw_refl_left /-
theorem btw_refl_left (a b : α) : Btw a a b :=
  btw_rfl_left_right.cyclic_right
#align btw_refl_left btw_refl_left
-/

#print btw_rfl_left /-
theorem btw_rfl_left {a b : α} : Btw a a b :=
  btw_refl_left _ _
#align btw_rfl_left btw_rfl_left
-/

#print btw_refl_right /-
theorem btw_refl_right (a b : α) : Btw a b b :=
  btw_rfl_left_right.cyclic_left
#align btw_refl_right btw_refl_right
-/

#print btw_rfl_right /-
theorem btw_rfl_right {a b : α} : Btw a b b :=
  btw_refl_right _ _
#align btw_rfl_right btw_rfl_right
-/

#print sbtw_iff_not_btw /-
theorem sbtw_iff_not_btw {a b c : α} : Sbtw a b c ↔ ¬Btw c b a :=
  by
  rw [sbtw_iff_btw_not_btw]
  exact and_iff_right_of_imp (btw_total _ _ _).resolve_left
#align sbtw_iff_not_btw sbtw_iff_not_btw
-/

#print btw_iff_not_sbtw /-
theorem btw_iff_not_sbtw {a b c : α} : Btw a b c ↔ ¬Sbtw c b a :=
  iff_not_comm.1 sbtw_iff_not_btw
#align btw_iff_not_sbtw btw_iff_not_sbtw
-/

end CircularOrder

/-! ### Circular intervals -/

namespace Set

section CircularPreorder

variable {α : Type _} [CircularPreorder α]

#print Set.cIcc /-
/-- Closed-closed circular interval -/
def cIcc (a b : α) : Set α :=
  { x | Btw a x b }
#align set.cIcc Set.cIcc
-/

#print Set.cIoo /-
/-- Open-open circular interval -/
def cIoo (a b : α) : Set α :=
  { x | Sbtw a x b }
#align set.cIoo Set.cIoo
-/

#print Set.mem_cIcc /-
@[simp]
theorem mem_cIcc {a b x : α} : x ∈ cIcc a b ↔ Btw a x b :=
  Iff.rfl
#align set.mem_cIcc Set.mem_cIcc
-/

#print Set.mem_cIoo /-
@[simp]
theorem mem_cIoo {a b x : α} : x ∈ cIoo a b ↔ Sbtw a x b :=
  Iff.rfl
#align set.mem_cIoo Set.mem_cIoo
-/

end CircularPreorder

section CircularOrder

variable {α : Type _} [CircularOrder α]

#print Set.left_mem_cIcc /-
theorem left_mem_cIcc (a b : α) : a ∈ cIcc a b :=
  btw_rfl_left
#align set.left_mem_cIcc Set.left_mem_cIcc
-/

#print Set.right_mem_cIcc /-
theorem right_mem_cIcc (a b : α) : b ∈ cIcc a b :=
  btw_rfl_right
#align set.right_mem_cIcc Set.right_mem_cIcc
-/

/- warning: set.compl_cIcc -> Set.compl_cIcc is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CircularOrder.{u1} α] {a : α} {b : α}, Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) (Set.cIcc.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) a b)) (Set.cIoo.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) b a)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CircularOrder.{u1} α] {a : α} {b : α}, Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) (Set.cIcc.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) a b)) (Set.cIoo.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) b a)
Case conversion may be inaccurate. Consider using '#align set.compl_cIcc Set.compl_cIccₓ'. -/
theorem compl_cIcc {a b : α} : cIcc a bᶜ = cIoo b a :=
  by
  ext
  rw [Set.mem_cIoo, sbtw_iff_not_btw]
  rfl
#align set.compl_cIcc Set.compl_cIcc

/- warning: set.compl_cIoo -> Set.compl_cIoo is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CircularOrder.{u1} α] {a : α} {b : α}, Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) (Set.cIoo.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) a b)) (Set.cIcc.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) b a)
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CircularOrder.{u1} α] {a : α} {b : α}, Eq.{succ u1} (Set.{u1} α) (HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) (Set.cIoo.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) a b)) (Set.cIcc.{u1} α (CircularPartialOrder.toCircularPreorder.{u1} α (CircularOrder.toCircularPartialOrder.{u1} α _inst_1)) b a)
Case conversion may be inaccurate. Consider using '#align set.compl_cIoo Set.compl_cIooₓ'. -/
theorem compl_cIoo {a b : α} : cIoo a bᶜ = cIcc b a :=
  by
  ext
  rw [Set.mem_cIcc, btw_iff_not_sbtw]
  rfl
#align set.compl_cIoo Set.compl_cIoo

end CircularOrder

end Set

/-! ### Circularizing instances -/

#print LE.toBtw /-
/-- The betweenness relation obtained from "looping around" `≤`.
See note [reducible non-instances]. -/
@[reducible]
def LE.toBtw (α : Type _) [LE α] : Btw α
    where Btw a b c := a ≤ b ∧ b ≤ c ∨ b ≤ c ∧ c ≤ a ∨ c ≤ a ∧ a ≤ b
#align has_le.to_has_btw LE.toBtw
-/

#print LT.toSBtw /-
/-- The strict betweenness relation obtained from "looping around" `<`.
See note [reducible non-instances]. -/
@[reducible]
def LT.toSBtw (α : Type _) [LT α] : SBtw α
    where Sbtw a b c := a < b ∧ b < c ∨ b < c ∧ c < a ∨ c < a ∧ a < b
#align has_lt.to_has_sbtw LT.toSBtw
-/

#print Preorder.toCircularPreorder /-
/-- The circular preorder obtained from "looping around" a preorder.
See note [reducible non-instances]. -/
@[reducible]
def Preorder.toCircularPreorder (α : Type _) [Preorder α] : CircularPreorder α
    where
  Btw a b c := a ≤ b ∧ b ≤ c ∨ b ≤ c ∧ c ≤ a ∨ c ≤ a ∧ a ≤ b
  Sbtw a b c := a < b ∧ b < c ∨ b < c ∧ c < a ∨ c < a ∧ a < b
  btw_refl a := Or.inl ⟨le_rfl, le_rfl⟩
  btw_cyclic_left a b c h := by
    unfold btw at h⊢
    rwa [← or_assoc, or_comm']
  sbtw_trans_left a b c d :=
    by
    rintro (⟨hab, hbc⟩ | ⟨hbc, hca⟩ | ⟨hca, hab⟩) (⟨hbd, hdc⟩ | ⟨hdc, hcb⟩ | ⟨hcb, hbd⟩)
    · exact Or.inl ⟨hab.trans hbd, hdc⟩
    · exact (hbc.not_lt hcb).elim
    · exact (hbc.not_lt hcb).elim
    · exact Or.inr (Or.inl ⟨hdc, hca⟩)
    · exact Or.inr (Or.inl ⟨hdc, hca⟩)
    · exact (hbc.not_lt hcb).elim
    · exact Or.inr (Or.inl ⟨hdc, hca⟩)
    · exact Or.inr (Or.inl ⟨hdc, hca⟩)
    · exact Or.inr (Or.inr ⟨hca, hab.trans hbd⟩)
  sbtw_iff_btw_not_btw a b c := by
    simp_rw [lt_iff_le_not_le]
    set x₀ := a ≤ b
    set x₁ := b ≤ c
    set x₂ := c ≤ a
    have : x₀ → x₁ → a ≤ c := le_trans
    have : x₁ → x₂ → b ≤ a := le_trans
    have : x₂ → x₀ → c ≤ b := le_trans
    clear_value x₀ x₁ x₂
    tauto
#align preorder.to_circular_preorder Preorder.toCircularPreorder
-/

#print PartialOrder.toCircularPartialOrder /-
/-- The circular partial order obtained from "looping around" a partial order.
See note [reducible non-instances]. -/
@[reducible]
def PartialOrder.toCircularPartialOrder (α : Type _) [PartialOrder α] : CircularPartialOrder α :=
  { Preorder.toCircularPreorder α with
    btw_antisymm := fun a b c =>
      by
      rintro (⟨hab, hbc⟩ | ⟨hbc, hca⟩ | ⟨hca, hab⟩) (⟨hcb, hba⟩ | ⟨hba, hac⟩ | ⟨hac, hcb⟩)
      · exact Or.inl (hab.antisymm hba)
      · exact Or.inl (hab.antisymm hba)
      · exact Or.inr (Or.inl <| hbc.antisymm hcb)
      · exact Or.inr (Or.inl <| hbc.antisymm hcb)
      · exact Or.inr (Or.inr <| hca.antisymm hac)
      · exact Or.inr (Or.inl <| hbc.antisymm hcb)
      · exact Or.inl (hab.antisymm hba)
      · exact Or.inl (hab.antisymm hba)
      · exact Or.inr (Or.inr <| hca.antisymm hac) }
#align partial_order.to_circular_partial_order PartialOrder.toCircularPartialOrder
-/

#print LinearOrder.toCircularOrder /-
/-- The circular order obtained from "looping around" a linear order.
See note [reducible non-instances]. -/
@[reducible]
def LinearOrder.toCircularOrder (α : Type _) [LinearOrder α] : CircularOrder α :=
  { PartialOrder.toCircularPartialOrder α with
    btw_total := fun a b c =>
      by
      cases' le_total a b with hab hba <;> cases' le_total b c with hbc hcb <;>
        cases' le_total c a with hca hac
      · exact Or.inl (Or.inl ⟨hab, hbc⟩)
      · exact Or.inl (Or.inl ⟨hab, hbc⟩)
      · exact Or.inl (Or.inr <| Or.inr ⟨hca, hab⟩)
      · exact Or.inr (Or.inr <| Or.inr ⟨hac, hcb⟩)
      · exact Or.inl (Or.inr <| Or.inl ⟨hbc, hca⟩)
      · exact Or.inr (Or.inr <| Or.inl ⟨hba, hac⟩)
      · exact Or.inr (Or.inl ⟨hcb, hba⟩)
      · exact Or.inr (Or.inr <| Or.inl ⟨hba, hac⟩) }
#align linear_order.to_circular_order LinearOrder.toCircularOrder
-/

/-! ### Dual constructions -/

section OrderDual

instance (α : Type _) [Btw α] : Btw αᵒᵈ :=
  ⟨fun a b c : α => Btw c b a⟩

instance (α : Type _) [SBtw α] : SBtw αᵒᵈ :=
  ⟨fun a b c : α => Sbtw c b a⟩

instance (α : Type _) [h : CircularPreorder α] : CircularPreorder αᵒᵈ :=
  { OrderDual.hasBtw α,
    OrderDual.hasSbtw α with
    btw_refl := btw_refl
    btw_cyclic_left := fun a b c => btw_cyclic_right
    sbtw_trans_left := fun a b c d habc hbdc => hbdc.trans_right habc
    sbtw_iff_btw_not_btw := fun a b c => @sbtw_iff_btw_not_btw α _ c b a }

instance (α : Type _) [CircularPartialOrder α] : CircularPartialOrder αᵒᵈ :=
  { OrderDual.circularPreorder α with
    btw_antisymm := fun a b c habc hcba => @btw_antisymm α _ _ _ _ hcba habc }

instance (α : Type _) [CircularOrder α] : CircularOrder αᵒᵈ :=
  { OrderDual.circularPartialOrder α with btw_total := fun a b c => btw_total c b a }

end OrderDual


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import geometry.euclidean.circumcenter

/-!
# Monge point and orthocenter

This file defines the orthocenter of a triangle, via its n-dimensional
generalization, the Monge point of a simplex.

## Main definitions

* `monge_point` is the Monge point of a simplex, defined in terms of
  its position on the Euler line and then shown to be the point of
  concurrence of the Monge planes.

* `monge_plane` is a Monge plane of an (n+2)-simplex, which is the
  (n+1)-dimensional affine subspace of the subspace spanned by the
  simplex that passes through the centroid of an n-dimensional face
  and is orthogonal to the opposite edge (in 2 dimensions, this is the
  same as an altitude).

* `altitude` is the line that passes through a vertex of a simplex and
  is orthogonal to the opposite face.

* `orthocenter` is defined, for the case of a triangle, to be the same
  as its Monge point, then shown to be the point of concurrence of the
  altitudes.

* `orthocentric_system` is a predicate on sets of points that says
  whether they are four points, one of which is the orthocenter of the
  other three (in which case various other properties hold, including
  that each is the orthocenter of the other three).

## References

* <https://en.wikipedia.org/wiki/Altitude_(triangle)>
* <https://en.wikipedia.org/wiki/Monge_point>
* <https://en.wikipedia.org/wiki/Orthocentric_system>
* Małgorzata Buba-Brzozowa, [The Monge Point and the 3(n+1) Point
  Sphere of an
  n-Simplex](https://pdfs.semanticscholar.org/6f8b/0f623459c76dac2e49255737f8f0f4725d16.pdf)

-/

noncomputable theory
open_locale big_operators
open_locale classical
open_locale real_inner_product_space

namespace affine

namespace simplex

open finset affine_subspace euclidean_geometry points_with_circumcenter_index

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- The Monge point of a simplex (in 2 or more dimensions) is a
generalization of the orthocenter of a triangle.  It is defined to be
the intersection of the Monge planes, where a Monge plane is the
(n-1)-dimensional affine subspace of the subspace spanned by the
simplex that passes through the centroid of an (n-2)-dimensional face
and is orthogonal to the opposite edge (in 2 dimensions, this is the
same as an altitude).  The circumcenter O, centroid G and Monge point
M are collinear in that order on the Euler line, with OG : GM = (n-1)
: 2.  Here, we use that ratio to define the Monge point (so resulting
in a point that equals the centroid in 0 or 1 dimensions), and then
show in subsequent lemmas that the point so defined lies in the Monge
planes and is their unique point of intersection. -/
def monge_point {n : ℕ} (s : simplex ℝ P n) : P :=
(((n + 1 : ℕ) : ℝ) / (((n - 1) : ℕ) : ℝ)) •
  ((univ : finset (fin (n + 1))).centroid ℝ s.points -ᵥ s.circumcenter) +ᵥ
  s.circumcenter

/-- The position of the Monge point in relation to the circumcenter
and centroid. -/
lemma monge_point_eq_smul_vsub_vadd_circumcenter {n : ℕ} (s : simplex ℝ P n) :
  s.monge_point = (((n + 1 : ℕ) : ℝ) / (((n - 1) : ℕ) : ℝ)) •
    ((univ : finset (fin (n + 1))).centroid ℝ s.points -ᵥ s.circumcenter) +ᵥ
    s.circumcenter :=
rfl

/-- The Monge point lies in the affine span. -/
lemma monge_point_mem_affine_span {n : ℕ} (s : simplex ℝ P n) :
  s.monge_point ∈ affine_span ℝ (set.range s.points) :=
smul_vsub_vadd_mem _ _
  (centroid_mem_affine_span_of_card_eq_add_one ℝ _ (card_fin (n + 1)))
  s.circumcenter_mem_affine_span
  s.circumcenter_mem_affine_span

/-- Two simplices with the same points have the same Monge point. -/
lemma monge_point_eq_of_range_eq {n : ℕ} {s₁ s₂ : simplex ℝ P n}
  (h : set.range s₁.points = set.range s₂.points) : s₁.monge_point = s₂.monge_point :=
by simp_rw [monge_point_eq_smul_vsub_vadd_circumcenter, centroid_eq_of_range_eq h,
            circumcenter_eq_of_range_eq h]

omit V

/-- The weights for the Monge point of an (n+2)-simplex, in terms of
`points_with_circumcenter`. -/
def monge_point_weights_with_circumcenter (n : ℕ) : points_with_circumcenter_index (n + 2) → ℝ
| (point_index i) := (((n + 1) : ℕ) : ℝ)⁻¹
| circumcenter_index := (-2 / (((n + 1) : ℕ) : ℝ))

/-- `monge_point_weights_with_circumcenter` sums to 1. -/
@[simp] lemma sum_monge_point_weights_with_circumcenter (n : ℕ) :
  ∑ i, monge_point_weights_with_circumcenter n i = 1 :=
begin
  simp_rw [sum_points_with_circumcenter, monge_point_weights_with_circumcenter, sum_const,
           card_fin, nsmul_eq_mul],
  have hn1 : (n + 1 : ℝ) ≠ 0,
  { exact_mod_cast nat.succ_ne_zero _ },
  field_simp [hn1],
  ring
end

include V

/-- The Monge point of an (n+2)-simplex, in terms of
`points_with_circumcenter`. -/
lemma monge_point_eq_affine_combination_of_points_with_circumcenter {n : ℕ}
  (s : simplex ℝ P (n + 2)) :
  s.monge_point = (univ : finset (points_with_circumcenter_index (n + 2))).affine_combination ℝ
    s.points_with_circumcenter (monge_point_weights_with_circumcenter n) :=
begin
  rw [monge_point_eq_smul_vsub_vadd_circumcenter,
      centroid_eq_affine_combination_of_points_with_circumcenter,
      circumcenter_eq_affine_combination_of_points_with_circumcenter,
      affine_combination_vsub, ←linear_map.map_smul,
      weighted_vsub_vadd_affine_combination],
  congr' with i,
  rw [pi.add_apply, pi.smul_apply, smul_eq_mul, pi.sub_apply],
  have hn1 : (n + 1 : ℝ) ≠ 0,
  { exact_mod_cast nat.succ_ne_zero _ },
  cases i;
    simp_rw [centroid_weights_with_circumcenter, circumcenter_weights_with_circumcenter,
             monge_point_weights_with_circumcenter];
    rw [add_tsub_assoc_of_le (dec_trivial : 1 ≤ 2), (dec_trivial : 2 - 1 = 1)],
  { rw [if_pos (mem_univ _), sub_zero, add_zero, card_fin],
    have hn3 : (n + 2 + 1 : ℝ) ≠ 0,
    { exact_mod_cast nat.succ_ne_zero _ },
    field_simp [hn1, hn3, mul_comm] },
  { field_simp [hn1],
    ring }
end

omit V

/-- The weights for the Monge point of an (n+2)-simplex, minus the
centroid of an n-dimensional face, in terms of
`points_with_circumcenter`.  This definition is only valid when `i₁ ≠ i₂`. -/
def monge_point_vsub_face_centroid_weights_with_circumcenter {n : ℕ} (i₁ i₂ : fin (n + 3)) :
  points_with_circumcenter_index (n + 2) → ℝ
| (point_index i) := if i = i₁ ∨ i = i₂ then (((n + 1) : ℕ) : ℝ)⁻¹ else 0
| circumcenter_index := (-2 / (((n + 1) : ℕ) : ℝ))

/-- `monge_point_vsub_face_centroid_weights_with_circumcenter` is the
result of subtracting `centroid_weights_with_circumcenter` from
`monge_point_weights_with_circumcenter`. -/
lemma monge_point_vsub_face_centroid_weights_with_circumcenter_eq_sub {n : ℕ}
  {i₁ i₂ : fin (n + 3)} (h : i₁ ≠ i₂) :
  monge_point_vsub_face_centroid_weights_with_circumcenter i₁ i₂ =
    monge_point_weights_with_circumcenter n -
      centroid_weights_with_circumcenter ({i₁, i₂}ᶜ) :=
begin
  ext i,
  cases i,
  { rw [pi.sub_apply, monge_point_weights_with_circumcenter, centroid_weights_with_circumcenter,
        monge_point_vsub_face_centroid_weights_with_circumcenter],
    have hu : card ({i₁, i₂}ᶜ : finset (fin (n + 3))) = n + 1,
    { simp [card_compl, fintype.card_fin, h] },
    rw hu,
    by_cases hi : i = i₁ ∨ i = i₂;
      simp [compl_eq_univ_sdiff, hi] },
  { simp [monge_point_weights_with_circumcenter, centroid_weights_with_circumcenter,
          monge_point_vsub_face_centroid_weights_with_circumcenter] }
end

/-- `monge_point_vsub_face_centroid_weights_with_circumcenter` sums to 0. -/
@[simp] lemma sum_monge_point_vsub_face_centroid_weights_with_circumcenter {n : ℕ}
  {i₁ i₂ : fin (n + 3)} (h : i₁ ≠ i₂) :
  ∑ i, monge_point_vsub_face_centroid_weights_with_circumcenter i₁ i₂ i = 0 :=
begin
  rw monge_point_vsub_face_centroid_weights_with_circumcenter_eq_sub h,
  simp_rw [pi.sub_apply, sum_sub_distrib, sum_monge_point_weights_with_circumcenter],
  rw [sum_centroid_weights_with_circumcenter, sub_self],
  simp [←card_pos, card_compl, h]
end

include V

/-- The Monge point of an (n+2)-simplex, minus the centroid of an
n-dimensional face, in terms of `points_with_circumcenter`. -/
lemma monge_point_vsub_face_centroid_eq_weighted_vsub_of_points_with_circumcenter {n : ℕ}
  (s : simplex ℝ P (n + 2)) {i₁ i₂ : fin (n + 3)} (h : i₁ ≠ i₂) :
  s.monge_point -ᵥ ({i₁, i₂}ᶜ : finset (fin (n + 3))).centroid ℝ s.points =
    (univ : finset (points_with_circumcenter_index (n + 2))).weighted_vsub
      s.points_with_circumcenter (monge_point_vsub_face_centroid_weights_with_circumcenter i₁ i₂) :=
by simp_rw [monge_point_eq_affine_combination_of_points_with_circumcenter,
            centroid_eq_affine_combination_of_points_with_circumcenter,
            affine_combination_vsub,
            monge_point_vsub_face_centroid_weights_with_circumcenter_eq_sub h]

/-- The Monge point of an (n+2)-simplex, minus the centroid of an
n-dimensional face, is orthogonal to the difference of the two
vertices not in that face. -/
lemma inner_monge_point_vsub_face_centroid_vsub {n : ℕ} (s : simplex ℝ P (n + 2))
  {i₁ i₂ : fin (n + 3)} :
  ⟪s.monge_point -ᵥ ({i₁, i₂}ᶜ : finset (fin (n + 3))).centroid ℝ s.points,
        s.points i₁ -ᵥ s.points i₂⟫ = 0 :=
begin
  by_cases h : i₁ = i₂,
  { simp [h], },
  simp_rw [monge_point_vsub_face_centroid_eq_weighted_vsub_of_points_with_circumcenter s h,
           point_eq_affine_combination_of_points_with_circumcenter,
           affine_combination_vsub],
  have hs : ∑ i, (point_weights_with_circumcenter i₁ - point_weights_with_circumcenter i₂) i = 0,
  { simp },
  rw [inner_weighted_vsub _ (sum_monge_point_vsub_face_centroid_weights_with_circumcenter h) _ hs,
      sum_points_with_circumcenter, points_with_circumcenter_eq_circumcenter],
  simp only [monge_point_vsub_face_centroid_weights_with_circumcenter,
             points_with_circumcenter_point],
  let fs : finset (fin (n + 3)) := {i₁, i₂},
  have hfs : ∀ i : fin (n + 3),
    i ∉ fs → (i ≠ i₁ ∧ i ≠ i₂),
  { intros i hi,
    split ; { intro hj, simpa [←hj] using hi } },
  rw ←sum_subset fs.subset_univ _,
  { simp_rw [sum_points_with_circumcenter, points_with_circumcenter_eq_circumcenter,
             points_with_circumcenter_point, pi.sub_apply, point_weights_with_circumcenter],
    rw [←sum_subset fs.subset_univ _],
    { simp_rw [sum_insert (not_mem_singleton.2 h), sum_singleton],
      repeat { rw ←sum_subset fs.subset_univ _ },
      { simp_rw [sum_insert (not_mem_singleton.2 h), sum_singleton],
        simp [h, ne.symm h, dist_comm (s.points i₁)] },
      all_goals { intros i hu hi, simp [hfs i hi] } },
    { intros i hu hi,
      simp [hfs i hi, point_weights_with_circumcenter] } },
  { intros i hu hi,
    simp [hfs i hi] }
end

/-- A Monge plane of an (n+2)-simplex is the (n+1)-dimensional affine
subspace of the subspace spanned by the simplex that passes through
the centroid of an n-dimensional face and is orthogonal to the
opposite edge (in 2 dimensions, this is the same as an altitude).
This definition is only intended to be used when `i₁ ≠ i₂`. -/
def monge_plane {n : ℕ} (s : simplex ℝ P (n + 2)) (i₁ i₂ : fin (n + 3)) :
  affine_subspace ℝ P :=
mk' (({i₁, i₂}ᶜ : finset (fin (n + 3))).centroid ℝ s.points)
  (ℝ ∙ (s.points i₁ -ᵥ s.points i₂))ᗮ ⊓
    affine_span ℝ (set.range s.points)

/-- The definition of a Monge plane. -/
lemma monge_plane_def {n : ℕ} (s : simplex ℝ P (n + 2)) (i₁ i₂ : fin (n + 3)) :
  s.monge_plane i₁ i₂ = mk' (({i₁, i₂}ᶜ : finset (fin (n + 3))).centroid ℝ s.points)
                            (ℝ ∙ (s.points i₁ -ᵥ s.points i₂))ᗮ ⊓
                          affine_span ℝ (set.range s.points) :=
rfl

/-- The Monge plane associated with vertices `i₁` and `i₂` equals that
associated with `i₂` and `i₁`. -/
lemma monge_plane_comm {n : ℕ} (s : simplex ℝ P (n + 2)) (i₁ i₂ : fin (n + 3)) :
  s.monge_plane i₁ i₂ = s.monge_plane i₂ i₁ :=
begin
  simp_rw monge_plane_def,
  congr' 3,
  { congr' 1,
    exact pair_comm _ _ },
  { ext,
    simp_rw submodule.mem_span_singleton,
    split,
    all_goals { rintros ⟨r, rfl⟩, use -r, rw [neg_smul, ←smul_neg, neg_vsub_eq_vsub_rev] } }
end

/-- The Monge point lies in the Monge planes. -/
lemma monge_point_mem_monge_plane {n : ℕ} (s : simplex ℝ P (n + 2)) {i₁ i₂ : fin (n + 3)} :
  s.monge_point ∈ s.monge_plane i₁ i₂ :=
begin
  rw [monge_plane_def, mem_inf_iff, ←vsub_right_mem_direction_iff_mem (self_mem_mk' _ _),
      direction_mk', submodule.mem_orthogonal'],
  refine ⟨_, s.monge_point_mem_affine_span⟩,
  intros v hv,
  rcases submodule.mem_span_singleton.mp hv with ⟨r, rfl⟩,
  rw [inner_smul_right, s.inner_monge_point_vsub_face_centroid_vsub, mul_zero]
end

/-- The direction of a Monge plane. -/
lemma direction_monge_plane {n : ℕ} (s : simplex ℝ P (n + 2)) {i₁ i₂ : fin (n + 3)} :
  (s.monge_plane i₁ i₂).direction = (ℝ ∙ (s.points i₁ -ᵥ s.points i₂))ᗮ ⊓
    vector_span ℝ (set.range s.points) :=
by rw [monge_plane_def, direction_inf_of_mem_inf s.monge_point_mem_monge_plane, direction_mk',
       direction_affine_span]

/-- The Monge point is the only point in all the Monge planes from any
one vertex. -/
lemma eq_monge_point_of_forall_mem_monge_plane {n : ℕ} {s : simplex ℝ P (n + 2)}
  {i₁ : fin (n + 3)} {p : P} (h : ∀ i₂, i₁ ≠ i₂ → p ∈ s.monge_plane i₁ i₂) :
  p = s.monge_point :=
begin
  rw ←@vsub_eq_zero_iff_eq V,
  have h' : ∀ i₂, i₁ ≠ i₂ → p -ᵥ s.monge_point ∈
    (ℝ ∙ (s.points i₁ -ᵥ s.points i₂))ᗮ ⊓ vector_span ℝ (set.range s.points),
  { intros i₂ hne,
    rw [←s.direction_monge_plane,
        vsub_right_mem_direction_iff_mem s.monge_point_mem_monge_plane],
    exact h i₂ hne },
  have hi : p -ᵥ s.monge_point ∈ ⨅ (i₂ : {i // i₁ ≠ i}),
    (ℝ ∙ (s.points i₁ -ᵥ s.points i₂))ᗮ,
  { rw submodule.mem_infi,
    exact λ i, (submodule.mem_inf.1 (h' i i.property)).1 },
  rw [submodule.infi_orthogonal, ←submodule.span_Union] at hi,
  have hu : (⋃ (i : {i // i₁ ≠ i}), ({s.points i₁ -ᵥ s.points i} : set V)) =
    (-ᵥ) (s.points i₁) '' (s.points '' (set.univ \ {i₁})),
  { rw [set.image_image],
    ext x,
    simp_rw [set.mem_Union, set.mem_image, set.mem_singleton_iff, set.mem_diff_singleton],
    split,
    { rintros ⟨i, rfl⟩,
      use [i, ⟨set.mem_univ _, i.property.symm⟩] },
    { rintros ⟨i, ⟨hiu, hi⟩, rfl⟩,
      use [⟨i, hi.symm⟩, rfl] } },
  rw [hu, ←vector_span_image_eq_span_vsub_set_left_ne ℝ _ (set.mem_univ _),
      set.image_univ] at hi,
  have hv : p -ᵥ s.monge_point ∈ vector_span ℝ (set.range s.points),
  { let s₁ : finset (fin (n + 3)) := univ.erase i₁,
    obtain ⟨i₂, h₂⟩ :=
      card_pos.1 (show 0 < card s₁, by simp [card_erase_of_mem]),
    have h₁₂ : i₁ ≠ i₂ := (ne_of_mem_erase h₂).symm,
    exact (submodule.mem_inf.1 (h' i₂ h₁₂)).2 },
  exact submodule.disjoint_def.1 ((vector_span ℝ (set.range s.points)).orthogonal_disjoint)
    _ hv hi,
end

/-- An altitude of a simplex is the line that passes through a vertex
and is orthogonal to the opposite face. -/
def altitude {n : ℕ} (s : simplex ℝ P (n + 1)) (i : fin (n + 2)) : affine_subspace ℝ P :=
mk' (s.points i) (affine_span ℝ (s.points '' ↑(univ.erase i))).directionᗮ ⊓
  affine_span ℝ (set.range s.points)

/-- The definition of an altitude. -/
lemma altitude_def {n : ℕ} (s : simplex ℝ P (n + 1)) (i : fin (n + 2)) :
  s.altitude i = mk' (s.points i)
                     (affine_span ℝ (s.points '' ↑(univ.erase i))).directionᗮ ⊓
    affine_span ℝ (set.range s.points) :=
rfl

/-- A vertex lies in the corresponding altitude. -/
lemma mem_altitude {n : ℕ} (s : simplex ℝ P (n + 1)) (i : fin (n + 2)) :
  s.points i ∈ s.altitude i :=
(mem_inf_iff _ _ _).2 ⟨self_mem_mk' _ _, mem_affine_span ℝ (set.mem_range_self _)⟩

/-- The direction of an altitude. -/
lemma direction_altitude {n : ℕ} (s : simplex ℝ P (n + 1)) (i : fin (n + 2)) :
  (s.altitude i).direction = (vector_span ℝ (s.points '' ↑(finset.univ.erase i)))ᗮ ⊓
    vector_span ℝ (set.range s.points) :=
by rw [altitude_def,
       direction_inf_of_mem (self_mem_mk' (s.points i) _)
         (mem_affine_span ℝ (set.mem_range_self _)), direction_mk', direction_affine_span,
       direction_affine_span]

/-- The vector span of the opposite face lies in the direction
orthogonal to an altitude. -/
lemma vector_span_le_altitude_direction_orthogonal  {n : ℕ} (s : simplex ℝ P (n + 1))
    (i : fin (n + 2)) :
  vector_span ℝ (s.points '' ↑(finset.univ.erase i)) ≤ (s.altitude i).directionᗮ :=
begin
  rw direction_altitude,
  exact le_trans
    (vector_span ℝ (s.points '' ↑(finset.univ.erase i))).le_orthogonal_orthogonal
    (submodule.orthogonal_le inf_le_left)
end

open finite_dimensional

/-- An altitude is finite-dimensional. -/
instance finite_dimensional_direction_altitude {n : ℕ} (s : simplex ℝ P (n + 1))
  (i : fin (n + 2)) : finite_dimensional ℝ ((s.altitude i).direction) :=
begin
  rw direction_altitude,
  apply_instance
end

/-- An altitude is one-dimensional (i.e., a line). -/
@[simp] lemma finrank_direction_altitude {n : ℕ} (s : simplex ℝ P (n + 1)) (i : fin (n + 2)) :
  finrank ℝ ((s.altitude i).direction) = 1 :=
begin
  rw direction_altitude,
  have h := submodule.finrank_add_inf_finrank_orthogonal
    (vector_span_mono ℝ (set.image_subset_range s.points ↑(univ.erase i))),
  have hc : card (univ.erase i) = n + 1, { rw card_erase_of_mem (mem_univ _), simp },
  refine add_left_cancel (trans h _),
  rw [s.independent.finrank_vector_span (fintype.card_fin _),
      ← finset.coe_image, s.independent.finrank_vector_span_image_finset hc]
end

/-- A line through a vertex is the altitude through that vertex if and
only if it is orthogonal to the opposite face. -/
lemma affine_span_pair_eq_altitude_iff {n : ℕ} (s : simplex ℝ P (n + 1))
    (i : fin (n + 2)) (p : P) :
  line[ℝ, p, s.points i] = s.altitude i ↔ (p ≠ s.points i ∧
    p ∈ affine_span ℝ (set.range s.points) ∧
    p -ᵥ s.points i ∈ (affine_span ℝ (s.points '' ↑(finset.univ.erase i))).directionᗮ) :=
begin
  rw [eq_iff_direction_eq_of_mem
        (mem_affine_span ℝ (set.mem_insert_of_mem _ (set.mem_singleton _))) (s.mem_altitude _),
      ←vsub_right_mem_direction_iff_mem (mem_affine_span ℝ (set.mem_range_self i)) p,
      direction_affine_span, direction_affine_span, direction_affine_span],
  split,
  { intro h,
    split,
    { intro heq,
      rw [heq, set.pair_eq_singleton, vector_span_singleton] at h,
      have hd : finrank ℝ (s.altitude i).direction = 0,
      { rw [←h, finrank_bot] },
      simpa using hd },
    { rw [←submodule.mem_inf, _root_.inf_comm, ←direction_altitude, ←h],
      exact vsub_mem_vector_span ℝ (set.mem_insert _ _)
                                   (set.mem_insert_of_mem _ (set.mem_singleton _)) } },
  { rintro ⟨hne, h⟩,
    rw [←submodule.mem_inf, _root_.inf_comm, ←direction_altitude] at h,
    rw [vector_span_eq_span_vsub_set_left_ne ℝ (set.mem_insert _ _),
        set.insert_diff_of_mem _ (set.mem_singleton _),
        set.diff_singleton_eq_self (λ h, hne (set.mem_singleton_iff.1 h)), set.image_singleton],
    refine eq_of_le_of_finrank_eq _ _,
    { rw submodule.span_le,
      simpa using h },
    { rw [finrank_direction_altitude, finrank_span_set_eq_card],
      { simp },
      { refine linear_independent_singleton _,
        simpa using hne } } }
end

end simplex

namespace triangle

open euclidean_geometry finset simplex affine_subspace finite_dimensional

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]
include V

/-- The orthocenter of a triangle is the intersection of its
altitudes.  It is defined here as the 2-dimensional case of the
Monge point. -/
def orthocenter (t : triangle ℝ P) : P := t.monge_point

/-- The orthocenter equals the Monge point. -/
lemma orthocenter_eq_monge_point (t : triangle ℝ P) : t.orthocenter = t.monge_point := rfl

/-- The position of the orthocenter in relation to the circumcenter
and centroid. -/
lemma orthocenter_eq_smul_vsub_vadd_circumcenter (t : triangle ℝ P) :
  t.orthocenter = (3 : ℝ) •
    ((univ : finset (fin 3)).centroid ℝ t.points -ᵥ t.circumcenter : V) +ᵥ t.circumcenter :=
begin
  rw [orthocenter_eq_monge_point, monge_point_eq_smul_vsub_vadd_circumcenter],
  norm_num
end

/-- The orthocenter lies in the affine span. -/
lemma orthocenter_mem_affine_span (t : triangle ℝ P) :
  t.orthocenter ∈ affine_span ℝ (set.range t.points) :=
t.monge_point_mem_affine_span

/-- Two triangles with the same points have the same orthocenter. -/
lemma orthocenter_eq_of_range_eq {t₁ t₂ : triangle ℝ P}
  (h : set.range t₁.points = set.range t₂.points) : t₁.orthocenter = t₂.orthocenter :=
monge_point_eq_of_range_eq h

/-- In the case of a triangle, altitudes are the same thing as Monge
planes. -/
lemma altitude_eq_monge_plane (t : triangle ℝ P) {i₁ i₂ i₃ : fin 3} (h₁₂ : i₁ ≠ i₂)
  (h₁₃ : i₁ ≠ i₃) (h₂₃ : i₂ ≠ i₃) : t.altitude i₁ = t.monge_plane i₂ i₃ :=
begin
  have hs : ({i₂, i₃}ᶜ : finset (fin 3)) = {i₁}, by dec_trivial!,
  have he : univ.erase i₁ = {i₂, i₃}, by dec_trivial!,
  rw [monge_plane_def, altitude_def, direction_affine_span, hs, he, centroid_singleton,
      coe_insert, coe_singleton,
      vector_span_image_eq_span_vsub_set_left_ne ℝ _ (set.mem_insert i₂ _)],
  simp [h₂₃, submodule.span_insert_eq_span]
end

/-- The orthocenter lies in the altitudes. -/
lemma orthocenter_mem_altitude (t : triangle ℝ P) {i₁ : fin 3} :
  t.orthocenter ∈ t.altitude i₁ :=
begin
  obtain ⟨i₂, i₃, h₁₂, h₂₃, h₁₃⟩ : ∃ i₂ i₃, i₁ ≠ i₂ ∧ i₂ ≠ i₃ ∧ i₁ ≠ i₃, by dec_trivial!,
  rw [orthocenter_eq_monge_point, t.altitude_eq_monge_plane h₁₂ h₁₃ h₂₃],
  exact t.monge_point_mem_monge_plane
end

/-- The orthocenter is the only point lying in any two of the
altitudes. -/
lemma eq_orthocenter_of_forall_mem_altitude {t : triangle ℝ P} {i₁ i₂ : fin 3} {p : P}
  (h₁₂ : i₁ ≠ i₂) (h₁ : p ∈ t.altitude i₁) (h₂ : p ∈ t.altitude i₂) : p = t.orthocenter :=
begin
  obtain ⟨i₃, h₂₃, h₁₃⟩ : ∃ i₃, i₂ ≠ i₃ ∧ i₁ ≠ i₃, { clear h₁ h₂, dec_trivial! },
  rw t.altitude_eq_monge_plane h₁₃ h₁₂ h₂₃.symm at h₁,
  rw t.altitude_eq_monge_plane h₂₃ h₁₂.symm h₁₃.symm at h₂,
  rw orthocenter_eq_monge_point,
  have ha : ∀ i, i₃ ≠ i → p ∈ t.monge_plane i₃ i,
  { intros i hi,
    have hi₁₂ : i₁ = i ∨ i₂ = i, { clear h₁ h₂, dec_trivial! },
    cases hi₁₂,
    { exact hi₁₂ ▸ h₂ },
    { exact hi₁₂ ▸ h₁ } },
  exact eq_monge_point_of_forall_mem_monge_plane ha
end

/-- The distance from the orthocenter to the reflection of the
circumcenter in a side equals the circumradius. -/

/-- The distance from the orthocenter to the reflection of the
circumcenter in a side equals the circumradius, variant using a
`finset`. -/
lemma dist_orthocenter_reflection_circumcenter_finset (t : triangle ℝ P) {i₁ i₂ : fin 3}
  (h : i₁ ≠ i₂) :
  dist t.orthocenter (reflection (affine_span ℝ (t.points '' ↑({i₁, i₂} : finset (fin 3))))
                                 t.circumcenter) =
    t.circumradius :=
by { convert dist_orthocenter_reflection_circumcenter _ h, simp }

/-- The affine span of the orthocenter and a vertex is contained in
the altitude. -/
lemma affine_span_orthocenter_point_le_altitude (t : triangle ℝ P) (i : fin 3) :
  line[ℝ, t.orthocenter, t.points i] ≤ t.altitude i :=
begin
  refine span_points_subset_coe_of_subset_coe _,
  rw [set.insert_subset, set.singleton_subset_iff],
  exact ⟨t.orthocenter_mem_altitude, t.mem_altitude i⟩
end

/-- Suppose we are given a triangle `t₁`, and replace one of its
vertices by its orthocenter, yielding triangle `t₂` (with vertices not
necessarily listed in the same order).  Then an altitude of `t₂` from
a vertex that was not replaced is the corresponding side of `t₁`. -/
lemma altitude_replace_orthocenter_eq_affine_span {t₁ t₂ : triangle ℝ P} {i₁ i₂ i₃ j₁ j₂ j₃ : fin 3}
    (hi₁₂ : i₁ ≠ i₂) (hi₁₃ : i₁ ≠ i₃) (hi₂₃ : i₂ ≠ i₃) (hj₁₂ : j₁ ≠ j₂) (hj₁₃ : j₁ ≠ j₃)
    (hj₂₃ : j₂ ≠ j₃) (h₁ : t₂.points j₁ = t₁.orthocenter) (h₂ : t₂.points j₂ = t₁.points i₂)
    (h₃ : t₂.points j₃ = t₁.points i₃) :
  t₂.altitude j₂ = line[ℝ, t₁.points i₁, t₁.points i₂] :=
begin
  symmetry,
  rw [←h₂, t₂.affine_span_pair_eq_altitude_iff],
  rw [h₂],
  use t₁.independent.injective.ne hi₁₂,
  have he : affine_span ℝ (set.range t₂.points) = affine_span ℝ (set.range t₁.points),
  { refine ext_of_direction_eq _
      ⟨t₁.points i₃, mem_affine_span ℝ ⟨j₃, h₃⟩, mem_affine_span ℝ (set.mem_range_self _)⟩,
    refine eq_of_le_of_finrank_eq (direction_le (span_points_subset_coe_of_subset_coe _)) _,
    { have hu : (finset.univ : finset (fin 3)) = {j₁, j₂, j₃}, { clear h₁ h₂ h₃, dec_trivial! },
      rw [←set.image_univ, ←finset.coe_univ, hu, finset.coe_insert, finset.coe_insert,
          finset.coe_singleton, set.image_insert_eq, set.image_insert_eq, set.image_singleton,
          h₁, h₂, h₃, set.insert_subset, set.insert_subset, set.singleton_subset_iff],
      exact ⟨t₁.orthocenter_mem_affine_span,
             mem_affine_span ℝ (set.mem_range_self _),
             mem_affine_span ℝ (set.mem_range_self _)⟩ },
    { rw [direction_affine_span, direction_affine_span,
          t₁.independent.finrank_vector_span (fintype.card_fin _),
          t₂.independent.finrank_vector_span (fintype.card_fin _)] } },
  rw he,
  use mem_affine_span ℝ (set.mem_range_self _),
  have hu : finset.univ.erase j₂ = {j₁, j₃}, { clear h₁ h₂ h₃, dec_trivial! },
  rw [hu, finset.coe_insert, finset.coe_singleton, set.image_insert_eq, set.image_singleton,
      h₁, h₃],
  have hle : (t₁.altitude i₃).directionᗮ ≤
    line[ℝ, t₁.orthocenter, t₁.points i₃].directionᗮ :=
      submodule.orthogonal_le (direction_le (affine_span_orthocenter_point_le_altitude _ _)),
  refine hle ((t₁.vector_span_le_altitude_direction_orthogonal i₃) _),
  have hui : finset.univ.erase i₃ = {i₁, i₂}, { clear hle h₂ h₃, dec_trivial! },
  rw [hui, finset.coe_insert, finset.coe_singleton, set.image_insert_eq, set.image_singleton],
  refine vsub_mem_vector_span ℝ (set.mem_insert _ _)
    (set.mem_insert_of_mem _ (set.mem_singleton _))
end

/-- Suppose we are given a triangle `t₁`, and replace one of its
vertices by its orthocenter, yielding triangle `t₂` (with vertices not
necessarily listed in the same order).  Then the orthocenter of `t₂`
is the vertex of `t₁` that was replaced. -/
lemma orthocenter_replace_orthocenter_eq_point {t₁ t₂ : triangle ℝ P} {i₁ i₂ i₃ j₁ j₂ j₃ : fin 3}
    (hi₁₂ : i₁ ≠ i₂) (hi₁₃ : i₁ ≠ i₃) (hi₂₃ : i₂ ≠ i₃) (hj₁₂ : j₁ ≠ j₂) (hj₁₃ : j₁ ≠ j₃)
    (hj₂₃ : j₂ ≠ j₃) (h₁ : t₂.points j₁ = t₁.orthocenter) (h₂ : t₂.points j₂ = t₁.points i₂)
    (h₃ : t₂.points j₃ = t₁.points i₃) :
  t₂.orthocenter = t₁.points i₁ :=
begin
  refine (triangle.eq_orthocenter_of_forall_mem_altitude hj₂₃ _ _).symm,
  { rw altitude_replace_orthocenter_eq_affine_span hi₁₂ hi₁₃ hi₂₃ hj₁₂ hj₁₃ hj₂₃ h₁ h₂ h₃,
    exact mem_affine_span ℝ (set.mem_insert _ _) },
  { rw altitude_replace_orthocenter_eq_affine_span hi₁₃ hi₁₂ hi₂₃.symm hj₁₃ hj₁₂ hj₂₃.symm h₁ h₃ h₂,
    exact mem_affine_span ℝ (set.mem_insert _ _) }
end

end triangle

end affine

namespace euclidean_geometry

open affine affine_subspace finite_dimensional

variables {V : Type*} {P : Type*}
  [normed_add_comm_group V] [inner_product_space ℝ V] [metric_space P] [normed_add_torsor V P]

include V

/-- Four points form an orthocentric system if they consist of the
vertices of a triangle and its orthocenter. -/
def orthocentric_system (s : set P) : Prop :=
∃ t : triangle ℝ P,
  t.orthocenter ∉ set.range t.points ∧ s = insert t.orthocenter (set.range t.points)

/-- This is an auxiliary lemma giving information about the relation
of two triangles in an orthocentric system; it abstracts some
reasoning, with no geometric content, that is common to some other
lemmas.  Suppose the orthocentric system is generated by triangle `t`,
and we are given three points `p` in the orthocentric system.  Then
either we can find indices `i₁`, `i₂` and `i₃` for `p` such that `p
i₁` is the orthocenter of `t` and `p i₂` and `p i₃` are points `j₂`
and `j₃` of `t`, or `p` has the same points as `t`. -/
lemma exists_of_range_subset_orthocentric_system {t : triangle ℝ P}
  (ho : t.orthocenter ∉ set.range t.points) {p : fin 3 → P}
  (hps : set.range p ⊆ insert t.orthocenter (set.range t.points)) (hpi : function.injective p) :
  (∃ (i₁ i₂ i₃ j₂ j₃ : fin 3), i₁ ≠ i₂ ∧ i₁ ≠ i₃ ∧ i₂ ≠ i₃ ∧
    (∀ i : fin 3, i = i₁ ∨ i = i₂ ∨ i = i₃) ∧ p i₁ = t.orthocenter ∧ j₂ ≠ j₃ ∧
    t.points j₂ = p i₂ ∧ t.points j₃ = p i₃) ∨ set.range p = set.range t.points :=
begin
  by_cases h : t.orthocenter ∈ set.range p,
  { left,
    rcases h with ⟨i₁, h₁⟩,
    obtain ⟨i₂, i₃, h₁₂, h₁₃, h₂₃, h₁₂₃⟩ :
      ∃ (i₂ i₃ : fin 3), i₁ ≠ i₂ ∧ i₁ ≠ i₃ ∧ i₂ ≠ i₃ ∧ ∀ i : fin 3, i = i₁ ∨ i = i₂ ∨ i = i₃,
    { clear h₁, dec_trivial! },
    have h : ∀ i, i₁ ≠ i → ∃ (j : fin 3), t.points j = p i,
    { intros i hi,
      replace hps := set.mem_of_mem_insert_of_ne
        (set.mem_of_mem_of_subset (set.mem_range_self i) hps) (h₁ ▸ hpi.ne hi.symm),
      exact hps },
    rcases h i₂ h₁₂ with ⟨j₂, h₂⟩,
    rcases h i₃ h₁₃ with ⟨j₃, h₃⟩,
    have hj₂₃ : j₂ ≠ j₃,
    { intro he,
      rw [he, h₃] at h₂,
      exact h₂₃.symm (hpi h₂) },
    exact ⟨i₁, i₂, i₃, j₂, j₃, h₁₂, h₁₃, h₂₃, h₁₂₃, h₁, hj₂₃, h₂, h₃⟩ },
  { right,
    have hs := set.subset_diff_singleton hps h,
    rw set.insert_diff_self_of_not_mem ho at hs,
    refine set.eq_of_subset_of_card_le hs _,
    rw [set.card_range_of_injective hpi,
        set.card_range_of_injective t.independent.injective] }
end

/-- For any three points in an orthocentric system generated by
triangle `t`, there is a point in the subspace spanned by the triangle
from which the distance of all those three points equals the circumradius. -/
lemma exists_dist_eq_circumradius_of_subset_insert_orthocenter {t : triangle ℝ P}
  (ho : t.orthocenter ∉ set.range t.points) {p : fin 3 → P}
  (hps : set.range p ⊆ insert t.orthocenter (set.range t.points)) (hpi : function.injective p) :
  ∃ c ∈ affine_span ℝ (set.range t.points), ∀ p₁ ∈ set.range p, dist p₁ c = t.circumradius :=
begin
  rcases exists_of_range_subset_orthocentric_system ho hps hpi with
    ⟨i₁, i₂, i₃, j₂, j₃, h₁₂, h₁₃, h₂₃, h₁₂₃, h₁, hj₂₃, h₂, h₃⟩ | hs,
  { use [reflection (affine_span ℝ (t.points '' {j₂, j₃})) t.circumcenter,
         reflection_mem_of_le_of_mem (affine_span_mono ℝ (set.image_subset_range _ _))
                                     t.circumcenter_mem_affine_span],
    intros p₁ hp₁,
    rcases hp₁ with ⟨i, rfl⟩,
    replace h₁₂₃ := h₁₂₃ i,
    repeat { cases h₁₂₃ },
    { rw h₁,
      exact triangle.dist_orthocenter_reflection_circumcenter t hj₂₃ },
    { rw [←h₂,
          dist_reflection_eq_of_mem _
            (mem_affine_span ℝ (set.mem_image_of_mem _ (set.mem_insert _ _)))],
      exact t.dist_circumcenter_eq_circumradius _ },
    { rw [←h₃,
          dist_reflection_eq_of_mem _
            (mem_affine_span ℝ (set.mem_image_of_mem _
              (set.mem_insert_of_mem _ (set.mem_singleton _))))],
      exact t.dist_circumcenter_eq_circumradius _ } },
  { use [t.circumcenter, t.circumcenter_mem_affine_span],
    intros p₁ hp₁,
    rw hs at hp₁,
    rcases hp₁ with ⟨i, rfl⟩,
    exact t.dist_circumcenter_eq_circumradius _ }
end

/-- Any three points in an orthocentric system are affinely independent. -/
lemma orthocentric_system.affine_independent {s : set P} (ho : orthocentric_system s)
    {p : fin 3 → P} (hps : set.range p ⊆ s) (hpi : function.injective p) :
  affine_independent ℝ p :=
begin
  rcases ho with ⟨t, hto, hst⟩,
  rw hst at hps,
  rcases exists_dist_eq_circumradius_of_subset_insert_orthocenter hto hps hpi with ⟨c, hcs, hc⟩,
  exact cospherical.affine_independent ⟨c, t.circumradius, hc⟩ set.subset.rfl hpi
end

/-- Any three points in an orthocentric system span the same subspace
as the whole orthocentric system. -/
lemma affine_span_of_orthocentric_system {s : set P} (ho : orthocentric_system s)
    {p : fin 3 → P} (hps : set.range p ⊆ s) (hpi : function.injective p) :
  affine_span ℝ (set.range p) = affine_span ℝ s :=
begin
  have ha := ho.affine_independent hps hpi,
  rcases ho with ⟨t, hto, hts⟩,
  have hs : affine_span ℝ s = affine_span ℝ (set.range t.points),
  { rw [hts, affine_span_insert_eq_affine_span ℝ t.orthocenter_mem_affine_span] },
  refine ext_of_direction_eq _
    ⟨p 0, mem_affine_span ℝ (set.mem_range_self _), mem_affine_span ℝ (hps (set.mem_range_self _))⟩,
  have hfd : finite_dimensional ℝ (affine_span ℝ s).direction, { rw hs, apply_instance },
  haveI := hfd,
  refine eq_of_le_of_finrank_eq (direction_le (affine_span_mono ℝ hps)) _,
  rw [hs, direction_affine_span, direction_affine_span,
      ha.finrank_vector_span (fintype.card_fin _),
      t.independent.finrank_vector_span (fintype.card_fin _)]
end

/-- All triangles in an orthocentric system have the same circumradius. -/
lemma orthocentric_system.exists_circumradius_eq {s : set P} (ho : orthocentric_system s) :
  ∃ r : ℝ, ∀ t : triangle ℝ P, set.range t.points ⊆ s → t.circumradius = r :=
begin
  rcases ho with ⟨t, hto, hts⟩,
  use t.circumradius,
  intros t₂ ht₂,
  have ht₂s := ht₂,
  rw hts at ht₂,
  rcases exists_dist_eq_circumradius_of_subset_insert_orthocenter hto ht₂
    t₂.independent.injective with ⟨c, hc, h⟩,
  rw set.forall_range_iff at h,
  have hs : set.range t.points ⊆ s,
  { rw hts,
    exact set.subset_insert _ _ },
  rw [affine_span_of_orthocentric_system ⟨t, hto, hts⟩ hs
        t.independent.injective,
      ←affine_span_of_orthocentric_system ⟨t, hto, hts⟩ ht₂s
        t₂.independent.injective] at hc,
  exact (t₂.eq_circumradius_of_dist_eq hc h).symm
end

/-- Given any triangle in an orthocentric system, the fourth point is
its orthocenter. -/
lemma orthocentric_system.eq_insert_orthocenter {s : set P} (ho : orthocentric_system s)
    {t : triangle ℝ P} (ht : set.range t.points ⊆ s) :
  s = insert t.orthocenter (set.range t.points) :=
begin
  rcases ho with ⟨t₀, ht₀o, ht₀s⟩,
  rw ht₀s at ht,
  rcases exists_of_range_subset_orthocentric_system ht₀o ht
    t.independent.injective with
    ⟨i₁, i₂, i₃, j₂, j₃, h₁₂, h₁₃, h₂₃, h₁₂₃, h₁, hj₂₃, h₂, h₃⟩ | hs,
  { obtain ⟨j₁, hj₁₂, hj₁₃, hj₁₂₃⟩ :
      ∃ j₁ : fin 3, j₁ ≠ j₂ ∧ j₁ ≠ j₃ ∧ ∀ j : fin 3, j = j₁ ∨ j = j₂ ∨ j = j₃,
    { clear h₂ h₃, dec_trivial! },
    suffices h : t₀.points j₁ = t.orthocenter,
    { have hui : (set.univ : set (fin 3)) = {i₁, i₂, i₃}, { ext x, simpa using h₁₂₃ x },
      have huj : (set.univ : set (fin 3)) = {j₁, j₂, j₃}, { ext x, simpa using hj₁₂₃ x },
      rw [←h, ht₀s, ←set.image_univ, huj, ←set.image_univ, hui],
      simp_rw [set.image_insert_eq, set.image_singleton, h₁, ←h₂, ←h₃],
      rw set.insert_comm },
    exact (triangle.orthocenter_replace_orthocenter_eq_point
      hj₁₂ hj₁₃ hj₂₃ h₁₂ h₁₃ h₂₃ h₁ h₂.symm h₃.symm).symm },
  { rw hs,
    convert ht₀s using 2,
    exact triangle.orthocenter_eq_of_range_eq hs }
end

end euclidean_geometry


/-
Copyright (c) 2020 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kyle Miller, Yury Kudryashov
-/
import data.nat.modeq
import data.set.finite
import algebra.big_operators.order
import algebra.module.basic
import algebra.module.big_operators

/-!
# Pigeonhole principles

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

Given pigeons (possibly infinitely many) in pigeonholes, the
pigeonhole principle states that, if there are more pigeons than
pigeonholes, then there is a pigeonhole with two or more pigeons.

There are a few variations on this statement, and the conclusion can
be made stronger depending on how many pigeons you know you might
have.

The basic statements of the pigeonhole principle appear in the
following locations:

* `data.finset.basic` has `finset.exists_ne_map_eq_of_card_lt_of_maps_to`
* `data.fintype.basic` has `fintype.exists_ne_map_eq_of_card_lt`
* `data.fintype.basic` has `finite.exists_ne_map_eq_of_infinite`
* `data.fintype.basic` has `finite.exists_infinite_fiber`
* `data.set.finite` has `set.infinite.exists_ne_map_eq_of_maps_to`

This module gives access to these pigeonhole principles along with 20 more.
The versions vary by:

* using a function between `fintype`s or a function between possibly infinite types restricted to
  `finset`s;
* counting pigeons by a general weight function (`∑ x in s, w x`) or by heads (`finset.card s`);
* using strict or non-strict inequalities;
* establishing upper or lower estimate on the number (or the total weight) of the pigeons in one
  pigeonhole;
* in case when we count pigeons by some weight function `w` and consider a function `f` between
  `finset`s `s` and `t`, we can either assume that each pigeon is in one of the pigeonholes
  (`∀ x ∈ s, f x ∈ t`), or assume that for `y ∉ t`, the total weight of the pigeons in this
  pigeonhole `∑ x in s.filter (λ x, f x = y), w x` is nonpositive or nonnegative depending on
  the inequality we are proving.

Lemma names follow `mathlib` convention (e.g.,
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`); "pigeonhole principle" is mentioned in the
docstrings instead of the names.

## See also

* `ordinal.infinite_pigeonhole`: pigeonhole principle for cardinals, formulated using cofinality;

* `measure_theory.exists_nonempty_inter_of_measure_univ_lt_tsum_measure`,
  `measure_theory.exists_nonempty_inter_of_measure_univ_lt_sum_measure`: pigeonhole principle in a
  measure space.

## Tags

pigeonhole principle
-/

universes u v w
variables {α : Type u} {β : Type v} {M : Type w} [decidable_eq β]

open nat
open_locale big_operators

namespace finset

variables {s : finset α} {t : finset β} {f : α → β} {w : α → M} {b : M} {n : ℕ}

/-!
### The pigeonhole principles on `finset`s, pigeons counted by weight

In this section we prove the following version of the pigeonhole principle: if the total weight of a
finite set of pigeons is greater than `n • b`, and they are sorted into `n` pigeonholes, then for
some pigeonhole, the total weight of the pigeons in this pigeonhole is greater than `b`, and a few
variations of this theorem.

The principle is formalized in the following way, see
`finset.exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum`: if `f : α → β` is a function which maps all
elements of `s : finset α` to `t : finset β` and `card t • b < ∑ x in s, w x`, where `w : α → M` is
a weight function taking values in a `linear_ordered_cancel_add_comm_monoid`, then for
some `y ∈ t`, the sum of the weights of all `x ∈ s` such that `f x = y` is greater than `b`.

There are a few bits we can change in this theorem:

* reverse all inequalities, with obvious adjustments to the name;
* replace the assumption `∀ a ∈ s, f a ∈ t` with
  `∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0`,
  and replace `of_maps_to` with `of_sum_fiber_nonpos` in the name;
* use non-strict inequalities assuming `t` is nonempty.

We can do all these variations independently, so we have eight versions of the theorem.
-/

section
variables [linear_ordered_cancel_add_comm_monoid M]

/-!
#### Strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, and they are sorted into
`n` pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is
greater than `b`. -/
lemma exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (hf : ∀ a ∈ s, f a ∈ t)
  (hb : t.card • b < ∑ x in s, w x) :
  ∃ y ∈ t, b < ∑ x in s.filter (λ x, f x = y), w x :=
exists_lt_of_sum_lt $ by simpa only [sum_fiberwise_of_maps_to hf, sum_const]

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, and they are sorted into `n`
pigeonholes, then for some pigeonhole, the total weight of the pigeons in this pigeonhole is less
than `b`. -/
lemma exists_sum_fiber_lt_of_maps_to_of_sum_lt_nsmul (hf : ∀ a ∈ s, f a ∈ t)
  (hb : (∑ x in s, w x) < t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is greater than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonpositive,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is greater than `b`. -/
lemma exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum
  (ht : ∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0) (hb : t.card • b < ∑ x in s, w x) :
  ∃ y ∈ t, b < ∑ x in s.filter (λ x, f x = y), w x :=
exists_lt_of_sum_lt $
calc (∑ y in t, b) < ∑ x in s, w x : by simpa
... ≤ ∑ y in t, ∑ x in s.filter (λ x, f x = y), w x :
  sum_le_sum_fiberwise_of_sum_fiber_nonpos ht

/-- The pigeonhole principle for finitely many pigeons counted by weight, strict inequality version:
if the total weight of a finite set of pigeons is less than `n • b`, they are sorted into some
pigeonholes, and for all but `n` pigeonholes the total weight of the pigeons there is nonnegative,
then for at least one of these `n` pigeonholes, the total weight of the pigeons in this pigeonhole
is less than `b`. -/
lemma exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul
  (ht : ∀ y ∉ t, (0:M) ≤ ∑ x in s.filter (λ x, f x = y), w x) (hb : (∑ x in s, w x) < t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_sum_fiber_nonpos_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ ht hb

/-!
#### Non-strict inequality versions
-/

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, and
they are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons
in this pigeonhole is greater than or equal to `b`. -/
lemma exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hb : t.card • b ≤ ∑ x in s, w x) :
  ∃ y ∈ t, b ≤ ∑ x in s.filter (λ x, f x = y), w x :=
exists_le_of_sum_le ht $ by simpa only [sum_fiberwise_of_maps_to hf, sum_const]

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, and they
are sorted into `n > 0` pigeonholes, then for some pigeonhole, the total weight of the pigeons in
this pigeonhole is less than or equal to `b`. -/
lemma exists_sum_fiber_le_of_maps_to_of_sum_le_nsmul (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hb : (∑ x in s, w x) ≤ t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf ht hb

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is greater than or equal to `n • b`, they
are sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the
pigeons there is nonpositive, then for at least one of these `n` pigeonholes, the total weight of
the pigeons in this pigeonhole is greater than or equal to `b`. -/
lemma exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum
  (hf : ∀ y ∉ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ 0) (ht : t.nonempty)
  (hb : t.card • b ≤ ∑ x in s, w x) :
  ∃ y ∈ t, b ≤ ∑ x in s.filter (λ x, f x = y), w x :=
exists_le_of_sum_le ht $
calc (∑ y in t, b) ≤ ∑ x in s, w x : by simpa
... ≤ ∑ y in t, ∑ x in s.filter (λ x, f x = y), w x :
  sum_le_sum_fiberwise_of_sum_fiber_nonpos hf

/-- The pigeonhole principle for finitely many pigeons counted by weight, non-strict inequality
version: if the total weight of a finite set of pigeons is less than or equal to `n • b`, they are
sorted into some pigeonholes, and for all but `n > 0` pigeonholes the total weight of the pigeons
there is nonnegative, then for at least one of these `n` pigeonholes, the total weight of the
pigeons in this pigeonhole is less than or equal to `b`. -/
lemma exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul
  (hf : ∀ y ∉ t, (0:M) ≤ ∑ x in s.filter (λ x, f x = y), w x) (ht : t.nonempty)
  (hb : (∑ x in s, w x) ≤ t.card • b) :
  ∃ y ∈ t, (∑ x in s.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_sum_fiber_nonpos_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ hf ht hb

end

variables [linear_ordered_comm_semiring M]

/-!
### The pigeonhole principles on `finset`s, pigeons counted by heads

In this section we formalize a few versions of the following pigeonhole principle: there is a
pigeonhole with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes.

First, we can use strict or non-strict inequalities. While the versions with non-strict inequalities
are weaker than those with strict inequalities, sometimes it might be more convenient to apply the
weaker version. Second, we can either state that there exists a pigeonhole with at least `n`
pigeons, or state that there exists a pigeonhole with at most `n` pigeons. In the latter case we do
not need the assumption `∀ a ∈ s, f a ∈ t`.

So, we prove four theorems: `finset.exists_lt_card_fiber_of_maps_to_of_mul_lt_card`,
`finset.exists_le_card_fiber_of_maps_to_of_mul_le_card`,
`finset.exists_card_fiber_lt_of_card_lt_mul`, and `finset.exists_card_fiber_le_of_card_le_mul`. -/

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes. -/
lemma exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t)
  (ht : t.card • b < s.card) :
  ∃ y ∈ t, b < (s.filter $ λ x, f x = y).card :=
begin
  simp_rw cast_card at ⊢ ht,
  exact exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum hf ht,
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at least as many pigeons as the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function between finite sets `s` and `t` and a natural number `n` such that
`card t * n < card s`, there exists `y ∈ t` such that its preimage in `s` has more than `n`
elements. -/
lemma exists_lt_card_fiber_of_mul_lt_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t)
  (hn : t.card * n < s.card) :
  ∃ y ∈ t, n < (s.filter (λ x, f x = y)).card :=
exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to hf hn

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes. -/
lemma exists_card_fiber_lt_of_card_lt_nsmul (ht : ↑(s.card) < t.card • b) :
  ∃ y ∈ t, ↑((s.filter $ λ x, f x = y).card) < b :=
begin
  simp_rw cast_card at ⊢ ht,
  exact exists_sum_fiber_lt_of_sum_fiber_nonneg_of_sum_lt_nsmul
    (λ _ _, sum_nonneg $ λ _ _, zero_le_one) ht,
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: there is a pigeonhole with
at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.  ("The
minimum is at most the mean" specialized to integers.)

More formally, given a function `f`, a finite sets `s` in its domain, a finite set `t` in its
codomain, and a natural number `n` such that `card s < card t * n`, there exists `y ∈ t` such that
its preimage in `s` has less than `n` elements. -/
lemma exists_card_fiber_lt_of_card_lt_mul (hn : s.card < t.card * n) :
  ∃ y ∈ t, (s.filter (λ x, f x = y)).card < n :=
exists_card_fiber_lt_of_card_lt_nsmul hn

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a number `b` such that `card t • b ≤ card s`, there exists `y ∈ t` such
that its preimage in `s` has at least `b` elements.
See also `finset.exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to` for a stronger statement. -/
lemma exists_le_card_fiber_of_nsmul_le_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hb : t.card • b ≤ s.card) :
  ∃ y ∈ t, b ≤ (s.filter $ λ x, f x = y).card :=
begin
  simp_rw cast_card at ⊢ hb,
  exact exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum hf ht hb,
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function between
finite sets `s` and `t` and a natural number `b` such that `card t * n ≤ card s`, there exists `y ∈
t` such that its preimage in `s` has at least `n` elements. See also
`finset.exists_lt_card_fiber_of_mul_lt_card_of_maps_to` for a stronger statement. -/
lemma exists_le_card_fiber_of_mul_le_card_of_maps_to (hf : ∀ a ∈ s, f a ∈ t) (ht : t.nonempty)
  (hn : t.card * n ≤ s.card) :
  ∃ y ∈ t, n ≤ (s.filter (λ x, f x = y)).card :=
exists_le_card_fiber_of_nsmul_le_card_of_maps_to hf ht hn

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` and `t`, and a number `b` such that `card s ≤ card t • b`, there exists `y ∈ t` such
that its preimage in `s` has no more than `b` elements.
See also `finset.exists_card_fiber_lt_of_card_lt_nsmul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_nsmul (ht : t.nonempty) (hb : ↑(s.card) ≤ t.card • b) :
  ∃ y ∈ t, ↑((s.filter $ λ x, f x = y).card) ≤ b :=
begin
  simp_rw cast_card at ⊢ hb,
  refine exists_sum_fiber_le_of_sum_fiber_nonneg_of_sum_le_nsmul
    (λ _ _, sum_nonneg $ λ _ _, zero_le_one) ht hb,
end

/-- The pigeonhole principle for finitely many pigeons counted by heads: given a function `f`, a
finite sets `s` in its domain, a finite set `t` in its codomain, and a natural number `n` such that
`card s ≤ card t * n`, there exists `y ∈ t` such that its preimage in `s` has no more than `n`
elements. See also `finset.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_mul (ht : t.nonempty) (hn : s.card ≤ t.card * n) :
  ∃ y ∈ t, (s.filter (λ x, f x = y)).card ≤ n :=
exists_card_fiber_le_of_card_le_nsmul ht hn

end finset

namespace fintype
open finset

variables [fintype α] [fintype β] (f : α → β) {w : α → M} {b : M} {n : ℕ}

section
variables [linear_ordered_cancel_add_comm_monoid M]

/-!
### The pigeonhole principles on `fintypes`s, pigeons counted by weight

In this section we specialize theorems from the previous section to the special case of functions
between `fintype`s and `s = univ`, `t = univ`. In this case the assumption `∀ x ∈ s, f x ∈ t` always
holds, so we have four theorems instead of eight. -/

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than `b` provided that
the total number of pigeonholes times `b` is less than the total weight of all pigeons. -/
lemma exists_lt_sum_fiber_of_nsmul_lt_sum (hb : card β • b < ∑ x, w x) :
  ∃ y, b < ∑ x in univ.filter (λ x, f x = y), w x :=
let ⟨y, _, hy⟩ := exists_lt_sum_fiber_of_maps_to_of_nsmul_lt_sum (λ _ _, mem_univ _) hb in ⟨y, hy⟩

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it greater than or equal to `b`
provided that the total number of pigeonholes times `b` is less than or equal to the total weight of
all pigeons. -/
lemma exists_le_sum_fiber_of_nsmul_le_sum [nonempty β] (hb : card β • b ≤ ∑ x, w x) :
  ∃ y, b ≤ ∑ x in univ.filter (λ x, f x = y), w x :=
let ⟨y, _, hy⟩ :=
  exists_le_sum_fiber_of_maps_to_of_nsmul_le_sum (λ _ _, mem_univ _) univ_nonempty hb
in ⟨y, hy⟩

/-- The pigeonhole principle for finitely many pigeons of different weights, strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than `b` provided that
the total number of pigeonholes times `b` is greater than the total weight of all pigeons. -/
lemma exists_sum_fiber_lt_of_sum_lt_nsmul (hb : (∑ x, w x) < card β • b) :
  ∃ y, (∑ x in univ.filter (λ x, f x = y), w x) < b :=
@exists_lt_sum_fiber_of_nsmul_lt_sum α β Mᵒᵈ _ _ _ _ _ _ _ hb

/-- The pigeonhole principle for finitely many pigeons of different weights, non-strict inequality
version: there is a pigeonhole with the total weight of pigeons in it less than or equal to `b`
provided that the total number of pigeonholes times `b` is greater than or equal to the total weight
of all pigeons. -/
lemma exists_sum_fiber_le_of_sum_le_nsmul [nonempty β] (hb : (∑ x, w x) ≤ card β • b) :
  ∃ y, (∑ x in univ.filter (λ x, f x = y), w x) ≤ b :=
@exists_le_sum_fiber_of_nsmul_le_sum α β Mᵒᵈ _ _ _ _ _ _ _ _ hb

end

variables [linear_ordered_comm_semiring M]

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes. There is a pigeonhole
with at least as many pigeons as the ceiling of the average number of pigeons across all
pigeonholes. -/
lemma exists_lt_card_fiber_of_nsmul_lt_card (hb : card β • b < card α) :
  ∃ y : β, b < (univ.filter (λ x, f x = y)).card :=
let ⟨y, _, h⟩ := exists_lt_card_fiber_of_nsmul_lt_card_of_maps_to (λ _ _, mem_univ _) hb in ⟨y, h⟩

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at least as many pigeons as
the ceiling of the average number of pigeons across all pigeonholes.
("The maximum is at least the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card β * n < card α`, there exists an element `y : β` such that its preimage has more than `n`
elements. -/
lemma exists_lt_card_fiber_of_mul_lt_card (hn : card β * n < card α) :
  ∃ y : β, n < (univ.filter (λ x, f x = y)).card :=
exists_lt_card_fiber_of_nsmul_lt_card _ hn

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes. There is a pigeonhole
with at most as many pigeons as the floor of the average number of pigeons across all pigeonholes.
-/
lemma exists_card_fiber_lt_of_card_lt_nsmul (hb : ↑(card α) < card β • b) :
  ∃ y : β, ↑((univ.filter $ λ x, f x = y).card) < b :=
let ⟨y, _, h⟩ := exists_card_fiber_lt_of_card_lt_nsmul hb in ⟨y, h⟩

/--
The strong pigeonhole principle for finitely many pigeons and pigeonholes.
There is a pigeonhole with at most as many pigeons as
the floor of the average number of pigeons across all pigeonholes.
("The minimum is at most the mean" specialized to integers.)

More formally, given a function `f` between finite types `α` and `β` and a number `n` such that
`card α < card β * n`, there exists an element `y : β` such that its preimage has less than `n`
elements. -/
lemma exists_card_fiber_lt_of_card_lt_mul (hn : card α < card β * n) :
  ∃ y : β, (univ.filter (λ x, f x = y)).card < n :=
exists_card_fiber_lt_of_card_lt_nsmul _ hn

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `b` such that `card β • b ≤ card α`, there exists an
element `y : β` such that its preimage has at least `b` elements.
See also `fintype.exists_lt_card_fiber_of_nsmul_lt_card` for a stronger statement. -/
lemma exists_le_card_fiber_of_nsmul_le_card [nonempty β] (hb : card β • b ≤ card α) :
  ∃ y : β, b ≤ (univ.filter $ λ x, f x = y).card :=
let ⟨y, _, h⟩ := exists_le_card_fiber_of_nsmul_le_card_of_maps_to (λ _ _, mem_univ _) univ_nonempty
  hb in ⟨y, h⟩

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card β * n ≤ card α`, there exists an
element `y : β` such that its preimage has at least `n` elements. See also
`fintype.exists_lt_card_fiber_of_mul_lt_card` for a stronger statement. -/
lemma exists_le_card_fiber_of_mul_le_card [nonempty β] (hn : card β * n ≤ card α) :
  ∃ y : β, n ≤ (univ.filter (λ x, f x = y)).card :=
exists_le_card_fiber_of_nsmul_le_card _ hn

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `b` such that `card α ≤ card β • b`, there exists an
element `y : β` such that its preimage has at most `b` elements.
See also `fintype.exists_card_fiber_lt_of_card_lt_nsmul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_nsmul [nonempty β] (hb : ↑(card α) ≤ card β • b) :
  ∃ y : β, ↑((univ.filter $ λ x, f x = y).card) ≤ b :=
let ⟨y, _, h⟩ := exists_card_fiber_le_of_card_le_nsmul univ_nonempty hb in ⟨y, h⟩

/-- The strong pigeonhole principle for finitely many pigeons and pigeonholes.  Given a function `f`
between finite types `α` and `β` and a number `n` such that `card α ≤ card β * n`, there exists an
element `y : β` such that its preimage has at most `n` elements. See also
`fintype.exists_card_fiber_lt_of_card_lt_mul` for a stronger statement. -/
lemma exists_card_fiber_le_of_card_le_mul [nonempty β] (hn : card α ≤ card β * n) :
  ∃ y : β, (univ.filter (λ x, f x = y)).card ≤ n :=
exists_card_fiber_le_of_card_le_nsmul _ hn

end fintype

namespace nat

open set

/-- If `s` is an infinite set of natural numbers and `k > 0`, then `s` contains two elements `m < n`
that are equal mod `k`. -/
theorem exists_lt_modeq_of_infinite {s : set ℕ} (hs : s.infinite) {k : ℕ} (hk : 0 < k) :
  ∃ (m ∈ s) (n ∈ s), m < n ∧ m ≡ n [MOD k] :=
hs.exists_lt_map_eq_of_maps_to (λ n _, show n % k ∈ Iio k, from nat.mod_lt n hk) $
  finite_lt_nat k

end nat


------------------------------------------------------------------------
-- Teoría elemental de funciones
------------------------------------------------------------------------

import tactic

open function

variables {X Y Z : Type}
variables (a b x : X)
variable  (y : Y)
variable  (z : Z)
variables {f : X → Y}
variable  {g : Y → Z}

------------------------------------------------------------------------
-- § Funciones inyectivas                                             --
------------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Ejercicio 1. Demostrar que
--    injective f ↔ ∀ a b : X, f a = f b → a = b
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  injective f ↔ ∀ a b : X, f a = f b → a = b :=
by refl

-- 2ª demostración
example :
  injective f ↔ ∀ a b : X, f a = f b → a = b :=
-- by library_search
iff.rfl

-- ---------------------------------------------------------------------
-- Ejercicio 2. Demostrar que
--    id x = x
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  id x = x :=
rfl

-- 1ª demostración
example :
  id x = x :=
-- by library_search
id.def x

-- ---------------------------------------------------------------------
-- Ejercicio 3. Demostrar que la función identidad es inyectiva
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  injective (id : X → X) :=
begin
  unfold injective,
  intros a b hab,
  rw id.def at hab,
  rw id.def at hab,
  exact hab,
end

-- 2ª demostración
example :
  injective (id : X → X) :=
begin
  intros a b hab,
  rw id.def at hab,
  rw id.def at hab,
  exact hab,
end

-- 3ª demostración
example :
  injective (id : X → X) :=
begin
  intros a b hab,
  iterate 2 {rw id.def at hab},
  exact hab,
end

-- 4ª demostración
example :
  injective (id : X → X) :=
begin
  intros a b hab,
  exact hab,
end

-- 5ª demostración
example :
  injective (id : X → X) :=
λ a b hab, hab

-- 6ª demostración
example :
  injective (id : X → X) :=
-- by library_search
injective_id

-- 7ª demostración
example :
  injective (id : X → X) :=
-- by hint
by finish

-- ---------------------------------------------------------------------
-- Ejercicio 4. Demostrar que
--    (g ∘ f) x = g (f x)
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  (g ∘ f) x = g (f x) :=
rfl

-- 2ª demostración
example :
  (g ∘ f) x = g (f x) :=
by simp

-- ---------------------------------------------------------------------
-- Ejercicio 5. Demostrar que la composición de dos funciones inyectivas
-- es inyectiva.
-- ----------------------------------------------------------------------

-- 1ª demostración
example
  (hf : injective f)
  (hg : injective g)
  : injective (g ∘ f) :=
begin
  intros a b h,
  apply hf,
  apply hg,
  exact h,
end

-- 2ª demostración
example
  (hf : injective f)
  (hg : injective g)
  : injective (g ∘ f) :=
begin
  intros a b h,
  exact hf (hg h),
end

-- 3ª demostración
example
  (hf : injective f)
  (hg : injective g)
  : injective (g ∘ f) :=
λ a b h, hf (hg h)

-- 3ª demostración
example
  (hf : injective f)
  (hg : injective g)
  : injective (g ∘ f) :=
-- by library_search
injective.comp hg hf

------------------------------------------------------------------------
-- § Funciones suprayectivas                                          --
------------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Ejercicio 6. Demostrar que
--    surjective f ↔ ∀ y : Y, ∃ x : X, f x = y
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  surjective f ↔ ∀ y : Y, ∃ x : X, f x = y :=
by refl

-- 2ª demostración
example :
  surjective f ↔ ∀ y : Y, ∃ x : X, f x = y :=
-- by library_search
iff.rfl

-- ---------------------------------------------------------------------
-- Ejercicio 7. Demostrar que la función identidad es suprayectiva.
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  surjective (id : X → X) :=
begin
  intro x,
  use x,
  refl,
end

-- 2ª demostración
example :
  surjective (id : X → X) :=
λ x, ⟨x, rfl⟩

-- 3ª demostración
example :
  surjective (id : X → X) :=
-- by library_search
surjective_id

-- 4ª demostración
example :
  surjective (id : X → X) :=
-- by hint
by tauto

-- ---------------------------------------------------------------------
-- Ejercicio 8. Demostrar que la composición de dos funciones
-- suprayectivas es supreyectiva.
-- ----------------------------------------------------------------------

-- 1ª demostración
example
  (hf : surjective f)
  (hg : surjective g)
  : surjective (g ∘ f) :=
begin
  intro z,
  cases hg z with y hy,
  cases hf y with x hx,
  use x,
  show g(f(x)) = z,
  rw hx,
  exact hy,
end

-- 2ª demostración
example
  (hf : surjective f)
  (hg : surjective g)
  : surjective (g ∘ f) :=
begin
  intro z,
  cases hg z with y hy,
  cases hf y with x hx,
  use x,
  dsimp,
  convert hy,
end

-- 3ª demostración
example
  (hf : surjective f)
  (hg : surjective g)
  : surjective (g ∘ f) :=
-- by library_search
surjective.comp hg hf

------------------------------------------------------------------------
-- § Funciones biyectivas                                             --
------------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Ejercicio 9. Demostrar que
--    bijective f ↔ injective f ∧ surjective f
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  bijective f ↔ injective f ∧ surjective f :=
by refl

-- 2ª demostración
example :
  bijective f ↔ injective f ∧ surjective f :=
-- by suggest
iff.rfl

-- ---------------------------------------------------------------------
-- Ejercicio 10. Demostrar que la función identidad es biyectiva.
-- ----------------------------------------------------------------------

-- 1ª demostración
example :
  bijective (id : X → X) :=
⟨injective_id, surjective_id⟩

-- 2ª demostración
example :
  bijective (id : X → X) :=
-- by library_search
bijective_id

-- ---------------------------------------------------------------------
-- Ejercicio 12. Demostrar que la composición de dos funciones biyectivas
-- es biyectiva.
-- ----------------------------------------------------------------------

-- 1ª demostración
example
  (hf : bijective f)
  (hg : bijective g)
  : bijective (g ∘ f) :=
begin
  cases hf with hfi hfs,
  cases hg with hgi hgs,
  exact ⟨injective.comp hgi hfi,
         surjective.comp hgs hfs⟩
end

-- =====================================================================
-- § Referencias                                                      --
-- =====================================================================

-- + Kevin Buzzard. "Formalising mathematics : workshop 1 — logic, sets,
--   functions, relations" https://bit.ly/3kJo231
-- + Kevin Buzzard. formalising-mathematics: Part_C_functions.lean
--   https://bit.ly/3EWExRb
-- + Kevin Buzzard. formalising-mathematics: Part_C_functions_solutions.lean
--   https://bit.ly/3CPs1Ba


/-
Copyright (c) 2020 James Arthur. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: James Arthur, Chris Hughes, Shing Tak Lam
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.special_functions.trigonometric
import Mathlib.PostPort

namespace Mathlib

/-!
# Inverse of the sinh function

In this file we prove that sinh is bijective and hence has an
inverse, arsinh.

## Main Results

- `sinh_injective`: The proof that `sinh` is injective
- `sinh_surjective`: The proof that `sinh` is surjective
- `sinh_bijective`: The proof `sinh` is bijective
- `arsinh`: The inverse function of `sinh`

## Tags

arsinh, arcsinh, argsinh, asinh, sinh injective, sinh bijective, sinh surjective
-/

namespace real

/-- `arsinh` is defined using a logarithm, `arsinh x = log (x + sqrt(1 + x^2))`. -/
def arsinh (x : ℝ) : ℝ :=
  log (x + sqrt (1 + x ^ bit0 1))

/-- `sinh` is injective, `∀ a b, sinh a = sinh b → a = b`. -/
theorem sinh_injective : function.injective sinh :=
  strict_mono.injective sinh_strict_mono

/-- `arsinh` is the right inverse of `sinh`. -/
theorem sinh_arsinh (x : ℝ) : sinh (arsinh x) = x := sorry

/-- `sinh` is surjective, `∀ b, ∃ a, sinh a = b`. In this case, we use `a = arsinh b`. -/
theorem sinh_surjective : function.surjective sinh :=
  function.left_inverse.surjective sinh_arsinh

/-- `sinh` is bijective, both injective and surjective. -/
theorem sinh_bijective : function.bijective sinh :=
  { left := sinh_injective, right := sinh_surjective }

/-- A rearrangement and `sqrt` of `real.cosh_sq_sub_sinh_sq`. -/
theorem sqrt_one_add_sinh_sq (x : ℝ) : sqrt (1 + sinh x ^ bit0 1) = cosh x := sorry

/-- `arsinh` is the left inverse of `sinh`. -/
theorem arsinh_sinh (x : ℝ) : arsinh (sinh x) = x :=
  function.right_inverse_of_injective_of_left_inverse sinh_injective sinh_arsinh x


import data.vector
import data.real.basic
import init.data.list

universes u
variables {α : Type u} {n : ℕ}

@[simp] def resize_constant (m : ℕ) (zero : α) : vector α n → vector α m
| ⟨l, p⟩ := ⟨ list.take m (l ++ list.repeat zero m), by simp ⟩

theorem resize_preserves_elements (zero : α) :
∀ (n : ℕ) (v : vector α n),
v = resize_constant n zero v
| n ⟨l, p⟩ := begin
  simp,
  suffices len : n = l.length,
  rw len,
  simp,
  symmetry,
  rw p
end

/-
theorem resize_sensitivity (n : ℕ) (zero : α) [decidable_eq α] :
∀ (v₁ : vector α n) (v₂ : vector α n) (m : ℕ),
v₁ ~ v₂ → (resize_constant m zero v₁) ~ (resize_constant m zero v₂)
| v₁ v₂ m := begin
  intros neighbors,
  simp,
  suffices v₁_take : (resize_constant m zero v₁).to_list
    = list.take m (v₁.to_list ++ list.repeat zero m),
  suffices v₂_take : (resize_constant m zero v₂).to_list
    = list.take m (v₂.to_list ++ list.repeat zero m),
  rw [v₁_take, v₂_take],
  suffices distrib : list.zip_with element_dist
               (list.take m (v₁.to_list ++ list.repeat zero m))
               (list.take m (v₂.to_list ++ list.repeat zero m))
             = list.take m
                 (list.zip_with element_dist
                                (v₁.to_list ++ list.repeat zero m)
                                (v₂.to_list ++ list.repeat zero m)),
  rw distrib,
  cases m,
  simp
end
-/


open classical

variables p q r s : Prop

example : (p → r ∨ s) → ((p → r) ∨ (p → s)) :=
  assume h,
  by_cases
    (assume hp,
      (h hp).elim
        (assume hr, or.inl (λ hp, hr))
        (assume hr, or.inr (λ hp, hr)))
    (assume hnp,
      or.inl (λ hp, absurd hp hnp))
example : ¬(p ∧ q) → ¬p ∨ ¬q :=
  assume h,
  by_cases
    (assume hp,
      suffices hnq : ¬q, from or.inr hnq,
      assume hq,
      h ⟨hp, hq⟩)
    (assume hnp,
      or.inl hnp)
example : ¬(p → q) → p ∧ ¬q :=
  assume h,
  by_cases
    (assume hp,
      suffices hnq : ¬q, from ⟨hp, hnq⟩,
      assume hq,
      h (λ hp, hq))
    (assume hnp,
      suffices hp2q : p → q, from false.elim (h hp2q),
      assume hp,
      absurd hp hnp)
example : (p → q) → (¬p ∨ q) :=
  assume hp2q,
  by_cases
    (assume hp,
      or.inr (hp2q hp))
    (assume hnp,
      or.inl hnp)
example : (¬q → ¬p) → (p → q) :=
  assume hnq2np hp,
  by_cases
    id
    (assume hnq,
      absurd hp (hnq2np hnq))
example : p ∨ ¬p := em p
example : (((p → q) → p) → p) :=
  assume h,
  by_contradiction
    (assume hnp,
      have hp : p, from h (λ hp, absurd hp hnp),
      hnp hp)


import game.sup_inf.level03
import data.real.basic

namespace xena -- hide

/-
# Chapter 3 : Sup and Inf

## Level 4
-/

/-
A generalization of the result in the previous level.
-/

-- begin hide
-- these three helper results to go in sidebar
lemma two_real_ne_zero : (2:ℝ) ≠ 0 :=
begin
    intro, linarith,
end

lemma avg_lt_max {mn mx: ℝ} (H : mn < mx) : (mn+mx) / 2 < mx :=
begin
  apply (mul_lt_mul_right (show (0:ℝ)<2, by norm_num)).1,
  rw [div_mul_cancel _ (two_real_ne_zero)],
  simp [H,mul_two],
end

lemma min_lt_avg {mn mx: ℝ} (H : mn < mx) : mn < (mn+mx) / 2 :=
begin
  apply (mul_lt_mul_right (show (0:ℝ)<2, by norm_num)).1,
  rw [div_mul_cancel _ (two_real_ne_zero)],
  simp [H,mul_two],
end
-- end hide

/- Lemma
A more general version of the previous level...
-/
lemma lub_open (y : ℝ) : is_lub {x : ℝ | x < y} y :=
begin
split,
{ intros a ha,
  exact le_of_lt ha,
},
--unfold lower_bounds,
intro b,
intro Hb,
refine le_of_not_gt _,
intro Hnb,
let c:=(b+y)/2,
--unfold upper_bounds at Hb,
have H2 := Hb c,
clear Hb,
have H : c ∈ {x : ℝ | x < y},
{ exact avg_lt_max Hnb,
},
have Hcleb := H2 H,
have Hbltc : b < c := min_lt_avg Hnb,
exact not_lt.2 Hcleb Hbltc,
end

end xena -- hide