(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*

   Proof of Fermat little theorem

   The proof is as follows:
    we considere the product
     prod_{i=1}^{p-1} (a * i)
     on one side we have
       prod_{i=1}^{p-1} (a * i)
         = prod_{i=1}^{p-1} a * prod_{i=1}^{p-1} i
         = a^(p-1) * (p - 1)!
     on the other side we have
       prod_{i=1}^{p-1} (a * i) mod p
         = prod_{i=1}^{p-1} ((a * i) mod p) mod p
       but we have that a is relatively prime,
          so by the cancelation rule we have
              (a * i) mod p = (a * j) mod p implies that i = j
          this means that the (a * i) mod p are p-1 distinct elements
          between 1 and p-1, so they can be put in a one-to-one correspondance
          with 1..p-1
       prod_{i=1}^{p-1} ((a * i) mod p) mod p
          = prod_{i=1}^{p-1} (i) mod p
          = (p-1)! mod p

     using both sides we have that
         (a^(p-1) * (p - 1)!) mod p = (p-1)! mod p
     using once again the cancellation rule sine ((p-1)! is relatively
     prime to p (as a product of number relatively primes to p))
         a^(p-1)  mod p = 1

*)
Require Export ZisMod.

Theorem fermat_little:
 forall a p, prime p -> rel_prime a p ->  Zis_mod (Zpower a (p - 1)) 1 p.
intros a p H1 H2.
assert (Hp: 1 < p).
apply Zlt_le_trans with 2; auto with zarith.
apply prime_le_2; auto.
assert (Hp1: 0 <= p - 1); auto with zarith.
apply Zis_mod_cancel with (Zfact (p - 1)).
apply rel_prime_sym; unfold Zfact.
apply inv_Zprod; auto with zarith.
apply prime_rel_prime; auto.
intros [x H3].
absurd (prime p); auto.
replace p with 1; auto.
apply not_prime_1.
apply sym_equal; apply (Zmult_one p x); auto with zarith.
rewrite H3; auto with zarith.
intros; apply rel_prime_mult; auto with zarith.
intros x [H3 H4]; apply prime_rel_prime; auto with zarith.
intros [y H5].
assert (H6: 0 < p).
apply Zlt_trans with 1; auto with zarith.
generalize H3 H4; rewrite H5; clear H3 H4; intros H3 H4.
case (Zle_or_lt y 0); intros H7.
contradict H3; apply Zlt_not_le.
apply Zle_lt_trans with (0 * p); auto with zarith.
contradict H4; apply Zlt_not_le.
apply Zlt_le_trans with (1 * p); auto with zarith.
rewrite Zmult_1_r; auto with zarith.
pattern (p - 1) at 2; replace (p - 1) with ((1 + (p - 1)) - 1); auto with zarith.
rewrite <- Zprod_c; auto with zarith.
unfold Zfact; rewrite Zprod_mult.
apply Zis_mod_trans with (Zmod (Zprod 1 (p - 1) (fun (i : Z) => i * a)) p).
apply Zis_mod_mod; auto with zarith.
replace (Zprod 1 (p - 1) (fun (i : Z) => i * a) mod p)
     with (Zprod 1 (p - 1) (fun (i : Z) => (i * a) mod p) mod p).
apply Zis_mod_trans with (Zprod 1 (p - 1) (fun (i : Z) => (i * a) mod p)).
apply Zis_mod_sym; apply Zis_mod_mod; auto with zarith.
replace (Zprod 1 (p - 1) (fun (i : Z) => (i * a) mod p))
     with (Zprod 1 (p - 1) (fun (x : Z) => x)).
apply Zis_mod_ref.
unfold Zprod; rewrite Zle_imp_le_bool; auto with zarith.
replace ((1 + (p - 1)) - 1) with (p - 1); auto with zarith.
rewrite <- (iter_map
             _ _ _ 1 (fun (x : Z) => x) Zmult (fun (i : Z) => (i * a) mod p)).
apply iter_permutation; auto with zarith.
apply permutation_sym; apply ulist_eq_permutation; auto with zarith.
cut (ulist (progression Zsucc 1 (Zabs_nat (p - 1)))).
generalize (Zprogression_le_init 1 (Zabs_nat (p - 1))).
generalize (Zprogression_le_end 1 (Zabs_nat (p - 1))).
replace (1 + Z_of_nat (Zabs_nat (p - 1))) with p; auto with zarith.
elim (progression Zsucc 1 (Zabs_nat (p - 1))); auto.
intros a0 l H H0 H3 H4; simpl; apply ulist_cons; auto.
intros Hi1; case (in_map_inv _ _ _ _ _ Hi1).
intros x [Ha1 Ha2].
absurd (In a0 l); auto with zarith.
inversion H4; auto.
replace a0 with x; auto.
rewrite <- (Zmod_def_small x p); auto with zarith.
rewrite <- (Zmod_def_small a0 p); auto with zarith.
apply Zis_mod_def_inv; auto with zarith.
apply Zis_mod_cancel with a; auto with zarith.
(repeat rewrite (Zmult_comm a)); apply Zis_mod_def; auto with zarith.
split; auto with datatypes zarith.
apply Zle_trans with 1; auto with datatypes zarith.
split; auto with datatypes zarith.
apply Zle_trans with 1; auto with datatypes zarith.
apply H; auto with datatypes zarith.
apply ulist_inv with ( 1 := H4 ).
rewrite Z_of_nat_Zabs_nat; auto with zarith.
apply ulist_Zprogression.
intros b Hb.
apply in_Zprogression; auto with zarith.
case (in_map_inv _ _ _ _ _ Hb); intros c [Hc1 Hc2].
subst b.
assert (Hd: 1 + Z_of_nat (Zabs_nat (p - 1)) = p).
rewrite Z_of_nat_Zabs_nat; auto with zarith.
rewrite Hd.
case (Z_mod_lt (c * a) p); auto with zarith; intros Hm1 Hm2; split;
 auto with zarith.
case (Zle_lt_or_eq _ _ Hm1); auto with zarith.
intros Hm3.
assert (Hm4: Zdivide p (c * a)); auto with zarith.
apply Zmod_divide; auto with zarith.
case (prime_mult _ H1 _ _ Hm4).
intros [d Hd1]; case (Zle_or_lt d 0); intros Hm5.
absurd (1 <= c); auto with zarith.
apply Zlt_not_le; subst c.
apply Zle_lt_trans with (0 * p); auto with zarith.
apply Zprogression_le_init with ( 1 := Hc1 ).
absurd (c < 1 * p).
apply Zle_not_lt; subst c; auto with zarith.
rewrite <- Hd.
rewrite Zmult_1_l.
apply Zprogression_le_end with ( 1 := Hc1 ).
intros Hm5; case (Zdivide_1 p); auto with zarith.
apply Gauss with ( b := a ); auto with zarith.
apply rel_prime_sym; auto with zarith.
apply length_map.
unfold Zprod; rewrite Zle_imp_le_bool; auto with zarith.
elim (progression Zsucc 1 (Zabs_nat ((1 + (p - 1)) - 1))); simpl;
 auto with zarith.
intros a0 l H.
rewrite (Zmod_mult ((a0 * a) mod p)); auto with zarith.
rewrite H.
rewrite Zmod_mod; auto with zarith.
rewrite <- Zmod_mult; auto with zarith.
Qed.


Require Import Coq.Lists.List.
Require Import Coq.Sorting.Permutation.
Import List Setoid Compare_dec Morphisms FinFun PeanoNat Permutation.
Import ListNotations.
Local Set Implicit Arguments.

(** From Coq's Coq.Sorting.Permutation file on newer versions of Coq than 8.11 *)
Module Export Coq.
Module Export Sorting.
Module Permutation.
Export Coq.Sorting.Permutation.

Section Permutation_properties.

Variable A B:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** TODO: Remove this when be bump the minimum version to Coq 8.12 *)
Local Hint Resolve perm_swap perm_trans : core.
Lemma Permutation_Forall2 (P : A -> B -> Prop) :
 forall l1 l1' (l2 : list B), Permutation l1 l1' -> Forall2 P l1 l2 ->
 exists l2' : list B, Permutation l2 l2' /\ Forall2 P l1' l2'.
Proof using Type.
  intros l1 l1' l2 HP.
  revert l2; induction HP; intros l2 HF; inversion HF as [ | ? b ? ? HF1 HF2 ]; subst.
  - now exists nil.
  - apply IHHP in HF2 as [l2' [HP2 HF2]].
    exists (b :: l2'); auto.
  - inversion_clear HF2 as [ | ? b' ? l2' HF3 HF4 ].
    exists (b' :: b :: l2'); auto.
  - apply Permutation_nil in HP1; subst.
    apply Permutation_nil in HP2; subst.
    now exists nil.
  - apply IHHP1 in HF as [l2' [HP2' HF2']].
    apply IHHP2 in HF2' as [l2'' [HP2'' HF2'']].
    exists l2''; split; auto.
    now transitivity l2'.
Qed.

End Permutation_properties.
End Permutation.
End Sorting.
End Coq.


Require Import List BasicTactics EqDec.
Import ListNotations.

Export List.
Export ListNotations.

Notation "f <$> l" := (map f l) (at level 35).

Lemma concatIn {A} {a:A} l {L} : In a l -> In l L -> In a (concat L).
  induction L as [|l' L']; simpl; intros.
  + contradiction.
  + apply in_or_app.
    simpl in *.
    intuition.
    subst.
    intuition.
Qed.

Lemma concat_app {A} {l l':list (list A)} : concat (l ++ l') = concat l ++ concat l'.
  induction l; simpl.
  - reflexivity.
  - rewrite <- app_assoc.
    congruence.
Defined.

Definition elem {A} `{eqDec A} (a:A) : list A -> bool :=
  existsb (fun a' => if a =? a' then true else false).

Lemma elem_In :
  forall A `{eqDec A} a l,
    elem a l = true <-> In a l.
Proof.
  unfold elem.
  intros A H a l.
  rewrite existsb_exists.
  split.
  - intros (x & Hin & ?).
    break_if; congruence.
  - intros Hin. exists a.
    break_if; [auto | congruence].
Qed.

Fixpoint distinct {A} `{eqDec A} (l:list A) : bool :=
  match l with
  | a :: l => andb (negb (elem a l)) (distinct l)
  | [] => true
  end.

Lemma distinct_sound :
  forall A `{eqDec A} (l:list A),
    distinct l = true -> NoDup l.
Proof.
  induction l; simpl; intros.
  - constructor.
  - do_bool.
    constructor; auto.
    rewrite <- elem_In with (H := H).
    congruence.
Qed.

Lemma distinct_complete :
  forall A `{eqDec A} (l:list A),
    NoDup l -> distinct l = true.
Proof.
  induction 1; simpl.
  - auto.
  - do_bool.
    split; auto.
    rewrite <- elem_In with (H := H) in H0.
    destruct (elem x l); simpl; congruence.
Qed.

Lemma distinct_iff_NoDup :
  forall A `{eqDec A} (l:list A),
    distinct l = true <-> NoDup l.
Proof.
  intuition eauto using distinct_sound, distinct_complete.
Qed.

Lemma map_inj : forall A B (f : A -> B),
    (forall x y, f x = f y -> x = y) ->
    forall l1 l2, map f l1 = map f l2 -> l1 = l2.
Proof.
  induction l1; destruct l2; simpl; intros; auto; try discriminate.
  invc H0.
  f_equal; auto.
Qed.


(*|
####################################################
Proof of the application of a substitution on a term
####################################################

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

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

I am trying to proof that the application of an empty substitution on
a term is equal to the given term. Here is the code:
|*)

Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Recdef.
Require Import Omega.
Import ListNotations.
Set Implicit Arguments.

Inductive Term : Type :=
| Var : nat -> Term
| Fun : string -> list Term -> Term.

Definition Subst : Type := list (nat * Term).

Definition maybe {X Y: Type} (x : X) (f : Y -> X) (o : option Y): X :=
  match o with
  | None   => x
  | Some a => f a
  end.

Fixpoint lookup {A B : Type} (eqA : A -> A -> bool)
         (kvs : list (A * B)) (k : A) : option B :=
  match kvs with
  | []           => None
  | (x, y) :: xs => if eqA k x then Some y else lookup eqA xs k
  end.

(*| I am trying to proof some properties of this function. |*)

Fixpoint apply (s : Subst) (t : Term) : Term :=
  match t with
  | Var x    => maybe (Var x) id (lookup beq_nat s x)
  | Fun f ts => Fun f (map (apply s ) ts)
  end.

Lemma empty_apply_on_term : forall t, apply [] t = t.
Proof.
  intros. induction t.
  - reflexivity.
Abort. (* .none *)

(*|
I am stuck after the ``reflexivity``. I wanted to do induction on the
list build in a term but if i do so i'ĺl get stuck in a loop.
|*)

(*|
Answer (Tej Chajed)
*******************

The problem is that the automatically generated inductive principle
for the ``Term`` type is too weak, because it has another inductive
type ``list`` inside it (specifically, ``list`` is applied to the very
type being constructed). Adam Chlipala's CPDT gives a good explanation
of what's going on, as well as an example of how to manually build a
better inductive principle for such types in the `inductive types
chapter
<http://adam.chlipala.net/cpdt/html/InductiveTypes.html#lab32>`__.
I've adapted his example ``nat_tree_ind'`` principle for your ``Term``
inductive, using the builtin ``Forall`` rather than a custom
definition. With it, your theorem becomes easy to prove:
|*)

Section Term_ind'.
  Variable P : Term -> Prop.

  Hypothesis Var_case : forall (n : nat), P (Var n).

  Hypothesis Fun_case : forall (s : string) (ls : list Term),
      Forall P ls -> P (Fun s ls).

  Fixpoint Term_ind' (tr : Term) : P tr :=
    match tr with
    | Var n => Var_case n
    | Fun s ls =>
        Fun_case s
                 ((fix list_Term_ind (ls : list Term) : Forall P ls :=
                     match ls with
                     | [] => Forall_nil _
                     | tr' :: rest =>
                         Forall_cons tr' (Term_ind' tr') (list_Term_ind rest)
                     end) ls)
    end.
End Term_ind'.

Lemma empty_apply_on_term : forall t, apply [] t = t.
Proof.
  intros. induction t using Term_ind'; simpl; auto.
  f_equal. induction H; simpl; auto.
  congruence.
Qed.
                                                                                (*|
Answer (Arthur Azevedo De Amorim)
*********************************

This is a typical trap for beginners. The problem is that your
definition of ``Term`` has a recursive occurrence inside another
inductive type -- in this case, ``list``. Coq does not generate a
useful inductive principle for such types, unfortunately; you have to
program your own. Adam Chlipala's CDPT `has a chapter on inductive
types <http://adam.chlipala.net/cpdt/html/InductiveTypes.html>`__ that
describes the problem. Just look for "nested inductive types".
|*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import Rcomplete.
Require Import Max.
Local Open Scope R_scope.

Lemma tech1 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> 0 < An n) -> 0 < sum_f_R0 An N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H; apply le_n.
  simpl; apply Rplus_lt_0_compat.
  apply HrecN; intros; apply H; apply le_S; assumption.
  apply H; apply le_n.
Qed.

(* Chasles' relation *)
Lemma tech2 :
  forall (An:nat -> R) (m n:nat),
    (m < n)%nat ->
    sum_f_R0 An n =
    sum_f_R0 An m + sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m).
Proof.
  intros; induction  n as [| n Hrecn].
  elim (lt_n_O _ H).
  cut ((m < n)%nat \/ m = n).
  intro; elim H0; intro.
  replace (sum_f_R0 An (S n)) with (sum_f_R0 An n + An (S n));
  [ idtac | reflexivity ].
  replace (S n - S m)%nat with (S (n - S m)).
  replace (sum_f_R0 (fun i:nat => An (S m + i)%nat) (S (n - S m))) with
  (sum_f_R0 (fun i:nat => An (S m + i)%nat) (n - S m) +
    An (S m + S (n - S m))%nat); [ idtac | reflexivity ].
  replace (S m + S (n - S m))%nat with (S n).
  rewrite (Hrecn H1).
  ring.
  apply INR_eq; rewrite S_INR; rewrite plus_INR; do 2 rewrite S_INR;
    rewrite minus_INR.
  rewrite S_INR; ring.
  apply lt_le_S; assumption.
  apply INR_eq; rewrite S_INR; repeat rewrite minus_INR.
  repeat rewrite S_INR; ring.
  apply le_n_S; apply lt_le_weak; assumption.
  apply lt_le_S; assumption.
  rewrite H1; rewrite <- minus_n_n; simpl.
  replace (n + 0)%nat with n; [ reflexivity | ring ].
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with (S m); [ apply lt_n_Sn | assumption ].
Qed.

(* Sum of geometric sequences *)
Lemma tech3 :
  forall (k:R) (N:nat),
    k <> 1 -> sum_f_R0 (fun i:nat => k ^ i) N = (1 - k ^ S N) / (1 - k).
Proof.
  intros; cut (1 - k <> 0).
  intro; induction  N as [| N HrecN].
  simpl; rewrite Rmult_1_r; unfold Rdiv; rewrite <- Rinv_r_sym.
  reflexivity.
  apply H0.
  replace (sum_f_R0 (fun i:nat => k ^ i) (S N)) with
  (sum_f_R0 (fun i:nat => k ^ i) N + k ^ S N); [ idtac | reflexivity ];
  rewrite HrecN;
    replace ((1 - k ^ S N) / (1 - k) + k ^ S N) with
    ((1 - k ^ S N + (1 - k) * k ^ S N) / (1 - k)).
  apply Rmult_eq_reg_l with (1 - k).
  unfold Rdiv; do 2 rewrite <- (Rmult_comm (/ (1 - k)));
    repeat rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym;
      [ do 2 rewrite Rmult_1_l; simpl; ring | apply H0 ].
  apply H0.
  unfold Rdiv; rewrite Rmult_plus_distr_r; rewrite (Rmult_comm (1 - k));
    repeat rewrite Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply H0.
  apply Rminus_eq_contra; red; intro; elim H; symmetry ;
    assumption.
Qed.

Lemma tech4 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k -> (forall i:nat, An (S i) < k * An i) -> An N <= An 0%nat * k ^ N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; right; ring.
  apply Rle_trans with (k * An N).
  left; apply (H0 N).
  replace (S N) with (N + 1)%nat; [ idtac | ring ].
  rewrite pow_add; simpl; rewrite Rmult_1_r;
    replace (An 0%nat * (k ^ N * k)) with (k * (An 0%nat * k ^ N));
    [ idtac | ring ]; apply Rmult_le_compat_l.
  assumption.
  apply HrecN.
Qed.

Lemma tech5 :
  forall (An:nat -> R) (N:nat), sum_f_R0 An (S N) = sum_f_R0 An N + An (S N).
Proof.
  intros; reflexivity.
Qed.

Lemma tech6 :
  forall (An:nat -> R) (k:R) (N:nat),
    0 <= k ->
    (forall i:nat, An (S i) < k * An i) ->
    sum_f_R0 An N <= An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; right; ring.
  apply Rle_trans with (An 0%nat * sum_f_R0 (fun i:nat => k ^ i) N + An (S N)).
  rewrite tech5; do 2 rewrite <- (Rplus_comm (An (S N)));
    apply Rplus_le_compat_l.
  apply HrecN.
  rewrite tech5; rewrite Rmult_plus_distr_l; apply Rplus_le_compat_l.
  apply tech4; assumption.
Qed.

Lemma tech7 : forall r1 r2:R, r1 <> 0 -> r2 <> 0 -> r1 <> r2 -> / r1 <> / r2.
Proof.
  intros; red; intro.
  assert (H3 := Rmult_eq_compat_l r1 _ _ H2).
  rewrite <- Rinv_r_sym in H3; [ idtac | assumption ].
  assert (H4 := Rmult_eq_compat_l r2 _ _ H3).
  rewrite Rmult_1_r in H4; rewrite <- Rmult_assoc in H4.
  rewrite Rinv_r_simpl_m in H4; [ idtac | assumption ].
  elim H1; symmetry ; assumption.
Qed.

Lemma tech11 :
  forall (An Bn Cn:nat -> R) (N:nat),
    (forall i:nat, An i = Bn i - Cn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N - sum_f_R0 Cn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H.
  do 3 rewrite tech5; rewrite HrecN; rewrite (H (S N)); ring.
Qed.

Lemma tech12 :
  forall (An:nat -> R) (x l:R),
    Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l ->
    Pser An x l.
Proof.
  intros; unfold Pser; unfold infinite_sum; unfold Un_cv in H;
    assumption.
Qed.

Lemma scal_sum :
  forall (An:nat -> R) (N:nat) (x:R),
    x * sum_f_R0 An N = sum_f_R0 (fun i:nat => An i * x) N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; ring.
  do 2 rewrite tech5.
  rewrite Rmult_plus_distr_l; rewrite <- HrecN; ring.
Qed.

Lemma decomp_sum :
  forall (An:nat -> R) (N:nat),
    (0 < N)%nat ->
    sum_f_R0 An N = An 0%nat + sum_f_R0 (fun i:nat => An (S i)) (pred N).
Proof.
  intros; induction  N as [| N HrecN].
  elim (lt_irrefl _ H).
  cut ((0 < N)%nat \/ N = 0%nat).
  intro; elim H0; intro.
  cut (S (pred N) = pred (S N)).
  intro; rewrite <- H2.
  do 2 rewrite tech5.
  replace (S (S (pred N))) with (S N).
  rewrite (HrecN H1); ring.
  rewrite H2; simpl; reflexivity.
  destruct (O_or_S N) as [(m,<-)|<-].
  simpl; reflexivity.
  elim (lt_irrefl _ H1).
  rewrite H1; simpl; reflexivity.
  inversion H.
  right; reflexivity.
  left; apply lt_le_trans with 1%nat; [ apply lt_O_Sn | assumption ].
Qed.

Lemma plus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i + Bn i) N = sum_f_R0 An N + sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_eq :
  forall (An Bn:nat -> R) (N:nat),
    (forall i:nat, (i <= N)%nat -> An i = Bn i) ->
    sum_f_R0 An N = sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H; apply le_n.
  do 2 rewrite tech5; rewrite HrecN.
  rewrite (H (S N)); [ reflexivity | apply le_n ].
  intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

(* Unicity of the limit defined by convergent series *)
Lemma uniqueness_sum :
  forall (An:nat -> R) (l1 l2:R),
    infinite_sum An l1 -> infinite_sum An l2 -> l1 = l2.
Proof.
  unfold infinite_sum; intros.
  case (Req_dec l1 l2); intro.
  assumption.
  cut (0 < Rabs ((l1 - l2) / 2)); [ intro | apply Rabs_pos_lt ].
  elim (H (Rabs ((l1 - l2) / 2)) H2); intros.
  elim (H0 (Rabs ((l1 - l2) / 2)) H2); intros.
  set (N := max x0 x); cut (N >= x0)%nat.
  cut (N >= x)%nat.
  intros; assert (H7 := H3 N H5); assert (H8 := H4 N H6).
  cut (Rabs (l1 - l2) <= R_dist (sum_f_R0 An N) l1 + R_dist (sum_f_R0 An N) l2).
  intro; assert (H10 := Rplus_lt_compat _ _ _ _ H7 H8);
    assert (H11 := Rle_lt_trans _ _ _ H9 H10); unfold Rdiv in H11;
      rewrite Rabs_mult in H11.
  cut (Rabs (/ 2) = / 2).
  intro; rewrite H12 in H11; assert (H13 := double_var); unfold Rdiv in H13;
    rewrite <- H13 in H11.
  elim (Rlt_irrefl _ H11).
  apply Rabs_right; left; change (0 < / 2); apply Rinv_0_lt_compat;
    cut (0%nat <> 2%nat);
      [ intro H20; generalize (lt_INR_0 2 (neq_O_lt 2 H20)); unfold INR;
        intro; assumption
        | discriminate ].
  unfold R_dist; rewrite <- (Rabs_Ropp (sum_f_R0 An N - l1));
    rewrite Ropp_minus_distr'.
  replace (l1 - l2) with (l1 - sum_f_R0 An N + (sum_f_R0 An N - l2));
  [ idtac | ring ].
  apply Rabs_triang.
  unfold ge; unfold N; apply le_max_r.
  unfold ge; unfold N; apply le_max_l.
  unfold Rdiv; apply prod_neq_R0.
  apply Rminus_eq_contra; assumption.
  apply Rinv_neq_0_compat; discrR.
Qed.

Lemma minus_sum :
  forall (An Bn:nat -> R) (N:nat),
    sum_f_R0 (fun i:nat => An i - Bn i) N = sum_f_R0 An N - sum_f_R0 Bn N.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; ring.
  do 3 rewrite tech5; rewrite HrecN; ring.
Qed.

Lemma sum_decomposition :
  forall (An:nat -> R) (N:nat),
    sum_f_R0 (fun l:nat => An (2 * l)%nat) (S N) +
    sum_f_R0 (fun l:nat => An (S (2 * l))) N = sum_f_R0 An (2 * S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl; ring.
  rewrite tech5.
  rewrite (tech5 (fun l:nat => An (S (2 * l))) N).
  replace (2 * S (S N))%nat with (S (S (2 * S N))).
  rewrite (tech5 An (S (2 * S N))).
  rewrite (tech5 An (2 * S N)).
  rewrite <- HrecN.
  ring.
  ring.
Qed.

Lemma sum_Rle :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n <= Bn n) ->
    sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl; apply H.
  apply le_n.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l.
  apply H.
  apply le_n.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l.
  apply HrecN.
  intros; apply H.
  apply le_trans with N; [ assumption | apply le_n_Sn ].
Qed.

Lemma Rsum_abs :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun l:nat => Rabs (An l)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l.
  apply HrecN.
Qed.

Lemma sum_cte :
  forall (x:R) (N:nat), sum_f_R0 (fun _:nat => x) N = x * INR (S N).
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl; ring.
  rewrite tech5.
  rewrite HrecN; repeat rewrite S_INR; ring.
Qed.

(**********)
Lemma sum_growing :
  forall (An Bn:nat -> R) (N:nat),
    (forall n:nat, An n <= Bn n) -> sum_f_R0 An N <= sum_f_R0 Bn N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl; apply H.
  do 2 rewrite tech5.
  apply Rle_trans with (sum_f_R0 An N + Bn (S N)).
  apply Rplus_le_compat_l; apply H.
  do 2 rewrite <- (Rplus_comm (Bn (S N))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma Rabs_triang_gen :
  forall (An:nat -> R) (N:nat),
    Rabs (sum_f_R0 An N) <= sum_f_R0 (fun i:nat => Rabs (An i)) N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl.
  right; reflexivity.
  do 2 rewrite tech5.
  apply Rle_trans with (Rabs (sum_f_R0 An N) + Rabs (An (S N))).
  apply Rabs_triang.
  do 2 rewrite <- (Rplus_comm (Rabs (An (S N)))).
  apply Rplus_le_compat_l; apply HrecN.
Qed.

(**********)
Lemma cond_pos_sum :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, 0 <= An n) -> 0 <= sum_f_R0 An N.
Proof.
  intros.
  induction  N as [| N HrecN].
  simpl; apply H.
  rewrite tech5.
  apply Rplus_le_le_0_compat.
  apply HrecN.
  apply H.
Qed.

(* Cauchy's criterion for series *)
Definition Cauchy_crit_series (An:nat -> R) : Prop :=
  Cauchy_crit (fun N:nat => sum_f_R0 An N).

(* If (|An|) satisfies the Cauchy's criterion for series, then (An) too *)
Lemma cauchy_abs :
  forall An:nat -> R,
    Cauchy_crit_series (fun i:nat => Rabs (An i)) -> Cauchy_crit_series An.
Proof.
  unfold Cauchy_crit_series; unfold Cauchy_crit.
  intros.
  elim (H eps H0); intros.
  exists x.
  intros.
  cut
    (R_dist (sum_f_R0 An n) (sum_f_R0 An m) <=
      R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  intro.
  apply Rle_lt_trans with
    (R_dist (sum_f_R0 (fun i:nat => Rabs (An i)) n)
      (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  assumption.
  apply H1; assumption.
  destruct (lt_eq_lt_dec n m) as [[ | -> ]|].
  rewrite (tech2 An n m); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) n m); [ idtac | assumption ].
  unfold R_dist.
  unfold Rminus.
  do 2 rewrite Ropp_plus_distr.
  do 2 rewrite <- Rplus_assoc.
  do 2 rewrite Rplus_opp_r.
  do 2 rewrite Rplus_0_l.
  do 2 rewrite Rabs_Ropp.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S n + i)%nat)) (m - S n)))
    .
  set (Bn := fun i:nat => An (S n + i)%nat).
  replace (fun i:nat => Rabs (An (S n + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
  unfold R_dist.
  unfold Rminus; do 2 rewrite Rplus_opp_r.
  rewrite Rabs_R0; right; reflexivity.
  rewrite (tech2 An m n); [ idtac | assumption ].
  rewrite (tech2 (fun i:nat => Rabs (An i)) m n); [ idtac | assumption ].
  unfold R_dist.
  unfold Rminus.
  do 2 rewrite Rplus_assoc.
  rewrite (Rplus_comm (sum_f_R0 An m)).
  rewrite (Rplus_comm (sum_f_R0 (fun i:nat => Rabs (An i)) m)).
  do 2 rewrite Rplus_assoc.
  do 2 rewrite Rplus_opp_l.
  do 2 rewrite Rplus_0_r.
  rewrite
    (Rabs_right (sum_f_R0 (fun i:nat => Rabs (An (S m + i)%nat)) (n - S m)))
    .
  set (Bn := fun i:nat => An (S m + i)%nat).
  replace (fun i:nat => Rabs (An (S m + i)%nat)) with
  (fun i:nat => Rabs (Bn i)).
  apply Rabs_triang_gen.
  unfold Bn; reflexivity.
  apply Rle_ge.
  apply cond_pos_sum.
  intro; apply Rabs_pos.
Qed.

(**********)
Lemma cv_cauchy_1 :
  forall An:nat -> R,
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
    Cauchy_crit_series An.
Proof.
  intros An (x,p).
  unfold Un_cv in p.
  unfold Cauchy_crit_series; unfold Cauchy_crit.
  intros.
  cut (0 < eps / 2).
  intro.
  elim (p (eps / 2) H0); intros.
  exists x0.
  intros.
  apply Rle_lt_trans with (R_dist (sum_f_R0 An n) x + R_dist (sum_f_R0 An m) x).
  unfold R_dist.
  replace (sum_f_R0 An n - sum_f_R0 An m) with
  (sum_f_R0 An n - x + - (sum_f_R0 An m - x)); [ idtac | ring ].
  rewrite <- (Rabs_Ropp (sum_f_R0 An m - x)).
  apply Rabs_triang.
  apply Rlt_le_trans with (eps / 2 + eps / 2).
  apply Rplus_lt_compat.
  apply H1; assumption.
  apply H1; assumption.
  right; symmetry ; apply double_var.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

Lemma cv_cauchy_2 :
  forall An:nat -> R,
    Cauchy_crit_series An ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros.
  apply R_complete.
  unfold Cauchy_crit_series in H.
  exact H.
Qed.

(**********)
Lemma sum_eq_R0 :
  forall (An:nat -> R) (N:nat),
    (forall n:nat, (n <= N)%nat -> An n = 0) -> sum_f_R0 An N = 0.
Proof.
  intros; induction  N as [| N HrecN].
  simpl; apply H; apply le_n.
  rewrite tech5; rewrite HrecN;
    [ rewrite Rplus_0_l; apply H; apply le_n
      | intros; apply H; apply le_trans with N; [ assumption | apply le_n_Sn ] ].
Qed.

Definition SP (fn:nat -> R -> R) (N:nat) (x:R) : R :=
  sum_f_R0 (fun k:nat => fn k x) N.

(**********)
Lemma sum_incr :
  forall (An:nat -> R) (N:nat) (l:R),
    Un_cv (fun n:nat => sum_f_R0 An n) l ->
    (forall n:nat, 0 <= An n) -> sum_f_R0 An N <= l.
Proof.
  intros; destruct (total_order_T (sum_f_R0 An N) l) as [[Hlt|Heq]|Hgt].
  left; apply Hlt.
  right; apply Heq.
  cut (Un_growing (fun n:nat => sum_f_R0 An n)).
  intro; set (l1 := sum_f_R0 An N) in Hgt.
  unfold Un_cv in H; cut (0 < l1 - l).
  intro; elim (H _ H2); intros.
  set (N0 := max x N); cut (N0 >= x)%nat.
  intro; assert (H5 := H3 N0 H4).
  cut (l1 <= sum_f_R0 An N0).
  intro; unfold R_dist in H5; rewrite Rabs_right in H5.
  cut (sum_f_R0 An N0 < l1).
  intro; elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H7 H6)).
  apply Rplus_lt_reg_l with (- l).
  do 2 rewrite (Rplus_comm (- l)).
  apply H5.
  apply Rle_ge; apply Rplus_le_reg_l with l.
  rewrite Rplus_0_r; replace (l + (sum_f_R0 An N0 - l)) with (sum_f_R0 An N0);
    [ idtac | ring ]; apply Rle_trans with l1.
  left; apply Hgt.
  apply H6.
  unfold l1; apply Rge_le;
    apply (growing_prop (fun k:nat => sum_f_R0 An k)).
  apply H1.
  unfold ge, N0; apply le_max_r.
  unfold ge, N0; apply le_max_l.
  apply Rplus_lt_reg_l with l; rewrite Rplus_0_r;
    replace (l + (l1 - l)) with l1; [ apply Hgt | ring ].
  unfold Un_growing; intro; simpl;
    pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r;
      apply Rplus_le_compat_l; apply H0.
Qed.

(**********)
Lemma sum_cv_maj :
  forall (An:nat -> R) (fn:nat -> R -> R) (x l1 l2:R),
    Un_cv (fun n:nat => SP fn n x) l1 ->
    Un_cv (fun n:nat => sum_f_R0 An n) l2 ->
    (forall n:nat, Rabs (fn n x) <= An n) -> Rabs l1 <= l2.
Proof.
  intros; destruct (total_order_T (Rabs l1) l2) as [[Hlt|Heq]|Hgt].
  left; apply Hlt.
  right; apply Heq.
  cut (forall n0:nat, Rabs (SP fn n0 x) <= sum_f_R0 An n0).
  intro; cut (0 < (Rabs l1 - l2) / 2).
  intro; unfold Un_cv in H, H0.
  elim (H _ H3); intros Na H4.
  elim (H0 _ H3); intros Nb H5.
  set (N := max Na Nb).
  unfold R_dist in H4, H5.
  cut (Rabs (sum_f_R0 An N - l2) < (Rabs l1 - l2) / 2).
  intro; cut (Rabs (Rabs l1 - Rabs (SP fn N x)) < (Rabs l1 - l2) / 2).
  intro; cut (sum_f_R0 An N < (Rabs l1 + l2) / 2).
  intro; cut ((Rabs l1 + l2) / 2 < Rabs (SP fn N x)).
  intro; cut (sum_f_R0 An N < Rabs (SP fn N x)).
  intro; assert (H11 := H2 N).
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H11 H10)).
  apply Rlt_trans with ((Rabs l1 + l2) / 2); assumption.
  destruct (Rcase_abs (Rabs l1 - Rabs (SP fn N x))) as [Hlt|Hge].
  apply Rlt_trans with (Rabs l1).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv; rewrite (Rmult_comm 2); rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite double; apply Rplus_lt_compat_l; apply Hgt.
  discrR.
  apply (Rminus_lt _ _ Hlt).
  rewrite (Rabs_right _ Hge) in H7.
  apply Rplus_lt_reg_l with ((Rabs l1 - l2) / 2 - Rabs (SP fn N x)).
  replace ((Rabs l1 - l2) / 2 - Rabs (SP fn N x) + (Rabs l1 + l2) / 2) with
  (Rabs l1 - Rabs (SP fn N x)).
  unfold Rminus; rewrite Rplus_assoc; rewrite Rplus_opp_l;
    rewrite Rplus_0_r; apply H7.
  unfold Rdiv; rewrite Rmult_plus_distr_r;
    rewrite <- (Rmult_comm (/ 2)); rewrite Rmult_minus_distr_l;
      repeat rewrite (Rmult_comm (/ 2)); pattern (Rabs l1) at 1;
        rewrite double_var; unfold Rdiv in |- *; ring.
  destruct (Rcase_abs (sum_f_R0 An N - l2)) as [Hlt|Hge].
  apply Rlt_trans with l2.
  apply (Rminus_lt _ _ Hlt).
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite (double l2); unfold Rdiv; rewrite (Rmult_comm 2);
    rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; rewrite (Rplus_comm (Rabs l1)); apply Rplus_lt_compat_l;
    apply Hgt.
  discrR.
  rewrite (Rabs_right _ Hge) in H6; apply Rplus_lt_reg_l with (- l2).
  replace (- l2 + (Rabs l1 + l2) / 2) with ((Rabs l1 - l2) / 2).
  rewrite Rplus_comm; apply H6.
  unfold Rdiv; rewrite <- (Rmult_comm (/ 2));
    rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_r;
      pattern l2 at 2; rewrite double_var;
        repeat rewrite (Rmult_comm (/ 2)); rewrite Ropp_plus_distr;
          unfold Rdiv; ring.
  apply Rle_lt_trans with (Rabs (SP fn N x - l1)).
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply Rabs_triang_inv2.
  apply H4; unfold ge, N; apply le_max_l.
  apply H5; unfold ge, N; apply le_max_r.
  unfold Rdiv; apply Rmult_lt_0_compat.
  apply Rplus_lt_reg_l with l2.
  rewrite Rplus_0_r; replace (l2 + (Rabs l1 - l2)) with (Rabs l1);
    [ apply Hgt | ring ].
  apply Rinv_0_lt_compat; prove_sup0.
  intros; induction  n0 as [| n0 Hrecn0].
  unfold SP; simpl; apply H1.
  unfold SP; simpl.
  apply Rle_trans with
    (Rabs (sum_f_R0 (fun k:nat => fn k x) n0) + Rabs (fn (S n0) x)).
  apply Rabs_triang.
  apply Rle_trans with (sum_f_R0 An n0 + Rabs (fn (S n0) x)).
  do 2 rewrite <- (Rplus_comm (Rabs (fn (S n0) x))).
  apply Rplus_le_compat_l; apply Hrecn0.
  apply Rplus_le_compat_l; apply H1.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Lists accessed with integers (not nat), using LibContainer typeclasses  *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
From SLF (* TLC *) Require Import LibTactics LibLogic LibOperation LibReflect
  LibProd LibNat LibInt LibOption LibWf.
From SLF (* TLC *) Require Export LibList LibNat.
From SLF (* TLC *) Require Import LibInt.
From SLF (* TLC *) Require Export LibContainer.

Open Scope Int_scope.
Local Open Scope comp_scope.

Ltac auto_tilde ::= eauto with maths.

(* ********************************************************************** *)
(* ################################################################# *)
(** * List operations using indices in Z *)

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Length, with result as [int] *)

(** Defined using a coercion from [nat] to [int] *)

Definition length A (l:list A) : int :=
  LibList.length l.

Section Length.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types i : int.

Lemma length_eq : forall l,
  length l = LibList.length l.
Proof using. auto. Qed.

Lemma abs_length : forall i l,
  i = length l ->
  abs i = LibList.length l.
Proof using.
  introv E. unfold length in E.
  applys eq_nat_of_eq_int.
  rewrite abs_nonneg; math.
Qed.

Lemma length_nonneg : forall (l: list A),
  0 <= length l.
Proof using. intros. rewrite length_eq. math. Qed.

Lemma length_nil :
  length (@nil A) = 0.
Proof using. auto. Qed.

Lemma length_cons : forall x l,
  length (x::l) = 1 + length l.
Proof using. intros. unfold length. rew_list~. Qed.

Lemma length_one: forall x,
  length (x::nil) = 1.
Proof using. reflexivity. Qed.

Lemma length_app : forall l1 l2,
  length (l1 ++ l2) = length l1 + length l2.
Proof using. intros. unfold length. rew_list~. Qed.

Lemma length_last : forall x l,
  length (l & x) = 1 + length l.
Proof using. intros. unfold length. rew_list~. Qed.

End Length.

Hint Rewrite length_nil length_cons length_app
 length_last : rew_list.
Hint Rewrite length_nil length_cons length_app
 length_last : rew_listx.
 (* --TODO: should we use a separate [rew_listZ] data base? probably so *)

(** Automation for [math], to unfold [length] *)

Hint Rewrite length_eq : rew_maths.

(** Demo of automation with maths *)

Goal forall A (l : list A), 0 <= length l.
Proof using. intros. math. Qed.

Goal forall (l : list Z) (s n : int),
  s <= n ->
  s = length l ->
  n >= 0.
Proof using. intros. math. Qed.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Inversion lemmas for structural composition *)

Section AppInversion.
Variables A : Type.
Implicit Types x : A.
Implicit Types l : list A.

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

Lemma length_zero_inv : forall l,
  length l = 0 ->
  l = nil.
Proof using. intros. unfolds length. applys~ LibList.length_zero_inv. Qed.

Lemma length_zero_eq_eq_nil : forall l,
  (length l = 0) = (l = nil).
Proof using.
  intros. unfolds length. rewrite <-LibList.length_zero_eq_eq_nil. math.
Qed.

Lemma length_neq_inv : forall l1 l2,
  length l1 <> length l2 ->
  (l1 <> l2).
Proof using. introv N E. subst*. Qed.

Lemma length_pos_inv_cons : forall l,
  (length l > 0) ->
  exists x l', l = x :: l'.
Proof using.
  intros. unfolds length. applys~ LibList.length_pos_inv_cons.
Qed.

Lemma length_pos_inv_last : forall l,
  (length l > 0) ->
  exists x l', l = l' & x.
Proof using.
  intros. unfolds length. applys~ LibList.length_pos_inv_last.
Qed.

End AppInversion.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [index], with length as [int], as typeclass *)

Definition index_impl A (l:list A) (i:int) : Prop :=
  index (LibList.length l : int) i.

Instance index_inst : forall A, BagIndex int (list A).
Proof using. constructor. rapply (@index_impl A). Defined.

Section Index.
Variables (A : Type).
Implicit Types l : list A.
Implicit Types n i : int.

Lemma index_eq_inbound : forall l i,
  index l i = (0 <= i < length l).
Proof using. auto. Qed.

Lemma index_of_inbound : forall l i,
  0 <= i < length l ->
  index l i.
Proof using. intros. rewrite~ index_eq_inbound. Qed.

Lemma index_eq_index_length : forall l i,
  index l i = index (length l) i.
Proof using. auto. Qed.

Lemma index_of_index_length : forall l i,
  index (length l) i ->
  index l i.
Proof using. introv H. rewrite* index_eq_index_length. Qed.

(** Reformulation of above, helpful for automation *)

Lemma index_of_index_length' : forall l n i,
  index n i ->
  n = length l ->
  index l i.
Proof using. intros. subst. rewrite~ index_eq_index_length. Qed.

End Index.

Global Opaque index_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [read], with length as [int], as typeclass *)

Definition read_impl `{Inhab A} (l:list A) (i:int) : A :=
  If i < 0 then arbitrary else nth (abs i) l.

Instance read_inst : forall `{Inhab A}, BagRead int A (list A).
Proof using. constructor. rapply (@read_impl A H). Defined.

Section Read.
Context (A : Type) `{Inhab A}.
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma read_cons_case : forall l i v,
  (v::l)[i] = (If i = 0 then v else l[i-1]).
Proof using.
  introv. simpl. unfold read_impl. case_if.
  { case_if. math. case_if~. math. }
  { case_if~.
    { subst. rewrite abs_0. rew_listx~. }
    { rewrite~ abs_eq_succ_abs_minus_one. rew_listx.
      case_if. math. auto. } }
Qed.

Lemma read_zero : forall x l,
  (x::l)[0] = x.
Proof using.
  intros. rewrite read_cons_case. case_if. auto.
Qed.

Lemma read_succ : forall x l i,
  0 <= i < length l ->
  (x::l)[i+1] = l[i].
Proof using.
  introv M. rewrite read_cons_case. case_if. { math. }
  fequals. math.
Qed.

Lemma read_last_case : forall l i v,
  (l & v)[i] = (If i = length l then v else l[i]).
Proof using.
  introv. simpl. unfold read_impl. case_if.
  { case_if~; math. }
  { rewrite nth_last_case. rewrite~ abs_eq_nat_eq. }
Qed.

Lemma read_middle : forall i l1 l2 x,
  i = length l1 ->
  (l1 ++ x :: l2)[i] = x.
Proof.
  introv M. rewrite length_eq in M. unfold read, read_inst, read_impl.
  case_if. { false; math. }
  rewrite~ nth_middle. subst. rewrite~ abs_nat.
Qed.

Lemma read_app : forall i l1 l2,
  (l1 ++ l2)[i] = (If i < length l1 then l1[i] else l2[i - length l1]).
Proof using.
  intros. rewrite length_eq. unfold read, read_inst, read_impl. case_if.
  { case_if. { auto. } { false; math. } }
  case_if as C'.
  { applys nth_app_l. applys lt_nat_of_lt_int. rewrite abs_nonneg; math. }
  case_if. { false; math. }
  rewrite abs_gt_minus_nat; [|math]. applys nth_app_r.
  { applys ge_nat_of_ge_int. rewrite abs_nonneg; math. }
Qed.

(** * Equality between two lists from equality of length and
      extensional equality of reads. *)

Lemma eq_of_extens_range : forall l1 l2,
  length l1 = length l2 ->
  (forall i, 0 <= i < length l1 -> l1[i] = l2[i]) ->
  l1 = l2.
Proof using.
  introv HL HR. do 2 rewrite length_eq in HL.
  unfold read, read_inst, read_impl in HR.
  applys~ LibList.eq_of_extens l1 l2.
  { intros n L. forwards M: (rm HR) (nat_to_Z n). math.
    case_if. false; math. rewrite~ abs_nat in M. }
Qed.

Lemma eq_of_extens : forall l1 l2,
  length l1 = length l2 ->
  (forall i, index l1 i -> l1[i] = l2[i]) ->
  l1 = l2.
Proof using. intros. applys~ eq_of_extens_range. Qed.

End Read.

Global Opaque read_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [update], with index as [int], as typeclass *)

Definition update_impl A (l:list A) (i:int) (v:A) : list A :=
  If i < 0 then l else LibList.update (abs i) v l.

Instance update_inst : forall A, BagUpdate int A (list A).
Proof using. constructor. rapply (@update_impl A). Defined.

Section Update.
Transparent index_inst read_inst update_inst.
Context (A : Type) `{IA:Inhab A}.
Implicit Types x v w : A.
Implicit Types l : list A.
Implicit Types i j : int.

Lemma length_update : forall l i v,
  length (l[i:=v]) = length l.
Proof using.
  intros. unfold update_inst, update_impl, length, update. simpl.
  case_if. math. rewrite~ length_update.
Qed.

Lemma index_update_eq : forall l i j v,
  index (l[j:=v]) i = index l i.
Proof using. intros. rewrite index_eq_index_length in *. rewrite~ length_update. Qed.

Lemma index_update : forall l i j v,
  index l i ->
  index (l[j:=v]) i.
Proof using. intros. rewrite~ index_update_eq. Qed.

Lemma read_update_case : forall l i j v,
  index l j ->
  l[i:=v][j] = (If i = j then v else l[j]).
Proof using.
  introv. unfold index_inst, index_impl, update_inst, update_impl, update,
    read_inst, read_impl. simpl. introv N. rewrite int_index_eq in N.
  case_if. math.
  case_if. case_if. auto. case_if.
    subst. rewrite~ nth_update_same. apply lt_nat_of_lt_int. rewrite abs_nonneg; try math.
    rewrite~ nth_update_neq. apply neq_nat_of_neq_int. rewrite abs_nonneg; try math.
     rewrite abs_nonneg; try math.
Qed.

Lemma read_update_same : forall l i v,
  index l i ->
  (l[i:=v])[i] = v.
Proof using. introv N. rewrite~ read_update_case. case_if~. Qed.

Lemma read_update_neq : forall l i j v,
  index l j ->
  (i <> j) ->
  (l[i:=v])[j] = l[j].
Proof using. introv N. rewrite~ read_update_case. case_if; auto_false~. Qed.

End Update.

Section UpdateNoInhab.
Transparent index_inst read_inst update_inst.
Context (A : Type).
Implicit Types x v w : A.
Implicit Types l : list A.
Implicit Types i j : int.

Lemma update_zero : forall v x l,
  (x::l)[0:=v] = v::l.
Proof using.
  intros. unfold update, update_inst, update_impl.
  case_if. false; math. rewrite~ update_zero.
Qed.

Lemma update_cons_pos : forall n v x l,
  n > 0 ->
  (x::l)[n:=v] = x::(l[(n-1):=v]).
Proof using.
  introv N. unfold update, update_inst, update_impl.
  do 2 (case_if; try solve [ false; math ]).
  rewrite~ update_cons_pos.
  { fequals_rec. rewrite <- abs_gt_minus_nat. fequals. math. }
  { applys gt_nat_of_gt_int. rewrite abs_nonneg; math. }
Qed.

Lemma update_update_same : forall l i v w,
  index l i ->
  l[i:=v][i:=w] = l[i:=w].
Proof using.
  intros. asserts IA: (Inhab A). typeclass.
  eapply eq_of_extens; repeat rewrite length_update. { auto. }
  intros k Hk. repeat rewrite index_update_eq in Hk.
  repeat rewrite read_update_case by eauto using index_update.
  case_if~.
Qed.

Lemma update_update_neq : forall l i j v w,
  index l i ->
  index l j ->
  i <> j ->
  l[i:=v][j:=w] = l[j:=w][i:=v].
Proof using.
  intros. asserts IA: (Inhab A). typeclass.
  applys eq_of_extens; repeat rewrite length_update. { auto. }
  intros k Hk. repeat rewrite index_update_eq in Hk.
  repeat rewrite read_update_case by eauto using index_update.
  repeat case_if~.
Qed.

Lemma update_app_l : forall l1 i l2 v,
  0 <= i < length l1 ->
  (l1 ++ l2)[i:=v] = (l1[i:=v]) ++ l2.
Proof using.
  introv N. asserts IA: (Inhab A). typeclass.
  unfold LibContainer.update, update_inst, update_impl.
  rewrite length_eq in N. case_if~. rewrite~ update_app_l.
  applys lt_nat_of_lt_int. rewrite~ abs_nonneg.
Qed.

Lemma update_app_r : forall l2 j l1 i ij v,
  i = length l1 ->
  0 <= j ->
  ij = i + j ->
  (l1 ++ l2)[ij:=v] = l1 ++ (l2[j:=v]).
Proof using.
  intros. asserts IA: (Inhab A). typeclass. subst ij.
  unfold LibContainer.update, update_inst, update_impl.
  do 2 (case_if; [ math | ]).
  rewrite Zabs2Nat.inj_add; try math. subst i.
  rewrite length_eq. rewrite abs_nat.
  rewrite~ update_app_r. fequals_rec. math.
Qed.

Lemma update_middle : forall i l1 l2 v w,
  i = length l1 ->
  (l1 ++ w :: l2)[i := v] = l1 & v ++ l2.
Proof using.
  introv E. rewrites~ (>> update_app_r 0 i).
  rewrite update_zero. rew_list~.
Qed.

End UpdateNoInhab.

Global Opaque update_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [make], with length as [int] *)

Definition make A (n:int) (v:A) : list A :=
  If n < 0 then arbitrary else make (abs n) v.

Section Make.
Transparent index_inst read_inst.
Context (A : Type) {IA:Inhab A}.
Implicit Types x v : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma length_make : forall n v,
  n >= 0 ->
  length (make n v) = n.
Proof using.
  introv N. unfold make. case_if. math.
  unfold length. rewrite LibList.length_make.
  rewrite~ abs_nonneg.
Qed.

Lemma index_make : forall n i v,
  index n i ->
  index (make n v) i.
Proof using.
  introv H. rewrite index_eq_index_length.
  rewrite int_index_eq in H.
  rewrite~ length_make.
Qed.

Lemma read_make : forall i n v,
  index n i ->
  (make n v)[i] = v.
Proof using.
  introv N. rewrite int_index_eq in N.
  unfold make, read_inst, read_impl, nth.
  case_if. math. simpl. case_if. math.
  applys nth_make. forwards: lt_abs_abs i n; try math.
Qed.

Lemma make_zero : forall v,
  make 0 v = nil.
Proof using.
  intros. unfold make. case_if. { false; math. }
  asserts_rewrite (abs 0 = 0%nat).
  { applys eq_nat_of_eq_int. rewrite abs_nonneg; math. }
  auto.
Qed.

End Make.

Section MakeNoInhab.
Transparent index_inst read_inst.
Context (A : Type).
Implicit Types x v : A.
Implicit Types l : list A.
Implicit Types n i : int.

Lemma make_succ_l : forall n v,
  n >= 0 ->
  make (n+1) v = v :: make n v.
Proof using.
  introv N. unfold make. case_if; case_if; try solve [false;math].
  rewrite <- LibList.make_succ. fequal.
  { rewrite succ_abs_eq_abs_one_plus. fequal. math. math. }
Qed.

Lemma make_succ_r : forall n v,
  n >= 0 ->
  make (n+1) v = make n v & v.
Proof using.
  intros. asserts IA: (Inhab A). applys Inhab_of_val v.
  applys eq_of_extens_range.
  { rewrite length_make. rew_list. rewrite length_make.
    math. math. math. }
  { intros i Ei. rewrite length_make in Ei; [| math ].
    rewrite read_make; [| rewrite int_index_eq; math ].
    rewrite read_app. rewrite length_make; [|math].
    case_if as C.
    { rewrite read_make. auto. rewrite int_index_eq; math. }
    { math_rewrite (i-n = 0). rewrite~ read_zero. } }
Qed.

Lemma make_eq_cons_make_pred : forall n v,
  0 < n ->
  make n v = v :: (make (n-1) v).
Proof using.
  intros. math_rewrite (n = (n-1)+1). rewrite make_succ_l.
  fequals_rec. math. math.
Qed.

End MakeNoInhab.

Global Opaque make.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.rev] interactions with [LibListZ] operations *)

Section Rev.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma length_rev : forall l,
  length (rev l) = length l.
Proof using. intros. unfold length. rew_list~. Qed.

End Rev.

Hint Rewrite length_rev : rew_list.
Hint Rewrite length_rev : rew_listx.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.map] interactions with [LibListZ] operations *)

Section Map.
Transparent index_inst read_inst update_inst.
(*Context (A : Type).
Implicit Types x v : A.
Implicit Types l : list A.
*)
Implicit Types n i : int.

Lemma length_map : forall A B (l:list A) (f:A->B),
  length (map f l) = length l.
Proof using. intros. unfold length. rewrite~ length_map. Qed.

Lemma index_map_eq : forall A B (l:list A) i (f:A->B),
  index (map f l) i = index l i.
Proof using. intros. rewrite index_eq_inbound in *. rewrite~ length_map. Qed.

Lemma index_map : forall A B (l:list A) i (f:A->B),
  index l i -> index (map f l) i.
Proof using. intros. rewrite~ index_map_eq. Qed.

Lemma map_make : forall A B (f:A->B) (n:int) (v:A),
  n >= 0 ->
  map f (make n v) = make n (f v).
Proof using.
  Transparent make.
  intros. unfold make. case_if. { false; math. }
  applys map_make.
Qed.

Lemma map_update : forall A B (l:list A) (i:int) (x:A) (f:A->B),
  index l i ->
  map f (l[i := x]) = (map f l)[i := f x].
Proof using.
  introv H. rewrite index_eq_inbound in H.
  unfold update_inst, update_impl, update. simpl.
  case_if. { false; math. }
  { applys LibList.map_update.
    { applys lt_nat_of_lt_int. rewrite abs_nonneg; math. } }
Qed.

Lemma read_map : forall `{IA:Inhab A} `{IB:Inhab B} (l:list A) (i:int) (f:A->B),
  index l i ->
  (map f l)[i] = f (l[i]).
Proof using.
  introv H. rewrite index_eq_inbound in H.
  unfold read_inst, read_impl. simpl. case_if.
  { false; math. }
  { rewrite nth_map. auto.
    applys lt_nat_of_lt_int. rewrite abs_nonneg; math. }
Qed.

End Map.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.filter] interactions with [LibListZ] operations *)

Section Filter.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.
Implicit Types P : A -> Prop.

Lemma length_filter : forall l P,
  length (filter P l) <= length l.
Proof using.
  intros. unfolds length. forwards~: LibList.length_filter l P.
Qed.

Lemma filter_length_two_disjoint : forall (P Q : A-> Prop) l,
  (forall x, mem x l -> P x -> Q x -> False) ->
  length (filter P l) + length (filter Q l) <= length l.
Proof using.
  intros. unfolds length.
  forwards~: LibList.filter_length_two_disjoint.
Qed.

Lemma filter_length_partition : forall P l,
    length (filter (fun x => P x) l)
  + length (filter (fun x => ~ P x) l)
  <= length l.
Proof using.
  intros. unfolds length. forwards~: LibList.filter_length_partition P l.
Qed.

Lemma length_filter_eq_mem_ge_one : forall x l,
  mem x l ->
  length (filter (= x) l) >= 1.
Proof using.
  intros. unfolds length. forwards~: LibList.length_filter_eq_mem_ge_one.
Qed.

End Filter.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [LibList.remove] interactions with [LibListZ] operations *)

Section Remove.
Variables (A : Type).
Implicit Types a x : A.
Implicit Types l : list A.

Lemma length_remove : forall l a,
  length (LibList.remove a l) <= length l.
Proof using. intros. applys length_filter. Qed.

Lemma length_remove_mem : forall x l,
  mem x l ->
  length (LibList.remove x l) < length l.
Proof using.
  intros. unfolds length. forwards~: LibList.length_remove_mem.
Qed.

End Remove.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Take, with an [int] as the number of elements *)

Definition take A (n:int) (l:list A) : list A :=
  LibList.take (to_nat n) l.

Section Take.
Variables (A : Type).
Implicit Types n : int.
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_nil : forall n,
  take n (@nil A) = nil.
Proof using. intros. unfold take. apply LibList.take_nil. Qed.

Lemma take_zero : forall l,
  take 0 l = nil.
Proof using. auto. Qed.

Lemma take_succ : forall x l n,
  0 <= n ->
  take (n+1) (x::l) = x :: (take n l).
Proof using.
  intros. unfold take. rew_to_nat_nonneg~.
  rewrite Nat.add_1_r. apply LibList.take_succ.
Qed.

Definition take_cons := take_succ.

Lemma take_cons_pos : forall x l n,
  (n > 0) ->
  take n (x::l) = x :: (take (n-1) l).
Proof using.
  intros. unfold take. rew_to_nat_nonneg~.
  rewrite~ LibList.take_cons_pos.
  forwards~: lt_to_nat_to_nat 0 n.
Qed.

Lemma take_neg : forall n l,
  n <= 0 ->
  take n l = nil.
Proof using. intros. unfold take. rewrite~ to_nat_neg. Qed.

Lemma take_ge : forall n l,
  (n >= length l) ->
  take n l = l.
Proof using.
  intros. unfold take, length in *. applys~ LibList.take_ge.
  rewrites~ to_nat_ge_nat_ge.
Qed.

Lemma take_is_prefix : forall n l,
  exists q, l = take n l ++ q.
Proof using.
  intros. unfold take. applys~ LibList.take_is_prefix.
Qed.

Lemma take_app_l : forall n l l',
  (n <= length l) ->
  take n (l ++ l') = take n l.
Proof using.
  intros. tests: (0 <= n).
  { unfold take, length in *.
    applys~ LibList.take_app_l. rewrites~ to_nat_le_nat_le. }
  { rewrite !take_neg; auto; math. }
Qed.

Lemma take_app_r : forall n l l',
  (n >= length l) ->
  take n (l ++ l') = l ++ take (n - length l) l'.
Proof using.
  intros. unfold take, length in *. rew_to_nat_nonneg~.
  applys~ LibList.take_app_r. rewrites~ to_nat_ge_nat_ge.
Qed.

Lemma take_prefix_length : forall l l',
  take (length l) (l ++ l') = l.
Proof using.
  intros. unfold take, length. rew_to_nat_nonneg~.
  applys~ LibList.take_prefix_length.
Qed.

Lemma take_full_length : forall l,
  take (length l) l = l.
Proof using.
  intros. unfold take, length. rew_to_nat_nonneg~.
  apply LibList.take_full_length.
Qed.

(* See below for [length_take] and other properties *)

End Take.

(* Arguments take [A] : simpl never. *)

Hint Rewrite take_nil take_zero take_succ : rew_listx.
(* Note: [take_prefix_length] and [take_full_length]
   may be safely added to [rew_listx]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Drop, with an [int] as the number of elements. *)

Definition drop A (n:int) (l:list A) : list A :=
  LibList.drop (to_nat n) l.

Section Drop.
Variables (A : Type).
Implicit Types n : int.
Implicit Types x : A.
Implicit Types l : list A.

Lemma drop_nil : forall n,
  drop n (@nil A) = nil.
Proof using. intros. unfold drop. apply LibList.drop_nil. Qed.

Lemma drop_zero : forall l,
  drop 0 l = l.
Proof using. auto. Qed.

Lemma drop_succ : forall x l n,
  0 <= n ->
  drop (n+1) (x::l) = (drop n l).
Proof using.
  intros. unfold drop. rew_to_nat_nonneg~.
  rewrite Nat.add_1_r. apply LibList.drop_succ.
Qed.

Definition drop_cons := drop_succ.

Lemma drop_neg : forall n l,
  n <= 0 ->
  drop n l = l.
Proof using. intros. unfold drop. rewrite~ to_nat_neg. Qed.

Lemma drop_cons_pos : forall x l n,
  (n > 0) ->
  drop n (x::l) = drop (n-1) l.
Proof using.
  intros. unfold drop. rew_to_nat_nonneg~.
  apply~ LibList.drop_cons_pos.
  forwards~: lt_to_nat_to_nat 0 n.
Qed.

Lemma drop_is_suffix : forall n l,
  exists q, l = q ++ drop n l.
Proof using.
  intros. unfold drop. apply LibList.drop_is_suffix.
Qed.

Lemma drop_app_l : forall n l l',
  (n <= length l) ->
  drop n (l ++ l') = drop n l ++ l'.
Proof using.
  intros. tests: (0 <= n).
  { unfold drop, length in *.
    apply LibList.drop_app_l. rewrites~ to_nat_le_nat_le. }
  { rewrite !drop_neg; auto; math. }
Qed.

Lemma drop_app_r : forall n l l',
  (n >= length l) ->
  drop n (l ++ l') = drop (n - length l) l'.
Proof using.
  intros. unfold drop, length in *. rew_to_nat_nonneg~.
  apply LibList.drop_app_r. rewrites~ to_nat_ge_nat_ge.
Qed.

Lemma drop_app_length : forall l l',
  drop (length l) (l ++ l') = l'.
Proof using.
  intros. unfold drop, length. rew_to_nat_nonneg~.
  apply LibList.drop_app_length.
Qed.

Lemma drop_at_length : forall l,
  drop (length l) l = nil.
Proof using.
  intros. unfold drop, length. rew_to_nat_nonneg~.
  apply LibList.drop_at_length.
Qed.

(* See below for [length_drop] and other properties *)

End Drop.

(* Arguments drop [A] : simpl never. *)

Hint Rewrite drop_nil drop_zero drop_succ : rew_listx.
(* Note: [drop_prefix_length] and [drop_full_length]
   may be safely added to [rew_list]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Take and drop decomposition of a list *)

Section TakeAndDrop.
Variables (A : Type).
Implicit Types x : A.
Implicit Types l : list A.

Lemma take_app_drop_spec : forall n l f r,
  f = take n l ->
  r = drop n l ->
  (0 <= n <= length l ->
      l = f ++ r
   /\ length f = n
   /\ length r = length l - n) /\
  (n <= 0 ->
    f = nil /\ r = l).
Proof using.
  introv ? ?. split.
  { intros (? & Hn). unfold take, drop, length in *.
    forwards~ (? & ? & Hlenrest): @LibList.take_app_drop_spec (to_nat n) l f r.
    { rewrites~ to_nat_le_nat_le. }
    splits~.
    { symmetry. rewrite~ <-to_nat_eq_nat_eq. }
    { rewrites~ <-(>> to_nat_to_int n). rewrite Hlenrest.
      rewrite~ minus_nat_eq_minus_int.
      rewrite~ <-to_nat_le_nat_le in Hn. } }
  { intros. rewrites~ take_neg in *. rewrites~ drop_neg in *. }
Qed.

Lemma take_spec : forall n l,
  0 <= n <= length l ->
  exists l', length (take n l) = n
          /\ l = (take n l) ++ l'.
Proof using. introv E. forwards* (E1&_): take_app_drop_spec. forwards*: E1. Qed.

Lemma length_take_nonneg : forall n l,
  0 <= n <= length l ->
  length (take n l) = n.
Proof using. introv E. forwards~ (l'&N&M): take_spec n l. Qed.

Lemma length_take : forall n l,
  n <= length l ->
  length (take n l) = Z.max 0 n.
Proof using.
  intros. tests: (0 <= n).
  { rewrite~ length_take_nonneg. rewrite~ Z.max_r. }
  { rewrite~ take_neg. rewrite~ Z.max_l. }
Qed.

Lemma drop_spec : forall n l,
  0 <= n <= length l ->
  exists l', length l' = n
          /\ l = l' ++ (drop n l).
Proof using. introv E. forwards* (E1&_): take_app_drop_spec. forwards*: E1. Qed.

Lemma length_drop_nonneg : forall n l,
  0 <= n <= length l ->
  length (drop n l) = length l - n.
Proof using.
  introv E. forwards~ (l'&N&M): drop_spec n l.
  pattern l at 2. rewrite M. rew_list. math.
Qed.

Lemma length_drop : forall n l,
  n <= length l ->
  length (drop n l) = Z.min (length l) (length l - n).
Proof using.
  intros. tests: (0 <= n).
  { rewrite~ length_drop_nonneg. rewrite~ Z.min_r. }
  { rewrite~ drop_neg. rewrite~ Z.min_l. }
Qed.

Lemma list_eq_take_app_drop : forall n l,
  n <= length l ->
  take n l ++ drop n l = l.
Proof using.
  introv H. tests: (0 <= n).
  { forwards*: take_app_drop_spec n l. }
  { rewrite~ take_neg. rewrite~ drop_neg. }
Qed.

End TakeAndDrop.

Arguments take_app_drop_spec [A].
Arguments take_spec [A].
Arguments drop_spec [A].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** [count], returning an int *)

Definition count A (P: A -> Prop) (l: list A): int :=
  abs (LibList.count P l).

Section Count.
Variables A : Type.
Implicit Types l : list A.
Implicit Types P : A -> Prop.

Ltac gowith L :=
  let H := fresh in
  lets H: L;
  repeat (let x := fresh in intro x; specializes H x);
  unfold count in *; repeat rewrites~ abs_nonneg in *;
  try solve [
    first [ rewrites~ H in * | forwards~: H ];
    repeat case_if~
  ].

(* Rewriting *)

Lemma count_nil : forall P,
  count P nil = 0.
Proof using. auto. Qed.

Lemma count_one : forall P x,
  count P (x::nil) = If P x then 1 else 0.
Proof using. gowith LibList.count_one. Qed.

Lemma count_cons : forall P l x,
  count P (x::l) = count P l + If P x then 1 else 0.
Proof using. gowith LibList.count_cons. Qed.

Lemma count_app : forall P l1 l2,
  count P (l1++l2) = count P l1 + count P l2.
Proof using. gowith LibList.count_app. Qed.

Lemma count_last : forall P l x,
  count P (l&x) = count P l + If P x then 1 else 0.
Proof using. gowith LibList.count_last. Qed.

Lemma count_rev : forall P l,
  count P (rev l) = count P l.
Proof using. gowith LibList.count_rev. Qed.

Lemma count_eq_length_filter : forall P l,
  count P l = length (filter P l).
Proof using. gowith LibList.count_eq_length_filter. Qed.

(* Properties *)

Lemma count_nonneg : forall P l,
  0 <= count P l.
Proof using. intros. unfold count. math. Qed.

Lemma count_le_length : forall P l,
  count P l <= length l.
Proof using. gowith LibList.count_le_length. Qed.

(* Interactions with [Forall] *)

Lemma Forall_eq_count_eq_length : forall P l,
  Forall P l = (count P l = length l).
Proof using.
  intros. rewrite LibList.Forall_eq_count_eq_length, length_eq.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma count_Forall : forall P l,
  Forall P l ->
  count P l = length l.
Proof using. introv. rewrite~ Forall_eq_count_eq_length. Qed.

Lemma Forall_of_count_eq_length : forall P l,
  count P l = length l ->
  Forall P l.
Proof using. introv. rewrite~ Forall_eq_count_eq_length. Qed.

(* Interactions with [Forall (pred_not P)] *)

Lemma Forall_not_eq_count_eq_zero : forall P l,
  Forall (fun x => ~ P x) l = (count P l = 0).
Proof using.
  intros. rewrite LibList.Forall_not_eq_count_eq_zero.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma Forall_not_of_count_eq_zero : forall P l,
  count P l = 0 ->
  Forall (fun x => ~ P x) l.
Proof using. introv. rewrite~ Forall_not_eq_count_eq_zero. Qed.

Lemma count_eq_zero_of_Forall_not : forall P l,
  Forall (fun x => ~ P x) l ->
  count P l = 0.
Proof using. introv. rewrite~ Forall_not_eq_count_eq_zero. Qed.

(* Interactions with [Exists] *)

Lemma Exists_eq_count_pos : forall P l,
  Exists P l = (count P l > 0).
Proof using.
  intros. rewrite LibList.Exists_eq_count_pos.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma Exists_of_count_pos : forall P l,
  count P l > 0 ->
  Exists P l.
Proof using. introv. rewrite~ Exists_eq_count_pos. Qed.

Lemma count_pos_of_Exists : forall P l,
  Exists P l ->
  count P l > 0.
Proof using. introv. rewrite~ Exists_eq_count_pos. Qed.

(* Interactions with [mem] *)

Lemma count_pos_eq_exists_mem : forall P l,
  (count P l > 0) = (exists x, mem x l /\ P x).
Proof using.
  intros. rewrite <- LibList.count_pos_eq_exists_mem.
  unfold count. rewrite abs_nonneg; math.
Qed.

Lemma count_pos_of_mem : forall x P l,
  mem x l ->
  P x ->
  count P l > 0.
Proof using. introv. rewrite* count_pos_eq_exists_mem. Qed.

Lemma exists_mem_of_count_pos : forall P l,
  count P l > 0 ->
  exists x, mem x l /\ P x.
Proof using. introv. rewrite* count_pos_eq_exists_mem. Qed.

End Count.

Opaque count.

Hint Rewrite count_nil count_cons count_app count_last count_rev : rew_listx.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [card], with result as [nat], as typeclass *)

(** Note that [card] produces a [nat], whereas [length] produces an [int].
    Currently, in practice, we use [LibList.length] rather than [card]. *)

Definition card_impl A (l:list A) : nat :=
  LibList.length l.

Instance card_inst : forall A, BagCard (list A).
Proof using. constructor. rapply (@card_impl A). Defined.

Global Opaque card_inst.

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Normalization tactics *)

(** [rew_array_nocase] is a light normalization tactic for array *)

Hint Rewrite @read_make @length_make @length_update @read_update_same
  : rew_array_nocase.

Tactic Notation "rew_array_nocase" :=
  autorewrite with rew_array_nocase.
Tactic Notation "rew_array_nocase" "in" hyp(H) :=
  autorewrite with rew_array_nocase in H.
Tactic Notation "rew_array_nocase" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_array_nocase).
  (* autorewrite with rew_array_nocase in *. *)
Tactic Notation "rew_array_nocase" "~" :=
  rew_array_nocase; auto_tilde.
Tactic Notation "rew_array_nocase" "*" :=
  rew_array_nocase; auto_star.
Tactic Notation "rew_array_nocase" "~" "in" hyp(H) :=
  rew_array_nocase in H; auto_tilde.
Tactic Notation "rew_array_nocase" "*" "in" hyp(H) :=
  rew_array_nocase in H; auto_star.
Tactic Notation "rew_array_nocase" "~" "in" "*" :=
  rew_array_nocase in *; auto_tilde.
Tactic Notation "rew_array_nocase" "*" "in" "*" :=
  rew_array_nocase in *; auto_star.

(** [rew_array] is a normalization tactic for array, which introduces
    case analyses for all read-on-update operations. *)

Hint Rewrite @read_make @length_make @length_update @read_update_same
  @read_update_case @read_cons_case @read_last_case : rew_array.

Tactic Notation "rew_array" :=
  autorewrite with rew_array.
Tactic Notation "rew_array" "in" hyp(H) :=
  autorewrite with rew_array in H.
Tactic Notation "rew_array" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_array).
  (* autorewrite with rew_array in *. *)
Tactic Notation "rew_array" "~" :=
  rew_array; auto_tilde.
Tactic Notation "rew_array" "*" :=
  rew_array; auto_star.
Tactic Notation "rew_array" "~" "in" hyp(H) :=
  rew_array in H; auto_tilde.
Tactic Notation "rew_array" "*" "in" hyp(H) :=
  rew_array in H; auto_star.
Tactic Notation "rew_array" "~" "in" "*" :=
  rew_array in *; auto_tilde.
Tactic Notation "rew_array" "*" "in" "*" :=
  rew_array in *; auto_star.

(* **********************************************************************

    Restore automation *)

Ltac auto_tilde ::= auto_tilde_default.

(* **********************************************************************

    FUTURE WORK *)

(*-- Lemmas on tail; is this useful? *)

(*
Lemma length_tail : forall l,
  l <> nil ->
  length (tail l) = length l - 1.
Proof using. induction l; intros; simpl; unfold length; rew_list. congruence. math. Qed.

Lemma length_tail_le : forall l,
  length (tail l) <= length l.
Proof using. destruct l; simpl; unfold length; rew_list; math. Qed.

Lemma length_le_1_inv_tail_eq_nil : forall l,
  length l <= 1 ->
  tail l = nil.
Proof using.
  intros. destruct l; eauto.
  simpl. unfold length in *. rew_list in *.
  eapply length_zero_inv. math.
Qed.
*)

(* ---------------------------------------------------------------------- *)
(* ################################################################# *)
(** * [binds], with length as [int], as typeclass *)

(* --LATER: is this any useful?

  Definition binds_impl A (l:list A) (i:int) (v:A) : Prop :=
    index_impl l i /\ nth i l = v.

  Instance binds_inst : forall A, BagBinds int A (list A).
  Proof using. constructor. rapply (@binds_impl A). Defined.

  Global Opaque binds_inst

*)

(* 2020-03-09 15:04:13 (UTC+01) *)


From Hammer Require Import Hammer.

Require Export ZArith.
Require Export ZArithRing.
Require Export Morphisms Setoid Bool.

Record Q : Set := Qmake {Qnum : Z; Qden : positive}.

Delimit Scope Q_scope with Q.
Bind Scope Q_scope with Q.
Arguments Qmake _%Z _%positive.
Open Scope Q_scope.
Ltac simpl_mult := rewrite ?Pos2Z.inj_mul.

Notation "a # b" := (Qmake a b) (at level 55, no associativity) : Q_scope.

Definition inject_Z (x : Z) := Qmake x 1.
Arguments inject_Z x%Z.

Notation QDen p := (Zpos (Qden p)).
Notation " 0 " := (0#1) : Q_scope.
Notation " 1 " := (1#1) : Q_scope.

Definition Qeq (p q : Q) := (Qnum p * QDen q)%Z = (Qnum q * QDen p)%Z.
Definition Qle (x y : Q) := (Qnum x * QDen y <= Qnum y * QDen x)%Z.
Definition Qlt (x y : Q) := (Qnum x * QDen y < Qnum y * QDen x)%Z.
Notation Qgt a b := (Qlt b a) (only parsing).
Notation Qge a b := (Qle b a) (only parsing).

Infix "==" := Qeq (at level 70, no associativity) : Q_scope.
Infix "<" := Qlt : Q_scope.
Infix "<=" := Qle : Q_scope.
Notation "x > y" := (Qlt y x)(only parsing) : Q_scope.
Notation "x >= y" := (Qle y x)(only parsing) : Q_scope.
Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope.

Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b.
Proof. hammer_hook "QArith_base" "QArith_base.inject_Z_injective".
unfold Qeq. simpl. omega.
Qed.

Definition Qcompare (p q : Q) := (Qnum p * QDen q ?= Qnum q * QDen p)%Z.
Notation "p ?= q" := (Qcompare p q) : Q_scope.

Lemma Qeq_alt p q : (p == q) <-> (p ?= q) = Eq.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_alt".
symmetry. apply Z.compare_eq_iff.
Qed.

Lemma Qlt_alt p q : (p<q) <-> (p?=q = Lt).
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_alt".
reflexivity.
Qed.

Lemma Qgt_alt p q : (p>q) <-> (p?=q = Gt).
Proof. hammer_hook "QArith_base" "QArith_base.Qgt_alt".
symmetry. apply Z.gt_lt_iff.
Qed.

Lemma Qle_alt p q : (p<=q) <-> (p?=q <> Gt).
Proof. hammer_hook "QArith_base" "QArith_base.Qle_alt".
reflexivity.
Qed.

Lemma Qge_alt p q : (p>=q) <-> (p?=q <> Lt).
Proof. hammer_hook "QArith_base" "QArith_base.Qge_alt".
symmetry. apply Z.ge_le_iff.
Qed.

Hint Unfold Qeq Qlt Qle : qarith.
Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith.

Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x).
Proof. hammer_hook "QArith_base" "QArith_base.Qcompare_antisym".
symmetry. apply Z.compare_antisym.
Qed.

Lemma Qcompare_spec x y : CompareSpec (x==y) (x<y) (y<x) (x ?= y).
Proof. hammer_hook "QArith_base" "QArith_base.Qcompare_spec".
unfold Qeq, Qlt, Qcompare. case Z.compare_spec; now constructor.
Qed.

Theorem Qeq_refl x : x == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_refl".
auto with qarith.
Qed.

Theorem Qeq_sym x y : x == y -> y == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_sym".
auto with qarith.
Qed.

Theorem Qeq_trans x y z : x == y -> y == z -> x == z.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_trans".
unfold Qeq; intros XY YZ.
apply Z.mul_reg_r with (QDen y); [auto with qarith|].
now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0.
Qed.

Hint Immediate Qeq_sym : qarith.
Hint Resolve Qeq_refl Qeq_trans : qarith.

Instance Q_Setoid : Equivalence Qeq.
Proof. hammer_hook "QArith_base" "QArith_base.Q_Setoid".   split; red; eauto with qarith. Qed.

Theorem Qeq_dec x y : {x==y} + {~ x==y}.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_dec".
apply Z.eq_dec.
Defined.

Definition Qeq_bool x y :=
(Zeq_bool (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Definition Qle_bool x y :=
(Z.leb (Qnum x * QDen y) (Qnum y * QDen x))%Z.

Lemma Qeq_bool_iff x y : Qeq_bool x y = true <-> x == y.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_bool_iff".
symmetry; apply Zeq_is_eq_bool.
Qed.

Lemma Qeq_bool_eq x y : Qeq_bool x y = true -> x == y.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_bool_eq".
apply Qeq_bool_iff.
Qed.

Lemma Qeq_eq_bool x y : x == y -> Qeq_bool x y = true.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_eq_bool".
apply Qeq_bool_iff.
Qed.

Lemma Qeq_bool_neq x y : Qeq_bool x y = false -> ~ x == y.
Proof. hammer_hook "QArith_base" "QArith_base.Qeq_bool_neq".
rewrite <- Qeq_bool_iff. now intros ->.
Qed.

Lemma Qle_bool_iff x y : Qle_bool x y = true <-> x <= y.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_bool_iff".
symmetry; apply Zle_is_le_bool.
Qed.

Lemma Qle_bool_imp_le x y : Qle_bool x y = true -> x <= y.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_bool_imp_le".
apply Qle_bool_iff.
Qed.

Theorem Qnot_eq_sym x y : ~x == y -> ~y == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qnot_eq_sym".
auto with qarith.
Qed.

Hint Resolve Qnot_eq_sym : qarith.

Definition Qplus (x y : Q) :=
(Qnum x * QDen y + Qnum y * QDen x) # (Qden x * Qden y).

Definition Qmult (x y : Q) := (Qnum x * Qnum y) # (Qden x * Qden y).

Definition Qopp (x : Q) := (- Qnum x) # (Qden x).

Definition Qminus (x y : Q) := Qplus x (Qopp y).

Definition Qinv (x : Q) :=
match Qnum x with
| Z0 => 0
| Zpos p => (QDen x)#p
| Zneg p => (Zneg (Qden x))#p
end.

Definition Qdiv (x y : Q) := Qmult x (Qinv y).

Infix "+" := Qplus : Q_scope.
Notation "- x" := (Qopp x) : Q_scope.
Infix "-" := Qminus : Q_scope.
Infix "*" := Qmult : Q_scope.
Notation "/ x" := (Qinv x) : Q_scope.
Infix "/" := Qdiv : Q_scope.

Notation " ' x " := (Zpos x) (at level 20, no associativity) : Z_scope.

Lemma Qmake_Qdiv a b : a#b==inject_Z a/inject_Z ('b).
Proof. hammer_hook "QArith_base" "QArith_base.Qmake_Qdiv".
unfold Qeq. simpl. ring.
Qed.

Instance Qplus_comp : Proper (Qeq==>Qeq==>Qeq) Qplus.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_comp".
unfold Qeq, Qplus; simpl.
Open Scope Z_scope.
intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
simpl_mult; ring_simplify.
replace (p1 * 'r2 * 'q2) with (p1 * 'q2 * 'r2) by ring.
rewrite H.
replace (r1 * 'p2 * 'q2 * 's2) with (r1 * 's2 * 'p2 * 'q2) by ring.
rewrite H0.
ring.
Close Scope Z_scope.
Qed.

Instance Qopp_comp : Proper (Qeq==>Qeq) Qopp.
Proof. hammer_hook "QArith_base" "QArith_base.Qopp_comp".
unfold Qeq, Qopp; simpl.
Open Scope Z_scope.
intros x y H; simpl.
replace (- Qnum x * ' Qden y) with (- (Qnum x * ' Qden y)) by ring.
rewrite H;  ring.
Close Scope Z_scope.
Qed.

Instance Qminus_comp : Proper (Qeq==>Qeq==>Qeq) Qminus.
Proof. hammer_hook "QArith_base" "QArith_base.Qminus_comp".
intros x x' Hx y y' Hy.
unfold Qminus. rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qmult_comp : Proper (Qeq==>Qeq==>Qeq) Qmult.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_comp".
unfold Qeq; simpl.
Open Scope Z_scope.
intros (p1, p2) (q1, q2) H (r1, r2) (s1, s2) H0; simpl in *.
intros; simpl_mult; ring_simplify.
replace (q1 * s1 * 'p2) with (q1 * 'p2 * s1) by ring.
rewrite <- H.
replace (p1 * r1 * 'q2 * 's2) with (r1 * 's2 * p1 * 'q2) by ring.
rewrite H0.
ring.
Close Scope Z_scope.
Qed.

Instance Qinv_comp : Proper (Qeq==>Qeq) Qinv.
Proof. hammer_hook "QArith_base" "QArith_base.Qinv_comp".
unfold Qeq, Qinv; simpl.
Open Scope Z_scope.
intros (p1, p2) (q1, q2) EQ; simpl in *.
destruct q1; simpl in *.
- apply Z.mul_eq_0 in EQ. destruct EQ; now subst.
- destruct p1; simpl in *; try discriminate.
now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
- destruct p1; simpl in *; try discriminate.
now rewrite Pos.mul_comm, <- EQ, Pos.mul_comm.
Close Scope Z_scope.
Qed.

Instance Qdiv_comp : Proper (Qeq==>Qeq==>Qeq) Qdiv.
Proof. hammer_hook "QArith_base" "QArith_base.Qdiv_comp".
intros x x' Hx y y' Hy; unfold Qdiv.
rewrite Hx, Hy; auto with qarith.
Qed.

Instance Qcompare_comp : Proper (Qeq==>Qeq==>eq) Qcompare.
Proof. hammer_hook "QArith_base" "QArith_base.Qcompare_comp".
unfold Qeq, Qcompare.
Open Scope Z_scope.
intros (p1,p2) (q1,q2) H (r1,r2) (s1,s2) H'; simpl in *.
rewrite <- (Zcompare_mult_compat (q2*s2) (p1*'r2)).
rewrite <- (Zcompare_mult_compat (p2*r2) (q1*'s2)).
change ('(q2*s2)) with ('q2 * 's2).
change ('(p2*r2)) with ('p2 * 'r2).
replace ('q2 * 's2 * (p1*'r2)) with ((p1*'q2)*'r2*'s2) by ring.
rewrite H.
replace ('q2 * 's2 * (r1*'p2)) with ((r1*'s2)*'q2*'p2) by ring.
rewrite H'.
f_equal; ring.
Close Scope Z_scope.
Qed.

Instance Qle_comp : Proper (Qeq==>Qeq==>iff) Qle.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_comp".
intros p q H r s H'. rewrite 2 Qle_alt, H, H'; auto with *.
Qed.

Instance Qlt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_compat".
intros p q H r s H'. rewrite 2 Qlt_alt, H, H'; auto with *.
Qed.

Instance Qeqb_comp : Proper (Qeq==>Qeq==>eq) Qeq_bool.
Proof. hammer_hook "QArith_base" "QArith_base.Qeqb_comp".
intros p q H r s H'; apply eq_true_iff_eq.
rewrite 2 Qeq_bool_iff, H, H'; split; auto with qarith.
Qed.

Instance Qleb_comp : Proper (Qeq==>Qeq==>eq) Qle_bool.
Proof. hammer_hook "QArith_base" "QArith_base.Qleb_comp".
intros p q H r s H'; apply eq_true_iff_eq.
rewrite 2 Qle_bool_iff, H, H'; split; auto with qarith.
Qed.

Lemma Q_apart_0_1 : ~ 1 == 0.
Proof. hammer_hook "QArith_base" "QArith_base.Q_apart_0_1".
unfold Qeq; auto with qarith.
Qed.

Theorem Qplus_assoc : forall x y z, x+(y+z)==(x+y)+z.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_assoc".
intros (x1, x2) (y1, y2) (z1, z2).
unfold Qeq, Qplus; simpl; simpl_mult; ring.
Qed.

Lemma Qplus_0_l : forall x, 0+x == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_0_l".
intros (x1, x2); unfold Qeq, Qplus; simpl; ring.
Qed.

Lemma Qplus_0_r : forall x, x+0 == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_0_r".
intros (x1, x2); unfold Qeq, Qplus; simpl.
rewrite Pos.mul_comm; simpl; ring.
Qed.

Theorem Qplus_comm : forall x y, x+y == y+x.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_comm".
intros (x1, x2); unfold Qeq, Qplus; simpl.
intros; rewrite Pos.mul_comm; ring.
Qed.

Lemma Qopp_involutive : forall q, - -q == q.
Proof. hammer_hook "QArith_base" "QArith_base.Qopp_involutive".
red; simpl; intros; ring.
Qed.

Theorem Qplus_opp_r : forall q, q+(-q) == 0.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_opp_r".
red; simpl; intro; ring.
Qed.

Lemma Qplus_inj_r (x y z: Q):
x + z == y + z <-> x == y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_inj_r".
split; intro E.
rewrite <- (Qplus_0_r x), <- (Qplus_0_r y).
rewrite <- (Qplus_opp_r z); auto.
do 2 rewrite Qplus_assoc.
rewrite E. reflexivity.
rewrite E. reflexivity.
Qed.

Lemma Qplus_inj_l (x y z: Q):
z + x == z + y <-> x == y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_inj_l".
rewrite (Qplus_comm z x), (Qplus_comm z y).
apply Qplus_inj_r.
Qed.

Theorem Qmult_assoc : forall n m p, n*(m*p)==(n*m)*p.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_assoc".
intros; red; simpl; rewrite Pos.mul_assoc; ring.
Qed.

Lemma Qmult_0_l : forall x , 0*x == 0.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_0_l".
intros; compute; reflexivity.
Qed.

Lemma Qmult_0_r : forall x , x*0 == 0.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_0_r".
intros; red; simpl; ring.
Qed.

Lemma Qmult_1_l : forall n, 1*n == n.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_1_l".
intro; red; simpl; destruct (Qnum n); auto.
Qed.

Theorem Qmult_1_r : forall n, n*1==n.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_1_r".
intro; red; simpl.
rewrite Z.mul_1_r with (n := Qnum n).
rewrite Pos.mul_comm; simpl; trivial.
Qed.

Theorem Qmult_comm : forall x y, x*y==y*x.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_comm".
intros; red; simpl; rewrite Pos.mul_comm; ring.
Qed.

Theorem Qmult_plus_distr_r : forall x y z, x*(y+z)==(x*y)+(x*z).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_plus_distr_r".
intros (x1, x2) (y1, y2) (z1, z2).
unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

Theorem Qmult_plus_distr_l : forall x y z, (x+y)*z==(x*z)+(y*z).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_plus_distr_l".
intros (x1, x2) (y1, y2) (z1, z2).
unfold Qeq, Qmult, Qplus; simpl; simpl_mult; ring.
Qed.

Theorem Qmult_integral : forall x y, x*y==0 -> x==0 \/ y==0.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_integral".
intros (x1,x2) (y1,y2).
unfold Qeq, Qmult; simpl.
now rewrite <- Z.mul_eq_0, !Z.mul_1_r.
Qed.

Theorem Qmult_integral_l : forall x y, ~ x == 0 -> x*y == 0 -> y == 0.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_integral_l".
intros (x1, x2) (y1, y2).
unfold Qeq, Qmult; simpl.
rewrite !Z.mul_1_r, Z.mul_eq_0. intuition.
Qed.

Lemma inject_Z_plus (x y: Z): inject_Z (x + y) = inject_Z x + inject_Z y.
Proof. hammer_hook "QArith_base" "QArith_base.inject_Z_plus".
unfold Qplus, inject_Z. simpl. f_equal. ring.
Qed.

Lemma inject_Z_mult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y.
Proof. hammer_hook "QArith_base" "QArith_base.inject_Z_mult".   reflexivity. Qed.

Lemma inject_Z_opp (x: Z): inject_Z (- x) = - inject_Z x.
Proof. hammer_hook "QArith_base" "QArith_base.inject_Z_opp".   reflexivity. Qed.

Lemma Qinv_involutive : forall q, (/ / q) == q.
Proof. hammer_hook "QArith_base" "QArith_base.Qinv_involutive".
intros [[|n|n] d]; red; simpl; reflexivity.
Qed.

Theorem Qmult_inv_r : forall x, ~ x == 0 -> x*(/x) == 1.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_inv_r".
intros (x1, x2); unfold Qeq, Qdiv, Qmult; case x1; simpl;
intros; simpl_mult; try ring.
elim H; auto.
Qed.

Lemma Qinv_mult_distr : forall p q, / (p * q) == /p * /q.
Proof. hammer_hook "QArith_base" "QArith_base.Qinv_mult_distr".
intros (x1,x2) (y1,y2); unfold Qeq, Qinv, Qmult; simpl.
destruct x1; simpl; auto;
destruct y1; simpl; auto.
Qed.

Theorem Qdiv_mult_l : forall x y, ~ y == 0 -> (x*y)/y == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qdiv_mult_l".
intros; unfold Qdiv.
rewrite <- (Qmult_assoc x y (Qinv y)).
rewrite (Qmult_inv_r y H).
apply Qmult_1_r.
Qed.

Theorem Qmult_div_r : forall x y, ~ y == 0 -> y*(x/y) == x.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_div_r".
intros; unfold Qdiv.
rewrite (Qmult_assoc y x (Qinv y)).
rewrite (Qmult_comm y x).
fold (Qdiv (Qmult x y) y).
apply Qdiv_mult_l; auto.
Qed.

Lemma Qmult_inj_r (x y z: Q): ~ z == 0 -> (x * z == y * z <-> x == y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_inj_r".
intro z_ne_0.
split; intro E.
rewrite <- (Qmult_1_r x), <- (Qmult_1_r y).
rewrite <- (Qmult_inv_r z); auto.
do 2 rewrite Qmult_assoc.
rewrite E. reflexivity.
rewrite E. reflexivity.
Qed.

Lemma Qmult_inj_l (x y z: Q): ~ z == 0 -> (z * x == z * y <-> x == y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_inj_l".
rewrite (Qmult_comm z x), (Qmult_comm z y).
apply Qmult_inj_r.
Qed.

Lemma Qle_refl x : x<=x.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_refl".
unfold Qle; auto with zarith.
Qed.

Lemma Qle_antisym x y : x<=y -> y<=x -> x==y.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_antisym".
unfold Qle, Qeq; auto with zarith.
Qed.

Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_trans".
unfold Qle; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
apply Z.mul_le_mono_pos_r with ('y2); [easy|].
apply Z.le_trans with (y1 * 'x2 * 'z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_le_mono_pos_r.
Close Scope Z_scope.
Qed.

Hint Resolve Qle_trans : qarith.

Lemma Qlt_irrefl x : ~x<x.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_irrefl".
unfold Qlt. auto with zarith.
Qed.

Lemma Qlt_not_eq x y : x<y -> ~ x==y.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_not_eq".
unfold Qlt, Qeq; auto with zarith.
Qed.

Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y).
Proof. hammer_hook "QArith_base" "QArith_base.Zle_Qle".
unfold Qle. simpl. now rewrite !Z.mul_1_r.
Qed.

Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y).
Proof. hammer_hook "QArith_base" "QArith_base.Zlt_Qlt".
unfold Qlt. simpl. now rewrite !Z.mul_1_r.
Qed.

Lemma Qle_lteq x y : x<=y <-> x<y \/ x==y.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_lteq".
rewrite Qeq_alt, Qle_alt, Qlt_alt.
destruct (x ?= y); intuition; discriminate.
Qed.

Lemma Qlt_le_weak x y : x<y -> x<=y.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_le_weak".
unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_lt_trans".
unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
apply Z.le_lt_trans with (y1 * 'x2 * 'z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_le_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_lt_mono_pos_r.
Close Scope Z_scope.
Qed.

Lemma Qlt_le_trans : forall x y z, x<y -> y<=z -> x<z.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_le_trans".
unfold Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2); simpl; intros.
Open Scope Z_scope.
apply Z.mul_lt_mono_pos_r with ('y2); [easy|].
apply Z.lt_le_trans with (y1 * 'x2 * 'z2).
- rewrite Z.mul_shuffle0. now apply Z.mul_lt_mono_pos_r.
- rewrite Z.mul_shuffle0, (Z.mul_shuffle0 z1).
now apply Z.mul_le_mono_pos_r.
Close Scope Z_scope.
Qed.

Lemma Qlt_trans : forall x y z, x<y -> y<z -> x<z.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_trans".
intros.
apply Qle_lt_trans with y; auto.
apply Qlt_le_weak; auto.
Qed.

Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x.
Proof. hammer_hook "QArith_base" "QArith_base.Qnot_lt_le".
unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x.
Proof. hammer_hook "QArith_base" "QArith_base.Qnot_le_lt".
unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_not_le".
unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_not_lt".
unfold Qle, Qlt; auto with zarith.
Qed.

Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_lt_or_eq".
unfold Qle, Qlt, Qeq; intros; now apply Z.lt_eq_cases.
Qed.

Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le
Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith.

Lemma Q_dec : forall x y, {x<y} + {y<x} + {x==y}.
Proof. hammer_hook "QArith_base" "QArith_base.Q_dec".
unfold Qlt, Qle, Qeq; intros.
exact (Z_dec' (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

Lemma Qlt_le_dec : forall x y, {x<y} + {y<=x}.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_le_dec".
unfold Qlt, Qle; intros.
exact (Z_lt_le_dec (Qnum x * QDen y) (Qnum y * QDen x)).
Defined.

Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p.
Proof. hammer_hook "QArith_base" "QArith_base.Qopp_le_compat".
intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl.
rewrite !Z.mul_opp_l. omega.
Qed.

Hint Resolve Qopp_le_compat : qarith.

Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_minus_iff".
intros (x1,x2) (y1,y2); unfold Qle; simpl.
rewrite Z.mul_opp_l. omega.
Qed.

Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_minus_iff".
intros (x1,x2) (y1,y2); unfold Qlt; simpl.
rewrite Z.mul_opp_l. omega.
Qed.

Lemma Qplus_le_compat :
forall x y z t, x<=y -> z<=t -> x+z <= y+t.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_le_compat".
unfold Qplus, Qle; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
simpl; simpl_mult.
Open Scope Z_scope.
intros.
match goal with |- ?a <= ?b => ring_simplify a b end.
rewrite Z.add_comm.
apply Z.add_le_mono.
match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
auto with zarith.
match goal with |- ?a <= ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
auto with zarith.
Close Scope Z_scope.
Qed.

Lemma Qplus_lt_le_compat :
forall x y z t, x<y -> z<=t -> x+z < y+t.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_lt_le_compat".
unfold Qplus, Qle, Qlt; intros (x1, x2) (y1, y2) (z1, z2) (t1, t2);
simpl; simpl_mult.
Open Scope Z_scope.
intros.
match goal with |- ?a < ?b => ring_simplify a b end.
rewrite Z.add_comm.
apply Z.add_le_lt_mono.
match goal with |- ?a <= ?b => ring_simplify z1 t1 ('z2) ('t2) a b end.
auto with zarith.
match goal with |- ?a < ?b => ring_simplify x1 y1 ('x2) ('y2) a b end.
do 2 (apply Z.mul_lt_mono_pos_r;try easy).
Close Scope Z_scope.
Qed.

Lemma Qplus_le_l (x y z: Q): x + z <= y + z <-> x <= y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_le_l".
split; intros.
rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
do 2 rewrite Qplus_assoc.
apply Qplus_le_compat; auto with *.
apply Qplus_le_compat; auto with *.
Qed.

Lemma Qplus_le_r (x y z: Q): z + x <= z + y <-> x <= y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_le_r".
rewrite (Qplus_comm z x), (Qplus_comm z y).
apply Qplus_le_l.
Qed.

Lemma Qplus_lt_l (x y z: Q): x + z < y + z <-> x < y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_lt_l".
split; intros.
rewrite <- (Qplus_0_r x), <- (Qplus_0_r y), <- (Qplus_opp_r z).
do 2 rewrite Qplus_assoc.
apply Qplus_lt_le_compat; auto with *.
apply Qplus_lt_le_compat; auto with *.
Qed.

Lemma Qplus_lt_r (x y z: Q): z + x < z + y <-> x < y.
Proof. hammer_hook "QArith_base" "QArith_base.Qplus_lt_r".
rewrite (Qplus_comm z x), (Qplus_comm z y).
apply Qplus_lt_l.
Qed.

Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_le_compat_r".
intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
Open Scope Z_scope.
intros; simpl_mult.
rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
apply Z.mul_le_mono_nonneg_r; auto with zarith.
Close Scope Z_scope.
Qed.

Lemma Qmult_lt_0_le_reg_r : forall x y z, 0 < z  -> x*z <= y*z -> x <= y.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_lt_0_le_reg_r".
intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
Open Scope Z_scope.
simpl_mult.
rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
intros LT LE.
apply Z.mul_le_mono_pos_r in LE; trivial.
apply Z.mul_pos_pos; [omega|easy].
Close Scope Z_scope.
Qed.

Lemma Qmult_le_r (x y z: Q): 0 < z -> (x*z <= y*z <-> x <= y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_le_r".
split; intro.
now apply Qmult_lt_0_le_reg_r with z.
apply Qmult_le_compat_r; auto with qarith.
Qed.

Lemma Qmult_le_l (x y z: Q): 0 < z -> (z*x <= z*y <-> x <= y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_le_l".
rewrite (Qmult_comm z x), (Qmult_comm z y).
apply Qmult_le_r.
Qed.

Lemma Qmult_lt_compat_r : forall x y z, 0 < z  -> x < y -> x*z < y*z.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_lt_compat_r".
intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl.
Open Scope Z_scope.
intros; simpl_mult.
rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
apply Z.mul_lt_mono_pos_r; auto with zarith.
apply Z.mul_pos_pos; [omega|reflexivity].
Close Scope Z_scope.
Qed.

Lemma Qmult_lt_r: forall x y z, 0 < z -> (x*z < y*z <-> x < y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_lt_r".
Open Scope Z_scope.
intros (a1,a2) (b1,b2) (c1,c2).
unfold Qle, Qlt; simpl.
simpl_mult.
rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1).
intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity.
apply Z.mul_pos_pos; [omega|reflexivity].
Close Scope Z_scope.
Qed.

Lemma Qmult_lt_l (x y z: Q): 0 < z -> (z*x < z*y <-> x < y).
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_lt_l".
rewrite (Qmult_comm z x), (Qmult_comm z y).
apply Qmult_lt_r.
Qed.

Lemma Qmult_le_0_compat : forall a b, 0 <= a -> 0 <= b -> 0 <= a*b.
Proof. hammer_hook "QArith_base" "QArith_base.Qmult_le_0_compat".
intros a b Ha Hb.
unfold Qle in *.
simpl in *.
auto with *.
Qed.

Lemma Qinv_le_0_compat : forall a, 0 <= a -> 0 <= /a.
Proof. hammer_hook "QArith_base" "QArith_base.Qinv_le_0_compat".
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qle_shift_div_l : forall a b c,
0 < c -> a*c <= b -> a <= b/c.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_shift_div_l".
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with (c).
assumption.
setoid_replace (b/c*c) with (c*(b/c)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_l : forall a c,
0 < c -> a*c <= 1 -> a <= /c.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_shift_inv_l".
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a <= 1/c).
apply Qle_shift_div_l; assumption.
Qed.

Lemma Qle_shift_div_r : forall a b c,
0 < b -> a <= c*b -> a/b <= c.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_shift_div_r".
intros a b c Hc H.
apply Qmult_lt_0_le_reg_r with b.
assumption.
setoid_replace (a/b*b) with (b*(a/b)) by apply Qmult_comm.
rewrite Qmult_div_r; try assumption.
auto with *.
Qed.

Lemma Qle_shift_inv_r : forall b c,
0 < b -> 1 <= c*b -> /b <= c.
Proof. hammer_hook "QArith_base" "QArith_base.Qle_shift_inv_r".
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b <= c).
apply Qle_shift_div_r; assumption.
Qed.

Lemma Qinv_lt_0_compat : forall a, 0 < a -> 0 < /a.
Proof. hammer_hook "QArith_base" "QArith_base.Qinv_lt_0_compat".
intros [[|n|n] d] Ha; assumption.
Qed.

Lemma Qlt_shift_div_l : forall a b c,
0 < c -> a*c < b -> a < b/c.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_shift_div_l".
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/c).
apply Qinv_lt_0_compat.
assumption.
setoid_replace (a*c/c) with (a) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_l : forall a c,
0 < c -> a*c < 1 -> a < /c.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_shift_inv_l".
intros a c Hc H.
setoid_replace (/c) with (1*/c) by (symmetry; apply Qmult_1_l).
change (a < 1/c).
apply Qlt_shift_div_l; assumption.
Qed.

Lemma Qlt_shift_div_r : forall a b c,
0 < b -> a < c*b -> a/b < c.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_shift_div_r".
intros a b c Hc H.
apply Qnot_le_lt.
intros H0.
apply (Qlt_not_le _ _ H).
apply Qmult_lt_0_le_reg_r with (/b).
apply Qinv_lt_0_compat.
assumption.
setoid_replace (c*b/b) with (c) by (apply Qdiv_mult_l; auto with *).
assumption.
Qed.

Lemma Qlt_shift_inv_r : forall b c,
0 < b -> 1 < c*b -> /b < c.
Proof. hammer_hook "QArith_base" "QArith_base.Qlt_shift_inv_r".
intros b c Hc H.
setoid_replace (/b) with (1*/b) by (symmetry; apply Qmult_1_l).
change (1/b < c).
apply Qlt_shift_div_r; assumption.
Qed.

Definition Qpower_positive : Q -> positive -> Q :=
pow_pos Qmult.

Instance Qpower_positive_comp : Proper (Qeq==>eq==>Qeq) Qpower_positive.
Proof. hammer_hook "QArith_base" "QArith_base.Qpower_positive_comp".
intros x x' Hx y y' Hy. rewrite <-Hy; clear y' Hy.
unfold Qpower_positive.
induction y; simpl;
try rewrite IHy;
try rewrite Hx;
reflexivity.
Qed.

Definition Qpower (q:Q) (z:Z) :=
match z with
| Zpos p => Qpower_positive q p
| Z0 => 1
| Zneg p => /Qpower_positive q p
end.

Notation " q ^ z " := (Qpower q z) : Q_scope.

Instance Qpower_comp : Proper (Qeq==>eq==>Qeq) Qpower.
Proof. hammer_hook "QArith_base" "QArith_base.Qpower_comp".
intros x x' Hx y y' Hy. rewrite <- Hy; clear y' Hy.
destruct y; simpl; rewrite ?Hx; auto with *.
Qed.