Require Import FloydSeq.base2.
Require Import FloydSeq.client_lemmas.
Require Import VST.floyd.mapsto_memory_block.
Require Import FloydSeq.closed_lemmas.
Require Import FloydSeq.compare_lemmas.
Require Import FloydSeq.semax_tactics.
Require Import FloydSeq.forward_lemmas.
Require Import FloydSeq.entailer.
Require Import FloydSeq.local2ptree_denote.
Require Import FloydSeq.local2ptree_eval.

Require Import CSplit.strong.
Require Import CSplit.strongFacts.

Import Cop.
Import LiftNotation.
Local Open Scope logic.

Definition int_type_min_max (type_i type_hi: type): option (Z * Z) :=
  match type_i, type_hi with
  | Tint I32 s_i _, Tint i_hi s_hi _ =>
    Some match s_i with
         | Signed => (match i_hi, s_hi with
                      | I32, Unsigned => 0
                      | _, _ => Int.min_signed
                      end, Int.max_signed)
         | Unsigned => (0, Int.max_unsigned)
         end
  | Tint I32 s_i _, Tlong s_hi _ =>
    Some match s_i with
         | Signed => match s_hi with
                     | Unsigned => (0, Int.max_signed)
                     | _ => (Int.min_signed, Int.max_signed)
                     end
         | Unsigned => (0, Int.max_unsigned)
         end
  | _, _ => None
  end.

Inductive range_init_hl (type_lo type_i type_hi: type): (Z -> Z -> Prop) -> Prop :=
| construct_range_init_hl:
  forall int_min int_max,
    is_int_type type_lo = true ->
    int_type_min_max type_i type_hi = Some (int_min, int_max) ->
    range_init_hl type_lo type_i type_hi (fun m n => int_min <= m <= n /\ n <= int_max).
(*
Lemma range_init_hl_spec: forall (type_lo type_i type_hi: type) range,
  range_init_hl type_lo type_i type_hi range ->
  exists int_min_lo int_max_lo int_min_i int_max_i int_min_hi int_max_hi
    int_min int_max,
    is_int32_type type_lo = true /\
    is_int32_type type_i = true /\
    int_type_min_max type_lo = Some (int_min_lo, int_max_lo) /\
    int_type_min_max type_i = Some (int_min_i, int_max_i) /\
    int_type_min_max type_hi = Some (int_min_hi, int_max_hi) /\
    int_min = Z.max (Z.max int_min_lo int_min_i) int_min_hi /\
    int_max = Z.min int_max_i int_max_hi /\
    forall m n,
      range m n ->
      m <= int_max_lo /\ int_min <= m <= n /\
      int_min_hi <= n <= int_max.
Proof.
  intros.
  inv H.
  exists int_min_lo, int_max_lo, int_min_i, int_max_i, int_min_hi, int_max_hi, (Z.max (Z.max int_min_lo int_min_i) int_min_hi), (Z.min int_max_i int_max_hi).
  do 7 (split; auto).
  intros.
  destruct (int_max_lo <? Z.min int_max_i int_max_hi) eqn:?H, (int_min_hi >? Z.max (Z.max int_min_lo int_min_i) int_min_hi) eqn:?H.
  + rewrite Z.ltb_lt in H5.
    rewrite Z.gtb_lt in H6.
    omega.
  + rewrite Z.ltb_lt in H5.
    rewrite <- not_true_iff_false, Z.gtb_lt in H6.
    omega.
  + rewrite <- not_true_iff_false, Z.ltb_lt in H5.
    rewrite Z.gtb_lt in H6.
    omega.
  + rewrite <- not_true_iff_false, Z.ltb_lt in H5.
    rewrite <- not_true_iff_false, Z.gtb_lt in H6.
    omega.
Qed.
*)
Inductive range_init_h (type_i type_hi: type): Z -> (Z -> Prop) -> Prop :=
| construct_range_init_h:
  forall int_min int_max,
    int_type_min_max type_i type_hi = Some (int_min, int_max) ->
    range_init_h type_i type_hi int_min (fun n =>
      int_min <= n <= int_max).

Inductive Int_eqm_unsigned: int -> Z -> Prop :=
| Int_eqm_unsigned_repr: forall z, Int_eqm_unsigned (Int.repr z) z.

Inductive Int64_eqm_unsigned: int64 -> Z -> Prop :=
| Int64_eqm_unsigned_repr: forall z, Int64_eqm_unsigned (Int64.repr z) z.

Inductive Int6432_val: type -> val -> Z -> Prop :=
| Int_64_eqm_unsigned_repr: forall s i64 z,
    Int64_eqm_unsigned i64 z ->
    Int6432_val (Tlong s noattr) (Vlong i64) z
| Int_32_eqm_unsigned_repr: forall s i i32 z,
    Int_eqm_unsigned i32 z ->
    Int6432_val (Tint s i noattr) (Vint i32) z.

Lemma Int_eqm_unsigned_repr': forall i z,
  i = Int.repr z ->
  Int_eqm_unsigned i z.
Proof.
  intros.
  subst; constructor.
Qed.

Require Import FloydSeq.local2ptree_denote.
Require Import FloydSeq.local2ptree_eval.
Require Import FloydSeq.local2ptree_typecheck.

Lemma Int64_eqm_unsigned_repr': forall i z,
  i = Int64.repr z ->
  Int64_eqm_unsigned i z.
Proof.
  intros.
  subst; constructor.
Qed.

Lemma Int_eqm_unsigned_spec: forall i z,
  Int_eqm_unsigned i z -> Int.eqm (Int.unsigned i) z.
Proof.
  intros.
  inv H.
  apply Int.eqm_sym, Int.eqm_unsigned_repr.
Qed.

Lemma Int64_eqm_unsigned_spec: forall i z,
  Int64_eqm_unsigned i z -> Int64.eqm (Int64.unsigned i) z.
Proof.
  intros.
  inv H.
  apply Int64.eqm_sym, Int64.eqm_unsigned_repr.
Qed.

Inductive Sfor_inv_rec {cs: compspecs} (Delta: tycontext): ident -> Z -> Z -> expr -> Z -> (environ -> mpred) -> (environ -> mpred) -> (environ -> mpred) -> Prop :=
| Sfor_inv_rec_step': forall A _i i m hi n assert_callee inv0 inv1,
    (forall x: A,
       Sfor_inv_rec Delta _i i m hi n (assert_callee x) (inv0 x) (inv1 x)) ->
    Sfor_inv_rec Delta _i i m hi n (exp assert_callee) (exp inv0) (exp inv1)
| Sfor_inv_rec_end: forall _i i m hi n' n P Q R T1 T2 GV (*tactic callee*),
    local2ptree Q = (T1, T2, nil, GV) ->
    T1 ! _i = None ->
    msubst_eval_expr Delta T1 T2 GV hi = Some n' ->
    Int6432_val (typeof hi) n' n ->
    ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |-- tc_expr Delta hi ->
    Sfor_inv_rec Delta _i i m hi n
      (PROPx P (LOCALx Q (SEPx R)))
      (PROPx ((m <= i <= n) :: P) (LOCALx (temp _i (Vint (Int.repr i)) :: Q) (SEPx R)))
      (PROPx P (LOCALx (temp _i (Vint (Int.repr i)) :: Q) (SEPx R))).

Lemma Sfor_inv_rec_step {cs: compspecs} (Delta: tycontext): forall A _i i m hi n assert_callee inv0 inv1,
    (forall x: A, exists inv0' inv1',
       Sfor_inv_rec Delta _i i m hi n (assert_callee x) inv0' inv1' /\
       inv0 x = inv0' /\ inv1 x = inv1') ->
    Sfor_inv_rec Delta _i i m hi n (exp assert_callee) (exp inv0) (exp inv1).
Proof.
  intros.
  apply Sfor_inv_rec_step'.
  intros.
  specialize (H x).
  destruct H as [? [? [? [? ?]]]].
  subst; auto.
Qed.

Inductive Sfor_inv {cs: compspecs} (Delta: tycontext):
  forall (_i: ident) (m: Z) (hi: expr) (n: Z)
         (assert_callee: Z -> environ -> mpred)
         (inv0: environ -> mpred)
         (inv1 inv2: Z -> environ -> mpred), Prop :=
| construct_Sfor_inv: forall _i m hi n assert_callee inv0 inv1,
    (forall i i', exists inv0' inv0'' inv1' inv1'', Sfor_inv_rec Delta _i i' m hi n (assert_callee i) inv0'' inv1'' /\ inv0' i' = inv0'' /\ inv0 i = inv0' /\ inv1' i' = inv1'' /\ inv1 i = inv1') ->
    Sfor_inv Delta _i m hi n assert_callee (EX i: Z, inv0 i i) (fun i => inv1 i i) (fun i => inv1 (i+1) i).

(* need to export range_hi? no *)

Inductive Sfor_setup {cs: compspecs} {Espec: OracleKind} (Delta: tycontext):
  forall (_i: ident) (Pre: environ -> mpred) (init: statement) (hi: expr) (type_i: type)
         (m n: Z) (assert_callee: Z -> environ -> mpred)
         (inv0: environ -> mpred), Prop :=
| Sfor_setup_const_init: forall m' m lo _i type_i hi n Pre assert_callee inv0 range,
    range_init_hl (typeof lo) type_i (typeof hi) range ->
    const_only_eval_expr lo = Some (Vint m') ->
    Int_eqm_unsigned m' m ->
    range m n ->
    ENTAIL Delta, Pre |-- assert_callee m ->
    Sfor_setup Delta _i Pre (Sset _i lo) hi type_i m n assert_callee inv0
| Sfor_setup_other: forall _i Pre init hi type_i m n assert_callee inv0 range,
    range_init_h type_i (typeof hi) m range ->
    range n ->
    @semax cs Espec Delta Pre init (normal_ret_assert inv0) ->
    Sfor_setup Delta _i Pre init hi type_i m n assert_callee inv0.

Lemma Sfor_inv_rec_spec: forall {cs: compspecs} (Delta: tycontext),
  forall _i i m hi n assert_callee inv0 inv1,
    Sfor_inv_rec Delta _i i m hi n assert_callee inv0 inv1 ->
    ENTAIL Delta, inv0 |-- EX n': val, !! (Int6432_val (typeof hi) n' n) && local (` (eq n') (eval_expr hi)) /\
    ENTAIL Delta, inv0 |-- tc_expr Delta hi /\
    (closed_wrt_vars (eq _i) assert_callee) /\
    local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee = inv1 /\
    !! (m <= i <= n) && inv1 = inv0.
Proof.
  intros.
  induction H.
  + split; [| split; [| split; [| split]]].
    - specialize (fun x => proj1 (H0 x)); clear H H0; intros.
      rewrite exp_andp2.
      apply exp_left; auto.
    - specialize (fun x => proj1 (proj2 (H0 x))); clear H H0; intros.
      rewrite exp_andp2.
      apply exp_left; auto.
    - specialize (fun x => proj1 (proj2 (proj2 (H0 x)))); clear H H0; intros.
      apply closed_wrt_exp; auto.
    - specialize (fun x => proj1 (proj2 (proj2 (proj2 (H0 x))))); clear H H0; intros.
      rewrite exp_andp2.
      apply exp_congr; auto.
    - specialize (fun x => proj2 (proj2 (proj2 (proj2 (H0 x))))); clear H H0; intros.
      rewrite exp_andp2.
      apply exp_congr; auto.
  + split; [| split; [| split; [| split]]].
    - eapply (msubst_eval_expr_eq _ P _ _ _ R) in H1.
      erewrite <- (app_nil_l P), <- local2ptree_soundness in H1 by eauto.
      rewrite <- insert_local, <- insert_prop.
      Exists n'.
      normalize.
      eapply derives_trans; [| exact H1].
      solve_andp.
    - rewrite <- insert_local, <- insert_prop.
      eapply derives_trans; [| exact H3].
      solve_andp.
    - erewrite local2ptree_soundness, app_nil_l by eauto.
      apply closed_wrt_PROPx.
      apply closed_wrt_LOCALx; [| apply closed_wrt_SEPx].
      rewrite Forall_forall.
      intros.
      rewrite in_map_iff in H4.
      destruct H4 as [? [? ?]]; subst.
      apply LocalD_complete in H5.
      destruct H5 as [[? [? [? ?]]] | [[? [? [? [? ?]]]] | [? [? ?]]]]; subst.
      * apply closed_wrt_temp.
        intros; subst; congruence.
      * apply closed_wrt_lvar.
      * apply closed_wrt_gvars.
    - rewrite <- insert_local.
      reflexivity.
    - rewrite <- insert_prop.
      reflexivity.
Qed.

Lemma Sfor_inv_spec: forall {cs: compspecs} (Delta: tycontext),
  forall _i m hi n assert_callee inv0 inv1 inv2,
    Sfor_inv Delta _i m hi n assert_callee inv0 inv1 inv2 ->
    ENTAIL Delta, inv0 |-- EX n': val, !! (Int6432_val (typeof hi) n' n) && local (` (eq n') (eval_expr hi)) /\
    ENTAIL Delta, inv0 |-- tc_expr Delta hi /\
    (forall v i, subst _i (`v) (assert_callee i) = assert_callee i) /\
    (forall i, local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee i = inv1 i) /\
    (forall i, local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee (i+1) = inv2 i) /\
    (EX i: Z, !! (m <= i <= n) && inv1 i = inv0).
Proof.
  intros.
  inv H.
  rename inv3 into inv0, inv4 into inv1.
  assert (forall i i' : Z,
             Sfor_inv_rec Delta _i i' m hi n (assert_callee i) (inv0 i i') (inv1 i i')); [| clear H0].
  {
    intros i i'; specialize (H0 i i').
    destruct H0 as [? [? [? [? [? [? [? [? ?]]]]]]]].
    subst; auto.
  }
  specialize (fun i i' => Sfor_inv_rec_spec _ _ _ _ _ _ _ _ _ (H i i')).
  clear H; intros.
  split; [| split; [| split; [| split; [| split]]]].
  + Intros i.
    specialize (H i i).
    destruct H as [? _].
    auto.
  + Intros i.
    specialize (H i i).
    destruct H as [_ [? _]].
    auto.
  + intros.
    apply closed_wrt_subst.
    specialize (H i i).
    destruct H as [_ [_ [? _]]].
    auto.
  + intros.
    specialize (H i i).
    destruct H as [_ [_ [_ [? _]]]].
    auto.
  + intros.
    specialize (H (i + 1) i).
    destruct H as [_ [_ [_ [? _]]]].
    auto.
  + apply exp_congr; intros i.
    specialize (H i i).
    destruct H as [_ [_ [_ [_ ?]]]].
    auto.
Qed.

(* [litao]
Admitted
because use const_only_isUnOpResultType_spec

Lemma Sfor_setup_spec: forall {cs: compspecs} {Espec: OracleKind} (Delta: tycontext),
  forall _i Pre init type_i hi m n assert_callee inv0 inv1,
    Sfor_setup Delta _i Pre init hi type_i m n assert_callee inv0 ->
    forall
      (TI: (temp_types Delta) ! _i = Some type_i),
    (forall i, local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee i = inv1 i) ->
    (EX i: Z, !! (m <= i <= n) && inv1 i = inv0) ->
    (forall v i, subst _i (`v) (assert_callee i) = assert_callee i) ->
    @semax cs Espec Delta Pre init (normal_ret_assert inv0) /\
    exists int_min int_max,
    int_type_min_max type_i (typeof hi) = Some (int_min, int_max) /\
    is_int32_type type_i = true /\
    int_min <= m <= int_max /\
    int_min <= n <= int_max.
Proof.
  intros.
  inv H.
  + remember (typeof hi) as type_hi eqn:?H.
    inv H3.
    split.
    - eapply semax_pre; [apply H7 | clear H7].
      eapply semax_post'; [| clear H0].
      {
        apply andp_left2, (exp_right m).
        apply andp_right; [apply prop_right; omega |].
        apply derives_refl', H0.
      }
      eapply semax_pre_post'; [| | apply semax_set_forward].
      * eapply derives_trans; [| apply now_later].
        apply andp_right; [| apply andp_left2, derives_refl].
        unfold tc_expr, tc_temp_id.
        apply andp_right; [eapply const_only_eval_expr_tc; eauto |].
        unfold typecheck_temp_id.
        rewrite TI.
        simpl typeof.
        replace (is_neutral_cast (implicit_deref (typeof lo)) type_i) with true
          by (destruct (typeof lo) as [| [| | |] [|] | | | | | | | ]; inv H1; auto;
              destruct type_i as [| [| | |] | | | | | | | ]; inv H8; auto).
        simpl tc_bool.
        unfold isCastResultType.
        replace (is_pointer_type type_i && is_pointer_type (implicit_deref (typeof lo))
            || is_int_type type_i && is_int_type (implicit_deref (typeof lo)))%bool with true
          by (destruct (typeof lo) as [| [| | |] | | | | | | | ]; inv H1; auto;
              destruct type_i as [| [| | |] | | | | | | | ]; inv H8; auto).
        rewrite tc_andp_TT1.
        destruct (typeof lo) as [| [| | |] | | | | | | | ]; inv H1; auto;
              destruct type_i as [| [| | |] | | | | | | | ]; inv H8; auto;
        simpl denote_tc_assert;
        destruct Archi.ptr64 eqn:Hp; try apply TT_right.
        simple_if_tac; apply TT_right.
      * apply andp_left2.
        Intros old.
        apply andp_derives; [| rewrite H2; auto].
        simpl; intro rho.
        eapply (const_only_eval_expr_eq (env_set rho _i old)) in H4.
        unfold subst, local, lift1; unfold_lift; simpl.
        inv H5.
        rewrite H4.
        normalize.
        split; [auto | congruence].
    - exists int_min, int_max.
      split; auto.
      split; [destruct type_i as [| [| | |] | | | | | | | ]; inv H8; auto |].
      split; omega.
  + inv H3.
    split.
    - auto.
    - exists m, int_max.
      split; auto.
      split; [destruct type_i as [| [| | |] | | | | | | | ]; inv H; auto |].
      omega.
Qed.

*)

Lemma typed_false_tint_e:
  forall v, typed_false tint v -> v = Vint Int.zero.
Proof.
clear; intros.
destruct v; inv H.
pose proof (Int.eq_spec i Int.zero).
destruct (Int.eq i Int.zero); inv H1; auto.
Qed.

Section Sfor.

Context {cs : compspecs}
        (Delta: tycontext)
        (_i: ident)
        (m n: Z)
        (init: statement)
        (hi: expr)
        (inv0: environ -> mpred)
        (assert_callee inv1 inv2: Z -> environ -> mpred)
        (type_i: type)
        (int_min int_max: Z).

Hypothesis EVAL_hi: ENTAIL Delta, inv0 |-- EX n': val, !! (Int6432_val (typeof hi) n' n) && local (` (eq n') (eval_expr hi)).
Hypothesis TC_hi: ENTAIL Delta, inv0 |-- tc_expr Delta hi.
Hypothesis I32_i: is_int32_type type_i = true.
Hypothesis IMM: int_type_min_max type_i (typeof hi) = Some (int_min, int_max).
Hypothesis Range_m: int_min <= m <= int_max.
Hypothesis Range_n: int_min <= n <= int_max.
Hypothesis TI: (temp_types Delta) ! _i = Some type_i.
Hypothesis EQ_inv1: forall i : Z, local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee i = inv1 i.
Hypothesis EQ_inv0: (EX i : Z, !! (m <= i <= n) && inv1 i)%assert = inv0.
Hypothesis EQ_inv2: forall i, local (locald_denote (temp _i (Vint (Int.repr i)))) && assert_callee (i+1) = inv2 i.
Hypothesis SUBST_callee: forall v i, subst _i (`v) (assert_callee i) = assert_callee i.

Lemma CLASSIFY_CMP: classify_cmp type_i (typeof hi) = cmp_default.
Proof.
  destruct type_i as [| [| | |] [|] | | | | | | | ];
  destruct (typeof hi) as [| [| | |] [|] | | | | | | | ]; inv IMM; auto.
Qed.

Lemma Sfor_loop_cond_tc:
  ENTAIL Delta, inv0 |-- tc_expr Delta (Eunop Onotbool (Ebinop Olt (Etempvar _i type_i) hi tint) tint).
Proof.
  intros.
  remember (Ebinop Olt (Etempvar _i type_i) hi tint).
  unfold tc_expr at 1; simpl typecheck_expr.
  replace (typeof e) with tint by (rewrite Heqe; auto).
  rewrite tc_andp_TT1.
  subst e.

  Opaque isBinOpResultType.
  simpl typecheck_expr.
  Transparent isBinOpResultType.
  rewrite TI.

  simpl orb.
  simpl snd.
  replace (is_neutral_cast type_i type_i || same_base_type type_i type_i)%bool with true
    by (destruct type_i as [| [| | |] [|] | | | | | | | ]; inv IMM; auto).

  rewrite denote_tc_assert_andp; apply andp_right; auto.
  rewrite (add_andp _ _ EVAL_hi).
  Intros n'.
  apply andp_left1.
  rewrite <- EQ_inv0.
  Intros i.
  rewrite <- EQ_inv1.
  rewrite denote_tc_assert_andp; apply andp_right;
    [| rewrite <- andp_assoc; apply andp_left1, temp_tc_initialized; auto].

  unfold isBinOpResultType; simpl typeof.
  rewrite CLASSIFY_CMP.
  replace (is_numeric_type type_i) with true
    by (destruct type_i as [| [| | |] [|] | | | | | | | ]; inv IMM; auto).
  replace (is_numeric_type (typeof hi)) with true
    by (destruct type_i as [| [| | |] | | | | | | | ]; destruct (typeof hi) as [| [| | |] [|] | | | | | | | ]; inv IMM; auto).
  simpl tc_bool.
  apply TT_right.
Qed.

Lemma Sfor_comparison_Signed_I32: forall i n',
  Int6432_val (typeof hi) n' n ->
  classify_binarith type_i (typeof hi) = bin_case_i Signed ->
  m <= i <= n ->
  force_val (sem_cmp_default Clt type_i (typeof hi) (Vint (Int.repr i)) n') = Vint Int.zero <->
  i >= n.
Proof.
  intros.
  unfold sem_cmp_default, Clight_Cop2.sem_binarith, binarith_type.
  rewrite H0.
  destruct type_i as [| [| | |] [|] a_i | [|] | | | | | |]; inv I32_i;
    try solve [destruct (typeof hi) as [| | | [|] | | | | |]; inv H0].
  destruct (typeof hi) as [| i_hi s_hi a_hi | | [|] | | | | |]; try solve [inv H0].
  inv IMM.
(*  change (Clight_Cop2.sem_cast (Tint I32 Signed a_i) (Tint I32 Signed noattr)) with sem_cast_pointer.
  change (Clight_Cop2.sem_cast (Tint i_hi s_hi a_hi) (Tint I32 Signed noattr)) with sem_cast_pointer.
*)
  inv H.
  inv H7.
  simpl.
  unfold Int.lt.
  unfold both_int. simpl. unfold Clight_Cop2.sem_cast, Clight_Cop2.classify_cast.
  destruct Archi.ptr64 eqn:Hp; simpl;
  rewrite !Int.signed_repr by (destruct i_hi, s_hi; rep_omega);
  (if_tac; [split; [intro HH; inv HH | intros; omega] |  split; auto]).
Qed.

Lemma Sfor_comparison_Unsigned_I32: forall i n',
  Int6432_val (typeof hi) n' n ->
  classify_binarith type_i (typeof hi) = bin_case_i Unsigned ->
  m <= i <= n ->
  force_val (sem_cmp_default Clt type_i (typeof hi) (Vint (Int.repr i)) n') = Vint Int.zero <->
  i >= n.
Proof.
  intros.
  unfold sem_cmp_default, Clight_Cop2.sem_binarith, binarith_type.
  rewrite H0.
  destruct type_i as [| [| | |] s_i a_i | [|] | | | | | |]; inv I32_i;
    try solve [destruct (typeof hi) as [| | | [|] | | | | |]; inv H0].
  destruct (typeof hi) as [| i_hi s_hi a_hi | | [|] | | | | |]; try solve [destruct s_i; inv H0].
  inv H.
  inv H7.
  simpl.
  unfold Int.ltu.
  assert (s_i = Unsigned \/ s_i = Signed /\ s_hi = Unsigned /\ i_hi = I32)
    by (destruct s_i, s_hi, i_hi; auto; inv H0).
  unfold both_int. simpl. unfold Clight_Cop2.sem_cast, Clight_Cop2.classify_cast.
  destruct Archi.ptr64 eqn:Hp; simpl;
  rewrite !Int.unsigned_repr
    by (destruct H as [? | [? [? ?]]]; subst; inv IMM; rep_omega);
  (if_tac; [split; [intro HH; inv HH | intros; omega] |  split; auto]).
Qed.

Lemma Sfor_comparison_Signed_I64: forall i n',
  Int6432_val (typeof hi) n' n ->
  classify_binarith type_i (typeof hi) = bin_case_l Signed ->
  m <= i <= n ->
  force_val (sem_cmp_default Clt type_i (typeof hi) (Vint (Int.repr i)) n') = Vint Int.zero <->
  i >= n.
Proof.
  intros.
  unfold sem_cmp_default, Clight_Cop2.sem_binarith, binarith_type.
  rewrite H0.
  destruct type_i as [| [| | |] s_i a_i | [|] | | | | | |]; inv I32_i.
  destruct (typeof hi) as [| [| | |] [|] | [|] | [|] | | | | |];
    try solve [destruct s_i; inv H0].
(*  change (Cop2.sem_cast (Tint I32 s_i a_i) (Tlong Signed noattr)) with (sem_cast_i2l s_i).
  change (Cop2.sem_cast (Tlong Signed a) (Tlong Signed noattr)) with sem_cast_l2l.
*)
  inv H.
  inv H6.
  simpl.
  unfold Int64.lt.
  unfold both_long, Clight_Cop2.sem_cast; simpl.
  replace (cast_int_long s_i (Int.repr i)) with (Int64.repr i).
  2: {
    unfold cast_int_long.
    destruct s_i; inv IMM.
    + rewrite Int.signed_repr by omega; auto.
    + rewrite Int.unsigned_repr by omega; auto.
  }
  destruct Archi.ptr64 eqn:Hp; simpl;
  rewrite !Int64.signed_repr by (destruct s_i; inv IMM; rep_omega);
  (if_tac; [split; [intro HH; inv HH | intros; omega] | split; auto]).
Qed.

Lemma Sfor_comparison_Unsigned_I64: forall i n',
  Int6432_val (typeof hi) n' n ->
  classify_binarith type_i (typeof hi) = bin_case_l Unsigned ->
  m <= i <= n ->
  force_val (sem_cmp_default Clt type_i (typeof hi) (Vint (Int.repr i)) n') = Vint Int.zero <->
  i >= n.
Proof.
  intros.
  unfold sem_cmp_default, Clight_Cop2.sem_binarith, binarith_type.
  rewrite H0.
  destruct type_i as [| [| | |] s_i a_i | [|] | | | | | |]; inv I32_i.
  destruct (typeof hi) as [| [| | |] [|] | [|] | [|] | | | | |];
    try solve [destruct s_i; inv H0].
  inv H.
  inv H6.
  simpl.
  unfold Int64.ltu.
  unfold both_long, Clight_Cop2.sem_cast; simpl.
  replace (cast_int_long s_i (Int.repr i)) with (Int64.repr i).
  2: {
    unfold cast_int_long.
    destruct s_i; inv IMM.
    + rewrite Int.signed_repr by rep_omega; auto.
    + rewrite Int.unsigned_repr by omega; auto.
  }
  destruct Archi.ptr64 eqn:Hp; simpl;
  rewrite !Int64.unsigned_repr by (destruct s_i; inv IMM; rep_omega);
  (if_tac; [split; [intro HH; inv HH | intros; omega] | split; auto]).
Qed.

Lemma Sfor_loop_cond_true:
  ENTAIL Delta, inv0 && local
    ((` (typed_true (typeof (Ebinop Olt (Etempvar _i type_i) hi tint))))
       (eval_expr (Ebinop Olt (Etempvar _i type_i) hi tint))) |--
  EX i: Z, !! (m <= i < n) && inv1 i.
Proof.
  intros.
  rewrite <- andp_assoc, (add_andp _ _ EVAL_hi), <- EQ_inv0.
  Intros n' i; Exists i.
  rewrite <- EQ_inv1.
  apply andp_right; [| solve_andp].
  simpl eval_expr.
  unfold local, lift1; intro rho; simpl; unfold_lift.
  normalize.
  apply prop_right; auto.
  rewrite <- H3 in H1.
  forget (eval_expr hi rho) as n'.
  clear H3.
  unfold force_val2, Clight_Cop2.sem_cmp in H1.
  rewrite CLASSIFY_CMP in H1.
  destruct (classify_binarith type_i (typeof hi)) as [ [|] | [|] | | |] eqn:H3;
    [| | | |
     destruct type_i as [| [| | |] [|] | [|] | | | | | |]; try solve [inv IMM];
     destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; inv H3 ..].
  + assert (H6: force_val (sem_cmp_default Clt type_i (typeof hi)
                           (Vint (Int.repr i)) n') <> Vint Int.zero)
        by (intro Hx; rewrite Hx in H1; inv H1).
      rewrite Sfor_comparison_Signed_I32 in H6 by auto.
      omega.
  + assert (H6: force_val (sem_cmp_default Clt type_i (typeof hi)
                           (Vint (Int.repr i)) n') <> Vint Int.zero)
        by (intro Hx; rewrite Hx in H1; inv H1).
      rewrite Sfor_comparison_Unsigned_I32 in H6 by auto.
      omega.
  + assert (H6: force_val (sem_cmp_default Clt type_i (typeof hi)
                           (Vint (Int.repr i)) n') <> Vint Int.zero)
        by (intro Hx; rewrite Hx in H1; inv H1).
      rewrite Sfor_comparison_Signed_I64 in H6 by auto.
      omega.
  + assert (H6: force_val (sem_cmp_default Clt type_i (typeof hi)
                           (Vint (Int.repr i)) n') <> Vint Int.zero)
        by (intro Hx; rewrite Hx in H1; inv H1).
      rewrite Sfor_comparison_Unsigned_I64 in H6 by auto.
    omega.
Qed.

Lemma Sfor_loop_cond_false:
  ENTAIL Delta, inv0 && local
    ((` (typed_false (typeof (Ebinop Olt (Etempvar _i type_i) hi tint))))
       (eval_expr (Ebinop Olt (Etempvar _i type_i) hi tint))) |--
  inv1 n.
Proof.
  intros.
  rewrite <- andp_assoc, (add_andp _ _ EVAL_hi), <- EQ_inv0.
  Intros n' i. assert_PROP (i = n); [| subst; solve_andp].
  rewrite <- EQ_inv1.
  simpl eval_expr.
  unfold local, lift1; intro rho; simpl; unfold_lift.
  normalize.
  apply prop_right; auto.
  rewrite <- H3 in H1.
  forget (eval_expr hi rho) as n'.
  clear H3.
  unfold force_val2, Clight_Cop2.sem_cmp in H1.
  rewrite CLASSIFY_CMP in H1.
  destruct (classify_binarith type_i (typeof hi)) as [ [|] | [|] | | |] eqn:H3;
    [| | | |
     destruct type_i as [| [| | |] [|] | [|] | | | | | |]; try solve [inv IMM];
     destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; inv H3 ..];
    try apply typed_false_tint_e in H1.
  + rewrite Sfor_comparison_Signed_I32 in H1 by auto.
    omega.
  + rewrite Sfor_comparison_Unsigned_I32 in H1 by auto.
    omega.
  + rewrite Sfor_comparison_Signed_I64 in H1 by auto.
    omega.
  + rewrite Sfor_comparison_Unsigned_I64 in H1 by auto.
    omega.
Qed.

Lemma Sfor_inc_tc: forall i s,
  m <= i < n ->
  ENTAIL Delta, inv2 i
  |-- tc_expr Delta (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i) &&
      tc_temp_id _i (typeof (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i))
        Delta (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i).
Proof.
  intros.
  unfold tc_expr, tc_temp_id.
  destruct type_i as [| [| | |] [|] | | | | | | |]; inv I32_i;
  simpl typecheck_expr; unfold typecheck_temp_id.
  + rewrite TI. simpl tc_andp.
    match goal with
    | |- context [ binarithType ?A ?B ?C ?D ?E ] =>
           replace (binarithType A B C D E) with tc_TT by (destruct s; auto)
    end.
    rewrite <- EQ_inv2, <- denote_tc_assert_andp, tc_andp_TT1, !tc_andp_TT2.
    simpl; intro rho.
    unfold isCastResultType, Clight_Cop2.classify_cast.
    destruct Archi.ptr64 eqn:Hp;
    simpl denote_tc_assert;
    try rewrite (proj2 (eqb_attr_spec a a) (eq_refl _));
    unfold_lift; unfold local, lift1;
    normalize.
    *
    rewrite <- H1;
    simpl;
    apply andp_right; apply prop_right.
    exists (Vint (Int.repr i)); split; auto;
      unfold eval_id in H1;
      destruct (Map.get (te_of rho) _i); simpl in H1; inv H1; auto.
    rewrite !Int.signed_repr by (destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; rep_omega).
    destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; rep_omega.
   *
    simpl denote_tc_assert.
    unfold_lift; unfold local, lift1.
    rewrite <- H1.
    rewrite ?(andp_comm (prop _)).
    simpl;
    apply andp_right; apply prop_right.
    rewrite !Int.signed_repr by (destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; rep_omega).
    destruct (typeof hi) as [| [| | |] [|] | [|] | | | | | |]; inv IMM; rep_omega.
    exists (Vint (Int.repr i)); split; auto;
      unfold eval_id in H1;
      destruct (Map.get (te_of rho) _i); simpl in H1; inv H1; auto.
  + rewrite TI. simpl tc_andp.
    intro rho.
    simpl.
    rewrite <- EQ_inv2.
    unfold isCastResultType;
    simpl; unfold_lift; unfold local, lift1.
    destruct Archi.ptr64 eqn:Hp;
    normalize.
    apply prop_right.
    exists (Vint (Int.repr i)); split; auto.
    unfold eval_id in H1.
    destruct (Map.get (te_of rho) _i); simpl in H1; inv H1; auto.
    apply andp_right.
    apply prop_right.
       exists (Vint (Int.repr i)); split; auto;
      unfold eval_id in H1;
      destruct (Map.get (te_of rho) _i); simpl in H1; inv H1; auto.
    simple_if_tac; simpl; apply TT_right.
Qed.

Lemma Sfor_inc_entail: forall i s,
  m <= i < n ->
  EX old : val,
  local
    ((` eq) (eval_id _i)
       (subst _i (` old)
          (eval_expr (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i)))) &&
    subst _i (` old) (inv2 i) |--
  inv0.
Proof.
  intros.
  Intros old.
  rewrite <- EQ_inv0.
  Exists (i + 1).
  rewrite <- EQ_inv1, <- EQ_inv2.
  rewrite subst_andp, SUBST_callee.
  simpl.
  intro rho; unfold local, lift1, subst; unfold_lift.
  normalize.
  rewrite eval_id_same in *.
  subst old.
  normalize.
  apply andp_right; auto.
  apply prop_right.
  split; [omega |].
  rewrite H0; clear H0.
  destruct type_i as [| [| | |] [|] | | | | | | |]; inv I32_i.
  + destruct s.
    - change (force_val2 (Clight_Cop2.sem_add (Tint I32 Signed a) (Tint I32 Signed noattr)) (Vint (Int.repr i)) (Vint (Int.repr 1))) with (Vint (Int.add (Int.repr i) (Int.repr 1))).
      rewrite add_repr.
      split; [auto | congruence].
    - change (force_val2 (Clight_Cop2.sem_add (Tint I32 Signed a) (Tint I32 Unsigned noattr)) (Vint (Int.repr i)) (Vint (Int.repr 1))) with (Vint (Int.add (Int.repr i) (Int.repr 1))).
      rewrite add_repr.
      split; [auto | congruence].
  + destruct s.
    - change (force_val2 (Clight_Cop2.sem_add (Tint I32 Unsigned a) (Tint I32 Signed noattr)) (Vint (Int.repr i)) (Vint (Int.repr 1))) with (Vint (Int.add (Int.repr i) (Int.repr 1))).
      rewrite add_repr.
      split; [auto | congruence].
    - change (force_val2 (Clight_Cop2.sem_add (Tint I32 Unsigned a) (Tint I32 Unsigned noattr)) (Vint (Int.repr i)) (Vint (Int.repr 1))) with (Vint (Int.add (Int.repr i) (Int.repr 1))).
      rewrite add_repr.
      split; [auto | congruence].
Qed.

End Sfor.

(*

Admitted
because use const_only_isUnOpResultType_spec
because use setup lemma
*)
Lemma semax_for :
 forall (Inv: environ->mpred) (n: Z) Espec {cs: compspecs} Delta
           (Pre: environ->mpred)
           (_i: ident) (init: statement) (m: Z) (hi: expr) (body MORE_COMMAND: statement) (Post: ret_assert)
           (type_i: type)
           (assert_callee: Z -> environ -> mpred)
           (inv0: environ -> mpred)
           (inv1 inv2: Z -> environ -> mpred) s
     (TI: (temp_types Delta) ! _i = Some type_i)
     (CALLEE: Inv = exp assert_callee)
     (INV: Sfor_inv Delta _i m hi n assert_callee inv0 inv1 inv2)
     (SETUP: Sfor_setup Delta _i Pre init hi type_i m n assert_callee inv0),
     (forall i, m <= i < n ->
     @semax cs Espec Delta (inv1 i)
        body
        (for_ret_assert (inv2 i) Post)) ->
     @semax cs Espec Delta
        (inv1 n) MORE_COMMAND Post ->
     @semax cs Espec Delta Pre
       (Ssequence
         (Sfor init
                (Ebinop Olt (Etempvar _i type_i) hi (Tint I32 Signed noattr))
                body
                (Sset _i (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i)))
         MORE_COMMAND) Post.
(* Proof. *)
  (* intros.
  destruct Post as [nPost bPost cPost rPost].
  apply semax_seq with (inv1 n); [clear H0 | exact H0].
  apply semax_post with {| RA_normal := inv1 n; RA_break := FF; RA_continue := FF; RA_return := rPost |};
    [apply andp_left2, derives_refl | apply andp_left2, FF_left | apply andp_left2, FF_left | intros; simpl RA_return; solve_andp |].
  simpl for_ret_assert in H.
  clear bPost cPost.
  unfold Sfor.

  apply Sfor_inv_spec in INV.
  destruct INV as [? [? [? [? [? ?]]]]].
  eapply Sfor_setup_spec in SETUP; [| eauto ..].
  destruct SETUP as [INIT [init_min_i [init_max_i [init_min_hi [init_max_hi [? [? ?]]]]]]].

  apply semax_seq' with inv0; [exact INIT | clear INIT].
  apply (semax_loop _ inv0 (EX i: Z, !! (m <= i < n) && inv2 i));
    [apply semax_seq with (EX i : Z, !! (m <= i < n) && inv1 i) |].
  + apply semax_pre with (tc_expr Delta (Eunop Onotbool (Ebinop Olt (Etempvar _i type_i) hi tint) (Tint I32 Signed noattr)) && inv0).
    {
      apply andp_right; [| solve_andp].
      eapply Sfor_loop_cond_tc; eauto.
    }
    apply semax_ifthenelse; auto.
    - eapply semax_post; [.. | apply semax_skip].
      * unfold RA_normal, normal_ret_assert, overridePost, loop1_ret_assert.
        eapply Sfor_loop_cond_true; eauto.
      * apply andp_left2, FF_left.
      * apply andp_left2, FF_left.
      * intros; apply andp_left2, FF_left.
    - eapply semax_pre; [| apply semax_break].
      unfold RA_break, overridePost, loop1_ret_assert.
      eapply Sfor_loop_cond_false; eauto.
  + Intros i.
    apply semax_extract_prop; intros.
    unfold loop1_ret_assert.
    eapply semax_post; [.. | apply H; auto].
    - unfold RA_normal.
      apply (exp_right i).
      apply andp_right; [apply prop_right | apply andp_left2]; auto.
    - unfold RA_break.
      intro; simpl;
      apply andp_left2, FF_left.
    - unfold RA_continue.
      apply (exp_right i).
      apply andp_right; [apply prop_right | apply andp_left2]; auto.
    - intros.
      apply andp_left2, derives_refl.
  + Intros i.
    apply semax_extract_prop; intros.
    eapply semax_pre_post; [.. | apply semax_set_forward].
    - eapply derives_trans; [| apply now_later].
      apply andp_right; [| apply andp_left2, derives_refl].
      eapply (Sfor_inc_tc _ _ m n); eauto.
    - unfold RA_normal, loop2_ret_assert, normal_ret_assert.
      eapply andp_left2, (Sfor_inc_entail _ _ m n); eauto.
    - apply andp_left2, FF_left.
    - apply andp_left2, FF_left.
    - intros; apply andp_left2, FF_left.
Qed. *)
Abort.

(*

Admitted
because use const_only_isUnOpResultType_spec
because use setup lemma
*)
Lemma semax_for_x :
 forall (Inv: environ->mpred) (n: Z) Espec {cs: compspecs} Delta
           (Pre: environ->mpred)
           (_i: ident) (init: statement) (m: Z) (hi: expr) (body MORE_COMMAND: statement) (Post: ret_assert)
           (type_i: type)
           (assert_callee: Z -> environ -> mpred)
           (inv0: environ -> mpred)
           (inv1 inv2: Z -> environ -> mpred) s
           test incr,
     test = Ebinop Olt (Etempvar _i type_i) hi (Tint I32 Signed noattr) ->
     incr = Sset _i (Ebinop Oadd (Etempvar _i type_i) (Econst_int (Int.repr 1) (Tint I32 s noattr)) type_i) ->
     forall
     (TI: (temp_types Delta) ! _i = Some type_i)
     (CALLEE: Inv = exp assert_callee)
     (INV: Sfor_inv Delta _i m hi n assert_callee inv0 inv1 inv2)
     (SETUP: Sfor_setup Delta _i Pre init hi type_i m n assert_callee inv0),
     (forall i, m <= i < n ->
     @semax cs Espec Delta (inv1 i)
        body
        (for_ret_assert (inv2 i) Post)) ->
     @semax cs Espec Delta
        (inv1 n) MORE_COMMAND Post ->
     @semax cs Espec Delta Pre
       (Ssequence (Sfor init test body incr)
         MORE_COMMAND) Post.
(* Proof.
intros.
subst test incr.
eapply semax_for; eauto.
Qed. *)
Abort.

Lemma quick_derives_right:
  forall P Q : environ -> mpred,
   TT |-- Q -> P |-- Q.
Proof.
intros. eapply derives_trans; try eassumption; auto.
Qed.

Ltac quick_typecheck3 :=
 clear;
 repeat match goal with
 | H := _ |- _ => clear H
 | H : _ |- _ => clear H
 end;
 apply quick_derives_right; clear; go_lowerx; intros;
 clear; repeat apply andp_right; auto; fail.

Ltac default_entailer_for_load_store :=
  repeat match goal with H := _ |- _ => clear H end;
  try quick_typecheck3;
  unfold tc_expr; simpl typeof;
  try solve [entailer!].

Ltac solve_Int_eqm_unsigned :=
    autorewrite with norm;
    match goal with
    | |- Int_eqm_unsigned ?V _ =>
      match V with
      | Int.repr _ => idtac
      | Int.sub _ _ => unfold Int.sub at 1
      | Int.add _ _ => unfold Int.add at 1
      | Int.mul _ _ => unfold Int.mul at 1
      | Int.and _ _ => unfold Int.and at 1
      | Int.or _ _ => unfold Int.or at 1
(*      | Int.shl _ _ => unfold Int.shl at 1
      | Int.shr _ _ => unfold Int.shr at 1*)
      | _ => rewrite <- (Int.repr_unsigned V) at 1
      end
    end;
    first [apply Int_eqm_unsigned_repr | apply Int_eqm_unsigned_repr'].

Ltac solve_Int64_eqm_unsigned :=
    autorewrite with norm;
    match goal with
    | |- Int64_eqm_unsigned ?V _ =>
      match V with
      | Int64.repr _ => idtac
      | Int64.sub _ _ => unfold Int64.sub at 1
      | Int64.add _ _ => unfold Int64.add at 1
      | Int64.mul _ _ => unfold Int64.mul at 1
      | Int64.and _ _ => unfold Int64.and at 1
      | Int64.or _ _ => unfold Int64.or at 1
      | _ => rewrite <- (Int64.repr_unsigned V) at 1
      end
    end;
    first [apply Int64_eqm_unsigned_repr | apply Int64_eqm_unsigned_repr'].

Ltac prove_Int6432_val :=
  first [ apply Int_64_eqm_unsigned_repr; solve_Int64_eqm_unsigned
        | apply Int_32_eqm_unsigned_repr; solve_Int_eqm_unsigned].

Ltac prove_Sfor_inv_rec :=
  match goal with
  | |- Sfor_inv_rec _ _ _ _ _ _ ?assert_callee _ _ =>
    lazymatch assert_callee with
    | exp (fun x => _) =>
        let x' := fresh x in
        eapply Sfor_inv_rec_step;
        intros x';
        do 2 eexists;
        split; [prove_Sfor_inv_rec | split; build_func_abs_right]
    | _ =>
        eapply Sfor_inv_rec_end;
        [ prove_local2ptree
        | reflexivity
        | solve_msubst_eval_expr
        | prove_Int6432_val
        | default_entailer_for_load_store]
    end
  end.

Ltac prove_Sfor_inv :=
  apply construct_Sfor_inv;
  intros ? ?;
  do 4 eexists;
  split; [prove_Sfor_inv_rec | split; [| split; [| split]]; build_func_abs_right].

Ltac simplify_Zmax a b :=
  let c := eval hnf in (Z.compare a b) in
  change (Z.max a b) with (match c with | Lt => b | _ => a end); cbv beta iota.

Ltac simplify_Zmin a b :=
  let c := eval hnf in (Z.compare a b) in
  change (Z.min a b) with (match c with | Gt => b | _ => a end); cbv beta iota.

Ltac prove_range_init_hl :=
  eapply construct_range_init_hl; reflexivity.

Ltac prove_range_init_h :=
  eapply construct_range_init_h; reflexivity.

Ltac simplify_Sfor_setup :=
  first
  [ simple eapply Sfor_setup_const_init;
    [ prove_range_init_hl
    | reflexivity
    | solve_Int_eqm_unsigned
    | cbv beta;
      repeat match goal with
             | |- _ <= _ <= _ => fail
             | |- _ /\ _ => split
             end;
      try rep_omega
    | ]
  | simple eapply Sfor_setup_other;
    [ prove_range_init_h
    | cbv beta; try rep_omega
    | ]
].

Ltac check_forloop_test :=
 reflexivity ||
 match goal with |- ?test = ?desired =>
  fail "To use forward_for_simple_bound, your loop test must have the form i<n, where i is the loop iteration variable and n is the bound expression.
 You have:" test "
Required:" desired
  end.

Ltac check_forloop_incr :=
 reflexivity ||
 match goal with |- ?incr = ?desired =>
  fail "To use forward_for_simple_bound, your loop increment must be i=i+1, where i is the loop iteration variable.
 You have:" incr "
Required:" desired
  end.

(*
[litao]
Abort tactic because using semax_for

Ltac forward_for_simple_bound'' n Inv :=
  eapply (semax_for_x Inv n);
  [ check_forloop_test
  | check_forloop_incr
  | reflexivity
  | (reflexivity || fail 1000 "The loop invariant for forward_for_simple_bound should have form (EX i: Z, _).")
  | prove_Sfor_inv
  | simplify_Sfor_setup
  | intros; abbreviate_semax;
    repeat
      match goal with
      | |- semax _ (exp (fun x => _)) _ _ =>
          let x' := fresh x in
          apply extract_exists_pre; intro x'; cbv beta
      end
  | ..]. *)


(* 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                                                     *)

Require Import FunInd.
Require Export Qquadratic.
Require Import homographic_correctness.

Lemma fraction_encoding_reduces :
 forall (a b m n : Z) (Hb : b <> 0%Z) (Hn : n <> 0%Z),
 (a * n)%Z = (m * b)%Z -> fraction_encoding a b Hb = fraction_encoding m n Hn.
Proof.
 intros a b m n Hb Hn H.
 do 2 rewrite coding_Q.
 unfold spec_fraction_encoding in |- *.
 rewrite (Qdiv_num_denom a b n).
 rewrite <- Z_to_Qmult.
 rewrite H.
 rewrite Z_to_Qmult.
 rewrite (Qmult_sym b n).
 rewrite <- Qdiv_num_denom.
 reflexivity.
 replace Zero with (Z_to_Q 0); trivial; apply Z_to_Q_not_eq; assumption.
 replace Zero with (Z_to_Q 0); trivial; apply Z_to_Q_not_eq; assumption.
Qed.

Functional Scheme Qquadratic_Qpositive_to_Q_ind :=
  Induction for Qquadratic_Qpositive_to_Q Sort Prop.

Lemma Qquadratic_Qpositive_to_Q_0 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2)
   (Hh : h <> 0%Z),
 same_ratio a b c d e f g h ->
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero = fraction_encoding d h Hh.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
                                     H_Qquadratic_sg_denom_nonzero);
            intros; try solve [ Falsum ];
	      match goal with
		[ id:same_ratio _ _ _ _ _ _ _ _ |- _]  =>
		  elim id; intros h1 (h2, (h3, (h4, (h5, h6))));
		    apply fraction_encoding_reduces; trivial
	      end.
Qed.

Lemma Qquadratic_Qpositive_to_Q_1 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2)
   (Hg : g <> 0%Z),
 same_ratio a b c d e f g h ->
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero = fraction_encoding c g Hg.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
                                     H_Qquadratic_sg_denom_nonzero);
            intros; try solve [ Falsum ];
	      match goal with
		[ id:same_ratio _ _ _ _ _ _ _ _ |- _]  =>
		  elim id; intros h1 (h2, (h3, (h4, (h5, h6))));
		    apply fraction_encoding_reduces; trivial;
		      symmetry  in |- *; assumption
	      end.
Qed.

Lemma Qquadratic_Qpositive_to_Q_2 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2)
   (Hf : f <> 0%Z),
 same_ratio a b c d e f g h ->
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero = fraction_encoding b f Hf.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
     H_Qquadratic_sg_denom_nonzero);
   intros; try solve [ Falsum ];
     match goal with
       [ id:same_ratio _ _ _ _ _ _ _ _ |- _]  =>
       elim id; intros h1 (h2, (h3, (h4, (h5, h6))));
	 apply fraction_encoding_reduces; trivial;
           symmetry  in |- *; assumption
     end.
Qed.

Lemma Qquadratic_Qpositive_to_Q_3 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2)
   (He : e <> 0%Z),
 same_ratio a b c d e f g h ->
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero = fraction_encoding a e He.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
  functional induction
    (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
      H_Qquadratic_sg_denom_nonzero);
    intros; try solve [ Falsum ];
      match goal with
	[ id:same_ratio _ _ _ _ _ _ _ _ |- _]  =>
	elim id; intros h1 (h2, (h3, (h4, (h5, h6))));
          apply fraction_encoding_reduces; trivial;
            symmetry  in |- *; assumption
      end.
Qed.

Ltac QSign_mismatch_ :=
  apply False_ind;
   match goal with
   | id1:(?X1 = 1%Z),id2:(?X1 = 0%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = (-1)%Z),id2:(?X1 = 0%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = 1%Z),id2:(?X1 = (-1)%Z) |- _ =>
       rewrite id2 in id1; discriminate id1

   | id2:(?X1 = 0%Z),id1:(?X1 = 1%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = 0%Z),id2:(?X1 = (-1)%Z) |- _ =>
       rewrite id2 in id1; discriminate id1
   | id1:(?X1 = (-1)%Z),id2:(?X1 = 1%Z) |- _ =>
       rewrite id2 in id1; discriminate id1

   end.

(* The tactique Absurd_q_sign_ solves the goal by contradiction if in the context we have:

(C1)  id1:(q_sign a b c d e f g h p1 p2 H)=1
     id2:(Z.sgn new_a+new_b+new_c+new_d)=0
     ----------------------------------

or

(C2)  id1:(q_sign a b c d e f g h p1 p2 H)=1
     id2:(Z.sgn new_e+new_f+new_g+new_h)=0
     ----------------------------------

or

(C3)  id1:(q_sign a b c d e f g h p1 p2 H)=-1
     id2:(Z.sgn new_a+new_b+new_c+new_d)=0
     ----------------------------------

or

(C4)  id1:(q_sign a b c d e f g h p1 p2 H)=-1
     id2:(Z.sgn new_e+new_f+new_g+new_h)=0
     ----------------------------------

otherwise if in the context we have

(C5)  id1:(q_sign a b c d e f g h p1 p2 H)=0
     id2:(Z.sgn ?)=0
     ----------------------------------

it calls the QSign_mismatch_ tactic.

and otherwise it fails.

In the next files we used this tactic 4 times and all of them are instances of case (C1) or (C3) above.
*)

Ltac Absurd_q_sign_ :=
  match goal with
  | id1:(q_sign ?X1 ?X2 ?X3 ?X4 ?X5 ?X6 ?X7 ?X8 ?X9 ?X10 ?X11 = ?X0),id2:
  (Z.sgn _ = 0%Z) |- _ =>
      match constr:(X0) with
      | 0%Z => QSign_mismatch_
      end ||
        (apply False_ind;
          assert
           (HH :
            Qquadratic_sign X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 =
            (X0,
            (qnew_a X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            (qnew_b X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            (qnew_c X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            qnew_d X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)),
            (qnew_e X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            (qnew_f X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            (qnew_g X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            qnew_h X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11))),
            (qnew_p1 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11,
            qnew_p2 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11))));
          [ rewrite <- id1;
             unfold qnew_a, qnew_b, qnew_c, qnew_d, qnew_e, qnew_f, qnew_g,
              qnew_h, qnew_p1, qnew_p2 in |- *;
             replace (q_sign X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11) with
              (fst (Qquadratic_sign X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11));
             [ idtac | reflexivity ]; repeat rewrite <- pair_1;
             reflexivity
          | idtac ];
          match constr:(X0) with
          | 1%Z =>
              generalize
               (Qquadratic_sign_pos_1 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11
                  (qnew_a X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_b X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_c X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_d X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_e X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_f X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_g X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_h X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_p1 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_p2 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11) HH)
          | (-1)%Z =>
              generalize
               (Qquadratic_sign_neg_1 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11
                  (qnew_a X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_b X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_c X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_d X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_e X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_f X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_g X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_h X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_p1 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)
                  (qnew_p2 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11) HH)
          end; intros [(na_nb_nc_nd_pos, _)| (na_nb_nc_nd_neg, _)];
          generalize (Zsgn_2 _ id2); [ apply sym_not_eq | idtac ];
          apply Zorder.Zlt_not_eq; assumption)
  end.

Lemma Qquadratic_Qpositive_to_Q_4 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2),
 ~ same_ratio a b c d e f g h ->
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero = 0%Z ->
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero = Zero.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
             (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
                                      H_Qquadratic_sg_denom_nonzero);
            intros; try solve [ Falsum ]; trivial;Clear_eq_;
	      match goal with
		[ id1 : q_sign ?a ?b ?c ?d ?e ?f ?g ?h ?p1 ?p2 ?H_Qquadratic_sg_denom_nonzero = _,
		  id2 : q_sign ?a ?b ?c ?d ?e ?f ?g ?h ?p1 ?p2 ?H_Qquadratic_sg_denom_nonzero = _ |- _ ] =>
		rewrite id1 in id2;discriminate id2
	      end.
Qed.

Lemma Qquadratic_Qpositive_to_Q_5 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2),
 ~ same_ratio a b c d e f g h ->
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero = 1%Z ->
 Z.sgn
   (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero) = 1%Z ->
 forall
   hyp_quadraticAcc : quadraticAcc
                        (qnew_a a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_b a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_c a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_d a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_e a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_f a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_g a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_h a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p1 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p2 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero),
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero =
 Qpos
   (Qquadratic_Qpositive_to_Qpositive
      (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      hyp_quadraticAcc).
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
     H_Qquadratic_sg_denom_nonzero);
   intros; try solve [ Falsum ]; trivial; Clear_eq_;
     QSign_mismatch_ || apply f_equal with Qpositive;
       apply Qquadratic_Qpositive_to_Qpositive_equal.
Qed.

Lemma Qquadratic_Qpositive_to_Q_6 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2),
 ~ same_ratio a b c d e f g h ->
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero = 1%Z ->
 Z.sgn
   (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero) =
 (-1)%Z ->
 forall
   hyp_quadraticAcc : quadraticAcc
                        (-
                         qnew_a a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_b a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_c a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_d a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_e a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_f a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_g a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_h a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p1 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p2 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero),
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero =
 Qpos
   (Qquadratic_Qpositive_to_Qpositive
      (- qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      hyp_quadraticAcc).
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
     H_Qquadratic_sg_denom_nonzero);
            intros; try solve [ Falsum ]; trivial; Clear_eq_;
              QSign_mismatch_ || apply f_equal with Qpositive;
		apply Qquadratic_Qpositive_to_Qpositive_equal.
Qed.

Lemma Qquadratic_Qpositive_to_Q_7 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2),
 ~ same_ratio a b c d e f g h ->
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero = (-1)%Z ->
 Z.sgn
   (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero) = 1%Z ->
 forall
   hyp_quadraticAcc : quadraticAcc
                        (qnew_a a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_b a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_c a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_d a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_e a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_f a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_g a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_h a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p1 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p2 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero),
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero =
 Qneg
   (Qquadratic_Qpositive_to_Qpositive
      (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      hyp_quadraticAcc).
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
     H_Qquadratic_sg_denom_nonzero);
   intros; try solve [ Falsum ]; trivial; Clear_eq_;
     QSign_mismatch_ || apply f_equal with Qpositive;
            apply Qquadratic_Qpositive_to_Qpositive_equal.
Qed.

Lemma Qquadratic_Qpositive_to_Q_8 :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero : Qquadratic_sg_denom_nonzero e f g h p1 p2),
 ~ same_ratio a b c d e f g h ->
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero = (-1)%Z ->
 Z.sgn
   (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero +
    qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero) =
 (-1)%Z ->
 forall
   hyp_quadraticAcc : quadraticAcc
                        (-
                         qnew_a a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_b a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_c a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (-
                         qnew_d a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_e a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_f a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_g a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_h a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p1 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero)
                        (qnew_p2 a b c d e f g h p1 p2
                           H_Qquadratic_sg_denom_nonzero),
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero =
 Qneg
   (Qquadratic_Qpositive_to_Qpositive
      (- qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (- qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      (qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero)
      hyp_quadraticAcc).
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero.
 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
     H_Qquadratic_sg_denom_nonzero);
   intros; try solve [ Falsum ]; trivial; Clear_eq_;
     QSign_mismatch_ || apply f_equal with Qpositive;
       apply Qquadratic_Qpositive_to_Qpositive_equal.
Qed.

Lemma q_sign_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 q_sign a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2;
            change
              (fst
                 (Qquadratic_sign a b c d e f g h p1 p2
                    H_Qquadratic_sg_denom_nonzero1) =
               fst
                 (Qquadratic_sign a b c d e f g h p1 p2
                    H_Qquadratic_sg_denom_nonzero2))
             in |- *;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_a_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
  intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_a in |- *;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_b_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_b in |- *;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_c_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
   H_Qquadratic_sg_denom_nonzero2; unfold qnew_c in |- *;
     apply f_equal with (Z * Z)%type;
       apply f_equal with (Z * (Z * Z))%type;
         apply f_equal with (Z * (Z * (Z * Z)))%type;
           apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
             apply
	       f_equal
               with
               (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
               apply
		 f_equal
		 with
                 (Z *
                   (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                     (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_d_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
  intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_d in |- *;
            apply f_equal with (Z * Z)%type;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_e_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_e a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
  intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2; unfold qnew_e in |- *;
      apply f_equal with (Z * (Z * (Z * Z)))%type;
        apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
          apply
            f_equal
            with
            (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
              (Qpositive * Qpositive))%type;
            apply
              f_equal
              with
              (Z *
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_f_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_f a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
  intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2; unfold qnew_f in |- *;
      apply f_equal with (Z * (Z * Z))%type;
        apply f_equal with (Z * (Z * (Z * Z)))%type;
          apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
              f_equal
              with
              (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                (Qpositive * Qpositive))%type;
              apply
		f_equal
		with
                (Z *
                  (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                    (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_g_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_g a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_g in |- *;
            apply f_equal with (Z * Z)%type;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_h_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_h a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_h in |- *;
            apply f_equal with (Z * Z)%type;
            apply f_equal with (Z * (Z * Z))%type;
            apply f_equal with (Z * (Z * (Z * Z)))%type;
            apply f_equal with (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))))%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_p1_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_p1 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_p1 in |- *;
            apply f_equal with (Qpositive * Qpositive)%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma qnew_p2_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1 =
 qnew_p2 a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1
            H_Qquadratic_sg_denom_nonzero2; unfold qnew_p2 in |- *;
            apply f_equal with (Qpositive * Qpositive)%type;
            apply
             f_equal
              with
                (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                 (Qpositive * Qpositive))%type;
            apply
             f_equal
              with
                (Z *
                 (Z * (Z * (Z * Z)) * (Z * (Z * (Z * Z))) *
                  (Qpositive * Qpositive)))%type; apply Qquadratic_sign_equal.
Qed.

Lemma Qquadratic_Qpositive_to_Q_equal :
 forall (a b c d e f g h : Z) (p1 p2 : Qpositive)
   (H_Qquadratic_sg_denom_nonzero1
    H_Qquadratic_sg_denom_nonzero2 : Qquadratic_sg_denom_nonzero e f g h p1
                                       p2),
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero1 =
 Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
   H_Qquadratic_sg_denom_nonzero2.
Proof.
 intros a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero1.

 functional induction
   (Qquadratic_Qpositive_to_Q a b c d e f g h p1 p2
                            H_Qquadratic_sg_denom_nonzero1);
  intros; Clear_eq_.
 (* 1 *)
 rewrite
  (Qquadratic_Qpositive_to_Q_3 _ _ _ _ _ _ _ _ _ _
     H_Qquadratic_sg_denom_nonzero2 He _x); reflexivity.
 (* 2 *)
 rewrite
  (Qquadratic_Qpositive_to_Q_2 _ _ _ _ _ _ _ _ _ _
     H_Qquadratic_sg_denom_nonzero2 Hf _x); reflexivity.
 (* 3 *)
 rewrite
  (Qquadratic_Qpositive_to_Q_1 _ _ _ _ _ _ _ _ _ _
     H_Qquadratic_sg_denom_nonzero2 Hg _x); reflexivity.
 (* 4 *)
 rewrite
  (Qquadratic_Qpositive_to_Q_0 _ _ _ _ _ _ _ _ _ _
     H_Qquadratic_sg_denom_nonzero2 Hh _x); reflexivity.
 (* 5 *)
 rewrite
  (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero1
     H_Qquadratic_sg_denom_nonzero2) in _x;
  rewrite
   (Qquadratic_Qpositive_to_Q_4 _ _ _ _ _ _ _ _ _ _
      H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh _x)
   ; reflexivity.
 (* 6 *)
 Absurd_q_sign_.
 (* 7 *)
 assert
  (H :
   Z.sgn
     (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2) = 1%Z).
   rewrite
    (qnew_a_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
       H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_b_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_c_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_d_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1); assumption.
   rewrite
    (Qquadratic_Qpositive_to_Q_5 _ _ _ _ _ _ _ _ _ _
       H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
       (trans_eq
          (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
             H_Qquadratic_sg_denom_nonzero1) l1_eq_one) H
       (Qquadratic_Qpositive_to_Q_quadraticAcc_pos_1 _ _ _ _ _ _ _ _ _ _
          H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
          (trans_eq
             (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
                H_Qquadratic_sg_denom_nonzero1) l1_eq_one) H))
    ; apply f_equal with Qpositive;
    apply Qquadratic_Qpositive_to_Qpositive_equal_strong;
    [ apply qnew_a_equal
    | apply qnew_b_equal
    | apply qnew_c_equal
    | apply qnew_d_equal
    | apply qnew_e_equal
    | apply qnew_f_equal
    | apply qnew_g_equal
    | apply qnew_h_equal
    | apply qnew_p1_equal
    | apply qnew_p2_equal ].
 (* 8 *)
 assert
  (H :
   Z.sgn
     (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2) =
   (-1)%Z).
   rewrite
    (qnew_a_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
       H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_b_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_c_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_d_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1); assumption.
   rewrite
    (Qquadratic_Qpositive_to_Q_6 _ _ _ _ _ _ _ _ _ _
       H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
       (trans_eq
          (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
             H_Qquadratic_sg_denom_nonzero1) l1_eq_one) H
       (Qquadratic_Qpositive_to_Q_quadraticAcc_pos_2 _ _ _ _ _ _ _ _ _ _
          H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
          (trans_eq
             (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
                H_Qquadratic_sg_denom_nonzero1) l1_eq_one) H))
    .
   apply f_equal with Qpositive;
    apply Qquadratic_Qpositive_to_Qpositive_equal_strong;
    try apply f_equal with Z;
    [ apply qnew_a_equal
    | apply qnew_b_equal
    | apply qnew_c_equal
    | apply qnew_d_equal
    | apply qnew_e_equal
    | apply qnew_f_equal
    | apply qnew_g_equal
    | apply qnew_h_equal
    | apply qnew_p1_equal
    | apply qnew_p2_equal ].
 (* 9 *)
 Absurd_q_sign_.
 (* 10 *)
 assert
  (H :
   Z.sgn
     (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2) = 1%Z).
   rewrite
    (qnew_a_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
       H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_b_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_c_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_d_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1); assumption.
   rewrite
    (Qquadratic_Qpositive_to_Q_7 _ _ _ _ _ _ _ _ _ _
       H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
       (trans_eq
          (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
             H_Qquadratic_sg_denom_nonzero1) l1_eq_min_one) H
       (Qquadratic_Qpositive_to_Q_quadraticAcc_neg_1 _ _ _ _ _ _ _ _ _ _
          H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
          (trans_eq
             (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
                H_Qquadratic_sg_denom_nonzero1) l1_eq_min_one) H))
    .
   apply f_equal with Qpositive;
    apply Qquadratic_Qpositive_to_Qpositive_equal_strong;
    try apply f_equal with Z;
    [ apply qnew_a_equal
    | apply qnew_b_equal
    | apply qnew_c_equal
    | apply qnew_d_equal
    | apply qnew_e_equal
    | apply qnew_f_equal
    | apply qnew_g_equal
    | apply qnew_h_equal
    | apply qnew_p1_equal
    | apply qnew_p2_equal ].
 (* 11 *)
 assert
  (H :
   Z.sgn
     (qnew_a a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_b a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_c a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2 +
      qnew_d a b c d e f g h p1 p2 H_Qquadratic_sg_denom_nonzero2) =
   (-1)%Z).
   rewrite
    (qnew_a_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
       H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_b_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_c_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1);
    rewrite
     (qnew_d_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
        H_Qquadratic_sg_denom_nonzero1); assumption.
   rewrite
    (Qquadratic_Qpositive_to_Q_8 _ _ _ _ _ _ _ _ _ _
       H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
       (trans_eq
          (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
             H_Qquadratic_sg_denom_nonzero1) l1_eq_min_one) H
       (Qquadratic_Qpositive_to_Q_quadraticAcc_neg_2 _ _ _ _ _ _ _ _ _ _
          H_Qquadratic_sg_denom_nonzero2 not_same_ratio_abcdefgh
          (trans_eq
             (q_sign_equal a b c d _ _ _ _ _ _ H_Qquadratic_sg_denom_nonzero2
                H_Qquadratic_sg_denom_nonzero1) l1_eq_min_one) H))
    .
   apply f_equal with Qpositive;
    apply Qquadratic_Qpositive_to_Qpositive_equal_strong;
    try apply f_equal with Z;
    [ apply qnew_a_equal
    | apply qnew_b_equal
    | apply qnew_c_equal
    | apply qnew_d_equal
    | apply qnew_e_equal
    | apply qnew_f_equal
    | apply qnew_g_equal
    | apply qnew_h_equal
    | apply qnew_p1_equal
    | apply qnew_p2_equal ].
Qed.


Require Import RGref.DSL.DSL.
Require Import TrieberStack.
Require Import ProducerConsumer.

(* The fact that the stack only escapes this scope as a consumer means that this
   code /will/ terminate: other could either do nothing, or pop some number of elements, but it can't make the stack any larger than three elements *)
Definition client {Δ} (other : consumer -> rgref Δ unit Δ) : rgref Δ unit Δ :=
  stack <- alloc_ts tt;
  _ <- push_ts stack 3;
  _ <- push_ts stack 4;
  _ <- push_ts stack 5;
  _ <- other (consumer_of_ts stack);
  RGFix _ _ (fun again _ =>
               opt <- pop_ts stack;
               match opt with
               | None => rgret tt
               | Some n => again tt
               end) tt.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * GuillouQuisquater.v : Guillou-Quisquater protocol *)

Require Import SigmaPhi.
Require Import FilterMap.
Require Import LtIrrelevance.
Require Import PrimeLib.

Set Implicit Arguments.

Module Type Z_nZ_PARAMETERS.

 Open Scope Z_scope.

 Parameters n : nat -> Z.

 Parameter n_pos : forall k, 1 < (n k).

 Parameter n_poly : polynomial.

 Parameter n_poly_spec : forall k, (size_Z (n k) < peval n_poly k)%nat.

End Z_nZ_PARAMETERS.

Module Z_nZ_PROPERTIES (P : Z_nZ_PARAMETERS).

  Import P.

  Lemma n_pos' : forall k, (1 < Zabs_nat (n k))%nat.
  Proof.
   intros.
   change 1%nat with (Zabs_nat 1%Z).
   apply Zabs_nat_lt.
   split;[ omega | ].
   apply n_pos.
  Qed.

End Z_nZ_PROPERTIES.

Module Z_nZ (P: Z_nZ_PARAMETERS) <: GROUP.

 Module P' := Z_nZ_PROPERTIES P.
 Import P.
 Import P'.

 Definition P k x : bool :=
  Zle_bool 0 x && negb (Zle_bool (n k) x) && Zeq_bool (Zgcd x (n k)) 1.

 Lemma eq_P : forall k x (H1:P k x) (H2:P k x), H1 = H2.
 Proof.
  intros.
  apply eq_proofs_unicity.
  intros a b; case (bool_dec a b); auto.
 Qed.

 Lemma P_prop : forall k x, P k x <->
  (0 <= x < n k) /\ rel_prime x (n k).
 Proof.
  unfold P; split; intros.

  apply andb_prop in H; destruct H.
  apply andb_prop in H; destruct H.
  split.
  split.

  apply Zle_bool_imp_le; trivial.
  generalize (Zle_cases (n k) x).
  apply -> is_true_negb_false in H1.
  rewrite H1.
  omega.

  apply Zeq_is_eq_bool in H0.
  apply Zgcd_1_rel_prime in H0.
  trivial.

  destruct H.
  apply andb_true_intro; split.
  apply andb_true_intro; split.
  apply Zle_imp_le_bool; omega.
  apply eq_true_not_negb.
  intro.
  apply Zle_bool_imp_le in H1.
  omega.

  apply -> Zeq_is_eq_bool.
  apply <- Zgcd_1_rel_prime.
  trivial.
 Qed.

 Definition t k := {x | P k x}.

 Definition elems k : list (t k) :=
  filter_map (P k) (@exist _ _) (map (fun x => Z_of_nat x)
   (seq 0 (Zabs_nat (n k)))).

 Lemma elems_not_nil : forall k, elems k <> nil.
 Proof.
  intro k; unfold elems.

  assert (Hn := n_pos k).
  assert (Hn' := n_pos' k).
  assert (P k 1).
  unfold P.
  apply andb_true_intro; split.
  apply andb_true_intro; split.
  trivial.
  apply fold_is_true.
  rewrite is_true_negb_false.
  apply not_true_is_false; intro.
  apply Zle_bool_imp_le in H.
  omega.

  apply -> Zeq_is_eq_bool.
  apply <- Zgcd_1_rel_prime.
  apply rel_prime_1.

  induction (Zabs_nat (n k));[ omega | ].

  assert (In 1 (map (fun x : nat => Z_of_nat x) (seq 0 (S n0)))).
  change 1 with (Z_of_nat (Zabs_nat 1)).
  apply in_map.
  apply le_In_seq.
  split; [ omega | ].
  apply le_trans with 2%nat; [ trivial | ].
  rewrite <- plus_n_O; trivial.

  intro Heq.
  apply In_filter_map with (A:=Z) (f:=@exist _ _) (H:=H) in H0.
  rewrite Heq in H0.
  inversion H0.
 Qed.

 Lemma elems_full : forall k (x:t k), In x (elems k).
 Proof.
  intros k (x,H).
  apply In_filter_map.
  replace x with (Z_of_nat (Zabs_nat x)).
  apply in_map.
  apply le_In_seq.
  apply andb_prop in H; destruct H.
  apply andb_prop in H; destruct H.
  apply Zle_bool_imp_le in H.
  split.
  change 0%nat with (Zabs_nat (Z_of_nat 0)).
  apply Zabs_nat_le; simpl; omega.
  simpl.
  rewrite <- plus_n_O.
  apply Zabs_nat_lt.
  apply is_true_negb_false in H1.
  generalize (Zle_cases (n k) x).
  rewrite H1; omega.

  apply P_prop in H.
  rewrite inj_Zabs_nat, Zabs_eq; trivial.
  omega.
 Qed.

 Lemma elems_nodup : forall k, NoDup (elems k).
 Proof.
  intro k; unfold elems.
  apply NoDup_filter_map_inj.
  intros x y ? ? H; inversion H; trivial.
  apply NoDup_map_inj.
  intros; apply inj_eq_rev; trivial.
  apply NoDup_seq.
 Qed.

 (** Equality is decidable *)
 Definition eqb k (x y:t k) :=
  match x, y with
   | exist n _, exist m _ => Zeq_bool n m
  end.

 Lemma eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.
 Proof.
  intros k (a,Ha) (b,Hb).
  unfold eqb.
  generalize (Zeq_bool_eq a b); generalize (Zeq_bool_neq a b).
  case (Zeq_bool a b); intros.
  assert (a = b) by (apply H0; trivial).
  subst; rewrite (eq_P _ _ Hb Ha); trivial.
  assert (a <> b) by (apply H; trivial).
  intro H2; elim H1; injection H2; trivial.
 Qed.

 (** Identity element *)
 Definition e k : t k.
 intro k.
 refine (exist _ 1 _).
 apply <- P_prop; split.
 split; [omega | apply n_pos].
 apply rel_prime_1.
 Defined.

 (** Operations: product, inverse *)

 Definition mul : forall k, t k -> t k -> t k.
  intros k (a,Ha) (b,Hb).
  assert (Hpos := n_pos k).
  refine (exist _ ( (a * b) mod n k) _)%Z.
  apply P_prop in Ha; destruct Ha as [[ Ha1 Ha2 ] Ha3 ].
  apply P_prop in Hb; destruct Hb as [[ Hb1 Hb2 ] Hb3 ].
  apply <- P_prop; split.
  apply Z_mod_lt.
  omega.
  apply rel_prime_mod.
  omega.
  apply rel_prime_sym.
  apply rel_prime_mult; apply rel_prime_sym; trivial.
 Defined.

 Definition inv : forall k, t k -> t k.
  intros k (a,Ha).
  assert (Hn := n_pos k).
  refine
   (exist (P k) ((fst (fst (eeuclid a (n k)))) mod (n k)) _).

  apply P_prop in Ha; destruct Ha as [[Hlt1 Hlt2] Hrel_prime].
  apply <- P_prop.

  destruct (eeuclid_bound a (n k) (Zabs (n k))) as [H2 H3].
  repeat rewrite Zabs_eq; omega.
  apply Zle_refl.

  assert (H1:=eeuclid_spec a (n k)).
  assert (Hgcd:Zis_gcd a (n k) 1).
  apply Zgcd_1_rel_prime in Hrel_prime.
  rewrite <- Hrel_prime.
  apply Zgcd_is_gcd.

  destruct (eeuclid a (n k)) as ((u, v), d); simpl in *.
  destruct (H1 u v d) as [H4 [H5 H6] ]; [ trivial | ]; clear H1.
  case (Zis_gcd_unique _ _ _ _ H5 Hgcd); intro; [ | rewrite H in H6; elim H6; trivial].
  subst.

  split.
  apply Z_mod_lt.
  omega.

  apply rel_prime_mod.
  omega.
  apply bezout_rel_prime.
  econstructor.
  instantiate (1:=v).
  instantiate (1:=a).
  rewrite Zmult_comm; trivial.
 Defined.

 (** Specification *)
 Lemma mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Proof.
  intros k (a,Ha) (b,Hb) (c,Hc); unfold mul.
  match goal with
   |- exist _ ?a ?Ha = exist _ ?b ?Hb =>
    generalize Ha Hb; assert (H:a = b)
  end.
  rewrite Zmult_mod_idemp_l, Zmult_mod_idemp_r.
  rewrite Zmult_assoc; trivial.
  rewrite H; intros p1 p2; rewrite (eq_P _ _ p1 p2); trivial.
 Qed.

 Lemma mul_e_l : forall k (x:t k), mul (e k) x = x.
 Proof.
  intros k (a,Ha); unfold mul, e.
  match goal with
   |- exist _ ?a ?Ha = exist _ ?b ?Hb =>
    generalize Hb Ha; assert (H:a = b)
  end.
  rewrite P_prop in Ha; destruct Ha as [[H1 H2] H3].
  rewrite Zmult_1_l, Zmod_small; trivial.
  omega.
  rewrite H; intros p1 p2; rewrite (eq_P _ _ p1 p2); trivial.
 Qed.

 Lemma mul_inv_l : forall k (x:t k), mul (inv x) x = e k.
 Proof.
  intros k (a,Ha); unfold mul, inv, e.
  match goal with
   |- exist _ ?a ?Ha = exist _ ?b ?Hb =>
    generalize Ha Hb; assert (H:a = b);
     [ | rewrite H; intros p1 p2; rewrite (eq_P _ _ p1 p2); trivial]
  end.

  apply P_prop in Ha; destruct Ha as [[Hlt1 Hlt2] Hrp].
  destruct (eeuclid_bound a (n k) (Zabs (n k))) as [H2 H3].
  repeat rewrite Zabs_eq; omega.
  apply Zle_refl.

  assert (H1:=eeuclid_spec a (n k)).
  assert (Hp:=n_pos k).

  assert (Hgcd:Zis_gcd a (n k) 1).
  apply  Zgcd_1_rel_prime in Hrp.
  rewrite <- Hrp.
  apply Zgcd_is_gcd.

  destruct (eeuclid a (n k)) as ((u, v), d); simpl in *.
  destruct (H1 u v d) as [H4 [H5 H6] ]; [ trivial | ]; clear H1.
  case (Zis_gcd_unique _ _ _ _ H5 Hgcd); intro; [ | rewrite H in H6; elim H6; trivial].
  clear H5 H6 Hgcd; subst.

  rewrite <- Zmod_1_l with (n k); [ | auto with zarith].

  rewrite <- H, Z_mod_plus_full; trivial.
  rewrite Zmult_mod_idemp_l; trivial.
 Qed.

 Lemma mul_comm : forall k (x y:t k), mul x y = mul y x.
 Proof.
  intros k (a,Ha) (b,Hb); unfold mul.
  match goal with
   |- exist _ ?a ?Ha = exist _ ?b ?Hb =>
    generalize Ha Hb; assert (H:a = b)
  end.
  rewrite Zmult_comm; trivial.
  rewrite H; intros p1 p2; rewrite (eq_P _ _ p1 p2); trivial.
 Qed.

 (* Power *)
 Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
  match n with
  | O => e k
  | S n => mul x (pow x n)
  end.

 Fixpoint powZ (k:nat) (x:t k) (n:Z) {struct n}: t k :=
  match n with
  | Z0 => pow x 0
  | Zpos p => pow x (nat_of_P p)
  | Zneg p => inv (pow x (nat_of_P p))
  end.

 (* Cost *)
 Open Scope nat_scope.

 Definition order_poly : polynomial := n_poly.

 Lemma order_size_nat : forall k,
  size_nat (length (elems k)) < peval order_poly k.
 Proof.
  intro k.
  apply le_lt_trans with (2:=n_poly_spec k).
  apply size_nat_monotonic.
  eapply le_trans; [apply filter_map_length | ].
  rewrite map_length, seq_length; apply le_refl.
 Qed.

 Definition cost_mul k (x y:t k) : nat := size_Z (proj1_sig y).

 Definition cost_pow k (x:t k) (m:Z) : nat :=
  size_Z (proj1_sig x) * (size_Z (n k)).

 Definition cost_inv k (x:t k) : nat := size_Z (proj1_sig x) * size_Z (n k).

 Definition cost_mul_poly : polynomial := n_poly.
 Definition cost_pow_poly : polynomial := pmult n_poly n_poly.
 Definition cost_inv_poly : polynomial := pmult n_poly n_poly.

 Lemma cost_mul_poly_spec : forall k (x y:t k),
  cost_mul x y <= peval cost_mul_poly k.
 Proof.
  intros k x (b,Hb).
  unfold cost_mul; simpl.
  apply P_prop in Hb; decompose [and] Hb; clear Hb.
  apply le_trans with (size_Z (n k)).
  apply size_nat_monotonic; apply lt_le_weak; trivial.
  apply Zabs_nat_lt; omega.
  apply lt_le_weak; apply n_poly_spec.
 Qed.

 Lemma cost_pow_poly_spec : forall k (x:t k) (m:Z),
  cost_pow x m <= peval cost_pow_poly k.
 Proof.
  intros k (a,Ha) m.
  unfold cost_pow, cost_pow_poly; simpl.
  rewrite pmult_spec.
  apply P_prop in Ha; decompose [and] Ha; clear Ha.
  apply mult_le_compat.
  apply le_trans with (size_Z (n k)).
  apply size_nat_monotonic; apply lt_le_weak; trivial.
  apply Zabs_nat_lt; omega.
  apply lt_le_weak; apply n_poly_spec.
  apply lt_le_weak; apply n_poly_spec.
 Qed.

 Lemma cost_inv_poly_spec : forall k (x:t k),
  cost_inv x <= peval cost_inv_poly k.
 Proof.
  intros k (a,Ha).
  unfold cost_inv, cost_inv_poly; simpl.
  rewrite pmult_spec.
  apply P_prop in Ha; decompose [and] Ha; clear Ha.
  apply mult_le_compat.
  apply le_trans with (size_Z (n k)).
  apply size_nat_monotonic; apply lt_le_weak; trivial.
  apply Zabs_nat_lt; omega.
  apply lt_le_weak; apply n_poly_spec.
  apply lt_le_weak; apply n_poly_spec.
 Qed.

End Z_nZ.

Module Type GUILLOU_QUISQUATER_PARAMETERS (ZnP : Z_nZ_PARAMETERS).

 Import ZnP.

 Open Scope Z_scope.

 Parameters p q e : nat -> Z.

 Parameter p_prime : forall k, prime (p k).

 Parameter q_prime : forall k, prime (q k).

 Parameter pq_distinct : forall k, (p k) <> (q k).

 Parameter rsa_modulus : forall k,  (n k) = (p k) * (q k).

 Parameter rsa_exponent : forall k, rel_prime (e k) ((p k - 1) * (q k - 1)).

 Parameter e_poly : polynomial.

 Parameter e_poly_spec : forall k, (size_Z (e k) < peval e_poly k)%nat.

End GUILLOU_QUISQUATER_PARAMETERS.

Module Guillou_Quisquater_Parameters_Properties
 (ZnP:Z_nZ_PARAMETERS) (SP:GUILLOU_QUISQUATER_PARAMETERS ZnP).

 Import SP.
 Import ZnP.

 Lemma n_pos : forall k, (0 < Zabs_nat (n k))%nat.
 Proof.
  intro k.
  assert (Hp:=n_pos k).
  change 0%nat with (Zabs_nat 0).
  apply Zabs_nat_lt.
  omega.
 Qed.

End Guillou_Quisquater_Parameters_Properties.

Module Guillou_Quisquater_Homomorphism
 (ZnP:Z_nZ_PARAMETERS) (GQP:GUILLOU_QUISQUATER_PARAMETERS ZnP).

 Import GQP.

 Module G := (Z_nZ ZnP).
 Module H := G.

 Module HP := Group_Properties H.
 Import HP.

 Module GQPP :=  Guillou_Quisquater_Parameters_Properties ZnP GQP.
 Import GQPP.

 Open Scope nat_scope.

 Definition phi k (x:G.t k) : (H.t k) := H.powZ x (GQP.e k).

 Definition cost_phi k (x:G.t k) :=
   (G.cost_pow x (GQP.e k) * (size_Z (GQP.e k)))%nat.

 Definition cost_phi_poly : polynomial := pmult G.cost_pow_poly e_poly.

 Lemma cost_phi_poly_spec : forall k (x:G.t k),
  @cost_phi k x <= peval cost_phi_poly k.
 Proof.
  intros k (a,b); unfold cost_phi, cost_phi_poly; simpl.
  rewrite pmult_spec.
  apply mult_le_compat.
  apply G.cost_pow_poly_spec.
  apply lt_le_weak.
  apply e_poly_spec.
 Qed.

 Lemma phi_homo : forall k (x y:G.t k),
  phi (G.mul x y) = H.mul (phi x) (phi y).
 Proof.
  intros k x y; unfold phi; simpl.
  rewrite HP.powZ_mul_distr.
  trivial.
 Qed.

 (* [phi] is a special homomorphism *)
 Definition special_v k := (e k).

 Lemma special_v_spec : forall k, special_v k <> 0%Z.
 Proof.
  intro k; unfold special_v.
  intro Heq.
  generalize (rsa_exponent k).
  intros.
  rewrite Heq in H.
  generalize (not_rel_prime_0 ((p k - 1) * (q k - 1))).
  intros.
  destruct H0;[ | trivial].
  assert (Hq :=prime_ge_2 _ (q_prime k)).
  assert (Hp :=prime_ge_2 _ (p_prime k)).
  assert (Hpq := @pq_distinct k).
  apply Zle_lt_trans with ((1 * 1)%Z);[ omega | ].
  destruct (Z_dec (p k) (q k)).
  destruct s.
  apply Zmult_lt_compat2; split; omega.
  rewrite (Zmult_comm (p k - 1) (q k - 1)).
  apply Zmult_lt_compat2; split; omega.
  elimtype False; omega.
 Qed.

 Definition special_v_poly : polynomial := e_poly.

 Lemma size_nat_special_v : forall k,
  size_nat (Zabs_nat (special_v k)) <= peval special_v_poly k.
 Proof.
  intro k; unfold special_v.
  apply lt_le_weak.
  apply e_poly_spec.
 Qed.

 Definition cost_special_v (k:nat) := 1.

 Definition cost_special_v_poly : polynomial := 1.

 Lemma cost_special_v_poly_spec : forall k,
  cost_special_v k <= peval cost_special_v_poly k.
 Proof.
  intro k; unfold cost_special_v_poly; rewrite pcst_spec; trivial.
 Qed.

 Definition special_u k (x:H.t k) : G.t k := x.

 Definition cost_special_u k (x:H.t k) := 1.

 Definition cost_special_u_poly : polynomial := 1.

 Lemma cost_special_u_poly_spec : forall k (x:H.t k),
  cost_special_u x <= peval cost_special_u_poly k.
 Proof.
  intro k; unfold cost_special_u_poly; rewrite pcst_spec; trivial.
 Qed.

 Lemma phi_special : forall k (y:H.t k),
  phi (special_u y) = H.powZ y (special_v k).
 Proof.
  intros; simpl; unfold special_v, special_u, phi.
  trivial.
 Qed.

End Guillou_Quisquater_Homomorphism.

(** Instantiation *)
Declare Module ZnP : Z_nZ_PARAMETERS.
Declare Module GQP : GUILLOU_QUISQUATER_PARAMETERS ZnP.

Module HM := Guillou_Quisquater_Homomorphism ZnP GQP.
Module CS := Largest_Challenge_Set HM.G HM.H HM.

Module S := SigmaPhi.SigmaPhi HM.G HM.H HM CS.