import tactic
open nat

inductive le : ℕ → ℕ → Prop
| le0 {n : ℕ} : le 0 n
| les {m n : ℕ} : le m n → le (succ m) (succ n)

open le

inductive le' : ℕ → ℕ → Prop
| reflle' {n : ℕ} : le' n n
| le's {m n : ℕ} : le' m n → le' m (succ n)

open le'

lemma l1 : ∀ n : ℕ, le' zero n :=
begin
  assume n,
  induction n,
  exact reflle',
  apply le's,
  exact n_ih,
end

lemma l2 : ∀ m n : ℕ, le' m n → le' (succ m) (succ n) :=
begin
  assume m n h,
  induction h,
  {
    exact reflle',
  },
  {
    apply le's,
    exact h_ih,
  }
end

lemma l3 : ∀ n : ℕ, le n n :=
begin
  assume n,
  induction n,
  exact le0,
  apply les,
  exact n_ih,
end

lemma l4 : ∀ m n : ℕ, le m n → le m (succ n) :=
begin
  assume m n h,
  induction h,
  {
    exact le0,
  },
  {
    apply les,
    exact h_ih,
  }
end

theorem equ {m n : ℕ} : le m n ↔ le' m n :=
begin
  constructor,
  {
    assume h,
    induction h,
    {
      exact l1 h,
    },
    {
      apply l2,
      exact h_ih,
    }
  },
  {
    assume h,
    induction h,
    {
      exact l3 h,
    },
    {
      apply l4,
      exact h_ih,
    }
  }
end


import tactic --hide

-- Level name : absorption laws pt 1

/-
This level proves the first *absorption* law.
-/

/-Lemma
If $P,Q$ are logical statements then $P ∧ (P ∨ Q)$ is true if and only if $P$ is true.
-/
lemma absorption_one (P Q : Prop) : P ∧ (P ∨ Q) ↔ P :=
begin
  split,
  intro h,
  cases h with hP hPQ,
  exact hP,
  intro h,
  split,
  exact h,
  left,
  exact h,

end


import .prop_logic

/-
A logic is a "formal language" with
a mathematically defined syntax and a
mathematically defined semantics. The
syntax of a language defines the set
of legal expressions in the language
(sometimes called formula, well-formed
formula, sentences, etc). The semantics
then explains how to give a meaning to
each such expression.
In this unit, we formalize the syntax
and semantics of our first example of
a complete logic: a simple logic called
propositional logic.
The *syntactic* terms of propositional
logic again fall in three categories:
- there are two literal terms, which we
will call pTrue and pFalse
- there are variable terms
- and there are application terms, in
which propositional logic connectives
are applied to smaller terms to create
larger ones. These connectives are the
familiar connectives of Boolean algebra:
and (∧), or (∨), not (¬), and so forth.
Examples of propositional logic terms
thus include:
- pTrue             -- literal
- pFalse            -- literal
- and pTrue pFalse  -- application
- X                 -- variable
- Y                 -- variable
- Z                 -- variable
- X ∨ Y             -- application: or X Y
- (X ∨ Y) ∧ (X ∧ Z) -- etc.
- (X ∨ Y) ∧ (X ∧ pTrue)
- etc
The semantic domain of discourse, in which
such expressions are given meaning, is the
set of Boolean truth values, {true, false}.
The semantics of propositional logic assigns
a simple Boolean truth value to each such
propositional logic expression.
In this unit, we will define "eval" to be
a function that takes an expressions and
returns its meaning as a Boolean value.
(As we'll see shortly, the eval function
will have to take one more argument in
order to deal with variable expressions).
Here are the rules for how eval works:
LITERAL TERMS
To the literal, pTrue, the semantic
"evaluation" function assigns the truth
value, true. To pFalse, it assigns the
truth value false. In other words, we
define eval(pFalse) to be the bool, ff,
and eval (pTrue) to be the bool, tt.
VARIABLE TERMS
To evaluate a variable expression, such
as X, or to evaluate an expression with
several variables, such as X ∧ Y, we need
an addition piece of data: what Boolean
truth value each such variable has.
We call this data an *interpretation*.
We will represent it as a function, interp,
from variables to Boolean truth values.
The semantic meaning of the syntactic
variable term, X, is then interp(X).
I.e., eval(X) is defined as interp(X).
There are many possible interpretations
for a given (non-empty) set of variables.
Self-test: How many interpretations are
there for a single variable, X? How many
interpretations are possible for a set
of variables {X_i} of size n?
APPLICATION TERMS
Application terms are built inductively
by applying proposition logic connectives
to smaller terms. For example, if e1 and
e2 are terms (whether literal, variable,
or application), then so are (and e1 e2),
(or e1 e2), (not e1), etc.
Our intention is that the semantics of
such syntactic terms should reflect the
usual Boolean algebraic meaning of the
connectives. So, for example, if e1 and
e2 are expressions, then so is (and e1
e2), and we wish to evaluate this as
true if and only if both e1 and e2
evaluate to true.
We thus define eval to work recursively
on such expressions. We evaluate the truth
of e1 and of e2 and then apply the *bool*
and operator (as distinct from the and
logical connective) to the results to
determine the truth value of (and e1 e2).
-/

open prop_logic
open prop_logic.var
open prop_logic.unOp
open prop_logic.binOp
open prop_logic.pExp

/-
    **************
    *** SYNTAX ***
    **************
-/

-- Variables

#check mkVar
#check mkVar 0
#check mkVar 1
#check mkVar 2
#check mkVar 3

-- names for a few
def varX := mkVar 0
def varY := mkVar 1
def varZ := mkVar 2

-- Operators (connectives)
#check pNot     -- unary
#check pAnd     -- binary
#check pOr      -- binary

-- Expressions

-- Literal
#check litExp ff
#check litExp tt
#check pFalse
#check pTrue

-- Variable
#check varExp varX
#check varExp varY
def X : pExp:= varExp varX
def Y : pExp := varExp varY
def Z : pExp := varExp varZ
#check X
#check Y

-- Operator/application
#check unOpExp notOp pTrue
#check unOpExp notOp

-- with shorthands
#check pNot pTrue
#check pNot X
#check binOpExp andOp X Y
#check binOpExp andOp
#check pAnd X Y
#check pOr X Y

-- finally, logical expressions!
#check pTrue
#check ¬ pTrue
#check ¬ pFalse
#check X
#check ¬ X
#check Y
#check X ∧ Y
#check X ∨ Y
#check ¬ (X ∧ Y)
#check ¬ (X ∧ Y) ∨ (¬ X ∨ ¬ Y)

/-
You have now defined the syntax of the
formal language, propositional logic!
You can now check syntactic correctness
of expressions.
-/

#check ¬ (X ∧ Y) ∨ (X ∨ Z) -- correct
#check ¬ (X ∧ Y) ∨ (X ∨ )  -- error
#check ¬ X ¬ Y             -- error
#check pTrue pFalse        -- error

/-
    *****************
    *** SEMANTICS ***
    *****************
-/

-- Interpretations

def allFalse : var → bool
| _ := ff

def allTrue : var → bool
| _ := tt

def anInterp: var → bool
  | (mkVar 0) := tt
  | (mkVar 1) := ff
  | (mkVar 2) := tt
  | (mkVar _) := ff

-- interpretation

#eval allFalse varX
#eval allTrue varX
#eval anInterp varX
#eval anInterp varY

-- Interpretation of operators

#check interpUnOp notOp
#eval (interpUnOp notOp) tt
#eval interpBinOp andOp tt ff
#eval interpBinOp andOp tt tt

-- evaluation of expressions

#eval pEval pTrue allTrue
#eval pEval pTrue allFalse
#eval pEval X allTrue
#eval pEval Y allFalse
#eval pEval X anInterp
#eval pEval Y anInterp
#eval pEval (X ∧ Y) allTrue
#eval pEval (X ∧ Y) allFalse
#eval pEval (X ∧ Y) anInterp
#eval pEval (X ∨ Y) anInterp
#eval pEval (X ∧ Z) anInterp
#eval pEval (¬ (X ∧ Z)) anInterp
#eval pEval (¬ (X ∧ Y) ∨ (¬ X ∨ ¬ Y)) anInterp
#eval pEval (¬ (X ∧ Y) ∨ (¬ X ∨ ¬ Y)) allTrue

/-
To formalize a semantics for our
realization of propositional logic,
we need to formally define what we
mean by an interpretation.
An interpretation in propositional
logic is a function from propositional
variables to corresponding (Boolean)
truth values. An interpretation tells
us what each variable "means" -- i.e.,
whether it means true, or false.
We now define a name for the type
of an interpretation (pVar → bool).
Then we present several examples of
interpretations.
-/

-- Semantics

/-
We now define a semantics for our
language in the form of a function
that, when given any expression in
our language *and* an interpretation
for the variables that might appear
in it, evaluates its truth value and
returns it as a result.
The definition is by cases, i.e.,
with one rule for each possible form
(constructor) of expression.
Note: Lean "overloads" logical
operator notations, such as ∧, ∨,
and ¬. Here they are applied not to
values of type Prop, but to values
of type bool, where they have their
usual means from Boolean algebra.
-/

/-
And now we have a formal language, with
a syntax, interpretations, and semantics.
Let's evaluate some of our expressions
under varying interpretations.
-/

/-
So there you have it: a complete
formal definition of the syntax,
interpretation, and semantics of
propositional logic, in Lean, with
a nice "surface syntax," to boot.
(Ok, it's complete except for the
definitions for the other logical
connectives. You will add some of
them in homework and on the exam.)
-/

/-
From here, we can define richer
functions, such as functions that
analyze expressions; and we can
even state and prove theorems
about our language.
-/

/-
Let's define a function that
returns the set of variables
in a given pExp. This will be
useful in the future.
-/

/-
We start by defining a recursive
helper function that adds all the
variables in given expression to
the given, often already non-empty,
set of variables.
Understand the type and purpose of
this function, then go on to read
the following main function. Study
its purpose, type, and implementation,
then come back for a deeper look at
how this function is implemented.
Learn to use functions knowing only
their type and purpose, ignoring, at
least at first, their implementation
details. Pratice mental abstracting.
We implement (prove) this recursive
function (type) by case analysis on
possible forms of the given pExp.
-/
/-
Main function: a non-recursive function
that passes an initially empty set of
variables to the helper function and
then gets back a set of all, and only,
the variables in the given expression.
-/
/-
Examples of its use
-/
#reduce vars_in_exp (X ∧ Y)
-- A predicate for set {X,Y}

/-
Another example
-/
#reduce vars_in_exp (X ∧ Z)

/-
EXERCISE: Write a function that when
given an expression, e, returns the
"nesting depth" of the expression. The
nesting depth of a literal or variable
expression is 1. The depth of a (not e)
expression is 1 + the depth of e. And
the depth of an (and e1 e2) expression
is 1 + the max of the depths of e1 and
e2. You can use the Lean-provided max
function in your answer.
-/

#reduce max 5 7
#reduce max 7 5

/-
We can also prove theorems about
our language in general. Here's a
proof that evaluation under a given
interpretation is "deterministic::
it always produces the same result.
This is really just a corollary of
the facts that (1) functions in Lean
are single valued and (2) we defined
the semantics of expressions with a
function. There's one and only one
answer for the value of any given
expression.
-/

theorem pEval_deterministic :
∀ e : pExp,
∀ i : pInterp,
∀ v1 v2 : bool,
v1 = pEval e i → v2 = pEval e i → v1 = v2 :=
begin
intros e i v1 v2 h_v1 h_v2,
rw h_v1,
rw h_v2,
end

/-
We can also prove theorems ("reason
about") particular expressions, or
certain classes of expressions, in
our language. For example, if X_exp
is any variable expression, then the
expression (X_exp ∧ (¬ X_exp)) is
false under any interpretation. We
can easily prove this proposition.
-/

theorem contra :
∀ V : pVar,
∀ i : pInterp,
pEval
    ((mk_var_pexp V) ∧ ¬ (mk_var_pexp V)) i = ff
:=
begin
intros X i,
simp [pEval],
-- case analysis on result of function!
cases (i X),
left, apply rfl,
right, apply rfl,
end

/-
Note that it is quantified over all
possible interpretations: over all
possible functions from pVar → bool.
Lean supports what is called higher
order predicate logic. Quantifying
over functions and relations is ok
in a higher-order predicate logic.
It is not allowed in the first-order
predicate logic of everyday math and
computer science. Here you can see
that it gives you great expressive
power to be able to quantify over
functions. It gives us a way to say,
"under any possible interpretation",
which is exactly what we need to be
able to say to define satisfiability,
validity, unsatisfiability, etc.
-/

/-
Exercise: Prove that for any
variable, V, the logical expression
(mk_var_exp V) ∨ (¬ (mk_var_exp V))
always evaluates to true.
-/

def valid (e : pExp) : Prop :=
    ∀ i : pInterp, pEval e i = tt

/-
An expression in propositional logic
is unsatisfiable if it does'ot evaluate
to true under any interpretation.
-/

def unsatisfiable (e : pExp) : Prop :=
    ∀ i, pEval e i = ff

/-
You could also have said there does not
exist an i that makes (pEval e i) = tt.
-/

/-
An interpretation that makes an
expression, e, evaluate to true,
is said to be a "model" of that
expression. Here's a predicate
asserting that i is a model of e.
-/

def isModel (i: pInterp) (e : pExp) :=
    pEval e i = tt

/-
An expression is said to be satisfiable
if there is at least one interpretation
under which it evaluates to true.
-/
def satisfiable (e : pExp) : Prop :=
    ∃ i, isModel i e

/-
Example: X ∧ ¬ X is unsatisfiable.
-/

example : unsatisfiable (X_exp ∧ (¬ (X_exp))) :=
begin
unfold unsatisfiable,
intro i,
rw pEval, -- you can do this
rw pEval, -- and do it again
cases (pEval X_exp i), -- cool!
trivial,
trivial,
end

/-
EXERCISE: Once you've extended
our logic with an or operator,
formulize and prove the proposition
that (our rendering of) X ∨ (¬ X)
is valid.
EXERCISE: Prove the proposition
that (X ∨ Y) ∧ Z is satisfiable.
Hint: You'll need a witness. There
is an element of search involved
in solving a problem like this.
-/

/-
EXERCISE: Write a SAT solver based
on what we've done here.
-/

-- m'th bit from right in binary rep of n
def mrbn: ℕ → ℕ → bool
| 0 n := n % 2 = 1
| (nat.succ m') n := mrbn m' (n/2)

/- smoke test
#reduce mrbn 0 15
#reduce mrbn 2 15
#reduce mrbn 2 15
#reduce mrbn 3 15
#reduce mrbn 4 15
#reduce mrbn 5 15
-/

/-
The mth canonical interpretation
among the 2^n-1 interpretations
for a set of variables of size n.
The values of the first n-indexed
variables in the mth interpretation
are determined by the bits in the
binary representation of m. The
leftmost bit gives the value for
the variable with index 0. Each
bit to the left gives the value of
the next indexed variable. All
subsequent values are ff. m thus
effectively enumerates the 2^n
interpretations on the n first
variables in the index set of all
variables.
-/

def mthInterpOf2toN (m n: ℕ) : pInterp :=
    if (m >= 2^n)
    then falseInterp
    else
    λ v : pVar,
        match v with
        | (pVar.mk i) :=
        if i >= n then
        ff
        else
        (mrbn i m)
        end

/-
Examples:
-/

#reduce pEval and_X_Y_exp (mthInterpOf2toN 3 3)

-- unincorporated

#reduce mthInterpOf2toN 3 5

def first_n_true_inter (n : ℕ) : pInterp :=
λ v,
    match v with
    | (pVar.mk n') := if n' < n then tt else ff
    end

def all_models (e : pExp) :=
    { m | isModel m e}

def sat_solve (e : pExp) : option pInterp :=
none


import tactic.basic

/-
It's time to learn about universes!

This assignment is hopefully fairly quick, but will walk you through the
universe polymorphism issues involved in defining categories in Lean.
-/

-- Here's a simple attempt at defining a category.
-- The parameter `C` describes the objects of the category.
class category (C : Type) :=
(hom : C → C → Type)
(id : Π X : C, hom X X)
(comp : Π {X Y Z : C}, hom X Y → hom Y Z → hom X Z)
(comp_id : Π {X Y : C} (f : hom X Y), comp f (id Y) = f)
(id_comp : Π {X Y : C} (f : hom X Y), comp (id X) f = f)
(assoc : Π {W X Y Z : C} (f : hom W X) (g : hom X Y) (h : hom Y Z), comp (comp f g) h = comp f (comp g h))

-- However, this definition is no good: we can't define the category of types:
instance category_of_types_broken : category Type :=
{ hom := λ X Y, X → Y }

-- To fix this, you're going to need to modify the definition above,
-- to fix the universe levels.

-- Question 0: Explain why the definition above wasn't useful, perhaps
-- mentioning Russell's paradox.

/- Answer: Because of the hierarchy of the universes, Type cannot be of type Type.
Instead, it must be of Type 1 (otherwise, we would have an analogue of Russell's Paradox:
the set of all sets being an element of itself). In a dependent type theory context,
this means that nothing can be of Type itself, which is implemented by setting Type to be of
Type 1, Type 1 of Type 2 etc. This is not reflected in the definition,
as the universe level of the category above is fixed. It should instead be polymorphic, so
that elements belonging to higher universe levels can be made into categories.

One possible solution to this would be to change Type to Type 1 (at the very least, this would
allow the category of types to be defined. However, we would then have an identical problem to
the one above when we tried to create a category for a type in a universe level higher
than 1).
-/

-- Here's one attempt:

class category_1 (C : Type 1) :=
(hom : C → C → Type)
(id : Π X : C, hom X X)
(comp : Π {X Y Z : C}, hom X Y → hom Y Z → hom X Z)
(comp_id : Π {X Y : C} (f : hom X Y), comp f (id Y) = f)
(id_comp : Π {X Y : C} (f : hom X Y), comp (id X) f = f)
(assoc : Π {W X Y Z : C} (f : hom W X) (g : hom X Y) (h : hom Y Z), comp (comp f g) h = comp f (comp g h))

-- Question 1: fill in the remaining fields of this definition.
instance category_of_types : category_1 Type :=
{ hom := λ X Y, X → Y,
  id := λ X, λ x, x,
  comp := λ X Y Z, λ f g, λ x, g (f x),
  comp_id := by {intros X Y f, simp},
  id_comp := by {intros X Y f, simp},
  assoc := by {intros W X Y Z f g h, simp}
}

-- However, this variant has its own problems. A standard solution to Russell's
-- paradox about "the set of all sets" (resolved in Lean's dependent type theory
-- by the typing judgement `Type : Type 1`) is to consider all subsets of some
-- fixed 'big' set, rather than "all sets".

-- Question 2: Decide whether `C` below should be `category` or `category_1`,
-- and fill in the remaining fields.
instance category_of_subsets (X : Type) : category (set X) :=
{ hom := λ P Q, { x // P x } → { x // Q x },
  id := λ P, λ x, x,
  comp := λ P Q R, λ p q, λ x, q (p x),
  comp_id := by {intros P Q f, simp},
  id_comp := by {intros P Q f, simp},
  assoc := by {intros P Q R f g h, simp}
}

-- We've now got a conundrum: for some reasonable examples, we want the
-- objects and morphisms to live in the same universe, while for other
-- examples we want the objects to live one universe level higher than
-- the morphisms.

-- In ZFC based category theory, these two variants of the notion of a category
-- are called "small categories" and "large categories".

-- Rather than duplicate everything we want to prove about categories
-- (or worse: we'll need to worry about four different sorts of functors,
-- as the source and target categories could individually be small or large!)
-- in the mathlib category theory library we've made a "universe polymorphic"
-- definition, which is essentially this one:

universes v u

class pcategory (C : Type u) :=
(hom : C → C → Type v)
(id : Π X : C, hom X X)
(comp : Π {X Y Z : C}, hom X Y → hom Y Z → hom X Z)
(comp_id : Π {X Y : C} (f : hom X Y), comp f (id Y) = f)
(id_comp : Π {X Y : C} (f : hom X Y), comp (id X) f = f)
(assoc : Π {W X Y Z : C} (f : hom W X) (g : hom X Y) (h : hom Y Z), comp (comp f g) h = comp f (comp g h))

-- Question 3:
-- Work out the appropriate values of the universe parameters `p`, `q`, `r`, `s`
-- below, and then verify that the same fields you used above can be used to
-- complete the following two definitions:
-- (Hint: substitute fixed large values, like p=5, q=10, and read the error messages...)
instance category_of_types' : pcategory.{0 1} Type :=
{ hom := λ X Y, X → Y,
  id := λ X, λ x, x,
  comp := λ X Y Z, λ f g, λ x, g (f x),
  comp_id := by {intros X Y f, simp},
  id_comp := by {intros X Y f, simp},
  assoc := by {intros W X Y Z f g h, simp}
}

instance category_of_subsets' (X : Type) : pcategory.{0 0} (set X) :=
{ hom := λ P Q, { x // P x } → { x // Q x },
  id := λ P, λ x, x,
  comp := λ P Q R, λ p q, λ x, q (p x),
  comp_id := by {intros P Q f, simp},
  id_comp := by {intros P Q f, simp},
  assoc := by {intros P Q R f g h, simp}
}

-- Question 4:
-- Complete the following definitions:
universes v₁ u₁ v₂ u₂

structure Functor (C : Type u₁) [pcategory.{v₁ u₁} C] (D : Type u₂) [pcategory.{v₂ u₂} D] :=
(obj : C → D)
(map : Π {X Y : C}, pcategory.hom X Y → pcategory.hom (obj X) (obj Y))
(id_map : Π X : C, map (pcategory.id X) = pcategory.id (obj X))
(map_comp : Π X Y Z : C, Π f : pcategory.hom X Y, Π g : pcategory.hom Y Z, map (pcategory.comp f g) = pcategory.comp (map f) (map g))
-- Hint: there are two missing fields here, giving the axioms for functors.

def List : Functor Type Type :=
{ obj := λ α, list α,
  map := λ α β : Type, λ f : pcategory.hom α β, λ L, list.map f L,
  id_map := by {intros X, dsimp [pcategory.id], funext, induction x, simp, dsimp [list.map], rw [x_ih]},
  map_comp := by {intros X Y Z f g, simp, funext, dsimp [pcategory.comp], induction x,
                  simp, dsimp [list.map], rw [x_ih],}}

-- Question 5:
-- Complete the following definitions:

structure NaturalTransformation
  {C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D]
  (F G : Functor C D) :=
(app : Π X : C, pcategory.hom (F.obj X) (G.obj X))
(naturality : Π X Y : C, Π f : pcategory.hom X Y, pcategory.comp (F.map f) (app Y) = pcategory.comp (app X) (G.map f))

namespace NaturalTransformation
def id
  {C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D]
  (F : Functor C D) : NaturalTransformation F F :=
{app := λ X : C, pcategory.id (F.obj X),
 naturality := by {intros X Y f, rw [pcategory.comp_id, pcategory.id_comp]}}

def comp
  {C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D]
  {F G H : Functor C D}
  (α : NaturalTransformation F G) (β : NaturalTransformation G H) : NaturalTransformation F H :=
{app := λ X : C, pcategory.comp (α.app X) (β.app X),
 naturality := by {intros X Y f, rw [←pcategory.assoc, α.naturality, pcategory.assoc, pcategory.assoc],
 apply congr_arg, rw [β.naturality]}}

@[extensionality] lemma Natural_ext
{C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D]
{F G : Functor C D} {N M : NaturalTransformation F G} :
(Π X : C, N.app X = M.app X) → N = M :=
begin
  intros h,
  induction N,
  induction M,
  simp at h,
  simp [h],
  funext,
  exact h x,
end

@[simp] lemma id_app
{C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D] {F : Functor C D} :
(id F).app = λ X : C, pcategory.id (F.obj X) := rfl

-- Hint: you may find `conv` helpful.
end NaturalTransformation

-- Here's the crux of the whole assignment: understand what the correct values
-- of `p` and `q` are in this definition, then complete the definition.
-- Hint: you may like to prove an extensionality lemma for natural transformations,
-- and appropriate simp lemmas.
instance {C : Type u₁} [pcategory.{v₁ u₁} C] {D : Type u₂} [pcategory.{v₂ u₂} D] :
  pcategory.{(max u₁ v₂) (max u₁ u₂ v₁ v₂)} (Functor C D) :=
{ hom := λ F G, NaturalTransformation F G ,
  id := NaturalTransformation.id,
  comp := λ F G H, NaturalTransformation.comp,
  comp_id := by {intros F G N, ext X, dsimp [NaturalTransformation.comp], rw [pcategory.comp_id]},
  id_comp := by {intros F G N, ext X, dsimp [NaturalTransformation.comp], rw [pcategory.id_comp]},
  assoc := by {intros F G H I N M O, ext X, dsimp [NaturalTransformation.comp], rw [pcategory.assoc]}
}

constant C : Type u₁
constant D : Type u₂
variables [C_cat : pcategory.{v₁ u₁} C] [D_cat : pcategory.{v₂ u₂} D]
variables F G : @Functor C C_cat D D_cat
constant N : NaturalTransformation F G

set_option pp.universes true
#check @Functor C C_cat D D_cat -- Type (max u₁ u₂ v₁ v₂)
#check @NaturalTransformation C C_cat D D_cat F G -- Type (max u₁ v₂)

-- Question 6:
-- What universe does `NaturalTransformation F G` live in? Why?
-- Hint: a really good answer will use the word 'impredicativity' somewhere
-- along the way.

/- Answer: NaturalTransformation F G lives in the universe 'max (u₁ v₂)'.
  We begin by noting that Functor C D is of type Type max (u₁ u₂ v₁ v₂).
  This is because the field obj has type Type (max u₁ u₂) (because C : Type u₁
  and D : Type u₂ and so) and the field map has type Type (max v₁ v₂) (because
  the morphisms in the category of C live in the universe v₁,  and the morphisms
  in the category of D live in the universe v₂).

  The other fields are of type Prop = Sort 0 : Type 0, because they are functions from some type
  into Prop. Impredicativity means that regardless of the universe level
  of the domain, the type of this will always be Type 0. We want this feature
  in our universe levels in Lean because we can interpret a function f : A → B for some
  types A : Type u and B : Prop by the statement "given some element of A, I can give you an
  element of B". In the case where B : Prop, an element of B is a proof of B and so f : A → Prop
  represents the statement "if A has an element then B", so f is itself a proposition (and hence
  of type Prop), even if this is a lower universe level than A.

  All of these facts together mean that Functor C D is of type
  Type max (max u₁ u₂) (max v₁ v₂) = Type max (u₁ u₂ v₁ v₂).
  [Note : I realised after I had written this that the universe level of Functor does not affect
   the universe level of NaturalTransformation. However, the explanation about impredicativity above
   is still used below when we discuss why the field naturality of NaturalTransformation does not
   affect its universe level, so I left it in.]

  We can now apply the same reasoning as above to determine the universe level of
  NaturalTransformation. Because naturality is a Prop, it will not affect the universe level of
  NaturalTransformation (once again by impredicativity), so it suffices to determine the universe
  level of app. pcategory.hom (F.obj X) (G.obj X) is a morphism in the category D and so is of type
  Type v₂. Because X : C, app is a function from something of type Type u₁ to something of type
  Type v₂ and so its type is Type (max u₁ v₂) (meaning it lives in the universe level max (u₁ v₂)).
  Then NaturalTransformation has the same universe level as app and so lives in the universe level
  max (u₁ v₂).
-/


/-
Defines a notion of getting two distinct indexes from a list.

Authors: Cayden Codel
Carnegie Mellon University
-/

import basic

import data.list.basic
import data.nat.basic
import tactic

namespace distinct

open list
open nat

def distinct {α : Type*} (a₁ a₂ : α) (l : list α) :=
  ∃ (i j : nat) (Hi : i < l.length) (Hj : j < l.length),
  i < j ∧ l.nth_le i Hi = a₁ ∧ l.nth_le j Hj = a₂

theorem not_distinct_nil {α : Type*} (a₁ a₂ : α) : ¬distinct a₁ a₂ [] :=
begin
  rintro ⟨i, _, hi, _, _⟩,
  rw length at hi,
  linarith
end

theorem not_distinct_singleton {α : Type*} (a₁ a₂ a₃ : α) : ¬distinct a₁ a₂ [a₃] :=
begin
  rintro ⟨i, j, _, hj, hij, _⟩,
  have := gt_of_gt_of_ge hij (zero_le i),
  rw [length, length] at hj,
  linarith
end

theorem distinct_double {α : Type*} (a₁ a₂ : α) : distinct a₁ a₂ [a₁, a₂] :=
by { use [0, 1], simp }

theorem eq_of_distinct_double {α : Type*} {a₁ a₂ b₁ b₂ : α} :
  distinct a₁ a₂ [b₁, b₂] → a₁ = b₁ ∧ a₂ = b₂ :=
begin
  rintros ⟨i, j, hi, hj, hij, hil, hjl⟩,
  cases i,
  { rcases nth_le_of_ge hj (succ_le_iff.mpr hij) with ⟨h₁, h₂⟩,
    rw [hjl, nth_le, nth_le_singleton] at h₂,
    rw nth_le at hil,
    exact ⟨hil.symm, h₂⟩ },
  { simp [length] at hj,
    have : 1 ≤ i + 1, exact le_add_self,
    have := gt_of_gt_of_ge hij this,
    linarith }
end

theorem length_ge_two_of_distinct {α : Type*} {a₁ a₂ : α} {l : list α} :
  distinct a₁ a₂ l → length l ≥ 2 :=
begin
  rintros ⟨i, j, _, Hj, hij, _, _⟩,
  have : 1 ≤ j, exact succ_le_iff.mpr (pos_of_gt hij),
  have : 1 < length l, exact gt_of_gt_of_ge Hj this,
  exact succ_le_iff.mpr this
end

theorem exists_distinct_of_length_ge_two {α : Type*} {l : list α} :
  length l ≥ 2 → ∃ {a₁ a₂ : α}, distinct a₁ a₂ l :=
begin
  intro hl,
  rcases exists_cons_cons_of_length_ge_two hl with ⟨a₁, a₂, as, rfl⟩,
  use [a₁, a₂, 0, 1], simp
end

theorem distinct_cons_of_mem {α : Type*} (a₁ : α) {a₂ : α} {l : list α} :
  a₂ ∈ l → distinct a₁ a₂ (a₁ :: l) :=
begin
  intro h,
  rcases mem_iff_nth_le.mp h with ⟨n, hlen, hn⟩,
  have hi : 0 < length (a₁ :: l), simp,
  have hj : n + 1 < length (a₁ :: l),
    by { rw [length, succ_lt_succ_iff], exact hlen },
  use [0, n + 1, hi, hj],
  simp [← hn],
  refl
end

theorem distinct_cons_of_distinct {α : Type*} {a₁ a₂ : α} {l : list α} (a : α) :
  distinct a₁ a₂ l → distinct a₁ a₂ (a :: l) :=
begin
  rintros ⟨i, j, hi, hj, hij, hil, hjl⟩,
  have hi₂ : i + 1 < (a :: l).length,
  { simp only [hi, length, add_lt_add_iff_right] },
  have hj₂ : j + 1 < (a :: l).length,
  { simp only [hj, length, add_lt_add_iff_right] },
  use [i + 1, j + 1, hi₂, hj₂, succ_lt_succ hij],
  rw [nth_le, nth_le],
  exact ⟨hil, hjl⟩
end

theorem distinct_of_distinct_cons_of_ne {α : Type*} {a₁ a₂ a : α} {l : list α} :
  distinct a₁ a₂ (a :: l) → a₁ ≠ a → distinct a₁ a₂ l :=
begin
  rintros ⟨i, j, hi, hj, hij, hil, hjl⟩ hne,
  cases i,
  { rw nth_le at hil, exact absurd hil.symm hne },
  { rw length at hi,
    have := succ_le_iff.mpr ((gt_of_gt_of_ge hij (zero_le i.succ))),
    rcases nth_le_of_ge hj this with ⟨hjm, hnth⟩,
    rw [← nat.sub_add_cancel this, length] at hj,
    rw ← nat.sub_add_cancel this at hij,
    use [i, j - 1, succ_lt_succ_iff.mp hi, succ_lt_succ_iff.mp hj,
      succ_lt_succ_iff.mp hij],
    rw [← hil, ← hjl, hnth, nth_le, nth_le],
    exact ⟨rfl, rfl⟩ }
end

theorem eq_or_distinct_of_distinct_cons {α : Type*} {a₁ a₂ a : α} {l : list α} :
  distinct a₁ a₂ (a :: l) → a₁ = a ∨ distinct a₁ a₂ l :=
begin
  intro hdis,
  by_cases h : (a₁ = a),
  { exact or.inl h },
  { exact or.inr (distinct_of_distinct_cons_of_ne hdis h) }
end

theorem mem_tail_of_distinct_cons {α : Type*} {a₁ a₂ a : α} {as : list α} :
  distinct a₁ a₂ (a :: as) → a₂ ∈ as :=
begin
  rintro ⟨i, j, Hi, Hj, hij, hil, hjl⟩,
  have := succ_le_iff.mpr ((gt_of_gt_of_ge hij (zero_le i))),
  rcases (nth_le_of_ge Hj this) with ⟨Hj₂, hnth⟩,
  rw hjl at hnth,
  rw [hnth, nth_le],
  exact nth_le_mem as _ _
end

theorem distinct_sublist {α : Type*} {a₁ a₂ : α} {l₁ l₂ : list α} :
  l₁ <+ l₂ → distinct a₁ a₂ l₁ → distinct a₁ a₂ l₂ :=
begin
  induction l₂ with a as ih generalizing l₁,
  { rw sublist_nil_iff_eq_nil, rintro rfl, exact id },
  { intros hl₁ hdis,
    cases hl₁,
    { exact distinct_cons_of_distinct a (ih hl₁_ᾰ hdis) },
    { by_cases ha : (a₁ = a),
      { have := (sublist.subset hl₁_ᾰ) (mem_tail_of_distinct_cons hdis),
        rcases mem_iff_nth_le.mp this with ⟨n, hn₁, hn₂⟩,
        have Hi : 0 < (a :: as).length, by dec_trivial,
        have Hj : n + 1 < (a :: as).length,
        { rw length, exact succ_lt_succ_iff.mpr hn₁ },
        use [0, n + 1, Hi, Hj],
        simp [ha],
        rw ← hn₂,
        refl },
      { have := distinct_of_distinct_cons_of_ne hdis ha,
        exact distinct_cons_of_distinct a (ih hl₁_ᾰ this) } } }
end

-- TODO way to do in a non-tactic way?
theorem mem_of_distinct_left {α : Type*} {a₁ a₂ : α} {l : list α} :
  distinct a₁ a₂ l → a₁ ∈ l :=
begin
  rintro ⟨i, _, hi, _, _, hil, _⟩,
  rw ← hil, exact nth_le_mem l _ _
end

-- TODO this too
theorem mem_of_distinct_right {α : Type*} {a₁ a₂ : α} {l : list α} :
  distinct a₁ a₂ l → a₂ ∈ l :=
begin
  rintro ⟨_, j, _, hj, _, _, hjl⟩,
  rw ← hjl, exact nth_le_mem l _ _
end

theorem countp_ge_two_of_distinct_of_pos {α : Type*} {a₁ a₂ : α}
  {p : α → Prop} [decidable_pred p] (h₁ : p a₁) (h₂ : p a₂) :
  ∀ {l : list α}, distinct a₁ a₂ l → countp p l ≥ 2
| [] hdis := absurd hdis (not_distinct_nil _ _)
| [a] hdis := absurd hdis (not_distinct_singleton _ _ _)
| (a :: b :: bs) hdis := begin
  have hmem := mem_tail_of_distinct_cons hdis,
  rcases hdis with ⟨i, j, hi, hj, hij, hil, hjl⟩,
  cases i,
  { rw nth_le at hil,
    rw [hil, countp_cons_of_pos p (b :: bs) h₁],
    apply succ_le_succ_iff.mpr,
    apply succ_le_iff.mpr,
    apply (countp_pos p).mpr,
    use [a₂, hmem, h₂] },
  { cases j,
    { linarith },
    { have : distinct a₁ a₂ (b :: bs),
      { rw [length, succ_lt_succ_iff] at hi hj,
        rw succ_lt_succ_iff at hij,
        rw nth_le at hil hjl,
        use [i, j, hi, hj, hij, hil, hjl] },
      have ih := countp_ge_two_of_distinct_of_pos this,
      exact le_trans ih (sublist.countp_le p (sublist_cons a (b :: bs))) } }
end

end distinct


/-
Copyright (c) 2017 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
-/

import mathematica
import data.real.basic
open expr tactic nat mmexpr

/--
`factor e nm` takes an expression representing a polynomial, like `` `(x^2-1)``.
It gets translated to Mathematica, factored, and reconstructed.
The `ring` tactic is called to prove that the input `e` is equal to the result,
and this equality is added to the context as a hypothesis with name `nm`.
-/
meta def factor (e : expr) (nm : option name) : tactic unit :=
do t ← mathematica.run_command_on (λ s, s ++" // LeanForm // Activate // Factor") e,
   ts ← to_expr t,
   (_, pf) ← to_expr ``(%%e = %%ts) >>= λ tgt, solve_aux tgt `[ring, done],
   match nm with
   | some n := note n none pf >> skip
   | none := do n ← get_unused_name `h none, note n none pf, skip
   end

namespace tactic
namespace interactive

setup_tactic_parser

meta def factor (e : parse texpr) (nm : parse using_ident) : tactic unit :=
do e' ← i_to_expr e,
   _root_.factor e' nm

end interactive
end tactic

/-
In these first two examples we prove that polynomials are nonnegative
by factoring them into squares.
-/
example (x : ℝ) : 1 - 2*x + 3*x^2 - 2*x^3 + x^4 ≥ 0 :=
begin
 factor  1 - 2*x + 3*x^2 - 2*x^3 + x^4  using h,
 rewrite h,
 apply pow_two_nonneg
end

example (x : ℝ) : x^2-2*x+1 ≥ 0 :=
begin
factor x^2-2*x+1 using q,
rewrite q,
apply pow_two_nonneg
end

/-
Here we factor a larger polynomial and trace the state afterward:

x y : ℝ,
h :
  x ^ 10 - y ^ 10 =
    (x + (-1) * y) * (x + y) * (x ^ 4 + (-1) * x ^ 3 * y + x ^ 2 * y ^ 2 + (-1) * x * y ^ 3 + y ^ 4) *
      (x ^ 4 + x ^ 3 * y + x ^ 2 * y ^ 2 + x * y ^ 3 + y ^ 4)
⊢ true
-/
example (x y : ℝ) : true :=
begin
factor (x^10-y^10),
trace_state,
triv
end


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Sébastien Gouëzel
-/
import analysis.calculus.mean_value
import analysis.special_functions.pow_deriv

/-!
# Collection of convex functions

In this file we prove that the following functions are convex:

* `strict_convex_on_exp` : The exponential function is strictly convex.
* `even.convex_on_pow`, `even.strict_convex_on_pow` : For an even `n : ℕ`, `λ x, x ^ n` is convex
  and strictly convex when `2 ≤ n`.
* `convex_on_pow`, `strict_convex_on_pow` : For `n : ℕ`, `λ x, x ^ n` is convex on $[0, +∞)$ and
  strictly convex when `2 ≤ n`.
* `convex_on_zpow`, `strict_convex_on_zpow` : For `m : ℤ`, `λ x, x ^ m` is convex on $[0, +∞)$ and
  strictly convex when `m ≠ 0, 1`.
* `convex_on_rpow`, `strict_convex_on_rpow` : For `p : ℝ`, `λ x, x ^ p` is convex on $[0, +∞)$ when
  `1 ≤ p` and strictly convex when `1 < p`.
* `strict_concave_on_log_Ioi`, `strict_concave_on_log_Iio`: `real.log` is strictly concave on
  $(0, +∞)$ and $(-∞, 0)$ respectively.

## TODO

For `p : ℝ`, prove that `λ x, x ^ p` is concave when `0 ≤ p ≤ 1` and strictly concave when
`0 < p < 1`.
-/

open real set
open_locale big_operators

/-- The norm of a real normed space is convex. Also see `seminorm.convex_on`. -/
lemma convex_on_norm {E : Type*} [normed_group E] [normed_space ℝ E] :
  convex_on ℝ univ (norm : E → ℝ) :=
⟨convex_univ, λ x y hx hy a b ha hb hab,
  calc ∥a • x + b • y∥ ≤ ∥a • x∥ + ∥b • y∥ : norm_add_le _ _
    ... = a * ∥x∥ + b * ∥y∥
        : by rw [norm_smul, norm_smul, real.norm_of_nonneg ha, real.norm_of_nonneg hb]⟩

/-- `exp` is strictly convex on the whole real line. -/
lemma strict_convex_on_exp : strict_convex_on ℝ univ exp :=
strict_convex_on_univ_of_deriv2_pos differentiable_exp (λ x, (iter_deriv_exp 2).symm ▸ exp_pos x)

/-- `exp` is convex on the whole real line. -/
lemma convex_on_exp : convex_on ℝ univ exp := strict_convex_on_exp.convex_on

/-- `x^n`, `n : ℕ` is convex on the whole real line whenever `n` is even -/
lemma even.convex_on_pow {n : ℕ} (hn : even n) : convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply convex_on_univ_of_deriv2_nonneg differentiable_pow,
  { simp only [deriv_pow', differentiable.mul, differentiable_const, differentiable_pow] },
  { intro x,
    rcases nat.even.sub_even hn (nat.even_bit0 1) with ⟨k, hk⟩,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub, hk, pow_mul'],
    exact mul_nonneg (nat.cast_nonneg _) (pow_two_nonneg _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on the whole real line whenever `n ≠ 0` is even. -/
lemma even.strict_convex_on_pow {n : ℕ} (hn : even n) (h : n ≠ 0) :
  strict_convex_on ℝ set.univ (λ x : ℝ, x^n) :=
begin
  apply strict_mono.strict_convex_on_univ_of_deriv differentiable_pow,
  rw deriv_pow',
  replace h := nat.pos_of_ne_zero h,
  exact strict_mono.const_mul (odd.strict_mono_pow $ nat.even.sub_odd h hn $ nat.odd_iff.2 rfl)
    (nat.cast_pos.2 h),
end

/-- `x^n`, `n : ℕ` is convex on `[0, +∞)` for all `n` -/
lemma convex_on_pow (n : ℕ) : convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply convex_on_of_deriv2_nonneg (convex_Ici _) (continuous_pow n).continuous_on
    differentiable_on_pow,
  { simp only [deriv_pow'], exact (@differentiable_on_pow ℝ _ _ _).const_mul (n : ℝ) },
  { intros x hx,
    rw [iter_deriv_pow, finset.prod_range_cast_nat_sub],
    exact mul_nonneg (nat.cast_nonneg _) (pow_nonneg (interior_subset hx) _) }
end

/-- `x^n`, `n : ℕ` is strictly convex on `[0, +∞)` for all `n` greater than `2`. -/
lemma strict_convex_on_pow {n : ℕ} (hn : 2 ≤ n) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^n) :=
begin
  apply strict_mono_on.strict_convex_on_of_deriv (convex_Ici _) (continuous_on_pow _)
    differentiable_on_pow,
  rw [deriv_pow', interior_Ici],
  exact λ x (hx : 0 < x) y hy hxy, mul_lt_mul_of_pos_left (pow_lt_pow_of_lt_left hxy hx.le $
    nat.sub_pos_of_lt hn) (nat.cast_pos.2 $ zero_lt_two.trans_le hn),
end

lemma finset.prod_nonneg_of_card_nonpos_even
  {α β : Type*} [linear_ordered_comm_ring β]
  {f : α → β} [decidable_pred (λ x, f x ≤ 0)]
  {s : finset α} (h0 : even (s.filter (λ x, f x ≤ 0)).card) :
  0 ≤ ∏ x in s, f x :=
calc 0 ≤ (∏ x in s, ((if f x ≤ 0 then (-1:β) else 1) * f x)) :
  finset.prod_nonneg (λ x _, by
    { split_ifs with hx hx, by simp [hx], simp at hx ⊢, exact le_of_lt hx })
... = _ : by rw [finset.prod_mul_distrib, finset.prod_ite, finset.prod_const_one,
  mul_one, finset.prod_const, neg_one_pow_eq_pow_mod_two, nat.even_iff.1 h0, pow_zero, one_mul]

lemma int_prod_range_nonneg (m : ℤ) (n : ℕ) (hn : even n) :
  0 ≤ ∏ k in finset.range n, (m - k) :=
begin
  rcases hn with ⟨n, rfl⟩,
  induction n with n ihn, { simp },
  rw [nat.succ_eq_add_one, mul_add, mul_one, bit0, ← add_assoc, finset.prod_range_succ,
    finset.prod_range_succ, mul_assoc],
  refine mul_nonneg ihn _, generalize : (1 + 1) * n = k,
  cases le_or_lt m k with hmk hmk,
  { have : m ≤ k + 1, from hmk.trans (lt_add_one ↑k).le,
    exact mul_nonneg_of_nonpos_of_nonpos (sub_nonpos_of_le hmk) (sub_nonpos_of_le this) },
  { exact mul_nonneg (sub_nonneg_of_le hmk.le) (sub_nonneg_of_le hmk) }
end

lemma int_prod_range_pos {m : ℤ} {n : ℕ} (hn : even n) (hm : m ∉ Ico (0 : ℤ) n) :
  0 < ∏ k in finset.range n, (m - k) :=
begin
  refine (int_prod_range_nonneg m n hn).lt_of_ne (λ h, hm _),
  rw [eq_comm, finset.prod_eq_zero_iff] at h,
  obtain ⟨a, ha, h⟩ := h,
  rw sub_eq_zero.1 h,
  exact ⟨int.coe_zero_le _, int.coe_nat_lt.2 $ finset.mem_range.1 ha⟩,
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` -/
lemma convex_on_zpow (m : ℤ) : convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply convex_on_of_deriv2_nonneg (convex_Ioi 0);
    try { simp only [interior_Ioi, deriv_zpow'] },
  { exact (this _).continuous_on },
  { exact this _ },
  { exact (this _).const_mul _ },
  { intros x hx,
    simp only [iter_deriv_zpow, ← int.cast_coe_nat, ← int.cast_sub, ← int.cast_prod],
    refine mul_nonneg (int.cast_nonneg.2 _) (zpow_nonneg (le_of_lt hx) _),
    exact int_prod_range_nonneg _ _ (nat.even_bit0 1) }
end

/-- `x^m`, `m : ℤ` is convex on `(0, +∞)` for all `m` except `0` and `1`. -/
lemma strict_convex_on_zpow {m : ℤ} (hm₀ : m ≠ 0) (hm₁ : m ≠ 1) :
  strict_convex_on ℝ (Ioi 0) (λ x : ℝ, x^m) :=
begin
  have : ∀ n : ℤ, differentiable_on ℝ (λ x, x ^ n) (Ioi (0 : ℝ)),
    from λ n, differentiable_on_zpow _ _ (or.inl $ lt_irrefl _),
  apply strict_convex_on_of_deriv2_pos (convex_Ioi 0),
  { exact (this _).continuous_on },
   all_goals { rw interior_Ioi },
  { exact this _ },
  intros x hx,
  simp only [iter_deriv_zpow, ← int.cast_coe_nat, ← int.cast_sub, ← int.cast_prod],
  refine mul_pos (int.cast_pos.2 _) (zpow_pos_of_pos hx _),
  refine int_prod_range_pos (nat.even_bit0 1) (λ hm, _),
  norm_cast at hm,
  rw ←finset.coe_Ico at hm,
  fin_cases hm,
  { exact hm₀ rfl },
  { exact hm₁ rfl }
end

lemma convex_on_rpow {p : ℝ} (hp : 1 ≤ p) : convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp] },
  apply convex_on_of_deriv2_nonneg (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp)) },
  { exact (differentiable_rpow_const hp).differentiable_on },
  { rw A,
    assume x hx,
    replace hx : x ≠ 0, by { simp at hx, exact ne_of_gt hx },
    simp [differentiable_at.differentiable_within_at, hx] },
  { assume x hx,
    replace hx : 0 < x, by simpa using hx,
    suffices : 0 ≤ p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
    apply mul_nonneg (le_trans zero_le_one hp),
    exact mul_nonneg (sub_nonneg_of_le hp) (rpow_nonneg_of_nonneg hx.le _) }
end

lemma strict_convex_on_rpow {p : ℝ} (hp : 1 < p) : strict_convex_on ℝ (Ici 0) (λ x : ℝ, x^p) :=
begin
  have A : deriv (λ (x : ℝ), x ^ p) = λ x, p * x^(p-1), by { ext x, simp [hp.le] },
  apply strict_convex_on_of_deriv2_pos (convex_Ici 0),
  { exact continuous_on_id.rpow_const (λ x _, or.inr (zero_le_one.trans hp.le)) },
  { exact (differentiable_rpow_const hp.le).differentiable_on },
  rw interior_Ici,
  rintro x (hx : 0 < x),
  suffices : 0 < p * ((p - 1) * x ^ (p - 1 - 1)), by simpa [ne_of_gt hx, A],
  exact mul_pos (zero_lt_one.trans hp) (mul_pos (sub_pos_of_lt hp) (rpow_pos_of_pos hx _)),
end

lemma strict_concave_on_log_Ioi : strict_concave_on ℝ (Ioi 0) log :=
begin
  have h₁ : Ioi 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : 0 < x) (hx' : x = 0), hx.ne' hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Ioi 0) is_open_Ioi
    (differentiable_on_log.mono h₁) (λ x (hx : 0 < x), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne'),
end

lemma strict_concave_on_log_Iio : strict_concave_on ℝ (Iio 0) log :=
begin
  have h₁ : Iio 0 ⊆ ({0} : set ℝ)ᶜ,
  { exact λ x (hx : x < 0) (hx' : x = 0), hx.ne hx' },
  refine strict_concave_on_open_of_deriv2_neg (convex_Iio 0) is_open_Iio
    (differentiable_on_log.mono h₁) (λ x (hx : x < 0), _),
  rw [function.iterate_succ, function.iterate_one],
  change (deriv (deriv log)) x < 0,
  rw [deriv_log', deriv_inv],
  exact neg_neg_of_pos (inv_pos.2 $ sq_pos_of_ne_zero _ hx.ne),
end


/-
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, Mario Carneiro
-/
import data.fintype.basic

/-!
# Finite sets

This file defines predicates `finite : set α → Prop` and `infinite : set α → Prop` and proves some
basic facts about finite sets.
-/

open set function

universes u v w x
variables {α : Type u} {β : Type v} {ι : Sort w} {γ : Type x}

namespace set

/-- A set is finite if the subtype is a fintype, i.e. there is a
  list that enumerates its members. -/
def finite (s : set α) : Prop := nonempty (fintype s)

/-- A set is infinite if it is not finite. -/
def infinite (s : set α) : Prop := ¬ finite s

/-- The subtype corresponding to a finite set is a finite type. Note
that because `finite` isn't a typeclass, this will not fire if it
is made into an instance -/
noncomputable def finite.fintype {s : set α} (h : finite s) : fintype s :=
classical.choice h

/-- Get a finset from a finite set -/
noncomputable def finite.to_finset {s : set α} (h : finite s) : finset α :=
@set.to_finset _ _ h.fintype

@[simp] theorem finite.mem_to_finset {s : set α} (h : finite s) {a : α} : a ∈ h.to_finset ↔ a ∈ s :=
@mem_to_finset _ _ h.fintype _

@[simp] theorem finite.to_finset.nonempty {s : set α} (h : finite s) :
  h.to_finset.nonempty ↔ s.nonempty :=
show (∃ x, x ∈ h.to_finset) ↔ (∃ x, x ∈ s),
from exists_congr (λ _, h.mem_to_finset)

@[simp] lemma finite.coe_to_finset {s : set α} (h : finite s) : ↑h.to_finset = s :=
@set.coe_to_finset _ s h.fintype

@[simp] lemma finite_empty_to_finset (h : finite (∅ : set α)) : h.to_finset = ∅ :=
by rw [← finset.coe_inj, h.coe_to_finset, finset.coe_empty]

@[simp] lemma finite.to_finset_inj {s t : set α} {hs : finite s} {ht : finite t} :
  hs.to_finset = ht.to_finset ↔ s = t :=
by simp [←finset.coe_inj]

@[simp] lemma finite_to_finset_eq_empty_iff {s : set α} {h : finite s} :
  h.to_finset = ∅ ↔ s = ∅ :=
by simp [←finset.coe_inj]

theorem finite.exists_finset {s : set α} : finite s →
  ∃ s' : finset α, ∀ a : α, a ∈ s' ↔ a ∈ s
| ⟨h⟩ := by exactI ⟨to_finset s, λ _, mem_to_finset⟩

theorem finite.exists_finset_coe {s : set α} (hs : finite s) :
  ∃ s' : finset α, ↑s' = s :=
⟨hs.to_finset, hs.coe_to_finset⟩

/-- Finite sets can be lifted to finsets. -/
instance : can_lift (set α) (finset α) :=
{ coe := coe,
  cond := finite,
  prf := λ s hs, hs.exists_finset_coe }

theorem finite_mem_finset (s : finset α) : finite {a | a ∈ s} :=
⟨fintype.of_finset s (λ _, iff.rfl)⟩

theorem finite.of_fintype [fintype α] (s : set α) : finite s :=
by classical; exact ⟨set_fintype s⟩

theorem exists_finite_iff_finset {p : set α → Prop} :
  (∃ s, finite s ∧ p s) ↔ ∃ s : finset α, p ↑s :=
⟨λ ⟨s, hs, hps⟩, ⟨hs.to_finset, hs.coe_to_finset.symm ▸ hps⟩,
  λ ⟨s, hs⟩, ⟨↑s, finite_mem_finset s, hs⟩⟩

lemma finite.fin_embedding {s : set α} (h : finite s) : ∃ (n : ℕ) (f : fin n ↪ α), range f = s :=
⟨_, (fintype.equiv_fin (h.to_finset : set α)).symm.as_embedding, by simp⟩

lemma finite.fin_param {s : set α} (h : finite s) :
  ∃ (n : ℕ) (f : fin n → α), injective f ∧ range f = s :=
let ⟨n, f, hf⟩ := h.fin_embedding in ⟨n, f, f.injective, hf⟩

/-- Membership of a subset of a finite type is decidable.

Using this as an instance leads to potential loops with `subtype.fintype` under certain decidability
assumptions, so it should only be declared a local instance. -/
def decidable_mem_of_fintype [decidable_eq α] (s : set α) [fintype s] (a) : decidable (a ∈ s) :=
decidable_of_iff _ mem_to_finset

instance fintype_empty : fintype (∅ : set α) :=
fintype.of_finset ∅ $ by simp

theorem empty_card : fintype.card (∅ : set α) = 0 := rfl

@[simp] theorem empty_card' {h : fintype.{u} (∅ : set α)} :
  @fintype.card (∅ : set α) h = 0 :=
eq.trans (by congr) empty_card

@[simp] theorem finite_empty : @finite α ∅ := ⟨set.fintype_empty⟩

instance finite.inhabited : inhabited {s : set α // finite s} := ⟨⟨∅, finite_empty⟩⟩

/-- A `fintype` structure on `insert a s`. -/
def fintype_insert' {a : α} (s : set α) [fintype s] (h : a ∉ s) : fintype (insert a s : set α) :=
fintype.of_finset ⟨a ::ₘ s.to_finset.1,
  multiset.nodup_cons_of_nodup (by simp [h]) s.to_finset.2⟩ $ by simp

theorem card_fintype_insert' {a : α} (s : set α) [fintype s] (h : a ∉ s) :
  @fintype.card _ (fintype_insert' s h) = fintype.card s + 1 :=
by rw [fintype_insert', fintype.card_of_finset];
   simp [finset.card, to_finset]; refl

@[simp] theorem card_insert {a : α} (s : set α)
  [fintype s] (h : a ∉ s) {d : fintype.{u} (insert a s : set α)} :
  @fintype.card _ d = fintype.card s + 1 :=
by rw ← card_fintype_insert' s h; congr

lemma card_image_of_inj_on {s : set α} [fintype s]
  {f : α → β} [fintype (f '' s)] (H : ∀x∈s, ∀y∈s, f x = f y → x = y) :
  fintype.card (f '' s) = fintype.card s :=
by haveI := classical.prop_decidable; exact
calc fintype.card (f '' s) = (s.to_finset.image f).card : fintype.card_of_finset' _ (by simp)
... = s.to_finset.card : finset.card_image_of_inj_on
    (λ x hx y hy hxy, H x (mem_to_finset.1 hx) y (mem_to_finset.1 hy) hxy)
... = fintype.card s : (fintype.card_of_finset' _ (λ a, mem_to_finset)).symm

lemma card_image_of_injective (s : set α) [fintype s]
  {f : α → β} [fintype (f '' s)] (H : function.injective f) :
  fintype.card (f '' s) = fintype.card s :=
card_image_of_inj_on $ λ _ _ _ _ h, H h

section

local attribute [instance] decidable_mem_of_fintype

instance fintype_insert [decidable_eq α] (a : α) (s : set α) [fintype s] :
  fintype (insert a s : set α) :=
if h : a ∈ s then by rwa [insert_eq, union_eq_self_of_subset_left (singleton_subset_iff.2 h)]
else fintype_insert' _ h

end

@[simp] theorem finite.insert (a : α) {s : set α} : finite s → finite (insert a s)
| ⟨h⟩ := ⟨@set.fintype_insert _ (classical.dec_eq α) _ _ h⟩

lemma to_finset_insert [decidable_eq α] {a : α} {s : set α} (hs : finite s) :
  (hs.insert a).to_finset = insert a hs.to_finset :=
finset.ext $ by simp

@[simp] lemma insert_to_finset [decidable_eq α] {a : α} {s : set α} [fintype s] :
  (insert a s).to_finset = insert a s.to_finset :=
by simp [finset.ext_iff, mem_insert_iff]

@[elab_as_eliminator]
theorem finite.induction_on {C : set α → Prop} {s : set α} (h : finite s)
  (H0 : C ∅) (H1 : ∀ {a s}, a ∉ s → finite s → C s → C (insert a s)) : C s :=
let ⟨t⟩ := h in by exactI
match s.to_finset, @mem_to_finset _ s _ with
| ⟨l, nd⟩, al := begin
    change ∀ a, a ∈ l ↔ a ∈ s at al,
    clear _let_match _match t h, revert s nd al,
    refine multiset.induction_on l _ (λ a l IH, _); intros s nd al,
    { rw show s = ∅, from eq_empty_iff_forall_not_mem.2 (by simpa using al),
      exact H0 },
    { rw ← show insert a {x | x ∈ l} = s, from set.ext (by simpa using al),
      cases multiset.nodup_cons.1 nd with m nd',
      refine H1 _ ⟨finset.subtype.fintype ⟨l, nd'⟩⟩ (IH nd' (λ _, iff.rfl)),
      exact m }
  end
end

@[elab_as_eliminator]
theorem finite.dinduction_on {C : ∀s:set α, finite s → Prop} {s : set α} (h : finite s)
  (H0 : C ∅ finite_empty)
  (H1 : ∀ {a s}, a ∉ s → ∀h:finite s, C s h → C (insert a s) (h.insert a)) :
  C s h :=
have ∀h:finite s, C s h,
  from finite.induction_on h (assume h, H0) (assume a s has hs ih h, H1 has hs (ih _)),
this h

instance fintype_singleton (a : α) : fintype ({a} : set α) :=
unique.fintype

@[simp] theorem card_singleton (a : α) :
  fintype.card ({a} : set α) = 1 :=
fintype.card_of_subsingleton _

@[simp] theorem finite_singleton (a : α) : finite ({a} : set α) :=
⟨set.fintype_singleton _⟩

lemma subsingleton.finite {s : set α} (h : s.subsingleton) : finite s :=
h.induction_on finite_empty finite_singleton

instance fintype_pure : ∀ a : α, fintype (pure a : set α) :=
set.fintype_singleton

theorem finite_pure (a : α) : finite (pure a : set α) :=
⟨set.fintype_pure a⟩

instance fintype_univ [fintype α] : fintype (@univ α) :=
fintype.of_equiv α $ (equiv.set.univ α).symm

theorem finite_univ [fintype α] : finite (@univ α) := ⟨set.fintype_univ⟩

/-- If `(set.univ : set α)` is finite then `α` is a finite type. -/
noncomputable def fintype_of_univ_finite (H : (univ : set α).finite ) :
  fintype α :=
@fintype.of_equiv _ (univ : set α) H.fintype (equiv.set.univ _)

lemma univ_finite_iff_nonempty_fintype :
  (univ : set α).finite ↔ nonempty (fintype α) :=
begin
  split,
  { intro h, exact ⟨fintype_of_univ_finite h⟩ },
  { rintro ⟨_i⟩, exactI finite_univ }
end

theorem infinite_univ_iff : (@univ α).infinite ↔ _root_.infinite α :=
⟨λ h₁, ⟨λ h₂, h₁ $ @finite_univ α h₂⟩, λ ⟨h₁⟩ h₂, h₁ (fintype_of_univ_finite h₂)⟩

theorem infinite_univ [h : _root_.infinite α] : infinite (@univ α) :=
infinite_univ_iff.2 h

theorem infinite_coe_iff {s : set α} : _root_.infinite s ↔ infinite s :=
⟨λ ⟨h₁⟩ h₂, h₁ h₂.some, λ h₁, ⟨λ h₂, h₁ ⟨h₂⟩⟩⟩

theorem infinite.to_subtype {s : set α} (h : infinite s) : _root_.infinite s :=
infinite_coe_iff.2 h

/-- Embedding of `ℕ` into an infinite set. -/
noncomputable def infinite.nat_embedding (s : set α) (h : infinite s) : ℕ ↪ s :=
by { haveI := h.to_subtype, exact infinite.nat_embedding s }

lemma infinite.exists_subset_card_eq {s : set α} (hs : infinite s) (n : ℕ) :
  ∃ t : finset α, ↑t ⊆ s ∧ t.card = n :=
⟨((finset.range n).map (hs.nat_embedding _)).map (embedding.subtype _), by simp⟩

lemma infinite.nonempty {s : set α} (h : s.infinite) : s.nonempty :=
let a := infinite.nat_embedding s h 37 in ⟨a.1, a.2⟩

instance fintype_union [decidable_eq α] (s t : set α) [fintype s] [fintype t] :
  fintype (s ∪ t : set α) :=
fintype.of_finset (s.to_finset ∪ t.to_finset) $ by simp

theorem finite.union {s t : set α} : finite s → finite t → finite (s ∪ t)
| ⟨hs⟩ ⟨ht⟩ := ⟨@set.fintype_union _ (classical.dec_eq α) _ _ hs ht⟩

lemma finite.sup {s t : set α} : finite s → finite t → finite (s ⊔ t) := finite.union

lemma infinite_of_finite_compl {α : Type} [_root_.infinite α] {s : set α}
  (hs : sᶜ.finite) : s.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)

lemma finite.infinite_compl {α : Type} [_root_.infinite α] {s : set α}
  (hs : s.finite) : sᶜ.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)

instance fintype_sep (s : set α) (p : α → Prop) [fintype s] [decidable_pred p] :
  fintype ({a ∈ s | p a} : set α) :=
fintype.of_finset (s.to_finset.filter p) $ by simp

instance fintype_inter (s t : set α) [fintype s] [decidable_pred t] : fintype (s ∩ t : set α) :=
set.fintype_sep s t

/-- A `fintype` structure on a set defines a `fintype` structure on its subset. -/
def fintype_subset (s : set α) {t : set α} [fintype s] [decidable_pred t] (h : t ⊆ s) : fintype t :=
by rw ← inter_eq_self_of_subset_right h; apply_instance

theorem finite.subset {s : set α} : finite s → ∀ {t : set α}, t ⊆ s → finite t
| ⟨hs⟩ t h := ⟨@set.fintype_subset _ _ _ hs (classical.dec_pred t) h⟩

lemma finite.union_iff {s t : set α} : finite (s ∪ t) ↔ finite s ∧ finite t :=
⟨λ h, ⟨h.subset (subset_union_left _ _), h.subset (subset_union_right _ _)⟩,
 λ ⟨hs, ht⟩, hs.union ht⟩

lemma finite.diff {s t u : set α} (hs : s.finite) (ht : t.finite) (h : u \ t ≤ s) : u.finite :=
begin
  refine finite.subset (ht.union hs) _,
  exact diff_subset_iff.mp h
end

theorem finite.inter_of_left {s : set α} (h : finite s) (t : set α) : finite (s ∩ t) :=
h.subset (inter_subset_left _ _)

theorem finite.inter_of_right {s : set α} (h : finite s) (t : set α) : finite (t ∩ s) :=
h.subset (inter_subset_right _ _)

theorem finite.inf_of_left {s : set α} (h : finite s) (t : set α) : finite (s ⊓ t) :=
h.inter_of_left t

theorem finite.inf_of_right {s : set α} (h : finite s) (t : set α) : finite (t ⊓ s) :=
h.inter_of_right t

theorem infinite_mono {s t : set α} (h : s ⊆ t) : infinite s → infinite t :=
mt (λ ht, ht.subset h)

instance fintype_image [decidable_eq β] (s : set α) (f : α → β) [fintype s] : fintype (f '' s) :=
fintype.of_finset (s.to_finset.image f) $ by simp

instance fintype_range [decidable_eq β] (f : α → β) [fintype α] : fintype (range f) :=
fintype.of_finset (finset.univ.image f) $ by simp [range]

theorem finite_range (f : α → β) [fintype α] : finite (range f) :=
by haveI := classical.dec_eq β; exact ⟨by apply_instance⟩

theorem finite.image {s : set α} (f : α → β) : finite s → finite (f '' s)
| ⟨h⟩ := ⟨@set.fintype_image _ _ (classical.dec_eq β) _ _ h⟩

theorem infinite_of_infinite_image (f : α → β) {s : set α} (hs : (f '' s).infinite) :
  s.infinite :=
mt (finite.image f) hs

lemma finite.dependent_image {s : set α} (hs : finite s) (F : Π i ∈ s, β) :
  finite {y : β | ∃ x (hx : x ∈ s), y = F x hx} :=
begin
  letI : fintype s := hs.fintype,
  convert finite_range (λ x : s, F x x.2),
  simp only [set_coe.exists, subtype.coe_mk, eq_comm],
end

theorem finite.of_preimage {f : α → β} {s : set β} (h : finite (f ⁻¹' s)) (hf : surjective f) :
  finite s :=
hf.image_preimage s ▸ h.image _

instance fintype_map {α β} [decidable_eq β] :
  ∀ (s : set α) (f : α → β) [fintype s], fintype (f <$> s) := set.fintype_image

theorem finite.map {α β} {s : set α} :
  ∀ (f : α → β), finite s → finite (f <$> s) := finite.image

/-- If a function `f` has a partial inverse and sends a set `s` to a set with `[fintype]` instance,
then `s` has a `fintype` structure as well. -/
def fintype_of_fintype_image (s : set α)
  {f : α → β} {g} (I : is_partial_inv f g) [fintype (f '' s)] : fintype s :=
fintype.of_finset ⟨_, @multiset.nodup_filter_map β α g _
  (@injective_of_partial_inv_right _ _ f g I) (f '' s).to_finset.2⟩ $ λ a,
begin
  suffices : (∃ b x, f x = b ∧ g b = some a ∧ x ∈ s) ↔ a ∈ s,
  by simpa [exists_and_distrib_left.symm, and.comm, and.left_comm, and.assoc],
  rw exists_swap,
  suffices : (∃ x, x ∈ s ∧ g (f x) = some a) ↔ a ∈ s, {simpa [and.comm, and.left_comm, and.assoc]},
  simp [I _, (injective_of_partial_inv I).eq_iff]
end

theorem finite_of_finite_image {s : set α} {f : α → β} (hi : set.inj_on f s) :
  finite (f '' s) → finite s | ⟨h⟩ :=
⟨@fintype.of_injective _ _ h (λa:s, ⟨f a.1, mem_image_of_mem f a.2⟩) $
  assume a b eq, subtype.eq $ hi a.2 b.2 $ subtype.ext_iff_val.1 eq⟩

theorem finite_image_iff {s : set α} {f : α → β} (hi : inj_on f s) :
  finite (f '' s) ↔ finite s :=
⟨finite_of_finite_image hi, finite.image _⟩

theorem infinite_image_iff {s : set α} {f : α → β} (hi : inj_on f s) :
  infinite (f '' s) ↔ infinite s :=
not_congr $ finite_image_iff hi

theorem infinite_of_inj_on_maps_to {s : set α} {t : set β} {f : α → β}
  (hi : inj_on f s) (hm : maps_to f s t) (hs : infinite s) : infinite t :=
infinite_mono (maps_to'.mp hm) $ (infinite_image_iff hi).2 hs

theorem infinite.exists_ne_map_eq_of_maps_to {s : set α} {t : set β} {f : α → β}
  (hs : infinite s) (hf : maps_to f s t) (ht : finite t) :
  ∃ (x ∈ s) (y ∈ s), x ≠ y ∧ f x = f y :=
begin
  unfreezingI { contrapose! ht },
  exact infinite_of_inj_on_maps_to (λ x hx y hy, not_imp_not.1 (ht x hx y hy)) hf hs
end

theorem infinite.exists_lt_map_eq_of_maps_to [linear_order α] {s : set α} {t : set β} {f : α → β}
  (hs : infinite s) (hf : maps_to f s t) (ht : finite t) :
  ∃ (x ∈ s) (y ∈ s), x < y ∧ f x = f y :=
let ⟨x, hx, y, hy, hxy, hf⟩ := hs.exists_ne_map_eq_of_maps_to hf ht
in hxy.lt_or_lt.elim (λ hxy, ⟨x, hx, y, hy, hxy, hf⟩) (λ hyx, ⟨y, hy, x, hx, hyx, hf.symm⟩)

theorem infinite_range_of_injective [_root_.infinite α] {f : α → β} (hi : injective f) :
  infinite (range f) :=
by { rw [←image_univ, infinite_image_iff (inj_on_of_injective hi _)], exact infinite_univ }

theorem infinite_of_injective_forall_mem [_root_.infinite α] {s : set β} {f : α → β}
  (hi : injective f) (hf : ∀ x : α, f x ∈ s) : infinite s :=
by { rw ←range_subset_iff at hf, exact infinite_mono hf (infinite_range_of_injective hi) }

theorem finite.preimage {s : set β} {f : α → β}
  (I : set.inj_on f (f⁻¹' s)) (h : finite s) : finite (f ⁻¹' s) :=
finite_of_finite_image I (h.subset (image_preimage_subset f s))

theorem finite.preimage_embedding {s : set β} (f : α ↪ β) (h : s.finite) : (f ⁻¹' s).finite :=
finite.preimage (λ _ _ _ _ h', f.injective h') h

lemma finite_option {s : set (option α)} : finite s ↔ finite {x : α | some x ∈ s} :=
⟨λ h, h.preimage_embedding embedding.some,
  λ h, ((h.image some).insert none).subset $
    λ x, option.cases_on x (λ _, or.inl rfl) (λ x hx, or.inr $ mem_image_of_mem _ hx)⟩

instance fintype_Union [decidable_eq α] {ι : Type*} [fintype ι]
  (f : ι → set α) [∀ i, fintype (f i)] : fintype (⋃ i, f i) :=
fintype.of_finset (finset.univ.bUnion (λ i, (f i).to_finset)) $ by simp

theorem finite_Union {ι : Type*} [fintype ι] {f : ι → set α} (H : ∀i, finite (f i)) :
  finite (⋃ i, f i) :=
⟨@set.fintype_Union _ (classical.dec_eq α) _ _ _ (λ i, finite.fintype (H i))⟩

/-- A union of sets with `fintype` structure over a set with `fintype` structure has a `fintype`
structure. -/
def fintype_bUnion [decidable_eq α] {ι : Type*} {s : set ι} [fintype s]
  (f : ι → set α) (H : ∀ i ∈ s, fintype (f i)) : fintype (⋃ i ∈ s, f i) :=
by rw bUnion_eq_Union; exact
@set.fintype_Union _ _ _ _ _ (by rintro ⟨i, hi⟩; exact H i hi)

instance fintype_bUnion' [decidable_eq α] {ι : Type*} {s : set ι} [fintype s]
  (f : ι → set α) [H : ∀ i, fintype (f i)] : fintype (⋃ i ∈ s, f i) :=
fintype_bUnion _ (λ i _, H i)

theorem finite.sUnion {s : set (set α)} (h : finite s) (H : ∀t∈s, finite t) : finite (⋃₀ s) :=
by rw sUnion_eq_Union; haveI := finite.fintype h;
   apply finite_Union; simpa using H

theorem finite.bUnion {α} {ι : Type*} {s : set ι} {f : Π i ∈ s, set α} :
  finite s → (∀ i ∈ s, finite (f i ‹_›)) → finite (⋃ i∈s, f i ‹_›)
| ⟨hs⟩ h := by rw [bUnion_eq_Union]; exactI finite_Union (λ i, h _ _)

theorem finite_Union_Prop {p : Prop} {f : p → set α} (hf : ∀ h, finite (f h)) :
  finite (⋃ h : p, f h) :=
by by_cases p; simp *

instance fintype_lt_nat (n : ℕ) : fintype {i | i < n} :=
fintype.of_finset (finset.range n) $ by simp

instance fintype_le_nat (n : ℕ) : fintype {i | i ≤ n} :=
by simpa [nat.lt_succ_iff] using set.fintype_lt_nat (n+1)

lemma finite_le_nat (n : ℕ) : finite {i | i ≤ n} := ⟨set.fintype_le_nat _⟩

lemma finite_lt_nat (n : ℕ) : finite {i | i < n} := ⟨set.fintype_lt_nat _⟩

instance fintype_prod (s : set α) (t : set β) [fintype s] [fintype t] : fintype (set.prod s t) :=
fintype.of_finset (s.to_finset.product t.to_finset) $ by simp

lemma finite.prod {s : set α} {t : set β} : finite s → finite t → finite (set.prod s t)
| ⟨hs⟩ ⟨ht⟩ := by exactI ⟨set.fintype_prod s t⟩

/-- `image2 f s t` is finitype if `s` and `t` are. -/
instance fintype_image2 [decidable_eq γ] (f : α → β → γ) (s : set α) (t : set β)
  [hs : fintype s] [ht : fintype t] : fintype (image2 f s t : set γ) :=
by { rw ← image_prod, apply set.fintype_image }

lemma finite.image2 (f : α → β → γ) {s : set α} {t : set β} (hs : finite s) (ht : finite t) :
  finite (image2 f s t) :=
by { rw ← image_prod, exact (hs.prod ht).image _ }

/-- If `s : set α` is a set with `fintype` instance and `f : α → set β` is a function such that
each `f a`, `a ∈ s`, has a `fintype` structure, then `s >>= f` has a `fintype` structure. -/
def fintype_bind {α β} [decidable_eq β] (s : set α) [fintype s]
  (f : α → set β) (H : ∀ a ∈ s, fintype (f a)) : fintype (s >>= f) :=
set.fintype_bUnion _ H

instance fintype_bind' {α β} [decidable_eq β] (s : set α) [fintype s]
  (f : α → set β) [H : ∀ a, fintype (f a)] : fintype (s >>= f) :=
fintype_bind _ _ (λ i _, H i)

theorem finite.bind {α β} {s : set α} {f : α → set β} (h : finite s) (hf : ∀ a ∈ s, finite (f a)) :
  finite (s >>= f) :=
h.bUnion hf

instance fintype_seq [decidable_eq β] (f : set (α → β)) (s : set α) [fintype f] [fintype s] :
  fintype (f.seq s) :=
by { rw seq_def, apply set.fintype_bUnion' }

instance fintype_seq' {α β : Type u} [decidable_eq β]
  (f : set (α → β)) (s : set α) [fintype f] [fintype s] :
  fintype (f <*> s) :=
set.fintype_seq f s

theorem finite.seq {f : set (α → β)} {s : set α} (hf : finite f) (hs : finite s) :
  finite (f.seq s) :=
by { rw seq_def, exact hf.bUnion (λ f _, hs.image _) }

theorem finite.seq' {α β : Type u} {f : set (α → β)} {s : set α} (hf : finite f) (hs : finite s) :
  finite (f <*> s) :=
hf.seq hs

/-- There are finitely many subsets of a given finite set -/
lemma finite.finite_subsets {α : Type u} {a : set α} (h : finite a) : finite {b | b ⊆ a} :=
begin
  -- we just need to translate the result, already known for finsets,
  -- to the language of finite sets
  let s : set (set α) := coe '' (↑(finset.powerset (finite.to_finset h)) : set (finset α)),
  have : finite s := (finite_mem_finset _).image _,
  apply this.subset,
  refine λ b hb, ⟨(h.subset hb).to_finset, _, finite.coe_to_finset _⟩,
  simpa [finset.subset_iff]
end

lemma exists_min_image [linear_order β] (s : set α) (f : α → β) (h1 : finite s) :
  s.nonempty → ∃ a ∈ s, ∀ b ∈ s, f a ≤ f b
| ⟨x, hx⟩ := by simpa only [exists_prop, finite.mem_to_finset]
  using h1.to_finset.exists_min_image f ⟨x, h1.mem_to_finset.2 hx⟩

lemma exists_max_image [linear_order β] (s : set α) (f : α → β) (h1 : finite s) :
  s.nonempty → ∃ a ∈ s, ∀ b ∈ s, f b ≤ f a
| ⟨x, hx⟩ := by simpa only [exists_prop, finite.mem_to_finset]
  using h1.to_finset.exists_max_image f ⟨x, h1.mem_to_finset.2 hx⟩

theorem exists_lower_bound_image [hα : nonempty α] [linear_order β] (s : set α) (f : α → β)
  (h : s.finite) : ∃ (a : α), ∀ b ∈ s, f a ≤ f b :=
begin
  by_cases hs : set.nonempty s,
  { exact let ⟨x₀, H, hx₀⟩ := set.exists_min_image s f h hs in ⟨x₀, λ x hx, hx₀ x hx⟩ },
  { exact nonempty.elim hα (λ a, ⟨a, λ x hx, absurd (set.nonempty_of_mem hx) hs⟩) }
end

theorem exists_upper_bound_image [hα : nonempty α] [linear_order β] (s : set α) (f : α → β)
  (h : s.finite) : ∃ (a : α), ∀ b ∈ s, f b ≤ f a :=
begin
  by_cases hs : set.nonempty s,
  { exact let ⟨x₀, H, hx₀⟩ := set.exists_max_image s f h hs in ⟨x₀, λ x hx, hx₀ x hx⟩ },
  { exact nonempty.elim hα (λ a, ⟨a, λ x hx, absurd (set.nonempty_of_mem hx) hs⟩) }
end

end set

namespace finset
variables [decidable_eq β]
variables {s : finset α}

lemma finite_to_set (s : finset α) : set.finite (↑s : set α) :=
set.finite_mem_finset s

@[simp] lemma coe_bUnion {f : α → finset β} : ↑(s.bUnion f) = (⋃x ∈ (↑s : set α), ↑(f x) : set β) :=
by simp [set.ext_iff]

@[simp] lemma finite_to_set_to_finset {α : Type*} (s : finset α) :
  (finite_to_set s).to_finset = s :=
by { ext, rw [set.finite.mem_to_finset, mem_coe] }

end finset

namespace set

/-- Finite product of finite sets is finite -/
lemma finite.pi {δ : Type*} [fintype δ] {κ : δ → Type*} {t : Π d, set (κ d)}
  (ht : ∀ d, (t d).finite) :
  (pi univ t).finite :=
begin
  classical,
  convert (fintype.pi_finset (λ d, (ht d).to_finset)).finite_to_set,
  ext,
  simp,
end

lemma eq_finite_Union_of_finite_subset_Union  {ι} {s : ι → set α} {t : set α} (tfin : finite t)
  (h : t ⊆ ⋃ i, s i) :
  ∃ I : set ι, (finite I) ∧ ∃ σ : {i | i ∈ I} → set α,
     (∀ i, finite (σ i)) ∧ (∀ i, σ i ⊆ s i) ∧ t = ⋃ i, σ i :=
let ⟨I, Ifin, hI⟩ := finite_subset_Union tfin h in
⟨I, Ifin, λ x, s x ∩ t,
    λ i, tfin.subset (inter_subset_right _ _),
    λ i, inter_subset_left _ _,
    begin
      ext x,
      rw mem_Union,
      split,
      { intro x_in,
        rcases mem_Union.mp (hI x_in) with ⟨i, _, ⟨hi, rfl⟩, H⟩,
        use [i, hi, H, x_in] },
      { rintros ⟨i, hi, H⟩,
        exact H }
    end⟩

/-- An increasing union distributes over finite intersection. -/
lemma Union_Inter_of_monotone {ι ι' α : Type*} [fintype ι] [linear_order ι']
  [nonempty ι'] {s : ι → ι' → set α} (hs : ∀ i, monotone (s i)) :
  (⋃ j : ι', ⋂ i : ι, s i j) = ⋂ i : ι, ⋃ j : ι', s i j :=
begin
  ext x, refine ⟨λ hx, Union_Inter_subset hx, λ hx, _⟩,
  simp only [mem_Inter, mem_Union, mem_Inter] at hx ⊢, choose j hj using hx,
  obtain ⟨j₀⟩ := show nonempty ι', by apply_instance,
  refine ⟨finset.univ.fold max j₀ j, λ i, hs i _ (hj i)⟩,
  rw [finset.fold_op_rel_iff_or (@le_max_iff _ _)],
  exact or.inr ⟨i, finset.mem_univ i, le_rfl⟩
end

instance nat.fintype_Iio (n : ℕ) : fintype (Iio n) :=
fintype.of_finset (finset.range n) $ by simp

/--
If `P` is some relation between terms of `γ` and sets in `γ`,
such that every finite set `t : set γ` has some `c : γ` related to it,
then there is a recursively defined sequence `u` in `γ`
so `u n` is related to the image of `{0, 1, ..., n-1}` under `u`.

(We use this later to show sequentially compact sets
are totally bounded.)
-/
lemma seq_of_forall_finite_exists  {γ : Type*}
  {P : γ → set γ → Prop} (h : ∀ t,  finite t → ∃ c, P c t) :
  ∃ u : ℕ → γ, ∀ n, P (u n) (u '' Iio n) :=
⟨λ n, @nat.strong_rec_on' (λ _, γ) n $ λ n ih, classical.some $ h
    (range $ λ m : Iio n, ih m.1 m.2)
    (finite_range _),
λ n, begin
  classical,
  refine nat.strong_rec_on' n (λ n ih, _),
  rw nat.strong_rec_on_beta', convert classical.some_spec (h _ _),
  ext x, split,
  { rintros ⟨m, hmn, rfl⟩, exact ⟨⟨m, hmn⟩, rfl⟩ },
  { rintros ⟨⟨m, hmn⟩, rfl⟩, exact ⟨m, hmn, rfl⟩ }
end⟩

lemma finite_range_ite {p : α → Prop} [decidable_pred p] {f g : α → β} (hf : finite (range f))
  (hg : finite (range g)) : finite (range (λ x, if p x then f x else g x)) :=
(hf.union hg).subset range_ite_subset

lemma finite_range_const {c : β} : finite (range (λ x : α, c)) :=
(finite_singleton c).subset range_const_subset

lemma range_find_greatest_subset {P : α → ℕ → Prop} [∀ x, decidable_pred (P x)] {b : ℕ}:
  range (λ x, nat.find_greatest (P x) b) ⊆ ↑(finset.range (b + 1)) :=
by { rw range_subset_iff, assume x, simp [nat.lt_succ_iff, nat.find_greatest_le] }

lemma finite_range_find_greatest {P : α → ℕ → Prop} [∀ x, decidable_pred (P x)] {b : ℕ} :
  finite (range (λ x, nat.find_greatest (P x) b)) :=
(finset.range (b + 1)).finite_to_set.subset range_find_greatest_subset

lemma card_lt_card {s t : set α} [fintype s] [fintype t] (h : s ⊂ t) :
  fintype.card s < fintype.card t :=
fintype.card_lt_of_injective_not_surjective (set.inclusion h.1) (set.inclusion_injective h.1) $
  λ hst, (ssubset_iff_subset_ne.1 h).2 (eq_of_inclusion_surjective hst)

lemma card_le_of_subset {s t : set α} [fintype s] [fintype t] (hsub : s ⊆ t) :
  fintype.card s ≤ fintype.card t :=
fintype.card_le_of_injective (set.inclusion hsub) (set.inclusion_injective hsub)

lemma eq_of_subset_of_card_le {s t : set α} [fintype s] [fintype t]
   (hsub : s ⊆ t) (hcard : fintype.card t ≤ fintype.card s) : s = t :=
(eq_or_ssubset_of_subset hsub).elim id
  (λ h, absurd hcard $ not_le_of_lt $ card_lt_card h)

lemma subset_iff_to_finset_subset (s t : set α) [fintype s] [fintype t] :
  s ⊆ t ↔ s.to_finset ⊆ t.to_finset :=
by simp

@[simp, mono] lemma finite.to_finset_mono {s t : set α} {hs : finite s} {ht : finite t} :
  hs.to_finset ⊆ ht.to_finset ↔ s ⊆ t :=
begin
  split,
  { intros h x,
    rw [←finite.mem_to_finset hs, ←finite.mem_to_finset ht],
    exact λ hx, h hx },
  { intros h x,
    rw [finite.mem_to_finset hs, finite.mem_to_finset ht],
    exact λ hx, h hx }
end

@[simp, mono] lemma finite.to_finset_strict_mono {s t : set α} {hs : finite s} {ht : finite t} :
  hs.to_finset ⊂ ht.to_finset ↔ s ⊂ t :=
begin
  rw [←lt_eq_ssubset, ←finset.lt_iff_ssubset, lt_iff_le_and_ne, lt_iff_le_and_ne],
  simp
end

lemma card_range_of_injective [fintype α] {f : α → β} (hf : injective f)
  [fintype (range f)] : fintype.card (range f) = fintype.card α :=
eq.symm $ fintype.card_congr $ equiv.of_injective f hf

lemma finite.exists_maximal_wrt [partial_order β] (f : α → β) (s : set α) (h : set.finite s) :
  s.nonempty → ∃a∈s, ∀a'∈s, f a ≤ f a' → f a = f a' :=
begin
  classical,
  refine h.induction_on _ _,
  { assume h, exact absurd h empty_not_nonempty },
  assume a s his _ ih _,
  cases s.eq_empty_or_nonempty with h h,
  { use a, simp [h] },
  rcases ih h with ⟨b, hb, ih⟩,
  by_cases f b ≤ f a,
  { refine ⟨a, set.mem_insert _ _, assume c hc hac, le_antisymm hac _⟩,
    rcases set.mem_insert_iff.1 hc with rfl | hcs,
    { refl },
    { rwa [← ih c hcs (le_trans h hac)] } },
  { refine ⟨b, set.mem_insert_of_mem _ hb, assume c hc hbc, _⟩,
    rcases set.mem_insert_iff.1 hc with rfl | hcs,
    { exact (h hbc).elim },
    { exact ih c hcs hbc } }
end

lemma finite.card_to_finset {s : set α} [fintype s] (h : s.finite) :
  h.to_finset.card = fintype.card s :=
by { rw [← finset.card_attach, finset.attach_eq_univ, ← fintype.card], congr' 2, funext,
     rw set.finite.mem_to_finset }

section decidable_eq

lemma to_finset_compl {α : Type*} [fintype α] [decidable_eq α]
  (s : set α) [fintype (sᶜ : set α)] [fintype s] : sᶜ.to_finset = (s.to_finset)ᶜ :=
by ext; simp

lemma to_finset_inter {α : Type*} [decidable_eq α] (s t : set α) [fintype (s ∩ t : set α)]
  [fintype s] [fintype t] : (s ∩ t).to_finset = s.to_finset ∩ t.to_finset :=
by ext; simp

lemma to_finset_union {α : Type*} [decidable_eq α] (s t : set α) [fintype (s ∪ t : set α)]
  [fintype s] [fintype t] : (s ∪ t).to_finset = s.to_finset ∪ t.to_finset :=
by ext; simp

lemma to_finset_ne_eq_erase {α : Type*} [decidable_eq α] [fintype α] (a : α)
  [fintype {x : α | x ≠ a}] : {x : α | x ≠ a}.to_finset = finset.univ.erase a :=
by ext; simp

lemma card_ne_eq [fintype α] (a : α) [fintype {x : α | x ≠ a}] :
  fintype.card {x : α | x ≠ a} = fintype.card α - 1 :=
begin
  haveI := classical.dec_eq α,
  rw [←to_finset_card, to_finset_ne_eq_erase, finset.card_erase_of_mem (finset.mem_univ _),
      finset.card_univ, nat.pred_eq_sub_one],
end

end decidable_eq

section

variables [semilattice_sup α] [nonempty α] {s : set α}

/--A finite set is bounded above.-/
protected lemma finite.bdd_above (hs : finite s) : bdd_above s :=
finite.induction_on hs bdd_above_empty $ λ a s _ _ h, h.insert a

/--A finite union of sets which are all bounded above is still bounded above.-/
lemma finite.bdd_above_bUnion {I : set β} {S : β → set α} (H : finite I) :
  (bdd_above (⋃i∈I, S i)) ↔ (∀i ∈ I, bdd_above (S i)) :=
finite.induction_on H
  (by simp only [bUnion_empty, bdd_above_empty, ball_empty_iff])
  (λ a s ha _ hs, by simp only [bUnion_insert, ball_insert_iff, bdd_above_union, hs])

end

section

variables [semilattice_inf α] [nonempty α] {s : set α}

/--A finite set is bounded below.-/
protected lemma finite.bdd_below (hs : finite s) : bdd_below s :=
@finite.bdd_above (order_dual α) _ _ _ hs

/--A finite union of sets which are all bounded below is still bounded below.-/
lemma finite.bdd_below_bUnion {I : set β} {S : β → set α} (H : finite I) :
  (bdd_below (⋃i∈I, S i)) ↔ (∀i ∈ I, bdd_below (S i)) :=
@finite.bdd_above_bUnion (order_dual α) _ _ _ _ _ H

end

end set

namespace finset

/-- A finset is bounded above. -/
protected lemma bdd_above [semilattice_sup α] [nonempty α] (s : finset α) :
  bdd_above (↑s : set α) :=
s.finite_to_set.bdd_above

/-- A finset is bounded below. -/
protected lemma bdd_below [semilattice_inf α] [nonempty α] (s : finset α) :
  bdd_below (↑s : set α) :=
s.finite_to_set.bdd_below

end finset

namespace fintype
variables [fintype α] {p q : α → Prop} [decidable_pred p] [decidable_pred q]

@[simp]
lemma card_subtype_compl : fintype.card {x // ¬ p x} = fintype.card α - fintype.card {x // p x} :=
begin
  classical,
  rw [fintype.card_of_subtype (set.to_finset pᶜ), set.to_finset_compl p, finset.card_compl,
      fintype.card_of_subtype (set.to_finset p)];
    intros; simp; refl
end

/-- If two subtypes of a fintype have equal cardinality, so do their complements. -/
lemma card_compl_eq_card_compl (h : fintype.card {x // p x} = fintype.card {x // q x}) :
  fintype.card {x // ¬ p x} = fintype.card {x // ¬ q x} :=
by simp only [card_subtype_compl, h]

end fintype