/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.continuous_function.bounded
import topology.uniform_space.compact_separated
import tactic.equiv_rw

/-!
# Continuous functions on a compact space

Continuous functions `C(α, β)` from a compact space `α` to a metric space `β`
are automatically bounded, and so acquire various structures inherited from `α →ᵇ β`.

This file transfers these structures, and restates some lemmas
characterising these structures.

If you need a lemma which is proved about `α →ᵇ β` but not for `C(α, β)` when `α` is compact,
you should restate it here. You can also use
`bounded_continuous_function.equiv_continuous_map_of_compact` to move functions back and forth.

-/

noncomputable theory
open_locale topological_space classical nnreal bounded_continuous_function

open set filter metric

open bounded_continuous_function

namespace continuous_map

variables {α β E : Type*} [topological_space α] [compact_space α] [metric_space β] [normed_group E]

section

variables (α β)

/--
When `α` is compact, the bounded continuous maps `α →ᵇ β` are
equivalent to `C(α, β)`.
-/
@[simps { fully_applied := ff }]
def equiv_bounded_of_compact : C(α, β) ≃ (α →ᵇ β) :=
⟨mk_of_compact, to_continuous_map, λ f, by { ext, refl, }, λ f, by { ext, refl, }⟩

/--
When `α` is compact, the bounded continuous maps `α →ᵇ 𝕜` are
additively equivalent to `C(α, 𝕜)`.
-/
@[simps apply symm_apply { fully_applied := ff }]
def add_equiv_bounded_of_compact [add_monoid β] [has_lipschitz_add β] :
  C(α, β) ≃+ (α →ᵇ β) :=
({ .. to_continuous_map_add_hom α β,
   .. (equiv_bounded_of_compact α β).symm, } : (α →ᵇ β) ≃+ C(α, β)).symm

instance : metric_space C(α, β) :=
metric_space.induced
  (equiv_bounded_of_compact α β)
  (equiv_bounded_of_compact α β).injective
  (by apply_instance)

/--
When `α` is compact, and `β` is a metric space, the bounded continuous maps `α →ᵇ β` are
isometric to `C(α, β)`.
-/
@[simps to_equiv apply symm_apply { fully_applied := ff }]
def isometric_bounded_of_compact :
  C(α, β) ≃ᵢ (α →ᵇ β) :=
{ isometry_to_fun := λ x y, rfl,
  to_equiv := equiv_bounded_of_compact α β }

end

@[simp] lemma _root_.bounded_continuous_function.dist_mk_of_compact (f g : C(α, β)) :
  dist (mk_of_compact f) (mk_of_compact g) = dist f g := rfl

@[simp] lemma _root_.bounded_continuous_function.dist_to_continuous_map (f g : α →ᵇ β) :
  dist (f.to_continuous_map) (g.to_continuous_map) = dist f g := rfl

open bounded_continuous_function

section
variables {α β} {f g : C(α, β)} {C : ℝ}

/-- The pointwise distance is controlled by the distance between functions, by definition. -/
lemma dist_apply_le_dist (x : α) : dist (f x) (g x) ≤ dist f g :=
by simp only [← dist_mk_of_compact, dist_coe_le_dist, ← mk_of_compact_apply]

/-- The distance between two functions is controlled by the supremum of the pointwise distances -/
lemma dist_le (C0 : (0 : ℝ) ≤ C) : dist f g ≤ C ↔ ∀x:α, dist (f x) (g x) ≤ C :=
by simp only [← dist_mk_of_compact, dist_le C0, mk_of_compact_apply]

lemma dist_le_iff_of_nonempty [nonempty α] :
  dist f g ≤ C ↔ ∀ x, dist (f x) (g x) ≤ C :=
by simp only [← dist_mk_of_compact, dist_le_iff_of_nonempty, mk_of_compact_apply]

lemma dist_lt_iff_of_nonempty [nonempty α] :
  dist f g < C ↔ ∀x:α, dist (f x) (g x) < C :=
by simp only [← dist_mk_of_compact, dist_lt_iff_of_nonempty_compact, mk_of_compact_apply]

lemma dist_lt_of_nonempty [nonempty α] (w : ∀x:α, dist (f x) (g x) < C) : dist f g < C :=
(dist_lt_iff_of_nonempty).2 w

lemma dist_lt_iff (C0 : (0 : ℝ) < C) :
  dist f g < C ↔ ∀x:α, dist (f x) (g x) < C :=
by simp only [← dist_mk_of_compact, dist_lt_iff_of_compact C0, mk_of_compact_apply]

end

instance [complete_space β] : complete_space (C(α, β)) :=
(isometric_bounded_of_compact α β).complete_space

@[continuity] lemma continuous_eval : continuous (λ p : C(α, β) × α, p.1 p.2) :=
continuous_eval.comp ((isometric_bounded_of_compact α β).continuous.prod_map continuous_id)

@[continuity] lemma continuous_evalx (x : α) : continuous (λ f : C(α, β), f x) :=
continuous_eval.comp (continuous_id.prod_mk continuous_const)

lemma continuous_coe : @continuous (C(α, β)) (α → β) _ _ coe_fn :=
continuous_pi continuous_evalx

-- TODO at some point we will need lemmas characterising this norm!
-- At the moment the only way to reason about it is to transfer `f : C(α,E)` back to `α →ᵇ E`.
instance : has_norm C(α, E) :=
{ norm := λ x, dist x 0 }

@[simp] lemma _root_.bounded_continuous_function.norm_mk_of_compact (f : C(α, E)) :
  ∥mk_of_compact f∥ = ∥f∥ := rfl

@[simp] lemma _root_.bounded_continuous_function.norm_to_continuous_map_eq (f : α →ᵇ E) :
  ∥f.to_continuous_map∥ = ∥f∥ :=
rfl

open bounded_continuous_function

instance : normed_group C(α, E) :=
{ dist_eq := λ x y,
  begin
    rw [← norm_mk_of_compact, ← dist_mk_of_compact, dist_eq_norm],
    congr' 1,
    exact ((add_equiv_bounded_of_compact α E).map_sub _ _).symm
  end, }

section
variables (f : C(α, E))
-- The corresponding lemmas for `bounded_continuous_function` are stated with `{f}`,
-- and so can not be used in dot notation.

lemma norm_coe_le_norm (x : α) : ∥f x∥ ≤ ∥f∥ :=
(mk_of_compact f).norm_coe_le_norm x

/-- Distance between the images of any two points is at most twice the norm of the function. -/
lemma dist_le_two_norm (x y : α) : dist (f x) (f y) ≤ 2 * ∥f∥ :=
(mk_of_compact f).dist_le_two_norm x y

/-- The norm of a function is controlled by the supremum of the pointwise norms -/
lemma norm_le {C : ℝ} (C0 : (0 : ℝ) ≤ C) : ∥f∥ ≤ C ↔ ∀x:α, ∥f x∥ ≤ C :=
@bounded_continuous_function.norm_le _ _ _ _
  (mk_of_compact f) _ C0

lemma norm_le_of_nonempty [nonempty α] {M : ℝ} : ∥f∥ ≤ M ↔ ∀ x, ∥f x∥ ≤ M :=
@bounded_continuous_function.norm_le_of_nonempty _ _ _ _ _ (mk_of_compact f) _

lemma norm_lt_iff {M : ℝ} (M0 : 0 < M) : ∥f∥ < M ↔ ∀ x, ∥f x∥ < M :=
@bounded_continuous_function.norm_lt_iff_of_compact _ _ _ _ _ (mk_of_compact f) _ M0

lemma norm_lt_iff_of_nonempty [nonempty α] {M : ℝ} :
  ∥f∥ < M ↔ ∀ x, ∥f x∥ < M :=
@bounded_continuous_function.norm_lt_iff_of_nonempty_compact _ _ _ _ _ _ (mk_of_compact f) _

lemma apply_le_norm (f : C(α, ℝ)) (x : α) : f x ≤ ∥f∥ :=
le_trans (le_abs.mpr (or.inl (le_refl (f x)))) (f.norm_coe_le_norm x)

lemma neg_norm_le_apply (f : C(α, ℝ)) (x : α) : -∥f∥ ≤ f x :=
le_trans (neg_le_neg (f.norm_coe_le_norm x)) (neg_le.mp (neg_le_abs_self (f x)))

lemma norm_eq_supr_norm : ∥f∥ = ⨆ x : α, ∥f x∥ :=
(mk_of_compact f).norm_eq_supr_norm

end

section
variables {R : Type*} [normed_ring R]

instance : normed_ring C(α,R) :=
{ norm_mul := λ f g, norm_mul_le (mk_of_compact f) (mk_of_compact g),
  ..(infer_instance : normed_group C(α,R)) }

end

section
variables {𝕜 : Type*} [normed_field 𝕜] [normed_space 𝕜 E]

instance : normed_space 𝕜 C(α,E) :=
{ norm_smul_le := λ c f, le_of_eq (norm_smul c (mk_of_compact f)) }

section
variables (α 𝕜 E)

/--
When `α` is compact and `𝕜` is a normed field,
the `𝕜`-algebra of bounded continuous maps `α →ᵇ β` is
`𝕜`-linearly isometric to `C(α, β)`.
-/
def linear_isometry_bounded_of_compact :
  C(α, E) ≃ₗᵢ[𝕜] (α →ᵇ E) :=
{ map_smul' := λ c f, by { ext, simp, },
  norm_map' := λ f, rfl,
  .. add_equiv_bounded_of_compact α E }

end

-- this lemma and the next are the analogues of those autogenerated by `@[simps]` for
-- `equiv_bounded_of_compact`, `add_equiv_bounded_of_compact`
@[simp] lemma linear_isometry_bounded_of_compact_symm_apply (f : α →ᵇ E) :
  (linear_isometry_bounded_of_compact α E 𝕜).symm f = f.to_continuous_map :=
rfl

@[simp] lemma linear_isometry_bounded_of_compact_apply_apply (f : C(α, E)) (a : α) :
  (linear_isometry_bounded_of_compact α E 𝕜 f) a = f a :=
rfl

@[simp]
lemma linear_isometry_bounded_of_compact_to_isometric :
  (linear_isometry_bounded_of_compact α E 𝕜).to_isometric = (isometric_bounded_of_compact α E) :=
rfl

@[simp]
lemma linear_isometry_bounded_of_compact_to_add_equiv :
  (linear_isometry_bounded_of_compact α E 𝕜).to_linear_equiv.to_add_equiv =
    (add_equiv_bounded_of_compact α E) :=
rfl

@[simp]
lemma linear_isometry_bounded_of_compact_of_compact_to_equiv :
  (linear_isometry_bounded_of_compact α E 𝕜).to_linear_equiv.to_equiv =
    (equiv_bounded_of_compact α E) :=
rfl

end

section
variables {𝕜 : Type*} {γ : Type*} [normed_field 𝕜] [normed_ring γ] [normed_algebra 𝕜 γ]

instance [nonempty α] : normed_algebra 𝕜 C(α, γ) :=
{ norm_algebra_map_eq := λ c, (norm_algebra_map_eq (α →ᵇ γ) c : _), }

end

end continuous_map

namespace continuous_map

section uniform_continuity
variables {α β : Type*}
variables [metric_space α] [compact_space α] [metric_space β]

/-!
We now set up some declarations making it convenient to use uniform continuity.
-/

lemma uniform_continuity
  (f : C(α, β)) (ε : ℝ) (h : 0 < ε) :
  ∃ δ > 0, ∀ {x y}, dist x y < δ → dist (f x) (f y) < ε :=
metric.uniform_continuous_iff.mp
  (compact_space.uniform_continuous_of_continuous f.continuous) ε h

/--
An arbitrarily chosen modulus of uniform continuity for a given function `f` and `ε > 0`.
-/
-- This definition allows us to separate the choice of some `δ`,
-- and the corresponding use of `dist a b < δ → dist (f a) (f b) < ε`,
-- even across different declarations.
def modulus (f : C(α, β)) (ε : ℝ) (h : 0 < ε) : ℝ :=
classical.some (uniform_continuity f ε h)

lemma modulus_pos (f : C(α, β)) {ε : ℝ} {h : 0 < ε} : 0 < f.modulus ε h :=
(classical.some_spec (uniform_continuity f ε h)).fst

lemma dist_lt_of_dist_lt_modulus
  (f : C(α, β)) (ε : ℝ) (h : 0 < ε) {a b : α} (w : dist a b < f.modulus ε h) :
  dist (f a) (f b) < ε :=
(classical.some_spec (uniform_continuity f ε h)).snd w

end uniform_continuity

end continuous_map

section comp_left
variables (X : Type*) {𝕜 β γ : Type*} [topological_space X] [compact_space X]
  [nondiscrete_normed_field 𝕜]
variables [normed_group β] [normed_space 𝕜 β] [normed_group γ] [normed_space 𝕜 γ]

open continuous_map

/--
Postcomposition of continuous functions into a normed module by a continuous linear map is a
continuous linear map.
Transferred version of `continuous_linear_map.comp_left_continuous_bounded`,
upgraded version of `continuous_linear_map.comp_left_continuous`,
similar to `linear_map.comp_left`. -/
protected def continuous_linear_map.comp_left_continuous_compact (g : β →L[𝕜] γ) :
  C(X, β) →L[𝕜] C(X, γ) :=
(linear_isometry_bounded_of_compact X γ 𝕜).symm.to_linear_isometry.to_continuous_linear_map.comp $
(g.comp_left_continuous_bounded X).comp $
(linear_isometry_bounded_of_compact X β 𝕜).to_linear_isometry.to_continuous_linear_map

@[simp] lemma continuous_linear_map.to_linear_comp_left_continuous_compact (g : β →L[𝕜] γ) :
  (g.comp_left_continuous_compact X : C(X, β) →ₗ[𝕜] C(X, γ)) = g.comp_left_continuous 𝕜 X :=
by { ext f, refl }

@[simp] lemma continuous_linear_map.comp_left_continuous_compact_apply (g : β →L[𝕜] γ)
  (f : C(X, β)) (x : X) :
  g.comp_left_continuous_compact X f x = g (f x) :=
rfl

end comp_left

namespace continuous_map
/-!
We now setup variations on `comp_right_* f`, where `f : C(X, Y)`
(that is, precomposition by a continuous map),
as a morphism `C(Y, T) → C(X, T)`, respecting various types of structure.

In particular:
* `comp_right_continuous_map`, the bundled continuous map (for this we need `X Y` compact).
* `comp_right_homeomorph`, when we precompose by a homeomorphism.
* `comp_right_alg_hom`, when `T = R` is a topological ring.
-/
section comp_right

/--
Precomposition by a continuous map is itself a continuous map between spaces of continuous maps.
-/
def comp_right_continuous_map {X Y : Type*} (T : Type*)
  [topological_space X] [compact_space X] [topological_space Y] [compact_space Y] [normed_group T]
  (f : C(X, Y)) : C(C(Y, T), C(X, T)) :=
{ to_fun := λ g, g.comp f,
  continuous_to_fun :=
  begin
    refine metric.continuous_iff.mpr _,
    intros g ε ε_pos,
    refine ⟨ε, ε_pos, λ g' h, _⟩,
    rw continuous_map.dist_lt_iff ε_pos at h ⊢,
    { exact λ x, h (f x), },
  end }

@[simp] lemma comp_right_continuous_map_apply {X Y : Type*} (T : Type*)
  [topological_space X] [compact_space X] [topological_space Y] [compact_space Y] [normed_group T]
  (f : C(X, Y)) (g : C(Y, T)) :
  (comp_right_continuous_map T f) g = g.comp f :=
rfl

/--
Precomposition by a homeomorphism is itself a homeomorphism between spaces of continuous maps.
-/
def comp_right_homeomorph {X Y : Type*} (T : Type*)
  [topological_space X] [compact_space X] [topological_space Y] [compact_space Y] [normed_group T]
  (f : X ≃ₜ Y) : C(Y, T) ≃ₜ C(X, T) :=
{ to_fun := comp_right_continuous_map T f.to_continuous_map,
  inv_fun := comp_right_continuous_map T f.symm.to_continuous_map,
  left_inv := by tidy,
  right_inv := by tidy, }

/--
Precomposition of functions into a normed ring by continuous map is an algebra homomorphism.
-/
def comp_right_alg_hom {X Y : Type*} (R : Type*)
  [topological_space X] [topological_space Y] [normed_comm_ring R] (f : C(X, Y)) :
  C(Y, R) →ₐ[R] C(X, R) :=
{ to_fun := λ g, g.comp f,
  map_zero' := by { ext, simp, },
  map_add' := λ g₁ g₂, by { ext, simp, },
  map_one' := by { ext, simp, },
  map_mul' := λ g₁ g₂, by { ext, simp, },
  commutes' := λ r, by { ext, simp, }, }

@[simp] lemma comp_right_alg_hom_apply {X Y : Type*} (R : Type*)
  [topological_space X] [topological_space Y] [normed_comm_ring R] (f : C(X, Y)) (g : C(Y, R)) :
  (comp_right_alg_hom R f) g = g.comp f :=
rfl

lemma comp_right_alg_hom_continuous {X Y : Type*} (R : Type*)
  [topological_space X] [compact_space X] [topological_space Y] [compact_space Y]
  [normed_comm_ring R] (f : C(X, Y)) :
  continuous (comp_right_alg_hom R f) :=
begin
  change continuous (comp_right_continuous_map R f),
  continuity,
end

end comp_right

end continuous_map


/-
Copyright (c) 2022 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import model_theory.semantics

/-!
# Ordered First-Ordered Structures
This file defines ordered first-order languages and structures, as well as their theories.

## Main Definitions
* `first_order.language.order` is the language consisting of a single relation representing `≤`.
* `first_order.language.order_Structure` is the structure on an ordered type, assigning the symbol
representing `≤` to the actual relation `≤`.
* `first_order.language.is_ordered` points out a specific symbol in a language as representing `≤`.
* `first_order.language.is_ordered_structure` indicates that a structure over a
* `first_order.language.linear_order` and similar define the theories of preorders, partial orders,
and linear orders.

## Main Results
* `partial_order`s model the theory of partial orders, and `linear_order`s model the theory of
linear orders.

-/

universes u v w

namespace first_order
namespace language
open Structure

variables {L : language.{u v}} {α : Type w} {n : ℕ}

/-- The language consisting of a single relation representing `≤`. -/
protected def order : language :=
language.mk₂ empty empty empty empty unit

instance order.Structure [has_le α] : language.order.Structure α :=
Structure.mk₂ empty.elim empty.elim empty.elim empty.elim (λ _, (≤))

instance : is_relational (language.order) := language.is_relational_mk₂

instance : subsingleton (language.order.relations n) :=
language.subsingleton_mk₂_relations

/-- A language is ordered if it has a symbol representing `≤`. -/
class is_ordered (L : language.{u v}) := (le_symb : L.relations 2)

export is_ordered (le_symb)

section is_ordered

variables [is_ordered L]

/-- Joins two terms `t₁, t₂` in a formula representing `t₁ ≤ t₂`. -/
def term.le (t₁ t₂ : L.term (α ⊕ fin n)) : L.bounded_formula α n :=
le_symb.bounded_formula₂ t₁ t₂

variable (L)

/-- The language homomorphism sending the unique symbol `≤` of `language.order` to `≤` in an ordered
 language. -/
def order_Lhom : language.order →ᴸ L :=
Lhom.mk₂ empty.elim empty.elim empty.elim empty.elim (λ _, le_symb)

end is_ordered

instance : is_ordered language.order := ⟨unit.star⟩

@[simp]
lemma order_Lhom_order : order_Lhom language.order = Lhom.id language.order :=
Lhom.funext (subsingleton.elim _ _) (subsingleton.elim _ _)

instance : is_ordered (L.sum language.order) := ⟨sum.inr is_ordered.le_symb⟩

/-- The theory of preorders. -/
protected def Theory.preorder : language.order.Theory :=
{le_symb.reflexive, le_symb.transitive}

/-- The theory of partial orders. -/
protected def Theory.partial_order : language.order.Theory :=
{le_symb.reflexive, le_symb.antisymmetric, le_symb.transitive}

/-- The theory of linear orders. -/
protected def Theory.linear_order : language.order.Theory :=
{le_symb.reflexive, le_symb.antisymmetric, le_symb.transitive, le_symb.total}

variables (L α)

/-- A structure is ordered if its language has a `≤` symbol whose interpretation is -/
def is_ordered_structure [is_ordered L] [has_le α] [L.Structure α] : Prop :=
Lhom.is_expansion_on (order_Lhom L) α

instance is_ordered_structure_has_le [has_le α] :
  is_ordered_structure language.order α :=
begin
  rw [is_ordered_structure, order_Lhom_order],
  exact Lhom.id_is_expansion_on α,
end

instance model_preorder [preorder α] :
  α ⊨ Theory.preorder :=
begin
  simp only [Theory.preorder, Theory.model_iff, set.mem_insert_iff, set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, forall_eq,
    relations.realize_transitive],
  exact ⟨le_refl, λ _ _ _, le_trans⟩
end

instance model_partial_order [partial_order α] :
  α ⊨ Theory.partial_order :=
begin
  simp only [Theory.partial_order, Theory.model_iff, set.mem_insert_iff, set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, relations.realize_antisymmetric,
    forall_eq, relations.realize_transitive],
  exact ⟨le_refl, λ _ _, le_antisymm, λ _ _ _, le_trans⟩,
end

instance model_linear_order [linear_order α] :
  α ⊨ Theory.linear_order :=
begin
  simp only [Theory.linear_order, Theory.model_iff, set.mem_insert_iff, set.mem_singleton_iff,
    forall_eq_or_imp, relations.realize_reflexive, rel_map_apply₂, relations.realize_antisymmetric,
    relations.realize_transitive, forall_eq, relations.realize_total],
  exact ⟨le_refl, λ _ _, le_antisymm, λ _ _ _, le_trans, le_total⟩,
end

end language
end first_order


import data.list.basic
open list

-- Exercise: 2 stars (filter_even_gt7)
lemma test_filter1 : filter (λ a, ¬nat.bodd a) [1,2,3,4] = [2,4] := rfl

def filter_even_gt7 (l : list ℕ) : list ℕ :=
filter (λ a : ℕ, ¬nat.bodd a ∧ a ≥ 7) l

lemma test_filter_even_gt7_1 :
  filter_even_gt7 [1,2,6,9,10,3,12,8] = [10,12,8] := rfl
lemma test_filter_even_gt7_2 :
  filter_even_gt7 [5,2,6,19,129] = [] := rfl

-- Exercise: 3 stars (partition)
def partition {α : Type} (test : α → bool) (l : list α) : list α × list α :=
let a := filter (λ z, test z) l, b := filter (λ z, ¬ test z) l in ⟨a, b⟩

lemma test_partition1 : partition nat.bodd [1,2,3,4,5] = ⟨[1,3,5], [2,4]⟩ :=
rfl
lemma test_partition2 : partition (λ x, ff) [5,9,0] = ⟨[], [5,9,0]⟩ := rfl

lemma t1 {α : Type} (head : α) (tail : list α)
  : cons head tail = append [head] tail := rfl

-- Exercise: 3 stars (map_rev)
theorem map_reverse_commutes {α β : Type} (f : α → β) (l : list α)
  : map f (reverse l) = reverse (map f l) :=
list.rec_on l (rfl)
  (λ head tail ih,
    begin
      rw reverse_cons,
      rw map_append,
      rw ih,
      rw map_cons,
      rw map_cons,
      rw reverse_cons,
      rw map,
    end)

-- Exercise: 2 stars, recommended (flat_map)
def flat_map {α β : Type} (f : α → list β) : list α → list β
| nil := []
| (hd::tl) := f hd ++ flat_map tl

lemma test_flat_map1 : flat_map (λn, [n,n,n]) [1,5,4] = [1,1,1,5,5,5,4,4,4] :=
rfl


/-!
# A Certified Type Checker

In this example, we build a certified type checker for a simple expression
language.

Remark: this example is based on an example in the book [Certified Programming with Dependent Types](http://adam.chlipala.net/cpdt/) by Adam Chlipala.
-/
inductive Expr where
  | nat  : Nat → Expr
  | plus : Expr → Expr → Expr
  | bool : Bool → Expr
  | and  : Expr → Expr → Expr

/-!
We define a simple language of types using the inductive datatype `Ty`, and
its typing rules using the inductive predicate `HasType`.
-/
inductive Ty where
  | nat
  | bool
  deriving DecidableEq

inductive HasType : Expr → Ty → Prop
  | nat  : HasType (.nat v) .nat
  | plus : HasType a .nat → HasType b .nat → HasType (.plus a b) .nat
  | bool : HasType (.bool v) .bool
  | and  : HasType a .bool → HasType b .bool → HasType (.and a b) .bool

/-!
We can easily show that if `e` has type `t₁` and type `t₂`, then `t₁` and `t₂` must be equal
by using the the `cases` tactic. This tactic creates a new subgoal for every constructor,
and automatically discharges unreachable cases. The tactic combinator `tac₁ <;> tac₂` applies
`tac₂` to each subgoal produced by `tac₁`. Then, the tactic `rfl` is used to close all produced
goals using reflexivity.
-/
theorem HasType.det (h₁ : HasType e t₁) (h₂ : HasType e t₂) : t₁ = t₂ := by
  cases h₁ <;> cases h₂ <;> rfl

/-!
The inductive type `Maybe p` has two contructors: `found a h` and `unknown`.
The former contains an element `a : α` and a proof that `a` satisfies the predicate `p`.
The constructor `unknown` is used to encode "failure".
-/

inductive Maybe (p : α → Prop) where
  | found : (a : α) → p a → Maybe p
  | unknown

/-!
We define a notation for `Maybe` that is similar to the builtin notation for the Lean builtin type `Subtype`.
-/
notation "{{ " x " | " p " }}" => Maybe (fun x => p)

/-!
The function `Expr.typeCheck e` returns a type `ty` and a proof that `e` has type `ty`,
or `unknown`.
Recall that, `def Expr.typeCheck ...` in Lean is notation for `namespace Expr def typeCheck ... end Expr`.
The term `.found .nat .nat` is sugar for `Maybe.found Ty.nat HasType.nat`. Lean can infer the namespaces using
the expected types.
-/
def Expr.typeCheck (e : Expr) : {{ ty | HasType e ty }} :=
  match e with
  | nat ..   => .found .nat .nat
  | bool ..  => .found .bool .bool
  | plus a b =>
    match a.typeCheck, b.typeCheck with
    | .found .nat h₁, .found .nat h₂ => .found .nat (.plus h₁ h₂)
    | _, _ => .unknown
  | and a b =>
    match a.typeCheck, b.typeCheck with
    | .found .bool h₁, .found .bool h₂ => .found .bool (.and h₁ h₂)
    | _, _ => .unknown

theorem Expr.typeCheck_correct (h₁ : HasType e ty) (h₂ : e.typeCheck ≠ .unknown)
        : e.typeCheck = .found ty h := by
  revert h₂
  cases typeCheck e with
  | found ty' h' => intro; have := HasType.det h₁ h'; subst this; rfl
  | unknown => intros; contradiction

/-!
Now, we prove that if `Expr.typeCheck e` returns `Maybe.unknown`, then forall `ty`, `HasType e ty` does not hold.
The notation `e.typeCheck` is sugar for `Expr.typeCheck e`. Lean can infer this because we explicitly said that `e` has type `Expr`.
The proof is by induction on `e` and case analysis. The tactic `rename_i` is used to to rename "inaccessible" variables.
We say a variable is inaccessible if it is introduced by a tactic (e.g., `cases`) or has been shadowed by another variable introduced
by the user. Note that the tactic `simp [typeCheck]` is applied to all goal generated by the `induction` tactic, and closes
the cases corresponding to the constructors `Expr.nat` and `Expr.bool`.
-/
theorem Expr.typeCheck_complete {e : Expr} : e.typeCheck = .unknown → ¬ HasType e ty := by
  induction e with simp [typeCheck]
  | plus a b iha ihb =>
    split
    next => intros; contradiction
    next ra rb hnp =>
      -- Recall that `hnp` is a hypothesis generated by the `split` tactic
      -- that asserts the previous case was not taken
      intro h ht
      cases ht with
      | plus h₁ h₂ => exact hnp h₁ h₂ (typeCheck_correct h₁ (iha · h₁)) (typeCheck_correct h₂ (ihb · h₂))
  | and a b iha ihb =>
    split
    next => intros; contradiction
    next ra rb hnp =>
      intro h ht
      cases ht with
      | and h₁ h₂ =>  exact hnp h₁ h₂ (typeCheck_correct h₁ (iha · h₁)) (typeCheck_correct h₂ (ihb · h₂))

/-!
Finally, we show that type checking for `e` can be decided using `Expr.typeCheck`.
-/
instance (e : Expr) (t : Ty) : Decidable (HasType e t) :=
  match h' : e.typeCheck with
  | .found t' ht' =>
    if heq : t = t' then
      isTrue (heq ▸ ht')
    else
      isFalse fun ht => heq (HasType.det ht ht')
  | .unknown => isFalse (Expr.typeCheck_complete h')


/-
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 analysis.convex.star
! leanprover-community/mathlib commit 9003f28797c0664a49e4179487267c494477d853
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Analysis.Convex.Segment

/-!
# Star-convex sets

This files defines star-convex sets (aka star domains, star-shaped set, radially convex set).

A set is star-convex at `x` if every segment from `x` to a point in the set is contained in the set.

This is the prototypical example of a contractible set in homotopy theory (by scaling every point
towards `x`), but has wider uses.

Note that this has nothing to do with star rings, `Star` and co.

## Main declarations

* `StarConvex 𝕜 x s`: `s` is star-convex at `x` with scalars `𝕜`.

## Implementation notes

Instead of saying that a set is star-convex, we say a set is star-convex *at a point*. This has the
advantage of allowing us to talk about convexity as being "everywhere star-convexity" and of making
the union of star-convex sets be star-convex.

Incidentally, this choice means we don't need to assume a set is nonempty for it to be star-convex.
Concretely, the empty set is star-convex at every point.

## TODO

Balanced sets are star-convex.

The closure of a star-convex set is star-convex.

Star-convex sets are contractible.

A nonempty open star-convex set in `ℝ^n` is diffeomorphic to the entire space.
-/

open Set

open Convex Pointwise

variable {𝕜 E F : Type _}

section OrderedSemiring

variable [OrderedSemiring 𝕜]

section AddCommMonoid

variable [AddCommMonoid E] [AddCommMonoid F]

section SMul

variable (𝕜) [SMul 𝕜 E] [SMul 𝕜 F] (x : E) (s : Set E)

/-- Star-convexity of sets. `s` is star-convex at `x` if every segment from `x` to a point in `s` is
contained in `s`. -/
def StarConvex : Prop :=
  ∀ ⦃y : E⦄, y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 → a • x + b • y ∈ s
#align star_convex StarConvex

variable {𝕜 x s} {t : Set E}

theorem starConvex_iff_segment_subset : StarConvex 𝕜 x s ↔ ∀ ⦃y⦄, y ∈ s → [x -[𝕜] y] ⊆ s := by
  constructor
  · rintro h y hy z ⟨a, b, ha, hb, hab, rfl⟩
    exact h hy ha hb hab
  · rintro h y hy a b ha hb hab
    exact h hy ⟨a, b, ha, hb, hab, rfl⟩
#align star_convex_iff_segment_subset starConvex_iff_segment_subset

theorem StarConvex.segment_subset (h : StarConvex 𝕜 x s) {y : E} (hy : y ∈ s) : [x -[𝕜] y] ⊆ s :=
  starConvex_iff_segment_subset.1 h hy
#align star_convex.segment_subset StarConvex.segment_subset

theorem StarConvex.openSegment_subset (h : StarConvex 𝕜 x s) {y : E} (hy : y ∈ s) :
    openSegment 𝕜 x y ⊆ s :=
  (openSegment_subset_segment 𝕜 x y).trans (h.segment_subset hy)
#align star_convex.open_segment_subset StarConvex.openSegment_subset

/-- Alternative definition of star-convexity, in terms of pointwise set operations. -/
theorem starConvex_iff_pointwise_add_subset :
    StarConvex 𝕜 x s ↔ ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 → a • {x} + b • s ⊆ s := by
  refine'
    ⟨_, fun h y hy a b ha hb hab =>
      h ha hb hab (add_mem_add (smul_mem_smul_set <| mem_singleton _) ⟨_, hy, rfl⟩)⟩
  rintro hA a b ha hb hab w ⟨au, bv, ⟨u, rfl : u = x, rfl⟩, ⟨v, hv, rfl⟩, rfl⟩
  exact hA hv ha hb hab
#align star_convex_iff_pointwise_add_subset starConvex_iff_pointwise_add_subset

theorem starConvex_empty (x : E) : StarConvex 𝕜 x ∅ := fun _ hy => hy.elim
#align star_convex_empty starConvex_empty

theorem starConvex_univ (x : E) : StarConvex 𝕜 x univ := fun _ _ _ _ _ _ _ => trivial
#align star_convex_univ starConvex_univ

theorem StarConvex.inter (hs : StarConvex 𝕜 x s) (ht : StarConvex 𝕜 x t) : StarConvex 𝕜 x (s ∩ t) :=
  fun _ hy _ _ ha hb hab => ⟨hs hy.left ha hb hab, ht hy.right ha hb hab⟩
#align star_convex.inter StarConvex.inter

theorem starConvex_interₛ {S : Set (Set E)} (h : ∀ s ∈ S, StarConvex 𝕜 x s) :
    StarConvex 𝕜 x (⋂₀ S) := fun _ hy _ _ ha hb hab s hs => h s hs (hy s hs) ha hb hab
#align star_convex_sInter starConvex_interₛ

theorem starConvex_interᵢ {ι : Sort _} {s : ι → Set E} (h : ∀ i, StarConvex 𝕜 x (s i)) :
    StarConvex 𝕜 x (⋂ i, s i) :=
  interₛ_range s ▸ starConvex_interₛ <| forall_range_iff.2 h
#align star_convex_Inter starConvex_interᵢ

theorem StarConvex.union (hs : StarConvex 𝕜 x s) (ht : StarConvex 𝕜 x t) : StarConvex 𝕜 x (s ∪ t) :=
  by
  rintro y (hy | hy) a b ha hb hab
  · exact Or.inl (hs hy ha hb hab)
  · exact Or.inr (ht hy ha hb hab)
#align star_convex.union StarConvex.union

theorem starConvex_unionᵢ {ι : Sort _} {s : ι → Set E} (hs : ∀ i, StarConvex 𝕜 x (s i)) :
    StarConvex 𝕜 x (⋃ i, s i) := by
  rintro y hy a b ha hb hab
  rw [mem_unionᵢ] at hy⊢
  obtain ⟨i, hy⟩ := hy
  exact ⟨i, hs i hy ha hb hab⟩
#align star_convex_Union starConvex_unionᵢ

theorem starConvex_unionₛ {S : Set (Set E)} (hS : ∀ s ∈ S, StarConvex 𝕜 x s) :
    StarConvex 𝕜 x (⋃₀ S) := by
  rw [unionₛ_eq_unionᵢ]
  exact starConvex_unionᵢ fun s => hS _ s.2
#align star_convex_sUnion starConvex_unionₛ

theorem StarConvex.prod {y : F} {s : Set E} {t : Set F} (hs : StarConvex 𝕜 x s)
    (ht : StarConvex 𝕜 y t) : StarConvex 𝕜 (x, y) (s ×ˢ t) := fun _ hy _ _ ha hb hab =>
  ⟨hs hy.1 ha hb hab, ht hy.2 ha hb hab⟩
#align star_convex.prod StarConvex.prod

theorem starConvex_pi {ι : Type _} {E : ι → Type _} [∀ i, AddCommMonoid (E i)] [∀ i, SMul 𝕜 (E i)]
    {x : ∀ i, E i} {s : Set ι} {t : ∀ i, Set (E i)} (ht : ∀ ⦃i⦄, i ∈ s → StarConvex 𝕜 (x i) (t i)) :
    StarConvex 𝕜 x (s.pi t) := fun _ hy _ _ ha hb hab i hi => ht hi (hy i hi) ha hb hab
#align star_convex_pi starConvex_pi

end SMul

section Module

variable [Module 𝕜 E] [Module 𝕜 F] {x y z : E} {s : Set E}

theorem StarConvex.mem (hs : StarConvex 𝕜 x s) (h : s.Nonempty) : x ∈ s := by
  obtain ⟨y, hy⟩ := h
  convert hs hy zero_le_one le_rfl (add_zero 1)
  rw [one_smul, zero_smul, add_zero]
#align star_convex.mem StarConvex.mem

theorem starConvex_iff_forall_pos (hx : x ∈ s) :
    StarConvex 𝕜 x s ↔ ∀ ⦃y⦄, y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ s :=
  by
  refine' ⟨fun h y hy a b ha hb hab => h hy ha.le hb.le hab, _⟩
  intro h y hy a b ha hb hab
  obtain rfl | ha := ha.eq_or_lt
  · rw [zero_add] at hab
    rwa [hab, one_smul, zero_smul, zero_add]
  obtain rfl | hb := hb.eq_or_lt
  · rw [add_zero] at hab
    rwa [hab, one_smul, zero_smul, add_zero]
  exact h hy ha hb hab
#align star_convex_iff_forall_pos starConvex_iff_forall_pos

theorem starConvex_iff_forall_ne_pos (hx : x ∈ s) :
    StarConvex 𝕜 x s ↔
      ∀ ⦃y⦄, y ∈ s → x ≠ y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ s := by
  refine' ⟨fun h y hy _ a b ha hb hab => h hy ha.le hb.le hab, _⟩
  intro h y hy a b ha hb hab
  obtain rfl | ha' := ha.eq_or_lt
  · rw [zero_add] at hab
    rwa [hab, zero_smul, one_smul, zero_add]
  obtain rfl | hb' := hb.eq_or_lt
  · rw [add_zero] at hab
    rwa [hab, zero_smul, one_smul, add_zero]
  obtain rfl | hxy := eq_or_ne x y
  · rwa [Convex.combo_self hab]
  exact h hy hxy ha' hb' hab
#align star_convex_iff_forall_ne_pos starConvex_iff_forall_ne_pos

theorem starConvex_iff_openSegment_subset (hx : x ∈ s) :
    StarConvex 𝕜 x s ↔ ∀ ⦃y⦄, y ∈ s → openSegment 𝕜 x y ⊆ s :=
  starConvex_iff_segment_subset.trans <|
    forall₂_congr fun _ hy => (openSegment_subset_iff_segment_subset hx hy).symm
#align star_convex_iff_open_segment_subset starConvex_iff_openSegment_subset

theorem starConvex_singleton (x : E) : StarConvex 𝕜 x {x} := by
  rintro y (rfl : y = x) a b _ _ hab
  exact Convex.combo_self hab _
#align star_convex_singleton starConvex_singleton

theorem StarConvex.linear_image (hs : StarConvex 𝕜 x s) (f : E →ₗ[𝕜] F) :
    StarConvex 𝕜 (f x) (s.image f) := by
  intro y hy a b ha hb hab
  obtain ⟨y', hy', rfl⟩ := hy
  exact ⟨a • x + b • y', hs hy' ha hb hab, by rw [f.map_add, f.map_smul, f.map_smul]⟩
#align star_convex.linear_image StarConvex.linear_image

theorem StarConvex.is_linear_image (hs : StarConvex 𝕜 x s) {f : E → F} (hf : IsLinearMap 𝕜 f) :
    StarConvex 𝕜 (f x) (f '' s) :=
  hs.linear_image <| hf.mk' f
#align star_convex.is_linear_image StarConvex.is_linear_image

theorem StarConvex.linear_preimage {s : Set F} (f : E →ₗ[𝕜] F) (hs : StarConvex 𝕜 (f x) s) :
    StarConvex 𝕜 x (s.preimage f) := by
  intro y hy a b ha hb hab
  rw [mem_preimage, f.map_add, f.map_smul, f.map_smul]
  exact hs hy ha hb hab
#align star_convex.linear_preimage StarConvex.linear_preimage

theorem StarConvex.is_linear_preimage {s : Set F} {f : E → F} (hs : StarConvex 𝕜 (f x) s)
    (hf : IsLinearMap 𝕜 f) : StarConvex 𝕜 x (preimage f s) :=
  hs.linear_preimage <| hf.mk' f
#align star_convex.is_linear_preimage StarConvex.is_linear_preimage

theorem StarConvex.add {t : Set E} (hs : StarConvex 𝕜 x s) (ht : StarConvex 𝕜 y t) :
    StarConvex 𝕜 (x + y) (s + t) := by
  rw [← add_image_prod]
  exact (hs.prod ht).is_linear_image IsLinearMap.isLinearMap_add
#align star_convex.add StarConvex.add

theorem StarConvex.add_left (hs : StarConvex 𝕜 x s) (z : E) :
    StarConvex 𝕜 (z + x) ((fun x => z + x) '' s) := by
  intro y hy a b ha hb hab
  obtain ⟨y', hy', rfl⟩ := hy
  refine' ⟨a • x + b • y', hs hy' ha hb hab, _⟩
  rw [smul_add, smul_add, add_add_add_comm, ← add_smul, hab, one_smul]
#align star_convex.add_left StarConvex.add_left

theorem StarConvex.add_right (hs : StarConvex 𝕜 x s) (z : E) :
    StarConvex 𝕜 (x + z) ((fun x => x + z) '' s) := by
  intro y hy a b ha hb hab
  obtain ⟨y', hy', rfl⟩ := hy
  refine' ⟨a • x + b • y', hs hy' ha hb hab, _⟩
  rw [smul_add, smul_add, add_add_add_comm, ← add_smul, hab, one_smul]
#align star_convex.add_right StarConvex.add_right

/-- The translation of a star-convex set is also star-convex. -/
theorem StarConvex.preimage_add_right (hs : StarConvex 𝕜 (z + x) s) :
    StarConvex 𝕜 x ((fun x => z + x) ⁻¹' s) := by
  intro y hy a b ha hb hab
  have h := hs hy ha hb hab
  rwa [smul_add, smul_add, add_add_add_comm, ← add_smul, hab, one_smul] at h
#align star_convex.preimage_add_right StarConvex.preimage_add_right

/-- The translation of a star-convex set is also star-convex. -/
theorem StarConvex.preimage_add_left (hs : StarConvex 𝕜 (x + z) s) :
    StarConvex 𝕜 x ((fun x => x + z) ⁻¹' s) := by
  rw [add_comm] at hs
  simpa only [add_comm] using hs.preimage_add_right
#align star_convex.preimage_add_left StarConvex.preimage_add_left

end Module

end AddCommMonoid

section AddCommGroup

variable [AddCommGroup E] [Module 𝕜 E] {x y : E}

theorem StarConvex.sub' {s : Set (E × E)} (hs : StarConvex 𝕜 (x, y) s) :
    StarConvex 𝕜 (x - y) ((fun x : E × E => x.1 - x.2) '' s) :=
  hs.is_linear_image IsLinearMap.isLinearMap_sub
#align star_convex.sub' StarConvex.sub'

end AddCommGroup

end OrderedSemiring

section OrderedCommSemiring

variable [OrderedCommSemiring 𝕜]

section AddCommMonoid

variable [AddCommMonoid E] [AddCommMonoid F] [Module 𝕜 E] [Module 𝕜 F] {x : E} {s : Set E}

theorem StarConvex.smul (hs : StarConvex 𝕜 x s) (c : 𝕜) : StarConvex 𝕜 (c • x) (c • s) :=
  hs.linear_image <| LinearMap.lsmul _ _ c
#align star_convex.smul StarConvex.smul

theorem StarConvex.preimage_smul {c : 𝕜} (hs : StarConvex 𝕜 (c • x) s) :
    StarConvex 𝕜 x ((fun z => c • z) ⁻¹' s) :=
  hs.linear_preimage (LinearMap.lsmul _ _ c)
#align star_convex.preimage_smul StarConvex.preimage_smul

theorem StarConvex.affinity (hs : StarConvex 𝕜 x s) (z : E) (c : 𝕜) :
    StarConvex 𝕜 (z + c • x) ((fun x => z + c • x) '' s) := by
  have h := (hs.smul c).add_left z
  rwa [← image_smul, image_image] at h
#align star_convex.affinity StarConvex.affinity

end AddCommMonoid

end OrderedCommSemiring

section OrderedRing

variable [OrderedRing 𝕜]

section AddCommMonoid

variable [AddCommMonoid E] [SMulWithZero 𝕜 E] {s : Set E}

theorem starConvex_zero_iff :
    StarConvex 𝕜 0 s ↔ ∀ ⦃x : E⦄, x ∈ s → ∀ ⦃a : 𝕜⦄, 0 ≤ a → a ≤ 1 → a • x ∈ s := by
  refine'
    forall_congr' fun x => forall_congr' fun _ => ⟨fun h a ha₀ ha₁ => _, fun h a b ha hb hab => _⟩
  · simpa only [sub_add_cancel, eq_self_iff_true, forall_true_left, zero_add, smul_zero] using
      h (sub_nonneg_of_le ha₁) ha₀
  · rw [smul_zero, zero_add]
    exact h hb (by rw [← hab]; exact le_add_of_nonneg_left ha)
#align star_convex_zero_iff starConvex_zero_iff

end AddCommMonoid

section AddCommGroup

variable [AddCommGroup E] [AddCommGroup F] [Module 𝕜 E] [Module 𝕜 F] {x y : E} {s t : Set E}

theorem StarConvex.add_smul_mem (hs : StarConvex 𝕜 x s) (hy : x + y ∈ s) {t : 𝕜} (ht₀ : 0 ≤ t)
    (ht₁ : t ≤ 1) : x + t • y ∈ s := by
  have h : x + t • y = (1 - t) • x + t • (x + y) := by
    rw [smul_add, ← add_assoc, ← add_smul, sub_add_cancel, one_smul]
  rw [h]
  exact hs hy (sub_nonneg_of_le ht₁) ht₀ (sub_add_cancel _ _)
#align star_convex.add_smul_mem StarConvex.add_smul_mem

theorem StarConvex.smul_mem (hs : StarConvex 𝕜 0 s) (hx : x ∈ s) {t : 𝕜} (ht₀ : 0 ≤ t)
    (ht₁ : t ≤ 1) : t • x ∈ s := by simpa using hs.add_smul_mem (by simpa using hx) ht₀ ht₁
#align star_convex.smul_mem StarConvex.smul_mem

theorem StarConvex.add_smul_sub_mem (hs : StarConvex 𝕜 x s) (hy : y ∈ s) {t : 𝕜} (ht₀ : 0 ≤ t)
    (ht₁ : t ≤ 1) : x + t • (y - x) ∈ s := by
  apply hs.segment_subset hy
  rw [segment_eq_image']
  exact mem_image_of_mem _ ⟨ht₀, ht₁⟩
#align star_convex.add_smul_sub_mem StarConvex.add_smul_sub_mem

/-- The preimage of a star-convex set under an affine map is star-convex. -/
theorem StarConvex.affine_preimage (f : E →ᵃ[𝕜] F) {s : Set F} (hs : StarConvex 𝕜 (f x) s) :
    StarConvex 𝕜 x (f ⁻¹' s) := by
  intro y hy a b ha hb hab
  rw [mem_preimage, Convex.combo_affine_apply hab]
  exact hs hy ha hb hab
#align star_convex.affine_preimage StarConvex.affine_preimage

/-- The image of a star-convex set under an affine map is star-convex. -/
theorem StarConvex.affine_image (f : E →ᵃ[𝕜] F) {s : Set E} (hs : StarConvex 𝕜 x s) :
    StarConvex 𝕜 (f x) (f '' s) := by
  rintro y ⟨y', ⟨hy', hy'f⟩⟩ a b ha hb hab
  refine' ⟨a • x + b • y', ⟨hs hy' ha hb hab, _⟩⟩
  rw [Convex.combo_affine_apply hab, hy'f]
#align star_convex.affine_image StarConvex.affine_image

theorem StarConvex.neg (hs : StarConvex 𝕜 x s) : StarConvex 𝕜 (-x) (-s) := by
  rw [← image_neg]
  exact hs.is_linear_image IsLinearMap.isLinearMap_neg
#align star_convex.neg StarConvex.neg

theorem StarConvex.sub (hs : StarConvex 𝕜 x s) (ht : StarConvex 𝕜 y t) :
    StarConvex 𝕜 (x - y) (s - t) := by
  simp_rw [sub_eq_add_neg]
  exact hs.add ht.neg
#align star_convex.sub StarConvex.sub

end AddCommGroup

end OrderedRing

section LinearOrderedField

variable [LinearOrderedField 𝕜]

section AddCommGroup

variable [AddCommGroup E] [Module 𝕜 E] {x : E} {s : Set E}

/-- Alternative definition of star-convexity, using division. -/
theorem starConvex_iff_div :
    StarConvex 𝕜 x s ↔
      ∀ ⦃y⦄,
        y ∈ s →
          ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → 0 < a + b → (a / (a + b)) • x + (b / (a + b)) • y ∈ s :=
  ⟨fun h y hy a b ha hb hab => by
    apply h hy
    · have ha' := mul_le_mul_of_nonneg_left ha (inv_pos.2 hab).le
      rwa [MulZeroClass.mul_zero, ← div_eq_inv_mul] at ha'
    · have hb' := mul_le_mul_of_nonneg_left hb (inv_pos.2 hab).le
      rwa [MulZeroClass.mul_zero, ← div_eq_inv_mul] at hb'
    · rw [← add_div]
      exact div_self hab.ne', fun h y hy a b ha hb hab =>
    by
    have h' := h hy ha hb
    rw [hab, div_one, div_one] at h'
    exact h' zero_lt_one⟩
#align star_convex_iff_div starConvex_iff_div

theorem StarConvex.mem_smul (hs : StarConvex 𝕜 0 s) (hx : x ∈ s) {t : 𝕜} (ht : 1 ≤ t) : x ∈ t • s :=
  by
  rw [mem_smul_set_iff_inv_smul_mem₀ (zero_lt_one.trans_le ht).ne']
  exact hs.smul_mem hx (inv_nonneg.2 <| zero_le_one.trans ht) (inv_le_one ht)
#align star_convex.mem_smul StarConvex.mem_smul

end AddCommGroup

end LinearOrderedField

/-!
#### Star-convex sets in an ordered space

Relates `starConvex` and `Set.ordConnected`.
-/

section OrdConnected

theorem Set.OrdConnected.starConvex [OrderedSemiring 𝕜] [OrderedAddCommMonoid E] [Module 𝕜 E]
    [OrderedSMul 𝕜 E] {x : E} {s : Set E} (hs : s.OrdConnected) (hx : x ∈ s)
    (h : ∀ y ∈ s, x ≤ y ∨ y ≤ x) : StarConvex 𝕜 x s := by
  intro y hy a b ha hb hab
  obtain hxy | hyx := h _ hy
  · refine' hs.out hx hy (mem_Icc.2 ⟨_, _⟩)
    calc
      x = a • x + b • x := (Convex.combo_self hab _).symm
      _ ≤ a • x + b • y := add_le_add_left (smul_le_smul_of_nonneg hxy hb) _
    calc
      a • x + b • y ≤ a • y + b • y := add_le_add_right (smul_le_smul_of_nonneg hxy ha) _
      _ = y := Convex.combo_self hab _
  · refine' hs.out hy hx (mem_Icc.2 ⟨_, _⟩)
    calc
      y = a • y + b • y := (Convex.combo_self hab _).symm
      _ ≤ a • x + b • y := add_le_add_right (smul_le_smul_of_nonneg hyx ha) _
    calc
      a • x + b • y ≤ a • x + b • x := add_le_add_left (smul_le_smul_of_nonneg hyx hb) _
      _ = x := Convex.combo_self hab _

#align set.ord_connected.star_convex Set.OrdConnected.starConvex

theorem starConvex_iff_ordConnected [LinearOrderedField 𝕜] {x : 𝕜} {s : Set 𝕜} (hx : x ∈ s) :
    StarConvex 𝕜 x s ↔ s.OrdConnected := by
  simp_rw [ordConnected_iff_uIcc_subset_left hx, starConvex_iff_segment_subset, segment_eq_uIcc]
#align star_convex_iff_ord_connected starConvex_iff_ordConnected

alias starConvex_iff_ordConnected ↔ StarConvex.ordConnected _
#align star_convex.ord_connected StarConvex.ordConnected

end OrdConnected


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin

! This file was ported from Lean 3 source module logic.unique
! leanprover-community/mathlib commit c4658a649d216f57e99621708b09dcb3dcccbd23
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Logic.IsEmpty
import Mathlib.Init.Logic
import Mathlib.Init.Data.Fin.Basic
import Mathlib.Tactic.Inhabit

/-!
# Types with a unique term

In this file we define a typeclass `Unique`,
which expresses that a type has a unique term.
In other words, a type that is `Inhabited` and a `Subsingleton`.

## Main declaration

* `Unique`: a typeclass that expresses that a type has a unique term.

## Main statements

* `Unique.mk'`: an inhabited subsingleton type is `Unique`. This can not be an instance because it
  would lead to loops in typeclass inference.

* `Function.Surjective.unique`: if the domain of a surjective function is `Unique`, then its
  codomain is `unique` as well.

* `Function.Injective.subsingleton`: if the codomain of an injective function is `Subsingleton`,
  then its domain is `Subsingleton` as well.

* `Function.Injective.unique`: if the codomain of an injective function is `Subsingleton` and its
  domain is `Inhabited`, then its domain is `Unique`.

## Implementation details

The typeclass `Unique α` is implemented as a type,
rather than a `Prop`-valued predicate,
for good definitional properties of the default term.

-/

universe u v w

/-- `Unique α` expresses that `α` is a type with a unique term `default`.

This is implemented as a type, rather than a `Prop`-valued predicate,
for good definitional properties of the default term. -/
@[ext]
structure Unique (α : Sort u) extends Inhabited α where
  /-- In a `Unique` type, every term is equal to the default element (from `Inhabited`). -/
  uniq : ∀ a : α, a = default
#align unique Unique
#align unique.ext_iff Unique.ext_iff
#align unique.ext Unique.ext

attribute [class] Unique
-- The simplifier can already prove this using `eq_iff_true_of_subsingleton`
attribute [nolint simpNF] Unique.mk.injEq

theorem unique_iff_exists_unique (α : Sort u) : Nonempty (Unique α) ↔ ∃! _ : α, True :=
  ⟨fun ⟨u⟩ ↦ ⟨u.default, trivial, fun a _ ↦ u.uniq a⟩,
   fun ⟨a, _, h⟩ ↦ ⟨⟨⟨a⟩, fun _ ↦ h _ trivial⟩⟩⟩
#align unique_iff_exists_unique unique_iff_exists_unique

theorem unique_subtype_iff_exists_unique {α} (p : α → Prop) :
    Nonempty (Unique (Subtype p)) ↔ ∃! a, p a :=
  ⟨fun ⟨u⟩ ↦ ⟨u.default.1, u.default.2, fun a h ↦ congr_arg Subtype.val (u.uniq ⟨a, h⟩)⟩,
   fun ⟨a, ha, he⟩ ↦ ⟨⟨⟨⟨a, ha⟩⟩, fun ⟨b, hb⟩ ↦ by
      congr
      exact he b hb⟩⟩⟩
#align unique_subtype_iff_exists_unique unique_subtype_iff_exists_unique

/-- Given an explicit `a : α` with `Subsingleton α`, we can construct
a `Unique α` instance. This is a def because the typeclass search cannot
arbitrarily invent the `a : α` term. Nevertheless, these instances are all
equivalent by `Unique.Subsingleton.unique`.

See note [reducible non-instances]. -/
@[reducible]
def uniqueOfSubsingleton {α : Sort _} [Subsingleton α] (a : α) : Unique α where
  default := a
  uniq _ := Subsingleton.elim _ _
#align unique_of_subsingleton uniqueOfSubsingleton

instance PUnit.unique : Unique PUnit.{u} where
  default := PUnit.unit
  uniq x := subsingleton x _

-- Porting note:
-- This should not require a nolint,
-- but it is currently failing due to a problem in the linter discussed at
-- https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/.60simpNF.60.20error.20.22unknown.20metavariable.22
@[simp, nolint simpNF]
theorem PUnit.default_eq_unit : (default : PUnit) = PUnit.unit :=
  rfl

#align punit.default_eq_star PUnit.default_eq_unit

/-- Every provable proposition is unique, as all proofs are equal. -/
def uniqueProp {p : Prop} (h : p) : Unique.{0} p where
  default := h
  uniq _ := rfl
#align unique_prop uniqueProp

instance : Unique True :=
  uniqueProp trivial

theorem Fin.eq_zero : ∀ n : Fin 1, n = 0
  | ⟨_, hn⟩ => Fin.eq_of_veq (Nat.eq_zero_of_le_zero (Nat.le_of_lt_succ hn))
#align fin.eq_zero Fin.eq_zero

instance {n : ℕ} : Inhabited (Fin n.succ) :=
  ⟨0⟩

instance inhabitedFinOneAdd (n : ℕ) : Inhabited (Fin (1 + n)) :=
  ⟨⟨0, by rw [Nat.add_comm]; exact Nat.zero_lt_succ _⟩⟩

@[simp]
theorem Fin.default_eq_zero (n : ℕ) : (default : Fin n.succ) = 0 :=
  rfl
#align fin.default_eq_zero Fin.default_eq_zero

instance Fin.unique : Unique (Fin 1) where
  uniq := Fin.eq_zero

namespace Unique

open Function

section

variable [Unique α]

-- see Note [lower instance priority]
instance (priority := 100) : Inhabited α :=
  toInhabited ‹Unique α›

theorem eq_default (a : α) : a = default :=
  uniq _ a
#align unique.eq_default Unique.eq_default

theorem default_eq (a : α) : default = a :=
  (uniq _ a).symm
#align unique.default_eq Unique.default_eq

-- see Note [lower instance priority]
instance (priority := 100) : Subsingleton α :=
  subsingleton_of_forall_eq _ eq_default

theorem forall_iff {p : α → Prop} : (∀ a, p a) ↔ p default :=
  ⟨fun h ↦ h _, fun h x ↦ by rwa [Unique.eq_default x]⟩
#align unique.forall_iff Unique.forall_iff

theorem exists_iff {p : α → Prop} : Exists p ↔ p default :=
  ⟨fun ⟨a, ha⟩ ↦ eq_default a ▸ ha, Exists.intro default⟩
#align unique.exists_iff Unique.exists_iff

end

@[ext]
protected theorem subsingleton_unique' : ∀ h₁ h₂ : Unique α, h₁ = h₂
  | ⟨⟨x⟩, h⟩, ⟨⟨y⟩, _⟩ => by congr; rw [h x, h y]
#align unique.subsingleton_unique' Unique.subsingleton_unique'

instance subsingleton_unique : Subsingleton (Unique α) :=
  ⟨Unique.subsingleton_unique'⟩

/-- Construct `Unique` from `Inhabited` and `Subsingleton`. Making this an instance would create
a loop in the class inheritance graph. -/
@[reducible]
def mk' (α : Sort u) [h₁ : Inhabited α] [Subsingleton α] : Unique α :=
  { h₁ with uniq := fun _ ↦ Subsingleton.elim _ _ }
#align unique.mk' Unique.mk'

end Unique

theorem unique_iff_subsingleton_and_nonempty (α : Sort u) :
    Nonempty (Unique α) ↔ Subsingleton α ∧ Nonempty α :=
  ⟨fun ⟨u⟩ ↦ by constructor <;> exact inferInstance,
   fun ⟨hs, hn⟩ ↦ ⟨by inhabit α; exact Unique.mk' α⟩⟩
#align unique_iff_subsingleton_and_nonempty unique_iff_subsingleton_and_nonempty

@[simp]
theorem Pi.default_def {β : α → Sort v} [∀ a, Inhabited (β a)] :
    @default (∀ a, β a) _ = fun a : α ↦ @default (β a) _ :=
  rfl
#align pi.default_def Pi.default_def

theorem Pi.default_apply {β : α → Sort v} [∀ a, Inhabited (β a)] (a : α) :
    @default (∀ a, β a) _ a = default :=
  rfl
#align pi.default_apply Pi.default_apply

instance Pi.unique {β : α → Sort v} [∀ a, Unique (β a)] : Unique (∀ a, β a) where
  uniq := fun _ ↦ funext fun _ ↦ Unique.eq_default _

/-- There is a unique function on an empty domain. -/
instance Pi.uniqueOfIsEmpty [IsEmpty α] (β : α → Sort v) : Unique (∀ a, β a) where
  default := isEmptyElim
  uniq _ := funext isEmptyElim

theorem eq_const_of_unique [Unique α] (f : α → β) : f = Function.const α (f default) := by
  ext x
  rw [Subsingleton.elim x default]
  rfl
#align eq_const_of_unique eq_const_of_unique

theorem heq_const_of_unique [Unique α] {β : α → Sort v} (f : ∀ a, β a) :
    HEq f (Function.const α (f default)) :=
  (Function.hfunext rfl) fun i _ _ ↦ by rw [Subsingleton.elim i default]; rfl
#align heq_const_of_unique heq_const_of_unique

namespace Function

variable {f : α → β}

/-- If the codomain of an injective function is a subsingleton, then the domain
is a subsingleton as well. -/
protected theorem Injective.subsingleton (hf : Injective f) [Subsingleton β] : Subsingleton α :=
  ⟨fun _ _ ↦ hf <| Subsingleton.elim _ _⟩
#align function.injective.subsingleton Function.Injective.subsingleton

/-- If the domain of a surjective function is a subsingleton, then the codomain is a subsingleton as
well. -/
protected

/-- If the domain of a surjective function is a singleton,
then the codomain is a singleton as well. -/
protected def Surjective.unique (f : α → β) (hf : Surjective f) [Unique.{u} α] : Unique β :=
  @Unique.mk' _ ⟨f default⟩ hf.subsingleton
#align function.surjective.unique Function.Surjective.unique

/-- If `α` is inhabited and admits an injective map to a subsingleton type, then `α` is `Unique`. -/
protected def Injective.unique [Inhabited α] [Subsingleton β] (hf : Injective f) : Unique α :=
  @Unique.mk' _ _ hf.subsingleton
#align function.injective.unique Function.Injective.unique

/-- If a constant function is surjective, then the codomain is a singleton. -/
def Surjective.uniqueOfSurjectiveConst (α : Type _) {β : Type _} (b : β)
    (h : Function.Surjective (Function.const α b)) : Unique β :=
  @uniqueOfSubsingleton _ (subsingleton_of_forall_eq b <| h.forall.mpr fun _ ↦ rfl) b
#align function.surjective.unique_of_surjective_const Function.Surjective.uniqueOfSurjectiveConst

end Function

-- TODO: Mario turned this off as a simp lemma in Std, wanting to profile it.
attribute [simp] eq_iff_true_of_subsingleton in
theorem Unique.bijective {A B} [Unique A] [Unique B] {f : A → B} : Function.Bijective f := by
  rw [Function.bijective_iff_has_inverse]
  refine' ⟨default, _, _⟩ <;> intro x <;> simp
#align unique.bijective Unique.bijective

namespace Option

/-- `Option α` is a `Subsingleton` if and only if `α` is empty. -/
theorem subsingleton_iff_isEmpty {α : Type u} : Subsingleton (Option α) ↔ IsEmpty α :=
  ⟨fun h ↦ ⟨fun x ↦ Option.noConfusion <| @Subsingleton.elim _ h x none⟩,
   fun h ↦ ⟨fun x y ↦
     Option.casesOn x (Option.casesOn y rfl fun x ↦ h.elim x) fun x ↦ h.elim x⟩⟩
#align option.subsingleton_iff_is_empty Option.subsingleton_iff_isEmpty

instance {α} [IsEmpty α] : Unique (Option α) :=
  @Unique.mk' _ _ (subsingleton_iff_isEmpty.2 ‹_›)

end Option

section Subtype
variable {α : Sort u}

instance Unique.subtypeEq (y : α) : Unique { x // x = y } where
  default := ⟨y, rfl⟩
  uniq := fun ⟨x, hx⟩ ↦ by congr

instance Unique.subtypeEq' (y : α) : Unique { x // y = x } where
  default := ⟨y, rfl⟩
  uniq := fun ⟨x, hx⟩ ↦ by subst hx; congr

end Subtype


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.multiset.finset_ops
import data.multiset.fold

/-!
# Lattice operations on multisets
-/

namespace multiset
variables {α : Type*}

/-! ### sup -/
section sup
-- can be defined with just `[has_bot α]` where some lemmas hold without requiring `[order_bot α]`
variables [semilattice_sup α] [order_bot α]

/-- Supremum of a multiset: `sup {a, b, c} = a ⊔ b ⊔ c` -/
def sup (s : multiset α) : α := s.fold (⊔) ⊥

@[simp] lemma sup_zero : (0 : multiset α).sup = ⊥ :=
fold_zero _ _

@[simp] lemma sup_cons (a : α) (s : multiset α) :
  (a ::ₘ s).sup = a ⊔ s.sup :=
fold_cons_left _ _ _ _

@[simp] lemma sup_singleton {a : α} : ({a} : multiset α).sup = a :=
sup_bot_eq

@[simp] lemma sup_add (s₁ s₂ : multiset α) : (s₁ + s₂).sup = s₁.sup ⊔ s₂.sup :=
eq.trans (by simp [sup]) (fold_add _ _ _ _ _)

lemma sup_le {s : multiset α} {a : α} : s.sup ≤ a ↔ (∀b ∈ s, b ≤ a) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib] {contextual := tt})

lemma le_sup {s : multiset α} {a : α} (h : a ∈ s) : a ≤ s.sup :=
sup_le.1 (le_refl _) _ h

lemma sup_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₁.sup ≤ s₂.sup :=
sup_le.2 $ assume b hb, le_sup (h hb)

variables [decidable_eq α]

@[simp] lemma sup_erase_dup (s : multiset α) : (erase_dup s).sup = s.sup :=
fold_erase_dup_idem _ _ _

@[simp] lemma sup_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).sup = s₁.sup ⊔ s₂.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_add]; simp

@[simp] lemma sup_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).sup = s₁.sup ⊔ s₂.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_add]; simp

@[simp] lemma sup_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).sup = a ⊔ s.sup :=
by rw [← sup_erase_dup, erase_dup_ext.2, sup_erase_dup, sup_cons]; simp

lemma nodup_sup_iff {α : Type*} [decidable_eq α] {m : multiset (multiset α) } :
  m.sup.nodup ↔ ∀ (a : multiset α), a ∈ m → a.nodup :=
begin
  apply m.induction_on,
  { simp },
  { intros a s h,
    simp [h] }
end

end sup

/-! ### inf -/
section inf
-- can be defined with just `[has_top α]` where some lemmas hold without requiring `[order_top α]`
variables [semilattice_inf α] [order_top α]

/-- Infimum of a multiset: `inf {a, b, c} = a ⊓ b ⊓ c` -/
def inf (s : multiset α) : α := s.fold (⊓) ⊤

@[simp] lemma inf_zero : (0 : multiset α).inf = ⊤ :=
fold_zero _ _

@[simp]

@[simp] lemma inf_singleton {a : α} : ({a} : multiset α).inf = a :=
inf_top_eq

@[simp] lemma inf_add (s₁ s₂ : multiset α) : (s₁ + s₂).inf = s₁.inf ⊓ s₂.inf :=
eq.trans (by simp [inf]) (fold_add _ _ _ _ _)

lemma le_inf {s : multiset α} {a : α} : a ≤ s.inf ↔ (∀b ∈ s, a ≤ b) :=
multiset.induction_on s (by simp)
  (by simp [or_imp_distrib, forall_and_distrib] {contextual := tt})

lemma inf_le {s : multiset α} {a : α} (h : a ∈ s) : s.inf ≤ a :=
le_inf.1 (le_refl _) _ h

lemma inf_mono {s₁ s₂ : multiset α} (h : s₁ ⊆ s₂) : s₂.inf ≤ s₁.inf :=
le_inf.2 $ assume b hb, inf_le (h hb)

variables [decidable_eq α]

@[simp] lemma inf_erase_dup (s : multiset α) : (erase_dup s).inf = s.inf :=
fold_erase_dup_idem _ _ _

@[simp] lemma inf_ndunion (s₁ s₂ : multiset α) :
  (ndunion s₁ s₂).inf = s₁.inf ⊓ s₂.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_add]; simp

@[simp] lemma inf_union (s₁ s₂ : multiset α) :
  (s₁ ∪ s₂).inf = s₁.inf ⊓ s₂.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_add]; simp

@[simp] lemma inf_ndinsert (a : α) (s : multiset α) :
  (ndinsert a s).inf = a ⊓ s.inf :=
by rw [← inf_erase_dup, erase_dup_ext.2, inf_erase_dup, inf_cons]; simp

end inf

end multiset


-- Las_clases_de_equivalencia_son_disjuntas.lean
-- Las clases de equivalencia son disjuntas
-- José A. Alonso Jiménez
-- Sevilla, 7 de octubre de 2021
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Este ejercicio es el 8º de una serie, que comenzó con el [ejercicio
-- del 30 de septiembre](https://bit.ly/2YfsvBZ), cuyo objetivo es
-- demostrar que el tipo de las particiones de un conjunto `X` es
-- isomorfo al tipo de las relaciones de equivalencia sobre `X`.
--
-- El ejercicio consiste en demostrar que si R es una relación de
-- equivalencia en A, entonces las clases de equivalencia de R son
-- disjuntas.
-- ---------------------------------------------------------------------

import tactic

variable {A : Type}
variable (R : A → A → Prop)

def clase (a : A) :=
  {b : A | R b a}

def clases : (A → A → Prop) → set (set A) :=
  λ R, {B : set A | ∃ x : A, B = clase R x}

-- Se usarán los dos siguientes lemas auxiliares
lemma subclase_si_pertenece
  {R : A → A → Prop}
  (hR: equivalence R)
  {a b : A}
  : a ∈ clase R b → clase R a ⊆ clase R b :=
λ hab z hza, hR.2.2 hza hab

lemma clases_iguales_si_pertenece
  {R : A → A → Prop}
  (hR: equivalence R)
  {a b : A}
  : a ∈ clase R b → clase R a = clase R b :=
λ hab, set.subset.antisymm
        (subclase_si_pertenece hR hab)
        (subclase_si_pertenece hR (hR.2.1 hab))

-- 1ª demostración
example
  (hR: equivalence R)
  : ∀ X Y ∈ clases R, (X ∩ Y : set A).nonempty → X = Y :=
begin
  intros X hX Y hY hXY,
  unfold clases at hX hY,
  dsimp at hX hY,
  cases hX with a ha,
  cases hY with b hb,
  rw [ha, hb] at *,
  rw set.nonempty_def at hXY,
  cases hXY with c hc,
  cases hc with hca hcb,
  apply clases_iguales_si_pertenece hR,
  apply hR.2.2 _ hcb,
  apply hR.2.1,
  exact hca,
end

-- 2ª demostración
example
  (hR: equivalence R)
  : ∀ X Y ∈ clases R, (X ∩ Y : set A).nonempty → X = Y :=
begin
  intros X hX Y hY hXY,
  cases hX with a ha,
  cases hY with b hb,
  rw [ha, hb] at *,
  rw set.nonempty_def at hXY,
  cases hXY with c hc,
  cases hc with hca hcb,
  apply clases_iguales_si_pertenece hR,
  apply hR.2.2 _ hcb,
  apply hR.2.1,
  exact hca,
end

-- 3ª demostración
example
  (hR: equivalence R)
  : ∀ X Y ∈ clases R, (X ∩ Y : set A).nonempty → X = Y :=
begin
  rintros X ⟨a, rfl⟩ Y ⟨b, rfl⟩ ⟨c, hca, hcb⟩,
  apply clases_iguales_si_pertenece hR,
  apply hR.2.2 _ hcb,
  apply hR.2.1,
  exact hca,
end

-- 4ª demostración
lemma clases_disjuntas
  (hR: equivalence R)
  : ∀ X Y ∈ clases R, (X ∩ Y : set A).nonempty → X = Y :=
begin
  rintros X ⟨a, rfl⟩ Y ⟨b, rfl⟩ ⟨c, hca, hcb⟩,
  exact clases_iguales_si_pertenece hR (hR.2.2 (hR.2.1 hca) hcb),
end


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

! This file was ported from Lean 3 source module field_theory.is_alg_closed.classification
! leanprover-community/mathlib commit 70fd9563a21e7b963887c9360bd29b2393e6225a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.AlgebraicIndependent
import Mathbin.FieldTheory.IsAlgClosed.Basic
import Mathbin.Data.Polynomial.Cardinal
import Mathbin.Data.MvPolynomial.Cardinal
import Mathbin.Data.Zmod.Algebra

/-!
# Classification of Algebraically closed fields

This file contains results related to classifying algebraically closed fields.

## Main statements

* `is_alg_closed.equiv_of_transcendence_basis` Two fields with the same characteristic and the same
  cardinality of transcendence basis are isomorphic.
* `is_alg_closed.ring_equiv_of_cardinal_eq_of_char_eq` Two uncountable algebraically closed fields
  are isomorphic if they have the same characteristic and the same cardinality.
-/

universe u

open Cardinal Polynomial

open Cardinal

section AlgebraicClosure

namespace Algebra.IsAlgebraic

variable (R L : Type u) [CommRing R] [CommRing L] [IsDomain L] [Algebra R L]

variable [NoZeroSMulDivisors R L] (halg : Algebra.IsAlgebraic R L)

theorem cardinal_mk_le_sigma_polynomial :
    (#L) ≤ (#Σp : R[X], { x : L // x ∈ (p.map (algebraMap R L)).roots }) :=
  @mk_le_of_injective L (Σp : R[X], { x : L | x ∈ (p.map (algebraMap R L)).roots })
    (fun x : L =>
      let p := Classical.indefiniteDescription _ (halg x)
      ⟨p.1, x, by
        dsimp
        have h : p.1.map (algebraMap R L) ≠ 0 :=
          by
          rw [Ne.def, ← Polynomial.degree_eq_bot,
            Polynomial.degree_map_eq_of_injective (NoZeroSMulDivisors.algebraMap_injective R L),
            Polynomial.degree_eq_bot]
          exact p.2.1
        erw [Polynomial.mem_roots h, Polynomial.IsRoot, Polynomial.eval_map, ← Polynomial.aeval_def,
          p.2.2]⟩)
    fun x y => by
    intro h
    simp only at h
    refine' (Subtype.heq_iff_coe_eq _).1 h.2
    simp only [h.1, iff_self_iff, forall_true_iff]
#align algebra.is_algebraic.cardinal_mk_le_sigma_polynomial Algebra.IsAlgebraic.cardinal_mk_le_sigma_polynomial

/-- The cardinality of an algebraic extension is at most the maximum of the cardinality
of the base ring or `ℵ₀` -/
theorem cardinal_mk_le_max : (#L) ≤ max (#R) ℵ₀ :=
  calc
    (#L) ≤ (#Σp : R[X], { x : L // x ∈ (p.map (algebraMap R L)).roots }) :=
      cardinal_mk_le_sigma_polynomial R L halg
    _ = Cardinal.sum fun p : R[X] => #{ x : L | x ∈ (p.map (algebraMap R L)).roots } := by
      rw [← mk_sigma] <;> rfl
    _ ≤ Cardinal.sum.{u, u} fun p : R[X] => ℵ₀ :=
      (sum_le_sum _ _ fun p => (Multiset.finite_toSet _).lt_aleph0.le)
    _ = (#R[X]) * ℵ₀ := (sum_const' _ _)
    _ ≤ max (max (#R[X]) ℵ₀) ℵ₀ := (mul_le_max _ _)
    _ ≤ max (max (max (#R) ℵ₀) ℵ₀) ℵ₀ :=
      (max_le_max (max_le_max Polynomial.cardinal_mk_le_max le_rfl) le_rfl)
    _ = max (#R) ℵ₀ := by simp only [max_assoc, max_comm ℵ₀, max_left_comm ℵ₀, max_self]

#align algebra.is_algebraic.cardinal_mk_le_max Algebra.IsAlgebraic.cardinal_mk_le_max

end Algebra.IsAlgebraic

end AlgebraicClosure

namespace IsAlgClosed

section Classification

noncomputable section

variable {R L K : Type _} [CommRing R]

variable [Field K] [Algebra R K]

variable [Field L] [Algebra R L]

variable {ι : Type _} (v : ι → K)

variable {κ : Type _} (w : κ → L)

variable (hv : AlgebraicIndependent R v)

theorem isAlgClosureOfTranscendenceBasis [IsAlgClosed K] (hv : IsTranscendenceBasis R v) :
    IsAlgClosure (Algebra.adjoin R (Set.range v)) K :=
  letI := RingHom.domain_nontrivial (algebraMap R K)
  { alg_closed := by infer_instance
    algebraic := hv.is_algebraic }
#align is_alg_closed.is_alg_closure_of_transcendence_basis IsAlgClosed.isAlgClosureOfTranscendenceBasis

variable (hw : AlgebraicIndependent R w)

/-- setting `R` to be `zmod (ring_char R)` this result shows that if two algebraically
closed fields have equipotent transcendence bases and the same characteristic then they are
isomorphic. -/
def equivOfTranscendenceBasis [IsAlgClosed K] [IsAlgClosed L] (e : ι ≃ κ)
    (hv : IsTranscendenceBasis R v) (hw : IsTranscendenceBasis R w) : K ≃+* L :=
  by
  letI := is_alg_closure_of_transcendence_basis v hv <;>
      letI := is_alg_closure_of_transcendence_basis w hw <;>
    have e : Algebra.adjoin R (Set.range v) ≃+* Algebra.adjoin R (Set.range w)
  · refine' hv.1.aevalEquiv.symm.toRingEquiv.trans _
    refine'
      (AlgEquiv.ofAlgHom (MvPolynomial.rename e) (MvPolynomial.rename e.symm) _ _).toRingEquiv.trans
        _
    · ext
      simp
    · ext
      simp
    exact hw.1.aevalEquiv.toRingEquiv
  exact IsAlgClosure.equivOfEquiv K L e
#align is_alg_closed.equiv_of_transcendence_basis IsAlgClosed.equivOfTranscendenceBasis

end Classification

section Cardinal

variable {R L K : Type u} [CommRing R]

variable [Field K] [Algebra R K] [IsAlgClosed K]

variable {ι : Type u} (v : ι → K)

variable (hv : IsTranscendenceBasis R v)

theorem cardinal_le_max_transcendence_basis (hv : IsTranscendenceBasis R v) :
    (#K) ≤ max (max (#R) (#ι)) ℵ₀ :=
  calc
    (#K) ≤ max (#Algebra.adjoin R (Set.range v)) ℵ₀ :=
      letI := is_alg_closure_of_transcendence_basis v hv
      Algebra.IsAlgebraic.cardinal_mk_le_max _ _ IsAlgClosure.algebraic
    _ = max (#MvPolynomial ι R) ℵ₀ := by rw [Cardinal.eq.2 ⟨hv.1.aevalEquiv.toEquiv⟩]
    _ ≤ max (max (max (#R) (#ι)) ℵ₀) ℵ₀ := (max_le_max MvPolynomial.cardinal_mk_le_max le_rfl)
    _ = _ := by simp [max_assoc]

#align is_alg_closed.cardinal_le_max_transcendence_basis IsAlgClosed.cardinal_le_max_transcendence_basis

/-- If `K` is an uncountable algebraically closed field, then its
cardinality is the same as that of a transcendence basis. -/
theorem cardinal_eq_cardinal_transcendence_basis_of_aleph0_lt [Nontrivial R]
    (hv : IsTranscendenceBasis R v) (hR : (#R) ≤ ℵ₀) (hK : ℵ₀ < (#K)) : (#K) = (#ι) :=
  have : ℵ₀ ≤ (#ι) :=
    le_of_not_lt fun h =>
      not_le_of_gt hK <|
        calc
          (#K) ≤ max (max (#R) (#ι)) ℵ₀ := cardinal_le_max_transcendence_basis v hv
          _ ≤ _ := max_le (max_le hR (le_of_lt h)) le_rfl

  le_antisymm
    (calc
      (#K) ≤ max (max (#R) (#ι)) ℵ₀ := cardinal_le_max_transcendence_basis v hv
      _ = (#ι) := by
        rw [max_eq_left, max_eq_right]
        · exact le_trans hR this
        · exact le_max_of_le_right this
      )
    (mk_le_of_injective (show Function.Injective v from hv.1.Injective))
#align is_alg_closed.cardinal_eq_cardinal_transcendence_basis_of_aleph_0_lt IsAlgClosed.cardinal_eq_cardinal_transcendence_basis_of_aleph0_lt

end Cardinal

variable {K L : Type} [Field K] [Field L] [IsAlgClosed K] [IsAlgClosed L]

/-- Two uncountable algebraically closed fields of characteristic zero are isomorphic
if they have the same cardinality. -/
@[nolint def_lemma]
theorem ringEquivOfCardinalEqOfCharZero [CharZero K] [CharZero L] (hK : ℵ₀ < (#K))
    (hKL : (#K) = (#L)) : K ≃+* L := by
  apply Classical.choice
  cases'
    exists_isTranscendenceBasis ℤ
      (show Function.Injective (algebraMap ℤ K) from Int.cast_injective) with
    s hs
  cases'
    exists_isTranscendenceBasis ℤ
      (show Function.Injective (algebraMap ℤ L) from Int.cast_injective) with
    t ht
  have : (#s) = (#t) :=
    by
    rw [← cardinal_eq_cardinal_transcendence_basis_of_aleph_0_lt _ hs (le_of_eq mk_int) hK, ←
      cardinal_eq_cardinal_transcendence_basis_of_aleph_0_lt _ ht (le_of_eq mk_int), hKL]
    rwa [← hKL]
  cases' Cardinal.eq.1 this with e
  exact ⟨equiv_of_transcendence_basis _ _ e hs ht⟩
#align is_alg_closed.ring_equiv_of_cardinal_eq_of_char_zero IsAlgClosed.ringEquivOfCardinalEqOfCharZero

private theorem ring_equiv_of_cardinal_eq_of_char_p (p : ℕ) [Fact p.Prime] [CharP K p] [CharP L p]
    (hK : ℵ₀ < (#K)) (hKL : (#K) = (#L)) : K ≃+* L :=
  by
  apply Classical.choice
  cases'
    exists_isTranscendenceBasis (ZMod p)
      (show Function.Injective (algebraMap (ZMod p) K) from RingHom.injective _) with
    s hs
  cases'
    exists_isTranscendenceBasis (ZMod p)
      (show Function.Injective (algebraMap (ZMod p) L) from RingHom.injective _) with
    t ht
  have : (#s) = (#t) :=
    by
    rw [←
      cardinal_eq_cardinal_transcendence_basis_of_aleph_0_lt _ hs (lt_aleph_0_of_finite (ZMod p)).le
        hK,
      ←
      cardinal_eq_cardinal_transcendence_basis_of_aleph_0_lt _ ht
        (lt_aleph_0_of_finite (ZMod p)).le,
      hKL]
    rwa [← hKL]
  cases' Cardinal.eq.1 this with e
  exact ⟨equiv_of_transcendence_basis _ _ e hs ht⟩
#align is_alg_closed.ring_equiv_of_cardinal_eq_of_char_p is_alg_closed.ring_equiv_of_cardinal_eq_of_char_p

/-- Two uncountable algebraically closed fields are isomorphic
if they have the same cardinality and the same characteristic. -/
@[nolint def_lemma]
theorem ringEquivOfCardinalEqOfCharEq (p : ℕ) [CharP K p] [CharP L p] (hK : ℵ₀ < (#K))
    (hKL : (#K) = (#L)) : K ≃+* L := by
  apply Classical.choice
  rcases CharP.char_is_prime_or_zero K p with (hp | hp)
  · haveI : Fact p.prime := ⟨hp⟩
    exact ⟨ring_equiv_of_cardinal_eq_of_char_p p hK hKL⟩
  · rw [hp] at *
    skip
    letI : CharZero K := CharP.charP_to_charZero K
    letI : CharZero L := CharP.charP_to_charZero L
    exact ⟨ring_equiv_of_cardinal_eq_of_char_zero hK hKL⟩
#align is_alg_closed.ring_equiv_of_cardinal_eq_of_char_eq IsAlgClosed.ringEquivOfCardinalEqOfCharEq

end IsAlgClosed


import Euclid.axioms
open Euclidean_plane
variables {point : Type} [Euclidean_plane point]

theorem prop1 (a b : point) : ∃ c, eqd a b a c → eqd a b b c := sorry
theorem prop2 (a b c : point) : ∃ d, eqd a d b c := sorry
theorem prop3 (a b c d : point) (h : ¬eqd a b c d) : (∃ x, B a x b → eqd a x c d) ∨ (∃ x, B c x d → eqd a b c x) := sorry
--theorem prop4
--theorem prop5
--theorem prop6
theorem prop7 (a b c d c' d' x : point) : eqd a c a c' → eqd b c b c' → B a d b → B a d' b
→ B c d x → B c' d' x → d ≠ x → d' ≠ x → c = c' := unique_tri a b c d c' d' x
--theorem prop8
--theorem prop9
theorem prop10 (a b : point) : ∃ c, B a c b → eqd a c b c := sorry
--theorem prop11
--theorem prop12
--theorem prop13
--theorem prop14
--theorem prop15
--theorem prop16
--theorem prop17
--theorem prop18
--theorem prop19
--theorem prop20
--theorem prop21
--theorem prop22
--theorem prop23
--theorem prop24
--theorem prop25
--theorem prop26
--theorem prop27
--theorem prop28
--theorem prop29
theorem prop30 (a b c d e f : point) {h1 : a ≠ b} {h2 : c ≠ d} {h3 : e ≠ f} : parallel a b c d h1 h2 → parallel a b e f h1 h3 → parallel c d e f h2 h3:=
sorry