(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * bmx: Boolean matrices, characterisation of reflexive transitive closure *)

Require Import kleene boolean sups matrix.
Set Implicit Arguments.

Notation bmx := (mx_ops bool_ops bool_tt).

(** intermediate alternative definition of the star of a Boolean matrix *)

Fixpoint bmx_str n: bmx n n -> bmx n n :=
  match n with
    | O => fun M => M
    | S n => fun M =>
      let b := sub01_mx (n1:=1) (m1:=1) M in
      let c := sub10_mx (n1:=1) (m1:=1) M in
      let d := bmx_str (sub11_mx (n1:=1) (m1:=1)  M) in
      blk_mx 1 (b*d) (d*c) (d+d*c*(b*d))
  end.

Lemma bmx_top_1: top == (1: bmx 1%nat 1%nat).
Proof. intros i j. now setoid_rewrite ord0_unique. Qed.

Lemma bmx_str_str n (M: bmx n n): M^* == bmx_str M.
Proof.
  induction n as [|n IHn]. intro i. elim (ord_0_empty i).
  change (M^*) with (mx_str _ _ _ M).
  simpl mx_str. simpl bmx_str. unfold mx_str_build.
  ra_fold (mx_ops bool_ops bool_tt). rewrite bmx_top_1.
  now rewrite IHn, dot1x, dotx1.
Qed.

(** reflexive transitive closure as an inductive predicate *)

Inductive rt_clot n (M: bmx n n): ord n -> ord n -> Prop :=
| clot_nil: forall i, rt_clot M i i
| clot_cons: forall i j k, M i j -> rt_clot M j k -> rt_clot M i k.

Lemma clot_app n (M: bmx n n): forall i j k, rt_clot M i j -> rt_clot M j k -> rt_clot M i k.
Proof. induction 1; eauto using clot_cons. Qed.

Lemma clot_snoc n (M: bmx n n): forall i j k, rt_clot M i j -> M j k -> rt_clot M i k.
Proof. intros. eapply clot_app. eassumption. eapply clot_cons. eassumption. constructor. Qed.

Lemma rt_clot_S_S n (M: bmx (1+n)%nat (1+n)%nat): forall i j,
  rt_clot (sub11_mx M) i j -> rt_clot M (rshift i) (rshift j).
Proof. induction 1. constructor. eapply clot_cons; eassumption. Qed.

(** characterisation theorem  *)

Theorem bmx_str_clot n (M: bmx n n) i j: M^* i j <-> rt_clot M i j.
Proof.
split.
- assert (M^* i j == bmx_str M i j). (*MS: FIXME, why is it needed now ? *)
  apply bmx_str_str. rewrite H. clear H. revert i j.
  induction n as [|n IH]; intros i' j'.
   simpl. intro. eapply clot_cons. eassumption. constructor.
  unfold bmx_str; fold (@bmx_str n). set (M' := sub11_mx (n1:=1) (m1:=1) M).
  specialize (IH M'). unfold blk_mx, row_mx, col_mx.
  case ordinal.split_spec; intros i ->; case ordinal.split_spec; intros j -> Hij.
  + setoid_rewrite ord0_unique. constructor.
  + setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]].
    apply Bool.andb_true_iff in Hk as [Hik Hkj].
    apply IH in Hkj. unfold M' in Hkj.
    eapply clot_cons. eassumption. now apply rt_clot_S_S.
  + setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]].
    apply Bool.andb_true_iff in Hk as [Hik Hkj].
    apply IH in Hik. unfold M' in Hik.
    eapply clot_snoc. apply rt_clot_S_S; eassumption. assumption.
  + setoid_rewrite Bool.orb_true_iff in Hij. destruct Hij as [Hij|Hij].
     apply IH in Hij. now apply rt_clot_S_S.
    setoid_rewrite is_true_sup in Hij. destruct Hij as [k [_ Hk]].
    apply Bool.andb_true_iff in Hk as [Hik Hkj].
    setoid_rewrite is_true_sup in Hik. destruct Hik as [i' [_ Hi']].
    apply Bool.andb_true_iff in Hi' as [Hii' Hi'k].
    setoid_rewrite is_true_sup in Hkj. destruct Hkj as [j' [_ Hj']].
    apply Bool.andb_true_iff in Hj' as [Hkj' Hj'j].
    apply IH in Hii'. apply IH in Hj'j.
    eapply clot_app. apply rt_clot_S_S, Hii'.
    eapply clot_cons. apply Hi'k.
    eapply clot_cons. apply Hkj'.
    apply rt_clot_S_S, Hj'j.
- induction 1 as [i|i j k Hij Hjk IH].
  + pose proof (str_refl (X:=bmx) M i i). simpl in H.
    setoid_rewrite le_bool_spec in H. apply H. unfold mx_one. now rewrite eqb_refl.
  + pose proof (str_cons (X:=bmx) M i k). simpl in H.
    setoid_rewrite le_bool_spec in H. apply H. clear H.
    unfold mx_dot. rewrite is_true_sup. eexists. split. apply in_seq.
    apply Bool.andb_true_iff. split; eassumption.
Qed.


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

(** Bit vectors interpreted as integers.
    Contribution by Jean Duprat (ENS Lyon). *)

Require Import Bvector.
Require Import ZArith.
Require Export Zpower.
Require Import Omega.

(** The evaluation of boolean vector is done both in binary and
    two's complement. The computed number belongs to Z.
    We hence use Omega to perform computations in Z.
    Moreover, we use functions [2^n] where [n] is a natural number
    (here the vector length).
*)

Section VALUE_OF_BOOLEAN_VECTORS.

(** Computations are done in the usual convention.
    The values correspond either to the binary coding (nat) or
    to the two's complement coding (int).
    We perform the computation via Horner scheme.
    The two's complement coding only makes sense on vectors whose
    size is greater or equal to one (a sign bit should be present).
*)

  Definition bit_value (b:bool) : Z :=
    match b with
      | true => 1%Z
      | false => 0%Z
    end.

  Lemma binary_value : forall n:nat, Bvector n -> Z.
  Proof.
    simple induction n; intros.
    exact 0%Z.

    inversion H0.
    exact (bit_value h + 2 * H H2)%Z.
  Defined.

  Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
  Proof.
    simple induction n; intros.
    inversion H.
    exact (- bit_value h)%Z.

    inversion H0.
    exact (bit_value h + 2 * H H2)%Z.
  Defined.

End VALUE_OF_BOOLEAN_VECTORS.

Section ENCODING_VALUE.

(** We compute the binary value via a Horner scheme.
    Computation stops at the vector length without checks.
    We define a function Zmod2 similar to Zdiv2 returning the
    quotient of division z=2q+r with 0<=r<=1.
    The two's complement value is also computed via a Horner scheme
    with Zmod2, the parameter is the size minus one.
*)

  Definition Zmod2 (z:Z) :=
    match z with
      | Z0 => 0%Z
      | Zpos p => match p with
		    | xI q => Zpos q
		    | xO q => Zpos q
		    | xH => 0%Z
		  end
      | Zneg p =>
	match p with
	  | xI q => (Zneg q - 1)%Z
	  | xO q => Zneg q
	  | xH => (-1)%Z
	end
    end.

  Lemma Zmod2_twice :
    forall z:Z, z = (2 * Zmod2 z + bit_value (Zeven.Zodd_bool z))%Z.
  Proof.
    destruct z; simpl in |- *.
    trivial.

    destruct p; simpl in |- *; trivial.

    destruct p; simpl in |- *.
    destruct p as [p| p| ]; simpl in |- *.
    rewrite <- (Pdouble_minus_one_o_succ_eq_xI p); trivial.

    trivial.

    trivial.

    trivial.

    trivial.
  Qed.

  Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
  Proof.
    simple induction n; intros.
    exact Bnil.

    exact (Bcons (Zeven.Zodd_bool H0) n0 (H (Zeven.Zdiv2 H0))).
  Defined.

  Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
  Proof.
    simple induction n; intros.
    exact (Bcons (Zeven.Zodd_bool H) 0 Bnil).

    exact (Bcons (Zeven.Zodd_bool H0) (S n0) (H (Zmod2 H0))).
  Defined.

End ENCODING_VALUE.

Section Z_BRIC_A_BRAC.

  (** Some auxiliary lemmas used in the next section. Large use of ZArith.
      Deserve to be properly rewritten.
  *)

  Lemma binary_value_Sn :
    forall (n:nat) (b:bool) (bv:Bvector n),
      binary_value (S n) ( b :: bv) =
      (bit_value b + 2 * binary_value n bv)%Z.
  Proof.
    intros; auto.
  Qed.

  Lemma Z_to_binary_Sn :
    forall (n:nat) (b:bool) (z:Z),
      (z >= 0)%Z ->
      Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
  Proof.
    destruct b; destruct z; simpl in |- *; auto.
    intro H; elim H; trivial.
  Qed.

  Lemma binary_value_pos :
    forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
  Proof.
    induction bv as [| a n v IHbv]; simpl in |- *.
    omega.

    destruct a; destruct (binary_value n v); simpl in |- *; auto.
    auto with zarith.
  Qed.

  Lemma two_compl_value_Sn :
    forall (n:nat) (bv:Bvector (S n)) (b:bool),
      two_compl_value (S n) (Bcons b (S n) bv) =
      (bit_value b + 2 * two_compl_value n bv)%Z.
  Proof.
    intros; auto.
  Qed.

  Lemma Z_to_two_compl_Sn :
    forall (n:nat) (b:bool) (z:Z),
      Z_to_two_compl (S n) (bit_value b + 2 * z) =
      Bcons b (S n) (Z_to_two_compl n z).
  Proof.
    destruct b; destruct z as [| p| p]; auto.
    destruct p as [p| p| ]; auto.
    destruct p as [p| p| ]; simpl in |- *; auto.
    intros; rewrite (Psucc_o_double_minus_one_eq_xO p); trivial.
  Qed.

  Lemma Z_to_binary_Sn_z :
    forall (n:nat) (z:Z),
      Z_to_binary (S n) z =
      Bcons (Zeven.Zodd_bool z) n (Z_to_binary n (Zeven.Zdiv2 z)).
  Proof.
    intros; auto.
  Qed.

  Lemma Z_div2_value :
    forall z:Z,
      (z >= 0)%Z -> (bit_value (Zeven.Zodd_bool z) + 2 * Zeven.Zdiv2 z)%Z = z.
  Proof.
    destruct z as [| p| p]; auto.
    destruct p; auto.
    intro H; elim H; trivial.
  Qed.

  Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Zeven.Zdiv2 z >= 0)%Z.
  Proof.
    destruct z as [| p| p].
    auto.

    destruct p; auto.
    simpl in |- *; intros; omega.

    intro H; elim H; trivial.
  Qed.

  Lemma Zdiv2_two_power_nat :
    forall (z:Z) (n:nat),
      (z >= 0)%Z ->
      (z < two_power_nat (S n))%Z -> (Zeven.Zdiv2 z < two_power_nat n)%Z.
  Proof.
    intros.
    cut (2 * Zeven.Zdiv2 z < 2 * two_power_nat n)%Z; intros.
    omega.

    rewrite <- two_power_nat_S.
    destruct (Zeven.Zeven_odd_dec z); intros.
    rewrite <- Zeven.Zeven_div2; auto.

    generalize (Zeven.Zodd_div2 z z0); omega.
  Qed.

  Lemma Z_to_two_compl_Sn_z :
    forall (n:nat) (z:Z),
      Z_to_two_compl (S n) z =
      Bcons (Zeven.Zodd_bool z) (S n) (Z_to_two_compl n (Zmod2 z)).
  Proof.
    intros; auto.
  Qed.

  Lemma Zeven_bit_value :
    forall z:Z, Zeven.Zeven z -> bit_value (Zeven.Zodd_bool z) = 0%Z.
  Proof.
    destruct z; unfold bit_value in |- *; auto.
    destruct p; tauto || (intro H; elim H).
    destruct p; tauto || (intro H; elim H).
  Qed.

  Lemma Zodd_bit_value :
    forall z:Z, Zeven.Zodd z -> bit_value (Zeven.Zodd_bool z) = 1%Z.
  Proof.
    destruct z; unfold bit_value in |- *; auto.
    intros; elim H.
    destruct p; tauto || (intros; elim H).
    destruct p; tauto || (intros; elim H).
  Qed.

  Lemma Zge_minus_two_power_nat_S :
    forall (n:nat) (z:Z),
      (z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
  Proof.
    intros n z; rewrite (two_power_nat_S n).
    generalize (Zmod2_twice z).
    destruct (Zeven.Zeven_odd_dec z) as [H| H].
    rewrite (Zeven_bit_value z H); intros; omega.

    rewrite (Zodd_bit_value z H); intros; omega.
  Qed.

  Lemma Zlt_two_power_nat_S :
    forall (n:nat) (z:Z),
      (z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
  Proof.
    intros n z; rewrite (two_power_nat_S n).
    generalize (Zmod2_twice z).
    destruct (Zeven.Zeven_odd_dec z) as [H| H].
    rewrite (Zeven_bit_value z H); intros; omega.

    rewrite (Zodd_bit_value z H); intros; omega.
  Qed.

End Z_BRIC_A_BRAC.

Section COHERENT_VALUE.

(** We check that the functions are reciprocal on the definition interval.
    This uses earlier library lemmas.
*)

  Lemma binary_to_Z_to_binary :
    forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
  Proof.
    induction bv as [| a n bv IHbv].
    auto.

    rewrite binary_value_Sn.
    rewrite Z_to_binary_Sn.
    rewrite IHbv; trivial.

    apply binary_value_pos.
  Qed.

  Lemma two_compl_to_Z_to_two_compl :
    forall (n:nat) (bv:Bvector n) (b:bool),
      Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
  Proof.
    induction bv as [| a n bv IHbv]; intro b.
    destruct b; auto.

    rewrite two_compl_value_Sn.
    rewrite Z_to_two_compl_Sn.
    rewrite IHbv; trivial.
  Qed.

  Lemma Z_to_binary_to_Z :
    forall (n:nat) (z:Z),
      (z >= 0)%Z ->
      (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
  Proof.
    induction n as [| n IHn].
    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros; omega.

    intros; rewrite Z_to_binary_Sn_z.
    rewrite binary_value_Sn.
    rewrite IHn.
    apply Z_div2_value; auto.

    apply Pdiv2; trivial.

    apply Zdiv2_two_power_nat; trivial.
  Qed.

  Lemma Z_to_two_compl_to_Z :
    forall (n:nat) (z:Z),
      (z >= - two_power_nat n)%Z ->
      (z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
  Proof.
    induction n as [| n IHn].
    unfold two_power_nat, shift_nat in |- *; simpl in |- *; intros.
    assert (z = (-1)%Z \/ z = 0%Z). omega.
    intuition; subst z; trivial.

    intros; rewrite Z_to_two_compl_Sn_z.
    rewrite two_compl_value_Sn.
    rewrite IHn.
    generalize (Zmod2_twice z); omega.

    apply Zge_minus_two_power_nat_S; auto.

    apply Zlt_two_power_nat_S; auto.
  Qed.

End COHERENT_VALUE.


Require Export Coq.Init.Nat.
Definition FILL_IN_HERE {T: Type} : T.  Admitted.

Inductive list (X:Type) : Type :=
  | nil
  | cons (x : X) (l : list X).

Arguments nil {X}.
Arguments cons {X} _ _.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil => l2
  | cons h t => cons h (app t l2)
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Definition natlist := list nat.

Fixpoint map {X Y: Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | nil => nil
  | cons h t => cons (f h) (map f t)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint In {A : Type} (x : A) (l : list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.


Lemma s : 3*3=9.
Proof.
	apply eq_refl.
Qed.
(* (a) *)
Inductive aexpr (N:Type)  :=
| cst : N -> aexpr N
| var : nat -> aexpr N
| add : aexpr N -> aexpr N -> aexpr N
.
(* (b) *)
Check (cst).

(* (c) *)
Print aexpr_ind.

Fixpoint aexpr_iter (N : Type) (P : Type)
           (Pcst : N -> P)
           (Pvar : nat -> P)
           (Padd : aexpr N -> P -> aexpr N -> P -> P)
           (e : aexpr N) : P :=
  match e with
    | cst _ n => Pcst n
    | var _ n => Pvar n
    | add _ x y => Padd x (aexpr_iter N P Pcst Pvar Padd x)
                      y (aexpr_iter N P Pcst Pvar Padd y)
  end.

Inductive iff (A B:Prop) : Prop :=
|iff_intro : (A -> B) -> (B -> A) -> iff A B
.

Definition iff_rd :=
fun (A B:Prop) (P: iff A B -> Type)
 (f: forall (a : A -> B) (b : B -> A), P(iff_intro A B a b))
 (i: iff A B) =>
 match i  with
 | iff_intro _ _ x x0 => f x x0
 end

.

Print iff_ind.
Print aexpr_rect.

Definition iff_l (A B:Prop) (e: iff A B) :=
  iff_rd A B (fun _ => A -> B) (fun l _ => l) e.

  Definition iff_out (A B : Prop) (e : iff A B) : A -> B :=
  iff_ind A B (A -> B) (fun l _ => l) e.
Parameter (A B:Prop).
Check (iff_out B  (iff A B )).
Check (iff_l B  (iff A B )).


Require Import FiatFormal.Data.List.Base.
Require Import FiatFormal.Data.Nat.
Require Import FiatFormal.Tactics.

(* Insert a new element at a place in the list.
   All the elements above that place are shifted up one.
   The resulting list is one element larger. *)
Fixpoint insert {A: Type} (ix: nat) (x: A) (xs: list A) : list A :=
 match ix, xs with
 | _,     nil      => x :: nil
 | S ix', y :: xs' => y :: (insert ix' x xs')
 | O    , xs'      => x :: xs'
 end.

(* When using the 'simpl' tactic we don't want to do a reduction
   that will leave the inner match expression in head position. *)
Arguments insert A ix x xs : simpl nomatch.

(********************************************************************)
(** Lemmas: insert *)

Lemma insert_rewind
 :  forall {A} ix t1 t2 (xx: list A)
 ,  insert ix t2 xx :> t1 = insert (S ix) t2 (xx :> t1).
Proof. auto. Qed.

Lemma insert_zero
 :  forall {A} x (xs : list A)
 ,  insert 0 x xs = xs :> x.
Proof.
 rip. destruct xs; auto.
Qed.
Hint Resolve insert_zero.

(* If we insert an element at a particular point in a list,
   then we can still get the elements above that point
   provided we increment their original indices. *)
Lemma get_insert_above
 :  forall {A: Type} n ix (xx: list A) x1 x2
 ,  n >= ix
 -> get n xx                    = Some x1
 -> get (S n) (insert ix x2 xx) = Some x1.
Proof.
 intros. gen n xx.
 induction ix; intros.
  destruct xx.
   false.
   destruct n; auto.
  destruct xx.
   false.
   destruct n.
    false. omega.
    simpl in H0. simpl. apply IHix.
     omega.
     auto.
Qed.
Hint Resolve get_insert_above.

(* If we insert an element at a particular point in a list,
   then we can still get the elements below that point
   using their original indices. *)
Lemma get_insert_below
 :  forall {A: Type} n ix (xx: list A) x1 x2
 ,  n < ix
 -> get n xx                = Some x1
 -> get n (insert ix x2 xx) = Some x1.
Proof.
 intros. gen n xx.
 induction ix; intros.
  destruct xx.
   false.
   destruct n.
    false. omega.
    false. omega.
  destruct xx.
   false.
   destruct n.
    simpl in H0. auto.
    simpl in H0. simpl. apply IHix. omega. auto.
Qed.
Hint Resolve get_insert_below.

(* Inserting a new element into a list then applying a function to
   all elements is the same as applying the function to all the
   original elements, then inserting the new one with the function
   already applied. *)
Lemma map_insert
 : forall {A B: Type} (f: A -> B) ix x (xs: list A)
 , map f (insert ix x xs)
 = insert ix (f x) (map f xs).
Proof.
 intros. gen ix x.
 induction xs; intros.
  simpl. destruct ix; auto.
  simpl. destruct ix; auto.
   rewrite <- insert_rewind. simpl.
   rewrite IHxs. auto.
Qed.

Lemma insert_app
 : forall {A : Type} ix (x: A) xs ys
 , insert ix x xs >< ys = insert (ix + length ys) x (xs >< ys).
Proof.
 intros.
 induction ys.
  simpl. norm_nat.  auto.
  simpl. rewrite IHys.
   rewrite insert_rewind.
   assert (S (ix + length ys) = ix + S (length ys)). auto.
   rewrite H. auto.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* ************************************************************************* *)
(*                                                                           *)
(*          Buchberger : ordering: lexi and total                            *)
(*                                                                           *)
(*          Laurent Thery 	                                             *)
(*                                                                           *)
(* ************************************************************************* *)

From Coq Require Import Arith Compare_dec.
From Buchberger Require Import Monomials LetP.

Set Default Proof Using "Type".

Section lexi_order.

Inductive orderc : forall n : nat, mon n -> mon n -> Prop :=
  | lo1 :
      forall (n a b : nat) (p : mon n),
      b < a -> orderc (S n) (c_n n a p) (c_n n b p)
  | lo2 :
      forall (n a b : nat) (p q : mon n),
      orderc n p q -> orderc (S n) (c_n n a p) (c_n n b q).

Local Hint Resolve lo1 lo2 : core.

Definition orderc_dec :
 forall (n : nat) (a b : mon n), {orderc n a b} + {orderc n b a} + {a = b}.
intros n a; elim a; auto.
intro b.
rewrite <- (mon_0 b); auto.
intros d n0 m H' b; try assumption.
rewrite <- (proj_ok d b).
case (H' (pmon2 (S d) b)).
intro H'0; case H'0.
intro H'1.
left; left; auto.
intro H'1; left; right; auto.
intro H'0.
elim (lt_eq_lt_dec n0 (pmon1 (S d) b)); [ intro H'1; elim H'1 | idtac ];
 intro H'2; auto.
left; right; auto.
rewrite H'0; auto.
right; rewrite H'0; rewrite H'2; auto.
left; left; rewrite H'0; auto.
Defined.

Definition degc : forall n : nat, mon n -> nat.
intros n H'; elim H'.
exact 0.
intros d n1 M n2; exact (n1 + n2).
Defined.

Inductive total_orderc : forall n : nat, mon n -> mon n -> Prop :=
  | total_orderc0 :
      forall (n : nat) (p q : mon n),
      degc n p < degc n q -> total_orderc n p q
  | total_orderc1 :
      forall (n : nat) (p q : mon n),
      degc n p = degc n q -> orderc n p q -> total_orderc n p q.

Local Hint Resolve total_orderc0 total_orderc1 : core.

Definition total_orderc_dec :
 forall (n : nat) (a b : mon n),
 {total_orderc n a b} + {total_orderc n b a} + {a = b}.
intros n a b.
apply LetP with (A := nat) (h := degc n a).
intros u H'; apply LetP with (A := nat) (h := degc n b).
intros u0 H'0.
case (le_lt_dec u u0); auto.
intro H'1; case (le_lt_eq_dec u u0); auto.
rewrite H'0; rewrite H'; auto.
rewrite H'0; rewrite H'; intro H'2; case (orderc_dec n a b); auto.
intro H'3; case H'3; auto.
rewrite H'0; rewrite H'; auto.
Defined.

End lexi_order.


Require Import ct00.
(* ct00 contains the original conjecture. *)

Require Import ct16.
(* ct16 contains all necessary divide-and-conquer tactics *)

Require Import ct02 ct06 ct14 ct15 ct17.
(* ct02 ct06 ct14 contains the following lemmas that are solved by the automated
 * system, CoqHammer:
 * - sort_prog_base
 * - sort_prog_one
 * - HdRel_merge_snd_cons
 * - sorted_merge_cons
 * - HdRel_merge_fst_cons
 * - permutation_merge_concat
 * - permutation_split
 *)

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if (le_lt_dec a1 a2) then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

Lemma merge_sorted : forall (l1 l2 : list nat),
  sorted l1 -> sorted l2 -> sorted (merge l1 l2).
Proof.
induction l1; induction l2; intros; simpl; auto.
destruct (le_lt_dec a a0).
- constructor. apply IHl1; inversion H; auto. apply HdRel_merge_snd_cons; auto.
- constructor. eapply sorted_merge_cons; eassumption.
  apply HdRel_merge_fst_cons; auto.
Defined.

Lemma merge_permutation : forall (l l1 l2 : list nat),
  permutation l1 (fst (split nat l)) -> permutation l2 (snd (split nat l))
  -> permutation (merge l1 l2) l.
Proof.
intros; rewrite permutation_merge_concat, H, H0; apply permutation_split.
Defined.

Lemma sort_prog_split : forall (ls l' l'0: list nat),
  sorted l'0 -> permutation l'0 (fst (split nat ls))
  -> sorted l' -> permutation l' (snd (split nat ls))
  -> {l'1 : list nat | sorted l'1 /\ permutation l'1 ls}.
Proof.
intros; exists (merge l'0 l'); split.
  + apply merge_sorted; eassumption.
  + apply merge_permutation; eassumption.
Defined.

Lemma msort_prog : forall (l : list nat),
  {l' : list nat | sorted l' /\ permutation l' l}.
Proof.
div_conq_split.
- apply sort_prog_base.
- apply sort_prog_one.
- intros; destruct H; destruct a; destruct H0; destruct a;
  eapply sort_prog_split. exact H. eassumption. exact H0. eassumption.
Defined.

(*---------------------------------Extraction---------------------------------*)

Require Extraction.
Require Import ExtrOcamlBasic.
Require Import ExtrOcamlNatInt.
(* Suppose all the packages above are embedded in some trans *)

Extraction Language OCaml.
Set Extraction AccessOpaque.

Extraction "extraction/merge.ml" merge.
Extraction "extraction/msort.ml" msort_prog.

(*----------------------------------------------------------------------------*)


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Parameter bag : forall (a:Type), Type.

Parameter nb_occ: forall (a:Type), a -> (bag a)  -> Z.

Implicit Arguments nb_occ.

Axiom occ_non_negative : forall (a:Type), forall (b:(bag a)) (x:a),
  (0%Z <= (nb_occ x b))%Z.

Definition eq_bag (a:Type)(a1:(bag a)) (b:(bag a)): Prop := forall (x:a),
  ((nb_occ x a1) = (nb_occ x b)).
Implicit Arguments eq_bag.

Axiom bag_extensionality : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  (eq_bag a1 b) -> (a1 = b).

Parameter empty_bag: forall (a:Type),  (bag a).

Set Contextual Implicit.
Implicit Arguments empty_bag.
Unset Contextual Implicit.

Axiom occ_empty : forall (a:Type), forall (x:a), ((nb_occ x (empty_bag:(bag
  a))) = 0%Z).

Axiom is_empty : forall (a:Type), forall (b:(bag a)), (forall (x:a),
  ((nb_occ x b) = 0%Z)) -> (b = (empty_bag:(bag a))).

Parameter singleton: forall (a:Type), a  -> (bag a).

Implicit Arguments singleton.

Axiom occ_singleton_eq : forall (a:Type), forall (x:a) (y:a), (x = y) ->
  ((nb_occ y (singleton x)) = 1%Z).

Axiom occ_singleton_neq : forall (a:Type), forall (x:a) (y:a), (~ (x = y)) ->
  ((nb_occ y (singleton x)) = 0%Z).

Parameter union: forall (a:Type), (bag a) -> (bag a)  -> (bag a).

Implicit Arguments union.

Axiom occ_union : forall (a:Type), forall (x:a) (a1:(bag a)) (b:(bag a)),
  ((nb_occ x (union a1 b)) = ((nb_occ x a1) + (nb_occ x b))%Z).

Axiom Union_comm : forall (a:Type), forall (a1:(bag a)) (b:(bag a)),
  ((union a1 b) = (union b a1)).

Axiom Union_identity : forall (a:Type), forall (a1:(bag a)), ((union a1
  (empty_bag:(bag a))) = a1).

Axiom Union_assoc : forall (a:Type), forall (a1:(bag a)) (b:(bag a)) (c:(bag
  a)), ((union a1 (union b c)) = (union (union a1 b) c)).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem bag_simpl : forall (a:Type), forall (a1:(bag a)) (b:(bag a)) (c:(bag
  a)), ((union a1 b) = (union c b)) -> (a1 = c).
(* YOU MAY EDIT THE PROOF BELOW *)
intros X a b c H_union.
apply bag_extensionality; intro x.
assert (h: (nb_occ x (union a b)) =  (nb_occ x (union c b)))
  by (rewrite H_union; auto).
do 2 rewrite occ_union in h; auto with zarith.
Qed.
(* DO NOT EDIT BELOW *)


Require Import SetoidCat Algebra.SetoidCat.SetoidUtils Algebra.Functor Algebra.Monoid PairUtils Algebra.Utils UnitUtils.

Require Import SetoidClass.

Section Applicative.

  Context
    {t : forall A, Setoid A -> Type}
    {tS : forall A (AS : Setoid A), Setoid (t A AS)}
    {func : @Functor t tS}.

  Definition left_unitor {A} {AS : Setoid A} : unitS ~*~ AS ~> AS := sndS.

  Definition right_unitor {A} {AS : Setoid A} : AS ~*~ unitS ~> AS := fstS.

  Definition associator {A B C} {AS : Setoid A} {BS : Setoid B} {CS : Setoid C} : (AS ~*~ BS) ~*~ CS ~> AS ~*~ (BS ~*~ CS) := (fstS ∘ fstS) &&& ((sndS ∘ fstS) &&& sndS).

  Class Applicative :=
    {
      unitA :  t unit _;
      prod {A B} {AS : Setoid A} {BS : Setoid B} : tS _ AS ~> tS _ BS ~~> tS _ (AS ~*~ BS);

      left_unit_applicative :
        forall {A} {AS : Setoid A} (a : t A _),
          left_unitor <$> (prod  @ unitA @ a) == a;
      right_unit_applicative :
        forall {A} {AS : Setoid A} (a : t A _),
          right_unitor <$> (prod  @ a @ unitA) == a;
      associativity_applicative:
        forall {A B C} {AS : Setoid A} {BS : Setoid B} {CS : Setoid C}
               (a : t A _) (b : t B _) (c : t C _) ,
          associator <$> (prod  @ (prod  @ a @ b) @ c) == prod  @ a @ (prod  @ b @ c);
      naturality_prod:
        forall {A B C D} {AS : Setoid A} {BS : Setoid B} {CS : Setoid C} {DS : Setoid D}
               (f : AS ~> BS) (g : CS ~> DS) (a : t A _) (c : t C _),
          prod  @ (f <$> a) @ (g <$> c) == (f *** g) <$> (prod  @ a @ c)
    }.

  Context
    {app : Applicative}.

  Definition pure  {A} {AS : Setoid A} : AS ~> tS _ AS := (flipS @ fmap @ unitA) ∘ constS unitS.

  Definition ap {A B} {AS : Setoid A} {BS : Setoid B} : tS _ (AS ~~> BS) ~> tS _ AS ~~> tS _ BS :=
    comp2S @ prod @ (fmap @ (uncurryS @ evalS)).

  Definition produ {A B} {AS : Setoid A} {BS : Setoid B} : tS _ AS ~*~ tS _ BS ~> tS _ (AS ~*~ BS) := uncurryS @ prod  .

End Applicative.

Notation "a ** b" := (prod @ a @ b) (at level 49, left associativity).
Notation "a <*> b" := (ap @ a @ b) (at level 49, left associativity).


Require Import List ZArith.
Import ListNotations.

Require Import formal_av1.basic_types.

Module bit_index_order.

  Definition t := byte.bit_index.

  Inductive is_next (a b : t) : Prop :=
  | is_index_intro :
    proj1_sig (Fin.to_nat a) = S (proj1_sig (Fin.to_nat b)) ->
      is_next a b.

  Inductive is_previous (a b : t) : Prop :=
    | is_previous_intro :
      is_next b a -> is_previous a b.

  Inductive is_last (a : t) : Prop :=
    | is_last_intro :
      ~(exists b, is_next a b) -> is_last a.

  Inductive is_first (a : t) : Prop :=
    | is_first_intro :
      ~(exists b, is_previous a b) -> is_first a.

End bit_index_order.

Module bitstream_position.

  Record t := t_intro {
    byte_index : nat;
    bit_index : byte.bit_index;
  }.

  (* Bitstream positions go from most significant bit to least significant bit. *)

  Inductive is_next : t -> t -> Prop :=
    | is_next_same_byte :
      forall bit_pos_a bit_pos_b,
        bit_index_order.is_previous bit_pos_a bit_pos_b ->
      forall byte_pos, is_next
        (t_intro byte_pos bit_pos_a)
        (t_intro byte_pos bit_pos_b)
    | is_next_next_byte :
      forall bit_pos_a, bit_index_order.is_first bit_pos_a ->
      forall bit_pos_b, bit_index_order.is_last bit_pos_b ->
      forall byte_pos, is_next
        (t_intro byte_pos bit_pos_a)
        (t_intro (S byte_pos) bit_pos_b).

  Inductive is_previous (bit_pos_a bit_pos_b : t) : Prop :=
    | is_previous_intro :
      is_next bit_pos_b bit_pos_a ->
      is_previous bit_pos_a bit_pos_b.

End bitstream_position.

Inductive bit_in_byte_relation
    (bt : byte.t)
    (index : byte.bit_index)
    (b : bit)
    : Prop :=
  | bit_in_byte_intro :
    Vector.nth bt index = b -> bit_in_byte_relation bt index b.

Inductive byte_in_obu_relation :
    open_bitstream_unit -> nat -> byte.t -> Prop :=
  byte_in_bitstream_relation_intro:
    forall obu bp b,
      nth_error obu bp = Some b ->
        byte_in_obu_relation obu bp b.

Inductive obu_at_relation :
    open_bitstream_unit -> bitstream_position.t -> bit -> Prop :=
  obu_at_relation_intro :
    forall obu byte_index bit_index byte value,
      byte_in_obu_relation obu byte_index byte ->
      bit_in_byte_relation byte bit_index value ->
      obu_at_relation obu (bitstream_position.t_intro byte_index bit_index)
        value.

Inductive read_bit_relation
    (obu : open_bitstream_unit)
    (bp_0 : bitstream_position.t)
    (b : bit)
    (bp_1 : bitstream_position.t)
    : Prop :=
  | read_bit_relation_intro :
    obu_at_relation obu bp_0 b ->
    bitstream_position.is_next bp_0 bp_1 ->
    read_bit_relation obu bp_0 b bp_1.

Inductive read_bit_list_relation
    (obu : open_bitstream_unit)
    (bp_a : bitstream_position.t)
    (bp_b : bitstream_position.t)
    : list bit -> Prop :=
  | read_bit_list_relation_first :
    forall (b : bit),
    read_bit_relation obu bp_a b bp_b ->
    read_bit_list_relation obu bp_a bp_b [b]
  | read_bit_list_relation_next :
    forall (b : bit) (l : list bit) (bp_a_next : bitstream_position.t),
    read_bit_relation obu bp_a b bp_a_next ->
    read_bit_list_relation obu bp_a_next bp_b l ->
    read_bit_list_relation obu bp_a bp_b (b :: l).


Require Import Omega.
Require Import Imp.

(* ((Evaluation Function)) *)

Notation "'LETOPT' x <== e1 'IN' e2" :=
   (match e1 with
      | Some x => e2
      | None => None
   end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat) : option state :=
  match i with
    | 0    => None
    | S i' =>
    match c with
      | CSkip     => Some st
      | CAss  x a => Some (update st x (aeval st a))
      | CSeq  c d => LETOPT st' <== ceval_step st c i' IN ceval_step st' d i'
      | CIf b t e => if beval st b then ceval_step st t i'
                                     else ceval_step st e i'
      | CWhile b k => if beval st b
                      then LETOPT st' <== ceval_step st k i'
                           IN ceval_step st' c i'
                      else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

(* Exercise: 2 stars (pup_to_n) *)

Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

(* END pup_to_n. *)

(* Exercise: 2 stars, optional (peven) *)

Definition peven : com :=
  Z ::= ANum 1;;
  WHILE BLe (ANum 1) (AId X) DO
    X ::= AMinus (AId X) (ANum 1);;
    IFB BEq (AId Z) (ANum 1) THEN Z ::= ANum 0 ELSE Z ::= ANum 1 FI
  END
.

Example peven_test :
  test_ceval (update empty_state X 5) peven
  = Some (0, 0, 0).
Proof. reflexivity. Qed.

Example peven_test2 :
  test_ceval (update empty_state X 10) peven
  = Some (0, 0, 1).
Proof. reflexivity. Qed.

(* END peven. *)

Theorem ceval_step__ceval : forall c st st',
  (exists i, ceval_step st c i = Some st') ->
  c / st ⇓ st'.
Proof.
  intros.
  inversion H as [i E].
  clear H.
  generalize dependent st.
  generalize dependent st'.
  generalize dependent c.
  induction i; intros.
  (* Case "contradiction" *)
  - inversion E.
  (* Case "at least one level of execution was performed" *)
  - destruct c; inversion E; subst.
      constructor.
      constructor.
      (* SCase "c ;; d" *)
      + destruct (ceval_step st c1 i) eqn: H.
        (* SSCase "exists state `s`" *)
        * apply E_Seq with (st' := s). apply IHi. apply H. apply IHi. apply H0.
        (* SSCase "c1 did not execute" *)
        * inversion H0.
      (* SCase "IFB" *)
      + destruct (beval st b) eqn: H; apply IHi in H0;
        [apply E_IfTrue | apply E_IfFalse]; try apply H; try apply H0.
      (* SCase "WHILE" *)
      + destruct (beval st b) eqn: H.
        (* SSCase "going on with the loop" *)
        * destruct (ceval_step st c i) eqn: I.
          (* SSSCase "current iteration returned a result" *)
          { apply E_WhileLoop with (st' := s). apply H.
            apply (IHi _ _ _ I).
            apply (IHi _ _ _ H0). }
          (* SSSCase "current iteration did not return" *)
          { inversion H0. }
        (* SSCase "leaving the loop" *)
        * inversion H0; subst.
          apply E_WhileEnd.
          apply H.
Qed.

(* Exercise: 4 stars (ceval_step__ceval_inf) *)

(* Theorem: if there exists some integer `i` after which ceval_step of command
c with initial state st returns a new state st', then c / st ⇓ st'.

Let's take a fixed value i. By induction on it,

if i = 0, then ceval_step couldn't have returned a state; by contradiction,
the induction base is proved.

The inductive step is: if c / st ⇓ st' holds for a computation which returns
after i steps, then adding a new step does not change the result of the
computation and, as such, does not break the relation.

Let's analyze all the cases for command c and prove that for each of them
incrementing i does not change the result.

For SKIP and assignment, the case is simple: it is evident that step counter is
not used in their operation simply by looking at the function definition.

For sequential execution c1 ;; c2, we analyze the two cases: if c1 executed
normally, then the process of updating the state corresponds to the one in the
E_Seq. Otherwise, we arrive at contradiction: if c1 returned Nothing, the whole
function couldn't have returned Some st'.

For conditional operator, we analyze `true` and `false` branches separately,
for each applying the corresponding constructor: E_IfTrue and E_IfFalse,
respectively.

For loops, the condition can be `true` or `false` for each iteration; we shall
separate the cases. If a new iteration occurs, then it must have returned some
state; otherwise, the whole loop would have returned Nothing; thus, relation
(loop body) / (initial state on this iteration) ⇓ (state after iteration) holds
by E_WhileTrue. If, on the other hand, we're leaving the loop, then the
function does not change the state, and (loop) / st ⇓ st holds by E_WhileEnd.

*)

(* END ceval_step__ceval_inf. *)

Theorem ceval_step_more : forall i1 i2 st st' c,
  i1 <= i2 ->
  ceval_step st c i1 = Some st' ->
  ceval_step st c i2 = Some st'.
Proof.
  induction i1; intros.
    - (* Case "returned after 0 steps" *)
      inversion H0.
    - (* Case "returned after (S i1) steps" *)
      destruct i2.
      + (* SCase "S _ <= 0" *)
        inversion H.
      + (* SCase "S i1 <= S i2" *)
        apply le_S_n in H.
        destruct c; inversion H0; simpl; try reflexivity.
          * (* SSCase ";;  " *)
            destruct (ceval_step st c1 i1) eqn: Heq.
              apply (IHi1 i2) in Heq; try assumption. rewrite -> Heq.
                rewrite -> H2. apply IHi1; try assumption.
              inversion H2.
          * (* SSCase "IFB " *)
            destruct (beval st b) eqn: Heq;
              rewrite -> H2; apply IHi1; assumption.
          * (* SSCase "While" *)
            destruct (beval st b) eqn: Heq.
              rewrite -> H2.
              destruct (ceval_step st c i1) eqn: Heq'.
                assert (ceval_step st c i2 = Some s)
                  by apply (IHi1 _ _ _ _ H Heq').
                rewrite -> H1.
                apply IHi1; assumption.
                inversion H2.
             trivial.
Qed.

(* Exercise: 3 stars (ceval__ceval_step) *)

Theorem ceval__ceval_step : forall c st st',
  c / st ⇓ st' -> exists i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce; try (exists 1; reflexivity).
    - (* Case "c1 ;; c2" *)
      destruct IHHce1. destruct IHHce2.
      exists (S (x + x0)).
        simpl.
        assert (ceval_step st c1 (x + x0) = Some st').
          apply (ceval_step_more x). omega. assumption.
        rewrite -> H1. apply (ceval_step_more x0). omega. assumption.
    - (* Case "IFB True" *)
      destruct IHHce. exists (S x). simpl. rewrite -> H. assumption.
    - (* Case "IFB False" *)
      destruct IHHce. exists (S x). simpl. rewrite -> H. assumption.
    - (* Case "While False" *)
      exists 1. simpl. rewrite -> H. trivial.
    - (* Case "While True" *)
      destruct IHHce1. destruct IHHce2.
      exists (S (x + x0)).
      simpl. rewrite -> H.
      assert (ceval_step st c (x + x0) = Some st').
        apply (ceval_step_more x). omega. assumption.
      rewrite -> H2.
      apply (ceval_step_more x0). omega. assumption.
Qed.

(* END ceval__ceval_step. *)


Require Export fin.
Require Import notations decidables Setoid Morphisms.

Definition vect A n := fin n -> A.
Definition vect_eq {A n} (v1 v2: vect A n) := forall i, v1 i = v2 i.
Definition vect_sym {A n} (v: vect A n): vect A n := fun i => v (fin_sym i).

Definition remove_element {A n} (num: fin (S n)) (v: vect A (S n)): vect A n :=
 fun i => if le_dec i.1 num.1 then v (le_to_fin (le_S _ _ i.2)) else v (le_to_fin (Le.le_n_S _ _ i.2)).

Definition vect_swap {A n} (i j: fin n) (v: vect A n): vect A n :=
 fun m => if eq_dec i.1 m.1 then v j else if eq_dec j.1 m.1 then v i else v m.
Theorem vect_swap_involutive {A n} (i j: fin n) (v: vect A n): vect_eq (vect_swap i j (vect_swap i j v)) v.
 unfold vect_eq, vect_swap; intro; destruct i, j, i0; simpl; repeat destruct eq_dec; f_equal; apply fin_eq_thm; simpl;
 congruence.
Qed.
Theorem vect_swap_sym {A n} (i j: fin n) (v: vect A n): vect_eq (vect_swap i j v) (vect_swap j i v).
 unfold vect_eq, vect_swap; intro; destruct i, j, i0; simpl; repeat destruct eq_dec; f_equal; apply fin_eq_thm; simpl;
 congruence.
Qed.

Definition vect_fold_right' {A B n} (f: B -> A -> B) (i: fin n) (start: B) (v: vect A n) :=
 let fix aux {A B n i} (f: B -> A -> B) (v: vect A n): i <= n -> B -> B :=
  match i with
  | O => fun (H: O <= n) b => f b (v (fin_zero n))
  | S m => fun (H: S m <= n) b => f (aux f v (Le.le_Sn_le _ _ H) b) (v (le_to_fin H))
  end
 in aux f v i.2 start.
Definition vect_fold_left' {A B n} (f: B -> A -> B) (i: fin n) (start: B) (v: vect A n) := vect_fold_right' f i start (vect_sym v).
Definition vect_fold_right {A B n} (f: B -> A -> B) (start: B) (v: vect A n) := vect_fold_right' f (fin_limit n) start v.
Definition vect_fold_left {A B n} (f: B -> A -> B) (start: B) (v: vect A n) := vect_fold_left' f (fin_limit n) start v.

Definition vect_to_list {A n} (v: vect A n): list A := vect_fold_left (fun x y => cons y x) nil v.

Instance vect_eq_Equiv A n: Equivalence (vect_eq (A:=A) (n:=n)).
 split; unfold Reflexive, Symmetric, Transitive, vect_eq; congruence.
Qed.
Instance vect_sym_Proper A n: Proper (vect_eq ==> vect_eq) (vect_sym (A:=A) (n:=n)).
 unfold Proper, respectful, vect_eq, vect_sym; auto.
Qed.
Instance remove_element_Proper A n num: Proper (vect_eq ==> vect_eq) (remove_element (A:=A) (n:=n) num).
 unfold Proper, respectful, vect_eq, remove_element; intros; destruct le_dec; auto.
Qed.
Instance vect_swap_Proper A n i j: Proper (vect_eq ==> vect_eq) (vect_swap (A:=A) (n:=n) i j).
 unfold Proper, respectful, vect_eq, vect_swap; intros; repeat destruct eq_dec; auto.
Qed.
Instance vect_fold_right'_Proper A B n f i start: Proper (vect_eq ==> eq) (vect_fold_right' (A:=A) (B:=B) (n:=n) f i start).
 unfold Proper, respectful, vect_eq, vect_fold_right'; destruct i; simpl; intros;
 induction x; rewrite H; [| rewrite IHx]; auto.
Qed.
Instance vect_fold_left'_Proper A B n f i start: Proper (vect_eq ==> eq) (vect_fold_left' (A:=A) (B:=B) (n:=n) f i start).
 unfold Proper, respectful, vect_fold_left'; intros; rewrite H; auto.
Qed.
Instance vect_fold_right_Proper A B n f start: Proper (vect_eq ==> eq) (vect_fold_right (A:=A) (B:=B) (n:=n) f start) :=
 vect_fold_right'_Proper A B n f (fin_limit n) start.
Instance vect_fold_left_Proper A B n f start: Proper (vect_eq ==> eq) (vect_fold_left (A:=A) (B:=B) (n:=n) f start) :=
 vect_fold_left'_Proper A B n f (fin_limit n) start.