Require Import ZArith.
Require Import NArith.
Require Import NAux.
Require Export Replace2.
Require Import P.

Require Import Reals.

(* Definition of the opposite for nat *)
Definition Natopp := (fun x:nat => 0%nat).

(* Definition of the opposite for N *)
Definition Nopp := (fun x:N => 0%N).

(* Auxillary functions for Z *)

Definition is_Z0 := (Zeq_bool 0).
Definition is_Z1 := (Zeq_bool 1).
Definition is_Zpos := (Zle_bool 0).
Definition is_Zdiv :=
  fun x y => if Zeq_bool x Z0 then false else Zeq_bool Z0 (Zmod y x).
Definition Zgcd :=
 fun x y => (if (is_Zdiv x y) then x else if (is_Zdiv y x) then y else 1%Z).

(* Check if a nat is a number *)
Ltac is_NatCst p :=
  match p with
  | O => constr:(true)
  | S ?p' => is_NatCst p'
  | _ => constr:(false)
end.

(* Convert a Z into a nat if it is a number *)
Ltac NatCst t :=
  match is_NatCst t with
  | false => constr:(false)
  | _ => let res := eval compute in (Z_of_nat t) in constr:(res)
end.

(* Check if a number is a positive *)
Ltac is_PCst p :=
  match p with
  | xH => constr:(true)
  | xO ?p' => is_PCst p'
  | xI ?p' => is_PCst p'
  | _ => constr:(false)
end.

(* Check if a N is a number *)
Ltac is_NCst p :=
  match p with
  | N0 => constr:(true)
  | Npos ?p' => is_PCst p'
  | _ => constr:(false)
end.

(* Convert a Z into a nat if it is a number *)
Ltac NCst t :=
  match is_NCst t with
  | false => constr:(false)
  | _ => let res := eval compute in (Z_of_N t) in constr:(res)
end.

(* If a number is an integer return itself otherwise false *)
Ltac ZCst t :=
  match t with
  | Z0 => constr:(t)
  | Zpos ?p => match is_PCst p with
               | false => constr:(false)
               | _ => constr:(t)
               end
  | Zneg ?p => match is_PCst p with
               | false => constr:(false)
               | _ => constr:(t)
               end
  | _ => constr:(false)
  end.

(* Check if a number is an integer *)
Ltac is_ZCst t := match t with
                | Z0 => constr:(true)
                | Zpos ?p => is_PCst p
                | Zneg ?p => is_PCst p
                | _ => constr:(false) end.

(* Turn a positive into a real *)
Fixpoint P2R (z: positive) {struct z}: R :=
  match z with
     xH => 1%R
  | (xO xH) => 2%R
  | (xI xH) => 3%R
  | (xO z1) => (2*(P2R z1))%R
  | (xI z1) => (1+2*(P2R z1))%R
 end.

(* Turn an integer into a real *)
Definition Z2R (z: Z): R :=
  match z with
     Z0 => 0%R
  | (Zpos z1) => (P2R z1)%R
  | (Zneg z1) => (-(P2R z1))%R
 end.

(* Turn a R when possible into a Z *)
Ltac RCst t :=
  match t with
   | R0 => constr:(Z0)
   | R1 => constr:(Zpos xH)
   | Rplus ?e1 ?e2 =>
       match (RCst e1) with
        false => constr:(false)
      | ?e3 => match (RCst e2) with
                 false => constr:(false)
              |  ?e4 =>  eval vm_compute in (Zplus e3  e4)
              end
      end
   | Rminus ?e1 ?e2 =>
       match (RCst e1) with
        false => constr:(false)
      | ?e3 => match (RCst e2) with
                 false => constr:(false)
              |  ?e4 => eval vm_compute in (Zminus e3  e4)
              end
      end
   | Rmult ?e1 ?e2 =>
       match (RCst e1) with
        false => constr:(false)
      | ?e3 => match (RCst e2) with
                 false => constr:(false)
              |  ?e4 => eval vm_compute in (Zmult e3  e4)
              end
      end
   | Ropp ?e1 =>
       match (RCst e1) with
        false => constr:(false)
      | ?e3 => eval vm_compute in (Z.opp e3)
      end
   | IZR ?e1 =>
       match (ZCst e1) with
        false => constr:(false)
      | ?e3 => e3
      end

   | _ => constr:(false)
 end.

(* Remove the Z.abs_nat of a number, unfortunately stops at
   the first Z.abs_nat x where x is not a number *)

Ltac clean_zabs term :=
  match term with
   context id [(Z.abs_nat ?X)] =>
     match is_ZCst X with
       true =>
         let x := eval vm_compute in (Z.abs_nat X) in
         let y := context id [x] in
           clean_zabs y
     | false => term
     end
    | _ => term
  end.

(* Remove the Z.abs_N of a number, unfortunately stops at
   the first Z.abs_nat x where x is not a number *)

Ltac clean_zabs_N term :=
  match term with
   context id [(Z.abs_N ?X)] =>
     match is_ZCst X with
       true =>
         let x := eval vm_compute in (Z.abs_N X) in
         let y := context id [x] in
           clean_zabs_N y
     | false => term
     end
    | _ => term
  end.

(* Equality test for Ltac *)

Ltac eqterm t1 t2 :=
  match constr:((t1,t2)) with (?X, ?X) => true | _ => false end.

(* For replace *)

Theorem trans_equal_r : forall (A: Set) (x y z:A), y = z -> x = y -> x = z.
intros; apply trans_equal with y; auto.
Qed.

(* Theorems for nat *)

Open Scope nat_scope.

Theorem plus_eq_compat_l: forall a b c, b = c -> a + b = a + c.
intros; apply f_equal2 with (f := plus); auto.
Qed.

Theorem plus_neg_compat_l: forall a b c, b <> c -> a + b <> a + c.
intros a b c H H1; case H.
apply plus_reg_l with a; auto.
Qed.

Theorem plus_ge_compat_l: forall n m p : nat, n >= m -> p + n >= p + m.
intros n m p H; unfold ge; apply plus_le_compat_l; auto.
Qed.

Theorem plus_neg_reg_l: forall a b c,  a + b <> a + c -> b <> c.
intros a b c H H1; case H; subst; auto.
Qed.

Theorem plus_ge_reg_l: forall n m p : nat, p + n >= p + m -> n >= m.
intros n m p H; unfold ge; apply plus_le_reg_l with p; auto.
Qed.

(* For replace *)
Theorem eq_lt_trans_l : forall x y z, (x = z) -> (x < y) -> (z < y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_lt_trans_r : forall x y z, (y = z) -> (x < y) -> (x < z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_gt_trans_l : forall x y z, (x = z) -> (x > y) -> (z > y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_gt_trans_r : forall x y z, (y = z) -> (x > y) -> (x > z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_le_trans_l : forall x y z, (x = z) -> (x <= y) -> (z <= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_le_trans_r : forall x y z, (y = z) -> (x <= y) -> (x <= z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_ge_trans_l : forall x y z, (x = z) -> (x >= y) -> (z >= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_ge_trans_r : forall x y z, (y = z) -> (x >= y) -> (x >= z).
intros x y z H; rewrite H; auto.
Qed.

Theorem ge_trans: forall x y z, (x >= z) -> (z >= y) -> (x >= y).
intros x y z H1 H2; red; apply le_trans with z; auto.
Qed.

Close Scope nat_scope.

(* Theorems for N *)

Open Scope N_scope.

Theorem Nplus_eq_compat_l: forall a b c, b = c -> a + b = a + c.
intros; apply f_equal2 with (f:= Nplus); auto.
Qed.

Theorem Nplus_neg_compat_l: forall a b c, b <> c -> a + b <> a + c.
intros a b c H1 H2; case H1.
apply Nplus_reg_l with a; auto.
Qed.

Theorem Nplus_lt_compat_l: forall n m p, n < m -> p + n < p + m.
intros; to_nat; auto with arith.
Qed.

Theorem Nplus_gt_compat_l: forall n m p, n > m -> p + n > p + m.
intros; to_nat; auto with arith.
Qed.

Theorem Nplus_le_compat_l: forall n m p, n <= m -> p + n <= p + m.
intros; to_nat; auto with arith.
Qed.

Theorem Nplus_ge_compat_l: forall n m p, n >= m -> p + n >= p + m.
intros; to_nat; auto with arith.
Qed.

Theorem Nplus_neg_reg_l: forall a b c,  a + b <> a + c -> b <> c.
intros a b c H H1; case H; apply f_equal2 with (f:= Nplus); auto.
Qed.

Theorem Nplus_lt_reg_l: forall n m p, p + n < p + m -> n < m.
intros; to_nat; apply plus_lt_reg_l with nn1; auto with arith.
Qed.

Theorem Nplus_gt_reg_l: forall n m p, p + n > p + m -> n > m.
intros; to_nat; apply plus_gt_reg_l with nn1; auto with arith.
Qed.

Theorem Nplus_le_reg_l: forall n m p, p + n <= p + m -> n <= m.
intros; to_nat; apply plus_le_reg_l with nn1; auto with arith.
Qed.

Theorem Nplus_ge_reg_l: forall n m p, p + n >= p + m -> n >= m.
intros; to_nat; apply plus_ge_reg_l with nn1; auto with arith.
Qed.

(* For replace *)
Theorem Neq_lt_trans_l : forall x y z, (x = z) -> (x < y) -> (z < y).
intros; subst; auto.
Qed.

Theorem Neq_lt_trans_r : forall x y z, (y = z) -> (x < y) -> (x < z).
intros; subst; auto.
Qed.

Theorem Neq_gt_trans_l : forall x y z, (x = z) -> (x > y) -> (z > y).
intros x y z H; rewrite H; auto.
Qed.
Theorem Neq_gt_trans_r : forall x y z, (y = z) -> (x > y) -> (x > z).
intros x y z H; rewrite H; auto.
Qed.
Theorem Neq_le_trans_l : forall x y z, (x = z) -> (x <= y) -> (z <= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem Neq_le_trans_r : forall x y z, (y = z) -> (x <= y) -> (x <= z).
intros x y z H; rewrite H; auto.
Qed.
Theorem Neq_ge_trans_l : forall x y z, (x = z) -> (x >= y) -> (z >= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem Neq_ge_trans_r : forall x y z, (y = z) -> (x >= y) -> (x >= z).
intros x y z H; rewrite H; auto.
Qed.

Theorem Nge_trans: forall x y z, (x >= z) -> (z >= y) -> (x >= y).
intros; to_nat; red; apply le_trans with nn1; auto with arith.
Qed.

Close Scope N_scope.

(* Theorems for Z *)

Open Scope Z_scope.

Theorem Zplus_eq_compat_l: forall a b c:Z, (b = c -> a + b = a + c)%Z.
intros; apply f_equal2 with (f := Zplus); auto.
Qed.

Theorem Zplus_neg_compat_l: forall a b c: Z, (b <> c -> a + b <> a + c)%Z.
intros a b c H H1; case H.
apply Zplus_reg_l with a; auto.
Qed.

Theorem Zplus_ge_compat_l: forall n m p : Z, (n >= m -> p + n >= p + m)%Z.
intros n m p H; apply Z.le_ge; apply Zplus_le_compat_l; auto; apply Z.ge_le; auto.
Qed.

Theorem Zplus_neg_reg_l: forall a b c: Z,  (a + b <> a + c -> b <> c)%Z.
intros a b c H H1; case H; subst; auto.
Qed.

Theorem Zplus_ge_reg_l: forall n m p : Z, (p + n >= p + m -> n >= m)%Z.
intros n m p H; apply Z.le_ge; apply Zplus_le_reg_l with p; auto; apply Z.ge_le; auto.
Qed.

(* Theorems to simplify the goal 0 ? x * y and x * y ? 0 where ? is < > <= >= *)

Theorem Zle_sign_pos_pos: forall x y: Z, (0 <= x -> 0 <= y  -> 0 <= x * y)%Z.
auto with zarith.
Qed.

Theorem Zle_sign_neg_neg: forall x y: Z, (x <= 0 -> y <= 0  -> 0 <= x * y)%Z.
intros x y H1 H2; replace (x * y)%Z with (-x * -y)%Z; auto with zarith; ring.
Qed.

Theorem Zopp_le: forall n m, (m <= n -> -n <= -m)%Z.
auto with zarith.
Qed.

Theorem Zle_pos_neg: forall x, (0 <= -x -> x <= 0)%Z.
auto with zarith.
Qed.

Theorem Zle_sign_pos_neg: forall x y: Z, (0 <= x -> y <= 0  -> x * y <= 0)%Z.
intros x y H1 H2; apply Zle_pos_neg; replace (- (x * y))%Z with (x * (- y))%Z; auto with zarith; ring.
Qed.

Theorem Zle_sign_neg_pos: forall x y: Z, (x <= 0 -> 0 <= y  -> x * y <= 0)%Z.
intros x y H1 H2; apply Zle_pos_neg; replace (- (x * y))%Z with (-x * y)%Z; auto with zarith; ring.
Qed.

Theorem Zlt_sign_pos_pos: forall x y: Z, (0 < x -> 0 < y  -> 0 < x * y)%Z.
intros; apply Zmult_lt_O_compat; auto with zarith.
Qed.

Theorem Zlt_sign_neg_neg: forall x y: Z, (x < 0 -> y < 0  -> 0 < x * y)%Z.
intros x y H1 H2; replace (x * y)%Z with (-x * -y)%Z; auto with zarith; try ring.
apply Zmult_lt_O_compat; auto with zarith.
Qed.

Theorem Zlt_pos_neg: forall x, (0 < -x -> x < 0)%Z.
auto with zarith.
Qed.

Theorem Zlt_sign_pos_neg: forall x y: Z, (0 < x -> y < 0  -> x * y < 0)%Z.
intros x y H1 H2; apply Zlt_pos_neg; replace (- (x * y))%Z with (x * (- y))%Z; auto with zarith; try ring.
apply Zmult_lt_O_compat; auto with zarith.
Qed.

Theorem Zlt_sign_neg_pos: forall x y: Z, (x < 0 -> 0 < y  -> x * y < 0)%Z.
intros x y H1 H2; apply Zlt_pos_neg; replace (- (x * y))%Z with (-x * y)%Z; auto with zarith; try ring.
apply Zmult_lt_O_compat; auto with zarith.
Qed.

Theorem Zge_sign_neg_neg: forall x y: Z, (0 >= x -> 0 >= y  -> x * y >= 0)%Z.
intros; apply Z.le_ge; apply Zle_sign_neg_neg; auto with zarith.
Qed.

Theorem Zge_sign_pos_pos: forall x y: Z, (x >= 0 -> y >= 0  -> x * y >= 0)%Z.
intros; apply Z.le_ge; apply Zle_sign_pos_pos; auto with zarith.
Qed.

Theorem Zge_neg_pos: forall x, (0 >= -x -> x >= 0)%Z.
auto with zarith.
Qed.

Theorem Zge_sign_neg_pos: forall x y: Z, (0 >= x -> y >= 0  -> 0>= x * y)%Z.
intros; apply Z.le_ge; apply Zle_sign_neg_pos; auto with zarith.
Qed.

Theorem Zge_sign_pos_neg: forall x y: Z, (x >= 0 -> 0 >= y  -> 0 >= x * y)%Z.
intros; apply Z.le_ge; apply Zle_sign_pos_neg; auto with zarith.
Qed.

Theorem Zgt_sign_neg_neg: forall x y: Z, (0 > x -> 0 > y  -> x * y > 0)%Z.
intros; apply Z.lt_gt; apply Zlt_sign_neg_neg; auto with zarith.
Qed.

Theorem Zgt_sign_pos_pos: forall x y: Z, (x > 0 -> y > 0  -> x * y > 0)%Z.
intros; apply Z.lt_gt; apply Zlt_sign_pos_pos; auto with zarith.
Qed.

Theorem Zgt_neg_pos: forall x, (0 > -x -> x > 0)%Z.
auto with zarith.
Qed.

Theorem Zgt_sign_neg_pos: forall x y: Z, (0 > x -> y > 0  -> 0> x * y)%Z.
intros; apply Z.lt_gt; apply Zlt_sign_neg_pos; auto with zarith.
Qed.

Theorem Zgt_sign_pos_neg: forall x y: Z, (x > 0 -> 0 > y  -> 0 > x * y)%Z.
intros; apply Z.lt_gt; apply Zlt_sign_pos_neg; auto with zarith.
Qed.

(* Theorems to simplify the hyp 0 ? x * y and x * y ? 0 where ? is < > <= >= *)

Theorem Zle_sign_pos_pos_rev: forall x y: Z, (0 < x -> 0 <= x * y -> 0 <= y)%Z.
intros x y H1 H2; case (Zle_or_lt 0 y); auto with zarith.
intros H3; absurd (0 <= x * y)%Z; auto with zarith.
apply Zlt_not_le;apply Zlt_sign_pos_neg; auto.
Qed.

Theorem Zle_sign_neg_neg_rev: forall x y: Z, (x < 0 -> 0 <= x * y ->  y <= 0)%Z.
intros x y H1 H2; case (Zle_or_lt y  0); auto with zarith.
intros H3; absurd (0 <= x * y)%Z; auto with zarith.
apply Zlt_not_le;apply Zlt_sign_neg_pos; auto.
Qed.

Theorem Zle_sign_pos_neg_rev: forall x y: Z, (0 < x -> x * y <= 0 -> y <= 0)%Z.
intros x y H1 H2; case (Zle_or_lt y 0); auto with zarith.
intros H3; absurd (x * y <= 0)%Z; auto with zarith.
apply Zlt_not_le;apply Zlt_sign_pos_pos; auto.
Qed.

Theorem Zle_sign_neg_pos_rev: forall x y: Z, (x < 0 -> x * y <= 0 ->  0 <= y)%Z.
intros x y H1 H2; case (Zle_or_lt 0 y); auto with zarith.
intros H3; absurd (x * y <= 0)%Z; auto with zarith.
apply Zlt_not_le;apply Zlt_sign_neg_neg; auto.
Qed.

Theorem Zge_sign_pos_pos_rev: forall x y: Z, (x > 0 -> x * y >= 0 -> y >= 0)%Z.
intros x y H1 H2; apply Z.le_ge; apply Zle_sign_pos_pos_rev with x; auto with zarith.
Qed.

Theorem Zge_sign_neg_neg_rev: forall x y: Z, (0 > x -> x * y  >= 0->  0 >= y)%Z.
intros x y H1 H2; apply Z.le_ge; apply Zle_sign_neg_neg_rev with x; auto with zarith.
Qed.

Theorem Zge_sign_pos_neg_rev: forall x y: Z, (x > 0 -> 0 >= x * y -> 0 >= y)%Z.
intros x y H1 H2; apply Z.le_ge; apply Zle_sign_pos_neg_rev with x; auto with zarith.
Qed.

Theorem Zge_sign_neg_pos_rev: forall x y: Z, (0 > x -> 0 >= x * y ->  y >= 0)%Z.
intros x y H1 H2; apply Z.le_ge; apply Zle_sign_neg_pos_rev with x; auto with zarith.
Qed.

Theorem Zlt_sign_pos_pos_rev: forall x y: Z, (0 < x -> 0 < x * y -> 0 < y)%Z.
intros x y H1 H2; case (Zle_or_lt y 0); auto with zarith.
intros H3; absurd (0 < x * y)%Z; auto with zarith.
apply Zle_not_lt;apply Zle_sign_pos_neg; auto with zarith.
Qed.

Theorem Zlt_sign_neg_neg_rev: forall x y: Z, (x < 0 -> 0 < x * y ->  y < 0)%Z.
intros x y H1 H2; case (Zle_or_lt 0 y); auto with zarith.
intros H3; absurd (0 < x * y)%Z; auto with zarith.
apply Zle_not_lt;apply Zle_sign_neg_pos; auto with zarith.
Qed.

Theorem Zlt_sign_pos_neg_rev: forall x y: Z, (0 < x -> x * y < 0 -> y < 0)%Z.
intros x y H1 H2; case (Zle_or_lt 0 y); auto with zarith.
intros H3; absurd (x * y < 0)%Z; auto with zarith.
apply Zle_not_lt;apply Zle_sign_pos_pos; auto with zarith.
Qed.

Theorem Zlt_sign_neg_pos_rev: forall x y: Z, (x < 0 -> x * y < 0 ->  0 < y)%Z.
intros x y H1 H2; case (Zle_or_lt y 0); auto with zarith.
intros H3; absurd (x * y < 0)%Z; auto with zarith.
apply Zle_not_lt;apply Zle_sign_neg_neg; auto with zarith.
Qed.

Theorem Zgt_sign_pos_pos_rev: forall x y: Z, (x > 0 -> x * y > 0 -> y > 0)%Z.
intros x y H1 H2; apply Z.lt_gt; apply Zlt_sign_pos_pos_rev with x; auto with zarith.
Qed.

Theorem Zgt_sign_neg_neg_rev: forall x y: Z, (0 > x -> x * y  > 0->  0 > y)%Z.
intros x y H1 H2; apply Z.lt_gt; apply Zlt_sign_neg_neg_rev with x; auto with zarith.
Qed.

Theorem Zgt_sign_pos_neg_rev: forall x y: Z, (x > 0 -> 0 > x * y -> 0 > y)%Z.
intros x y H1 H2; apply Z.lt_gt; apply Zlt_sign_pos_neg_rev with x; auto with zarith.
Qed.

Theorem Zgt_sign_neg_pos_rev: forall x y: Z, (0 > x -> 0 > x * y ->  y > 0)%Z.
intros x y H1 H2; apply Z.lt_gt; apply Zlt_sign_neg_pos_rev with x; auto with zarith.
Qed.

(* Theorem to simplify x * y ? x * z where ? is < > <= >= *)

Theorem Zmult_le_neg_compat_l:
  forall n m p : Z, (m <= n)%Z -> (p <= 0)%Z -> (p * n <= p * m)%Z.
intros n m p H1 H2; replace (p * n)%Z with (-(-p * n))%Z; auto with zarith; try ring.
replace (p * m)%Z with (-(-p * m))%Z; auto with zarith; try ring.
apply Zopp_le; apply Zmult_le_compat_l; auto with zarith.
Qed.

Theorem Zopp_lt: forall n m, (m < n -> -n < -m)%Z.
auto with zarith.
Qed.

Theorem Zmult_lt_neg_compat_l:
  forall n m p : Z, (m < n)%Z -> (p < 0)%Z -> (p * n < p * m)%Z.
intros n m p H1 H2; replace (p * n)%Z with (-(-p * n))%Z; auto with zarith; try ring.
replace (p * m)%Z with (-(-p * m))%Z; auto with zarith; try ring.
apply Zopp_lt; apply Zmult_lt_compat_l; auto with zarith.
Qed.

Theorem Zopp_ge: forall n m, (m >= n -> -n >= -m)%Z.
auto with zarith.
Qed.

Theorem Zmult_ge_neg_compat_l:
  forall n m p : Z, (m >= n)%Z -> (0 >= p)%Z -> (p * n >= p * m)%Z.
intros n m p H1 H2; replace (p * n)%Z with (-(-p * n))%Z; auto with zarith; try ring.
replace (p * m)%Z with (-(-p * m))%Z; auto with zarith; try ring.
apply Zopp_ge; apply Zmult_ge_compat_l; auto with zarith.
Qed.

Theorem Zopp_gt: forall n m, (m > n -> -n > -m)%Z.
auto with zarith.
Qed.

Theorem Zmult_gt_neg_compat_l:
  forall n m p : Z, (m > n)%Z -> (0 > p)%Z -> (p * n > p * m)%Z.
intros n m p H1 H2; replace (p * n)%Z with (-(-p * n))%Z; auto with zarith; try ring.
replace (p * m)%Z with (-(-p * m))%Z; auto with zarith; try ring.
apply Zopp_gt; apply Zmult_gt_compat_l; auto with zarith.
Qed.

(* Theorem to simplify a hyp x * y ? x * z where ? is < > <= >= *)

Theorem Zmult_le_compat_l_rev:
  forall n m p : Z, (0 < p)%Z -> (p * n <= p * m)%Z -> (n <= m)%Z.
intros n m p H H1; case (Zle_or_lt n m); auto; intros H2.
absurd (p * n <= p * m)%Z; auto with zarith.
apply Zlt_not_le; apply Zmult_lt_compat_l; auto.
Qed.

Theorem Zmult_le_neg_compat_l_rev:
  forall n m p : Z, (p < 0)%Z -> (p * n <= p * m)%Z -> (m <= n)%Z.
intros n m p H H1; case (Zle_or_lt m n); auto; intros H2.
absurd (p * n <= p * m)%Z; auto with zarith.
apply Zlt_not_le; apply Zmult_lt_neg_compat_l; auto.
Qed.

Theorem Zmult_lt_compat_l_rev:
  forall n m p : Z, (0 < p)%Z -> (p * n < p * m)%Z -> (n < m)%Z.
intros n m p H H1; case (Zle_or_lt m n); auto; intros H2.
absurd (p * n < p * m)%Z; auto with zarith.
apply Zle_not_lt; apply Zmult_le_compat_l; auto with zarith.
Qed.

Theorem Zmult_lt_neg_compat_l_rev:
  forall n m p : Z, (p < 0)%Z -> (p * n < p * m)%Z -> (m < n)%Z.
intros n m p H H1; case (Zle_or_lt n m); auto; intros H2.
absurd (p * n < p * m)%Z; auto with zarith.
apply Zle_not_lt; apply Zmult_le_neg_compat_l; auto with zarith.
Qed.

Theorem Zmult_ge_compat_l_rev:
  forall n m p : Z, (p > 0)%Z -> (p * n >= p * m)%Z -> (n >= m)%Z.
intros n m p H H1;
 apply Z.le_ge; apply Zmult_le_compat_l_rev with p; auto with zarith.
Qed.

Theorem Zmult_ge_neg_compat_l_rev:
  forall n m p : Z, (0 > p)%Z -> (p * n >= p * m)%Z -> (m >= n)%Z.
intros n m p H H1;
 apply Z.le_ge; apply Zmult_le_neg_compat_l_rev with p; auto with zarith.
Qed.

Theorem Zmult_gt_compat_l_rev:
  forall n m p : Z, (p > 0)%Z -> (p * n > p * m)%Z -> (n > m)%Z.
intros n m p H H1;
 apply Z.lt_gt; apply Zmult_lt_compat_l_rev with p; auto with zarith.
Qed.

Theorem Zmult_gt_neg_compat_l_rev:
  forall n m p : Z, (0 > p)%Z -> (p * n > p * m)%Z -> (m > n)%Z.
intros n m p H H1;
 apply Z.lt_gt; apply Zmult_lt_neg_compat_l_rev with p; auto with zarith.
Qed.

(* For replace *)

Theorem eq_Zlt_trans_l : forall x y z, (x = z) -> (x < y) -> (z < y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zlt_trans_r : forall x y z, (y = z) -> (x < y) -> (x < z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zgt_trans_l : forall x y z, (x = z) -> (x > y) -> (z > y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zgt_trans_r : forall x y z, (y = z) -> (x > y) -> (x > z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zle_trans_l : forall x y z, (x = z) -> (x <= y) -> (z <= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zle_trans_r : forall x y z, (y = z) -> (x <= y) -> (x <= z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zge_trans_l : forall x y z, (x = z) -> (x >= y) -> (z >= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Zge_trans_r : forall x y z, (y = z) -> (x >= y) -> (x >= z).
intros x y z H; rewrite H; auto.
Qed.

Theorem Zge_trans: forall x y z, (x >= z) -> (z >= y) -> (x >= y).
intros x y z H1 H2; red; apply Zge_trans with z; auto.
Qed.

Close Scope Z_scope.

(* Theorems for R *)

Open Scope R_scope.

Theorem Rplus_eq_compat_l: forall a b c:R, (b = c -> a + b = a + c)%R.
intros; apply f_equal2 with (f := Rplus); auto.
Qed.

Theorem Rplus_neg_compat_l: forall a b c: R, (b <> c -> a + b <> a + c)%R.
intros a b c H H1; case H.
apply Rplus_eq_reg_l with a; auto.
Qed.

Theorem Rplus_ge_compat_l: forall n m p : R, (n >= m -> p + n >= p + m)%R.
intros n m p H; apply Rle_ge; apply Rplus_le_compat_l; auto; apply Rge_le; auto.
Qed.

Theorem Rplus_neg_reg_l: forall a b c: R,  (a + b <> a + c -> b <> c)%R.
intros a b c H H1; case H; subst; auto.
Qed.

Theorem Rplus_ge_reg_l: forall n m p : R, (p + n >= p + m -> n >= m)%R.
intros n m p H; apply Rle_ge; apply Rplus_le_reg_l with p; auto; apply Rge_le; auto.
Qed.

(* Theorems to simplify the goal 0 ? x * y and x * y ? 0 where ? is < > <= >= *)

Theorem Rle_sign_pos_pos: forall x y, (0 <= x -> 0 <= y  -> 0 <= x * y)%R.
intros x y H; apply Rmult_le_pos; auto with real.
Qed.

Theorem Rle_sign_neg_neg: forall x y, (x <= 0 -> y <= 0  -> 0 <= x * y)%R.
intros x y H1 H2; replace (x * y)%R with (-x * -y)%R; auto with real; try ring.
apply Rmult_le_pos; auto with real.
Qed.

Theorem Rle_pos_neg: forall x, (0 <= -x -> x <= 0)%R.
intros x H; rewrite <- (Ropp_involutive 0);  rewrite <- (Ropp_involutive x); auto with real.
apply Ropp_le_contravar; auto with real.
rewrite Ropp_0; auto with real.
Qed.

Theorem Rle_sign_pos_neg: forall x y: R, (0 <= x -> y <= 0  -> x * y <= 0)%R.
intros x y H1 H2; apply Rle_pos_neg; replace (- (x * y))%R with (x * (- y))%R; auto with real; try ring.
apply Rmult_le_pos; auto with real.
Qed.

Theorem Rle_sign_neg_pos: forall x y, (x <= 0 -> 0 <= y  -> x * y <= 0)%R.
intros x y H1 H2; apply Rle_pos_neg; replace (- (x * y))%R with (-x * y)%R; auto with real; try ring.
apply Rmult_le_pos; auto with real.
Qed.

Theorem Rlt_sign_pos_pos: forall x y, (0 < x -> 0 < y  -> 0 < x * y)%R.
intros; apply Rmult_lt_0_compat; auto with real.
Qed.

Theorem Rlt_sign_neg_neg: forall x y, (x < 0 -> y < 0  -> 0 < x * y)%R.
intros x y H1 H2; replace (x * y)%R with (-x * -y)%R; auto with real; try ring.
apply Rmult_lt_0_compat; auto with real.
Qed.

Theorem Rlt_pos_neg: forall x, (0 < -x -> x < 0)%R.
intros x H; rewrite <- (Ropp_involutive 0);  rewrite <- (Ropp_involutive x); auto with real.
apply Ropp_lt_contravar; auto with real.
rewrite Ropp_0; auto with real.
Qed.

Theorem Rlt_sign_pos_neg: forall x y, (0 < x -> y < 0  -> x * y < 0)%R.
intros x y H1 H2; apply Rlt_pos_neg; replace (- (x * y))%R with (x * (- y))%R; auto with real; try ring.
apply Rmult_lt_0_compat; auto.
replace 0%R with (-0)%R; auto with real.
Qed.

Theorem Rlt_sign_neg_pos: forall x y, (x < 0 -> 0 < y  -> x * y < 0)%R.
intros x y H1 H2; apply Rlt_pos_neg; replace (- (x * y))%R with (-x * y)%R; auto with real; try ring.
apply Rmult_lt_0_compat; auto with real.
Qed.

Theorem Rge_sign_neg_neg: forall x y, (0 >= x -> 0 >= y  -> x * y >= 0)%R.
intros; apply Rle_ge; apply Rle_sign_neg_neg; auto with real.
Qed.

Theorem Rge_sign_pos_pos: forall x y, (x >= 0 -> y >= 0  -> x * y >= 0)%R.
intros; apply Rle_ge; apply Rle_sign_pos_pos; auto with real.
Qed.

Theorem Rge_neg_pos: forall x, (0 >= -x -> x >= 0)%R.
intros x H; rewrite <- (Ropp_involutive 0);  rewrite <- (Ropp_involutive x); auto with real.
apply Rle_ge;apply Ropp_le_contravar; auto with real.
rewrite Ropp_0; auto with real.
Qed.

Theorem Rge_sign_neg_pos: forall x y: R, (0 >= x -> y >= 0  -> 0>= x * y)%R.
intros; apply Rle_ge; apply Rle_sign_neg_pos; auto with real.
Qed.

Theorem Rge_sign_pos_neg: forall x y, (x >= 0 -> 0 >= y  -> 0 >= x * y)%R.
intros; apply Rle_ge; apply Rle_sign_pos_neg; auto with real.
Qed.

Theorem Rgt_sign_neg_neg: forall x y, (0 > x -> 0 > y  -> x * y > 0)%R.
intros; red;  apply Rlt_sign_neg_neg; auto with real.
Qed.

Theorem Rgt_sign_pos_pos: forall x y, (x > 0 -> y > 0  -> x * y > 0)%R.
intros; red; apply Rlt_sign_pos_pos; auto with real.
Qed.

Theorem Rgt_neg_pos: forall x, (0 > -x -> x > 0)%R.
intros x H; rewrite <- (Ropp_involutive 0);  rewrite <- (Ropp_involutive x); auto with real.
red;apply Ropp_lt_contravar; auto with real.
rewrite Ropp_0; auto with real.
Qed.

Theorem Rgt_sign_neg_pos: forall x y, (0 > x -> y > 0  -> 0> x * y)%R.
intros; red; apply Rlt_sign_neg_pos; auto with real.
Qed.

Theorem Rgt_sign_pos_neg: forall x y, (x > 0 -> 0 > y  -> 0 > x * y)%R.
intros; red; apply Rlt_sign_pos_neg; auto with real.
Qed.

(* Theorems to simplify the hyp 0 ? x * y and x * y ? 0 where ? is < > <= >= *)

Theorem Rle_sign_pos_pos_rev: forall x y: R, (0 < x -> 0 <= x * y -> 0 <= y)%R.
intros x y H1 H2; case (Rle_or_lt 0 y); auto with real.
intros H3; absurd (0 <= x * y)%R; auto with real.
apply Rlt_not_le;apply Rlt_sign_pos_neg; auto.
Qed.

Theorem Rle_sign_neg_neg_rev: forall x y: R, (x < 0 -> 0 <= x * y ->  y <= 0)%R.
intros x y H1 H2; case (Rle_or_lt y  0); auto with real.
intros H3; absurd (0 <= x * y)%R; auto with real.
apply Rlt_not_le;apply Rlt_sign_neg_pos; auto.
Qed.

Theorem Rle_sign_pos_neg_rev: forall x y: R, (0 < x -> x * y <= 0 -> y <= 0)%R.
intros x y H1 H2; case (Rle_or_lt y 0); auto with real.
intros H3; absurd (x * y <= 0)%R; auto with real.
apply Rlt_not_le;apply Rlt_sign_pos_pos; auto.
Qed.

Theorem Rle_sign_neg_pos_rev: forall x y: R, (x < 0 -> x * y <= 0 ->  0 <= y)%R.
intros x y H1 H2; case (Rle_or_lt 0 y); auto with real.
intros H3; absurd (x * y <= 0)%R; auto with real.
apply Rlt_not_le;apply Rlt_sign_neg_neg; auto.
Qed.

Theorem Rge_sign_pos_pos_rev: forall x y: R, (x > 0 -> x * y >= 0 -> y >= 0)%R.
intros x y H1 H2; apply Rle_ge; apply Rle_sign_pos_pos_rev with x; auto with real.
Qed.

Theorem Rge_sign_neg_neg_rev: forall x y: R, (0 > x -> x * y  >= 0->  0 >= y)%R.
intros x y H1 H2; apply Rle_ge; apply Rle_sign_neg_neg_rev with x; auto with real.
Qed.

Theorem Rge_sign_pos_neg_rev: forall x y: R, (x > 0 -> 0 >= x * y -> 0 >= y)%R.
intros x y H1 H2; apply Rle_ge; apply Rle_sign_pos_neg_rev with x; auto with real.
Qed.

Theorem Rge_sign_neg_pos_rev: forall x y: R, (0 > x -> 0 >= x * y ->  y >= 0)%R.
intros x y H1 H2; apply Rle_ge; apply Rle_sign_neg_pos_rev with x; auto with real.
Qed.

Theorem Rlt_sign_pos_pos_rev: forall x y: R, (0 < x -> 0 < x * y -> 0 < y)%R.
intros x y H1 H2; case (Rle_or_lt y 0); auto with real.
intros H3; absurd (0 < x * y)%R; auto with real.
apply Rle_not_lt;apply Rle_sign_pos_neg; auto with real.
Qed.

Theorem Rlt_sign_neg_neg_rev: forall x y: R, (x < 0 -> 0 < x * y ->  y < 0)%R.
intros x y H1 H2; case (Rle_or_lt 0 y); auto with real.
intros H3; absurd (0 < x * y)%R; auto with real.
apply Rle_not_lt;apply Rle_sign_neg_pos; auto with real.
Qed.

Theorem Rlt_sign_pos_neg_rev: forall x y: R, (0 < x -> x * y < 0 -> y < 0)%R.
intros x y H1 H2; case (Rle_or_lt 0 y); auto with real.
intros H3; absurd (x * y < 0)%R; auto with real.
apply Rle_not_lt;apply Rle_sign_pos_pos; auto with real.
Qed.

Theorem Rlt_sign_neg_pos_rev: forall x y: R, (x < 0 -> x * y < 0 ->  0 < y)%R.
intros x y H1 H2; case (Rle_or_lt y 0); auto with real.
intros H3; absurd (x * y < 0)%R; auto with real.
apply Rle_not_lt;apply Rle_sign_neg_neg; auto with real.
Qed.

Theorem Rgt_sign_pos_pos_rev: forall x y: R, (x > 0 -> x * y > 0 -> y > 0)%R.
intros x y H1 H2; red; apply Rlt_sign_pos_pos_rev with x; auto with real.
Qed.

Theorem Rgt_sign_neg_neg_rev: forall x y: R, (0 > x -> x * y  > 0->  0 > y)%R.
intros x y H1 H2; red; apply Rlt_sign_neg_neg_rev with x; auto with real.
Qed.

Theorem Rgt_sign_pos_neg_rev: forall x y: R, (x > 0 -> 0 > x * y -> 0 > y)%R.
intros x y H1 H2; red; apply Rlt_sign_pos_neg_rev with x; auto with real.
Qed.

Theorem Rgt_sign_neg_pos_rev: forall x y: R, (0 > x -> 0 > x * y ->  y > 0)%R.
intros x y H1 H2; red; apply Rlt_sign_neg_pos_rev with x; auto with real.
Qed.

(* Theorem to simplify x * y ? x * z where ? is < > <= >= *)

Theorem Rmult_le_compat_l:
  forall n m p : R, (m <= n)%R -> (0 <= p)%R -> (p * m <= p * n)%R.
auto with real.
Qed.

Theorem Rmult_le_neg_compat_l:
  forall n m p : R, (m <= n)%R -> (p <= 0)%R -> (p * n <= p * m)%R.
intros n m p H1 H2; replace (p * n)%R with (-(-p * n))%R; auto with real; try ring.
replace (p * m)%R with (-(-p * m))%R; auto with real; try ring.
Qed.

Theorem Ropp_lt: forall n m, (m < n -> -n < -m)%R.
auto with real.
Qed.

Theorem Rmult_lt_neg_compat_l:
  forall n m p : R, (m < n)%R -> (p < 0)%R -> (p * n < p * m)%R.
intros n m p H1 H2; replace (p * n)%R with (-(-p * n))%R; auto with real; try ring.
replace (p * m)%R with (-(-p * m))%R; auto with real; try ring.
Qed.

Theorem Ropp_ge: forall n m, (m >= n -> -n >= -m)%R.
auto with real.
Qed.

Theorem Rmult_ge_compat_l:
  forall n m p : R, (m >= n)%R -> (p >= 0)%R -> (p * m >= p * n)%R.
intros n m p H H1; apply Rle_ge; auto with real.
Qed.

Theorem Rmult_ge_neg_compat_l:
  forall n m p : R, (m >= n)%R -> (0 >= p)%R -> (p * n >= p * m)%R.
intros n m p H1 H2; replace (p * n)%R with (-(-p * n))%R; auto with real; try ring.
replace (p * m)%R with (-(-p * m))%R; auto with real;try ring.
Qed.

Theorem Ropp_gt: forall n m, (m > n -> -n > -m)%R.
auto with real.
Qed.

Theorem Rmult_gt_compat_l:
  forall n m p : R, (n > m)%R -> (p > 0)%R -> (p * n > p * m)%R.
unfold Rgt; auto with real.
Qed.

Theorem Rmult_gt_neg_compat_l:
  forall n m p : R, (m > n)%R -> (0 > p)%R -> (p * n > p * m)%R.
intros n m p H1 H2; replace (p * n)%R with (-(-p * n))%R; auto with real; try ring.
replace (p * m)%R with (-(-p * m))%R; auto with real; try ring.
Qed.

(* Theorem to simplify a hyp x * y ? x * z where ? is < > <= >= *)

Theorem Rmult_le_compat_l_rev:
  forall n m p : R, (0 < p)%R -> (p * n <= p * m)%R -> (n <= m)%R.
intros n m p H H1; case (Rle_or_lt n m); auto; intros H2.
absurd (p * n <= p * m)%R; auto with real.
apply Rlt_not_le; apply Rmult_lt_compat_l; auto.
Qed.

Theorem Rmult_le_neg_compat_l_rev:
  forall n m p : R, (p < 0)%R -> (p * n <= p * m)%R -> (m <= n)%R.
intros n m p H H1; case (Rle_or_lt m n); auto; intros H2.
absurd (p * n <= p * m)%R; auto with real.
apply Rlt_not_le; apply Rmult_lt_neg_compat_l; auto.
Qed.

Theorem Rmult_lt_compat_l_rev:
  forall n m p : R, (0 < p)%R -> (p * n < p * m)%R -> (n < m)%R.
intros n m p H H1; case (Rle_or_lt m n); auto; intros H2.
absurd (p * n < p * m)%R; auto with real.
apply Rle_not_lt; apply Rmult_le_compat_l; auto with real.
Qed.

Theorem Rmult_lt_neg_compat_l_rev:
  forall n m p : R, (p < 0)%R -> (p * n < p * m)%R -> (m < n)%R.
intros n m p H H1; case (Rle_or_lt n m); auto; intros H2.
absurd (p * n < p * m)%R; auto with real.
apply Rle_not_lt; apply Rmult_le_neg_compat_l; auto with real.
Qed.

Theorem Rmult_ge_compat_l_rev:
  forall n m p : R, (p > 0)%R -> (p * n >= p * m)%R -> (n >= m)%R.
intros n m p H H1;
 apply Rle_ge; apply Rmult_le_compat_l_rev with p; auto with real.
Qed.

Theorem Rmult_ge_neg_compat_l_rev:
  forall n m p : R, (0 > p)%R -> (p * n >= p * m)%R -> (m >= n)%R.
intros n m p H H1;
 apply Rle_ge; apply Rmult_le_neg_compat_l_rev with p; auto with real.
Qed.

Theorem Rmult_gt_compat_l_rev:
  forall n m p : R, (p > 0)%R -> (p * n > p * m)%R -> (n > m)%R.
intros n m p H H1;
 red; apply Rmult_lt_compat_l_rev with p; auto with real.
Qed.

Theorem Rmult_gt_neg_compat_l_rev:
  forall n m p : R, (0 > p)%R -> (p * n > p * m)%R -> (m > n)%R.
intros n m p H H1;
 red; apply Rmult_lt_neg_compat_l_rev with p; auto with real.
Qed.

(* For replace *)

Theorem eq_Rlt_trans_l : forall x y z, (x = z) -> (x < y) -> (z < y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rlt_trans_r : forall x y z, (y = z) -> (x < y) -> (x < z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rgt_trans_l : forall x y z, (x = z) -> (x > y) -> (z > y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rgt_trans_r : forall x y z, (y = z) -> (x > y) -> (x > z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rle_trans_l : forall x y z, (x = z) -> (x <= y) -> (z <= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rle_trans_r : forall x y z, (y = z) -> (x <= y) -> (x <= z).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rge_trans_l : forall x y z, (x = z) -> (x >= y) -> (z >= y).
intros x y z H; rewrite H; auto.
Qed.
Theorem eq_Rge_trans_r : forall x y z, (y = z) -> (x >= y) -> (x >= z).
intros x y z H; rewrite H; auto.
Qed.

Theorem Rge_trans: forall x y z, (x >= z) -> (z >= y) -> (x >= y).
intros x y z H1 H2; red; apply Rge_trans with z; auto.
Qed.

(* For RGroundTac *)

Theorem Z2R_correct: forall p, (Z2R p) = (IZR p).
intros p; case p; auto.
intros p1; elim p1; auto.
intros p2 Rec; pattern (Zpos (xI p2)) at 2; replace (Zpos (xI p2)) with (2 * (Zpos p2) +1)%Z; auto with zarith.
rewrite plus_IZR; rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1);ring.
intros p2 Rec; pattern (Zpos (xO p2)) at 2; replace (Zpos (xO p2)) with (2 * (Zpos p2))%Z; auto with zarith.
rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
intros p1; elim p1; auto.
intros p2 Rec; pattern (Zneg (xI p2)) at 2; replace (Zneg (xI p2)) with ((2 * (Zneg p2) +  -1))%Z; auto with zarith.
rewrite plus_IZR; rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
intros p2 Rec; pattern (Zneg (xO p2)) at 2; replace (Zneg (xO p2)) with (2 * (Zneg p2))%Z; auto with zarith.
rewrite mult_IZR; rewrite <- Rec.
simpl Z2R; simpl IZR; case p2; intros; simpl (P2R 1); ring.
Qed.

Theorem Z2R_le: forall p q, (p <= q)%Z -> (Z2R p <= Z2R q)%R.
intros p q; repeat rewrite Z2R_correct; intros; apply IZR_le; auto.
Qed.

Theorem Z2R_lt: forall p q, (p < q)%Z -> (Z2R p < Z2R q)%R.
intros p q; repeat rewrite Z2R_correct; intros; apply IZR_lt; auto.
Qed.

Theorem Z2R_ge: forall p q, (p >= q)%Z -> (Z2R p >= Z2R q)%R.
intros p q; repeat rewrite Z2R_correct; intros; apply IZR_ge; auto.
Qed.

Theorem Z2R_gt: forall p q, (p > q)%Z -> (Z2R p > Z2R q)%R.
intros p q; repeat rewrite Z2R_correct; intros; red; apply IZR_lt;
apply Z.gt_lt; auto.
Qed.

Close Scope R_scope.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Igroup

    Build the group of the inversible elements for the operation

    Definition: ZpGroup
  **********************************************************************)
Require Import ZArith.
Require Import Tactic.
Require Import Wf_nat.
Require Import UList.
Require Import ListAux.
Require Import FGroup.

Open Scope Z_scope.

Section IG.

Variable A: Set.
Variable op: A -> A -> A.
Variable support: list A.
Variable e: A.

Hypothesis A_dec: forall a b: A, {a = b} + {a <> b}.
Hypothesis support_ulist: ulist support.
Hypothesis e_in_support: In e support.
Hypothesis op_internal: forall a b, In a support -> In b support -> In (op a b) support.
Hypothesis op_assoc: forall a b c, In a support -> In b support -> In c support -> op a (op b c) = op (op a b) c.
Hypothesis e_is_zero_l:  forall a, In a support ->  op e a = a.
Hypothesis e_is_zero_r:  forall a, In a support ->  op a e = a.

(**************************************
  is_inv_aux tests if there is an inverse of a for op in l
 **************************************)

Fixpoint is_inv_aux (l: list A) (a: A) {struct l}: bool :=
  match l with nil => false | cons b l1 =>
   if (A_dec (op a b) e) then if (A_dec (op b a) e) then true else is_inv_aux l1 a else is_inv_aux l1 a
  end.

Theorem is_inv_aux_false: forall b l, (forall a, (In a l) -> op b a <> e \/  op a b <> e) -> is_inv_aux l b = false.
intros b l; elim l; simpl; auto.
intros a l1 Rec H; case (A_dec (op a b) e); case (A_dec (op b a) e); auto.
intros H1 H2; case (H a); auto; intros H3; case H3; auto.
Qed.

(**************************************
  is_inv tests if there is an inverse in support
 **************************************)
Definition is_inv := is_inv_aux support.

(**************************************
  isupport_aux returns the sublist of inversible element of support
 **************************************)

Fixpoint isupport_aux (l: list A) : list  A :=
  match l with nil => nil | cons a  l1 => if is_inv a then a::isupport_aux l1 else isupport_aux l1 end.

(**************************************
  Some properties of isupport_aux
 **************************************)

Theorem isupport_aux_is_inv_true: forall l a, In a (isupport_aux l) -> is_inv a = true.
intros l a; elim l; simpl; auto.
intros b l1 H; case_eq (is_inv b); intros H1; simpl; auto.
intros [H2 | H2]; subst; auto.
Qed.

Theorem isupport_aux_is_in: forall l a,  is_inv a = true -> In a l -> In a (isupport_aux l).
intros l a; elim l; simpl; auto.
intros b l1 Rec H [H1 | H1]; subst.
rewrite H; auto with datatypes.
case (is_inv b); auto with datatypes.
Qed.

Theorem isupport_aux_not_in:
  forall b l, (forall a, (In a support) -> op b a <> e \/  op a b <> e) -> ~ In b (isupport_aux l).
intros b l; elim l; simpl; simpl; auto.
intros a l1 H; case_eq (is_inv a); intros H1; simpl; auto.
intros H2 [H3 | H3]; subst.
contradict H1.
unfold is_inv; rewrite is_inv_aux_false; auto.
case H; auto; apply isupport_aux_is_in; auto.
Qed.

Theorem isupport_aux_incl: forall l, incl (isupport_aux l) l.
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1; case (is_inv a); auto with datatypes.
Qed.

Theorem isupport_aux_ulist: forall l, ulist l -> ulist (isupport_aux l).
intros l; elim l; simpl; auto with datatypes.
intros a l1 H1 H2; case_eq (is_inv a); intros H3; auto with datatypes.
apply ulist_cons; auto with datatypes.
intros H4; apply (ulist_app_inv _ (a::nil) l1 a); auto with datatypes.
apply (isupport_aux_incl l1 a); auto.
apply H1; apply ulist_app_inv_r with (a:: nil); auto.
apply H1; apply ulist_app_inv_r with (a:: nil); auto.
Qed.

(**************************************
  isupport is the sublist of inversible element of support
 **************************************)

Definition isupport := isupport_aux support.

(**************************************
  Some properties of isupport
 **************************************)

Theorem isupport_is_inv_true: forall a, In a isupport -> is_inv a = true.
unfold isupport; intros a H; apply isupport_aux_is_inv_true with (1 := H).
Qed.

Theorem isupport_is_in: forall a,  is_inv a = true -> In a support -> In a isupport.
intros a H H1; unfold isupport; apply isupport_aux_is_in; auto.
Qed.

Theorem isupport_incl: incl isupport support.
unfold isupport; apply isupport_aux_incl.
Qed.

Theorem isupport_ulist: ulist isupport.
unfold isupport; apply isupport_aux_ulist.
apply support_ulist.
Qed.

Theorem isupport_length: (length isupport <= length support)%nat.
apply ulist_incl_length.
apply isupport_ulist.
apply isupport_incl.
Qed.

Theorem isupport_length_strict:
  forall b, (In b support) -> (forall a, (In a support) -> op b a <> e \/  op a b <> e) ->
           (length isupport < length support)%nat.
intros b H H1; apply ulist_incl_length_strict.
apply isupport_ulist.
apply isupport_incl.
intros H2; case (isupport_aux_not_in b support); auto.
Qed.

Fixpoint inv_aux (l: list A) (a: A) {struct l}: A :=
  match l with nil => e | cons b l1 =>
   if  A_dec (op a b) e then  if (A_dec (op b a) e) then b else inv_aux l1 a else inv_aux l1 a
  end.

Theorem inv_aux_prop_r: forall l a, is_inv_aux l a = true -> op a (inv_aux l a) = e.
intros l a; elim l; simpl.
intros; discriminate.
intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto.
Qed.

Theorem inv_aux_prop_l: forall l a, is_inv_aux l a = true -> op (inv_aux l a) a = e.
intros l a; elim l; simpl.
intros; discriminate.
intros b l1 H1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros H3 H4; subst; auto.
Qed.

Theorem inv_aux_inv: forall l a b, op a b = e -> op b a = e ->  (In a l) -> is_inv_aux l b = true.
intros l a b; elim l; simpl.
intros  _ _ H; case H.
intros c l1 Rec H H0 H1; case H1; clear H1; intros H1. subst c.
case (A_dec (op b a) e); case (A_dec (op a b) e); auto.
case (A_dec (op b c) e); case (A_dec (op c b) e); auto.
Qed.

Theorem inv_aux_in: forall l a,  In (inv_aux l a) l \/ inv_aux l a = e.
intros l a; elim l; simpl; auto.
intros b l1; case (A_dec (op a b) e); case (A_dec (op b a) e); intros _ _ [H1 | H1]; auto.
Qed.

(**************************************
  The inverse function
 **************************************)

Definition inv := inv_aux support.

(**************************************
  Some properties of inv
 **************************************)

Theorem inv_prop_r: forall a, In a isupport -> op a (inv a) = e.
intros a H; unfold inv; apply inv_aux_prop_r with (l := support).
change (is_inv a = true).
apply isupport_is_inv_true; auto.
Qed.

Theorem inv_prop_l: forall a, In a isupport -> op (inv a) a = e.
intros a H; unfold inv; apply inv_aux_prop_l with (l := support).
change (is_inv a = true).
apply isupport_is_inv_true; auto.
Qed.

Theorem is_inv_true: forall a b, op b a = e ->  op a b = e -> (In a support) -> is_inv b = true.
intros a b H H1 H2; unfold is_inv; apply inv_aux_inv with a; auto.
Qed.

Theorem is_inv_false: forall b, (forall a, (In a support) -> op b a <> e \/  op a b <> e) -> is_inv b = false.
intros b H; unfold is_inv; apply is_inv_aux_false; auto.
Qed.

Theorem inv_internal: forall a, In a isupport -> In (inv a) isupport.
intros a H; apply isupport_is_in.
apply is_inv_true with a; auto.
apply inv_prop_l; auto.
apply inv_prop_r; auto.
apply (isupport_incl a); auto.
case (inv_aux_in support a); unfold inv; auto.
intros H1; rewrite H1; apply e_in_support; auto with zarith.
Qed.

(**************************************
   We are now ready to build our group
 **************************************)

Definition IGroup : (FGroup op).
generalize (fun x=> (isupport_incl x)); intros Hx.
apply mkGroup with (s := isupport) (e := e) (i := inv); auto.
apply isupport_ulist.
intros a b H H1.
assert (Haii: In (inv a) isupport); try apply  inv_internal; auto.
assert (Hbii: In (inv b) isupport); try apply  inv_internal; auto.
apply isupport_is_in; auto.
apply is_inv_true with (op (inv b) (inv a)); auto.
rewrite op_assoc; auto.
rewrite <- (op_assoc a); auto.
rewrite inv_prop_r; auto.
rewrite e_is_zero_r; auto.
apply inv_prop_r; auto.
rewrite <- (op_assoc (inv b)); auto.
rewrite  (op_assoc (inv a)); auto.
rewrite inv_prop_l; auto.
rewrite e_is_zero_l; auto.
apply inv_prop_l; auto.
apply isupport_is_in; auto.
apply is_inv_true with e; auto.
intros a H; apply inv_internal; auto.
intros; apply inv_prop_l; auto.
intros; apply inv_prop_r; auto.
Defined.

End IG.


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

(** Power Function *)

Require Import NZAxioms NZMulOrder.

(** Interface of a power function, then its specification on naturals *)

Module Type Pow (Import A : Typ).
 Parameters Inline pow : t -> t -> t.
End Pow.

Module Type PowNotation (A : Typ)(Import B : Pow A).
 Infix "^" := pow.
End PowNotation.

Module Type Pow' (A : Typ) := Pow A <+ PowNotation A.

Module Type NZPowSpec (Import A : NZOrdAxiomsSig')(Import B : Pow' A).
 Declare Instance pow_wd : Proper (eq==>eq==>eq) pow.
 Axiom pow_0_r : forall a, a^0 == 1.
 Axiom pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
 Axiom pow_neg_r : forall a b, b<0 -> a^b == 0.
End NZPowSpec.

(** The above [pow_neg_r] specification is useless (and trivially
   provable) for N. Having it here allows to already derive
   some slightly more general statements. *)

Module Type NZPow (A : NZOrdAxiomsSig) := Pow A <+ NZPowSpec A.
Module Type NZPow' (A : NZOrdAxiomsSig) := Pow' A <+ NZPowSpec A.

(** Derived properties of power *)

Module Type NZPowProp
 (Import A : NZOrdAxiomsSig')
 (Import B : NZPow' A)
 (Import C : NZMulOrderProp A).

Hint Rewrite pow_0_r pow_succ_r : nz.

(** Power and basic constants *)

Lemma pow_0_l : forall a, 0<a -> 0^a == 0.
Proof.
 intros a Ha.
 destruct (lt_exists_pred _ _ Ha) as (a' & EQ & Ha').
 rewrite EQ. now nzsimpl.
Qed.

Lemma pow_0_l' : forall a, a~=0 -> 0^a == 0.
Proof.
 intros a Ha.
 destruct (lt_trichotomy a 0) as [LT|[EQ|GT]]; try order.
 now rewrite pow_neg_r.
 now apply pow_0_l.
Qed.

Lemma pow_1_r : forall a, a^1 == a.
Proof.
 intros. now nzsimpl'.
Qed.

Lemma pow_1_l : forall a, 0<=a -> 1^a == 1.
Proof.
 apply le_ind; intros. solve_proper.
 now nzsimpl.
 now nzsimpl.
Qed.

Hint Rewrite pow_1_r pow_1_l : nz.

Lemma pow_2_r : forall a, a^2 == a*a.
Proof.
 intros. rewrite two_succ. nzsimpl; order'.
Qed.

Hint Rewrite pow_2_r : nz.

(** Power and nullity *)

Lemma pow_eq_0 : forall a b, 0<=b -> a^b == 0 -> a == 0.
Proof.
 intros a b Hb. apply le_ind with (4:=Hb).
 solve_proper.
 rewrite pow_0_r. order'.
 clear b Hb. intros b Hb IH.
 rewrite pow_succ_r by trivial.
 intros H. apply eq_mul_0 in H. destruct H; trivial.
 now apply IH.
Qed.

Lemma pow_nonzero : forall a b, a~=0 -> 0<=b -> a^b ~= 0.
Proof.
 intros a b Ha Hb. contradict Ha. now apply pow_eq_0 with b.
Qed.

Lemma pow_eq_0_iff : forall a b, a^b == 0 <-> b<0 \/ (0<b /\ a==0).
Proof.
 intros a b. split.
 intros H.
 destruct (lt_trichotomy b 0) as [Hb|[Hb|Hb]].
 now left.
 rewrite Hb, pow_0_r in H; order'.
 right. split; trivial. apply pow_eq_0 with b; order.
 intros [Hb|[Hb Ha]]. now rewrite pow_neg_r.
 rewrite Ha. apply pow_0_l'. order.
Qed.

(** Power and addition, multiplication *)

Lemma pow_add_r : forall a b c, 0<=b -> 0<=c ->
  a^(b+c) == a^b * a^c.
Proof.
 intros a b c Hb. apply le_ind with (4:=Hb). solve_proper.
 now nzsimpl.
 clear b Hb. intros b Hb IH Hc.
 nzsimpl; trivial.
 rewrite IH; trivial. apply mul_assoc.
 now apply add_nonneg_nonneg.
Qed.

Lemma pow_mul_l : forall a b c,
  (a*b)^c == a^c * b^c.
Proof.
 intros a b c.
 destruct (lt_ge_cases c 0) as [Hc|Hc].
 rewrite !(pow_neg_r _ _ Hc). now nzsimpl.
 apply le_ind with (4:=Hc). solve_proper.
 now nzsimpl.
 clear c Hc. intros c Hc IH.
 nzsimpl; trivial.
 rewrite IH; trivial. apply mul_shuffle1.
Qed.

Lemma pow_mul_r : forall a b c, 0<=b -> 0<=c ->
  a^(b*c) == (a^b)^c.
Proof.
 intros a b c Hb. apply le_ind with (4:=Hb). solve_proper.
 intros. now nzsimpl.
 clear b Hb. intros b Hb IH Hc.
 nzsimpl; trivial.
 rewrite pow_add_r, IH, pow_mul_l; trivial. apply mul_comm.
 now apply mul_nonneg_nonneg.
Qed.

(** Positivity *)

Lemma pow_nonneg : forall a b, 0<=a -> 0<=a^b.
Proof.
 intros a b Ha.
 destruct (lt_ge_cases b 0) as [Hb|Hb].
 now rewrite !(pow_neg_r _ _ Hb).
 apply le_ind with (4:=Hb). solve_proper.
 nzsimpl; order'.
 clear b Hb. intros b Hb IH.
 nzsimpl; trivial. now apply mul_nonneg_nonneg.
Qed.

Lemma pow_pos_nonneg : forall a b, 0<a -> 0<=b -> 0<a^b.
Proof.
 intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper.
 nzsimpl; order'.
 clear b Hb. intros b Hb IH.
 nzsimpl; trivial. now apply mul_pos_pos.
Qed.

(** Monotonicity *)

Lemma pow_lt_mono_l : forall a b c, 0<c -> 0<=a<b -> a^c < b^c.
Proof.
 intros a b c Hc. apply lt_ind with (4:=Hc). solve_proper.
 intros (Ha,H). nzsimpl; trivial; order.
 clear c Hc. intros c Hc IH (Ha,H).
 nzsimpl; try order.
 apply mul_lt_mono_nonneg; trivial.
 apply pow_nonneg; try order.
 apply IH. now split.
Qed.

Lemma pow_le_mono_l : forall a b c, 0<=a<=b -> a^c <= b^c.
Proof.
 intros a b c (Ha,H).
 destruct (lt_trichotomy c 0) as [Hc|[Hc|Hc]].
 rewrite !(pow_neg_r _ _ Hc); now nzsimpl.
 rewrite Hc; now nzsimpl.
 apply lt_eq_cases in H. destruct H as [H|H]; [|now rewrite <- H].
 apply lt_le_incl, pow_lt_mono_l; now try split.
Qed.

Lemma pow_gt_1 : forall a b, 1<a -> (0<b <-> 1<a^b).
Proof.
 intros a b Ha. split; intros Hb.
 rewrite <- (pow_1_l b) by order.
 apply pow_lt_mono_l; try split; order'.
 destruct (lt_trichotomy b 0) as [H|[H|H]]; trivial.
 rewrite pow_neg_r in Hb; order'.
 rewrite H, pow_0_r in Hb. order.
Qed.

Lemma pow_lt_mono_r : forall a b c, 1<a -> 0<=c -> b<c -> a^b < a^c.
Proof.
 intros a b c Ha Hc H.
 destruct (lt_ge_cases b 0) as [Hb|Hb].
 rewrite pow_neg_r by trivial. apply pow_pos_nonneg; order'.
 assert (H' : b<=c) by order.
 destruct (le_exists_sub _ _ H') as (d & EQ & Hd).
 rewrite EQ, pow_add_r; trivial. rewrite <- (mul_1_l (a^b)) at 1.
 apply mul_lt_mono_pos_r.
 apply pow_pos_nonneg; order'.
 apply pow_gt_1; trivial.
 apply lt_eq_cases in Hd; destruct Hd as [LT|EQ']; trivial.
  rewrite <- EQ' in *. rewrite add_0_l in EQ. order.
Qed.

(** NB: since 0^0 > 0^1, the following result isn't valid with a=0 *)

Lemma pow_le_mono_r : forall a b c, 0<a -> b<=c -> a^b <= a^c.
Proof.
 intros a b c Ha H.
 destruct (lt_ge_cases b 0) as [Hb|Hb].
 rewrite (pow_neg_r _ _ Hb). apply pow_nonneg; order.
 apply le_succ_l in Ha; rewrite <- one_succ in Ha.
 apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha].
 apply lt_eq_cases in H; destruct H as [H|H]; [|now rewrite <- H].
 apply lt_le_incl, pow_lt_mono_r; order.
 nzsimpl; order.
Qed.

Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d ->
 a^b <= c^d.
Proof.
 intros. transitivity (a^d).
 apply pow_le_mono_r; intuition order.
 apply pow_le_mono_l; intuition order.
Qed.

Lemma pow_lt_mono : forall a b c d, 0<a<c -> 0<b<d ->
 a^b < c^d.
Proof.
 intros a b c d (Ha,Hac) (Hb,Hbd).
 apply le_succ_l in Ha; rewrite <- one_succ in Ha.
 apply lt_eq_cases in Ha; destruct Ha as [Ha|Ha]; [|rewrite <- Ha].
 transitivity (a^d).
 apply pow_lt_mono_r; intuition order.
 apply pow_lt_mono_l; try split; order'.
 nzsimpl; try order. apply pow_gt_1; order.
Qed.

(** Injectivity *)

Lemma pow_inj_l : forall a b c, 0<=a -> 0<=b -> 0<c ->
 a^c == b^c -> a == b.
Proof.
 intros a b c Ha Hb Hc EQ.
 destruct (lt_trichotomy a b) as [LT|[EQ'|GT]]; trivial.
 assert (a^c < b^c) by (apply pow_lt_mono_l; try split; trivial).
 order.
 assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial).
 order.
Qed.

Lemma pow_inj_r : forall a b c, 1<a -> 0<=b -> 0<=c ->
 a^b == a^c -> b == c.
Proof.
 intros a b c Ha Hb Hc EQ.
 destruct (lt_trichotomy b c) as [LT|[EQ'|GT]]; trivial.
 assert (a^b < a^c) by (apply pow_lt_mono_r; try split; trivial).
 order.
 assert (a^c < a^b) by (apply pow_lt_mono_r; try split; trivial).
 order.
Qed.

(** Monotonicity results, both ways *)

Lemma pow_lt_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c ->
  (a<b <-> a^c < b^c).
Proof.
 intros a b c Ha Hb Hc.
 split; intro LT.
 apply pow_lt_mono_l; try split; trivial.
 destruct (le_gt_cases b a) as [LE|GT]; trivial.
 assert (b^c <= a^c) by (apply pow_le_mono_l; try split; order).
 order.
Qed.

Lemma pow_le_mono_l_iff : forall a b c, 0<=a -> 0<=b -> 0<c ->
  (a<=b <-> a^c <= b^c).
Proof.
 intros a b c Ha Hb Hc.
 split; intro LE.
 apply pow_le_mono_l; try split; trivial.
 destruct (le_gt_cases a b) as [LE'|GT]; trivial.
 assert (b^c < a^c) by (apply pow_lt_mono_l; try split; trivial).
 order.
Qed.

Lemma pow_lt_mono_r_iff : forall a b c, 1<a -> 0<=c ->
  (b<c <-> a^b < a^c).
Proof.
 intros a b c Ha Hc.
 split; intro LT.
 now apply pow_lt_mono_r.
 destruct (le_gt_cases c b) as [LE|GT]; trivial.
 assert (a^c <= a^b) by (apply pow_le_mono_r; order').
 order.
Qed.

Lemma pow_le_mono_r_iff : forall a b c, 1<a -> 0<=c ->
  (b<=c <-> a^b <= a^c).
Proof.
 intros a b c Ha Hc.
 split; intro LE.
 apply pow_le_mono_r; order'.
 destruct (le_gt_cases b c) as [LE'|GT]; trivial.
 assert (a^c < a^b) by (apply pow_lt_mono_r; order').
 order.
Qed.

(** For any a>1, the a^x function is above the identity function *)

Lemma pow_gt_lin_r : forall a b, 1<a -> 0<=b -> b < a^b.
Proof.
 intros a b Ha Hb. apply le_ind with (4:=Hb). solve_proper.
 nzsimpl. order'.
 clear b Hb. intros b Hb IH. nzsimpl; trivial.
 rewrite <- !le_succ_l in *. rewrite <- two_succ in Ha.
 transitivity (2*(S b)).
  nzsimpl'. rewrite <- 2 succ_le_mono.
  rewrite <- (add_0_l b) at 1. apply add_le_mono; order.
 apply mul_le_mono_nonneg; trivial.
 order'.
 now apply lt_le_incl, lt_succ_r.
Qed.

(** Someday, we should say something about the full Newton formula.
    In the meantime, we can at least provide some inequalities about
    (a+b)^c.
*)

Lemma pow_add_lower : forall a b c, 0<=a -> 0<=b -> 0<c ->
  a^c + b^c <= (a+b)^c.
Proof.
 intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper.
 nzsimpl; order.
 clear c Hc. intros c Hc IH.
 assert (0<=c) by order'.
 nzsimpl; trivial.
 transitivity ((a+b)*(a^c + b^c)).
 rewrite mul_add_distr_r, !mul_add_distr_l.
 apply add_le_mono.
 rewrite <- add_0_r at 1. apply add_le_mono_l.
  apply mul_nonneg_nonneg; trivial.
  apply pow_nonneg; trivial.
 rewrite <- add_0_l at 1. apply add_le_mono_r.
  apply mul_nonneg_nonneg; trivial.
  apply pow_nonneg; trivial.
 apply mul_le_mono_nonneg_l; trivial.
 now apply add_nonneg_nonneg.
Qed.

(** This upper bound can also be seen as a convexity proof for x^c :
    image of (a+b)/2 is below the middle of the images of a and b
*)

Lemma pow_add_upper : forall a b c, 0<=a -> 0<=b -> 0<c ->
  (a+b)^c <= 2^(pred c) * (a^c + b^c).
Proof.
 assert (aux : forall a b c, 0<=a<=b -> 0<c ->
         (a + b) * (a ^ c + b ^ c) <= 2 * (a * a ^ c + b * b ^ c)).
 (* begin *)
  intros a b c (Ha,H) Hc.
  rewrite !mul_add_distr_l, !mul_add_distr_r. nzsimpl'.
  rewrite <- !add_assoc. apply add_le_mono_l.
  rewrite !add_assoc. apply add_le_mono_r.
  destruct (le_exists_sub _ _ H) as (d & EQ & Hd).
  rewrite EQ.
  rewrite 2 mul_add_distr_r.
  rewrite !add_assoc. apply add_le_mono_r.
  rewrite add_comm. apply add_le_mono_l.
  apply mul_le_mono_nonneg_l; trivial.
  apply pow_le_mono_l; try split; order.
 (* end *)
 intros a b c Ha Hb Hc. apply lt_ind with (4:=Hc). solve_proper.
 nzsimpl; order.
 clear c Hc. intros c Hc IH.
 assert (0<=c) by order.
 nzsimpl; trivial.
 transitivity ((a+b)*(2^(pred c) * (a^c + b^c))).
 apply mul_le_mono_nonneg_l; trivial.
 now apply add_nonneg_nonneg.
 rewrite mul_assoc. rewrite (mul_comm (a+b)).
 assert (EQ : S (P c) == c) by (apply lt_succ_pred with 0; order').
 assert (LE : 0 <= P c) by (now rewrite succ_le_mono, EQ, le_succ_l).
 assert (EQ' : 2^c == 2^(P c) * 2) by (rewrite <- EQ at 1; nzsimpl'; order).
 rewrite EQ', <- !mul_assoc.
 apply mul_le_mono_nonneg_l.
 apply pow_nonneg; order'.
 destruct (le_gt_cases a b).
 apply aux; try split; order'.
 rewrite (add_comm a), (add_comm (a^c)), (add_comm (a*a^c)).
 apply aux; try split; order'.
Qed.

End NZPowProp.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Definition synth (lf1 : natural) (y : natural) : natural := plus y lf1.


(** * Introduction *)

Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

From QuickChick Require Import QuickChick.
Require Import List ZArith. Import ListNotations.

(* ################################################################# *)
(** * A First Taste of Testing *)

(** Consider the following definition of a function [remove], which
    takes a natural number [x] and a list of nats [l] and removes [x]
    from the list. *)

Fixpoint remove (x : nat) (l : list nat) : list nat :=
  match l with
    | []   => []
    | h::t => if h =? x then t else h :: remove x t
  end.

(** One possible specification for [remove] might be this property... *)

Conjecture removeP : forall x l,  ~ (In x (remove x l)).

(** ...which says that [x] never occurs in the result of [remove x l]
    for any [x] and [l].  ([Conjecture foo...] means the same as
    [Theorem foo... Admitted.]  Formally, [foo] is treated as an
    axiom.) *)

(** Sadly, this property is false, as we would (eventually) discover
    if we were to try to prove it. *)

(** A different -- perhaps much more efficient -- way to discover
    the discrepancy between the definition and specification is
    to _test_ it: *)

(* QuickChick removeP. *)

(** (Try uncommenting and evaluating the previous line.) *)

(** The [QuickChick] command takes an "executable" property (we'll see
    later exactly what this means) and attempts to falsify it by
    running it on many randomly generated inputs, resulting in output
    like this:

       0
       [0, 0]
       Failed! After 17 tests and 12 shrinks

    This means that, if we run [remove] with [x] being [0] and [l]
    being the two-element list containing two zeros, then the property
    [removeP] fails. *)

(** With this example in hand, we can see that the [then] branch
    of [remove] fails to make a recursive call, which means that only
    one occurence of [x] will be deleted. The last line of the output
    records that it took 17 tests to identify some fault-inducing
    input and 12 "shrinks" to reduce it to a minimal
    counterexample. *)

(** **** Exercise: 1 star (insertP)  *)
(** Here is a somewhat mangled definition of a function for inserting a
   new element into a sorted list of numbers: *)

Fixpoint insert x l :=
  match l with
  | [] => [x]
  | y::t => if y <? x then insert x t else y::t
  end.

(** Write a property that says "inserting a number [x] into a list [l]
    always yields a list containing [x]."  Make sure QuickChick finds
    a counterexample. *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 2 stars (insertP2)  *)
(** Translate the following claim into a [Conjecture] (using [In] for
    list membership): "For all numbers [x] and [y] and lists [l], if
    [y] is in [l] then it is also in the list that results from
    inserting [x] into [l]" (i.e., [insert] preserves all the elements
    already in [l]). Make sure QuickChick finds a counterexample. *)

(* FILL IN HERE *)
(** [] *)

(* ################################################################# *)
(** * Overview *)

(** Property-based random testing involves four basic ingredients:

    - an _executable property_ like [removeP],
    - _generators_ for random elements of the types of the inputs to
      the property (here, numbers and lists of numbers),
    - _printers_ for converting data structures like numbers and lists
      to strings when reporting counterexamples, and
    - _shrinkers_, which are used to minimize counterexamples. *)

(** We will delve into each of these in detail later on, but first we
    need to make a digression to explain Coq's support for
    _typeclasses_, which QuickChick uses extensively both internally
    and in its programmatic interface to users.  This is the
    [Typeclasses] chapter.

    In the [QC] chapter we'll cover the core concepts and
    features of QuickChick itself.

    The [TImp] chapter develops a small case study around a typed
    variant of the Imp language.

    The [QuickChickTool] chapter presents a command line tool,
    _quickChick_, that supports larger-scale projects and mutation
    testing.

    The [QuickChickInterface] chapter is a complete reference
    manual for QuickChick.

    Finally, the [Postscript] chapter gives some suggestions for
    further reading. *)

(* Tue Oct 9 11:47:30 EDT 2018 *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) : natural := mult Zero (Succ y).


Require Import Arith Lia Nat.
From Undecidability.Synthetic Require Import DecidabilityFacts.
From FOL.Tennenbaum Require Import SyntheticInType CantorPairing.
(** * Decidability of bounded quantifiers. *)

Lemma Dec_sigT_transport {X} p q :
  Dec_sigT p -> (forall x : X, p x <-> q x) -> Dec_sigT q.
Proof.
  intros Dec_p Equiv. intros x.
  destruct (Dec_p x) as [H|H];
  [left | right]; firstorder.
Qed.

Lemma dec_lt_bounded_sig N (p : nat -> Type) :
  (forall x, p x + (p x -> False)) -> { x & ((x < N) * p x)%type } + (forall x, x < N -> p x -> False).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. destruct Hx. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
      now apply IH.
Defined.

Lemma dec_lt_bounded_exist' N p :
  Dec_sigT p -> (exists x, x < N /\ p x) + (forall x, x < N -> ~ p x).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
Defined.

Lemma dec_lt_bounded_exist N p :
  Dec_sigT p -> dec (exists x, x < N /\ p x).
Proof.
  intros Dec_p.
  destruct (dec_lt_bounded_exist' N p Dec_p).
  now left. right. firstorder.
Defined.

Lemma dec_lt_bounded_forall N p :
  Dec_sigT p -> dec (forall x, x < N -> p x).
Proof.
  intros Dec_p. induction N.
  left. lia.
  destruct (Dec_p N) as [HN | HN].
  - destruct (IHN) as [IH | IH].
    +  left. intros x Hx.
    assert (x = N \/ x < N) as [->|] by lia; auto.
    + right. intros H. apply IH.
      intros x Hx. apply H. lia.
  - right. intros H. apply HN.
    apply H. lia.
Defined.

Lemma neg_lt_bounded_forall N p :
  Dec_sigT p -> (~ forall x, x < N -> p x) -> exists x, x < N /\ ~ p x.
Proof.
  intros Hp H.
  induction N. exfalso. apply H; lia.
  destruct (Hp N).
  - destruct IHN as [n ].
    + intros H1. apply H. intros.
      assert (x = N \/ x < N) as [->|] by lia.
      auto. now apply H1.
    + exists n. intuition lia.
  - exists N. auto.
Qed.

(** * The product type for Nat is witnessing. *)

Theorem ProductWO (p : nat -> nat -> Prop) :
  ( forall x y, dec (p x y) ) -> (exists x y, p x y) -> { x & { y & p x y }}.
Proof.
  intros Dec_p H.
  pose (P n := let (x, y) := decode n in p x y).
  assert ({n & P n}) as [n Hn].
  apply Witnessing_nat.
  - intros n.
    destruct (decode n) as [x y] eqn:E.
    destruct (Dec_p x y); (left + right); unfold P; now rewrite E.
  - destruct H as (x & y & H).
    exists (code (x, y)). unfold P.
    now rewrite inv_dc.
  - destruct (decode n) as [x y] eqn:E.
    exists x, y. unfold P in Hn; now rewrite E in Hn.
Qed.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* presyntax *)

Inductive term : Type :=
| Var (x : var)
| TT
| App (s t : term)
| Fun (s : {bind 2 of term})
| Pi (s : term) (t : {bind term})
| Cast (s t : term).

Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance substLemmas_term : SubstLemmas term. derive. Qed.


(** This file continues the development of algebra [Operation]. It
    gives a way to construct operations using (conventional) curried
    functions, and shows that such curried operations are equivalent
    to the uncurried operations [Operation]. *)

Require Export HoTT.Algebra.Universal.Algebra.

Require Import
  HoTT.Types
  HoTT.Spaces.Finite
  HoTT.Spaces.Nat.

Local Open Scope Algebra_scope.
Local Open Scope nat_scope.

(** Functions [head_dom'] and [head_dom] are used to get the first
    element of a nonempty operation domain [a : forall i, A (ss i)]. *)

Monomorphic Definition head_dom' {σ} (A : Carriers σ) (n : nat)
  : forall (N : n > 0) (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)),
    A (fshead' n N ss)
  := match n with
     | 0 => fun N ss _ => Empty_rec (not_lt_n_n _ N)
     | n'.+1 => fun N ss a => a fin_zero
     end.

Monomorphic Definition head_dom {σ} (A : Carriers σ) {n : nat}
  (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i))
  : A (fshead ss)
  := head_dom' A n.+1 _ ss a.

(** Functions [tail_dom'] and [tail_dom] are used to obtain the tail
    of an operation domain [a : forall i, A (ss i)]. *)

Monomorphic Definition tail_dom' {σ} (A : Carriers σ) (n : nat)
  : forall (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)) (i : Fin (pred n)),
    A (fstail' n ss i)
  := match n with
     | 0 => fun ss _ i => Empty_rec i
     | n'.+1 => fun ss a i => a (fsucc i)
     end.

Monomorphic Definition tail_dom {σ} (A : Carriers σ) {n : nat}
  (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i))
  : forall i, A (fstail ss i)
  := tail_dom' A n.+1 ss a.

(** Functions [cons_dom'] and [cons_dom] to add an element to
    the front of a given domain [a : forall i, A (ss i)]. *)

Monomorphic Definition cons_dom' {σ} (A : Carriers σ) {n : nat}
  : forall (i : Fin n) (ss : FinSeq n (Sort σ)) (N : n > 0),
    A (fshead' n N ss) -> (forall i, A (fstail' n ss i)) -> A (ss i)
  := fin_ind
      (fun n i =>
        forall (ss : Fin n -> Sort σ) (N : n > 0),
        A (fshead' n N ss) -> (forall i, A (fstail' n ss i)) -> A (ss i))
      (fun n' _ z x _ => x)
      (fun n' i' _ => fun _ _ _ xs => xs i').

Definition cons_dom {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n.+1 (Sort σ))
  (x : A (fshead ss)) (xs : forall i, A (fstail ss i))
  : forall i : Fin n.+1, A (ss i)
  := fun i => cons_dom' A i ss _ x xs.

(** The empty domain: *)

Definition nil_dom {σ} (A : Carriers σ) (ss : FinSeq 0 (Sort σ))
  : forall i : Fin 0, A (ss i)
  := Empty_ind (A o ss).

(** A specialization of [Operation] to finite [Fin n] arity. *)

Definition FiniteOperation {σ : Signature} (A : Carriers σ)
  {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ) : Type
  := Operation A {| Arity := Fin n; sorts_dom := ss; sort_cod := t |}.

(** A type of curried operations
<<
CurriedOperation A [s1, ..., sn] t := A s1 -> ... -> A sn -> A t.
>> *)

Fixpoint CurriedOperation {σ} (A : Carriers σ) {n : nat}
  : (FinSeq n (Sort σ)) -> Sort σ -> Type
  := match n with
     | 0 => fun ss t => A t
     | n'.+1 =>
        fun ss t => A (fshead ss) -> CurriedOperation A (fstail ss) t
     end.

(** Function [operation_uncurry] is used to uncurry an operation
<<
operation_uncurry A [s1, ..., sn] t (op : CurriedOperation A [s1, ..., sn] t)
  : FiniteOperation A [s1, ..., sn] t
  := fun (x1 : A s1, ..., xn : A xn) => op x1 ... xn
>>
See [equiv_operation_curry] below. *)

Fixpoint operation_uncurry {σ} (A : Carriers σ) {n : nat}
  : forall (ss : FinSeq n (Sort σ)) (t : Sort σ),
    CurriedOperation A ss t -> FiniteOperation A ss t
  := match n with
     | 0 => fun ss t op _ => op
     | n'.+1 =>
        fun ss t op a =>
          operation_uncurry A (fstail ss) t (op (a fin_zero)) (a o fsucc)
     end.

Local Example computation_example_operation_uncurry
  : forall
      (σ : Signature) (A : Carriers σ) (n : nat) (s1 s2 t : Sort σ)
      (ss := (fscons s1 (fscons s2 fsnil)))
      (op : CurriedOperation A ss t) (a : forall i, A (ss i)),
    operation_uncurry A ss t op
    = fun a => op (a fin_zero) (a (fsucc fin_zero)).
Proof.
  reflexivity.
Qed.

(** Function [operation_curry] is used to curry an operation
<<
operation_curry A [s1, ..., sn] t (op : FiniteOperation A [s1, ..., sn] t)
  : CurriedOperation A [s1, ..., sn] t
  := fun (x1 : A s1) ... (xn : A xn) => op (x1, ..., xn)
>>
See [equiv_operation_curry] below. *)

Fixpoint operation_curry {σ} (A : Carriers σ) {n : nat}
  : forall (ss : FinSeq n (Sort σ)) (t : Sort σ),
    FiniteOperation A ss t -> CurriedOperation A ss t
  := match n with
     | 0 => fun ss t op => op (Empty_ind _)
     | n'.+1 =>
        fun ss t op x =>
          operation_curry A (fstail ss) t (op o cons_dom A ss x)
     end.

Local Example computation_example_operation_curry
  : forall
      (σ : Signature) (A : Carriers σ) (n : nat) (s1 s2 t : Sort σ)
      (ss := (fscons s1 (fscons s2 fsnil)))
      (op : FiniteOperation A ss t)
      (x1 : A s1) (x2 : A s2),
    operation_curry A ss t op
    = fun x1 x2 => op (cons_dom A ss x1 (cons_dom A _ x2 (nil_dom A _))).
Proof.
  reflexivity.
Qed.

Lemma expand_cons_dom' {σ} (A : Carriers σ) (n : nat)
  : forall (i : Fin n) (ss : FinSeq n (Sort σ)) (N : n > 0)
           (a : forall i, A (ss i)),
    cons_dom' A i ss N (head_dom' A n N ss a) (tail_dom' A n ss a) = a i.
Proof.
  intro i.
  induction i using fin_ind; intros ss N a.
  - unfold cons_dom'.
    rewrite compute_fin_ind_fin_zero.
    reflexivity.
  - unfold cons_dom'.
    by rewrite compute_fin_ind_fsucc.
Qed.

Lemma expand_cons_dom `{Funext} {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n.+1 (Sort σ)) (a : forall i, A (ss i))
  : cons_dom A ss (head_dom A ss a) (tail_dom A ss a) = a.
Proof.
  funext i.
  apply expand_cons_dom'.
Defined.

Lemma path_operation_curry_to_cunurry `{Funext} {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ)
  : operation_uncurry A ss t o operation_curry A ss t == idmap.
Proof.
  intro a.
  induction n as [| n IHn].
  - funext d. refine (ap a _). apply path_contr.
  - funext a'.
    refine (ap (fun x => x _) (IHn _ _) @ _).
    refine (ap a _).
    apply expand_cons_dom.
Qed.

Lemma path_operation_uncurry_to_curry `{Funext} {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ)
  : operation_curry A ss t o operation_uncurry A ss t == idmap.
Proof.
  intro a.
  induction n; [reflexivity|].
  funext x.
  refine (_ @ IHn (fstail ss) (a x)).
  refine (ap (operation_curry A (fstail ss) t) _).
  funext a'.
  simpl.
  unfold cons_dom, cons_dom'.
  rewrite compute_fin_ind_fin_zero.
  refine (ap (operation_uncurry A (fstail ss) t (a x)) _).
  funext i'.
  now rewrite compute_fin_ind_fsucc.
Qed.

Global Instance isequiv_operation_curry `{Funext} {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ)
  : IsEquiv (operation_curry A ss t).
Proof.
  srapply isequiv_adjointify.
  - apply operation_uncurry.
  - apply path_operation_uncurry_to_curry.
  - apply path_operation_curry_to_cunurry.
Defined.

Definition equiv_operation_curry `{Funext} {σ} (A : Carriers σ)
  {n : nat} (ss : FinSeq n (Sort σ)) (t : Sort σ)
  : FiniteOperation A ss t <~> CurriedOperation A ss t
  := Build_Equiv _ _ (operation_curry A ss t) _.


(* Ejercicio 3 - dependencia del 4 *)
Section Ejercicio3.

Variable A B C: Set.

Definition apply := fun (x : A -> B) (y : A) => (x y).
Definition o_ := fun (x : A -> B) (y : B -> C) => fun (z : A) => (y (x z)).
Definition twice := fun (x : A -> A) (y : A) => (x (x y)).

(* Al cerrar la sección, los operadores anteriores se generalizan *)
End Ejercicio3.

(* Ejercicio 4 *)
Section Ejercicio4.

Variable A: Set.

Infix "o" := (o_ A A A) (at level 80, right associativity).
Definition id := fun (x : A) => x.

Theorem e4_1 : forall x:A, (id o id) x = id x.
Proof.
  reflexivity.
Qed.

Theorem e4_2 : forall x:A, (id o id) x = id x.
Proof.
  cbv delta.
  simpl.
  reflexivity.
Qed.

Theorem e4_3 : forall x:A, (id o id) x = id x.
Proof.
  intros.
  unfold o_, id.
  reflexivity.
Qed.

End Ejercicio4.

(* Ejercicio 5 *)
Section Ejercicio5.

(* 5.1 *)
Definition opI (A : Set) (x : A) := x.
Definition opK (A : Set) (B : Set) (x : A) (y : B) := x.
Definition opS (A : Set) (B : Set) (C : Set) (f : A -> B -> C) (g : A -> B) (x : A) := ((f x) (g x)).

(* 5.2 *)
(* Para formalizar el siguiente lema, determine los tipos ?1 ... ?8 adecuados *)
Lemma e52 : forall A B : Set, opS A (B -> A) A (opK A (B -> A)) (opK A B) = opI A.
Proof.
  reflexivity.
Qed.

End Ejercicio5.

(* Ejercicio 10 *)
Section Ejercicio10.

Parameter Array : Set -> nat -> Set.
Parameter emptyA : forall X : Set, Array X 0.
Parameter addA : forall (X : Set) (n : nat), X -> Array X n -> Array X (S n).

Parameter Matrix : Set -> nat -> Set.
Parameter emptyM : forall {X : Set}, Matrix X 0.
Parameter addM : forall {X : Set}, forall {n : nat}, Matrix X n -> Array X (n + 1) -> Matrix X (n + 1).

Definition M1 := addM emptyM (addA nat 0 1 (emptyA nat)). (* matriz de una columna *)
Definition M2 := addM M1 (addA nat 1 2 (addA nat 0 2 (emptyA nat))). (* matriz de dos columnas *)
Definition M3 := addM M2 (addA nat 2 3 (addA nat 1 3 (addA nat 0 3 (emptyA nat)))). (* matriz de tres columnas *)

End Ejercicio10.

(* Ejercicio 11 *)
Section Ejercicio11.

Parameter ABNat : forall n: nat, Set.
Parameter emptyAB : ABNat 0.
Parameter addAB : forall {n: nat}, nat -> ABNat n -> ABNat n -> ABNat (n + 1).

Definition AB1 := addAB 7 emptyAB emptyAB.
Definition AB2 := addAB 3 AB1 AB1.

Check AB2.

Parameter BTree : forall T: Set, forall n: nat, Set.
Parameter emptyBT : forall {T: Set}, BTree T 0.
Parameter addBT : forall {T: Set}, forall {n: nat}, T -> BTree T n -> BTree T n -> BTree T (n + 1).

Definition BT1 := addBT 7 emptyBT emptyBT.
Definition BT2 := addBT 3 BT1 BT1.

Check BT2.

Definition BBT1 := addBT false emptyBT emptyBT.
Definition BBT2 := addBT true BBT1 BBT1.

Check BBT2.

End Ejercicio11.

(* Ejercicio 15 *)
Section Ejercicio15.

Variable U : Set.
Variable e : U.
Variable A B : U -> Prop.
Variable P : Prop.
Variable R : U -> U -> Prop.

Lemma Ej315_1 : (forall x : U, A x -> B x) -> (forall x : U, A x) -> forall x : U, B x.
Proof.
  intros.
  exact (H x (H0 x)).
Qed.

Lemma Ej315_2 : forall x : U, A x -> ~ (forall x : U, ~ A x).
Proof.
  unfold not.
  intros.
  exact (H0 x H).
Qed.

Lemma Ej315_3 : (forall x : U, P -> A x) -> P -> forall x : U, A x.
Proof.
  exact (fun D => fun P => fun x => D x P).
Qed.

Lemma Ej315_4 : (forall x y : U, R x y) -> forall x : U, R x x.
Proof.
  exact (fun G => fun x => G x x).
Qed.

Lemma Ej315_5 : (forall x y: U, R x y -> R y x) ->
                 forall z : U, R e z -> R z e.
Proof.
  exact (fun C => fun z => C e z).
Qed.

End Ejercicio15.