(** * BagPerm:  Insertion Sort With Bags *)

(** We have seen how to specify algorithms on "collections", such as
    sorting algorithms, using [Permutation]s.  Instead of using
    permutations, another way to specify these algorithms is to use
    _bags_ (also called _multisets_), which we introduced in [Lists].
    A _set_ of values is like a list with no repeats where
    the order does not matter.  A _multiset_ is like a list, possibly
    with repeats, where the order does not matter.  Whereas the principal
    query on a set is whether a given element appears in it, the
    principal query on a bag is _how many_ times a given element appears
    in it. *)

From Coq Require Import Strings.String. (* for manual grading *)
From Coq Require Import Setoid Morphisms.
From VFA Require Import Perm.
From VFA Require Import Sort.

(** To keep this chapter more self-contained,
we restate the critical definitions from [Lists].  *)
Definition bag := list nat.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => 0
  | h :: t =>
      (if h =? v then 1 else 0) + count v t
  end.

(** We will say two bags are _equivalent_ if they have the same number
    of copies of every possible element. *)

Definition bag_eqv (b1 b2: bag) : Prop :=
  forall n, count n b1 = count n b2.

(** **** Exercise: 2 stars, standard (bag_eqv_properties) *)

(* It is easy to prove [bag_eqv] is an equivalence relation. *)

Lemma bag_eqv_refl : forall b, bag_eqv b b.
Proof.
(* TODO: FILL IN HERE *) Admitted.

Lemma bag_eqv_sym: forall b1 b2, bag_eqv b1 b2 -> bag_eqv b2 b1.
Proof.
(* TODO: FILL IN HERE *) Admitted.

Lemma bag_eqv_trans: forall b1 b2 b3, bag_eqv b1 b2 -> bag_eqv b2 b3 -> bag_eqv b1 b3.
Proof.
(* TODO: FILL IN HERE *) Admitted.

(** The following little lemma is handy in a couple of places. *)

Lemma bag_eqv_cons : forall x b1 b2, bag_eqv b1 b2 -> bag_eqv (x::b1) (x::b2).
Proof.
  (* TODO: FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Correctness *)

(** A sorting algorithm must rearrange the elements into a list that
    is totally ordered.  But let's say that a different way: the
    algorithm must produce a list _with the same multiset of values_,
    and this list must be totally ordered. *)

Definition is_a_sorting_algorithm' (f: list nat -> list nat) :=
  forall al, bag_eqv al (f al) /\ sorted (f al).

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

    First, prove the auxiliary lemma [insert_bag], which will be
    useful for proving [sort_bag] below.  Your proof will be by
    induction.  *)

Lemma insert_bag: forall x l, bag_eqv (x::l) (insert x l).
Proof.
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (sort_bag)

    Now prove that sort preserves bag contents. *)
Theorem sort_bag: forall l, bag_eqv l (sort l).
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** Now we wrap it all up.  *)

Theorem insertion_sort_correct:
  is_a_sorting_algorithm' sort.
Proof.
split. apply sort_bag. apply sort_sorted.
Qed.

(** **** Exercise: 1 star, standard (permutations_vs_multiset)

    Compare your proofs of [insert_perm, sort_perm] with your proofs
    of [insert_bag, sort_bag].  Which proofs are simpler?

      - [ ] easier with permutations,
      - [ ] easier with multisets
      - [ ] about the same.

   Regardless of "difficulty", which do you prefer / find easier to
   think about?
      - [ ] permutations or
      - [ ] multisets

   Put an X in one box in each list. *)
(* Do not modify the following line: *)
Definition manual_grade_for_permutations_vs_multiset : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Permutations and Multisets *)

(** The two specifications of insertion sort are equivalent.  One
    reason is that permutations and multisets are closely related.
    We're going to prove:

       [Permutation al bl <-> bag_eqv al bl.] *)

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

    The forward direction is straighforward, by induction on the evidence for
    [Permutation]: *)
Lemma perm_bag:
  forall al bl : list nat,
   Permutation al bl -> bag_eqv al bl.
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** The other direction,
    [bag_eqv al bl -> Permutation al bl],
    is surprisingly difficult.
    This proof approach is due to Zhong Sheng Hu.
    The first three lemmas are used to prove the fourth one. *)

(** **** Exercise: 2 stars, advanced (bag_nil_inv) *)
Lemma bag_nil_inv : forall b, bag_eqv [] b -> b = [].
Proof.
  (* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (bag_cons_inv) *)
Lemma bag_cons_inv : forall l x n,
    S n = count x l ->
    exists l1 l2,
      l = l1 ++ x :: l2
      /\ count x (l1 ++ l2) = n.
Proof.
  (* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, advanced (count_insert_other) *)
Lemma count_insert_other : forall l1 l2 x y,
    y <> x -> count y (l1 ++ x :: l2) = count y (l1 ++ l2).
Proof.
  (* TODO: FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, advanced (bag_perm) *)
Lemma bag_perm:
  forall al bl, bag_eqv al bl -> Permutation al bl.
Proof.
(* TODO: FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * The Main Theorem: Equivalence of Multisets and Permutations *)
Theorem bag_eqv_iff_perm:
  forall al bl, bag_eqv al bl <-> Permutation al bl.
Proof.
  intros. split. apply bag_perm. apply perm_bag.
Qed.

(** Therefore, it doesn't matter whether you prove your sorting
    algorithm using the Permutations method or the multiset method. *)

Corollary sort_specifications_equivalent:
    forall sort, is_a_sorting_algorithm sort <->  is_a_sorting_algorithm' sort.
Proof.
  unfold is_a_sorting_algorithm, is_a_sorting_algorithm'.
  split; intros;
  destruct (H al); split; auto;
  apply bag_eqv_iff_perm; auto.
Qed.

(** $Date$ *)

(* 2022-08-08 17:36 *)


Require Import Bool Arith List.
Import ListNotations.

Definition cons [A:Type] (e :  A) (l: list A) :=
	e :: l
.

Definition decons [A:Type] (l: list A) :=
	match l with
	| [] => None
	| h::t => Some (h,t)
	end.

Fixpoint nth [A:Type] (l: list A) n :=
match n,l with
| _,[] => None
| 0,h::_ => Some h
| S n, _::t => nth t n

end.

Compute nth [1;2;3] 2.
Compute nth [1;2;3] 4.

Inductive tree (A:Type) : Type :=
|leaf : A -> tree A
|node : tree A -> tree A -> tree A
.

Arguments leaf {A}.
Arguments node {A}.

Definition blist (A:Type) : Type :=
list (nat * tree A)
.

Check  [ (0,leaf 0)] : blist nat.
Check  [] : blist nat.

Fixpoint tsize {A} (t: tree A) :=
match t with
|leaf _ => 1
|node t _ => 2 * (tsize t)
end.

Compute tsize (node (leaf 0) (leaf 0)).
Compute tsize (node (node (leaf 0) (leaf 1)) (node (leaf 1) (leaf 0))).

Fixpoint tcons {A} (t:tree A) (l:blist A) :=
	match l with
	|[] => [(tsize t, t)]
	|(st',t')::ll =>
		let st  := tsize t in
		if st =? st'
		then tcons (node t t') ll
		else (st,t)::l
end.

Definition bcons {A} (a:A) l := tcons (leaf a) l.

Compute bcons 1 (bcons 2 (bcons 3 (bcons 4 []))).
Compute bcons 1 (bcons 2 (bcons 3  [])).

Fixpoint tdecons {A} (st:nat) (t:tree A) (l:blist A) :=
	match t with
	|leaf a =>  (a,l)
	|node fg fd =>
		let size := st-1 in
		tdecons size fg ((size,fd)::l)
	end.

Definition l := bcons 1 (bcons 2 (bcons 3  [])).

Definition bdecons [A:Type] (l: blist A) :=
	match l with
	| [] => None
	| (st,t)::ll => Some (tdecons st t ll)
	end.

Compute bdecons l .

Fixpoint tnth [A:Type] (t: tree A) n size :=
	match t,n with
	|leaf a,0 => Some a
	|leaf _,_ => None
	|node fg fd, _ =>
		let size' := size/2 in
		if n <? size'
		then tnth fg n size'
		else tnth fd (n-size') size'
	end.

Fixpoint bnth [A:Type] (l: blist A) n :=
match l with
	| [] => None
	| (st,t)::ll =>
		if n <? st
		then tnth t n st
		else bnth ll (n-st)
end.

Compute l.
Compute bnth l 1.

Fixpoint list_to_blist [A] (l:list A) : blist A :=
	match l with
	|[] => []
	|h::t => bcons h (list_to_blist t)
end.

Definition l' := list_to_blist [1;2;3;4;5;6;7;8].
Compute bnth l' 4.


(* Exercise 38 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

(* Can the following theorem be proved without the
   (exists x : D, x = x) in it?
   If so, how? If not, why not?
*)

Theorem exercise_038 :
  (exists x : D, x = x)
->
    (forall x, P x \/ Q x)
  ->
    ~ (forall x, ~ P x /\ ~ Q x).
Proof.
imp_i a1.
imp_i a2.
exi_e (exists y:D, y = y) y a3.
hyp a1.
neg_i (~P y /\ ~Q y) a4.
dis_e (P y \/ Q y) a5 a5.
all_e (forall x:D, P x \/ Q x) y.
hyp a2.
neg_i (P y) a6.
con_e1 (~Q y).
hyp a6.
hyp a5.
neg_i (Q y) a6.
con_e2 (~P y).
hyp a6.
hyp a5.
all_e (forall x:D, ~P x /\ ~Q x) y.
hyp a4.
Qed.


Require Import ZArith.
Open Scope Z_scope.

Theorem ring_example1: forall x y: Z, (x+y)*(x+y) = x*x + 2*x*y + y*y.
Proof.
  intros x y. ring.
Qed.

Definition square (z:Z) := z*z.

Theorem ring_example2: forall x y:Z, square (x+y) = square x + 2*x*y + square y.
Proof.
  intros x y. unfold square. ring.
Qed.

Require Import Arith. (* otherwise ring tactic wil fail for nat *)

Theorem ring_example3:
  (forall x y: nat, (x+y)*(x+y) = x*x + 2*x*y + y*y)%nat.
Proof.
  intros x y. ring.
Qed.


(*---------------------------------- Descriptions ---------------------------------------

In this file we define the idea of graph isomorphism. This is done by defining following
predicates:

Definition iso (G G': @UG A) :=
     exists (f: A->A), (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
                 (forall x y, In x G -> In y G-> edg G x y = edg G' (f x) (f y)).

 Definition iso_using (f: A->A)(G G': @UG A) :=
     (forall x, f (f x) = x) /\
     (nodes G') = (img f G) /\
     (forall x y, edg G x y = edg G' (f x) (f y)).

When we say (iso_using f G1 G2), we mean f is the function establishing the isomorphism
between G1 and G2. We also prove that this relation is symmetric and transitive.
Note that the self invertible nature of f makes it one_one on both G1 and G2.
Following are some useful property of f:

 Lemma fx_is_one_one (l: list A)(f: A->A): (forall x, f (f x) = x) -> one_one_on l f.
 Lemma img_of_img (l: list A)(f: A->A)(Hl: IsOrd l):
    (forall x, f (f x) = x)-> img f (img f l) = l.

 Lemma iso_sym1 (G G': @UG A)(f: A-> A): iso_using f G G' -> iso_using f G' G.
 Lemma iso_sym (G G': @UG A): iso G G' -> iso G' G.

 Lemma iso_one_one1 (G G': @UG A)(f: A-> A): iso_using f G G' -> one_one_on G f.
 Lemma iso_using_G' (G G': @UG A)(f: A-> A): iso_using f G G' -> nodes G' = (img f G).
 Lemma iso_one_one (G G': @UG A)(f: A-> A)(l: list A): iso_using f G G'-> one_one_on l f.
 Lemma iso_cardinal (G G': @UG A)(f: A-> A): iso_using f G G' -> |G|=|G'|.
 Lemma iso_sub_cardinal (G G': @UG A)(X: list A)(f: A->A): iso_using f G G' ->
                                                           NoDup X -> |X|= | img f X |.
 Lemma iso_edg1  (G G': @UG A)(f: A-> A)(x y:A): iso_using f G G' ->
                                                (edg G x y = edg G' (f x) (f y)).
 Lemma iso_edg2  (G G': @UG A)(f: A-> A)(x y: A): iso_using f G G' ->
                                                (edg G' x y = edg G (f x) (f y)).
-------------------------------------------------------------------------------------

 Stable Set, Cliq and Coloring of graphs has exact counterpart in the isomorphic Graphs.
 These results of existence of counterparts are summarized below:

 Lemma iso_cliq_in (G G': @UG A)(f: A-> A)(K: list A): iso_using f G G' ->
                                                      Cliq_in G K -> Cliq_in G' (img f K).
 Lemma iso_cliq_in1 (G G': @UG A)(K: list A): iso G G' -> Cliq_in G K ->
                                              (exists K', Cliq_in G' K' /\ |K|=|K'|).
 Lemma max_K_in_G' (G G': @UG A)(f: A-> A)(K: list A): iso_using f G G' ->
                                                    Max_K_in G K -> Max_K_in G' (img f K).

Lemma iso_stable (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G' ->
                                                     Stable G I -> Stable G' (img f I).
Lemma iso_stable_in (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G'->
                                                Stable_in G I -> Stable_in G' (img f I).
Lemma max_I_in_G' (G G': @UG A)(f: A-> A)(I: list A): iso_using f G G' ->
                                                  Max_I_in G I -> Max_I_in G' (img f I).

Lemma cliq_num_G' (G G': @UG A)(n: nat): iso G G' -> cliq_num G n -> cliq_num G' n.
Lemma i_num_G' (G G': @UG A)(n: nat):  iso G G' -> i_num G n -> i_num G' n.
Lemma chrom_num_G' (G G': @UG A)(n:nat): iso G G' -> chrom_num G n -> chrom_num G' n.

Lemma nice_G' (G G': @UG A): iso G G' -> Nice G -> Nice G'.
Lemma iso_subgraphs (G G' H: @UG A)(f: A->A):  iso_using f G G' -> Ind_subgraph H G ->
                                      (exists H', Ind_subgraph H' G' /\ iso_using f H H').
Lemma perfect_G' (G G': @UG A): iso G G' -> Perfect G -> Perfect G'.

Following definition represents the Graph G restricted to the vertex set K:

  Definition Ind_at (K: list A)(Pk: IsOrd K)(G: @UG A): @UG A.
     refine {|nodes:= K; nodes_IsOrd := Pk;
              edg:= (G.(edg) at_ K); |}. all: auto. Defined.

------------------------------------------------------------------------------------------*)

Require Export MoreUG.

Set Implicit Arguments.

Section GraphIsomorphism.

  Context { A: ordType }.

   Definition iso (G G': @UG A) :=
     exists (f: A->A), (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
                 (forall x y, In x G-> In y G-> edg G x y = edg G' (f x) (f y)).

   Definition iso_using (f: A->A)(G G': @UG A) :=
     (forall x, f (f x) = x) /\ (nodes G') = (img f G) /\
     (forall x y, In x G-> In y G-> edg G x y = edg G' (f x) (f y)).

   (*--------------------- properties of bijective function for isomorphism----------------*)

   Lemma f_is_one_one (f: A->A): (forall x, f (f x) = x) -> one_one f.
   Proof.  { intros H. unfold one_one. intros x y  Hxy HC. absurd (x=y).
               auto. replace y with (f (f y)). rewrite <- HC. symmetry;auto. auto. } Qed.

  Lemma fx_is_one_one (l: list A)(f: A->A): (forall x, f (f x) = x) -> one_one_on l f.
  Proof. { intros H. unfold one_one_on. intros x y Hx Hy Hxy HC. absurd (x=y).
           auto. replace y with (f (f y)). rewrite <- HC. symmetry;auto. auto. } Qed.

  Lemma img_of_img (l: list A)(f: A->A)(Hl: IsOrd l):
    (forall x, f (f x) = x)-> img f (img f l) = l.
  Proof. { intro H.
         assert (H1: Equal (img f (img f l)) l).
         { unfold Equal. split.
           { unfold Subset. intros a H1.
             assert (H2: exists b, In b (img f l) /\ a = f b); auto.
             destruct H2 as [b H2]. destruct H2 as [H2a H2b].
             assert (H3: exists x, In x l /\ b = f x ); auto.
             destruct H3 as [x H3]. destruct H3 as [H3a H3b].
             subst a. subst b. replace (f (f x)) with x. auto. symmetry;auto. }
           { unfold Subset. intros a H1.
             assert (H2: In (f a) (img f l)). auto.
             assert (H2a: In (f (f a)) (img f (img f l))). auto.
             replace (f (f a)) with a in H2a. auto. symmetry;auto. } }
         auto. } Qed.

   Lemma img_of_img1 (l: list A)(f: A->A)(Hl: IsOrd l):
     (forall x, f (f x) = x)-> l= img f (img f l).
   Proof. intros. symmetry. auto using img_of_img. Qed.

   Hint Resolve f_is_one_one fx_is_one_one img_of_img img_of_img1: core.

   (* ---------------------- Isomorphism is commutative and transitive------------------*)
   Lemma iso_sym1 (G G': @UG A)(f: A-> A): iso_using f G G' -> iso_using f G' G.
    Proof. { intro H. destruct H as [Ha H]; destruct H as [Hb H].
           split.
           { auto. }
           split.
           { rewrite Hb;  auto. }
           { intros; symmetry.
             replace (edg G' x y) with ( edg G' (f (f x)) (f (f y))).
             assert (H2: In (f x) G).
             { rewrite Hb in H0.
               assert (h1: exists x0, In x0 G /\ x = f x0). auto.
               destruct h1 as [x0 h1]. destruct h1 as [h1 h2].
               subst x. specialize (Ha x0) as Hx0. rewrite Hx0. auto. }
             assert (H3: In (f y) G).
              { rewrite Hb in H1.
               assert (h1: exists y0, In y0 G /\ y = f y0). auto.
               destruct h1 as [y0 h1]. destruct h1 as [h1 h2].
               subst y. specialize (Ha y0) as Hy0. rewrite Hy0. auto. }
             auto. replace (f (f x)) with x. replace (f (f y)) with y.
             auto. all: symmetry;auto. } } Qed.

  Lemma iso_elim1 (G G': @UG A)(f: A->A)(x:A): iso_using f G G'-> In x G-> In (f x) G'.
   Proof. intros H Hx. replace (nodes G') with (img f G). auto. symmetry; apply H. Qed.

  Lemma iso_elim2 (G G': @UG A)(f: A->A)(x:A): iso_using f G G'-> In x G'-> In (f x) G.
  Proof. intros H Hx. replace (nodes G) with (img f G'). auto. symmetry.
         apply iso_sym1 in H as Ha. apply Ha. Qed.

  Lemma iso_sym (G G': @UG A): iso G G' -> iso G' G.
  Proof. { intro H. destruct H as [f H].  exists f. apply iso_sym1. auto. } Qed.

  Lemma iso_using_iso (G G':@UG A)(f: A->A): iso_using f G G' -> iso G G'.
  Proof. intros h. exists f. auto. Qed.

  Lemma iso_using_iso1 (G G':@UG A)(f: A->A): iso_using f G G' -> iso G' G.
  Proof. intro h. apply iso_sym. eapply iso_using_iso. eauto. Qed.

  Hint Immediate iso_sym1 iso_sym iso_elim1 iso_elim2: core.

  Hint Resolve iso_using_iso iso_using_iso1: core.

  Lemma iso_one_one1 (G G': @UG A)(f: A-> A): iso_using f G G' -> one_one_on G f.
  Proof.  intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_one_one2 (G G': @UG A)(f: A-> A): iso_using f G G' -> one_one_on G' f.
  Proof. intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_using_G' (G G': @UG A)(f: A-> A): iso_using f G G' -> nodes G' = (img f G).
  Proof.  intro H;apply H. Qed.

  Lemma iso_using_G (G G': @UG A)(f: A-> A): iso_using f G G' -> nodes G = (img f G').
  Proof. intro H0. cut (iso_using f G' G). intro H;apply H. auto. Qed.

  Lemma iso_one_one (G G': @UG A)(f: A-> A)(l: list A):
    iso_using f G G'-> one_one_on l f.
  Proof. intro H; apply fx_is_one_one; apply H. Qed.

  Lemma iso_f_one_one (G G': @UG A)(f: A-> A): iso_using f G G'-> one_one f.
    Proof. intro H; apply f_is_one_one; apply H. Qed.

    Hint Immediate iso_one_one1 iso_one_one2 iso_one_one iso_f_one_one
         iso_using_G iso_using_G': core.

  Lemma iso_cardinal (G G': @UG A)(f: A-> A): iso_using f G G' -> |G|=|G'|.
  Proof. { intro H.  apply iso_one_one1 in H as H1.
           replace (nodes G') with (img f G). auto.
           symmetry; auto using iso_using_G'. } Qed.
  Lemma iso_sub_cardinal (G G': @UG A)(X: list A)(f: A->A):
    iso_using f G G' -> NoDup X -> |X|= | img f X |.
  Proof. { intros H H0.
         assert (H2: one_one_on G f). eauto.
         assert (H2a: one_one_on X f). eauto. auto. } Qed.

   Lemma iso_edg1  (G G': @UG A)(f: A-> A)(x y:A): iso_using f G G' -> In x G -> In y G->
                                                (edg G x y = edg G' (f x) (f y)).
  Proof. intro H;apply H. Qed.

  Lemma iso_edg2  (G G': @UG A)(f: A-> A)(x y: A): iso_using f G G' -> In x G'-> In y G'->
                                                (edg G' x y = edg G (f x) (f y)).
  Proof. intro H0. cut (iso_using f G' G). intro H;apply H. auto. Qed.

  Hint Immediate iso_cardinal iso_sub_cardinal iso_edg1 iso_edg2: core.

   Lemma iso_edg3(G G': @UG A)(f: A-> A)(x y:A): iso_using f G G' -> In x G -> In y G->
                                                edg G x y -> edg G' (f x) (f y).
  Proof.  intros; replace (edg G' (f x) (f y)) with (edg G x y); auto.  Qed.

  Lemma iso_edg4  (G G': @UG A)(f: A-> A)(x y: A): iso_using f G G' -> In x G -> In y G->
                                                ~ edg G x y -> ~ edg G' (f x) (f y).
  Proof. intros ; replace (edg G' (f x) (f y)) with (edg G x y); auto. Qed.

  Hint Immediate iso_edg3 iso_edg4: core.

  (* ------------- Isomorphism preserves Cliques and Cliq_num for a graph-----------------*)

   Lemma iso_cliq (G G': @UG A)(f: A-> A)(K: list A):
    iso_using f G G' -> K [<=] G-> Cliq G K -> Cliq G' (img f K).
  Proof. {  unfold Cliq. intros H H1 h1.  intros x y Hx Hy.
          assert (H2: exists x0, In x0 K /\ x = f x0). auto.
          destruct H2 as [x0 H2]. destruct H2 as [H2a H2b].
          assert (H3: exists y0, In y0 K /\ y = f y0). auto.
          destruct H3 as [y0 H3]. destruct H3 as [H3a H3b].
          replace x with (f x0). replace y with (f y0).
          assert (H2:  x0 = y0 \/ edg G x0 y0). auto.
          destruct H2.
          { left. subst x0. auto. }
          { right. replace (edg G' (f x0) (f y0)) with (edg G x0 y0).
            auto. apply H. all: auto. }  }  Qed.

  Lemma iso_cliq1 (G G': @UG A)(K: list A): iso G G' -> K [<=] G -> Cliq G K -> NoDup K ->
                                           (exists K', Cliq G' K' /\ |K|=|K'|).
  Proof. { intros H h1 H1 H2. destruct H as [f H].
         exists (img f K). split. eauto using iso_cliq.
         assert (H3: one_one_on K f). eauto.
         auto. } Qed.

  Lemma iso_cliq_in (G G': @UG A)(f: A-> A)(K: list A):
    iso_using f G G' -> Cliq_in G K -> Cliq_in G' (img f K).
  Proof. { intros H H1.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c].
         split.
         { destruct H as [Ha H]. destruct H as [Hb Hc]. rewrite Hb; auto. }
         split.
         { auto. }
         { eauto using iso_cliq. }  } Qed.

  Lemma iso_cliq_in1 (G G': @UG A)(K: list A): iso G G' -> Cliq_in G K ->
                                              (exists K', Cliq_in G' K' /\ |K|=|K'|).
  Proof. { intros H H1. destruct H as [f H].
         exists (img f K). split. eauto using iso_cliq_in.
         assert (H3: one_one_on K f). eauto.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c]. auto. } Qed.

  Hint Immediate iso_cliq iso_cliq1 iso_cliq_in iso_cliq_in1: core.

  Lemma max_K_in_G' (G G': @UG A)(f: A-> A)(K: list A):
    iso_using f G G' -> Max_K_in G K -> Max_K_in G' (img f K).
  Proof. { intros H H1. assert (H0: iso_using f G' G); auto.
         apply  Max_K_in_intro.
         { cut (Cliq_in G K); eauto. }
         { intros Y H2.
           replace (|Y|) with (|img f Y|).
           replace (|img f K|) with (|K|).
            assert (H3: Cliq_in G (img f Y)). eauto.
           eauto using Max_K_in_elim. eapply iso_sub_cardinal;eauto.
           symmetry. eapply iso_sub_cardinal; eauto. } } Qed.

  Lemma cliq_num_G' (G G': @UG A)(n: nat):
    iso G G' -> cliq_num G n -> cliq_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [K H1].
         destruct H1 as [H1 H1b]. exists (img f K).
         split. eauto using max_K_in_G'. replace n with (|K|).
         symmetry. eapply iso_sub_cardinal;eauto. } Qed.

  Hint Immediate max_K_in_G' cliq_num_G': core.

  (*---------- Isomorphism preserves Stable set and i_num ----------------------------*)

   Lemma iso_stable (G G': @UG A)(f: A-> A)(I: list A):
    iso_using f G G' -> I [<=] G-> Stable G I -> Stable G' (img f I).
  Proof. {  unfold Stable. intros H h1 H1.  intros x y Hx Hy.
          assert (H2: exists x0, In x0 I /\ x = f x0). auto.
          destruct H2 as [x0 H2]. destruct H2 as [H2a H2b].
          assert (H3: exists y0, In y0 I /\ y = f y0). auto.
          destruct H3 as [y0 H3]. destruct H3 as [H3a H3b].
          replace x with (f x0). replace y with (f y0).
          assert (H2: edg G x0 y0 = false). auto.
          replace (edg G' (f x0) (f y0)) with (edg G x0 y0).
            auto. apply H. all: auto. } Qed.

   Lemma iso_stable1 (G G': @UG A)(I: list A): iso G G' -> I [<=] G-> Stable G I -> NoDup I ->
                                           (exists I', Stable G' I' /\ |I|=|I'|).
  Proof. { intros H h1 H1 H2. destruct H as [f H].
         exists (img f I). split. eauto using iso_stable.
         assert (H3: one_one_on I f). eauto.
         auto. } Qed.

  Lemma iso_stable_in (G G': @UG A)(f: A-> A)(I: list A):
    iso_using f G G' -> Stable_in G I -> Stable_in G' (img f I).
  Proof. { intros H H1.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c].
         split.
         { destruct H as [Ha H]. destruct H as [Hb Hc]. rewrite Hb; auto. }
         split.
         { auto. }
         { eauto using iso_stable. }  } Qed.

  Lemma iso_stable_in1 (G G': @UG A)(I: list A): iso G G' -> Stable_in G I ->
                                              (exists I', Stable_in G' I' /\ |I|=|I'|).
  Proof. { intros H H1. destruct H as [f H].
         exists (img f I). split. eauto using iso_stable_in.
         assert (H3: one_one_on I f). eauto.
         destruct H1 as [H1a H1]. destruct H1 as [H1b H1c]. auto. } Qed.

  Hint Immediate iso_stable iso_stable1 iso_stable_in iso_stable_in1: core.

  Lemma max_I_in_G' (G G': @UG A)(f: A-> A)(I: list A):
    iso_using f G G' -> Max_I_in G I -> Max_I_in G' (img f I).
  Proof. { intros H H1. assert (H0: iso_using f G' G); auto.
         apply  Max_I_in_intro.
         { cut (Stable_in G I); eauto. }
         { intros Y H2.
           replace (|Y|) with (|img f Y|).
           replace (|img f I|) with (|I|).
           assert (H3: Stable_in G (img f Y)). eauto.
           eauto using Max_I_in_elim. eapply iso_sub_cardinal;eauto.
           symmetry. eapply iso_sub_cardinal; eauto. } } Qed.

  Lemma i_num_G' (G G': @UG A)(n: nat):
    iso G G' -> i_num G n -> i_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [I H1].
         destruct H1 as [H1 H1b]. exists (img f I).
         split. eauto using max_I_in_G'. replace n with (|I|).
         symmetry. eapply iso_sub_cardinal;eauto. } Qed.

  Hint Immediate max_I_in_G' i_num_G': core.

  (*----------- Isomorphism, graph coloring and chromatic number -------------------------*)

  Lemma iso_coloring (G G': @UG A)(f: A->A)(C: A->nat):
    iso_using f G G' -> Coloring_of G C -> Coloring_of G' (fun (x:A) => C (f x)).
  Proof. { intros H H1. assert (Ha: iso_using f G' G);auto. unfold Coloring_of.
           intros x y Hx Hy H2. assert (H3: edg G (f x) (f y)). eauto. apply H1; eauto. } Qed.

  Lemma iso_same_clrs (G G': @UG A)(f: A->A)(C: A->nat):
    iso_using f G G' -> Coloring_of G C -> (clrs_of C G) = clrs_of (fun (x:A) => C (f x)) G'.
  Proof. { intros H H1. assert (Ha: iso_using f G' G). auto.
         assert (H2: (nodes G) = img f G'). auto. unfold clrs_of; rewrite H2; auto. } Qed.

  Lemma best_coloring_of_G' (G G': @UG A)(f: A-> A)(C: A->nat):
    iso_using f G G' -> Best_coloring_of G C -> Best_coloring_of G' (fun (x:A) => C (f x)).
  Proof. { unfold Best_coloring_of. intros H H1.
         assert (H0: iso_using f G' G). auto.
         destruct H1 as [H1 H2].
         split. { eauto using iso_coloring. }
                { intros C' H3.
                  assert (H4: (clrs_of C G) = clrs_of (fun (x:A) => C (f x)) G').
                  auto using iso_same_clrs. rewrite <- H4.
                  assert (H5: (clrs_of C' G') = clrs_of (fun (x:A) => C' (f x)) G).
                  auto using iso_same_clrs. rewrite H5.
                  apply H2. eauto using iso_coloring. } } Qed.

  Lemma chrom_num_G' (G G': @UG A)(n:nat):
    iso G G' -> chrom_num G n -> chrom_num G' n.
  Proof. { intros H H1. destruct H as [f H]. destruct H1 as [C H1].
         destruct H1 as [H1 H2].
         exists (fun (x:A) => C (f x)). split. eauto using best_coloring_of_G'.
         subst n. replace (clrs_of (fun x : A => C (f x)) G') with (clrs_of C G).
         auto. destruct H1 as [H1 H2]. auto using iso_same_clrs. } Qed.

  Hint Resolve iso_coloring iso_same_clrs best_coloring_of_G': core.
  Hint Immediate chrom_num_G': core.

  (*------------Isomorphism, nice graphs and perfect graph--------------------------------*)

  Lemma nice_G' (G G': @UG A): iso G G' -> Nice G -> Nice G'.
  Proof. { intro H.  assert (H0: iso G' G). auto.
         unfold Nice. intros H1 n H2.
         cut (chrom_num G n). eauto. cut (cliq_num G n); eauto. } Qed.

  Lemma iso_subgraphs (G G' H: @UG A)(f: A->A):
    iso_using f G G' -> Ind_subgraph H G -> (exists H', Ind_subgraph H' G' /\ iso_using f H H').
  Proof.  { intros F1 F2.
            assert (F0: iso_using f G' G). auto.
            assert (Nk: IsOrd (img f H)). auto.
            pose H' := (ind_at (img f H) G').
            exists H'.
            assert (h0: H' [<=] G').
            { replace (nodes G') with (img f G). simpl.
              cut (img f H [<=] img f G). auto.
              eapply img_subset. apply F2. symmetry. auto. }
            assert (h1: img f H [<=] G').
            { replace (nodes G') with (img f G).
                cut (H [<=] G). auto. apply F2.  symmetry.
                assert(F3: iso_using f G G'). auto. apply F3. }
            assert (h2: img f H = inter (img f H) G').
            { apply set_equal; auto. }
            split.
            (* Ind_subgraph H' G' *)
            {  unfold Ind_subgraph. split.
               { auto. }
               { unfold H'. simpl. intros. symmetry. auto. } }

            {  (* iso_using f H H' *)
              unfold iso_using.
              split.
              { apply F1. }
              split.
              { simpl. symmetry. auto.  }
              { (* forall x y : A, edg H x y = edg (Ind_at Nk G') (f x) (f y) *)
                simpl. intros x y Hx Hy.
                replace (edg H x y) with (edg G x y). rewrite <- h2.
                assert (H2: In (f x) (img f H)). auto.
                replace ((edg G' at_ img f H) (f x) (f y)) with (edg G' (f x)(f y)).
                destruct F2. cut(In x G). cut(In y G). all: auto. symmetry. auto. } } } Qed.

  Lemma perfect_G' (G G': @UG A): iso G G' -> Perfect G -> Perfect G'.
  Proof. { intro F.  assert (F0: iso G' G). auto.
         unfold Perfect. destruct F0 as [f F0].
         intros F1 H' F2.
         assert (F3: exists H, Ind_subgraph H G /\ iso_using f H' H).
         { eapply iso_subgraphs. apply F0. auto. }
         destruct F3 as [H F3]. destruct F3 as [F3 F4].
         cut (Nice H).
         { cut (iso H H'). eauto using nice_G'.
           exists f. cut (iso_using f H H'); auto. } auto.  } Qed.

  Hint Immediate nice_G' induced_fact1 iso_subgraphs perfect_G': core.

End GraphIsomorphism.

Hint Resolve f_is_one_one fx_is_one_one img_of_img img_of_img1: core.

Hint Immediate iso_sym1 iso_sym iso_elim1 iso_elim2: core.
 Hint Resolve iso_using_iso iso_using_iso1: core.
Hint Immediate iso_one_one1 iso_one_one2: core.
Hint Immediate iso_one_one iso_f_one_one iso_using_G iso_using_G': core.

Hint Immediate iso_cardinal iso_sub_cardinal iso_edg1 iso_edg2: core.
Hint Immediate iso_edg3 iso_edg4: core.

Hint Immediate iso_cliq iso_cliq1 iso_cliq_in iso_cliq_in1: core.
Hint Immediate max_K_in_G' cliq_num_G': core.

Hint Immediate iso_stable iso_stable1 iso_stable_in iso_stable_in1: core.
Hint Immediate max_I_in_G' i_num_G': core.

Hint Resolve iso_coloring iso_same_clrs best_coloring_of_G': core.
Hint Immediate chrom_num_G': core.

Hint Immediate nice_G' iso_subgraphs perfect_G': core.


(*Sidorets Kirill et Ait gueni ssaid Abderrahmane*)
Require Import untypedLC.
(* 1.1 λ-calcul non typé *)

  (* 1. Booléens (codage des constantes et des opérations de base)   *)
  (*booléens de Church vrai: λx y.x*)
  Definition ctr := \x y·x.
  (*booléens de Church faux: λx y.y*)
  Definition cfa := \x y·y.
  (*if b then m else n : λ b m n .b m n*)
  Definition cif := \b m n · b m n.
  (* a and  b : λ a b.λx y. a (b x y) y *)
  Definition cand := \ a b · (\ x y · a (b x y) y).
  (* a or  b : λ a b.λx y. a x (b x y) *)
  Definition cor := \a b ·\x y·a x(b x y).
  (* a or  b : λ a b.λx y. cif a x (b x y) *)
  Definition cor_cif :=\a b·\x y ·cif a x( b x  y).
  (*Dérivée à partir de la version non factorisée *)
  Definition cor' :=\a·a a.
  (*not a ( if a then {false} else {true}):λ a.cif a cfa ctr*)
  Definition cnot := \ a· cif a cfa ctr .
  (*not a :λ a.a cfa ctr*)
  Definition cnot' := \ a· a cfa ctr .

  Compute show_cbn(cif ctr a b).
  Compute show_cbn(cif cfa a b).
  Compute show_cbn(cif (cor_cif cfa (cnot ctr)) a b).
  Compute show_cbn(cor_cif cfa cfa a b).
  Compute show_cbn(cif( cor' (cand cfa ctr) cnot' cfa) a b).

  (* 2. Entiers naturels (codage de quelques constantes,
  des opérations successeur, addition et multiplication, et
  du test à 0)*)
  (*Codage des entiers naturels en λ-calcul inventé par Alonzo Church *)
  (* 0 :λ f x .x *)
  Definition c0 := \f x·x.
  (* 1 :λ f x . f x *)
  Definition c1 :=\f x·f x.
  (* 2 :λ f x . f (f x) *)
  Definition c2 :=\f x·f (f x).
  (* 3 :λ f x . f (f (f x)) *)
  Definition c3 :=\f x·f (f (f x)).
  (* 4 :λ f x . f (f (f (f x))) *)
  Definition c4 :=\f x·f (f (f (f x))).
  (* csucc(n)=n+1 : λ n.λ f x. f (n f x)*)
  Definition csucc := \n·\f x · f ( n f x).
  (* cadd (a,b)=a+b :λ n m.λ f x. n f (m f x) *)
  Definition cadd := \n m ·\f x · n f ( m f x).
  (* cmult (a,b)=a*b :λ n m.λ f . n (m f) *)
  Definition cmult := \n m ·\f· n( m f).
  (* ceq0(n) = {si n=c0 true sinon false}:λ n .λ x y . n (λ z.y ) x*)
  Definition ceq0 :=\n·\x y·n(\z·y) x.

  Compute (show_cbn (csucc c4)).
  Compute (show_cbn (cadd c2 c3)).
  Compute (show_cbn (cmult c2 c4)).
(* l'expression ceq0 retourne a si true sinon elle retourne b  *)
  Compute (show_cbn ((ceq0 c0) a b)).
  Compute (show_cbn ((ceq0 c3) a b )).

  (* 3. Couples*)
  (*La fonction cpl prend deux arguments(a,b) et construit un couple : λa b.λk.k a b *)
  Definition cpl := \ a b · \ k·k a b.
  (*Prends en argument un couple, retournent premier élément : λ x y. x*)
  Definition kfst := \ x y· x.
  (*Prends en argument un couple, retournent deuxième élément : λ x y. y*)
  Definition ksnd := \ x y· y.
  (*fst(c) = x ou c - un couple x - premier élément de c  : λ c. c kfst *)
  Definition fst := \ x · x kfst.
  (*fst(c) = y ou c - une cople x - deuxième élément de c  : λ c. c ksnd *)
  Definition snd := \ x · x ksnd.

  Compute (show_cbn (fst (cpl a b))).
  Compute (show_cbn (snd (cpl ctr cfa))).

  (*ksumcpl(cp(n,m))= n+m Renvoie la somme des éléments d'une couple
  :λx.(cadd (fst x) (snd x)) *)
  Definition ksumcpl := \x · (cadd (fst x) (snd x)).
  Compute show_cbn(ksumcpl (cpl c2 c3)).

  (*4. Structure de choix (inj1, inj2, donnée optionnelle).*)
  (*Constructeur structure de choix a partir du premier élément : λ a b. a x *)
  Definition inj1 := \a b · a x.
  (*Constructeur structure de choix a partir du deuxième élément : λ a b. b x *)
  Definition inj2 := \a b · b x.

  Compute show_cbn(inj1 f g).
  Compute show_cbn(inj2 f g).
  (*Fonction prenant en argument une donnée qui est soit un entier n (emballé par
  inj1) soit un booléen b (emballé par inj2) et qui rend le double de n dans le
  premier cas, la négation de b dans le second *)
  Definition funcinj1inj2:=\a x · a (cmult x c2) (cnot x).
  Compute show_cbn(funcinj1inj2 inj1 c3).
  Compute show_cbn(funcinj1inj2 inj2 ctr).

  (* La donnée optionnelle correspond à un choix entre une donnée (Some x) ou
  son absence (None). Elle se représente avec une continuation à un argument
  et une continuation à zéro argument. Coder en Coq les injections Some et None,
  puis une fonction osucc prenant en argument un entier optionnel (Some n ou None)
  et rendant un entier optionnel qui est Some (n+1) dans le premier cas et Some 0
  dans le second *)
  Definition Some:= \f m n · m f.
  Definition None:= \x y · y.
  Definition osucc:= \a b · a b csucc c0.
  Compute show_cbn(osucc Some c3).
  Compute show_cbn(osucc None).

  (* 5. Prédécesseur (cpred; cpredo en bonus)*)
  (*la fonction iter qui prend un entier de Church n, une fonction g et
  un argument x et qui applique n fois la fonction g sur x. *)
  Definition iter := \n g x · n g x.
  (*  la fonction cpred1 qui à partir d’un couple λk.k x y donné en
  argument rend le couple λk.k y (csucc y).*)
  Definition cpred1 := \c · \k · k (snd c) (csucc(snd c)).
  Compute show_cbn(cpl c1 c2).
  Compute show_cbn(fst (cpred1 (cpl c1 c2))).
  Compute show_cbn(snd (cpred1 (cpl c1 c2))).
  Compute show_cbn(cpred1 (cpl c1 c2)).
  (* Pour définir le prédécesseur sur les entiers de Church, on utilise les couples.
  L’idée est d’itérer n fois une fonction agissant sur des couples d’entiers.
  Prenons une fonction g qui à partir de (x, y) donné en argument rend (y, y +1).
  Alors, en itérant n fois g sur (0, 0), on obtient (n −1,n) et il suffit d’extraire
  la première composante de ce couple. Si n est codé comme un entier de Church alors
  itérer n fois une fonction g sur un argument a est juste (n g a).*)
  Definition cpred := \n· fst (iter n cpred1 (cpl c0 c0) ).
  Compute show_cbn(cpred c3).
  Definition cpred_v2 := \n· fst ( n cpred1 (cpl c0 c0) ).
  Compute show_cbn(cpred_v2 c3).

  (*6. Factorielle*)
  (* cfonc -> f if(n==0) alors retourne 1 sinon n*f(n-1)  *)
  Definition cfonc := \f n· cif (ceq0 n) c1 (cmult n (f f (cpred n))).
  (*cfact(3)=1*2*3=6 *)
  Definition cfact :=\x· cfonc cfonc x.
  Compute red_cbn(cfact c0).
  Compute red_cbn(cfact c1).
  Compute red_cbn(cfact c2).
  Compute red_cbn(cfact c3).


Require Import Group.
Require Import ZArith.

Open Scope Z_scope.

Include BinIntDef.Z.

(* Make a Group consisting of all integers under addition, with 0 as the identity element *)
Instance ZAdd : Group Zplus opp 0.
Proof.
  split.
  * apply Zplus_assoc.
  * intros x.
    rewrite Z.add_opp_l.
    apply Zminus_diag.
  * intros x.
    rewrite Z.add_opp_r.
    apply Zminus_diag.
  * reflexivity.
  * apply Zplus_0_r.
Qed.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

Definition relation (X: Type) := X -> X -> Prop.

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X,
    R x y1 -> R x y2 -> y1 = y2.

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  discriminate Nonsense.
Qed.

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.
Qed.

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X,
    (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.
Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo.
Qed.

Theorem lt_trans' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [|m' Hm'o].
  - apply le_S in Hnm. apply Hnm.
  - apply le_S, IHHm'o.
Qed.

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply Sn_le_Sm__n_le_m in Hmo.
    apply le_S in Hmo.
    apply (le_trans (S n) m (S o')).
    apply Hnm. apply Hmo.
Qed.

Theorem le_Sn_le : forall n m,
  S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  apply le_S, le_n. apply H.
Qed.

Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros n m H. inversion H. apply le_n.
  apply le_Sn_le in H1. apply H1.
Qed.

Theorem le_Sn_n : forall n,
  ~ (S n <= n).
Proof.
  unfold not. intros. induction n.
  inversion H. apply le_S_n in H.
  apply IHn in H. apply H.
Qed.

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold symmetric. intros H.
  assert (1 <= 0) as Nonsense.
  { apply H. apply le_S. apply le_n. }
  inversion Nonsense.
Qed.

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric. intros.
  inversion H. reflexivity.
  assert (S a <= a) as Nonsense.
  (* S b <= S a <= b *)
  { apply le_trans with (b := b).
  rewrite <- H2. apply le_n_S, H1. apply H0. }
  apply le_Sn_n in Nonsense.
  apply ex_falso_quodlibet, Nonsense.
Qed.

Theorem le_step : forall n m p,
  n < m -> m <= S p -> n <= p.
Proof.
  unfold lt. intros.
  apply le_S_n, (le_trans (S n) m (S p)).
  apply H. apply H0.
Qed.

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* Actually, it is Partial Orders *)
Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\
    (antisymmetric R) /\ (transitive R).

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
  - apply le_reflexive.
  - split.
    + apply le_antisymmetric.
    + apply le_trans.
Qed.

Inductive clos_refl_trans {A: Type} (R: relation A) :
  relation A :=
    | rt_step x y (H : R x y) : clos_refl_trans R x y
    | rt_refl x : clos_refl_trans R x x
    | rt_trans x y z
          (Hxy : clos_refl_trans R x y)
          (Hyz : clos_refl_trans R y z) :
          clos_refl_trans R x z.

Print next_nat.
(*
Inductive next_nat : nat -> nat -> Prop :=
    nn : forall n : nat, next_nat n (S n)
*)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - intros H. induction H.
    + apply rt_refl.
    + apply rt_trans with m. apply IHle.
      apply rt_step. apply nn.
  - intros H. induction H.
    + inversion H. apply le_S, le_n.
    + apply le_n.
    + apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2.
Qed.

Inductive clos_refl_trans_1n {A : Type}
                       (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A)
      (Hxy : R x y) (Hrest : clos_refl_trans_1n R y z) :
      clos_refl_trans_1n R x z.

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y.
  apply H. apply rt1n_refl.
Qed.

Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  intros. induction H.
  - apply H0.
  - apply rt1n_trans with y. apply Hxy.
    apply IHclos_refl_trans_1n, H0.
Qed.

Theorem rtc_rsc_coincide :
  forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <->
    clos_refl_trans_1n R x y.
Proof.
  intros. split.
  - intros H. induction H.
    + apply rsc_R, H.
    + apply rt1n_refl.
    + apply rsc_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2.
  - intros H. induction H.
    + apply rt_refl.
    + apply rt_trans with y.
      apply rt_step in Hxy. apply Hxy.
      apply IHclos_refl_trans_1n.
Qed.


Require Import Znumtheory.
Require Import Qreduction.

Open Scope Q_scope.

Coercion inject_Z : Z >-> Q.

Fixpoint fib_pair (n:nat) : Z*Z := match n with
 | O => (0,1)%Z
 | S n => let (p,q) := fib_pair n in (q,p+q)%Z
 end.

Definition fibonacci (n:nat) := snd (fib_pair n).

Definition fibo_frac (n:nat) := Qred (fibonacci (S n) # Z2P (fibonacci n)).

Time Eval vm_compute in fibo_frac 1000.

(* display for humans: *)

Definition get_first_n_decimal_digits (n:nat)(q:Q) : Z :=
 let q' := q*(10^n) in
 Zdiv (Qnum q') (QDen q').

Eval vm_compute in get_first_n_decimal_digits 30 (fibo_frac 1000).

(*
From bc:
scale=30
(1+sqrt(5))/2
1.618033988749894848204586834365
*)

Fixpoint sqrt2_newton (n:nat) : Q := match n with
 | O => 1%Q
 | S n => let q := sqrt2_newton n in
               Qred ( (1/2)*q + /q)
 end.

(*
Time Eval vm_compute in sqrt2_newton 10.
*)

Eval vm_compute in get_first_n_decimal_digits 100 (sqrt2_newton 10).
(*
1414213562373095048801688724209698078569671875376948073176679737990\
7324784621070388503875343276415727
*)

(* from bc:
scale=100
sqrt(2)
1.414213562373095048801688724209698078569671875376948073176679737990\
7324784621070388503875343276415727
*)

Fixpoint e_frac_aux (n:nat) : Q*(Z*Z) := match n with
 | O => (1,(1%Z,1%Z))
 | S n => let (q,pr) := e_frac_aux n in
               let (fact,next) := pr in
               let nextfact:=(next*fact)%Z in
               (Qred (q+/nextfact), (nextfact,Zsucc next))
 end.

Definition e_frac (n:nat) := fst (e_frac_aux n).

Time Eval vm_compute in e_frac 150.
Time Eval vm_compute in get_first_n_decimal_digits 100 (e_frac 150).
(*
2718281828459045235360287471352662497757247093699959574966967627724\
0766303535475945713821785251664274
*)

(* from bc:
scale=100
2.718281828459045235360287471352662497757247093699959574966967627724\
0766303535475945713821785251664274
*)

Fixpoint atan_aux (n:nat)(q:Q) {struct n } : (Q*(Q*Z)) := match n with
	                          (* part sum / last term / (-1)^n*(2n+1) *)
  | O => (q,(q,1%Z))
  | S n => let (sum,pr) := atan_aux n q in
                let (power,div) := pr in
                let nextpower:=q*q*power in
	        let nextdiv:= ((-2)*Zsgn(div)-div)%Z in
                (Qred (sum+nextpower/nextdiv), (nextpower, nextdiv))
 end.

Definition atan (n:nat)(q:Q) := fst (atan_aux n q).

Definition pi_frac (n:nat) := Qred (16*(atan n (1#5))-4*(atan n (1#239))).

Time Eval vm_compute in get_first_n_decimal_digits 100 (pi_frac 70).
(*
3141592653589793238462643383279502884197169399375105820974944592307\
8164062862089986280348253421170679

bc:
3.141592653589793238462643383279502884197169399375105820974944592307\
8164062862089986280348253421170680
*)

Extraction "pi.ml" pi_frac get_first_n_decimal_digits.


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

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

Theorem S_injective : forall m n : nat, S m = S n -> m = n.
  injection 1.
  trivial.
Qed.

Theorem O_left_id : forall m : nat, plus O m = m.
  intros.
  case m.
    (* m = O *)
    simpl.
    trivial.
    (* m = S m' *)
    intros.
    simpl.
    trivial.
Qed.

Theorem O_right_id : forall m : nat, plus m O = m.
    intros.
  case m.
    (* m = O *)
    simpl.
    trivial.
    (* m = S m' *)
    intros.
    simpl.
    trivial.
Qed.

Theorem O_id : forall m : nat, plus O m = m /\ plus m O = m.
  intros.
  refine (conj _ _).
    apply O_left_id.
    apply O_right_id.
Qed.


(* 3 Introducing Inductive Types *)

Require Import Cpdt.CpdtTactics.
Set Implicit Arguments.

(* 3.1 Proof Terms *)

Check (fun x : nat => x).

Check (fun x : True => x).

Check I.

Check (fun _ : False => I).

Check (fun x : False => x).

(* 3.2 Enumerations *)

Inductive unit : Set :=
| tt
.

Check unit.
Check tt.

(* We can prove that unit is a genuine singleton type. *)

Theorem unit_singleton : forall x : unit, x = tt.

induction x.
reflexivity.
Qed.

Check unit_ind.

Inductive Empty_set : Set := .

Theorem the_sky_is_falling : forall x : Empty_set, 2 + 2 = 5.
   destruct 1.
Qed.

Check Empty_set_ind.

Definition e2u (e : Empty_set) : unit := match e with end.

Inductive bool : Set :=
| true
| false
.

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

Definition negb' (b : bool) : bool :=
  if b then false else true
.

Definition negb'' (b : bool) : _ :=
  if b then false else true
.

Theorem negb_inverse : forall b : bool , negb (negb b) = b.
  destruct b; reflexivity.
Qed.

Theorem negb_inqe : forall b : bool, negb b <> b.
  destruct b; discriminate.
Qed.

Check bool_ind.

(* 3.3 Simple Recursive Types *)

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

Definition isZero (n : nat) : bool :=
  match n with
  | O => true
  | S _ => false
  end
.

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

Check pred.

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

Check plus.

Theorem O_plus_n : forall n : nat , plus O n = n.
  intro; reflexivity.
Qed.

Theorem n_plus_O : forall n : nat , plus n O = n.
                                      induction n.
                                      reflexivity.
                                      simpl.
                                      rewrite IHn.
                                      reflexivity.
Qed.

Theorem n_plus_O' : forall n : nat , plus n O = n.
  induction n; crush.
Qed.

Check nat_ind.

Theorem S_inj : forall n m : nat , S n = S m -> n = m.
  injection 1; trivial.
Qed.

(* Haskell extraction of a given function *)
Extraction Language Haskell.
Extraction "arith.hs" plus.

Inductive nat_list : Set :=
| NNil : nat_list
| NCons : nat -> nat_list -> nat_list
.

Fixpoint nlength (ls : nat_list) : nat :=
  match ls with
  | NNil => O
  | NCons _ ls' => S (nlength ls')
  end
.

Fixpoint napp (ls1 ls2 : nat_list) : nat_list :=
  match ls1 with
  | NNil => ls2
  | NCons n ls1' => NCons n (napp ls1' ls2)
  end
.

Theorem nlength_app : forall ls1 ls2 : nat_list ,
    nlength (napp ls1 ls2) = plus (nlength ls1) (nlength ls2).
      induction ls1; crush.
Qed.

Check nat_list_ind.

Inductive nat_btree : Set :=
| Leaf : nat_btree
| Node : nat_btree -> nat -> nat_btree -> nat_btree
.

Fixpoint size (tr : nat_btree) : nat :=
  match tr with
  | Leaf => S O
  | Node tr1 _ tr2 => plus (size tr1) (size tr2)
  end
.

Fixpoint splice (tr1 tr2 : nat_btree) : nat_btree :=
  match tr1 with
  | Leaf => Node tr2 O Leaf
  | Node tr1' n tr2' => Node (splice tr1' tr2) n tr2'
  end
.

Theorem plus_assoc : forall n1 n2 n3 : nat ,
    plus (plus n1 n2) n3 = plus n1 (plus n2 n3).
      induction n1; crush.
Qed.

Hint Rewrite n_plus_O plus_assoc.

Theorem size_splice : forall tr1 tr2 : nat_btree ,
    size (splice tr1 tr2) = plus (size tr2) (size tr1).
      induction tr1; crush.
Qed.

Check nat_btree_ind.

(* 3.4 Parameterized Types *)

(* Without section
Inductive list (T : Set) : Set :=
| Nil : list T
| Cons : T -> list T -> list T
.

Fixpoint length T (ls : list T) : nat :=
  match ls with
  | Nil => O
  | Cons _ ls' => S (length ls')
  end
.

(* Without implicit arguments
Fixpoint length T (ls : list T) : nat :=
  match ls with
  | Nil => O
  | Cons _ ls' => S (length _ ls')
  end
.
*)

Fixpoint app T (ls1 ls2 : list T) : list T :=
  match ls1 with
  | Nil => ls2
  | Cons x ls1' => Cons x (app ls1' ls2)
  end
.

Theorem length_app : forall T (ls1 ls2 : list T) ,
    length (app ls1 ls2) = plus (length ls1) (length ls2).
      induction ls1; crush.
Qed.
*)

Section list.
  Variable T : Set.

  Inductive list : Set :=
  | Nil : list
  | Cons : T -> list -> list
  .

  Fixpoint length (ls : list) : nat :=
    match ls with
    | Nil => O
    | Cons _ ls' => S (length ls')
    end.

  Fixpoint app (ls1 ls2 : list) : list :=
    match ls1 with
    | Nil => ls2
    | Cons x ls1' => Cons x (app ls1' ls2)
    end.

  Theorem length_app : forall ls1 ls2 : list,
      length (app ls1 ls2) = plus (length ls1) (length ls2).
        induction ls1; crush.
  Qed.
End list.

(*
Implicit Arguments Nil [T].
Warning: Implicit Arguments is deprecated; use Arguments instead
*)

Arguments Nil [T].

Print list.

Check length.

Check list_ind.

(* 3.5 Mutually Inductive Types *)

Inductive even_list : Set :=
| ENil : even_list
| ECons : nat -> odd_list -> even_list

with odd_list : Set :=
| OCons : nat -> even_list -> odd_list
.

Fixpoint elength (el : even_list) : nat :=
  match el with
  | ENil => O
  | ECons _ ol => S (olength ol)
  end

with olength (ol : odd_list) : nat :=
  match ol with
  | OCons _ el => S (elength el)
  end
.

Fixpoint eapp (el1 el2 : even_list) : even_list :=
  match el1 with
  | ENil => el2
  | ECons n ol => ECons n (oapp ol el2)
  end

with oapp (ol : odd_list) (el : even_list) : odd_list :=
  match ol with
  | OCons n el' => OCons n (eapp el' el)
  end
.
(*
Theorem elength_eapp : forall el1 el2 : even_list ,
    elength (eapp el1 el2) = plus (elength el1) (elength el2).
      induction el1; crush.
Abort.
*)
Check even_list_ind.

Scheme even_list_mut := Induction for even_list Sort Prop
with odd_list_mut := Induction for odd_list Sort Prop
.

Check even_list_mut.

Theorem elength_eapp : forall el1 el2 : even_list ,
    elength (eapp el1 el2) = plus (elength el1) (elength el2).
      apply (even_list_mut
               (fun el1 : even_list => forall el2 : even_list,
                    elength (eapp el1 el2) = plus (elength el1) (elength el2))
               (fun ol : odd_list => forall el : even_list,
                    olength (oapp ol el) = plus (olength ol) (elength el))); crush.
Qed.

(* 3.6 Reflexive Types *)

(*
A kind of inductive type called a reflexive type includes at least
one constructor that takes as an argument a function returning the
same tye we are defining.
*)

Inductive pformula : Set :=
| Truth : pformula
| Falsehood : pformula
| Conjuction : pformula -> pformula -> pformula
.

Fixpoint pformulaDenote (f : pformula) : Prop :=
  match f with
  | Truth => True
  | Falsehood => False
  | Conjuction f1 f2 => pformulaDenote f1 /\ pformulaDenote f2
  end
.

Inductive formula : Set :=
| Eq : nat -> nat -> formula
| And : formula -> formula -> formula
| Forall : (nat -> formula) -> formula (* Constructor which makes this type reflexive *)
.

Example forall_refl : formula := Forall (fun x =>  Eq x x).

Fixpoint formulaDenote (f : formula) : Prop :=
  match f with
  | Eq n1 n2 => n1 = n2
  | And f1 f2 => formulaDenote f1 /\ formulaDenote f2
  | Forall f' => forall n : nat, formulaDenote (f' n)
  end
.

Fixpoint swapper (f : formula) : formula :=
  match f with
  | Eq n1 n2 => Eq n2 n1
  | And f1 f2 => And (swapper f2) (swapper f1)
  | Forall f' => Forall (fun n => swapper (f' n))
  end
.

Theorem swapper_preserves_truth : forall f , formulaDenote f -> formulaDenote (swapper f).
   induction f; crush.
Qed.

Check formula_ind.

(*
Inductive term : Set :=
| App : term -> term -> term
| Abs : (term -> term) -> term
.
Error: Non strictly positive occurrence of "term" in "(term -> term) -> term".

Our candidate definition above violates the positivity requirement because it
involves an argument of type 'term -> term', where the type term that we are
defining appears to the left of an arrow. The candidate type of App is fine,
however, since every occurrence of term is either a consturctor argument or
the final result type.
*)

(* 3.7 An Interlude on Induction Principles *)

Print nat_ind.

Check nat_rect.

Print nat_rec.

Fixpoint plus_recursive (n : nat) : nat -> nat :=
  match n with
  | O => fun m => m
  | S n' => fun m => S (plus_recursive n' m)
  end
.

Definition plus_rec : nat -> nat -> nat :=
  nat_rec (fun _ : nat => nat -> nat) (fun m => m) (fun _ r m => S (r m))
.

Extraction "plus.hs" plus_rec.

Theorem plus_equivalent :
  plus_recursive = plus_rec.
    reflexivity.
Qed.

Print nat_rect.

Fixpoint nat_rect' (P : nat -> Type)
         (HO : P O)
         (HS : forall n , P n -> P (S n)) (n : nat) :=
  match n return P n with
  | O => HO
  | S n' => HS n' (nat_rect' P HO HS n')
  end
.

Section nat_ind'.
  Variable P : nat -> Prop.
  Hypothesis O_case : P O.
  Hypothesis S_case : forall n : nat , P n -> P (S n).
  Fixpoint nat_ind' (n : nat) : P n :=
    match n with
    | O => O_case
    | S n' => S_case (nat_ind' n')
    end
  .
End nat_ind'.

Print even_list_mut.

Section even_list_mut'.
  Variable Peven : even_list -> Prop.
  Variable Podd : odd_list -> Prop.
  Hypothesis ENil_case : Peven ENil.
  Hypothesis ECons_case : forall (n : nat) (o : odd_list) , Podd o -> Peven (ECons n o).
  Hypothesis OCons_case : forall (n : nat) (e : even_list) , Peven e -> Podd (OCons n e).
  Fixpoint even_list_mut' (e : even_list) : Peven e :=
    match e with
    | ENil => ENil_case
    | ECons n o => ECons_case n (odd_list_mut' o)
    end
  with
  odd_list_mut' (o : odd_list) : Podd o :=
    match o with
    | OCons n e => OCons_case n (even_list_mut' e)
    end.
End even_list_mut'.

Section formula_ind'.
  Variable P : formula -> Prop.
  Hypothesis Eq_case : forall n1 n2 : nat , P (Eq n1 n2).
  Hypothesis And_case : forall f1 f2 : formula,
      P f1 -> P f2 -> P (And f1 f2).
  Hypothesis Forall_case : forall f : nat -> formula ,
      (forall n : nat , P (f n)) -> P (Forall f).
  Fixpoint formula_ind' (f : formula) : P f :=
    match f with
    | Eq n1 n2 => Eq_case n1 n2
    | And f1 f2 => And_case (formula_ind' f1) (formula_ind' f2)
    | Forall f' => Forall_case f' (fun n => formula_ind' (f' n))
    end
  .
End formula_ind'.

(* 3.8 Nested Inductive Types *)

Inductive nat_tree : Set :=
| NNode' : nat -> list nat_tree -> nat_tree
.

Check nat_tree_ind.

Section All.
  Variable T : Set.
  Variable P : T -> Prop.
  Fixpoint All (ls : list T) : Prop :=
    match ls with
    | Nil => True
    | Cons h t => P h /\ All t
    end
  .
End All.

Print True.

Locate "/\".

Print and.

Section nat_tree_ind'.
  Variable P : nat_tree -> Prop.
  Hypothesis NNode'_case : forall (n : nat) (ls : list nat_tree) ,
      All P ls -> P (NNode' n ls).

  Fixpoint nat_tree_ind' (tr : nat_tree) : P tr :=
    match tr with
    | NNode' n ls =>
        NNode'_case n ls
          ((fix list_nat_tree_ind (ls : list nat_tree) : All P ls :=
             match ls with
             | Nil => I
             | Cons tr' rest => conj (nat_tree_ind' tr') (list_nat_tree_ind rest)
             end)
             ls)
    end.

End nat_tree_ind'.

Section map.
  Variables T T' : Set.
  Variable F : T -> T'.
  Fixpoint map(ls : list T) : list T' :=
    match ls with
    | Nil => Nil
    | Cons h t => Cons (F h) (map t)
    end.
End map.

Fixpoint sum (ls : list nat) : nat :=
  match ls with
  | Nil => O
  | Cons h t => plus h (sum t)
  end.

Fixpoint ntsize (tr : nat_tree) : nat :=
  match tr with
  | NNode' _ trs => S (sum (map ntsize trs))
  end.

Fixpoint ntsplice (tr1 tr2 : nat_tree) : nat_tree :=
  match tr1 with
  | NNode' n Nil => NNode' n (Cons tr2 Nil)
  | NNode' n (Cons tr trs) => NNode' n (Cons (ntsplice tr tr2) trs)
  end.

Lemma plus_S : forall n1 n2 : nat,
    plus n1 (S n2) = S (plus n1 n2).
      induction n1; crush.
Qed.

Hint Rewrite plus_S.

Theorem ntsize_ntsplice : forall tr1 tr2 : nat_tree ,
    ntsize (ntsplice tr1 tr2) = plus (ntsize tr2) (ntsize tr1).
      induction tr1 using nat_tree_ind'; crush.
      destruct ls; crush.
    Restart.
    Hint Extern 1 (ntsize (match ?LS with Nil => _ | Cons _ _ => _ end) = _) =>
    destruct LS; crush.
    induction tr1 using nat_tree_ind'; crush.
Qed.

(* 3.9 Manual Proofs About Constructors *)

Theorem true_neq_false :
  true <> false.
    red.
    intro H.
    Definition toProp (b : bool) := if b then True else False.
    change (toProp false).
    rewrite <- H.
    simpl.
    trivial.
Qed.

Theorem S_inj' : forall n m : nat ,
    S n = S m -> n = m.
                   intros n m H.
                   change (pred (S n) = pred (S m)).
                   rewrite H.
                   reflexivity.
Qed.


(* Module NatPlayground.
Inductive nat : Type :=
  | O
  | S (n : nat).

Inductive nat' : Type :=
  | stop
  | tick (foo : nat').

Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.
End NatPlayground.*)
Inductive bool : Type :=
  | true
  | false.

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.

Notation "x && y" := (andb x y).

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

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

(*Compute (mult 3 2).*)

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

(* Compute (factorial 3).*)

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

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

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

Definition ltb (n m: nat) : bool:=
  ((leb n m) && (negb (eqb n m))).

Theorem plus_O_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_id_example : forall n m:nat,
  n = m ->
  n + n = 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.
  rewrite -> H1.
  intros H2.
  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 plus_1_l : forall n:nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_S_1 : forall n m : nat,
  m = S n ->
  m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  rewrite <- plus_1_l.
  reflexivity. Qed.
  (* (N.b. This proof can actually be completed with tactics other than
     rewrite, but please do use rewrite for the sake of the exercise.) *)

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

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

Theorem andb_commutative :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c: bool,
  andb b c = true -> c = true.
Proof.
  intros b c H.
  destruct c eqn:Ec.
   { reflexivity. }
   { rewrite <- H.
      destruct b eqn:Eb.
      { reflexivity. }
      { reflexivity. } }
Qed.

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


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* * Shared libraries *)

(* ** Finitary sums and products over monoids *)

Require Import List Arith ZArith Lia.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list binomial.

Set Implicit Arguments.

Record monoid_theory (X : Type) (m : X -> X -> X) (u : X) := mk_monoid {
  monoid_unit_l : forall x, m u x = x;
  monoid_unit_r : forall x, m x u = x;
  monoid_assoc  : forall x y z, m x (m y z) = m (m x y) z;
}.

Fact Nat_plus_monoid : monoid_theory plus 0.
Proof. exists; intros; ring. Qed.

Fact Nat_mult_monoid : monoid_theory mult 1.
Proof. exists; intros; ring. Qed.

Fact Zplus_monoid : monoid_theory Zplus 0%Z.
Proof. exists; intros; ring. Qed.

Fact Zmult_monoid : monoid_theory Zmult 1%Z.
Proof. exists; intros; ring. Qed.

#[export] Hint Resolve Nat_plus_monoid Nat_mult_monoid
             Zplus_monoid Zmult_monoid : core.

Section msum.

  Variable (X : Type) (m : X -> X -> X) (u : X).

  Infix "⊕" := m (at level 50, left associativity).

  Fixpoint msum n f :=
    match n with
      | 0   => u
      | S n => f 0 ⊕ msum n (fun n => f (S n))
    end.

  Notation "∑" := msum.

  Fact msum_fold_map n f : ∑ n f = fold_right m u (map f (list_an 0 n)).
  Proof.
    revert f; induction n as [ | n IHn ]; intros f; simpl; f_equal; auto.
    rewrite IHn, <-  map_S_list_an, map_map; auto.
  Qed.

  Fact msum_0 f : ∑ 0 f = u.
  Proof. auto. Qed.

  Fact msum_S n f : ∑ (S n) f = f 0 ⊕ ∑ n (fun n => f (S n)).
  Proof. auto. Qed.

  Hypothesis Hmonoid : monoid_theory m u.

  Fact msum_1 f : ∑ 1 f = f 0.
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 H2 ].
    rewrite msum_S, msum_0, H2; auto.
  Qed.

  Fact msum_plus a b f : ∑ (a+b) f = ∑ a f ⊕ ∑ b (fun i => f (a+i)).
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 _ H3 ].
    revert f; induction a as [ | a IHa ]; intros f; simpl; auto.
    rewrite <- H3; f_equal; apply IHa.
  Qed.

  Fact msum_plus1 n f : ∑ (S n) f = ∑ n f ⊕ f n.
  Proof using Hmonoid.
    destruct Hmonoid as [ _ H2 _ ].
    replace (S n) with (n+1) by lia.
    rewrite msum_plus; simpl; f_equal.
    rewrite H2; f_equal; lia.
  Qed.

  Fact msum_ext n f g : (forall i, i < n -> f i = g i) -> ∑ n f = ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g Hfg; simpl; f_equal; auto.
    + apply Hfg; lia.
    + apply IHn; intros; apply Hfg; lia.
  Qed.

  Fact msum_unit n : ∑ n (fun _ => u) = u.
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 _ _ ].
    induction n as [ | n IHn ]; simpl; auto.
    rewrite IHn; auto.
  Qed.

  Fact msum_comm a n f : (forall i, i < n -> f i ⊕ a = a ⊕ f i) -> ∑ n f ⊕ a = a ⊕ ∑ n f.
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f; induction n as [ | n IHn ]; intros f H; simpl; auto.
    + rewrite H1, H2; auto.
    + rewrite H3, <- H; try lia.
      repeat rewrite <- H3; f_equal.
      apply IHn.
      intros; apply H; lia.
  Qed.

  Fact msum_sum n f g : (forall i j, i < j < n -> f j ⊕ g i = g i ⊕ f j) -> ∑ n (fun i => f i ⊕ g i) = ∑ n f ⊕ ∑ n g.
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 H2 H3 ].
    revert f g; induction n as [ | n IHn ]; intros f g H; simpl; auto.
    rewrite IHn.
    + repeat rewrite <- H3; f_equal.
      repeat rewrite H3; f_equal.
      symmetry; apply msum_comm.
      intros; apply H; lia.
    + intros; apply H; lia.
  Qed.

  Fact msum_of_unit n f : (forall i, i < n -> f i = u) -> ∑ n f = u.
  Proof using Hmonoid.
    intros H.
    rewrite <- (msum_unit n).
    apply msum_ext; auto.
  Qed.

  Fact msum_only_one n f i : i < n
                          -> (forall j, j < n -> i <> j -> f j = u)
                          -> ∑ n f = f i.
  Proof using Hmonoid.
    destruct Hmonoid as [ M1 M2 M3 ].
    intros H1 H2.
    replace n with (i + 1 + (n-i-1)) by lia.
    do 2 rewrite msum_plus.
    rewrite msum_of_unit, msum_1, msum_of_unit, M1, M2.
    + f_equal; lia.
    + intros j Hj; destruct (H2 (i+1+j)); auto; lia.
    + intros j Hj; destruct (H2 j); auto; lia.
  Qed.

  Fact msum_msum n k f :
          (forall i1 j1 i2 j2, i1 < n -> j1 < k -> i2 < n -> j2 < k -> f i1 j1 ⊕ f i2 j2 = f i2 j2 ⊕ f i1 j1)
       -> ∑ n (fun i => ∑ k (f i)) = ∑ k (fun j => ∑ n (fun i => f i j)).
  Proof using Hmonoid.
    revert k f; induction n as [ | n IHn ]; intros k f Hf.
    + rewrite msum_0, msum_of_unit; auto.
    + rewrite msum_S, IHn.
      * rewrite <- msum_sum.
        - apply msum_ext.
          intros; rewrite msum_S; trivial.
        - intros; symmetry; apply msum_comm.
          intros; apply Hf; lia.
      * intros; apply Hf; lia.
  Qed.

  Fact msum_ends n f : (forall i, 0 < i <= n -> f i = u) -> ∑ (n+2) f = f 0 ⊕ f (S n).
  Proof using Hmonoid.
    destruct Hmonoid as [ H1 H2 H3 ].
    intros H.
    replace (n+2) with (1 + n + 1) by lia.
    do 2 rewrite msum_plus; simpl.
    rewrite msum_of_unit.
    + rewrite H2, H2, H2; do 2 f_equal; lia.
    + intros; apply H; lia.
  Qed.

  Fact msum_first_two n f : 2 <= n -> (forall i, 2 <= i -> f i = u) -> ∑ n f = f 0 ⊕ f 1.
  Proof using Hmonoid.
    destruct Hmonoid as [ _ M2 _ ].
    intros Hn H1.
    destruct n as [ | [ | n ] ]; try lia.
    do 2 rewrite msum_S.
    rewrite msum_of_unit.
    + rewrite M2; trivial.
    + intros; apply H1; lia.
  Qed.

  Definition mscal n x := msum n (fun _ => x).

  Fact mscal_0 x : mscal 0 x = u.
  Proof. apply msum_0. Qed.

  Fact mscal_S n x : mscal (S n) x = x ⊕ mscal n x.
  Proof. apply msum_S. Qed.

  Fact mscal_1 x : mscal 1 x = x.
  Proof using Hmonoid.
    destruct Hmonoid as [ _ H2 _ ].
    rewrite mscal_S, mscal_0, H2; trivial.
  Qed.

  Fact mscal_of_unit n : mscal n u = u.
  Proof using Hmonoid. apply msum_of_unit; auto. Qed.

  Fact mscal_plus a b x : mscal (a+b) x = mscal a x ⊕ mscal b x.
  Proof using Hmonoid. apply msum_plus. Qed.

  Fact mscal_plus1 n x : mscal (S n) x = mscal n x ⊕ x.
  Proof using Hmonoid. apply msum_plus1. Qed.

  Fact mscal_comm n x y : x ⊕ y = y ⊕ x -> mscal n x ⊕ y = y ⊕ mscal n x.
  Proof using Hmonoid. intros H; apply msum_comm; auto. Qed.

  Fact mscal_sum n x y : x ⊕ y = y ⊕ x -> mscal n (x ⊕ y) = mscal n x ⊕ mscal n y.
  Proof using Hmonoid. intro; apply msum_sum; auto. Qed.

  Fact mscal_mult a b x : mscal (a*b) x = mscal a (mscal b x).
  Proof using Hmonoid.
    induction a as [ | a IHa ]; simpl.
    + do 2 rewrite mscal_0; auto.
    + rewrite mscal_plus, IHa, mscal_S; auto.
  Qed.

  Fact msum_mscal n k f : (forall i j, i < n -> j < n -> f i ⊕ f j = f j ⊕ f i)
                       -> ∑ n (fun i => mscal k (f i)) = mscal k (∑ n f).
  Proof using Hmonoid. intros H; apply msum_msum; auto. Qed.

End msum.

Section msum_morphism.

  Variable (X Y : Type) (m1 : X -> X -> X) (u1 : X)
                        (m2 : Y -> Y -> Y) (u2 : Y)
           (H1 : monoid_theory m1 u1)
           (H2 : monoid_theory m2 u2)
           (phi : X -> Y)
           (Hphi1 : phi u1 = u2)
           (Hphi2 : forall x y, phi (m1 x y) = m2 (phi x) (phi y)).

  Fact msum_morph n f : phi (msum m1 u1 n f) = msum m2 u2 n (fun x => phi (f x)).
  Proof using Hphi1 Hphi2.
    revert f; induction n as [ | n IHn ]; intros f; simpl; auto.
    rewrite Hphi2, IHn; trivial.
  Qed.

  Fact mscal_morph n x : phi (mscal m1 u1 n x) = mscal m2 u2 n (phi x).
  Proof using Hphi1 Hphi2. apply msum_morph. Qed.

End msum_morphism.

Section binomial_Newton.

  Variable (X : Type) (sum times : X -> X -> X) (zero one : X).

  Infix "⊕" := sum (at level 50, left associativity).
  Infix "⊗" := times (at level 40, left associativity).

  Notation z := zero.
  Notation o := one.

  Notation scal := (mscal sum zero).
  Notation expo := (mscal times one).

  Hypothesis (M_sum : monoid_theory sum zero)
             (sum_comm : forall x y, x ⊕ y = y ⊕ x)
             (sum_cancel : forall x u v, x ⊕ u = x ⊕ v -> u = v)
             (M_times : monoid_theory times one)
             (distr_l : forall x y z, x ⊗ (y⊕z) = x⊗y ⊕ x⊗z)
             (distr_r : forall x y z, (y⊕z) ⊗ x = y⊗x ⊕ z⊗x).

  Fact times_zero_l x : z ⊗ x = z.
  Proof using M_sum M_times sum_cancel distr_r.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (z⊗x).
    rewrite S2, <- distr_r, S1; trivial.
  Qed.

  Fact times_zero_r x : x ⊗ z = z.
  Proof using M_sum M_times sum_cancel distr_l.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    apply sum_cancel with (x⊗z).
    rewrite S2, <- distr_l, S1; trivial.
  Qed.

  Notation "∑" := (msum sum zero).

  Fact sum_0n_scal n k f : ∑ n (fun i => scal k (f i)) = scal k (∑ n f).
  Proof using M_sum sum_comm. apply msum_mscal; auto. Qed.

  Fact scal_times k x y : scal k (x⊗y) = x⊗scal k y.
  Proof using M_sum M_times sum_cancel distr_l.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, mscal_0, times_zero_r; auto.
    + rewrite mscal_S, mscal_S, IHk, distr_l; auto.
  Qed.

  Fact scal_one_comm k x : scal k o ⊗ x = x ⊗ scal k o.
  Proof using M_sum M_times sum_cancel distr_r distr_l.
    destruct M_times as [ T1 T2 T3 ].
    induction k as [ | k IHk ].
    + rewrite mscal_0, times_zero_l, times_zero_r; auto.
    + rewrite mscal_S, distr_l, distr_r; f_equal; auto.
      rewrite T1, T2; auto.
  Qed.

  Corollary scal_one k x : scal k x = scal k o ⊗ x.
  Proof using M_sum M_times sum_cancel distr_r distr_l.
    destruct M_times as [ T1 T2 T3 ].
    rewrite <- (T2 x) at 1.
    rewrite scal_times.
    symmetry; apply scal_one_comm.
  Qed.

  Fact sum_0n_distr_l b n f : ∑ n (fun i => b⊗f i) = b⊗∑ n f.
  Proof using M_sum M_times sum_cancel distr_l.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_r; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_l; auto.
  Qed.

  Fact sum_0n_distr_r b n f : ∑ n (fun i => f i⊗b) = ∑ n f ⊗ b.
  Proof using M_sum M_times sum_cancel distr_r.
    revert f; induction n as [ | n IHn ]; intros f.
    + do 2 rewrite msum_0; rewrite times_zero_l; auto.
    + do 2 rewrite msum_S; rewrite IHn, distr_r; auto.
  Qed.

  (*   Newton Binomial theorem for (X,⊕,z,⊗,o) where
          1) (X,⊕,z) is a cancellative commutative monoid
          2) (X,⊗,o) is a monoid
          3) ⊗ distributes over ⊕ on the left and one the right

        cancellative could be weakened into z is left and right
        absorbing for ⊗, ie a⊗z = z⊗a = z

   *)

  Theorem binomial_Newton n a b :
        a ⊗ b = b ⊗ a
     -> expo n (a ⊕ b) = ∑ (S n) (fun i => scal (binomial n i) (expo (n - i) a ⊗ expo i b)).
  Proof using All.
    destruct M_sum as [ S1 S2 S3 ].
    destruct M_times as [ T1 T2 T3 ].
    intros Hab; induction n as [ | n IHn ].
    + rewrite mscal_0, msum_S, msum_0; simpl.
      rewrite mscal_0, mscal_0, mscal_1; auto.
      rewrite S2, T1; auto.
    + rewrite msum_S with (n := S n), binomial_n0, mscal_1; auto.
      rewrite mscal_0, Nat.sub_0_r; auto.
      rewrite T2.
      rewrite msum_ext with (g := fun i => b ⊗ scal (binomial n i) (expo (n-i) a ⊗ expo i b)
                                         ⊕ a ⊗ scal (binomial n (S i)) (expo (n-S i) a ⊗ expo (S i) b)).
      2: { intros; rewrite binomial_SS, mscal_plus; auto.
           replace (S n - S i) with (n-i) by lia; f_equal.
           * rewrite mscal_S.
             do 3 rewrite scal_times.
             do 2 rewrite T3; f_equal.
             apply mscal_comm; auto.
           * destruct (le_lt_dec n i).
             + rewrite binomial_gt; try lia.
               do 2 rewrite mscal_0.
               rewrite times_zero_r; auto.
             + replace (n - i) with (S (n - S i)) by lia.
               rewrite mscal_S.
               repeat rewrite scal_times.
               repeat rewrite T3; auto. }
      rewrite msum_sum; auto.
      do 2 rewrite sum_0n_distr_l.
      rewrite <- IHn.
      rewrite msum_plus1, binomial_gt; auto.
      rewrite mscal_0, S2.
      generalize (msum_S sum z n (fun i => scal (binomial n i) (expo (n-i) a ⊗ expo i b))); intros H.
      rewrite Nat.sub_0_r, binomial_n0, mscal_1, mscal_0, T2 in H; auto.
      rewrite S3, (sum_comm (expo _ _)), <- S3.
      rewrite mscal_S with (x :=a), <- distr_l, <- H, <- IHn.
      rewrite mscal_S, distr_r.
      apply sum_comm.
  Qed.

End binomial_Newton.

Section Newton_nat.

  Notation power := (mscal mult 1).
  Notation "∑" := (msum plus 0).

  Fact sum_fold_map n f : ∑ n f = fold_right plus 0 (map f (list_an 0 n)).
  Proof. apply msum_fold_map. Qed.

  Fact power_0 x : power 0 x = 1.
  Proof. apply mscal_0. Qed.

  Fact power_S n x : power (S n) x = x * power n x.
  Proof. apply mscal_S. Qed.

  Fact power_1 x : power 1 x = x.
  Proof. apply mscal_1, Nat_mult_monoid. Qed.

  Fact power_of_0 n : 0 < n -> power n 0 = 0.
  Proof. destruct n; try lia; rewrite power_S; auto. Qed.

  Fact power_of_1 n : power n 1 = 1.
  Proof. rewrite mscal_of_unit; auto. Qed.

  Fact power_plus p a b : power (a+b) p = power a p * power b p.
  Proof. apply mscal_plus, Nat_mult_monoid. Qed.

  Fact power_mult p a b : power (a*b) p = power a (power b p).
  Proof. apply mscal_mult; auto. Qed.

  Fact power_ge_1 k p : p <> 0 -> 1 <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + rewrite power_S.
      apply (Nat.mul_le_mono 1 _ 1); lia.
  Qed.

  Fact power2_gt_0 n : 0 < power n 2.
  Proof. apply power_ge_1; discriminate. Qed.

  Fact power_sinc k p : 2 <= p -> power k p < power (S k) p.
  Proof.
    intros Hp; rewrite power_S.
    rewrite <- (Nat.mul_1_l (power k p)) at 1.
    apply Nat.mul_lt_mono_pos_r; try lia.
    apply power_ge_1; lia.
  Qed.

  Fact power_ge_n k p : 2 <= p -> k <= power k p.
  Proof.
    intros Hp.
    induction k as [ | k IHk ].
    + rewrite power_0; auto.
    + apply Nat.le_lt_trans with (2 := power_sinc _ Hp); auto.
  Qed.

  Fact power_mono_l p q x : 1 <= x -> p <= q -> power p x <= power q x.
  Proof.
    intros Hx.
    induction 1 as [ | q H IH ]; auto.
    apply Nat.le_trans with (1 := IH).
    rewrite power_S.
    rewrite <- (Nat.mul_1_l (power _ _)) at 1.
    apply Nat.mul_le_mono; auto.
  Qed.

  Definition power_mono := power_mono_l.

  Fact power_smono_l p q x : 2 <= x -> p < q -> power p x < power q x.
  Proof.
    intros H1 H2.
    apply Nat.lt_le_trans with (1 := power_sinc _ H1).
    apply power_mono_l; lia.
  Qed.

  Fact power_mono_r n p q : p <= q -> power n p <= power n q.
  Proof.
    intros H.
    induction n as [ | n IHn ].
    + do 2 rewrite power_0; auto.
    + do 2 rewrite power_S; apply Nat.mul_le_mono; auto.
  Qed.

  Fact power_0_inv p n : power p n = 0 <-> n = 0 /\ 0 < p.
  Proof.
    induction p as [ | p IHp ].
    + rewrite power_0; lia.
    + rewrite power_S; split.
      * intros H.
        apply Nat.eq_mul_0 in H.
        rewrite IHp in H; lia.
      * intros (?&?); subst; simpl; auto.
  Qed.

  Fact plus_cancel_l : forall a b c, a + b = a + c -> b = c.
  Proof. intros; lia. Qed.

  Let plus_cancel_l':= plus_cancel_l.

  Fact sum_0n_scal_l n k f : ∑ n (fun i => k*f i) = k*∑ n f.
  Proof.
    apply sum_0n_distr_l with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_scal_r n k f : ∑ n (fun i => (f i)*k) = (∑ n f)*k.
  Proof.
    apply sum_0n_distr_r with (3 := Nat_mult_monoid); auto.
    intros; ring.
  Qed.

  Fact sum_0n_mono n f g : (forall i, i < n -> f i <= g i) -> ∑ n f <= ∑ n g.
  Proof.
    revert f g; induction n as [ | n IHn ]; intros f g H.
    + do 2 rewrite msum_0; auto.
    + do 2 rewrite msum_S; apply Nat.add_le_mono.
      * apply H; lia.
      * apply IHn; intros; apply H; lia.
  Qed.

  Fact sum_0n_le_one n f i : i < n -> f i <= ∑ n f.
  Proof.
    revert f i; induction n as [ | n IHn ]; intros f i H.
    + lia.
    + rewrite msum_S.
      destruct i as [ | i ]; try lia.
      apply Nat.succ_lt_mono, IHn with (f := fun i => f (S i)) in H.
      lia.
  Qed.

  Fact sum_power_lt k n f : k <> 0 -> (forall i, i < n -> f i < k) -> ∑ n (fun i => f i * power i k) < power n k.
  Proof.
    intros Hk.
    revert f; induction n as [ | n IHn ]; intros f Hf.
    + rewrite msum_0, power_0; lia.
    + rewrite msum_S, power_S, power_0, Nat.mul_1_r.
      apply Nat.le_trans with (k+ k * (power n k-1)).
      * apply (@Nat.add_le_mono (S (f 0))).
        - apply Hf; lia.
        - rewrite msum_ext with (g := fun i => k*(f (S i)*power i k)).
          ++ rewrite sum_0n_distr_l with (one := 1); auto; try (intros; ring).
             apply Nat.mul_le_mono_l.
             apply le_S_n, Nat.le_trans with (power n k); try lia.
             apply IHn; intros; apply Hf; lia.
          ++ intros; rewrite power_S; ring.
      * generalize (power_ge_1 n Hk); intros ?.
        replace (power n k) with (1+(power n k - 1)) at 2 by lia.
        rewrite Nat.mul_add_distr_l.
        apply Nat.add_le_mono; lia.
  Qed.

  Theorem Newton_nat a b n :
       power n (a + b) = ∑ (S n) (fun i => binomial n i * power (n - i) a * power i b).
  Proof.
    rewrite binomial_Newton with (1 := Nat_plus_monoid) (4 := Nat_mult_monoid); try (intros; ring); auto.
    apply msum_ext; intros i Hi.
    rewrite scal_one with (1 := Nat_plus_monoid) (3 := Nat_mult_monoid); auto; try (intros; ring).
    rewrite <-Nat.mul_assoc; f_equal; auto.
    generalize (binomial n i); intros k.
    induction k as [ | k IHk ].
    + rewrite mscal_0; auto.
    + rewrite mscal_S, IHk; auto; apply plus_cancel_l.
  Qed.

  Theorem Newton_nat_S a n :
       power n (1 + a) = ∑ (S n) (fun i => binomial n i * power i a).
  Proof.
    rewrite Newton_nat.
    apply msum_ext.
    intros; rewrite power_of_1; ring.
  Qed.

  Lemma binomial_le_power n i : binomial n i <= power n 2.
  Proof.
    destruct (le_lt_dec i n) as [ Hi | Hi ].
    + change 2 with (1+1).
      rewrite Newton_nat_S.
      eapply Nat.le_trans.
      2:{ apply sum_0n_le_one with (f := fun i => binomial n i * power i 1).
          apply le_n_S, Hi. }
      rewrite power_of_1; lia.
    + rewrite binomial_gt; auto; lia.
  Qed.

  Corollary binomial_lt_power n i : binomial n i < power (S n) 2.
  Proof.
    apply Nat.le_lt_trans with (1 := binomial_le_power _ _), power_sinc; auto.
  Qed.

End Newton_nat.


Require Import ZArith.
Require Import PolTac.

Open Scope Z_scope.

Theorem pols_test1: forall (x y : Z), x < y ->  (x + x < y + x).
intros.
pols.
auto.
Qed.

Theorem pols_test2: forall (x y : Z), y < 0 ->  (x + y < x).
intros.
pols.
auto.
Qed.

Theorem pols_test3: forall (x y : Z), 0 < y * y ->  ((x + y) * (x - y) < x * x).
intros.
pols.
auto with zarith.
Qed.

Theorem pols_test4:
 forall (x y : Z),
 x * x  < y * y ->  ((x + y) * (x + y) < 2 * (x * y + y * y)).
intros.
pols.
auto.
Qed.

Theorem pols_test5:
 forall x y z, x + y * (y + z) = 2 * z ->  2 * x + y * (y + z) = (x + z) + z.
intros.
pols.
auto.
Qed.

Theorem polf_test1: forall x y, (0 <= x -> 1 <= y -> x  <= x  * y)%Z.
intros.
polf.
Qed.

Theorem polf_test2: forall x y, (0 < x -> x  <= x  * y -> 1 <= y)%Z.
intros.
hyp_polf H0.
Qed.

Theorem polr_test1: forall x y z, (x + z) < y -> x + y + z < 2*y.
intros x y z H.
polr H.
pols.
auto.
pols.
auto with zarith.
Qed.


Require Export BasicTypes.
(* Primal field arithmetics. *)
Definition P_add (p x y : N) :=
  (x + y) mod p.

Definition P_mul (p x y : N) :=
  (x * y) mod p.

Definition P_opp (p x : N) :=
  (p - (x mod p)) mod p.

Definition P_sub (p x y : N) :=
  P_add p x (P_opp p y).

Definition P_sq (p x : N) :=
  (N.square x) mod p.

(*B.1.1*)
Fixpoint power_tail (g : N)(e : bL)(q : N)(sq : N -> N)
  (mp : N ->  N -> N)(acc : N) : N :=
  match e with
  | [] => acc
  | h :: tl =>
      power_tail g tl q sq mp
      match h with
      | true => (mp (sq acc) g)
      | false => (sq acc)
      end
  end.

(* Returns g ^ a, q is the size of the field *)
Definition power_general (g : N)(a : N)(q : N)(sq : N -> N)
  (mp : N -> N -> N)  : N :=
  let e := N.modulo a (q - 1) in
  power_tail g (NtobL e) q sq mp 1.

(*TODO added mod p for convenience of proof. Should remove it. *)
Definition P_pow (p : N)(g : N)(a : N) : N :=
  (power_general g a p (P_sq p) (P_mul p)) mod p.

(* B.1.2 *)
Definition P_inv (p g : N) :=
  P_pow p g (p - 2).
Definition P_div (p : N)(x : N)(y : N) : N :=
  P_mul p x (P_inv p y).

(*4.2.5*)
(*Inductive field_type : Set :=
  pri : field_type | ext : field_type .*)
(* The order of a primal field, a prime number greater than 3 *)
Record prime_order : Type := mkpo {order : N; gt3 : order > 3 }.

(* The type of an element in F_p *)
Record Fpe (po : prime_order) : Type :=
  mkFpe {val : N; inrng : val < order po}.
(* The type of an element in F_2m *)
Record Fbe (len : N) : Type := mkFbe {num : N; inlen : N.size num <= len}.

(* U is the type of field elements. id0 is the identity of addition.
id1 is the identity of multiplication. wrp is wrapper from N to U and
uwp is the unwrapper. The rest are operators on the field.  *)
Class ECField (U: Type) : Type := mkField {wrp : N -> U; uwp : U -> N;
  id0 : U; id1 : U; eql : U -> U -> bool; opp : U -> U;
     inv : U -> U; add : U -> U -> U; sub : U -> U -> U;
       mul : U -> U -> U; div : U -> U -> U; dbl : U -> U;
         squ : U -> U; pow : U -> N -> U}.
Definition wrapper {U : Type}(fd : ECField U):= @wrp _ fd.
Definition unwrapper {U : Type}(fd : ECField U):= @uwp _ fd.

Section inrng_sec.
Context (po : prime_order).
Lemma mod_inrng (a : N) :
a mod (order po) < (order po).
Proof.
intros.
destruct po as [p H].
assert (H0: p <> 0). {
inversion H. unfold not. unfold eq.
intros. rewrite H0 in H1. inversion H1.
}
apply mod_lt. apply H0.
Qed.

Definition pfe_builder (n : N) : Fpe po :=
  mkFpe po (n mod (order po)) (mod_inrng n).

Lemma add_inrng (x y : Fpe po) :
P_add (order po) (val po x) (val po y) < (order po).
Proof. apply mod_inrng. Qed.

Lemma opp_inrng (x : Fpe po) :
P_opp (order po) (val po x) < (order po).
Proof. apply mod_inrng. Qed.

Lemma sub_inrng (x y : Fpe po) :
P_sub (order po) (val po x) (val po y) < (order po).
Proof. apply mod_inrng. Qed.

Lemma dbl_inrng (x : Fpe po) :
(N.double  (val po x)) mod (order po) < (order po).
Proof. apply mod_inrng. Qed.

Lemma sq_inrng (x : Fpe po) :
P_sq (order po) (val po x) < (order po).
Proof. apply mod_inrng. Qed.

Lemma pow_inrng (g : Fpe po)(a : N):
P_pow (order po) (val po g) a < (order po).
Proof. apply mod_inrng. Qed.

Lemma mul_inrng (x y : Fpe po) :
P_mul (order po) (val po x) (val po y) < (order po).
Proof. apply mod_inrng. Qed.

Lemma div_inrng (x y : Fpe po) :
P_div (order po) (val po x) (val po y) < (order po).
Proof. apply mod_inrng. Qed.

Lemma inv_inrng (x : Fpe po) :
P_inv (order po) (val po x) < (order po).
Proof. apply mod_inrng. Qed.

Definition po_eq (x y : Fpe po) : bool :=
(val po x) =? (val po y).
Definition po_add (x y : Fpe po) : Fpe po :=
  mkFpe po (P_add (order po) (val po x) (val po y)) (add_inrng x y).
Definition po_sub (x y : Fpe po) : Fpe po :=
  mkFpe po (P_sub (order po) (val po x) (val po y)) (sub_inrng x y).
Definition po_mul (x y : Fpe po) : Fpe po :=
  mkFpe po (P_mul (order po) (val po x) (val po y)) (mul_inrng x y).
Definition po_div (x y : Fpe po) : Fpe po :=
  mkFpe po (P_div (order po) (val po x) (val po y)) (div_inrng x y).
Definition po_opp (x : Fpe po) : Fpe po :=
  mkFpe po (P_opp (order po) (val po x)) (opp_inrng x).
Definition po_inv (x : Fpe po) : Fpe po :=
  mkFpe po (P_inv (order po) (val po x)) (inv_inrng x).
Definition po_dbl (x : Fpe po) : Fpe po :=
  mkFpe po ( (N.double (val po x)) mod (order po) ) (dbl_inrng x).
Definition po_sq (x : Fpe po) : Fpe po :=
  mkFpe po (P_sq (order po) (val po x)) (sq_inrng x).
Definition po_pow (g : Fpe po)(a : N) : Fpe po :=
  mkFpe po (P_pow (order po) (val po g) a) (pow_inrng g a).
End inrng_sec.

(* TODO Consider make pf_builder a constructor of ECField *)
(* : ECField (Fpe {| order := p; gt3 := gt3 |})*)
Definition pf_builder (p : N)(gt3 : p > 3) :=
let po := mkpo p gt3 in
let U := Fpe po in
mkField U (pfe_builder po) (val po)
(pfe_builder po 0) (pfe_builder po 1) (po_eq po)
(po_opp po) (po_inv po) (po_add po) (po_sub po) (po_mul po)
  (po_div po) (po_dbl po) (po_sq po) (po_pow po).

Inductive FieldType : Type := primal_field | binary_field.

(*
Context {fd : ECField}
Definition u := U fd.
Definition wp : N -> u := wrp fd.
Definition uw : u -> N := uwp fd.
Definition i0 := id0 fd.
Definition i1 := id1 fd.
Definition eq : u -> u -> bool := eql fd.
Definition eq0 := eq i0.
Definition op := opp fd.
Definition iv := inv fd.
Definition ad := add fd.
Definition sb := sub fd.
Definition ml := mul fd.
Definition dv := div fd.
Definition sq := squ fd.
Definition db := dbl fd.
Definition pw := pow fd.

Notation "- x" := (op x).
Infix "+" := ad.
Infix "-" := sb.
Infix "*" := ml.
Infix "/" := dv.
Infix "^" := pw.
Infix "=?" := eq.
*)
Declare Scope ecfield_scope.
Open Scope ecfield_scope.
Notation "- x" := (opp x) : ecfield_scope.
Infix "+" := add : ecfield_scope.
Infix "-" := sub : ecfield_scope.
Infix "*" := mul : ecfield_scope.
Infix "/" := div : ecfield_scope.
Infix "^" := pow : ecfield_scope.
Infix "=?" := eql : ecfield_scope.
(* Regular Condition on Primal Fields *)
Definition pf_rgl_cdt {U : Type}{_ : ECField U}(a b : U) : Prop :=
  let (f4, f27) := (wrp 4, wrp 27) in
    f4 * a^3 + f27 * (squ b) =? id0 = false.
(*Definition pf_rgl_cdt {U : Type}{_ : ECField U}(a b : U) : Prop :=
  let (f4, f27) := (wrp 4, wrp 27) in
  let ad1 := f4 * (a^3) in
  let ad2 := f27 * (squ b) in
    ad1 + ad2 =? id0 = false. *)

Inductive ECurve {U : Type}{fd : ECField U} : Type :=
  | pf_curve (a b : U) (rgl : pf_rgl_cdt a b).
  (*| bf_curve (a b : U) (rgl : b =? id0 = false) *)

(*
Inductive EC_Field : Type :=
  | primal : ECField -> EC_Field
  | binary : ECField -> EC_Field.
*)
(* Same as NtoBL *)
(*Definition FieldtoBL_p (fd : ECField)(ele : U fd) :=
  NtoBL (uwr fd ele). *)
(*Definition FieldtoBL_p := NtoBL.

Definition FieldtoBL_b (m : N) :=
  NtoBL_len (N.to_nat (div_ceil_N m 8)). *)

Definition FieldtoBL {U : Type}{fd : ECField U}(ele : U) := NtoBL (uwp ele).
Definition FieldtobL {U : Type}{fd : ECField U}(ele : U) := NtoBbL (uwp ele).

(*4.2.6*)
Definition BLtoField {U : Type}{fd : ECField U}(p : N)(Bl : BL) : option U :=
  let alpha := BLtoN Bl in
  if leb p alpha then None else
    Some (wrapper fd alpha). (*TODO bf case*)

(*Definition BLtoField_p (Bl : BL)(q : N) : option N :=
  (fun (alpha : N)  => if leb q alpha then None else Some alpha) (BLtoN Bl).

Definition BLtoField_b (Bl : BL)(m : N) : option N :=
  BLtoField_p Bl (N.shiftl 1 m). *)

(*
Definition BLtoField_b (Bl : BL) : bL :=
  BLtobL Bl.
*)

(*4.2.7*)
(* Still no need to convert since we are using N *)
(*
Definition FieldtoN_m (alpha : bL) : N :=
  bLtoN alpha.
  *)

Close Scope list_scope.


Require Import List.
Import ListNotations.

Notation "'existsT' x .. y , p" :=
  (sigT (fun x => .. (sigT (fun y => p)) ..))
    (at level 200, x binder, right associativity,
     format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'") : type_scope.
(* http://www.cs.nott.ac.uk/~pszgmh/fold.pdf *)

(* Changing Haskell List function into Inductive data type, sort of Relational programming *)
Module Haskellfun.
  Section Hfold.

    Fixpoint fold (A B : Type) (f : A -> B -> B) (b : B) (l : list A) : B :=
      match l with
      | [] => b
      | h :: tl => f h (fold A B f b tl)
      end.

    Inductive foldind (A B : Type) (f : A -> B -> B) (b : B) : list A -> B -> Type :=
    | Basecase  : foldind A B f b [] b
    | Conscase b' h tl : foldind A B f b tl b' -> foldind A B f b (h :: tl) (f h b').

    Lemma same_fold_foldind :
      forall (A B : Type) (f : A -> B -> B) (b : B) (l : list A),
        foldind A B f b l (fold A B f b l).
    Proof.
      refine (fun A B f b =>
                fix Fn l :=
                match l with
                | [] => Basecase A B f b (* Base case *)
                | h :: tl => _ (* Cons case *)
                end).
      cbn. eapply Conscase. apply Fn.
    Qed.

    Lemma same_fold_foldind_proof :
      forall (A B : Type) (f : A -> B -> B) (b : B) (l : list A) (v : B),
        foldind A B f b l v -> v = fold A B f b l.
    Proof.
      refine (fun A B f b =>
                fix Fn l :=
                match l with
                | [] => fun v Hi => _
                | h :: tl => fun v Hi => _
                end).
      inversion Hi; cbn; reflexivity.
      inversion Hi; subst; cbn; f_equal;
        apply Fn; assumption.
    Qed.

    Lemma fold_fun_correctness :
      forall (A B : Type) (f : A -> B -> B) (l : list A) (b v : B),
        v = fold A B f b l -> foldind A B f b l v.
    Proof.
      refine (fun A B f =>
                fix Fn l :=
                match l with
                | [] => fun b v Hv => _
                | h :: t => fun b v Hv => _
                end).
      subst; cbn; eapply Basecase.
      subst; cbn; eapply Conscase; auto.
    Qed.

  End Hfold.

  Section Htakewhile.

    Fixpoint takewhile (A : Type) (p : A -> bool) (l : list A) : list A :=
      match l with
      | [] => []
      | h :: t => if p h then h :: takewhile A p t else []
      end.

    (* constant space *)
    Fixpoint takewhile_acc (A : Type) (p : A -> bool) (l acc : list A) :=
      match l with
      | [] => List.rev acc
      | h :: tl => if p h then takewhile_acc A p tl (h :: acc)
                  else List.rev acc
      end.

    Lemma same_takewhile_acc :
      forall (A : Type) (p : A -> bool) (l acc : list A),
        takewhile_acc A p l acc = List.rev acc ++ takewhile A p l.
    Proof.
      intros A p.
      induction l.
      + cbn. intro acc.  rewrite app_nil_r.
        auto.
      + cbn. intro acc. case_eq (p a); intro Pa.
        ++ rewrite IHl. cbn.
           rewrite <-  app_assoc.
           auto.
        ++ rewrite app_nil_r. auto.
    Qed.

    (* Turing takewhile_acc into relation.
       R : l -> acc -> takewhile_acc A p l acc *)
    Inductive Takewhileind (A : Type) (p : A -> bool) : list A -> list A -> list A -> Prop :=
    | TBasecase acc : Takewhileind A p [] acc acc
    | TTruecase h tl acc ts : p h = true -> Takewhileind A p tl (h :: acc) ts ->
                              Takewhileind A p (h :: tl) acc ts
    | TFalsecase h tl acc : p h = false -> Takewhileind A p (h :: tl) acc acc.

    Lemma same_takewhile_takewhileind :
      forall (A : Type) (p : A -> bool) (l acc : list A),
        Takewhileind A p l acc (List.rev (takewhile_acc A p l acc)).
    Proof.
      intros A p.
      induction l.
      + cbn; intros acc.
        rewrite rev_involutive.
        constructor.
      + cbn; intros acc.
        case_eq (p a); intros Pa.
        constructor 2. auto.
        apply IHl.
        rewrite rev_involutive. constructor 3.
        auto.
    Qed.

  End  Htakewhile.

  Section Hdropwhile.

    Fixpoint dropWhile (A : Type) (p : A -> bool) (l : list A) : list A :=
      match l with
      | [] => []
      | h :: tl => if p h then dropWhile A p tl else h :: tl
      end.

    Inductive Dropwhileind (A : Type) (p : A -> bool) : list A -> list A -> Prop :=
    | DBasecase : Dropwhileind A p [] []
    | DTruecase h tl t : p h = true ->  Dropwhileind A p tl t ->   Dropwhileind A p (h :: tl) t
    | DFalsecase h t : p h = false -> Dropwhileind A p (h :: t) (h :: t).

    Lemma same_drop_caitlin_convinced_and_smiling :
      forall (A : Type) (p : A -> bool) l, Dropwhileind A p l (dropWhile A p l).
    Proof.
      intros A p.
      induction l.
      + cbn. constructor 1.
      + cbn. case_eq (p a); intros Pa.
        eapply DTruecase. auto. auto.
        constructor 3.  auto.
    Qed.

  End Hdropwhile.

  Section Hintersperse.

    Fixpoint intersperse (A : Type) (c : A) (l : list A) : list A :=
      match l with
      | [] => []
      | [h] => [h]
      | h :: t => h :: c :: intersperse _ c t
      end.

    Fixpoint intersperse_acc (A : Type) (c : A) (l : list A) (acc : list A) : list A :=
      match l with
      | [] => acc
      | [h] => acc ++ [h]
      | h :: t => intersperse_acc A c t (acc ++ [h; c])
      end.

    Eval cbn in intersperse_acc nat 0 [1; 2; 3; 4] []. (*  [1; 0; 2; 0; 3; 0; 4]
     : list nat *)
    Eval cbn in intersperse nat 0 [1; 2; 3; 4].

    Lemma intersperse_intersperse_acc :
      forall (A : Type) (c : A) (l acc : list A),
        acc ++ intersperse A c l = intersperse_acc A c l acc.
    Proof.
      induction l.
      + cbn. intros. rewrite app_nil_r. auto.
      + destruct l.
        ++ cbn. intros acc.  auto.
        ++ assert (intersperse A c (a :: a0 :: l) = a :: c :: intersperse A c (a0 :: l)).
           auto. rewrite H.
           intro acc.
           assert (intersperse_acc A c (a :: a0 :: l) acc =
                   intersperse_acc A c (a0 :: l) (acc ++ [a; c])).
           auto. rewrite H0.
           rewrite <- IHl. rewrite <- app_assoc.
           auto.
    Qed.

    Inductive Intersperseind (A : Type) (c : A) : list A -> list A -> list A -> Prop :=
    | IBasecase acc : Intersperseind A c [] acc acc
    | IOnecase h xs : Intersperseind A c [h] xs (xs ++ [h])
    | IGencase h t acc zs : Intersperseind A c t (acc ++ [h; c]) zs ->
                            Intersperseind A c (h :: t) acc  zs.

    Lemma same_intersperse : forall (A : Type) (c : A) (l acc : list A),
        Intersperseind A c l acc (intersperse_acc A c l acc).
    Proof.
      intros A c.
      induction l.
      + cbn. intros.
        constructor.
      + intros. destruct l.
        ++ cbn in *. constructor 2.
        ++ constructor 3.
           eapply IHl.
    Qed.

    Lemma intersperse_acc_same : forall (A : Type) (c : A) (l acc : list A),
        Intersperseind A c l acc (acc ++ intersperse A c l).
    Proof.
      intros. rewrite intersperse_intersperse_acc.
      apply same_intersperse.
    Qed.

  End Hintersperse.


Lemma Na : forall N :nat, (N * 1) = N.
intros.
elim N.
simpl.
reflexivity.
intros.
simpl.
rewrite H.
reflexivity.
Qed.

Fixpoint f (n : nat) {struct n} : nat :=
 match n with
 | 0 => 1
 | S p => 2 * (f p)
end.

Lemma  f10 : (f 10) = 1024.

simpl.
reflexivity.
Qed.

Require Export List.
Lemma trois : forall E: Type ,forall l : list E, forall e:
E , rev(l ++ e::nil) = e :: rev l.
intros.
elim l.
simpl.
reflexivity.
intros.
simpl.
rewrite H.
simpl.
reflexivity.
Qed.

Lemma quatre : forall E : Type , forall l : list E , rev(rev l) = l.
intros.
elim l.
simpl.
reflexivity.
intros.
simpl.
rewrite trois.
rewrite H.
reflexivity.
Qed.

Inductive is_even : nat -> Prop :=
| is_even_0 : is_even 0
| is_even_S : forall n : nat, is_even n -> is_even (S (S n)).

Lemma iseven2 : is_even 2.
apply is_even_S.
apply is_even_0.
Qed.

Ltac isEven :=
intros;
(repeat
 apply is_even_S);
  apply is_even_0.

Lemma is_even4 : is_even 4.

isEven.
Qed.

Ltac NotIsEven :=
intro;
(repeat
match goal with
|H : is_even ?A |-_ => inversion H
end).

Lemma nonIsEven3 : ~is_even 2037.

NotIsEven.


Load "7_list_induction.v".

Theorem app_nil_r : forall l : natlist, l ++ [] = l.
Proof.
  intros l.
  induction l.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite IHl. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist, rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2.
  induction l1.
  - (* base *) simpl. rewrite app_nil_r. reflexivity.
  - (* i.h. *) simpl. rewrite -> IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist, rev (rev l) = l.
Proof.
  intros l.
  induction l.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite rev_app_distr. rewrite IHl. simpl. reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist, l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  case l1.
  - (* empty list case *) rewrite app_assoc. reflexivity.
  - (* l1 = n : l1'    *) intros n n0. simpl. rewrite app_assoc. rewrite app_assoc. reflexivity.
Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | [ ]       => []
  | cons 0 l' => (nonzeros l')
  | cons x l' => cons x (nonzeros l')
  end.

Lemma nonzeros_app : forall l1 l2 : natlist, nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) simpl. rewrite IHl1. case n. (* we run case on n for cons zero on nonzeros *)
    + (* zero *) reflexivity.
    + (* S _  *) intros n0. simpl. rewrite <- IHl1. simpl. reflexivity.
Qed.