import tactic data.vector

namespace exlean

open nat

section induction_on_nat

@[elab_as_eliminator, reducible]
def nat.ind (P : ℕ → Prop) (n : ℕ) (h₀ : P 0) (h₁ : ∀ (k : ℕ), P k → P k.succ) : P n :=
nat.rec_on n h₀ h₁

lemma add_zero (a : ℕ) : a + 0 = a := rfl

lemma add_succ (a b : ℕ) : a + succ b = succ (a + b) := rfl

def P := λ k, 0 + k = k

example : (P 0) = (0 = 0 + 0) := rfl

lemma base : P 0 := add_zero 0

lemma ind_step : ∀ k, P k → P k.succ :=
begin
  unfold P,
  intros k ih, -- k : ℕ, ih : 0 + k = k, ⊢ 0 + (succ k) = succ k
  rw add_succ, -- ⊢ succ (0 + k) = succ k
  rw ih, -- ⊢ succ k = succ k
end

example : ℕ := succ (succ zero)

lemma zero_add (a : ℕ) : 0 + a = a := nat.ind P a base ind_step

lemma zero_add' (a : ℕ) : 0 + a = a :=
begin
  let P := λ k, 0 + k = k,
  have h₀ : P 0, { dsimp [P], refl, },
  have h₁ : ∀ (k : ℕ), P k → P k.succ,
  { dsimp [P], intros k ih, rw add_succ, rw ih, },
  exact nat.ind P a h₀ h₁
end

lemma zero_add'' (a : ℕ) : 0 + a = a :=
begin
  apply nat.ind (λ k, 0 + k = k),
  { refl, },
  { intros k ih, rw [add_succ, ih], },
end

lemma zero_add_apply_placeholder (a : ℕ) : 0 + a = a :=
begin
  apply nat.ind _ a,
  { refl, },
  { intros k ih, rw [add_succ, ih], },
end

lemma zero_add_refine (a : ℕ) : 0 + a = a :=
begin
  refine nat.ind _ a rfl _,
  { intros k ih, rw [add_succ, ih], },
end

lemma zero_add''' : ∀ a : ℕ, 0 + a = a := @nat.rec (λ k, 0 + k = k) rfl (λ k ih,
  have h₂ : 0 + succ k = succ (0 + k) := add_succ 0 k,
  have h₃ : succ (0 + k) = succ k := ih.symm ▸ rfl,
  eq.trans h₂ h₃)

lemma zero_add'''' (a : ℕ) : 0 + a = a := nat.ind _ a rfl
(λ k ih, eq.trans (add_succ 0 k) (ih.symm ▸ rfl))

lemma zero_add''''' (a : ℕ) : 0 + a = a := nat.rec_on a rfl (λ k ih,
  have h₂ : 0 + succ k = succ (0 + k) := add_succ 0 k,
  have h₃ : succ (0 + k) = succ k := ih.symm ▸ rfl,
  eq.trans h₂ h₃)

end induction_on_nat

section recursively_defined_sequences_of_ints

-- Here is recursion principle for defining sequences of integers.
/- def nat.int_seq (n : ℕ) (h₀ : ℤ) (h₁ : ∀ (k : ℕ), ℤ → ℤ) : ℤ :=
nat.rec_on n h₀ h₁ -/

def nat.int_seq (n : ℕ) (a₀ : ℤ) (h : ∀ (k : ℕ) (ak : ℤ), ℤ) : ℤ :=
nat.rec_on n a₀ h

-- The following is a sequence of integers with `a₀ = 6` and `aₙ₊₁ = 5 + 2 * aₙ`.
def seq1 (n : ℕ) : ℤ := nat.int_seq n (6 : ℤ) (λ k ak, 5 + 2 * ak)

lemma seq1_succ (k : ℕ) : seq1 (succ k) = 5 + 2 * (seq1 k) := rfl

example : seq1 2 = 39 := dec_trivial

-- We can easily prove a formula for the n-th term of the sequence.

-- First using the `induction` tactic
lemma seq1_formula (n : ℕ) : seq1 n = 11 * 2 ^ n - 5 :=
begin
  induction n with k ih,
  { refl, },
  { rw [seq1_succ, ih], ring_exp, }
end

-- Second, using `apply nat.ind`.
lemma seq1_formula' (n : ℕ) : seq1 n = 11 * 2 ^ n - 5 :=
begin
  apply nat.ind (λ n, seq1 n = 11 * 2 ^ n - 5),
  { refl, },
  { intros k ih, rw [seq1_succ, ih], ring_exp, },
end

lemma seq1_formula''' (n : ℕ) : seq1 n = 11 * 2 ^ n - 5 :=
begin
  refine nat.ind _ n rfl _,
  { intros k ih, rw [seq1_succ, ih], ring_exp, },
end

-- Third, using `nat.ind` term-style.
lemma seq1_formula'' (n : ℕ) : seq1 n = 11 * 2 ^ n - 5 :=
nat.ind _ n rfl (λ k ih, by {rw [seq1_succ, ih], ring_exp })

-- Here's another sequence.
def triangle (n : ℕ) : ℤ := nat.int_seq n 0 (λ k ak, k + ak)

lemma triangle_succ (n : ℕ) : triangle (succ n) = n + triangle n := rfl

-- We prove the formula for the sum of the triangle numbers.
lemma triangle_formula (n : ℕ) : 2 * triangle (succ n) = n * (succ n) :=
begin
  refine nat.ind _ n rfl _,
  { intros k ih, rw [triangle_succ, mul_add, ih], ring, }
end

lemma triangle_formula' (n : ℕ) : 2 * triangle (succ n) = n * (succ n) :=
nat.ind _ n rfl (λ k ih, by { rw [triangle_succ, mul_add, ih], ring })

end recursively_defined_sequences_of_ints

section recursively_defined_sequences_of_nats

-- Here's a principle for defining sequences of natural numbers.
def nat.nat_seq (n : ℕ) (h₀ : ℕ) (h₁ : Π (k : ℕ), ℕ → ℕ) : ℕ :=
nat.rec_on n h₀ h₁

-- The following sequence is `a₀ = 6` and `aₙ₊₁ = 5 + 2 * aₙ`.
def seq2 (n : ℕ) : ℕ := nat.nat_seq n 6 (λ k seq_k, 5 + 2 * seq_k)

lemma seq2_succ (n : ℕ) : seq2 (succ n) = 5 + 2 * (seq2 n) := rfl

-- Proving a formula is tricker in the ℕ case than in the ℤ case.
-- One approach is to use an auxiliary result.
lemma seq2_formula' (n : ℕ) : 5 + seq2 n = 11 * 2 ^ n :=
begin
  induction n with n ih,
  { refl, },
  { have h : ∀ a, 5 + (5 + 2 * a) = 2 * (5 + a), { intro a, ring },
    simp only [seq2_succ, h, ih], ring_exp, }
end

lemma seq2_formula (n : ℕ) : seq2 n = 11 * 2 ^ n - 5 :=
begin
  symmetry,
  apply nat.sub_eq_of_eq_add,
  rw ←seq2_formula',
end

end recursively_defined_sequences_of_nats

section sequences_of_vectors

def natvec (k : ℕ) := vector ℕ (succ k)

-- A principle for defining sequences of vectors of natural numbers. The `n`th term in the sequence
-- is a vector of length `n + 1`.
def nat.vec_seq (n : ℕ) (a₀ : natvec 0) (h : Π (k : ℕ) (ak : natvec k), natvec (succ k)) :
  natvec n := nat.rec_on n a₀ h

-- A sequence of triangular numbers.
def vseq_triangle (n : ℕ) : natvec n :=
  nat.vec_seq n ⟨[0], rfl⟩ (λ k ak, vector.cons (k + ak.head) ak)

example : vseq_triangle 5 = ⟨[10, 6, 3, 1, 0, 0], _⟩ := rfl

-- A principle for defining sequences of vectors. The `n`th term in the sequence is a vector of
-- length `n`.
def nat.vec_seq_simple (n : ℕ) (h : Π (k : ℕ) (ak : vector ℕ k), vector ℕ (k+1)) : vector ℕ n :=
  nat.rec_on n vector.nil h

def vseq (n : ℕ) : vector ℕ n := nat.vec_seq_simple n (λ k ak, vector.cons (k*k) ak)

/--
A slighly different definition of a sequence of triangular numbers. We begin with an auxiliary function.
**Note** this is a bit of a cheat as pattern matching of course involves recursion. We'll redo this
in the next section.
-/
def next_vec : Π (k : ℕ), vector ℕ k → vector ℕ (k+1)
| 0       _   := ⟨[0], rfl⟩
| m@(a+1) am  := vector.cons (m + am.head) am

def vseq_triangle' (n : ℕ) : vector ℕ n :=
  nat.vec_seq_simple n next_vec

def vseq_triangle'' (n : ℕ) : vector ℕ n :=
  nat.vec_seq_simple n (λ k,
  match k with
  | 0       := λ ak, ⟨[0], rfl⟩
  | m@(a+1) := λ am, vector.cons (m + am.head) am
  end )

example : vseq_triangle' 6 = ⟨[15, 10, 6, 3, 1, 0], _⟩ := rfl

/-
Using the above idea, we can define the Fibonacci sequence. Again, we can do this with `nat.rec_on`
as we'll see later.
-/
def next_fib_cheat : Π (k : ℕ), vector ℕ k → vector ℕ (k+1)
| 0       _   := ⟨[1], rfl⟩
| 1       _   := ⟨[1,1], rfl⟩
| m@(a+2) am  := vector.cons (am.head + am.tail.head) am

def vseq_fib_cheat (n : ℕ) : vector ℕ n :=
  nat.vec_seq_simple n next_fib_cheat

example : vseq_fib_cheat 7 = ⟨[13, 8, 5, 3, 2, 1, 1], _⟩ := rfl

end sequences_of_vectors

universe u

section recursion_in_general

@[elab_as_eliminator, reducible]
def nat.rec_on' {C : ℕ → Sort u} (n : ℕ) (h₀ : C 0) (h₁ : Π (k : ℕ), C k → C k.succ) : C n :=
nat.rec_on n h₀ h₁

example (P : ℕ → Prop) (n : ℕ) (h₀ : P 0) (h₁ : ∀ (k : ℕ), P k → P k.succ) :
  @nat.ind P n h₀ h₁ = @nat.rec_on P n h₀ h₁ := rfl

example (n : ℕ) (a₀ : ℤ) (h : ∀ (k : ℕ) (ak : ℤ), ℤ) :
  nat.int_seq n a₀ h = @nat.rec_on' (λ (k : ℕ), ℤ) n a₀ h := rfl

example (n : ℕ) (a₀ : natvec 0) (h : Π (k : ℕ) (ak : natvec k), natvec (succ k)) :
  nat.vec_seq n a₀ h = @nat.rec_on' natvec n a₀ h := rfl

def next_vec' : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
begin
  intro k,
  refine nat.rec_on' k _ _,
  { intro am, exact ⟨[0], rfl⟩, },
  { intros m h am, exact vector.cons (m + am.head) am },
end

def next_vec'' : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
λ k, nat.rec_on k (λ am, ⟨[0], rfl⟩) (λ m h am, vector.cons (m + am.head) am)

def next_vec''' : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
λ k, nat.rec_on k (λ am, ⟨[0], rfl⟩) (λ m h am, vector.cons (m + am.head) am)

def vseq_triangle''' (n : ℕ) : vector ℕ n :=
  nat.vec_seq_simple n (λ k, nat.rec_on k (λ am, ⟨[0], rfl⟩) (λ m h am, vector.cons (m + am.head) am))

def vseq_triangle'''' (n : ℕ) : vector ℕ n :=
  nat.rec_on n vector.nil next_vec''

def next_fib : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
begin
  intro k,
  refine nat.rec_on' k _ _,
  { intro am, exact ⟨[1], rfl⟩, },
  { intros m h am,
    refine nat.rec_on' m _ _,
    { exact ⟨[1, 1], rfl⟩ },
    { intros c ac, exact vector.cons (ac.head + ac.tail.head) ac }, },
end

def next_fibbum : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
show Π (k : ℕ), vector ℕ k → vector ℕ (k+1),
{
  intro k,
  refine nat.rec_on' k _ _,
  { intro am, exact ⟨[1], rfl⟩, },
  { intros m h am,
    refine nat.rec_on' m _ _,
    { exact ⟨[1, 1], rfl⟩ },
    { intros c ac, exact vector.cons (ac.head + ac.tail.head) ac }, },
}

def next_fib'' : Π (k : ℕ), vector ℕ k → vector ℕ (k+1) :=
λ k, nat.rec_on' k (λ _, ⟨[1], rfl⟩) (λ m _ _, nat.rec_on' m ⟨[1,1], rfl⟩
  (λ _ ac, vector.cons (ac.head + ac.tail.head) ac))

def vfib (n : ℕ) : vector ℕ n :=
  nat.rec_on n vector.nil next_fib

lemma vfib_succ (n : ℕ) : vfib (succ (succ (succ n))) =
  vector.cons ( (vfib (succ (succ n))).head + (vfib (succ (succ n))).tail.head)
    (vfib (succ (succ n))) := rfl

lemma vfib_succ_tail (n : ℕ) : (vfib (succ n)).tail = vfib n :=
begin
  refine nat.rec_on n rfl _,
  intro k,
  refine nat.rec_on k _ _,
  { intro h, refl, },
  { intros m ih, rw vfib_succ, simp, },
end

lemma vfib_formula (n : ℕ) :
  (vfib (n+3)).head = (vfib (n+2)).head + (vfib (n+1)).head :=
by simp [vfib_succ, vfib_succ_tail]

def vseq1 (n : ℕ) : vector ℕ n := nat.rec_on' n vector.nil (λ k seq_k, vector.cons (k*k) seq_k)

def seq (n : ℕ) : ℕ := nat.rec_on' n 6 (λ k seq_k, 5 + 2 * seq_k)

def add_one (n : ℕ) : ℕ := nat.rec_on n 1 (λ k h, succ h)

def add_one' (n : ℕ) : ℕ := @nat.rec_on (λ x, ℕ) n 1 (λ k h, succ h)

def add_two (n : ℕ) : ℕ := nat.rec_on n 2 (λ k h, succ h)

def add_two' (n : ℕ) : ℕ := @nat.rec_on (λ x, ℕ) n 2 (λ k h, succ h)

example (n : ℕ) : add_two n = add_two' n := rfl

example : add_one 4 = 5 := rfl

example : add_two 4 = 6 := rfl

def myadd (m n : ℕ) : ℕ := nat.rec_on n m (λ k h, succ h)

example : myadd 11 5 = 16 := rfl

example : ∀ n, add_two n = myadd 2 n := λ n, rfl

lemma myadd_eq_add (m n : ℕ) : myadd m n = nat.add m n :=
begin
  apply nat.rec_on n,
  { refl, },
  { intros k ih,
    dsimp [myadd, nat.add] at *, rw ih, },
end

def mymul (m n : ℕ) : ℕ := nat.rec_on n 0 (λ k h, myadd h m)

lemma mymul_zero (m : ℕ) : mymul m 0 = 0 := rfl

lemma mymul_succ (m n : ℕ) : mymul m (succ n) = myadd (mymul m n) m := rfl

lemma mymul_eq_mul  (m n : ℕ) : mymul m n = nat.mul m n :=
begin
  induction n with k ih,
  { refl, },
  { dsimp [mymul, nat.mul] at *, rw ih, rw myadd_eq_add, refl, }
end

end recursion_in_general

end exlean


/-
To prove that (∃ (p : P), Q) we show that there
is a specific value, p, in the context of which
we can prove Q.
-/

/-
Here's a silly example. We want to show that
we can pick some natural number in the context
of which we can construct a proof of 1=1. Of
course it doesn't matter what number we pick
because 1=1 is true in any case. So in the
following example, we pick 524. But any value
will do.
-/

lemma silly : ∃ (n : ℕ), 1 = 1 :=
exists.intro 524 rfl

/-
The identifier, silly, is now bound to a
proof of ∃ (n : ℕ), 1 = 1, and we can see
that this proof is actually an ordered pair,
labelled by the exists.intro constructor, the
first element of which is a specific value of
type P and the second of which is a proof of Q.
-/

#reduce silly

/-
In practice, Q will almost always be a
predicate taking a value of type P. In
this case, ∃ (p : P), Q p asserts that
there is some value, p : P, that makes
the predicate, Q p true. In other words,
∃ (p : P), Q p asserts that there is some
p with propery Q.
-/

axiom Ball : Type   -- assume there are Balls
axioms b1 b2 : Ball -- b1 and b2 are balls
axiom Blue : Ball → Prop -- Blue is a property
axiom b1_is_blue : Blue b1 -- b1 is blue

-- Prove there exists a blue ball
example : ∃ (b : Ball), Blue b :=
-- use exists.intro
exists.intro
    b1          -- here's the ball we picked
    b1_is_blue  -- here's a proof it's Blue

/-
Here's another example. We'll define ev to be
a predicate specifying a property of natural
numbers of "being even". Then we'll show that
there exists a number that has this property.
-/

def even : ℕ → bool := λ n, n%2 = 0

example : exists (n : ℕ), even n :=
exists.intro 6 rfl

/-
The elimination rule for ∃ tells us what we
can do with a a proof of an existentially
quanitified proposition.

Suppose for example that we're given a proof
that there exists an even natural number. What
can we deduce from this fact? We can deduce
two things: first, there is a specific number
and *we can give it a name*, such as n, for
which, second, there is a proof, that we can
also name, e.g., pf, that *that specific n*
is even. This is the elimination rule.

It sounds complicated but it's not really.
Compare exists.intro and exists.elim to
and.intro and and.elim. The and.intro rule
takes two proofs and forms a pair. The and
elimination rule takes such a pair and lets
us get back (and give names to) the component
proofs. Similarly, exists.intro forms a pair,
of a value and a proof (usually a proof that
that specific value has some property); and
the exists.elimination rule, given a proof
that such a value exists, let's us then give
names to that value and the associated proof.
*We can then use those two values in building
other proofs*. And, as you might expect, we
bind names to the component elements of a
proof of ∃ (p : P), Q by case analysis, and
specifically by pattern matching.
-/

/-
Example: Assume there are people and a binary
predicate/relation called Likes.
-/
axiom Person : Prop
axiom Likes : Person → Person → Prop

/-
Show that if there exists someone everyone
likes then everyone likes someone.
-/
example :   (∃ (p : Person), ∀ (q : Person), Likes q p) →
            (∀ (p : Person), ∃ (q : Person), Likes p q):=
λ h,                -- assume proof of ∃ (n : ℕ), even n
    match h with    -- destructure this proof
    -- there's only one constructor, exists.intro
    -- give names to arguments to which it must have been applied
    | exists.intro beloved liked_by_all :=
    -- now use *these* (now named) values to constructed needed proof
        λ anyone,
            exists.intro beloved (liked_by_all beloved)
    end

/-
Here it is in plain English.

Suppose there's someone everyone likes. Show that everyone
likes someone.

Proof: From the fact that there exists someone that everyone
likes, we can deduce that (1) there is a specific person, who
everyone likes; let's call that person "beloved"; and (2) it
is the case that everyone likes beloved. Now we must show that
everyone likes someone. Pick an arbitrary but specific person,
call this person "anyone". We must show that there is someone
that "anyone" likes. But everyone likes beloved, so "anyone",
in particular, likes "beloved". Note: "anyone" might or might
not like other people, but we can be sure that "anyone" likes
beloved, and all we needed to show was that there is someone
that "anyone" likes. QED.
-/

/-
In Lean, if you already have a proof of some existentially
quantified proposition in your context, do case analysis on
it to assign names to its two components: first a value and
then a proof that that value makes the rest of the proposition
true. By the way, we call such a value a "witness" to the
given proposition.
-/


/-
THIS ASSIGNMENT IS DUE BEFORE NEXT CLASS.
WE WILL THEN REVIEW IT IN CLASS. FOLLOWING
THAT REVIEW WE WILL GIVE A BRIEF IN-CLASS,
GRADED EXERCISE TO TEST YOUR UNDERSTANDING.

This file comes in two parts. The first
part presents an example that you are to
read and understand. It's an example of
a proof of a bi-implication between two
equivalent disjunctions. The key lesson
it teaches is proof by *case analysis*.

When you are asked to prove that P ∨ Q
implies some conclusion, you do it by
case analysis. The idea is that if P ∨ Q
is true, there are two ways in which it
can be true: either P is true, or Q is
true. You have prove the goal follows
in either case. If the goal follows in
either case,  then it follows from the
disjunction, P ∨ Q, as a whole.

We use the "cases" tactic in lean to
reason about the two possible cases of
a proof of P ∨ Q. Using this tactic
produces two subgoals. In one case, P
is assumed to have a proof, p. In the
other case, Q is assumed to have a proof,
q. The aim then is to show that the main
goal follows in each case, as that will
then prove that the goal follows from
the disjunction as a whole.

The second part of this file presents a
problem for you to solve. One again it's
a bi-implication involving a disjunction
as a premise (in one direction but not in
the other direction).

In both of these parts, we, or you will,
start by applying iff.intro to split the
bi-implication into two implications to be proved.

Then in the subproblems with disjunctions
as premises, you will use case analysis.
A hint: Remember that ¬ X means X → false,
and the way to prove this is to assume X
and show this leads to a contradiction. It
is this maneuver that gets you a disjunction
as a premise in the problem you're to solve.
-/

-- PART I: A WORKED EXAMPLE

/-
We first show you how to prove P ∨ Q ↔ Q ∨ P.
At the highest level, the proof is by showing
the implication in each direction. Within each
direction, the proof is by case analysis for
the disjunction that forms the premise of the
implication. These ideas are explained in more
detail in the proof that follows.
-/

theorem
or_commutes :
    ∀ P Q: Prop, P ∨ Q ↔ Q ∨ P
:=
begin

/-
Introduce the assumptions that P and Q
are arbitrary propositions.
-/
assume P Q: Prop,

/-
To prove a bi-implication, we prove the
implications in each direction. That is,
we break the overall goal into subgoals,
one for the forward implication and one
for its converse (in the other direction).
-/
apply iff.intro,

    -- now we prove the forward implication
    assume pq : P ∨ Q,
    show Q ∨ P,
    from
        begin
        /-
        The key proof technique for reasoning
        from a proof of a disjunction, P ∨ Q,
        is to consider two possible cases for
        this proof, that either P is true or
        Q is, and to show that the goal is
        true in either case. This shows that
        no matter why P ∨ Q is true, the goal
        follows.

        So, the proof strategy is first to
        assumes that P ∨ Q is true because P
        is true, which is to say you assume
        you have a proof of P, and then show
        that the goal follows. Then you assume
        P ∨ Q is true because Q is true, and
        you show that given an assumed proof
        of Q, the goal follows. The goal thus
        follows in either case.

        The tactic that we use in Lean to
        reason by cases from a disjunction is
        called "cases." As arguments you give
        it (1) the name of the disjunction to
        reason from, and (2) names to use for
        the assumed proofs of P and Q in the
        respective cases (after keyword "with").

        So here we go. Make sure you have the
        Lean Messages window open so that you
        can see how "cases" changes your tactic
        state. Note that it introduces two new
        subgoals. In the first, there is an
        assumed proof, p : P. In the second,
        there is an an assumed proof q : Q.
        -/
        cases pq with p q,
        -- now prove each case separately

            -- proof for case where P is true
            show Q ∨ P,
            from or.intro_right Q p,

            -- proof for case where Q is true
            show Q ∨ P,
            from or.intro_left P q,
        end,

    -- and now we prove the converse
    assume qp : Q ∨ P,
    show P ∨ Q,
    from
        begin
        cases qp with q p,
            show P ∨ Q,
            from or.intro_right P q,
            show P ∨ Q,
            from or.intro_left Q p,
        end,
end

-- PART II: YOUR HOMEWORK ASSIGNMENT

/-
Homework:

Prove, ∀ P Q: Prop, ¬ P ∧ ¬ Q ↔ ¬ (P ∨ Q)

-/

theorem aDemorganLaw :
    ∀ P Q: Prop, ¬ P ∧ ¬ Q ↔ ¬ (P ∨ Q) :=
begin

    assume P Q : Prop,
    apply iff.intro,
    -- forward
    assume npnq : ¬ P ∧ ¬ Q,
    show ¬ (P ∨ Q),
    from
        begin
            assume pq : (P ∨ Q),
            cases pq with p q,

            show false,
            from npnq.1 p,

            show false,
            from npnq.2 q,
        end,

    --backwards
    assume nporq : ¬ (P ∨ Q),
    --show not p
    have np : ¬ P,
    from
        begin
        assume p : P,

        have  pq : (P ∨ Q),
        from
            begin
            apply or.intro_left,
            show P,
            from p,
            end,
<<<<<<< HEAD

        --left side
        -- to get a proof of ¬ P ∧ ¬ Q we need
        -- both ¬ P and ¬ Q and then use and.intro
        -- Show a contratradiction by first assuming
        -- P and Q are true, then show they must be
        -- false, then use and.intro
        assume nporq : ¬ (P ∨ Q),

        have np : ¬ P,
        from
            begin
            assume p : P,

            have porq : P ∨ Q,
            from
                begin
                apply or.intro_left,
                show P,
                from p,
                end,

            show false,
            from nporq porq,
            end,

        have nq : ¬ Q,
        from
            begin
            assume q : Q,

            have porq : P ∨ Q,
            from
                begin
                apply or.intro_right,
                show Q,
                from q,
                end,

            show false,
            from nporq porq,
            end,

        exact and.intro np nq
=======

        show false,
        from nporq pq,
        end,
    --show not
    have nq : ¬ Q,
    from
        begin
        assume q : Q,

        have pq : (P ∨ Q),
        from
            begin
            apply or.intro_right,
            show Q,
            from q,
            end,

        show false,
        from nporq pq,
        end,

>>>>>>> 7bf877fc487881e7123ecc6a6cc372d320cd5eed
end


variable (t1 t2 t3 t4 : Nat)
variable (pf12 : t1 = t2) (pf23 : t2 = t3) (pf34 : t3 = t4)

theorem foo : t1 = t4 :=
  calc
    t1 = t2 := pf12
    _  = t3 := pf23
    _  = t4 := pf34

variable (t5 : Nat)
variable (pf23' : t2 < t3) (pf45' : t4 < t5)

instance [LT α] : Trans (α := α) (· < ·) (· < ·) (· < ·) where
  trans := sorry

theorem foo₁ : t1 < t5 :=
  let p := calc
    t1 = t2 := pf12
    _  < t3 := pf23'
    _  = t4 := pf34
    _  < t5 := pf45'
  -- dedent terminates the block
  p

-- same-line `calc <first relation>` with normal indent afterwards
theorem foo₂ : t1 < t5 :=
  calc t1 = t2 := pf12
    _  < t3 := pf23'
    _  = t4 := pf34
    _  < t5 := pf45'

-- `calc <first relation LHS>\n<indent><relation and relation RHS>`
theorem foo₃ : t1 < t5 :=
  calc t1
      = t2 := pf12
    _ < t3 := pf23'
    _ = t4 := pf34
    _ < t5 := pf45'

-- `calc <first relation LHS>\n<indent><relation and relation RHS>`
theorem foo₄ : t1 < t5 :=
  calc t1 = t2 := pf12
       _  < t3 := pf23'
       _  = t4 := pf34
       _  < t5 := pf45'

-- `by` with indented sequence of tactics in `calc`-item RHS
theorem foo₅ : t1 = t4 :=
  calc
    t1 = t2 := pf12
    _  = t3 := by
      skip
      skip
      exact pf23
    _  = t4 := pf34

-- function application with indented argument in `calc`-item RHS
theorem foo₆ : t1 = t4 :=
  calc
    t1 = t2 := pf12
    _  = t3 := id
      pf23
    _  = t4 := pf34

-- `calc <first relation LHS>\n<indent>_ <rel> <rhs> := <proof>` (term)
theorem foo₇ : t1 < t5 :=
  calc t1
    _ = t2 := pf12
    _ < t3 := pf23'
    _ = t4 := pf34
    _ < t5 := pf45'

-- `calc <first relation LHS>\n<indent>_ <rel> <rhs> := <proof>` (tactic)
theorem foo₈ : t1 < t5 := by
  calc t1
    _ = t2 := pf12
    _ < t3 := pf23'
    _ = t4 := pf34
    _ < t5 := pf45'


-- El_producto_por_un_par_es_par.lean
-- El producto por un par es par.
-- José A. Alonso Jiménez <https://jaalonso.github.io>
-- Sevilla, 21-agosto-2022
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar que los productos de los números naturales por números
-- pares son pares.
-- ---------------------------------------------------------------------

import data.nat.parity
import tactic

open nat

-- 1ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  intros m n hn,
  unfold even at *,
  cases hn with k hk,
  use m * k,
  calc m * n
       = m * (k + k)   : congr_arg (has_mul.mul m) hk
   ... = m * k + m * k : mul_add m k k
end

-- 2ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  intros m n hn,
  cases hn with k hk,
  use m * k,
  calc m * n
       = m * (k + k)   : congr_arg (has_mul.mul m) hk
   ... = m * k + m * k : mul_add m k k
end

-- 3ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  rintros m n ⟨k, hk⟩,
  use m * k,
  calc m * n
       = m * (k + k)   : congr_arg (has_mul.mul m) hk
   ... = m * k + m * k : mul_add m k k
end

-- 4ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  rintros m n ⟨k, hk⟩,
  use m * k,
  rw hk,
  exact mul_add m k k,
end

-- 5ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  rintros m n ⟨k, hk⟩,
  use m * k,
  rw [hk, mul_add]
end

-- 6ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
begin
  rintros m n ⟨k, hk⟩,
  exact ⟨m * k, by rw [hk, mul_add]⟩
end

-- 7ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
λ m n ⟨k, hk⟩, ⟨m * k, by rw [hk, mul_add]⟩

-- 8ª demostración
example : ∀ m n : ℕ, even n → even (m * n) :=
  assume m n ⟨k, (hk : n = k + k)⟩,
  have hmn : m * n = m * k + m * k,
    by rw [hk, mul_add],
  show ∃ l, m * n = l + l,
    from ⟨_, hmn⟩


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen

! This file was ported from Lean 3 source module linear_algebra.matrix.trace
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Matrix.Basic

/-!
# Trace of a matrix

This file defines the trace of a matrix, the map sending a matrix to the sum of its diagonal
entries.

See also `linear_algebra.trace` for the trace of an endomorphism.

## Tags

matrix, trace, diagonal

-/

open BigOperators Matrix

namespace Matrix

variable {ι m n p : Type _} {α R S : Type _}

variable [Fintype m] [Fintype n] [Fintype p]

section AddCommMonoid

variable [AddCommMonoid R]

/-- The trace of a square matrix. For more bundled versions, see:
* `matrix.trace_add_monoid_hom`
* `matrix.trace_linear_map`
-/
def trace (A : Matrix n n R) : R :=
  ∑ i, diag A i
#align matrix.trace Matrix.trace

variable (n R)

@[simp]
theorem trace_zero : trace (0 : Matrix n n R) = 0 :=
  (Finset.sum_const (0 : R)).trans <| smul_zero _
#align matrix.trace_zero Matrix.trace_zero

variable {n R}

@[simp]
theorem trace_add (A B : Matrix n n R) : trace (A + B) = trace A + trace B :=
  Finset.sum_add_distrib
#align matrix.trace_add Matrix.trace_add

@[simp]
theorem trace_smul [Monoid α] [DistribMulAction α R] (r : α) (A : Matrix n n R) :
    trace (r • A) = r • trace A :=
  Finset.smul_sum.symm
#align matrix.trace_smul Matrix.trace_smul

@[simp]
theorem trace_transpose (A : Matrix n n R) : trace Aᵀ = trace A :=
  rfl
#align matrix.trace_transpose Matrix.trace_transpose

@[simp]
theorem trace_conjTranspose [StarAddMonoid R] (A : Matrix n n R) : trace Aᴴ = star (trace A) :=
  (star_sum _ _).symm
#align matrix.trace_conj_transpose Matrix.trace_conjTranspose

variable (n α R)

/-- `matrix.trace` as an `add_monoid_hom` -/
@[simps]
def traceAddMonoidHom : Matrix n n R →+ R
    where
  toFun := trace
  map_zero' := trace_zero n R
  map_add' := trace_add
#align matrix.trace_add_monoid_hom Matrix.traceAddMonoidHom

/-- `matrix.trace` as a `linear_map` -/
@[simps]
def traceLinearMap [Semiring α] [Module α R] : Matrix n n R →ₗ[α] R
    where
  toFun := trace
  map_add' := trace_add
  map_smul' := trace_smul
#align matrix.trace_linear_map Matrix.traceLinearMap

variable {n α R}

@[simp]
theorem trace_list_sum (l : List (Matrix n n R)) : trace l.Sum = (l.map trace).Sum :=
  map_list_sum (traceAddMonoidHom n R) l
#align matrix.trace_list_sum Matrix.trace_list_sum

@[simp]
theorem trace_multiset_sum (s : Multiset (Matrix n n R)) : trace s.Sum = (s.map trace).Sum :=
  map_multiset_sum (traceAddMonoidHom n R) s
#align matrix.trace_multiset_sum Matrix.trace_multiset_sum

@[simp]
theorem trace_sum (s : Finset ι) (f : ι → Matrix n n R) :
    trace (∑ i in s, f i) = ∑ i in s, trace (f i) :=
  map_sum (traceAddMonoidHom n R) f s
#align matrix.trace_sum Matrix.trace_sum

end AddCommMonoid

section AddCommGroup

variable [AddCommGroup R]

@[simp]
theorem trace_sub (A B : Matrix n n R) : trace (A - B) = trace A - trace B :=
  Finset.sum_sub_distrib
#align matrix.trace_sub Matrix.trace_sub

@[simp]
theorem trace_neg (A : Matrix n n R) : trace (-A) = -trace A :=
  Finset.sum_neg_distrib
#align matrix.trace_neg Matrix.trace_neg

end AddCommGroup

section One

variable [DecidableEq n] [AddCommMonoidWithOne R]

@[simp]
theorem trace_one : trace (1 : Matrix n n R) = Fintype.card n := by
  simp_rw [trace, diag_one, Pi.one_def, Finset.sum_const, nsmul_one, Finset.card_univ]
#align matrix.trace_one Matrix.trace_one

end One

section Mul

@[simp]
theorem trace_transpose_mul [AddCommMonoid R] [Mul R] (A : Matrix m n R) (B : Matrix n m R) :
    trace (Aᵀ ⬝ Bᵀ) = trace (A ⬝ B) :=
  Finset.sum_comm
#align matrix.trace_transpose_mul Matrix.trace_transpose_mul

theorem trace_mul_comm [AddCommMonoid R] [CommSemigroup R] (A : Matrix m n R) (B : Matrix n m R) :
    trace (A ⬝ B) = trace (B ⬝ A) := by rw [← trace_transpose, ← trace_transpose_mul, transpose_mul]
#align matrix.trace_mul_comm Matrix.trace_mul_comm

theorem trace_mul_cycle [NonUnitalCommSemiring R] (A : Matrix m n R) (B : Matrix n p R)
    (C : Matrix p m R) : trace (A ⬝ B ⬝ C) = trace (C ⬝ A ⬝ B) := by
  rw [trace_mul_comm, Matrix.mul_assoc]
#align matrix.trace_mul_cycle Matrix.trace_mul_cycle

theorem trace_mul_cycle' [NonUnitalCommSemiring R] (A : Matrix m n R) (B : Matrix n p R)
    (C : Matrix p m R) : trace (A ⬝ (B ⬝ C)) = trace (C ⬝ (A ⬝ B)) := by
  rw [← Matrix.mul_assoc, trace_mul_comm]
#align matrix.trace_mul_cycle' Matrix.trace_mul_cycle'

@[simp]
theorem trace_col_mul_row [NonUnitalNonAssocSemiring R] (a b : n → R) :
    trace (col a ⬝ row b) = dotProduct a b := by simp [dot_product, trace]
#align matrix.trace_col_mul_row Matrix.trace_col_mul_row

end Mul

section Fin

variable [AddCommMonoid R]

/-! ### Special cases for `fin n`

While `simp [fin.sum_univ_succ]` can prove these, we include them for convenience and consistency
with `matrix.det_fin_two` etc.
-/

@[simp]
theorem trace_fin_zero (A : Matrix (Fin 0) (Fin 0) R) : trace A = 0 :=
  rfl
#align matrix.trace_fin_zero Matrix.trace_fin_zero

theorem trace_fin_one (A : Matrix (Fin 1) (Fin 1) R) : trace A = A 0 0 :=
  add_zero _
#align matrix.trace_fin_one Matrix.trace_fin_one

theorem trace_fin_two (A : Matrix (Fin 2) (Fin 2) R) : trace A = A 0 0 + A 1 1 :=
  congr_arg ((· + ·) _) (add_zero (A 1 1))
#align matrix.trace_fin_two Matrix.trace_fin_two

theorem trace_fin_three (A : Matrix (Fin 3) (Fin 3) R) : trace A = A 0 0 + A 1 1 + A 2 2 :=
  by
  rw [← add_zero (A 2 2), add_assoc]
  rfl
#align matrix.trace_fin_three Matrix.trace_fin_three

end Fin

end Matrix


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module ring_theory.mv_polynomial.ideal
! leanprover-community/mathlib commit 72c366d0475675f1309d3027d3d7d47ee4423951
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.MonoidAlgebra.Ideal
import Mathbin.Data.MvPolynomial.Division

/-!
# Lemmas about ideals of `mv_polynomial`

Notably this contains results about monomial ideals.

## Main results

* `mv_polynomial.mem_ideal_span_monomial_image`
* `mv_polynomial.mem_ideal_span_X_image`
-/

variable {σ R : Type _}

namespace MvPolynomial

variable [CommSemiring R]

/-- `x` is in a monomial ideal generated by `s` iff every element of of its support dominates one of
the generators. Note that `si ≤ xi` is analogous to saying that the monomial corresponding to `si`
divides the monomial corresponding to `xi`. -/
theorem mem_ideal_span_monomial_image {x : MvPolynomial σ R} {s : Set (σ →₀ ℕ)} :
    x ∈ Ideal.span ((fun s => monomial s (1 : R)) '' s) ↔ ∀ xi ∈ x.support, ∃ si ∈ s, si ≤ xi :=
  by
  refine' add_monoid_algebra.mem_ideal_span_of'_image.trans _
  simp_rw [le_iff_exists_add, add_comm]
  rfl
#align mv_polynomial.mem_ideal_span_monomial_image MvPolynomial.mem_ideal_span_monomial_image

theorem mem_ideal_span_monomial_image_iff_dvd {x : MvPolynomial σ R} {s : Set (σ →₀ ℕ)} :
    x ∈ Ideal.span ((fun s => monomial s (1 : R)) '' s) ↔
      ∀ xi ∈ x.support, ∃ si ∈ s, monomial si 1 ∣ monomial xi (x.coeff xi) :=
  by
  refine' mem_ideal_span_monomial_image.trans (forall₂_congr fun xi hxi => _)
  simp_rw [monomial_dvd_monomial, one_dvd, and_true_iff, mem_support_iff.mp hxi, false_or_iff]
#align mv_polynomial.mem_ideal_span_monomial_image_iff_dvd MvPolynomial.mem_ideal_span_monomial_image_iff_dvd

/-- `x` is in a monomial ideal generated by variables `X` iff every element of of its support
has a component in `s`. -/
theorem mem_ideal_span_x_image {x : MvPolynomial σ R} {s : Set σ} :
    x ∈ Ideal.span (MvPolynomial.X '' s : Set (MvPolynomial σ R)) ↔
      ∀ m ∈ x.support, ∃ i ∈ s, (m : σ →₀ ℕ) i ≠ 0 :=
  by
  have := @mem_ideal_span_monomial_image σ R _ _ ((fun i => Finsupp.single i 1) '' s)
  rw [Set.image_image] at this
  refine' this.trans _
  simp [Nat.one_le_iff_ne_zero]
#align mv_polynomial.mem_ideal_span_X_image MvPolynomial.mem_ideal_span_x_image

end MvPolynomial


/-
Let X, Y, Z be sets, and let f : X → Y and g : Y → Z be functions.
(a) Given that g ∘ f is onto, can you deduce that f is onto? Give a proof
or a counterexample.
(b) Given that g ∘ f is onto, can you deduce that g is onto?
(c) Given that g ∘ f is 1-1, can you deduce that f is 1-1?
(d) Given that g ∘ f is 1-1, can you deduce that g is 1-1?
-/
import tactic

open function -- so we can write `injective`/`surjective` instead of `function.injective`/`function.surjective`

-- For each of the parts below, if you think it's false then stick `¬` in front of it before you start proving it.

-- The below is for counterexamples
-- Let X be {a}
inductive X : Type
| a : X

-- Let Y be {b,c}
inductive Y : Type
| b : Y
| c : Y

-- Let Z be {d}
inductive Z : Type
| d : Z

-- Define f by f(X.a)=Y.b
def f : X → Y
| X.a := Y.b

-- define g by g(Y.b)=g(Y.c)=Z.d
def g : Y → Z
| Y.b := Z.d
| Y.c := Z.d

lemma parta : ¬ (∀ (X Y Z : Type) (f : X → Y) (g : Y → Z), surjective (g ∘ f) → surjective f) :=
begin
  by_contra,
  specialize h X Y Z f g,
  have hgf : surjective (g ∘ f),
  { rintro z,
    cases z,
    use X.a,
    refl },
  obtain ⟨⟨⟩, ⟨⟩⟩ := h hgf Y.c,
end

lemma partb : ∀ (X Y Z : Type) (f : X → Y) (g : Y → Z), surjective (g ∘ f) → surjective g :=
begin
  intros X Y Z f g hgf b,
  obtain ⟨a, hgf⟩ := hgf b,
  exact ⟨f a, hgf⟩,
end

lemma gf_injective : injective (g ∘ f) :=
begin
  rintros ⟨⟩ ⟨⟩ _,
  refl,
end

lemma partc : ∀ (X Y Z : Type) (f : X → Y) (g : Y → Z), injective (g ∘ f) → injective f :=
begin
  intros X Y Z f g hgf a b hf,
  have hg : g (f a) = g (f b),
  { rw hf },
  exact hgf hg,
end

lemma partd : ¬ (∀ (X Y Z : Type) (f : X → Y) (g : Y → Z), injective (g ∘ f) → injective g) :=
begin
  by_contra,
  specialize h X Y Z f g,
  specialize h gf_injective,
  have hy : g Y.b = g Y.c,
  { unfold g },
  specialize h hy,
  simpa using h,
end


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad

The power function on the natural numbers.
-/
import data.nat.basic data.nat.order data.nat.div data.nat.gcd algebra.ring_power

namespace nat

definition nat_has_pow_nat [instance] [priority nat.prio] : has_pow_nat nat :=
has_pow_nat.mk has_pow_nat.pow_nat

theorem pow_le_pow_of_le {x y : ℕ} (i : ℕ) (H : x ≤ y) : x^i ≤ y^i :=
pow_le_pow_of_le i !zero_le H

theorem eq_zero_of_pow_eq_zero {a m : ℕ} (H : a^m = 0) : a = 0 :=
or.elim (eq_zero_or_pos m)
  (suppose m = 0,
    by rewrite [`m = 0` at H, pow_zero at H]; contradiction)
  (suppose m > 0,
    have h₁ : ∀ m, a^succ m = 0 → a = 0,
      begin
        intro m,
        induction m with m ih,
          {krewrite pow_one; intros; assumption},
        rewrite pow_succ,
        intro H,
        cases eq_zero_or_eq_zero_of_mul_eq_zero H with h₃ h₄,
          assumption,
        exact ih h₄
      end,
    obtain m' (h₂ : m = succ m'), from exists_eq_succ_of_pos `m > 0`,
    show a = 0, by rewrite h₂ at H; apply h₁ m' H)

-- generalize to semirings?
theorem le_pow_self {x : ℕ} (H : x > 1) : ∀ i, i ≤ x^i
| 0        := !zero_le
| (succ j) := have x > 0,        from lt.trans zero_lt_one H,
              have h₁ : x^j ≥ 1, from succ_le_of_lt (pow_pos_of_pos _ this),
              have x ≥ 2,        from succ_le_of_lt H,
              calc
                succ j = j + 1         : rfl
                   ... ≤ x^j + 1       : add_le_add_right (le_pow_self j)
                   ... ≤ x^j + x^j     : add_le_add_left h₁
                   ... = x^j * (1 + 1) : by rewrite [left_distrib, *mul_one]
                   ... = x^j * 2       : rfl
                   ... ≤ x^j * x       : mul_le_mul_left _ `x ≥ 2`
                   ... = x^(succ j)    : pow_succ'

-- TODO: eventually this will be subsumed under the algebraic theorems

theorem mul_self_eq_pow_2 (a : nat) : a * a = a ^ 2 :=
show a * a = a ^ (succ (succ zero)), from
by krewrite [*pow_succ, *pow_zero, mul_one]

theorem pow_cancel_left : ∀ {a b c : nat}, a > 1 → a ^ b = a ^ c → b = c
| a 0        0        h₁ h₂ := rfl
| a (succ b) 0        h₁ h₂ :=
  have a = 1, by rewrite [pow_succ at h₂, pow_zero at h₂]; exact (eq_one_of_mul_eq_one_right h₂),
  have (1:nat) < 1, by rewrite [this at h₁]; exact h₁,
  absurd `1 <[nat] 1` !lt.irrefl
| a 0        (succ c) h₁ h₂ :=
  have a = 1, by rewrite [pow_succ at h₂, pow_zero at h₂]; exact (eq_one_of_mul_eq_one_right (eq.symm h₂)),
  have (1:nat) < 1, by rewrite [this at h₁]; exact h₁,
  absurd `1 <[nat] 1` !lt.irrefl
| a (succ b) (succ c) h₁ h₂ :=
  have a ≠ 0, from assume aeq0, by rewrite [aeq0 at h₁]; exact (absurd h₁ dec_trivial),
  have a^b = a^c, by rewrite [*pow_succ at h₂]; exact (eq_of_mul_eq_mul_left (pos_of_ne_zero this) h₂),
  by rewrite [pow_cancel_left h₁ this]

theorem pow_div_cancel : ∀ {a b : nat}, a ≠ 0 → (a ^ succ b) / a = a ^ b
| a 0        h := by rewrite [pow_succ, pow_zero, mul_one, nat.div_self (pos_of_ne_zero h)]
| a (succ b) h := by rewrite [pow_succ, nat.mul_div_cancel_left _ (pos_of_ne_zero h)]

lemma dvd_pow : ∀ (i : nat) {n : nat}, n > 0 → i ∣ i^n
| i 0        h := absurd h !lt.irrefl
| i (succ n) h := by rewrite [pow_succ']; apply dvd_mul_left

lemma dvd_pow_of_dvd_of_pos : ∀ {i j n : nat}, i ∣ j → n > 0 → i ∣ j^n
| i j 0        h₁ h₂ := absurd h₂ !lt.irrefl
| i j (succ n) h₁ h₂ := by rewrite [pow_succ']; apply dvd_mul_of_dvd_right h₁

lemma pow_mod_eq_zero (i : nat) {n : nat} (h : n > 0) : (i ^ n) % i = 0 :=
iff.mp !dvd_iff_mod_eq_zero (dvd_pow i h)

lemma pow_dvd_of_pow_succ_dvd {p i n : nat} : p^(succ i) ∣ n → p^i ∣ n :=
suppose p^(succ i) ∣ n,
have p^i ∣ p^(succ i),
  by rewrite [pow_succ']; apply nat.dvd_of_eq_mul; apply rfl,
dvd.trans `p^i ∣ p^(succ i)` `p^(succ i) ∣ n`

lemma dvd_of_pow_succ_dvd_mul_pow {p i n : nat} (Ppos : p > 0) :
  p^(succ i) ∣ (n * p^i) → p ∣ n :=
by rewrite [pow_succ]; apply nat.dvd_of_mul_dvd_mul_right; apply pow_pos_of_pos _ Ppos

lemma coprime_pow_right {a b} : ∀ n, coprime b a → coprime b (a^n)
| 0        h := !comprime_one_right
| (succ n) h :=
  begin
    rewrite [pow_succ'],
    apply coprime_mul_right,
      exact coprime_pow_right n h,
      exact h
  end

lemma coprime_pow_left {a b} : ∀ n, coprime b a → coprime (b^n) a :=
take n, suppose coprime b a,
coprime_swap (coprime_pow_right n (coprime_swap this))
end nat


import data.equiv.basic

/-

data.equiv.basic  is the import which gives you the type `equiv X Y`, the type of
bijections from X to Y.

Here's the definition of equiv from that file.

structure equiv (α : Sort*) (β : Sort*) :=
(to_fun    : α → β)
(inv_fun   : β → α)
(left_inv  : left_inverse inv_fun to_fun)
(right_inv : right_inverse inv_fun to_fun)

To make a term of type `equiv α β` you have to supply a function α → β,
a function β → α, and proofs that both composites are the identity function.

Let's see how to create the bijection ℤ → ℤ sending x to -x.
-/
-- let's prove that x ↦ -x can be extended to
example : equiv ℤ ℤ :=
{ to_fun := λ x, -x, -- this is data
  inv_fun := λ x, -x,  -- this is data
  left_inv := begin -- this is a proof
    change ∀ (x : ℤ), - -x = x, -- that's the question
    exact neg_neg, -- note: I guessed what this function was called.
                   -- If it had been called "lemma 12" I would not have been able to guess
  end,
  right_inv := neg_neg -- another proof, this time in term mode
}

/-
Q1 Define the type of partitions of a type.
A partition of X is a set of subsets of X with the property that each subset
is non-empty and each element of X is in precisely one of the subsets.
NB : this is one of the harder questions here.
-/

structure partition (X : Type*) :=
(ℱ : set (set X))
(disjoint : ∀ A B ∈ ℱ, A ≠ B → A ∩ B = ∅)
(cover : ∀ x : X, ∃ A ∈ ℱ, x ∈ A)
(nonempty : ∀ A ∈ ℱ, A ≠ ∅)

/-
Equivalence relations are in core Lean -- we don't need any imports.
Here's an example: I'll prove that the "always true" relation on a set is
an equivalence relation.

-/

def always_true (X : Type*) : X → X → Prop := λ a b, true

-- and now here's the proof that it's an equivalence relation.

theorem always_true_refl (X) : reflexive (always_true X) :=
begin
  intro x,
  trivial
end

theorem always_true_symm (X) : symmetric (always_true X) :=
begin
  intros a b H,
  trivial
end

theorem always_true_trans (X) : transitive (always_true X) :=
begin
  intros a b c Hab Hbc,
  trivial
end

-- note pointy brackets to make a term of type "A ∧ B ∧ C"
theorem always_true_equiv (X): equivalence (always_true X) :=
⟨always_true_refl X, always_true_symm X, always_true_trans X⟩
-- autocomplete made that proof really easy to type. It's really
-- lucky that I didn't call these lemmas lemma 12, lemma 13 and lemma 14.

-- if X is a type, then `setoid X` is is the type of equivalence relations on X.
-- I'll now make a term of type `setoid X` corresponding to that equivalence
-- relation above.

-- note squiggly brackets and commas at the end of each definition to make a structure
def always_true_setoid (X : Type*) : setoid X :=
{ r := always_true X,
  iseqv := always_true_equiv X }

/-
Q2 : If X is a type then `setoid X` is the type of equivalence relations on X,
and `partitions X` is the type of partitions of X. These two concepts are in
some sort of "canonical" bijection with each other (interesting exercise: make
this statement mathematically meaningful -- I know we all say it, but what
does it *mean*?).

Let's prove that these sets biject with each other by defining
a term of type equiv (setoid X) (partitions X)
-/

variable {X : Type*}

def F (S : setoid X) : partition X := sorry

/-
Q3 : now define a map the other way
-/

def G (P : partition X) : setoid X := sorry

/-
Q4 : now finally prove that the composite of maps in both directions
is the identity
-/

theorem FG_eq_id (P : partition X) : F (G P) = P := sorry
theorem GF_eq_id (S : setoid X) : G (F S) = S := sorry

/-
Q5 : now finally construct the term we seek.
-/

def partitions_biject_with_equivalence_relations :
  equiv (setoid X) (partition X) := sorry


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import order.basic
import data.equiv.encodable.basic
import order.atoms

/-!
# Order ideals, cofinal sets, and the Rasiowa–Sikorski lemma

## Main definitions

Throughout this file, `P` is at least a preorder, but some sections require more
structure, such as a bottom element, a top element, or a join-semilattice structure.
- `order.ideal P`: the type of nonempty, upward directed, and downward closed subsets of `P`.
  Dual to the notion of a filter on a preorder.
- `order.is_ideal P`: a predicate for when a `set P` is an ideal.
- `order.ideal.principal p`: the principal ideal generated by `p : P`.
- `order.ideal.is_proper P`: a predicate for proper ideals.
  Dual to the notion of a proper filter.
- `order.ideal.is_maximal`: a predicate for maximal ideals.
  Dual to the notion of an ultrafilter.
- `ideal_inter_nonempty P`: a predicate for when the intersection of any two ideals of
  `P` is nonempty.
- `order.cofinal P`: the type of subsets of `P` containing arbitrarily large elements.
  Dual to the notion of 'dense set' used in forcing.
- `order.ideal_of_cofinals p 𝒟`, where `p : P`, and `𝒟` is a countable family of cofinal
  subsets of P: an ideal in `P` which contains `p` and intersects every set in `𝒟`. (This a form
  of the Rasiowa–Sikorski lemma.)

## References

- <https://en.wikipedia.org/wiki/Ideal_(order_theory)>
- <https://en.wikipedia.org/wiki/Cofinal_(mathematics)>
- <https://en.wikipedia.org/wiki/Rasiowa%E2%80%93Sikorski_lemma>

Note that for the Rasiowa–Sikorski lemma, Wikipedia uses the opposite ordering on `P`,
in line with most presentations of forcing.

## Tags

ideal, cofinal, dense, countable, generic

-/

namespace order

variables {P : Type*}

/-- An ideal on a preorder `P` is a subset of `P` that is
  - nonempty
  - upward directed (any pair of elements in the ideal has an upper bound in the ideal)
  - downward closed (any element less than an element of the ideal is in the ideal). -/
structure ideal (P) [preorder P] :=
(carrier   : set P)
(nonempty  : carrier.nonempty)
(directed  : directed_on (≤) carrier)
(mem_of_le : ∀ {x y : P}, x ≤ y → y ∈ carrier → x ∈ carrier)

/-- A subset of a preorder `P` is an ideal if it is
  - nonempty
  - upward directed (any pair of elements in the ideal has an upper bound in the ideal)
  - downward closed (any element less than an element of the ideal is in the ideal). -/
@[mk_iff] structure is_ideal {P} [preorder P] (I : set P) : Prop :=
(nonempty : I.nonempty)
(directed : directed_on (≤) I)
(mem_of_le : ∀ {x y : P}, x ≤ y → y ∈ I → x ∈ I)

/-- Create an element of type `order.ideal` from a set satisfying the predicate
`order.is_ideal`. -/
def is_ideal.to_ideal [preorder P] {I : set P} (h : is_ideal I) : ideal P :=
⟨I, h.1, h.2, h.3⟩

/-- A preorder `P` has the `ideal_inter_nonempty` property if the
    intersection of any two ideals is nonempty.
    Most importantly, a `semilattice_sup` preorder with this property
    satisfies that its ideal poset is a lattice.
-/
class ideal_inter_nonempty (P) [preorder P] : Prop :=
(inter_nonempty : ∀ (I J : ideal P), (I.carrier ∩ J.carrier).nonempty)

lemma inter_nonempty [preorder P] [ideal_inter_nonempty P] :
∀ (I J : ideal P), (I.carrier ∩ J.carrier).nonempty :=
ideal_inter_nonempty.inter_nonempty

namespace ideal

section preorder
variables [preorder P] {x y : P} {I J : ideal P}

/-- The smallest ideal containing a given element. -/
def principal (p : P) : ideal P :=
{ carrier   := { x | x ≤ p },
  nonempty  := ⟨p, le_refl _⟩,
  directed  := λ x hx y hy, ⟨p, le_refl _, hx, hy⟩,
  mem_of_le := λ x y hxy hy, le_trans hxy hy, }

instance [inhabited P] : inhabited (ideal P) :=
⟨ideal.principal $ default P⟩

/-- An ideal of `P` can be viewed as a subset of `P`. -/
instance : has_coe (ideal P) (set P) := ⟨carrier⟩

/-- For the notation `x ∈ I`. -/
instance : has_mem P (ideal P) := ⟨λ x I, x ∈ (I : set P)⟩

@[simp] lemma mem_coe : x ∈ (I : set P) ↔ x ∈ I := iff_of_eq rfl

@[simp] lemma mem_principal : x ∈ principal y ↔ x ≤ y := by refl

/-- Two ideals are equal when their underlying sets are equal. -/
@[ext] lemma ext : ∀ (I J : ideal P), (I : set P) = J → I = J
| ⟨_, _, _, _⟩ ⟨_, _, _, _⟩ rfl := rfl

@[simp, norm_cast] lemma ext_set_eq {I J : ideal P} : (I : set P) = J ↔ I = J :=
⟨by ext, congr_arg _⟩

lemma ext'_iff {I J : ideal P} : I = J ↔ (I : set P) = J := ext_set_eq.symm

lemma is_ideal (I : ideal P) : is_ideal (I : set P) := ⟨I.2, I.3, I.4⟩

/-- The partial ordering by subset inclusion, inherited from `set P`. -/
instance : partial_order (ideal P) := partial_order.lift coe ext

@[trans] lemma mem_of_mem_of_le : x ∈ I → I ≤ J → x ∈ J :=
@set.mem_of_mem_of_subset P x I J

@[simp] lemma principal_le_iff : principal x ≤ I ↔ x ∈ I :=
⟨λ (h : ∀ {y}, y ≤ x → y ∈ I), h (le_refl x),
 λ h_mem y (h_le : y ≤ x), I.mem_of_le h_le h_mem⟩

lemma mem_compl_of_ge {x y : P} : x ≤ y → x ∈ (I : set P)ᶜ → y ∈ (I : set P)ᶜ :=
λ h, mt (I.mem_of_le h)

/-- A proper ideal is one that is not the whole set.
    Note that the whole set might not be an ideal. -/
@[mk_iff] class is_proper (I : ideal P) : Prop := (ne_univ : (I : set P) ≠ set.univ)

lemma is_proper_of_not_mem {I : ideal P} {p : P} (nmem : p ∉ I) : is_proper I :=
⟨λ hp, begin
  change p ∉ ↑I at nmem,
  rw hp at nmem,
  exact nmem (set.mem_univ p),
end⟩

/-- An ideal is maximal if it is maximal in the collection of proper ideals.
  Note that we cannot use the `is_coatom` class because `P` might not have a `top` element.
-/
@[mk_iff] class is_maximal (I : ideal P) extends is_proper I : Prop :=
(maximal_proper : ∀ ⦃J : ideal P⦄, I < J → J.carrier = set.univ)

end preorder

section order_bot
variables [order_bot P] {I : ideal P}

/-- A specific witness of `I.nonempty` when `P` has a bottom element. -/
@[simp] lemma bot_mem : ⊥ ∈ I :=
I.mem_of_le bot_le I.nonempty.some_mem

/-- There is a bottom ideal when `P` has a bottom element. -/
instance : order_bot (ideal P) :=
{ bot := principal ⊥,
  bot_le := by simp,
  .. ideal.partial_order }

end order_bot

section order_top

variables [order_top P]

/-- There is a top ideal when `P` has a top element. -/
instance : order_top (ideal P) :=
{ top := principal ⊤,
  le_top := λ I x h, le_top,
  .. ideal.partial_order }

@[simp] lemma top_carrier : (⊤ : ideal P).carrier = set.univ :=
set.univ_subset_iff.1 (λ p _, le_top)

@[simp] lemma top_coe : ((⊤ : ideal P) : set P) = set.univ := top_carrier

lemma top_of_mem_top {I : ideal P} (mem_top : ⊤ ∈ I) : I = ⊤ :=
begin
  ext,
  change x ∈ I.carrier ↔ x ∈ (⊤ : ideal P).carrier,
  split,
  { simp [top_carrier] },
  { exact λ _, I.mem_of_le le_top mem_top }
end

lemma is_proper_of_ne_top {I : ideal P} (ne_top : I ≠ ⊤) : is_proper I :=
is_proper_of_not_mem (λ h, ne_top (top_of_mem_top h))

lemma is_proper.ne_top {I : ideal P} (hI : is_proper I) : I ≠ ⊤ :=
begin
  intro h,
  rw [ext'_iff, top_coe] at h,
  apply hI.ne_univ,
  assumption,
end

lemma _root_.is_coatom.is_proper {I : ideal P} (hI : is_coatom I) : is_proper I :=
is_proper_of_ne_top hI.1

lemma is_proper_iff_ne_top {I : ideal P} : is_proper I ↔ I ≠ ⊤ :=
⟨λ h, h.ne_top, λ h, is_proper_of_ne_top h⟩

lemma is_maximal.is_coatom {I : ideal P} (h : is_maximal I) : is_coatom I :=
⟨is_maximal.to_is_proper.ne_top,
 λ _ _, by { rw [ext'_iff, top_coe], exact is_maximal.maximal_proper ‹_› }⟩

lemma is_maximal.is_coatom' {I : ideal P} [is_maximal I] : is_coatom I :=
is_maximal.is_coatom ‹_›

lemma _root_.is_coatom.is_maximal {I : ideal P} (hI : is_coatom I) : is_maximal I :=
{ maximal_proper := λ _ _, by simp [hI.2 _ ‹_›],
  ..is_coatom.is_proper ‹_› }

lemma is_maximal_iff_is_coatom {I : ideal P} : is_maximal I ↔ is_coatom I :=
⟨λ h, h.is_coatom, λ h, h.is_maximal⟩

end order_top

section semilattice_sup
variables [semilattice_sup P] {x y : P} {I : ideal P}

/-- A specific witness of `I.directed` when `P` has joins. -/
lemma sup_mem (x y ∈ I) : x ⊔ y ∈ I :=
let ⟨z, h_mem, hx, hy⟩ := I.directed x ‹_› y ‹_› in
I.mem_of_le (sup_le hx hy) h_mem

@[simp] lemma sup_mem_iff : x ⊔ y ∈ I ↔ x ∈ I ∧ y ∈ I :=
⟨λ h, ⟨I.mem_of_le le_sup_left h, I.mem_of_le le_sup_right h⟩,
 λ h, sup_mem x y h.left h.right⟩

end semilattice_sup

section semilattice_sup_ideal_inter_nonempty

variables [semilattice_sup P] [ideal_inter_nonempty P] {x : P} {I J K : ideal P}

/-- The intersection of two ideals is an ideal, when it is nonempty and `P` has joins. -/
def inf (I J : ideal P) : ideal P :=
{ carrier   := I ∩ J,
  nonempty  := inter_nonempty I J,
  directed  := λ x ⟨_, _⟩ y ⟨_, _⟩, ⟨x ⊔ y, ⟨sup_mem x y ‹_› ‹_›, sup_mem x y ‹_› ‹_›⟩, by simp⟩,
  mem_of_le := λ x y h ⟨_, _⟩, ⟨mem_of_le I h ‹_›, mem_of_le J h ‹_›⟩ }

/-- There is a smallest ideal containing two ideals, when their intersection is nonempty and
    `P` has joins. -/
def sup (I J : ideal P) : ideal P :=
{ carrier   := {x | ∃ (i ∈ I) (j ∈ J), x ≤ i ⊔ j},
  nonempty  := by { cases inter_nonempty I J, exact ⟨w, w, h.1, w, h.2, le_sup_left⟩ },
  directed  := λ x ⟨xi, _, xj, _, _⟩ y ⟨yi, _, yj, _, _⟩,
    ⟨x ⊔ y,
     ⟨xi ⊔ yi, sup_mem xi yi ‹_› ‹_›,
      xj ⊔ yj, sup_mem xj yj ‹_› ‹_›,
      sup_le
        (calc x ≤ xi ⊔ xj               : ‹_›
         ...    ≤ (xi ⊔ yi) ⊔ (xj ⊔ yj) : sup_le_sup le_sup_left le_sup_left)
        (calc y ≤ yi ⊔ yj               : ‹_›
         ...    ≤ (xi ⊔ yi) ⊔ (xj ⊔ yj) : sup_le_sup le_sup_right le_sup_right)⟩,
     le_sup_left, le_sup_right⟩,
  mem_of_le := λ x y _ ⟨yi, _, yj, _, _⟩, ⟨yi, ‹_›, yj, ‹_›, le_trans ‹x ≤ y› ‹_›⟩ }

lemma sup_le : I ≤ K → J ≤ K → sup I J ≤ K :=
λ hIK hJK x ⟨i, hiI, j, hjJ, hxij⟩,
K.mem_of_le hxij $ sup_mem i j (mem_of_mem_of_le hiI hIK) (mem_of_mem_of_le hjJ hJK)

instance : lattice (ideal P) :=
{ sup          := sup,
  le_sup_left  := λ I J (i ∈ I), by { cases nonempty J, exact ⟨i, ‹_›, w, ‹_›, le_sup_left⟩ },
  le_sup_right := λ I J (j ∈ J), by { cases nonempty I, exact ⟨w, ‹_›, j, ‹_›, le_sup_right⟩ },
  sup_le       := @sup_le _ _ _,
  inf          := inf,
  inf_le_left  := λ I J, set.inter_subset_left I J,
  inf_le_right := λ I J, set.inter_subset_right I J,
  le_inf       := λ I J K, set.subset_inter,
  .. ideal.partial_order }

@[simp] lemma mem_inf : x ∈ I ⊓ J ↔ x ∈ I ∧ x ∈ J := iff_of_eq rfl

@[simp] lemma mem_sup : x ∈ I ⊔ J ↔ ∃ (i ∈ I) (j ∈ J), x ≤ i ⊔ j := iff_of_eq rfl

lemma lt_sup_principal_of_not_mem (hx : x ∉ I) : I < I ⊔ principal x :=
begin
  apply lt_of_le_of_ne le_sup_left,
  intro h,
  simp at h,
  exact hx h
end

end semilattice_sup_ideal_inter_nonempty

section semilattice_sup_bot
variables [semilattice_sup_bot P]

@[priority 100]
instance semilattice_sup_bot.ideal_inter_nonempty : ideal_inter_nonempty P :=
{ inter_nonempty := λ _ _, ⟨⊥, ⟨bot_mem, bot_mem⟩⟩ }

end semilattice_sup_bot

section semilattice_inf

variable [semilattice_inf P]

@[priority 100]
instance semilattice_inf.ideal_inter_nonempty : ideal_inter_nonempty P :=
{ inter_nonempty := λ I J, begin
    cases I.nonempty with i _,
    cases J.nonempty with j _,
    exact ⟨i ⊓ j, I.mem_of_le inf_le_left ‹_›, J.mem_of_le inf_le_right ‹_›⟩
  end }

end semilattice_inf

section distrib_lattice

variables [distrib_lattice P]
variables {I J : ideal P}

lemma eq_sup_of_le_sup {x i j: P} (hi : i ∈ I) (hj : j ∈ J) (hx : x ≤ i ⊔ j):
∃ (i' ∈ I) (j' ∈ J), x = i' ⊔ j' :=
begin
  refine ⟨x ⊓ i, I.mem_of_le inf_le_right hi, x ⊓ j, J.mem_of_le inf_le_right hj, _⟩,
  calc
  x    = x ⊓ (i ⊔ j)       : left_eq_inf.mpr hx
  ...  = (x ⊓ i) ⊔ (x ⊓ j) : inf_sup_left,
end

lemma coe_sup_eq : ↑(I ⊔ J) = {x | ∃ i ∈ I, ∃ j ∈ J, x = i ⊔ j} :=
begin
  ext,
  rw [mem_coe, mem_sup],
  exact ⟨λ ⟨_, _, _, _, _⟩, eq_sup_of_le_sup ‹_› ‹_› ‹_›,
  λ ⟨i, _, j, _, _⟩, ⟨i, ‹_›, j, ‹_›, le_of_eq ‹_›⟩⟩
end

end distrib_lattice

end ideal

/-- For a preorder `P`, `cofinal P` is the type of subsets of `P`
  containing arbitrarily large elements. They are the dense sets in
  the topology whose open sets are terminal segments. -/
structure cofinal (P) [preorder P] :=
(carrier : set P)
(mem_gt  : ∀ x : P, ∃ y ∈ carrier, x ≤ y)

namespace cofinal

variables [preorder P]

instance : inhabited (cofinal P) :=
⟨{ carrier := set.univ, mem_gt := λ x, ⟨x, trivial, le_refl _⟩ }⟩

instance : has_mem P (cofinal P) := ⟨λ x D, x ∈ D.carrier⟩

variables (D : cofinal P) (x : P)
/-- A (noncomputable) element of a cofinal set lying above a given element. -/
noncomputable def above : P := classical.some $ D.mem_gt x

lemma above_mem : D.above x ∈ D :=
exists.elim (classical.some_spec $ D.mem_gt x) $ λ a _, a

lemma le_above : x ≤ D.above x :=
exists.elim (classical.some_spec $ D.mem_gt x) $ λ _ b, b

end cofinal

section ideal_of_cofinals

variables [preorder P] (p : P) {ι : Type*} [encodable ι] (𝒟 : ι → cofinal P)

/-- Given a starting point, and a countable family of cofinal sets,
  this is an increasing sequence that intersects each cofinal set. -/
noncomputable def sequence_of_cofinals : ℕ → P
| 0 := p
| (n+1) := match encodable.decode ι n with
           | none   := sequence_of_cofinals n
           | some i := (𝒟 i).above (sequence_of_cofinals n)
           end

lemma sequence_of_cofinals.monotone : monotone (sequence_of_cofinals p 𝒟) :=
by { apply monotone_of_monotone_nat, intros n, dunfold sequence_of_cofinals,
  cases encodable.decode ι n, { refl }, { apply cofinal.le_above }, }

lemma sequence_of_cofinals.encode_mem (i : ι) :
  sequence_of_cofinals p 𝒟 (encodable.encode i + 1) ∈ 𝒟 i :=
by { dunfold sequence_of_cofinals, rw encodable.encodek, apply cofinal.above_mem, }

/-- Given an element `p : P` and a family `𝒟` of cofinal subsets of a preorder `P`,
  indexed by a countable type, `ideal_of_cofinals p 𝒟` is an ideal in `P` which
  - contains `p`, according to `mem_ideal_of_cofinals p 𝒟`, and
  - intersects every set in `𝒟`, according to `cofinal_meets_ideal_of_cofinals p 𝒟`.

  This proves the Rasiowa–Sikorski lemma. -/
def ideal_of_cofinals : ideal P :=
{ carrier   := { x : P | ∃ n, x ≤ sequence_of_cofinals p 𝒟 n },
  nonempty  := ⟨p, 0, le_refl _⟩,
  directed  := λ x ⟨n, hn⟩ y ⟨m, hm⟩,
               ⟨_, ⟨max n m, le_refl _⟩,
               le_trans hn $ sequence_of_cofinals.monotone p 𝒟 (le_max_left _ _),
               le_trans hm $ sequence_of_cofinals.monotone p 𝒟 (le_max_right _ _) ⟩,
  mem_of_le := λ x y hxy ⟨n, hn⟩, ⟨n, le_trans hxy hn⟩, }

lemma mem_ideal_of_cofinals : p ∈ ideal_of_cofinals p 𝒟 := ⟨0, le_refl _⟩

/-- `ideal_of_cofinals p 𝒟` is `𝒟`-generic. -/
lemma cofinal_meets_ideal_of_cofinals (i : ι) : ∃ x : P, x ∈ 𝒟 i ∧ x ∈ ideal_of_cofinals p 𝒟 :=
⟨_, sequence_of_cofinals.encode_mem p 𝒟 i, _, le_refl _⟩

end ideal_of_cofinals

end order


/-
Some useful facts about distances
(this helps us avoid reasoning about negative numbers)
-/

def dist : ℕ → ℕ → ℕ
| 0     m     := m
| n     0     := n
| (n+1) (m+1) := dist n m

lemma dist_rfl (n : ℕ) : dist n n = 0 :=
begin
induction n with n ih,
{ reflexivity },
{ simp [dist, ih] }
end

lemma dist_zero_left (m : ℕ) : dist 0 m = m := by cases m; reflexivity
lemma dist_zero_right (n : ℕ) : dist n 0 = n := by cases n; reflexivity

lemma dist_add (n m : ℕ) : dist n (n+m) = m :=
begin induction n with n ih,
  { by simp [dist_zero_left] },
  { from calc dist (nat.succ n) (nat.succ n + m)
            = dist (nat.succ n) (nat.succ (n + m)) : by simp
        ... = dist n (n + m)                       : by simp [dist]
        ... = m                                    : ih
  }
end

lemma add_dist (n m : ℕ) : dist (n+m) n = m :=
begin induction n with n ih,
  { by simp [dist_zero_right] },
  { from calc dist (nat.succ n + m) (nat.succ n)
            = dist (nat.succ (n + m)) (nat.succ n) : by simp
        ... = dist (n + m) n                       : by simp [dist]
        ... = m                                    : ih
  }
end

lemma dist_sum (n m k : ℕ) (h : n = m + k) : dist n m = k :=
by rw [h]; simp [add_dist]

lemma dist_iden (m n : ℕ) : dist m n = 0 ↔ m = n :=
iff.intro
(begin
revert n, induction m with m ih,
{ intro n, simp [dist_zero_left]; from eq.symm },
{ intro n, cases n with n,
  { simp [dist]; intro; assumption },
  { simp [dist]; intro h; rw [(ih n) h] } }
end)
(by intro h; simp [h, dist_rfl] )

lemma dist_symm (m n : ℕ) : dist m n = dist n m :=
begin
revert n, induction m with m ih,
{ intro n; induction n; reflexivity },
{ intro n, cases n with n,
  { simp [dist_zero_left, dist_zero_right] },
  { simp [dist, ih n] } }
end

lemma dist_cancel (n m k : ℕ) : dist (n+k) (m+k) = dist n m :=
begin revert n m, induction k with k ih,
{ intros, simp },
{ intros, apply ih }
end

lemma dist_mul (n m k : ℕ) : dist (n*k) (m*k) = (dist n m)*k :=
begin
revert n, induction m with m ih,
{ intro n; simp [dist_zero_right] },
{ intro n; cases n with n,
  { simp [dist_zero_left] },
  { simp [dist, nat.succ_mul];
    repeat { rw [nat.add_comm k] };
    rw [dist_cancel];
    repeat { rw [nat.mul_comm k] };
    apply ih
  }
}
end

lemma bounded_dist {n m k : ℕ} (hn : n < k) (hm : m < k) : dist n m < k :=
begin
revert n m, induction k with k ih,
{ intros, from absurd (nat.eq_zero_of_le_zero hn) (nat.succ_ne_zero n) },
{ intros, cases n with n,
  { cases m with m; simp [dist]; assumption },
  { cases m with m,
    { simp [dist]; assumption },
    { simp [dist];
      have hnk : n < k, from nat.lt_of_succ_lt_succ hn,
      have hmk : m < k, from nat.lt_of_succ_lt_succ hm,
      apply nat.lt.step; apply ih hnk hmk; assumption
    }
  }
}
end

lemma dist_sub {n m : ℕ} (hm : m ≤ n) : dist n (n - m) = m :=
calc dist n (n - m) = dist (n+m) ((n - m) + m) : by rw [dist_cancel]
                ... = dist (n+m) n             : by rw [nat.sub_add_cancel hm]
                ... = m                        : by rw [add_dist]

lemma dist_cancel_sub {n m k : ℕ} (hm : m ≤ n) (hk : k ≤ n) : dist (n - m) (n - k) = dist m k :=
calc dist (n - m) (n - k) = dist (n - m + m) ((n - k) + m) : by rw [dist_cancel]
                      ... = dist n (n - k + m)             : by rw [nat.sub_add_cancel hm]
                      ... = dist (n+k) (n - k + m + k)     : by rw [dist_cancel]
                      ... = dist (n+k) (n - k + (m + k))   : by rw [nat.add_assoc]
                      ... = dist (n+k) (n - k + (k + m))   : by rw [nat.add_comm k]
                      ... = dist (n+k) ((n - k + k) + m)   : by rw [nat.add_assoc]
                      ... = dist (n+k) (n+m)               : by rw [nat.sub_add_cancel hk]
                      ... = dist (k+n) (m+n)               : by rw [nat.add_comm k, nat.add_comm m]
                      ... = dist k m                       : by rw [dist_cancel]
                      ... = dist m k                       : by rw [dist_symm]


theorem mul_eq_zero_iff (a b : mynat): a * b = 0 ↔ a = 0 ∨ b = 0 :=
begin
split,
apply eq_zero_or_eq_zero_of_mul_eq_zero,
intro h,
cases h,
rwa [h, zero_mul],
rwa [h, mul_zero],
end


-- Euler's proof of the infinitude of primes.
-- Uses the product of all primes up to n.

import data.nat.basic
import data.nat.prime

def prod_primes : ℕ → ℕ
| 0 := 1
| (nat.succ n) := (if nat.prime n.succ then n.succ else 1) * prod_primes n

lemma dvd_prod {n p : ℕ} : p ≤ n → nat.prime p → p ∣ prod_primes n :=
begin
  induction n with k hk,
    simp,
    intro hp,
    rw hp,
    simp [nat.not_prime_zero],
  intro hn,
  generalize hm : prod_primes k.succ = m,
  rw prod_primes at hm, rw ite_mul at hm, rw ite_eq_iff at hm, simp at hm,
  cases nat.of_le_succ hn,
    cases hm,
      intro hp,
      rw ← hm.right,
      apply dvd_trans (hk h hp) (dvd_mul_left _ _),
    rw ← hm.right,
    apply hk h,
  rw ← h at hm,
  cases hm,
    intro hp,
    rw ← hm.right,
    apply dvd_mul_right,
  intro hp,
  exfalso, apply hm.left, assumption,
end

lemma not_dvd_succ_prod {n p : ℕ} : nat.prime p → p ≤ n → ¬ p ∣ (prod_primes n).succ :=
begin
  intro h_prime,
  intro hn,
  rw ← nat.not_dvd_iff_between_consec_multiples,
    have h := dvd_prod hn h_prime,
    cases h with c hc,
    apply exists.intro c,
    simp [mul_add],
    rw hc,
    simp [nat.lt_succ_self, ← nat.add_one],
    apply lt_of_le_of_lt' (nat.prime.two_le h_prime), simp,
  apply lt_of_le_of_lt' (nat.prime.two_le h_prime), simp,
end

lemma zero_lt_prod {n : ℕ} : 0 < prod_primes n :=
begin
  induction n with k hk,
    rw prod_primes, simp,
  generalize hm : prod_primes k.succ = m,
  rw prod_primes at hm,
  rw ite_mul at hm,
  rw ite_eq_iff at hm,
  simp at hm,
  cases hm,
    rw ← hm.right,
    rw zero_lt_iff,
    simp,
    intro h,
    rw h at hk,
    simp at hk, contradiction,
  rw ← hm.right,
  assumption,
end

theorem infinite_primes (n : ℕ) : ∃ (p : ℕ), nat.prime p ∧ n < p :=
begin
  -- Let x be product of primes up to n.
  generalize hx : prod_primes n = x,
  have h_prime := @nat.min_fac_prime x.succ _,
    apply exists.intro x.succ.min_fac,
    cases decidable.em (x.succ.min_fac ≤ n),
      exfalso,
      apply not_dvd_succ_prod h_prime h,
      rw hx,
      apply nat.min_fac_dvd,
    apply and.intro, exact h_prime,
    rw not_le at h, exact h,
  simp,
  rw nat.succ_eq_add_one, simp,
  rw ← hx,
  rw ← le_zero_iff,
  apply has_lt.lt.not_le,
  apply zero_lt_prod,
end


/-
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/rewrite.20le.2Eantisymm.20from.20Lean.202
-/

import tactic
import tactic.lint

open int

theorem le.antisymm : ∀ {a b : ℤ}, a ≤ b → b ≤ a → a = b :=
begin
assume a b : ℤ, assume (H₁ : a ≤ b) (H₂ : b ≤ a),
obtain ⟨n, Hn⟩ : ∃ n : ℕ, a + n = b := int.le.dest H₁,
obtain ⟨m, Hm⟩ : ∃ m : ℕ, b + m = a := int.le.dest H₂,
have H₃ : a + of_nat (n + m) = a + 0, from
  calc
    a + of_nat (n + m) = a + (of_nat n + m) : rfl
      ... = a + (n + m)                     : by rw of_nat_eq_coe
      ... = a + n + m                       : by rw add_assoc
      ... = b + m                           : by rw Hn
      ... = a                               : Hm
      ... = a + 0                           : by rw add_zero,
have H₄ : of_nat (n + m) = of_nat 0, from add_left_cancel H₃,
have H₅ : n + m = 0,                 from of_nat.inj H₄,
have h₆ : n = 0,                     from nat.eq_zero_of_add_eq_zero_right H₅,
show a = b, from
  calc
    a = a + 0    : by simp_rw [add_zero]
  ... = a + n    : by simp_rw [h₆, int.coe_nat_zero]
  ... = b        : Hn
end


-- Suma de los primeros números de Fibonacci
-- =========================================

import data.nat.basic
import tactic

def fibonacci : ℕ → ℕ
| 0       := 0
| 1       := 1
| (n + 2) := fibonacci n + fibonacci (n + 1)

def fibonacci_sum : ℕ → ℕ
| 0       := 0
| (n + 1) := fibonacci_sum n + fibonacci (n + 1)

lemma fibonacci_succ_pos
  (n : ℕ)
  : 0 < fibonacci (n + 1) :=
begin
  induction n with n HI,
  { exact nat.one_pos, },
  { dsimp [fibonacci],
    apply nat.lt_add_left,
    exact HI, },
end

lemma closed_form
  {n : ℕ}
  : fibonacci_sum n = fibonacci (n + 2) - 1 :=
begin
  induction n with n HI,
  { refl, },
  { dsimp [fibonacci_sum],
    rw HI,
    dsimp [fibonacci],
    have h := fibonacci_succ_pos n,
    omega, },
end


/-
Copyright (c) 2019 Jared Corduan. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jared Corduan.
-/

import logic.basic

/-!
# The Infinite Ramsey Theorem

The main theorem, `infinite_ramsey_pairs_two_colors`, states that given
a function from the unordered pairs of natural numbers to a set
with two elements (often named `red` and `blue`), there exists an
infinite set of natural numbers whose unordered pairs are all given
the same color.

The proof given here follows a very standard proof, such as the one
given in chapter 1, theorem 5, of Graham, et al.

The proof roughly goes as follows:

Given a function `f` of unordered pairs into the colors `red` and `blue`,
define a sequence `(Sᵢ, xᵢ)` so that:

* (S₀, x₀) = (ℕ, 0)
* Sᵢ₊₁ ⊆ Sᵢ
* xᵢ₊₁ ∈ Sᵢ
* xᵢ < xᵢ₊₁
* f {xᵢ, y} = f {xᵢ, z} for all xᵢ < y < z in Sₓ

Then the set {xᵢ | i ∈ ℕ} has the property that
f {xᵢ, xⱼ} = f {xᵢ, xₖ} for all i < j < k.
If we color singletons in this set by f' xᵢ = f {xᵢ, xᵢ₊₁},
then by the pigeon hole principle there is an infinite subset
of the xᵢ's whose unordered pairs are all colored the same.

## Notation

This file uses `[S]²` to denote the set of unordered pairs of
the given set `S`.

## Implementation notes

The set of two colors is defined as an emumeration.
This definition is easy to work with, and easy to read,
but comes at the cost of not generalizing.

Unordered pairs are implemented as ordered pairs with the condition
that the second element is strictly greater than the first.
This definition is also easy to work with but does not generalize.

## References

*  [Graham, R.L. and Rothschild, B.L. and Spencer, J.H., *Ramsey Theory*][graham1990]
-/

open set
open classical
open nat

section infinite_ramsey_pairs

/--
A set of natural numbers H is infinite if for any natural
number there is a larger number in H.
-/
def infinite (H : set ℕ) := ∀ x : ℕ, ∃ y : ℕ, x < y ∧ y ∈ H

/--
There are two colors, red and blue.
-/
inductive color
| red : color
| blue : color

/--
An infinite set of natural numbers.
-/
structure Inf :=
(s : set ℕ)
(pf : infinite s)

instance : has_coe Inf (set ℕ) := ⟨Inf.s⟩
instance : has_mem ℕ Inf := ⟨λ n H, n ∈ H.s⟩
instance : has_subset Inf := ⟨λ H₁ H₂, H₁.s ⊆ H₂.s⟩

open color

/--
Given a function from natural numbers to colors,
this property describes the numbers which are mapped to red.
-/
def reds (f : ℕ → color) (H : set ℕ) := (λ n : ℕ, f n = red ∧ n ∈ H )

/--
Given a function from natural numbers to colors,
this property describes the numbers which are mapped to blue.
-/
def blues (f : ℕ → color) (H : set ℕ) := (λ n : ℕ, f n = blue ∧ H n)

lemma lt_succ_sum : forall x y : ℕ, x < x + y + 1 :=
λ x y : ℕ, lt_add_of_pos_right x (succ_pos y)

/--
Unordered pairs are defined as ordered pairs with the condition
that the second element is strictly greater than the first.
-/
def unordered_pairs (S : set ℕ) :=
  {p : ℕ × ℕ // p.fst < p.snd ∧ S p.fst ∧ S p.snd}

notation `[ℕ]²` := unordered_pairs univ
notation `[` S `]²` := unordered_pairs S

/--
Given a number m and a coloring f, the projection of a coloring
of unordered_pairs to a coloring of numbers is given by fixing
the first element as m. Note that red is arbitrarily chosen
as the color assigned to any number below m.
-/
def project (f : [ℕ]² → color) (m : ℕ) : ℕ → color :=
  λ n : ℕ,
    dite (m < n)
      (λ h : m < n, f (subtype.mk (m, n) ⟨h, trivial, trivial⟩))
      (λ _, red)

/--
The coloring of an unordered pair {a, b}, where a < b,
agrees with the projection of a applied to b.
-/
lemma project_eq (f : [ℕ]² → color) (p : [ℕ]²):
  f p = project f p.val.fst p.val.snd :=
begin
  unfold project,
  simp [p.property.left]
end

/--
Given coloring of natural numbers, a homogeneous set is
one which is always mapped to the same color.
-/
def homogeneous (f : ℕ → color) (H : Inf) :=
  ∃ c : color, ∀ n, n ∈ H → f n = c

/--
Given a coloring f, a homogeneous projection is a set of natural numbers
together with a single natural number.
The intended use is a set which is homogeneous when projected
with the given number and coloring.
-/
structure homogeneous_proj (f : [ℕ]² → color) extends Inf := (pt : ℕ)

instance (f : [ℕ]² → color) : has_coe (homogeneous_proj f) Inf := ⟨λ c, c.to_Inf⟩

/--
A homogeneous projection p is refined by another homogeneous projection q if:
the number given by q is greater than the number given by p,
the number given by q is an elment of the set given by p,
the set given by q is contained in the set given by p,
and the projection using the number given by q is homogeneous
on the set given by q.
-/
def refines {f : [ℕ]² → color} (p q: homogeneous_proj f) :=
p.pt < q.pt ∧ q.pt ∈ p.s ∧ q.s ⊆ p.s ∧ homogeneous (project f q.pt) q

infix `<<`:50 := refines

local attribute [instance] prop_decidable

/--
A version of the infinite pigeon hole principle, tailored to our use case.
-/
lemma pigeon_hole_principle (f : ℕ → color) (H : Inf):
  infinite (reds f H) ∨ infinite (blues f H) :=
begin
  rw or_iff_not_imp_left,
  intros redFin,
  simp [infinite, not_forall, not_exists] at redFin,
  cases redFin with w Hw,
  intros x,
  have x_lt_a : x < x + w + 1, exact lt_succ_sum x w,
  have w_lt_a : w < x + w + 1,
    { simp, exact lt_succ_sum w x },
  let a : ℕ := x + w + 1,
    cases (H.pf a) with b Hb,
  have w_lt_b : w < b, exact lt_trans w_lt_a Hb.left,
  have hrb : f b = red ∨ f b = blue,
    { cases f b, simp, simp },
  apply exists.intro b,
  constructor,
  { exact lt_trans x_lt_a Hb.left },
  {
    cases hrb with hRed hBlue,
    { exact absurd (and.intro hRed Hb.right) (Hw b w_lt_b) },
    { exact ⟨hBlue, Hb.right⟩ }
  }
end

/--
This is the key lemma, reducing the Ramsey Theorem for pairs
to the pigeon hole principle. It shows how to refine one homogeneous
projection to get another homogeneous projection.
-/
lemma refine_homo_proj (f : [ℕ]² → color) :
  ∀ (p : homogeneous_proj f), ∃ q : homogeneous_proj f, p << q :=
begin
  intros p,
  cases p.pf p.pt with x Hx,
  have Hinf :
    infinite (reds (project f x) p.s) ∨ infinite (blues (project f x) p.s),
    apply pigeon_hole_principle,
  cases Hinf,
  any_goals { -- Red Case
    apply exists.intro (homogeneous_proj.mk f ⟨reds (project f x) p.s, Hinf⟩ x),
  },
  any_goals { -- Blue Case
    apply exists.intro (homogeneous_proj.mk f ⟨blues (project f x) p.s, Hinf⟩ x)
  },
  all_goals
  {
    constructor,
    { exact Hx.left },
    constructor,
    { exact Hx.right },
    constructor,
    { intros n Hn, exact Hn.right },
    { apply exists.intro, intros n Hn, exact Hn.left },
  }
end

/--
The natural numbers, as an infinite set.
-/
def NatInf : Inf := Inf.mk univ
begin
  intro x, apply exists.intro (x+1),
  constructor, exact lt_succ_sum x 0, trivial,
end

/--
The initial set and number used to define
all the homogeneous projections.
-/
def init (f : [ℕ]² → color) := (⟨f, NatInf, 0⟩ : homogeneous_proj f)

/--
Iterate the procedure of refining a homogeneous projection.
TODO is is possible to remove this definition?
-/
def iterate_refinement (f : [ℕ]² → color)
    (cf : Π (x : homogeneous_proj f), (λ (x : homogeneous_proj f), homogeneous_proj f) x) :
  ℕ → homogeneous_proj f
| 0 := cf (init f)
| (n+1) := let p := iterate_refinement n in cf ⟨f, p, p.pt⟩

/--
There exists an infinet sequence of homogeneous projections,
each a refinement of the previous one.
-/
lemma exists_homo_proj_seq (f : [ℕ]² → color) :
∃ (g : ℕ → homogeneous_proj f), init f << g 0 ∧ ∀ n, g n << g (n+1) :=
begin
  have ac : ∃ (cf : Π (x : homogeneous_proj f), (λ (x : homogeneous_proj f), homogeneous_proj f) x),
    ∀ (p : homogeneous_proj f), (λ (p q : homogeneous_proj f), p<<q) p (cf p),
    exact axiom_of_choice (refine_homo_proj f),
  cases ac with cf Hcf,
  let g := λ m : ℕ, (iterate_refinement f cf m),
  apply exists.intro g,
  constructor,
  {
    exact Hcf (init f)
  },
  {
    intro n,
    have h1 : (g n) << cf (g n),
      exact Hcf (g n),
    have h2 : ∀ p : homogeneous_proj f, p = ⟨f, ↑p, p.pt⟩,
      intro p, cases p with H n, cases H with s pf, refl,
    have h3 : cf (g n) = iterate_refinement f cf (n+1),
      unfold iterate_refinement, simp, rw ← (h2 (g n)),
    simp * at *
  }
end

/--
The sets in a sequence of refined homogeneous projections are
closed upward under inclusion.
-/
lemma homo_proj_seq_mono_sets
  (f : [ℕ]² → color)
  (g : ℕ → homogeneous_proj f)
  (h : ∀ n, g n << g (n+1))
  (x y : ℕ) :
  (g (x+y)).s ⊆ (g x).s :=
begin
  induction y with y ih,
  {
    intros y hy, exact hy,
  },
  {
    intros a ha,
    exact ih ((h (x+y)).right.right.left ha),
  }
end

/--
The points in a sequence of refined homogeneous projections are
contained in the previous sets.
-/
lemma homo_proj_seq_mono_pts
  (f : [ℕ]² → color)
  (g : ℕ → homogeneous_proj f)
  (h : ∀ n, g n << g (n+1))
  (x y : ℕ) :
  (g (x+y+1)).pt ∈ (g x).s :=
by exact (homo_proj_seq_mono_sets f g h x y) ((h (x+y)).right.left)

/--
The points in a sequence of refined homogeneous projections have
the property that f {xᵢ, y} = f {xᵢ, z} for all xᵢ < y < z in Sₓ.
-/
lemma homo_proj_seq_stable_colors
  (f : [ℕ]² → color)
  (g : ℕ → homogeneous_proj f)
  (h0 : (init f) << g 0)
  (hn : ∀ n, g n << g (n+1))
  (x y : ℕ) :
  (project f (g x).pt) (g (x+1)).pt = (project f (g x).pt) (g (x+y+1)).pt :=
begin
  cases x,
  {
    have h : homogeneous (project f (g 0).pt) (g 0),
      exact h0.right.right.right,
    cases h with c hm,
    simp,
    rw hm ((g 1).pt) (homo_proj_seq_mono_pts f g hn 0 0),
    have hzy : y + 1 = 0 + y + 1, simp,
    rw hzy,
    rw hm ((g (0+y+1)).pt) (homo_proj_seq_mono_pts f g hn 0 y),
  },
  {
    have hgx : g x << g (x+1), exact (hn x),
    have hm : homogeneous (project f (g (x+1)).pt) (g (x+1)),
      exact hgx.right.right.right,
    cases hm with c Hm',
    rw Hm' ((g (x + 1 + 1)).pt) (homo_proj_seq_mono_pts f g hn (x+1) 0),
    rw Hm' ((g (x + 1 + y + 1)).pt) (homo_proj_seq_mono_pts f g hn (x+1) y),
  }
end

section increasing_functions

--TODO are the results of this section proved elsewhere in mathlib?

def increasing (f : ℕ → ℕ) := ∀ x y : ℕ, x < y → f x < f y

lemma increasing_by_step (f : ℕ → ℕ) :
  (∀ n : ℕ, f n < f (n+1)) → increasing f :=
λ (hf : ∀ n : ℕ, f n < f (n+1)) (x y : ℕ), nat.rec_on y
(λ (contr : x < 0), absurd contr (not_succ_le_zero x))
(λ (z : ℕ) (ih : x < z → f x < f z) (h : x < succ z),
or.cases_on (nat.eq_or_lt_of_le (le_of_lt_succ h))
(λ hxz : x = z, hxz ▸ (hf x))
(λ (hxz : x < z), lt_trans (ih hxz) (hf z)))

lemma x_le_fx_incr (f : ℕ → ℕ) (x : ℕ): increasing f → x ≤ f x :=
λ (incr : increasing f),
  nat.rec_on x (zero_le (f 0))
  (λ (n : ℕ) (ih : n ≤ f n),
  le_trans (succ_le_succ ih) (incr n (succ n) (lt_succ_self n)))

lemma incr_range_inf (H : Inf) (g : ℕ → ℕ) (hg : increasing g) :
  infinite (image g H) :=
begin
  intros x,
  have h : ∃ h, x < h ∧ h ∈ H, exact H.pf x,
  cases h with h Hh,
  apply exists.intro (g h),
  constructor,
  exact (lt_of_lt_of_le Hh.left (x_le_fx_incr g h hg)),
  unfold image,
  apply exists.intro h, constructor, exact Hh.right, refl,
end

lemma incr_dom (g : ℕ → ℕ) (hg : increasing g) (x y : ℕ) (h : g x < g y):
  x < y :=
begin
  cases (lt_trichotomy x y) with hlt hlte,
    exact hlt,
    cases hlte with hlt he, rw hlt at h,
    exact absurd h (lt_irrefl (g y)),
    exact absurd (lt_trans (hg y x he) h) (lt_irrefl (g y)),
end

end increasing_functions

/--
Trivial lemma needed below.
-/
lemma domain_dist_rw (x y : ℕ) (h : x < y): y = x + (y - (x+1)) + 1 :=
by rw [ add_assoc x (y - (x+1)) 1
      , add_comm (y - (x+1)) 1
      , ←add_assoc x 1 (y - (x+1))
      , add_sub_of_le (succ_le_of_lt h)]

/--
The points in a sequence of refined homogeneous projections
are increasing.
-/
lemma homo_proj_seq_incr
(f : [ℕ]² → color)
(g : ℕ → homogeneous_proj f)
(h : ∀ n, g n << g (n+1)) :
increasing (λ n : ℕ, (g n).pt) :=
begin
have h : ∀ n : ℕ, (g n).pt < (g (n+1)).pt,
intro, exact (h n).left,
exact increasing_by_step (λ n : ℕ, (g n).pt) h,
end

/--
Restrict a coloring of unordered pairs of all natural numbers
to unordered pairs of a given infinite set H.
-/
def restrict (f : [ℕ]² → color) (H : set ℕ) : [H]² → color :=
  λ h, f (⟨h.val, ⟨h.property.left, ⟨true.intro, true.intro⟩⟩⟩)

/--
The main theorem, stating that given a function from the unordered pairs of
natural numbers to a set with two elements, there exists an infinite set of
natural numbers whose unordered pairs are all given the same color.
-/
theorem infinite_ramsey_pairs_two_colors (f : [ℕ]² → color) :
  ∃ H : Inf, ∃ c : color,
  ∀ h : [H]²,
  (restrict f H) h = c :=
begin
  have hseq : ∃ (g : ℕ → homogeneous_proj f), init f << g 0 ∧ ∀ n, g n << g (n+1),
    exact exists_homo_proj_seq f,
  cases hseq with g Hg,
  cases Hg with HgInit HgSeq,
  let g' := (λ n, (g n).pt),
  let f' := (λ n, project f (g' n) (g' (n+1))),
  have HgIncr : increasing g', exact homo_proj_seq_incr f g HgSeq,
  let preH := (⟨image g' NatInf, incr_range_inf NatInf g' HgIncr⟩ : Inf),
  cases (pigeon_hole_principle f' preH) with Hred Hblue,

  any_goals { -- Red Case
    let H := (⟨reds f' preH, Hred⟩ : Inf),
    apply exists.intro (⟨image g' H, incr_range_inf H g' HgIncr⟩ : Inf),
    apply exists.intro red,
    intros p,
  },
  any_goals { -- Blue Case
    let H := (⟨blues f' preH, Hblue⟩ : Inf),
    apply exists.intro (⟨image g' H, incr_range_inf H g' HgIncr⟩ : Inf),
    apply exists.intro blue,
    intros p,
  },
  all_goals {
    have hp1 : p.val.fst ∈ image g' H, exact p.property.right.left,
    cases hp1 with h₁ Hh₁,
    have hfh₁ : f' h₁ = _, exact Hh₁.left.left,
    have hfgh₁ : project f (g' h₁) (g' (h₁+1)) = _, rw ←hfh₁,
    have hp2 : p.val.snd ∈ image g' H, exact p.property.right.right,
    cases hp2 with h₂ Hgh₂,
    have hg : p.val.fst < p.val.snd, exact p.property.left,
    rw [←Hh₁.right, ←Hgh₂.right] at hg,
    let d := h₂ - (h₁ + 1),
    have hd : h₂ = h₁ + d + 1,
      exact domain_dist_rw h₁ h₂ (incr_dom g' HgIncr h₁ h₂ hg),
    have stable :
      (project f (g' h₁)) (g' (h₁+1)) = (project f (g' h₁)) (g' (h₁+d+1)),
      exact homo_proj_seq_stable_colors f g HgInit HgSeq h₁ d,
    rw [hfgh₁, ←hd, Hh₁.right, Hgh₂.right] at stable,
    have hproj : f ⟨p.val, _⟩ = project f p.val.fst p.val.snd,
      exact project_eq f ⟨p.val, ⟨p.property.left, trivial, trivial⟩⟩,
    rw [←stable, hproj] at hproj,
    rw ←hproj, refl,
  }
end

end infinite_ramsey_pairs


theorem le_succ (a b : mynat) : a ≤ b → a ≤ (succ b) :=
begin
intro h,
rw le_iff_exists_add at h,
cases h with c hc,
rw hc,
use c + 1,
rw succ_eq_add_one,
refl,
end