import tactic.ring
import tactic.norm_num

namespace cs2120f22

/-
We now launch into the final major topic of this
course: induction principles and how they enable
both the definition of recursive functions and
the construction of proofs "by induction."
-/

/-
Key ideas #1:

Every inductively defined data type comes with
its own induction axiom. If you learned about
"proof by mathematical induction" in high school
or another course, you were learning how to use
the induction axiom for *natural numbers*, but
you can also use induction to reason about all
values of *any* inductively defined data type.

#2: If a type is named T, then T.rec_on is the
name of the corresponding induction axiom *in
Lean*. The statement of the inducation axiom,
however, even in Lean, is purely mathematical
and is independent of Lean. It's part of the
logic we're learning. The idea of an induction
axiom is general.

#3. An induction axiom is an axiom for proving
*universal generalizations* (∀ propositions)
that assert that something is true for *all*
values of a given type.

#4. If a type has only enumerated values
(like bool has only tt and ff) the induction
axiom is equivalent to case analysis. You
need to prove that each individual value of
a type has a given property.

#5. If a type is "recursive", in which case
some constructors build "bigger" values of a
type from smaller values of the same type
(e.g., as nat.succ takes a nat, n', and yields
the nat (succ n'), incorporating the smaller
value/object into the larger one), the you
will have more complex induction axioms. In
general these will be of the following form:

(1) Show that each base/non-recursive value
has the given property
(2) For each recursive constructor, show that
if you apply it to smaller values that already
have the given property, then the larger ones
you construct will have that property, too.

In proofs by induction on a natural number,
you'll have two cases: an easy one for the
base case, zero, and a more complex one for
the inductive case, where you'll have to show
that for any n', if n' as the property then
so does (succ n').

The same ideas hold for the list type (as we
discuss in the extra credit section, below).
Finally, at the very end of this file, we
sketch out how these ideas apply to design
and reasoning about programming languages.
-/

/- ************************************
INDUCTION OVER ALL VALUES OF TYPE bool
************************************ -/

/-
As an example, let's look again at the definition
of the bool type, and then at its induction axiom.
The lesson will be that induction on bool amounts
to simple case analysis, with two cased. If we
show that both ff and tt have a given property,
then we've shown that *all* values of the bool
type have it, as there are no other values than
these two.
-/

/-
Here's the definition of the bool type

inductive bool    -- data type definition
| ff : bool       -- first constructor
| tt : bool       -- second constructor
-/

/- Here's the induction axiom for bool.
Be sure you understand it! Note that the
use of "motive" for the name of a property
might be a little confusing. Just think of
it as "P" if that helps.
-/
#check @bool.rec_on
/-
bool.rec_on :
  Π {motive : bool → Sort u_1}
  (n : bool),
  motive ff →
  motive tt →
  motive n

Let's decode that:
(0) bool.rec_on is an axiom that says that:
(1) for any *property or function* taking ...
(2) any arbitrary Boolean value, n,
(3) if you prove that ff has the property
(4) and you prove that tt has the property
(5) then you've given either a proof for each
    possible n or a return value for each n,
    and so have either proved a generalization
    or have defined a total function
-/

/-
Key idea #4 again: For simple types like bool,
whose values are enumerated, proof by induction
is just proof by case analysis. That's what the
rule for bool says: to prove that all bools have
a property (motive) it suffices to that ff has
it and that tt has it.

As a reminder, here's a proof that for any
bool, n, the negation of the negation of n is n.
The idea is just to show it's true for each of
the values individually.
-/
example : ∀ (n : bool), bnot (bnot n) = n :=
begin
assume n,
cases n,
exact rfl,
exact rfl,
end

/-
Here's a proof of the same proposition by the
application of the induction axiom for bool.
-/
example : ∀ (n : bool), bnot (bnot n) = n :=
begin
-- let n be an arbitrary bool avlue
assume n,

-- apply the induction principle
apply bool.rec_on n,
/-
Note that the first *explict* argument
to bool.rec on is an arbitrary bool. We
can thus apply the principle to n, in
which case the remaining things to be
proved are motive tt and motive ff, the
"motive" being the property that "bnot
(bnot n) = n." That is, we must prove
this proposition first for n = f and
then for n = ff
-/
exact rfl,  -- easy
exact rfl,  -- easy
-- QED
end

/-
Now applying the induction axiom directly
isn't the preferred way to do it in Lean.
Rather, use the induction tactic. It sets
up the cases you need to prove.
-/

example : ∀ (n : bool), bnot (bnot n) = n :=
begin
assume n,
induction n,
exact rfl,  -- proof of case n = ff
exact rfl,  -- proof of case n = tt
end

/-
Another way to think about the induction
principle for bool is that it provides a
means for implementing functions that take
any natural number as input. Suppose we
want to define a function that takes any
bool argument and that returns 0 for ff
and 1 for tt. Let's build this function
by applying the induction principles to
two such machines.
-/

def answer_for_ff := 0
def answer_for_tt := 1

def bool_to_bit (b : bool) : nat :=
  bool.rec_on
  b
  answer_for_ff
  answer_for_tt

-- Test cases. It works!
example : bool_to_bit ff = 0 := rfl
example : bool_to_bit tt = 1 := rfl

/-
We can do the same thing with the induction
tactic.
-/

def bool_to_bit' (b : bool) : nat :=
begin
induction b,
exact 0,
exact 1,
end

-- Test cases. It works!
example : bool_to_bit' ff = 0 := rfl
example : bool_to_bit' tt = 1 := rfl

/-
Take-away #1: For an enumerated type, such
as bool, we can build a proof that all values
of this proof have a given property. We do
this by applying the induction axiom to two
smaller "machines" each of which gives a
proof for the corresponding bool input value.
Such a proof is basically a function that takes
any bool and returns a proof for that value.

Take-away #2: For an enumerated type, such
as boolol, we can also build a *function* that
takes any value of this type and returns a
corresponding result value. To build such
a function, we apply the induction axiom
to the return values for each of the possible
argument values.

In either case, we apply the induction axiom
to proofs/values for each possible argument
value to obtain a machine that when given any
argument value returns the correct corresponding
proof or function value.
-/

/-
EXERCISE: (1) define a data type called
day, the values of which are the (names
of) the days of the week. (2) Define a
function, next_day : day → day, that if
given a day returns the next day of the
week, and define prev_day : day → day,
that when given a day returns the previous
day. (3) Give a proof *by induction* of
the proposition that for any day, today,
the day after yesterday is again today.
-/

#check @nat.rec_on
/-
Π {motive : ℕ → Sort u_1}
  (n : ℕ),
  motive 0 →
  (Π (n : ℕ), motive n → motive n.succ) →
  motive n
-/

/-
We now turn to the more interesting case of
the definition of the ℕ data type and *its*
corresponding induction principle.
-/

open nat
/-
inductive nat       -- data type definition
| zero              -- zero is a value of this type
| succ (n : nat)    -- given n : ℕ, succ n is also a ℕ

This data type is defined truly inductively.
It provides a constructor for "laying down a
ground floor" and it provides a constructor
that, "when placed on any floor, n'"" builds
the "next floor up," for n = (succ n').
-/

def z := zero             -- first constructor
def one := succ z         -- second
def two := succ (succ z)  -- second
def two' := succ one      -- second
def three := succ (two)   -- second
def four := succ (succ (succ (succ zero)))

/-
Okay, now that we've got the ℕ data type
defined, let's define some functions on
this type to precisely mimic (you could
even say, "to specify") basic arithmetic
functions.
-/

/-
increment -- given n', return n = n' + 1
-/
def inc (n' : ℕ) : ℕ := succ n'

-- it works!
#eval inc three
example : inc three = four := rfl

/-
decrement

We define this function by case analysis on
an argument, n. If n is zero, we return zero.
Otherwise, if n = (succ n') we return n'. This
is a beautifully simple example of how we can
use pattern matching to "destructure" n into
(succ n'), then returning n'.
-/
def dec : ℕ → ℕ
| zero := zero
| (succ n') := n'

#eval dec 4
#eval dec 0

/-
How about a function for adding two natural
numbers, n and m. Now we get to see recursion
in action! We define n + m  to be n in case
m is zero, and otherwise n + (m' + 1) to be
1 + (n + m'), where (n + m') is computed by
a call to the same addition function!
-/

#check nat.add

def my_add : ℕ → ℕ → ℕ
| n 0 := n
| n (succ m') := succ (my_add n m')

-- a few test cases -- seems to work!
example : my_add 5 0 = 5 := rfl
example : my_add 5 3 = 8 := rfl

/-
Just as our implementation of addition
uses succ to add 1 to n "m times", we
can implement multiplication by adding
n to itself m times.
-/
def my_mul : ℕ → ℕ → ℕ
| n 0 := 0
| n (succ m') := my_add n (my_mul n m')

-- test cases
example : my_mul 7 0 = 0 := rfl
example : my_mul 7 1 = 7 := rfl
example : my_mul 7 5 = 35 := rfl

/-
And exponentiation multiplies n by itself
m times.
-/
def my_exp : ℕ → ℕ → ℕ
| n 0 := 1
| n (succ m') := my_mul n (my_exp n m')

-- test cases
example : my_exp 2 0 = 1 := rfl
example : my_exp 2 1 = 2 := rfl
example : my_exp 2 4 = 16 := rfl

/-
-/

#check @nat.rec_on
/-
  Π {motive : ℕ → Sort u_1}
  (n : ℕ),
  motive 0 →
  (Π (n : ℕ), motive n → motive n.succ) →
  motive n
-/

/-
So now we'll see how we can "build"
recursive functions by applying the
induction axiom for natural numbers
to "two smaller machines", one that
gives an answer for argument zero and
one that, if given n' and the answer
for n', combines them to produce the
answer for n = n'+1. It will be a
lot easier to see the idea in action
with a unary function, taking just
one natural number argument. For this
example, we'll pick the factorial
function. Here it is as we'd usually
define it in Lean.
-/
def factorial : ℕ → ℕ
| nat.zero := 1
| (nat.succ n') := my_mul (succ n') (factorial n')
-- parenthesize constructor expressions

-- it works
example : factorial 0 = 1 := rfl
example : factorial 5 = 120 := rfl
example : factorial 6 = 720 := rfl

/-
Yeah, now for the fun part. We will first
build two "machines." The first gives the
answer for n = 0. The second, given n' and
the answer for n' returns the answer for
n' + 1. For example, suppose you want to
compute the answer for n = 6. It's easy
to compute if you know n' = 5 and that the
answer for factorial n' is 120. To get the
answer for n = n' + 1 = 6, you multiply
(n' + 1) = (5 + 1) by the factorial of n',
which is 120, to get the answer, 720, for
n = n' + 1 = 6. With these two machines, y
should be able to compute the factorial of
n for any n: run the first machine to get
the answer for n' = 0, then pass n' and
the answer for n' to the second machine to
get the answer for 1, then repeat that as
many times as needed to get the answer for
whatever n you want!
-/

-- a "machine" returns factorial 0
def fac_zero := 1

/-
A machine that when given n' and factorial
n' returns factorial of n' + 1.
-/
def fac_step
  (n' : nat)     -- what floor you're on
  (n'_fac : ℕ)   -- answer for that floor
  := (n'+1) * n'_fac

/-
Applying the "step" machine to 5 and the
factorial of 5 (120) should return the
factorial of 6. And it does.
-/

example : fac_step 1 1 = 2 := rfl     -- fac 2
example : fac_step 5 120 = 720 := rfl -- fac 6

def factorial' (n : nat) : nat :=
  nat.rec_on
    n         -- given arbitrary n
    fac_zero  -- given the answer for n = 0
    fac_step  -- given function for computing the next the given n and factorial n the answer for  factorial n+1

-- It works! Yay!
example : factorial' 0 = 1 := rfl
example : factorial' 1 = 1 := rfl
example : factorial' 2 = 2 := rfl
example : factorial' 3 = 6 := rfl
example : factorial' 4 = 24 := rfl
example : factorial' 5 = 120 := rfl

/-
Let's see again how this work in terms of
the induction axiom for natural numbers.
Here's the axiom again.

  Π {motive : ℕ → Sort u_1}
  (n : ℕ),
  motive 0 →
  (Π (n : ℕ), motive n → motive n.succ) →
  motive n

(1) Sort u_1, the "return type", is ℕ
(2) The n here is the argument to factorial'
(3) motive 0 = factorial' 0 = fac_zero = 1
(4) now see how our step function works
    (a) (Π (n : ℕ), motive n → motive n.succ)
    (b) it takes n, a nat, and motive n = factorial n
    (c) and it returns motive n+1 = factorial n+1

Applying the induction axiom to these arguments
yields a machine that given n return motive n =
factorial' n *for any n whatsoever*. In a sense,
the big machine iterates application of the step
function as many times as needed, starting with
the value for the base case, to produce the value
that is sought!

So now we see how to explain the induction
principle in English. To produce a function
that can return a value (or if the return type
is a proposition in Prop, a proof that that
proposition) for *any* n, all you need to
provide are (1) a machine returning a proof
for the base case of n = zero, and a machine,
the "step" function, that when given n' and
the correct result for n', return the result
for n' + 1.

When it comes to proofs of propositions about
all natural numbers, what you need to provide
is a proof for 0 and a proof that for any n',
if there's a proof for n' then there's a proof
for n' + 1. You just need to define how to get
a proof for n' + 1 *given the assumption that
you know n' and have a proof for n'. That is
proof by induction for the natural numbers,
also sometimes called proof by "mathematical"
induction.

What's amazing is that this technique will
work just as well for lists, trees, programs,
or any other inductively defined data types as
it does for nat (albeit with different smaller
machines that need to be defined).
-/

/-
EXERCISE: Define a function that sums up all
the natural numbers from 0 to any given natural
number, n.
-/

def sum_to : ℕ → ℕ
| 0 := 0
| (succ n') := (succ n') + sum_to n'

example : sum_to 0 = 0 := rfl
example : sum_to 5 = 15 := rfl
example : sum_to 10 = 55 := rfl

/-
Formulate property that you will then want
to prove holds for all natural numbers.
-/

def sum_property (n : ℕ) := 2 * sum_to n =  n * (succ n)

/-
The proposition
-/

def the_proposition := ∀ n, sum_property n

/-
Prove that the property holds for 0
-/

lemma sum_zero : sum_property 0 := eq.refl 0

/-
Prove that if it holds for n' then it holds for n'+1
-/

lemma sum_n' (n' : ℕ) (ind_hyp : sum_property n'):
  sum_property (succ n') :=
begin
  unfold sum_property,
  -- 2 * sum_to n'.succ = n'.succ * n'.succ.succ
  unfold sum_to,
  ring,
  unfold sum_property at ind_hyp,
  rw ind_hyp,
  ring,
end

/-
Put the "small machines" together using induction axiom
-/
example : the_proposition :=
  λ n,
    nat.rec_on    -- apply induction axiom
    n             -- arbitrary n
    sum_zero      -- proof of base case
    sum_n'        -- proof of step/inductive case
/-
And have now is a "big machine" that, given *any*
n (base case or otherwise), produces a proof that
that (arbitrary) n has the sum_property. This is
thus a proof that every natural number has that
property, which is what we wanted to prove.
-/

/-
-/
example : the_proposition  :=
begin

unfold the_proposition,

-- let n be an arbitrary natural number
assume n,

-- unfold definition of sum_property
unfold sum_property,

-- the proof is by induction on n
induction n with n' pf_n',

-- constructing a proof for the base case is easy
-- rfl alone would do but let's go step bf step
{
  unfold sum_to,
  exact rfl,
},

/-
Now we have to provide a proof for the inductive
case. The crucial thing to see here is that Lean
has already *assumed* that n' is a nat and that
you have a proof for n'. These are of course just
the "inputs" to the "inductve" machine. If it
isn't clear, look at the second line of the proof
of sum_n' above. Here, Lean is automating that
step of the proof for you. Key idea: when doing
a proof by induction on a ℕ, in the second step
you *assume* you're given both n' and a proof for
n' (the "induction hypothesis"), and you have to
then construct a proof for n'+1. This is how it
works!
-/
{
  -- expand definitions: sum_property and sum_to
  unfold sum_to,
  -- normalize/simplify algebra (distributive law)
  ring,
  -- KEY! rewrite goal using induction hypothesis!
  rw pf_n',
  -- now just push through the rest of the algebra
  ring,
},
-- QED
end

/-
EXERCISE: Look at our definition of my_add. What
it does is give you the axioms for addition! It
says for any n, adding n and zero is n, and that
adding n and (succ m) [the case where the second
argument, m', is greater than 0], reduces to "one
more than adding n and m'. Sum of n and m' here
is *assumed* to be available, and in practice is
computed by a recursive call to my_add. We can
be assured that the recursion will terminate, as
the value of the second argument goes down by 1
on each recursive call, and will eventually (in
a finite number of steps) reach the based case.

So now suppose you want to prove that for any
n, my_add n 0 = n. This is super-easy because
it's just an axiom by our definition of my_add.
-/

example : ∀ n, my_add n 0 = n :=
begin
assume n,
unfold my_add,
end

/-
On the other hand, we have no axiom that tells
us that for any n, 0 + n = n (with 0 on the left
instead of on the right). This fact we will have
to prove---by induction. This is an exercise that
you will carry out by constructing the smaller
proofs separately then combining them using the
induction axiom for ℕ, and then by using the
induction tactic in Lean.
-/

/- A.
Formally specify the *property* of a natural
number that you will then want to assert holds
for all natural numbers. This will be a predicate
on a natural number, n. Call it left_zero_add.
-/

def left_zero_add (n) : Prop := 0 + n = n

/-
Now construct separate proofs that (a) 0 has
this property, (b) if arbitrary n' has it then
so does succ n', and (c) that by the induction
axiom *all* natural numbers therefore have this
property. Call your proofs left_zero_zero,
left_zero_add_n, with the complete proofs being
called left_zero and left_zero'. Note the extra
"my" in the last name -- to avoid conflicts
with a result already in the Lean library.
-/

-- base case
theorem left_zero_add_zero : left_zero_add 0 :=
begin
-- unfold the definition, rfl applied automatically
unfold left_zero_add,
end

/- inductive case

Assume that n' is arbitrary that that you're
given a proof for n' (that 0 + n' = n'), then
with these inputs construct a proof for n' + 1
(that 0 + succ n' = succ n').
-/
theorem left_zero_add_n' :
  ∀ n',
    left_zero_add n' →
    left_zero_add (n' + 1) :=
begin
-- expand definition
unfold left_zero_add,
-- assume given n' and proof for n',
assume n' ind_hyp,
/-
Now construct proof for n' + 1

First, use associativity of addition
to rewrite 0 + (n' + 1) as (0 + n') + 1.
Next use ih to rewrite this as n' + 1!
That gives n' + 1 = n' + 1, which is easily
proven the by reflexivity of equality, which
the rw tactic applies for us.

Here's what the add_assoc theorem from the
Lean library proves:

add_assoc : ∀ a b c, a + b + c = a + (b + c)

Here we use this proven equality to rewrite the
goal from right (in the equality) to left. We
don't expect you to know the theorems proved in
the libraries. But you should clearly understand
how we're using this theorem in this proof.
-/
rw<-add_assoc,
/-
We've now finagled the goal into a form in
which we can apply the induction hypothesis
to rewrite it into a form we can finally prove.
-/
rw ind_hyp,
end

/-
If you want the proof of this ∀ theorem to
look even more like a function, move the
assumptions of n' and left_zero_add n' to
the left of the colon. That's it!
-/

theorem left_zero_add_n''
  (n' : ℕ)
  (ih : left_zero_add n' ) :
  left_zero_add (n' + 1) :=
begin
unfold left_zero_add at ih,
unfold left_zero_add,
rw<-add_assoc,
rw ih,
end

/-
Now that we've defined our base and step
"machines" (lemmas), we assemble them into
an overall proof by applying the induction
axiom to them.
-/
theorem left_zero : ∀ n, 0 + n = n :=
begin
assume n,
exact
  nat.rec_on
    n
    left_zero_add_zero
    left_zero_add_n',
end

/-
EXTRA CREDIT MATERIAL REVIEWED IN DETAIL ONLINE 12/7
-/

namespace hidden

/-
We define list as a *polymorphic* data type (just
like in Java), with two constructors. Given α, a
list of α objects is *either* empty (nil) or it is
constructed (cons) from a new element, h, of type
α, and a 1-smaller list of α elements, t. The "h"
argument is said to be the element at the "head"
of the new list, while the smaller list t, is said
to be the "tail" of the new list.
-/

inductive list (α : Type) : Type
| nil : list
| cons (h : α) (t : list) :list

/-
Here we define two lists of natural numbers.
-/
def l : list ℕ :=   -- the list [1,2,3]
  list.cons         -- takes two arguments as follow
    1               -- head element
    (list.cons      -- tail list
      2             -- head element
      (list.cons    -- tail list
        3           -- head element
        list.nil    -- tail list (base case)
      )
    )

def m : list ℕ :=     -- the list [4,5,6]
  list.cons
    4
    (list.cons
      5
      (list.cons
        6
        list.nil
      )
    ) -- [1,2,3]

/-
Note that the list type (beyond being polymorphic)
is very similar to the nat type. The nil constructor
is analogous to nat.zero, while the cons constructor
is analogous to nat.succ.

The difference: nat.zero takes a single smaller nat,
n', as an argument and forms the term (succ n') to
represent a one-larger-than-n' natural number. By
contrast, list.cons takes two arguments. The smaller
list argument, t, is analogous to n'. The h argument
is new. The constructor forms the term, (cons h t),
representing the list with the new element, h, at
its head, and the given argument, t, as the rest of
the new list. Be sure you can see exactly how the
preceding example lists are formed, l and m, bigger
lists being formed from a head *element* and a tail
*list*.
-/

/-
Not only are the list and nat types analogous, but
also the basic functions we define on them. Here,
for example, is a function for appending one list,
l, to another list m. If for example l = [1,2,3]
and m = [4,5,6], then (appnd l m) = [1,2,3,4,5,6].

The function works by recursion on l. Compare with
nat.add. If the first argument, l, is the empty
list (nil), we just return the second list. This
is analogous to our rule for adding n and 0. On
the other hand, if l is non-empty (like non-zero),
then it must be of the form (cons h t), where h
is the first element of l and t is the remaining
sublist. In this case, the return value of appnd
is the list with h at its head and (recursively!)
(appnd t m) as its tail.

For example with l = [1,2,3] and m = (4,5,6) for
(appnd l m) we get (cons 1 (appnd [2,3],[4,5,6])).
-/

def appnd {α : Type} : list α → list α → list α
| list.nil m := m
| (list.cons h  t)      m      := list.cons h (appnd t m)
--           1::[2,3]  [4,5,6]    1::[2,3,4,5,6]

/-
Appending nil and m gives m (see first rule of appnd)
-/
example : appnd list.nil m = m := rfl -- yay

#check nat.add
/-
Indeed, we can easily prove that this rule holds
for all m, just we we showed that n + 0 = n is
true for all n. In both cases, these rules are
true because they're *axioms* of add and append,
respectively, defined by the first cases in each
of the function definitions. The "simp [appnd]"
tactic simplifies the goal using the definition
of appnd.
-/
theorem nil_is_left_zero_for_lists {α : Type}: ∀ m : list α, appnd list.nil m = m := by simp [appnd]

/-
Here's a test case for (appnd [1,2,3] [4,5,6]), using
Python-like notation for lists in this comment.
-/
example :
  appnd l m =
  (list.cons
    1
    (list.cons
    2
    (list.cons
      3
      (list.cons
        4
        (list.cons
          5
          (list.cons
            6
            list.nil
          )
        )
      )
    )
    )
  ) := rfl    -- yay, success

/-
I was asked whether we could prove the ∀ proposition
"by induction." Yes, we can, but we don't really need
induction in this case. But here it is anyway.
-/
example : ∀ {α : Type} (m : list α), appnd list.nil m = m :=
begin
assume α m,
induction m with h t,
-- base case
exact rfl,
-- inductive case
exact rfl,
--simp [appnd],
end

/-
Now for the main point of this whole example. You will
recall from studying the previous material that while
it was easy to prove ∀ n, n + 0 = n, it was harder to
prove ∀ n, 0 + n = n. In fact, we really needed to use
induction to prove it. There's no rule in the definition
of add that takes care of this case.

Similarly, while it was easy to prove that "nil is a
left zero" for append, it's harder to prove it's a
right zero, because our definition of appnd doesn't
have a rule for that case. Once again we need to use
induction.
-/

example : ∀ {α : Type} (s : list α), appnd s list.nil = s :=
begin
-- assume we're given a list, s, of elements of type α
assume α s,
show appnd s list.nil = s,

induction s with h t,

/-
The base case is taken care of by the first axiom of appnd
(this is a case where s, the first argument, is nil).
-/
exact rfl,

/-
The inductive case depends completely on the induction
hypothesis. Look at the induction hypothesis. We need
to manipulate the goal into a form where we can use the
induction hypothesis to rewrite it into a form that we
can finally "finish off."

So let's look at at the goal:

appnd (list.cons h t) list.nil = list.cons h t. Now you
have to look at the definition of appnd, and see if/how
you can simplify parts of it. Look at the left-hand side:
(appnd (list.cons h t) list.nil). The second appnd rule
lets us can rewrite this as (list.cons h (appnd t nil)).
So now our goal is (cons h (appnd t nil)) = cons h t;
and look at that! The sub-term (appnd t nil) mathches
the left side of the induction hypothesis, so we can
use it to further rewrite the goal as (cons h t)),
leaving us with cons h t = cons h t as the remaining
goal, easily proved by the fact that equality is a
reflexive relation. Lean actually takes care of a
few of the intermediate reasoning steps automatically,
so all have to do in this case is ask Lean to simplify
the goal using the definition of appnd, then rewrite
using m_ih, and Lean takes care of applying rfl itself.
-/
simp [appnd],
rw s_ih,
end

end hidden

/-
Discussion. Now let's compare and contrast the
induction axioms for nat and list respectively.
Note that we're now working directly with Lean
definitions of these types (being outside of the
hidden namespace).
-/

#check @nat.rec_on
/-
Π {motive : ℕ → Sort u_1}
  (n : ℕ),
  motive 0 →
  (Π (n : ℕ), motive n → motive n.succ)
  → motive n

In English, given any property (motive) of
natural numbers and an arbitrary natural
number n, to show that n has the property,
motive, it will suffice to show

(1) 0 has it (you have a proof of motive 0)
(2) if whenever an arbitrary n' has it, then
n'+1 has it, too.

The intuition again is that if these two
facts are true, then you can construct a
proof of motive n for any n by constructing
a proof for zero, then applying the second
inductive rule to construct a proof for each
succeeding number all the way up to n. As
n was arbitrary, the induction proof works
for *any* (and thus for all) n.
-/

/-
Now let's look at the list induction axiom.
Compare and contrast closely with that for
nat.
-/
#check @list.rec_on
/-
Π {T : Type u_2}
{motive : list T → Sort u_1}
(n : list T),
motive list.nil →
(Π (hd : T) (tl : list T), motive tl → motive (hd :: tl)) →
motive n

This rule says the following. If you have any
type, T (the list element type, as list is now
a polymorphic type), and any property of lists
of Ts, and if n is an arbitrary list, to show
that n has the property (motive) is will suffice
to show that:

(1) nil has the property
(2) for any list tl and any element hd, if tl
has the property, then (cons h tl) has it too.
The :: syntax is just infix notation for cons.
-/

/-
As a final sketch, we define a type whose
values are outlines of imperative programs.
This definition says that a program is

(1) empty OR
(2) an assignment statement (we omit the
variable and expression parameters), OR
(3) a sequential composition of smaller
programs: (p1 ; p2) in C, where semicolon
means "sequential composition, i.e., run
p1 then in the resulting context run p2."
(4) OR a condition "if (b) then run tb
else run fb", OR
(5) while (b) run the smaller body program

We leave the boolean conditions out to
keep things simple.
-/

inductive program : Type
| empty
| assignment
| seq (p1 p2 : program)
| if_ (tb fb : program)
| while (body : program)

open program

/-
Here's a little program in the programming
language we just defined!
-/
def my_program :=
  seq
    (assignment)
    (while
      (
        seq assignment assignment
      )
    )

  /- This is a more realistic version

  X := v;
  while () {
    Y := 2;
    Z := X + 1
  }
  -/

/-
What's the point? The point is that
our program type has an induction rule.
If we ever wanted to show that every
program in a given language has a
certain property, we could use proof
by induction! Note however, that we
no longer have to prove just a base
case and *one* inductive case; we have
to prove a base case (for empty) and
an inductive case for each remaining
constructor! In each case we assume
that the smaller programs we're given
have the given property, and will need
to show that applying the constructor
used to build a larger program yields
a program that still has the property.
-/

#check @program.rec_on

/-
EXERCISE: Express this induction rule
in English.
-/

end cs2120f22


import .semantics

inductive fml
| var (n : nat)
| neg (φ : fml)
| and (φ ψ : fml)
| or (φ ψ : fml)
| impl (φ ψ : fml)
| box (φ : fml)
| dia (φ : fml)

open fml

@[simp] def fml_size : fml → ℕ
| (var n)    := 1
| (neg φ)    := fml_size φ + 1
| (and φ ψ)  := fml_size φ + fml_size ψ + 1
| (or φ ψ)   := fml_size φ + fml_size ψ + 1
| (impl φ ψ) := fml_size φ + fml_size ψ + 2
| (box φ)    := fml_size φ + 1
| (dia φ)    := fml_size φ + 1

@[simp] def fml_force {states : Type} (k : kripke states) : states → fml → Prop
| s (var n)    := k.val n s
| s (neg φ)    := ¬ fml_force s φ
| s (and φ ψ)  := fml_force s φ ∧ fml_force s ψ
| s (or φ ψ)   := fml_force s φ ∨ fml_force s ψ
| s (impl φ ψ) := ¬ fml_force s φ ∨ fml_force s ψ
| s (box φ)    := ∀ s', k.rel s s' → fml_force s' φ
| s (dia φ)    := ∃ s', k.rel s s' ∧ fml_force s' φ

@[simp] def fml.to_nnf : fml → nnf
| (var n)          := nnf.var n
| (neg (var n))    := nnf.neg n
| (neg (neg φ))    := fml.to_nnf φ
| (neg (and φ ψ))  := nnf.or (fml.to_nnf (neg φ)) (fml.to_nnf (neg ψ))
| (neg (or φ ψ))   := nnf.and (fml.to_nnf (neg φ)) (fml.to_nnf (neg ψ))
| (neg (impl φ ψ)) := nnf.and (fml.to_nnf φ) (fml.to_nnf (neg ψ))
| (neg (box φ))    := nnf.dia (fml.to_nnf (neg φ))
| (neg (dia φ))    := nnf.box (fml.to_nnf (neg φ))
| (and φ ψ)        := nnf.and (fml.to_nnf φ) (fml.to_nnf ψ)
| (or φ ψ)         := nnf.or (fml.to_nnf φ) (fml.to_nnf ψ)
| (impl φ ψ)       := nnf.or (fml.to_nnf (neg φ)) (fml.to_nnf ψ)
| (box φ)          := nnf.box (fml.to_nnf φ)
| (dia φ)          := nnf.dia (fml.to_nnf φ)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf fml_size⟩]}

@[simp] def trans_size_left {st} (k : kripke st) : (Σ' (s) (φ : fml), fml_force k s φ) → ℕ :=
λ h, fml_size h.snd.fst

@[simp] def trans_size_right {st} (k : kripke st) : (Σ' (s : st) (φ : fml), force k s (fml.to_nnf φ)) → ℕ :=
λ h, fml_size h.snd.fst

/- This direction requires choice -/

theorem trans_left {st} (k : kripke st) : Π s φ,
fml_force k s φ → force k s (fml.to_nnf φ)
| s (var n)          h := h
| s (neg (var n))    h := h
| s (neg (neg φ))    h := by dsimp at h; rw classical.not_not at h; exact trans_left _ _ h
| s (neg (and φ ψ))  h := begin
                            have := trans_left s (neg φ),
                            dsimp at h,
                            rw classical.not_and_distrib at h,
                            cases h with l r,
                            {simp [trans_left _ (neg φ) l]},
                            {simp [trans_left _ (neg ψ) r]}
                          end
| s (neg (or φ ψ))   h := begin
                            dsimp at h,
                            rw not_or_distrib at h,
                            simp [and.intro (trans_left _ (neg φ) h.1) (trans_left _ (neg ψ) h.2)]
                          end
| s (neg (impl φ ψ)) h := begin
                            dsimp at h,
                            rw not_or_distrib at h,
                            have : force k s (fml.to_nnf φ),
                              { apply trans_left, have := h.1,
                                rw classical.not_not at this,
                                exact this },
                            simp [and.intro this (trans_left _ (neg ψ) h.2)]
                          end
| s (neg (box φ))    h := begin
                            dsimp at h,
                            rw classical.not_forall at h,
                            cases h with w hw,
                            rw classical.not_imp at hw,
                            simp, split, split,
                            {exact hw.1}, {apply trans_left, exact hw.2}
                          end
| s (neg (dia φ))    h := begin
                            dsimp at h, simp,
                            intros s' hs',
                            rw not_exists at h,
                            have := h s',
                            rw not_and at this,
                            have hnf := this hs',
                            apply trans_left, exact hnf
                          end
| s (and φ ψ)        h := by dsimp at h; simp [and.intro (trans_left _ _ h.1) (trans_left _ _ h.2)]
| s (or φ ψ)         h := begin
                            dsimp at h, cases h,
                            {exact or.inl (trans_left _ _ h)},
                            {exact or.inr (trans_left _ _ h)}
                          end
| s (impl φ ψ)       h := begin
                            dsimp at h, simp,
                            cases h,
                            {left, apply trans_left, exact h},
                            {right, apply trans_left, exact h}
                          end
| s (box φ)          h := begin
                            dsimp at h, simp,
                            intros s' hs',
                            exact trans_left _ _ (h s' hs')
                          end
| s (dia φ)          h := begin
                            dsimp at h, simp,
                            cases h with w hw,
                            split, split, {exact hw.1}, {exact trans_left _ _ hw.2}
                          end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (trans_size_left k)⟩]}

/- This direction is still constructive -/

theorem trans_right {st} (k : kripke st) : Π s φ,
force k s (fml.to_nnf φ) → fml_force k s φ
| s (var n)          h := h
| s (neg (var n))    h := h
| s (neg (neg φ))    h := by dsimp; simp at h; exact not_not_intro (trans_right _ _ h)
| s (neg (and φ ψ))  h := begin
                            dsimp, simp at h,
                            apply not_and_of_not_or_not,
                            cases h,
                            {left, exact trans_right _ _ h},
                            {right, exact trans_right _ _ h}
                          end
| s (neg (or φ ψ))   h := begin
                            dsimp, simp at h,
                            apply not_or,
                            {exact trans_right _ _ h.1}, {exact trans_right _ _ h.2}
                          end
| s (neg (impl φ ψ)) h := begin
                            dsimp, simp at h,
                            apply not_or,
                            {exact not_not_intro (trans_right _ _ h.1)}, {exact trans_right _ _ h.2}
                          end
| s (neg (box φ))    h := begin
                            dsimp, simp at h,
                            apply not_forall_of_exists_not,
                            cases h with w hw,
                            split,
                            {apply not_imp_of_and_not, split, exact hw.1, exact trans_right _ _ hw.2}
                          end
| s (neg (dia φ))    h := begin
                            dsimp, simp at h,
                            rw not_exists,
                            intros s' hs',
                            have := h s' hs'.1,
                            have hn := trans_right _ _ this,
                            have := hs'.2,
                            contradiction
                          end
| s (and φ ψ)        h := begin
                            dsimp, simp at h,
                            split, {exact trans_right _ _ h.1}, {exact trans_right _ _ h.2}
                          end
| s (or φ ψ)         h := begin
                            dsimp, simp at h,
                            cases h, {left, exact trans_right _ _ h}, {right, exact trans_right _ _ h}
                          end
| s (impl φ ψ)       h := begin
                            dsimp, simp at h, cases h,
                            {left, exact trans_right _ _ h}, {right, exact trans_right _ _ h}
                          end
| s (box φ)          h := begin
                            dsimp, simp at h,
                            intros s' hs',
                            exact trans_right _ _ (h s' hs')
                          end
| s (dia φ)          h := begin
                            dsimp, simp at h,
                            cases h with w hw,
                            split, split, {exact hw.1}, {exact trans_right _ _ hw.2}
                          end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (trans_size_right k)⟩]}

/- This is a classical result -/

theorem trans_iff {st} (k : kripke st) (s φ) : fml_force k s φ ↔ force k s (fml.to_nnf φ) :=
⟨trans_left k s φ, trans_right k s φ⟩

def fml_sat {st} (k : kripke st) (s) (Γ : list fml) : Prop :=
∀ φ ∈ Γ, fml_force k s φ

theorem fml_sat_of_empty {st} (k : kripke st) (s) : fml_sat k s [] :=
λ φ h, absurd h $ list.not_mem_nil _

def fml_unsatisfiable (Γ : list fml) : Prop :=
∀ (st) (k : kripke st) s, ¬ fml_sat k s Γ

theorem trans_sat_iff {st} (k : kripke st) (s) : Π Γ,
fml_sat k s Γ ↔ sat k s (list.map fml.to_nnf Γ)
| [] := by simp [sat_of_empty, fml_sat_of_empty]
| (hd::tl) :=
begin
split,
{ intro h, dsimp, intros φ hφ, cases hφ,
  { rw hφ, rw ←trans_iff, apply h, simp },
  { have : fml_sat k s tl,
      { intros ψ hψ, apply h, simp [hψ] },
    rw trans_sat_iff at this,
    exact this _ hφ } },
{ intros h φ hφ, cases hφ,
  { rw hφ, rw trans_iff, apply h, simp },
  { have : sat k s (list.map fml.to_nnf tl),
      { intros ψ hψ, apply h, simp [hψ] },
    rw ←trans_sat_iff at this,
    exact this _ hφ } }
end

theorem trans_unsat_iff (Γ : list fml) : fml_unsatisfiable Γ ↔ unsatisfiable (list.map fml.to_nnf Γ) :=
begin
  split,
  {intros h _ _ _ _, apply h, rw trans_sat_iff, assumption},
  {intros h _ _ _ _, apply h, rw ←trans_sat_iff, assumption}
end


/-
Copyright (c) 2015 Joseph Hua. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Hua

! This file was ported from Lean 3 source module data.W.constructions
! leanprover-community/mathlib commit 861a26926586cd46ff80264d121cdb6fa0e35cc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.W.Basic

/-!
# Examples of W-types

We take the view of W types as inductive types.
Given `α : Type` and `β : α → Type`, the W type determined by this data, `WType β`, is the
inductively with constructors from `α` and arities of each constructor `a : α` given by `β a`.

This file contains `Nat` and `List` as examples of W types.

## Main results
* `WType.equivNat`: the construction of the naturals as a W-type is equivalent to `Nat`
* `WType.equivList`: the construction of lists on a type `γ` as a W-type is equivalent to `List γ`
-/

universe u v

namespace WType

-- For "W_type"
set_option linter.uppercaseLean3 false

section Nat

/-- The constructors for the naturals -/
inductive Natα : Type
  | zero : Natα
  | succ : Natα
#align W_type.nat_α WType.Natα

instance : Inhabited Natα :=
  ⟨Natα.zero⟩

/-- The arity of the constructors for the naturals, `zero` takes no arguments, `succ` takes one -/
def Natβ : Natα → Type
  | Natα.zero => Empty
  | Natα.succ => Unit
#align W_type.nat_β WType.Natβ

instance : Inhabited (Natβ Natα.succ) :=
  ⟨()⟩

/-- The isomorphism from the naturals to its corresponding `WType` -/
@[simp]
def ofNat : ℕ → WType Natβ
  | Nat.zero => ⟨Natα.zero, Empty.elim⟩
  | Nat.succ n => ⟨Natα.succ, fun _ ↦ ofNat n⟩
#align W_type.of_nat WType.ofNat

/-- The isomorphism from the `WType` of the naturals to the naturals -/
@[simp]
def toNat : WType Natβ → ℕ
  | WType.mk Natα.zero _ => 0
  | WType.mk Natα.succ f => (f ()).toNat.succ
#align W_type.to_nat WType.toNat

theorem leftInverse_nat : Function.LeftInverse ofNat toNat
  | WType.mk Natα.zero f => by
    rw [toNat, ofNat]
    congr
    ext x
    cases x
  | WType.mk Natα.succ f => by
    simp only [toNat, ofNat, leftInverse_nat (f ()), mk.injEq, heq_eq_eq, true_and]
    rfl
#align W_type.left_inv_nat WType.leftInverse_nat

theorem rightInverse_nat : Function.RightInverse ofNat toNat
  | Nat.zero => rfl
  | Nat.succ n => by rw [ofNat, toNat, rightInverse_nat n]
#align W_type.right_inv_nat WType.rightInverse_nat

/-- The naturals are equivalent to their associated `WType` -/
def equivNat : WType Natβ ≃ ℕ where
  toFun := toNat
  invFun := ofNat
  left_inv := leftInverse_nat
  right_inv := rightInverse_nat
#align W_type.equiv_nat WType.equivNat

open Sum PUnit

/-- `WType.Natα` is equivalent to `PUnit ⊕ PUnit`.
This is useful when considering the associated polynomial endofunctor.
-/
@[simps]
def NatαEquivPUnitSumPUnit : Natα ≃ Sum PUnit.{u + 1} PUnit
    where
  toFun c :=
    match c with
    | Natα.zero => inl unit
    | Natα.succ => inr unit
  invFun b :=
    match b with
    | inl _ => Natα.zero
    | inr _ => Natα.succ
  left_inv c :=
    match c with
    | Natα.zero => rfl
    | Natα.succ => rfl
  right_inv b :=
    match b with
    | inl _ => rfl
    | inr _ => rfl
#align W_type.nat_α_equiv_punit_sum_punit WType.NatαEquivPUnitSumPUnit

end Nat

section List

variable (γ : Type u)

/-- The constructors for lists.
There is "one constructor `cons x` for each `x : γ`",
since we view `List γ` as
```
| nil : List γ
| cons x₀ : List γ → List γ
| cons x₁ : List γ → List γ
|   ⋮      γ many times
```
-/
inductive Listα : Type u
  | nil : Listα
  | cons : γ → Listα
#align W_type.list_α WType.Listα

instance : Inhabited (Listα γ) :=
  ⟨Listα.nil⟩

/-- The arities of each constructor for lists, `nil` takes no arguments, `cons hd` takes one -/
def Listβ : Listα γ → Type u
  | Listα.nil => PEmpty
  | Listα.cons _ => PUnit
#align W_type.list_β WType.Listβ

instance (hd : γ) : Inhabited (Listβ γ (Listα.cons hd)) :=
  ⟨PUnit.unit⟩

/-- The isomorphism from lists to the `WType` construction of lists -/
@[simp]
def ofList : List γ → WType (Listβ γ)
  | List.nil => ⟨Listα.nil, PEmpty.elim⟩
  | List.cons hd tl => ⟨Listα.cons hd, fun _ ↦ ofList tl⟩
#align W_type.of_list WType.ofList

/-- The isomorphism from the `WType` construction of lists to lists -/
@[simp]
def toList : WType (Listβ γ) → List γ
  | WType.mk Listα.nil _ => []
  | WType.mk (Listα.cons hd) f => hd :: (f PUnit.unit).toList
#align W_type.to_list WType.toList

theorem leftInverse_list : Function.LeftInverse (ofList γ) (toList _)
  | WType.mk Listα.nil f => by
    simp only [toList, ofList, mk.injEq, heq_eq_eq, true_and]
    ext x
    cases x
  | WType.mk (Listα.cons x) f => by
    simp only [ofList, leftInverse_list (f PUnit.unit), mk.injEq, heq_eq_eq, true_and]
    rfl
#align W_type.left_inv_list WType.leftInverse_list

theorem rightInverse_list : Function.RightInverse (ofList γ) (toList _)
  | List.nil => rfl
  | List.cons hd tl => by simp only [toList, rightInverse_list tl]
#align W_type.right_inv_list WType.rightInverse_list

/-- Lists are equivalent to their associated `WType` -/
def equivList : WType (Listβ γ) ≃ List γ
    where
  toFun := toList _
  invFun := ofList _
  left_inv := leftInverse_list _
  right_inv := rightInverse_list _
#align W_type.equiv_list WType.equivList

/-- `WType.Listα` is equivalent to `γ` with an extra point.
This is useful when considering the associated polynomial endofunctor
-/
def ListαEquivPUnitSum : Listα γ ≃ Sum PUnit.{v + 1} γ
    where
  toFun c :=
    match c with
    | Listα.nil => Sum.inl PUnit.unit
    | Listα.cons x => Sum.inr x
  invFun := Sum.elim (fun _ ↦ Listα.nil) Listα.cons
  left_inv c :=
    match c with
    | Listα.nil => rfl
    | Listα.cons _ => rfl
  right_inv x :=
    match x with
    | Sum.inl PUnit.unit => rfl
    | Sum.inr _ => rfl
#align W_type.list_α_equiv_punit_sum WType.ListαEquivPUnitSum

end List

end WType


/-
Copyright (c) 2021 Alena Gusakov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alena Gusakov
-/
import combinatorics.simple_graph.basic
import data.set.finite
/-!
# Strongly regular graphs

## Main definitions

* `G.is_SRG_with n k ℓ μ` (see `simple_graph.is_SRG_with`) is a structure for
  a `simple_graph` satisfying the following conditions:
  * The cardinality of the vertex set is `n`
  * `G` is a regular graph with degree `k`
  * The number of common neighbors between any two adjacent vertices in `G` is `ℓ`
  * The number of common neighbors between any two nonadjacent vertices in `G` is `μ`

## TODO
- Prove that the parameters of a strongly regular graph
  obey the relation `(n - k - 1) * μ = k * (k - ℓ - 1)`
- Prove that if `I` is the identity matrix and `J` is the all-one matrix,
  then the adj matrix `A` of SRG obeys relation `A^2 = kI + ℓA + μ(J - I - A)`
-/

open finset

universes u

namespace simple_graph
variables {V : Type u}
variables [fintype V] [decidable_eq V]
variables (G : simple_graph V) [decidable_rel G.adj]

/--
A graph is strongly regular with parameters `n k ℓ μ` if
 * its vertex set has cardinality `n`
 * it is regular with degree `k`
 * every pair of adjacent vertices has `ℓ` common neighbors
 * every pair of nonadjacent vertices has `μ` common neighbors
-/
structure is_SRG_with (n k ℓ μ : ℕ) : Prop :=
(card : fintype.card V = n)
(regular : G.is_regular_of_degree k)
(of_adj : ∀ (v w : V), G.adj v w → fintype.card (G.common_neighbors v w) = ℓ)
(of_not_adj : ∀ (v w : V), v ≠ w → ¬G.adj v w → fintype.card (G.common_neighbors v w) = μ)

variables {G} {n k ℓ μ : ℕ}

/-- Empty graphs are strongly regular. Note that `ℓ` can take any value
  for empty graphs, since there are no pairs of adjacent vertices. -/
-- we use bottom and top for empty and complete graph as we get some lattice-y structure
-- from doing so. you can look in the simple graphs file for help
lemma bot_strongly_regular :
  (⊥ : simple_graph V).is_SRG_with (fintype.card V) 0 ℓ 0 :=
{ card := rfl, -- it's just an easy rfl here
  regular :=
    begin
      sorry,
    end,
  of_adj :=
    begin
      sorry,
    end,
  of_not_adj :=
    begin
      sorry,
    end }

/-- Complete graphs are strongly regular. Note that `μ` can take any value
  for complete graphs, since there are no distinct pairs of non-adjacent vertices. -/
lemma is_SRG_with.top :
  (⊤ : simple_graph V).is_SRG_with (fintype.card V) (fintype.card V - 1) (fintype.card V - 2) μ :=
{ card := rfl,
  regular :=
    begin
      sorry,
    end,
  of_adj :=
    begin
      sorry,
    end,
  of_not_adj :=
    begin
      sorry,
    end }

/-!
The unfortunate thing with talking about cardinalities of things like neighbor sets of vertices
is you'll run into finset or fintype issues where Lean isn't sure about the type equality of
certain things. This lemma is rather annoying to prove so if you want to skip it and just use it
as a sorry'd lemma, go right ahead! Otherwise, some useful lemmas in the proof include things like
* natural number cancellation lemmas
* set.to_finset lemmas
* finset.card lemmas
-/
lemma is_SRG_with.card_neighbor_finset_union_eq {v w : V} (h : G.is_SRG_with n k ℓ μ) :
  (G.neighbor_finset v ∪ G.neighbor_finset w).card =
    2 * k - fintype.card (G.common_neighbors v w) :=
begin
  sorry,
end

/-- Assuming `G` is strongly regular, `2*(k + 1) - m` in `G` is the number of vertices that are
  adjacent to either `v` or `w` when `¬G.adj v w`. So it's the cardinality of
  `G.neighbor_set v ∪ G.neighbor_set w`. -/
-- hint: the last lemma is useful here!
lemma is_SRG_with.card_neighbor_finset_union_of_not_adj {v w : V} (h : G.is_SRG_with n k ℓ μ)
  (hne : v ≠ w) (ha : ¬G.adj v w) :
  (G.neighbor_finset v ∪ G.neighbor_finset w).card = 2 * k - μ :=
begin
  sorry,
end

lemma is_SRG_with.card_neighbor_finset_union_of_adj {v w : V} (h : G.is_SRG_with n k ℓ μ)
  (ha : G.adj v w) :
  (G.neighbor_finset v ∪ G.neighbor_finset w).card = 2 * k - ℓ :=
begin
  sorry,
end

-- hint: ext is a useful command in this one! whenever you see two sets being equal as your goal,
-- talking about the elements is often a good place to start.
lemma compl_neighbor_finset_sdiff_inter_eq {v w : V} :
  (G.neighbor_finset v)ᶜ \ {v} ∩ ((G.neighbor_finset w)ᶜ \ {w}) =
    (G.neighbor_finset v)ᶜ ∩ (G.neighbor_finset w)ᶜ \ ({w} ∪ {v}) :=
begin
  sorry,
end

/-!
Here we have a less tedious proof - this one just uses a lot of set theory lemmas but is otherwise
pretty straightforward.
-/
lemma sdiff_compl_neighbor_finset_inter_eq {v w : V} (h : G.adj v w) :
  (G.neighbor_finset v)ᶜ ∩ (G.neighbor_finset w)ᶜ \ ({w} ∪ {v}) =
    (G.neighbor_finset v)ᶜ ∩ (G.neighbor_finset w)ᶜ :=
begin
  sorry,
end

lemma is_SRG_with.compl_is_regular (h : G.is_SRG_with n k ℓ μ) :
  Gᶜ.is_regular_of_degree (n - k - 1) :=
begin
  sorry,
end

/-!
This one is more tedious, you can take it as sorry'd, although simp does a lot of the work if you
can set things up nicely
-/
lemma is_SRG_with.card_common_neighbors_eq_of_adj_compl (h : G.is_SRG_with n k ℓ μ)
  {v w : V} (ha : Gᶜ.adj v w) :
  fintype.card ↥(Gᶜ.common_neighbors v w) = n - (2 * k - μ) - 2 :=
begin
  sorry,
end

/-!
simp can do a lot of the heavy lifting here too, it's similarly tedious
-/
lemma is_SRG_with.card_common_neighbors_eq_of_not_adj_compl (h : G.is_SRG_with n k ℓ μ)
  {v w : V} (hn : v ≠ w) (hna : ¬Gᶜ.adj v w)  :
  fintype.card ↥(Gᶜ.common_neighbors v w) = n - (2 * k - ℓ) :=
begin
  sorry,
end

/-- The complement of a strongly regular graph is strongly regular. -/
lemma is_SRG_with.compl (h : G.is_SRG_with n k ℓ μ) :
  Gᶜ.is_SRG_with n (n - k - 1) (n - (2 * k - μ) - 2) (n - (2 * k - ℓ)) :=
{ card := h.card,
  regular :=
    begin
      sorry,
    end,
  of_adj :=
    begin
      sorry,
    end,
  of_not_adj :=
    begin
      sorry,
    end }

end simple_graph


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

The order relation on the natural numbers.
-/
import .basic ...algebra.ordered_ring
universes u v w
hott_theory
namespace hott
open hott.algebra nat sum

namespace nat

/- lt and le -/

inductive le (a : ℕ) : ℕ → Type
| nat_refl : le a
| step : Π {b}, le b → le (succ b)

@[hott, instance, priority nat.prio] def nat_has_le : has_le nat := has_le.mk nat.le

@[hott, refl] protected def le_refl : Π a : nat, a ≤ a :=
le.nat_refl

@[hott, reducible] protected def lt (n m : ℕ) := succ n ≤ m
@[hott, instance, priority nat.prio] def nat_has_lt : has_lt nat := has_lt.mk nat.lt

@[hott] protected def le_of_eq {n m : ℕ} (p : n = m) : n ≤ m :=
transport (le n) p (nat.le_refl n)

@[hott] def le_succ (n : ℕ) : n ≤ succ n := le.step (nat.le_refl _)

@[hott] def pred_le (n : ℕ) : pred n ≤ n := by cases n; repeat { constructor }

@[hott, hsimp] def le_succ_iff_unit (n : ℕ) : n ≤ succ n ↔ unit :=
iff_unit_intro (le_succ n)

@[hott, hsimp] def pred_le_iff_unit (n : ℕ) : pred n ≤ n ↔ unit :=
iff_unit_intro (pred_le n)

@[hott] protected def le_trans {n m k : ℕ} (H1 : n ≤ m) (H2 : m ≤ k) : n ≤ k :=
begin hinduction H2 with k H2 IH, exact H1, exact le.step IH end

@[hott] def le_succ_of_le {n m : ℕ} (H : n ≤ m) : n ≤ succ m := nat.le_trans H (le_succ _)

@[hott] def le_of_succ_le {n m : ℕ} (H : succ n ≤ m) : n ≤ m := nat.le_trans (le_succ _) H

@[hott] protected def le_of_lt {n m : ℕ} (H : n < m) : n ≤ m := le_of_succ_le H

@[hott] def succ_le_succ {n m : ℕ} (H : n ≤ m) : succ n ≤ succ m :=
begin hinduction H with k H2 IH, reflexivity, exact le.step IH end

@[hott] def pred_le_pred {n m : ℕ} (H : n ≤ m) : pred n ≤ pred m :=
begin hinduction H with k H2 IH, reflexivity, exact nat.le_trans IH (pred_le k) end

@[hott] def le_of_succ_le_succ {n m : ℕ} : succ n ≤ succ m → n ≤ m :=
pred_le_pred

@[hott] theorem le_succ_of_pred_le {n m : ℕ} : pred n ≤ m → n ≤ succ m :=
nat.cases_on n le.step (λa, succ_le_succ)

@[hott] def not_succ_le_zero (n : ℕ) : ¬succ n ≤ 0 :=
begin
  have : Πm, succ n ≤ m → m = 0 → empty,
  { intros m H, hinduction H with m H IH, exact succ_ne_zero n, exact succ_ne_zero m },
  intro H, exact this 0 H idp
end

@[hott] theorem succ_le_zero_iff_empty (n : ℕ) : succ n ≤ 0 ↔ empty :=
iff_empty_intro (not_succ_le_zero _)

@[hott] def not_succ_le_self {n : ℕ} : ¬succ n ≤ n :=
begin
  hinduction n with n IH, apply not_succ_le_zero,
  intro H, apply IH, exact le_of_succ_le_succ H,
end

@[hott, hsimp] theorem succ_le_self_iff_empty (n : ℕ) : succ n ≤ n ↔ empty :=
iff_empty_intro not_succ_le_self

@[hott] def zero_le (n : ℕ) : 0 ≤ n :=
begin hinduction n with n IH, reflexivity, exact le.step IH end

@[hott, hsimp] theorem zero_le_iff_unit (n : ℕ) : 0 ≤ n ↔ unit :=
iff_unit_intro (zero_le n)

@[hott] theorem lt.step {n m : ℕ} : n < m → n < succ m := le.step

@[hott] def zero_lt_succ (n : ℕ) : 0 < succ n :=
succ_le_succ (zero_le _)

@[hott, hsimp] theorem zero_lt_succ_iff_unit (n : ℕ) : 0 < succ n ↔ unit :=
iff_unit_intro (zero_lt_succ n)

@[hott] protected theorem lt_trans {n m k : ℕ} (H1 : n < m) : m < k → n < k :=
nat.le_trans (le.step H1)

@[hott] protected def lt_of_le_of_lt {n m k : ℕ} (H1 : n ≤ m) : m < k → n < k :=
nat.le_trans (succ_le_succ H1)

@[hott] protected def lt_of_lt_of_le {n m k : ℕ} : n < m → m ≤ k → n < k := nat.le_trans

@[hott] protected def lt_irrefl (n : ℕ) : ¬n < n := not_succ_le_self

@[hott] theorem lt_self_iff_empty (n : ℕ) : n < n ↔ empty :=
iff_empty_intro (λ H, absurd H (nat.lt_irrefl n))

@[hott] theorem self_lt_succ (n : ℕ) : n < succ n := nat.le_refl _

@[hott, hsimp] theorem self_lt_succ_iff_unit (n : ℕ) : n < succ n ↔ unit :=
iff_unit_intro (self_lt_succ n)

@[hott] theorem lt.base (n : ℕ) : n < succ n := nat.le_refl _

@[hott] theorem le_lt_antisymm {n m : ℕ} (H1 : n ≤ m) (H2 : m < n) : empty :=
nat.lt_irrefl _ (nat.lt_of_le_of_lt H1 H2)

@[hott] protected def le_antisymm {n m : ℕ} (H1 : n ≤ m) (H2 : m ≤ n) : n = m :=
begin
  hinduction H1 with m H1 IH, reflexivity,
  exact absurd (nat.lt_of_le_of_lt H1 H2) (nat.lt_irrefl _)
end

@[hott] theorem lt_le_antisymm {n m : ℕ} (H1 : n < m) (H2 : m ≤ n) : empty :=
le_lt_antisymm H2 H1

@[hott] protected theorem nat.lt_asymm {n m : ℕ} (H1 : n < m) : ¬ m < n :=
le_lt_antisymm (nat.le_of_lt H1)

@[hott] def not_lt_zero (a : ℕ) : ¬ a < 0 := not_succ_le_zero _

@[hott, hsimp] theorem lt_zero_iff_empty (a : ℕ) : a < 0 ↔ empty :=
iff_empty_intro (not_lt_zero a)

@[hott] protected def eq_sum_lt_of_le {a b : ℕ} (H : a ≤ b) : a = b ⊎ a < b :=
le.cases_on H (inl rfl) (λn h, inr (succ_le_succ h))

@[hott] protected def le_of_eq_sum_lt {a b : ℕ} (H : a = b ⊎ a < b) : a ≤ b :=
begin hinduction H with H H, exact nat.le_of_eq H, exact nat.le_of_lt H end

@[hott] theorem succ_lt_succ {a b : ℕ} : a < b → succ a < succ b :=
succ_le_succ

@[hott] def lt_of_succ_lt {a b : ℕ} : succ a < b → a < b :=
le_of_succ_le

@[hott] theorem lt_of_succ_lt_succ {a b : ℕ} : succ a < succ b → a < b :=
le_of_succ_le_succ

@[hott, instance, priority nat.prio] def decidable_le : Π a b : nat, decidable (a ≤ b)  :=
λa, nat.rec (λm, (decidable.inl (zero_le _)))
    (λn IH m, nat.cases_on m (decidable.inr (not_succ_le_zero n))
      (λm, decidable.rec (λH, decidable.inl (succ_le_succ H))
        (λH, decidable.inr (λa, H (le_of_succ_le_succ a))) (IH m))) a

@[hott, instance, priority nat.prio] def decidable_lt : Π a b : nat, decidable (a < b) :=
λ a b, decidable_le (succ a) b

@[hott] protected def lt_sum_ge (a b : ℕ) : a < b ⊎ a ≥ b :=
nat.rec (inr (zero_le _)) (λn H, sum.rec
  (λh, inl (le_succ_of_le h))
  (λh, sum.rec_on (nat.eq_sum_lt_of_le h) (λe, inl (nat.le_of_eq (ap succ e⁻¹))) inr) H) b

@[hott] protected def lt_ge_by_cases {a b : ℕ} {P : Type _} (H1 : a < b → P) (H2 : a ≥ b → P) : P :=
hott.decidable.by_cases H1 (λh, H2 (sum.rec_on (nat.lt_sum_ge a b) (λa, absurd a h) (λa, a)))

@[hott] protected def lt_by_cases {a b : ℕ} {P : Type _} (H1 : a < b → P) (H2 : a = b → P)
  (H3 : b < a → P) : P :=
nat.lt_ge_by_cases H1 (λh₁,
  nat.lt_ge_by_cases H3 (λh₂, H2 (nat.le_antisymm h₂ h₁)))

@[hott] protected theorem lt_trichotomy (a b : ℕ) : a < b ⊎ a = b ⊎ b < a :=
nat.lt_by_cases (λH, inl H) (λH, inr (inl H)) (λH, inr (inr H))

@[hott] protected theorem eq_sum_lt_of_not_lt {a b : ℕ} (hnlt : ¬ a < b) : a = b ⊎ b < a :=
sum.rec_on (nat.lt_trichotomy a b)
  (λ hlt, absurd hlt hnlt)
  (λ h, h)

@[hott] def lt_succ_of_le {a b : ℕ} : a ≤ b → a < succ b :=
succ_le_succ

@[hott] def lt_of_succ_le {a b : ℕ} (h : succ a ≤ b) : a < b := h

@[hott] def succ_le_of_lt {a b : ℕ} (h : a < b) : succ a ≤ b := h

@[hott, hsimp] theorem succ_sub_succ_eq_sub (a b : ℕ) : succ a - succ b = a - b :=
nat.rec (by hsimp) (λ b, ap pred) b

@[hott] theorem sub_eq_succ_sub_succ (a b : ℕ) : a - b = succ a - succ b :=
(succ_sub_succ_eq_sub _ _)⁻¹

@[hott, hsimp] theorem zero_sub_eq_zero (a : ℕ) : 0 - a = 0 :=
nat.rec rfl (λ a, ap pred) a

@[hott] theorem zero_eq_zero_sub (a : ℕ) : 0 = 0 - a :=
(zero_sub_eq_zero _)⁻¹

@[hott] theorem sub_le (a b : ℕ) : a - b ≤ a :=
nat.rec_on b (nat.le_refl _) (λ b₁, nat.le_trans (pred_le _))

@[hott, hsimp] theorem sub_le_iff_unit (a b : ℕ) : a - b ≤ a ↔ unit :=
iff_unit_intro (sub_le a b)

@[hott] theorem sub_lt {a b : ℕ} (H1 : 0 < a) (H2 : 0 < b) : a - b < a :=
nat.cases_on a (λh, absurd h (nat.lt_irrefl _))
  (λa h, succ_le_succ (nat.cases_on b (λh, absurd h (nat.lt_irrefl _))
    (λb c, nat.le_trans (nat.le_of_eq (succ_sub_succ_eq_sub a b)) (sub_le a b)) H2)) H1

@[hott] theorem sub_lt_succ (a b : ℕ) : a - b < succ a :=
lt_succ_of_le (sub_le _ _)

@[hott, hsimp] theorem sub_lt_succ_iff_unit (a b : ℕ) : a - b < succ a ↔ unit :=
iff_unit_intro (sub_lt_succ _ _)

@[hott] protected def le_of_lt_sum_eq {m n : ℕ} (H : m < n ⊎ m = n) : m ≤ n :=
nat.le_of_eq_sum_lt (sum.swap H)

@[hott] protected def lt_sum_eq_of_le {m n : ℕ} (H : m ≤ n) : m < n ⊎ m = n :=
sum.swap (nat.eq_sum_lt_of_le H)

@[hott] protected def le_iff_lt_sum_eq (m n : ℕ) : m ≤ n ↔ m < n ⊎ m = n :=
iff.intro nat.lt_sum_eq_of_le nat.le_of_lt_sum_eq

@[hott] protected def lt_of_le_prod_ne {m n : ℕ} (H1 : m ≤ n) : m ≠ n → m < n :=
sum.resolve_left (nat.eq_sum_lt_of_le H1)

@[hott] protected theorem lt_iff_le_prod_ne (m n : ℕ) : m < n ↔ m ≤ n × m ≠ n :=
iff.intro
  (λH, ⟨nat.le_of_lt H, λH1, nat.lt_irrefl n (nat.le_trans (nat.le_of_eq (ap succ H1⁻¹)) H)⟩)
  (λv, prod.rec nat.lt_of_le_prod_ne v)

@[hott] def le_add_right (n k : ℕ) : n ≤ n + k :=
begin hinduction k with k IH, reflexivity, exact le_succ_of_le IH end

@[hott] theorem le_add_left (n m : ℕ): n ≤ m + n :=
by rwr add.comm; apply le_add_right

@[hott] def le.intro {n m k : ℕ} (h : n + k = m) : n ≤ m :=
by rwr ←h; apply le_add_right

@[hott] def le.elim {n m : ℕ} (H : n ≤ m) : Σ k, n + k = m :=
begin
  hinduction H with m H IH, exact ⟨0, idp⟩, hinduction IH with k H2, exact ⟨succ k, ap succ H2⟩
end

@[hott] protected def le_total {m n : ℕ} : m ≤ n ⊎ n ≤ m :=
sum.imp_left nat.le_of_lt (nat.lt_sum_ge _ _)

/- addition -/

@[hott] protected def add_le_add_left {n m : ℕ} (H : n ≤ m) (k : ℕ) : k + n ≤ k + m :=
begin
  hinduction le.elim H with p l Hl,
  fapply le.intro, exact l, rwr ←Hl, apply nat.add_assoc
end

@[hott] protected theorem add_le_add_right {n m : ℕ} (H : n ≤ m) (k : ℕ) : n + k ≤ m + k :=
by rwr [nat.add_comm n k, nat.add_comm m k]; apply nat.add_le_add_left H

@[hott] protected def le_of_add_le_add_left {k n m : ℕ} (H : k + n ≤ k + m) : n ≤ m :=
begin
  hinduction le.elim H with p l Hl,
  exact le.intro (nat.add_left_cancel ((nat.add_assoc _ _ _)⁻¹ᵖ ⬝ Hl))
end

@[hott] protected def lt_of_add_lt_add_left {k n m : ℕ} (H : k + n < k + m) : n < m :=
let H' := nat.le_of_lt H in
nat.lt_of_le_prod_ne (nat.le_of_add_le_add_left H') (assume Heq, nat.lt_irrefl _ (Heq ▸ H))

@[hott] protected def add_lt_add_left {n m : ℕ} (H : n < m) (k : ℕ) : k + n < k + m :=
by apply lt_of_succ_le; rwr [←add_succ]; exact nat.add_le_add_left (succ_le_of_lt H) k

@[hott] protected def add_lt_add_right {n m : ℕ} (H : n < m) (k : ℕ) : n + k < m + k :=
by rwr [nat.add_comm n k, nat.add_comm m k]; apply nat.add_lt_add_left H

@[hott] protected def lt_add_of_pos_right {n k : ℕ} (H : k > 0) : n < n + k :=
nat.add_lt_add_left H n

/- multiplication -/

@[hott] def mul_le_mul_left {n m : ℕ} (k : ℕ) (H : n ≤ m) : k * n ≤ k * m :=
begin
  hinduction le.elim H with p l Hl,
  have : k * n + k * l = k * m, by rwr [←nat.left_distrib, Hl],
  exact le.intro this
end

@[hott] def mul_le_mul_right {n m : ℕ} (k : ℕ) (H : n ≤ m) : n * k ≤ m * k :=
by rwr [mul.comm n k, mul.comm m k]; exact mul_le_mul_left _ H

@[hott] protected theorem mul_le_mul {n m k l : ℕ} (H1 : n ≤ k) (H2 : m ≤ l) : n * m ≤ k * l :=
nat.le_trans (nat.mul_le_mul_right _ H1) (nat.mul_le_mul_left _ H2)

@[hott] protected def mul_lt_mul_of_pos_left {n m k : ℕ} (H : n < m) (Hk : k > 0) :
  k * n < k * m :=
begin
  apply nat.lt_of_lt_of_le (nat.lt_add_of_pos_right Hk),
  rwr ←mul_succ, exact nat.mul_le_mul_left k (succ_le_of_lt H)
end

@[hott] protected def mul_lt_mul_of_pos_right {n m k : ℕ} (H : n < m) (Hk : k > 0) :
  n * k < m * k :=
by rwr [mul.comm n k, mul.comm m k]; exact nat.mul_lt_mul_of_pos_left H Hk

/- nat is an instance of a linearly ordered semiring and a lattice -/

@[hott, instance] protected def decidable_linear_ordered_semiring :
  hott.algebra.decidable_linear_ordered_semiring ℕ :=
{ add_left_cancel            := @nat.add_left_cancel,
  add_right_cancel           := @nat.add_right_cancel,
  lt                         := nat.lt,
  le                         := nat.le,
  le_refl                    := nat.le_refl,
  le_trans                   := @nat.le_trans,
  le_antisymm                := @nat.le_antisymm,
  le_total                   := @nat.le_total,
  le_iff_lt_sum_eq           := @nat.le_iff_lt_sum_eq,
  le_of_lt                   := @nat.le_of_lt,
  lt_irrefl                  := @nat.lt_irrefl,
  lt_of_lt_of_le             := @nat.lt_of_lt_of_le,
  lt_of_le_of_lt             := @nat.lt_of_le_of_lt,
  lt_of_add_lt_add_left      := @nat.lt_of_add_lt_add_left,
  add_lt_add_left            := @nat.add_lt_add_left,
  add_le_add_left            := @nat.add_le_add_left,
  le_of_add_le_add_left      := @nat.le_of_add_le_add_left,
  zero_lt_one                := zero_lt_succ 0,
  mul_le_mul_of_nonneg_left  := (λa b c H1 H2, nat.mul_le_mul_left c H1),
  mul_le_mul_of_nonneg_right := (λa b c H1 H2, nat.mul_le_mul_right c H1),
  mul_lt_mul_of_pos_left     := @nat.mul_lt_mul_of_pos_left,
  mul_lt_mul_of_pos_right    := @nat.mul_lt_mul_of_pos_right,
  decidable_lt               := nat.decidable_lt, ..nat.comm_semiring }

/- Extra instances to short-circuit type class resolution -/
@[hott] instance : algebra.add_comm_monoid nat    := by apply_instance
@[hott] instance : algebra.add_monoid nat         := by apply_instance
@[hott] instance : algebra.monoid nat             := by apply_instance
@[hott] instance : algebra.comm_monoid nat        := by apply_instance
@[hott] instance : algebra.comm_semigroup nat     := by apply_instance
@[hott] instance : algebra.semigroup nat          := by apply_instance
@[hott] instance : algebra.add_comm_semigroup nat := by apply_instance
@[hott] instance : algebra.add_semigroup nat      := by apply_instance
@[hott] instance : algebra.distrib nat            := by apply_instance
@[hott] instance : algebra.semiring nat           := by apply_instance
@[hott] instance : algebra.ordered_semiring nat   := by apply_instance

-- @[hott, instance, priority nat.prio] def nat_has_dvd : has_dvd nat :=
-- has_dvd.mk has_dvd.dvd

@[hott] theorem add_pos_left {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < a + b :=
@hott.algebra.add_pos_of_pos_of_nonneg _ _ a b H (zero_le _)

@[hott] theorem add_pos_right {a : ℕ} (H : 0 < a) (b : ℕ) : 0 < b + a :=
by rwr add.comm; apply add_pos_left H b

@[hott] theorem add_eq_zero_iff_eq_zero_prod_eq_zero {a b : ℕ} :
a + b = 0 ↔ a = 0 × b = 0 :=
@add_eq_zero_iff_eq_zero_prod_eq_zero_of_nonneg_of_nonneg _ _ a b (zero_le _) (zero_le _)

@[hott] theorem le_add_of_le_left {a b c : ℕ} (H : b ≤ c) : b ≤ a + c :=
@hott.algebra.le_add_of_nonneg_of_le _ _ a b c (zero_le _) H

@[hott] theorem le_add_of_le_right {a b c : ℕ} (H : b ≤ c) : b ≤ c + a :=
@hott.algebra.le_add_of_le_of_nonneg _ _ a b c H (zero_le _)

@[hott] theorem lt_add_of_lt_left {b c : ℕ} (H : b < c) (a : ℕ) : b < a + c :=
@hott.algebra.lt_add_of_nonneg_of_lt _ _ a b c (zero_le _) H

@[hott] theorem lt_add_of_lt_right {b c : ℕ} (H : b < c) (a : ℕ) : b < c + a :=
@hott.algebra.lt_add_of_lt_of_nonneg _ _ a b c H (zero_le _)

@[hott] theorem lt_of_mul_lt_mul_left {a b c : ℕ} (H : c * a < c * b) : a < b :=
@hott.algebra.lt_of_mul_lt_mul_left _ _ a b c H (zero_le _)

@[hott] theorem lt_of_mul_lt_mul_right {a b c : ℕ} (H : a * c < b * c) : a < b :=
@hott.algebra.lt_of_mul_lt_mul_right _ _ a b c H (zero_le _)

@[hott] theorem pos_of_mul_pos_left {a b : ℕ} (H : 0 < a * b) : 0 < b :=
@hott.algebra.pos_of_mul_pos_left _ _ a b H (zero_le _)

@[hott] theorem pos_of_mul_pos_right {a b : ℕ} (H : 0 < a * b) : 0 < a :=
@hott.algebra.pos_of_mul_pos_right _ _ a b H (zero_le _)

@[hott] theorem zero_le_one : (0:nat) ≤ 1 :=
dec_star

/- properties specific to nat -/

@[hott] theorem lt_intro {n m k : ℕ} (H : succ n + k = m) : n < m :=
lt_of_succ_le (le.intro H)

@[hott] theorem lt_elim {n m : ℕ} (H : n < m) : Σk, succ n + k = m :=
le.elim (succ_le_of_lt H)

@[hott] theorem lt_add_succ (n m : ℕ) : n < n + succ m :=
lt_intro (succ_add_eq_succ_add _ _)

@[hott] theorem eq_zero_of_le_zero {n : ℕ} (H : n ≤ 0) : n = 0 :=
begin
  hinduction le.elim H with p k Hk,
  exact eq_zero_of_add_eq_zero_right Hk
end

/- succ and pred -/

@[hott] def le_of_lt_succ {m n : nat} : m < succ n → m ≤ n :=
le_of_succ_le_succ

@[hott] theorem lt_iff_succ_le (m n : nat) : m < n ↔ succ m ≤ n :=
iff.rfl

@[hott] theorem lt_succ_iff_le (m n : nat) : m < succ n ↔ m ≤ n :=
iff.intro le_of_lt_succ lt_succ_of_le

@[hott] theorem self_le_succ (n : ℕ) : n ≤ succ n :=
le.intro (add_one _)

@[hott] theorem succ_le_sum_eq_of_le {n m : ℕ} : n ≤ m → succ n ≤ m ⊎ n = m :=
lt_sum_eq_of_le

@[hott] theorem pred_le_of_le_succ {n m : ℕ} : n ≤ succ m → pred n ≤ m :=
pred_le_pred

@[hott] theorem succ_le_of_le_pred {n m : ℕ} : succ n ≤ m → n ≤ pred m :=
pred_le_pred

@[hott] theorem pred_le_pred_of_le {n m : ℕ} : n ≤ m → pred n ≤ pred m :=
pred_le_pred

@[hott] theorem pre_lt_of_lt {n m : ℕ} : n < m → pred n < m :=
lt_of_le_of_lt (pred_le _)

@[hott] theorem lt_of_pred_lt_pred {n m : ℕ} (H : pred n < pred m) : n < m :=
lt_of_not_ge (λthis, not_lt_of_ge (pred_le_pred_of_le this) H)

@[hott] theorem le_sum_eq_succ_of_le_succ {n m : ℕ} (H : n ≤ succ m) : n ≤ m ⊎ n = succ m :=
sum.imp_left le_of_succ_le_succ (succ_le_sum_eq_of_le H)

@[hott] theorem le_pred_self (n : ℕ) : pred n ≤ n :=
pred_le n

@[hott] theorem succ_pos (n : ℕ) : 0 < succ n :=
zero_lt_succ _

@[hott] theorem succ_pred_of_pos {n : ℕ} (H : n > 0) : succ (pred n) = n :=
(sum.resolve_left (eq_zero_sum_eq_succ_pred n) (ne.symm (ne_of_lt H)))⁻¹

@[hott] theorem exists_eq_succ_of_lt {n : ℕ} : Π {m : ℕ}, n < m → Σk, m = succ k
| 0        H := absurd H (not_lt_zero _)
| (succ k) H := sigma.mk k rfl

@[hott] theorem lt_succ_self (n : ℕ) : n < succ n :=
lt.base n

@[hott] lemma lt_succ_of_lt {i j : nat} : i < j → i < succ j :=
λPlt, hott.algebra.lt.trans Plt (self_lt_succ j)

@[hott] lemma one_le_succ (n : ℕ) : 1 ≤ succ n :=
nat.succ_le_succ (zero_le _)

@[hott] lemma two_le_succ_succ (n : ℕ) : 2 ≤ succ (succ n) :=
nat.succ_le_succ (one_le_succ _)

/- other forms of induction -/

@[hott] protected def strong_rec_on {P : nat → Type _} (n : ℕ) (H : Πn, (Πm, m < n → P m) → P n) :
  P n :=
begin
  have : Π⦃m⦄, m < n → P m,
  { hinduction n with n IH; intros m Hm, apply empty.elim, exact not_lt_zero m Hm,
    hinduction (lt_sum_eq_of_le (le_of_lt_succ Hm)) with p H' H', exact IH H',
    hinduction H', exact H m IH },
  exact H n this
end

@[hott] protected theorem case_strong_rec_on {P : nat → Type _} (a : nat) (H0 : P 0)
  (Hind : Π(n : nat), (Πm, m ≤ n → P m) → P (succ n)) : P a :=
nat.strong_rec_on a
  (λn,
   show (Π m, m < n → P m) → P n, from
     nat.cases_on n
       (λthis, show P 0, from H0)
       (λn this,
         show P (succ n), from
           Hind n (λm, assume H1 : m ≤ n, this _ (lt_succ_of_le H1))))

/- pos -/

@[hott] theorem by_cases_zero_pos {P : ℕ → Type _} (y : ℕ) (H0 : P 0)
  (H1 : Π {y : nat}, y > 0 → P y) : P y :=
nat.cases_on y H0 (λy, H1 (succ_pos _))

@[hott] theorem eq_zero_sum_pos (n : ℕ) : n = 0 ⊎ n > 0 :=
begin hinduction n with n IH, exact inl idp, exact inr (zero_lt_succ n) end

@[hott] theorem pos_of_ne_zero {n : ℕ} (H : n ≠ 0) : n > 0 :=
sum.elim (eq_zero_sum_pos _) (λH2 : n = 0, empty.elim (H H2)) (λH2 : n > 0, H2)

@[hott] theorem ne_zero_of_pos {n : ℕ} (H : n > 0) : n ≠ 0 :=
ne.symm (ne_of_lt H)

@[hott] theorem exists_eq_succ_of_pos {n : ℕ} (H : n > 0) : Σl, n = succ l :=
exists_eq_succ_of_lt H

-- @[hott] theorem pos_of_dvd_of_pos {m n : ℕ} (H1 : m ∣ n) (H2 : n > 0) : m > 0 :=
-- pos_of_ne_zero
--   (λthis,
--    have n = 0, by apply eq_zero_of_zero_dvd; rwra ←this,
--    ne_of_lt H2 (by subst n))

/- multiplication -/

@[hott] theorem mul_lt_mul_of_le_of_lt {n m k l : ℕ} (Hk : k > 0) (H1 : n ≤ k) (H2 : m < l) :
  n * m < k * l :=
lt_of_le_of_lt (mul_le_mul_right m H1) (mul_lt_mul_of_pos_left H2 Hk)

@[hott] theorem mul_lt_mul_of_lt_of_le {n m k l : ℕ} (Hl : l > 0) (H1 : n < k) (H2 : m ≤ l) :
  n * m < k * l :=
lt_of_le_of_lt (mul_le_mul_left n H2) (mul_lt_mul_of_pos_right H1 Hl)

@[hott] theorem mul_lt_mul_of_le_of_le {n m k l : ℕ} (H1 : n < k) (H2 : m < l) : n * m < k * l :=
have H3 : n * m ≤ k * m, from mul_le_mul_right m (le_of_lt H1),
have H4 : k * m < k * l, from mul_lt_mul_of_pos_left H2 (lt_of_le_of_lt (zero_le _) H1),
lt_of_le_of_lt H3 H4

@[hott] theorem eq_of_mul_eq_mul_left {m k n : ℕ} (Hn : n > 0) (H : n * m = n * k) : m = k :=
have n * m ≤ n * k, by rwr H,
have H2 : m ≤ k,         from le_of_mul_le_mul_left this Hn,
have n * k ≤ n * m, by rwr H,
have k ≤ m,         from le_of_mul_le_mul_left this Hn,
le.antisymm H2 this

@[hott] theorem eq_of_mul_eq_mul_right {n m k : ℕ} (Hm : m > 0) (H : n * m = k * m) : n = k :=
by apply eq_of_mul_eq_mul_left Hm; rwra [mul.comm m n, mul.comm m k]

@[hott] theorem eq_zero_sum_eq_of_mul_eq_mul_left {n m k : ℕ} (H : n * m = n * k) : n = 0 ⊎ m = k :=
(eq_zero_sum_pos _).functor_right _ (assume Hn : n > 0, eq_of_mul_eq_mul_left Hn H)

@[hott] theorem eq_zero_sum_eq_of_mul_eq_mul_right {n m k : ℕ} (H : n * m = k * m) :
  m = 0 ⊎ n = k :=
by apply eq_zero_sum_eq_of_mul_eq_mul_left; rwra [mul.comm m n, mul.comm m k]

@[hott] theorem eq_one_of_mul_eq_one_right {n m : ℕ} (H : n * m = 1) : n = 1 :=
have H2 : n * m > 0, by rwr H; apply succ_pos,
sum.elim (le_sum_gt n 1)
  (λH3,
    have n > 0, from pos_of_mul_pos_right H2,
    show n = 1, from le.antisymm H3 (succ_le_of_lt this))
  (λH3,
    have m > 0, from pos_of_mul_pos_left H2,
    have n * m ≥ 2 * 1, from nat.mul_le_mul (succ_le_of_lt H3) (succ_le_of_lt this),
    have 1 ≥ 2, by rwra [H, hott.algebra.mul_one] at this,
    absurd (lt_succ_self _) (not_lt_of_ge this))

@[hott] theorem eq_one_of_mul_eq_one_left {n m : ℕ} (H : n * m = 1) : m = 1 :=
by apply eq_one_of_mul_eq_one_right; rwra [mul.comm]

@[hott] theorem eq_one_of_mul_eq_self_left {n m : ℕ} (Hpos : n > 0) (H : m * n = n) : m = 1 :=
eq_of_mul_eq_mul_right Hpos (H ⬝ (one_mul _)⁻¹ᵖ)

@[hott] theorem eq_one_of_mul_eq_self_right {n m : ℕ} (Hpos : m > 0) (H : m * n = m) : n = 1 :=
by apply eq_one_of_mul_eq_self_left Hpos; rwra [mul.comm]

-- @[hott] theorem eq_one_of_dvd_one {n : ℕ} (H : n ∣ 1) : n = 1 :=
-- dvd.elim H
--   (λm, suppose 1 = n * m,
--    eq_one_of_mul_eq_one_right this⁻¹)

/- min and max -/
open decidable

local notation `min` := hott.algebra.min
local notation `max` := hott.algebra.max

@[hott, hsimp] theorem min_zero (a : ℕ) : min a 0 = 0 :=
by rwr [hott.algebra.min_eq_right (zero_le _)]

@[hott, hsimp] theorem zero_min (a : ℕ) : min 0 a = 0 :=
by rwr [min_eq_left (zero_le _)]

@[hott, hsimp] theorem max_zero (a : ℕ) : max a 0 = a :=
by rwr [max_eq_left (zero_le _)]

@[hott, hsimp] theorem zero_max (a : ℕ) : max 0 a = a :=
by rwr [max_eq_right (zero_le _)]

@[hott, hsimp] theorem min_succ_succ (a b : ℕ) : min (succ a) (succ b) = succ (min a b) :=
sum.elim (lt_sum_ge a b)
  (λthis, by rwr [min_eq_left_of_lt this, min_eq_left_of_lt (succ_lt_succ this)])
  (λthis, by rwr [min_eq_right this, min_eq_right (succ_le_succ this)])

@[hott, hsimp] theorem max_succ_succ (a b : ℕ) : max (succ a) (succ b) = succ (max a b) :=
sum.elim (lt_sum_ge a b)
  (λthis, by rwr [max_eq_right_of_lt this, max_eq_right_of_lt (succ_lt_succ this)])
  (λthis, by rwr [max_eq_left this, max_eq_left (succ_le_succ this)])

/- In algebra.ordered_group, these next four are only proved for additive groups, not additive
   semigroups. -/

@[hott] protected theorem min_add_add_left (a b c : ℕ) : min (a + b) (a + c) = a + min b c :=
sum.elim (le_sum_gt b c)
  (λH,
   have a + b ≤ a + c, from add_le_add_left H _,
   by rwr [min_eq_left H, min_eq_left this])
  (λthis,
   have H : c ≤ b,     from le_of_lt this,
   have a + c ≤ a + b, from add_le_add_left H _,
   by rwr [min_eq_right H, min_eq_right this])

@[hott] protected theorem min_add_add_right (a b c : ℕ) : min (a + c) (b + c) = min a b + c :=
by rwr [nat.add_comm a c, nat.add_comm b c, nat.add_comm (min _ _) c]; apply nat.min_add_add_left

@[hott] protected theorem max_add_add_left (a b c : ℕ) : max (a + b) (a + c) = a + max b c :=
sum.elim (le_sum_gt b c)
  (λH, /- b ≤ c -/
   have a + b ≤ a + c, from add_le_add_left H _,
   by rwr [max_eq_right H, max_eq_right this])
  (λthis,
   have H : c ≤ b,         from le_of_lt this,
   have a + c ≤ a + b, from add_le_add_left H _,
   by rwr [max_eq_left H, max_eq_left this])

@[hott] protected theorem max_add_add_right (a b c : ℕ) : max (a + c) (b + c) = max a b + c :=
by rwr [nat.add_comm a c, nat.add_comm b c, nat.add_comm (max _ _) c]; apply nat.max_add_add_left

/- least and greatest -/

section least_prod_greatest
  variable (P : ℕ → Type _)
  variable [decP : Π n, decidable (P n)]
  include decP

  -- returns the least i < n satisfying P, sum n if there is none
  @[hott] def least : ℕ → ℕ
    | 0        := 0
    | (succ n) := if' P (least n) then least n else succ n

  @[hott] theorem least_of_bound {n : ℕ} (H : P n) : P (least P n) :=
    begin
      induction n with m ih,
      dsimp [least],
      apply H,
      dsimp [least],
      cases decidable.em (P (least P m)) with Hlp Hlp,
      rwr [if_pos Hlp],
      apply Hlp,
      rwr [if_neg Hlp],
      apply H
    end

  @[hott] theorem least_le (n : ℕ) : least P n ≤ n:=
    begin
      induction n with m ih, reflexivity,
      dsimp [least],
      cases decidable.em (P (least P m)) with Psm Pnsm,
      rwr [if_pos Psm],
      apply le.trans ih (le_succ _),
      rwr [if_neg Pnsm]
    end

 @[hott] theorem least_of_lt {i n : ℕ} (ltin : i < n) (H : P i) : P (least P n) :=
   begin
     induction n with m ih,
     exact absurd ltin (not_lt_zero _),
     dsimp [least],
     cases decidable.em (P (least P m)) with Psm Pnsm,
     rwr [if_pos Psm],
     apply Psm,
     rwr [if_neg Pnsm],
     cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with Hlt Heq,
     exact absurd (ih Hlt) Pnsm,
     rwr Heq at H,
     exact absurd (least_of_bound P H) Pnsm
   end

  @[hott] theorem ge_least_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : i ≥ least P n :=
    begin
      induction n with m ih,
      exact absurd ltin (not_lt_zero _),
      dsimp [least],
      cases decidable.em (P (least P m)) with Psm Pnsm,
      rwr [if_pos Psm],
      cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with Hlt Heq,
      apply ih Hlt,
      rwr Heq,
      apply least_le,
      rwr [if_neg Pnsm],
      cases (lt_sum_eq_of_le (le_of_lt_succ ltin)) with Hlt Heq,
      apply absurd (least_of_lt P Hlt Hi) Pnsm,
      rwr Heq at Hi,
      apply absurd (least_of_bound P Hi) Pnsm
    end

  @[hott] theorem least_lt {n i : ℕ} (ltin : i < n) (Hi : P i) : least P n < n :=
    lt_of_le_of_lt (ge_least_of_lt P ltin Hi) ltin

  -- returns the largest i < n satisfying P, sum n if there is none.
  @[hott] def greatest : ℕ → ℕ
  | 0        := 0
  | (succ n) := if' P n then n else greatest n

  @[hott] theorem greatest_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : P (greatest P n) :=
  begin
    induction n with m ih,
      {exact absurd ltin (not_lt_zero _)},
      {cases (decidable.em (P m)) with Psm Pnsm,
        {dsimp [greatest], rwr [if_pos Psm]; exact Psm},
        {dsimp [greatest], rwr [if_neg Pnsm],
          have neim : i ≠ m, from assume H : i = m, absurd (H ▸ Hi) Pnsm,
          have ltim : i < m, from lt_of_le_of_ne (le_of_lt_succ ltin) neim,
          apply ih ltim}}
  end

  @[hott] theorem le_greatest_of_lt {i n : ℕ} (ltin : i < n) (Hi : P i) : i ≤ greatest P n :=
  begin
    induction n with m ih,
      {exact absurd ltin (not_lt_zero _)},
      {cases (decidable.em (P m)) with Psm Pnsm,
        {dsimp [greatest], rwr [if_pos Psm], apply le_of_lt_succ ltin},
        {dsimp [greatest], rwr [if_neg Pnsm],
          have neim : i ≠ m, from assume H : i = m, absurd (H ▸ Hi) Pnsm,
          have ltim : i < m, from lt_of_le_of_ne (le_of_lt_succ ltin) neim,
          apply ih ltim}}
  end

end least_prod_greatest

end nat
end hott


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import data.set.prod

/-!
# N-ary images of sets

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines `finset.image₂`, the binary image of finsets. This is the finset version of
`set.image2`. This is mostly useful to define pointwise operations.

## Notes

This file is very similar to the n-ary section of `data.set.basic`, to `order.filter.n_ary` and to
`data.option.n_ary`. Please keep them in sync.

We do not define `finset.image₃` as its only purpose would be to prove properties of `finset.image₂`
and `set.image2` already fulfills this task.
-/

open function

namespace set
variables {α α' β β' γ γ' δ δ' ε ε' ζ ζ' ν : Type*} {f f' : α → β → γ} {g g' : α → β → γ → δ}
variables {s s' : set α} {t t' : set β} {u u' : set γ} {v : set δ} {a a' : α} {b b' : β} {c c' : γ}
  {d d' : δ}

/-- The image of a binary function `f : α → β → γ` as a function `set α → set β → set γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`.-/
def image2 (f : α → β → γ) (s : set α) (t : set β) : set γ :=
{c | ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c }

@[simp] lemma mem_image2 : c ∈ image2 f s t ↔ ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c := iff.rfl

lemma mem_image2_of_mem (ha : a ∈ s) (hb : b ∈ t) : f a b ∈ image2 f s t := ⟨a, b, ha, hb, rfl⟩

lemma mem_image2_iff (hf : injective2 f) : f a b ∈ image2 f s t ↔ a ∈ s ∧ b ∈ t :=
⟨ by { rintro ⟨a', b', ha', hb', h⟩, rcases hf h with ⟨rfl, rfl⟩, exact ⟨ha', hb'⟩ },
  λ ⟨ha, hb⟩, mem_image2_of_mem ha hb⟩

/-- image2 is monotone with respect to `⊆`. -/
lemma image2_subset (hs : s ⊆ s') (ht : t ⊆ t') : image2 f s t ⊆ image2 f s' t' :=
by { rintro _ ⟨a, b, ha, hb, rfl⟩, exact mem_image2_of_mem (hs ha) (ht hb) }

lemma image2_subset_left (ht : t ⊆ t') : image2 f s t ⊆ image2 f s t' := image2_subset subset.rfl ht

lemma image2_subset_right (hs : s ⊆ s') : image2 f s t ⊆ image2 f s' t :=
image2_subset hs subset.rfl

lemma image_subset_image2_left (hb : b ∈ t) : (λ a, f a b) '' s ⊆ image2 f s t :=
ball_image_of_ball $ λ a ha, mem_image2_of_mem ha hb

lemma image_subset_image2_right (ha : a ∈ s) : f a '' t ⊆ image2 f s t :=
ball_image_of_ball $ λ b, mem_image2_of_mem ha

lemma forall_image2_iff {p : γ → Prop} :
  (∀ z ∈ image2 f s t, p z) ↔ ∀ (x ∈ s) (y ∈ t), p (f x y) :=
⟨λ h x hx y hy, h _ ⟨x, y, hx, hy, rfl⟩, λ h z ⟨x, y, hx, hy, hz⟩, hz ▸ h x hx y hy⟩

@[simp] lemma image2_subset_iff {u : set γ} :
  image2 f s t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), f x y ∈ u :=
forall_image2_iff

lemma image2_subset_iff_left : image2 f s t ⊆ u ↔ ∀ a ∈ s, (λ b, f a b) '' t ⊆ u :=
by simp_rw [image2_subset_iff, image_subset_iff, subset_def, mem_preimage]

lemma image2_subset_iff_right : image2 f s t ⊆ u ↔ ∀ b ∈ t, (λ a, f a b) '' s ⊆ u :=
by simp_rw [image2_subset_iff, image_subset_iff, subset_def, mem_preimage, @forall₂_swap α]

variables (f)

@[simp] lemma image_prod : (λ x : α × β, f x.1 x.2) '' s ×ˢ t = image2 f s t :=
ext $ λ a,
⟨ by { rintro ⟨_, _, rfl⟩, exact ⟨_, _, (mem_prod.1 ‹_›).1, (mem_prod.1 ‹_›).2, rfl⟩ },
  by { rintro ⟨_, _, _, _, rfl⟩, exact ⟨(_, _), ⟨‹_›, ‹_›⟩, rfl⟩ }⟩

@[simp] lemma image_uncurry_prod (s : set α) (t : set β) : uncurry f '' s ×ˢ t = image2 f s t :=
image_prod _

@[simp] lemma image2_mk_eq_prod : image2 prod.mk s t = s ×ˢ t := ext $ by simp

@[simp] lemma image2_curry (f : α × β → γ) (s : set α) (t : set β) :
  image2 (λ a b, f (a, b)) s t = f '' s ×ˢ t :=
by simp [←image_uncurry_prod, uncurry]

lemma image2_swap (s : set α) (t : set β) : image2 f s t = image2 (λ a b, f b a) t s :=
by { ext, split; rintro ⟨a, b, ha, hb, rfl⟩; refine ⟨b, a, hb, ha, rfl⟩ }

variables {f}

lemma image2_union_left : image2 f (s ∪ s') t = image2 f s t ∪ image2 f s' t :=
begin
  ext c,
  split,
  { rintro ⟨a, b, ha | ha, hb, rfl⟩; [left, right]; exact ⟨_, _, ‹_›, ‹_›, rfl⟩ },
  { rintro (⟨_, _, _, _, rfl⟩|⟨_, _, _, _, rfl⟩); refine ⟨_, _, _, ‹_›, rfl⟩;
    simp [mem_union, *] }
end

lemma image2_union_right : image2 f s (t ∪ t') = image2 f s t ∪ image2 f s t' :=
by rw [←image2_swap, image2_union_left, image2_swap f, image2_swap f]

lemma image2_inter_left (hf : injective2 f) : image2 f (s ∩ s') t = image2 f s t ∩ image2 f s' t :=
by simp_rw [←image_uncurry_prod, inter_prod, image_inter hf.uncurry]

lemma image2_inter_right (hf : injective2 f) : image2 f s (t ∩ t') = image2 f s t ∩ image2 f s t' :=
by simp_rw [←image_uncurry_prod, prod_inter, image_inter hf.uncurry]

@[simp] lemma image2_empty_left : image2 f ∅ t = ∅ := ext $ by simp
@[simp] lemma image2_empty_right : image2 f s ∅ = ∅ := ext $ by simp

lemma nonempty.image2 : s.nonempty → t.nonempty → (image2 f s t).nonempty :=
λ ⟨a, ha⟩ ⟨b, hb⟩, ⟨_, mem_image2_of_mem ha hb⟩

@[simp] lemma image2_nonempty_iff : (image2 f s t).nonempty ↔ s.nonempty ∧ t.nonempty :=
⟨λ ⟨_, a, b, ha, hb, _⟩, ⟨⟨a, ha⟩, b, hb⟩, λ h, h.1.image2 h.2⟩

lemma nonempty.of_image2_left (h : (image2 f s t).nonempty) : s.nonempty :=
(image2_nonempty_iff.1 h).1

lemma nonempty.of_image2_right (h : (image2 f s t).nonempty) : t.nonempty :=
(image2_nonempty_iff.1 h).2

@[simp] lemma image2_eq_empty_iff : image2 f s t = ∅ ↔ s = ∅ ∨ t = ∅ :=
by simp_rw [←not_nonempty_iff_eq_empty, image2_nonempty_iff, not_and_distrib]

lemma image2_inter_subset_left : image2 f (s ∩ s') t ⊆ image2 f s t ∩ image2 f s' t :=
by { rintro _ ⟨a, b, ⟨h1a, h2a⟩, hb, rfl⟩, split; exact ⟨_, _, ‹_›, ‹_›, rfl⟩ }

lemma image2_inter_subset_right : image2 f s (t ∩ t') ⊆ image2 f s t ∩ image2 f s t' :=
by { rintro _ ⟨a, b, ha, ⟨h1b, h2b⟩, rfl⟩, split; exact ⟨_, _, ‹_›, ‹_›, rfl⟩ }

@[simp] lemma image2_singleton_left : image2 f {a} t = f a '' t := ext $ λ x, by simp
@[simp] lemma image2_singleton_right : image2 f s {b} = (λ a, f a b) '' s := ext $ λ x, by simp

lemma image2_singleton : image2 f {a} {b} = {f a b} := by simp

@[simp] lemma image2_insert_left : image2 f (insert a s) t = (λ b, f a b) '' t ∪ image2 f s t :=
by rw [insert_eq, image2_union_left, image2_singleton_left]

@[simp] lemma image2_insert_right : image2 f s (insert b t) = (λ a, f a b) '' s  ∪ image2 f s t :=
by rw [insert_eq, image2_union_right, image2_singleton_right]

@[congr] lemma image2_congr (h : ∀ (a ∈ s) (b ∈ t), f a b = f' a b) :
  image2 f s t = image2 f' s t :=
by { ext, split; rintro ⟨a, b, ha, hb, rfl⟩; refine ⟨a, b, ha, hb, by rw h a ha b hb⟩ }

/-- A common special case of `image2_congr` -/
lemma image2_congr' (h : ∀ a b, f a b = f' a b) : image2 f s t = image2 f' s t :=
image2_congr (λ a _ b _, h a b)

/-- The image of a ternary function `f : α → β → γ → δ` as a function
  `set α → set β → set γ → set δ`. Mathematically this should be thought of as the image of the
  corresponding function `α × β × γ → δ`.
-/
def image3 (g : α → β → γ → δ) (s : set α) (t : set β) (u : set γ) : set δ :=
{d | ∃ a b c, a ∈ s ∧ b ∈ t ∧ c ∈ u ∧ g a b c = d }

@[simp] lemma mem_image3 : d ∈ image3 g s t u ↔ ∃ a b c, a ∈ s ∧ b ∈ t ∧ c ∈ u ∧ g a b c = d :=
iff.rfl

lemma image3_mono (hs : s ⊆ s') (ht : t ⊆ t') (hu : u ⊆ u') : image3 g s t u ⊆ image3 g s' t' u' :=
λ x, Exists₃.imp $ λ a b c ⟨ha, hb, hc, hx⟩, ⟨hs ha, ht hb, hu hc, hx⟩

@[congr] lemma image3_congr (h : ∀ (a ∈ s) (b ∈ t) (c ∈ u), g a b c = g' a b c) :
  image3 g s t u = image3 g' s t u :=
by { ext x,
     split; rintro ⟨a, b, c, ha, hb, hc, rfl⟩; exact ⟨a, b, c, ha, hb, hc, by rw h a ha b hb c hc⟩ }

/-- A common special case of `image3_congr` -/
lemma image3_congr' (h : ∀ a b c, g a b c = g' a b c) : image3 g s t u = image3 g' s t u :=
image3_congr (λ a _ b _ c _, h a b c)

lemma image2_image2_left (f : δ → γ → ε) (g : α → β → δ) :
  image2 f (image2 g s t) u = image3 (λ a b c, f (g a b) c) s t u :=
begin
  ext, split,
  { rintro ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩, refine ⟨a, b, c, ha, hb, hc, rfl⟩ },
  { rintro ⟨a, b, c, ha, hb, hc, rfl⟩, refine ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩ }
end

lemma image2_image2_right (f : α → δ → ε) (g : β → γ → δ) :
  image2 f s (image2 g t u) = image3 (λ a b c, f a (g b c)) s t u :=
begin
  ext, split,
  { rintro ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩, refine ⟨a, b, c, ha, hb, hc, rfl⟩ },
  { rintro ⟨a, b, c, ha, hb, hc, rfl⟩, refine ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩ }
end

lemma image_image2 (f : α → β → γ) (g : γ → δ) :
  g '' image2 f s t = image2 (λ a b, g (f a b)) s t :=
begin
  ext, split,
  { rintro ⟨_, ⟨a, b, ha, hb, rfl⟩, rfl⟩, refine ⟨a, b, ha, hb, rfl⟩ },
  { rintro ⟨a, b, ha, hb, rfl⟩, refine ⟨_, ⟨a, b, ha, hb, rfl⟩, rfl⟩ }
end

lemma image2_image_left (f : γ → β → δ) (g : α → γ) :
  image2 f (g '' s) t = image2 (λ a b, f (g a) b) s t :=
begin
  ext, split,
  { rintro ⟨_, b, ⟨a, ha, rfl⟩, hb, rfl⟩, refine ⟨a, b, ha, hb, rfl⟩ },
  { rintro ⟨a, b, ha, hb, rfl⟩, refine ⟨_, b, ⟨a, ha, rfl⟩, hb, rfl⟩ }
end

lemma image2_image_right (f : α → γ → δ) (g : β → γ) :
  image2 f s (g '' t) = image2 (λ a b, f a (g b)) s t :=
begin
  ext, split,
  { rintro ⟨a, _, ha, ⟨b, hb, rfl⟩, rfl⟩, refine ⟨a, b, ha, hb, rfl⟩ },
  { rintro ⟨a, b, ha, hb, rfl⟩, refine ⟨a, _, ha, ⟨b, hb, rfl⟩, rfl⟩ }
end

@[simp] lemma image2_left (h : t.nonempty) : image2 (λ x y, x) s t = s :=
by simp [nonempty_def.mp h, ext_iff]

@[simp] lemma image2_right (h : s.nonempty) : image2 (λ x y, y) s t = t :=
by simp [nonempty_def.mp h, ext_iff]

lemma image2_assoc {f : δ → γ → ε} {g : α → β → δ} {f' : α → ε' → ε} {g' : β → γ → ε'}
  (h_assoc : ∀ a b c, f (g a b) c = f' a (g' b c)) :
  image2 f (image2 g s t) u = image2 f' s (image2 g' t u) :=
by simp only [image2_image2_left, image2_image2_right, h_assoc]

lemma image2_comm {g : β → α → γ} (h_comm : ∀ a b, f a b = g b a) : image2 f s t = image2 g t s :=
(image2_swap _ _ _).trans $ by simp_rw h_comm

lemma image2_left_comm {f : α → δ → ε} {g : β → γ → δ} {f' : α → γ → δ'} {g' : β → δ' → ε}
  (h_left_comm : ∀ a b c, f a (g b c) = g' b (f' a c)) :
  image2 f s (image2 g t u) = image2 g' t (image2 f' s u) :=
by { rw [image2_swap f', image2_swap f], exact image2_assoc (λ _ _ _, h_left_comm _ _ _) }

lemma image2_right_comm {f : δ → γ → ε} {g : α → β → δ} {f' : α → γ → δ'} {g' : δ' → β → ε}
  (h_right_comm : ∀ a b c, f (g a b) c = g' (f' a c) b) :
  image2 f (image2 g s t) u = image2 g' (image2 f' s u) t :=
by { rw [image2_swap g, image2_swap g'], exact image2_assoc (λ _ _ _, h_right_comm _ _ _) }

lemma image2_image2_image2_comm {f : ε → ζ → ν} {g : α → β → ε} {h : γ → δ → ζ} {f' : ε' → ζ' → ν}
  {g' : α → γ → ε'} {h' : β → δ → ζ'}
  (h_comm : ∀ a b c d, f (g a b) (h c d) = f' (g' a c) (h' b d)) :
  image2 f (image2 g s t) (image2 h u v) = image2 f' (image2 g' s u) (image2 h' t v) :=
begin
  ext,
  split,
  { rintro ⟨_, _, ⟨a, b, ha, hb, rfl⟩, ⟨c, d, hc, hd, rfl⟩, rfl⟩,
    exact ⟨_, _, ⟨a, c, ha, hc, rfl⟩, ⟨b, d, hb, hd, rfl⟩, (h_comm _ _ _ _).symm⟩ },
  { rintro ⟨_, _, ⟨a, c, ha, hc, rfl⟩, ⟨b, d, hb, hd, rfl⟩, rfl⟩,
    exact ⟨_, _, ⟨a, b, ha, hb, rfl⟩, ⟨c, d, hc, hd, rfl⟩, h_comm _ _ _ _⟩ }
end

lemma image_image2_distrib {g : γ → δ} {f' : α' → β' → δ} {g₁ : α → α'} {g₂ : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' (g₁ a) (g₂ b)) :
  (image2 f s t).image g = image2 f' (s.image g₁) (t.image g₂) :=
by simp_rw [image_image2, image2_image_left, image2_image_right, h_distrib]

/-- Symmetric statement to `set.image2_image_left_comm`. -/
lemma image_image2_distrib_left {g : γ → δ} {f' : α' → β → δ} {g' : α → α'}
  (h_distrib : ∀ a b, g (f a b) = f' (g' a) b) :
  (image2 f s t).image g = image2 f' (s.image g') t :=
(image_image2_distrib h_distrib).trans $ by rw image_id'

/-- Symmetric statement to `set.image_image2_right_comm`. -/
lemma image_image2_distrib_right {g : γ → δ} {f' : α → β' → δ} {g' : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' a (g' b)) :
  (image2 f s t).image g = image2 f' s (t.image g') :=
(image_image2_distrib h_distrib).trans $ by rw image_id'

/-- Symmetric statement to `set.image_image2_distrib_left`. -/
lemma image2_image_left_comm {f : α' → β → γ} {g : α → α'} {f' : α → β → δ} {g' : δ → γ}
  (h_left_comm : ∀ a b, f (g a) b = g' (f' a b)) :
  image2 f (s.image g) t = (image2 f' s t).image g' :=
(image_image2_distrib_left $ λ a b, (h_left_comm a b).symm).symm

/-- Symmetric statement to `set.image_image2_distrib_right`. -/
lemma image_image2_right_comm {f : α → β' → γ} {g : β → β'} {f' : α → β → δ} {g' : δ → γ}
  (h_right_comm : ∀ a b, f a (g b) = g' (f' a b)) :
  image2 f s (t.image g) = (image2 f' s t).image g' :=
(image_image2_distrib_right $ λ a b, (h_right_comm a b).symm).symm

/-- The other direction does not hold because of the `s`-`s` cross terms on the RHS. -/
lemma image2_distrib_subset_left {f : α → δ → ε} {g : β → γ → δ} {f₁ : α → β → β'} {f₂ : α → γ → γ'}
  {g' : β' → γ' → ε} (h_distrib : ∀ a b c, f a (g b c) = g' (f₁ a b) (f₂ a c)) :
  image2 f s (image2 g t u) ⊆ image2 g' (image2 f₁ s t) (image2 f₂ s u) :=
begin
  rintro _ ⟨a, _, ha, ⟨b, c, hb, hc, rfl⟩, rfl⟩,
  rw h_distrib,
  exact mem_image2_of_mem (mem_image2_of_mem ha hb) (mem_image2_of_mem ha hc),
end

/-- The other direction does not hold because of the `u`-`u` cross terms on the RHS. -/
lemma image2_distrib_subset_right {f : δ → γ → ε} {g : α → β → δ} {f₁ : α → γ → α'}
  {f₂ : β → γ → β'} {g' : α' → β' → ε} (h_distrib : ∀ a b c, f (g a b) c = g' (f₁ a c) (f₂ b c)) :
  image2 f (image2 g s t) u ⊆ image2 g' (image2 f₁ s u) (image2 f₂ t u) :=
begin
  rintro _ ⟨_, c, ⟨a, b, ha, hb, rfl⟩, hc, rfl⟩,
  rw h_distrib,
  exact mem_image2_of_mem (mem_image2_of_mem ha hc) (mem_image2_of_mem hb hc),
end

lemma image_image2_antidistrib {g : γ → δ} {f' : β' → α' → δ} {g₁ : β → β'} {g₂ : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g₁ b) (g₂ a)) :
  (image2 f s t).image g = image2 f' (t.image g₁) (s.image g₂) :=
by { rw image2_swap f, exact image_image2_distrib (λ _ _, h_antidistrib _ _) }

/-- Symmetric statement to `set.image2_image_left_anticomm`. -/
lemma image_image2_antidistrib_left {g : γ → δ} {f' : β' → α → δ} {g' : β → β'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g' b) a) :
  (image2 f s t).image g = image2 f' (t.image g') s :=
(image_image2_antidistrib h_antidistrib).trans $ by rw image_id'

/-- Symmetric statement to `set.image_image2_right_anticomm`. -/
lemma image_image2_antidistrib_right {g : γ → δ} {f' : β → α' → δ} {g' : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' b (g' a)) :
  (image2 f s t).image g = image2 f' t (s.image g') :=
(image_image2_antidistrib h_antidistrib).trans $ by rw image_id'

/-- Symmetric statement to `set.image_image2_antidistrib_left`. -/
lemma image2_image_left_anticomm {f : α' → β → γ} {g : α → α'} {f' : β → α → δ} {g' : δ → γ}
  (h_left_anticomm : ∀ a b, f (g a) b = g' (f' b a)) :
  image2 f (s.image g) t = (image2 f' t s).image g' :=
(image_image2_antidistrib_left $ λ a b, (h_left_anticomm b a).symm).symm

/-- Symmetric statement to `set.image_image2_antidistrib_right`. -/
lemma image_image2_right_anticomm {f : α → β' → γ} {g : β → β'} {f' : β → α → δ} {g' : δ → γ}
  (h_right_anticomm : ∀ a b, f a (g b) = g' (f' b a)) :
  image2 f s (t.image g) = (image2 f' t s).image g' :=
(image_image2_antidistrib_right $ λ a b, (h_right_anticomm b a).symm).symm

/-- If `a` is a left identity for `f : α → β → β`, then `{a}` is a left identity for
`set.image2 f`. -/

/-- If `b` is a right identity for `f : α → β → α`, then `{b}` is a right identity for
`set.image2 f`. -/
lemma image2_right_identity {f : α → β → α} {b : β} (h : ∀ a, f a b = a) (s : set α) :
  image2 f s {b} = s :=
by rw [image2_singleton_right, funext h, image_id']

lemma image2_inter_union_subset_union :
  image2 f (s ∩ s') (t ∪ t') ⊆ image2 f s t ∪ image2 f s' t' :=
by { rw image2_union_right, exact union_subset_union
  (image2_subset_right $ inter_subset_left _ _) (image2_subset_right $ inter_subset_right _ _) }

lemma image2_union_inter_subset_union :
  image2 f (s ∪ s') (t ∩ t') ⊆ image2 f s t ∪ image2 f s' t' :=
by { rw image2_union_left, exact union_subset_union
  (image2_subset_left $ inter_subset_left _ _) (image2_subset_left $ inter_subset_right _ _) }

lemma image2_inter_union_subset {f : α → α → β} {s t : set α} (hf : ∀ a b, f a b = f b a) :
  image2 f (s ∩ t) (s ∪ t) ⊆ image2 f s t :=
by { rw inter_comm,
  exact image2_inter_union_subset_union.trans (union_subset (image2_comm hf).subset subset.rfl) }

lemma image2_union_inter_subset {f : α → α → β} {s t : set α} (hf : ∀ a b, f a b = f b a) :
  image2 f (s ∪ t) (s ∩ t) ⊆ image2 f s t :=
by { rw image2_comm hf, exact image2_inter_union_subset hf }

end set