/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.list
import Mathlib.logic.function.iterate
import Mathlib.PostPort

universes u_1 l u_2 u_3 u_5 u_4

namespace Mathlib

/-!
# The primitive recursive functions

The primitive recursive functions are the least collection of functions
`nat → nat` which are closed under projections (using the mkpair
pairing function), composition, zero, successor, and primitive recursion
(i.e. nat.rec where the motive is C n := nat).

We can extend this definition to a large class of basic types by
using canonical encodings of types as natural numbers (Gödel numbering),
which we implement through the type class `encodable`. (More precisely,
we need that the composition of encode with decode yields a
primitive recursive function, so we have the `primcodable` type class
for this.)

## References

* [Mario Carneiro, *Formalizing computability theory via partial recursive functions*][carneiro2019]
-/

namespace nat

def elim {C : Sort u_1} : C → (ℕ → C → C) → ℕ → C :=
  Nat.rec

@[simp] theorem elim_zero {C : Sort u_1} (a : C) (f : ℕ → C → C) : elim a f 0 = a :=
  rfl

@[simp] theorem elim_succ {C : Sort u_1} (a : C) (f : ℕ → C → C) (n : ℕ) : elim a f (Nat.succ n) = f n (elim a f n) :=
  rfl

def cases {C : Sort u_1} (a : C) (f : ℕ → C) : ℕ → C :=
  elim a fun (n : ℕ) (_x : C) => f n

@[simp] theorem cases_zero {C : Sort u_1} (a : C) (f : ℕ → C) : cases a f 0 = a :=
  rfl

@[simp] theorem cases_succ {C : Sort u_1} (a : C) (f : ℕ → C) (n : ℕ) : cases a f (Nat.succ n) = f n :=
  rfl

@[simp] def unpaired {α : Sort u_1} (f : ℕ → ℕ → α) (n : ℕ) : α :=
  f (prod.fst (unpair n)) (prod.snd (unpair n))

/-- The primitive recursive functions `ℕ → ℕ`. -/
inductive primrec : (ℕ → ℕ) → Prop
where
| zero : primrec fun (n : ℕ) => 0
| succ : primrec Nat.succ
| left : primrec fun (n : ℕ) => prod.fst (unpair n)
| right : primrec fun (n : ℕ) => prod.snd (unpair n)
| pair : ∀ {f g : ℕ → ℕ}, primrec f → primrec g → primrec fun (n : ℕ) => mkpair (f n) (g n)
| comp : ∀ {f g : ℕ → ℕ}, primrec f → primrec g → primrec fun (n : ℕ) => f (g n)
| prec : ∀ {f g : ℕ → ℕ},
  primrec f →
    primrec g → primrec (unpaired fun (z n : ℕ) => elim (f z) (fun (y IH : ℕ) => g (mkpair z (mkpair y IH))) n)

namespace primrec

theorem of_eq {f : ℕ → ℕ} {g : ℕ → ℕ} (hf : primrec f) (H : ∀ (n : ℕ), f n = g n) : primrec g :=
  funext H ▸ hf

theorem const (n : ℕ) : primrec fun (_x : ℕ) => n := sorry

protected theorem id : primrec id := sorry

theorem prec1 {f : ℕ → ℕ} (m : ℕ) (hf : primrec f) : primrec fun (n : ℕ) => elim m (fun (y IH : ℕ) => f (mkpair y IH)) n := sorry

theorem cases1 {f : ℕ → ℕ} (m : ℕ) (hf : primrec f) : primrec (cases m f) := sorry

theorem cases {f : ℕ → ℕ} {g : ℕ → ℕ} (hf : primrec f) (hg : primrec g) : primrec (unpaired fun (z n : ℕ) => cases (f z) (fun (y : ℕ) => g (mkpair z y)) n) := sorry

protected theorem swap : primrec (unpaired (function.swap mkpair)) := sorry

theorem swap' {f : ℕ → ℕ → ℕ} (hf : primrec (unpaired f)) : primrec (unpaired (function.swap f)) := sorry

theorem pred : primrec Nat.pred := sorry

theorem add : primrec (unpaired Add.add) := sorry

theorem sub : primrec (unpaired Sub.sub) := sorry

theorem mul : primrec (unpaired Mul.mul) := sorry

theorem pow : primrec (unpaired pow) := sorry

end primrec

end nat

/-- A `primcodable` type is an `encodable` type for which
  the encode/decode functions are primitive recursive. -/
class primcodable (α : Type u_1)
extends encodable α
where
  prim : nat.primrec fun (n : ℕ) => encodable.encode (encodable.decode α n)

namespace primcodable

protected instance of_denumerable (α : Type u_1) [denumerable α] : primcodable α :=
  mk sorry

def of_equiv (α : Type u_1) {β : Type u_2} [primcodable α] (e : β ≃ α) : primcodable β :=
  mk sorry

protected instance empty : primcodable empty :=
  mk nat.primrec.zero

protected instance unit : primcodable PUnit :=
  mk sorry

protected instance option {α : Type u_1} [h : primcodable α] : primcodable (Option α) :=
  mk sorry

protected instance bool : primcodable Bool :=
  mk sorry

end primcodable

/-- `primrec f` means `f` is primitive recursive (after
  encoding its input and output as natural numbers). -/
def primrec {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] (f : α → β) :=
  nat.primrec fun (n : ℕ) => encodable.encode (option.map f (encodable.decode α n))

namespace primrec

protected theorem encode {α : Type u_1} [primcodable α] : primrec encodable.encode := sorry

protected theorem decode {α : Type u_1} [primcodable α] : primrec (encodable.decode α) :=
  nat.primrec.comp nat.primrec.succ (primcodable.prim α)

theorem dom_denumerable {α : Type u_1} {β : Type u_2} [denumerable α] [primcodable β] {f : α → β} : primrec f ↔ nat.primrec fun (n : ℕ) => encodable.encode (f (denumerable.of_nat α n)) := sorry

theorem nat_iff {f : ℕ → ℕ} : primrec f ↔ nat.primrec f :=
  dom_denumerable

theorem encdec {α : Type u_1} [primcodable α] : primrec fun (n : ℕ) => encodable.encode (encodable.decode α n) :=
  iff.mpr nat_iff (primcodable.prim α)

theorem option_some {α : Type u_1} [primcodable α] : primrec some := sorry

theorem of_eq {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] {f : α → σ} {g : α → σ} (hf : primrec f) (H : ∀ (n : α), f n = g n) : primrec g :=
  funext H ▸ hf

theorem const {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] (x : σ) : primrec fun (a : α) => x := sorry

protected theorem id {α : Type u_1} [primcodable α] : primrec id := sorry

theorem comp {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : β → σ} {g : α → β} (hf : primrec f) (hg : primrec g) : primrec fun (a : α) => f (g a) := sorry

theorem succ : primrec Nat.succ :=
  iff.mpr nat_iff nat.primrec.succ

theorem pred : primrec Nat.pred :=
  iff.mpr nat_iff nat.primrec.pred

theorem encode_iff {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] {f : α → σ} : (primrec fun (a : α) => encodable.encode (f a)) ↔ primrec f := sorry

theorem of_nat_iff {α : Type u_1} {β : Type u_2} [denumerable α] [primcodable β] {f : α → β} : primrec f ↔ primrec fun (n : ℕ) => f (denumerable.of_nat α n) :=
  iff.trans dom_denumerable (iff.trans (iff.symm nat_iff) encode_iff)

protected theorem of_nat (α : Type u_1) [denumerable α] : primrec (denumerable.of_nat α) :=
  iff.mp of_nat_iff primrec.id

theorem option_some_iff {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] {f : α → σ} : (primrec fun (a : α) => some (f a)) ↔ primrec f :=
  { mp := fun (h : primrec fun (a : α) => some (f a)) => iff.mp encode_iff (comp pred (iff.mpr encode_iff h)),
    mpr := comp option_some }

theorem of_equiv {α : Type u_1} [primcodable α] {β : Type u_2} {e : β ≃ α} : primrec ⇑e :=
  iff.mp encode_iff primrec.encode

theorem of_equiv_symm {α : Type u_1} [primcodable α] {β : Type u_2} {e : β ≃ α} : primrec ⇑(equiv.symm e) := sorry

theorem of_equiv_iff {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] {β : Type u_2} (e : β ≃ α) {f : σ → β} : (primrec fun (a : σ) => coe_fn e (f a)) ↔ primrec f := sorry

theorem of_equiv_symm_iff {α : Type u_1} {σ : Type u_3} [primcodable α] [primcodable σ] {β : Type u_2} (e : β ≃ α) {f : σ → α} : (primrec fun (a : σ) => coe_fn (equiv.symm e) (f a)) ↔ primrec f := sorry

end primrec

namespace primcodable

protected instance prod {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primcodable (α × β) :=
  mk sorry

end primcodable

namespace primrec

theorem fst {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec prod.fst := sorry

theorem snd {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec prod.snd := sorry

theorem pair {α : Type u_1} {β : Type u_2} {γ : Type u_3} [primcodable α] [primcodable β] [primcodable γ] {f : α → β} {g : α → γ} (hf : primrec f) (hg : primrec g) : primrec fun (a : α) => (f a, g a) := sorry

theorem unpair : primrec nat.unpair := sorry

theorem list_nth₁ {α : Type u_1} [primcodable α] (l : List α) : primrec (list.nth l) := sorry

end primrec

/-- `primrec₂ f` means `f` is a binary primitive recursive function.
  This is technically unnecessary since we can always curry all
  the arguments together, but there are enough natural two-arg
  functions that it is convenient to express this directly. -/
def primrec₂ {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] (f : α → β → σ) :=
  primrec fun (p : α × β) => f (prod.fst p) (prod.snd p)

/-- `primrec_pred p` means `p : α → Prop` is a (decidable)
  primitive recursive predicate, which is to say that
  `to_bool ∘ p : α → bool` is primitive recursive. -/
def primrec_pred {α : Type u_1} [primcodable α] (p : α → Prop) [decidable_pred p] :=
  primrec fun (a : α) => to_bool (p a)

/-- `primrec_rel p` means `p : α → β → Prop` is a (decidable)
  primitive recursive relation, which is to say that
  `to_bool ∘ p : α → β → bool` is primitive recursive. -/
def primrec_rel {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] (s : α → β → Prop) [(a : α) → (b : β) → Decidable (s a b)] :=
  primrec₂ fun (a : α) (b : β) => to_bool (s a b)

namespace primrec₂

theorem of_eq {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} {g : α → β → σ} (hg : primrec₂ f) (H : ∀ (a : α) (b : β), f a b = g a b) : primrec₂ g :=
  (funext fun (a : α) => funext fun (b : β) => H a b) ▸ hg

theorem const {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] (x : σ) : primrec₂ fun (a : α) (b : β) => x :=
  primrec.const x

protected theorem pair {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec₂ Prod.mk :=
  primrec.pair primrec.fst primrec.snd

theorem left {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec₂ fun (a : α) (b : β) => a :=
  primrec.fst

theorem right {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec₂ fun (a : α) (b : β) => b :=
  primrec.snd

theorem mkpair : primrec₂ nat.mkpair := sorry

theorem unpaired {α : Type u_1} [primcodable α] {f : ℕ → ℕ → α} : primrec (nat.unpaired f) ↔ primrec₂ f := sorry

theorem unpaired' {f : ℕ → ℕ → ℕ} : nat.primrec (nat.unpaired f) ↔ primrec₂ f :=
  iff.trans (iff.symm primrec.nat_iff) unpaired

theorem encode_iff {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : (primrec₂ fun (a : α) (b : β) => encodable.encode (f a b)) ↔ primrec₂ f :=
  primrec.encode_iff

theorem option_some_iff {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : (primrec₂ fun (a : α) (b : β) => some (f a b)) ↔ primrec₂ f :=
  primrec.option_some_iff

theorem of_nat_iff {α : Type u_1} {β : Type u_2} {σ : Type u_3} [denumerable α] [denumerable β] [primcodable σ] {f : α → β → σ} : primrec₂ f ↔ primrec₂ fun (m n : ℕ) => f (denumerable.of_nat α m) (denumerable.of_nat β n) := sorry

theorem uncurry {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : primrec (function.uncurry f) ↔ primrec₂ f := sorry

theorem curry {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α × β → σ} : primrec₂ (function.curry f) ↔ primrec f := sorry

end primrec₂

theorem primrec.comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : γ → σ} {g : α → β → γ} (hf : primrec f) (hg : primrec₂ g) : primrec₂ fun (a : α) (b : β) => f (g a b) :=
  primrec.comp hf hg

theorem primrec₂.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : β → γ → σ} {g : α → β} {h : α → γ} (hf : primrec₂ f) (hg : primrec g) (hh : primrec h) : primrec fun (a : α) => f (g a) (h a) :=
  primrec.comp hf (primrec.pair hg hh)

theorem primrec₂.comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ] {f : γ → δ → σ} {g : α → β → γ} {h : α → β → δ} (hf : primrec₂ f) (hg : primrec₂ g) (hh : primrec₂ h) : primrec₂ fun (a : α) (b : β) => f (g a b) (h a b) :=
  primrec₂.comp hf hg hh

theorem primrec_pred.comp {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {p : β → Prop} [decidable_pred p] {f : α → β} : primrec_pred p → primrec f → primrec_pred fun (a : α) => p (f a) :=
  primrec.comp

theorem primrec_rel.comp {α : Type u_1} {β : Type u_2} {γ : Type u_3} [primcodable α] [primcodable β] [primcodable γ] {R : β → γ → Prop} [(a : β) → (b : γ) → Decidable (R a b)] {f : α → β} {g : α → γ} : primrec_rel R → primrec f → primrec g → primrec_pred fun (a : α) => R (f a) (g a) :=
  primrec₂.comp

theorem primrec_rel.comp₂ {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] {R : γ → δ → Prop} [(a : γ) → (b : δ) → Decidable (R a b)] {f : α → β → γ} {g : α → β → δ} : primrec_rel R → primrec₂ f → primrec₂ g → primrec_rel fun (a : α) (b : β) => R (f a b) (g a b) :=
  primrec_rel.comp

theorem primrec_pred.of_eq {α : Type u_1} [primcodable α] {p : α → Prop} {q : α → Prop} [decidable_pred p] [decidable_pred q] (hp : primrec_pred p) (H : ∀ (a : α), p a ↔ q a) : primrec_pred q :=
  primrec.of_eq hp fun (a : α) => to_bool_congr (H a)

theorem primrec_rel.of_eq {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {r : α → β → Prop} {s : α → β → Prop} [(a : α) → (b : β) → Decidable (r a b)] [(a : α) → (b : β) → Decidable (s a b)] (hr : primrec_rel r) (H : ∀ (a : α) (b : β), r a b ↔ s a b) : primrec_rel s :=
  primrec₂.of_eq hr fun (a : α) (b : β) => to_bool_congr (H a b)

namespace primrec₂

theorem swap {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} (h : primrec₂ f) : primrec₂ (function.swap f) :=
  comp₂ h right left

theorem nat_iff {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : primrec₂ f ↔
  nat.primrec
    (nat.unpaired
      fun (m n : ℕ) =>
        encodable.encode (option.bind (encodable.decode α m) fun (a : α) => option.map (f a) (encodable.decode β n))) := sorry

theorem nat_iff' {α : Type u_1} {β : Type u_2} {σ : Type u_3} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : primrec₂ f ↔
  primrec₂ fun (m n : ℕ) => option.bind (encodable.decode α m) fun (a : α) => option.map (f a) (encodable.decode β n) :=
  iff.trans nat_iff (iff.trans unpaired' encode_iff)

end primrec₂

namespace primrec

theorem to₂ {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {f : α × β → σ} (hf : primrec f) : primrec₂ fun (a : α) (b : β) => f (a, b) :=
  of_eq hf
    fun (_x : α × β) =>
      (fun (_a : α × β) => prod.cases_on _a fun (fst : α) (snd : β) => idRhs (f (fst, snd) = f (fst, snd)) rfl) _x

theorem nat_elim {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → β} {g : α → ℕ × β → β} (hf : primrec f) (hg : primrec₂ g) : primrec₂ fun (a : α) (n : ℕ) => nat.elim (f a) (fun (n : ℕ) (IH : β) => g a (n, IH)) n := sorry

theorem nat_elim' {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → ℕ} {g : α → β} {h : α → ℕ × β → β} (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) : primrec fun (a : α) => nat.elim (g a) (fun (n : ℕ) (IH : β) => h a (n, IH)) (f a) :=
  primrec₂.comp (nat_elim hg hh) primrec.id hf

theorem nat_elim₁ {α : Type u_1} [primcodable α] {f : ℕ → α → α} (a : α) (hf : primrec₂ f) : primrec (nat.elim a f) :=
  nat_elim' primrec.id (const a) (comp₂ hf primrec₂.right)

theorem nat_cases' {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → β} {g : α → ℕ → β} (hf : primrec f) (hg : primrec₂ g) : primrec₂ fun (a : α) => nat.cases (f a) (g a) :=
  nat_elim hf (primrec₂.comp₂ hg primrec₂.left (comp₂ fst primrec₂.right))

theorem nat_cases {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → ℕ} {g : α → β} {h : α → ℕ → β} (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) : primrec fun (a : α) => nat.cases (g a) (h a) (f a) :=
  primrec₂.comp (nat_cases' hg hh) primrec.id hf

theorem nat_cases₁ {α : Type u_1} [primcodable α] {f : ℕ → α} (a : α) (hf : primrec f) : primrec (nat.cases a f) :=
  nat_cases primrec.id (const a) (comp₂ hf primrec₂.right)

theorem nat_iterate {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → ℕ} {g : α → β} {h : α → β → β} (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) : primrec fun (a : α) => nat.iterate (h a) (f a) (g a) := sorry

theorem option_cases {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {o : α → Option β} {f : α → σ} {g : α → β → σ} (ho : primrec o) (hf : primrec f) (hg : primrec₂ g) : primrec fun (a : α) => option.cases_on (o a) (f a) (g a) := sorry

theorem option_bind {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {f : α → Option β} {g : α → β → Option σ} (hf : primrec f) (hg : primrec₂ g) : primrec fun (a : α) => option.bind (f a) (g a) := sorry

theorem option_bind₁ {α : Type u_1} {σ : Type u_5} [primcodable α] [primcodable σ] {f : α → Option σ} (hf : primrec f) : primrec fun (o : Option α) => option.bind o f :=
  option_bind primrec.id (to₂ (comp hf snd))

theorem option_map {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {f : α → Option β} {g : α → β → σ} (hf : primrec f) (hg : primrec₂ g) : primrec fun (a : α) => option.map (g a) (f a) :=
  option_bind hf (comp₂ option_some hg)

theorem option_map₁ {α : Type u_1} {σ : Type u_5} [primcodable α] [primcodable σ] {f : α → σ} (hf : primrec f) : primrec (option.map f) :=
  option_map primrec.id (to₂ (comp hf snd))

theorem option_iget {α : Type u_1} [primcodable α] [Inhabited α] : primrec option.iget := sorry

theorem option_is_some {α : Type u_1} [primcodable α] : primrec option.is_some := sorry

theorem option_get_or_else {α : Type u_1} [primcodable α] : primrec₂ option.get_or_else := sorry

theorem bind_decode_iff {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → Option σ} : (primrec₂ fun (a : α) (n : ℕ) => option.bind (encodable.decode β n) (f a)) ↔ primrec₂ f := sorry

theorem map_decode_iff {α : Type u_1} {β : Type u_2} {σ : Type u_5} [primcodable α] [primcodable β] [primcodable σ] {f : α → β → σ} : (primrec₂ fun (a : α) (n : ℕ) => option.map (f a) (encodable.decode β n)) ↔ primrec₂ f :=
  iff.trans bind_decode_iff primrec₂.option_some_iff

theorem nat_add : primrec₂ Add.add :=
  iff.mp primrec₂.unpaired' nat.primrec.add

theorem nat_sub : primrec₂ Sub.sub :=
  iff.mp primrec₂.unpaired' nat.primrec.sub

theorem nat_mul : primrec₂ Mul.mul :=
  iff.mp primrec₂.unpaired' nat.primrec.mul

theorem cond {α : Type u_1} {σ : Type u_5} [primcodable α] [primcodable σ] {c : α → Bool} {f : α → σ} {g : α → σ} (hc : primrec c) (hf : primrec f) (hg : primrec g) : primrec fun (a : α) => cond (c a) (f a) (g a) := sorry

theorem ite {α : Type u_1} {σ : Type u_5} [primcodable α] [primcodable σ] {c : α → Prop} [decidable_pred c] {f : α → σ} {g : α → σ} (hc : primrec_pred c) (hf : primrec f) (hg : primrec g) : primrec fun (a : α) => ite (c a) (f a) (g a) := sorry

theorem nat_le : primrec_rel LessEq := sorry

theorem nat_min : primrec₂ min :=
  ite nat_le fst snd

theorem nat_max : primrec₂ max :=
  ite (primrec_rel.comp nat_le snd fst) fst snd

theorem dom_bool {α : Type u_1} [primcodable α] (f : Bool → α) : primrec f :=
  of_eq (cond primrec.id (const (f tt)) (const (f false)))
    fun (b : Bool) =>
      bool.cases_on b (Eq.refl (cond (id false) (f tt) (f false))) (Eq.refl (cond (id tt) (f tt) (f false)))

theorem dom_bool₂ {α : Type u_1} [primcodable α] (f : Bool → Bool → α) : primrec₂ f := sorry

protected theorem bnot : primrec bnot :=
  dom_bool bnot

protected theorem band : primrec₂ band :=
  dom_bool₂ band

protected theorem bor : primrec₂ bor :=
  dom_bool₂ bor

protected theorem not {α : Type u_1} [primcodable α] {p : α → Prop} [decidable_pred p] (hp : primrec_pred p) : primrec_pred fun (a : α) => ¬p a := sorry

protected theorem and {α : Type u_1} [primcodable α] {p : α → Prop} {q : α → Prop} [decidable_pred p] [decidable_pred q] (hp : primrec_pred p) (hq : primrec_pred q) : primrec_pred fun (a : α) => p a ∧ q a := sorry

protected theorem or {α : Type u_1} [primcodable α] {p : α → Prop} {q : α → Prop} [decidable_pred p] [decidable_pred q] (hp : primrec_pred p) (hq : primrec_pred q) : primrec_pred fun (a : α) => p a ∨ q a := sorry

protected theorem eq {α : Type u_1} [primcodable α] [DecidableEq α] : primrec_rel Eq := sorry

theorem nat_lt : primrec_rel Less := sorry

theorem option_guard {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {p : α → β → Prop} [(a : α) → (b : β) → Decidable (p a b)] (hp : primrec_rel p) {f : α → β} (hf : primrec f) : primrec fun (a : α) => option.guard (p a) (f a) :=
  ite (primrec_rel.comp hp primrec.id hf) (iff.mpr option_some_iff hf) (const none)

theorem option_orelse {α : Type u_1} [primcodable α] : primrec₂ has_orelse.orelse := sorry

protected theorem decode2 {α : Type u_1} [primcodable α] : primrec (encodable.decode2 α) :=
  option_bind primrec.decode (option_guard (primrec_rel.comp primrec.eq (iff.mpr encode_iff snd) (comp fst fst)) snd)

theorem list_find_index₁ {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {p : α → β → Prop} [(a : α) → (b : β) → Decidable (p a b)] (hp : primrec_rel p) (l : List β) : primrec fun (a : α) => list.find_index (p a) l := sorry

theorem list_index_of₁ {α : Type u_1} [primcodable α] [DecidableEq α] (l : List α) : primrec fun (a : α) => list.index_of a l :=
  list_find_index₁ primrec.eq l

theorem dom_fintype {α : Type u_1} {σ : Type u_5} [primcodable α] [primcodable σ] [fintype α] (f : α → σ) : primrec f := sorry

theorem nat_bodd_div2 : primrec nat.bodd_div2 := sorry

theorem nat_bodd : primrec nat.bodd :=
  comp fst nat_bodd_div2

theorem nat_div2 : primrec nat.div2 :=
  comp snd nat_bodd_div2

theorem nat_bit0 : primrec bit0 :=
  primrec₂.comp nat_add primrec.id primrec.id

theorem nat_bit1 : primrec bit1 :=
  primrec₂.comp nat_add nat_bit0 (const 1)

theorem nat_bit : primrec₂ nat.bit := sorry

theorem nat_div_mod : primrec₂ fun (n k : ℕ) => (n / k, n % k) := sorry

theorem nat_div : primrec₂ Div.div :=
  comp₂ fst nat_div_mod

theorem nat_mod : primrec₂ Mod.mod :=
  comp₂ snd nat_div_mod

end primrec

namespace primcodable

protected instance sum {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primcodable (α ⊕ β) :=
  mk sorry

protected instance list {α : Type u_1} [primcodable α] : primcodable (List α) :=
  mk sorry

end primcodable

namespace primrec

theorem sum_inl {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec sum.inl :=
  iff.mp encode_iff (comp nat_bit0 primrec.encode)

theorem sum_inr {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] : primrec sum.inr :=
  iff.mp encode_iff (comp nat_bit1 primrec.encode)

theorem sum_cases {α : Type u_1} {β : Type u_2} {γ : Type u_3} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] {f : α → β ⊕ γ} {g : α → β → σ} {h : α → γ → σ} (hf : primrec f) (hg : primrec₂ g) (hh : primrec₂ h) : primrec fun (a : α) => sum.cases_on (f a) (g a) (h a) := sorry

theorem list_cons {α : Type u_1} [primcodable α] : primrec₂ List.cons :=
  list_cons' (primcodable.prim (List α))

theorem list_cases {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → List β} {g : α → σ} {h : α → β × List β → σ} : primrec f →
  primrec g → primrec₂ h → primrec fun (a : α) => list.cases_on (f a) (g a) fun (b : β) (l : List β) => h a (b, l) :=
  list_cases' (primcodable.prim (List β))

theorem list_foldl {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → List β} {g : α → σ} {h : α → σ × β → σ} : primrec f → primrec g → primrec₂ h → primrec fun (a : α) => list.foldl (fun (s : σ) (b : β) => h a (s, b)) (g a) (f a) :=
  list_foldl' (primcodable.prim (List β))

theorem list_reverse {α : Type u_1} [primcodable α] : primrec list.reverse :=
  list_reverse' (primcodable.prim (List α))

theorem list_foldr {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → List β} {g : α → σ} {h : α → β × σ → σ} (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) : primrec fun (a : α) => list.foldr (fun (b : β) (s : σ) => h a (b, s)) (g a) (f a) := sorry

theorem list_head' {α : Type u_1} [primcodable α] : primrec list.head' := sorry

theorem list_head {α : Type u_1} [primcodable α] [Inhabited α] : primrec list.head :=
  of_eq (comp option_iget list_head') fun (l : List α) => Eq.symm (list.head_eq_head' l)

theorem list_tail {α : Type u_1} [primcodable α] : primrec list.tail := sorry

theorem list_rec {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → List β} {g : α → σ} {h : α → β × List β × σ → σ} (hf : primrec f) (hg : primrec g) (hh : primrec₂ h) : primrec fun (a : α) => list.rec_on (f a) (g a) fun (b : β) (l : List β) (IH : σ) => h a (b, l, IH) := sorry

theorem list_nth {α : Type u_1} [primcodable α] : primrec₂ list.nth := sorry

theorem list_inth {α : Type u_1} [primcodable α] [Inhabited α] : primrec₂ list.inth :=
  comp₂ option_iget list_nth

theorem list_append {α : Type u_1} [primcodable α] : primrec₂ append := sorry

theorem list_concat {α : Type u_1} [primcodable α] : primrec₂ fun (l : List α) (a : α) => l ++ [a] :=
  primrec₂.comp list_append fst (primrec₂.comp list_cons snd (const []))

theorem list_map {α : Type u_1} {β : Type u_2} {σ : Type u_4} [primcodable α] [primcodable β] [primcodable σ] {f : α → List β} {g : α → β → σ} (hf : primrec f) (hg : primrec₂ g) : primrec fun (a : α) => list.map (g a) (f a) := sorry

theorem list_range : primrec list.range := sorry

theorem list_join {α : Type u_1} [primcodable α] : primrec list.join := sorry

theorem list_length {α : Type u_1} [primcodable α] : primrec list.length := sorry

theorem list_find_index {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → List β} {p : α → β → Prop} [(a : α) → (b : β) → Decidable (p a b)] (hf : primrec f) (hp : primrec_rel p) : primrec fun (a : α) => list.find_index (p a) (f a) := sorry

theorem list_index_of {α : Type u_1} [primcodable α] [DecidableEq α] : primrec₂ list.index_of :=
  to₂ (list_find_index snd (primrec_rel.comp₂ primrec.eq (to₂ (comp fst fst)) (to₂ snd)))

theorem nat_strong_rec {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] (f : α → ℕ → σ) {g : α → List σ → Option σ} (hg : primrec₂ g) (H : ∀ (a : α) (n : ℕ), g a (list.map (f a) (list.range n)) = some (f a n)) : primrec₂ f := sorry

end primrec

namespace primcodable

def subtype {α : Type u_1} [primcodable α] {p : α → Prop} [decidable_pred p] (hp : primrec_pred p) : primcodable (Subtype p) :=
  mk sorry

protected instance fin {n : ℕ} : primcodable (fin n) :=
  of_equiv (Subtype fun (a : ℕ) => id a < n) (equiv.fin_equiv_subtype n)

protected instance vector {α : Type u_1} [primcodable α] {n : ℕ} : primcodable (vector α n) :=
  subtype sorry

protected instance fin_arrow {α : Type u_1} [primcodable α] {n : ℕ} : primcodable (fin n → α) :=
  of_equiv (vector α n) (equiv.symm (equiv.vector_equiv_fin α n))

protected instance array {α : Type u_1} [primcodable α] {n : ℕ} : primcodable (array n α) :=
  of_equiv (fin n → α) (equiv.array_equiv_fin n α)

protected instance ulower {α : Type u_1} [primcodable α] : primcodable (ulower α) :=
  (fun (this : primrec_pred fun (n : ℕ) => encodable.decode2 α n ≠ none) => subtype sorry) sorry

end primcodable

namespace primrec

theorem subtype_val {α : Type u_1} [primcodable α] {p : α → Prop} [decidable_pred p] {hp : primrec_pred p} : primrec subtype.val := sorry

theorem subtype_val_iff {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {p : β → Prop} [decidable_pred p] {hp : primrec_pred p} {f : α → Subtype p} : (primrec fun (a : α) => subtype.val (f a)) ↔ primrec f := sorry

theorem subtype_mk {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {p : β → Prop} [decidable_pred p] {hp : primrec_pred p} {f : α → β} {h : ∀ (a : α), p (f a)} (hf : primrec f) : primrec fun (a : α) => { val := f a, property := h a } :=
  iff.mp subtype_val_iff hf

theorem option_get {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {f : α → Option β} {h : ∀ (a : α), ↥(option.is_some (f a))} : primrec f → primrec fun (a : α) => option.get (h a) := sorry

theorem ulower_down {α : Type u_1} [primcodable α] : primrec ulower.down :=
  subtype_mk primrec.encode

theorem ulower_up {α : Type u_1} [primcodable α] : primrec ulower.up :=
  option_get (comp primrec.decode2 subtype_val)

theorem fin_val_iff {α : Type u_1} [primcodable α] {n : ℕ} {f : α → fin n} : (primrec fun (a : α) => subtype.val (f a)) ↔ primrec f :=
  iff.trans (iff.trans (iff.refl (primrec fun (a : α) => subtype.val (f a))) subtype_val_iff)
    (of_equiv_iff (equiv.fin_equiv_subtype n))

theorem fin_val {n : ℕ} : primrec coe :=
  iff.mpr fin_val_iff primrec.id

theorem fin_succ {n : ℕ} : primrec fin.succ := sorry

theorem vector_to_list {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.to_list :=
  subtype_val

theorem vector_to_list_iff {α : Type u_1} {β : Type u_2} [primcodable α] [primcodable β] {n : ℕ} {f : α → vector β n} : (primrec fun (a : α) => vector.to_list (f a)) ↔ primrec f :=
  subtype_val_iff

theorem vector_cons {α : Type u_1} [primcodable α] {n : ℕ} : primrec₂ vector.cons := sorry

theorem vector_length {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.length :=
  const n

theorem vector_head {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.head := sorry

theorem vector_tail {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.tail := sorry

theorem vector_nth {α : Type u_1} [primcodable α] {n : ℕ} : primrec₂ vector.nth := sorry

theorem list_of_fn {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α → σ} : (∀ (i : fin n), primrec (f i)) → primrec fun (a : α) => list.of_fn fun (i : fin n) => f i a := sorry

theorem vector_of_fn {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α → σ} (hf : ∀ (i : fin n), primrec (f i)) : primrec fun (a : α) => vector.of_fn fun (i : fin n) => f i a := sorry

theorem vector_nth' {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.nth :=
  of_equiv_symm

theorem vector_of_fn' {α : Type u_1} [primcodable α] {n : ℕ} : primrec vector.of_fn :=
  of_equiv

theorem fin_app {σ : Type u_4} [primcodable σ] {n : ℕ} : primrec₂ id := sorry

theorem fin_curry₁ {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : fin n → α → σ} : primrec₂ f ↔ ∀ (i : fin n), primrec (f i) := sorry

theorem fin_curry {α : Type u_1} {σ : Type u_4} [primcodable α] [primcodable σ] {n : ℕ} {f : α → fin n → σ} : primrec f ↔ primrec₂ f := sorry

end primrec

namespace nat

/-- An alternative inductive definition of `primrec` which
  does not use the pairing function on ℕ, and so has to
  work with n-ary functions on ℕ instead of unary functions.
  We prove that this is equivalent to the regular notion
  in `to_prim` and `of_prim`. -/
inductive primrec' : {n : ℕ} → (vector ℕ n → ℕ) → Prop
where
| zero : primrec' fun (_x : vector ℕ 0) => 0
| succ : primrec' fun (v : vector ℕ 1) => Nat.succ (vector.head v)
| nth : ∀ {n : ℕ} (i : fin n), primrec' fun (v : vector ℕ n) => vector.nth v i
| comp : ∀ {m n : ℕ} {f : vector ℕ n → ℕ} (g : fin n → vector ℕ m → ℕ),
  primrec' f →
    (∀ (i : fin n), primrec' (g i)) → primrec' fun (a : vector ℕ m) => f (vector.of_fn fun (i : fin n) => g i a)
| prec : ∀ {n : ℕ} {f : vector ℕ n → ℕ} {g : vector ℕ (n + bit0 1) → ℕ},
  primrec' f →
    primrec' g →
      primrec'
        fun (v : vector ℕ (n + 1)) =>
          elim (f (vector.tail v)) (fun (y IH : ℕ) => g (y::ᵥIH::ᵥvector.tail v)) (vector.head v)

end nat

namespace nat.primrec'

theorem to_prim {n : ℕ} {f : vector ℕ n → ℕ} (pf : primrec' f) : primrec f := sorry

theorem of_eq {n : ℕ} {f : vector ℕ n → ℕ} {g : vector ℕ n → ℕ} (hf : primrec' f) (H : ∀ (i : vector ℕ n), f i = g i) : primrec' g :=
  funext H ▸ hf

theorem const {n : ℕ} (m : ℕ) : primrec' fun (v : vector ℕ n) => m := sorry

theorem head {n : ℕ} : primrec' vector.head := sorry

theorem tail {n : ℕ} {f : vector ℕ n → ℕ} (hf : primrec' f) : primrec' fun (v : vector ℕ (Nat.succ n)) => f (vector.tail v) := sorry

def vec {n : ℕ} {m : ℕ} (f : vector ℕ n → vector ℕ m) :=
  ∀ (i : fin m), primrec' fun (v : vector ℕ n) => vector.nth (f v) i

protected theorem nil {n : ℕ} : vec fun (_x : vector ℕ n) => vector.nil :=
  fun (i : fin 0) => fin.elim0 i

protected theorem cons {n : ℕ} {m : ℕ} {f : vector ℕ n → ℕ} {g : vector ℕ n → vector ℕ m} (hf : primrec' f) (hg : vec g) : vec fun (v : vector ℕ n) => f v::ᵥg v := sorry

theorem idv {n : ℕ} : vec id :=
  nth

theorem comp' {n : ℕ} {m : ℕ} {f : vector ℕ m → ℕ} {g : vector ℕ n → vector ℕ m} (hf : primrec' f) (hg : vec g) : primrec' fun (v : vector ℕ n) => f (g v) := sorry

theorem comp₁ (f : ℕ → ℕ) (hf : primrec' fun (v : vector ℕ 1) => f (vector.head v)) {n : ℕ} {g : vector ℕ n → ℕ} (hg : primrec' g) : primrec' fun (v : vector ℕ n) => f (g v) :=
  comp (fun (i : fin 1) => g) hf fun (i : fin 1) => hg

theorem comp₂ (f : ℕ → ℕ → ℕ) (hf : primrec' fun (v : vector ℕ (bit0 1)) => f (vector.head v) (vector.head (vector.tail v))) {n : ℕ} {g : vector ℕ n → ℕ} {h : vector ℕ n → ℕ} (hg : primrec' g) (hh : primrec' h) : primrec' fun (v : vector ℕ n) => f (g v) (h v) := sorry

theorem prec' {n : ℕ} {f : vector ℕ n → ℕ} {g : vector ℕ n → ℕ} {h : vector ℕ (n + bit0 1) → ℕ} (hf : primrec' f) (hg : primrec' g) (hh : primrec' h) : primrec' fun (v : vector ℕ n) => elim (g v) (fun (y IH : ℕ) => h (y::ᵥIH::ᵥv)) (f v) := sorry

theorem pred : primrec' fun (v : vector ℕ 1) => Nat.pred (vector.head v) := sorry

theorem add : primrec' fun (v : vector ℕ (bit0 1)) => vector.head v + vector.head (vector.tail v) := sorry

theorem sub : primrec' fun (v : vector ℕ (bit0 1)) => vector.head v - vector.head (vector.tail v) := sorry

theorem mul : primrec' fun (v : vector ℕ (bit0 1)) => vector.head v * vector.head (vector.tail v) := sorry

theorem if_lt {n : ℕ} {a : vector ℕ n → ℕ} {b : vector ℕ n → ℕ} {f : vector ℕ n → ℕ} {g : vector ℕ n → ℕ} (ha : primrec' a) (hb : primrec' b) (hf : primrec' f) (hg : primrec' g) : primrec' fun (v : vector ℕ n) => ite (a v < b v) (f v) (g v) := sorry

theorem mkpair : primrec' fun (v : vector ℕ (bit0 1)) => mkpair (vector.head v) (vector.head (vector.tail v)) :=
  if_lt head (tail head) (comp₂ Add.add add (tail (comp₂ Mul.mul mul head head)) head)
    (comp₂ Add.add add (comp₂ Add.add add (comp₂ Mul.mul mul head head) head) (tail head))

protected theorem encode {n : ℕ} : primrec' encodable.encode := sorry

theorem sqrt : primrec' fun (v : vector ℕ 1) => sqrt (vector.head v) := sorry

theorem unpair₁ {n : ℕ} {f : vector ℕ n → ℕ} (hf : primrec' f) : primrec' fun (v : vector ℕ n) => prod.fst (unpair (f v)) := sorry

theorem unpair₂ {n : ℕ} {f : vector ℕ n → ℕ} (hf : primrec' f) : primrec' fun (v : vector ℕ n) => prod.snd (unpair (f v)) := sorry

theorem of_prim {n : ℕ} {f : vector ℕ n → ℕ} : primrec f → primrec' f := sorry

theorem prim_iff {n : ℕ} {f : vector ℕ n → ℕ} : primrec' f ↔ primrec f :=
  { mp := to_prim, mpr := of_prim }

theorem prim_iff₁ {f : ℕ → ℕ} : (primrec' fun (v : vector ℕ 1) => f (vector.head v)) ↔ primrec f := sorry

theorem prim_iff₂ {f : ℕ → ℕ → ℕ} : (primrec' fun (v : vector ℕ (bit0 1)) => f (vector.head v) (vector.head (vector.tail v))) ↔ primrec₂ f := sorry

theorem vec_iff {m : ℕ} {n : ℕ} {f : vector ℕ m → vector ℕ n} : vec f ↔ primrec f := sorry

end nat.primrec'

theorem primrec.nat_sqrt : primrec nat.sqrt :=
  iff.mp nat.primrec'.prim_iff₁ nat.primrec'.sqrt


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

! This file was ported from Lean 3 source module order.zorn
! leanprover-community/mathlib commit 46a64b5b4268c594af770c44d9e502afc6a515cb
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.Chain

/-!
# Zorn's lemmas

This file proves several formulations of Zorn's Lemma.

## Variants

The primary statement of Zorn's lemma is `exists_maximal_of_chains_bounded`. Then it is specialized
to particular relations:
* `(≤)` with `zorn_partialOrder`
* `(⊆)` with `zorn_subset`
* `(⊇)` with `zorn_superset`

Lemma names carry modifiers:
* `₀`: Quantifies over a set, as opposed to over a type.
* `_nonempty`: Doesn't ask to prove that the empty chain is bounded and lets you give an element
  that will be smaller than the maximal element found (the maximal element is no smaller than any
  other element, but it can also be incomparable to some).

## How-to

This file comes across as confusing to those who haven't yet used it, so here is a detailed
walkthrough:
1. Know what relation on which type/set you're looking for. See Variants above. You can discharge
  some conditions to Zorn's lemma directly using a `_nonempty` variant.
2. Write down the definition of your type/set, put a `suffices : ∃ m, ∀ a, m ≺ a → a ≺ m, { ... },`
  (or whatever you actually need) followed by a `apply some_version_of_zorn`.
3. Fill in the details. This is where you start talking about chains.

A typical proof using Zorn could look like this (TODO: update to mathlib4)
```lean
lemma zorny_lemma : zorny_statement :=
begin
  let s : set α := {x | whatever x},
  suffices : ∃ x ∈ s, ∀ y ∈ s, y ⊆ x → y = x, -- or with another operator
  { exact proof_post_zorn },
  apply zorn_subset, -- or another variant
  rintro c hcs hc,
  obtain rfl | hcnemp := c.eq_empty_or_nonempty, -- you might need to disjunct on c empty or not
  { exact ⟨edge_case_construction,
      proof_that_edge_case_construction_respects_whatever,
      proof_that_edge_case_construction_contains_all_stuff_in_c⟩ },
  exact ⟨construction,
    proof_that_construction_respects_whatever,
    proof_that_construction_contains_all_stuff_in_c⟩,
end
```

## Notes

Originally ported from Isabelle/HOL. The
[original file](https://isabelle.in.tum.de/dist/library/HOL/HOL/Zorn.html) was written by Jacques D.
Fleuriot, Tobias Nipkow, Christian Sternagel.
-/

open Classical Set

variable {α β : Type _} {r : α → α → Prop} {c : Set α}

/-- Local notation for the relation being considered. -/
local infixl:50 " ≺ " => r

/-- **Zorn's lemma**

If every chain has an upper bound, then there exists a maximal element. -/
theorem exists_maximal_of_chains_bounded (h : ∀ c, IsChain r c → ∃ ub, ∀ a ∈ c, a ≺ ub)
    (trans : ∀ {a b c}, a ≺ b → b ≺ c → a ≺ c) : ∃ m, ∀ a, m ≺ a → a ≺ m :=
  have : ∃ ub, ∀ a ∈ maxChain r, a ≺ ub := h _ <| maxChain_spec.left
  let ⟨ub, (hub : ∀ a ∈ maxChain r, a ≺ ub)⟩ := this
  ⟨ub, fun a ha =>
    have : IsChain r (insert a <| maxChain r) :=
      maxChain_spec.1.insert fun b hb _ => Or.inr <| trans (hub b hb) ha
    hub a <| by
      rw [maxChain_spec.right this (subset_insert _ _)]
      exact mem_insert _ _⟩
#align exists_maximal_of_chains_bounded exists_maximal_of_chains_bounded

/-- A variant of Zorn's lemma. If every nonempty chain of a nonempty type has an upper bound, then
there is a maximal element.
-/
theorem exists_maximal_of_nonempty_chains_bounded [Nonempty α]
    (h : ∀ c, IsChain r c → c.Nonempty → ∃ ub, ∀ a ∈ c, a ≺ ub)
    (trans : ∀ {a b c}, a ≺ b → b ≺ c → a ≺ c) : ∃ m, ∀ a, m ≺ a → a ≺ m :=
  exists_maximal_of_chains_bounded
    (fun c hc =>
      (eq_empty_or_nonempty c).elim
        (fun h => ⟨Classical.arbitrary α, fun x hx => (h ▸ hx : x ∈ (∅ : Set α)).elim⟩) (h c hc))
    trans
#align exists_maximal_of_nonempty_chains_bounded exists_maximal_of_nonempty_chains_bounded

section Preorder

variable [Preorder α]

theorem zorn_preorder (h : ∀ c : Set α, IsChain (· ≤ ·) c → BddAbove c) :
    ∃ m : α, ∀ a, m ≤ a → a ≤ m :=
  exists_maximal_of_chains_bounded h le_trans
#align zorn_preorder zorn_preorder

theorem zorn_nonempty_preorder [Nonempty α]
    (h : ∀ c : Set α, IsChain (· ≤ ·) c → c.Nonempty → BddAbove c) : ∃ m : α, ∀ a, m ≤ a → a ≤ m :=
  exists_maximal_of_nonempty_chains_bounded h le_trans
#align zorn_nonempty_preorder zorn_nonempty_preorder

theorem zorn_preorder₀ (s : Set α)
    (ih : ∀ (c) (_ : c ⊆ s), IsChain (· ≤ ·) c → ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) :
    ∃ m ∈ s, ∀ z ∈ s, m ≤ z → z ≤ m :=
  let ⟨⟨m, hms⟩, h⟩ :=
    @zorn_preorder s _ fun c hc =>
      let ⟨ub, hubs, hub⟩ :=
        ih (Subtype.val '' c) (fun _ ⟨⟨_, hx⟩, _, h⟩ => h ▸ hx)
          (by
            rintro _ ⟨p, hpc, rfl⟩ _ ⟨q, hqc, rfl⟩ hpq
            refine' hc hpc hqc fun t => hpq (Subtype.ext_iff.1 t))
      ⟨⟨ub, hubs⟩, fun ⟨y, hy⟩ hc => hub _ ⟨_, hc, rfl⟩⟩
  ⟨m, hms, fun z hzs hmz => h ⟨z, hzs⟩ hmz⟩
#align zorn_preorder₀ zorn_preorder₀

theorem zorn_nonempty_preorder₀ (s : Set α)
    (ih : ∀ (c) (_ : c ⊆ s), IsChain (· ≤ ·) c → ∀ y ∈ c, ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) (x : α)
    (hxs : x ∈ s) : ∃ m ∈ s, x ≤ m ∧ ∀ z ∈ s, m ≤ z → z ≤ m := by
  -- Porting note: the first three lines replace the following two lines in mathlib3.
  -- The mathlib3 `rcases` supports holes for proof obligations, this is not yet implemented in 4.
  -- rcases zorn_preorder₀ ({ y ∈ s | x ≤ y }) fun c hcs hc => ?_ with ⟨m, ⟨hms, hxm⟩, hm⟩
  -- · exact ⟨m, hms, hxm, fun z hzs hmz => hm _ ⟨hzs, hxm.trans hmz⟩ hmz⟩
  have H := zorn_preorder₀ ({ y ∈ s | x ≤ y }) fun c hcs hc => ?_
  . rcases H with ⟨m, ⟨hms, hxm⟩, hm⟩
    exact ⟨m, hms, hxm, fun z hzs hmz => hm _ ⟨hzs, hxm.trans hmz⟩ hmz⟩
  · rcases c.eq_empty_or_nonempty with (rfl | ⟨y, hy⟩)
    · exact ⟨x, ⟨hxs, le_rfl⟩, fun z => False.elim⟩
    · rcases ih c (fun z hz => (hcs hz).1) hc y hy with ⟨z, hzs, hz⟩
      exact ⟨z, ⟨hzs, (hcs hy).2.trans <| hz _ hy⟩, hz⟩
#align zorn_nonempty_preorder₀ zorn_nonempty_preorder₀

theorem zorn_nonempty_Ici₀ (a : α)
    (ih : ∀ (c) (_ : c ⊆ Ici a), IsChain (· ≤ ·) c → ∀ y ∈ c, ∃ ub, a ≤ ub ∧ ∀ z ∈ c, z ≤ ub)
    (x : α) (hax : a ≤ x) : ∃ m, x ≤ m ∧ ∀ z, m ≤ z → z ≤ m :=
  let ⟨m, _, hxm, hm⟩ := zorn_nonempty_preorder₀ (Ici a) (by simpa using ih) x hax
  ⟨m, hxm, fun z hmz => hm _ (hax.trans <| hxm.trans hmz) hmz⟩
#align zorn_nonempty_Ici₀ zorn_nonempty_Ici₀

end Preorder

section PartialOrder

variable [PartialOrder α]

theorem zorn_partialOrder (h : ∀ c : Set α, IsChain (· ≤ ·) c → BddAbove c) :
    ∃ m : α, ∀ a, m ≤ a → a = m :=
  let ⟨m, hm⟩ := zorn_preorder h
  ⟨m, fun a ha => le_antisymm (hm a ha) ha⟩
#align zorn_partial_order zorn_partialOrder

theorem zorn_nonempty_partialOrder [Nonempty α]
    (h : ∀ c : Set α, IsChain (· ≤ ·) c → c.Nonempty → BddAbove c) : ∃ m : α, ∀ a, m ≤ a → a = m :=
  let ⟨m, hm⟩ := zorn_nonempty_preorder h
  ⟨m, fun a ha => le_antisymm (hm a ha) ha⟩
#align zorn_nonempty_partial_order zorn_nonempty_partialOrder

theorem zorn_partialOrder₀ (s : Set α)
    (ih : ∀ (c) (_ : c ⊆ s), IsChain (· ≤ ·) c → ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) :
    ∃ m ∈ s, ∀ z ∈ s, m ≤ z → z = m :=
  let ⟨m, hms, hm⟩ := zorn_preorder₀ s ih
  ⟨m, hms, fun z hzs hmz => (hm z hzs hmz).antisymm hmz⟩
#align zorn_partial_order₀ zorn_partialOrder₀

theorem zorn_nonempty_partialOrder₀ (s : Set α)
    (ih : ∀ (c) (_ : c ⊆ s), IsChain (· ≤ ·) c → ∀ y ∈ c, ∃ ub ∈ s, ∀ z ∈ c, z ≤ ub) (x : α)
    (hxs : x ∈ s) : ∃ m ∈ s, x ≤ m ∧ ∀ z ∈ s, m ≤ z → z = m :=
  let ⟨m, hms, hxm, hm⟩ := zorn_nonempty_preorder₀ s ih x hxs
  ⟨m, hms, hxm, fun z hzs hmz => (hm z hzs hmz).antisymm hmz⟩
#align zorn_nonempty_partial_order₀ zorn_nonempty_partialOrder₀

end PartialOrder

theorem zorn_subset (S : Set (Set α))
    (h : ∀ (c) (_ : c ⊆ S), IsChain (· ⊆ ·) c → ∃ ub ∈ S, ∀ s ∈ c, s ⊆ ub) :
    ∃ m ∈ S, ∀ a ∈ S, m ⊆ a → a = m :=
  zorn_partialOrder₀ S h
#align zorn_subset zorn_subset

theorem zorn_subset_nonempty (S : Set (Set α))
    (H : ∀ (c) (_ : c ⊆ S), IsChain (· ⊆ ·) c → c.Nonempty → ∃ ub ∈ S, ∀ s ∈ c, s ⊆ ub) (x)
    (hx : x ∈ S) : ∃ m ∈ S, x ⊆ m ∧ ∀ a ∈ S, m ⊆ a → a = m :=
  zorn_nonempty_partialOrder₀ _ (fun _ cS hc y yc => H _ cS hc ⟨y, yc⟩) _ hx
#align zorn_subset_nonempty zorn_subset_nonempty

theorem zorn_superset (S : Set (Set α))
    (h : ∀ (c) (_ : c ⊆ S), IsChain (· ⊆ ·) c → ∃ lb ∈ S, ∀ s ∈ c, lb ⊆ s) :
    ∃ m ∈ S, ∀ a ∈ S, a ⊆ m → a = m :=
  (@zorn_partialOrder₀ (Set α)ᵒᵈ _ S) fun c cS hc => h c cS hc.symm
#align zorn_superset zorn_superset

theorem zorn_superset_nonempty (S : Set (Set α))
    (H : ∀ (c) (_ : c ⊆ S), IsChain (· ⊆ ·) c → c.Nonempty → ∃ lb ∈ S, ∀ s ∈ c, lb ⊆ s) (x)
    (hx : x ∈ S) : ∃ m ∈ S, m ⊆ x ∧ ∀ a ∈ S, a ⊆ m → a = m :=
  @zorn_nonempty_partialOrder₀ (Set α)ᵒᵈ _ S (fun _ cS hc y yc => H _ cS hc.symm ⟨y, yc⟩) _ hx
#align zorn_superset_nonempty zorn_superset_nonempty

/-- Every chain is contained in a maximal chain. This generalizes Hausdorff's maximality principle.
-/
theorem IsChain.exists_maxChain (hc : IsChain r c) : ∃ M, @IsMaxChain _ r M ∧ c ⊆ M := by
  -- Porting note: the first three lines replace the following two lines in mathlib3.
  -- The mathlib3 `obtain` supports holes for proof obligations, this is not yet implemented in 4.
  -- obtain ⟨M, ⟨_, hM₀⟩, hM₁, hM₂⟩ :=
  --   zorn_subset_nonempty { s | c ⊆ s ∧ IsChain r s } _ c ⟨Subset.rfl, hc⟩
  have H := zorn_subset_nonempty { s | c ⊆ s ∧ IsChain r s } ?_ c ⟨Subset.rfl, hc⟩
  · obtain ⟨M, ⟨_, hM₀⟩, hM₁, hM₂⟩ := H
    exact ⟨M, ⟨hM₀, fun d hd hMd => (hM₂ _ ⟨hM₁.trans hMd, hd⟩ hMd).symm⟩, hM₁⟩
  rintro cs hcs₀ hcs₁ ⟨s, hs⟩
  refine'
    ⟨⋃₀cs, ⟨fun _ ha => Set.mem_unionₛ_of_mem ((hcs₀ hs).left ha) hs, _⟩, fun _ =>
      Set.subset_unionₛ_of_mem⟩
  rintro y ⟨sy, hsy, hysy⟩ z ⟨sz, hsz, hzsz⟩ hyz
  obtain rfl | hsseq := eq_or_ne sy sz
  · exact (hcs₀ hsy).right hysy hzsz hyz
  cases' hcs₁ hsy hsz hsseq with h h
  · exact (hcs₀ hsz).right (h hysy) hzsz hyz
  · exact (hcs₀ hsy).right hysy (h hzsz) hyz
#align is_chain.exists_max_chain IsChain.exists_maxChain


-- import data.set
import tactic

-- dEAduction imports
import structures2
import utils
import push_neg_once

-- General principles :
-- Type should be defined as parameters, in order to be implicit everywhere
-- other parameters are implicit in definitions, i.e. defined using '{}' (e.g. {A : set X} )
-- but explicit everywhere else, i.e. defined using '()' (e.g. (A : set X) )
-- each definition must be an iff statement (since it will be called with 'rw' or 'symp_rw')

-- no Magic button ("compute")
/- dEAduction
Title
    Logique propositionnelle (tutoriel)
Author
    Frédéric Le Roux
Institution
    Université du Monde
Description
    Ce fichier, qui peut servir de tutoriel, contient quelques énoncés de logiques propositionnelle.
    Le but n'est pas de les démontrer du point de vue de la logique propositionnelle,
    mais plutôt de voir comment l'interface fonctionne sur ces énoncés.
DefaultAvailableProof
    NONE
DefaultAvailableMagic
    Assumption
-/

-- logic names ['and', 'or', 'not', 'implies', 'iff', 'forall', 'exists']
-- proofs names ['proof_methods', 'new_object', 'apply']
-- magic names ['compute', 'assumption']

local attribute [instance] classical.prop_decidable
---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
variables (P Q R: Prop) -- NOT global
notation [parsing_only] P ` \and ` Q := P ∧ Q
notation [parsing_only]  P ` \or ` Q := P ∨ Q
notation [parsing_only]  ` \not ` P := ¬ P
notation [parsing_only]  P ` \implies ` Q := P → Q
notation [parsing_only]  P ` \iff ` Q := P ↔ Q

------------------
-- COURSE TITLE --
------------------
namespace Logique_propositionnelle

lemma exercise.tautologie :
P → P
:=
/- dEAduction
PrettyName
    La tautologie
Description
    Le bouton "=>" permet de démontrer une implication : pour montrer
    "P => Q", on suppose P, et on montre Q.
AvailableLogic
    implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et :
P ∧ Q → P
:=
/- dEAduction
PrettyName
    P et Q implique P
Description
    Le bouton "ET" permet de découper une hypothèse
AvailableLogic
    and implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_I :
P ∧ Q → Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif (version faible)
Description
    Le bouton "ET" permet aussi de découper le but en deux buts distincts
AvailableLogic
    and implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.et_commutatif_II :
P ∧ Q ↔ Q ∧ P
:=
/- dEAduction
PrettyName
    Le "ET" est commutatif
Description
    Le bouton "↔" permet de découper le but en deux implications.
    On peut alors appliquer le résultat de l'exercice précédent en le
    sélectionnant dans la liste...
AvailableLogic
    and iff implies
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_commutatif :
P ∨ Q ↔ Q ∨ P
:=
/- dEAduction
PrettyName
    Le "OU" est commutatif
Description
    Pour utiliser l'hypothèse "P OU Q", on sépare les cas :
    dans le premier cas on suppose P, dans le second cas on suppose Q.
    Pour démontrer "Q OU P", on doit démontrer soit P, soit Q.
AvailableLogic
    and or implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_non :
¬ ¬ P ↔ P
:=
/- dEAduction
PrettyName
    Double négation
Description
    Le bouton "NON" permet d'utiliser les règles logiques du "NON".
    On peut l'utiliser uniquement sur les propriétés qui sont des négations,
    c'est-à-dire de la forme "NON (...)".
AvailableLogic
    and or not implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.non_ET :
¬ (P ∧ Q) ↔ (¬ P) ∨ (¬ Q)
:=
/- dEAduction
PrettyName
    Négation d'un "ET"
Description
    En général, le bouton "NON" tente de "pousser" la négation le long de la
    propriété.
AvailableLogic
    and or not implies iff
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.contradiction :
R ∨ ¬ R
:=
/- dEAduction
PrettyName
    Le tiers exclu : l'une des deux propriétés "R" et "NON R" est vraie
Description
    Le mécanisme de preuve inclus le tiers exclu, de façon un peu cachée...
AvailableLogic
    and or not implies iff
AvailableProof
    proof_methods
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.negation_implication :
¬ (P → Q) ↔ (P ∧ ¬ Q)
:=
/- dEAduction
PrettyName
    Négation d'une implication
Description
    Blabla
AvailableLogic
    and or not implies iff
AvailableProof
    proof_methods
AvailableMagic
    assumption

-/
begin
    sorry
end

lemma exercise.contraposition :
(P → Q) ↔ (¬ Q → ¬ P)
:=
/- dEAduction
PrettyName
    Contraposition
Description
    Le bouton "=>" permet également d'appliquer une implication "P => Q" à la
    propriété "P" pour obtenir la propriété "Q". Attention, avant de
    l'actionner il faut sélectionner toutes les propriétés requises !
    On pourra raisonner par l'absurde en utilisant les "Méthodes de preuves".
AvailableLogic
    and or not implies iff
AvailableProof
    proof_methods
AvailableMagic
    assumption

-/
begin
    sorry
end

lemma exercise.ou_implication_I :
(P → Q) ↔ (¬ P ∨ Q)
:=
/- dEAduction
PrettyName
    Implication sous forme de "OU"
Description
    Cette propriété permet de transformer une implication en une disjonction
AvailableLogic
    and or not implies iff
AvailableProof
    use_proof_methods
AvailableMagic
    assumption
-/
begin
    sorry
end

lemma exercise.ou_implication_II :
(P ∨ Q) ↔ (¬ P → Q)
:=
/- dEAduction
PrettyName
    "OU" sous forme d'implication
Description
    Cette propriété est très proche de la précédente.
    On peut la redémontrer entièrement, mais on peut aussi tenter d'appliquer
    le résultat de l'exercice précédent. Pour cela, il faudra introduire
    un nouvel objet, avant de lui appliquer le résultat précédent...
AvailableLogic
    and or not implies iff
AvailableProof
    use_proof_methods new_object
AvailableMagic
    assumption
-/
begin
    sorry
end

end Logique_propositionnelle

end course


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import analysis.convex.basic
import topology.algebra.mul_action
import topology.algebra.ordered.basic

/-!
# Strictly convex sets

This file defines strictly convex sets.

A set is strictly convex if the open segment between any two distinct points lies in its interior.

## TODO

Define strictly convex spaces.
-/

open set
open_locale convex pointwise

variables {𝕜 E F β : Type*}

open function set
open_locale convex

section ordered_semiring
variables [ordered_semiring 𝕜] [topological_space E] [topological_space F]

section add_comm_monoid
variables [add_comm_monoid E] [add_comm_monoid F]

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

/-- A set is strictly convex if the open segment between any two distinct points lies is in its
interior. This basically means "convex and not flat on the boundary". -/
def strict_convex : Prop :=
s.pairwise $ λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → a + b = 1 → a • x + b • y ∈ interior s

variables {𝕜 s} {x y : E}

lemma strict_convex_iff_open_segment_subset :
  strict_convex 𝕜 s ↔ s.pairwise (λ x y, open_segment 𝕜 x y ⊆ interior s) :=
forall₅_congr $ λ x hx y hy hxy, (open_segment_subset_iff 𝕜).symm

lemma strict_convex.open_segment_subset (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s)
  (h : x ≠ y) :
  open_segment 𝕜 x y ⊆ interior s :=
strict_convex_iff_open_segment_subset.1 hs hx hy h

lemma strict_convex_empty : strict_convex 𝕜 (∅ : set E) := pairwise_empty _

lemma strict_convex_univ : strict_convex 𝕜 (univ : set E) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  rw interior_univ,
  exact mem_univ _,
end

protected lemma strict_convex.inter {t : set E} (hs : strict_convex 𝕜 s) (ht : strict_convex 𝕜 t) :
  strict_convex 𝕜 (s ∩ t) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  rw interior_inter,
  exact ⟨hs hx.1 hy.1 hxy ha hb hab, ht hx.2 hy.2 hxy ha hb hab⟩,
end

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

lemma directed_on.strict_convex_sUnion {S : set (set E)} (hdir : directed_on (⊆) S)
  (hS : ∀ s ∈ S, strict_convex 𝕜 s) :
  strict_convex 𝕜 (⋃₀ S) :=
begin
  rw sUnion_eq_Union,
  exact (directed_on_iff_directed.1 hdir).strict_convex_Union (λ s, hS _ s.2),
end

end has_scalar

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

protected lemma strict_convex.convex (hs : strict_convex 𝕜 s) : convex 𝕜 s :=
convex_iff_pairwise_pos.2 $ λ x hx y hy hxy a b ha hb hab, interior_subset $ hs hx hy hxy ha hb hab

/-- An open convex set is strictly convex. -/
protected lemma convex.strict_convex (h : is_open s) (hs : convex 𝕜 s) : strict_convex 𝕜 s :=
λ x hx y hy _ a b ha hb hab, h.interior_eq.symm ▸ hs hx hy ha.le hb.le hab

lemma is_open.strict_convex_iff (h : is_open s) : strict_convex 𝕜 s ↔ convex 𝕜 s :=
⟨strict_convex.convex, convex.strict_convex h⟩

lemma strict_convex_singleton (c : E) : strict_convex 𝕜 ({c} : set E) := pairwise_singleton _ _

lemma set.subsingleton.strict_convex (hs : s.subsingleton) : strict_convex 𝕜 s := hs.pairwise _

lemma strict_convex.linear_image (hs : strict_convex 𝕜 s) (f : E →ₗ[𝕜] F) (hf : is_open_map f) :
  strict_convex 𝕜 (f '' s) :=
begin
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab,
  exact hf.image_interior_subset _
    ⟨a • x + b • y, hs hx hy (ne_of_apply_ne _ hxy) ha hb hab,
    by rw [f.map_add, f.map_smul, f.map_smul]⟩,
end

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

lemma strict_convex.linear_preimage {s : set F} (hs : strict_convex 𝕜 s) (f : E →ₗ[𝕜] F)
  (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (s.preimage f) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  refine preimage_interior_subset_interior_preimage hf _,
  rw [mem_preimage, f.map_add, f.map_smul, f.map_smul],
  exact hs hx hy (hfinj.ne hxy) ha hb hab,
end

lemma strict_convex.is_linear_preimage {s : set F} (hs : strict_convex 𝕜 s) {f : E → F}
  (h : is_linear_map 𝕜 f) (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (s.preimage f) :=
hs.linear_preimage (h.mk' f) hf hfinj

section linear_ordered_cancel_add_comm_monoid
variables [topological_space β] [linear_ordered_cancel_add_comm_monoid β] [order_topology β]
  [module 𝕜 β] [ordered_smul 𝕜 β]

lemma strict_convex_Iic (r : β) : strict_convex 𝕜 (Iic r) :=
begin
  rintro x (hx : x ≤ r) y (hy : y ≤ r) hxy a b ha hb hab,
  refine (subset_interior_iff_subset_of_open is_open_Iio).2 Iio_subset_Iic_self _,
  rw ←convex.combo_self hab r,
  obtain rfl | hx := hx.eq_or_lt,
  { exact add_lt_add_left (smul_lt_smul_of_pos (hy.lt_of_ne hxy.symm) hb) _ },
  obtain rfl | hy := hy.eq_or_lt,
  { exact add_lt_add_right (smul_lt_smul_of_pos hx ha) _ },
  { exact add_lt_add (smul_lt_smul_of_pos hx ha) (smul_lt_smul_of_pos hy hb) }
end

lemma strict_convex_Ici (r : β) : strict_convex 𝕜 (Ici r) :=
@strict_convex_Iic 𝕜 (order_dual β) _ _ _ _ _ _ r

lemma strict_convex_Icc (r s : β) : strict_convex 𝕜 (Icc r s) :=
(strict_convex_Ici r).inter $ strict_convex_Iic s

lemma strict_convex_Iio (r : β) : strict_convex 𝕜 (Iio r) :=
(convex_Iio r).strict_convex is_open_Iio

lemma strict_convex_Ioi (r : β) : strict_convex 𝕜 (Ioi r) :=
(convex_Ioi r).strict_convex is_open_Ioi

lemma strict_convex_Ioo (r s : β) : strict_convex 𝕜 (Ioo r s) :=
(strict_convex_Ioi r).inter $ strict_convex_Iio s

lemma strict_convex_Ico (r s : β) : strict_convex 𝕜 (Ico r s) :=
(strict_convex_Ici r).inter $ strict_convex_Iio s

lemma strict_convex_Ioc (r s : β) : strict_convex 𝕜 (Ioc r s) :=
(strict_convex_Ioi r).inter $ strict_convex_Iic s

lemma strict_convex_interval (r s : β) : strict_convex 𝕜 (interval r s) :=
strict_convex_Icc _ _

end linear_ordered_cancel_add_comm_monoid
end module
end add_comm_monoid

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

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

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

end add_cancel_comm_monoid

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

lemma strict_convex.add_left [has_continuous_add E] (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, z + x) '' s) :=
begin
  rintro _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ hxy a b ha hb hab,
  refine (is_open_map_add_left _).image_interior_subset _ _,
  refine ⟨a • x + b • y, hs hx hy (ne_of_apply_ne _ hxy) ha hb hab, _⟩,
  rw [smul_add, smul_add, add_add_add_comm, ←add_smul, hab, one_smul],
end

lemma strict_convex.add_right [has_continuous_add E] (hs : strict_convex 𝕜 s) (z : E) :
  strict_convex 𝕜 ((λ x, x + z) '' s) :=
by simpa only [add_comm] using hs.add_left z

lemma strict_convex.add [has_continuous_add E] {t : set E} (hs : strict_convex 𝕜 s)
  (ht : strict_convex 𝕜 t) :
  strict_convex 𝕜 (s + t) :=
begin
  rintro _ ⟨v, w, hv, hw, rfl⟩ _ ⟨x, y, hx, hy, rfl⟩ h a b ha hb hab,
  rw [smul_add, smul_add, add_add_add_comm],
  obtain rfl | hvx := eq_or_ne v x,
  { rw convex.combo_self hab,
    suffices : v + (a • w + b • y) ∈ interior ({v} + t),
    { exact interior_mono (add_subset_add (singleton_subset_iff.2 hv) (subset.refl _)) this },
    rw singleton_add,
    exact (is_open_map_add_left _).image_interior_subset _
      (mem_image_of_mem _ $ ht hw hy (ne_of_apply_ne _ h) ha hb hab) },
  obtain rfl | hwy := eq_or_ne w y,
  { rw convex.combo_self hab,
    suffices : a • v + b • x + w ∈ interior (s + {w}),
    { exact interior_mono (add_subset_add (subset.refl _) (singleton_subset_iff.2 hw)) this },
    rw add_singleton,
    exact (is_open_map_add_right _).image_interior_subset _
      (mem_image_of_mem _ $ hs hv hx hvx ha hb hab) },
  exact subset_interior_add (add_mem_add (hs hv hx hvx ha hb hab) $ ht hw hy hwy ha hb hab),
end

end add_comm_group
end ordered_semiring

section ordered_comm_semiring
variables [ordered_comm_semiring 𝕜] [topological_space 𝕜] [topological_space E]

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

lemma strict_convex.preimage_smul (hs : strict_convex 𝕜 s) (c : 𝕜) :
  strict_convex 𝕜 ((λ z, c • z) ⁻¹' s) :=
begin
  classical,
  obtain rfl | hc := eq_or_ne c 0,
  { simp_rw [zero_smul, preimage_const],
    split_ifs,
    { exact strict_convex_univ },
    { exact strict_convex_empty } },
  refine hs.linear_preimage (linear_map.lsmul _ _ c) _ (smul_right_injective E hc),
  unfold linear_map.lsmul linear_map.mk₂ linear_map.mk₂' linear_map.mk₂'ₛₗ,
  exact continuous_const.smul continuous_id,
end

end add_comm_group
end ordered_comm_semiring

section ordered_ring
variables [ordered_ring 𝕜] [topological_space E] [topological_space F]

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

lemma strict_convex.eq_of_open_segment_subset_frontier [nontrivial 𝕜] [densely_ordered 𝕜]
  (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (h : open_segment 𝕜 x y ⊆ frontier s) :
  x = y :=
begin
  obtain ⟨a, ha₀, ha₁⟩ := densely_ordered.dense (0 : 𝕜) 1 zero_lt_one,
  classical,
  by_contra hxy,
  exact (h ⟨a, 1 - a, ha₀, sub_pos_of_lt ha₁, add_sub_cancel'_right _ _, rfl⟩).2
    (hs hx hy hxy ha₀ (sub_pos_of_lt ha₁) $ add_sub_cancel'_right _ _),
end

lemma strict_convex.add_smul_mem (hs : strict_convex 𝕜 s) (hx : x ∈ s) (hxy : x + y ∈ s)
  (hy : y ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) :
  x + t • y ∈ interior s :=
begin
  have h : x + t • y = (1 - t) • x + t • (x + y),
  { rw [smul_add, ←add_assoc, ←add_smul, sub_add_cancel, one_smul] },
  rw h,
  refine hs hx hxy (λ h, hy $ add_left_cancel _) (sub_pos_of_lt ht₁) ht₀ (sub_add_cancel _ _),
  exact x,
  rw [←h, add_zero],
end

lemma strict_convex.smul_mem_of_zero_mem (hs : strict_convex 𝕜 s) (zero_mem : (0 : E) ∈ s)
  (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) :
  t • x ∈ interior s :=
by simpa using hs.add_smul_mem zero_mem (by simpa using hx) hx₀ ht₀ ht₁

lemma strict_convex.add_smul_sub_mem (h : strict_convex 𝕜 s) (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y)
  {t : 𝕜} (ht₀ : 0 < t) (ht₁ : t < 1) : x + t • (y - x) ∈ interior s :=
begin
  apply h.open_segment_subset hx hy hxy,
  rw open_segment_eq_image',
  exact mem_image_of_mem _ ⟨ht₀, ht₁⟩,
end

/-- The preimage of a strict_convex set under an affine map is strict_convex. -/
lemma strict_convex.affine_preimage {s : set F} (hs : strict_convex 𝕜 s) {f : E →ᵃ[𝕜] F}
  (hf : continuous f) (hfinj : injective f) :
  strict_convex 𝕜 (f ⁻¹' s) :=
begin
  intros x hx y hy hxy a b ha hb hab,
  refine preimage_interior_subset_interior_preimage hf _,
  rw [mem_preimage, convex.combo_affine_apply hab],
  exact hs hx hy (hfinj.ne hxy) ha hb hab,
end

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

lemma strict_convex.neg [topological_add_group E] (hs : strict_convex 𝕜 s) :
  strict_convex 𝕜 ((λ z, -z) '' s) :=
hs.is_linear_image is_linear_map.is_linear_map_neg (homeomorph.neg E).is_open_map

lemma strict_convex.neg_preimage [topological_add_group E] (hs : strict_convex 𝕜 s) :
  strict_convex 𝕜 ((λ z, -z) ⁻¹' s) :=
hs.is_linear_preimage is_linear_map.is_linear_map_neg continuous_id.neg neg_injective

end add_comm_group
end ordered_ring

section linear_ordered_field
variables [linear_ordered_field 𝕜] [topological_space E]

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

lemma strict_convex.smul [topological_space 𝕜] [has_continuous_smul 𝕜 E] (hs : strict_convex 𝕜 s)
  (c : 𝕜) :
  strict_convex 𝕜 (c • s) :=
begin
  obtain rfl | hc := eq_or_ne c 0,
  { exact (subsingleton_zero_smul_set _).strict_convex },
  { exact hs.linear_image (linear_map.lsmul _ _ c) (is_open_map_smul₀ hc) }
end

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

/-- Alternative definition of set strict_convexity, using division. -/
lemma strict_convex_iff_div :
  strict_convex 𝕜 s ↔ s.pairwise
    (λ x y, ∀ ⦃a b : 𝕜⦄, 0 < a → 0 < b → (a / (a + b)) • x + (b / (a + b)) • y ∈ interior s) :=
⟨λ h x hx y hy hxy a b ha hb, begin
  apply h hx hy hxy (div_pos ha $ add_pos ha hb) (div_pos hb $ add_pos ha hb),
  rw ←add_div,
  exact div_self (add_pos ha hb).ne',
end, λ h x hx y hy hxy a b ha hb hab, by convert h hx hy hxy ha hb; rw [hab, div_one] ⟩

lemma strict_convex.mem_smul_of_zero_mem (hs : strict_convex 𝕜 s) (zero_mem : (0 : E) ∈ s)
  (hx : x ∈ s) (hx₀ : x ≠ 0) {t : 𝕜} (ht : 1 < t) :
  x ∈ t • interior s :=
begin
  rw mem_smul_set_iff_inv_smul_mem₀ (zero_lt_one.trans ht).ne',
  exact hs.smul_mem_of_zero_mem zero_mem hx hx₀ (inv_pos.2 $ zero_lt_one.trans ht)  (inv_lt_one ht),
end

end add_comm_group
end linear_ordered_field

/-!
#### Convex sets in an ordered space

Relates `convex` and `set.ord_connected`.
-/

section
variables [topological_space E]

/-- A set in a linear ordered field is strictly convex if and only if it is convex. -/
@[simp] lemma strict_convex_iff_convex [linear_ordered_field 𝕜] [topological_space 𝕜]
  [order_topology 𝕜] {s : set 𝕜} :
  strict_convex 𝕜 s ↔ convex 𝕜 s :=
begin
  refine ⟨strict_convex.convex, λ hs, strict_convex_iff_open_segment_subset.2 (λ x hx y hy hxy, _)⟩,
  obtain h | h := hxy.lt_or_lt,
  { refine (open_segment_subset_Ioo h).trans _,
    rw ←interior_Icc,
    exact interior_mono (Icc_subset_segment.trans $ hs.segment_subset hx hy) },
  { rw open_segment_symm,
    refine (open_segment_subset_Ioo h).trans _,
    rw ←interior_Icc,
    exact interior_mono (Icc_subset_segment.trans $ hs.segment_subset hy hx) }
end

lemma strict_convex_iff_ord_connected [linear_ordered_field 𝕜] [topological_space 𝕜]
  [order_topology 𝕜] {s : set 𝕜} :
  strict_convex 𝕜 s ↔ s.ord_connected :=
strict_convex_iff_convex.trans convex_iff_ord_connected

alias strict_convex_iff_ord_connected ↔ strict_convex.ord_connected _

end