(** * Merge:  Merge Sort, With Specification and Proof of Correctness*)

Require Import Le Lt Gt Decidable PeanoNat Recdef.
From Coq Require Import Recdef.  (* needed for [Function] feature *)
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

Notation  "a >=? b" := (Nat.leb b a)
                          (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a)
                         (at level 70) : nat_scope.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
      [ | try first [apply not_lt in H | apply not_le in H]]].

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Ltac inv H := inversion H; clear H; subst.

Inductive sorted: list nat -> Set :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).

(** Mergesort is a well-known sorting algorithm, normally presented
    as an imperative algorithm on arrays, that has worst-case
    O(n log n) execution time and requires O(n) auxiliary space.

    The basic idea is simple: we divide the data to be sorted into two
    halves, recursively sort each of them, and then
    merge together the (sorted) results from each half:

    [[
    mergesort xs =
      split xs into ys,zs;
      ys' = mergesort ys;
      zs' = mergesort zs;
      return (merge ys' zs')
    ]]

    (As usual, if you are unfamiliar with mergesort see Wikipedia or
    your favorite algorithms textbook.)

    Mergesort on lists works essentially the same way: we split the
    original list into two halves, recursively sort each sublist,
    and then merge the two sublists together again.  The only
    difference, compared to the imperative algorithm, is that splitting
    the list takes O(n) rather than O(1) time; however, that
    does not affect the asymptotic cost, since the merge step already
    takes O(n) anyhow.
*)

(* ================================================================= *)
(** ** Split and its properties *)

(** Let us try to write down the Gallina code for mergesort.
    The first step is to write a splitting function. There are
    several ways to do this, since the exact splitting method does
    not matter as long as the results are (roughly) equal in size.
    For example, if we know the length of the list, we could use that to split
    at the half-way point. But here is an attractive alternative, which simply
    alternates assigning the elements into left and right sublists:
*)

Fixpoint split {X:Type} (l:list X) : (list X * list X) :=
  match l with
  | [] => ([],[])
  | [x] => ([x],[])
  | x1::x2::l' =>
    let (l1,l2) := split l' in
    (x1::l1,x2::l2)
  end.

(** Note: For generality, we made this function polymorphic, since the
    type of the values in the list is irrelevant to the splitting process.

    While this function is straightforward to define, it can be a bit challenging
    to work with.  Let's try to prove the following lemma, which is obviously true:
*)

Lemma split_len_first_try: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  induction l; intros.
  - inv H. simpl. lia.
  - destruct l as [| x l'].
    + inv H.
      split; simpl; auto.
    + inv H. destruct (split l') as [l1' l2'] eqn:E. inv H1.
      (* We're stuck! The IH talks about [split (x::l')] but we
         only know aobut [split (a::x::l')]. *)
Abort.

(** The problem here is that the standard induction principle for lists
    requires us to show that the property being proved follows for
    any non-empty list if it holds for the tail of that list.
    What we want here is a "two-step" induction principle, that instead requires
    us to show that the property being proved follows for a list of
    length at least two, if it holds for the tail of the tail of that list.
    Formally:
*)

Definition list_ind2_principle:=
    forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l.

(** If we assume the correctness of this "non-standard" induction principle,
    our [split_len] proof is easy, using a form of the [induction] tactic
    that lets us specify the induction principle to use:
*)

Lemma split_len': list_ind2_principle ->
    forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  unfold list_ind2_principle; intro IP.
  induction l using IP; intros.
  - inv H. lia.
  - inv H. simpl; lia.
  - inv H. destruct (split l) as [l1' l2']. inv H1.
    simpl.
    destruct (IHl l1' l2') as [P1 P2]; auto; lia.
Qed.

(** We still need to prove [list_ind2_principle].  There are several
    ways to do this, but one direct way is to write an explicit proof
    term, thus: *)

Definition list_ind2 :
  forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l :=
  fun (A : Type)
      (P : list A -> Prop)
      (H : P [])
      (H0 : forall a : A, P [a])
      (H1 : forall (a b : A) (l : list A), P l -> P (a :: b :: l))  =>
    fix IH (l : list A) :  P l :=
    match l with
    | [] => H
    | [x] => H0 x
    | x::y::l' => H1 x y l' (IH l')
    end.

(** Here, the [fix] keyword defines a local recursive function [IH]
    of type [forall l:list A, P l], which is returned as the overall value of
    [list_ind2]. As usual, this function must be obviously terminating
    to Coq (which it is because the recursive call is on a sublist [l']
    of the original argument [l]) and the [match] must be exhaustive over
    all possible lists (which it evidently is).
*)

(** With our induction principle in hand, we can finally prove
    [split_len] free and clear:
*)

Lemma split_len: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
 apply (@split_len' list_ind2).
Qed.

(** **** Exercise: 3 stars, standard (split_perm) *)

(** Here's another fact about [split] that we will find useful later on.
*)

Lemma split_perm : forall {X:Type} (l l1 l2: list X),
    split l = (l1,l2) -> Permutation l (l1 ++ l2).
Proof.
  induction l as [| x | x1 x2 l1' IHl'] using list_ind2; intros.
  inv H. simpl. auto.
  inv H. simpl. auto.
  inv H.
  destruct (split l1').
  inv H1.
  assert (Permutation l1' (l ++ l0)) .
  apply (IHl' l l0 ) . auto.
  simpl.   econstructor.
  assert (Permutation (x2 :: l1') (x2 :: (l ++ l0))).
  econstructor. auto.
  econstructor. apply H0. clear H0.
  assert (Permutation (x2 :: l ++ l0) (x2 :: l0 ++ l)).
  econstructor.    apply Permutation_app_comm.
  econstructor. apply H0.
  assert ((x2 :: l0 ++ l) = ((x2 :: l0) ++ l )) .
  auto.
  rewrite H1.
  apply Permutation_app_comm.
Qed.

(* ================================================================= *)
(** ** Defining Merge *)

(** Next, we need a [merge] function, which takes two
    sorted lists (of naturals) and returns their sorted result.
    This would seem easy to write:

    [[
    Fixpoint merge l1 l2 :=
      match l1, l2 with
      | [], _ => l2
      | _, [] => l1
      | a1::l1', a2::l2' =>
          if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge l1 l2'
      end.
    ]]

    But Coq will reject this definition with the message:

    [[
    Error: Cannot guess decreasing argument of fix.
    ]]

    Coq insists the every [Fixpoint] definition be structurally recursive
    on some specified argument, meaning that at each recursive call the
    callee is passed a value that is a sub-term of the caller's argument value.
    This check guarantees that every [Fixpoint] is actually terminating.

    It is fairly obvious that this function is in fact terminating, because
    at each call, either [l1] or [l2] is passed the tail of its original value.
    But unfortunately, [Fixpoint] recursive calls must always decrease on
    a _single fixed_ argument -- and neither [l1] nor [l2] will do. (That's
    why Coq couldn't guess the one to use.)  We might reasonably wish
    that Coq was a little smarter, but it isn't.

    There are a number of ways to get around the problem of convincing
    Coq that a function is actually terminating when the "natural" [Fixpoint]
    doesn't work. In this case, a little creativity (or a peek at the Coq
    library) might lead us to the following definition:
*)

Fixpoint merge l1 l2  {struct l1} :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** Coq accepts the outer definition because it is structurally
    decreasing on [l1] (we specify that with the [{struct l1}] annotation,
    although Coq would have guessed this even if we didn't write it),
    and it accepts the inner definition because it is structurally recursive
    on its (sole) argument. (Note that [let fix ... in ... end] is just a
    mechanism for  defining a local recursive function.)

    This definition will turn out to work pretty well; the only irritation
    is that simplification will show the definition of [merge_aux], as
    illustrated by the following examples.

    First, let's remind ourselves that Coq desugars a [match] over multiple
    arguments into a nested sequence of matches:
*)

Print merge.

(** ==> (after a little renaming for clarity)

    [[
    fix merge (l1 l2 : list nat) {struct l1} : list nat :=
      let
        fix merge_aux (l2 : list nat) : list nat :=
          match l1 with
          | [] => l2
          | a1 :: l1' =>
              match l2 with
              | [] => l1
              | a2 :: l2' =>
                  if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
              end
          end in
      merge_aux l2.
    ]]
*)

(** Let's prove the following simple lemmas about [merge]:
*)

Lemma merge2 : forall (x1 x2:nat) r1 r2,
    x1 <= x2 ->
    merge (x1::r1) (x2::r2) =
    x1::merge r1 (x2::r2).
Proof.
  intros.
  simpl. (* This blows up in an unpleasant way, but we can
      still make some sense of it.  Look at the
      [(fix merge_aux ...)] term. It represents the
      the local function [merge_aux] after the value of the
      free variable [l1] has been substituted by [x1::r1],
      the match over [l1] has been simplified to its
      second arm (the non-empty case) and [x1] and [r1] have
      been substituted for the pattern variables [a1] and [l1'].
      The entire [fix] is applied to [r2], but Coq won't attempt
      any further simplification until the structure of [r2]
      is known. *)
  bdestruct (x1 <=? x2).
  - auto.
  - (* Since [H] and [H0] are contradictory, this case follows by [lia].
       But (ignoring that for the moment), note that we can get further
       simplification to occur if we give some structure to [l2]: *)
    simpl. (* does nothing *)
    destruct r2; simpl.  (* makes some progress *)
    + lia.
    + lia.
Qed.

Lemma merge_nil_l : forall l, merge [] l = l.
Proof.
  intros. simpl.
  (* Once again, we see a version of [merge_aux] specialized to
  the value [l1 = nil]. Now we see only the first arm (the
  empty case) of the [match] expression, which simply returns [l2];
  in other words, here the [fix] is just the identity function.
  And once again, the [fix] is applied to [l].  Irritatingly,
  Coq _still_ refuses to perform the application unless [l]
  is destructured first (even though the answer is always [l]). *)
  destruct l.
  - auto.
  - auto.
Qed.

(** Morals:

    (1) Even though the proof state involving local recursive
        functions can can be hard to read, persevere!

    (2) If Coq won't simplify an "obvious" application, try destructing
        the argument.

    We will defer stating and proving other properties of [merge] until later.
*)

(* ================================================================= *)
(** ** Defining Mergesort *)

(** Finally, we need to define the main mergesort function itself.
    Once again, we might hope to write something simple like this:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
       let (l1,l2) := split l in
       merge (mergesort l1) (mergesort l2).
    ]]

    Since this function has only one argument, Coq guesses that it is
    intended to be structurally decreasing, but still
    rejects the definition, this time with the complaint:

    [[
    Recursive call to mergesort has principal argument equal to
    "l1" instead of a subterm of "l".
    ]]

    Again, the problem is that Coq has no way to know that [l1] and [l2]
    are "smaller" than [l].  And this time, it is hard to complain that
    Coq is being stupid, since the fact that [split] returns smaller
    lists than it is passed is nontrivial.

    In fact, it isn't true! Consider the behavior of [split] on
    empty or singleton lists...  This is case where Coq's totality
    requirements can actually help us correct the definition of
    our code.  What we really want to write is something more like:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
        match l with
        | [] => []
        | [x] => [x]
        | _ => let (l1,l2) := split l in merge (mergesort l1) (mergesort l2).
    ]]

    Now this function really is terminating!  But Coq still won't let us
    write it with a [Fixpoint].  Instead, we need to use a mechanism
    (there are several available) for defining functions that accommodates
    an explicit way to show that the function only calls itself on smaller
    arguments.   We will use the [Function] command:
*)

Function mergesort (l: list nat) {measure length l} :  list nat :=
  match l with
  | [] => []
  | [x] => [x]
  | _ => let (l1,l2) := split l in
         merge (mergesort l1) (mergesort l2)
  end.

(** [Function] is similar to [Fixpoint], but it lets us specify
    an explicit _measure_ on the function arguments.
    The annotation [{measure length l}] says that the function
    [length] applied to argument [l] serves as a decreasing measure.
    After processing this definition, Coq enters proof mode and demands
    proofs that each recursive call is indeed on a shorter list.
    Happily, we proved that fact already.
*)

Proof.
  - (* recursive call on l1 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
  - (* recursive call on l2 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
Defined.

(** Notice that the [Proof] must end with the keyword [Defined] rather
    than [Qed]; if we don't do this, we won't be able to actually
    compute with [mergesort].

    Defining [mergesort] with [Function] rather than [Fixpoint] causes
    the automatic generation of some useful auxiliary definitions that we
    will need when working with it.
    First, we get a lemma [mergesort_equation], which performs a one-level
    unfolding of the function. *)

Check mergesort_equation.

(** ==>

    [[
    mergesort_equation
     : forall l : list nat,
       mergesort l =
       match l with
       | [] => []
       | [x] => [x]
       | x :: _ :: _ =>
           let (l2, l3) := split l in merge (mergesort l2) (mergesort l3)
       end
    ]]

    We should always use [apply mergesort_equation]
    to simplify a call to [mergesort] rather than trying to [unfold] or [simpl]
    it, which will lead to ugly or mysterious results.

    Second, we get an induction principle [mergesort_ind]; performing
    induction using this principle can be much easier than trying to
    use list induction over the argument [l].
*)

Check mergesort_ind.

(** ==>
    [[
    mergesort_ind
     : forall P : list nat -> list nat -> Prop,
       (forall l : list nat, l = [] -> P [] []) ->
       (forall (l : list nat) (x : nat), l = [x] -> P [x] [x]) ->
       (forall l _x : list nat,
        l = _x ->
        match _x with
        | _ :: _ :: _ => True
        | _ => False
        end ->
        forall l1 l2 : list nat,
        split l = (l1, l2) ->
        P l1 (mergesort l1) ->
        P l2 (mergesort l2) -> P _x (merge (mergesort l1) (mergesort l2))) ->
        forall l : list nat, P l (mergesort l)
    ]]
*)

(* ================================================================= *)
(** ** Correctness: Sortedness *)

(** As with insertion sort, our goal is to prove that mergesort produces
    a sorted list that is a permutation of the original list, i.e. to prove

    [[
    is_a_sorting_algorithm mergesort
    ]]

    We will start by showing that [mergesort] produces a sorted list.  The key
    lemma is to show that [merge] of two sorted lists produces a sorted list.
    It is perhaps easiest to break out a sub-lemma first:
*)

(** **** Exercise: 2 stars, standard (sorted_merge1) *)
Lemma sorted_merge1 : forall x x1 l1 x2 l2,
    x <= x1 -> x <= x2 ->
    sorted (merge (x1::l1) (x2::l2)) ->
    sorted (x :: merge (x1::l1) (x2::l2)).
Proof.
  firstorder.
  simpl in *.
  bdestruct (x2 >=? x1 ); constructor; try lia; auto.
Qed.

Lemma sorted_merge2 : forall x l1 l2 ,
    sorted (x :: l1) ->
    sorted (x :: l2) ->
    sorted (merge l1 l2) ->
    sorted (x :: merge l1 l2).
Proof.
destruct l1; intros.
rewrite (merge_nil_l l2) in *.
auto.
destruct l2.
simpl in *.
auto.
apply sorted_merge1.
inv H. auto.
inv H0. auto.
auto.
Qed.

Lemma sorted_inv : forall x l , sorted (x :: l) -> sorted l.
Proof.
  intros.
  induction l.
  constructor.
  inv H.
  auto.
Qed.

Lemma merge_nil_r : forall l , merge l [] = l .
  Proof.
induction l.
simpl.    easy.
simpl.
easy.
Qed.

(** **** Exercise: 4 stars, standard (sorted_merge) *)
Lemma sorted_merge (l1 l2 : list nat): sorted l1 ->
                                    sorted l2 ->
                                    sorted (merge l1 l2) .
Proof.
  generalize (lt_n_Sn (length l1 + length l2)).
  remember (S (length l1 + length l2)).
  clear Heqn.
  generalize l1.
  generalize l2.
  induction n; intros.
  lia.

  destruct l3.
  rewrite (merge_nil_l l0).
  easy.
  destruct l0.
  simpl. easy.

  simpl.
  bdestruct (n1 >=? n0).

  apply sorted_merge2.
  easy.
  econstructor.
  easy.
  easy.
  apply IHn.
  simpl in *.
  lia.
  eapply sorted_inv.
  apply H0.
  easy.

  assert (sorted (n1 :: merge (n0 :: l3) l0)).
  apply sorted_merge2.
  econstructor.
  lia. easy. easy.

  apply IHn.
  simpl in *.
  lia.
  easy.
  eapply sorted_inv.
  apply H1.
  assumption.

Qed.

(** **** Exercise: 2 stars, standard (mergesort_sorts) *)
Lemma mergesort_sorts : forall l, sorted (mergesort l).
Proof.
  intro.
  functional induction (mergesort l).
  constructor. constructor.
  apply sorted_merge; auto.
Qed.

(* ================================================================= *)
(** ** Correctness: Permutation *)

(** Finally, we must show that [mergesort] returns a permutation of its input.

    As usual, the key lemma is for [merge].

    Incidentally, you are welcome to import the alternative characterizations
    of permutations as multisets given in [Multiset] or [BagPerm]
    and use that instead of [Permutation] if you think it will be easier.
    (I'm not sure!)
*)

(** **** Exercise: 3 stars, advanced (merge_perm) *)
Lemma merge_perm: forall (l1 l2: list nat),
    Permutation (l1 ++ l2) (merge l1 l2).
Proof.
    (* Hint: A nested induction on [l2] is required. *)
  induction l1.
  intros. rewrite (merge_nil_l l2).
  simpl in *.
  auto.
  induction l2.
  simpl.
  assert (a :: l1 ++ [] = a :: l1).
  f_equal.
  apply app_nil_r.
  rewrite H.
  auto.
  simpl.
  bdestruct (a0 >=? a).
  simpl.
  econstructor.
  apply IHl1.
  assert  (Permutation ((a :: l1) ++ a0 :: l2) ((a0 :: l2) ++ a :: l1)).
  apply Permutation_app_comm.
  assert ((a :: l1 ++ a0 :: l2) = ((a :: l1) ++ a0 :: l2)).
  auto.
  rewrite H1.
  econstructor.
  apply H0.
  simpl.
  econstructor.
  econstructor.
  apply Permutation_app_comm.
  exact IHl2.
Qed.

(** **** Exercise: 3 stars, advanced (mergesort_perm) *)
Lemma mergesort_perm: forall l, Permutation l (mergesort l).
Proof.
  intros.
  functional induction (mergesort l).
    auto.
    auto.
    econstructor.
    apply (split_perm l l1 l2 e0).
    assert (Permutation (l1 ++ l2) ((mergesort l1) ++ (mergesort l2))).
    apply Permutation_app.
    auto. auto.
    econstructor.
    apply H.
    apply merge_perm.
Qed.

(*
(** Putting it all together: *)

Theorem mergesort_correct:
  is_a_sorting_algorithm mergesort.
Proof.
  split.
  apply mergesort_perm.
  apply mergesort_sorts.
Qed.
*)
(** $Date$ *)

(* 2021-08-11 15:15 *)


Generalizable All Variables.

Reserved Notation "a ~> b" (at level 70, right associativity).
Reserved Notation "g << f" (at level 45).
Reserved Notation "G <<< F" (at level 45).

(*** =============== Categories =============== ***)

(****************** Definition 3.1 ******************)
Class Category :=
  {
    (* The quadruple *)
    Ob    :  Type;
    hom   :  Ob -> Ob -> Type
             where "a ~> b" := (hom a b);
    id    :  `(hom a a);
    comp  :  forall a b c, (hom a b) -> (hom b c) -> (hom a c)
             where "g << f" := (comp _ _ _ f g);

    (* Constraints *)
    assoc :  forall a b c d (f: a~>b) (g: b~>c) (h: c~>d),
             h << (g << f) = (h << g) << f;
    id_l  :  forall `(f: a~>b), f << id a = f;
    id_r  :  forall `(f: a~>b), id b << f = f
  }.

Notation "a ~> b"        := (@hom _ a b)  :category_scope.
Notation "g << f"        := (comp _ _ _ f g)  :category_scope.

Open Scope category_scope.

Lemma juggle1 :
  forall `{_:Category}`(f:a~>b)`(g:b~>c)`(h:c~>d)`(k:d~>e),
    k << (h << (g << f)) = k << (h << g) << f.
Proof.
  intros; repeat rewrite -> assoc; reflexivity.
Qed.

Lemma juggle2 :
  forall `{_:Category}`(f:a~>b)`(g:b~>c)`(h:c~>d)`(k:d~>e),
    ((k << h) << g) << f = k << (h << g) << f.
Proof.
  intros; repeat rewrite -> assoc; reflexivity.
Qed.

Lemma juggle3 :
  forall `{_:Category}`(f:a~>b)`(g:b~>c)`(h:c~>d)`(k:d~>e),
    (k << h) << (g << f) = k << (h << g) << f.
Proof.
  intros; repeat rewrite -> assoc; reflexivity.
Qed.

(****************** Remark 3.2 ******************)
Definition dom `(C: Category) (a b: Ob) (_ : a ~> b)
  := a.

Definition cod `(C: Category) (a b: Ob) (_ : a ~> b)
  := b.

(****************** Example 3.3 ******************)
Instance catSet : Category :=
  {
    Ob   := Type;
    hom  := fun a b => a -> b;
    id   := fun a x => x;
    comp := fun a b c (f: a -> b) (g: b -> c) x => g (f x)
  }.
Proof.
  trivial.
  trivial.
  trivial.
Defined.

Inductive EmptyMor : Type := .
Class IdentityMor (A: Type) : Type :=
  {
    im_f := fun x: A => x
  }.

(*** =============== The Duality Principle =============== ***)

(****************** Definition 3.5 ******************)
Definition dual `(C: Category) : Category.
Proof.
  apply (Build_Category)
  with (Ob := Ob)
       (hom := (fun a b => b ~> a))
       (id := id)
       (comp := fun a b c f g => comp c b a g f).
  - symmetry; apply assoc.
  - intros; apply id_r.
  - intros; apply id_l.
Defined.

(****************** Remark 3.7 ******************)
Lemma double_dual : forall `(C: Category), (dual (dual C)) = C.
Proof.
  Admitted.

(* TODO: How can we formalize the duality principle? *)

(*** =============== Isomorphism =============== ***)

(****************** Definition 3.8 ******************)
Class Inversion `{C: Category} `(f: a~>b) g : Prop :=
  {
    inv_comp1 : g << f = id a;
    inv_comp2 : f << g = id b
  }.

Class Isomorphism `{C: Category} `(f: a ~> b) : Prop :=
  {
    iso_comp1: exists g, Inversion f g
  }.

(****************** Proposition 3.10 ******************)
Theorem morph_equal :
  forall `(_: Category) `(f: a ~> b) (g h: b ~> a),
    g << f = id a -> f << h = id b -> g = h.
Proof.
  intros C a b f g h Hfg Hhf.
  rewrite <- id_r.
  rewrite <- Hfg.
  rewrite <- assoc.
  rewrite -> Hhf.
  rewrite -> id_l.
  reflexivity.
Qed.

(****************** Corollary 3.11 ******************)
Theorem inv_unique :
  forall `(_: Category) `(f: a ~> b) g h,
    Inversion f g -> Inversion f h -> g = h.
Proof.
  intros C a b f g h Hgf Hhf.
  apply (morph_equal _ f).
  - destruct Hgf; assumption.
  - destruct Hhf; assumption.
Qed.

(****************** Proposition 3.14 ******************)
Lemma inv_symm :
  forall `(_: Category) `(f: a ~> b) g,
    Inversion f g -> Inversion g f.
Proof.
  intros C a b f g Hfg.
  apply Build_Inversion; destruct Hfg; assumption.
Qed.

Lemma double_inv :
  forall `(_: Category) `(f: a ~> b) g h,
    Inversion f g -> Inversion g h -> f = h.
Proof.
  intros C a b f g h Hfg Hgh.
  apply (morph_equal _ g).
  - destruct Hfg; assumption.
  - destruct Hgh; assumption.
Qed.

Theorem iso_inv :
  forall `(_: Category) `(f: a ~> b) g,
    Isomorphism f -> Inversion f g -> Isomorphism g.
Proof.
  intros C a b f g Hf Hfg.
  apply Build_Isomorphism.
  exists f.
  apply inv_symm; assumption.
Qed.

Theorem inv_comp :
  forall `(_: Category) `(f: a ~> b) `(g: b ~> c) f' g',
    Inversion f f' ->
    Inversion g g' ->
    Inversion (g << f) (f' << g').
Proof.
  intros C a b f c g f' g' Hf Hg.
  destruct Hf; destruct Hg.
  apply Build_Inversion.
  - rewrite -> juggle3; rewrite -> inv_comp5.
    rewrite -> id_l; assumption.
  - rewrite -> juggle3; rewrite -> inv_comp4.
    rewrite -> id_l; assumption.
Qed.

Theorem iso_comp :
  forall `(_: Category) `(f: a ~> b) `(g: b ~> c),
    Isomorphism f -> Isomorphism g -> Isomorphism (g << f).
Proof.
  intros C a b f c g Hf Hg.
  apply Build_Isomorphism.
  destruct Hf as [comp_f]; destruct Hg as [comp_g].
  destruct comp_f; destruct comp_g.
  exists (x << x0).
  apply inv_comp; assumption.
Qed.

(****************** Definition 3.15 ******************)
Class Isomorphic `{c: Category} (a b: Ob) : Prop :=
  {
    iso_ex : exists f: a ~> b, Isomorphism f
  }.


(*|
############################################################################
Coq ``leb`` (``<=?``) does not give me an hypothesis after case or induction
############################################################################

:Link: https://stackoverflow.com/q/66709518
|*)

(*|
Question
********

I have simplified my situation to the following piece of code,
hopefully this makes it easier to understand.

I would like to prove the following Lemma:
|*)

Require Import Arith.
Lemma example: forall a b,
    if a <=? b then a <= b else a > b.

(*| Doing the following step in the proof |*)

Proof.
  intros.

(*| Gives me the result |*)

  Show. (* .unfold .messages *)

(*|
It seems trivial that either ``a`` is smaller than or equal to ``b``,
in which case I could prove ``a<=b``. In the other case that ``b`` is
larger than ``a`` I could prove that ``a>b``.

I've tried to prove this with ``induction (a <=? b)`` or ``case (a <=?
b)`` but both give me the following result.
|*)

  induction (a <=? b). (* .unfold *)
Abort. (* .none *)

(*|
Now I have no way to prove these goals. I expected to gain an
hypothesis such as ``H: a <= b`` and ``H: a > b`` in the second case.
This way, I would be able to prove my goals.

Could anybody tell me how I could this issue of the non-appearing
hypothesis?

Edit: The whole lemma can be proven as follows:
|*)

Require Import Arith.
Lemma example: forall a b,
    if a <=? b then a <= b else a > b.
Proof.
  intros.
  case (Nat.leb_spec a b); intuition.
Qed.

(*|
Answer
******

To do the case distinction that you are looking for you can use
|*)

Lemma leb_spec x y : BoolSpec (x <= y) (y < x) (x <=? y).

(*|
The type ``BoolSpec`` embodies exactly what you are trying to do: if
``(x <=? y)`` is *the boolean* ``true``, then *the proposition* ``x <=
y`` is true, and if ``(x <=? y)`` is ``false`` then ``y < x`` is true.
Thus, ``Nat.leb_spec`` embodies the specification of the function ``x
<=? y``, as its name suggests.

Now using ``case (Nat.leb_spec a b)`` does exactly what you were
trying to do with ``case (a <=? b)``: it gives you two subgoals, one
where ``x <=? y`` is replaced by ``true`` and you have ``x <= y`` as
an extra hypothesis, and the other where ``x <=? y`` is replaced by
``false`` and you have ``y < x`` as an hypothesis instead. The fact
that you case distinction was on a term of type ``BoolSpec`` rather
than simply ``bool`` did the trick.
|*)


From Coq Require Import List.
From StructTact Require Import StructTactics ListTactics.
Import ListNotations.

Fixpoint before_all {A : Type} (x : A) y l : Prop :=
  match l with
    | [] => True
    | a :: l' =>
      ~ In x l' \/
      (y <> a /\ before_all x y l')
  end.

Section before_all.
  Variable A : Type.

  Lemma before_all_head_not_in :
    forall l (x y : A),
      x <> y ->
      before_all x y (y :: l) ->
      ~ In x l.
  Proof using.
    intros.
    simpl in *.
    break_or_hyp; auto.
    break_and. auto.
  Qed.

  Lemma before_all_neq_append :
  forall l (x y a : A),
    a <> x ->
    before_all x y l ->
    before_all x y (l ++ [a]).
  Proof using.
  induction l.
  - intros; left; auto.
  - intros;
    simpl in *.
    break_or_hyp.
    * left.
      intro H_in.
      do_in_app.
      break_or_hyp; auto.
      simpl in *.
      break_or_hyp; auto.
    * break_and.
      right.
      split; auto.
  Qed.

  Lemma before_all_not_in_1 :
    forall l (x y : A),
      ~ In x l ->
      before_all x y l.
  Proof using.
    intros.
    destruct l; simpl in *; auto.
  Qed.

  Lemma before_all_not_in_2 :
    forall l (x y : A),
      ~ In y l ->
      before_all x y l.
  Proof using.
    induction l.
    - intros. simpl in *. auto.
    - intros. simpl in *.
      assert (H_neq: y <> a); auto.
      assert (H_in: ~ In y l); auto.
   Qed.
End before_all.


Inductive listn : nat -> Set :=
  | niln : listn 0
  | consn : forall n : nat, nat -> listn n -> listn (S n).

Definition length1 (n : nat) (l : listn n) :=
  match l with
  | consn n _ (consn m _ _) => S (S m)
  | consn n _ _ => 1
  | _ => 0
  end.

Fail Type
  (fun (n : nat) (l : listn n) =>
   match n return nat with
   | O => 0
   | S n => match l return nat with
            | niln => 1
            | l' => length1 (S n) l'
            end
   end).


Require Export HRwgt.
Require Export Setoid.

Module mHRwspec (N:Num_w).

Import N.
Module Export GG := mHRwgt(N).

Lemma Padd : forall x y, P x -> P y -> P (x + y).
unfold P; intros x y Hx Hy.
elim Hx; intros nx Hnx.
elim Hy; intros ny Hny.
exists (nx+ny).
split.
eapply ANS2a.
intuition.
intuition.
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; solve [intuition].
eapply le_trans.
eapply abs_triang.
rewrite mult_comm.
setoid_replace (w * (nx+ny) ) with (w*nx + w*ny) by ring.
apply le_plus.
rewrite mult_comm.
intuition.
rewrite mult_comm.
intuition.
Qed.

Definition HRwplus (x y: HRw) : HRw :=
match x with exist _ xx Hxx =>
match y with exist _ yy Hyy =>
exist P (xx + yy) (Padd xx yy Hxx Hyy)
end end.

(* using the property that 0=1-1 and ANSx axioms *)
Lemma lim0 : lim 0.
Proof.
intros.
setoid_replace 0 with (plusA 1 (oppA 1)) by ring.
apply ANS2a.
apply ANS1.
apply ANS4.
exists 1.
split.
apply ANS1.
rewrite abs_neg_val.
setoid_replace (- - (1)) with 1 by ring.
rewrite abs_pos_val.
apply le_refl.
apply lt_le.
apply lt_0_1.
apply le_plus_inv with (z:=1).
setoid_replace (- (1) + 1) with 0 by ring.
setoid_replace (0+1) with 1 by ring.
apply lt_le.
apply lt_0_1.
Qed.

Lemma Popp : forall x, P x -> P (- x).
Proof.
unfold P; intros x Hx.
elim Hx; clear Hx; intros nx (Hlimx, (Hle0nx, Hnxw)).
exists nx.
split.
solve [auto].
split.
solve [auto].
apply le_trans with (|x|).
rewrite abs_minus.
apply le_refl.
assumption.
Qed.

Definition HRwopp (x: HRw) : HRw :=
match x with exist _ xx Hxx =>
exist P (- xx) (Popp xx Hxx)
end.

Definition HRwminus (x y : HRw) : HRw := HRwplus x (HRwopp y).

Lemma Pprod : forall x y, P x -> P y -> P (( x * y) / w).
Proof.
unfold P; intros x y Hx Hy.
elim Hx; intros nx Hnx.
elim Hy; intros ny Hny.
exists (nx * (ny+1)).
split.
apply ANS2b.
intuition.
apply ANS2a; solve [intuition| apply ANS1].
split.
apply mult_pos.
solve [intuition].
setoid_replace 0 with (0+0) by ring.
apply lt_plus.
solve [intuition].
apply lt_0_1.
rewrite <- (div_idg ( nx * (ny+1) * w) w).
(* branches here *)
apply le_mult_inv with w.
apply Aw.
rewrite <- (abs_pos_val w) at 1.
rewrite <- abs_prod.
rewrite div_mod2.
rewrite div_idg.
apply le_trans with (|x * y| + | - (x * y %% w) |).
apply abs_triang.
setoid_replace (w* (nx * (ny+1) * w)) with ((w* (nx * ny * w))+w*w*nx) by ring.
apply le_plus.
setoid_replace (w * (nx * ny * w)) with ((nx*w)*(ny*w)) by ring.
rewrite abs_prod.
apply mult_le.
apply abs_pos.
intuition.
apply abs_pos.
intuition.

apply le_trans with w.
rewrite abs_minus.
apply lt_le; apply div_mod3.
apply Aw.
setoid_replace w with (w*1) at 1 by ring.
rewrite <- mult_assoc.
apply le_mult.
apply lt_le; apply Aw.
setoid_replace 1 with (0+1) by ring.
apply lt_le_2.
apply mult_pos.
apply Aw.
solve [intuition].
apply Aw.
left; apply Aw.
apply lt_le; apply Aw.
apply Aw.
Qed.

Definition HRwmult (x y: HRw) : HRw :=
match x with exist _ xx Hxx =>
match y with exist _ yy Hyy =>
exist P ((xx * yy) / w) (Pprod xx yy Hxx Hyy)
end end.

Definition HRwdiff (x y : HRw) : Prop := x [>] y \/ y [>] x.

Lemma HRwdiff0_diff0_spec_or : forall a : A, forall Ha : P a,
  HRwdiff (exist (fun x : A => P x) a Ha) HRw0 ->  0<a\/a<0.
Proof.
intros; unfold HRwdiff in H; destruct H.
unfold HRw0, HRwgt in H.
left.
destruct H.
destruct H as [H1 [H2 H3]].
ring_simplify in H3.
apply lt_mult_inv with x.
assumption.
apply lt_le_trans with w.
ring_simplify.
apply Aw.
assumption.
right.
unfold HRw0, HRwgt in H.
destruct H.
destruct H as [H1 [H2 H3]].
ring_simplify in H3.
apply lt_mult_inv2 with (-x).
apply lt_plus_inv with x.
ring_simplify.
assumption.
apply lt_le_trans with w.
ring_simplify.
apply Aw.
assumption.
Qed.

Lemma HRwdiff0_diff0_spec2 : forall x, (exists n:A, lim n /\ 0 < n /\  w <= n*|x|) ->  |x|<>0.
Proof.
intros.
elim H.
intros n (Hlim,(Hlt,Hw)).
intro.
rewrite H0 in *.
eapply (le_lt_False w).
rewrite mult_absorb in *.
eassumption.
apply Aw.
Qed.

Lemma HRwdiff0_diff0_spec : forall x, (exists n:A, lim n /\ 0 < n /\  w <= n*|x|) ->  ~(|x|==0).
Proof.
intros.
elim H.
intros n (Hlim,(Hlt,Hw)).
intro.
rewrite H0 in *.
eapply (le_lt_False w).
rewrite mult_absorb in *.
eassumption.
apply Aw.
Qed.

Lemma Pdiv : forall x ,  HRwdiff x HRw0 -> P ((w * w ) /(proj1_sig x)).
Proof.
intros z Hz.
set (x:=(proj1_sig z)).
assert (Hx:(exists n:A, lim n /\ 0 < n /\  w <= n*|x|)).
unfold x; clear x.
revert Hz; case z.
intros xx Hxx H_HRwdiff.
elim H_HRwdiff.
simpl.
intros.
elim H; intros x (Hlim, (Hlt, Hw)).
setoid_replace (xx + -0) with xx in Hw by ring.
exists x; intuition.
assert (Habs:|xx|==xx).
apply abs_pos_val.
assert (0 <= x* xx).
apply le_trans with (y:=w).
apply lt_le; apply Aw.
assumption.
apply le_mult_inv with (x:=x).
assumption.
setoid_replace (x*0) with 0 by ring.
assumption.
rewrite Habs.
assumption.
simpl.
intros.
elim H; intros x (Hlim, (Hlt, Hw)).
rewrite plus_neutral in Hw.
exists x; intuition.

assert (Habs:|xx|==-xx).
apply abs_neg_val.
assert (0 <= x* -xx).
apply le_trans with (y:=w).
apply lt_le; apply Aw.
assumption.
apply le_mult_inv with (x:=x).
assumption.
setoid_replace (x*0) with 0 by ring.
apply le_plus_inv with (z:=x* -xx).
setoid_replace (x * xx + x * - xx) with 0 by ring.
setoid_replace (0 + x * - xx) with (x* -xx) by ring.
assumption.
rewrite Habs.
assumption.

destruct z; simpl in *; subst x.
unfold P.
assert (0<x0\/x0<0).
apply (HRwdiff0_diff0_spec_or x0 p Hz).
destruct H.

elim Hx; intros n Hn.
exists (n+1).
split.
apply ANS2a; solve [intuition | apply ANS1].
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; solve [intuition | apply lt_0_1].
apply le_mult_inv with x0.
assumption.
rewrite <- (abs_pos_val x0) at 1.
rewrite <- abs_prod.
rewrite div_mod2.
apply le_trans with (| w * w| + | - (w* w %% x0)|).
apply abs_triang.
rewrite (abs_pos_val x0) in Hn.
setoid_replace (x0 * ((n +1) * w)) with (x0 * (n * w) + x0* w) by ring.
apply le_plus.
rewrite abs_prod.
rewrite abs_pos_val.
setoid_replace (x0*(n*w)) with (w * (n*x0)) by ring.
apply le_mult.
apply lt_le; apply Aw.
solve [intuition].
apply lt_le; apply Aw.
apply le_trans with x0.
rewrite abs_minus.
apply lt_le; apply div_mod3.
assumption.
setoid_replace x0 with (x0*1) at 1 by ring.
apply le_mult.
apply lt_le; assumption.
setoid_replace 1 with (0+1) by ring.
apply lt_le_2.
apply Aw.
apply lt_le; assumption.
left; assumption.
apply lt_le; assumption.

elim Hx; intros n Hn.
exists (n+1).
split.
apply ANS2a; solve [intuition | apply ANS1].
split.
setoid_replace 0 with (0+0) by ring; apply lt_plus; solve [intuition | apply lt_0_1].
rewrite abs_neg_val in Hn.
apply le_mult_inv2 with x0.
assumption.
setoid_replace (x0 * (|w * w / x0 |)) with (- ((-x0) * (|w * w / x0 |))) by ring.
rewrite <- (abs_neg_val x0) at 1.
rewrite <- (abs_prod x0).
rewrite div_mod2.
apply le_plus_inv with ((|w * w + - (w * w %% x0) |) + - x0 * ((n + 1) * w)).
ring_simplify; unfold minusA.
apply le_trans with (| w * w| + | - (w* w %% x0)|).
apply abs_triang.
apply le_plus.
rewrite abs_prod.
rewrite abs_pos_val.
setoid_replace (- x0*n*w) with (w * (n* - x0)) by ring.
apply le_mult.
apply lt_le; apply Aw.
solve [intuition].
apply lt_le; apply Aw.
apply le_trans with (-x0).
rewrite abs_minus.
apply le_trans with (|x0|).
apply div_mod3_abs.
right; assumption.
rewrite abs_neg_val.
apply le_refl.
apply lt_le; assumption.
setoid_replace (-x0) with ((-x0)*1) by ring.
setoid_replace (- (x0* w)) with (-x0 * w) by ring.
apply le_mult.
apply le_plus_inv with x0; ring_simplify; apply lt_le; assumption.
setoid_replace 1 with (0+1) by ring.
apply lt_le_2.
apply Aw.
right; assumption.
apply lt_le; assumption.
apply lt_le; assumption.
Qed.

Definition HRwinv (x : HRw) (H: HRwdiff x HRw0) : HRw :=
exist P ((w * w ) / (proj1_sig x)) (Pdiv x H).

Notation "x [+] y " := (HRwplus  x y) (at level 40).
Notation "x [*] y " := (HRwmult  x y)(at level 35).

Notation "[0]" := HRw0.
Notation "[1]" := HRw1.

Notation "-w x" := (HRwopp x) (at level 30).
Notation "x [=] y" := (HRwequal x y) (at level 80).

(* example :
Lemma f: forall x y z, x +w -w y *w z [=] x +w (y *w z).
*)

Definition HRw2 : HRw := [1] [+] [1].
Notation "[2]" := HRw2.
Definition HRw3 : HRw := [2] [+] [1].
Notation "[3]" := HRw3.
End mHRwspec.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type :=   Zero : natural | Succ : natural -> natural .

Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - rewrite plus_zero. reflexivity.
   - simpl. rewrite plus_succ. rewrite IHx. reflexivity.
Qed.

Lemma plus_qmult : forall (x y z a : natural), plus (qmult x y z) a = qmult x y (plus z a).
Proof.
   intro.
   induction x.
   - reflexivity.
   - intros. simpl. rewrite IHx. rewrite plus_assoc. lfind. Admitted.


Module Demo.
  Inductive ex {X: Type} (p: X -> Prop) : Prop := E (x:X) (a: p x).

  (* X implicit for ex and E *)

  Definition match_ex {X: Type} (p: X -> Prop) (Z: Prop)
    : ex p -> (forall x, p x -> Z) -> Z
    := fun a e => match a with E _ x b => e x b end.

  Lemma deMorgan X (p: X -> Prop) :
    ~ ex (fun x => p x) <-> forall x, ~ p x.
  Proof.
    split.
    - intros f x a.
      apply f.
      exact (E p x a).   (* note eta conversion *)
    - intros f a.
      apply (match_ex p False a).
      exact f.
    Show Proof.
  Qed.
End Demo.

Locate "exists".
Print ex.

Lemma deMorgan X (p: X -> Prop) :
  ~ (exists x, p x) <-> forall x, ~ p x.
Proof.
  split.
  - intros f x a. apply f. exists x. exact a.
  - intros f [x a]. exact (f x a).
    Show Proof.
Qed.

Goal forall X (p: X -> Prop),
    ~ (exists x, p x) <-> forall x, ~ p x.
Proof.
  refine (fun X p => conj (fun f x a => _) (fun f b => _)).
  - refine (f (ex_intro p x a)).
  - refine (match b with ex_intro _ x a => f x a end).
  Show Proof.
Qed.

Theorem Barber X (p: X -> X -> Prop) :
  ~ (exists x, forall y, p x y <-> ~ p y y).
Proof.
  intros [x H]. specialize (H x). tauto.
Qed.

(** Lawvere *)

Fact negb_no_fp :
  ~ exists x, negb x = x.
Proof.
  intros [[|] H]; discriminate.
Qed.

Fact not_no_fp :
  ~ exists P: Prop, (~P) = P.
Proof.
  intros [P H].
  enough (H1: ~(P <-> P)).
  - tauto.
  -  pattern P at 2. rewrite <-H. tauto.
Qed.

Definition surjective {X Y} (f: X -> Y) :=
  forall y, exists x, f x = y.

Theorem Lawvere X Y (f: X -> X -> Y) (g: Y -> Y) :
  surjective f -> exists y, g y = y.
Proof.
  intros H.
  specialize (H (fun x => g (f x x))) as [x H].
  apply (f_equal (fun f => f x)) in H.
  exists (f x x).
  easy.
Qed.

Corollary Lawvere_bool X :
  ~ exists f: X -> X -> bool, surjective f.
Proof.
  intros [f H].
  apply negb_no_fp.
  revert H. apply Lawvere.
Qed.

Corollary Lawvere_Prop X :
  ~ exists f: X -> X -> Prop, surjective f.
Proof.
  intros [f H].
  apply not_no_fp.
  revert H. apply Lawvere.
Qed.

(** Exercise: Equational proof of not_no_fp, tricky *)

Corollary not_no_fp' X :
  (~X) <> X.
Proof.
  intros H.
  pose (id:= fun a: False => a).
  enough (exists a, id a = a) as [[] _].
  enough (exists f: X -> X -> False, surjective f) as [f H1].
  - revert H1. apply Lawvere.
  - pattern (X -> False). rewrite H.
    exists (fun x => x). intros x. exists x. reflexivity.
Qed.


From Coq Require Import ZArith Znumtheory Lia Psatz List Bool.
From Coqtail Require Import Ztools Zeqm Zlittle_fermat Zpow Zprime.

(** This file defines the Rabin Miller primality test, first as a
theorem, then as a boolean function.

We prove it is sound, in that it returns true when p is prime.

We prove it is complete below some bounds with sufficient sets of
witnesses:

- below 2048 for the set {2}
- below 10000 for the set {2,3}
- below 1373653 for the set {2,3}

The last item can be checked but it takes a lot of time. Without
parallelism, it is even worse, and enabling parallelism for all files
makes compiling most other files more slowly, so we removed this
exhaustive check.
*)

Theorem square_roots_of_unity (x p : Z) :
  prime p ->
  x ^ 2 ≡ 1 [p] ->
  x ≡ 1 [p] \/ x ≡ -1 [p].
Proof.
  intros pp.
  rewrite !eqm_divide.
  replace (x ^ 2 - 1) with ((x - 1) * (x + 1)) by lia.
  now intros H % prime_mult.
  all: apply prime_not_0, pp.
Qed.

Lemma miller_rabin_step (p a r d : Z) :
  prime p ->
  0 <= d ->
  0 <= r ->
  a ^ (2 ^ (r + 1) * d) ≡ 1 [p] ->
  a ^ (2 ^ r * d) ≡ 1 [p] \/
  a ^ (2 ^ r * d) ≡ - 1 [p].
Proof.
  intros pp Hd Hr H.
  apply square_roots_of_unity; auto.
  rewrite eqm_divide in *; try apply prime_not_0, pp.
  enough ((a ^ (2 ^ r * d)) ^ 2 = a ^ (2 ^ (r + 1) * d)) by congruence.
  assert (2 ^ (r + 1) * d = (2 ^ r * d) * 2) as ->
      by now rewrite Z.pow_add_r; lia || auto.
  rewrite (Z.pow_mul_r _ _ 2). easy.
  pose proof Z.pow_nonneg 2 r ltac:(lia). lia. lia.
Qed.

Lemma miller_rabin_step' (p a r d : Z) :
  prime p ->
  0 <= d ->
  1 <= r ->
  a ^ (2 ^ r * d) ≡ 1 [p] ->
  a ^ (2 ^ (r - 1) * d) ≡ 1 [p] \/
  a ^ (2 ^ (r - 1) * d) ≡ - 1 [p].
Proof.
  intros pp d0 r1 e.
  apply miller_rabin_step; auto; try lia.
  exact_eq e. do 4 f_equal. lia.
Qed.

Lemma factoring_out_prime p x :
  prime p -> 0 < x -> exists k y, x = p ^ k * y /\ ~(p | y) /\ 0 <= k.
Proof.
  intros pp xz. generalize xz.
  refine (Z_lt_induction
            (fun x => 0 < x -> exists k y : Z, x = p ^ k * y /\ ~ (p | y) /\ 0 <= k)
            _ x ltac:(lia)).
  clear x xz; intros x IHx xz.
  destruct (Zdivide_dec p x) as [ px | ? ].
  2:{ exists 0, x. split. rewrite Z.pow_0_r. lia. split. auto. lia. }
  pose proof prime_ge_2 p pp as p3.
  assert (0 < x / p). {
    apply Z.div_str_pos. split. lia.
    eapply Z.divide_pos_le; eauto.
  }
  destruct (IHx (x / p)) as (k & y & e & py & kz).
  - split. apply Z.div_pos; lia. apply Z.div_lt; lia.
  - auto.
  - exists (1 + k), y. split; auto.
    assert (k < 0 \/ 0 <= k) as [|] by lia.
    + rewrite Z.pow_neg_r in e; auto. lia.
    + rewrite Z.pow_add_r; try lia.
      rewrite <-Z.mul_assoc, <-e.
      replace (p ^ 1) with p by lia.
      apply Z_div_exact_2. lia.
      apply Zdivide_mod, px.
    + split; auto. lia.
Qed.

Lemma factoring_out_prime_at_least_once p x :
  prime p -> 0 < x -> (p | x) -> exists k y, x = p ^ k * y /\ ~(p | y) /\ 1 <= k.
Proof.
  intros pp xz px.
  destruct (factoring_out_prime p x pp xz) as (k & y & -> & py & kz).
  exists k, y; intuition.
  enough (k <> 0) by lia.
  intros ->.
  apply py. exact_eq px. f_equal.
  lia.
Qed.

Lemma Even_div x : Z.Even x <-> (2 | x).
Proof.
  split; intros [k]; exists k; lia.
Qed.

Lemma Odd_div x : Z.Odd x <-> ~(2 | x).
Proof.
  split.
  - intros [k ->] [l e]. lia.
  - intros d. destruct (Z.Even_or_Odd x) as [ [k ->] | ]; auto.
    destruct d. exists k; lia.
Qed.

Lemma Even_not_Odd x : Z.Even x <-> ~Z.Odd x.
Proof.
  rewrite Even_div, Odd_div.
  destruct (Zdivide_dec 2 x); tauto.
Qed.

Lemma Odd_not_Even x : Z.Odd x <-> ~Z.Even x.
Proof.
  rewrite Even_div, Odd_div.
  destruct (Zdivide_dec 2 x); tauto.
Qed.

Theorem miller_rabin_criterion (p : Z) :
  p > 2 ->
  prime p ->
  exists s d : Z,
    0 < s /\
    0 < d /\
    Z.Odd d /\
    p - 1 = 2 ^ s * d /\
    forall a,
      0 < a < p ->
      a ^ d ≡ 1 [p] \/
      exists r, 0 <= r < s /\ a ^ (2 ^ r * d) ≡ -1 [p].
Proof.
  intros p3 pp.
  pose proof primes_are_often_odd p ltac:(lia) pp as op.
  destruct (factoring_out_prime_at_least_once 2 (p - 1))
    as (s & d & psd & d2 & s1).
  - apply prime_2.
  - lia.
  - destruct op as (k & ->). exists k. lia.
  - assert (0 < d). {
      enough (~d = 0 /\ ~d < 0) by lia. split; intros d0.
      - apply d2. exists 0. lia.
      - enough (2 ^ s * d < 0) by lia. apply Z.mul_pos_neg. 2:lia.
        apply Z.pow_pos_nonneg; lia.
    }
    exists s, d. repeat split; try lia.
    + apply Odd_div, d2.
    + intros a zap.
      pose proof Fermat's_little_theorem_Z_pZ p a pp zap as f.
      rewrite psd in f. clear psd.
      apply eqm_divide in f; try now apply prime_not_0.
      change (a ^ (2 ^ s * d) ≡ 1 [p]) in f.
      (* main recurrence *)
      assert (s0 : 0 <= s) by lia.
      revert s s0 s1 f.
      match goal with
        |- forall s, 0 <= s -> ?G =>
        apply (Z.right_induction (fun s => G))
      end.
      intros ? ? ->; tauto.
      lia.
      intros s s0 IHs s0_ asp.
      apply miller_rabin_step in asp; lia || auto.
      destruct asp as [e | e].
      * destruct (Z.eq_dec s 0) as [-> | s1].
        -- left. exact_eq e. repeat f_equal. lia.
        -- destruct (IHs ltac:(lia) e) as [ ? | (r & lr & E)]; auto.
           right. exists r. split; lia || auto.
      * right. exists s. split; lia || auto.
Qed.

(* There will be pseudoprimes for many sets of [a]. The deterministic
 variant, of running time ~O(log^4), uses the bound 2ln(p) which
 relies on the generalized Riemann hypothesis. Maybe more useful would
 be to prove that the set {2,3,5,7,11} suffices for p<=10^14. *)

(* First step to implement the primality test: remove the null bits *)

Fixpoint remove_twos (x : positive) : (nat * positive) :=
  match x with
  | xO p => let (k, d) := remove_twos p in (S k, d)
  | _ => (O, x)
  end.

Lemma Odd_xI x : Z.Odd (Z.pos x~1).
Proof.
  exists (Z.pos x). auto.
Qed.

Lemma remove_twos_spec x k d :
  remove_twos x = (k, d) <->
  Zpos x = 2 ^ (Z.of_nat k) * Zpos d /\ Z.Odd (Zpos d).
Proof.
  revert k d; induction x; intros k d; split.
  - intros [=<-<-]. simpl; split; auto. apply Odd_xI.
  - intros [e _]. simpl.
    assert (k = O) as ->. {
      destruct k. easy. exfalso.
      eapply Odd_not_Even. eapply (Odd_xI x).
      rewrite e. rewrite <-Zpower_nat_Z. exists (Zpower_nat 2 k * Z.pos d).
      change (Zpower_nat 2 (S k)) with (2 * Zpower_nat 2 k).
      lia.
    }
    change (2 ^ Z.of_nat 0) with 1 in e.
    f_equal. lia.
  - simpl. destruct (remove_twos x) as (k_, d_).
    intros [=<-->]. rename k_ into k.
    specialize (IHx k d). apply proj1 in IHx. spec IHx by auto.
    destruct IHx as [e od]. split; auto.
    rewrite <-Zpower_nat_Z in *.
    change (Zpower_nat 2 (S k)) with (2 * Zpower_nat 2 k).
    lia.
  - simpl. destruct (remove_twos x) as (k_, d_).
    specialize (IHx k_ d_). apply proj1 in IHx.
    destruct IHx as [ex hd_]; auto.
    change (Z.pos x~0) with (2 * Z.pos x).
    rewrite ex.
    intros [ex' hd].
    assert (k <= k_ \/ k > S k_ \/ k = S k_)%nat as [lk | [lk | ->]] by lia.
    + enough (Z.Even (Z.pos d)) by now apply Odd_not_Even in hd.
      exists (2 ^ Z.of_nat (k_ - k) * Z.pos d_).
      rewrite <-(Z.mul_cancel_l _ _ (2 ^ Z.of_nat k)). 2:lia.
      rewrite <-ex'. replace k_ with (k + (k_ - k))%nat at 1 by lia.
      rewrite <-!Zpower_nat_Z, Zpower_nat_is_exp. lia.
    + enough (Z.Even (Z.pos d_)) by now apply Odd_not_Even in hd_.
      exists (2 ^ Z.of_nat (k - k_ - 2) * Z.pos d).
      rewrite <-(Z.mul_cancel_l _ _ (2 * 2 ^ Z.of_nat k_)). 2:lia.
      rewrite <-!Zpower_nat_Z in *.
      transitivity (Zpower_nat 2 k_ * Zpower_nat 2 (k - k_ - 2) * 4 * Z.pos d).
      2: lia.
      change 4 with (Zpower_nat 2 2).
      rewrite Z.mul_assoc in ex'. rewrite ex'.
      rewrite <-2Zpower_nat_is_exp.
      repeat f_equal. lia.
    + enough (d_ = d) by congruence.
      rewrite <-!Zpower_nat_Z in *.
      change (Zpower_nat 2 (S k_)) with (2 * Zpower_nat 2 k_) in ex'.
      enough (Z.pos d_ = Z.pos d) by congruence.
      rewrite <-(Z.mul_cancel_l _ _ (2 * Zpower_nat 2 k_)). lia. lia.
  - simpl. intros [=<-<-]. intuition. exists 0; lia.
  - intros (ek, od).
    assert (k = O). {
      destruct k; auto.
      pose proof Z.pow_le_mono_r 2 1 (Z.of_nat (S k)) ltac:(lia) ltac:(lia).
      nia.
    }
    simpl. subst. f_equal.
    enough (Z.pos d = 1) by congruence.
    auto.
Qed.

Definition eqmb (m a b : Z) : bool := a mod m =? b mod m.

Lemma eqmb_true_iff m a b : eqmb m a b = true <-> a ≡ b [m].
Proof.
  apply Z.eqb_eq.
Qed.

Import ListNotations.

Definition miller_rabin (l : list Z) (n : Z) : bool :=
  if n <? 2 then false else
    if n =? 2 then true else
      Z.odd n &&
      let (s, d) := remove_twos (Z.to_pos (n - 1)) in
      forallb
        (fun a =>
           implb
             ((0 <? a) && (a <? n))
             ((pow_mod n a (Zpos d) =? 1)
                  || existsb
                      (fun r => pow_mod n a (2 ^ r * Zpos d) =? n - 1)
                      (Zseq 0 s))) l.

Lemma pow_mod_help m a b : 1 < m -> (pow_mod m a b =? 1) = (eqmb m (a ^ b) 1).
Proof.
  intros hm.
  rewrite pow_mod_spec. unfold eqmb.
  f_equal.
  rewrite Zmod_1_l; auto.
Qed.

Lemma Zmod_m1_l a : 0 < a -> (-1) mod a = a - 1.
Proof.
  intros ha.
  destruct (Z.eq_dec a 1) as [-> | a1]. reflexivity.
  transitivity ((a - 1) mod a).
  - rewrite Zminus_mod, Z_mod_same, Zmod_1_l. reflexivity. lia. lia.
  - apply Z.mod_small. lia.
Qed.

Lemma pow_mod_help' m a b : 0 < m -> (pow_mod m a b =? m - 1) = (eqmb m (a ^ b) (- 1)).
Proof.
  intros hm.
  rewrite pow_mod_spec. unfold eqmb.
  f_equal.
  rewrite Zmod_m1_l; auto.
Qed.

Lemma miller_rabin_sound l n : miller_rabin l n = false -> ~prime n.
Proof.
  intros c pn.
  enough (miller_rabin l n = true) by congruence; clear c.
  unfold miller_rabin.

  destruct (n <? 2) eqn:n1.
  { apply Z.ltb_lt in n1. apply prime_ge_2 in pn. lia. }

  destruct (n =? 2) eqn:n2; auto.
  apply Z.eqb_neq in n2. apply Z.ltb_ge in n1.
  assert (bn : n > 2) by lia. clear n1 n2.

  rewrite andb_true_iff, Z.odd_spec.
  split. apply primes_are_often_odd; auto; lia.

  apply miller_rabin_criterion in pn; auto.
  destruct pn as (s & d & zs & zd & od & e & crit).

  destruct (remove_twos _) as (s_, d_) eqn:esd.
  assert (e' : remove_twos (Z.to_pos (n - 1)) = (Z.to_nat s, Z.to_pos d)).
  {
    apply remove_twos_spec; split.
    - exact_eq e; repeat f_equal.
      + rewrite Z2Pos.id; lia.
      + rewrite Z2Nat.id; lia.
      + rewrite Z2Pos.id; lia.
    - exact_eq od; f_equal.
      rewrite Z2Pos.id; lia.
  }
  rewrite esd in e'. injection e' as -> ->.
  rewrite Z2Pos.id; auto.

  rewrite forallb_forall.
  intros a al.
  destruct (_ <? _) eqn:za. apply Z.ltb_lt in za. 2:reflexivity.
  destruct (_ <? _) eqn:an. apply Z.ltb_lt in an. 2:reflexivity.
  specialize (crit a ltac:(lia)).
  change (implb (true && true) ?b) with b.
  rewrite pow_mod_help; try lia.
  rewrite orb_true_iff, existsb_exists, eqmb_true_iff.
  destruct crit as [?|(r & rs & er)]. now left.
  right. exists r.
  rewrite pow_mod_help'; try lia.
  rewrite eqmb_true_iff, in_Zseq.
  split. lia. exact_eq er; repeat f_equal.
Qed.

Lemma miller_rabin_more_tests l l' :
  (forall x, In x l -> In x l') -> forall n, implb (miller_rabin l' n) (miller_rabin l n) = true.
Proof.
  intros s n.
  unfold miller_rabin in *.
  destruct (_ <? _). reflexivity.
  destruct (_ =? _). reflexivity.
  destruct (Z.odd _). 2: reflexivity.
  destruct (remove_twos _).
  rewrite 2andb_true_l.
  assert (a : forall a b, (a = true -> b = true) -> implb a b = true)
    by now intros [|] [|]; try discriminate || tauto. apply a.
  rewrite 2forallb_forall. eauto.
Qed.

(* It is faster to just use "primeb", it seems:

Definition primes (n : Z) := filter primeb (Zseq 1 (Z.to_nat n)).
Definition primesmr l (n : Z) := filter (miller_rabin l) (Zseq 1 (Z.to_nat n)).

Time Eval vm_compute in primes 10000. (* 3s sec *)
Time Eval vm_compute in primesmr [2; 3] 10000. (* 6 sec *)
*)

(** Re-using work to try an accelerate the computation *)

Fixpoint mainloop n s x :=
  match s with
  | O => false
  | S s => (x =? n - 1) || mainloop n s ((x * x) mod n)
  end.

Lemma mainloop_spec n a d s x :
  x = pow_mod n a (Z.pos d) ->
  mainloop n s x =
  existsb
    (fun r => pow_mod n a (2 ^ r * Z.pos d) =? n - 1)
    (Zseq 0 s).
Proof.
  replace (Z.pos d) with (2 ^ 0 * Z.pos d) at 1 by lia.
  generalize (Z.le_refl 0).
  generalize 0 at 2 3 4 as offset.
  revert d x.
  induction s. reflexivity.
  intros d x offset oz ex.
  change (Zseq offset (S s)) with (offset :: Zseq (1 + offset) s).
  change (existsb ?f (?a :: ?l)) with (f a || existsb f l).
  simpl mainloop.
  f_equal. rewrite ex; auto.
  apply IHs. lia.
  replace (x * x) with (x ^ 2) by lia.
  rewrite ex.
  rewrite 2pow_mod_spec.
  rewrite <-Zpow_mod. f_equal.
  rewrite <-!Z.pow_mul_r.
  rewrite Z.pow_add_r.
  f_equal. lia.
  lia.
  lia.
  apply Z.mul_nonneg_nonneg; try lia; try (apply Z.pow_nonneg; lia).
  lia.
Qed.

Definition miller_rabin' (l : list Z) (n : Z) : bool :=
  if n <? 2 then false else
    if n =? 2 then true else
      Z.odd n &&
      let (s, d) := remove_twos (Z.to_pos (n - 1)) in
      forallb
        (fun a =>
           implb
             ((0 <? a) && (a <? n))
             (let x := pow_mod n a (Zpos d) in
              (x =? 1) ||
              mainloop n s x)) l.

Lemma forallb_ext {A} (f g : A -> bool) l :
  (forall a, f a = g a) -> forallb f l = forallb g l.
Proof.
  intros e; induction l; simpl; congruence.
Qed.

Lemma implb_true_l: forall b : bool, implb true b = b. now intros []. Qed.
Lemma implb_true_r: forall b : bool, implb b true = true. now intros []. Qed.
Lemma implb_false_l: forall b : bool, implb false b = true. now intros []. Qed.
Lemma implb_false_r: forall b : bool, implb b false = negb b. now intros []. Qed.

Definition miller_rabin'_spec l n : miller_rabin' l n = miller_rabin l n.
Proof.
  unfold miller_rabin.
  unfold miller_rabin'.
  destruct (n <? 2); auto.
  destruct (n =? 2); auto.
  destruct (Z.odd _); auto.
  rewrite 2 andb_true_l.
  destruct (remove_twos _) as (s, d).
  apply forallb_ext; intros a.
  destruct (_ && _); auto.
  rewrite 2 implb_true_l.
  f_equal.
  now apply mainloop_spec.
Qed.

(* Some benchmarking.

miller_rabin' is a bit faster, but not by much. If primeb (sqrt
algorithm) is still faster on small numbers, it does get surpassed by
the miller_rabin' above about 10000. miller_rabin also gets faster
than primeb only after about 80000.

Time Eval vm_compute in length (filter  primeb                (Zseq 1 (Z.to_nat 10000))). (* 3 secs *)
Time Eval vm_compute in length (filter (miller_rabin  [2; 3]) (Zseq 1 (Z.to_nat 10000))). (* 6 secs *)
Time Eval vm_compute in length (filter (miller_rabin' [2; 3]) (Zseq 1 (Z.to_nat 10000))). (* 4 secs *)

Time Eval vm_compute in length (filter  primeb                (Zseq 1 (Z.to_nat 20000))). (* 10.4 secs *)
Time Eval vm_compute in length (filter (miller_rabin  [2; 3]) (Zseq 1 (Z.to_nat 20000))). (* 21.1 secs *)
Time Eval vm_compute in length (filter (miller_rabin' [2; 3]) (Zseq 1 (Z.to_nat 20000))). (* 10.1 secs *)

Time Eval vm_compute in length (filter  primeb                (Zseq 1 (Z.to_nat 40000))). (* 41.3 secs *)
Time Eval vm_compute in length (filter (miller_rabin  [2; 3]) (Zseq 1 (Z.to_nat 40000))). (* 54.6 secs *)
Time Eval vm_compute in length (filter (miller_rabin' [2; 3]) (Zseq 1 (Z.to_nat 40000))). (* 26.6 secs *)

Time Eval vm_compute in length (filter  primeb                (Zseq 1 (Z.to_nat 80000))). (* 132 sec *)
Time Eval vm_compute in length (filter (miller_rabin  [2; 3]) (Zseq 1 (Z.to_nat 80000))). (* 125 sec *)
Time Eval vm_compute in length (filter (miller_rabin' [2; 3]) (Zseq 1 (Z.to_nat 80000))). (* 68 sec *)

other simple ideas for improvement:
- use positive instead of Z (maybe there is a lot of going back and forth)
- replace "x mod m" with "if x < m then x else x mod m" (seem unlikely)
- use 64 bits integers
*)

(** Checking that Miller-Rabin is sufficient below some bounds *)

Definition MR_at l n := if miller_rabin l n then primeb n else true.
Definition MR_range l a b := forallb (MR_at l) (Zseq a (Z.to_nat (b - a + 1))).

Lemma iff_intro {A} (P Q : A -> Prop) : (forall a, P a <-> Q a) -> (forall a, P a) <-> (forall a, Q a).
Proof.
  firstorder.
Qed.

Lemma iff_intro_Prop (P Q P' Q' : Prop) : (P <-> Q) -> (P -> Q -> (P' <-> Q')) -> ((P -> P') <-> (Q -> Q')).
Proof.
  firstorder.
Qed.

Lemma MR_range_spec l a b : MR_range l a b = true <-> (forall n : Z, a <= n <= b -> miller_rabin l n = primeb n).
Proof.
  unfold MR_range.
  rewrite forallb_forall.
  apply iff_intro; intros x.
  apply iff_intro_Prop. rewrite in_Zseq; lia.
  intros _ bx.
  unfold MR_at in *.
  destruct (miller_rabin l x) eqn:e. split; auto.
  destruct (primeb x) eqn:p; split; auto.
  apply miller_rabin_sound in e.
  now apply primeb_prime in p.
Qed.

Lemma MR_range_empty l a b : a > b -> MR_range l a b = true.
Proof.
  intros ab.
  unfold MR_range.
  replace (Z.to_nat _) with O by lia.
  easy.
Qed.

Lemma MR_range_spec_0 l b : MR_range l 0 b = true -> forall n : Z, n <= b -> miller_rabin l n = primeb n.
Proof.
  intros h n nb.
  pose proof proj1 (MR_range_spec _ _ _) h n as m.
  destruct (n <? 2) eqn:n2.
  - unfold miller_rabin in *. rewrite n2 in *.
    destruct (primeb n) eqn:pn; auto.
    apply Z.ltb_lt in n2. apply primeb_prime, prime_ge_2 in pn. lia.
  - apply Z.ltb_ge in n2. apply m. lia.
Qed.

Lemma MR_range_spec_2 l b : MR_range l 2 b = true -> forall n : Z, n <= b -> miller_rabin l n = primeb n.
Proof.
  intros h n nb.
  pose proof proj1 (MR_range_spec _ _ _) h n as m.
  destruct (n <? 2) eqn:n2.
  - unfold miller_rabin in *. rewrite n2 in *.
    destruct (primeb n) eqn:pn; auto.
    apply Z.ltb_lt in n2. apply primeb_prime, prime_ge_2 in pn. lia.
  - apply Z.ltb_ge in n2. tauto.
Qed.

(** Below 2047, it is enough to check a=2 *)

Lemma miller_rabin_2 n : n <= 2046 -> miller_rabin [2] n = primeb n.
Proof.
  apply MR_range_spec_2.
  vm_compute. (* 0.3 seconds *)
  reflexivity.
Qed.

Lemma first_miller_rabin_2_pseudo_prime :
  miller_rabin [2]    2047 = true /\
  miller_rabin [2; 3] 2047 = false /\
  primeb              2047 = false.
Proof.
  (*now native_compute.*)
  now vm_compute.
Qed.

(** Below 1373653, it is enough to check a=3, but we check for <= 10000 *)

Lemma miller_rabin_2_3 n : n <= 10000 -> miller_rabin [2; 3] n = primeb n.
Proof.
  apply MR_range_spec_2.
  (*Time native_compute.*) (* 1.6 secs *)
  Time vm_compute.
  reflexivity.
Time Qed. (* 1.6 secs *)

Lemma first_miller_rabin_2_3_pseudo_prime :
  miller_rabin [2; 3]    1373653 = true /\
  miller_rabin [2; 3; 5] 1373653 = false /\
  primeb                 1373653 = false.
Proof.
  (*now native_compute.*)
  now vm_compute.
Qed.


From CoqAlgs Require Export Base.

Set Implicit Arguments.

(* Formulas. [not f] will be represented as [fImpl f fFalse] and
   [f1 <-> f2] as [fAnd (fImpl f1 f2) (fImpl f2 f1)]. *)
Inductive formula : Type :=
    | fFalse : formula
    | fTrue : formula
    | fVar : nat -> formula
    | fAnd : formula -> formula -> formula
    | fOr : formula -> formula -> formula
    | fImpl : formula -> formula -> formula.

Fixpoint formulaDenote (env : Env Prop) (f : formula) : Prop :=
match f with
    | fFalse => False
    | fTrue => True
    | fVar i => holds i env
    | fAnd f1 f2 => formulaDenote env f1 /\ formulaDenote env f2
    | fOr f1 f2 => formulaDenote env f1 \/ formulaDenote env f2
    | fImpl f1 f2 => formulaDenote env f1 -> formulaDenote env f2
end.

Function simplifyFormula (f : formula) : formula :=
match f with
    | fFalse => fFalse
    | fTrue => fTrue
    | fVar P => fVar P
    | fAnd f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fOr f11 f12, f2' => fOr (fAnd f11 f2') (fAnd f12 f2')
            | f1', fOr f21 f22 => fOr (fAnd f1' f21) (fAnd f1' f22)
            | fFalse, _ => fFalse
            | _, fFalse => fFalse
            | fTrue, f2' => f2'
            | f1', fTrue => f1'
            | f1', f2' => fAnd f1' f2'
        end
    | fOr f1 f2 =>
        match simplifyFormula f1, simplifyFormula f2 with
            | fAnd f11 f12, f2' => fAnd (fOr f11 f2') (fOr f12 f2')
            | f1', fAnd f21 f22 => fAnd (fOr f1' f21) (fOr f1' f22)
            | fFalse, f2' => f2'
            | f1', fFalse => f1'
            | fTrue, _ => fTrue
            | _, fTrue => fTrue
            | f1', f2' => fOr f1' f2'
        end
    | fImpl f1 f2 =>
        match simplifyFormula f1 with
            | fFalse => fTrue
            | fTrue => f2
            | fAnd f11 f12 => fImpl f11 (fImpl f12 f2)
            | fOr f11 f12 => fAnd (fImpl f11 f2) (fImpl f12 f2)
            | f1' => fImpl f1' f2
        end
end.

Theorem simplifyFormula_correct :
  forall (f : formula) (env : Env Prop),
    formulaDenote env (simplifyFormula f) <-> formulaDenote env f.
Proof.
  intros. functional induction simplifyFormula f; cbn.
  all:
  repeat match goal with
      | e : simplifyFormula ?f = _,
        IH : formulaDenote _ (simplifyFormula ?f) <-> _ |- _ =>
        rewrite <- IH, e; cbn
  end; try (tauto; fail).
Qed.

Definition solveHypothesis (env : Env Prop) :
  forall (proofs : Proofs) (hyp f : formula)
    (cont : forall proofs : Proofs,
      solution (allTrue env proofs -> formulaDenote env f)),
        solution (allTrue env proofs -> formulaDenote env hyp ->
          formulaDenote env f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (hyp f : formula)
      (cont : forall proofs : Proofs,
        solution (allTrue env proofs -> formulaDenote env f)) :
          solution (allTrue env proofs -> formulaDenote env hyp ->
            formulaDenote env f) :=
  match hyp with
      | fFalse => Yes
      | fTrue => Reduce (cont proofs)
      | fVar i => Reduce (cont (i :: proofs))
      | fAnd f1 f2 =>
          Reduce (solve proofs f1 (fImpl f2 f)
                        (fun proofs' => Reduce (cont proofs')))
      | fOr f1 f2 =>
          solve proofs f1 f cont &&&
          solve proofs f2 f cont
      | _ => No
  end).
  all: cbn in *; try tauto.
Defined.

Definition solveGoal (env : Env Prop)
  : forall (proofs : Proofs) (f : formula),
      solution (allTrue env proofs -> formulaDenote env f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (f : formula)
      : solution (allTrue env proofs -> formulaDenote env f) :=
  match f with
      | fFalse => No
      | fTrue => Yes
      | fVar i =>
          match in_dec Nat.eq_dec i proofs with
              | left _ => Yes
              | right _ => No
          end
      | fAnd f1 f2 => solve proofs f1 &&& solve proofs f2
      | fOr f1 f2 => solve proofs f1 ||| solve proofs f2
      | fImpl f1 f2 =>
          solveHypothesis env proofs f1 f2
            (fun proofs' => solve proofs' f2)
  end).
  all: cbn; try tauto.
    intro. apply find_spec with proofs; assumption.
Defined.

Definition solveFormula (env : Env Prop) (f : formula)
  : solution (formulaDenote env f).
Proof.
  refine (Reduce (solveGoal env [] f)). apply f0. cbn. trivial.
Defined.

Theorem solveFormula_correct :
  forall (env : Env Prop) (f : formula),
    (exists p : formulaDenote env f, solveFormula env f = Yes' p) ->
      formulaDenote env f.
Proof.
  intros. destruct H. assumption.
Qed.

Ltac allVarsFormula xs P :=
match P with
    | ~ ?P' => allVarsFormula xs P'
    | ?P1 /\ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVarsFormula xs P2 in allVarsFormula xs' P1
    | _ => addToList P xs
end.

Ltac reifyFormula xs P :=
match P with
    | False => constr:(fFalse)
    | True => constr:(fTrue)
    | ~ ?P' =>
        let e := reifyFormula xs P' in constr:(fImpl e fFalse)
    | ?P1 /\ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fAnd e1 e2)
    | ?P1 \/ ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fOr e1 e2)
    | ?P1 -> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in constr:(fImpl e1 e2)
    | ?P1 <-> ?P2 =>
        let e1 := reifyFormula xs P1 in
        let e2 := reifyFormula xs P2 in
          constr:(fAnd (fImpl e1 e2) (fImpl e2 e1))
    | _ =>
        let i := lookup P xs in constr:(fVar i)
end.

Ltac reflectFormula :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in
          change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct; cbn
end.

Ltac solveGoal' :=
match goal with
    |- ?P =>
        let xs := allVarsFormula constr:(@nil Prop) P in
        let f := reifyFormula xs P in change (formulaDenote xs f);
          rewrite <- simplifyFormula_correct; cbn;
          try apply (unwrap (solveFormula xs (simplifyFormula f)))
end.

Ltac solveGoal := solveGoal'; fail.


Require Import List.
Import ListNotations.

(** Relations **)

(* A relation over a type `A` is a function `A -> A -> Prop` *)
Definition relation (A: Type) : Type := A -> A -> Prop.

Definition equivalent_relations {A: Type} (r1 r2: relation A) :=
  forall x y, r1 x y <-> r2 x y.

Notation "r1 == r2" := (equivalent_relations r1 r2) (at level 30).

Definition compose {A: Type} (r1 r2: relation A): relation A :=
  fun x y => (exists z, r1 x z /\ r2 z y).

Notation "r1 ** r2" := (compose r1 r2) (at level 20).

(* destruct existentials in context *)
Ltac destruct_exists :=
  match goal with
  | H: exists x, _ |- _ => let freshX := fresh x in destruct H as [ freshX ]
  end.

Lemma compose_assoc:
  forall A (r1 r2 r3: relation A),
    r1 ** (r2 ** r3) == (r1 ** r2) ** r3.
Proof.
  intros.
  unfold compose. unfold equivalent_relations. split.
    + intros. destruct H. destruct H. destruct H0. destruct H0. exists x1. split.
      - exists x0. split.
        * apply H.
        * apply H0.
      - apply H1.
    + intros. destruct H. destruct H. destruct H. destruct H. exists x1. split.
      - apply H.
      - exists x0. split.
        * apply H1.
        * apply H0.
Qed.

Fixpoint rel_pow {A: Type} (r: relation A) (n: nat): relation A :=
  match n with
  | 0 => fun a1 a2 => a1 = a2
  | S n => compose r (rel_pow r n)
  end.

Notation "r ^^ n" := (rel_pow r n) (at level 15).

Fixpoint is_path {A: Type} (r: relation A) (x: A) (p: list A) (y: A): Prop :=
  match p with
  | [] => x = y
  | z :: zs => r x z /\ is_path r z zs y
  end.

Lemma path_to_power: forall A (r: relation A) (p: list A) (y x: A),
    is_path r x p y -> (r ^^ (length p)) x y.
Proof.
   induction p.
    + intros. simpl. simpl in H. apply H.
    + simpl. intros. unfold compose. destruct H.  exists a.  split.
      - apply H.
      - pose proof IHp y a. apply H1. apply H0.
Qed.

Lemma is_path_cons:
  forall A (r: relation A) (x y z: A) (p: list A),
    r x y ->
    is_path r y p z ->
    is_path r x (y :: p) z.
Proof.
  intros. simpl. split.
    + apply H.
    + apply H0.
Qed.

Lemma power_to_path:
  forall A (r: relation A) (n: nat) (x y: A),
    (r ^^ n) x y ->
    exists p: list A, is_path r x p y /\ length p = n.
Proof.
  induction n.
    + intros. simpl in H. exists []. simpl. split.
      - apply H.
      - trivial.
    + intros. simpl. unfold compose. intuition. destruct H.
      destruct H. pose proof is_path_cons A r. pose proof IHn x0 y. destruct H2.
      - apply H0.
      - inversion H2. exists (x0::x1). simpl. split.
        * simpl. split.
          ++ apply H.
          ++ apply H3.
        * rewrite H4. trivial.
Qed.

Lemma path_compose:
  forall (A: Type) (r: relation A) (p1 p2: list A) (x y z: A),
    is_path r x p1 y ->
    is_path r y p2 z ->
    is_path r x (p1 ++ p2) z.
Proof.
  induction p1. induction p2.
  - simpl. intros. simpl in H. rewrite H. unfold is_path in H0. rewrite H0. reflexivity.
  - simpl. intros. simpl in H. simpl in H0. rewrite H. apply H0.
  - simpl. intros. simpl in H. destruct H. split.
    + apply H.
    + pose proof IHp1 p2 a y z. apply H2.
      * apply H1.
      * apply H0.
Qed.

Lemma power_compose:
  forall A (r : relation A) (n1 n2: nat),
    (r ^^ n1) ** (r ^^ n2) == r ^^ (n1 + n2).
Proof.
  induction n1.
    + intros. simpl. unfold compose. split.
      * intros. inversion H. destruct H0. rewrite <- H0 in H1. apply H1.
      * intros. exists x. split.
        - trivial.
        - apply H.
    + intros. simpl. unfold equivalent_relations. intros.

        pose proof compose_assoc A r (r^^n1) (r^^n2) as useless1.
        unfold equivalent_relations in useless1.
        pose proof IHn1 n2 as useless2.
        unfold equivalent_relations in useless2.

        pose proof useless1 x y as H1. destruct H1 as (H11, H12).
        split.
        - intros. inversion H. unfold compose in H0; destruct H0. inversion H0. unfold compose. exists x1. split.
          * destruct H2. apply H2.
          * pose proof useless2 x1 y as H3; destruct H3 as (H31, H32). apply H31. unfold compose. exists x0. split.
            ** destruct H2. apply H3.
            ** apply H1.
        - intros. apply H11. unfold compose. inversion H; destruct H0. exists x0. split.
          * apply H0.
          * pose proof useless2 x0 y. destruct H2. apply H3 in H2.
            ** unfold compose in H2. inversion H2. exists x1. apply H4.
            **  apply H3. apply H1.
Qed.

(* `star r` is the reflexive and transitive closure of the relation `R` *)
Definition star { A } (r : relation A): A -> A -> Prop :=
  fun x y => (exists n, (r ^^ n) x y).

(* The reflexive and transitive closure of a relation is reflexive *)
Lemma star_refl:
  forall A (r: relation A) x,
    star r x x.
Proof.
  intros. unfold star. exists 0. simpl. trivial.
Qed.

(* The reflexive and transitive closure of a relation is transitive *)
Lemma star_trans:
  forall A (r : relation A) x y z,
    star r x y ->
    star r y z ->
    star r x z.
Proof.
  unfold star. intros. inversion H. inversion H0. exists (x0+x1). pose proof power_compose.
  pose proof H3 A r x0 x1. unfold equivalent_relations in H4. pose proof H4 x z. destruct H5.
  apply H5. unfold compose. exists y. split.
    * apply H1.
    * apply H2.
Qed.

(* The transitive closure of a relation "contains" the relation *)
Lemma star_step:
  forall A (r: relation A) x y,
    r x y ->
    star r x y.
Proof.
  intros. unfold star. exists 1. simpl. unfold compose. exists y. split.
    + apply H.
    + trivial.
Qed.

Lemma star_1n:
  forall A (r: relation A) x y z,
    r x y ->
    star r y z ->
    star r x z.
Proof.
  intros.
  inversion H0.
  unfold star. exists (S x0). simpl. unfold compose. exists y. split.
    + apply H.
    + apply H1.
Qed.

(** Transition Systems and Reachability **)

(* A transition system with states `Q` and alphabet `A` is a pair with:                *)
(* - An `initial` function of type `Q -> Prop` that says which states are initial      *)
(* - A function `r` of type `Q -> A -> Q -> Prop` such that `r q1 a q2` holds when the *)
(*   transition system has a transition from state `q1` to `q2` labelled by `a`        *)
Record Transition_System (Q A : Type) := new_Transition_System {
  initial : Q -> Prop;
  r : Q -> A -> Q -> Prop
}.

Arguments initial { Q A }.
Arguments r { Q A }.
Arguments new_Transition_System { Q A }.

(* Example *)
Definition ex_Q := nat.
Inductive ex_A := inc (n : nat) | dec (n : nat).

Definition ex_Counter_1 := {|
  initial := fun q => q = 0;
  r := fun q1 a q2 => match a with
               | inc 1 => q2 = q1 + 1
               | dec 1 => q2 = q1 - 1
               | _ => False
               end
  |}.

Definition ex_Counter_n := {|
  initial := fun q => q = 0;
  r := fun q1 a q2 => match a with
               | inc n => q2 = q1 + n
               | dec n => q2 = q1 - n
               end
  |}.

Notation "ts |- q1 ~ a '~>' q2" := (r ts q1 a q2) (at level 20).
Notation "ts |- q1 '~>' q2" := (exists a, ts |- q1 ~a~> q2) (at level 20).
Notation "ts |- q1 '~>*' q2" := (star (fun p q => ts |- p ~> q) q1 q2) (at level 20).
Notation "ts |- q1 '~>^' n q2" := (((fun p q => ts |- p ~> q) ^^ n) q1 q2) (at level 20, n at level 1).

Definition reachable { Q A } (ts : Transition_System Q A) (q: Q) : Prop :=
  exists q_i, initial ts q_i  /\  ts |- q_i ~>* q.

(** Traces of Transition Systems **)

(* A trace an a starting state `start` and sequences of states and labels *)
Record Trace (Q A : Type) := new_Trace {
  start: Q;
  states : list Q;
  labels : list A
}.

Arguments start { Q A }.
Arguments states { Q A }.
Arguments labels { Q A }.
Arguments new_Trace { Q A }.

Definition in_trace { Q A } q (tr : Trace Q A) : Prop :=
  q = start tr \/ In q (states tr).

(* `is_trace_aux ts q0 xs` holds when there are transition in `ts`   *)
(* starting from (not necessarily initial) state `q0`, going through *)
(* the states in `qs` and with labels in `xs`                        *)
Fixpoint is_trace_aux { Q A } (ts : Transition_System Q A)
  (q0 : Q) (qs : list Q) (xs : list A) : Prop :=
  match qs, xs with
  | nil, nil => True
  | q :: qs', x :: xs' => r ts q0 x q /\ is_trace_aux ts q qs' xs'
  | _, _ => False
  end.

(* A `trace` of `ts` starts with an initial state and then has valid transitions *)
Definition is_trace { Q A } (ts: Transition_System Q A) (tr: Trace Q A) : Prop :=
  is_trace_aux ts (start tr) (states tr) (labels tr) /\
  initial ts (start tr).

Lemma is_trace_aux_nil:
  forall Q A (ts : Transition_System Q A) q, is_trace_aux ts q nil nil.
Proof.
  intros.
  unfold is_trace_aux.
  trivial.
Qed.

(* A trace can be extended from the front with another transition *)
Lemma is_trace_aux_cons:
  forall A Q (ts : Transition_System Q A) q1 q2 qs x xs,
    ts |- q1 ~x~> q2 ->
    is_trace_aux ts q2 qs xs ->
    is_trace_aux ts q1 (q2 :: qs) (x :: xs).
Proof.
  induction qs.
    + intros. unfold is_trace_aux. split.
      - apply H.
      - trivial.
    + intros. simpl. split.
      * apply H.
      * trivial.
Qed.

Lemma super_lemma_1 :
  forall A Q (ts : Transition_System Q A) q   (states_l: list Q) (labels_l: list A) (start_s: Q) ,
    is_trace_aux ts start_s states_l labels_l ->
    In q states_l ->
    ts |- start_s ~>* q.
Proof.
   induction states_l.
    + intros. contradiction.
    + intros. destruct labels_l.
      - simpl in H. contradiction.
      - inversion H0.
        * subst. simpl in H. destruct H. unfold star. exists 1. simpl. unfold compose. exists q. split.
          ++ exists a0. apply H.
          ++ reflexivity.
        * unshelve epose proof IHstates_l labels_l a _ H1.
          ++ inversion H. apply H3.
          ++ simpl in H. destruct H. eauto using star_1n .
Qed.

(** Equivalence between reachability and traces **)

(* All the states `q` that appear in the states of a trace are reachable *)
Lemma in_trace_reachable:
  forall A Q (ts : Transition_System Q A) (tr : Trace Q A) q,
    is_trace ts tr ->
    in_trace q tr ->
    reachable ts q.
Proof.
  intros.
  unfold reachable.
  exists (start tr). inversion H. inversion H0; subst.
    + eauto using star_refl.
    + eauto using super_lemma_1.
Qed.

Lemma super_lemma_2:
  forall A Q (ts : Transition_System Q A) q (start_s: Q),
    ts |- start_s ~>* q ->
      exists states_l labels_l,
        is_trace_aux ts start_s states_l labels_l /\ (In q states_l \/ start_s = q).
Proof.
  intros. destruct H. generalize dependent start_s. generalize dependent q. induction x.
  + exists (@nil Q). exists (@nil A). inversion H. unfold rel_pow. destruct H. split.
                                                                               - unfold is_trace_aux. trivial.
                                                                               - simpl. right. trivial.
  + intros.
    inversion H.
    inversion H0.
    pose proof IHx q x0.
    apply H3 in H2.
    destruct H2.
    destruct H2.
    destruct H2.
    destruct H0.
    destruct H0.
    exists (cons x0 x1).
    exists (cons x3 x2).
    destruct H4.
    - split.
      -- simpl. split.
                --- apply H0.
                ---  apply H2.
      -- left. unfold In. right. apply H4.
   - simpl. split. split.
            -- apply H0.
            -- apply H2.
            -- left. left. apply H4.
Qed.

(* Conversely, if a state `q` is reachable, there exists a trace containing it *)
Lemma reachable_in_trace:
  forall A Q (ts : Transition_System Q A) q,
    reachable ts q ->
    exists tr,
      is_trace ts tr /\
      in_trace q tr.
Proof.
  intros.
  inversion H. destruct H0. inversion H1.
  unfold is_trace. unfold in_trace. simpl. pose proof super_lemma_2 A Q ts q x.
  unshelve epose proof H3 _.
    * trivial.
    * inversion H4. inversion H5.
      exists {|
        start := x;
        states := x1;
        labels := x2
      |}. simpl. split.
      - inversion H6; eauto.
      - inversion H6. inversion H8.
                      right. apply H9.
                      left. subst. reflexivity.
Qed.

(** Simulation Relations **)

Definition simulates { QC QA A }
  (tsc : Transition_System QC A) (tsa : Transition_System QA A) (R : QC -> QA -> Prop) :=

  (forall qc, initial tsc qc -> exists qa, R qc qa /\ initial tsa qa) /\
  (forall qc1 a qc2 qa1, tsc |- qc1 ~a~> qc2 -> R qc1 qa1 -> exists qa2, R qc2 qa2 /\ tsa |- qa1 ~a~> qa2).

(* The counter with `inc 1` and `dec 1` simulates the counter with `inc n` and `dec n`. *)
(* The relation used to show the simulation is the diagonal or identity relation.       *)
Lemma simulates_counter_1_n: simulates ex_Counter_1 ex_Counter_n (fun qc qa => True).
Proof.
  unfold simulates. split.
    * intros. exists qc. split.
      - trivial.
      - trivial.
    * intros. unfold ex_Counter_n. simpl. unfold ex_Counter_1 in H; simpl in H. destruct a.
      destruct n.
      + contradiction.
      + destruct n. simpl.
        - exists (qa1 + 1). split.
          -- trivial.
          -- trivial.
        - contradiction.
      + destruct n.
        - contradiction.
        - exists (qa1 - S n). split.
          -- trivial.
          -- reflexivity.
Qed.

(* If a transition system `tsc` simulates a transition system `tsa`, then for every trace of *)
(* `tsc`, there exists a trace of `tsa` with the same labels.                                *)
Lemma simulates_inclusion_observable:
  forall QC QA A (tsc : Transition_System QC A) (tsa : Transition_System QA A) (R : QC -> QA -> Prop) trc,
    simulates tsc tsa R ->
    is_trace tsc trc ->
    exists tra,
      is_trace tsa tra /\
      labels trc = labels tra.
Proof.
  intros. inversion H. inversion H0.
Admitted.


From Hammer Require Import Hammer.

Require Import NZAxioms NZBase.

Module Type NZAddProp (Import NZ : NZAxiomsSig')(Import NZBase : NZBaseProp NZ).

Hint Rewrite
pred_succ add_0_l add_succ_l mul_0_l mul_succ_l sub_0_r sub_succ_r : nz.
Hint Rewrite one_succ two_succ : nz'.
Ltac nzsimpl := autorewrite with nz.
Ltac nzsimpl' := autorewrite with nz nz'.

Theorem add_0_r : forall n, n + 0 == n.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_0_r".
nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite succ_inj_wd.
Qed.

Theorem add_succ_r : forall n m, n + S m == S (n + m).
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_succ_r".
intros n m; nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite succ_inj_wd.
Qed.

Theorem add_succ_comm : forall n m, S n + m == n + S m.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_succ_comm".
intros n m. now rewrite add_succ_r, add_succ_l.
Qed.

Hint Rewrite add_0_r add_succ_r : nz.

Theorem add_comm : forall n m, n + m == m + n.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_comm".
intros n m; nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite succ_inj_wd.
Qed.

Theorem add_1_l : forall n, 1 + n == S n.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_1_l".
intro n; now nzsimpl'.
Qed.

Theorem add_1_r : forall n, n + 1 == S n.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_1_r".
intro n; now nzsimpl'.
Qed.

Hint Rewrite add_1_l add_1_r : nz.

Theorem add_assoc : forall n m p, n + (m + p) == (n + m) + p.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_assoc".
intros n m p; nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite succ_inj_wd.
Qed.

Theorem add_cancel_l : forall n m p, p + n == p + m <-> n == m.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_cancel_l".
intros n m p; nzinduct p. now nzsimpl.
intro p. nzsimpl. now rewrite succ_inj_wd.
Qed.

Theorem add_cancel_r : forall n m p, n + p == m + p <-> n == m.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_cancel_r".
intros n m p. rewrite (add_comm n p), (add_comm m p). apply add_cancel_l.
Qed.

Theorem add_shuffle0 : forall n m p, n+m+p == n+p+m.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_shuffle0".
intros n m p. rewrite <- 2 add_assoc, add_cancel_l. apply add_comm.
Qed.

Theorem add_shuffle1 : forall n m p q, (n + m) + (p + q) == (n + p) + (m + q).
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_shuffle1".
intros n m p q. rewrite 2 add_assoc, add_cancel_r. apply add_shuffle0.
Qed.

Theorem add_shuffle2 : forall n m p q, (n + m) + (p + q) == (n + q) + (m + p).
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_shuffle2".
intros n m p q. rewrite (add_comm p). apply add_shuffle1.
Qed.

Theorem add_shuffle3 : forall n m p, n + (m + p) == m + (n + p).
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.add_shuffle3".
intros n m p. now rewrite add_comm, <- add_assoc, (add_comm p).
Qed.

Theorem sub_1_r : forall n, n - 1 == P n.
Proof. hammer_hook "NZAdd" "NZAdd.NZAddProp.sub_1_r".
intro n; now nzsimpl'.
Qed.

Hint Rewrite sub_1_r : nz.

End NZAddProp.