(**
* Induction in Coq

  From: https://www.cs.cornell.edu/courses/cs3110/2018sp/l/22-coq-induction/notes.v
-----
##
Topics:

- recursive functions
- induction on lists
- induction on natural numbers
- rings and fields
- induction principles
- extraction

##

-----

We'll need the list library for these notes.
*)

Require Import List.
Import ListNotations.

(**

(**********************************************************************)

** Recursive functions

The [List] library defines the list append operator, which in Coq is written as
infix operator [++], or as prefix function [app].  In OCaml, the same operator
is written [@].  In OCaml's standard library, you'll recall that append
is defined as follows:

<<
let rec append lst1 lst2 =
  match lst1 with
  | [] -> lst2
  | h::t -> h :: (append t lst2)
>>

The Coq equivalent of that would be: *)

Fixpoint append {A : Type} (lst1 : list A) (lst2 : list A) :=
  match lst1 with
  | nil => lst2
  | h::t => h :: (append t lst2)
  end.

(** The [Fixpoint] keyword is similar to a [let rec] definition in OCaml. The
braces around [A : Type] in that definition make the [A] argument implicit,
hence we don't have to provide it at the recursive call to [append] in the
second branch of the pattern match.  Without the braces, we'd have to write the
function as follows: *)

Fixpoint append' (A : Type) (lst1 : list A) (lst2 : list A) :=
match lst1 with
| nil => lst2
| h::t => h :: (append' A t lst2)
end.

(** The actual definition of [++] in the Coq standard library is a little more
complicated, but it's essentially the same idea.  Here's that definition:

<<
Definition app (A : Type) : list A -> list A -> list A :=
  fix app' lst1 lst2 :=
    match lst1 with
    | nil => lst2
    | h :: t => h :: app' t lst2
    end.
>>

The Coq [fix] keyword is similar to a [let rec] expression in OCaml, but where
the body of the expression is implicit:  Coq [fix f x1 .. xn := e] is like OCaml
[let rec f x1 .. xn = e in f].  So in OCaml we could rephrase the above
definition as follows:

<<
let app : 'a list -> 'a list -> 'a list =
  let rec app' lst1 lst2 =
    match lst1 with
    | [] -> lst2
    | h :: t -> h :: app' t lst2
  in
  app'
>>

Now that we know how Coq defines [++], let's prove a theorem about it.
*)

Theorem nil_app : forall (A:Type) (lst : list A),
  [] ++ lst = lst.

(** Intuition:  appending the empty list to [lst] immediately returns
    [lst], by the definition of [++]. *)

Proof.
  intros A lst.
  simpl.
  trivial.
Qed.

(** The second step in that proof simplifies [[] ++ lst] to [lst].  That's
because of how [++] is defined:  it pattern matches against its first argument,
which here is [[]], hence simply returns its second argument.

Next, let's prove that appending nil on the right-hand side also results in
[lst]: *)

Theorem app_nil : forall (A:Type) (lst : list A),
  lst ++ [] = lst.

(* Intuition (incomplete):  by case analysis on [lst].
   - if [lst] is [[]], then trivially [[] ++ []] is [[]].
   - if [lst] is [h::t], then ...? *)

Proof.
  intros A lst. destruct lst as [ | h t].
  - trivial.
  - simpl.  (* can't proceed *)
Abort.

(** When we get to the end of that proof, we are trying to show that [h :: (t ++
[]) = h :: t].  There's no way to make progress on that, because we can't
simplify [t ++ []] to just [t].  Of course as humans we know that holds.  But to
Coq, that's a fact that hasn't yet been proved.  Indeed, it is an instance of
the theorem we're currently trying to prove!

What's going wrong here is that case analysis is not a sufficiently powerful
proof technique for this theorem.  We need to be able to _recursively_ apply the
theorem we're trying to prove to smaller lists.  That's where _induction_ comes
into play.

(**********************************************************************)

** Induction on lists

_Induction_ is a proof technique that you will have encountered in math
classes before---including CS 2800.  It is useful when you want to prove
that some property holds of all the members of an infinite set, such as
the natural numbers, as well as lists, trees, and other data types.

One classic metaphor for induction is _falling dominos_:  if you arrange some
dominos such that each domino, when it falls, will knock over the next domino,
and if you knock over the first domino, then all the dominos will fall. Another
classic metaphor for induction is a _ladder_:  if you can reach the first rung,
and if for any given rung the next rung can be reached, then you can reach any
rung you wish.  (As long as you're not afraid of heights.)

What both of those metaphors have in common is

- a _base case_, in which something is done first.  For the dominos, it's
  knocking over the first domino; for the ladder, it's climbing the first rung.
  And,

- an _inductive case_, in which a step is taken from one thing to the
  the next.  For the dominos, it's one domino knocking over the next; for the
  ladder, it's literally taking the step from one rung to the next.  In both
  cases, it must actually be possible for the action to occur:  if the dominos
  or the rungs were spaced too far apart, then progress would stop.

A proof by induction likewise has a base case and an inductive case.
Here's the structure of a proof by induction on a list:

<<
Theorem.  For all lists lst, P(lst).

Proof.  By induction on lst.

Case:  lst = nil
Show:  P(nil)

Case:  lst = h::t
IH:    P(t)
Show:  P(h::t)

QED.
>>

The _base case_ of a proof by induction on lists is for when the list is empty.
The _inductive case_ is when the list is non-empty, hence is the cons of a head
to a tail.  In the inductive case, we get to assume an _inductive hypothesis_,
which is that the property [P] holds of the tail.

In the metaphors above, the inductive hypothesis is the assumption that we've
already reached some particular domino or rung.  From there, the metaphorical
work we do in the inductive case of the proof is to show that from that domino
or rung, we can reach the next one.

An inductive hypothesis is exactly the kind of assumption we needed to get our
proof about appending nil to go through.

Here's how that proof could be written:

<<
Theorem:  for all lists lst, lst ++ nil = lst.

Proof:  by induction on lst.
P(lst) = lst ++ nil = lst.

Case:  lst = nil
Show:
  P(nil)
= nil ++ nil = nil
= nil = nil

Case:  lst = h::t
IH: P(t) = (t ++ nil = t)
Show
  P(h::t)
= (h::t) ++ nil = h::t
= h::(t ++ nil) = h::t     // by definition of ++
= h::t = h::t              // by IH

QED
>>

In Coq, we could prove that theorem as follows:
*)

Theorem app_nil : forall (A:Type) (lst : list A),
  lst ++ nil = lst.
Proof.
intros A lst. induction lst as [ | h t IH].
- simpl. trivial.
- simpl. rewrite -> IH. trivial.
Qed.

(** The tactics used in that proof correspond exactly to the non-Coq proof
above.

The [induction] tactic is new to us.  It initiates a proof by induction on its
argument, in this case [lst], and provides names for the variables to be used in
the cases.  There aren't any new variables in the base case, but the inductive
case has variables for the head of the list, the tail, and the inductive
hypothesis.  You could leave out those variables and simply write [induction
lst.], but that leads to a less human-readable proof.

In the inductive case, we use the [rewrite ->] tactic to rewrite [t ++
nil] to [t].  The [IH] says those terms are equal.  That tactic replaces the
left-hand side of the equality with the right-hand side, wherever the left-hand
side appears in the subgoal. It's also possible to rewrite from right to left
with the [rewrite <-] tactic.  If you leave out the arrow, Coq assumes that
you mean [->].

Here's another theorem we can prove in exactly the same manner. This
theorem shows that append is _associative_.

<<
Theorem:  forall lists l1 l2 l3, l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.

Proof: by induction on l1.
P(l1) = l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3

Case:  l1 = nil
Show:
  P(nil)
= nil ++ (l2 ++ l3) = (nil ++ l2) ++ l3
= l2 ++ l3 = l2 ++ l3   // simplifying ++, twice

Case:  l1 = h::t
IH:  P(t) = t ++ (l2 ++ l3) = (t ++ l2) ++ l3
Show:
  P(h::t)
= h::t ++ (l2 ++ l3) = (h::t ++ l2) ++ l3
= h::(t ++ (l2 ++ l3)) = h::((t ++ l2) ++ l3)  // simplifying ++, thrice
= h::((t ++ l2) ++ l3) = h::((t ++ l2) ++ l3)  // by IH

QED
>>

In Coq, that proof looks more or less identical to our previous Coq proof
about append and nil:
*)

Theorem app_assoc : forall (A:Type) (l1 l2 l3 : list A),
  l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
(* Intuition: above *)
Proof.
  intros A l1 l2 l3.
  induction l1 as [ | h t IH].
  - simpl. trivial.
  - simpl. rewrite -> IH. trivial.
Qed.

(**
(**********************************************************************)

** Induction on natural numbers

One of the classic theorems proved by induction is that [0 + 1 + ... + n] is
equal to [n * (n+1) / 2].  It uses proof by induction on the natural numbers,
which are the non-negative integers.  The structure of a proof by induction on
the naturals is as follows:

<<
Theorem.  For all natural numbers n, P(n).

Proof.  By induction on n.

Case:  n = 0
Show:  P(0)

Case:  n = k+1
IH:    P(k)
Show:  P(k+1)

QED.
>>

The base case is for zero, the smallest natural number.  The inductive case
assumes that P holds of k, then shows that P holds of k+1.

The [induction] tactic in Coq works for inductive types---that is, types defined
with the [Inductive] keyword.  You might, therefore, suspect that if we're going
to do induction over [nat]s, the type [nat] must be inductively defined.  Indeed
it is.  There is a famous inductive definition of the natural numbers that is
credited to Giuseppe Peano (1858-1932).  In OCaml, that definition would be:

<<
type nat = O | S of nat
>>

The [O] constructor (that's the letter capital O) represents zero.
The [S] constructor represents the successor function---that is, the
function that adds one to its argument.  So:

- 0 is [O]
- 1 is [S O]
- 2 is [S (S O)]
- 3 is [S (S (S O))]
- etc.

This is a kind of _unary_ representation of the naturals, in which we repeat
the symbol [S] a total of [n] times to represent the natural number [n].

The Coq definition of [nat] is much the same:
*)

Print nat.

(**
Coq responds with output that is equivalent to the following:
<<
Inductive nat : Set :=
  | O : nat
  | S : nat -> nat
>>

That is, [nat] has two constructors, [O] and [S], which are just like the OCaml
constructors we examined above.  And [nat] has type [Set], meaning that [nat] is
a specification for program computations.  (Or, a little more loosely, that
[nat] is a type representing program values.)

Anywhere we write something that looks like an integer literal in Coq, Coq
actually understand that as its expansion in the Peano representation defined
above.  For example, [2] is understood by Coq as just syntactic sugar for [S (S
O)].  We can even write computations using those constructors:
*)

Compute S (S O).

(**
Coq responds, though, by reintroducing the syntactic sugar:
<<
= 2 : nat
>>

The Coq standard library defines many functions over [nat] using those
constructors and pattern matching, including addition, subtraction,
and multiplication.  For example, addition is defined like this:
*)

Fixpoint my_add (a b : nat) : nat :=
  match a with
  | 0 => b
  | S c => S (my_add c b)
  end.

(**
Note that we're allowed to use either [0] or [O] as a pattern, because
the former is just syntactic sugar for the latter.  The second branch
of the pattern match is effectively calling [my_add] recursively with
[a-1] as its first argument, since [a = S c], meaning that [a] is the
successor of [c].

Now that we know how [nat] is defined inductively, let's try
to prove the classic theorem mentioned above about summation.
Moreover, let's prove that a program that computes the sum [0 + 1 + ... + n]
does in fact compute [n * (n+1) / 2].  First, we need to write
that program.  In OCaml, we could write the program quite easily:
<<
let rec sum_to n =
  if n=0 then 0
  else n + sum_to (n-1)
>>

In Coq, it will turn out to be surprisingly tricky...

(**********************************************************************)

** Recursive functions, revisited

Here's a first attempt at defining [sum_to], which is just a direct translation
of the OCaml code into Coq.  The [Fail] keyword before it tells Coq to expect
the definition to fail to compile. *)

Fail Fixpoint sum_to (n:nat) : nat :=
  if n = 0 then 0 else n + sum_to (n-1).

(**
Coq responds:
<<
The command has indeed failed with message:
The term "n = 0" has type "Prop"
which is not a (co-)inductive type.
>>
The problem is the the equality operator [=] returns a proposition (i.e.,
something we could try to prove), whereas the [if] expression expects a Boolean
(i.e., [true] or [false]) as its guard. (Actually [if] is willing to accept any
value of an inductive type with exactly two constructors as its guard, and
[bool] is an example of such a type.)

To fix this problem, we need to use an equality operator that returns a [bool],
rather than a [Prop], when applied to two [nat]s.  Such an operator is defined
in the [Arith] library for us: *)

Require Import Arith.

Locate "=?".
Check Nat.eqb.

(** Coq responds:
<<
Nat.eqb : nat -> nat -> bool
>>

We can now try to use that operator.  Unfortunately, we discover a new problem:
*)

Fail Fixpoint sum_to (n:nat) : nat :=
  if n =? 0 then 0 else n + sum_to (n-1).

(** Coq responds with output that contains the following lines:
<<
Recursive definition of sum_to is ill-formed.
...
Recursive call to sum_to has principal argument equal to
"n - 1" instead of a subterm of "n".
...
>>
Although the error message might be cryptic, you can see that Coq is complaining
about the recursive call in the [else] branch.  For some reason, Coq is unhappy
about the argument [n-1] provided at that call.  Coq wants that argument to be a
"subterm" of [n].  The words _term_ and _expression_ are synonymous here, so Coq
is saying that it wants the argument to be a subexpression of [n].  Of course
[n] doesn't have any subexpressions. So why is Coq giving us this error?

Before we can answer that question, let's look at a different recursive
function---one that implements an infinite loop: *)

Fail Fixpoint inf (x:nat) : nat := inf x.

(**
Coq responds very similarly to how it did with [sum_to]:
<<
Recursive definition of inf is ill-formed.
...
Recursive call to inf has principal argument equal to
"x" instead of a subterm of "x".
>>

The reason Coq rejects [inf] is that #Coq does not permit any infinite
loops#. That might seem strange, but there's an excellent reason for it.
Consider how [inf] would be defined in OCaml:
<<
# let rec inf x = inf x
val inf : 'a -> 'b = <fun>
>>
Let's look at the type of that function, using what we learned about
propositions-as-types in the previous lecture.  The type ['a -> 'b]
corresponds to the proposition [A -> B], where [A] and [B] could
be any propositions.  In particular, [A] could be [True] and [B]
could be [False], leading to the proposition [True -> False].  That's
a proposition that should never be provable:  truth does not imply
falsehood.  And yet, since [inf] is a program of that type, [inf]
corresponds to a proof of that proposition.  So using [inf] we could
actually prove [False]:
<<
type void = {nope : 'a . 'a};;
let rec inf x = inf x;;
let ff : void = inf ();;
>>
The [void] type is how we represented [False] in the previous lecture.
The value [ff] above corresponds to a proof of [False].
So infinite loops are able to prove [False].

In OCaml we don't mind that phenomenon, because OCaml's purpose is not to be a
proof assistant.  But in Coq it would be deadly:  we should never allow the
proof assistant to prove false propositions.  Coq therefore wants to prohibit
all infinite loops.  But that's easier said than done!  Recall from CS 2800 that
the _halting problem_ is undecidable:  we can't write a program that precisely
determines whether another program will terminate.  Well, the Coq compiler is a
program, and it wants to detect which programs terminate and which programs do
not---which is exactly what the halting problem says is impossible.

So instead of trying to do something impossible, Coq settles for doing something
possible but imprecise, specifically, something that prohibits all
non-terminating programs as well as prohibiting some terminating programs. Coq
enforces a syntactic restriction on recursive functions: there must always be an
argument that is _syntactically smaller_ at every recursive function
application.  An expression [e1] is syntactically smaller than [e2] if [e1] is a
subexpression of [e2].  For example, [1] is syntactically smaller than [1-x],
but [n-1] is not syntactically smaller than [n].  It turns out this restriction
is sufficient to guarantee that programs must terminate:  eventually, if every
call results in something smaller, you must reach something that is small enough
that you cannot make a recursive call on it, hence evaluation must terminate.  A
synonym for "syntactically smaller" is _structurally decreasing_.

But that does rule out some programs that we as humans know will terminate yet
do not meet the syntactic restriction.  And [sum_to] is one of them. Here is the
definition we previously tried: *)

Fail Fixpoint sum_to (n:nat) : nat :=
  if n =? 0 then 0 else n + sum_to (n-1).

(** The recursive call to [sum_to] has as its argument [n-1], which
syntactically is actually bigger than the original argument of [n].  So Coq
rejects the program.

To finally succeed in definining [sum_to], we can make use of what we know about
how [nat] is defined:  since it's an inductive type, we can pattern match on it:
*)

Fixpoint sum_to (n:nat) : nat :=
  match n with
  | 0 => 0
  | S k => n + sum_to k
  end.

(** The second branch of the pattern match recurses on an argument that is both
syntactically and arithmetically smaller, just as our definition of [my_add]
did, above.  So Coq's syntactic restriction on recursion is satisfied, and the
definition is accepted as a program that definitely terminates.

<<--------CS6225 STOPPED HERE-------->>

(**********************************************************************)

** Inductive proof of the summation formula

Now that we've finally succeeded in defining [sum_to], we can prove
the classic theorem about summation.

Here's how we would write the proof mathematically:

<<
Theorem:  for all natural numbers n, sum_to n = n * (n+1) / 2.

Proof:  by induction on n.
P(n) = sum_to n = n * (n+1) / 2

Case:  n=0
Show:
  P(0)
= sum_to 0 = 0 * (0+1) / 2
= 0 = 0 * (0+1) / 2         // simplifying sum_to 0
= 0 = 0                     // 0 * x = 0

Case:  n=k+1
IH:  P(k) = sum_to k = k * (k+1) / 2
Show:
  P(k+1)
= sum_to (k+1) = (k+1) * (k+1+1) / 2
= k + 1 + sum_to k = (k+1) * (k+1+1) / 2          // simplifying sum_to (k+1)
= k + 1 + k * (k+1) / 2 = (k+1) * (k+1+1) / 2     // using IH
= 2 + 3k + k*k = 2 + 3k + k*k                     // simplifying terms on each side

QED
>>

Now let's do the proof in Coq. *)

Theorem sum_sq : forall n : nat,
  sum_to n = n * (n+1) / 2.
Proof.
  intros n.
  induction n as [ | k IH].
  - trivial.
  - simpl. rewrite -> IH.
Abort.

(** The proof is working fine so far, but now we have a complicated algebraic
equation we need to prove:
<<
S (k + k * (k + 1) / 2) = fst (Nat.divmod (k + 1 + k * S (k + 1)) 1 0 0)
>>
([divmod] is part of how [/] is implemented in Coq.)

Although we could try to prove that manually using the definitions of all the
operators, it would be much nicer to get Coq to find the proof for us.  It turns
out that Coq does have great support for finding proofs that involve _rings_:
algebraic structures that support addition and multiplication operations.
(We'll discuss rings in detail after we finish the current proof.)  But we can't
use that automation here, because the equation we want to prove also involves
division, and rings do not support division operations.

To avoid having to reason about division, we could rewrite the theorem we want
to prove:  by multiplying both sides by 2, the division goes away: *)

Theorem sum_sq_no_div : forall n : nat,
  2 * sum_to n = n * (n+1).
Proof.
  intros n.
  induction n as [ | k IH].
  - trivial.
  - simpl.
Abort.

(** Now, after the call to [simpl], we don't have any division, but we also
don't have any expressions that look exactly like the left-hand side of the
inductive hypothesis.  The problem is that [simpl] was too agressive in
simplifying all the expressions. All we really want is to transform the
left-hand side of the subgoal, [2 * sum_to (S k)], into an expression that
contains the left-hand side of the inductive hypothesis, [2 * sum_to k].
Thinking about the definition of [sum_to], we ought to be able to transform

[2 * sum_to (S k)]

into

[2 * (S k + sum_to k)]

, which equals

[2 * (S k) + 2 * sum_to k].

That final expression does have the left-hand side of the inductive
hypothesis in it, as desired.  Let's factor out that reasoning as a separate
"helper" theorem.  In math, helper theorems are usually called _lemmas_.  The
Coq keyword [Lemma] is synonymous with [Theorem]. *)

Lemma sum_helper : forall n : nat,
  2 * sum_to (S n) = 2 * (S n) + 2 * sum_to n.
Proof.
  intros n. simpl. ring.
Qed.

(** The proof above simplifies the application of [sum_to (S n)], then invokes a
new tactic called [ring].  That tactic is able to automatically search for
proofs of equations involving addition and multiplication of natural numbers.

Now that we have our helper lemma, we can use it to prove the theorem: *)

Theorem sum_sq_no_div : forall n : nat,
  2 * sum_to n = n * (n+1).
Proof.
  intros n.
  induction n as [ | k IH].
  - trivial.
  - rewrite -> sum_helper.
    rewrite -> IH.
    ring.
Qed.

(** Once more, after doing the rewriting with the lemma and the inductive
hypothesis, we're left with algebraic equations that can be proved simply by
invoking the [ring] tactic.

Finally, we can use [sum_sq_no_div] to prove the original theorem involving
division.  To do that, we need to first prove another lemma that shows we can
transform a multiplication into a division: *)

Lemma div_helper : forall a b c : nat,
  c <> 0 -> c * a = b -> a = b / c.
Proof.
  intros a b c neq eq.
  rewrite <- eq.
  rewrite Nat.mul_comm.
  rewrite Nat.div_mul.
  trivial.
  assumption.
Qed.

Check Nat.mul_comm.

(**
That lemma involves two library theorems, [mult_comm] and [Nat.div_mul]. How
did we know to use these?  Coq can help us search for useful theorems. Right
after we [rewrite <- eq] in the above proof, our subgoal is [a = c * a / c]. It
looks like we ought to be able to cancel the [c] term on the right-hand side.
So we can search for a theorem that would help us do that.  The [Search] command
takes wildcards and reports all theorems that match the pattern we supply, for
example:
*)

Search (_ * _ / _).

(** This reveals a useful theorem:
<<
Nat.div_mul: forall a b : nat, b <> 0 -> a * b / b = a
>>
That would let us cancel a term from the numerator and denominator, but it
requires the left-hand side of the equality to be of the form [a * b / b],
whereas we have [c * a / c].  The problem is that the two sides of the
multiplication are reversed.  No worries; multiplication is commutative, and
there is a library theorem that proves it. Again, we could find that theorem: *)

Search (_ * _ = _ * _).

(** One of the results is:
<<
Nat.mul_comm: forall n m : nat, n * m = m * n
>>

Putting those two library theorems to use, we're able to prove the lemma as
above.

Finally, we can use that lemma to prove our classic theorem about summation. *)

Theorem sum_sq : forall n : nat,
  sum_to n = n * (n+1) / 2.
Proof.
  intros n.
  apply div_helper.
  - discriminate.
  - rewrite sum_sq_no_div. trivial.
Qed.

(** When we use [apply div_helper] in that proof, Coq generates two new
subgoals---one for each of the propositions [c <> 0] and [c * a = b] in the type
of [div_helper].

_Summary_:  wow, that was a lot of work to prove that seemingly simple classic
theorem!  We had to figure out how to code [sum_to], and we had to deal with a
lot of complications involving algebra.  This situation is not uncommon:  the
theorems that we think of as easy with pencil-and-paper (like arithmetic) turn
out to be hard to convince Coq of, whereas the theorems that we think of as
challenging with pencil-and-paper (like induction) turn out to be easy.

(**********************************************************************)

** Rings and fields

In the proof we just did above about summation, we used a tactic called [ring]
that we said searches for proofs about algebraic equations involving
multiplication and addition.  Let's look more closely at that tactic.

When we studied OCaml modules, we looked at _rings_ as an example of a
mathematical abstraction of addition, multiplication, and negation.  Here is an
OCaml signature for a ring:

<<
module type Ring = sig
  type t
  val zero : t
  val one  : t
  val add  : t -> t -> t
  val mult : t -> t -> t
  val neg  : t -> t
end
>>

We could implement that signature with a representation type [t] that is [int],
or [float], or even [bool].

The names given in [Ring] are suggestive of the operations they represent, but
to really specify how those operations should behave, we need to write some
equations that relate them.  Below are the equations that (it turns out) fully
specify [zero], [one], [add], and [mult].  Rather than use those identifiers, we
use the more familiar notation of [0], [1], [+], and [*].

<<
0 + x = x
x + y = y + x
x + (y + z) = (x + y) + z

0 * x = 0
1 * x = 1
x * y = y * x
x * (y * z) = (x * y) * z

(x + y) * z = (x * z) + (y * z)
>>

Technically these equations specify what is known as a _commutative semi-ring_.
It's a _semi_-ring because we don't have equations specifying negation yet.
It's a _commutative_ semi-ring because the [*] operation commutes. (The [+]
operation commutes too, but that's always required of a semi-ring.)

The first group of equations specifies how [+] behaves on its own. The second
group specifies how [*] behaves on its own. The final equation specifies how [+]
and [*] interact.

If we extend the equations above with the following two, we get a specification
for a _ring_:

<<
x - y = x + (-y)
x + (-x) = 0
>>

It's a remarkable fact from the study of _abstract algebra_ that those equations
completely specify a ring.  Any theorem you want to prove about addition,
multiplication, and negation follows from those equations.  We call the
equations the _axioms_ that specify a ring.

Rings don't have a division operation.  Let's introduce a new operator called
[inv] (short for "inverse"), and let's write [1/x] as syntactic sugar for [inv
x].  If we take all the the ring axioms and add the following axiom for [inv],
we get what is called a _field_:

<<
x * 1/x = 1     if x<>0
>>

A field is an abstraction of addition, multiplication, negation, and division.
Note that OCaml [int]s do not satisfy the [inv] axiom above.  For example, [2 *
(1/2)] equals [0] in OCaml, not [1].  OCaml [float]s mostly do satisfy the field
axioms, up to the limits of floating-point arithmetic.  And in mathematics, the
rational numbers and the real numbers are fields.

Coq provides two tactics, [ring] and [field], that automatically search for
proofs using the ring and field axioms. The [ring] tactic was already loaded for
us when we wrote [Require Import Arith] earlier in this file. We can use the
[ring] tactic to easily prove equalities that follow from the ring axioms.  Here
are two examples. *)

Theorem plus_comm : forall a b,
  a + b = b + a.
Proof.
  intros a b. ring.
Qed.

Theorem foil : forall a b c d,
  (a + b) * (c + d) = a*c + b*c + a*d + b*d.
Proof.
  intros a b c d. ring.
Qed.

(** Coq infers the types of the variables above to be [nat], because the [+] and
[*] operators are defined on [nat].

The proofs that the [ring] tactic finds can be quite complicated.  For example,
try looking at the output of the following command.  It's so long that we won't
put that output in this file! *)

Print foil.

(** Of course, [ring] won't find proofs of equations that don't actually hold.
For example, if we had a typo in our statement of [foil], then [ring] would
fail. *)

Theorem broken_foil:  forall a b c d,
  (a + b) * (c + d) = a*c + b*c + c*d + b*d.
Proof.
  intros a b c d. try ring.
Abort.

(** Here's a theorem that [ring], perhaps surprisingly, cannot prove. *)

Theorem sub_add_1 : forall a : nat, a - 1 + 1 = a.
Proof.
  intros a.
  try ring.
Abort.

(** What's going wrong here is that [nat] is really only a semi-ring, not a
ring. That is, [nat] doesn't satisfy the axioms about negation.  Why?  Remember
that the natural numbers stop at [0]; we don't get any negative numbers. So if
[a] is [0] in the above theorem, [a-1] actually evaluates to [0] rather than
[-1]. *)

Compute 0-1.  (* 0 : nat *)

(** If we want to reason about the integers instead of the natural numbers, we
can use a library called [ZArith] for that.  The name comes from the fact that
[Z] is used in mathematics to denote the integers. *)

Require Import ZArith.
Open Scope Z_scope.

(** The [Open Scope] command causes the [ZArith] library's scope to be used to
resolve names, hence [+] becomes the operator on [Z] instead of on [nat], as
does [-], etc. *)

Compute 0-1.  (* -1 : Z *)

(** Now we can prove the theorem from before. *)

Theorem sub_add_1 : forall a : Z, a - 1 + 1 = a.
Proof.
  intros a. ring.
Qed.

(** Before going on, let's close the [Z] scope so that the operators go back to
working on [nat], as usual. *)

Close Scope Z_scope.

Compute 0-1.  (* 0 : nat *)

(** Coq also provides implementations of the rational numbers as a field, as
well as the real numbers as a field.  To get the [field] tactic, we first need
to load the [Field] library. *)

Require Import Field.

(** The rational numbers are provided in a couple different Coq libraries; the
one we'll use here is [Qcanon].  In mathematics, [Q] denotes the rational
numbers, and [canon] indicates that the numbers are stored in a _canonical
form_---that is, as simplified fractions. For example, [Qcanon] would represent
[2/4] as [1/2], eliminating the common factor of [2] from the numerator and the
denominator.  (The [QArith] library provides rational numbers that are not in
canonical form.) *)

Require Import Qcanon.
Open Scope Qc_scope.

Theorem frac_qc: forall x y z : Qc, z <> 0 -> (x + y) / z = x / z + y /z.
Proof.
  intros x y z z_not_0.
  field. assumption.
Qed.

Close Scope Qc_scope.

(** The real numbers are provided in the [Reals] library.  Here's that same
theorem again. *)

Module RealExample.

(** This code is in its own module for an annoying reason: [Reals] redefines its
own [nil], which will interefere with the examples want to give further below in
this file with lists. *)

Require Import Reals.
Open Scope R_scope.

Theorem frac_r : forall x y z, z <> 0 -> (x + y) / z = x / z + y /z.
Proof.
  intros x y z z_not_0.
  field. assumption.
Qed.

(** The assumption that [z <> 0] was needed in the above theorems to avoid
division by zero.  If we omitted that assumption, the [field] tactic would leave
us with an unprovable subgoal, as in the proof below. *)

Theorem frac_r_broken : forall x y z, (x + y) / z = x / z + y /z.
Proof.
  intros x y z.
  field.
Abort.

Close Scope R_scope.
End RealExample.

(**

(**********************************************************************)

** Induction principles

When we studied the Curry-Howard correspondence, we learned that proofs
correspond to programs.  That correspondence applies to inductive proofs
as well, and as it turns out, inductive proofs correspond to recursive
programs.  Intuitively, that's because an inductive proof involves
an inductive hypothesis---which is an instance of the theorem that
is being proved, but applied to a smaller value.  Likewise, recursive
programs involve recursive calls---which are like another instance
of the function that is already being evaluated, but on a smaller value.

To get a more concrete idea of what this means, let's look at the proof
value (i.e., program) that Coq produces for our original inductive
proof in these notes:
*)

Check app_nil.

Print app_nil.

(**
Coq responds:
<<
app_nil =
fun (A : Type) (lst : list A) =>
list_ind (fun lst0 : list A => lst0 ++ nil = lst0) eq_refl
  (fun (h : A) (t : list A) (IH : t ++ nil = t) =>
   eq_ind_r (fun l : list A => h :: l = h :: t) eq_refl IH) lst
     : forall (A : Type) (lst : list A), lst ++ nil = lst
>>

That's dense, but let's start picking it apart.  First, we see that [app_nil] is
a function that takes in two arguments: [A] and [lst].  Then it immediately
applies another function named [list_ind].  That function was defined for us in
the standard library, and it's what "implements" induction on lists.  Let's
check it out: *)

Check list_ind.

(**
Coq responds:
<<
list_ind
     : forall (A : Type) (P : list A -> Prop),
       P nil ->
       (forall (a : A) (l : list A), P l -> P (a :: l)) ->
       forall l : list A, P l
>>

We call [list_ind] the _induction principle_ for lists.  It is a proposition
that says, intuitively, that induction is a valid reasoning principle for lists.
In more detail, it takes these arguments:

- [A], which is the type of the list elements.

- [P], which is the property to be proved by induction.  For example,
  the property being proved in [app_nil] is
  [fun (lst: list A) => lst ++ nil = lst].

- [P nil], which is a proof that [P] holds of the empty list.  In other words,
  a proof of the base case.

- A final argument of type [forall (a : A) (l : list A), P l -> P (a :: l)].
  This is the proof of the inductive case.  It takes an argument [a],
  which is the head of a list, [l], which is the tail of a list, and
  a proof [P l] that [P] holds of [l].  So, [P l] is the inductive
  hypothesis.  The output is of type [P (a :: l)], which is a proof
  that [P] holds of [a::l].

Finally, [list_ind] returns a value of type [forall l : list A, P l],
which is a proof that [P] holds of all lists.

Ok, so that's the type of [list_ind]: a proposition asserting that
if you have a proof of the base case, and a proof of the inductive
case, you can assemble those to prove that a property holds of a list.
Next, what's the _value_ of [list_ind]?  In other words, what's the
proof that [list_ind] itself is actually a true proposition?
*)

Print list_ind.

(**
Coq responds:
<<
list_ind =
fun (A : Type) (P : list A -> Prop) (f : P [])
  (f0 : forall (a : A) (l : list A), P l -> P (a :: l)) =>
fix F (l : list A) : P l :=
  match l as l0 return (P l0) with
  | [] => f
  | y :: l0 => f0 y l0 (F l0)
  end
     : forall (A : Type) (P : list A -> Prop),
       P [] ->
       (forall (a : A) (l : list A), P l -> P (a :: l)) ->
       forall l : list A, P l
...
>>

Before we look at [list_ind]'s actual implementation, let's look at our own
equivalent implementation that is easier to read: *)

Fixpoint my_list_ind
  (A : Type)
  (P : list A -> Prop)
  (baseCase : P nil)
  (inductiveCase : forall (h : A) (t : list A), P t -> P (h::t))
  (lst : list A)
  : P lst
:=
  match lst with
  | nil => baseCase
  | h::t => inductiveCase h t
              (my_list_ind A P baseCase inductiveCase t)
  end.

(** The arguments to [my_list_ind] are the same as the arguments to [list_ind]:
an element type, a property to be proved, a proof of the base case, and a proof
of the inductive case.  Then [my_list_ind] takes an argument [lst], which is
the list for which we want to prove that [P] holds.  Finally, [my_list_ind]
returns that proof specifically for [lst].

The body of [my_list_ind] constructs the proof that [P] holds of [lst].
It does so by matching against [lst]:

- If [lst] is empty, then [my_list_ind] returns the proof of the base case.

- If [lst] is [h::t], then [my_list_ind] returns the proof of the inductive
  case.  To construct that proof, it applies [inductiveCase] to [h] and [t] as
  the head and tail.  But [inductiveCase] also requires a final argument, which
  is the proof that [P] holds of [t].  To construct that proof, [my_list_ind]
  calls itself recursively on [t].

That recursive call is exactly why we said that inductive proofs are recursive
programs.  The inductive proof needs evidence that the inductive hypothesis
holds of the smaller list, and recursing on that smaller list produces the
evidence.

It's not immediately obvious, but [my_list_ind] is almost just [fold_right].
Here's how we could implement [fold_right] in Coq, with a slightly different
argument order than the same function in OCaml: *)

Fixpoint my_fold_right
  {A B : Type}
  (init : B)
  (f : A -> B -> B)
  (lst : list A)
:=
  match lst with
  | nil => init
  | h::t => f h (my_fold_right init f t)
  end.

(** Now compare the body of [my_fold_right] with [my_list_rect]:

<<
my_fold_right's body:

  match lst with
  | nil => init
  | h::t => f h (my_fold_right init f t)
  end.

my_list_ind's body:

  match lst with
  | nil => baseCase
  | h::t => inductiveCase h t (my_list_ind A P baseCase inductiveCase t)
  end.
>>

Both match against [lst].  If [lst] is empty, both return an initial/base-case
value.  If [lst] is non-empty, both recurse on the tail, then pass the result of
the recursive call to a function ([f] or [inductiveCase]) that combines that
result with the head.  The only essential difference is that [f] does not take
[t] directly as an input, whereas [inductiveCase] does.

So there you have it:  induction over a list is really just folding over the
list, eventually reaching the empty list and returning the proof of the base
case for it, then working the way back up the call stack, assembling an
ever-larger proof for each element of the list.  ##An inductive proof is a
recursive program.##

Going back to the actual definition of [list_ind], here it is: *)

Print list_ind.

(** Coq responds:
<<
list_rect =
fun (A : Type) (P : list A -> Type) (f : P nil)
  (f0 : forall (a : A) (l : list A), P l -> P (a :: l)) =>
fix F (l : list A) : P l :=
  match l as l0 return (P l0) with
  | nil => f
  | y :: l0 => f0 y l0 (F l0)
  end
     : forall (A : Type) (P : list A -> Type),
       P nil ->
       (forall (a : A) (l : list A), P l -> P (a :: l)) ->
       forall l : list A, P l
>>

That uses different syntax, but it ends up defining the same function as
[my_list_ind].

Whenever you define an inductive type, Coq automatically generates the induction
principle and recursive function that implements it for you. For example, we
could define our own lists: *)

Inductive mylist (A:Type) : Type :=
| mynil : mylist A
| mycons : A -> mylist A -> mylist A.

(** Coq automatically generates [mylist_ind] for us: *)

Print mylist_ind.

(**

(**********************************************************************)

** Extraction

Coq makes it possible to _extract_ OCaml code (or Haskell or Scheme) from
Coq code.  That makes it possible for us to

- write Coq code,
- prove the Coq code is correct, and
- extract OCaml code that can be compiled and run more efficiently
  than the original Coq code.

Let's first prove that a tail recursive factorial is equivalent to the non-tail-recursive one, and then extract the code for the tail recursive factorial.

*)

Fixpoint fact (n:nat) : nat :=
  match n with
  | 0 => 1
  | S k => n * fact k
  end.

Fixpoint fact_tail_rec' (n : nat) (acc: nat) : nat :=
  match n with
  | 0 => acc
  | S k => fact_tail_rec' k (acc * n)
  end.

Definition fact_tail_rec (n : nat) := fact_tail_rec' n 1.

(**

We need to prove an intermediate lemma about [fact_tail_rec'] for the proof of our main theorem to go through.

*)

Lemma fact_tail_rec_lem : forall n acc,
  fact_tail_rec' n acc = acc * fact_tail_rec' n 1.
Proof.
  intros n.
  induction n.
  - intro acc. simpl. ring.
  - intro acc. simpl (fact_tail_rec' (S n) 1). rewrite IHn.
    simpl. rewrite IHn. ring.
Qed.

(**

In the above proof, the [simpl] tactic is applied with a specific pattern only on which simplification occurs. This is done so that the subsequent [rewrite] tactic does not pick the wrong term to rewrite. Try changing [simpl (fact_tail_rec' (S n) 1)] to [simpl] and make the proof go through.

Now we are ready to prove our main theorem. The proof involves induction on the input and an application of the lemma [fact_tail_rec_lem] that we had proved.

*)

Theorem fact_tail_rec_ok : forall n, fact n = fact_tail_rec n.
Proof.
  unfold fact_tail_rec.
  induction n.
  - simpl. trivial.
  - simpl. rewrite fact_tail_rec_lem. rewrite <- IHn. ring.
Qed.

(**

Let's extract [fact_tail_rec] as an example.

*)

Require Import Extraction.
Extraction Language OCaml.
Extraction "/tmp/fact.ml" fact_tail_rec.

(**

That produces the following file:

<<

type nat =
| O
| S of nat

(** val add : nat -> nat -> nat **)

let rec add n m =
  match n with
  | O -> m
  | S p -> S (add p m)

(** val mul : nat -> nat -> nat **)

let rec mul n m =
  match n with
  | O -> O
  | S p -> add m (mul p m)

(** val fact_tail_rec' : nat -> nat -> nat **)

let rec fact_tail_rec' n acc =
  match n with
  | O -> acc
  | S k -> fact_tail_rec' k (mul acc n)

(** val fact_tail_rec : nat -> nat **)

let fact_tail_rec n =
  fact_tail_rec' n (S O)

>>

As you can see, Coq has preserved the [nat] type in this extracted
code.  Unforunately, computation on natural numbers is not efficient.
(Addition requires linear time; multiplication, quadratic!)

We can direct Coq to extract its own [nat] type to OCaml's [int]
type as follows:

*)

Extract Inductive nat =>
  int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))".
Extract Inlined Constant Init.Nat.mul => "( * )".

(**
The first command says to

- use [int] instead of [nat] in the extract code,
- use [0] instead of [O] and [succ] instead of [S]
  (the [succ] function is in [Pervasives] and is [fun x -> x + 1]), and
- use the provided function to emulate pattern matching over the type.

The second command says to use OCaml's integer [( * )] operator instead of
Coq's natural-number multiplication operator.

After issuing those commands, the extraction looks cleaner:

*)

Extraction "/tmp/fact.ml" fact_tail_rec.

(**
<<

(** val fact_tail_rec' : int -> int -> int **)

let rec fact_tail_rec' n acc =
  (fun fO fS n -> if n=0 then fO () else fS (n-1))
    (fun _ -> acc)
    (fun k -> fact_tail_rec' k (( * ) acc n))
    n

(** val fact_tail_rec : int -> int **)

let fact_tail_rec n =
  fact_tail_rec' n (succ 0)

>>

There is, however, a tradeoff.  The original version we extracted worked
(albeit inefficiently) for arbitrarily large numbers without any error.
But the second version is subject to integer overflow errors.  So the
proofs of correctness that we did for [fact_tail_rec] are no longer completely
applicable:  they hold only up to the limits of the types we subsituted
during extraction.

Do we truly care about the limits of machine arithmetic?  Maybe, maybe not.
For sake of this little example, we might not.  If we were verifying
software to control the flight dynamics of a space shuttle, maybe we
would.  The Coq standard library does contain a module 31-bit
integers and operators on them, which we could use if we wanted to
precisely model what would happen on a particular architecture.

*)

(**

(**********************************************************************)

** Summary

Coq excels as a proof assistant when it comes to proof by induction.  Whenever
we define an inductive type, Coq generates an induction principle for us
automatically.  That principle is really a recursive program that knows how to
assemble evidence for a proposition, given the constructors of the inductive
type.  The [induction] tactic manages the proof for us, automatically figuring
out what the base case and the inductive case, and automatically generating the
inductive hypothesis.

** Terms and concepts

- append
- base case
- field
- [fix]
- [Fixpoint]
- induction
- induction principle
- inductive case
- inductive hypothesis
- lemma
- Peano natural numbers
- [Prop] vs [bool]
- ring
- searching for library theorems
- semi-ring
- syntactically smaller restriction on recursive calls

** Tactics

- [field]
- [induction]
- [rewrite]
- [ring]
- tacticals: [try]

** Further reading

- _Software Foundations, Volume 1: Logical Foundations_.
  #
  Chapter 2 through 4: Induction, Lists, Poly#.

- _Interactive Theorem Proving and Program Development_.
  Chapters 6 through 10. Available
  #
  online from the Cornell library#.

*)


Definition admit {T: Type} : T.  Admitted.

Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
    | monday    => tuesday
    | tuesday   => wednesday
    | wednesday => thursday
    | thursday  => friday
    | friday    => monday
    | saturday  => monday
    | sunday    => monday
  end.

Compute (next_weekday monday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
    Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true : bool
  | false : bool.

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1:bool) (b2:bool) : bool :=
  match b1 with
  | true => true
  | false=> b2
  end.

Infix "&&" := andb.
Infix "||" := orb.

Example test_orb: false || false || true = true.
  Proof.
    simpl.
    reflexivity.
  Qed.

Definition nandb (b1:bool) (b2:bool) : bool :=
  negb (andb b1 b2).

Example test_nandb1: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  andb (andb b1 b2) b3.

Example test_andb31:                 (andb3 true true true) = true.
  Proof. simpl. reflexivity.  Qed. (* FILL IN HERE *)
Example test_andb32:                 (andb3 false true true) = false.
  Proof. simpl. reflexivity. Qed.    (* FILL IN HERE *)
Example test_andb33:                 (andb3 true false true) = false.
  Proof. simpl. reflexivity. Qed.      (* FILL IN HERE *)
Example test_andb34:                 (andb3 true true false) = false.
  Proof. simpl. reflexivity. Qed.   (* FILL IN HERE *)

Module Playground1.

Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

Definition pred (n:nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.

End Playground1.

Definition minustwo (n:nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Compute (minustwo 4).
Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O        => true
  | S O      => false
  | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool := negb (evenb n).

Module Playground2.

Fixpoint plus (n:nat) (m:nat) : nat :=
  match n with
    | O => m
    | S k => S (plus k m)
  end.

Compute (plus 3 2).

Fixpoint mult (n m : nat) : nat :=
  match n with
    | O => O
    | S n' => plus m (mult n' m)
  end.

Fixpoint minus (n m : nat) : nat :=
  match n,m with
    | O, _ => O
    | S _, O => S n
    | S n', S m' => minus n' m'
  end.

End Playground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => 1
    | S k => mult base (exp base k)
  end.

Fixpoint factorial (n:nat) : nat :=
  match n with
    | O => S O
    | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Check ((0 + 1) + 1).

Fixpoint beq_nat (n m : nat) : bool :=
  match n,m with
    | O, O => true
    | S n', O => false
    | O, S m' => false
    | S n', S m' => beq_nat n' m'
  end.

Fixpoint leb (n m : nat) : bool :=
  match n,m with
    | O, _ => true
    | S _, O => false
    | S n', S m' => leb n' m'
  end.

Example test_leb1:             (leb 2 2) = true.
Proof. simpl. reflexivity.  Qed.
Example test_leb2:             (leb 2 4) = true.
Proof. simpl. reflexivity.  Qed.
Example test_leb3:             (leb 4 2) = false.
Proof. simpl. reflexivity.  Qed.

Definition blt_nat (n m :nat) : bool :=
  leb n m && negb (beq_nat n m).

Example test_blt_nat1: (blt_nat 2 2) = false.
  Proof. simpl. reflexivity. Qed.
Example test_blt_nat2: (blt_nat 2 4) = true.
  Proof. simpl. reflexivity. Qed.

Theorem plus_O_N : forall n : nat, O + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_l : forall n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_r : forall n:nat, n * 0 = 0.
Proof.
  intros. induction n.
  - reflexivity.
  - simpl. rewrite IHn. reflexivity.
Qed.

Theorem plus_n_O : forall n, n = n + 0.
Proof.
  intros n. simpl. Abort.

Theorem plus_id_example : forall n m:nat,
  n = m -> n + m = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem mult_0_plus : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity. Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H1.
  rewrite -> plus_1_l.
  rewrite <- H1.
  reflexivity.
Qed.

Theorem plus_1_neq0 : forall n : nat,
    beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  - reflexivity.
  - reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
    negb (negb b) = b.
Proof.
  intros b. destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b.
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
    beq_nat 0 (n + 1) = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
    (forall (x : bool), f x = x) ->
    forall(b : bool), f (f b) = b.
  Proof.
    intros. rewrite -> H. rewrite -> H. reflexivity.
  Qed.

Theorem andb_eq_orb :
  forall(b c : bool),
    (andb b c = orb b c) ->
    b = c.
Proof.
  intros [] [].
  - simpl. intros. reflexivity.
  - simpl. intros. rewrite -> H. reflexivity.
  - simpl. intros. rewrite -> H. reflexivity.
  - simpl. intros. reflexivity.
Qed.

Inductive bin : Type :=
| Z : bin
| T : bin -> bin
| I : bin -> bin.

Fixpoint incr (b:bin) : bin :=
  match b with
  | Z => I Z
  | T b' => I b'
  | I b' => T (incr b')
  end.

Fixpoint bin_to_nat (b:bin) : nat :=
  match b with
  | Z => O
  | T b' => 2 * bin_to_nat b'
  | I b' => S (2 * bin_to_nat b')
  end.

Example test_bin_incr1 : bin_to_nat (incr Z) = S O.
Proof. reflexivity. Qed.

Example test_bin_incr2 : bin_to_nat (incr (incr Z)) = S (S O).
Proof. reflexivity. Qed.

Example test_bin_incr3 : bin_to_nat (incr (incr (incr Z))) = 3.
Proof. simpl. reflexivity. Qed.

Example test_bin_incr4 : bin_to_nat (incr (incr (incr (incr Z)))) = 4.
Proof. simpl. reflexivity. Qed.

Example test_bin_incr5 : bin_to_nat (incr (incr (incr (incr (incr Z))))) = 5.
Proof. reflexivity. Qed.


Require Import Coq.Init.Datatypes.

Definition isTrue (b:bool) := andb b true.

(*
The assertion we've just made can be
proved by observing that both sides
of the equality evaluate to the same
thing, after some simplification.*)

Example testIsTrue: (
   (isTrue true) = true
). Proof. reflexivity. Qed.

Eval compute in (isTrue true).
Eval compute in (isTrue false).
Eval compute in (isTrue (negb false)).

Definition nandb (b1:bool) (b2:bool) : bool :=
    match (andb b1 b2) with
    | true => false
    | false => true
    end.

Example nanddb_tt: (
nandb true true = false
). Proof. reflexivity. Qed.
Example nanddb_ff: (
nandb false false = true
). Proof. reflexivity. Qed.
Example nanddb_ft: (
nandb false true = true
). Proof. reflexivity. Qed.
Example nanddb_tf: (
nandb true false = true
). Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
andb (andb b1 b2) b3.

Example andb3_ttt: (andb3 true true true) = true.
Proof. reflexivity. Qed.


Require Import Arith.
Require Import Omega.

Module RecRel.

(*
We model super general (univariate, single function) reccurence relations for now.
We'll make them more restrictive if the general definition turns out to be a hassle.

*)
Inductive Expr :=
| Var : Expr
| T   : Expr -> Expr
| Const : nat -> Expr
| Sum : Expr -> Expr -> Expr
| Mul : Expr -> Expr -> Expr
| Div : Expr -> Expr -> Expr
| Fun : (nat -> nat) -> Expr -> Expr
.

Record Rel := { lhs : Expr; rhs : Expr }.

Print Rel.

Coercion Const : nat >-> Expr.

Notation "e1 <+> e2" := (Sum e1 e2)(at level 20).
Notation "e1 <*> e2" := (Mul e1 e2)(at level 20).
Notation "e1 </> e2" := (Div e1 e2)(at level 20).
Notation "f <@> e"   := (Fun f e)(at level 19).
Notation "<n>"       := Var.

Check (_/_).
Search (_/_).

Print Nat.div.
Print Nat.divmod.
Search Nat.divmod.

Fixpoint Interp (e : Expr) (f : nat -> nat) (n : nat) : nat :=
  match e with
      | <n> => n
      | T e' => f (Interp e' f n)
      | Const m => m
      | e1 <+> e2 => (Interp e1 f n) + (Interp e2 f n)
      | e1 <*> e2 => (Interp e1 f n) * (Interp e2 f n)
      | e1 </> e2 => (Interp e1 f n) / (Interp e2 f n)
      | g <@> e  => g (Interp e f n)
  end.

Notation "[[ e ]]" := (Interp e).

Definition ValRel (r : Rel) (f : nat -> nat) : Prop :=
  forall n, [[ lhs r ]] f n = [[ rhs r ]] f n.

Notation "l :== r" := (Build_Rel l r)(at level 30).

Opaque Nat.div.

Lemma test_lemma : forall f, ValRel (T <n> :== T ((<n> <*> 2) </> 2)) f.
Proof.
  unfold ValRel; intros; simpl Interp.

  assert (H := Nat.div_mul n 2).

  rewrite H; auto.
Qed.

Lemma test2 : ValRel (T <n> :== 2 <*> (T (<n> </> 2))) (fun n => n).
Proof.
  unfold ValRel; intros; simpl Interp.
Abort.

(*
We use the most straightforward definition here,
we'll amend it later if needed.
*)
Definition O (f : nat -> nat) (g : nat -> nat) : Prop :=
  exists n, exists C, forall M, n <= M -> g M <= C * (f M).

(*This notation is the worst *)
Notation "g ∈O a":= (O a g)(at level 10).

Ltac trivial_bounds := exists 0; exists 1.

Ltac o_of_n_bounds n C := exists n; exists C.

Ltac idk_bounds := eexists; eexists.

Lemma mul_le_r : forall n m k, k > 0 -> n <= m -> n <= m * k.
Proof.
  intros n m.
  induction k.
  - omega.
  -  rewrite Nat.mul_comm in *.
     simpl.
     intros.
     auto with arith.
Qed.

Lemma mul_le_l : forall n m k, k > 0 -> n <= m -> n <= k * m.
Proof.
  intros n m.
  induction k.
  - omega.
  -  simpl.
     intros.
     auto with arith.
Qed.

Ltac fast_progress_le_goal := match goal with
                         | [|- _ * _ <= _ * _] => apply mult_le_compat_l
                         | [|- _ * _ <= _ * _] => apply mult_le_compat_r
                         | [|- _ + _ <= _ + _] => apply plus_le_compat_l
                         | [|- _ + _ <= _ + _] => apply plus_le_compat_r
                         | [|- S _ <= S _]     => apply le_n_S
                         | [|- ?X / _ < ?X]    => apply Nat.div_lt
                         | [|- _ / ?X <= _ / ?X] => apply Nat.div_le_mono
                         | [|- ?X * (?Y / ?X) <= ?Y] => apply Nat.mul_div_le
                         | [|- _ ^ ?X <= _ ^ ?X] => apply Nat.pow_le_mono_l
                         | [|- ?X ^ _ <= ?X ^ _] => apply Nat.pow_le_mono_r
                         | [|- _ <= _ * _]     => apply mul_le_r; now auto with arith
                         | [|- _ <= _ * _]     => apply mul_le_l; now auto with arith
                         end; auto with arith.

Ltac progress_le_goal := try
                           (match goal with
                            | [_ : ((Nat.max ?X _) <= _) |- ?X <= _ ] => eapply Nat.max_lub_l; eauto with arith
                            | [_ : ((Nat.max _ ?X) <= _) |- ?X <= _ ] => eapply Nat.max_lub_r; eauto with arith
                            end); fast_progress_le_goal.

Lemma n_O_of_n_squared : (fun n => n) ∈O (fun n => n * n).
Proof.
  trivial_bounds.
  intros M l.
  simpl.
  replace (M * M + 0) with (M*M) by auto.
  induction M; auto.
  simpl.
  now progress_le_goal.
Qed.

Theorem O_refl : forall f, f ∈O f.
Proof.
  trivial_bounds.
  intros; simpl; auto with arith.
Qed.

Theorem O_trans : forall f g h, f ∈O g -> g ∈O h -> f ∈O h.
Proof.
  intros f g h (M1, (C1, H1)) (M2, (C2, H2)).
  o_of_n_bounds (Nat.max M1 M2) (C1 * C2).
  intros M lt.
  assert (f M <= C1 * g M).
  - apply H1.
    now progress_le_goal.

  - assert (g M <= C2 * h M).
    apply H2.
    now progress_le_goal.
    assert (C1 * g M <= C1 * (C2 * h M)) by auto with arith.
    eapply le_trans.
    * exact H.
    * Search (_*_*_).
      rewrite <- mult_assoc; now auto with arith.
Qed.

Theorem O_add_idempot : forall f g h, f ∈O (fun n => g n + h n) -> h ∈O g -> f ∈O g.
Proof.
  intros f g h (M1, (C1, H1)) (M2, (C2, H2)).
  o_of_n_bounds (Nat.max M1 M2) (C1 + C1*C2).
  intros M max_rel.
  SearchAbout ((_ + _)*_).
  rewrite Nat.mul_add_distr_r.
  Check mult_assoc_reverse.
  rewrite <- mult_assoc.
  apply (Nat.le_trans _ (C1 * g M + C1 * h M)).
  - rewrite <- Nat.mul_add_distr_l.
    apply H1.
    now progress_le_goal.
  - repeat fast_progress_le_goal.
    apply H2.
    progress_le_goal.
Qed.

Definition monotone f := forall n m, n <= m -> f n <= f m.

Definition non_zero f := exists k:nat, f k > 0.

Theorem O_mul_hyp : forall f g C, f ∈O (fun k => C * g k) -> f ∈O g.
Proof.
  intros f g C (M, (C', H)).
  o_of_n_bounds M (C' * C).
  intros M0 leq.
  rewrite <- Nat.mul_assoc.
  apply H; auto.
Qed.

Theorem O_mul_conc : forall f g C, C > 0 -> f ∈O g -> f ∈O (fun k => C * g k).
Proof.
  intros f g C nz (M, (C', H)).
  o_of_n_bounds M C'.
  intros; apply (Nat.le_trans _ (C' * g M0)); auto.
  repeat fast_progress_le_goal.
Qed.

Theorem O_mul_src : forall f g C, f ∈O g -> (fun k => C * f k) ∈O g.
Proof.
  intros f g C (M, (C', H)).
  o_of_n_bounds M (C * C').
  intros M0 leq.
  rewrite <- Nat.mul_assoc.
  fast_progress_le_goal.
Qed.

Theorem O_const_plus : forall f g h C, h ∈O g -> f ∈O (fun k => g k + C * h k) -> f ∈O g.
Proof.
  intros f g h C o_h_g o_f_sum.
  eapply O_add_idempot.
  apply o_f_sum.
  apply O_mul_src; auto.
Qed.

Theorem O_const : forall f n, monotone f -> non_zero f -> (fun _ => n) ∈O f.
Proof.
  intros f n mon non_zero.
  destruct non_zero as (k, k_n_z).
  o_of_n_bounds k (n * f k).
  intros M le_k.
  apply (Nat.le_trans _ (n * f k * f k)).
  repeat (apply mul_le_r; auto).
  fast_progress_le_goal.
Qed.

Theorem O_const_add_r : forall f g n, f ∈O g -> f ∈O (fun k => g k + n).
Proof.
  intros f g n (M, (C, H)).
  o_of_n_bounds M C.
  intros M0 leq.
  rewrite Nat.mul_add_distr_l.
  auto with arith.
Qed.

(* Untrue!! *)
Theorem O_const_add_l : forall f g n, f ∈O (fun k => g k + n) -> f ∈O g.
Abort.

Theorem O_const_add_l : forall f g n, monotone g -> non_zero g -> f ∈O (fun k => g k + n) -> f ∈O g.
Proof.
  intros f g n mon non_zero o_g_const.
  eapply O_add_idempot.
  apply o_g_const.
  apply O_const; auto.
Qed.

SearchAbout (_ * (_ / _) <= _).

Theorem O_id : forall f, ValRel (T <n> :== 2 <*> (T (<n> </> 2))) f ->
                         f ∈O (fun n => n).
Proof.
  Opaque Nat.mul.
  unfold ValRel; simpl.
  intros f eqn.
  o_of_n_bounds 1 (f 1).
  intros M geq; simpl.
  (* we need strong induction here *)
  induction M as (M,IH) using lt_wf_ind.
  case_eq M.
  - omega.
  - intros n eqM.
    case_eq n.
    * intros; omega.
    * intros m eq_m; assert (H1 := eqn M); clear eqn.
      assert (H2 : 1 < M).
      + subst n; rewrite eqM; auto with arith.
      + subst n; rewrite <- eqM.
        assert (H3: f (M / 2) <= f 1 * (M / 2)).
        apply IH.
        fast_progress_le_goal.
        apply (Nat.le_trans _ (2/2)); auto with arith.
        fast_progress_le_goal.

        rewrite H1.
        apply (Nat.le_trans _ (2 * (f 1 * (M/2)))).
        now auto with arith.

        replace (2 * (f 1 * (M / 2))) with (f 1 * (2 * (M/2))) by ring.
        repeat fast_progress_le_goal.
Qed.

Theorem O_pow : forall n m, n <= m -> (fun k => k^n) ∈O (fun k => k^m).
Proof.
  intros n m leq.
  o_of_n_bounds 1 1.
  intros M M_bound.
  replace (1 * M ^ m) with (M ^ m) by auto with arith.
  fast_progress_le_goal.
  omega.
Qed.

Print Nat.log2.
Print Nat.log2_iter.

SearchAbout (_^_).
SearchAbout Nat.log2_up.
Print Nat.log2_up.

Print Nat.log2_up.

Require Import FunInd.

Functional Scheme log2_up_ind := Induction for Nat.log2_up Sort Prop.

Check log2_up_ind.

SearchAbout (_^(Nat.log2_up _)).

Lemma exp_log2_up : forall a, 0 < a -> a <= 2 ^ Nat.log2_up a.
Proof.
  intros; apply Nat.log2_log2_up_spec; auto.
Qed.

SearchAbout ((_^_)*(_^_)).
Check Nat.pow_mul_l.

SearchAbout (_^_ <= _^_).
Check Nat.pow_le_mono_l.

SearchAbout (_*_ <= _*_).
Check Nat.mul_le_mono_r.

SearchAbout (_*(_/_)).
Check Nat.mul_div_le.

Lemma log_2_div : forall a b, 0 < a ->
                              a * (b/2)^(Nat.log2_up a) <= b^(Nat.log2_up a).
Proof.
  intros a b a_nz.
  etransitivity.
  eapply Nat.mul_le_mono_r.
  apply exp_log2_up; auto.
  rewrite <- Nat.pow_mul_l.
  apply Nat.pow_le_mono_l.
  apply Nat.mul_div_le; auto.
Qed.

Axiom I_GIVE_UP : forall {P}, P.

Lemma baby_master_theorem_1 : forall g f a n,
    n < Nat.log2 a ->
    ValRel (T <n> :== a <*> (T (<n> </> 2)) <+> (g <@> <n>)) f
    -> g ∈O (fun k => k ^ n)
    -> f ∈O (fun k => k ^ (Nat.log2_up a)).
Proof.
  intros g f a n crit f_eqn g_o_n.
  (* idk_bounds ?[n] ?[C]. *)
  eexists ?[n].
  eexists ?[C].
  induction M as (M, IH) using lt_wf_ind.
  intro M_large_enough.
  unfold ValRel in f_eqn; simpl in f_eqn.
  rewrite f_eqn.
  specialize IH with (m:= M/2).
  eapply (Nat.le_trans _ (a * (?C * (M / 2) ^ Nat.log2_up a) + g M)).

  -  repeat fast_progress_le_goal.
     apply IH.
     apply I_GIVE_UP.
     apply I_GIVE_UP.
  - Check log_2_div.
    apply log_2_div.

  (* Focus 2. *)
  (* SearchAbout (_ ^ (Nat.log2_up _)). *)
  (* induction a; simpl. *)

  (* - fast_progress_le_goal. *)
  (*   repeat fast_progress_le_goal. *)
  (*   apply IH. *)
  (*   * SearchAbout (_ / _ < _). *)
  (*     apply Nat.div_lt_upper_bound; auto with arith. *)

  (* assert (H : (f (M/2) <= ?C * (M/2) ^ Nat.log2_up a)). *)

Admitted.

Variable log : nat -> nat -> nat.

Variable log_up : nat -> nat -> nat.

(* To express this, we need a log_b a function and a log_b_up one! *)
Theorem master_theorem_1 : forall g f a b n,
    n < log b a ->
    ValRel (T <n> :== a <*> (T (<n> </> b)) <+> (g <@> <n>)) f
    -> g ∈O (fun k => k ^ n)
    -> f ∈O (fun k => k ^ (log_up b a)).
Proof.
Admitted.


(* Exercise 12 *)

Require Import BenB.

Definition D := R.
Variables P Q S T : D -> Prop.
Variable RR : D -> D -> Prop.

Theorem exercise_012 :
  (forall x : D, (exists y : D, exists z:D, RR (y+z) x) -> P x)
->
    (exists x : D, exists y : D, RR (x+y) y)
  ->
    (exists x : D, P (x+7)).
Proof.
imp_i a1.
imp_i a2.
exi_e (exists x:D, exists y:D, RR (x + y) y) a a3.
hyp a2.
exi_e (exists y:D, RR (a + y) y) b a4.
hyp a3.
exi_i (b-7).
replace (b-7+7) with b.
imp_e (exists y : D, exists z : D, RR (y + z) b).
all_e (forall x : D, (exists y : D, exists z : D, RR (y + z) x) -> P x) b.
hyp a1.
exi_i a.
exi_i b.
hyp a4.
lin_solve.
Qed.


(**
Here we define the category of rings using the mechanism of algebras.
Note: rings are commutative and always have `0` and `1`.
 *)
Require Import prelude.all.
Require Import syntax.hit_signature.
Require Import algebras.set_algebra.

Open Scope cat.

(** We first define the signature. *)

(** Operations *)
Definition ring_operations
  : poly_code
  := (I * I) (* plus *)
     + (I * I) (* mult *)
     + I (* minus *)
     + C unitset (* zero *)
     + C unitset (* one *).

(** Labels of group axioms *)
Inductive ring_ax :=
| p_assoc : ring_ax
| p_unit : ring_ax
| p_inv : ring_ax
| p_com : ring_ax
| m_assoc : ring_ax
| m_unit : ring_ax
| m_com : ring_ax
| distr : ring_ax.

(** Arguments for each label *)
Definition ring_arg
  : ring_ax → poly_code
  := fun j =>
       match j with
       | p_assoc => I * I * I
       | p_unit => I
       | p_inv => I
       | p_com => I * I
       | m_assoc => I * I * I
       | m_unit => I
       | m_com => I * I
       | distr => I * I * I
       end.

(** Some convenient notation for the constructor terms. These represent the operations *)
Definition plus
           {P : poly_code}
           (e₁ e₂ : endpoint ring_operations P I)
  : endpoint ring_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  exact (pair e₁ e₂).
Defined.

Definition mult
           {P : poly_code}
           (e₁ e₂ : endpoint ring_operations P I)
  : endpoint ring_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₂ _ _)).
  exact (pair e₁ e₂).
Defined.

Definition minus
           {P : poly_code}
           (e : endpoint ring_operations P I)
  : endpoint ring_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₂ _ _)).
  exact e.
Defined.

Definition zero_el
           {P : poly_code}
  : endpoint ring_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₁ _ _)).
  refine (comp _ (ι₂ _ _)).
  apply c.
  exact tt.
Defined.

Definition one_el
           {P : poly_code}
  : endpoint ring_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₂ _ _)).
  apply c.
  exact tt.
Defined.

(** The left hand side of each equation *)
Definition ring_lhs
  : ∏ (j : ring_ax), endpoint ring_operations (ring_arg j) I.
Proof.
  induction j ; cbn.
  - refine (plus (plus _ _) _). (* plus assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
  - refine (plus _ _). (* plus zero *)
    + apply zero_el.
    + apply id_e.
  - refine (plus _ _). (* plus minus *)
    + apply minus.
      apply id_e.
    + apply id_e.
  - refine (plus _ _). (* plus com *)
    + exact (π₁ _ _).
    + exact (π₂ _ _).
  - refine (mult (mult _ _) _). (* mult assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
  - refine (mult _ _). (* mult one *)
    + apply one_el.
    + apply id_e.
  - refine (mult _ _). (* mult com *)
    + exact (π₁ _ _).
    + exact (π₂ _ _).
  - refine (mult _ _). (* distr *)
    + refine (comp _ _).
      * exact (π₁ _ _).
      * exact (π₁ _ _).
    + refine (plus _ _).
      * refine (comp _ _).
        ** exact (π₁ _ _).
        ** exact (π₂ _ _).
      * exact (π₂ _ _).
Defined.

(** The right hand side of each equation *)
Definition ring_rhs
  : ∏ (j : ring_ax), endpoint ring_operations (ring_arg j) I.
Proof.
  induction j ; cbn.
  - refine (plus _ (plus _ _)). (* plus assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
  - apply id_e. (* plus zero *)
  - apply zero_el. (* plus minus *)
  - refine (plus _ _). (* plus com *)
    + exact (π₂ _ _).
    + exact (π₁ _ _).
  - refine (mult _ (mult _ _)). (* mult assoc *)
    + exact (comp (π₁ _ _) (π₁ _ _)).
    + exact (comp (π₁ _ _) (π₂ _ _)).
    + exact (π₂ _ _).
  - apply id_e. (* mult one *)
  - refine (mult _ _). (* mult com *)
    + exact (π₂ _ _).
    + exact (π₁ _ _).
  - refine (plus _ _). (* distr *)
    + refine (mult _ _).
      * refine (comp _ _).
        ** exact (π₁ _ _).
        ** exact (π₁ _ _).
      * refine (comp _ _).
        ** exact (π₁ _ _).
        ** exact (π₂ _ _).
    + refine (mult _ _).
      * refine (comp _ _).
        ** exact (π₁ _ _).
        ** exact (π₁ _ _).
      * exact (π₂ _ _).
Defined.

(** The signature of ring as a HIT signature *)
Definition ring_signature
  : hit_signature.
Proof.
  use tpair.
  - exact ring_operations.
  - use tpair.
    + exact ring_ax.
    + use tpair.
      * exact ring_arg.
      * split.
        ** exact ring_lhs.
        ** exact ring_rhs.
Defined.

(** The interpretation of ring in set *)
Definition ring_cat
  : univalent_category
  := set_algebra ring_signature.

(** Projections of a ring *)
Section RingProjections.
  Variable (R : ring_cat).

  Definition ring_carrier : hSet
    := pr11 R.

  Definition ring_plus
    : ring_carrier → ring_carrier → ring_carrier
    := λ x₁ x₂, pr21 R (inl (inl (inl (inl (x₁ ,, x₂))))).

  Local Notation "x₁ + x₂" := (ring_plus x₁ x₂).

  Definition ring_mult
    : ring_carrier → ring_carrier → ring_carrier
    := λ x₁ x₂, pr21 R (inl (inl (inl (inr (x₁ ,, x₂))))).

  Local Notation "x₁ * x₂" := (ring_mult x₁ x₂).

  Definition ring_minus
    : ring_carrier → ring_carrier
    := λ x, pr21 R (inl (inl (inr x))).

  Local Notation "- x" := (ring_minus x).

  Definition ring_zero
    : ring_carrier
    := pr21 R (inl (inr tt)).

  Local Notation "'0'" := ring_zero.

  Definition ring_one
    : ring_carrier
    := pr21 R (inr tt).

  Local Notation "'1'" := ring_one.

  Definition ring_plus_assoc
    : ∏ (x₁ x₂ x₃ : ring_carrier), (x₁ + x₂) + x₃ = x₁ + (x₂ + x₃)
    := λ x₁ x₂ x₃, pr2 R p_assoc ((x₁ ,, x₂) ,, x₃).

  Definition ring_zero_plus
    : ∏ (x : ring_carrier), 0 + x = x
    := λ x, pr2 R p_unit x.

  Definition ring_min_plus
    : ∏ (x : ring_carrier), (- x) + x = 0
    := λ x, pr2 R p_inv x.

  Definition ring_plus_com
    : ∏ (x y : ring_carrier), x + y = y + x
    := λ x y, pr2 R p_com (x ,, y).

  Definition ring_plus_zero
    : ∏ (x : ring_carrier), x + 0 = x
    := λ x, ring_plus_com x 0 @ ring_zero_plus x.

  Definition ring_plus_min
    : ∏ (x : ring_carrier), x + (- x) = 0
    := λ x, ring_plus_com x (- x) @ ring_min_plus x.

  Definition ring_mult_assoc
    : ∏ (x₁ x₂ x₃ : ring_carrier), (x₁ * x₂) * x₃ = x₁ * (x₂ * x₃)
    := λ x₁ x₂ x₃, pr2 R m_assoc ((x₁ ,, x₂) ,, x₃).

  Definition ring_one_mult
    : ∏ (x : ring_carrier), 1 * x = x
    := λ x, pr2 R m_unit x.

  Definition ring_mult_com
    : ∏ (x y : ring_carrier), x * y = y * x
    := λ x y, pr2 R m_com (x ,, y).

  Definition ring_mult_one
    : ∏ (x : ring_carrier), x * 1 = x
    := λ x, ring_mult_com x 1 @ ring_one_mult x.

  Definition ring_left_distr
    : ∏ (x₁ x₂ x₃ : ring_carrier), x₁ * (x₂ + x₃) = (x₁ * x₂) + (x₁ * x₃)
    := λ x₁ x₂ x₃, pr2 R distr ((x₁ ,, x₂) ,, x₃).

  Definition ring_right_distr
    : ∏ (x₁ x₂ x₃ : ring_carrier), (x₂ + x₃) * x₁ = (x₂ * x₁) + (x₃ * x₁).
  Proof.
    intros x₁ x₂ x₃.
    rewrite ring_mult_com.
    rewrite ring_left_distr.
    rewrite !(ring_mult_com _ x₁).
    reflexivity.
  Qed.
End RingProjections.

(** Builder for rings *)
Definition mk_ring
           (R : hSet)
           (plus : R → R → R)
           (mult : R → R → R)
           (min : R → R)
           (z : R)
           (o : R)
           (plus_assoc : ∏ (x₁ x₂ x₃ : R),
                         plus (plus x₁ x₂) x₃ = plus x₁ (plus x₂ x₃))
           (zero_plus : ∏ (x : R), plus z x = x)
           (plus_min : ∏ (x : R), plus (min x) x = z)
           (plus_com : ∏ (x y : R), plus x y = plus y x)
           (mult_assoc : ∏ (x₁ x₂ x₃ : R),
                         mult (mult x₁ x₂) x₃ = mult x₁ (mult x₂ x₃))
           (mult_one : ∏ (x : R), mult o x = x)
           (mult_com : ∏ (x y : R), mult x y = mult y x)
           (distr : ∏ (x y z : R), mult x (plus y z) = plus (mult x y) (mult x z))
  : ring_cat.
Proof.
  simple refine ((R ,, _) ,, _).
  - cbn.
    intros x.
    induction x as [x | x].
    + induction x as [x | x].
      * induction x as [x | x].
        ** induction x as [x | x].
           *** exact (plus (pr1 x) (pr2 x)).
           *** exact (mult (pr1 x) (pr2 x)).
        ** exact (min x).
      * exact z.
    +  exact o.
  - intros j.
    induction j.
    + exact (λ x, plus_assoc (pr11 x) (pr21 x) (pr2 x)).
    + exact zero_plus.
    + exact plus_min.
    + exact (λ x, plus_com (pr1 x) (pr2 x)).
    + exact (λ x, mult_assoc (pr11 x) (pr21 x) (pr2 x)).
    + exact mult_one.
    + exact (λ x, mult_com (pr1 x) (pr2 x)).
    + exact (λ x, distr (pr11 x) (pr21 x) (pr2 x)).
Defined.

(** Some laws for rings *)
Section Laws.
  Context {Ring : ring_cat}.

  Local Notation "'R'" := (alg_carrier Ring).
  Local Notation "x + y" := (ring_plus Ring x y).
  Local Notation "x * y" := (ring_mult Ring x y).
  Local Notation "- x" := (ring_minus Ring x).
  Local Notation "'0'" := (ring_zero Ring).
  Local Notation "'1'" := (ring_one Ring).

  Definition ring_cancel_plus_left
    : ∏ {x y : R} (z : R), z + x = z + y → x = y.
  Proof.
    intros x y z H.
    refine (_ @ maponpaths (λ r, (- z) + r) H @ _).
    - rewrite <- ring_plus_assoc.
      rewrite ring_min_plus.
      rewrite ring_zero_plus.
      reflexivity.
    - rewrite <- ring_plus_assoc.
      rewrite ring_min_plus.
      rewrite ring_zero_plus.
      reflexivity.
  Qed.

  Definition ring_cancel_plus_right
    : ∏ {x y : R} ( z : R), x + z = y + z → x = y.
  Proof.
    intros x y z H.
    refine (_ @ maponpaths (λ r, r + (- z)) H @ _).
    - rewrite ring_plus_assoc.
      rewrite ring_plus_min.
      rewrite ring_plus_zero.
      reflexivity.
    - rewrite ring_plus_assoc.
      rewrite ring_plus_min.
      rewrite ring_plus_zero.
      reflexivity.
  Qed.

  Definition ring_minus_eq
    : ∏ (x y : R), x + y = 0 → x = - y.
  Proof.
    intros x y H.
    apply (ring_cancel_plus_right y).
    rewrite H.
    rewrite ring_min_plus.
    reflexivity.
  Qed.

  Definition ring_inverse_unique'
    : ∏ (x : R) {y z : R}, x + y = 0 → x + z = 0 → y = z.
  Proof.
    intros x y z H₁ H₂.
    apply (ring_cancel_plus_left x).
    exact (H₁ @ !H₂).
  Qed.

  Definition ring_inverse_unique
    : ∏ {x y : R}, x + y = 0 → -x = y.
  Proof.
    intros x y H.
    symmetry.
    apply (ring_inverse_unique' x).
    - exact H.
    - apply ring_plus_min.
  Qed.

  Definition ring_mult_zero
    : ∏ (x : R), x * 0 = 0.
  Proof.
    intro x.
    apply (ring_cancel_plus_right (x * 0)).
    rewrite ring_zero_plus.
    rewrite <- ring_left_distr.
    rewrite ring_zero_plus.
    reflexivity.
  Qed.

  Definition ring_zero_mult
    : ∏ (x : R), 0 * x = 0.
  Proof.
    intro x.
    rewrite ring_mult_com.
    apply ring_mult_zero.
  Qed.

  Definition ring_mult_minus
    : ∏ (x y : R), x * (- y) = -(x * y).
  Proof.
    intros x y.
    apply (ring_inverse_unique' (x * y)).
    - rewrite <- ring_left_distr.
      rewrite ring_plus_min.
      apply ring_mult_zero.
    - apply ring_plus_min.
  Qed.

  Definition ring_minus_zero
    : - 0 = 0.
  Proof.
    apply ring_inverse_unique.
    apply ring_plus_zero.
  Qed.

  Definition ring_minus_minus
    : ∏ (x : R), -(- x) = x.
  Proof.
    intro x.
    apply ring_inverse_unique.
    apply ring_min_plus.
  Qed.

  Definition ring_inv_plus
    : ∏ (x y : R), -(x + y) = (-x) + (-y).
  Proof.
    intros x y.
    apply ring_inverse_unique.
    rewrite (ring_plus_com _ x y).
    rewrite ring_plus_assoc.
    refine (_ @ _).
    {
      apply maponpaths.
      rewrite <- ring_plus_assoc.
      rewrite ring_plus_min.
      apply ring_zero_plus.
    }
    apply ring_plus_min.
  Qed.
End Laws.

(** Builder for ring homomorphisms *)
Section BuildRingMap.
  Context {R₁ R₂ : ring_cat}.
  Variable (f : alg_carrier R₁ → alg_carrier R₂)
           (f_p : ∏ (x₁ x₂ : alg_carrier R₁),
                  f (ring_plus R₁ x₁ x₂)
                  =
                  ring_plus R₂ (f x₁) (f x₂))
           (f_m : ∏ (x₁ x₂ : alg_carrier R₁),
                  f (ring_mult R₁ x₁ x₂)
                  =
                  ring_mult R₂ (f x₁) (f x₂))
           (f_o : f (ring_one R₁) = ring_one R₂).

  Local Definition f_z
    : f (ring_zero R₁) = ring_zero R₂.
  Proof.
    apply (ring_cancel_plus_right (f (ring_zero R₁))).
    rewrite ring_zero_plus.
    rewrite <- f_p.
    exact (maponpaths f (ring_plus_zero _ _)).
  Qed.

  Local Definition f_minus
    : ∏ (x : alg_carrier R₁), f (ring_minus R₁ x) = ring_minus R₂ (f x).
  Proof.
    intro x.
    apply ring_minus_eq.
    rewrite <- f_p.
    refine (_ @ f_z).
    apply maponpaths.
    apply ring_min_plus.
  Qed.

  Definition mk_ring_map
    : R₁ --> R₂.
  Proof.
    use make_algebra_map.
    - exact f.
    - intros x.
      induction x as [x | x].
      + induction x as [x | x].
        * induction x as [x | x].
          ** induction x as [x | x].
             *** apply f_p.
             *** apply f_m.
          ** exact (f_minus x).
        * induction x.
          exact f_z.
      + induction x.
        exact f_o.
  Defined.
End BuildRingMap.

(** Laws of ring homomorphism *)
Section RingMapProjections.
  Context {R₁ R₂ : ring_cat}.
  Variable (f : R₁ --> R₂).

  Definition ring_map_plus
    : ∏ (x y : alg_carrier R₁),
      alg_map_carrier f (ring_plus R₁ x y)
      =
      ring_plus R₂ (alg_map_carrier f x) (alg_map_carrier f y)
    := λ x y, eqtohomot (pr21 f) (inl (inl (inl (inl (x ,, y))))).

  Definition ring_map_mult
    : ∏ (x y : alg_carrier R₁),
      alg_map_carrier f (ring_mult R₁ x y)
      =
      ring_mult R₂ (alg_map_carrier f x) (alg_map_carrier f y)
    := λ x y, eqtohomot (pr21 f) (inl (inl (inl (inr (x ,, y))))).

  Definition ring_map_minus
    : ∏ (x : alg_carrier R₁),
      alg_map_carrier f (ring_minus R₁ x)
      =
      ring_minus R₂ (alg_map_carrier f x)
    := λ x, eqtohomot (pr21 f) (inl (inl (inr x))).

  Definition ring_map_zero
    : alg_map_carrier f (ring_zero R₁)
      =
      ring_zero R₂
    := eqtohomot (pr21 f) (inl (inr tt)).

  Definition ring_map_one
    : alg_map_carrier f (ring_one R₁)
      =
      ring_one R₂
    := eqtohomot (pr21 f) (inr tt).
End RingMapProjections.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* non commutative rings *)

Require Import Setoid.
Require Import BinPos.
Require Import BinNat.
Require Export Morphisms Setoid Bool.
Require Export Algebra_syntax.

Set Implicit Arguments.

Class Ring (R:Type) := {
 ring0: R; ring1: R;
 ring_plus: R->R->R; ring_mult: R->R->R;
 ring_sub:  R->R->R; ring_opp: R->R;
 ring_eq : R -> R -> Prop;
 ring_setoid: Equivalence ring_eq;
 ring_plus_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_plus;
 ring_mult_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_mult;
 ring_sub_comp: Proper (ring_eq==>ring_eq==>ring_eq) ring_sub;
 ring_opp_comp: Proper (ring_eq==>ring_eq) ring_opp;

 ring_add_0_l    : forall x, ring_eq (ring_plus ring0 x) x;
 ring_add_comm    : forall x y, ring_eq (ring_plus x y) (ring_plus y x);
 ring_add_assoc  : forall x y z, ring_eq (ring_plus x (ring_plus y z))
                                         (ring_plus (ring_plus x y) z);
 ring_mul_1_l    : forall x, ring_eq (ring_mult ring1 x) x;
 ring_mul_1_r    : forall x, ring_eq (ring_mult x ring1) x;
 ring_mul_assoc  : forall x y z, ring_eq (ring_mult x (ring_mult y z))
                                         (ring_mult (ring_mult x y) z);
 ring_distr_l    : forall x y z, ring_eq (ring_mult (ring_plus x y) z)
                                   (ring_plus (ring_mult x z) (ring_mult y z));
 ring_distr_r    : forall x y z, ring_eq (ring_mult z (ring_plus x y))
                                  (ring_plus (ring_mult z x) (ring_mult z y));
 ring_sub_def    : forall x y, ring_eq (ring_sub x y) (ring_plus x (ring_opp y));
 ring_opp_def    : forall x, ring_eq (ring_plus x (ring_opp x)) ring0
}.

Instance zero_ring (R:Type)(Rr:Ring R) : Zero R := {zero := ring0}.
Instance one_ring(R:Type)(Rr:Ring R) : One R := {one := ring1}.
Instance addition_ring(R:Type)(Rr:Ring R) : Addition R :=
  {addition x y := ring_plus x y}.
Instance multiplication_ring(R:Type)(Rr:Ring R) : Multiplication:=
  {multiplication x y := ring_mult x y}.
Instance subtraction_ring(R:Type)(Rr:Ring R) : Subtraction R :=
  {subtraction x y := ring_sub x y}.
Instance opposite_ring(R:Type)(Rr:Ring R) : Opposite R :=
  {opposite x := ring_opp x}.
Instance equality_ring(R:Type)(Rr:Ring R) : Equality :=
  {equality x y := ring_eq x y}.

Existing Instance ring_setoid.
Existing Instance ring_plus_comp.
Existing Instance ring_mult_comp.
Existing Instance ring_sub_comp.
Existing Instance ring_opp_comp.
(** Interpretation morphisms definition*)

Class Ring_morphism (C R:Type)`{Cr:Ring C} `{Rr:Ring R}:= {
    ring_morphism_fun: C -> R;
    ring_morphism0    : ring_morphism_fun 0 == 0;
    ring_morphism1    : ring_morphism_fun 1 == 1;
    ring_morphism_add : forall x y, ring_morphism_fun (x + y)
                     == ring_morphism_fun x + ring_morphism_fun y;
    ring_morphism_sub : forall x y, ring_morphism_fun (x - y)
                     == ring_morphism_fun x - ring_morphism_fun y;
    ring_morphism_mul : forall x y, ring_morphism_fun (x * y)
                     == ring_morphism_fun x * ring_morphism_fun y;
    ring_morphism_opp : forall x, ring_morphism_fun (-x)
                          == -(ring_morphism_fun x);
    ring_morphism_eq  : forall x y, x == y
       -> ring_morphism_fun x == ring_morphism_fun y}.

Instance bracket_ring (C R:Type)`{Cr:Ring C} `{Rr:Ring R}
   `{phi:@Ring_morphism C R Cr Rr}
  : Bracket C R  :=
  {bracket x := ring_morphism_fun x}.

(* Tactics for rings *)

Lemma ring_syntax1:forall (A:Type)(Ar:Ring A), (@ring_eq _ Ar) = equality.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax2:forall (A:Type)(Ar:Ring A), (@ring_plus _ Ar) = addition.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax3:forall (A:Type)(Ar:Ring A), (@ring_mult _ Ar) = multiplication.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax4:forall (A:Type)(Ar:Ring A), (@ring_sub _ Ar) = subtraction.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax5:forall (A:Type)(Ar:Ring A), (@ring_opp _ Ar) = opposite.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax6:forall (A:Type)(Ar:Ring A), (@ring0 _ Ar) = zero.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax7:forall (A:Type)(Ar:Ring A), (@ring1 _ Ar) = one.
intros. symmetry. simpl; reflexivity. Qed.
Lemma ring_syntax8:forall (A:Type)(Ar:Ring A)(B:Type)(Br:Ring B)
  (pM:@Ring_morphism A B Ar Br), (@ring_morphism_fun _ _ _ _ pM) = bracket.
intros. symmetry. simpl; reflexivity. Qed.

Ltac set_ring_notations :=
  repeat (rewrite ring_syntax1);
  repeat (rewrite ring_syntax2);
  repeat (rewrite ring_syntax3);
  repeat (rewrite ring_syntax4);
  repeat (rewrite ring_syntax5);
  repeat (rewrite ring_syntax6);
  repeat (rewrite ring_syntax7);
  repeat (rewrite ring_syntax8).

Ltac unset_ring_notations :=
  unfold equality, equality_ring, addition, addition_ring,
     multiplication, multiplication_ring, subtraction, subtraction_ring,
     opposite, opposite_ring, one, one_ring, zero, zero_ring,
     bracket, bracket_ring.

Ltac ring_simpl := simpl; set_ring_notations.

Ltac ring_rewrite H:=
  generalize H;
  let h := fresh "H" in
  unset_ring_notations; intro h;
  rewrite h; clear h;
  set_ring_notations.

Ltac ring_rewrite_rev H:=
  generalize H;
  let h := fresh "H" in
  unset_ring_notations; intro h;
  rewrite <- h; clear h;
  set_ring_notations.

Ltac rrefl := unset_ring_notations; reflexivity.

Section Ring.

Variable R: Type.
Variable Rr: Ring R.

(* Powers *)

 Fixpoint pow_pos (x:R) (i:positive) {struct i}: R :=
  match i with
  | xH => x
  | xO i => let p := pow_pos x i in p * p
  | xI i => let p := pow_pos x i in x * (p * p)
  end.
Add Setoid R ring_eq ring_setoid as R_set_Power.
 Add Morphism ring_mult : rmul_ext_Power. exact ring_mult_comp. Qed.

 Lemma pow_pos_comm : forall x j,  x * pow_pos x j == pow_pos x j * x.
induction j; ring_simpl.
ring_rewrite_rev ring_mul_assoc. ring_rewrite_rev ring_mul_assoc.
ring_rewrite_rev IHj. ring_rewrite (ring_mul_assoc (pow_pos x j) x (pow_pos x j)).
ring_rewrite_rev IHj. ring_rewrite_rev ring_mul_assoc. rrefl.
ring_rewrite_rev ring_mul_assoc. ring_rewrite_rev IHj.
ring_rewrite ring_mul_assoc. ring_rewrite IHj.
ring_rewrite_rev ring_mul_assoc. ring_rewrite IHj. rrefl. rrefl.
Qed.

 Lemma pow_pos_Psucc : forall x j, pow_pos x (Psucc j) == x * pow_pos x j.
 Proof.
  induction j; ring_simpl.
  ring_rewrite IHj.
ring_rewrite_rev (ring_mul_assoc x (pow_pos x j) (x * pow_pos x j)).
ring_rewrite (ring_mul_assoc (pow_pos x j) x  (pow_pos x j)).
  ring_rewrite_rev pow_pos_comm. unset_ring_notations.
rewrite <- ring_mul_assoc. reflexivity.
rrefl. rrefl.
Qed.

 Lemma pow_pos_Pplus : forall x i j, pow_pos x (i + j) == pow_pos x i * pow_pos x j.
 Proof.
  intro x;induction i;intros.
  rewrite xI_succ_xO;rewrite Pplus_one_succ_r.
  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
  repeat ring_rewrite IHi.
  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;
  ring_rewrite pow_pos_Psucc.
  ring_simpl;repeat ring_rewrite ring_mul_assoc. rrefl.
  rewrite <- Pplus_diag;repeat rewrite <- Pplus_assoc.
  repeat ring_rewrite IHi. ring_rewrite ring_mul_assoc. rrefl.
  rewrite Pplus_comm;rewrite <- Pplus_one_succ_r;ring_rewrite pow_pos_Psucc.
   simpl. reflexivity.
 Qed.

 Definition pow_N (x:R) (p:N) :=
  match p with
  | N0 => 1
  | Npos p => pow_pos x p
  end.

 Definition id_phi_N (x:N) : N := x.

 Lemma pow_N_pow_N : forall x n, pow_N x (id_phi_N n) == pow_N x n.
 Proof.
  intros; rrefl.
 Qed.

End Ring.

Section Ring2.
Variable R: Type.
Variable Rr: Ring R.
 (** Identity is a morphism *)
 Definition IDphi (x:R) := x.
 Lemma IDmorph : @Ring_morphism R R Rr Rr.
 Proof.
  apply (Build_Ring_morphism Rr Rr IDphi);intros;unfold IDphi; try rrefl. trivial.
 Qed.

Ltac ring_replace a b :=
  unset_ring_notations; setoid_replace a with b; set_ring_notations.

 (** rings are almost rings*)
 Lemma ring_mul_0_l : forall x, 0 * x == 0.
 Proof.
  intro x. ring_replace (0*x) ((0+1)*x + -x).
  ring_rewrite ring_add_0_l. ring_rewrite ring_mul_1_l .
  ring_rewrite ring_opp_def ;rrefl.
  ring_rewrite ring_distr_l ;ring_rewrite ring_mul_1_l .
  ring_rewrite_rev ring_add_assoc ; ring_rewrite ring_opp_def .
  ring_rewrite ring_add_comm ; ring_rewrite ring_add_0_l ;rrefl.
 Qed.

 Lemma ring_mul_0_r : forall x, x * 0 == 0.
 Proof.
  intro x; ring_replace (x*0)  (x*(0+1) + -x).
  ring_rewrite ring_add_0_l ; ring_rewrite ring_mul_1_r .
  ring_rewrite ring_opp_def ;rrefl.

  ring_rewrite ring_distr_r ;ring_rewrite ring_mul_1_r .
  ring_rewrite_rev ring_add_assoc ; ring_rewrite ring_opp_def .
  ring_rewrite ring_add_comm ; ring_rewrite ring_add_0_l ;rrefl.
 Qed.

 Lemma ring_opp_mul_l : forall x y, -(x * y) == -x * y.
 Proof.
  intros x y;ring_rewrite_rev (ring_add_0_l (- x * y)).
  ring_rewrite ring_add_comm .
  ring_rewrite_rev (ring_opp_def (x*y)).
  ring_rewrite ring_add_assoc .
  ring_rewrite_rev ring_distr_l.
  ring_rewrite (ring_add_comm (-x));ring_rewrite ring_opp_def .
  ring_rewrite ring_mul_0_l;ring_rewrite ring_add_0_l ;rrefl.
 Qed.

Lemma ring_opp_mul_r : forall x y, -(x * y) == x * -y.
 Proof.
  intros x y;ring_rewrite_rev (ring_add_0_l (x * - y)).
  ring_rewrite ring_add_comm .
  ring_rewrite_rev (ring_opp_def (x*y)).
  ring_rewrite ring_add_assoc .
  ring_rewrite_rev ring_distr_r .
  ring_rewrite (ring_add_comm (-y));ring_rewrite ring_opp_def .
  ring_rewrite ring_mul_0_r;ring_rewrite ring_add_0_l ;rrefl.
 Qed.

 Lemma ring_opp_add : forall x y, -(x + y) == -x + -y.
 Proof.
  intros x y;ring_rewrite_rev (ring_add_0_l  (-(x+y))).
  ring_rewrite_rev (ring_opp_def  x).
  ring_rewrite_rev (ring_add_0_l  (x + - x + - (x + y))).
  ring_rewrite_rev (ring_opp_def  y).
  ring_rewrite (ring_add_comm  x).
  ring_rewrite (ring_add_comm  y).
  ring_rewrite_rev (ring_add_assoc  (-y)).
  ring_rewrite_rev (ring_add_assoc  (- x)).
  ring_rewrite (ring_add_assoc   y).
  ring_rewrite (ring_add_comm  y).
  ring_rewrite_rev (ring_add_assoc   (- x)).
  ring_rewrite (ring_add_assoc  y).
  ring_rewrite (ring_add_comm  y);ring_rewrite ring_opp_def .
  ring_rewrite (ring_add_comm  (-x) 0);ring_rewrite ring_add_0_l .
  ring_rewrite ring_add_comm; rrefl.
 Qed.

 Lemma ring_opp_opp : forall x, - -x == x.
 Proof.
  intros x; ring_rewrite_rev (ring_add_0_l (- -x)).
  ring_rewrite_rev (ring_opp_def x).
  ring_rewrite_rev ring_add_assoc ; ring_rewrite ring_opp_def .
  ring_rewrite (ring_add_comm  x); ring_rewrite ring_add_0_l . rrefl.
 Qed.

 Lemma ring_sub_ext :
      forall x1 x2, x1 == x2 -> forall y1 y2, y1 == y2 -> x1 - y1 == x2 - y2.
 Proof.
  intros.
  ring_replace (x1 - y1)  (x1 + -y1).
  ring_replace (x2 - y2)  (x2 + -y2).
  ring_rewrite H;ring_rewrite H0;rrefl.
  ring_rewrite ring_sub_def. rrefl.
  ring_rewrite ring_sub_def. rrefl.
 Qed.

 Ltac mring_rewrite :=
   repeat first
     [ ring_rewrite ring_add_0_l
     | ring_rewrite_rev (ring_add_comm 0)
     | ring_rewrite ring_mul_1_l
     | ring_rewrite ring_mul_0_l
     | ring_rewrite ring_distr_l
     | rrefl
     ].

 Lemma ring_add_0_r : forall x, (x + 0) == x.
 Proof. intros; mring_rewrite. Qed.

 Lemma ring_add_assoc1 : forall x y z, (x + y) + z == (y + z) + x.
 Proof.
  intros;ring_rewrite_rev (ring_add_assoc x).
  ring_rewrite (ring_add_comm x);rrefl.
 Qed.

 Lemma ring_add_assoc2 : forall x y z, (y + x) + z == (y + z) + x.
 Proof.
  intros; repeat ring_rewrite_rev ring_add_assoc.
   ring_rewrite (ring_add_comm x); rrefl.
 Qed.

 Lemma ring_opp_zero : -0 == 0.
 Proof.
  ring_rewrite_rev (ring_mul_0_r 0). ring_rewrite ring_opp_mul_l.
  repeat ring_rewrite ring_mul_0_r. rrefl.
 Qed.

End Ring2.

(** Some simplification tactics*)
Ltac gen_reflexivity := rrefl.

Ltac gen_ring_rewrite :=
  repeat first
     [ rrefl
     | progress ring_rewrite ring_opp_zero
     | ring_rewrite ring_add_0_l
     | ring_rewrite ring_add_0_r
     | ring_rewrite ring_mul_1_l
     | ring_rewrite ring_mul_1_r
     | ring_rewrite ring_mul_0_l
     | ring_rewrite ring_mul_0_r
     | ring_rewrite ring_distr_l
     | ring_rewrite ring_distr_r
     | ring_rewrite ring_add_assoc
     | ring_rewrite ring_mul_assoc
     | progress ring_rewrite ring_opp_add
     | progress ring_rewrite ring_sub_def
     | progress ring_rewrite_rev ring_opp_mul_l
     | progress ring_rewrite_rev ring_opp_mul_r ].

Ltac gen_add_push x :=
set_ring_notations;
repeat (match goal with
  | |- context [(?y + x) + ?z] =>
     progress ring_rewrite (@ring_add_assoc2 _ _ x y z)
  | |- context [(x + ?y) + ?z] =>
     progress ring_rewrite  (@ring_add_assoc1 _ _ x y z)
  end).


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.ZArith.Znumtheory Coq.ZArith.Zpow_facts.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.ZSimplify.Core.
Local Open Scope Z_scope.

Module Z.
  Lemma mod_r_distr_if (b : bool) x y z : z mod (if b then x else y) = if b then z mod x else z mod y.
  Proof. destruct b; reflexivity. Qed.
  Hint Rewrite mod_r_distr_if : push_Zmod.
  Hint Rewrite <- mod_r_distr_if : pull_Zmod.

  Lemma mod_l_distr_if (b : bool) x y z : (if b then x else y) mod z = if b then x mod z else y mod z.
  Proof. destruct b; reflexivity. Qed.
  Hint Rewrite mod_l_distr_if : push_Zmod.
  Hint Rewrite <- mod_l_distr_if : pull_Zmod.

  (** Version without the [n <> 0] assumption *)
  Lemma mul_mod_full a b n : (a * b) mod n = ((a mod n) * (b mod n)) mod n.
  Proof. auto using Zmult_mod. Qed.
  Hint Rewrite <- mul_mod_full : pull_Zmod.
  Hint Resolve mul_mod_full : zarith.

  Lemma mul_mod_l a b n : (a * b) mod n = ((a mod n) * b) mod n.
  Proof.
    intros; rewrite (mul_mod_full a b), (mul_mod_full (a mod n) b).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- mul_mod_l : pull_Zmod.
  Hint Resolve mul_mod_l : zarith.

  Lemma mul_mod_r a b n : (a * b) mod n = (a * (b mod n)) mod n.
  Proof.
    intros; rewrite (mul_mod_full a b), (mul_mod_full a (b mod n)).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- mul_mod_r : pull_Zmod.
  Hint Resolve mul_mod_r : zarith.

  Lemma add_mod_full a b n : (a + b) mod n = ((a mod n) + (b mod n)) mod n.
  Proof. auto using Zplus_mod. Qed.
  Hint Rewrite <- add_mod_full : pull_Zmod.
  Hint Resolve add_mod_full : zarith.

  Lemma add_mod_l a b n : (a + b) mod n = ((a mod n) + b) mod n.
  Proof.
    intros; rewrite (add_mod_full a b), (add_mod_full (a mod n) b).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- add_mod_l : pull_Zmod.
  Hint Resolve add_mod_l : zarith.

  Lemma add_mod_r a b n : (a + b) mod n = (a + (b mod n)) mod n.
  Proof.
    intros; rewrite (add_mod_full a b), (add_mod_full a (b mod n)).
    autorewrite with zsimplify; reflexivity.
  Qed.
  Hint Rewrite <- add_mod_r : pull_Zmod.
  Hint Resolve add_mod_r : zarith.

  Lemma opp_mod_mod a n : (-a) mod n = (-(a mod n)) mod n.
  Proof.
    intros; destruct (Z_zerop (a mod n)) as [H'|H']; [ rewrite H' | ];
      [ | rewrite !Z_mod_nz_opp_full ];
      autorewrite with zsimplify; lia.
  Qed.
  Hint Rewrite <- opp_mod_mod : pull_Zmod.
  Hint Resolve opp_mod_mod : zarith.

  (** Give alternate names for the next three lemmas, for consistency *)
  Lemma sub_mod_full a b n : (a - b) mod n = ((a mod n) - (b mod n)) mod n.
  Proof. auto using Zminus_mod. Qed.
  Hint Rewrite <- sub_mod_full : pull_Zmod.
  Hint Resolve sub_mod_full : zarith.

  Lemma sub_mod_l a b n : (a - b) mod n = ((a mod n) - b) mod n.
  Proof. auto using Zminus_mod_idemp_l. Qed.
  Hint Rewrite <- sub_mod_l : pull_Zmod.
  Hint Resolve sub_mod_l : zarith.

  Lemma sub_mod_r a b n : (a - b) mod n = (a - (b mod n)) mod n.
  Proof. auto using Zminus_mod_idemp_r. Qed.
  Hint Rewrite <- sub_mod_r : pull_Zmod.
  Hint Resolve sub_mod_r : zarith.

  Lemma lnot_mod_mod v m : (Z.lnot (v mod m) mod m) = (Z.lnot v) mod m.
  Proof.
    cbv [Z.lnot]; etransitivity; rewrite <- !Z.sub_1_r, Z.sub_mod_full, Z.opp_mod_mod, ?Zmod_mod; reflexivity.
  Qed.
  Hint Rewrite lnot_mod_mod : pull_Zmod.
  Hint Resolve lnot_mod_mod : zarith.

  Lemma mod_pow_full p q n : (p^q) mod n = ((p mod n)^q) mod n.
  Proof.
    destruct (Z_dec' n 0) as [ [H|H] | H]; subst;
      [
      | apply Zpower_mod; assumption
      | rewrite !Zmod_0_r; reflexivity ].
    { revert H.
      rewrite <- (Z.opp_involutive (p^q)),
      <- (Z.opp_involutive ((p mod n)^q)),
      <- (Z.opp_involutive p),
      <- (Z.opp_involutive n).
      generalize (-n); clear n; intros n H.
      rewrite !Zmod_opp_opp.
      rewrite !Z.opp_involutive.
      apply f_equal.
      destruct (Z.Even_or_Odd q).
      { rewrite !Z.pow_opp_even by (assumption || lia).
        destruct (Z.eq_dec (p^q mod n) 0) as [H'|H'], (Z.eq_dec ((-p mod n)^q mod n) 0) as [H''|H''];
          repeat first [ rewrite Z_mod_zero_opp_full by assumption
                       | rewrite Z_mod_nz_opp_full by assumption
                       | reflexivity
                       | rewrite <- Zpower_mod, Z.pow_opp_even in H'' by (assumption || lia); lia
                       | rewrite <- Zpower_mod, Z.pow_opp_even in H'' |- * by (assumption || lia); lia ]. }
      { rewrite Z.pow_opp_odd, !Z.opp_involutive, <- Zpower_mod, Z.pow_opp_odd, ?Z.opp_involutive by (assumption || lia).
        reflexivity. } }
  Qed.
  Hint Rewrite <- mod_pow_full : pull_Zmod.
  Hint Resolve mod_pow_full : zarith.
  Notation pow_mod_full := mod_pow_full.

  Definition NoZMod (x : Z) := True.
  Ltac NoZMod :=
    lazymatch goal with
    | [ |- NoZMod (?x mod ?y) ] => fail 0 "Goal has" x "mod" y
    | [ |- NoZMod _ ] => constructor
    end.

  Lemma mul_mod_push a b n : NoZMod a -> NoZMod b -> (a * b) mod n = ((a mod n) * (b mod n)) mod n.
  Proof. intros; apply mul_mod_full; assumption. Qed.
  Hint Rewrite mul_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_push a b n : NoZMod a -> NoZMod b -> (a + b) mod n = ((a mod n) + (b mod n)) mod n.
  Proof. intros; apply add_mod_full; assumption. Qed.
  Hint Rewrite add_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma mul_mod_l_push a b n : NoZMod a -> (a * b) mod n = ((a mod n) * b) mod n.
  Proof. intros; apply mul_mod_l; assumption. Qed.
  Hint Rewrite mul_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma mul_mod_r_push a b n : NoZMod b -> (a * b) mod n = (a * (b mod n)) mod n.
  Proof. intros; apply mul_mod_r; assumption. Qed.
  Hint Rewrite mul_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_l_push a b n : NoZMod a -> (a + b) mod n = ((a mod n) + b) mod n.
  Proof. intros; apply add_mod_l; assumption. Qed.
  Hint Rewrite add_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma add_mod_r_push a b n : NoZMod b -> (a + b) mod n = (a + (b mod n)) mod n.
  Proof. intros; apply add_mod_r; assumption. Qed.
  Hint Rewrite add_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_push a b n : NoZMod a -> NoZMod b -> (a - b) mod n = ((a mod n) - (b mod n)) mod n.
  Proof. intros; apply Zminus_mod; assumption. Qed.
  Hint Rewrite sub_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_l_push a b n : NoZMod a -> (a - b) mod n = ((a mod n) - b) mod n.
  Proof. intros; symmetry; apply Zminus_mod_idemp_l; assumption. Qed.
  Hint Rewrite sub_mod_l_push using solve [ NoZMod ] : push_Zmod.

  Lemma sub_mod_r_push a b n : NoZMod b -> (a - b) mod n = (a - (b mod n)) mod n.
  Proof. intros; symmetry; apply Zminus_mod_idemp_r; assumption. Qed.
  Hint Rewrite sub_mod_r_push using solve [ NoZMod ] : push_Zmod.

  Lemma opp_mod_mod_push a n : NoZMod a -> (-a) mod n = (-(a mod n)) mod n.
  Proof. intros; apply opp_mod_mod; assumption. Qed.
  Hint Rewrite opp_mod_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma lnot_mod_mod_push v m : NoZMod v -> (Z.lnot v) mod m = (Z.lnot (v mod m) mod m).
  Proof. intros; symmetry; apply lnot_mod_mod. Qed.
  Hint Rewrite lnot_mod_mod_push using solve [ NoZMod ] : push_Zmod.

  Lemma pow_mod_push p q n : NoZMod p -> (p^q) mod n = ((p mod n)^q) mod n.
  Proof. intros; apply pow_mod_full. Qed.
  Hint Rewrite pow_mod_push using solve [ NoZMod ] : push_Zmod.
End Z.