/-
Copyright (c) 2019 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp, François Dupuis
-/
import analysis.convex.basic
import tactic.field_simp
import tactic.linarith
import tactic.ring

/-!
# Convex and concave functions

This file defines convex and concave functions in vector spaces and proves the finite Jensen
inequality. The integral version can be found in `analysis.convex.integral`.

A function `f : E → β` is `convex_on` a set `s` if `s` is itself a convex set, and for any two
points `x y ∈ s`, the segment joining `(x, f x)` to `(y, f y)` is above the graph of `f`.
Equivalently, `convex_on 𝕜 f s` means that the epigraph `{p : E × β | p.1 ∈ s ∧ f p.1 ≤ p.2}` is
a convex set.

## Main declarations

* `convex_on 𝕜 s f`: The function `f` is convex on `s` with scalars `𝕜`.
* `concave_on 𝕜 s f`: The function `f` is concave on `s` with scalars `𝕜`.
* `strict_convex_on 𝕜 s f`: The function `f` is strictly convex on `s` with scalars `𝕜`.
* `strict_concave_on 𝕜 s f`: The function `f` is strictly concave on `s` with scalars `𝕜`.
-/

open finset linear_map set
open_locale big_operators classical convex pointwise

variables {𝕜 E F β ι : Type*}

section ordered_semiring
variables [ordered_semiring 𝕜]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid β]

section has_smul
variables (𝕜) [has_smul 𝕜 E] [has_smul 𝕜 β] (s : set E) (f : E → β)

/-- Convexity of functions -/
def convex_on : Prop :=
convex 𝕜 s ∧
  ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
    f (a • x + b • y) ≤ a • f x + b • f y

/-- Concavity of functions -/
def concave_on : Prop :=
convex 𝕜 s ∧
  ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → a + b = 1 →
    a • f x + b • f y ≤ f (a • x + b • y)

/-- Strict convexity of functions -/
def strict_convex_on : Prop :=
convex 𝕜 s ∧
  ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x ≠ y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
    f (a • x + b • y) < a • f x + b • f y

/-- Strict concavity of functions -/
def strict_concave_on : Prop :=
convex 𝕜 s ∧
  ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x ≠ y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
    a • f x + b • f y < f (a • x + b • y)

variables {𝕜 s f}

open order_dual (to_dual of_dual)

lemma convex_on.dual (hf : convex_on 𝕜 s f) : concave_on 𝕜 s (to_dual ∘ f) := hf

lemma concave_on.dual (hf : concave_on 𝕜 s f) : convex_on 𝕜 s (to_dual ∘ f) := hf

lemma strict_convex_on.dual (hf : strict_convex_on 𝕜 s f) : strict_concave_on 𝕜 s (to_dual ∘ f) :=
hf

lemma strict_concave_on.dual (hf : strict_concave_on 𝕜 s f) : strict_convex_on 𝕜 s (to_dual ∘ f) :=
hf

lemma convex_on_id {s : set β} (hs : convex 𝕜 s) : convex_on 𝕜 s id := ⟨hs, by { intros, refl }⟩

lemma concave_on_id {s : set β} (hs : convex 𝕜 s) : concave_on 𝕜 s id := ⟨hs, by { intros, refl }⟩

lemma convex_on.subset {t : set E} (hf : convex_on 𝕜 t f) (hst : s ⊆ t) (hs : convex 𝕜 s) :
  convex_on 𝕜 s f :=
⟨hs, λ x y hx hy, hf.2 (hst hx) (hst hy)⟩

lemma concave_on.subset {t : set E} (hf : concave_on 𝕜 t f) (hst : s ⊆ t) (hs : convex 𝕜 s) :
  concave_on 𝕜 s f :=
⟨hs, λ x y hx hy, hf.2 (hst hx) (hst hy)⟩

lemma strict_convex_on.subset {t : set E} (hf : strict_convex_on 𝕜 t f) (hst : s ⊆ t)
  (hs : convex 𝕜 s) :
  strict_convex_on 𝕜 s f :=
⟨hs, λ x y hx hy, hf.2 (hst hx) (hst hy)⟩

lemma strict_concave_on.subset {t : set E} (hf : strict_concave_on 𝕜 t f) (hst : s ⊆ t)
  (hs : convex 𝕜 s) :
  strict_concave_on 𝕜 s f :=
⟨hs, λ x y hx hy, hf.2 (hst hx) (hst hy)⟩

end has_smul

section distrib_mul_action
variables [has_smul 𝕜 E] [distrib_mul_action 𝕜 β] {s : set E} {f g : E → β}

lemma convex_on.add (hf : convex_on 𝕜 s f) (hg : convex_on 𝕜 s g) :
  convex_on 𝕜 s (f + g) :=
⟨hf.1, λ x y hx hy a b ha hb hab,
  calc
    f (a • x + b • y) + g (a • x + b • y) ≤ (a • f x + b • f y) + (a • g x + b • g y)
      : add_le_add (hf.2 hx hy ha hb hab) (hg.2 hx hy ha hb hab)
    ... = a • (f x + g x) + b • (f y + g y) : by rw [smul_add, smul_add, add_add_add_comm]⟩

lemma concave_on.add (hf : concave_on 𝕜 s f) (hg : concave_on 𝕜 s g) :
  concave_on 𝕜 s (f + g) :=
hf.dual.add hg

end distrib_mul_action

section module
variables [has_smul 𝕜 E] [module 𝕜 β] {s : set E} {f : E → β}

lemma convex_on_const (c : β) (hs : convex 𝕜 s) : convex_on 𝕜 s (λ x:E, c) :=
⟨hs, λ x y _ _ a b _ _ hab, (convex.combo_self hab c).ge⟩

lemma concave_on_const (c : β) (hs : convex 𝕜 s) : concave_on 𝕜 s (λ x:E, c) :=
@convex_on_const _ _ βᵒᵈ _ _ _ _ _ _ c hs

lemma convex_on_of_convex_epigraph (h : convex 𝕜 {p : E × β | p.1 ∈ s ∧ f p.1 ≤ p.2}) :
  convex_on 𝕜 s f :=
⟨λ x y hx hy a b ha hb hab, (@h (x, f x) (y, f y) ⟨hx, le_rfl⟩ ⟨hy, le_rfl⟩ a b ha hb hab).1,
  λ x y hx hy a b ha hb hab, (@h (x, f x) (y, f y) ⟨hx, le_rfl⟩ ⟨hy, le_rfl⟩ a b ha hb hab).2⟩

lemma concave_on_of_convex_hypograph (h : convex 𝕜 {p : E × β | p.1 ∈ s ∧ p.2 ≤ f p.1}) :
  concave_on 𝕜 s f :=
@convex_on_of_convex_epigraph 𝕜  E βᵒᵈ _ _ _ _ _ _ _ h

end module

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

lemma convex_on.convex_le (hf : convex_on 𝕜 s f) (r : β) :
  convex 𝕜 {x ∈ s | f x ≤ r} :=
λ x y hx hy a b ha hb hab, ⟨hf.1 hx.1 hy.1 ha hb hab,
  calc
    f (a • x + b • y) ≤ a • f x + b • f y : hf.2 hx.1 hy.1 ha hb hab
                  ... ≤ a • r + b • r     : add_le_add (smul_le_smul_of_nonneg hx.2 ha)
                                              (smul_le_smul_of_nonneg hy.2 hb)
                  ... = r                 : convex.combo_self hab r⟩

lemma concave_on.convex_ge (hf : concave_on 𝕜 s f) (r : β) :
  convex 𝕜 {x ∈ s | r ≤ f x} :=
hf.dual.convex_le r

lemma convex_on.convex_epigraph (hf : convex_on 𝕜 s f) :
  convex 𝕜 {p : E × β | p.1 ∈ s ∧ f p.1 ≤ p.2} :=
begin
  rintro ⟨x, r⟩ ⟨y, t⟩ ⟨hx, hr⟩ ⟨hy, ht⟩ a b ha hb hab,
  refine ⟨hf.1 hx hy ha hb hab, _⟩,
  calc f (a • x + b • y) ≤ a • f x + b • f y : hf.2 hx hy ha hb hab
  ... ≤ a • r + b • t : add_le_add (smul_le_smul_of_nonneg hr ha)
                            (smul_le_smul_of_nonneg ht hb)
end

lemma concave_on.convex_hypograph (hf : concave_on 𝕜 s f) :
  convex 𝕜 {p : E × β | p.1 ∈ s ∧ p.2 ≤ f p.1} :=
hf.dual.convex_epigraph

lemma convex_on_iff_convex_epigraph :
  convex_on 𝕜 s f ↔ convex 𝕜 {p : E × β | p.1 ∈ s ∧ f p.1 ≤ p.2} :=
⟨convex_on.convex_epigraph, convex_on_of_convex_epigraph⟩

lemma concave_on_iff_convex_hypograph :
  concave_on 𝕜 s f ↔ convex 𝕜 {p : E × β | p.1 ∈ s ∧ p.2 ≤ f p.1} :=
@convex_on_iff_convex_epigraph 𝕜 E βᵒᵈ _ _ _ _ _ _ _ f

end ordered_smul

section module
variables [module 𝕜 E] [has_smul 𝕜 β] {s : set E} {f : E → β}

/-- Right translation preserves convexity. -/
lemma convex_on.translate_right (hf : convex_on 𝕜 s f) (c : E) :
  convex_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, c + z)) :=
⟨hf.1.translate_preimage_right _, λ x y hx hy a b ha hb hab,
  calc
    f (c + (a • x + b • y)) = f (a • (c + x) + b • (c + y))
        : by rw [smul_add, smul_add, add_add_add_comm, convex.combo_self hab]
    ... ≤ a • f (c + x) + b • f (c + y) : hf.2 hx hy ha hb hab⟩

/-- Right translation preserves concavity. -/
lemma concave_on.translate_right (hf : concave_on 𝕜 s f) (c : E) :
  concave_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, c + z)) :=
hf.dual.translate_right _

/-- Left translation preserves convexity. -/
lemma convex_on.translate_left (hf : convex_on 𝕜 s f) (c : E) :
  convex_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, z + c)) :=
by simpa only [add_comm] using hf.translate_right _

/-- Left translation preserves concavity. -/
lemma concave_on.translate_left (hf : concave_on 𝕜 s f) (c : E) :
  concave_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, z + c)) :=
hf.dual.translate_left _

end module

section module
variables [module 𝕜 E] [module 𝕜 β]

lemma convex_on_iff_forall_pos {s : set E} {f : E → β} :
  convex_on 𝕜 s f ↔ convex 𝕜 s ∧
    ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1
    → f (a • x + b • y) ≤ a • f x + b • f y :=
begin
  refine and_congr_right' ⟨λ h x y hx hy a b ha hb hab, h hx hy ha.le hb.le hab,
    λ h x y hx hy a b ha hb hab, _⟩,
  obtain rfl | ha' := ha.eq_or_lt,
  { rw [zero_add] at hab, subst b, simp_rw [zero_smul, zero_add, one_smul] },
  obtain rfl | hb' := hb.eq_or_lt,
  { rw [add_zero] at hab, subst a, simp_rw [zero_smul, add_zero, one_smul] },
  exact h hx hy ha' hb' hab,
end

lemma concave_on_iff_forall_pos {s : set E} {f : E → β} :
  concave_on 𝕜 s f ↔ convex 𝕜 s ∧
    ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1
    → a • f x + b • f y ≤ f (a • x + b • y) :=
@convex_on_iff_forall_pos 𝕜 E βᵒᵈ _ _ _ _ _ _ _

lemma convex_on_iff_pairwise_pos {s : set E} {f : E → β} :
  convex_on 𝕜 s f ↔ convex 𝕜 s ∧
    s.pairwise (λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1
    → f (a • x + b • y) ≤ a • f x + b • f y) :=
begin
  rw convex_on_iff_forall_pos,
  refine and_congr_right' ⟨λ h x hx y hy _ a b ha hb hab, h hx hy ha hb hab,
    λ h x y hx hy a b ha hb hab, _⟩,
  obtain rfl | hxy := eq_or_ne x y,
  { rw [convex.combo_self hab, convex.combo_self hab] },
  exact h hx hy hxy ha hb hab,
end

lemma concave_on_iff_pairwise_pos {s : set E} {f : E → β} :
  concave_on 𝕜 s f ↔ convex 𝕜 s ∧
   s.pairwise (λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1
    → a • f x + b • f y ≤ f (a • x + b • y)) :=
@convex_on_iff_pairwise_pos 𝕜 E βᵒᵈ _ _ _ _ _ _ _

/-- A linear map is convex. -/
lemma linear_map.convex_on (f : E →ₗ[𝕜] β) {s : set E} (hs : convex 𝕜 s) : convex_on 𝕜 s f :=
⟨hs, λ _ _ _ _ _ _ _ _ _, by rw [f.map_add, f.map_smul, f.map_smul]⟩

/-- A linear map is concave. -/
lemma linear_map.concave_on (f : E →ₗ[𝕜] β) {s : set E} (hs : convex 𝕜 s) : concave_on 𝕜 s f :=
⟨hs, λ _ _ _ _ _ _ _ _ _, by rw [f.map_add, f.map_smul, f.map_smul]⟩

lemma strict_convex_on.convex_on {s : set E} {f : E → β} (hf : strict_convex_on 𝕜 s f) :
  convex_on 𝕜 s f :=
convex_on_iff_pairwise_pos.mpr ⟨hf.1, λ x hx y hy hxy a b ha hb hab, (hf.2 hx hy hxy ha hb hab).le⟩

lemma strict_concave_on.concave_on {s : set E} {f : E → β} (hf : strict_concave_on 𝕜 s f) :
  concave_on 𝕜 s f :=
hf.dual.convex_on

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

lemma strict_convex_on.convex_lt (hf : strict_convex_on 𝕜 s f) (r : β) :
  convex 𝕜 {x ∈ s | f x < r} :=
convex_iff_pairwise_pos.2 $ λ x hx y hy hxy a b ha hb hab, ⟨hf.1 hx.1 hy.1 ha.le hb.le hab,
  calc
    f (a • x + b • y) < a • f x + b • f y : hf.2 hx.1 hy.1 hxy ha hb hab
                  ... ≤ a • r + b • r     : add_le_add (smul_lt_smul_of_pos hx.2 ha).le
                                              (smul_lt_smul_of_pos hy.2 hb).le
                  ... = r                 : convex.combo_self hab r⟩

lemma strict_concave_on.convex_gt (hf : strict_concave_on 𝕜 s f) (r : β) :
  convex 𝕜 {x ∈ s | r < f x} :=
hf.dual.convex_lt r

end ordered_smul

section linear_order
variables [linear_order E] {s : set E} {f : E → β}

/-- For a function on a convex set in a linearly ordered space (where the order and the algebraic
structures aren't necessarily compatible), in order to prove that it is convex, it suffices to
verify the inequality `f (a • x + b • y) ≤ a • f x + b • f y` only for `x < y` and positive `a`,
`b`. The main use case is `E = 𝕜` however one can apply it, e.g., to `𝕜^n` with lexicographic order.
-/
lemma linear_order.convex_on_of_lt (hs : convex 𝕜 s)
  (hf : ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x < y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
    f (a • x + b • y) ≤ a • f x + b • f y) : convex_on 𝕜 s f :=
begin
  refine convex_on_iff_pairwise_pos.2 ⟨hs, λ x hx y hy hxy a b ha hb hab, _⟩,
  wlog h : x ≤ y using [x y a b, y x b a],
  { exact le_total _ _ },
  exact hf hx hy (h.lt_of_ne hxy) ha hb hab,
end

/-- For a function on a convex set in a linearly ordered space (where the order and the algebraic
structures aren't necessarily compatible), in order to prove that it is concave it suffices to
verify the inequality `a • f x + b • f y ≤ f (a • x + b • y)` for `x < y` and positive `a`, `b`. The
main use case is `E = ℝ` however one can apply it, e.g., to `ℝ^n` with lexicographic order. -/
lemma linear_order.concave_on_of_lt (hs : convex 𝕜 s)
  (hf : ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x < y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
     a • f x + b • f y ≤ f (a • x + b • y)) : concave_on 𝕜 s f :=
@linear_order.convex_on_of_lt _ _ βᵒᵈ _ _ _ _ _ _ s f hs hf

/-- For a function on a convex set in a linearly ordered space (where the order and the algebraic
structures aren't necessarily compatible), in order to prove that it is convex, it suffices to
verify the inequality `f (a • x + b • y) ≤ a • f x + b • f y` for `x < y` and positive `a`, `b`. The
main use case is `E = 𝕜` however one can apply it, e.g., to `𝕜^n` with lexicographic order. -/
lemma linear_order.strict_convex_on_of_lt (hs : convex 𝕜 s)
  (hf : ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x < y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
    f (a • x + b • y) < a • f x + b • f y) : strict_convex_on 𝕜 s f :=
begin
  refine ⟨hs, λ x y hx hy hxy a b ha hb hab, _⟩,
  wlog h : x ≤ y using [x y a b, y x b a],
  { exact le_total _ _ },
  exact hf hx hy (h.lt_of_ne hxy) ha hb hab,
end

/-- For a function on a convex set in a linearly ordered space (where the order and the algebraic
structures aren't necessarily compatible), in order to prove that it is concave it suffices to
verify the inequality `a • f x + b • f y ≤ f (a • x + b • y)` for `x < y` and positive `a`, `b`. The
main use case is `E = 𝕜` however one can apply it, e.g., to `𝕜^n` with lexicographic order. -/
lemma linear_order.strict_concave_on_of_lt (hs : convex 𝕜 s)
  (hf : ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x < y → ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 →
     a • f x + b • f y < f (a • x + b • y)) : strict_concave_on 𝕜 s f :=
@linear_order.strict_convex_on_of_lt _ _ βᵒᵈ _ _ _ _ _ _ _ _ hs hf

end linear_order
end module

section module
variables [module 𝕜 E] [module 𝕜 F] [has_smul 𝕜 β]

/-- If `g` is convex on `s`, so is `(f ∘ g)` on `f ⁻¹' s` for a linear `f`. -/
lemma convex_on.comp_linear_map {f : F → β} {s : set F} (hf : convex_on 𝕜 s f) (g : E →ₗ[𝕜] F) :
  convex_on 𝕜 (g ⁻¹' s) (f ∘ g) :=
⟨hf.1.linear_preimage _, λ x y hx hy a b ha hb hab,
  calc
    f (g (a • x + b • y)) = f (a • (g x) + b • (g y)) : by rw [g.map_add, g.map_smul, g.map_smul]
                      ... ≤ a • f (g x) + b • f (g y) : hf.2 hx hy ha hb hab⟩

/-- If `g` is concave on `s`, so is `(g ∘ f)` on `f ⁻¹' s` for a linear `f`. -/
lemma concave_on.comp_linear_map {f : F → β} {s : set F} (hf : concave_on 𝕜 s f) (g : E →ₗ[𝕜] F) :
  concave_on 𝕜 (g ⁻¹' s) (f ∘ g) :=
hf.dual.comp_linear_map g

end module
end ordered_add_comm_monoid

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid β]

section distrib_mul_action
variables [has_smul 𝕜 E] [distrib_mul_action 𝕜 β] {s : set E} {f g : E → β}

lemma strict_convex_on.add_convex_on (hf : strict_convex_on 𝕜 s f) (hg : convex_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f + g) :=
⟨hf.1, λ x y hx hy hxy a b ha hb hab,
  calc
    f (a • x + b • y) + g (a • x + b • y) < (a • f x + b • f y) + (a • g x + b • g y)
      : add_lt_add_of_lt_of_le (hf.2 hx hy hxy ha hb hab) (hg.2 hx hy ha.le hb.le hab)
    ... = a • (f x + g x) + b • (f y + g y) : by rw [smul_add, smul_add, add_add_add_comm]⟩

lemma convex_on.add_strict_convex_on (hf : convex_on 𝕜 s f) (hg : strict_convex_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f + g) :=
(add_comm g f) ▸ hg.add_convex_on hf

lemma strict_convex_on.add (hf : strict_convex_on 𝕜 s f) (hg : strict_convex_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f + g) :=
⟨hf.1, λ x y hx hy hxy a b ha hb hab,
  calc
    f (a • x + b • y) + g (a • x + b • y) < (a • f x + b • f y) + (a • g x + b • g y)
      : add_lt_add (hf.2 hx hy hxy ha hb hab) (hg.2 hx hy hxy ha hb hab)
    ... = a • (f x + g x) + b • (f y + g y) : by rw [smul_add, smul_add, add_add_add_comm]⟩

lemma strict_concave_on.add_concave_on (hf : strict_concave_on 𝕜 s f) (hg : concave_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f + g) :=
hf.dual.add_convex_on hg.dual

lemma concave_on.add_strict_concave_on (hf : concave_on 𝕜 s f) (hg : strict_concave_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f + g) :=
hf.dual.add_strict_convex_on hg.dual

lemma strict_concave_on.add (hf : strict_concave_on 𝕜 s f) (hg : strict_concave_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f + g) :=
hf.dual.add hg

end distrib_mul_action

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

lemma convex_on.convex_lt (hf : convex_on 𝕜 s f) (r : β) : convex 𝕜 {x ∈ s | f x < r} :=
convex_iff_forall_pos.2 $ λ x y hx hy a b ha hb hab, ⟨hf.1 hx.1 hy.1 ha.le hb.le hab,
  calc
    f (a • x + b • y)
        ≤ a • f x + b • f y : hf.2 hx.1 hy.1 ha.le hb.le hab
    ... < a • r + b • r     : add_lt_add_of_lt_of_le (smul_lt_smul_of_pos hx.2 ha)
                                (smul_le_smul_of_nonneg hy.2.le hb.le)
    ... = r                 : convex.combo_self hab _⟩

lemma concave_on.convex_gt (hf : concave_on 𝕜 s f) (r : β) : convex 𝕜 {x ∈ s | r < f x} :=
hf.dual.convex_lt r

lemma convex_on.open_segment_subset_strict_epigraph (hf : convex_on 𝕜 s f) (p q : E × β)
  (hp : p.1 ∈ s ∧ f p.1 < p.2) (hq : q.1 ∈ s ∧ f q.1 ≤ q.2) :
  open_segment 𝕜 p q ⊆ {p : E × β | p.1 ∈ s ∧ f p.1 < p.2} :=
begin
  rintro _ ⟨a, b, ha, hb, hab, rfl⟩,
  refine ⟨hf.1 hp.1 hq.1 ha.le hb.le hab, _⟩,
  calc f (a • p.1 + b • q.1) ≤ a • f p.1 + b • f q.1 : hf.2 hp.1 hq.1 ha.le hb.le hab
  ... < a • p.2 + b • q.2 :
    add_lt_add_of_lt_of_le (smul_lt_smul_of_pos hp.2 ha) (smul_le_smul_of_nonneg hq.2 hb.le)
end

lemma concave_on.open_segment_subset_strict_hypograph (hf : concave_on 𝕜 s f) (p q : E × β)
  (hp : p.1 ∈ s ∧ p.2 < f p.1) (hq : q.1 ∈ s ∧ q.2 ≤ f q.1) :
  open_segment 𝕜 p q ⊆ {p : E × β | p.1 ∈ s ∧ p.2 < f p.1} :=
hf.dual.open_segment_subset_strict_epigraph p q hp hq

lemma convex_on.convex_strict_epigraph (hf : convex_on 𝕜 s f) :
  convex 𝕜 {p : E × β | p.1 ∈ s ∧ f p.1 < p.2} :=
convex_iff_open_segment_subset.mpr $
  λ p q hp hq, hf.open_segment_subset_strict_epigraph p q hp ⟨hq.1, hq.2.le⟩

lemma concave_on.convex_strict_hypograph (hf : concave_on 𝕜 s f) :
  convex 𝕜 {p : E × β | p.1 ∈ s ∧ p.2 < f p.1} :=
hf.dual.convex_strict_epigraph

end module
end ordered_cancel_add_comm_monoid

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

/-- The pointwise maximum of convex functions is convex. -/
lemma convex_on.sup (hf : convex_on 𝕜 s f) (hg : convex_on 𝕜 s g) :
  convex_on 𝕜 s (f ⊔ g) :=
begin
  refine ⟨hf.left, λ x y hx hy a b ha hb hab, sup_le _ _⟩,
  { calc f (a • x + b • y) ≤ a • f x + b • f y : hf.right hx hy ha hb hab
     ...                   ≤ a • (f x ⊔ g x) + b • (f y ⊔ g y) : add_le_add
     (smul_le_smul_of_nonneg le_sup_left ha)
     (smul_le_smul_of_nonneg le_sup_left hb) },
  { calc g (a • x + b • y) ≤ a • g x + b • g y : hg.right hx hy ha hb hab
     ...                   ≤ a • (f x ⊔ g x) + b • (f y ⊔ g y) : add_le_add
     (smul_le_smul_of_nonneg le_sup_right ha)
     (smul_le_smul_of_nonneg le_sup_right hb) }
end

/-- The pointwise minimum of concave functions is concave. -/
lemma concave_on.inf (hf : concave_on 𝕜 s f) (hg : concave_on 𝕜 s g) :
  concave_on 𝕜 s (f ⊓ g) :=
hf.dual.sup hg

/-- The pointwise maximum of strictly convex functions is strictly convex. -/
lemma strict_convex_on.sup (hf : strict_convex_on 𝕜 s f) (hg : strict_convex_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f ⊔ g) :=
⟨hf.left, λ x y hx hy hxy a b ha hb hab, max_lt
  (calc f (a • x + b • y) < a • f x + b • f y : hf.2 hx hy hxy ha hb hab
    ...                   ≤ a • (f x ⊔ g x) + b • (f y ⊔ g y) : add_le_add
    (smul_le_smul_of_nonneg le_sup_left ha.le)
    (smul_le_smul_of_nonneg le_sup_left hb.le))
  (calc g (a • x + b • y) < a • g x + b • g y : hg.2 hx hy hxy ha hb hab
    ...                   ≤ a • (f x ⊔ g x) + b • (f y ⊔ g y) : add_le_add
    (smul_le_smul_of_nonneg le_sup_right ha.le)
    (smul_le_smul_of_nonneg le_sup_right hb.le))⟩

/-- The pointwise minimum of strictly concave functions is strictly concave. -/
lemma strict_concave_on.inf (hf : strict_concave_on 𝕜 s f) (hg : strict_concave_on 𝕜 s g) :
   strict_concave_on 𝕜 s (f ⊓ g) :=
hf.dual.sup hg

/-- A convex function on a segment is upper-bounded by the max of its endpoints. -/
lemma convex_on.le_on_segment' (hf : convex_on 𝕜 s f) {x y : E} (hx : x ∈ s) (hy : y ∈ s)
  {a b : 𝕜} (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  f (a • x + b • y) ≤ max (f x) (f y) :=
calc
  f (a • x + b • y) ≤ a • f x + b • f y : hf.2 hx hy ha hb hab
  ... ≤ a • max (f x) (f y) + b • max (f x) (f y) :
    add_le_add (smul_le_smul_of_nonneg (le_max_left _ _) ha)
      (smul_le_smul_of_nonneg (le_max_right _ _) hb)
  ... = max (f x) (f y) : convex.combo_self hab _

/-- A concave function on a segment is lower-bounded by the min of its endpoints. -/
lemma concave_on.ge_on_segment' (hf : concave_on 𝕜 s f) {x y : E} (hx : x ∈ s) (hy : y ∈ s)
  {a b : 𝕜} (ha : 0 ≤ a) (hb : 0 ≤ b) (hab : a + b = 1) :
  min (f x) (f y) ≤ f (a • x + b • y) :=
hf.dual.le_on_segment' hx hy ha hb hab

/-- A convex function on a segment is upper-bounded by the max of its endpoints. -/
lemma convex_on.le_on_segment (hf : convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s) (hy : y ∈ s)
  (hz : z ∈ [x -[𝕜] y]) :
  f z ≤ max (f x) (f y) :=
let ⟨a, b, ha, hb, hab, hz⟩ := hz in hz ▸ hf.le_on_segment' hx hy ha hb hab

/-- A concave function on a segment is lower-bounded by the min of its endpoints. -/
lemma concave_on.ge_on_segment (hf : concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s) (hy : y ∈ s)
  (hz : z ∈ [x -[𝕜] y]) :
  min (f x) (f y) ≤ f z :=
hf.dual.le_on_segment hx hy hz

/-- A strictly convex function on an open segment is strictly upper-bounded by the max of its
endpoints. -/
lemma strict_convex_on.lt_on_open_segment' (hf : strict_convex_on 𝕜 s f) {x y : E} (hx : x ∈ s)
  (hy : y ∈ s) (hxy : x ≠ y) {a b : 𝕜} (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1) :
  f (a • x + b • y) < max (f x) (f y) :=
calc
  f (a • x + b • y) < a • f x + b • f y : hf.2 hx hy hxy ha hb hab
  ... ≤ a • max (f x) (f y) + b • max (f x) (f y) :
    add_le_add (smul_le_smul_of_nonneg (le_max_left _ _) ha.le)
      (smul_le_smul_of_nonneg (le_max_right _ _) hb.le)
  ... = max (f x) (f y) : convex.combo_self hab _

/-- A strictly concave function on an open segment is strictly lower-bounded by the min of its
endpoints. -/
lemma strict_concave_on.lt_on_open_segment' (hf : strict_concave_on 𝕜 s f) {x y : E} (hx : x ∈ s)
  (hy : y ∈ s) (hxy : x ≠ y) {a b : 𝕜} (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1) :
  min (f x) (f y) < f (a • x + b • y) :=
hf.dual.lt_on_open_segment' hx hy hxy ha hb hab

/-- A strictly convex function on an open segment is strictly upper-bounded by the max of its
endpoints. -/
lemma strict_convex_on.lt_on_open_segment (hf : strict_convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hxy : x ≠ y) (hz : z ∈ open_segment 𝕜 x y) :
  f z < max (f x) (f y) :=
let ⟨a, b, ha, hb, hab, hz⟩ := hz in hz ▸ hf.lt_on_open_segment' hx hy hxy ha hb hab

/-- A strictly concave function on an open segment is strictly lower-bounded by the min of its
endpoints. -/
lemma strict_concave_on.lt_on_open_segment (hf : strict_concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hxy : x ≠ y) (hz : z ∈ open_segment 𝕜 x y) :
  min (f x) (f y) < f z :=
hf.dual.lt_on_open_segment hx hy hxy hz

end linear_ordered_add_comm_monoid

section linear_ordered_cancel_add_comm_monoid
variables [linear_ordered_cancel_add_comm_monoid β]

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

lemma convex_on.le_left_of_right_le' (hf : convex_on 𝕜 s f) {x y : E} (hx : x ∈ s) (hy : y ∈ s)
  {a b : 𝕜} (ha : 0 < a) (hb : 0 ≤ b) (hab : a + b = 1) (hfy : f y ≤ f (a • x + b • y)) :
  f (a • x + b • y) ≤ f x :=
le_of_not_lt $ λ h, lt_irrefl (f (a • x + b • y)) $
  calc
    f (a • x + b • y)
        ≤ a • f x + b • f y : hf.2 hx hy ha.le hb hab
    ... < a • f (a • x + b • y) + b • f (a • x + b • y)
        : add_lt_add_of_lt_of_le (smul_lt_smul_of_pos h ha) (smul_le_smul_of_nonneg hfy hb)
    ... = f (a • x + b • y) : convex.combo_self hab _

lemma concave_on.left_le_of_le_right' (hf : concave_on 𝕜 s f) {x y : E} (hx : x ∈ s) (hy : y ∈ s)
  {a b : 𝕜} (ha : 0 < a) (hb : 0 ≤ b) (hab : a + b = 1) (hfy : f (a • x + b • y) ≤ f y) :
  f x ≤ f (a • x + b • y) :=
hf.dual.le_left_of_right_le' hx hy ha hb hab hfy

lemma convex_on.le_right_of_left_le' (hf : convex_on 𝕜 s f) {x y : E} {a b : 𝕜}
  (hx : x ∈ s) (hy : y ∈ s) (ha : 0 ≤ a) (hb : 0 < b) (hab : a + b = 1)
  (hfx : f x ≤ f (a • x + b • y)) :
  f (a • x + b • y) ≤ f y :=
begin
  rw add_comm at ⊢ hab hfx,
  exact hf.le_left_of_right_le' hy hx hb ha hab hfx,
end

lemma concave_on.right_le_of_le_left' (hf : concave_on 𝕜 s f) {x y : E} {a b : 𝕜}
  (hx : x ∈ s) (hy : y ∈ s) (ha : 0 ≤ a) (hb : 0 < b) (hab : a + b = 1)
  (hfx : f (a • x + b • y) ≤ f x) :
  f y ≤ f (a • x + b • y) :=
hf.dual.le_right_of_left_le' hx hy ha hb hab hfx

lemma convex_on.le_left_of_right_le (hf : convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hyz : f y ≤ f z) :
  f z ≤ f x :=
begin
  obtain ⟨a, b, ha, hb, hab, rfl⟩ := hz,
  exact hf.le_left_of_right_le' hx hy ha hb.le hab hyz,
end

lemma concave_on.left_le_of_le_right (hf : concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hyz : f z ≤ f y) :
  f x ≤ f z :=
hf.dual.le_left_of_right_le hx hy hz hyz

lemma convex_on.le_right_of_left_le (hf : convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hxz : f x ≤ f z) :
  f z ≤ f y :=
begin
  obtain ⟨a, b, ha, hb, hab, rfl⟩ := hz,
  exact hf.le_right_of_left_le' hx hy ha.le hb hab hxz,
end

lemma concave_on.right_le_of_le_left (hf : concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hxz : f z ≤ f x) :
  f y ≤ f z :=
hf.dual.le_right_of_left_le hx hy hz hxz

end ordered_smul

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

/- The following lemmas don't require `module 𝕜 E` if you add the hypothesis `x ≠ y`. At the time of
the writing, we decided the resulting lemmas wouldn't be useful. Feel free to reintroduce them. -/
lemma strict_convex_on.lt_left_of_right_lt' (hf : strict_convex_on 𝕜 s f) {x y : E} (hx : x ∈ s)
  (hy : y ∈ s) {a b : 𝕜} (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1)
  (hfy : f y < f (a • x + b • y)) :
  f (a • x + b • y) < f x :=
not_le.1 $ λ h, lt_irrefl (f (a • x + b • y)) $
  calc
    f (a • x + b • y)
        < a • f x + b • f y : hf.2 hx hy begin
            rintro rfl,
            rw convex.combo_self hab at hfy,
            exact lt_irrefl _ hfy,
          end ha hb hab
    ... < a • f (a • x + b • y) + b • f (a • x + b • y)
        : add_lt_add_of_le_of_lt (smul_le_smul_of_nonneg h ha.le) (smul_lt_smul_of_pos hfy hb)
    ... = f (a • x + b • y) : convex.combo_self hab _

lemma strict_concave_on.left_lt_of_lt_right' (hf : strict_concave_on 𝕜 s f) {x y : E} (hx : x ∈ s)
  (hy : y ∈ s) {a b : 𝕜} (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1)
  (hfy : f (a • x + b • y) < f y) :
  f x < f (a • x + b • y) :=
hf.dual.lt_left_of_right_lt' hx hy ha hb hab hfy

lemma strict_convex_on.lt_right_of_left_lt' (hf : strict_convex_on 𝕜 s f) {x y : E} {a b : 𝕜}
  (hx : x ∈ s) (hy : y ∈ s) (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1)
  (hfx : f x < f (a • x + b • y)) :
  f (a • x + b • y) < f y :=
begin
  rw add_comm at ⊢ hab hfx,
  exact hf.lt_left_of_right_lt' hy hx hb ha hab hfx,
end

lemma strict_concave_on.lt_right_of_left_lt' (hf : strict_concave_on 𝕜 s f) {x y : E} {a b : 𝕜}
  (hx : x ∈ s) (hy : y ∈ s) (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1)
  (hfx : f (a • x + b • y) < f x) :
  f y < f (a • x + b • y) :=
hf.dual.lt_right_of_left_lt' hx hy ha hb hab hfx

lemma strict_convex_on.lt_left_of_right_lt (hf : strict_convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hyz : f y < f z) :
  f z < f x :=
begin
  obtain ⟨a, b, ha, hb, hab, rfl⟩ := hz,
  exact hf.lt_left_of_right_lt' hx hy ha hb hab hyz,
end

lemma strict_concave_on.left_lt_of_lt_right (hf : strict_concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hyz : f z < f y) :
  f x < f z :=
hf.dual.lt_left_of_right_lt hx hy hz hyz

lemma strict_convex_on.lt_right_of_left_lt (hf : strict_convex_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hxz : f x < f z) :
  f z < f y :=
begin
  obtain ⟨a, b, ha, hb, hab, rfl⟩ := hz,
  exact hf.lt_right_of_left_lt' hx hy ha hb hab hxz,
end

lemma strict_concave_on.lt_right_of_left_lt (hf : strict_concave_on 𝕜 s f) {x y z : E} (hx : x ∈ s)
  (hy : y ∈ s) (hz : z ∈ open_segment 𝕜 x y) (hxz : f z < f x) :
  f y < f z :=
hf.dual.lt_right_of_left_lt hx hy hz hxz

end module
end linear_ordered_cancel_add_comm_monoid

section ordered_add_comm_group
variables [ordered_add_comm_group β] [has_smul 𝕜 E] [module 𝕜 β] {s : set E} {f g : E → β}

/-- A function `-f` is convex iff `f` is concave. -/
@[simp] lemma neg_convex_on_iff : convex_on 𝕜 s (-f) ↔ concave_on 𝕜 s f :=
begin
  split,
  { rintro ⟨hconv, h⟩,
    refine ⟨hconv, λ x y hx hy a b ha hb hab, _⟩,
    simp [neg_apply, neg_le, add_comm] at h,
    exact h hx hy ha hb hab },
  { rintro ⟨hconv, h⟩,
    refine ⟨hconv, λ x y hx hy a b ha hb hab, _⟩,
    rw ←neg_le_neg_iff,
    simp_rw [neg_add, pi.neg_apply, smul_neg, neg_neg],
    exact h hx hy ha hb hab }
end

/-- A function `-f` is concave iff `f` is convex. -/
@[simp] lemma neg_concave_on_iff : concave_on 𝕜 s (-f) ↔ convex_on 𝕜 s f:=
by rw [← neg_convex_on_iff, neg_neg f]

/-- A function `-f` is strictly convex iff `f` is strictly concave. -/
@[simp] lemma neg_strict_convex_on_iff : strict_convex_on 𝕜 s (-f) ↔ strict_concave_on 𝕜 s f :=
begin
  split,
  { rintro ⟨hconv, h⟩,
    refine ⟨hconv, λ x y hx hy hxy a b ha hb hab, _⟩,
    simp [neg_apply, neg_lt, add_comm] at h,
    exact h hx hy hxy ha hb hab },
  { rintro ⟨hconv, h⟩,
    refine ⟨hconv, λ x y hx hy hxy a b ha hb hab, _⟩,
    rw ←neg_lt_neg_iff,
    simp_rw [neg_add, pi.neg_apply, smul_neg, neg_neg],
    exact h hx hy hxy ha hb hab }
end

/-- A function `-f` is strictly concave iff `f` is strictly convex. -/
@[simp] lemma neg_strict_concave_on_iff : strict_concave_on 𝕜 s (-f) ↔ strict_convex_on 𝕜 s f :=
by rw [← neg_strict_convex_on_iff, neg_neg f]

alias neg_convex_on_iff ↔ _ concave_on.neg
alias neg_concave_on_iff ↔ _ convex_on.neg
alias neg_strict_convex_on_iff ↔ _ strict_concave_on.neg
alias neg_strict_concave_on_iff ↔ _ strict_convex_on.neg

lemma convex_on.sub (hf : convex_on 𝕜 s f) (hg : concave_on 𝕜 s g) : convex_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add hg.neg

lemma concave_on.sub (hf : concave_on 𝕜 s f) (hg : convex_on 𝕜 s g) : concave_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add hg.neg

lemma strict_convex_on.sub (hf : strict_convex_on 𝕜 s f) (hg : strict_concave_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add hg.neg

lemma strict_concave_on.sub (hf : strict_concave_on 𝕜 s f) (hg : strict_convex_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add hg.neg

lemma convex_on.sub_strict_concave_on (hf : convex_on 𝕜 s f) (hg : strict_concave_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add_strict_convex_on hg.neg

lemma concave_on.sub_strict_convex_on (hf : concave_on 𝕜 s f) (hg : strict_convex_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add_strict_concave_on hg.neg

lemma strict_convex_on.sub_concave_on (hf : strict_convex_on 𝕜 s f) (hg : concave_on 𝕜 s g) :
  strict_convex_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add_convex_on hg.neg

lemma strict_concave_on.sub_convex_on (hf : strict_concave_on 𝕜 s f) (hg : convex_on 𝕜 s g) :
  strict_concave_on 𝕜 s (f - g) :=
(sub_eq_add_neg f g).symm ▸ hf.add_concave_on hg.neg

end ordered_add_comm_group
end add_comm_monoid

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

/-- Right translation preserves strict convexity. -/
lemma strict_convex_on.translate_right (hf : strict_convex_on 𝕜 s f) (c : E) :
  strict_convex_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, c + z)) :=
⟨hf.1.translate_preimage_right _, λ x y hx hy hxy a b ha hb hab,
  calc
    f (c + (a • x + b • y)) = f (a • (c + x) + b • (c + y))
        : by rw [smul_add, smul_add, add_add_add_comm, convex.combo_self hab]
    ... < a • f (c + x) + b • f (c + y) : hf.2 hx hy ((add_right_injective c).ne hxy) ha hb hab⟩

/-- Right translation preserves strict concavity. -/
lemma strict_concave_on.translate_right (hf : strict_concave_on 𝕜 s f) (c : E) :
  strict_concave_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, c + z)) :=
hf.dual.translate_right _

/-- Left translation preserves strict convexity. -/
lemma strict_convex_on.translate_left (hf : strict_convex_on 𝕜 s f) (c : E) :
  strict_convex_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, z + c)) :=
by simpa only [add_comm] using hf.translate_right _

/-- Left translation preserves strict concavity. -/
lemma strict_concave_on.translate_left (hf : strict_concave_on 𝕜 s f) (c : E) :
  strict_concave_on 𝕜 ((λ z, c + z) ⁻¹' s) (f ∘ (λ z, z + c)) :=
by simpa only [add_comm] using hf.translate_right _

end add_cancel_comm_monoid
end ordered_semiring

section ordered_comm_semiring
variables [ordered_comm_semiring 𝕜] [add_comm_monoid E]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid β]

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

lemma convex_on.smul {c : 𝕜} (hc : 0 ≤ c) (hf : convex_on 𝕜 s f) : convex_on 𝕜 s (λ x, c • f x) :=
⟨hf.1, λ x y hx hy a b ha hb hab,
  calc
    c • f (a • x + b • y) ≤ c • (a • f x + b • f y)
      : smul_le_smul_of_nonneg (hf.2 hx hy ha hb hab) hc
    ... = a • (c • f x) + b • (c • f y)
      : by rw [smul_add, smul_comm c, smul_comm c]; apply_instance⟩

lemma concave_on.smul {c : 𝕜} (hc : 0 ≤ c) (hf : concave_on 𝕜 s f) :
  concave_on 𝕜 s (λ x, c • f x) :=
hf.dual.smul hc

end module
end ordered_add_comm_monoid
end ordered_comm_semiring

section ordered_ring
variables [linear_ordered_field 𝕜] [add_comm_group E] [add_comm_group F]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid β]

section module
variables [module 𝕜 E] [module 𝕜 F] [has_smul 𝕜 β]

/-- If a function is convex on `s`, it remains convex when precomposed by an affine map. -/
lemma convex_on.comp_affine_map {f : F → β} (g : E →ᵃ[𝕜] F) {s : set F} (hf : convex_on 𝕜 s f) :
  convex_on 𝕜 (g ⁻¹' s) (f ∘ g) :=
⟨hf.1.affine_preimage _, λ x y hx hy a b ha hb hab,
  calc
    (f ∘ g) (a • x + b • y) = f (g (a • x + b • y))         : rfl
                       ...  = f (a • (g x) + b • (g y))     : by rw [convex.combo_affine_apply hab]
                       ...  ≤ a • f (g x) + b • f (g y)     : hf.2 hx hy ha hb hab⟩

/-- If a function is concave on `s`, it remains concave when precomposed by an affine map. -/
lemma concave_on.comp_affine_map {f : F → β} (g : E →ᵃ[𝕜] F) {s : set F} (hf : concave_on 𝕜 s f) :
  concave_on 𝕜 (g ⁻¹' s) (f ∘ g) :=
hf.dual.comp_affine_map g

end module
end ordered_add_comm_monoid
end ordered_ring

section linear_ordered_field
variables [linear_ordered_field 𝕜] [add_comm_monoid E]

section ordered_add_comm_monoid
variables [ordered_add_comm_monoid β]

section has_smul
variables [has_smul 𝕜 E] [has_smul 𝕜 β] {s : set E}

lemma convex_on_iff_div {f : E → β} :
  convex_on 𝕜 s f ↔ convex 𝕜 s ∧ ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b → 0 < a + b
  → f ((a/(a+b)) • x + (b/(a+b)) • y) ≤ (a/(a+b)) • f x + (b/(a+b)) • f y :=
and_congr iff.rfl
⟨begin
  intros h x y hx hy a b ha hb hab,
  apply h hx hy (div_nonneg ha hab.le) (div_nonneg hb hab.le),
  rw [←add_div, div_self hab.ne'],
end,
begin
  intros h x y hx hy a b ha hb hab,
  simpa [hab, zero_lt_one] using h hx hy ha hb,
end⟩

lemma concave_on_iff_div {f : E → β} :
  concave_on 𝕜 s f ↔ convex 𝕜 s ∧ ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → ∀ ⦃a b : 𝕜⦄, 0 ≤ a → 0 ≤ b
  → 0 < a + b → (a/(a+b)) • f x + (b/(a+b)) • f y ≤ f ((a/(a+b)) • x + (b/(a+b)) • y) :=
@convex_on_iff_div _ _ βᵒᵈ _ _ _ _ _ _ _

lemma strict_convex_on_iff_div {f : E → β} :
  strict_convex_on 𝕜 s f ↔ convex 𝕜 s ∧ ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x ≠ y → ∀ ⦃a b : 𝕜⦄, 0 < a
    → 0 < b → f ((a/(a+b)) • x + (b/(a+b)) • y) < (a/(a+b)) • f x + (b/(a+b)) • f y :=
and_congr iff.rfl
⟨begin
  intros h x y hx hy hxy a b ha hb,
  have hab := add_pos ha hb,
  apply h hx hy hxy (div_pos ha hab) (div_pos hb hab),
  rw [←add_div, div_self hab.ne'],
end,
begin
  intros h x y hx hy hxy a b ha hb hab,
  simpa [hab, zero_lt_one] using h hx hy hxy ha hb,
end⟩

lemma strict_concave_on_iff_div {f : E → β} :
  strict_concave_on 𝕜 s f ↔ convex 𝕜 s ∧ ∀ ⦃x y : E⦄, x ∈ s → y ∈ s → x ≠ y → ∀ ⦃a b : 𝕜⦄, 0 < a
    → 0 < b → (a/(a+b)) • f x + (b/(a+b)) • f y < f ((a/(a+b)) • x + (b/(a+b)) • y) :=
@strict_convex_on_iff_div _ _ βᵒᵈ _ _ _ _ _ _ _

end has_smul
end ordered_add_comm_monoid
end linear_ordered_field

section

variables [linear_ordered_field 𝕜] [linear_ordered_cancel_add_comm_monoid β] [module 𝕜 β]
  [ordered_smul 𝕜 β] {x y z : 𝕜} {s : set 𝕜} {f : 𝕜 → β}

lemma convex_on.le_right_of_left_le'' (hf : convex_on 𝕜 s f) (hx : x ∈ s) (hz : z ∈ s)
  (hxy : x < y) (hyz : y ≤ z) (h : f x ≤ f y) : f y ≤ f z :=
hyz.eq_or_lt.elim (λ hyz, (congr_arg f hyz).le)
  (λ hyz, hf.le_right_of_left_le hx hz (Ioo_subset_open_segment ⟨hxy, hyz⟩) h)

lemma convex_on.le_left_of_right_le'' (hf : convex_on 𝕜 s f) (hx : x ∈ s) (hz : z ∈ s)
  (hxy : x ≤ y) (hyz : y < z) (h : f z ≤ f y) : f y ≤ f x :=
hxy.eq_or_lt.elim (λ hxy, (congr_arg f hxy).ge)
  (λ hxy, hf.le_left_of_right_le hx hz (Ioo_subset_open_segment ⟨hxy, hyz⟩) h)

lemma concave_on.right_le_of_le_left'' (hf : concave_on 𝕜 s f) (hx : x ∈ s) (hz : z ∈ s)
  (hxy : x < y) (hyz : y ≤ z) (h : f y ≤ f x) : f z ≤ f y :=
hf.dual.le_right_of_left_le'' hx hz hxy hyz h

lemma concave_on.left_le_of_le_right'' (hf : concave_on 𝕜 s f) (hx : x ∈ s) (hz : z ∈ s)
  (hxy : x ≤ y) (hyz : y < z) (h : f y ≤ f z) : f x ≤ f y :=
hf.dual.le_left_of_right_le'' hx hz hxy hyz h

end


import .deduct
import .function_update_ite

set_option pp.parens true

open formula

def formula.is_atomic : formula → Prop
| (true_) := false
| (pred_ name args) := true
| (eq_ x y) := true
| (not_ P) := false
| (imp_ P Q) := false
| (forall_ x P) := true

def formula.atomic_set : formula → finset formula
| (true_) := ∅
| (pred_ name args) := {pred_ name args}
| (eq_ x y) := {eq_ x y}
| (not_ P) := P.atomic_set
| (imp_ P Q) := P.atomic_set ∪ Q.atomic_set
| (forall_ x P) := {forall_ x P}

def formula.subst_atomic (σ : formula → formula) : formula → formula
| (true_) := true_
| (pred_ name args) := σ (pred_ name args)
| (eq_ x y) := σ (eq_ x y)
| (not_ P) := not_ P.subst_atomic
| (imp_ P Q) := imp_ P.subst_atomic Q.subst_atomic
| (forall_ x P) := σ (forall_ x P)

@[derive inhabited]
def valuation : Type := formula → bool

def formula.eval_atomic (val : valuation) : formula → bool
| (true_) := bool.tt
| (pred_ name args) := val (pred_ name args)
| (eq_ x y) := val (eq_ x y)
| (not_ P) := ! P.eval_atomic
| (imp_ P Q) := (! P.eval_atomic) || Q.eval_atomic
| (forall_ x P) := val (forall_ x P)

def formula.is_tauto_atomic (P : formula) : Prop :=
  ∀ (val : valuation), P.eval_atomic val = bool.tt

def eval_atomic_ff_to_not (val : valuation) (P : formula) : formula :=
if formula.eval_atomic val P = bool.tt then P else P.not_

lemma eval_atomic_atomic
  (P : formula)
  (val : valuation)
  (h1 : P.is_atomic) :
  P.eval_atomic val = val P :=
begin
  induction P,
  case [formula.true_, formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold formula.is_atomic at h1,

      contradiction,
    }
  },
  case [formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      refl,
    }
  },
end

example
  (P : formula)
  (val val' : valuation)
  (h1 : ∀ (Q : formula), Q ∈ P.atomic_set → val Q = val' Q) :
  P.eval_atomic val = P.eval_atomic val' :=
begin
  induction P,
  case formula.true_
  {
    unfold formula.eval_atomic,
  },
  case [formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      unfold formula.atomic_set at h1,

      unfold formula.eval_atomic,
      apply h1,
      simp only [finset.mem_singleton, eq_self_iff_true, and_self],
    },
  },
  case formula.not_ : P P_ih
  {
    unfold formula.atomic_set at h1,

    unfold formula.eval_atomic,
    congr' 1,
    exact P_ih h1,
  },
  case formula.imp_ : P Q P_ih Q_ih
  {
    unfold formula.atomic_set at h1,
    simp only [finset.mem_union] at h1,

    unfold formula.eval_atomic,
    congr' 1,
    {
      congr' 1,
      apply P_ih,
      intros Q' a1,
      apply h1,
      left,
      exact a1,
    },
    {
      apply Q_ih,
      intros Q' a1,
      apply h1,
      right,
      exact a1,
    }
  },
end

lemma eval_atomic_subst_atomic_eq_eval_atomic_eval_atomic
  (P : formula)
  (σ : formula → formula)
  (val : valuation) :
  (P.subst_atomic σ).eval_atomic val =
    P.eval_atomic (fun (Q : formula), (σ Q).eval_atomic val) :=
begin
  induction P,
  case [formula.true_, formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      refl,
    }
  },
  case formula.not_ : P P_ih
  {
    unfold formula.subst_atomic,
    unfold formula.eval_atomic,
    congr,
    exact P_ih,
  },
  case formula.imp_ : P Q P_ih Q_ih
  {
    unfold formula.subst_atomic,
    unfold formula.eval_atomic,
    congr,
    {
      exact P_ih,
    },
    {
      exact Q_ih,
    }
  },
end

theorem is_tauto_atomic_imp_is_tauto_atomic_subst_atomic
  (P : formula)
  (h1 : P.is_tauto_atomic)
  (σ : formula → formula) :
  (formula.subst_atomic σ P).is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic at h1,

  unfold formula.is_tauto_atomic,
  intros val,
  simp only [eval_atomic_subst_atomic_eq_eval_atomic_eval_atomic P σ val],
  apply h1,
end

example
  (P Q R S : formula)
  (val : valuation)
  (σ : formula → formula)
  (h1 : P.eval_atomic val = Q.eval_atomic val) :
  (S.subst_atomic (function.update_ite σ R P)).eval_atomic val =
    (S.subst_atomic (function.update_ite σ R Q)).eval_atomic val :=
begin
  simp only [eval_atomic_subst_atomic_eq_eval_atomic_eval_atomic],
  congr' 1,
  funext Q',
  unfold function.update_ite,
  split_ifs,
  {
    exact h1,
  },
  {
    refl,
  }
end

theorem T_13_5
  (P : formula) :
  is_proof (P.imp_ P) :=
begin
  unfold is_proof,

  apply is_deduct.mp_,
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      exact is_axiom.prop_2_ P (P.imp_ P) P,
    },
    {
      apply is_deduct.axiom_,
      exact is_axiom.prop_1_ P (P.imp_ P),
    }
  },
  {
    apply is_deduct.axiom_,
    exact is_axiom.prop_1_ P P,
  },
end

alias T_13_5 <- prop_id

theorem T_13_6
  (P Q : formula) :
  is_proof (P.not_.imp_ (P.imp_ Q)) :=
begin
  unfold is_proof,

  apply is_deduct.mp_,
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      exact is_axiom.prop_2_ P.not_ (Q.not_.imp_ P.not_) (P.imp_ Q),
    },
    {
      apply is_deduct.mp_,
      {
        apply is_deduct.axiom_,
        exact is_axiom.prop_1_ ((Q.not_.imp_ P.not_).imp_ (P.imp_ Q)) P.not_,
      },
      {
        apply is_deduct.axiom_,
        exact is_axiom.prop_3_ Q P,
      }
    }
  },
  {
    apply is_deduct.axiom_,
    exact is_axiom.prop_1_ P.not_ Q.not_,
  },
end

-- Deduction Theorem

theorem T_14_3
  (P Q : formula)
  (Δ : set formula)
  (h1 : is_deduct (Δ ∪ {P}) Q) :
  is_deduct Δ (P.imp_ Q) :=
begin
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      exact is_axiom.prop_1_ h1_P P,
    },
    {
      apply is_deduct.axiom_,
      exact h1_1,
    },
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    simp only [set.union_singleton, set.mem_insert_iff] at h1_1,
    cases h1_1,
    {
      subst h1_1,
      apply proof_imp_deduct,
      exact prop_id h1_P,
    },
    {
      apply is_deduct.mp_,
      {
        apply is_deduct.axiom_,
        exact is_axiom.prop_1_ h1_P P,
      },
      {
        apply is_deduct.assume_,
        exact h1_1,
      },
    }
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.mp_,
      {
        apply is_deduct.axiom_,
        exact is_axiom.prop_2_ P h1_P h1_Q,
      },
      {
        exact h1_ih_1,
      }
    },
    {
      exact h1_ih_2,
    },
  },
end

alias T_14_3 <- deduction_theorem

example
  (P Q : formula) :
  is_proof (P.not_.imp_ (P.imp_ Q)) :=
begin
  unfold is_proof,

  apply deduction_theorem,
  apply is_deduct.mp_,
  {
    apply is_deduct.axiom_,
    exact is_axiom.prop_3_ Q P,
  },
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      exact is_axiom.prop_1_ P.not_ Q.not_,
    },
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, insert_emptyc_eq, set.mem_singleton],
    },
  },
end

theorem T_14_5
  (P : formula) :
  is_proof (P.not_.not_.imp_ P) :=
begin
  unfold is_proof,

  apply deduction_theorem,
  apply is_deduct.mp_ P.not_.not_,
  {
    apply is_deduct.mp_ (P.not_.imp_ P.not_.not_.not_),
    {
      apply is_deduct.axiom_,
      apply is_axiom.prop_3_,
    },
    {
      apply is_deduct.mp_ P.not_.not_,
      {
        apply proof_imp_deduct,
        apply T_13_6,
      },
      {
        apply is_deduct.assume_,
        simp only [set.union_singleton, insert_emptyc_eq, set.mem_singleton],
      }
    }
  },
  {
    apply is_deduct.assume_,
    simp only [set.union_singleton, insert_emptyc_eq, set.mem_singleton_iff],
  }
end

theorem T_14_6
  (P : formula) :
  is_proof (P.imp_ P.not_.not_) :=
begin
  unfold is_proof,

  apply is_deduct.mp_ (P.not_.not_.not_.imp_ P.not_),
  {
    apply is_deduct.axiom_,
    exact is_axiom.prop_3_ P.not_.not_ P,
  },
  {
    apply proof_imp_deduct,
    exact T_14_5 P.not_,
  }
end

theorem T_14_7
  (P Q : formula) :
  is_proof ((P.imp_ Q).imp_ (Q.not_.imp_ P.not_)) :=
begin
  unfold is_proof,

  apply deduction_theorem,
  apply is_deduct.mp_,
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_3_,
  },
  {
    apply deduction_theorem,
    apply is_deduct.mp_,
    {
      apply proof_imp_deduct,
      apply T_14_6,
    },
    {
      apply is_deduct.mp_,
      {
        apply is_deduct.assume_,
        simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton_iff, eq_self_iff_true, and_true,
  false_or],
      },
      {
        apply is_deduct.mp_,
        {
          apply proof_imp_deduct,
          apply T_14_5,
        },
        {
          apply is_deduct.assume_,
          simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton_iff, or_false],
        }
      }
    }
  }
end

theorem T_14_8
  (Q R : formula) :
  is_proof (Q.imp_ (R.not_.imp_ ((Q.imp_ R).not_))) :=
begin
  unfold is_proof,

  apply deduction_theorem,
  apply is_deduct.mp_,
  {
    apply proof_imp_deduct,
    apply T_14_7,
  },
  {
    apply deduction_theorem,
    apply is_deduct.mp_ Q R,
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, and_self, true_or],
    },
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton, or_true],
    }
  }
end

theorem T_14_9
  (P S : formula) :
  is_proof ((S.imp_ P).imp_ ((S.not_.imp_ P).imp_ P)) :=
begin
  unfold is_proof,

  apply deduction_theorem,
  apply is_deduct.mp_,
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_3_,
  },
  {
    apply deduction_theorem,
    apply is_deduct.mp_,
    {
      apply is_deduct.mp_,
      {
        apply proof_imp_deduct,
        apply T_14_8,
      },
      {
        apply is_deduct.mp_,
        {
          apply is_deduct.mp_ (S.imp_ P),
          {
            apply proof_imp_deduct,
            apply T_14_7,
          },
          {
            apply is_deduct.assume_,
            simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton, false_or],
          }
        },
        {
          apply is_deduct.assume_,
          simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton_iff, or_false],
        }
      }
    },
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, insert_emptyc_eq, set.mem_insert_iff, set.mem_singleton_iff, or_false],
    }
  }
end

theorem T_14_10
  (Q : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ Q) :
  ∀ (Γ : set formula), is_deduct (Δ ∪ Γ) Q :=
begin
  intros Γ,
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    apply is_deduct.axiom_,
    exact h1_1,
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    apply is_deduct.assume_,
    simp only [set.mem_union_eq],
    apply or.intro_left,
    exact h1_1,
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    apply is_deduct.mp_ h1_P h1_Q,
    {
      exact h1_ih_1,
    },
    {
      exact h1_ih_2,
    }
  },
end

theorem deduction_theorem_converse
  (P Q : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ (P.imp_ Q)) :
  is_deduct (Δ ∪ {P}) Q :=
begin
  have s1 : is_deduct (Δ ∪ {P}) (P.imp_ Q),
  exact T_14_10 (P.imp_ Q) Δ h1 {P},

  have s2 : is_deduct (Δ ∪ {P}) P,
  apply is_deduct.assume_,
  simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or],

  exact is_deduct.mp_ P Q s1 s2,
end

theorem C_14_11
  (Q : formula)
  (h1 : is_proof Q) :
  ∀ (Γ : set formula), is_deduct Γ Q :=
begin
  unfold is_proof at h1,

  intros Γ,
  rewrite <- set.union_empty Γ,
  rewrite set.union_comm,
  exact T_14_10 Q ∅ h1 Γ,
end

example :
  C_14_11 = proof_imp_deduct :=
begin
  refl,
end

theorem T_14_12
  (P Q : formula)
  (Δ Γ : set formula)
  (h1 : is_deduct Δ P)
  (h2 : is_deduct Γ (P.imp_ Q)) :
  is_deduct (Δ ∪ Γ) Q :=
begin
  have s1 : is_deduct (Δ ∪ Γ) P,
  apply T_14_10,
  exact h1,

  have s2 : is_deduct (Δ ∪ Γ) (P.imp_ Q),
  rewrite set.union_comm,
  apply T_14_10,
  exact h2,

  exact is_deduct.mp_ P Q s2 s1,
end

theorem C_14_13
  (P Q : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ P)
  (h2 : is_deduct Δ (P.imp_ Q)) :
  is_deduct Δ Q :=
begin
  have s1 : is_deduct (Δ ∪ Δ) Q,
  exact T_14_12 P Q Δ Δ h1 h2,

  simp only [set.union_self] at s1,
  exact s1,
end

theorem C_14_13'
  (P Q : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ P)
  (h2 : is_deduct Δ (P.imp_ Q)) :
  is_deduct Δ Q :=
begin
  exact is_deduct.mp_ P Q h2 h1,
end

theorem C_14_14
  (P Q : formula)
  (Γ : set formula)
  (h1 : is_proof P)
  (h2 : is_deduct Γ (P.imp_ Q)) :
  is_deduct Γ Q :=
begin
  have s1 : is_deduct Γ P,
  exact C_14_11 P h1 Γ,

  exact is_deduct.mp_ P Q h2 s1,
end

alias C_14_14 <- mp_proof_deduct

theorem C_14_15
  (P Q : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ P)
  (h2 : is_proof (P.imp_ Q)) :
  is_deduct Δ Q :=
begin
  have s1 : is_deduct Δ (P.imp_ Q),
  exact C_14_11 (P.imp_ Q) h2 Δ,

  exact is_deduct.mp_ P Q s1 h1,
end

alias C_14_15 <- mp_deduct_proof

theorem T_14_16
  (Q : formula)
  (Δ Γ : set formula)
  (h1 : is_deduct Γ Q)
  (h2 : ∀ (P : formula), P ∈ Γ → is_deduct Δ P) :
  is_deduct Δ Q :=
begin
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    apply is_deduct.axiom_,
    exact h1_1,
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    exact h2 h1_P h1_1,
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    exact is_deduct.mp_ h1_P h1_Q h1_ih_1 h1_ih_2,
  },
end

theorem C_14_17
  (Q : formula)
  (Γ : set formula)
  (h1 : is_deduct Γ Q)
  (h2 : ∀ (P : formula), P ∈ Γ → is_proof P) :
  is_proof Q :=
begin
  unfold is_proof at h2,

  unfold is_proof,
  exact T_14_16 Q ∅ Γ h1 h2,
end

theorem eval_not
  (P : formula)
  (val : valuation) :
  formula.eval_atomic val (not_ P) = bool.tt ↔
    ¬ (formula.eval_atomic val P = bool.tt) :=
begin
  unfold formula.eval_atomic,
  cases formula.eval_atomic val P;
  exact dec_trivial,
end

theorem eval_imp
  (P Q : formula)
  (val : valuation) :
  formula.eval_atomic val (imp_ P Q) = bool.tt ↔
    ((formula.eval_atomic val P = bool.tt) → (formula.eval_atomic val Q = bool.tt)) :=
begin
  unfold formula.eval_atomic,
  cases formula.eval_atomic val P;
  cases formula.eval_atomic val Q;
  exact dec_trivial,
end

theorem is_tauto_prop_true :
  true_.is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic,
  intro val,
  unfold formula.eval_atomic,
end

theorem is_tauto_prop_1
  (P Q : formula) :
  (P.imp_ (Q.imp_ P)).is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic,
  intro val,
  simp only [eval_imp],
  tauto,
end

theorem is_tauto_prop_2
  (P Q R : formula) :
  ((P.imp_ (Q.imp_ R)).imp_ ((P.imp_ Q).imp_ (P.imp_ R))).is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic,
  intro val,
  simp only [eval_imp],
  tauto,
end

theorem is_tauto_prop_3
  (P Q : formula) :
  (((not_ P).imp_ (not_ Q)).imp_ (Q.imp_ P)).is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic,
  intro val,
  simp only [eval_not, eval_imp],
  tauto,
end

theorem is_tauto_mp
  (P Q : formula)
  (h1 : (P.imp_ Q).is_tauto_atomic)
  (h2 : P.is_tauto_atomic) :
  Q.is_tauto_atomic :=
begin
  unfold formula.is_tauto_atomic at h1,
  unfold formula.is_tauto_atomic at h2,

  unfold formula.is_tauto_atomic,
  intro val,
  simp only [eval_imp] at h1,
  apply h1,
  exact h2 val,
end

example
  (P : formula)
  (h1 : is_prop_proof P) :
  P.is_tauto_atomic :=
begin
  induction h1,
  case is_prop_deduct.axiom_ : h1_P h1_1
  {
    induction h1_1,
    case is_prop_axiom.prop_true_ :
    {
      exact is_tauto_prop_true,
    },
    case is_prop_axiom.prop_1_ : h1_1_P h1_1_Q
    {
      exact is_tauto_prop_1 h1_1_P h1_1_Q,
    },
    case is_prop_axiom.prop_2_ : h1_1_P h1_1_Q h1_1_R
    {
      exact is_tauto_prop_2 h1_1_P h1_1_Q h1_1_R,
    },
    case is_prop_axiom.prop_3_ : h1_1_P h1_1_Q
    {
      exact is_tauto_prop_3 h1_1_P h1_1_Q,
    },
  },
  case is_prop_deduct.assume_ : h1_P h1_1
  {
    simp only [set.mem_empty_eq] at h1_1,
    contradiction,
  },
  case is_prop_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    exact is_tauto_mp h1_P h1_Q h1_ih_1 h1_ih_2,
  },
end

lemma mem_atomic_set_is_atomic
  (P P' : formula)
  (h1 : P' ∈ P.atomic_set) :
  P'.is_atomic :=
begin
  induction P,
  case formula.true_
  {
    unfold formula.atomic_set at h1,
    simp only [finset.not_mem_empty] at h1,

    contradiction,
  },
  case [formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      unfold formula.atomic_set at h1,
      simp only [finset.mem_singleton] at h1,

      subst h1,
      unfold formula.is_atomic,
    }
  },
  case formula.not_ : P P_ih
  {
    unfold formula.atomic_set at h1,

    exact P_ih h1,
  },
  case formula.imp_ : P Q P_ih Q_ih
  {
    unfold formula.atomic_set at h1,
    simp only [finset.mem_union] at h1,

    tauto,
  },
end

lemma bnot_eq_tt_iff_not_eq_tt
  (b : bool) :
  !b = bool.tt ↔ ¬ b = bool.tt :=
begin
  simp only [bnot_eq_true_eq_eq_ff, eq_ff_eq_not_eq_tt],
end

lemma L_15_7
  (P P' : formula)
  (Δ_U : set formula)
  (val : valuation)
  (Δ_U' : set formula)
  (h1 : coe P.atomic_set ⊆ Δ_U)
  (h2 : Δ_U' = Δ_U.image (eval_atomic_ff_to_not val))
  (h3 : P' = eval_atomic_ff_to_not val P) :
  is_deduct Δ_U' P' :=
begin
  subst h2,
  subst h3,
  induction P,
  case formula.true_
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_true_,
  },
  case formula.pred_ : name args
  {
    let P := pred_ name args,

    unfold formula.atomic_set at h1,
    simp only [finset.coe_singleton, set.singleton_subset_iff] at h1,

    unfold eval_atomic_ff_to_not,
    unfold formula.eval_atomic,
    apply is_deduct.assume_,
    simp only [finset.coe_image, set.mem_image, finset.mem_coe],
    apply exists.intro P,
    tauto,
  },
  case formula.eq_ : x y
  {
    let P := eq_ x y,

    unfold formula.atomic_set at h1,
    simp only [finset.coe_singleton, set.singleton_subset_iff] at h1,

    unfold eval_atomic_ff_to_not,
    unfold formula.eval_atomic,
    apply is_deduct.assume_,
    simp only [finset.coe_image, set.mem_image, finset.mem_coe],
    apply exists.intro P,
    tauto,
  },
  case formula.not_ : P P_ih
  {
    unfold formula.atomic_set at h1,

    unfold eval_atomic_ff_to_not at P_ih,

    unfold eval_atomic_ff_to_not,
    unfold formula.eval_atomic,

    simp only [bnot_eq_tt_iff_not_eq_tt],
    split_ifs,
    {
      simp only [if_pos h] at P_ih,
      apply is_deduct.mp_ P,
      {
        apply proof_imp_deduct,
        apply T_14_6,
      },
      {
        exact P_ih h1,
      },
    },
    {
      simp only [if_neg h] at P_ih,
      exact P_ih h1,
    },
  },
  case formula.imp_ : P Q P_ih Q_ih
  {
    unfold formula.atomic_set at h1,
    simp only [finset.coe_union, set.union_subset_iff] at h1,
    cases h1,

    unfold eval_atomic_ff_to_not at P_ih,
    unfold eval_atomic_ff_to_not at Q_ih,

    unfold eval_atomic_ff_to_not,
    unfold formula.eval_atomic,
    simp only [bor_eq_true_eq_eq_tt_or_eq_tt],
    simp only [bnot_eq_tt_iff_not_eq_tt],
    split_ifs,
    {
      cases h,
      {
        simp only [if_neg h] at P_ih,
        apply is_deduct.mp_ P.not_,
        {
          apply proof_imp_deduct,
          apply T_13_6,
        },
        {
          exact P_ih h1_left,
        },
      },
      {
        simp only [if_pos h] at Q_ih,

        apply is_deduct.mp_ Q,
        {
          apply is_deduct.axiom_,
          apply is_axiom.prop_1_,
        },
        {
          exact Q_ih h1_right,
        },
      }
    },
    {
      push_neg at h,
      dsimp at h,
      cases h,
      simp only [if_pos h_left] at P_ih,
      simp only [if_neg h_right] at Q_ih,
      apply is_deduct.mp_ Q.not_,
      {
        apply is_deduct.mp_ P,
        {
          apply proof_imp_deduct,
          apply T_14_8,
        },
        {
          exact P_ih h1_left,
        }
      },
      {
        exact Q_ih h1_right,
      },
    }
  },
  case formula.forall_ : x P P_ih
  {
    let P := forall_ x P,

    unfold formula.atomic_set at h1,
    simp only [finset.coe_singleton, set.singleton_subset_iff] at h1,

    unfold eval_atomic_ff_to_not,
    unfold formula.eval_atomic,
    apply is_deduct.assume_,
    simp only [finset.coe_image, set.mem_image, finset.mem_coe],
    apply exists.intro P,
    tauto,
  },
end

lemma T_14_9_deduct
  (P U : formula)
  (Δ : set formula)
  (h1 : is_deduct (Δ ∪ {U}) P)
  (h2 : is_deduct (Δ ∪ {U.not_}) P) :
  is_deduct Δ P :=
begin
  apply is_deduct.mp_ (U.not_.imp_ P),
  {
    apply is_deduct.mp_ (U.imp_ P),
    {
      apply proof_imp_deduct,
      apply T_14_9,
    },
    {
      apply deduction_theorem,
      exact h1,
    },
  },
  {
    apply deduction_theorem,
    exact h2,
  }
end

lemma eval_atomic_ff_to_not_of_function_update_ite_tt
  (P P' : formula)
  (val : valuation)
  (h1 : P.is_atomic) :
  eval_atomic_ff_to_not (function.update_ite val P' bool.tt) P =
    function.update_ite (eval_atomic_ff_to_not val) P' P P :=
begin
  induction P,
  case formula.true_
  {
    unfold function.update_ite,
    unfold eval_atomic_ff_to_not,
    tauto,
  },
  case [formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      unfold function.update_ite,
      unfold eval_atomic_ff_to_not,
      unfold formula.eval_atomic,
      unfold function.update_ite,
      split_ifs; tauto,
    }
  },
  case [formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold formula.is_atomic at h1,

      contradiction,
    }
  },
end

lemma eval_atomic_ff_to_not_of_function_update_ite_ff
  (P P' : formula)
  (val : valuation)
  (h1 : P.is_atomic) :
  eval_atomic_ff_to_not (function.update_ite val P' bool.ff) P =
    function.update_ite (eval_atomic_ff_to_not val) P' P.not_ P :=
begin
  induction P,
  case formula.true_
  {
    unfold function.update_ite,
    unfold eval_atomic_ff_to_not,
    tauto,
  },
  case [formula.pred_, formula.eq_, formula.forall_]
  {
    all_goals
    {
      unfold function.update_ite,
      unfold eval_atomic_ff_to_not,
      unfold formula.eval_atomic,
      unfold function.update_ite,
      split_ifs; tauto,
    }
  },
  case [formula.not_, formula.imp_]
  {
    all_goals
    {
      unfold formula.is_atomic at h1,

      contradiction,
    }
  },
end

lemma image_of_eval_atomic_ff_to_not_of_function_update_ite
  (U : formula)
  (Δ : set formula)
  (val : valuation)
  (b : bool)
  (h1_Δ: ∀ (U' : formula), (U' ∈ Δ) → U'.is_atomic)
  (h1_U: U.is_atomic)
  (h2: U ∉ Δ) :
  Δ.image (eval_atomic_ff_to_not (function.update_ite val U b)) =
    Δ.image (eval_atomic_ff_to_not val) :=
begin
  apply set.image_congr,
  intros U' a1,
  specialize h1_Δ U' a1,
  cases b,
  {
    simp only [eval_atomic_ff_to_not_of_function_update_ite_ff U' U val h1_Δ],
    unfold function.update_ite,
    simp only [ite_eq_right_iff],
    intros a2,
    subst a2,
    contradiction,
  },
  {
    simp only [eval_atomic_ff_to_not_of_function_update_ite_tt U' U val h1_Δ],
    unfold function.update_ite,
    simp only [ite_eq_right_iff],
    intros a2,
    subst a2,
    contradiction,
  }
end

lemma prop_complete_aux_aux
  (P U : formula)
  (Δ : set formula)
  (h1_Δ : ∀ (U' : formula), U' ∈ Δ → U'.is_atomic)
  (h1_U : U.is_atomic)
  (h2 : U ∉ Δ)
  (h3 : ∀ (val : valuation), is_deduct ((Δ.image (eval_atomic_ff_to_not val)) ∪ {eval_atomic_ff_to_not val U}) P) :
  ∀ (val : valuation), is_deduct (Δ.image (eval_atomic_ff_to_not val)) P :=
begin
  intros val,
  apply T_14_9_deduct P U (Δ.image (eval_atomic_ff_to_not val)),
  {
    specialize h3 (function.update_ite val U bool.tt),
    simp only [image_of_eval_atomic_ff_to_not_of_function_update_ite U Δ val bool.tt h1_Δ h1_U h2] at h3,
    simp only [eval_atomic_ff_to_not_of_function_update_ite_tt U U val h1_U] at h3,
    unfold function.update_ite at h3,
    simp only [eq_self_iff_true, if_true] at h3,
    exact h3,
  },
  {
    specialize h3 (function.update_ite val U bool.ff),
    simp only [image_of_eval_atomic_ff_to_not_of_function_update_ite U Δ val bool.ff h1_Δ h1_U h2] at h3,
    simp only [eval_atomic_ff_to_not_of_function_update_ite_ff U U val h1_U] at h3,
    unfold function.update_ite at h3,
    simp only [eq_self_iff_true, if_true] at h3,
    exact h3,
  }
end

theorem prop_complete_aux
  (P : formula)
  (Δ_U : finset formula)
  (h1 : P.is_tauto_atomic)
  (h2 : Δ_U ⊆ P.atomic_set)
  (h3 : ∀ (val : valuation), is_deduct (Δ_U.image (eval_atomic_ff_to_not val)) P) :
  is_deduct ∅ P :=
begin
  induction Δ_U using finset.induction_on,
  case h₁
  {
    simp only [finset.image_empty, finset.coe_empty, forall_const] at h3,

    exact h3,
  },
  case h₂ : U Δ_U Δ_U_1 Δ_U_2
  {
    apply Δ_U_2,
    {
      simp only [finset.insert_subset] at h2,
      cases h2,

      exact h2_right,
    },
    {
      simp only [finset.insert_subset] at h2,
      cases h2,

      simp only [finset.image_insert, finset.coe_insert, finset.coe_image] at h3,

      simp only [finset.coe_image],
      apply prop_complete_aux_aux P U Δ_U,
      {
        intros U' a1,
        apply mem_atomic_set_is_atomic P U',
        apply h2_right,
        exact a1,
      },
      {
        apply mem_atomic_set_is_atomic P U,
        exact h2_left,
      },
      {
        exact Δ_U_1,
      },
      {
        simp only [set.union_singleton],
        exact h3,
      }
    }
  },
end

theorem prop_complete
  (P : formula)
  (h1 : P.is_tauto_atomic) :
  is_proof P :=
begin
  unfold is_proof,

  apply prop_complete_aux P P.atomic_set h1,
  {
    refl,
  },
  {
    intros val,
    apply L_15_7 P P P.atomic_set val (P.atomic_set.image (eval_atomic_ff_to_not val)),
    {
      refl,
    },
    {
      simp only [finset.coe_image],
    },
    {
      unfold formula.is_tauto_atomic at h1,

      unfold eval_atomic_ff_to_not,
      specialize h1 val,
      simp only [if_pos h1],
    }
  }
end


import data.complex.is_R_or_C
import analysis.inner_product_space.pi_L2

variables {m n : ℕ}

variables (𝕜 : Type*)
[is_R_or_C 𝕜]

open_locale big_operators complex_conjugate matrix topological_space

local notation `𝕜^n` := (euclidean_space 𝕜 (fin n))

local notation `M_n` := (matrix (fin n) (fin n) 𝕜)

local notation `U_n` := matrix.unitary_group (fin n) 𝕜

variables (A B : ℕ → M_n) (L : M_n)

/-
matrix_SVD should look like this:
-/
noncomputable def matrix_SVD (M : M_n) : (fin 3) → M_n := sorry

theorem limit_svd_is_svd (h_lim : filter.tendsto A filter.at_top (𝓝 L))


import order

import lib.list

import etv.defs
import etv.label

open order_dual

variables {α : Type*} [linear_order α] (C : config α)

lemma config.join_n2_n2_case_ff
  (S : finset α) (n : ℕ) (a x b : α) (c1 c2 : list α) (lab : C.label S)
  (a_in_S : a ∈ S) (x_in_S : x ∈ S) (b_in_S : b ∈ S)
  (hc1 : C.ncup (n+2) (c1 ++ [a, x])) (c1_in_S : c1.in S)
  (hc2 : C.ncup (n+2) (x :: b :: c2)) (c2_in_S : c2.in S)
  (sab : ¬lab.slope a b) :
  C.has_ngon (n+3) S :=
begin
  have hax : a < x := by simp [config.cup, config.ncup] at hc1; tauto,
  have hxb : x < b := by simp [config.cup, config.ncup] at hc2; tauto,
  have hab : a < b := has_lt.lt.trans hax hxb,
  have h_b_c2 : b :: c2 ≠ [] := by simp,
  rcases list.take_last h_b_c2 with ⟨c, c3, eq_c2⟩,
  rw eq_c2 at hc2,
  have hxc : x < c := by
    apply hc2.head'_lt_last' x c; simp; dec_trivial,
  have c_in_S : c ∈ S := begin
    have h_in : (b :: c2).in S := by simp; tauto,
    rw eq_c2 at h_in, simp at h_in, tauto,
  end,
  by_cases haxc : C.cup3 a x c,
  { apply ncup_is_ngon, dec_trivial,
    use c1 ++ [a, x, c], split, split,
    simp, rw config.ncup at hc1, tauto,
    simp, simp [config.ncup] at hc1, tauto,
    simp, tauto },
  { use [[a, x, c], a :: (c3 ++ [c])],
    refine ⟨⟨_, _⟩, _, _⟩; try {simp}; try {tauto},
    split, tauto, split, dec_trivial,
    rw ←eq_c2, rw ←eq_c2 at hc2,
    have hbc2 := hc2.tail.left, simp at hbc2,
    apply hbc2.extend_left sab; try {tauto},
    simp, tauto, simp [config.ncup] at hc2,
    ring_nf, ring_nf at hc2, simp, simp at hc2,
    exact hc2.right, split, assumption,
    have hh : (b :: c2).in S := by simp; tauto,
    rw eq_c2 at hh, simp at hh, exact hh },
end

lemma config.join_n2_n2_case_tt
  (S : finset α) (n : ℕ) (a x b : α) (c1 c2 : list α) (lab : C.label S)
  (a_in_S : a ∈ S) (x_in_S : x ∈ S) (b_in_S : b ∈ S)
  (hc1 : C.ncup (n+2) (c1 ++ [a, x])) (c1_in_S : c1.in S)
  (hc2 : C.ncup (n+2) (x :: b :: c2)) (c2_in_S : c2.in S)
  (hab : lab.slope a b) :
  C.has_ngon (n+3) S :=
begin
  rw ←finset.mem_mirror at a_in_S x_in_S b_in_S,
  rw ←mirror.ncup at hc1 hc2,
  rw ←list.mirror_in at c1_in_S c2_in_S,
  simp at hc1 hc2,
  have hba := hab, rw ←mirror_slope at hba,

  have mirrored_goal :=
    (C.mirror).join_n2_n2_case_ff
      S.mirror n
      (to_dual b) (to_dual x) (to_dual a)
      c2.mirror c1.mirror lab.mirror
      b_in_S x_in_S a_in_S hc2 c2_in_S hc1 c1_in_S hba,
  rw mirror.has_ngon at mirrored_goal,
  tauto
end

lemma config.join_n2_n2 (S : finset α)
  {n : ℕ}
  (cap4_free : ¬C.has_ncap 4 S)
  {c1 : list α} (hc1 : C.ncup (n+2) c1) (c1_in_S : c1.in S)
  {c2 : list α} (hc2 : C.ncup (n+2) c2) (c2_in_S : c2.in S)
  (x : α) (hx1 : x ∈ c1.last') (hx2 : x ∈ c2.head') : C.has_ngon (n+3) S :=
begin
  -- Introduce variables
  have c1_size2 : 2 ≤ c1.length := by cases hc1; linarith,
  rcases list.take_last2 c1_size2 with ⟨a, x, c1', eq_c1⟩,
  subst eq_c1, simp at hx1, subst hx1,
  have c2_size2 : 2 ≤ c2.length := by cases hc2; linarith,
  rcases list.take_head2 c2_size2 with ⟨x, b, c2', eq_c2⟩,
  subst eq_c2, simp at hx2, subst hx2,

  have lab := cap4_free_label cap4_free,
  by_cases hl : lab.slope a b,
  { apply C.join_n2_n2_case_tt S n a x b c1' c2' lab;
    simp at c1_in_S c2_in_S; tauto },
  { apply C.join_n2_n2_case_ff S n a x b c1' c2' lab;
    simp at c1_in_S c2_in_S; tauto },
end


import .interp
import .expr

open arith
open arith.var

-- variables

def X := Δ 0
def Y := Δ 1
def Z := Δ 2
def W := Δ 0  -- W and X are the same variable

-- an interpretation

def init : var → nat
| v := nat.zero

-- test interpretation override

example : init X = 0 := rfl
example : init Y = 0 := rfl
example : init Z = 0 := rfl

-- "assignment operation"
-- {X = 0, Y = 0, Z = 0}
def st_1 := override init X 2
-- {X = 2, Y = 0, Z = 0}

example : st_1 X = 2 := rfl
example : st_1 Y = 0 := rfl
example : st_1 Z = 0 := rfl

-- "assignment operation"
-- {X = 2, Y = 0, Z = 0}
def st_2 := override (st_1) Z 5
-- {X = 2, Y = 0, Z = 5}

example : st_2 X = 2 := rfl
example : st_2 Y = 0 := rfl
example : st_2 Z = 5 := rfl

-- example expressions

def e1 := [0] -- overloaded []: literal expresion
def e2 := e1 + e1
def e3 := e2++
def e4 := ⟨ X ⟩   -- []: "var" expression

-- test evaluation

example : eval e3 init = 1 := rfl
example : eval e4 st_2 = 7 := rfl


/-
Copyright (c) 2022 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Daniel Selsam
-/
import logic.function.basic
import data.finset.card
import data.fintype.basic

/--
Five different awards are to be given to three students.
Each student will receive at least one award.
In how many different ways can the awards be distributed?
-/
theorem amc8_2020_p23 :
  (finset.filter function.surjective finset.univ : finset (fin 5 → fin 3)).card = 150 :=
begin
  dec_trivial
end


example (P Q F : Type) : (P → Q) → ((Q → F) → (P → F)) :=
begin
    intro pq,
    intro qf,
    intro p,
    apply qf,
    apply pq,
    exact p,
end


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

A model of ZFC in Lean.
-/
import data.set.basic

universes u v

/-- The type of `n`-ary functions `α → α → ... → α`. -/
def arity (α : Type u) : nat → Type u
| 0     := α
| (n+1) := α → arity n

namespace arity

/-- Constant `n`-ary function with value `a`. -/
def const {α : Type u} (a : α) : ∀ n, arity α n
| 0 := a
| (n+1) := λ _, const n

instance arity.inhabited {α n} [inhabited α] : inhabited (arity α n) :=
⟨const (default _) _⟩

end arity

/-- The type of pre-sets in universe `u`. A pre-set
  is a family of pre-sets indexed by a type in `Type u`.
  The ZFC universe is defined as a quotient of this
  to ensure extensionality. -/
inductive pSet : Type (u+1)
| mk (α : Type u) (A : α → pSet) : pSet

namespace pSet

/-- The underlying type of a pre-set -/
def type : pSet → Type u
| ⟨α, A⟩ := α

/-- The underlying pre-set family of a pre-set -/
def func : Π (x : pSet), x.type → pSet
| ⟨α, A⟩ := A

theorem mk_type_func : Π (x : pSet), mk x.type x.func = x
| ⟨α, A⟩ := rfl

/-- Two pre-sets are extensionally equivalent if every
  element of the first family is extensionally equivalent to
  some element of the second family and vice-versa. -/
def equiv (x y : pSet) : Prop :=
pSet.rec (λα z m ⟨β, B⟩, (∀a, ∃b, m a (B b)) ∧ (∀b, ∃a, m a (B b))) x y

theorem equiv.refl (x) : equiv x x :=
pSet.rec_on x $ λα A IH, ⟨λa, ⟨a, IH a⟩, λa, ⟨a, IH a⟩⟩

theorem equiv.euc {x} : Π {y z}, equiv x y → equiv z y → equiv x z :=
pSet.rec_on x $ λα A IH y, pSet.cases_on y $ λβ B ⟨γ, Γ⟩ ⟨αβ, βα⟩ ⟨γβ, βγ⟩,
⟨λa, let ⟨b, ab⟩ := αβ a, ⟨c, bc⟩ := βγ b in ⟨c, IH a ab bc⟩,
  λc, let ⟨b, cb⟩ := γβ c, ⟨a, ba⟩ := βα b in ⟨a, IH a ba cb⟩⟩

theorem equiv.symm {x y} : equiv x y → equiv y x :=
equiv.euc (equiv.refl y)

theorem equiv.trans {x y z} (h1 : equiv x y) (h2 : equiv y z) : equiv x z :=
equiv.euc h1 (equiv.symm h2)

instance setoid : setoid pSet :=
⟨pSet.equiv, equiv.refl, λx y, equiv.symm, λx y z, equiv.trans⟩

protected def subset : pSet → pSet → Prop
| ⟨α, A⟩ ⟨β, B⟩ := ∀a, ∃b, equiv (A a) (B b)

instance : has_subset pSet := ⟨pSet.subset⟩

theorem equiv.ext : Π (x y : pSet), equiv x y ↔ (x ⊆ y ∧ y ⊆ x)
| ⟨α, A⟩ ⟨β, B⟩ :=
  ⟨λ⟨αβ, βα⟩, ⟨αβ, λb, let ⟨a, h⟩ := βα b in ⟨a, equiv.symm h⟩⟩,
    λ⟨αβ, βα⟩, ⟨αβ, λb, let ⟨a, h⟩ := βα b in ⟨a, equiv.symm h⟩⟩⟩

theorem subset.congr_left : Π {x y z : pSet}, equiv x y → (x ⊆ z ↔ y ⊆ z)
| ⟨α, A⟩ ⟨β, B⟩ ⟨γ, Γ⟩ ⟨αβ, βα⟩ :=
  ⟨λαγ b, let ⟨a, ba⟩ := βα b, ⟨c, ac⟩ := αγ a in ⟨c, equiv.trans (equiv.symm ba) ac⟩,
    λβγ a, let ⟨b, ab⟩ := αβ a, ⟨c, bc⟩ := βγ b in ⟨c, equiv.trans ab bc⟩⟩

theorem subset.congr_right : Π {x y z : pSet}, equiv x y → (z ⊆ x ↔ z ⊆ y)
| ⟨α, A⟩ ⟨β, B⟩ ⟨γ, Γ⟩ ⟨αβ, βα⟩ :=
  ⟨λγα c, let ⟨a, ca⟩ := γα c, ⟨b, ab⟩ := αβ a in ⟨b, equiv.trans ca ab⟩,
    λγβ c, let ⟨b, cb⟩ := γβ c, ⟨a, ab⟩ := βα b in ⟨a, equiv.trans cb (equiv.symm ab)⟩⟩

/-- `x ∈ y` as pre-sets if `x` is extensionally equivalent to a member
  of the family `y`. -/
def mem : pSet → pSet → Prop
| x ⟨β, B⟩ := ∃b, equiv x (B b)
instance : has_mem pSet.{u} pSet.{u} := ⟨mem⟩

theorem mem.mk {α: Type u} (A : α → pSet) (a : α) : A a ∈ mk α A :=
show mem (A a) ⟨α, A⟩, from ⟨a, equiv.refl (A a)⟩

theorem mem.ext : Π {x y : pSet.{u}}, (∀w:pSet.{u}, w ∈ x ↔ w ∈ y) → equiv x y
| ⟨α, A⟩ ⟨β, B⟩ h := ⟨λa, (h (A a)).1 (mem.mk A a),
    λb, let ⟨a, ha⟩ := (h (B b)).2 (mem.mk B b) in ⟨a, equiv.symm ha⟩⟩

theorem mem.congr_right : Π {x y : pSet.{u}}, equiv x y → (∀{w:pSet.{u}}, w ∈ x ↔ w ∈ y)
| ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩ w :=
  ⟨λ⟨a, ha⟩, let ⟨b, hb⟩ := αβ a in ⟨b, equiv.trans ha hb⟩,
    λ⟨b, hb⟩, let ⟨a, ha⟩ := βα b in ⟨a, equiv.euc hb ha⟩⟩

theorem equiv_iff_mem {x y : pSet.{u}} : equiv x y ↔ (∀{w:pSet.{u}}, w ∈ x ↔ w ∈ y) :=
⟨mem.congr_right, match x, y with
| ⟨α, A⟩, ⟨β, B⟩, h := ⟨λ a, h.1 (mem.mk A a), λ b,
  let ⟨a, h⟩ := h.2 (mem.mk B b) in ⟨a, h.symm⟩⟩
end⟩

theorem mem.congr_left : Π {x y : pSet.{u}}, equiv x y → (∀{w : pSet.{u}}, x ∈ w ↔ y ∈ w)
| x y h ⟨α, A⟩ := ⟨λ⟨a, ha⟩, ⟨a, equiv.trans (equiv.symm h) ha⟩, λ⟨a, ha⟩, ⟨a, equiv.trans h ha⟩⟩

/-- Convert a pre-set to a `set` of pre-sets. -/
def to_set (u : pSet.{u}) : set pSet.{u} := {x | x ∈ u}

/-- Two pre-sets are equivalent iff they have the same members. -/
theorem equiv.eq {x y : pSet} : equiv x y ↔ to_set x = to_set y :=
equiv_iff_mem.trans set.ext_iff.symm

instance : has_coe pSet (set pSet) := ⟨to_set⟩

/-- The empty pre-set -/
protected def empty : pSet := ⟨ulift empty, λe, match e with end⟩

instance : has_emptyc pSet := ⟨pSet.empty⟩

instance : inhabited pSet := ⟨∅⟩

theorem mem_empty (x : pSet.{u}) : x ∉ (∅:pSet.{u}) := λe, match e with end

/-- Insert an element into a pre-set -/
protected def insert : pSet → pSet → pSet
| u ⟨α, A⟩ := ⟨option α, λo, option.rec u A o⟩

instance : has_insert pSet pSet := ⟨pSet.insert⟩

instance : has_singleton pSet pSet := ⟨λ s, insert s ∅⟩

instance : is_lawful_singleton pSet pSet := ⟨λ _, rfl⟩

/-- The n-th von Neumann ordinal -/
def of_nat : ℕ → pSet
| 0     := ∅
| (n+1) := pSet.insert (of_nat n) (of_nat n)

/-- The von Neumann ordinal ω -/
def omega : pSet := ⟨ulift ℕ, λn, of_nat n.down⟩

/-- The separation operation `{x ∈ a | p x}` -/
protected def sep (p : set pSet) : pSet → pSet
| ⟨α, A⟩ := ⟨{a // p (A a)}, λx, A x.1⟩

instance : has_sep pSet pSet := ⟨pSet.sep⟩

/-- The powerset operator -/
def powerset : pSet → pSet
| ⟨α, A⟩ := ⟨set α, λp, ⟨{a // p a}, λx, A x.1⟩⟩

theorem mem_powerset : Π {x y : pSet}, y ∈ powerset x ↔ y ⊆ x
| ⟨α, A⟩ ⟨β, B⟩ := ⟨λ⟨p, e⟩, (subset.congr_left e).2 $ λ⟨a, pa⟩, ⟨a, equiv.refl (A a)⟩,
  λβα, ⟨{a | ∃b, equiv (B b) (A a)}, λb, let ⟨a, ba⟩ := βα b in ⟨⟨a, b, ba⟩, ba⟩,
    λ⟨a, b, ba⟩, ⟨b, ba⟩⟩⟩

/-- The set union operator -/
def Union : pSet → pSet
| ⟨α, A⟩ := ⟨Σx, (A x).type, λ⟨x, y⟩, (A x).func y⟩

theorem mem_Union : Π {x y : pSet.{u}}, y ∈ Union x ↔ ∃ z:pSet.{u}, ∃_:z ∈ x, y ∈ z
| ⟨α, A⟩ y :=
  ⟨λ⟨⟨a, c⟩, (e : equiv y ((A a).func c))⟩,
    have func (A a) c ∈ mk (A a).type (A a).func, from mem.mk (A a).func c,
    ⟨_, mem.mk _ _, (mem.congr_left e).2 (by rwa mk_type_func at this)⟩,
  λ⟨⟨β, B⟩, ⟨a, (e:equiv (mk β B) (A a))⟩, ⟨b, yb⟩⟩,
    by rw ←(mk_type_func (A a)) at e; exact
    let ⟨βt, tβ⟩ := e, ⟨c, bc⟩ := βt b in ⟨⟨a, c⟩, equiv.trans yb bc⟩⟩

/-- The image of a function -/
def image (f : pSet.{u} → pSet.{u}) : pSet.{u} → pSet
| ⟨α, A⟩ := ⟨α, λa, f (A a)⟩

theorem mem_image {f : pSet.{u} → pSet.{u}} (H : ∀{x y}, equiv x y → equiv (f x) (f y)) :
  Π {x y : pSet.{u}}, y ∈ image f x ↔ ∃z ∈ x, equiv y (f z)
| ⟨α, A⟩ y := ⟨λ⟨a, ya⟩, ⟨A a, mem.mk A a, ya⟩, λ⟨z, ⟨a, za⟩, yz⟩, ⟨a, equiv.trans yz (H za)⟩⟩

/-- Universe lift operation -/
protected def lift : pSet.{u} → pSet.{max u v}
| ⟨α, A⟩ := ⟨ulift α, λ⟨x⟩, lift (A x)⟩

/-- Embedding of one universe in another -/
def embed : pSet.{max (u+1) v} := ⟨ulift.{v u+1} pSet, λ⟨x⟩, pSet.lift.{u (max (u+1) v)} x⟩

theorem lift_mem_embed : Π (x : pSet.{u}), pSet.lift.{u (max (u+1) v)} x ∈ embed.{u v} :=
λx, ⟨⟨x⟩, equiv.refl _⟩

/-- Function equivalence is defined so that `f ~ g` iff
  `∀ x y, x ~ y → f x ~ g y`. This extends to equivalence of n-ary
  functions. -/
def arity.equiv : Π {n}, arity pSet.{u} n → arity pSet.{u} n → Prop
| 0     a b := equiv a b
| (n+1) a b := ∀ x y, equiv x y → arity.equiv (a x) (b y)

lemma arity.equiv_const {a : pSet.{u}} : ∀ n, arity.equiv (arity.const a n) (arity.const a n)
| 0 := equiv.refl _
| (n+1) := λ x y h, arity.equiv_const _

/-- `resp n` is the collection of n-ary functions on `pSet` that respect
  equivalence, i.e. when the inputs are equivalent the output is as well. -/
def resp (n) := { x : arity pSet.{u} n // arity.equiv x x }

instance resp.inhabited {n} : inhabited (resp n) :=
⟨⟨arity.const (default _) _, arity.equiv_const _⟩⟩

def resp.f {n} (f : resp (n+1)) (x : pSet) : resp n :=
⟨f.1 x, f.2 _ _ $ equiv.refl x⟩

def resp.equiv {n} (a b : resp n) : Prop := arity.equiv a.1 b.1

theorem resp.refl {n} (a : resp n) : resp.equiv a a := a.2

theorem resp.euc : Π {n} {a b c : resp n}, resp.equiv a b → resp.equiv c b → resp.equiv a c
| 0     a b c hab hcb := equiv.euc hab hcb
| (n+1) a b c hab hcb := by delta resp.equiv; simp [arity.equiv]; exact λx y h,
  @resp.euc n (a.f x) (b.f y) (c.f y) (hab _ _ h) (hcb _ _ $ equiv.refl y)

instance resp.setoid {n} : setoid (resp n) :=
⟨resp.equiv, resp.refl, λx y h, resp.euc (resp.refl y) h,
  λx y z h1 h2, resp.euc h1 $ resp.euc (resp.refl z) h2⟩

end pSet

/-- The ZFC universe of sets consists of the type of pre-sets,
  quotiented by extensional equivalence. -/
def Set : Type (u+1) := quotient pSet.setoid.{u}

namespace pSet

namespace resp

def eval_aux : Π {n}, {f : resp n → arity Set.{u} n // ∀ (a b : resp n), resp.equiv a b → f a = f b}
| 0     := ⟨λa, ⟦a.1⟧, λa b h, quotient.sound h⟩
| (n+1) := let F : resp (n + 1) → arity Set (n + 1) := λa, @quotient.lift _ _ pSet.setoid
    (λx, eval_aux.1 (a.f x)) (λb c h, eval_aux.2 _ _ (a.2 _ _ h)) in
  ⟨F, λb c h, funext $ @quotient.ind _ _ (λq, F b q = F c q) $ λz,
  eval_aux.2 (resp.f b z) (resp.f c z) (h _ _ (equiv.refl z))⟩

/-- An equivalence-respecting function yields an n-ary Set function. -/
def eval (n) : resp n → arity Set.{u} n := eval_aux.1

theorem eval_val {n f x} : (@eval (n+1) f : Set → arity Set n) ⟦x⟧ = eval n (resp.f f x) := rfl

end resp

/-- A set function is "definable" if it is the image of some n-ary pre-set
  function. This isn't exactly definability, but is useful as a sufficient
  condition for functions that have a computable image. -/
class inductive definable (n) : arity Set.{u} n → Type (u+1)
| mk (f) : definable (resp.eval _ f)
attribute [instance] definable.mk

def definable.eq_mk {n} (f) : Π {s : arity Set.{u} n} (H : resp.eval _ f = s), definable n s
| ._ rfl := ⟨f⟩

def definable.resp {n} : Π (s : arity Set.{u} n) [definable n s], resp n
| ._ ⟨f⟩ := f

theorem definable.eq {n} :
  Π (s : arity Set.{u} n) [H : definable n s], (@definable.resp n s H).eval _ = s
| ._ ⟨f⟩ := rfl

end pSet

namespace classical
open pSet

noncomputable def all_definable : Π {n} (F : arity Set.{u} n), definable n F
| 0     F := let p := @quotient.exists_rep pSet _ F in
              definable.eq_mk ⟨some p, equiv.refl _⟩ (some_spec p)
| (n+1) (F : arity Set.{u} (n + 1)) := begin
    have I := λx, (all_definable (F x)),
    refine definable.eq_mk ⟨λx:pSet, (@definable.resp _ _ (I ⟦x⟧)).1, _⟩ _,
    { dsimp [arity.equiv],
      introsI x y h,
      rw @quotient.sound pSet _ _ _ h,
      exact (definable.resp (F ⟦y⟧)).2 },
    exact funext (λq, quotient.induction_on q $ λx,
      by simp [resp.eval_val, resp.f]; exact @definable.eq _ (F ⟦x⟧) (I ⟦x⟧))
  end

end classical

namespace Set
open pSet

def mk : pSet → Set := quotient.mk

@[simp] theorem mk_eq (x : pSet) : @eq Set ⟦x⟧ (mk x) := rfl

@[simp] lemma eval_mk {n f x} :
  (@resp.eval (n+1) f : Set → arity Set n) (mk x) = resp.eval n (resp.f f x) :=
rfl

def mem : Set → Set → Prop :=
quotient.lift₂ pSet.mem
  (λx y x' y' hx hy, propext (iff.trans (mem.congr_left hx) (mem.congr_right hy)))

instance : has_mem Set Set := ⟨mem⟩

/-- Convert a ZFC set into a `set` of sets -/
def to_set (u : Set.{u}) : set Set.{u} := {x | x ∈ u}

protected def subset (x y : Set.{u}) :=
∀ ⦃z⦄, z ∈ x → z ∈ y

instance has_subset : has_subset Set :=
⟨Set.subset⟩

lemma subset_def {x y : Set.{u}} : x ⊆ y ↔ ∀ ⦃z⦄, z ∈ x → z ∈ y := iff.rfl

theorem subset_iff : Π (x y : pSet), mk x ⊆ mk y ↔ x ⊆ y
| ⟨α, A⟩ ⟨β, B⟩ := ⟨λh a, @h ⟦A a⟧ (mem.mk A a),
  λh z, quotient.induction_on z (λz ⟨a, za⟩, let ⟨b, ab⟩ := h a in ⟨b, equiv.trans za ab⟩)⟩

theorem ext {x y : Set.{u}} : (∀z:Set.{u}, z ∈ x ↔ z ∈ y) → x = y :=
quotient.induction_on₂ x y (λu v h, quotient.sound (mem.ext (λw, h ⟦w⟧)))

theorem ext_iff {x y : Set.{u}} : (∀z:Set.{u}, z ∈ x ↔ z ∈ y) ↔ x = y :=
⟨ext, λh, by simp [h]⟩

/-- The empty set -/
def empty : Set := mk ∅
instance : has_emptyc Set := ⟨empty⟩
instance : inhabited Set := ⟨∅⟩

@[simp] theorem mem_empty (x) : x ∉ (∅:Set.{u}) :=
quotient.induction_on x pSet.mem_empty

theorem eq_empty (x : Set.{u}) : x = ∅ ↔ ∀y:Set.{u}, y ∉ x :=
⟨λh, by rw h; exact mem_empty,
λh, ext (λy, ⟨λyx, absurd yx (h y), λy0, absurd y0 (mem_empty _)⟩)⟩

/-- `insert x y` is the set `{x} ∪ y` -/
protected def insert : Set → Set → Set :=
resp.eval 2 ⟨pSet.insert, λu v uv ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λo, match o with
   | some a := let ⟨b, hb⟩ := αβ a in ⟨some b, hb⟩
   | none := ⟨none, uv⟩
   end, λo, match o with
   | some b := let ⟨a, ha⟩ := βα b in ⟨some a, ha⟩
   | none := ⟨none, uv⟩
   end⟩⟩

instance : has_insert Set Set := ⟨Set.insert⟩

instance : has_singleton Set Set := ⟨λ x, insert x ∅⟩

instance : is_lawful_singleton Set Set := ⟨λ x, rfl⟩

@[simp] theorem mem_insert {x y z : Set.{u}} : x ∈ insert y z ↔ x = y ∨ x ∈ z :=
quotient.induction_on₃ x y z
 (λx y ⟨α, A⟩, show x ∈ pSet.mk (option α) (λo, option.rec y A o) ↔
    mk x = mk y ∨ x ∈ pSet.mk α A, from
  ⟨λm, match m with
  | ⟨some a, ha⟩ := or.inr ⟨a, ha⟩
  | ⟨none, h⟩ := or.inl (quotient.sound h)
  end, λm, match m with
  | or.inr ⟨a, ha⟩ := ⟨some a, ha⟩
  | or.inl h := ⟨none, quotient.exact h⟩
  end⟩)

@[simp] theorem mem_singleton {x y : Set.{u}} : x ∈ @singleton Set.{u} Set.{u} _ y ↔ x = y :=
iff.trans mem_insert ⟨λo, or.rec (λh, h) (λn, absurd n (mem_empty _)) o, or.inl⟩

@[simp] theorem mem_pair {x y z : Set.{u}} : x ∈ ({y, z} : Set) ↔ x = y ∨ x = z :=
iff.trans mem_insert $ or_congr iff.rfl mem_singleton

/-- `omega` is the first infinite von Neumann ordinal -/
def omega : Set := mk omega

@[simp] theorem omega_zero : ∅ ∈ omega :=
show pSet.mem ∅ pSet.omega, from ⟨⟨0⟩, equiv.refl _⟩

@[simp] theorem omega_succ {n} : n ∈ omega.{u} → insert n n ∈ omega.{u} :=
quotient.induction_on n (λx ⟨⟨n⟩, h⟩, ⟨⟨n+1⟩,
  have Set.insert ⟦x⟧ ⟦x⟧ = Set.insert ⟦of_nat n⟧ ⟦of_nat n⟧, by rw (@quotient.sound pSet _ _ _ h),
  quotient.exact this⟩)

/-- `{x ∈ a | p x}` is the set of elements in `a` satisfying `p` -/
protected def sep (p : Set → Prop) : Set → Set :=
resp.eval 1 ⟨pSet.sep (λy, p ⟦y⟧), λ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λ⟨a, pa⟩, let ⟨b, hb⟩ := αβ a in ⟨⟨b, by rwa ←(@quotient.sound pSet _ _ _ hb)⟩, hb⟩,
   λ⟨b, pb⟩, let ⟨a, ha⟩ := βα b in ⟨⟨a, by rwa (@quotient.sound pSet _ _ _ ha)⟩, ha⟩⟩⟩

instance : has_sep Set Set := ⟨Set.sep⟩

@[simp] theorem mem_sep {p : Set.{u} → Prop} {x y : Set.{u}} : y ∈ {y ∈ x | p y} ↔ y ∈ x ∧ p y :=
quotient.induction_on₂ x y (λ⟨α, A⟩ y,
  ⟨λ⟨⟨a, pa⟩, h⟩, ⟨⟨a, h⟩, by rw (@quotient.sound pSet _ _ _ h); exact pa⟩,
  λ⟨⟨a, h⟩, pa⟩, ⟨⟨a, by rw ←(@quotient.sound pSet _ _ _ h); exact pa⟩, h⟩⟩)

/-- The powerset operation, the collection of subsets of a set -/
def powerset : Set → Set :=
resp.eval 1 ⟨powerset, λ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨λp, ⟨{b | ∃a, p a ∧ equiv (A a) (B b)},
    λ⟨a, pa⟩, let ⟨b, ab⟩ := αβ a in ⟨⟨b, a, pa, ab⟩, ab⟩,
    λ⟨b, a, pa, ab⟩, ⟨⟨a, pa⟩, ab⟩⟩,
   λq, ⟨{a | ∃b, q b ∧ equiv (A a) (B b)},
    λ⟨a, b, qb, ab⟩, ⟨⟨b, qb⟩, ab⟩,
    λ⟨b, qb⟩, let ⟨a, ab⟩ := βα b in ⟨⟨a, b, qb, ab⟩, ab⟩⟩⟩⟩

@[simp] theorem mem_powerset {x y : Set} : y ∈ powerset x ↔ y ⊆ x :=
quotient.induction_on₂ x y (λ⟨α, A⟩ ⟨β, B⟩,
  show (⟨β, B⟩ : pSet) ∈ (pSet.powerset ⟨α, A⟩) ↔ _,
    by simp [mem_powerset, subset_iff])

theorem Union_lem {α β : Type u} (A : α → pSet) (B : β → pSet)
  (αβ : ∀a, ∃b, equiv (A a) (B b)) : ∀a, ∃b, (equiv ((Union ⟨α, A⟩).func a) ((Union ⟨β, B⟩).func b))
| ⟨a, c⟩ := let ⟨b, hb⟩ := αβ a in
  begin
    induction ea : A a with γ Γ,
    induction eb : B b with δ Δ,
    rw [ea, eb] at hb,
    cases hb with γδ δγ,
    exact
    let c : type (A a) := c, ⟨d, hd⟩ := γδ (by rwa ea at c) in
    have equiv ((A a).func c) ((B b).func (eq.rec d (eq.symm eb))), from
    match A a, B b, ea, eb, c, d, hd with ._, ._, rfl, rfl, x, y, hd := hd end,
    ⟨⟨b, eq.rec d (eq.symm eb)⟩, this⟩
  end

/-- The union operator, the collection of elements of elements of a set -/
def Union : Set → Set :=
resp.eval 1 ⟨pSet.Union, λ⟨α, A⟩ ⟨β, B⟩ ⟨αβ, βα⟩,
  ⟨Union_lem A B αβ, λa, exists.elim (Union_lem B A (λb,
    exists.elim (βα b) (λc hc, ⟨c, equiv.symm hc⟩)) a) (λb hb, ⟨b, equiv.symm hb⟩)⟩⟩

notation `⋃` := Union

@[simp] theorem mem_Union {x y : Set.{u}} : y ∈ Union x ↔ ∃ z ∈ x, y ∈ z :=
quotient.induction_on₂ x y (λx y, iff.trans mem_Union
  ⟨λ⟨z, h⟩, ⟨⟦z⟧, h⟩, λ⟨z, h⟩, quotient.induction_on z (λz h, ⟨z, h⟩) h⟩)

@[simp] theorem Union_singleton {x : Set.{u}} : Union {x} = x :=
ext $ λy, by simp; exact ⟨λ⟨z, zx, yz⟩, by subst z; exact yz, λyx, ⟨x, by simp, yx⟩⟩

theorem singleton_inj {x y : Set.{u}} (H : ({x} : Set) = {y}) : x = y :=
let this := congr_arg Union H in by rwa [Union_singleton, Union_singleton] at this

/-- The binary union operation -/
protected def union (x y : Set.{u}) : Set.{u} := ⋃ {x, y}

/-- The binary intersection operation -/
protected def inter (x y : Set.{u}) : Set.{u} := {z ∈ x | z ∈ y}

/-- The set difference operation -/
protected def diff (x y : Set.{u}) : Set.{u} := {z ∈ x | z ∉ y}

instance : has_union Set := ⟨Set.union⟩
instance : has_inter Set := ⟨Set.inter⟩
instance : has_sdiff Set := ⟨Set.diff⟩

@[simp] theorem mem_union {x y z : Set.{u}} : z ∈ x ∪ y ↔ z ∈ x ∨ z ∈ y :=
iff.trans mem_Union
 ⟨λ⟨w, wxy, zw⟩, match mem_pair.1 wxy with
  | or.inl wx := or.inl (by rwa ←wx)
  | or.inr wy := or.inr (by rwa ←wy)
  end, λzxy, match zxy with
  | or.inl zx := ⟨x, mem_pair.2 (or.inl rfl), zx⟩
  | or.inr zy := ⟨y, mem_pair.2 (or.inr rfl), zy⟩
  end⟩

@[simp] theorem mem_inter {x y z : Set.{u}} : z ∈ x ∩ y ↔ z ∈ x ∧ z ∈ y :=
@@mem_sep (λz:Set.{u}, z ∈ y)

@[simp] theorem mem_diff {x y z : Set.{u}} : z ∈ x \ y ↔ z ∈ x ∧ z ∉ y :=
@@mem_sep (λz:Set.{u}, z ∉ y)

theorem induction_on {p : Set → Prop} (x) (h : ∀x, (∀y ∈ x, p y) → p x) : p x :=
quotient.induction_on x $ λu, pSet.rec_on u $ λα A IH, h _ $ λy,
show @has_mem.mem _ _ Set.has_mem y ⟦⟨α, A⟩⟧ → p y, from
quotient.induction_on y (λv ⟨a, ha⟩, by rw (@quotient.sound pSet _ _ _ ha); exact IH a)

theorem regularity (x : Set.{u}) (h : x ≠ ∅) : ∃ y ∈ x, x ∩ y = ∅ :=
classical.by_contradiction $ λne, h $ (eq_empty x).2 $ λy,
induction_on y $ λz (IH : ∀w:Set.{u}, w ∈ z → w ∉ x), show z ∉ x, from λzx,
ne ⟨z, zx, (eq_empty _).2 (λw wxz, let ⟨wx, wz⟩ := mem_inter.1 wxz in IH w wz wx)⟩

/-- The image of a (definable) set function -/
def image (f : Set → Set) [H : definable 1 f] : Set → Set :=
let r := @definable.resp 1 f _ in
resp.eval 1 ⟨image r.1, λx y e, mem.ext $ λz,
  iff.trans (mem_image r.2) $ iff.trans (by exact
   ⟨λ⟨w, h1, h2⟩, ⟨w, (mem.congr_right e).1 h1, h2⟩,
    λ⟨w, h1, h2⟩, ⟨w, (mem.congr_right e).2 h1, h2⟩⟩) $
  iff.symm (mem_image r.2)⟩

theorem image.mk :
  Π (f : Set.{u} → Set.{u}) [H : definable 1 f] (x) {y} (h : y ∈ x), f y ∈ @image f H x
| ._ ⟨F⟩ x y := quotient.induction_on₂ x y $ λ⟨α, A⟩ y ⟨a, ya⟩, ⟨a, F.2 _ _ ya⟩

@[simp] theorem mem_image :
  Π {f : Set.{u} → Set.{u}} [H : definable 1 f] {x y : Set.{u}}, y ∈ @image f H x ↔ ∃z ∈ x, f z = y
| ._ ⟨F⟩ x y := quotient.induction_on₂ x y $ λ⟨α, A⟩ y,
  ⟨λ⟨a, ya⟩, ⟨⟦A a⟧, mem.mk A a, eq.symm $ quotient.sound ya⟩,
  λ⟨z, hz, e⟩, e ▸ image.mk _ _ hz⟩

/-- Kuratowski ordered pair -/
def pair (x y : Set.{u}) : Set.{u} := {{x}, {x, y}}

/-- A subset of pairs `{(a, b) ∈ x × y | p a b}` -/
def pair_sep (p : Set.{u} → Set.{u} → Prop) (x y : Set.{u}) : Set.{u} :=
{z ∈ powerset (powerset (x ∪ y)) | ∃a ∈ x, ∃b ∈ y, z = pair a b ∧ p a b}

@[simp] theorem mem_pair_sep {p} {x y z : Set.{u}} :
  z ∈ pair_sep p x y ↔ ∃a ∈ x, ∃b ∈ y, z = pair a b ∧ p a b :=
begin
  refine mem_sep.trans ⟨and.right, λe, ⟨_, e⟩⟩,
  rcases e with ⟨a, ax, b, bY, rfl, pab⟩,
  simp only [mem_powerset, subset_def, mem_union, pair, mem_pair],
  rintros u (rfl|rfl) v; simp only [mem_singleton, mem_pair],
  { rintro rfl, exact or.inl ax },
  { rintro (rfl|rfl); [left, right]; assumption }
end

theorem pair_inj {x y x' y' : Set.{u}} (H : pair x y = pair x' y') : x = x' ∧ y = y' := begin
  have ae := ext_iff.2 H,
  simp [pair] at ae,
  have : x = x',
  { cases (ae {x}).1 (by simp) with h h,
    { exact singleton_inj h },
    { have m : x' ∈ ({x} : Set),
      { rw h, simp },
      simp at m, simp [*] } },
  subst x',
  have he : y = x → y = y',
  { intro yx, subst y,
    cases (ae {x, y'}).2 (by simp) with xy'x xy'xx,
    { have y'x : y' ∈ ({x} : Set) := by rw ← xy'x; simp,
      simp at y'x, simp [*] },
    { have yxx := (ext_iff.2 xy'xx y').1 (by simp),
      simp at yxx, subst y' } },
  have xyxy' := (ae {x, y}).1 (by simp),
  cases xyxy' with xyx xyy',
  { have yx := (ext_iff.2 xyx y).1 (by simp),
    simp at yx, simp [he yx] },
  { have yxy' := (ext_iff.2 xyy' y).1 (by simp),
    simp at yxy',
    cases yxy' with yx yy',
    { simp [he yx] },
    { simp [yy'] } }
end

/-- The cartesian product, `{(a, b) | a ∈ x, b ∈ y}` -/
def prod : Set.{u} → Set.{u} → Set.{u} := pair_sep (λa b, true)

@[simp] theorem mem_prod {x y z : Set.{u}} : z ∈ prod x y ↔ ∃a ∈ x, ∃b ∈ y, z = pair a b :=
by simp [prod]

@[simp] theorem pair_mem_prod {x y a b : Set.{u}} : pair a b ∈ prod x y ↔ a ∈ x ∧ b ∈ y :=
⟨λh, let ⟨a', a'x, b', b'y, e⟩ := mem_prod.1 h in
  match a', b', pair_inj e, a'x, b'y with ._, ._, ⟨rfl, rfl⟩, ax, bY := ⟨ax, bY⟩ end,
λ⟨ax, bY⟩, by simp; exact ⟨a, ax, b, bY, rfl⟩⟩

/-- `is_func x y f` is the assertion `f : x → y` where `f` is a ZFC function
  (a set of ordered pairs) -/
def is_func (x y f : Set.{u}) : Prop :=
f ⊆ prod x y ∧ ∀z:Set.{u}, z ∈ x → ∃! w, pair z w ∈ f

/-- `funs x y` is `y ^ x`, the set of all set functions `x → y` -/
def funs (x y : Set.{u}) : Set.{u} :=
{f ∈ powerset (prod x y) | is_func x y f}

@[simp] theorem mem_funs {x y f : Set.{u}} : f ∈ funs x y ↔ is_func x y f :=
by simp [funs, is_func]

-- TODO(Mario): Prove this computably
noncomputable instance map_definable_aux (f : Set → Set) [H : definable 1 f] :
  definable 1 (λy, pair y (f y)) :=
@classical.all_definable 1 _

/-- Graph of a function: `map f x` is the ZFC function which maps `a ∈ x` to `f a` -/
noncomputable def map (f : Set → Set) [H : definable 1 f] : Set → Set :=
image (λy, pair y (f y))

@[simp] theorem mem_map {f : Set → Set} [H : definable 1 f] {x y : Set} :
  y ∈ map f x ↔ ∃z ∈ x, pair z (f z) = y :=
mem_image

theorem map_unique {f : Set.{u} → Set.{u}} [H : definable 1 f] {x z : Set.{u}} (zx : z ∈ x) :
  ∃! w, pair z w ∈ map f x :=
⟨f z, image.mk _ _ zx, λy yx, let ⟨w, wx, we⟩ := mem_image.1 yx, ⟨wz, fy⟩ := pair_inj we in
  by rw[←fy, wz]⟩

@[simp] theorem map_is_func {f : Set → Set} [H : definable 1 f] {x y : Set} :
  is_func x y (map f x) ↔ ∀z ∈ x, f z ∈ y :=
⟨λ⟨ss, h⟩ z zx, let ⟨t, t1, t2⟩ := h z zx in by rw (t2 (f z) (image.mk _ _ zx));
  exact (pair_mem_prod.1 (ss t1)).right,
λh, ⟨λy yx, let ⟨z, zx, ze⟩ := mem_image.1 yx in by rw ←ze; exact pair_mem_prod.2 ⟨zx, h z zx⟩,
     λz, map_unique⟩⟩

end Set

def Class := set Set

namespace Class

instance : has_subset Class     := ⟨set.subset⟩
instance : has_sep Set Class    := ⟨set.sep⟩
instance : has_emptyc Class     := ⟨λ a, false⟩
instance : inhabited Class      := ⟨∅⟩
instance : has_insert Set Class := ⟨set.insert⟩
instance : has_union Class      := ⟨set.union⟩
instance : has_inter Class      := ⟨set.inter⟩
instance : has_neg Class        := ⟨set.compl⟩
instance : has_sdiff Class      := ⟨set.diff⟩

/-- Coerce a set into a class -/
def of_Set (x : Set.{u}) : Class.{u} := {y | y ∈ x}
instance : has_coe Set Class := ⟨of_Set⟩

/-- The universal class -/
def univ : Class := set.univ

/-- Assert that `A` is a set satisfying `p` -/
def to_Set (p : Set.{u} → Prop) (A : Class.{u}) : Prop := ∃x, ↑x = A ∧ p x

/-- `A ∈ B` if `A` is a set which is a member of `B` -/
protected def mem (A B : Class.{u}) : Prop := to_Set.{u} B A
instance : has_mem Class Class := ⟨Class.mem⟩

theorem mem_univ {A : Class.{u}} : A ∈ univ.{u} ↔ ∃ x : Set.{u}, ↑x = A :=
exists_congr $ λx, and_true _

/-- Convert a conglomerate (a collection of classes) into a class -/
def Cong_to_Class (x : set Class.{u}) : Class.{u} := {y | ↑y ∈ x}

/-- Convert a class into a conglomerate (a collection of classes) -/
def Class_to_Cong (x : Class.{u}) : set Class.{u} := {y | y ∈ x}

/-- The power class of a class is the class of all subclasses that are sets -/
def powerset (x : Class) : Class := Cong_to_Class (set.powerset x)

/-- The union of a class is the class of all members of sets in the class -/
def Union (x : Class) : Class := set.sUnion (Class_to_Cong x)
notation `⋃` := Union

theorem of_Set.inj {x y : Set.{u}} (h : (x : Class.{u}) = y) : x = y :=
Set.ext $ λz, by change (x : Class.{u}) z ↔ (y : Class.{u}) z; simp [*]

@[simp] theorem to_Set_of_Set (p : Set.{u} → Prop) (x : Set.{u}) : to_Set p x ↔ p x :=
⟨λ⟨y, yx, py⟩, by rwa of_Set.inj yx at py, λpx, ⟨x, rfl, px⟩⟩

@[simp] theorem mem_hom_left (x : Set.{u}) (A : Class.{u}) : (x : Class.{u}) ∈ A ↔ A x :=
to_Set_of_Set _ _

@[simp] theorem mem_hom_right (x y : Set.{u}) : (y : Class.{u}) x ↔ x ∈ y := iff.rfl

@[simp] theorem subset_hom (x y : Set.{u}) : (x : Class.{u}) ⊆ y ↔ x ⊆ y := iff.rfl

@[simp] theorem sep_hom (p : Set.{u} → Prop) (x : Set.{u}) :
  (↑{y ∈ x | p y} : Class.{u}) = {y ∈ x | p y} :=
set.ext $ λy, Set.mem_sep

@[simp] theorem empty_hom : ↑(∅ : Set.{u}) = (∅ : Class.{u}) :=
set.ext $ λy, show _ ↔ false, by simp; exact Set.mem_empty y

@[simp] theorem insert_hom (x y : Set.{u}) : (@insert Set.{u} Class.{u} _ x y) = ↑(insert x y) :=
set.ext $ λz, iff.symm Set.mem_insert

@[simp] theorem union_hom (x y : Set.{u}) : (x : Class.{u}) ∪ y = (x ∪ y : Set.{u}) :=
set.ext $ λz, iff.symm Set.mem_union

@[simp] theorem inter_hom (x y : Set.{u}) : (x : Class.{u}) ∩ y = (x ∩ y : Set.{u}) :=
set.ext $ λz, iff.symm Set.mem_inter

@[simp] theorem diff_hom (x y : Set.{u}) : (x : Class.{u}) \ y = (x \ y : Set.{u}) :=
set.ext $ λz, iff.symm Set.mem_diff

@[simp] theorem powerset_hom (x : Set.{u}) : powerset.{u} x = Set.powerset x :=
set.ext $ λz, iff.symm Set.mem_powerset

@[simp] theorem Union_hom (x : Set.{u}) : Union.{u} x = Set.Union x :=
set.ext $ λz, by refine iff.trans _ (iff.symm Set.mem_Union); exact
⟨λ⟨._, ⟨a, rfl, ax⟩, za⟩, ⟨a, ax, za⟩, λ⟨a, ax, za⟩, ⟨_, ⟨a, rfl, ax⟩, za⟩⟩

/-- The definite description operator, which is {x} if `{a | p a} = {x}`
  and ∅ otherwise -/
def iota (p : Set → Prop) : Class := Union {x | ∀y, p y ↔ y = x}

theorem iota_val (p : Set → Prop) (x : Set) (H : ∀y, p y ↔ y = x) : iota p = ↑x :=
set.ext $ λy, ⟨λ⟨._, ⟨x', rfl, h⟩, yx'⟩, by rwa ←((H x').1 $ (h x').2 rfl),
  λyx, ⟨_, ⟨x, rfl, H⟩, yx⟩⟩

/-- Unlike the other set constructors, the `iota` definite descriptor
  is a set for any set input, but not constructively so, so there is no
  associated `(Set → Prop) → Set` function. -/
theorem iota_ex (p) : iota.{u} p ∈ univ.{u} :=
mem_univ.2 $ or.elim (classical.em $ ∃x, ∀y, p y ↔ y = x)
 (λ⟨x, h⟩, ⟨x, eq.symm $ iota_val p x h⟩)
 (λhn, ⟨∅, by simp; exact set.ext (λz, ⟨false.rec _, λ⟨._, ⟨x, rfl, H⟩, zA⟩, hn ⟨x, H⟩⟩)⟩)

/-- Function value -/
def fval (F A : Class.{u}) : Class.{u} := iota (λy, to_Set (λx, F (Set.pair x y)) A)
infixl `′`:100 := fval

theorem fval_ex (F A : Class.{u}) : F ′ A ∈ univ.{u} := iota_ex _

end Class

namespace Set

@[simp] theorem map_fval {f : Set.{u} → Set.{u}} [H : pSet.definable 1 f]
  {x y : Set.{u}} (h : y ∈ x) :
  (Set.map f x ′ y : Class.{u}) = f y :=
Class.iota_val _ _ (λz, by simp; exact
  ⟨λ⟨w, wz, pr⟩, let ⟨wy, fw⟩ := Set.pair_inj pr in by rw[←fw, wy],
  λe, by cases e; exact ⟨_, h, rfl⟩⟩)

variables (x : Set.{u}) (h : ∅ ∉ x)

/-- A choice function on the set of nonempty sets `x` -/
noncomputable def choice : Set :=
@map (λy, classical.epsilon (λz, z ∈ y)) (classical.all_definable _) x

include h
theorem choice_mem_aux (y : Set.{u}) (yx : y ∈ x) : classical.epsilon (λz:Set.{u}, z ∈ y) ∈ y :=
@classical.epsilon_spec _ (λz:Set.{u}, z ∈ y) $ classical.by_contradiction $ λn, h $
by rwa ←((eq_empty y).2 $ λz zx, n ⟨z, zx⟩)

theorem choice_is_func : is_func x (Union x) (choice x) :=
(@map_is_func _ (classical.all_definable _) _ _).2 $
  λy yx, by simp; exact ⟨y, yx, choice_mem_aux x h y yx⟩

theorem choice_mem (y : Set.{u}) (yx : y ∈ x) : (choice x ′ y : Class.{u}) ∈ (y : Class.{u}) :=
by delta choice; rw map_fval yx; simp [choice_mem_aux x h y yx]

end Set