/-
Copyright (c) 2019 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp, Yury Kudriashov, Yaël Dillies
-/
import algebra.order.invertible
import algebra.order.module
import linear_algebra.affine_space.midpoint
import linear_algebra.affine_space.affine_subspace

/-!
# Convex sets and functions in vector spaces

In a 𝕜-vector space, we define the following objects and properties.
* `segment 𝕜 x y`: Closed segment joining `x` and `y`.
* `open_segment 𝕜 x y`: Open segment joining `x` and `y`.
* `convex 𝕜 s`: A set `s` is convex if for any two points `x y ∈ s` it includes `segment 𝕜 x y`.
* `std_simplex 𝕜 ι`: The standard simplex in `ι → 𝕜` (currently requires `fintype ι`). It is the
  intersection of the positive quadrant with the hyperplane `s.sum = 1`.

We also provide various equivalent versions of the definitions above, prove that some specific sets
are convex.

## Notations

We provide the following notation:
* `[x -[𝕜] y] = segment 𝕜 x y` in locale `convex`

## TODO

Generalize all this file to affine spaces.

Should we rename `segment` and `open_segment` to `convex.Icc` and `convex.Ioo`? Should we also
define `clopen_segment`/`convex.Ico`/`convex.Ioc`?
-/

variables {𝕜 E F β : Type*}

open linear_map set
open_locale big_operators classical pointwise

/-! ### Segment -/

section ordered_semiring
variables [ordered_semiring 𝕜] [add_comm_monoid E]

section has_scalar
variables (𝕜) [has_scalar 𝕜 E]

/-- Segments in a vector space. -/
def segment (x y : E) : set E :=
{z : E | ∃ (a b : 𝕜) (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1), a • x + b • y = z}

/-- Open segment in a vector space. Note that `open_segment 𝕜 x x = {x}` instead of being `∅` when
the base semiring has some element between `0` and `1`. -/
def open_segment (x y : E) : set E :=
{z : E | ∃ (a b : 𝕜) (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1), a • x + b • y = z}

localized "notation `[` x ` -[` 𝕜 `] ` y `]` := segment 𝕜 x y" in convex

lemma segment_symm (x y : E) : [x -[𝕜] y] = [y -[𝕜] x] :=
set.ext $ λ z,
⟨λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩,
  λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩⟩

lemma open_segment_symm (x y : E) :
  open_segment 𝕜 x y = open_segment 𝕜 y x :=
set.ext $ λ z,
⟨λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩,
  λ ⟨a, b, ha, hb, hab, H⟩, ⟨b, a, hb, ha, (add_comm _ _).trans hab, (add_comm _ _).trans H⟩⟩

lemma open_segment_subset_segment (x y : E) :
  open_segment 𝕜 x y ⊆ [x -[𝕜] y] :=
λ z ⟨a, b, ha, hb, hab, hz⟩, ⟨a, b, ha.le, hb.le, hab, hz⟩

lemma segment_subset_iff {x y : E} {s : set E} :
  [x -[𝕜] y] ⊆ s ↔ ∀ a b : 𝕜, 0 ≤ a → 0 ≤ b → a + b = 1 → a • x + b • y ∈ s :=
⟨λ H a b ha hb hab, H ⟨a, b, ha, hb, hab, rfl⟩,
  λ H z ⟨a, b, ha, hb, hab, hz⟩, hz ▸ H a b ha hb hab⟩

lemma open_segment_subset_iff {x y : E} {s : set E} :
  open_segment 𝕜 x y ⊆ s ↔ ∀ a b : 𝕜, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ s :=
⟨λ H a b ha hb hab, H ⟨a, b, ha, hb, hab, rfl⟩,
  λ H z ⟨a, b, ha, hb, hab, hz⟩, hz ▸ H a b ha hb hab⟩

end has_scalar

open_locale convex

section mul_action_with_zero
variables (𝕜) [mul_action_with_zero 𝕜 E]

lemma left_mem_segment (x y : E) : x ∈ [x -[𝕜] y] :=
⟨1, 0, zero_le_one, le_refl 0, add_zero 1, by rw [zero_smul, one_smul, add_zero]⟩

lemma right_mem_segment (x y : E) : y ∈ [x -[𝕜] y] :=
segment_symm 𝕜 y x ▸ left_mem_segment 𝕜 y x

end mul_action_with_zero

section module
variables (𝕜) [module 𝕜 E]

lemma segment_same (x : E) : [x -[𝕜] x] = {x} :=
set.ext $ λ z, ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
  by simpa only [(add_smul _ _ _).symm, mem_singleton_iff, hab, one_smul, eq_comm] using hz,
  λ h, mem_singleton_iff.1 h ▸ left_mem_segment 𝕜 z z⟩

lemma mem_open_segment_of_ne_left_right {x y z : E} (hx : x ≠ z) (hy : y ≠ z)
  (hz : z ∈ [x -[𝕜] y]) :
  z ∈ open_segment 𝕜 x y :=
begin
  obtain ⟨a, b, ha, hb, hab, hz⟩ := hz,
  by_cases ha' : a = 0,
  { rw [ha', zero_add] at hab,
    rw [ha', hab, zero_smul, one_smul, zero_add] at hz,
    exact (hy hz).elim },
  by_cases hb' : b = 0,
  { rw [hb', add_zero] at hab,
    rw [hb', hab, zero_smul, one_smul, add_zero] at hz,
    exact (hx hz).elim },
  exact ⟨a, b, ha.lt_of_ne (ne.symm ha'), hb.lt_of_ne (ne.symm hb'), hab, hz⟩,
end

variables {𝕜}

lemma open_segment_subset_iff_segment_subset {x y : E} {s : set E} (hx : x ∈ s) (hy : y ∈ s) :
  open_segment 𝕜 x y ⊆ s ↔ [x -[𝕜] y] ⊆ s :=
begin
  refine ⟨λ h z hz, _, (open_segment_subset_segment 𝕜 x y).trans⟩,
  obtain rfl | hxz := eq_or_ne x z,
  { exact hx },
  obtain rfl | hyz := eq_or_ne y z,
  { exact hy },
  exact h (mem_open_segment_of_ne_left_right 𝕜 hxz hyz hz),
end

lemma convex.combo_self {a b : 𝕜} (h : a + b = 1) (x : E) : a • x + b • x = x :=
by rw [←add_smul, h, one_smul]

end module
end ordered_semiring

open_locale convex

section ordered_ring
variables [ordered_ring 𝕜]

section add_comm_group
variables (𝕜) [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F]

section densely_ordered
variables [nontrivial 𝕜] [densely_ordered 𝕜]

@[simp] lemma open_segment_same (x : E) :
  open_segment 𝕜 x x = {x} :=
set.ext $ λ z, ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
  by simpa only [← add_smul, mem_singleton_iff, hab, one_smul, eq_comm] using hz,
  λ (h : z = x), begin
    obtain ⟨a, ha₀, ha₁⟩ := densely_ordered.dense (0 : 𝕜) 1 zero_lt_one,
    refine ⟨a, 1 - a, ha₀, sub_pos_of_lt ha₁, add_sub_cancel'_right _ _, _⟩,
    rw [←add_smul, add_sub_cancel'_right, one_smul, h],
  end⟩

end densely_ordered

lemma segment_eq_image (x y : E) : [x -[𝕜] y] = (λ θ : 𝕜, (1 - θ) • x + θ • y) '' Icc (0 : 𝕜) 1 :=
set.ext $ λ z,
  ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
    ⟨b, ⟨hb, hab ▸ le_add_of_nonneg_left ha⟩, hab ▸ hz ▸ by simp only [add_sub_cancel]⟩,
    λ ⟨θ, ⟨hθ₀, hθ₁⟩, hz⟩, ⟨1-θ, θ, sub_nonneg.2 hθ₁, hθ₀, sub_add_cancel _ _, hz⟩⟩

lemma open_segment_eq_image (x y : E) :
  open_segment 𝕜 x y = (λ (θ : 𝕜), (1 - θ) • x + θ • y) '' Ioo (0 : 𝕜) 1 :=
set.ext $ λ z,
  ⟨λ ⟨a, b, ha, hb, hab, hz⟩,
    ⟨b, ⟨hb, hab ▸ lt_add_of_pos_left _ ha⟩, hab ▸ hz ▸ by simp only [add_sub_cancel]⟩,
    λ ⟨θ, ⟨hθ₀, hθ₁⟩, hz⟩, ⟨1 - θ, θ, sub_pos.2 hθ₁, hθ₀, sub_add_cancel _ _, hz⟩⟩

lemma segment_eq_image₂ (x y : E) :
  [x -[𝕜] y] = (λ p : 𝕜 × 𝕜, p.1 • x + p.2 • y) '' {p | 0 ≤ p.1 ∧ 0 ≤ p.2 ∧ p.1 + p.2 = 1} :=
by simp only [segment, image, prod.exists, mem_set_of_eq, exists_prop, and_assoc]

lemma open_segment_eq_image₂ (x y : E) :
  open_segment 𝕜 x y =
    (λ p : 𝕜 × 𝕜, p.1 • x + p.2 • y) '' {p | 0 < p.1 ∧ 0 < p.2 ∧ p.1 + p.2 = 1} :=
by simp only [open_segment, image, prod.exists, mem_set_of_eq, exists_prop, and_assoc]

lemma segment_eq_image' (x y : E) :
  [x -[𝕜] y] = (λ (θ : 𝕜), x + θ • (y - x)) '' Icc (0 : 𝕜) 1 :=
by { convert segment_eq_image 𝕜 x y, ext θ, simp only [smul_sub, sub_smul, one_smul], abel }

lemma open_segment_eq_image' (x y : E) :
  open_segment 𝕜 x y = (λ (θ : 𝕜), x + θ • (y - x)) '' Ioo (0 : 𝕜) 1 :=
by { convert open_segment_eq_image 𝕜 x y, ext θ, simp only [smul_sub, sub_smul, one_smul], abel }

lemma segment_eq_image_line_map (x y : E) :
  [x -[𝕜] y] = affine_map.line_map x y '' Icc (0 : 𝕜) 1 :=
by { convert segment_eq_image 𝕜 x y, ext, exact affine_map.line_map_apply_module _ _ _ }

lemma open_segment_eq_image_line_map (x y : E) :
  open_segment 𝕜 x y = affine_map.line_map x y '' Ioo (0 : 𝕜) 1 :=
by { convert open_segment_eq_image 𝕜 x y, ext, exact affine_map.line_map_apply_module _ _ _ }

lemma segment_image (f : E →ₗ[𝕜] F) (a b : E) : f '' [a -[𝕜] b] = [f a -[𝕜] f b] :=
set.ext (λ x, by simp_rw [segment_eq_image, mem_image, exists_exists_and_eq_and, map_add, map_smul])

@[simp] lemma open_segment_image (f : E →ₗ[𝕜] F) (a b : E) :
  f '' open_segment 𝕜 a b = open_segment 𝕜 (f a) (f b) :=
set.ext (λ x, by simp_rw [open_segment_eq_image, mem_image, exists_exists_and_eq_and, map_add,
  map_smul])

lemma mem_segment_translate (a : E) {x b c} : a + x ∈ [a + b -[𝕜] a + c] ↔ x ∈ [b -[𝕜] c] :=
begin
  rw [segment_eq_image', segment_eq_image'],
  refine exists_congr (λ θ, and_congr iff.rfl _),
  simp only [add_sub_add_left_eq_sub, add_assoc, add_right_inj],
end

@[simp] lemma mem_open_segment_translate (a : E) {x b c : E} :
  a + x ∈ open_segment 𝕜 (a + b) (a + c) ↔ x ∈ open_segment 𝕜 b c :=
begin
  rw [open_segment_eq_image', open_segment_eq_image'],
  refine exists_congr (λ θ, and_congr iff.rfl _),
  simp only [add_sub_add_left_eq_sub, add_assoc, add_right_inj],
end

lemma segment_translate_preimage (a b c : E) : (λ x, a + x) ⁻¹' [a + b -[𝕜] a + c] = [b -[𝕜] c] :=
set.ext $ λ x, mem_segment_translate 𝕜 a

lemma open_segment_translate_preimage (a b c : E) :
  (λ x, a + x) ⁻¹' open_segment 𝕜 (a + b) (a + c) = open_segment 𝕜 b c :=
set.ext $ λ x, mem_open_segment_translate 𝕜 a

lemma segment_translate_image (a b c : E) : (λ x, a + x) '' [b -[𝕜] c] = [a + b -[𝕜] a + c] :=
segment_translate_preimage 𝕜 a b c ▸ image_preimage_eq _ $ add_left_surjective a

lemma open_segment_translate_image (a b c : E) :
  (λ x, a + x) '' open_segment 𝕜 b c = open_segment 𝕜 (a + b) (a + c) :=
open_segment_translate_preimage 𝕜 a b c ▸ image_preimage_eq _ $ add_left_surjective a

end add_comm_group
end ordered_ring

section linear_ordered_ring
variables [linear_ordered_ring 𝕜]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F]

lemma midpoint_mem_segment [invertible (2 : 𝕜)] (x y : E) :
  midpoint 𝕜 x y ∈ [x -[𝕜] y] :=
begin
  rw segment_eq_image_line_map,
  exact ⟨⅟2, ⟨inv_of_nonneg.mpr zero_le_two, inv_of_le_one one_le_two⟩, rfl⟩,
end

lemma mem_segment_sub_add [invertible (2 : 𝕜)] (x y : E) :
  x ∈ [x-y -[𝕜] x+y] :=
begin
  convert @midpoint_mem_segment 𝕜 _ _ _ _ _ _ _,
  rw midpoint_sub_add
end

lemma mem_segment_add_sub [invertible (2 : 𝕜)] (x y : E) :
  x ∈ [x+y -[𝕜] x-y] :=
begin
  convert @midpoint_mem_segment 𝕜 _ _ _ _ _ _ _,
  rw midpoint_add_sub
end

end add_comm_group
end linear_ordered_ring

section linear_ordered_field
variables [linear_ordered_field 𝕜]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F]

lemma mem_segment_iff_div {x y z : E} : x ∈ [y -[𝕜] z] ↔
  ∃ a b : 𝕜, 0 ≤ a ∧ 0 ≤ b ∧ 0 < a + b ∧ (a / (a + b)) • y + (b / (a + b)) • z = x :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    use [a, b, ha, hb],
    simp * },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    refine ⟨a / (a + b), b / (a + b), div_nonneg ha hab.le, div_nonneg hb hab.le, _, rfl⟩,
    rw [← add_div, div_self hab.ne'] }
end

lemma mem_open_segment_iff_div {x y z : E} : x ∈ open_segment 𝕜 y z ↔
  ∃ a b : 𝕜, 0 < a ∧ 0 < b ∧ (a / (a + b)) • y + (b / (a + b)) • z = x :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    use [a, b, ha, hb],
    rw [hab, div_one, div_one] },
  { rintro ⟨a, b, ha, hb, rfl⟩,
    have hab : 0 < a + b, from add_pos ha hb,
    refine ⟨a / (a + b), b / (a + b), div_pos ha hab, div_pos hb hab, _, rfl⟩,
    rw [← add_div, div_self hab.ne'] }
end

@[simp] lemma left_mem_open_segment_iff [no_zero_smul_divisors 𝕜 E] {x y : E} :
  x ∈ open_segment 𝕜 x y ↔ x = y :=
begin
  split,
  { rintro ⟨a, b, ha, hb, hab, hx⟩,
    refine smul_right_injective _ hb.ne' ((add_right_inj (a • x)).1 _),
    rw [hx, ←add_smul, hab, one_smul] },
  { rintro rfl,
    rw open_segment_same,
    exact mem_singleton _ }
end

@[simp] lemma right_mem_open_segment_iff {x y : E} :
  y ∈ open_segment 𝕜 x y ↔ x = y :=
by rw [open_segment_symm, left_mem_open_segment_iff, eq_comm]

end add_comm_group
end linear_ordered_field

/-!
#### Segments in an ordered space
Relates `segment`, `open_segment` and `set.Icc`, `set.Ico`, `set.Ioc`, `set.Ioo`
-/
section ordered_semiring
variables [ordered_semiring 𝕜]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E]

lemma segment_subset_Icc {x y : E} (h : x ≤ y) : [x -[𝕜] y] ⊆ Icc x y :=
begin
  rintro z ⟨a, b, ha, hb, hab, rfl⟩,
  split,
  calc
    x   = a • x + b • x :(convex.combo_self hab _).symm
    ... ≤ a • x + b • y : add_le_add_left (smul_le_smul_of_nonneg h hb) _,
  calc
    a • x + b • y
        ≤ a • y + b • y : add_le_add_right (smul_le_smul_of_nonneg h ha) _
    ... = y : convex.combo_self hab _,
end

end ordered_add_comm_monoid

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E]

lemma open_segment_subset_Ioo {x y : E} (h : x < y) : open_segment 𝕜 x y ⊆ Ioo x y :=
begin
  rintro z ⟨a, b, ha, hb, hab, rfl⟩,
  split,
  calc
    x   = a • x + b • x : (convex.combo_self hab _).symm
    ... < a • x + b • y : add_lt_add_left (smul_lt_smul_of_pos h hb) _,
  calc
    a • x + b • y
        < a • y + b • y : add_lt_add_right (smul_lt_smul_of_pos h ha) _
    ... = y : convex.combo_self hab _,
end

end ordered_cancel_add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid E] [module 𝕜 E] [ordered_smul 𝕜 E] {𝕜}

lemma segment_subset_interval (x y : E) : [x -[𝕜] y] ⊆ interval x y :=
begin
  cases le_total x y,
  { rw interval_of_le h,
    exact segment_subset_Icc h },
  { rw [interval_of_ge h, segment_symm],
    exact segment_subset_Icc h }
end

lemma convex.min_le_combo (x y : E) {a b : 𝕜} (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  min x y ≤ a • x + b • y :=
(segment_subset_interval x y ⟨_, _, ha, hb, hab, rfl⟩).1

lemma convex.combo_le_max (x y : E) {a b : 𝕜} (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  a • x + b • y ≤ max x y :=
(segment_subset_interval x y ⟨_, _, ha, hb, hab, rfl⟩).2

end linear_ordered_add_comm_monoid
end ordered_semiring

section linear_ordered_field
variables [linear_ordered_field 𝕜]

lemma Icc_subset_segment {x y : 𝕜} : Icc x y ⊆ [x -[𝕜] y] :=
begin
  rintro z ⟨hxz, hyz⟩,
  obtain rfl | h := (hxz.trans hyz).eq_or_lt,
  { rw segment_same,
    exact hyz.antisymm hxz },
  rw ←sub_nonneg at hxz hyz,
  rw ←sub_pos at h,
  refine ⟨(y - z) / (y - x), (z - x) / (y - x), div_nonneg hyz h.le, div_nonneg hxz h.le, _, _⟩,
  { rw [←add_div, sub_add_sub_cancel, div_self h.ne'] },
  { rw [smul_eq_mul, smul_eq_mul, ←mul_div_right_comm, ←mul_div_right_comm, ←add_div,
      div_eq_iff h.ne', add_comm, sub_mul, sub_mul, mul_comm x, sub_add_sub_cancel, mul_sub] }
end

@[simp] lemma segment_eq_Icc {x y : 𝕜} (h : x ≤ y) : [x -[𝕜] y] = Icc x y :=
(segment_subset_Icc h).antisymm Icc_subset_segment

lemma Ioo_subset_open_segment {x y : 𝕜} : Ioo x y ⊆ open_segment 𝕜 x y :=
λ z hz, mem_open_segment_of_ne_left_right _ hz.1.ne hz.2.ne'
    (Icc_subset_segment $ Ioo_subset_Icc_self hz)

@[simp] lemma open_segment_eq_Ioo {x y : 𝕜} (h : x < y) : open_segment 𝕜 x y = Ioo x y :=
(open_segment_subset_Ioo h).antisymm Ioo_subset_open_segment

lemma segment_eq_Icc' (x y : 𝕜) : [x -[𝕜] y] = Icc (min x y) (max x y) :=
begin
  cases le_total x y,
  { rw [segment_eq_Icc h, max_eq_right h, min_eq_left h] },
  { rw [segment_symm, segment_eq_Icc h, max_eq_left h, min_eq_right h] }
end

lemma open_segment_eq_Ioo' {x y : 𝕜} (hxy : x ≠ y) :
  open_segment 𝕜 x y = Ioo (min x y) (max x y) :=
begin
  cases hxy.lt_or_lt,
  { rw [open_segment_eq_Ioo h, max_eq_right h.le, min_eq_left h.le] },
  { rw [open_segment_symm, open_segment_eq_Ioo h, max_eq_left h.le, min_eq_right h.le] }
end

lemma segment_eq_interval (x y : 𝕜) : [x -[𝕜] y] = interval x y :=
segment_eq_Icc' _ _

/-- A point is in an `Icc` iff it can be expressed as a convex combination of the endpoints. -/
lemma convex.mem_Icc {x y : 𝕜} (h : x ≤ y) {z : 𝕜} :
  z ∈ Icc x y ↔ ∃ (a b : 𝕜), 0 ≤ a ∧ 0 ≤ b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  rw ←segment_eq_Icc h,
  simp_rw [←exists_prop],
  refl,
end

/-- A point is in an `Ioo` iff it can be expressed as a strict convex combination of the endpoints.
-/
lemma convex.mem_Ioo {x y : 𝕜} (h : x < y) {z : 𝕜} :
  z ∈ Ioo x y ↔ ∃ (a b : 𝕜), 0 < a ∧ 0 < b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  rw ←open_segment_eq_Ioo h,
  simp_rw [←exists_prop],
  refl,
end

/-- A point is in an `Ioc` iff it can be expressed as a semistrict convex combination of the
endpoints. -/
lemma convex.mem_Ioc {x y : 𝕜} (h : x < y) {z : 𝕜} :
  z ∈ Ioc x y ↔ ∃ (a b : 𝕜), 0 ≤ a ∧ 0 < b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  split,
  { rintro hz,
    obtain ⟨a, b, ha, hb, hab, rfl⟩ := (convex.mem_Icc h.le).1 (Ioc_subset_Icc_self hz),
    obtain rfl | hb' := hb.eq_or_lt,
    { rw add_zero at hab,
      rw [hab, one_mul, zero_mul, add_zero] at hz,
      exact (hz.1.ne rfl).elim },
    { exact ⟨a, b, ha, hb', hab, rfl⟩ } },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    obtain rfl | ha' := ha.eq_or_lt,
    { rw zero_add at hab,
      rwa [hab, one_mul, zero_mul, zero_add, right_mem_Ioc] },
    { exact Ioo_subset_Ioc_self ((convex.mem_Ioo h).2 ⟨a, b, ha', hb, hab, rfl⟩) } }
end

/-- A point is in an `Ico` iff it can be expressed as a semistrict convex combination of the
endpoints. -/
lemma convex.mem_Ico {x y : 𝕜} (h : x < y) {z : 𝕜} :
  z ∈ Ico x y ↔ ∃ (a b : 𝕜), 0 < a ∧ 0 ≤ b ∧ a + b = 1 ∧ a * x + b * y = z :=
begin
  split,
  { rintro hz,
    obtain ⟨a, b, ha, hb, hab, rfl⟩ := (convex.mem_Icc h.le).1 (Ico_subset_Icc_self hz),
    obtain rfl | ha' := ha.eq_or_lt,
    { rw zero_add at hab,
      rw [hab, one_mul, zero_mul, zero_add] at hz,
      exact (hz.2.ne rfl).elim },
    { exact ⟨a, b, ha', hb, hab, rfl⟩ } },
  { rintro ⟨a, b, ha, hb, hab, rfl⟩,
    obtain rfl | hb' := hb.eq_or_lt,
    { rw add_zero at hab,
      rwa [hab, one_mul, zero_mul, add_zero, left_mem_Ico] },
    { exact Ioo_subset_Ico_self ((convex.mem_Ioo h).2 ⟨a, b, ha, hb', hab, rfl⟩) } }
end

end linear_ordered_field

/-! ### Convexity of sets -/

section ordered_semiring
variables [ordered_semiring 𝕜]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F]

section has_scalar
variables (𝕜) [has_scalar 𝕜 E] [has_scalar 𝕜 F] (s : set E)

/-- Convexity of sets. -/
def convex : Prop :=
∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
  a • x + b • y ∈ s

variables {𝕜 s}

lemma convex_iff_segment_subset :
  convex 𝕜 s ↔ ∀ ⦃x y⦄, x ∈ s → y ∈ s → [x -[𝕜] y] ⊆ s :=
forall₄_congr $ λ x y hx hy, (segment_subset_iff _).symm

lemma convex.segment_subset (h : convex 𝕜 s) {x y : E} (hx : x ∈ s) (hy : y ∈ s) :
  [x -[𝕜] y] ⊆ s :=
convex_iff_segment_subset.1 h hx hy

lemma convex.open_segment_subset (h : convex 𝕜 s) {x y : E} (hx : x ∈ s) (hy : y ∈ s) :
  open_segment 𝕜 x y ⊆ s :=
(open_segment_subset_segment 𝕜 x y).trans (h.segment_subset hx hy)

/-- Alternative definition of set convexity, in terms of pointwise set operations. -/
lemma convex_iff_pointwise_add_subset :
  convex 𝕜 s ↔ ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 → a • s + b • s ⊆ s :=
iff.intro
  begin
    rintro hA a b ha hb hab w ⟨au, bv, ⟨u, hu, rfl⟩, ⟨v, hv, rfl⟩, rfl⟩,
    exact hA hu hv ha hb hab
  end
  (λ h x y hx hy a b ha hb hab,
    (h ha hb hab) (set.add_mem_add ⟨_, hx, rfl⟩ ⟨_, hy, rfl⟩))

alias convex_iff_pointwise_add_subset ↔ convex.set_combo_subset _

lemma convex_empty : convex 𝕜 (∅ : set E) :=
λ x y, false.elim

lemma convex_univ : convex 𝕜 (set.univ : set E) := λ _ _ _ _ _ _ _ _ _, trivial

lemma convex.inter {t : set E} (hs : convex 𝕜 s) (ht : convex 𝕜 t) : convex 𝕜 (s ∩ t) :=
λ x y (hx : x ∈ s ∩ t) (hy : y ∈ s ∩ t) a b (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1),
  ⟨hs hx.left hy.left ha hb hab, ht hx.right hy.right ha hb hab⟩

lemma convex_sInter {S : set (set E)} (h : ∀ s ∈ S, convex 𝕜 s) : convex 𝕜 (⋂₀ S) :=
assume x y hx hy a b ha hb hab s hs,
h s hs (hx s hs) (hy s hs) ha hb hab

lemma convex_Inter {ι : Sort*} {s : ι → set E} (h : ∀ i : ι, convex 𝕜 (s i)) :
  convex 𝕜 (⋂ i, s i) :=
(sInter_range s) ▸ convex_sInter $ forall_range_iff.2 h

lemma convex.prod {s : set E} {t : set F} (hs : convex 𝕜 s) (ht : convex 𝕜 t) :
  convex 𝕜 (s ×ˢ t) :=
begin
  intros x y hx hy a b ha hb hab,
  apply mem_prod.2,
  exact ⟨hs (mem_prod.1 hx).1 (mem_prod.1 hy).1 ha hb hab,
        ht (mem_prod.1 hx).2 (mem_prod.1 hy).2 ha hb hab⟩
end

lemma convex_pi {ι : Type*} {E : ι → Type*} [Π i, add_comm_monoid (E i)]
  [Π i, has_scalar 𝕜 (E i)] {s : set ι} {t : Π i, set (E i)} (ht : ∀ i, convex 𝕜 (t i)) :
  convex 𝕜 (s.pi t) :=
λ x y hx hy a b ha hb hab i hi, ht i (hx i hi) (hy i hi) ha hb hab

lemma directed.convex_Union {ι : Sort*} {s : ι → set E} (hdir : directed (⊆) s)
  (hc : ∀ ⦃i : ι⦄, convex 𝕜 (s i)) :
  convex 𝕜 (⋃ i, s i) :=
begin
  rintro x y hx hy a b ha hb hab,
  rw mem_Union at ⊢ hx hy,
  obtain ⟨i, hx⟩ := hx,
  obtain ⟨j, hy⟩ := hy,
  obtain ⟨k, hik, hjk⟩ := hdir i j,
  exact ⟨k, hc (hik hx) (hjk hy) ha hb hab⟩,
end

lemma directed_on.convex_sUnion {c : set (set E)} (hdir : directed_on (⊆) c)
  (hc : ∀ ⦃A : set E⦄, A ∈ c → convex 𝕜 A) :
  convex 𝕜 (⋃₀c) :=
begin
  rw sUnion_eq_Union,
  exact (directed_on_iff_directed.1 hdir).convex_Union (λ A, hc A.2),
end

end has_scalar

section module
variables [module 𝕜 E] [module 𝕜 F] {s : set E}

lemma convex_iff_open_segment_subset :
  convex 𝕜 s ↔ ∀ ⦃x y⦄, x ∈ s → y ∈ s → open_segment 𝕜 x y ⊆ s :=
convex_iff_segment_subset.trans $ forall₄_congr $ λ x y hx hy,
  (open_segment_subset_iff_segment_subset hx hy).symm

lemma convex_iff_forall_pos :
  convex 𝕜 s ↔ ∀ ⦃x y⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1
  → a • x + b • y ∈ s :=
convex_iff_open_segment_subset.trans $ forall₄_congr $ λ x y hx hy,
  open_segment_subset_iff 𝕜

lemma convex_iff_pairwise_pos :
  convex 𝕜 s ↔ s.pairwise (λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ s) :=
begin
  refine convex_iff_forall_pos.trans ⟨λ h x hx y hy _, h hx hy, _⟩,
  intros h x y hx hy a b ha hb hab,
  obtain rfl | hxy := eq_or_ne x y,
  { rwa convex.combo_self hab },
  { exact h hx hy hxy ha hb hab },
end

protected lemma set.subsingleton.convex {s : set E} (h : s.subsingleton) : convex 𝕜 s :=
convex_iff_pairwise_pos.mpr (h.pairwise _)

lemma convex_singleton (c : E) : convex 𝕜 ({c} : set E) :=
subsingleton_singleton.convex

lemma convex.linear_image (hs : convex 𝕜 s) (f : E →ₗ[𝕜] F) : convex 𝕜 (f '' s) :=
begin
  intros x y hx hy a b ha hb hab,
  obtain ⟨x', hx', rfl⟩ := mem_image_iff_bex.1 hx,
  obtain ⟨y', hy', rfl⟩ := mem_image_iff_bex.1 hy,
  exact ⟨a • x' + b • y', hs hx' hy' ha hb hab, by rw [f.map_add, f.map_smul, f.map_smul]⟩,
end

lemma convex.is_linear_image (hs : convex 𝕜 s) {f : E → F} (hf : is_linear_map 𝕜 f) :
  convex 𝕜 (f '' s) :=
hs.linear_image $ hf.mk' f

lemma convex.linear_preimage {s : set F} (hs : convex 𝕜 s) (f : E →ₗ[𝕜] F) :
  convex 𝕜 (f ⁻¹' s) :=
begin
  intros x y hx hy a b ha hb hab,
  rw [mem_preimage, f.map_add, f.map_smul, f.map_smul],
  exact hs hx hy ha hb hab,
end

lemma convex.is_linear_preimage {s : set F} (hs : convex 𝕜 s) {f : E → F} (hf : is_linear_map 𝕜 f) :
  convex 𝕜 (f ⁻¹' s) :=
hs.linear_preimage $ hf.mk' f

lemma convex.add {t : set E} (hs : convex 𝕜 s) (ht : convex 𝕜 t) : convex 𝕜 (s + t) :=
by { rw ← add_image_prod, exact (hs.prod ht).is_linear_image is_linear_map.is_linear_map_add }

lemma convex.translate (hs : convex 𝕜 s) (z : E) : convex 𝕜 ((λ x, z + x) '' s) :=
begin
  intros x y hx hy a b ha hb hab,
  obtain ⟨x', hx', rfl⟩ := mem_image_iff_bex.1 hx,
  obtain ⟨y', hy', rfl⟩ := mem_image_iff_bex.1 hy,
  refine ⟨a • x' + b • y', hs hx' hy' ha hb hab, _⟩,
  rw [smul_add, smul_add, add_add_add_comm, ←add_smul, hab, one_smul],
end

/-- The translation of a convex set is also convex. -/
lemma convex.translate_preimage_right (hs : convex 𝕜 s) (z : E) : convex 𝕜 ((λ x, z + x) ⁻¹' s) :=
begin
  intros x y hx hy a b ha hb hab,
  have h := hs hx hy ha hb hab,
  rwa [smul_add, smul_add, add_add_add_comm, ←add_smul, hab, one_smul] at h,
end

/-- The translation of a convex set is also convex. -/
lemma convex.translate_preimage_left (hs : convex 𝕜 s) (z : E) : convex 𝕜 ((λ x, x + z) ⁻¹' s) :=
by simpa only [add_comm] using hs.translate_preimage_right z

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid β] [module 𝕜 β] [ordered_smul 𝕜 β]

lemma convex_Iic (r : β) : convex 𝕜 (Iic r) :=
λ x y hx hy a b ha hb hab,
calc
  a • x + b • y
      ≤ a • r + b • r
      : add_le_add (smul_le_smul_of_nonneg hx ha) (smul_le_smul_of_nonneg hy hb)
  ... = r : convex.combo_self hab _

lemma convex_Ici (r : β) : convex 𝕜 (Ici r) :=
@convex_Iic 𝕜 (order_dual β) _ _ _ _ r

lemma convex_Icc (r s : β) : convex 𝕜 (Icc r s) :=
Ici_inter_Iic.subst ((convex_Ici r).inter $ convex_Iic s)

lemma convex_halfspace_le {f : E → β} (h : is_linear_map 𝕜 f) (r : β) :
  convex 𝕜 {w | f w ≤ r} :=
(convex_Iic r).is_linear_preimage h

lemma convex_halfspace_ge {f : E → β} (h : is_linear_map 𝕜 f) (r : β) :
  convex 𝕜 {w | r ≤ f w} :=
(convex_Ici r).is_linear_preimage h

lemma convex_hyperplane {f : E → β} (h : is_linear_map 𝕜 f) (r : β) :
  convex 𝕜 {w | f w = r} :=
begin
  simp_rw le_antisymm_iff,
  exact (convex_halfspace_le h r).inter (convex_halfspace_ge h r),
end

end ordered_add_comm_monoid

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid β] [module 𝕜 β] [ordered_smul 𝕜 β]

lemma convex_Iio (r : β) : convex 𝕜 (Iio r) :=
begin
  intros x y hx hy a b ha hb hab,
  obtain rfl | ha' := ha.eq_or_lt,
  { rw zero_add at hab,
    rwa [zero_smul, zero_add, hab, one_smul] },
  rw mem_Iio at hx hy,
  calc
    a • x + b • y
        < a • r + b • r
        : add_lt_add_of_lt_of_le (smul_lt_smul_of_pos hx ha') (smul_le_smul_of_nonneg hy.le hb)
    ... = r : convex.combo_self hab _
end

lemma convex_Ioi (r : β) : convex 𝕜 (Ioi r) :=
@convex_Iio 𝕜 (order_dual β) _ _ _ _ r

lemma convex_Ioo (r s : β) : convex 𝕜 (Ioo r s) :=
Ioi_inter_Iio.subst ((convex_Ioi r).inter $ convex_Iio s)

lemma convex_Ico (r s : β) : convex 𝕜 (Ico r s) :=
Ici_inter_Iio.subst ((convex_Ici r).inter $ convex_Iio s)

lemma convex_Ioc (r s : β) : convex 𝕜 (Ioc r s) :=
Ioi_inter_Iic.subst ((convex_Ioi r).inter $ convex_Iic s)

lemma convex_halfspace_lt {f : E → β} (h : is_linear_map 𝕜 f) (r : β) :
  convex 𝕜 {w | f w < r} :=
(convex_Iio r).is_linear_preimage h

lemma convex_halfspace_gt {f : E → β} (h : is_linear_map 𝕜 f) (r : β) :
  convex 𝕜 {w | r < f w} :=
(convex_Ioi r).is_linear_preimage h

end ordered_cancel_add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid β] [module 𝕜 β] [ordered_smul 𝕜 β]

lemma convex_interval (r s : β) : convex 𝕜 (interval r s) :=
convex_Icc _ _

end linear_ordered_add_comm_monoid
end module
end add_comm_monoid

section linear_ordered_add_comm_monoid
variables [linear_ordered_add_comm_monoid E] [ordered_add_comm_monoid β] [module 𝕜 E]
  [ordered_smul 𝕜 E] {s : set E} {f : E → β}

lemma monotone_on.convex_le (hf : monotone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | f x ≤ r} :=
λ x y hx hy a b ha hb hab, ⟨hs hx.1 hy.1 ha hb hab,
  (hf (hs hx.1 hy.1 ha hb hab) (max_rec' s hx.1 hy.1) (convex.combo_le_max x y ha hb hab)).trans
    (max_rec' _ hx.2 hy.2)⟩

lemma monotone_on.convex_lt (hf : monotone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | f x < r} :=
λ x y hx hy a b ha hb hab, ⟨hs hx.1 hy.1 ha hb hab,
  (hf (hs hx.1 hy.1 ha hb hab) (max_rec' s hx.1 hy.1) (convex.combo_le_max x y ha hb hab)).trans_lt
    (max_rec' _ hx.2 hy.2)⟩

lemma monotone_on.convex_ge (hf : monotone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | r ≤ f x} :=
@monotone_on.convex_le 𝕜 (order_dual E) (order_dual β) _ _ _ _ _ _ _ hf.dual hs r

lemma monotone_on.convex_gt (hf : monotone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | r < f x} :=
@monotone_on.convex_lt 𝕜 (order_dual E) (order_dual β) _ _ _ _ _ _ _ hf.dual hs r

lemma antitone_on.convex_le (hf : antitone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | f x ≤ r} :=
@monotone_on.convex_ge 𝕜 E (order_dual β) _ _ _ _ _ _ _ hf hs r

lemma antitone_on.convex_lt (hf : antitone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | f x < r} :=
@monotone_on.convex_gt 𝕜 E (order_dual β) _ _ _ _ _ _ _ hf hs r

lemma antitone_on.convex_ge (hf : antitone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | r ≤ f x} :=
@monotone_on.convex_le 𝕜 E (order_dual β) _ _ _ _ _ _ _ hf hs r

lemma antitone_on.convex_gt (hf : antitone_on f s) (hs : convex 𝕜 s) (r : β) :
  convex 𝕜 {x ∈ s | r < f x} :=
@monotone_on.convex_lt 𝕜 E (order_dual β) _ _ _ _ _ _ _ hf hs r

lemma monotone.convex_le (hf : monotone f) (r : β) :
  convex 𝕜 {x | f x ≤ r} :=
set.sep_univ.subst ((hf.monotone_on univ).convex_le convex_univ r)

lemma monotone.convex_lt (hf : monotone f) (r : β) :
  convex 𝕜 {x | f x ≤ r} :=
set.sep_univ.subst ((hf.monotone_on univ).convex_le convex_univ r)

lemma monotone.convex_ge (hf : monotone f ) (r : β) :
  convex 𝕜 {x | r ≤ f x} :=
set.sep_univ.subst ((hf.monotone_on univ).convex_ge convex_univ r)

lemma monotone.convex_gt (hf : monotone f) (r : β) :
  convex 𝕜 {x | f x ≤ r} :=
set.sep_univ.subst ((hf.monotone_on univ).convex_le convex_univ r)

lemma antitone.convex_le (hf : antitone f) (r : β) :
  convex 𝕜 {x | f x ≤ r} :=
set.sep_univ.subst ((hf.antitone_on univ).convex_le convex_univ r)

lemma antitone.convex_lt (hf : antitone f) (r : β) :
  convex 𝕜 {x | f x < r} :=
set.sep_univ.subst ((hf.antitone_on univ).convex_lt convex_univ r)

lemma antitone.convex_ge (hf : antitone f) (r : β) :
  convex 𝕜 {x | r ≤ f x} :=
set.sep_univ.subst ((hf.antitone_on univ).convex_ge convex_univ r)

lemma antitone.convex_gt (hf : antitone f) (r : β) :
  convex 𝕜 {x | r < f x} :=
set.sep_univ.subst ((hf.antitone_on univ).convex_gt convex_univ r)

end linear_ordered_add_comm_monoid

section add_comm_group
variables [add_comm_group E] [module 𝕜 E] {s t : set E}

lemma convex.combo_eq_vadd {a b : 𝕜} {x y : E} (h : a + b = 1) :
  a • x + b • y = b • (y - x) + x :=
calc
  a • x + b • y = (b • y - b • x) + (a • x + b • x) : by abel
            ... = b • (y - x) + x                   : by rw [smul_sub, convex.combo_self h]

lemma convex.sub {s : set (E × E)} (hs : convex 𝕜 s) : convex 𝕜 ((λ x : E × E, x.1 - x.2) '' s) :=
hs.is_linear_image is_linear_map.is_linear_map_sub

lemma convex_segment (x y : E) : convex 𝕜 [x -[𝕜] y] :=
begin
  rintro p q ⟨ap, bp, hap, hbp, habp, rfl⟩ ⟨aq, bq, haq, hbq, habq, rfl⟩ a b ha hb hab,
  refine ⟨a * ap + b * aq, a * bp + b * bq,
    add_nonneg (mul_nonneg ha hap) (mul_nonneg hb haq),
    add_nonneg (mul_nonneg ha hbp) (mul_nonneg hb hbq), _, _⟩,
  { rw [add_add_add_comm, ←mul_add, ←mul_add, habp, habq, mul_one, mul_one, hab] },
  { simp_rw [add_smul, mul_smul, smul_add],
    exact add_add_add_comm _ _ _ _ }
end

lemma convex_open_segment (a b : E) : convex 𝕜 (open_segment 𝕜 a b) :=
begin
  rw convex_iff_open_segment_subset,
  rintro p q ⟨ap, bp, hap, hbp, habp, rfl⟩ ⟨aq, bq, haq, hbq, habq, rfl⟩ z ⟨a, b, ha, hb, hab, rfl⟩,
  refine ⟨a * ap + b * aq, a * bp + b * bq,
    add_pos (mul_pos ha hap) (mul_pos hb haq),
    add_pos (mul_pos ha hbp) (mul_pos hb hbq), _, _⟩,
  { rw [add_add_add_comm, ←mul_add, ←mul_add, habp, habq, mul_one, mul_one, hab] },
  { simp_rw [add_smul, mul_smul, smul_add],
    exact add_add_add_comm _ _ _ _ }
end

end add_comm_group
end ordered_semiring

section ordered_comm_semiring
variables [ordered_comm_semiring 𝕜]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F] [module 𝕜 E] [module 𝕜 F] {s : set E}

lemma convex.smul (hs : convex 𝕜 s) (c : 𝕜) : convex 𝕜 (c • s) :=
hs.linear_image (linear_map.lsmul _ _ c)

lemma convex.smul_preimage (hs : convex 𝕜 s) (c : 𝕜) : convex 𝕜 ((λ z, c • z) ⁻¹' s) :=
hs.linear_preimage (linear_map.lsmul _ _ c)

lemma convex.affinity (hs : convex 𝕜 s) (z : E) (c : 𝕜) : convex 𝕜 ((λ x, z + c • x) '' s) :=
begin
  have h := (hs.smul c).translate z,
  rwa [←image_smul, image_image] at h,
end

end add_comm_monoid
end ordered_comm_semiring

section ordered_ring
variables [ordered_ring 𝕜]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F] {s : set E}

lemma convex.add_smul_mem (hs : convex 𝕜 s) {x y : E} (hx : x ∈ s) (hy : x + y ∈ s)
  {t : 𝕜} (ht : t ∈ Icc (0 : 𝕜) 1) : x + t • y ∈ s :=
begin
  have h : x + t • y = (1 - t) • x + t • (x + y),
  { rw [smul_add, ←add_assoc, ←add_smul, sub_add_cancel, one_smul] },
  rw h,
  exact hs hx hy (sub_nonneg_of_le ht.2) ht.1 (sub_add_cancel _ _),
end

lemma convex.smul_mem_of_zero_mem (hs : convex 𝕜 s) {x : E} (zero_mem : (0 : E) ∈ s) (hx : x ∈ s)
  {t : 𝕜} (ht : t ∈ Icc (0 : 𝕜) 1) : t • x ∈ s :=
by simpa using hs.add_smul_mem zero_mem (by simpa using hx) ht

lemma convex.add_smul_sub_mem (h : convex 𝕜 s) {x y : E} (hx : x ∈ s) (hy : y ∈ s)
  {t : 𝕜} (ht : t ∈ Icc (0 : 𝕜) 1) : x + t • (y - x) ∈ s :=
begin
  apply h.segment_subset hx hy,
  rw segment_eq_image',
  exact mem_image_of_mem _ ht,
end

/-- Affine subspaces are convex. -/
lemma affine_subspace.convex (Q : affine_subspace 𝕜 E) : convex 𝕜 (Q : set E) :=
begin
  intros x y hx hy a b ha hb hab,
  rw [eq_sub_of_add_eq hab, ← affine_map.line_map_apply_module],
  exact affine_map.line_map_mem b hx hy,
end

/--
Applying an affine map to an affine combination of two points yields
an affine combination of the images.
-/
lemma convex.combo_affine_apply {a b : 𝕜} {x y : E} {f : E →ᵃ[𝕜] F} (h : a + b = 1) :
  f (a • x + b • y) = a • f x + b • f y :=
begin
  simp only [convex.combo_eq_vadd h, ← vsub_eq_sub],
  exact f.apply_line_map _ _ _,
end

/-- The preimage of a convex set under an affine map is convex. -/
lemma convex.affine_preimage (f : E →ᵃ[𝕜] F) {s : set F} (hs : convex 𝕜 s) :
  convex 𝕜 (f ⁻¹' s) :=
begin
  intros x y xs ys a b ha hb hab,
  rw [mem_preimage, convex.combo_affine_apply hab],
  exact hs xs ys ha hb hab,
end

/-- The image of a convex set under an affine map is convex. -/
lemma convex.affine_image (f : E →ᵃ[𝕜] F) {s : set E} (hs : convex 𝕜 s) :
  convex 𝕜 (f '' s) :=
begin
  rintro x y ⟨x', ⟨hx', hx'f⟩⟩ ⟨y', ⟨hy', hy'f⟩⟩ a b ha hb hab,
  refine ⟨a • x' + b • y', ⟨hs hx' hy' ha hb hab, _⟩⟩,
  rw [convex.combo_affine_apply hab, hx'f, hy'f]
end

lemma convex.neg (hs : convex 𝕜 s) : convex 𝕜 ((λ z, -z) '' s) :=
hs.is_linear_image is_linear_map.is_linear_map_neg

lemma convex.neg_preimage (hs : convex 𝕜 s) : convex 𝕜 ((λ z, -z) ⁻¹' s) :=
hs.is_linear_preimage is_linear_map.is_linear_map_neg

end add_comm_group
end ordered_ring

section linear_ordered_field
variables [linear_ordered_field 𝕜]

section add_comm_group
variables [add_comm_group E] [add_comm_group F] [module 𝕜 E] [module 𝕜 F] {s : set E}

/-- Alternative definition of set convexity, using division. -/
lemma convex_iff_div :
  convex 𝕜 s ↔ ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄,
    0 ≤ a → 0 ≤ b → 0 < a + b → (a / (a + b)) • x + (b / (a + b)) • y ∈ s :=
begin
  simp only [convex_iff_segment_subset, subset_def, mem_segment_iff_div],
  refine forall₄_congr (λ x y hx hy, ⟨λ H a b ha hb hab, H _ ⟨a, b, ha, hb, hab, rfl⟩, _⟩),
  rintro H _ ⟨a, b, ha, hb, hab, rfl⟩,
  exact H ha hb hab
end

lemma convex.mem_smul_of_zero_mem (h : convex 𝕜 s) {x : E} (zero_mem : (0 : E) ∈ s)
  (hx : x ∈ s) {t : 𝕜} (ht : 1 ≤ t) :
  x ∈ t • s :=
begin
  rw mem_smul_set_iff_inv_smul_mem₀ (zero_lt_one.trans_le ht).ne',
  exact h.smul_mem_of_zero_mem zero_mem hx ⟨inv_nonneg.2 (zero_le_one.trans ht), inv_le_one ht⟩,
end

lemma convex.add_smul (h_conv : convex 𝕜 s) {p q : 𝕜} (hp : 0 ≤ p) (hq : 0 ≤ q) :
  (p + q) • s = p • s + q • s :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { simp_rw [smul_set_empty, add_empty] },
  obtain rfl | hp' := hp.eq_or_lt,
  { rw [zero_add, zero_smul_set hs, zero_add] },
  obtain rfl | hq' := hq.eq_or_lt,
  { rw [add_zero, zero_smul_set hs, add_zero] },
  ext,
  split,
  { rintro ⟨v, hv, rfl⟩,
    exact ⟨p • v, q • v, smul_mem_smul_set hv, smul_mem_smul_set hv, (add_smul _ _ _).symm⟩ },
  { rintro ⟨v₁, v₂, ⟨v₁₁, h₁₂, rfl⟩, ⟨v₂₁, h₂₂, rfl⟩, rfl⟩,
    have hpq := add_pos hp' hq',
    exact mem_smul_set.2 ⟨_, h_conv h₁₂ h₂₂ (div_pos hp' hpq).le (div_pos hq' hpq).le
      (by rw [←div_self hpq.ne', add_div] : p / (p + q) + q / (p + q) = 1),
      by simp only [← mul_smul, smul_add, mul_div_cancel' _ hpq.ne']⟩ }
end

end add_comm_group
end linear_ordered_field

/-!
#### Convex sets in an ordered space
Relates `convex` and `ord_connected`.
-/

section

lemma set.ord_connected.convex_of_chain [ordered_semiring 𝕜] [ordered_add_comm_monoid E]
  [module 𝕜 E] [ordered_smul 𝕜 E] {s : set E} (hs : s.ord_connected) (h : zorn.chain (≤) s) :
  convex 𝕜 s :=
begin
  refine convex_iff_segment_subset.mpr (λ x y hx hy, _),
  obtain hxy | hyx := h.total_of_refl hx hy,
  { exact (segment_subset_Icc hxy).trans (hs.out hx hy) },
  { rw segment_symm,
    exact (segment_subset_Icc hyx).trans (hs.out hy hx) }
end

lemma set.ord_connected.convex [ordered_semiring 𝕜] [linear_ordered_add_comm_monoid E] [module 𝕜 E]
  [ordered_smul 𝕜 E] {s : set E} (hs : s.ord_connected) :
  convex 𝕜 s :=
hs.convex_of_chain (zorn.chain_of_trichotomous s)

lemma convex_iff_ord_connected [linear_ordered_field 𝕜] {s : set 𝕜} :
  convex 𝕜 s ↔ s.ord_connected :=
begin
  simp_rw [convex_iff_segment_subset, segment_eq_interval, ord_connected_iff_interval_subset],
  exact forall_congr (λ x, forall_swap)
end

alias convex_iff_ord_connected ↔ convex.ord_connected _

end

/-! #### Convexity of submodules/subspaces -/

section submodule
open submodule

lemma submodule.convex [ordered_semiring 𝕜] [add_comm_monoid E] [module 𝕜 E] (K : submodule 𝕜 E) :
  convex 𝕜 (↑K : set E) :=
by { repeat {intro}, refine add_mem _ (smul_mem _ _ _) (smul_mem _ _ _); assumption }

lemma subspace.convex [linear_ordered_field 𝕜] [add_comm_group E] [module 𝕜 E] (K : subspace 𝕜 E) :
  convex 𝕜 (↑K : set E) :=
K.convex

end submodule

/-! ### Simplex -/

section simplex

variables (𝕜) (ι : Type*) [ordered_semiring 𝕜] [fintype ι]

/-- The standard simplex in the space of functions `ι → 𝕜` is the set of vectors with non-negative
coordinates with total sum `1`. This is the free object in the category of convex spaces. -/
def std_simplex : set (ι → 𝕜) :=
{f | (∀ x, 0 ≤ f x) ∧ ∑ x, f x = 1}

lemma std_simplex_eq_inter :
  std_simplex 𝕜 ι = (⋂ x, {f | 0 ≤ f x}) ∩ {f | ∑ x, f x = 1} :=
by { ext f, simp only [std_simplex, set.mem_inter_eq, set.mem_Inter, set.mem_set_of_eq] }

lemma convex_std_simplex : convex 𝕜 (std_simplex 𝕜 ι) :=
begin
  refine λ f g hf hg a b ha hb hab, ⟨λ x, _, _⟩,
  { apply_rules [add_nonneg, mul_nonneg, hf.1, hg.1] },
  { erw [finset.sum_add_distrib, ← finset.smul_sum, ← finset.smul_sum, hf.2, hg.2,
      smul_eq_mul, smul_eq_mul, mul_one, mul_one],
    exact hab }
end

variable {ι}

lemma ite_eq_mem_std_simplex (i : ι) : (λ j, ite (i = j) (1:𝕜) 0) ∈ std_simplex 𝕜 ι :=
⟨λ j, by simp only; split_ifs; norm_num, by rw [finset.sum_ite_eq, if_pos (finset.mem_univ _)]⟩

end simplex


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

import algebra.big_operators.basic
import data.finset.option

/-!
# Lemmas about products and sums over finite sets in `option α`

In this file we prove formulas for products and sums over `finset.insert_none s` and
`finset.erase_none s`.
-/

open_locale big_operators
open function

namespace finset

variables {α M : Type*} [comm_monoid M]

@[simp, to_additive] lemma prod_insert_none (f : option α → M) (s : finset α) :
  ∏ x in s.insert_none, f x = f none * ∏ x in s, f (some x) :=
by simp [insert_none]

@[to_additive] lemma prod_erase_none (f : α → M) (s : finset (option α)) :
  ∏ x in s.erase_none, f x = ∏ x in s, option.elim x 1 f :=
by classical;
calc ∏ x in s.erase_none, f x = ∏ x in s.erase_none.map embedding.some, option.elim x 1 f :
  (prod_map s.erase_none embedding.some (λ x, option.elim x 1 f)).symm
... = ∏ x in s.erase none, option.elim x 1 f : by rw map_some_erase_none
... = ∏ x in s, option.elim x 1 f : prod_erase _ rfl

end finset


lemma succ_mul (a b : mynat) : succ a * b = a * b + b :=
begin
induction b with c hc,
repeat {rw mul_zero},
simp,
repeat {rw mul_succ},
rw hc,
repeat {rw add_succ},
simp,
end


import syntax
universe u

namespace logic
-- namespace semantics (have to figure out how to use nested namespaces properly)
open list tactic set

-- a structure for the language define by σ, with domain in type α.
structure signature.structure (σ : signature) (α : Type u) [nonempty α] :=
    -- functional interpretation
    (I₁ : Π {n}, σ.nary n → (fin n → α) → α)
    -- relational interpretation
    (I₂ : Π {n}, σ.nrary n → (fin n → α) → Prop)

-- type of variable assignments
def signature.vasgn (σ : signature) (α : Type u) := σ.vars → α

variables {σ : signature} {α : Type u} [nonempty α]

-- the reference of a term in a structure relative to an assignment.
def signature.structure.reference' (M : σ.structure α) : σ.term → σ.vasgn α → α
| (signature.term.var x) asg := asg x
| (@signature.term.app _ 0 f _) _ := M.I₁ f fin_zero_elim
| (@signature.term.app _  (n+1) f v) asg := let v₂ := λ k, signature.structure.reference' (v k) asg
                                    in M.I₁ f v₂

-- The reference of a denotative term is independent from an assignment.
-- Note: We adopt the convention that functions ending with '
-- depend on assignments, and others do not.
def signature.structure.reference (M : σ.structure α) : σ.hterm → α :=
    begin
        -- Although idk if it is a good idea to define functions using tactics.
        -- What happens if I unfold their definitions later?
        intro t,
        obtain ⟨t, den⟩ := t,
        induction t,
            simp [set_of] at den,
            revert den,
            dunfold signature.term.denotes signature.term.vars,
            intro den,
            replace den := eq_empty_iff_forall_not_mem.mp den,
            specialize den t,
            simp at den,
            contradiction,
        cases t_n,
            exact M.I₁ t_f fin_zero_elim,
        have den_v : ∀ x, (t_v x).denotes,
            intro x,
            simp [set_of] at den,
            revert den,
            dunfold signature.term.denotes signature.term.vars,
            simp,
            intro den,
            have c := set.subset_Union (signature.term.vars ∘ t_v) x,
            simp [den] at c,
            -- could have used the set lemma,
            -- but library search finished
            -- this one off.
            exact eq_bot_iff.mpr c,
        have ih := λ x, t_ih x (den_v x),
        exact M.I₁ t_f ih,
    end

-- bind the value of a variable to `val` in an assignment
-- (generates a new assignment).
def signature.vasgn.bind (ass : σ.vasgn α) (x : σ.vars) (val : α) : σ.vasgn α :=
    λy, if y = x then val else ass y

-- tells whether a formula is true in a structure, relative to
-- an assignment.
def signature.structure.satisfies' : σ.structure α →  σ.formula → σ.vasgn α → Prop
| M ( signature.formula.relational r v) asg :=
          M.I₂ r $ λm,  M.reference' (v m) asg
| M ( signature.formula.for_all x φ) ass :=
    ∀ (a : α), M.satisfies' φ (ass.bind x a)
| M ( signature.formula.if_then φ ψ) asg :=
    let x := M.satisfies' φ asg,
        y := M.satisfies' ψ asg
    in x → y
| M ( signature.formula.equation t₁ t₂) asg :=
    let x := M.reference' t₁ asg,
        y := M.reference' t₂ asg
    in x = y
| M  signature.formula.false _ := false

-- tells whether a formula is true in a structure, absolutely.
def signature.structure.satisfies : σ.structure α → σ.formula → Prop
| M φ := ∀ (ass : σ.vasgn α), M.satisfies' φ ass

-- will reserve ⊨ without subscript for
-- semantic consequence of theories.
local infixr `⊨₁`:55 := signature.structure.satisfies

-- so here is some easy corollary.
lemma false_is_unsat : ¬∃ M : σ.structure α, M ⊨₁  signature.formula.false :=
begin
    intro h,
    obtain ⟨M, h⟩ := h,
    apply nonempty.elim _inst_1,
    intro x,
    exact h (λ_, x),
end

-- tells whether a model satisfies a set of formulas.
-- Ended up being an useless definition so far.
def signature.structure.for : σ.structure α → set σ.formula → Prop
| M Γ := ∀ φ ∈ Γ, M ⊨₁ φ

variables (Γ : set σ.formula) (φ : σ.formula)

-- semantic consequence.
-- Tells whether φ is true in every model/assignment in which Γ is true.
-- Ended up being a complex definition because of the synthesizer/elaborator,
-- maybe we can simplify it later?
def signature.follows (σ : signature) (Γ : set σ.formula) (φ : σ.formula) : Prop :=
    ∀{α : Type u}[h : nonempty α] (M : @signature.structure σ α h) (ass : σ.vasgn α),
      (∀ ψ ∈ Γ, @signature.structure.satisfies' σ α h M ψ ass) → @signature.structure.satisfies' σ α h M φ ass

local infixr `⊨`:55 := signature.follows σ

-- Here we move closer to the proof itself.
-- In order to prove it we need to prove several
-- auxiliary lemmas:

lemma bind_symm : ∀ {ass : σ.vasgn α} {x y : σ.vars} {a b}, x ≠ y → (ass.bind x a).bind y b = (ass.bind y b).bind x a :=
    begin
        intros ass x y a b h,
        simp [signature.vasgn.bind],
        ext z,
        replace h := ne.symm h,
        by_cases eq : z = y;
            simp[eq, h],
    end

lemma bind₁ : ∀ {ass : σ.vasgn α} {x : σ.vars}, ass.bind x (ass x) = ass :=
    begin
        intros ass x,
        simp [signature.vasgn.bind],
        ext y,
        by_cases y = x;
        simp[h],
    end

lemma bind₂ : ∀ {ass : σ.vasgn α} {x : σ.vars} {a b}, (ass.bind x a).bind x b = ass.bind x b :=
    begin
        intros ass x a b,
        simp [signature.vasgn.bind],
        ext y,
        by_cases y = x;
        simp[h],
    end

lemma bind_term : ∀ {M : σ.structure α} {ass : σ.vasgn α} {x : σ.vars} {t : σ.term} {a},
                  x ∉ t.vars →
                  M.reference' t (signature.vasgn.bind ass x a) =
                  M.reference' t ass :=
begin
    intros M ass x t a,
    induction t;
    dunfold signature.term.vars;
    simp;
    intro h,
        dunfold signature.structure.reference' signature.vasgn.bind,
        simp [ne.symm h],
    cases t_n;
        dunfold signature.structure.reference';
        simp,
    congr,
    ext y,
    specialize h y,
    exact t_ih y h,
end

-- Some things to note here:
-- . It seems it would be impossible to prove this without generalizing the assignment in the induction.
-- . It seems it would be impossible to prove just one side of the ↔ alone.
-- . I've learned this the hard way.
lemma bind₃ : ∀ {M : σ.structure α} {φ: σ.formula}{ass : σ.vasgn α}{x : σ.vars}{a},
              x ∉ φ.free →
              (M.satisfies' φ (ass.bind x a) ↔
              M.satisfies' φ ass)
              :=
begin
    intros M φ ass x a,
    induction φ generalizing ass;
    dunfold  signature.formula.free signature.structure.satisfies';
    simp;
    intros h₀,
    swap 3,
    replace h₀ := not_or_distrib.mp h₀,
    obtain ⟨h₀, h₁⟩ := h₀,
    constructor;
    intros h₂ h₃;
    have ih₁ := @φ_ih_a ass h₀;
    have ih₂ := @φ_ih_a_1 ass h₁,
        replace ih₁ := ih₁.2 h₃,
        apply ih₂.mp,
        exact h₂ ih₁,
    replace ih₁ := ih₁.mp h₃,
    apply ih₂.2,
    exact h₂ ih₁,
    focus {
        constructor,
        all_goals{
            intro h₁,
            convert h₁,
            ext y,
            specialize h₀ y,
            revert h₀,
            induction φ_v y;
            dunfold signature.term.vars signature.structure.reference' signature.vasgn.bind;
            intro h₀,
                simp at h₀,
                replace h₀ := ne.symm h₀,
                simp [h₀],
            cases n;
                dunfold signature.structure.reference',
                refl,
            simp at *,
            congr,
            ext z,
            exact ih z (h₀ z),
        },
    },
    constructor;
    intro h₁;
    intro a₂;
    classical;
    all_goals{
        by_cases (x ∈ φ_a_1.free),
            specialize h₁ a₂,
            revert h₁,
            rw (h₀ h),
            rw bind₂,
            intro h₁,
            exact h₁,
        by_cases eq : x = φ_a,
            specialize h₁ a₂,
            revert h₁,
            rw eq,
            rw bind₂,
            intro h₁,
            exact h₁,
        specialize h₁ a₂,
    },
        rw bind_symm eq at h₁,
        exact (φ_ih h).mp h₁,
    rw bind_symm eq,
    exact (φ_ih h).2 h₁,
        push_neg at h₀,
        obtain ⟨h₀, h₁⟩ := h₀,
        rw [bind_term h₀, bind_term h₁],
end

-- Here is the most important lemma I suppose.
-- It's an easy corollary of the last one.
-- That one was hard.
lemma fundamental : ∀ y x (M : σ.structure α) ass, abstract_in y Γ →
            (∀ φ ∈ Γ, M.satisfies' φ ass) →
            ( ∀φ ∈ Γ, M.satisfies' φ (ass.bind y x))
            :=

begin
    intros y x M ass h₁ h₂ φ H,
    simp [abstract_in] at h₁,
    specialize h₁ φ H,
    specialize h₂ φ H,
    exact (bind₃ h₁).2 h₂,
end

lemma term_rw_semantics : ∀ {M : σ.structure α} {ass:σ.vasgn α} {x} {t₁ t₂ : σ.term},
                          M.reference' (t₁.rw x t₂) ass =
                          M.reference' t₁ (ass.bind x (M.reference' t₂ ass))
                          :=
begin
    intros M ass x t₁ t₂,
    induction t₁,
        dunfold signature.term.rw signature.structure.reference',
        by_cases x = t₁;
            simp [signature.vasgn.bind, h],
        dunfold signature.structure.reference',
        simp [ne.symm h],
    cases t₁_n;
        dunfold signature.term.rw signature.structure.reference';
        simp,
    congr,
    ext y,
    exact t₁_ih y,
end

lemma rw_semantics : ∀ {M : σ.structure α} {ass:σ.vasgn α} {x t} {φ: σ.formula},
                     φ.substitutable x t →
                     (M.satisfies' (φ.rw x t) ass ↔
                     M.satisfies' φ (ass.bind x (M.reference' t ass)))
                     :=
begin
    intros M ass x t φ,
    induction φ generalizing ass;
    dunfold  signature.formula.substitutable  signature.formula.rw signature.structure.satisfies';
    try{simp},
    focus {
        constructor;
        intro h,
        all_goals{
        convert h,
        ext y,
        induction φ_v y;
        dunfold signature.term.rw signature.structure.reference' signature.vasgn.bind,
            by_cases eq : a = x;
                simp [eq],
            replace eq := ne.symm eq,
            simp [eq],
            dunfold signature.structure.reference',
            refl,
        simp,
        cases n;
            dunfold signature.structure.reference';
            simp,
        congr,
        ext z,
        exact ih z,},
    },

    focus{
        intro h,
        by_cases c : φ_a = x,
            simp [c, bind₂],
        simp [c],
        cases h,
            revert h,
            dunfold  signature.formula.free,
            simp_intros h,
            classical,
            replace h : x ∉ φ_a_1.free,
                by_contradiction H,
                replace h := eq.symm (h H),
                contradiction,
            constructor; intros hyp a;
            specialize hyp a,
                rw formula_rw h t at hyp,
                rw bind_symm (ne.symm c),
                rwa bind₃ h,
            rw formula_rw h t,
            rw bind_symm (ne.symm c) at hyp,
            rwa bind₃ h at hyp,
        obtain ⟨h₁, h₂⟩ := h,
        constructor; intros hyp a;
        specialize hyp a;
        have ih := @φ_ih (signature.vasgn.bind ass φ_a a) h₂;
        rw bind_term h₁ at ih,
            rw bind_symm (ne.symm c),
            exact ih.mp hyp,
        rw bind_symm (ne.symm c) at hyp,
        apply ih.2,
        exact hyp,
    },
        intros sub₁ sub₂,
        constructor; intros h₁ h₂;
        have ih₁ := @φ_ih_a ass sub₁;
        have ih₂ := @φ_ih_a_1 ass sub₂,
            replace h₂ := ih₁.2 h₂,
            apply ih₂.mp,
            apply_assumption,
            exact h₂,
        replace h₂ := ih₁.mp h₂,
        apply ih₂.2,
        apply_assumption,
        exact h₂,
    simp [term_rw_semantics],
end

-- We will generalize this notation to a typeclass later.
-- For now it is a local notation in both modules.
local infixr `⊢`:55 := proof

-- And here is the proof itself.
-- It proceeds by induction on the proof Γ ⊢ φ.

-- So pretty.
theorem soundness : Γ ⊢ φ → Γ ⊨ φ :=
begin
    intros proof α ne M ass h,
    induction proof generalizing ass,
    -- case reflexivity
    exact h proof_φ proof_h,
    -- case transitivity
    apply proof_ih_h₂,
    intros ψ H,
    exact proof_ih_h₁ ψ H ass h,
    -- case modus ponens
    have c₁ := proof_ih_h₁ ass h,
    have c₂ := proof_ih_h₂ ass h,
    revert c₁,
    dunfold signature.structure.satisfies',
    simp,
    intro c₁,
    exact c₁ c₂,
    -- case intro
    intro h₂,
    have sat := proof_ih,
    apply sat,
    intros ψ H,
    cases H,
    exact h ψ H,
    simp at H,
    rwa H,
    -- case universal intro
    intro x,
    have c := @fundamental σ α ne proof_Γ proof_x x,
    specialize c M ass proof_abs h,
    have ih := proof_ih (@signature.vasgn.bind σ α ne ass proof_x x),
    apply ih,
    exact c,
    -- case universal elim
    have ih := proof_ih ass h,
    rename proof_sub sub,
    clear proof_ih,
    revert ih,
    dunfold signature.structure.satisfies',
    intro ih,
    set ref := @signature.structure.reference' σ α ne M proof_t ass,
    specialize ih ref,
    exact (@rw_semantics σ α ne M ass proof_x proof_t proof_φ sub).2 ih,
    -- case exfalso
    exfalso,
    have ih := proof_ih ass h,
    revert ih,
    dunfold signature.structure.satisfies',
    contradiction,
    -- case by contradiction
    classical,
    by_contradiction,
    have ih := proof_ih ass h,
    revert ih,
    dunfold  signature.formula.not signature.structure.satisfies',
    simp,
    intro ih,
    apply ih,
    intro insanity,
    contradiction,
    -- case identity intro
    dunfold signature.structure.satisfies',
    simp,
    -- case identity elimination
    have ih₁ := proof_ih_h ass h,
    have ih₂ := proof_ih_eq ass h,
    rename proof_sub₁ sub₁,
    rename proof_sub₂ sub₂,
    replace ih₁ := (@rw_semantics σ α ne M ass proof_x proof_t₁ proof_φ sub₁).mp ih₁,
    apply (rw_semantics sub₂).2,
    convert ih₁ using 2,
    revert ih₂,
    dunfold signature.structure.satisfies',
    simp,
    intro ih₂,
    rw ←ih₂,
end

instance inhabited_structure : inhabited (σ.structure unit) :=
⟨{ I₁ := λ _ _ _, unit.star,
  I₂ := λ _ _ _, true }⟩

theorem consistency : consistent (∅ : set σ.formula) :=
begin
    intro h,
    obtain ⟨x⟩ := h,
    have h := @soundness σ ∅ signature.formula.false x,
    revert h,
    dunfold signature.follows,
    simp,
    intro h,
    have M : σ.structure unit := default _,
    specialize @h unit unit.star M,
    apply @false_is_unsat σ unit,
    dunfold signature.structure.satisfies,
    existsi M,
    exact h,
end

-- end semantics
end logic


import convex face linalg
  linear_algebra.affine_space.affine_subspace
  analysis.normed_space.hahn_banach.separation
  analysis.inner_product_space.dual

open_locale pointwise
open_locale nnreal

def convex_body (V : Type)
[inner_product_space ℝ V] [finite_dimensional ℝ V] :=
{ K : set V // is_convex_body K }

variables {V: Type} [inner_product_space ℝ V] [finite_dimensional ℝ V]

lemma nonempty_of_convex_body {K : convex_body V} : K.val.nonempty :=
K.property.2.2

lemma bounded_of_convex_body {K : convex_body V} : metric.bounded K.val :=
(metric.compact_iff_closed_bounded.mp K.property.2.1).2

lemma closed_of_convex_body {K : convex_body V} : is_closed K.val :=
(metric.compact_iff_closed_bounded.mp K.property.2.1).1

def convex_body_subset (E : submodule ℝ V) (K : convex_body V) : Prop :=
K.val ⊆ (E : set V)

/- -- MOVETO convex.lean
lemma affine_image_convex {W : Type}
[inner_product_space ℝ W] [finite_dimensional ℝ W]
(f : V →ₗ[ℝ] W)
{A : set V}
(Acv : convex ℝ A) :
convex ℝ (f '' A) :=
begin

end -/

def proj_body
(E : submodule ℝ V)
(K : convex_body V) :
convex_body E :=
begin
  refine ⟨proj E '' K.val, _⟩,
  rcases K with ⟨Kset, Kcv, Kcp, Kne⟩,
  refine ⟨_, _, _⟩,
  {
    exact Kcv.linear_image (proj E),
  },
  {
    change is_compact (orthogonal_projection E '' Kset),
    exact Kcp.image (orthogonal_projection E).continuous,
  },
  {
    simpa only [set.nonempty_image_iff] using Kne,
  },
end

def proj_coll
(E : submodule ℝ V)
(C : multiset (convex_body V)) :
multiset (convex_body E) :=
C.map (proj_body E)

/- noncomputable def span_of_convex_body_amb {E : submodule ℝ V}
(K : convex_body_amb E) : submodule ℝ V :=
submodule.span ℝ K.val.val -/

noncomputable def span_of_convex_body
(K : convex_body V) : submodule ℝ V :=
vector_span ℝ K.val

noncomputable instance has_dist_convex_body : has_dist (convex_body V) :=
{
  dist := λ K L, metric.Hausdorff_dist K.val L.val,
}

lemma edist_body_ne_top {K L : convex_body V} :
emetric.Hausdorff_edist K.val L.val ≠ ⊤ :=
begin
  apply metric.Hausdorff_edist_ne_top_of_nonempty_of_bounded,
  any_goals {apply nonempty_of_convex_body},
  any_goals {apply bounded_of_convex_body},
end

noncomputable instance pmetric_convex_body : pseudo_metric_space (convex_body V) :=
{
  to_has_dist := has_dist_convex_body,
  dist_self := λ K, metric.Hausdorff_dist_self_zero,
  dist_comm := λ K L, metric.Hausdorff_dist_comm,
  dist_triangle := λ K L M, metric.Hausdorff_dist_triangle edist_body_ne_top,
}

noncomputable instance metric_convex_body : metric_space (convex_body V) :=
{
  to_pseudo_metric_space := pmetric_convex_body,
  eq_of_dist_eq_zero :=
  begin
    intros K L hd,
    apply subtype.coe_inj.mp,
    rw [←subtype.val_eq_coe, ←subtype.val_eq_coe],
    refine (emetric.Hausdorff_edist_zero_iff_eq_of_closed _ _).mp _,
    any_goals {exact closed_of_convex_body},
    replace hd := congr_arg ennreal.of_real hd,
    simpa only [dist, metric.Hausdorff_dist, ennreal.of_real_zero,
      ennreal.of_real_to_real edist_body_ne_top] using hd,
  end
}

lemma dist_body_eq_Hausdorff_edist
(K L: convex_body V) :
ennreal.of_real (dist K L) = emetric.Hausdorff_edist K.val L.val :=
begin
  simp only [dist, metric.Hausdorff_dist],
  rw [ennreal.of_real_to_real edist_body_ne_top],
end

lemma edist_body_eq_Hausdorff_edist
(K L : convex_body V) :
edist K L = emetric.Hausdorff_edist K.val L.val :=
begin
  simp only [edist, pseudo_metric_space.edist,
    metric.Hausdorff_dist],
  convert ennreal.of_real_to_real _,
  {
    simp only [max_eq_left, ennreal.to_real_nonneg],
  },
  {
    apply edist_body_ne_top,
  },
end

lemma Hausdorff_edist_dist
{A B : set V} (h : emetric.Hausdorff_edist A B ≠ ⊤) :
emetric.Hausdorff_edist A B =
ennreal.of_real (metric.Hausdorff_dist A B) :=
begin
  simp only [metric.Hausdorff_dist],
  rw [ennreal.of_real_to_real h],
end

lemma compact_convex_body {K : set V} (Kcb : is_convex_body K) :
is_compact K := Kcb.2.1

lemma nonempty_convex_body {K : set V} (Kcb : is_convex_body K) :
K.nonempty := Kcb.2.2

lemma zero_convex_body : is_convex_body ({0} : set V) :=
begin
  simp only [is_convex_body],
  repeat {split},
  {apply convex_singleton},
  {apply is_compact_singleton},
end

lemma sum_convex_body {K L : set V}
(Kbd : is_convex_body K) (Lbd : is_convex_body L) :
is_convex_body (K + L) :=
begin
  simp only [is_convex_body],
  refine ⟨_, _, _⟩,
  {
    apply convex_sum,
    all_goals {apply convex_convex_body, assumption},
  },
  {
    rw [←set.add_image_prod],
    apply is_compact.image_of_continuous_on,
    {
      apply is_compact.prod,
      all_goals {apply compact_convex_body, assumption},
    },
    {
      apply continuous.continuous_on,
      exact continuous_add,
    },
  },
  {
    apply set.add_nonempty.mpr,
    split,
    all_goals {apply nonempty_convex_body, assumption},
  },
end

instance convex_body_add_monoid :
add_comm_monoid (convex_body V) :=
{
  add := λ K L, ⟨K.val + L.val, sum_convex_body K.prop L.prop⟩,
  add_assoc :=
  begin
    intros K L M,
    apply subtype.coe_injective,
    simp only [add_assoc, subtype.coe_mk], -- why does it work here but not for add_comm?
  end,
  add_comm :=
  begin
    intros K L,
    apply subtype.coe_injective,
    change K.val + L.val = L.val + K.val, -- ugly
    simp only [add_comm],
  end,
  zero := ⟨{0}, zero_convex_body⟩,
  zero_add :=
  begin
    intro K,
    apply subtype.coe_injective,
    change 0 + K.val = K.val,
    simp only [zero_add],
  end,
  add_zero :=
  begin
    intro K,
    apply subtype.coe_injective,
    change K.val + 0 = K.val,
    simp only [add_zero],
  end,
}

instance : has_lift_t (convex_body V) (set V) :=
{
  lift := (coe : { K // is_convex_body K } → set V)
}

@[simp]
lemma convex_body.coe_add
{K L : convex_body V} :
(↑(K + L) : set V) = ↑K + ↑L := rfl

@[simp]
lemma convex_body.coe_zero :
(↑(0 : convex_body V) : set V) = (0 : set V) := rfl

instance convex_body_has_smul : has_smul ℝ≥0 (convex_body V) :=
{
  smul :=
  begin
    intros c K,
    refine ⟨c • K.val, _⟩,
    obtain ⟨Kcv, Kcp, Kne⟩ := K.property,
    refine ⟨_, _, _⟩,
    {
      apply Kcv.smul,
    },
    {
      simp only [has_smul.smul],
      simp only [has_smul.comp.smul, nnreal.coe_to_real_hom],
      refine Kcp.image _,
      by continuity,
    },
    {
      apply Kne.smul_set,
    },
  end,
}

@[simp]
lemma convex_body.coe_smul
{c : ℝ≥0} {K : convex_body V} :
(↑(c • K) : set V) = c • ↑K := rfl

instance convex_body_mul_action : mul_action ℝ≥0 (convex_body V) :=
{
  to_has_smul := convex_body_has_smul,
  one_smul :=
  begin
    intro K,
    simp only [has_smul.smul, subtype.val_eq_coe, has_smul.comp.smul, nnreal.coe_to_real_hom, nonneg.coe_one, one_smul,
    set.image_id', subtype.coe_eta],
  end,
  mul_smul :=
  begin
    intros c d K,
    simp only [has_smul.smul],
    simp only [has_smul.comp.smul, nnreal.coe_to_real_hom, nonneg.coe_mul, set.image_smul, subtype.val_eq_coe, subtype.mk_eq_mk],
    simp only [smul_smul],
  end
}

instance convex_body_distrib_mul_action : distrib_mul_action ℝ≥0 (convex_body V) :=
{
  to_mul_action := convex_body_mul_action,
  smul_add :=
  begin
    intros c K L,
    simp only [has_smul.smul],
    simp only [has_smul.comp.smul, nnreal.coe_to_real_hom, set.image_smul, subtype.val_eq_coe, convex_body.coe_add, smul_add],
    simp only [subtype.ext_iff],
    simp only [convex_body.coe_add, subtype.coe_mk],
  end,
  smul_zero :=
  begin
    intros c,
    simp only [subtype.ext_iff, convex_body.coe_smul, convex_body.coe_zero, smul_zero],
  end
}

instance convex_body_module : module ℝ≥0 (convex_body V) :=
{
  to_distrib_mul_action := convex_body_distrib_mul_action,
  add_smul :=
  begin
    intros c d K,
    simp only [subtype.ext_iff, convex_body.coe_smul, convex_body.coe_add],
    simp only [has_smul.smul],
    ext,
    simp only [set.mem_image, set.mem_add],
    split,
    {
      rintro ⟨x, xK, rfl⟩,
      refine ⟨c • x, d • x, ⟨x, _, rfl⟩, ⟨x, _, rfl⟩, _⟩,
      {assumption}, {assumption},
      simp only [add_smul, has_smul.comp.smul, nnreal.coe_to_real_hom, nonneg.coe_add],
      refl,
    },
    {
      rintro ⟨cx, cy, ⟨x, hx, rfl⟩, ⟨x', hx', rfl⟩, rfl⟩,
      by_cases h : c = 0 ∧ d = 0,
      {
        simp only [h.1, h.2, add_zero, has_smul.comp.smul, nnreal.coe_to_real_hom, nonneg.coe_zero, zero_smul,
        eq_self_iff_true, and_true],
        exact ⟨x, hx⟩,
      },
      {
        have : c + d > 0,
        {
          by_contra hc,
          push_neg at hc,
          rw [←bot_eq_zero, le_bot_iff, bot_eq_zero] at hc,
          simp only [add_eq_zero_iff] at hc,
          exact h hc,
        },
        replace : (↑c : ℝ) + ↑d > 0 := this,
        simp only [has_smul.comp.smul, nnreal.coe_to_real_hom, nonneg.coe_add],
        refine ⟨(c / (c + d)) • x + (d / (c + d)) • x', _⟩,
        have ha : (c + d) • (c / (c + d)) • x = x,
        {
          admit,
        },
        have hb : (c + d) • (d / (c + d)) • x' = x',
        {
          admit,
        },
        refine ⟨_, _⟩,
        {
          apply K.property.1 hx hx',
          any_goals {apply nnreal.coe_nonneg},
          rw [←map_add],
          simp only [nnreal.coe_to_real_hom, nonneg.coe_add, nonneg.coe_div],
          rw [←add_div, div_self (ne_of_gt this)],
        },
        {
          rw [smul_add],
          simp only [nnreal.smul_def, nonneg.coe_div, nonneg.coe_add],
          simp only [smul_smul, mul_div_cancel' _ (ne_of_gt this)],
        },
      },
    },
  end,
  zero_smul :=
  begin
    intro K,
    apply subtype.coe_injective,
    simp only [convex_body.coe_smul, convex_body.coe_zero],
    rw [←subtype.val_eq_coe, set.zero_smul_set K.property.2.2],
  end
}

instance convex_body_has_singleton : has_singleton V (convex_body V) :=
{
  singleton :=
  begin
    intro x,
    refine ⟨{x}, _, _, _⟩,
    {
      exact convex_singleton x,
    },
    {
      exact is_compact_singleton,
    },
    {
      exact set.singleton_nonempty x,
    },
  end
}

@[simp]
lemma convex_body.coe_singleton
(x : V) :
(↑({x} : convex_body V) : set V) = {x} := rfl

lemma coe_zero_body_eq : (coe (0 : convex_body V) : set V) = ({0} : set V) :=
rfl

lemma convex_body.is_closed (K : convex_body V) : is_closed K.val :=
closed_of_convex_body

lemma convex_body.nonempty (K : convex_body V) : K.val.nonempty :=
nonempty_of_convex_body

noncomputable def convex_body.supp (K : convex_body V) (u : V) : ℝ :=
Sup (flip inner u '' K.val)

lemma convex_body.exists_inner_eq_supp (K : convex_body V) (u : V) :
∃ x : V, x ∈ K.val ∧ ⟪x, u⟫_ℝ = K.supp u :=
begin
  rcases K with ⟨Kset, Kcv, Kcp, Kne⟩,
  have := (Kcp.image (inner_left_continuous u)).Sup_mem (set.nonempty.image _ Kne),
  simpa only [set.mem_image] using this,
end

lemma convex_body.mem_normal_face_of_inner_eq_supp (K : convex_body V) (u : V)
{x : V} (xK : x ∈ K.val) (hx : ⟪x, u⟫_ℝ = K.supp u) :
x ∈ normal_face K.val u :=
begin
  rw [mem_normal_face],
  refine ⟨xK, _⟩,
  intros y yK,
  have : ⟪y, u⟫_ℝ ∈ (flip inner u) '' K.val,
  {
    rw [set.mem_image],
    exact ⟨y, yK, rfl⟩,
  },
  rcases K with ⟨Kset, Kcv, Kcp, Kne⟩,
  refine le_trans (le_cSup (Kcp.image (inner_left_continuous u)).bdd_above this) _,
  rw [hx],
  refl,
end

lemma convex_body.normal_face_supp (K : convex_body V) (u : V) :
normal_face K.val u = { x : V | x ∈ K.val ∧ ⟪x, u⟫_ℝ = K.supp u } :=
begin
  ext, split,
  {
    intro h,
    refine ⟨_, _⟩,
    {
      exact normal_face_subset h,
    },
    {
      rcases K.exists_inner_eq_supp u with
        ⟨y, yK, hy⟩,
      rw [←hy],
      apply inner_eq_of_mem_normal_face h,
      exact K.mem_normal_face_of_inner_eq_supp u yK hy,
    },
  },
  {
    rintro ⟨xK, hx⟩,
    exact K.mem_normal_face_of_inner_eq_supp u xK hx,
  },
end

def convex_body.normal_face_nonempty (K : convex_body V) (u : V) :
(normal_face K.val u).nonempty :=
begin
  rcases K.exists_inner_eq_supp u with ⟨x, xK, hx⟩,
  refine ⟨x, _⟩,
  exact K.mem_normal_face_of_inner_eq_supp u xK hx,
end

def convex_body.normal_face (K : convex_body V) (u : V) : convex_body V :=
begin
  refine ⟨normal_face K.val u, _⟩,
  rcases K with ⟨Kset, Kcv, Kcp, Kne⟩,
  have isface : is_face Kset (normal_face Kset u) :=
    normal_face_is_face Kcv _,
  refine ⟨_, _, _⟩,
  {
    exact face_convex isface,
  },
  {
    apply compact_of_is_closed_subset Kcp,
    {
      exact face_closed Kcp.is_closed isface,
    },
    {
      exact normal_face_subset,
    },
  },
  {
    exact convex_body.normal_face_nonempty _ _,
  },
end

lemma convex_body.supp_exists_mem_face (K : convex_body V) (u : V) :
∃ x ∈ normal_face K.val u, ⟪x, u⟫_ℝ = K.supp u :=
begin
  rcases K.exists_inner_eq_supp u with ⟨x, xK, hx⟩,
  refine ⟨x, _, hx⟩,
  apply K.mem_normal_face_of_inner_eq_supp u xK hx,
end

lemma convex_body.inner_le_supp (K : convex_body V) {u : V} {x : V}
(xK : x ∈ K.val) :
⟪x, u⟫_ℝ ≤ K.supp u :=
begin
  obtain ⟨y, yKu, ye⟩ := K.supp_exists_mem_face u,
  rw [←ye],
  rw [mem_normal_face] at yKu,
  exact yKu.2 x xK,
end

lemma convex_body.subset_of_supp_le (K L : convex_body V) :
K.supp ≤ L.supp → K.val ⊆ L.val :=
begin
  intros h x xK,
  rw [pi.le_def] at h,
  by_contradiction hc,
  let L' := L,
  rcases L with ⟨Lset, Lcv, Lcp, Lne⟩,
  rcases geometric_hahn_banach_point_closed Lcv Lcp.is_closed hc
    with ⟨f, ν, h₁, h₂⟩,
  let g := -f,
  let u := (inner_product_space.to_dual ℝ _).inv_fun g,
  rcases L'.supp_exists_mem_face u with ⟨y, fy, hy⟩,
  rw [real_inner_comm, ←inner_product_space.to_dual_apply] at hy,
  simp only [u] at hy,
  simp only [linear_equiv.inv_fun_eq_symm, linear_isometry_equiv.to_linear_equiv_symm, linear_isometry_equiv.coe_to_linear_equiv,
  linear_isometry_equiv.apply_symm_apply] at hy,
  change g y = L'.supp u at hy,
  replace h₂ := h₂ y (normal_face_subset fy),
  --replace hy := congr_arg has_neg.neg hy,
  --simp only [continuous_linear_map.neg_apply, neg_neg] at hy,
  rw [←neg_lt_neg_iff] at h₂,
  simp only [continuous_linear_map.neg_apply] at hy,
  simp only [hy, L'] at h₂,
  replace h₂ := lt_of_le_of_lt (h _) h₂,
  rcases K.supp_exists_mem_face u with ⟨z, fz, hz⟩,
  rw [←hz] at h₂,
  rw [mem_normal_face] at fz,
  replace fz := fz.2 x xK,
  have : f x = -⟪x, u⟫_ℝ,
  {
    simp only [u, linear_equiv.inv_fun_eq_symm, linear_isometry_equiv.to_linear_equiv_symm,
  linear_isometry_equiv.coe_to_linear_equiv, map_neg, inner_neg_right, neg_neg],
    rw [real_inner_comm, inner_product_space.to_dual_symm_apply],
  },
  rw [this] at h₁,
  linarith,
end

lemma convex_body.supp_injective (K L : convex_body V) :
K.supp = L.supp → K = L :=
begin
  intro h,
  apply subtype.coe_injective,
  apply subset_antisymm,
  all_goals {
    refine convex_body.subset_of_supp_le _ _ _,
    rw [h],
    exact le_refl _,
  },
end

lemma convex_body.proj_supp (K : convex_body V) (E : submodule ℝ V) :
(proj_body E K).supp = λ u, K.supp u :=
begin
  funext u,
  rcases K.supp_exists_mem_face u with ⟨x, fx, hx⟩,
  rcases (proj_body E K).supp_exists_mem_face u with ⟨y, fy, hy⟩,
  rcases normal_face_subset fy with ⟨z, zK, rfl⟩,
  rw [←hx, ←hy],
  apply le_antisymm,
  {
    rw [submodule.coe_inner, inner_orthogonal_eq_inner],
    rw [mem_normal_face] at fx,
    exact fx.2 _ zK,
  },
  {
    rw [←inner_orthogonal_eq_inner],
    exact fy.2 _ ⟨x, normal_face_subset fx, rfl⟩,
  },
end

@[simp]
lemma normal_face_normalize
(K : convex_body V) (u : V) :
↑(K.normal_face u) = normal_face ↑K u :=
begin
  simp only [convex_body.normal_face, subtype.val_eq_coe, subtype.coe_mk],
end

@[simp]
lemma normal_face_add
(K L : convex_body V) (u : V) :
(K + L).normal_face u = K.normal_face u + L.normal_face u :=
begin
  ext,
  simp only [convex_body.normal_face],
  simp only [subtype.val_eq_coe, subtype.coe_mk, mem_normal_face],
  split,
  {
    simp only [and_imp],
    rintro ⟨y, z, hy, hz, rfl⟩ h,
    refine ⟨y, z, _, _, rfl⟩,
    {
      rw [subtype.val_eq_coe, subtype.coe_mk, mem_normal_face],
      refine ⟨by assumption, _⟩,
      intros w hw,
      have := h (w + z) ⟨w, z, hw, hz, rfl⟩,
      simpa only [inner_add_left, ge_iff_le, add_le_add_iff_right] using this,
    },
    {
      rw [subtype.val_eq_coe, subtype.coe_mk, mem_normal_face],
      refine ⟨by assumption, _⟩,
      intros w hw,
      have := h (y + w) ⟨y, w, hy, hw, rfl⟩,
      simpa only [inner_add_left, ge_iff_le, add_le_add_iff_left] using this,
    },
  },
  {
    rintro ⟨y, z, hy, hz, rfl⟩,
    simp only [mem_normal_face] at hy hz,
    refine ⟨⟨y, z, hy.1, hz.1, rfl⟩, _⟩,
    rintro - ⟨a, b, ha, hb, rfl⟩,
    simp only [inner_add_left],
    exact add_le_add (hy.2 a ha) (hz.2 b hb),
  },
end

@[simp]
lemma normal_face_add'
(K L : convex_body V) (u : V) :
normal_face ↑(K + L) u = normal_face ↑K u + normal_face ↑L u :=
begin
  have := normal_face_add K L u,
  replace this := congr_arg (coe : convex_body V → set V) this,
  exact this,
end

@[simp]
lemma normal_face_idem'
(K : convex_body V) (u : V) :
normal_face (normal_face ↑K u) u = normal_face ↑K u :=
begin
  ext,
  simp only [mem_normal_face, ge_iff_le, and_imp, and_iff_left_iff_imp],
  intros xK hx y yK hy,
  exact hx y yK,
end

/- noncomputable def convex_body_to_positive_homogeneous : convex_body V →+ (V → ℝ) :=
{
  to_fun := λ K, finite_support_function K.prop,
  map_zero' :=
  begin
    simp only [finite_support_function, support_function, coe_zero_body_eq, supr_unique, set.default_coe_singleton, inner_zero_left,
  ereal.coe_zero, ereal.to_real_zero],
  funext,
  simp only [pi.zero_apply],
  end,
  map_add' :=
  begin
    simp only [finite_support_function, support_function],
    intros K L,
    funext,
    simp only [subtype.val_eq_coe, pi.add_apply],
    sorry,
  end
} -/


/-
Copyright (c) 2020 Jean Lo. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jean Lo

! This file was ported from Lean 3 source module dynamics.flow
! leanprover-community/mathlib commit 717c073262cd9d59b1a1dcda7e8ab570c5b63370
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Algebra.Group.Basic
import Mathlib.Logic.Function.Iterate

/-!
# Flows and invariant sets

This file defines a flow on a topological space `α` by a topological
monoid `τ` as a continuous monoid-act of `τ` on `α`. Anticipating the
cases where `τ` is one of `ℕ`, `ℤ`, `ℝ⁺`, or `ℝ`, we use additive
notation for the monoids, though the definition does not require
commutativity.

A subset `s` of `α` is invariant under a family of maps `ϕₜ : α → α`
if `ϕₜ s ⊆ s` for all `t`. In many cases `ϕ` will be a flow on
`α`. For the cases where `ϕ` is a flow by an ordered (additive,
commutative) monoid, we additionally define forward invariance, where
`t` ranges over those elements which are nonnegative.

Additionally, we define such constructions as the restriction of a
flow onto an invariant subset, and the time-reveral of a flow by a
group.
-/

open Set Function Filter

/-!
### Invariant sets
-/

section Invariant

variable {τ : Type _} {α : Type _}

/-- A set `s ⊆ α` is invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t` in `τ`. -/
def IsInvariant (ϕ : τ → α → α) (s : Set α) : Prop :=
  ∀ t, MapsTo (ϕ t) s s
#align is_invariant IsInvariant

variable (ϕ : τ → α → α) (s : Set α)

theorem isInvariant_iff_image : IsInvariant ϕ s ↔ ∀ t, ϕ t '' s ⊆ s := by
  simp_rw [IsInvariant, mapsTo']
#align is_invariant_iff_image isInvariant_iff_image

/-- A set `s ⊆ α` is forward-invariant under `ϕ : τ → α → α` if
    `ϕ t s ⊆ s` for all `t ≥ 0`. -/
def IsFwInvariant [Preorder τ] [Zero τ] (ϕ : τ → α → α) (s : Set α) : Prop :=
  ∀ ⦃t⦄, 0 ≤ t → MapsTo (ϕ t) s s
#align is_fw_invariant IsFwInvariant

theorem IsInvariant.isFwInvariant [Preorder τ] [Zero τ] {ϕ : τ → α → α} {s : Set α}
    (h : IsInvariant ϕ s) : IsFwInvariant ϕ s := fun t _ht => h t
#align is_invariant.is_fw_invariant IsInvariant.isFwInvariant

/-- If `τ` is a `CanonicallyOrderedAddMonoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`IsFwInvariant` and `IsInvariant` are equivalent. -/
theorem IsFwInvariant.isInvariant [CanonicallyOrderedAddMonoid τ] {ϕ : τ → α → α} {s : Set α}
    (h : IsFwInvariant ϕ s) : IsInvariant ϕ s := fun t => h (zero_le t)
#align is_fw_invariant.is_invariant IsFwInvariant.isInvariant

/-- If `τ` is a `CanonicallyOrderedAddMonoid` (e.g., `ℕ` or `ℝ≥0`), then the notions
`IsFwInvariant` and `IsInvariant` are equivalent. -/
theorem isFwInvariant_iff_isInvariant [CanonicallyOrderedAddMonoid τ] {ϕ : τ → α → α} {s : Set α} :
    IsFwInvariant ϕ s ↔ IsInvariant ϕ s :=
  ⟨IsFwInvariant.isInvariant, IsInvariant.isFwInvariant⟩
#align is_fw_invariant_iff_is_invariant isFwInvariant_iff_isInvariant

end Invariant

/-!
### Flows
-/

/-- A flow on a topological space `α` by an a additive topological
    monoid `τ` is a continuous monoid action of `τ` on `α`.-/
structure Flow (τ : Type _) [TopologicalSpace τ] [AddMonoid τ] [ContinuousAdd τ] (α : Type _)
  [TopologicalSpace α] where
  toFun : τ → α → α
  cont' : Continuous (uncurry toFun)
  map_add' : ∀ t₁ t₂ x, toFun (t₁ + t₂) x = toFun t₁ (toFun t₂ x)
  map_zero' : ∀ x, toFun 0 x = x
#align flow Flow

namespace Flow

variable {τ : Type _} [AddMonoid τ] [TopologicalSpace τ] [ContinuousAdd τ] {α : Type _}
  [TopologicalSpace α] (ϕ : Flow τ α)

instance : Inhabited (Flow τ α) :=
  ⟨{  toFun := fun _ x => x
      cont' := continuous_snd
      map_add' := fun _ _ _ => rfl
      map_zero' := fun _ => rfl }⟩

instance : CoeFun (Flow τ α) fun _ => τ → α → α := ⟨Flow.toFun⟩

@[ext]

@[continuity]
protected theorem continuous {β : Type _} [TopologicalSpace β] {t : β → τ} (ht : Continuous t)
    {f : β → α} (hf : Continuous f) : Continuous fun x => ϕ (t x) (f x) :=
  ϕ.cont'.comp (ht.prod_mk hf)
#align flow.continuous Flow.continuous

alias Flow.continuous ← _root_.Continuous.flow
#align continuous.flow Continuous.flow

theorem map_add (t₁ t₂ : τ) (x : α) : ϕ (t₁ + t₂) x = ϕ t₁ (ϕ t₂ x) := ϕ.map_add' _ _ _
#align flow.map_add Flow.map_add

@[simp]
theorem map_zero : ϕ 0 = id := funext ϕ.map_zero'
#align flow.map_zero Flow.map_zero

theorem map_zero_apply (x : α) : ϕ 0 x = x := ϕ.map_zero' x
#align flow.map_zero_apply Flow.map_zero_apply

/-- Iterations of a continuous function from a topological space `α`
    to itself defines a semiflow by `ℕ` on `α`. -/
def fromIter {g : α → α} (h : Continuous g) : Flow ℕ α where
  toFun n x := (g^[n]) x
  cont' := continuous_uncurry_of_discreteTopology_left (Continuous.iterate h)
  map_add' := iterate_add_apply _
  map_zero' _x := rfl
#align flow.from_iter Flow.fromIter

/-- Restriction of a flow onto an invariant set. -/
def restrict {s : Set α} (h : IsInvariant ϕ s) : Flow τ (↥s) where
  toFun t := (h t).restrict _ _ _
  cont' := (ϕ.continuous continuous_fst continuous_subtype_val.snd').subtype_mk _
  map_add' _ _ _ := Subtype.ext (map_add _ _ _ _)
  map_zero' _ := Subtype.ext (map_zero_apply _ _)
#align flow.restrict Flow.restrict

end Flow

namespace Flow

variable {τ : Type _} [AddCommGroup τ] [TopologicalSpace τ] [TopologicalAddGroup τ] {α : Type _}
  [TopologicalSpace α] (ϕ : Flow τ α)

theorem isInvariant_iff_image_eq (s : Set α) : IsInvariant ϕ s ↔ ∀ t, ϕ t '' s = s :=
  (isInvariant_iff_image _ _).trans
    (Iff.intro
      (fun h t => Subset.antisymm (h t) fun _ hx => ⟨_, h (-t) ⟨_, hx, rfl⟩, by simp [← map_add]⟩)
      fun h t => by rw [h t])
#align flow.is_invariant_iff_image_eq Flow.isInvariant_iff_image_eq

/-- The time-reversal of a flow `ϕ` by a (commutative, additive) group
    is defined `ϕ.reverse t x = ϕ (-t) x`. -/
def reverse : Flow τ α where
  toFun t := ϕ (-t)
  cont' := ϕ.continuous continuous_fst.neg continuous_snd
  map_add' _ _ _ := by dsimp; rw [neg_add, map_add]
  map_zero' _ := by dsimp; rw [neg_zero, map_zero_apply]
#align flow.reverse Flow.reverse

-- Porting note: add @continuity to Flow.toFun so that these works:
-- Porting note: Homeomorphism.continuous_toFun  : Continuous toFun  := by continuity
-- Porting note: Homeomorphism.continuous_invFun : Continuous invFun := by continuity
@[continuity]
theorem continuous_toFun (t : τ) : Continuous (ϕ.toFun t) := by
  rw [←curry_uncurry ϕ.toFun]
  apply continuous_curry
  exact ϕ.cont'

/-- The map `ϕ t` as a homeomorphism. -/
def toHomeomorph (t : τ) : (α ≃ₜ α) where
  toFun := ϕ t
  invFun := ϕ (-t)
  left_inv x := by rw [← map_add, neg_add_self, map_zero_apply]
  right_inv x := by rw [← map_add, add_neg_self, map_zero_apply]
#align flow.to_homeomorph Flow.toHomeomorph

theorem image_eq_preimage (t : τ) (s : Set α) : ϕ t '' s = ϕ (-t) ⁻¹' s :=
  (ϕ.toHomeomorph t).toEquiv.image_eq_preimage s
#align flow.image_eq_preimage Flow.image_eq_preimage

end Flow


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import data.finset.lattice
import data.set.pairwise
import order.preorder_hom

/-!
# The monotone sequence of partial supremums of a sequence

We define `partial_sups : (ℕ → α) → ℕ →ₘ α` inductively. For `f : ℕ → α`, `partial_sups f` is
the sequence `f 0 `, `f 0 ⊔ f 1`, `f 0 ⊔ f 1 ⊔ f 2`, ... The point of this definition is that
* it doesn't need a `⨆`, as opposed to `⨆ (i ≤ n), f i`.
* it doesn't need a `⊥`, as opposed to `(finset.range (n + 1)).sup f`.
* it avoids needing to prove that `finset.range (n + 1)` is nonempty to use `finset.sup'`.

Equivalence with those definitions is shown by `partial_sups_eq_bsupr`, `partial_sups_eq_sup_range`,
`partial_sups_eq_sup'_range` and respectively.

## Notes

One might dispute whether this sequence should start at `f 0` or `⊥`. We choose the former because :
* Starting at `⊥` requires... having a bottom element.
* `λ f n, (finset.range n).sup f` is already effectively the sequence starting at `⊥`.
* If we started at `⊥` we wouldn't have the Galois insertion. See `partial_sups.gi`.

## TODO

One could generalize `partial_sups` to any locally finite bot preorder domain, in place of `ℕ`.
Necessary for the TODO in the module docstring of `order.disjointed`.
-/

variables {α : Type*}

section semilattice_sup
variables [semilattice_sup α]

/-- The monotone sequence whose value at `n` is the supremum of the `f m` where `m ≤ n`. -/
def partial_sups (f : ℕ → α) : ℕ →ₘ α :=
⟨@nat.rec (λ _, α) (f 0) (λ (n : ℕ) (a : α), a ⊔ f (n + 1)),
  monotone_nat_of_le_succ (λ n, le_sup_left)⟩

@[simp] lemma partial_sups_zero (f : ℕ → α) : partial_sups f 0 = f 0 := rfl
@[simp] lemma partial_sups_succ (f : ℕ → α) (n : ℕ) :
  partial_sups f (n + 1) = partial_sups f n ⊔ f (n + 1) := rfl

lemma le_partial_sups_of_le (f : ℕ → α) {m n : ℕ} (h : m ≤ n) :
  f m ≤ partial_sups f n :=
begin
  induction n with n ih,
  { cases h, apply le_refl, },
  { cases h with h h,
    { exact le_sup_right, },
    { exact (ih h).trans le_sup_left, } },
end

lemma le_partial_sups (f : ℕ → α) :
  f ≤ partial_sups f :=
λ n, le_partial_sups_of_le f le_rfl

lemma partial_sups_le (f : ℕ → α) (n : ℕ)
  (a : α) (w : ∀ m, m ≤ n → f m ≤ a) : partial_sups f n ≤ a :=
begin
  induction n with n ih,
  { apply w 0 le_rfl, },
  { exact sup_le (ih (λ m p, w m (nat.le_succ_of_le p))) (w (n + 1) le_rfl) }
end

lemma monotone.partial_sups_eq {f : ℕ → α} (hf : monotone f) :
  (partial_sups f : ℕ → α) = f :=
begin
  ext n,
  induction n with n ih,
  { refl },
  { rw [partial_sups_succ, ih, sup_eq_right.2 (hf (nat.le_succ _))] }
end

lemma partial_sups_mono : monotone (partial_sups : (ℕ → α) → ℕ →ₘ α) :=
begin
  rintro f g h n,
  induction n with n ih,
  { exact h 0 },
  { exact sup_le_sup ih (h _) }
end

/-- `partial_sups` forms a Galois insertion with the coercion from monotone functions to functions.
-/
def partial_sups.gi : galois_insertion (partial_sups : (ℕ → α) → ℕ →ₘ α) coe_fn :=
{ choice := λ f h, ⟨f, begin
    convert (partial_sups f).monotone,
    exact (le_partial_sups f).antisymm h,
  end⟩,
  gc := λ f g, begin
    refine ⟨(le_partial_sups f).trans, λ h, _⟩,
    convert partial_sups_mono h,
    exact preorder_hom.ext _ _ g.monotone.partial_sups_eq.symm,
  end,
  le_l_u := λ f, le_partial_sups f,
  choice_eq := λ f h, preorder_hom.ext _ _ ((le_partial_sups f).antisymm h) }

lemma partial_sups_eq_sup'_range (f : ℕ → α) (n : ℕ) :
  partial_sups f n = (finset.range (n + 1)).sup' ⟨n, finset.self_mem_range_succ n⟩ f :=
begin
  induction n with n ih,
  { simp },
  { dsimp [partial_sups] at ih ⊢,
    simp_rw @finset.range_succ n.succ,
    rw [ih, finset.sup'_insert, sup_comm] }
end

end semilattice_sup

lemma partial_sups_eq_sup_range [semilattice_sup α] [order_bot α] (f : ℕ → α) (n : ℕ) :
  partial_sups f n = (finset.range (n + 1)).sup f :=
begin
  induction n with n ih,
  { simp },
  { dsimp [partial_sups] at ih ⊢,
    rw [finset.range_succ, finset.sup_insert, sup_comm, ih] }
end

/- Note this lemma requires a distributive lattice, so is not useful (or true) in situations such as
submodules. -/
lemma partial_sups_disjoint_of_disjoint [distrib_lattice α] [order_bot α]
  (f : ℕ → α) (h : pairwise (disjoint on f)) {m n : ℕ} (hmn : m < n) :
  disjoint (partial_sups f m) (f n) :=
begin
  induction m with m ih,
  { exact h 0 n hmn.ne, },
  { rw [partial_sups_succ, disjoint_sup_left],
    exact ⟨ih (nat.lt_of_succ_lt hmn), h (m + 1) n hmn.ne⟩ }
end

section complete_lattice
variables [complete_lattice α]

lemma partial_sups_eq_bsupr (f : ℕ → α) (n : ℕ) :
  partial_sups f n = ⨆ (i ≤ n), f i :=
begin
  rw [partial_sups_eq_sup_range, finset.sup_eq_supr],
  congr,
  ext a,
  exact supr_congr_Prop (by rw [finset.mem_range, nat.lt_succ_iff]) (λ _, rfl),
end

@[simp] lemma supr_partial_sups_eq (f : ℕ → α) :
  (⨆ n, partial_sups f n) = ⨆ n, f n :=
begin
  refine (supr_le $ λ n, _).antisymm (supr_le_supr $ le_partial_sups f),
  rw partial_sups_eq_bsupr,
  exact bsupr_le_supr _ _,
end

lemma supr_le_supr_of_partial_sups_le_partial_sups {f g : ℕ → α}
  (h : partial_sups f ≤ partial_sups g) :
  (⨆ n, f n) ≤ ⨆ n, g n :=
begin
  rw [←supr_partial_sups_eq f, ←supr_partial_sups_eq g],
  exact supr_le_supr h,
end

lemma supr_eq_supr_of_partial_sups_eq_partial_sups {f g : ℕ → α}
  (h : partial_sups f = partial_sups g) :
  (⨆ n, f n) = ⨆ n, g n :=
by simp_rw [←supr_partial_sups_eq f, ←supr_partial_sups_eq g, h]

end complete_lattice