From Coq Require Import Bool Reals List ListSet Classes.RelationClasses.

From CasperCBC Require Import Lib.Preamble Lib.ListExtras Lib.ListSetExtras Lib.Measurable.
From CasperCBC Require Import VLSM.Common VLSM.Composition VLSM.Equivocation VLSM.ObservableEquivocation.

(** * VLSM Preceeds Equivocation *)

(** ** Message-based equivocation

This definition relates a set of <<validator>>s and one of <<messages>>,
where messages are mapped to validators through the [sender] function,
and there is a function [message_preceeds_fn] which can decide whether
two messages having the same sender were seen one before another.

This allows to define that a message is [equivocating_with] another
if they have the same [sender] and are not comparable through
the [message_preceeds_fn].

Then, we can say that a message is [equivocating_in_set]
if it is [equivocating_with] any of the messages in that set.

_Note_: Ideally [message_preceeds_fn] should determine a strict partial order;
however this might not happen for the whole set of messages, but only
for a restricted set, e.g., [protocol_messsage]s
(please see class [HasPreceedsEquivocation] for more details).
*)

Class message_equivocation_evidence
  (message validator : Type)
  `{EqDecision message}
  `{EqDecision validator}
  (message_preceeds : message -> message -> Prop)
  {message_preceeds_dec : RelDecision message_preceeds}
  :=
  { sender : message -> option validator
  ; equivocating_with (msg1 msg2 : message)  : Prop
    := (exists v, sender msg1 = Some v /\ sender msg2 = Some v) /\
    ~comparable message_preceeds msg1 msg2
  ; equivocating_in_set
      (msg : message)
      (msgs : set message)
      :=
      exists m, In m msgs /\ equivocating_with msg m
  }.

Instance equivocating_with_dec `{message_equivocation_evidence}:
  RelDecision equivocating_with.
Proof with (try (right; intros [v1 [Hv Hv0]]; congruence)).
  intros msg1 msg2.
  unfold equivocating_with.
  apply Decision_and.
  - destruct (sender msg1) eqn:Hmsg1 ...
    destruct (sender msg2) eqn:Hmsg2 ...
    destruct (decide (v = v0)) ...
    subst. left. exists v0. intuition.
  - apply Decision_not.
    typeclasses eauto.
Qed.

Instance equivocating_in_set_dec `{message_equivocation_evidence} :
  Decision (equivocating_in_set msg msgs).
Proof.
  intros msg msgs.
  apply (Decision_iff (Exists_exists _ _)).
  apply @Exists_dec.
  typeclasses eauto.
Qed.

(**
First, let us fix events to be messages, and choose the [happens_before] relation
to be the [message_preceeds] relation.
*)

(** ** Equivocation for states encapsulating messages

The definition below assumes that one can [get_messages] associated to
states, and these messages are equipped with [message_equivocation_evidence].

For the purpose of the definition, what are the messages associated to the
state can remain an abstract notion; however, one could imagine these messages
as being those the state has memory of (sent, received, or otherwise observed).

We can use this to instantiate [basic_equivocation], by saying that a
validator is equivocating in a state iff there exists at least one message
in that state with it as a sender which is [equivocating_in_set] for
the messages of the state.
*)
Class state_encapsulating_messages
  (state message : Type)
  :=
  { get_messages : state -> set message }.

Definition state_encapsulating_messages_is_equivocating
  {state validator : Type}
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  (s : state)
  (v : validator)
  : Prop
  :=
  exists (msg : message),
    In msg (get_messages s) /\
    sender msg = Some v /\
    equivocating_in_set msg (get_messages s).

Lemma state_encapsulating_messages_is_equivocating_dec
  {state validator : Type}
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  : RelDecision state_encapsulating_messages_is_equivocating.
Proof.
  intros s v.
  unfold state_encapsulating_messages_is_equivocating.
  apply (Decision_iff (Exists_exists _ _)).
  apply @Exists_dec.
  intro m.
  apply Decision_and; [apply option_eq_dec|].
  unfold equivocating_in_set.
  apply (Decision_iff (Exists_exists _ _)).
  apply @Exists_dec.
  intro m'.
  apply equivocating_with_dec.
Qed.

Definition state_encapsulating_messages_validators
  {state message validator : Type}
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  (s : state)
  : set validator
  := nodup decide_eq (map_option sender (get_messages s)).

Lemma state_encapsulating_messages_validators_nodup
  {state message validator : Type}
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  (s : state)
  : NoDup (state_encapsulating_messages_validators s).
Proof.
  apply NoDup_nodup.
Qed.

Definition state_encapsulating_messages_equivocation
  (state message validator : Type)
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  {measurable_V : Measurable validator}
  {reachable_threshold : ReachableThreshold validator}
  : basic_equivocation state validator
  :=
  {|  state_validators := state_encapsulating_messages_validators
   ;  state_validators_nodup := state_encapsulating_messages_validators_nodup
   ;  is_equivocating := state_encapsulating_messages_is_equivocating
   ;  is_equivocating_dec := state_encapsulating_messages_is_equivocating_dec
  |}.

Section equivocation_properties.

Lemma equivocating_in_set_incl
  {message validator : Type}
  `{Heqv : message_equivocation_evidence message validator}
  (sigma sigma' : set message)
  (Hincl : incl sigma sigma')
  (msg : message)
  (Hmsg : equivocating_in_set msg sigma)
  : equivocating_in_set msg sigma'.
Proof. firstorder. Qed.

Context
  (state message validator : Type)
  `{Hstate : state_encapsulating_messages state message}
  `{Hmessage : message_equivocation_evidence message validator}
  {measurable_V : Measurable validator}
  {reachable_threshold : ReachableThreshold validator}
  (Hbasic := state_encapsulating_messages_equivocation state message validator)
  .

Existing Instance Hbasic.

Lemma state_validators_incl
  (sigma sigma' : state)
  (Hincl : incl (get_messages sigma) (get_messages sigma'))
  : incl (state_validators sigma) (state_validators sigma').
Proof.
  simpl. unfold incl. unfold state_encapsulating_messages_validators.
  intro v. repeat rewrite nodup_In. apply map_option_incl.
  assumption.
Qed.

Lemma equivocating_validators_incl
  (sigma sigma' : state)
  (Hincl : incl (get_messages sigma) (get_messages sigma'))
  : incl (equivocating_validators sigma) (equivocating_validators sigma').
Proof.
  unfold equivocating_validators.
  intro v. rewrite !filter_In.
  pose proof (state_validators_incl _ _ Hincl).
  rewrite !bool_decide_eq_true.
  firstorder.
Qed.

Lemma equivocation_fault_incl
  (sigma sigma' : state)
  (Hincl : incl (get_messages sigma) (get_messages sigma'))
  : (equivocation_fault sigma <= equivocation_fault sigma')%R.
Proof.
  intros.
  apply sum_weights_incl
  ; [solve[apply NoDup_filter; apply state_validators_nodup]..|].
  apply equivocating_validators_incl. assumption.
Qed.

(* If a state is not overweight, none of its subsets are *)
Lemma not_heavy_incl
  (sigma sigma' : state)
  (Hincl : incl (get_messages sigma) (get_messages sigma'))
  (Hsigma' : not_heavy sigma')
  : not_heavy sigma.
Proof.
  apply Rle_trans with (equivocation_fault sigma'); try assumption.
  apply equivocation_fault_incl; assumption.
Qed.

Lemma empty_not_heavy
  (s : state)
  (Hempty : get_messages s = nil)
  : not_heavy s.
Proof.
  unfold not_heavy. unfold equivocation_fault. unfold equivocating_validators.
  simpl. unfold state_encapsulating_messages_validators. rewrite Hempty. simpl.
  destruct threshold;simpl.
  apply Rge_le;assumption.
Qed.

End equivocation_properties.

(** ** VLSM equivocation based-on full-node-like  [message_equivocation_evidence]

Given a [VLSM] X over a type of messages which [message_equivocation_evidence], we say
that @X@ has [vlsm_message_equivocation_evidence] if [message_preceeds_fn]
determines a [StrictOrder] on the [protocol_message]s of @X@.
*)

Section vlsm_message_equivocation_evidence.

  Context
    {message : Type}
    (validator : Type)
    `{Eqv : message_equivocation_evidence message validator}
    (X : VLSM message).

  Class vlsm_message_equivocation_evidence
    :=
    { protocol_message_preceeds
        (pm1 pm2 : byzantine_message X)
        : Prop
        := message_preceeds (proj1_sig pm1) (proj1_sig pm2)
    ; protocol_message_preceeds_strict_order
      : StrictOrder protocol_message_preceeds
    ; evidence_of_equivocation
        (pm1 pm2 : byzantine_message X)
        (m1 := proj1_sig pm1)
        (m2 := proj1_sig pm2)
        (Heqv : equivocating_with m1 m2 = true)
        (s : state)
        (tr : list transition_item)
        (Htr : finite_protocol_trace (pre_loaded_with_all_messages_vlsm X) s tr)
        (Hm1 : trace_has_message (field_selector input) m1 tr)
        (Hm2 : trace_has_message (field_selector input) m2 tr)
        : equivocation_in_trace X m1 tr
        \/ equivocation_in_trace X m2 tr
    }.

End vlsm_message_equivocation_evidence.

Section composite_preceeds_equivocation.

  Context
    {message validator : Type}
    `{Eqv : message_equivocation_evidence message validator}
    `{EqDecision index}
    (IM : index -> VLSM message)
    {i0 : Inhabited index}
    (constraint1 : composite_label IM -> composite_state IM * option message -> Prop)
    (constraint2 : composite_label IM -> composite_state IM * option message -> Prop)
    (Hsubsumption : constraint_subsumption IM constraint1 constraint2)
    (X1 := composite_vlsm IM constraint1)
    (X2 := composite_vlsm IM constraint2)
    .

  Lemma preceeds_equivocation_constrained
    (Heqv : vlsm_message_equivocation_evidence validator X2)
    : vlsm_message_equivocation_evidence validator X1.
  Proof.
    destruct Heqv as
      [ protocol_message_preceeds2
        [ protocol_message_preceeds2_irreflexive
          protocol_message_preceeds2_transitive
        ]
        Heqv
      ].
    specialize
      (constraint_subsumption_byzantine_message_prop
        IM constraint1 constraint2 Hsubsumption
      ); intro Hem.
    repeat split.
    - intros [m1 Hem1].
      unfold complement. simpl.
      apply Hem in Hem1.
      specialize (protocol_message_preceeds2_irreflexive (exist _ m1 Hem1)).
      unfold complement in protocol_message_preceeds2_irreflexive.
      assumption.
    - intros [m1 Hem1] [m2 Hem2] [m3 Hem3]
      ; simpl.
      intros H12 H23.
      apply Hem in Hem1.
      apply Hem in Hem2.
      apply Hem in Hem3.
      specialize
        (protocol_message_preceeds2_transitive
          (exist _ m1 Hem1)
          (exist _ m2 Hem2)
          (exist _ m3 Hem3)
          H12
          H23
        ).
      assumption.
    - intros [m1 Hm1] [m2 Hm2]. simpl. intros.
      assert (Hm1': byzantine_message_prop X2 m1)
        by (apply constraint_subsumption_byzantine_message_prop with constraint1; assumption).
      assert (Hm2': byzantine_message_prop X2 m2)
        by (apply constraint_subsumption_byzantine_message_prop with constraint1; assumption).
      specialize (constraint_subsumption_pre_loaded_with_all_messages_incl IM constraint1 constraint2 Hsubsumption (@Finite _ (type X1) s tr) Htr)
        as Htrace'.
      simpl in Htrace'.
      specialize (Heqv (exist _ _ Hm1') (exist _ _ Hm2')). simpl in Heqv.
      specialize (Heqv Heqv0 s tr Htrace' Hm0 Hm3).
      assumption.
  Qed.

End composite_preceeds_equivocation.

Section message_observable_equivocation_equivalent_defnitions.

(** ** Deriving observable equivocation evidence from message-based equivocation evidence

In this section we show that given the [basic_equivocation] instance
obtained through [state_encapsulating_messages_equivocation], we can turn
it into a [basic_observable_equivocation].

*)

Context
  (state message validator : Type)
  `{Hmsgeqv : message_equivocation_evidence message validator}
  {Hstate : state_encapsulating_messages state message}
  {measurable_V : Measurable validator}
  {reachable_threshold : ReachableThreshold validator}
  (message_based_equivocation := state_encapsulating_messages_equivocation state message validator)
  .

(**
If we have a [state_encapsulating_messages], then we can use the [sender]
function to select ones having a given validator and obtain the
corresponding [observable_events].
*)

Definition has_been_observed_messages
  (s : state)
  (m : message)
  :=
  In m (get_messages s).

Lemma has_been_observed_messages_dec
  : RelDecision has_been_observed_messages.
Proof.
  intros s m.
  apply in_dec. assumption.
Qed.

Instance observable_messages
  : observable_events state message
  :=
  {| has_been_observed := has_been_observed_messages;
     has_been_observed_dec := has_been_observed_messages_dec
  |}.

Definition message_observation_based_equivocation_evidence
  : @observation_based_equivocation_evidence state validator message _ _ _ message_preceeds_dec sender.
Proof. split. Defined.

Local Instance message_observation_based_equivocation_evidence_dec
  : RelDecision (@equivocation_evidence _ _ _ _ _ _ _ _ message_observation_based_equivocation_evidence).
Proof.
  intros s v.
  unfold equivocation_evidence.
  unfold has_been_observed. simpl. unfold has_been_observed_messages.
  apply (Decision_iff (Exists_exists _ _)).
  apply @Exists_dec.
  intro m1.
  apply Decision_and; [apply option_eq_dec|].
  apply (Decision_iff (Exists_exists _ _)).
  apply @Exists_dec.
  intro m2.
  apply Decision_and; [apply option_eq_dec|].
  apply Decision_not.
  apply comparable_dec.
  assumption.
Qed.

(**
Further, we can get all validators for a state by projecting the messages
on [sender] and thus obtain a [basic_equivocation] instance through the
[basic_observable_equivocation] definition.
*)

Definition message_basic_observable_equivocation
  (Hevidence := message_observation_based_equivocation_evidence)
  : basic_equivocation state validator
  := @basic_observable_equivocation state validator message _ _ _ _ sender Hevidence _ _ _ state_encapsulating_messages_validators state_encapsulating_messages_validators_nodup.

(**
We can now show that the [message_based_equivocation] (customly built for
messages) and the [message_basic_observable_equivocation] (derived from it
as an instance of event-based equivocation) yield the same
[is_equivocating_fn].
*)

Lemma message_basic_observable_equivocation_iff
  (s : state)
  (v : validator)
  : @is_equivocating _ _ _ _ message_basic_observable_equivocation s v
  <-> @is_equivocating _ _ _ _ message_based_equivocation s v.
Proof.
  unfold is_equivocating. simpl. unfold equivocation_evidence.
  unfold state_encapsulating_messages_is_equivocating.
  unfold has_been_observed. simpl. unfold has_been_observed_messages.
  unfold equivocating_in_set. unfold equivocating_with.
  firstorder.
  exists x. split; [assumption|].  split; [assumption|].
  exists x0.  split; [assumption|].  split; [congruence|].
  firstorder.
Qed.

End message_observable_equivocation_equivalent_defnitions.


Require Import List.

Require Import String.
Require Import Strings.String.
Require Import Strings.Ascii.
Open Scope string_scope.

Require Import utils.
Require Import fol.

Definition TPTPTheory := list string.
Definition TPTPTerm := string.
Definition TPTPFormula := string.
Definition TPTPSystem := list string.
Definition TPTPQuery := list string.

Module TPTPSemantics.

Fixpoint termSemantics (t: folTerm): TPTPTerm := match t with
| fromVar v => v
| folIndRef i => i
| folFunctionApp f args => match args with
  | nil => f  (* prevent empty parentheses like `f()` *)
  | _ => f ++ "(" ++ (concat ", " (map termSemantics args)) ++ ")"
end
end.

Fixpoint formulaSemantics (f: folFormula): TPTPFormula := match f with
| folForall v f => "![" ++ v ++ "] : (" ++ (formulaSemantics f) ++ ")"
| folExists v f => "?[" ++ v ++ "] : (" ++ (formulaSemantics f) ++ ")"
| folBiimpl f g => "(" ++ (formulaSemantics f) ++ ") <=> (" ++ (formulaSemantics g) ++ ")"
| folImpl   f g => "(" ++ (formulaSemantics f) ++ ") => (" ++ (formulaSemantics g) ++ ")"
| folDisjunction f g => "(" ++ (formulaSemantics f) ++ ") | (" ++ (formulaSemantics g) ++ ")"
| folConjunction f g =>  "(" ++ (formulaSemantics f) ++ ") & (" ++ (formulaSemantics g) ++ ")"
| folEq s t => "(" ++ (termSemantics s) ++ ") = (" ++ (termSemantics t) ++ ")"

(* crappy code: manual uncurrying to nesting level 2

   because we cannot easily recurse on the result of an uncurrying helper function *)
| folApp f g => match f with
  | folApp h j => (formulaSemantics h) ++ "(" ++ (concat ", " (map termSemantics (j :: g :: nil))) ++ ")"
  | _ => (formulaSemantics f) ++ "(" ++ (termSemantics g) ++ ")"
  end
| folPredicateRef p => p
| folLam _ => "folLam to TPTP unsupported! Eliminate folLam first by running normalizeSystemFull."
end.

Fixpoint folTheorySemantics (folThy: folTheory): TPTPTheory:= mapWithIndex
  (fun idx => fun f => "fof(" ++ (nat_to_string idx) ++ ", axiom, " ++ (formulaSemantics f) ++ ").") folThy.

End TPTPSemantics.

(* 3. Overall Semantics *)
Definition folToTPTP (folOntology: folSystem): TPTPSystem := match folOntology with
| (folSig, folTheory) => TPTPSemantics.folTheorySemantics folTheory
end.

Definition folQueryToTPTP (query: folQuery): TPTPQuery := match query with
| (system, formula) =>
    let tptpFormula := "fof(query, conjecture, " ++ (TPTPSemantics.formulaSemantics formula) ++ ")." in
    app (folToTPTP system) (cons newline (cons tptpFormula nil))
end.

Definition tptpSystemToString := concat newline.
Definition tptpQueryToString := concat newline.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

(* Why3 assumption *)
Inductive tree :=
  | Leaf : tree
  | Node : tree -> tree -> tree.
Axiom tree_WhyType : WhyType tree.
Existing Instance tree_WhyType.

(* Why3 assumption *)
Fixpoint depths (d:Z) (t:tree) {struct t}: (list Z) :=
  match t with
  | Leaf => (Init.Datatypes.cons d Init.Datatypes.nil)
  | (Node l r) => (Init.Datatypes.app (depths (d + 1%Z)%Z
      l) (depths (d + 1%Z)%Z r))
  end.

Axiom depths_head : forall (t:tree) (d:Z), match (depths d
  t) with
  | (Init.Datatypes.cons x _) => (d <= x)%Z
  | Init.Datatypes.nil => False
  end.

Axiom depths_unique : forall (t1:tree) (t2:tree) (d:Z) (s1:(list Z))
  (s2:(list Z)), ((Init.Datatypes.app (depths d
  t1) s1) = (Init.Datatypes.app (depths d t2) s2)) -> ((t1 = t2) /\
  (s1 = s2)).

Axiom depths_prefix : forall (t:tree) (d1:Z) (d2:Z) (s1:(list Z))
  (s2:(list Z)), ((Init.Datatypes.app (depths d1
  t) s1) = (Init.Datatypes.app (depths d2 t) s2)) -> (d1 = d2).

Axiom depths_prefix_simple : forall (t:tree) (d1:Z) (d2:Z), ((depths d1
  t) = (depths d2 t)) -> (d1 = d2).

Axiom depths_subtree : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z)
  (s1:(list Z)), ((Init.Datatypes.app (depths d1 t1) s1) = (depths d2 t2)) ->
  (d2 <= d1)%Z.

Axiom depths_unique2 : forall (t1:tree) (t2:tree) (d1:Z) (d2:Z), ((depths d1
  t1) = (depths d2 t2)) -> ((d1 = d2) /\ (t1 = t2)).

(* Why3 assumption *)
Definition lex (x1:((list Z)* Z)%type) (x2:((list Z)* Z)%type): Prop :=
  match x1 with
  | (s1, d1) =>
      match x2 with
      | (s2, d2) => ((list.Length.length s1) < (list.Length.length s2))%Z \/
          (((list.Length.length s1) = (list.Length.length s2)) /\ match (s1,
          s2) with
          | ((Init.Datatypes.cons h1 _), (Init.Datatypes.cons h2 _)) =>
              (d2 < d1)%Z /\ ((d1 <= h1)%Z /\ (h1 = h2))
          | _ => False
          end)
      end
  end.

(* Why3 goal *)
Theorem WP_parameter_build : forall (s:(list Z)), forall (result:tree)
  (result1:(list Z)), (s = (Init.Datatypes.app (depths 0%Z
  result) result1)) -> ((exists w:Z, (exists w1:(list Z),
  (result1 = (Init.Datatypes.cons w w1)))) -> forall (t:tree), ~ ((depths 0%Z
  t) = s)).
intros s result result1 h1 (w,(w1,h2)) t.
subst.
intuition.
replace (depths 0 t) with (app (depths 0 t) nil) in H.
generalize (depths_unique _ _ _ _ _ H).
intuition.
discriminate H2.
apply Append.Append_l_nil.
Qed.


Require SynthExamples.Add SynthExamples.Stack SynthExamples.Sorter.

(** Produces an adder for numbers of size [2^n]  *)
Definition adder n := (Compiler.Fesic _ _  (Add.generator n)).

(** Produces a sorter core for [2^n] numbers. *)
Definition sorter n := (Compiler.Fesic _ _  (Sorter.generator 4 n)).

(** Produces the stack machine core. Parameters must be set in the corresponding Coq file. *)
Definition stack := Stack.t.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (IHx:@eq natural (plus (mult x y) x) (mult x (Succ y))):@eq natural (Succ (plus (plus (mult x y) y) x))
  (plus (mult x (Succ y)) (Succ y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_succ_78_plus_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y.
QuickChick collect_data.
Success.


Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical.
Require Import RndHoare.sigma_algebra.
Require Import RndHoare.measurable_function.
Require Import RndHoare.regular_conditional_prob.
Require Import RndHoare.random_oracle.
Require Import RndHoare.random_variable.

Section Predicates.

Context {ora: RandomOracle} {SFo: SigmaAlgebraFamily RandomHistory} {HBSFo: HistoryBasedSigF ora}.

Fixpoint _SigmaAlgebras (As: list Type): Type :=
  match As with
  | nil => unit
  | cons A As0 => (SigmaAlgebra A * _SigmaAlgebras As0)%type
  end.

Class SigmaAlgebras (As: list Type): Type := sigma_algebras: _SigmaAlgebras As.

Instance nil_SigmaAlgebras: SigmaAlgebras nil := tt.

Instance cons_SigmaAlgebras (A: Type) (As0: list Type) {sA: SigmaAlgebra A} {sAs: SigmaAlgebras As0}: SigmaAlgebras (cons A As0) := (sA, @sigma_algebras _ sAs).

Global Existing Instances nil_SigmaAlgebras cons_SigmaAlgebras.

Definition head_SigmaAlgebra (A: Type) (As0: list Type) {sAs: SigmaAlgebras (cons A As0)}: SigmaAlgebra A := fst sigma_algebras.

Definition tail_SigmaAlgebra (A: Type) (As0: list Type) {sAs: SigmaAlgebras (cons A As0)}: SigmaAlgebras As0 := snd sigma_algebras.

Definition _RandomPred (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, Type :=
  fix RandomPred (As: list Type): SigmaAlgebras As -> Type :=
    match As as As_PAT return SigmaAlgebras As_PAT -> Type with
    | nil => fun _ => Prop
    | cons A As0 => fun sAs => @RandomVariable _ _ _ Omega A (head_SigmaAlgebra A As0) -> RandomPred As0 (tail_SigmaAlgebra A As0)
    end.

Definition _RandomPred_consi (Omega1 Omega2: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, _RandomPred Omega1 As -> _RandomPred Omega2 As -> Prop :=
  fix RandomPred_consi (As: list Type): forall (sAs: SigmaAlgebras As), @_RandomPred Omega1 As sAs -> @_RandomPred Omega2 As sAs -> Prop :=
    match As as As_PAT return forall (sAs_PAT: SigmaAlgebras As_PAT), @_RandomPred Omega1 As_PAT sAs_PAT -> @_RandomPred Omega2 As_PAT sAs_PAT -> Prop
    with
    | nil => fun _ P1 P2 => P1 <-> P2
    | cons A As0 => fun sAs P1 P2 => forall a1 a2, (forall h, Omega1 h -> Omega2 h -> RandomVar_local_equiv a1 a2 h h) -> RandomPred_consi As0 (tail_SigmaAlgebra A As0) (P1 a1) (P2 a2)
    end.

Definition RandomPred (As: list Type) {sAs: SigmaAlgebras As}: Type := {P: forall (Omega: RandomVarDomain), _RandomPred Omega As | forall O1 O2, undistinguishable_sub_domain O1 O2 -> _RandomPred_consi O1 O2 As (P O1) (P O2)}.

Definition RandomPred_Func {As: list Type} {sAs: SigmaAlgebras As}: RandomPred As -> forall (Omega: RandomVarDomain), _RandomPred Omega As := @proj1_sig _ _.

Global Coercion RandomPred_Func: RandomPred >-> Funclass.

Definition _prop (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As} (P: Prop), _RandomPred Omega As :=
  fix prop (As: list Type): forall (sAs: SigmaAlgebras As) (P: Prop), _RandomPred Omega As :=
  match As as As_PAT return (forall (sAs: SigmaAlgebras As_PAT) (P: Prop), _RandomPred Omega As_PAT) with
  | nil => fun sAs P => P
  | cons A As0 => fun sAs P => fun _ => prop As0 (tail_SigmaAlgebra A As0) P
  end.

Definition _andp (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  fix andp (As: list Type): forall sAs: SigmaAlgebras As, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  match As as As_PAT return (forall sAs: SigmaAlgebras As_PAT, _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT) with
  | nil => fun sAs P Q => P /\ Q
  | cons A As0 => fun sAs P Q => fun rho => andp As0 (tail_SigmaAlgebra A As0) (P rho) (Q rho)
  end.

Definition _orp (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  fix orp (As: list Type): forall sAs: SigmaAlgebras As, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  match As as As_PAT return (forall sAs: SigmaAlgebras As_PAT, _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT) with
  | nil => fun sAs P Q => P \/ Q
  | cons A As0 => fun sAs P Q => fun rho => orp As0 (tail_SigmaAlgebra A As0) (P rho) (Q rho)
  end.

Definition _imp (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  fix imp (As: list Type): forall sAs: SigmaAlgebras As, _RandomPred Omega As -> _RandomPred Omega As -> _RandomPred Omega As :=
  match As as As_PAT return (forall sAs: SigmaAlgebras As_PAT, _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT) with
  | nil => fun sAs P Q => P \/ Q
  | cons A As0 => fun sAs P Q => fun rho => imp As0 (tail_SigmaAlgebra A As0) (P rho) (Q rho)
  end.

Definition _exp (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As} {B: Type}, (B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  fix exp (As: list Type): forall (sAs: SigmaAlgebras As) (B: Type), (B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  match As as As_PAT return (forall (sAs: SigmaAlgebras As_PAT) (B: Type), (B -> _RandomPred Omega As_PAT) -> _RandomPred Omega As_PAT) with
  | nil => fun sAs B (P: B -> Prop) => ex P
  | cons A As0 => fun sAs B P => fun rho => exp As0 (tail_SigmaAlgebra A As0) B (fun b => P b rho)
  end.

Definition _expR (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As} (B: Type) {sB: SigmaAlgebra B}, (RandomVariable Omega B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  fix expR (As: list Type): forall (sAs: SigmaAlgebras As) (B: Type) (sB: SigmaAlgebra B), (RandomVariable Omega B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  match As as As_PAT return (forall (sAs: SigmaAlgebras As_PAT) (B: Type) (sB: SigmaAlgebra B), (RandomVariable Omega B -> _RandomPred Omega As_PAT) -> _RandomPred Omega As_PAT) with
  | nil => fun sAs B sB (P: RandomVariable Omega B -> Prop) =>
              exists (b: HeredRandomVariable B) (H: well_defined_dom _ b Omega), P (ex_value _ b Omega H)
  | cons A As0 => fun sAs B sB P => fun rho => expR As0 (tail_SigmaAlgebra A As0) B sB (fun b => P b rho)
  end.

Definition _appp (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As} (B: Type) {sB: SigmaAlgebra B}, HeredRandomVariable B -> (RandomVariable Omega B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  fix appp (As: list Type): forall (sAs: SigmaAlgebras As) (B: Type) (sB: SigmaAlgebra B), HeredRandomVariable B -> (RandomVariable Omega B -> _RandomPred Omega As) -> _RandomPred Omega As :=
  match As as As_PAT return (forall (sAs: SigmaAlgebras As_PAT) (B: Type) (sB: SigmaAlgebra B), HeredRandomVariable B -> (RandomVariable Omega B -> _RandomPred Omega As_PAT) -> _RandomPred Omega As_PAT) with
  | nil => fun sAs B sB b (P: RandomVariable Omega B -> Prop) =>
              exists (H: well_defined_dom _ b Omega), P (ex_value _ b Omega H)
  | cons A As0 => fun sAs B sB b P => fun rho => appp As0 (tail_SigmaAlgebra A As0) B sB b (fun b => P b rho)
  end.

Definition _derives (Omega: RandomVarDomain): forall (As: list Type) {sAs: SigmaAlgebras As}, _RandomPred Omega As -> _RandomPred Omega As -> Prop :=
  fix derives (As: list Type): forall sAs: SigmaAlgebras As, _RandomPred Omega As -> _RandomPred Omega As -> Prop :=
  match As as As_PAT return (forall sAs: SigmaAlgebras As_PAT, _RandomPred Omega As_PAT -> _RandomPred Omega As_PAT -> Prop) with
  | nil => fun sAs P Q => P -> Q
  | cons A As0 => fun sAs P Q => forall rho, derives As0 (tail_SigmaAlgebra A As0) (P rho) (Q rho)
  end.

Definition prop {As: list Type} {sAs: SigmaAlgebras As} (P: Prop): RandomPred As.
  exists (fun Omega: RandomVarDomain => _prop Omega As P).
  intros.
  induction As.
  + simpl.
    tauto.
  + simpl.
    intros; apply IHAs.
Defined.

Definition andp {As: list Type} {sAs: SigmaAlgebras As} (P Q: RandomPred As): RandomPred As.
  exists (fun Omega: RandomVarDomain => _andp Omega As (P Omega) (Q Omega)).
  destruct P as [P ?H], Q as [Q ?H].
  intros; simpl in *.
  specialize (H O1 O2 H1); specialize (H0 O1 O2 H1).
  set (P1 := P O1) in *; set (P2 := P O2) in *; set (Q1 := Q O1) in *; set (Q2 := Q O2) in *.
  clearbody P1 P2 Q1 Q2.
  clear P Q.
  induction As.
  + simpl in *.
    tauto.
  + simpl.
    intros.
    apply IHAs; auto.
Defined.

Definition orp {As: list Type} {sAs: SigmaAlgebras As} (P Q: RandomPred As): RandomPred As.
  exists (fun Omega: RandomVarDomain => _orp Omega As (P Omega) (Q Omega)).
  destruct P as [P ?H], Q as [Q ?H].
  intros; simpl in *.
  specialize (H O1 O2 H1); specialize (H0 O1 O2 H1).
  set (P1 := P O1) in *; set (P2 := P O2) in *; set (Q1 := Q O1) in *; set (Q2 := Q O2) in *.
  clearbody P1 P2 Q1 Q2.
  clear P Q.
  induction As.
  + simpl in *.
    tauto.
  + simpl.
    intros.
    apply IHAs; auto.
Defined.

Definition imp {As: list Type} {sAs: SigmaAlgebras As} (P Q: RandomPred As): RandomPred As.
  exists (fun Omega: RandomVarDomain => _imp Omega As (P Omega) (Q Omega)).
  destruct P as [P ?H], Q as [Q ?H].
  intros; simpl in *.
  specialize (H O1 O2 H1); specialize (H0 O1 O2 H1).
  set (P1 := P O1) in *; set (P2 := P O2) in *; set (Q1 := Q O1) in *; set (Q2 := Q O2) in *.
  clearbody P1 P2 Q1 Q2.
  clear P Q.
  induction As.
  + simpl in *.
    tauto.
  + simpl.
    intros.
    apply IHAs; auto.
Defined.

(*
Definition exp {As: list Type} {sAs: SigmaAlgebras As} {B: Type} (P: B -> RandomPred As): RandomPred As.
  exists (fun Omega: RandomVarDomain => _exp Omega As (fun b => P b Omega)).
  intros; simpl in *.
  specialize (H O1 O2 H1).
  set (P1 := P O1) in *; set (P2 := P O2) in *; set (Q1 := Q O1) in *; set (Q2 := Q O2) in *.
  clearbody P1 P2 Q1 Q2.
  clear P Q.
  induction As.
  + simpl in *.
    tauto.
  + simpl.
    intros.
    apply IHAs; auto.
Defined.

Definition expR {As: list Type} {sAs: SigmaAlgebras As} {B: Type} {sB: SigmaAlgebra B} (P: RandomPred (B :: As)): RandomPred As := fun Omega: RandomVarDomain => _expR Omega As B (fun b => P Omega b).

Definition appp {As: list Type} {sAs: SigmaAlgebras As} {B: Type} {sB: SigmaAlgebra B} (P: RandomPred (B :: As)) (b: HeredRandomVariable B): RandomPred As := fun Omega: RandomVarDomain => _appp Omega As B b (P Omega).
*)

Definition derives {As: list Type} {sAs: SigmaAlgebras As} (P Q: RandomPred As): Prop := forall Omega: RandomVarDomain, _derives Omega As (P Omega) (Q Omega).

End Predicates.

(*

(*

Definition PTriple (P: global_state -> Prop) (c: cmd) (Q: global_state -> Prop): Prop :=
  forall (s1: global_state),
    P s1 ->
    nPr s1 = 0 ->
    forall (s2: global_state),
      command_oaccess c (proj1_sig s1) (proj1_sig s2) ->
      same_covered_domain (rv_domain _ (proj1_sig s1)) (rv_domain _ (proj1_sig s2)) /\
      (nPr s2 = 0 -> Q s2).

Definition TTriple (P: global_state -> Prop) (c: cmd) (Q: global_state -> Prop): Prop :=
  forall (s1: global_state),
    P s1 ->
    nPr s1 = 0 ->
    forall (s2: global_state),
      command_oaccess c (proj1_sig s1) (proj1_sig s2) ->
      same_covered_domain (rv_domain _ (proj1_sig s1)) (rv_domain _ (proj1_sig s2)) /\
      nPr s2 = 0 /\
      Q s2.

Require Import Morphisms.
*)
*)


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section VotesCorrectInterface.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition one_vote_per_term net :=
    forall h t n n',
      In (t, n) (votes (fst (nwState net h))) ->
      In (t, n') (votes (fst (nwState net h))) ->
      n = n'.

  Definition votes_currentTerm_votedFor_correct net :=
    forall h t n,
      In (t, n) (votes (fst (nwState net h))) ->
      currentTerm (snd (nwState net h)) = t ->
      votedFor (snd (nwState net h)) = Some n.

  Definition currentTerm_votedFor_votes_correct net :=
    forall h t n,
      currentTerm (snd (nwState net h)) = t ->
       votedFor (snd (nwState net h)) = Some n ->
      In (t, n) (votes (fst (nwState net h))).

  Definition votes_correct net :=
    one_vote_per_term net /\ votes_currentTerm_votedFor_correct net /\
    currentTerm_votedFor_votes_correct net.

  Class votes_correct_interface : Prop :=
    {
      votes_correct_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votes_correct net
    }.
End VotesCorrectInterface.


Fail Inductive List (M : Type -> Type) (a : Type) : Type :=
| Nil  : List M a
| Cons : M a -> M (List M a) -> List M a
.

Fail Inductive NonStrictlyPos :=
| con : (NonStrictlyPos -> nat) -> NonStrictlyPos
.

Inductive StrictlyPos :=
| con : StrictlyPos -> (nat -> StrictlyPos) -> StrictlyPos
.

Fail Definition applyFun (t:NonStrictlyPos) : nat :=
    match t with
    | con f => f t
    end.

Fail Inductive Mu (a:Type) : Type :=
| mu : (Mu a -> a) -> Mu a
.

Definition Cont r a := (a -> r) -> r.

Fail Inductive ListC r a :=
| NilC : ListC r a
| ConsC: ((a -> r) -> r) -> ((ListC r a -> r) -> r) -> ListC r a
.

Fail Inductive Free f a :=
| pure   : a -> Free f a
| impure : f (Free f a) -> Free f a
.

Inductive Void :=.

Definition Zero (a:Type) : Type := Void.
Definition One  (a:Type) : Type := unit.

Inductive Const (b a: Type) : Type :=
| const : b -> Const b a
.

Fail Inductive FixF f := fixF : f (FixF f) -> FixF f.

Inductive Ext (Shape : Type) (Pos:Shape -> Type) a :=
| ext : forall (s : Shape), (Pos s -> a) -> Ext Shape Pos a
.

Arguments ext {Shape} {Pos} {a} _ _.

Definition absurd (a:Type) : Void -> a :=
    fun p => match p with end.

Definition ShapeOne := unit.
Definition PosOne (s:ShapeOne) := Void.
Definition ExtOne a := Ext ShapeOne PosOne a.

Definition toOne (a:Type) (e:ExtOne a) : One a := tt.

Arguments toOne {a} _.

Definition fromOne (a:Type) (z:One a) : ExtOne a :=
    ext tt (absurd a).

Arguments fromOne {a} _.

Lemma toFromOne : forall (a:Type) (z:One a), toOne (fromOne z) = z.
Proof.
    intros a z. destruct z. unfold toOne. reflexivity.
Qed.

Axiom extensionality : forall (a b:Type) (f g:a -> b),
    (forall (x:a), f x = g x) -> f = g.

Arguments extensionality {a} {b} _ _ _.

Lemma absurd_unique : forall (a:Type) (f:Void -> a), f = absurd a.
Proof.
    intros a f. apply extensionality. intros x. inversion x.
Qed.

Lemma fromToOne : forall (a:Type) (e:ExtOne a), fromOne (toOne e) = e.
Proof.
    intros a [s pos]. unfold PosOne in pos. unfold ShapeOne in s. destruct s.
    unfold toOne. unfold fromOne. rewrite (absurd_unique a pos).
    reflexivity.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-04-25
- Adam Koprowski, 2008-05-27,
    introduced distinction of weak/strong monotonicity

monotone polynomials
*)

Set Implicit Arguments.

Require Import Polynom2 PositivePolynom2 NaryFunction VecUtil LogicUtil
  ListUtil ListForall List ZUtil RelUtil NatUtil OrdSemiRing2 VecArith2 ListExtras.

Section S.

  Context {OR: OrderedRing}.

  Import OR_Notations.

  Notation "x >>= y" := (@or_ge _ x y) (at  level 70).
  Notation not_neg   := (fun z => z >>= 0).
  Notation D         := (sig not_neg).
  Notation inj       := (@exist s_typ not_neg _).
  Notation val       := (@proj1_sig s_typ not_neg).
  Notation vec       := (vector D).
  Notation vals      := (@Vmap D s_typ val _).

  Definition Dgt x y := val x >> val y.
  Notation Dlt       := (transp Dgt).
  Definition Dge x y := val x >>= val y.
  Notation Dle       := (transp Dge).

  (* TODO : trans and refl *)

  (***********************************************************************)
  (** weak and strong monotony conditions *)

  Definition pweak_monotone n (p : poly n)  := coef_not_neg p.

  Definition pstrong_monotone n (p: poly n) :=
    pweak_monotone p /\ forall i (H: i < n), coef (mxi H) p >> 0.

  (***********************************************************************)
  (** alternative definition of monotony conditions *)

  Definition pstrong_monotone' n (p : poly n) := coef_not_neg p
   /\ forall i (H : i < n), exists p1, exists c, exists p2,
    c >> 0 /\ p = p1 ++ (c, mxi H) :: p2.

  Lemma pmonotone_imp_pmonotone' : forall n (p : poly n),
    pstrong_monotone p -> pstrong_monotone' p.

  Proof.
    intros n p (H1, H2).
    split. auto.
    intros i Hi. gen (H2 i Hi). clear H2.
    generalize dependent p. intro p. elim p. simpl in *.
    intros H1 H2. absurd (coef (mxi Hi) nil = 0).
    apply or_gt_0. hyp. simpl.
    refl.
    intros (c, m) p' Hrec H1. simpl in H1. gen H1. clear H1.
    intros (H1, H2). simpl.
    case_eq (monom_eq_dec (mxi Hi) m); intro Hm; simpl; intro H3.
    elim (or_gt_eq_ge_dec H1); clear H1. intro H1.

    (* If c > 0, it's easy to build the required elements *)
    intro H'. exists (pzero n). exists c. exists p'.
    split. hyp. simpl. subst m. refl.

    (* if c = 0, we must use the induction hypothesis *)
    intro Hc. rewrite Hc. subst m. rewrite Aplus_0_l. intros H4.
    elim (Hrec H2 H4). clear Hrec. intros p'1 H. elim H. intros c' H1.
    elim H1. clear H1. intros p'2 (Hc', Hp').
    exists ((c, mxi Hi) :: p'1).
    exists c'. exists p'2.
    split. hyp.
    rewrite Hp'. simpl in *. refl.

    intro H. elim (Hrec H2 H). clear H2. clear H.
    intros p'1 H. elim H. clear H. intros c' H. elim H. clear H.
    intros p'2 (Hc', Hp').
    exists ((c, m) :: p'1). exists c'. exists p'2.
    split. hyp.
    subst p'. simpl in *. refl.
  Qed.

  (***********************************************************************)
  (** correctness of monotony conditions *)

  Lemma meval_monotone_D : forall i (vi : vec i) (mi : monom i)
    j (vj : vec j) (mj : monom j) k x y (Hx : x >>= 0) (Hy : y >>= 0),
    x >>= y ->
    meval (Vapp mi (Vcons k mj)) (vals (Vapp vi (Vcons (inj Hx) vj)))
    >>= meval (Vapp mi (Vcons k mj)) (vals (Vapp vi (Vcons (inj Hy) vj))).

  Proof.
    intros. do 2 rewrite Vmap_app. simpl Vmap. do 2 rewrite meval_app.
    apply or_mul_ge_mono_l. apply not_neg_meval. simpl in *.
    apply or_mul_ge_mono_r. apply not_neg_meval.
    apply or_power_ge_compat; hyp.
  Qed.

  Lemma coef_not_neg_monotone_peval_Dge : forall n (p : poly n)
    (H : coef_not_neg p), Vmonotone1 (peval_D p H) Dge.

  Proof.
    unfold Vmonotone1, Vmonotone, peval_D, Vmonotone_i, restrict, monotone.
    intros n p H_coef_not_neg i j Hij vi vj. destruct x as (x, Hx).
    destruct y as (y, Hy). simpl. intro Hxy.
    generalize dependent p. intro p. elim p.
    intro. simpl. apply or_ge_refl.
    unfold coef_not_neg. intros (c, m) p' Hrec H_coef_not_neg.
    simpl in H_coef_not_neg. generalize H_coef_not_neg. clear H_coef_not_neg.
    intros (H_not_neg_c, H_coef_not_neg_p').
    generalize (Hrec H_coef_not_neg_p'). clear Hrec. intro H.
    lazy beta iota delta [peval]. fold peval.
    apply or_add_ge_compat.
    2: apply H.
    clear H.
    apply or_mul_ge_mono_l.
    hyp.
    rewrite (Vbreak_eq_app_cast Hij m).
    set (mi := (fst (Vbreak (n1:=i) (n2:=S j) (Vcast m (sym_equal Hij))))).
    set (mj := (snd (Vbreak (n1:=i) (n2:=S j) (Vcast m (sym_equal Hij))))).
    rewrite (VSn_eq mj).
    case Hij. simpl. repeat rewrite Vcast_refl.
    apply meval_monotone_D.
    hyp.
  Qed.

  Implicit Arguments coef_not_neg_monotone_peval_Dge [n p i j x y].

  Lemma pmonotone'_imp_monotone_peval_Dgt :
  forall n (p : poly n) (H: pstrong_monotone' p),
    Vmonotone1 (peval_D p (proj1 H)) Dgt.

  Proof.
    intros n p (H_coef_pos_p, H_pmonotone_p) i j Hij.
    gen (H_pmonotone_p _ (i_lt_n (sym_equal Hij))).
    intro H. elim H. clear H. intros p1 H. elim H. clear H.
    intros c H. elim H. clear H. intros p2 (H, H'). subst p.
    gen (coef_not_neg_app _ _ H_coef_pos_p).
    intros (H_coef_pos_p1, H').
    gen (coef_not_neg_cons H'). clear H'. intros (H', H_coef_pos_p2).
    clear H'. unfold Vmonotone_i, Dgt, peval_D, monotone, restrict.
    intros vi vj. destruct x as (x, Hx). destruct y as (y, Hy). simpl.
    intro Hxy. clear H_coef_pos_p.
    do 2 rewrite peval_app.
    apply or_add_ge_gt_mono.
    gen (coef_not_neg_monotone_peval_Dge H_coef_pos_p1).
    unfold Vmonotone, Dge, peval_D, Vmonotone_i, restrict, monotone.
    intro H'.
    gen (H' _ _ Hij vi vj (exist not_neg x Hx) (exist not_neg y Hy)).
    simpl. clear H'. intro H'. apply H'. unfold or_ge. left. hyp.
    lazy beta iota delta [peval]. fold peval.
    apply or_add_gt_ge_mono.
    apply or_mul_gt_mono_l. hyp. do 2 rewrite meval_xi.
    do 2 rewrite Vmap_cast. case Hij. simpl.
    clear H_pmonotone_p. clear Hij. generalize dependent i. intro i. elim i.
    intro vi. rewrite (VO_eq vi). simpl. hyp.
    intros i' Hrec vi. rewrite (VSn_eq vi). simpl Vapp.
    simpl Vmap. simpl Vnth. gen (Hrec (Vtail vi)). clear Hrec. intro H'.
    assert (H'' : i_lt_n (refl_equal (i' + S j)%nat) = lt_S_n
     (@i_lt_n (S (i' + S j)) (S i') _ (refl_equal (S (i' + S j))))).
    apply lt_unique.
    rewrite <- H''. hyp.
    gen (coef_not_neg_monotone_peval_Dge H_coef_pos_p2).
    unfold Vmonotone, Dge, peval_D, Vmonotone_i, restrict, monotone.
    intro H'.
    gen (H' _ _ Hij vi vj (exist not_neg x Hx) (exist not_neg y Hy)).
    simpl. clear H'. intro H'. apply H'. unfold or_ge.
    left. hyp.
  Qed.

  Lemma pmonotone_imp_monotone_peval_Dgt : forall n (p : poly n)
    (wm: pweak_monotone p) (sm: pstrong_monotone p),
     Vmonotone1 (peval_D p wm) Dgt.

  Proof.
    intros n p wm sm.
    gen (pmonotone'_imp_monotone_peval_Dgt (pmonotone_imp_pmonotone' sm)).
    unfold Vmonotone1, Vmonotone, Dgt, Vmonotone_i, peval_D, restrict, monotone.
    intros H0 i j Hij vi vj. destruct x as (x, Hx). destruct y as (y, Hy).
    simpl. intro Hxy.
    gen (H0 i j Hij vi vj (exist _ x Hx) (exist _ y Hy) Hxy).
    clear H0. simpl. intuition.
  Qed.

  (***********************************************************************)
  (** boolean functions for checking monotony conditions *)

  Definition bpweak_monotone    n (p : poly n) := bcoef_not_neg p.
  Definition bpweak_monotone_ok n (p : poly n) := bcoef_not_neg_ok p.

  Implicit Arguments mk_nat_lts [].
  Implicit Arguments mk_nat_lts_aux [].

  Require Import BoolUtil.

  Definition bpstrong_monotone n (p : poly n) :=
    bcoef_not_neg p &&
     forallb (fun x => or_bgt (coef (mxi (prf x)) p) 0) (mk_nat_lts n).

  Open Scope nat_scope.

  Lemma bpstrong_monotone_ok : forall n (p : poly n),
  bpstrong_monotone p = true <-> pstrong_monotone p.

  Proof.
    induction p.
    (* nil *)
    unfold pstrong_monotone, bpstrong_monotone, pweak_monotone. simpl.
    intuition. unfold mk_nat_lts in H. destruct n. absurd_arith.
    (*destruct n; discr. *)
    (*destruct n. refl. ded (H1 n (le_n (S n))).*)
    Focus 3.
    (* cons *)
    destruct a. intuition.
    (* -> *)
    unfold pstrong_monotone, pweak_monotone.
    unfold bpstrong_monotone, bnot_neg in H1. Opaque coef. simpl in *.
    rewrite !andb_eq in H1. intuition. change (bnot_neg s = true) in H1.
    rewrite <- bnot_neg_ok. hyp. rewrite <- bcoef_not_neg_ok. hyp.
    assert (In (mk_nat_lt H2) (mk_nat_lts n)). apply mk_nat_lts_complete.
    rewrite forallb_forall in H3. ded (H3 _ H5).
    rewrite or_bgt_ok in H6. simpl in H6. hyp.
    (* <- *)
    unfold pstrong_monotone, pweak_monotone in H1.
    unfold bpstrong_monotone, bcoef_not_neg. simpl in *.
    rewrite !andb_eq. intuition. rewrite bnot_neg_ok. hyp.
    change (bcoef_not_neg p = true). rewrite bcoef_not_neg_ok. hyp.
    rewrite forallb_forall. intros [i hi Hi]. simpl. rewrite or_bgt_ok.
    ded (H3 _ hi). hyp.
    Focus 2. destruct n. refl. ded (H1 n (le_n (S n))). simpl in *.
    rewrite forallb_forall. intros. rewrite or_bgt_ok. apply H.
    rewrite forallb_forall in H.
    rewrite <- or_bgt_ok. eapply H.

  Admitted.

  (***********************************************************************)
  (** check monotony conditions *)

  Definition is_pos_monom n (cm : s_typ * monom n) :=
    let (c, _) := cm in not_neg c.

End S.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable p_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable a9_ : Universe.
Variable a8_ : Universe.
Variable a7_ : Universe.
Variable a6_ : Universe.
Variable a5_ : Universe.
Variable a4_ : Universe.
Variable a3_ : Universe.
Variable a2_ : Universe.
Variable a15_ : Universe.
Variable a14_ : Universe.
Variable a13_ : Universe.
Variable a12_ : Universe.
Variable a11_ : Universe.
Variable a10_ : Universe.
Variable a1_ : Universe.

Variable ax1_1 : (dom_ a1_ /\ (dom_ a2_ /\ (dom_ a3_ /\ (dom_ a4_ /\ (dom_ a5_ /\ (dom_ a6_ /\ (dom_ a7_ /\ (dom_ a8_ /\ (dom_ a9_ /\ (dom_ a10_ /\ (dom_ a11_ /\ (dom_ a12_ /\ (dom_ a13_ /\ (dom_ a14_ /\ dom_ a15_)))))))))))))).
Variable ax2_2 : (forall A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15 : Universe, ((dom_ A1 /\ (dom_ A2 /\ (dom_ A3 /\ (dom_ A4 /\ (dom_ A5 /\ (dom_ A6 /\ (dom_ A7 /\ (dom_ A8 /\ (dom_ A9 /\ (dom_ A10 /\ (dom_ A11 /\ (dom_ A12 /\ (dom_ A13 /\ (dom_ A14 /\ dom_ A15)))))))))))))) -> p_ A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15)).
Variable ax3_3 : (p_ a15_ a14_ a13_ a12_ a11_ a10_ a9_ a8_ a7_ a6_ a5_ a4_ a3_ a2_ a1_ -> goal_).

Theorem lemma15_4 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import LanguageUtil.

Lemma extract_open_distr_rec : forall e e' n,
    extract (e <n> ^^ e') = extract e ⋆n^^ extract e'.
Proof.
  induction e; simpl; intros;
    try solve
        [ auto
        | now rewrite IHe
        | now rewrite IHe1, IHe2
        | now rewrite IHe2 ].
  - now destruct (n0 == n).
Qed.

Lemma extract_open_distr : forall e e',
    extract (e ^^ e') = extract e ⋆^^ extract e'.
Proof.
  intros. apply extract_open_distr_rec.
Qed.

Lemma extract_open_var : forall e x,
    extract (e ^` x) = extract e ⋆^` x.
Proof.
  intros. apply extract_open_distr.
Qed.

Lemma lc_extract_lc : forall e,
    lc_expr e -> lc_eexpr (extract e).
Proof.
  intros.
  induction H; simpl; auto;
    econstructor; eauto;
      intros; instantiate_cofinites; solve [now rewrite <- extract_open_var].
Qed.

Hint Resolve lc_extract_lc : core.

Ltac solve_evalue :=
  constructor; auto;
  econstructor; auto;
  intros; instantiate_cofinites; try rewrite <- extract_open_var; eauto.

Lemma value_evalue : forall e,
    value e -> evalue (extract e).
Proof.
  intros. induction H; simpl; solve [auto | inversion H0; subst; solve_evalue].
Qed.

Lemma evalue_value : forall e,
    lc_expr e -> evalue (extract e) -> value e.
Proof.
  intros e LC.
  induction LC; simpl; intros EV; try solve [inversion EV | eauto].
Qed.

Lemma subst_extract : forall e x v,
    extract ([v / x] e) = [(extract v) ⋆/ x] extract e.
Proof.
  induction e; simpl; intros;
    try solve
        [ auto
        | now destruct (x == x0)
        | now rewrite IHe
        | now rewrite IHe2
        | now rewrite IHe1, IHe2].
Qed.


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

(** General Facts About Q and Qpositive, the functions Qpositive_c and Qpositive_i and the operations Qmult, Qpositive, Qlt *)

Require Import FunInd.
Require Export Qpositive.
Require Export Q_field.
Require Export Q_order.
Require Import Field_Theory_Q.
Require Export Zaux.

(* An auxiliary lemma about [Z] *)

Lemma Z_of_nat_Zabs_nat_pos: forall z, (0<=z)%Z -> Z_of_nat (Z.abs_nat z) = z.
Proof.
 intros z Hz;
 destruct (Z_of_nat_complete_inf z Hz) as [n Hn];
 transitivity (Z_of_nat n); auto;
 apply (f_equal Z_of_nat);
 rewrite <- absolu_inj_nat;
 apply (f_equal Z.abs_nat); trivial.
Qed.

(** For decoding and encoing elements of Q: binary sequneces versus pairs of integers. *)

(*** Building the rational number m/n *)
Definition make_Q (m n : Z) :=
  match m, n with
  | Zpos _, Zpos _ =>
      Qpos (Qpositive_c (Z.abs_nat m) (Z.abs_nat n) (Z.abs_nat m + Z.abs_nat n))
  | Zneg _, Zneg _ =>
      Qpos (Qpositive_c (Z.abs_nat m) (Z.abs_nat n) (Z.abs_nat m + Z.abs_nat n))
  | Z0, _ => Zero
  | _, Z0 => Zero (* dummy *)
  | _, _ =>
      Qneg (Qpositive_c (Z.abs_nat m) (Z.abs_nat n) (Z.abs_nat m + Z.abs_nat n))
  end.

(*** decoding a sequnce consisting of dL and nR and ending in One. *)
Definition decode_Q (q : Q) :=
  match q with
  | Qpos p =>
      (Z_of_nat (fst (Qpositive_i p)), Z_of_nat (snd (Qpositive_i p)))
  | Qneg p =>
      ((- Z_of_nat (fst (Qpositive_i p)))%Z, Z_of_nat (snd (Qpositive_i p)))
  | Zero => (0%Z, 1%Z)
  end.

Definition numerator (q:Q) :Z := fst (decode_Q q).

Definition denominator (q:Q) :Z := snd (decode_Q q).

(** Definition of various functions *)
Definition Z_to_Qpositive : forall x : Z, (0 < x)%Z -> Qpositive.
intros [| p| p].
intros H; abstract discriminate H.
intro.
exact (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p))).
intro; abstract discriminate H.
Defined.

Definition Z_to_Q (x : Z) : Q :=
  match x with
  | Z0 => Zero
  | Zpos p => Qpos (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p)))
  | Zneg p => Qneg (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p)))
  end.

Definition Qpositive_tail (z : Qpositive) :=
  match z with
  | nR p => p
  | dL p => p
  | One => One
  end.

Definition Q_tail (z : Q) :=
  match z with
  | Zero => One
  | Qpos p => p
  | Qneg p => p
  end.

Definition Qsgn (q : Q) :=
  match q with
  | Zero => 0%Z
  | Qpos _ => 1%Z
  | Qneg _ => (-1)%Z
  end.

(** These two only consider the length, we won't use them further *)
Fixpoint length_of_Qpositive_to_positive (qp : Qpositive) : positive :=
  match qp with
  | One => 1%positive
  | dL qp' => Pos.succ (length_of_Qpositive_to_positive qp')
  | nR qp' => Pos.succ (length_of_Qpositive_to_positive qp')
  end.

Fixpoint length_of_Qpositive (qp : Qpositive) : Z :=
  match qp with
  | One => 0%Z
  | dL qp' => (1 + length_of_Qpositive qp')%Z
  | nR qp' => (1 + length_of_Qpositive qp')%Z
  end.

(** This is the oredr preserving projection from Q to Z *)

Fixpoint Qpositive_to_Z (qp : Qpositive) : Z :=
  match qp with
  | One => 1%Z
  | dL qp' => 0%Z
  | nR qp' => (1 + Qpositive_to_Z qp')%Z
  end.

Definition Q_to_Z (x : Q) : Z :=
  match x with
  | Zero => 0%Z
  | Qpos qp => Qpositive_to_Z qp
  | Qneg qp => (- Qpositive_to_Z qp)%Z
  end.

Coercion Z_to_Q : Z >-> Q.

Definition Qlt (x y : Q) : Prop := Qgt y x.

Definition Qle (x y : Q) : Prop := ~ Qlt y x.

Lemma Qlt_zero_pos : forall x' : Qpositive, Qlt Zero (Qpos x').
Proof.
 unfold Qlt in |- *; auto with *.
Qed.

Lemma Qlt_neg_pos : forall x' y' : Qpositive, Qlt (Qneg y') (Qpos x').
Proof.
 unfold Qlt in |- *; auto with *.
Qed.

Lemma Qlt_neg_zero : forall x' : Qpositive, Qlt (Qneg x') Zero.
 unfold Qlt in |- *; auto with *.
Qed.

Hint Resolve Qlt_neg_pos Qlt_neg_zero Qlt_zero_pos.

Ltac QltCleanAbsurdCases :=
  match goal with
  | id1:(Qlt Zero (Qneg _)) |- _ => inversion id1
  | id1:(Qlt (Qpos _) Zero) |- _ =>
      inversion id1
  | id1:(Qlt (Qpos _) (Qneg _)) |- _ =>
      inversion id1
  | id1:(Qle Zero (Qneg _)) |- _ =>
      apply False_ind; apply id1; auto with *
  | id1:(Qle (Qpos _) Zero) |- _ =>
      apply False_ind; apply id1; auto with *
  | id1:(Qle (Qpos _) (Qneg _)) |- _ =>
      apply False_ind; apply id1; auto with *
  end.

(* Hints Unfold Qle.*)

(** Properties of  Qpositive_c *)
Functional Scheme Qpositive_c_ind := Induction for Qpositive_c Sort Prop.

Lemma Qpositive_c_0 : forall p q n : nat, n = 0 -> Qpositive_c p q n = One.
Proof.
 intros p q n.
 functional induction (Qpositive_c p q n); trivial || (intros; discriminate).
(*
 Intros p q n Hn;
 Rewrite Hn;
 Simpl;
 Reflexivity.
*)
Qed.

Lemma Qpositive_c_1_0_0 :
 forall p q n' : nat, p - q = 0 -> q - p = 0 -> Qpositive_c p q (S n') = One.
Proof.
 intros p q n.
 functional induction (Qpositive_c p q (S n));trivial.
 rewrite e1;intros;discriminate.
 rewrite e0;intros;discriminate.
Qed.

Lemma Qpositive_c_equal_One :
 forall m n p : nat, m = n -> Qpositive_c m n p = One.
Proof.
 intros p q [| n'] Hpq;
  [ apply Qpositive_c_0
  | apply Qpositive_c_1_0_0; rewrite Hpq; rewrite <- minus_n_n ];
  reflexivity.
Qed.

Lemma Qpositive_c_1_0_1 :
 forall p q n' : nat,
 p - q = 0 ->
 q - p <> 0 -> Qpositive_c p q (S n') = dL (Qpositive_c p (q - p) n').
Proof.
 intros p q n' Hpq Hqp; simpl in |- *; rewrite Hpq; elim (not_O_S _ Hqp);
  intros p' Hqp'; rewrite Hqp'; simpl in |- *; reflexivity.
Qed.

Lemma Qpositive_c_dL :
 forall p q n' : nat,
 p < q -> Qpositive_c p q (S n') = dL (Qpositive_c p (q - p) n').
Proof.
 intros p q n Hpq.
 generalize (lt_minus_eq_0 p q Hpq) (lt_minus_neq p q Hpq).
 intros Hpq0 Hqp.
 apply (Qpositive_c_1_0_1 _ _ n Hpq0 Hqp).
Qed.

Lemma Qpositive_c_1_1 :
 forall p q n' : nat,
 p - q <> 0 -> Qpositive_c p q (S n') = nR (Qpositive_c (p - q) q n').
Proof.
 intros p q n' Hpq; simpl in |- *; elim (not_O_S _ Hpq); intros p' Hpq';
  rewrite Hpq'; simpl in |- *; reflexivity.
Qed.

Lemma Qpositive_c_nR :
 forall p q n' : nat,
 q < p -> Qpositive_c p q (S n') = nR (Qpositive_c (p - q) q n').
Proof.
 intros p q n Hqp.
 generalize (lt_minus_neq q p Hqp).
 intros Hpq.
 apply (Qpositive_c_1_1 _ _ n Hpq).
Qed.

Functional Scheme Qpositive_i_ind := Induction for Qpositive_i Sort Prop.
Lemma Qpositive_i_nR_with_let :
 forall w : Qpositive,
 let (p, q) := Qpositive_i w in Qpositive_i (nR w) = (p + q, q).
Proof.
 intros w;simpl Qpositive_i.
 functional induction (Qpositive_i w);subst;trivial.
Qed.

Lemma Qpositive_i_nR :
 forall (w : Qpositive) (p q : nat),
 Qpositive_i w = (p, q) -> Qpositive_i (nR w) = (p + q, q).
Proof.
 intros w p q H_w; generalize (Qpositive_i_nR_with_let w); rewrite H_w;
  trivial.
Qed.

Lemma Qpositive_i_c :
 forall m p : nat,
 0 < m -> S m <= p -> Qpositive_i (Qpositive_c m 1 p) = (m, 1).
Proof.
 intros m p.
 generalize m; clear m.
 induction p.
 intros m H1 H2.
 inversion H2.
 intros m H1 H2.

 case (le_lt_eq_dec 1 m).
 auto with arith.
 intro H_1_m.

 rewrite (Qpositive_c_nR _ _ p H_1_m).
 rewrite (Qpositive_i_nR (Qpositive_c (m - 1) 1 p) (m - 1) 1).
 apply pair_2; simpl in |- *; trivial; omega.
 apply IHp; omega.
 intro H_1_1.
 rewrite <- H_1_1.
 reflexivity.
Qed.

Lemma Qpositive_c_equal :
 forall m n p p' : nat,
 0 < m ->
 0 < n -> m + n <= p -> m + n <= p' -> Qpositive_c m n p = Qpositive_c m n p'.
Proof.
 intros m n p.
 functional induction (Qpositive_c m n p) as  [| | p q  p' H_eq_1  | ].
 intros p' _ _ Hpq.
 generalize (le_plus_O_l p q Hpq) (le_plus_O_r p q Hpq).
 intros Hp Hq.
 rewrite Hp.
 rewrite Hq.
 case p'; simpl in |- *; reflexivity.
  (* 2 *)
 intros p' _ _ _ _.
 symmetry  in |- *.
 apply Qpositive_c_equal_One.
 apply le_antisym; apply minus_O_le; assumption.
 (* 3 *)
 intros [| p'x] HpO HqO Hpq Hpq'.
 generalize (le_plus_O_r p q Hpq') (le_plus_O_l p q Hpq').
 intros Hq Hp.
 apply False_ind;omega.
(*  rewrite Hp in H_eq_1.  *)
(*  rewrite Hq in H_eq_1. *)
(*  apply False_ind. *)
(*  abstract discriminate H_eq_1. *)
 rewrite Qpositive_c_1_0_1;auto.
 apply f_equal with Qpositive.
 rewrite (IHq p'x);try omega.
 unfold Qpositive_c at 2;fold Qpositive_c.
 rewrite e1.
 destruct (q - p);tauto.
 omega.
 (* 4 *)
 intros [| p'x] HpO HqO Hpq Hpq'.
 generalize (le_plus_O_r p q Hpq') (le_plus_O_l p q Hpq').
 intros Hq Hp.
 apply False_ind;omega.
 unfold Qpositive_c at 2;fold Qpositive_c.

 rewrite e0.
 rewrite (IHq p'x);try omega.
 reflexivity.
Qed.

Lemma Qpositive_c_equal_strong :
 forall m1 m2 n1 n2 p1 p2 : nat,
 m1 = m2 ->
 n1 = n2 ->
 0 < m1 ->
 0 < n1 ->
 m1 + n1 <= p1 ->
 m2 + n2 <= p2 -> Qpositive_c m1 n1 p1 = Qpositive_c m2 n2 p2.
Proof.
 intros m1 m2 n1 n2 p1 p2 Hm Hn Hm' Hn' H1 H2; subst; apply Qpositive_c_equal;
  assumption.
Qed.

Functional Scheme Qpositive_plus_ind := Induction for Qpositive_plus Sort Prop.

Lemma what_nR_does : forall p : Qpositive, nR p = Qpositive_plus p One.
Proof.
 intros qp.
 unfold Qpositive_plus;fold Qpositive_plus.
 functional induction (Qpositive_plus qp One).
 rewrite e;rewrite e0.
 rename e into H_pq.
 rename e0 into H_p'q'.
 generalize (interp_non_zero qp).
 rename q0 into q.
 intros (p0', (q0', Hpq')).

 rewrite H_pq in Hpq'.
 let f_local := eval compute in (f_equal (fst (B:=_)) Hpq') in
 let g_local := eval compute in (sym_eq (f_equal (fst (B:=_)) H_p'q')) in
 generalize f_local g_local.
 let f_local := eval compute in (f_equal (snd (B:=_)) Hpq') in
 let g_local := eval compute in (sym_eq (f_equal (snd (B:=_)) H_p'q')) in
 generalize f_local g_local.
 intros Hq Hq' Hp Hp'.
 subst.
 rewrite <- (mult_n_Sm (S q0') 0).
 repeat rewrite <- plus_n_Sm.
 rewrite <- mult_n_O.
 rewrite plus_O_n.
 rewrite mult_1_l.
 rewrite mult_1_r.
 rewrite Qpositive_c_nR.
 rewrite plus_comm.
 rewrite minus_plus.
 apply f_equal with Qpositive.
 symmetry  in |- *; apply construct_correct.
 assumption.
 rewrite plus_comm.
 apply le_plus_l.
 clear;  omega.
Qed.

Functional Scheme Qpositive_mult_ind := Induction for Qpositive_mult Sort Prop.

Lemma what_dL_does :
 forall p : Qpositive,
 dL p = Qpositive_mult p (Qpositive_inv (Qpositive_plus p One)).
Proof.
 intros qp.

(* induction bug ? *)  unfold Qpositive_plus. (* /*)

 functional induction (Qpositive_plus qp One).
 rewrite e;rewrite e0.
 rename q0 into q;
   rename e into H_eq_;
     rename e0 into H_eq_0.

 generalize (interp_non_zero qp).
 intros (p0, (q0, Hpq)).
 rewrite H_eq_ in Hpq.
 let f_local := eval compute in (f_equal (fst (B:=_)) Hpq) in
 let g_local := eval compute in (sym_eq (f_equal (fst (B:=_)) H_eq_0)) in
 generalize f_local g_local.
 let f_local := eval compute in (f_equal (snd (B:=_)) Hpq) in
 let g_local := eval compute in (sym_eq (f_equal (snd (B:=_)) H_eq_0)) in
 generalize f_local g_local.
 intros Hq Hq' Hp Hp'.
 subst.
 rewrite <- (mult_n_Sm (S q0) 0).
 repeat rewrite <- plus_n_Sm.
 rewrite <- mult_n_O.
 rewrite plus_O_n.
 rewrite mult_1_l.
 rewrite mult_1_r.
 unfold Qpositive_mult in |- *.
 rewrite H_eq_.
 set
  (P :=
   Qpositive_i (Qpositive_c (S p0 + S q0) (S q0) (S (S p0 + S q0 + q0))))
  in *.
 set (p' := fst P) in *.
 set (q' := snd P) in *.
 assert
  (H_P :
   Qpositive_i (Qpositive_c (S p0 + S q0) (S q0) (S (S p0 + S q0 + q0))) =
   (p', q')).
 replace (p', q') with P; trivial; unfold p', q' in |- *; apply pair_1.
 rewrite (inv_correct _ _ _ H_P).
 rewrite (Qpositive_c_unfold1 p0 q0 (S p0 + S q0 + q0)) in H_P.
 rewrite
  (construct_correct qp (S p0) (S q0) (S p0 + S q0 + q0) H_eq_
     (le_plus_l _ _)) in H_P.
 rewrite (Qpositive_i_nR qp _ _ H_eq_) in H_P.
 let f_local :=
  eval cbv beta delta -[plus] in (sym_eq (f_equal (fst (B:=_)) H_P)) in
 let g_local :=
  eval cbv beta delta -[plus] in (sym_eq (f_equal (snd (B:=_)) H_P)) in
 generalize f_local g_local.
 intros Hp' Hq'; rewrite Hp'; rewrite Hq'.
 clear H_eq_0 Hpq H_P Hp' Hq' P p' q'.
 rewrite <- (mult_n_Sm (S p0) q0).
 rewrite <- plus_n_Sm.
 rewrite (plus_Sn_m (S p0 * q0 + p0)).
 replace (S (S p0 * q0 + p0)) with (S q0 * S p0).
 rewrite Qpositive_c_dL.
 replace (S q0 * (S p0 + S q0) - S q0 * S p0) with (S q0 * S q0).
 apply f_equal with Qpositive.
 symmetry  in |- *.
 rewrite
  (construct_correct4' (S q0 * S p0) (S q0 * S q0)
     (S p0) (S q0) (S p0 * q0 + p0 + S q0 * (S p0 + S q0))
     (S p0 + S q0)).
 apply construct_correct.
 assumption.
 omega.
 rewrite <- mult_n_Sm.
 rewrite <- plus_n_Sm.
 auto with arith.
 rewrite <- mult_n_Sm.
 rewrite <- plus_n_Sm.
 auto with arith.
 auto with arith.
 auto with arith.
 rewrite mult_plus_distr_l.
 apply le_plus_r.
 apply le_n.
 rewrite (mult_comm (S q0) (S p0)).
 auto with arith.
 rewrite mult_plus_distr_l.
 rewrite minus_plus; reflexivity.
 rewrite mult_plus_distr_l.
 rewrite plus_comm.
 repeat rewrite <- mult_n_Sm.
 rewrite <- plus_n_Sm.
 rewrite <- plus_n_Sm with (m := q0).
 generalize (S q0 * p0 + q0) (S q0 * q0 + q0); clear qp H_eq_; intros;
  omega.
 rewrite mult_comm.
 rewrite <- mult_n_Sm.
 rewrite <- plus_n_Sm; reflexivity.
 rewrite plus_n_Sm.
 apply le_n.
Qed.

Lemma Qpos_nR : forall p : Qpositive, Qpos (nR p) = Qplus (Qpos p) Qone.
Proof.
 intros.
 simpl in |- *.
 apply f_equal with Qpositive.
 apply what_nR_does.
Qed.

Lemma Qmult_Z_nR :
 forall (a : Z) (p : Qpositive),
 Qmult (Z_to_Q a) (Qpos (nR p)) =
 Qplus (Qmult (Z_to_Q a) (Qpos p)) (Z_to_Q a).
Proof.
 intros.
 rewrite Qpos_nR.
 ring.
Qed.

Lemma Qpos_dL :
 forall p : Qpositive,
 Qpos (dL p) = Qmult (Qpos p) (Qinv (Qplus (Qpos p) Qone)).
Proof.
 intros.
 simpl in |- *.
 apply f_equal with Qpositive.
 apply what_dL_does.
Qed.

Lemma Qmult_Z_dL :
 forall (a : Z) (p : Qpositive),
 Qmult (Z_to_Q a) (Qpos (dL p)) =
 Qmult (Qmult (Z_to_Q a) (Qpos p)) (Qinv (Qplus (Qpos p) Qone)).
Proof.
 intros.
 rewrite Qpos_dL.
 ring.
Qed.

(** mappings between Q and Z *)

Lemma length_of_Qpositive_is_length :
 forall p : positive,
 length_of_Qpositive (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p))) =
 (Zpos p - 1)%Z.
Proof.
 intro p.
 generalize (lt_O_nat_of_P p).
 rewrite <- ZL9.
 generalize (nat_of_P p).
 induction n.
 intro.
 inversion H.
 intro.
 case (le_lt_eq_dec 1 (S n) (lt_le_S _ _ H)).
 intro H1.
 rewrite (Qpositive_c_nR _ _ (S n) H1).
 transitivity (1 + length_of_Qpositive (Qpositive_c (S n - 1) 1 (S n)))%Z.
 reflexivity.
 rewrite Znat.inj_S.
 rewrite Zplus_comm.
 unfold Z.succ in |- *.
 transitivity (n - 1 + 1)%Z; [ idtac | omega ].
 apply f_equal2 with Z Z; trivial.
 rewrite <- IHn.
 apply f_equal with Qpositive.
 apply f_equal3 with nat nat nat; trivial.
 simpl in |- *; auto with arith.
 omega.
 intro H1; rewrite <- H1.
 rewrite Qpositive_c_equal_One; trivial.
Qed.

Lemma Qpositive_to_Z_is_integer_part :
 forall x : positive,
 Qpositive_to_Z (Qpositive_c (nat_of_P x) 1 (S (nat_of_P x))) = Zpos x.
Proof.
 intro p.
 generalize (lt_O_nat_of_P p).
 rewrite <- ZL9.
 generalize (nat_of_P p).
 induction n; intro H.
 inversion H.
 case (le_lt_eq_dec 1 (S n) (lt_le_S _ _ H)).
 intro H1.
 rewrite (Qpositive_c_nR _ _ (S n) H1).
 transitivity (1 + Qpositive_to_Z (Qpositive_c (S n - 1) 1 (S n)))%Z.
 reflexivity.
 rewrite Znat.inj_S.
 rewrite Zplus_comm.
 unfold Z.succ in |- *.
 apply f_equal2 with Z Z; trivial.
 rewrite <- IHn.
 apply f_equal with Qpositive.
 apply f_equal3 with nat nat nat; trivial.
 simpl in |- *; auto with arith.
 omega.
 intro H1; rewrite <- H1.
 rewrite Qpositive_c_equal_One; trivial.
Qed.

Lemma Q_to_Z_to_Q : forall x : Z, Q_to_Z (Z_to_Q x) = x.
Proof.
 intros [| x| x]; trivial; unfold Z_to_Q in |- *; unfold Q_to_Z in |- *;
  rewrite Qpositive_to_Z_is_integer_part; reflexivity.
Qed.

Lemma eq_Z_to_Q : forall x y : Z, Z_to_Q x = Z_to_Q y -> x = y.
Proof.
 intros x y H.
 generalize (f_equal Q_to_Z H).
 intro H0.
 rewrite (Q_to_Z_to_Q x) in H0.
 rewrite (Q_to_Z_to_Q y) in H0.
 assumption.
Qed.

Lemma Z_to_Qpositive_equal :
 forall (m1 m2 : Z) (Hm1 : (0 < m1)%Z) (Hm2 : (0 < m2)%Z),
 m1 = m2 -> Z_to_Qpositive m1 Hm1 = Z_to_Qpositive m2 Hm2.
Proof.
  intros m1;
  induction m1.

  discriminate Hm1.

  unfold Z_to_Qpositive.
  intros m2 H Hm2 H_eq;revert Hm2.
  rewrite <- H_eq;reflexivity.

  intros m2 m1 abs;discriminate.
Qed.

Functional Scheme Z_to_Q_ind := Induction for Z_to_Q Sort Prop.

Lemma Z_to_Qpositive_to_Q :
 forall (m : Z) (Hm : (0 < m)%Z), Z_to_Q m = Qpos (Z_to_Qpositive m Hm).
Proof.
 intros m; functional induction (Z_to_Q m); intros Hm;
            discriminate Hm || trivial.
Qed.

Lemma Qpos_injective :
 forall qp1 qp2 : Qpositive, Qpos qp1 = Qpos qp2 -> qp1 = qp2.
Proof.
 intros qp1 qp2 H; injection H; trivial.
Qed.

Lemma Qneg_injective :
 forall qp1 qp2 : Qpositive, Qneg qp1 = Qneg qp2 -> qp1 = qp2.
Proof.
 intros qp1 qp2 H; injection H; trivial.
Qed.

Lemma Q_tail_Q_pos : forall q : Q, Qlt Zero q -> q = Qpos (Q_tail q).
Proof.
 intros [| q| q]; unfold Qlt in |- *; intros H;
            inversion H || unfold Q_tail in |- *; reflexivity.
Qed.

Lemma Q_tail_Q_neg : forall q : Q, Qlt q Zero -> q = Qneg (Q_tail q).
Proof.
 intros [| q| q]; unfold Qlt in |- *; intros H;
            inversion H || unfold Q_tail in |- *; reflexivity.
Qed.

Lemma Qpositive_to_Z_nonneg : forall x : Qpositive, (0 <= Qpositive_to_Z x)%Z.
Proof.
 intros x; induction  x as [x Hrecx| x Hrecx| ];
            [ replace (Qpositive_to_Z (nR x)) with (1 + Qpositive_to_Z x)%Z;
               trivial; abstract omega
            | simpl in |- *; apply Z.le_refl
            | simpl in |- *; intro H; discriminate ].
Qed.

Functional Scheme Qpositive_le_bool_ind :=
  Induction for Qpositive_le_bool Sort Prop.

Lemma Qpositive_to_Z_Qpositive_le :
 forall x y : Qpositive,
 (Qpositive_to_Z x < Qpositive_to_Z y)%Z -> Qpositive_le x y.
Proof.
 intros x y.
 unfold Qpositive_le in |- *.
 functional induction (Qpositive_le_bool x y) ;intros;
    trivial.
 apply IHb.
 unfold Qpositive_to_Z in H;fold Qpositive_to_Z in H.
 omega.
unfold Qpositive_to_Z in H;fold Qpositive_to_Z in H;
 generalize (Qpositive_to_Z_nonneg y);intros;
 apply False_ind;omega.
unfold Qpositive_to_Z in H;fold Qpositive_to_Z in H;
 generalize (Qpositive_to_Z_nonneg y);intros;
 apply False_ind;omega.
 apply IHb.
 unfold Qpositive_to_Z in H;fold Qpositive_to_Z in H.
 omega.
 unfold Qpositive_to_Z in H;fold Qpositive_to_Z in H;discriminate.
Qed.

Lemma Q_to_Z_monotone : forall x y : Q, Qlt x y -> (Q_to_Z x <= Q_to_Z y)%Z.
Proof.
 intros x y.
 unfold Qlt in |- *.
 intro H.
 induction H; simpl in |- *; apply not_Zlt; intro H1.
 apply H; apply Qpositive_to_Z_Qpositive_le; assumption.
 generalize (Zmin_cancel_Zlt _ _ H1); intro H2; apply H;
  apply Qpositive_to_Z_Qpositive_le; assumption.
 apply Z.lt_irrefl with 0%Z; generalize (Qpositive_to_Z_nonneg x'); intro H2;
  omega.
 apply Z.lt_irrefl with 0%Z; generalize (Qpositive_to_Z_nonneg x');
  generalize (Qpositive_to_Z_nonneg y'); intros H2 H3; abstract
  omega.
 apply Z.lt_irrefl with 0%Z; generalize (Qpositive_to_Z_nonneg x'); intro H2;
  omega.
Qed.

Lemma Qlt_irreflexive : forall x : Q, ~ Qlt x x.
Proof.
 intro x; unfold Qlt in |- *; intro H; apply Qgt_antisym with x x; assumption.
Qed.

Hint Resolve Qlt_irreflexive.

Lemma Qlt_not_eq : forall x y : Q, Qlt x y -> y <> x.
Proof.
 intros x y Hxlty Hxy; rewrite Hxy in Hxlty; apply Qlt_irreflexive with x;
  assumption.
Qed.

Hint Resolve Qlt_not_eq.

Lemma Qlt_transitive : forall x y z : Q, Qlt x y -> Qlt y z -> Qlt x z.
Proof.
 intros x y z H1 H2.
 unfold Qlt in |- *.
 apply Qgt_trans with y; assumption.
Qed.

Lemma Z_to_Qopp : forall x : Z, Z_to_Q (- x) = Qopp (Z_to_Q x).
Proof.
 intros [| x| x]; trivial.
Qed.

Lemma Z_to_Qplus_POS :
 forall p1 p2 : positive,
 Z_to_Q (Zpos p1 + Zpos p2) = Qplus (Z_to_Q (Zpos p1)) (Z_to_Q (Zpos p2)).
Proof.
 intros p1 p2.
  unfold Z_to_Q at 2 3 in |- *.
  unfold Qplus in |- *.
  rewrite <- BinInt.Zpos_plus_distr.
  unfold Z_to_Q at 1 in |- *.
  apply f_equal with Qpositive.
  unfold Qpositive_plus in |- *.
  repeat rewrite Qpositive_i_c.
  repeat rewrite mult_1_l.
  repeat rewrite mult_1_r.
  apply f_equal3 with nat nat nat; trivial.
  apply nat_of_P_plus_morphism.
  rewrite nat_of_P_plus_morphism.
  omega.
  apply lt_O_nat_of_P.
  constructor.
  apply lt_O_nat_of_P.
  constructor.
Qed.

Lemma Z_to_Qplus_POS_NEG :
 forall p1 p2 : positive,
 Z_to_Q (Zpos p1 + Zneg p2) = Qplus (Z_to_Q (Zpos p1)) (Z_to_Q (Zneg p2)).
Proof.
 intros p1 p2.

  assert
   (H :
    Qplus (Z_to_Q (Zpos p1 + Zneg p2)) (Z_to_Q (Zpos p2)) = Z_to_Q (Zpos p1)).
  set (P := (Zpos p1 + Zneg p2)%Z) in *.
  assert (P = (Zpos p1 + Zneg p2)%Z); trivial.
  destruct P.
  unfold Z_to_Q at 1 in |- *.
  rewrite Qplus_zero_left.
  apply f_equal with Z.
  transitivity (- Zneg p2)%Z; trivial.
  omega.
  rewrite <- Z_to_Qplus_POS.
  apply f_equal with Z.
  replace (Zpos p2) with (- Zneg p2)%Z; trivial.
  omega.

  unfold Z_to_Q at 1 2 3 in |- *.
  assert (Hp : (Zpos p < Zpos p2)%Z).
  apply Zmin_cancel_Zlt.
  unfold Z.opp in |- *.
  rewrite H.
  rewrite <- (Zplus_0_l (Zneg p2)).
  apply Zplus_lt_compat_r.
  constructor.

  unfold Qplus in |- *.

  case
   (Qpositive_le_dec (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p)))
      (Qpositive_c (nat_of_P p2) 1 (S (nat_of_P p2))));
   intro H1.
   case
    (Qpositive_eq_dec (Qpositive_c (nat_of_P p) 1 (S (nat_of_P p)))
       (Qpositive_c (nat_of_P p2) 1 (S (nat_of_P p2))));
    intro H2.
    apply False_ind.
    generalize (f_equal Qpositive_to_Z H2).
    do 2 rewrite Qpositive_to_Z_is_integer_part.
    apply Zorder.Zlt_not_eq; assumption.

    assert (Hp' : Zpos p2 = (Zpos p1 + Zpos p)%Z).
    clear H1 H2.
    replace (Zpos p) with (- Zneg p)%Z; trivial.
    rewrite H.
    replace (Zneg p2) with (- Zpos p2)%Z; trivial.
    auto with zarith.
    rewrite <- BinInt.Zpos_plus_distr in Hp'.
    generalize (POS_resp_eq _ _ Hp').
    intro Hp2.

    apply f_equal with Qpositive.
    unfold Qpositive_sub in |- *.
    repeat rewrite Qpositive_i_c.
    repeat rewrite mult_1_l.
    repeat rewrite mult_1_r.
    clear H1 H2; apply Qpositive_c_equal_strong; trivial; try omega;
     rewrite Hp2; rewrite nat_of_P_plus_morphism.
    omega.
    replace (nat_of_P p1 + nat_of_P p - nat_of_P p) with (nat_of_P p1);
     [ apply lt_O_nat_of_P | omega ].
    apply lt_O_nat_of_P.
    constructor.
    apply lt_O_nat_of_P.
    constructor.

   apply False_ind; apply H1.
   apply Qpositive_to_Z_Qpositive_le.
   do 2 rewrite Qpositive_to_Z_is_integer_part.
   assumption.

 rewrite <- H.
 replace (Zneg p2) with (- Zpos p2)%Z; trivial.
 rewrite Z_to_Qopp.
 ring.
Qed.

Lemma Z_to_Qplus_NEG :
 forall p1 p2 : positive,
 Z_to_Q (Zneg p1 + Zneg p2) = Qplus (Z_to_Q (Zneg p1)) (Z_to_Q (Zneg p2)).
Proof.
 intros p1 p2.
 replace (Zneg p1) with (- Zpos p1)%Z; trivial.
 replace (Zneg p2) with (- Zpos p2)%Z; trivial.
 rewrite <- Zopp_plus_distr.
 repeat rewrite Z_to_Qopp.
 rewrite Z_to_Qplus_POS.
 ring.
Qed.

Lemma Z_to_Qplus :
 forall x y : Z, Z_to_Q (x + y) = Qplus (Z_to_Q x) (Z_to_Q y).
Proof.
 intros [| x| x] [| y| y]; trivial;
  [ apply Z_to_Qplus_POS
  | apply Z_to_Qplus_POS_NEG
  | rewrite Zplus_comm; rewrite Qplus_sym; apply Z_to_Qplus_POS_NEG
  | apply Z_to_Qplus_NEG ].
Qed.

Lemma Z_to_Qminus :
 forall x y : Z, Z_to_Q (x - y) = Qminus (Z_to_Q x) (Z_to_Q y).
Proof.
 intros x y.
 unfold Zminus in |- *.
 rewrite Z_to_Qplus.
 rewrite Z_to_Qopp.
 reflexivity.
Qed.

Lemma Z_to_Qmult_POS :
 forall p1 p2 : positive,
 Z_to_Q (Zpos p1 * Zpos p2) = Qmult (Z_to_Q (Zpos p1)) (Z_to_Q (Zpos p2)).
Proof.
 intros p1 p2.
 unfold Z_to_Q at 2 3 in |- *.
 unfold Qmult in |- *.
 replace (Zpos p1 * Zpos p2)%Z with (Zpos (p1 * p2)); trivial.
 unfold Z_to_Q at 1 in |- *.
 apply f_equal with Qpositive.
 unfold Qpositive_mult in |- *.
 repeat rewrite Qpositive_i_c.
 repeat rewrite mult_1_l.
 apply f_equal3 with nat nat nat; trivial.
 apply nat_of_P_mult_morphism.
 rewrite nat_of_P_mult_morphism.
 omega.
 apply lt_O_nat_of_P.
 constructor.
 apply lt_O_nat_of_P.
 constructor.
Qed.

Lemma Z_to_Qmult_POS_NEG :
 forall p1 p2 : positive,
 Z_to_Q (Zpos p1 * Zneg p2) = Qmult (Z_to_Q (Zpos p1)) (Z_to_Q (Zneg p2)).
Proof.
 intros p1 p2.
 unfold Z_to_Q at 2 3 in |- *.
 unfold Qmult in |- *.
 replace (Zpos p1 * Zneg p2)%Z with (Zneg (p1 * p2)); trivial.
 unfold Z_to_Q at 1 in |- *.
 apply f_equal with Qpositive.
 unfold Qpositive_mult in |- *.
 repeat rewrite Qpositive_i_c.
 repeat rewrite mult_1_l.
 apply f_equal3 with nat nat nat; trivial.
 apply nat_of_P_mult_morphism.
 rewrite nat_of_P_mult_morphism.
 omega.
 apply lt_O_nat_of_P.
 constructor.
 apply lt_O_nat_of_P.
 constructor.
Qed.

Lemma Z_to_Qmult_NEG :
 forall p1 p2 : positive,
 Z_to_Q (Zneg p1 * Zneg p2) = Qmult (Z_to_Q (Zneg p1)) (Z_to_Q (Zneg p2)).
Proof.
 intros p1 p2.
 unfold Z_to_Q at 2 3 in |- *.
 unfold Qmult in |- *.
 replace (Zneg p1 * Zneg p2)%Z with (Zpos (p1 * p2)); trivial.
 unfold Z_to_Q at 1 in |- *.
 apply f_equal with Qpositive.
 unfold Qpositive_mult in |- *.
 repeat rewrite Qpositive_i_c.
 repeat rewrite mult_1_l.
 apply f_equal3 with nat nat nat; trivial.
 apply nat_of_P_mult_morphism.
 rewrite nat_of_P_mult_morphism.
 omega.
 apply lt_O_nat_of_P.
 constructor.
 apply lt_O_nat_of_P.
 constructor.
Qed.

Lemma Z_to_Qmult :
 forall x y : Z, Z_to_Q (x * y) = Qmult (Z_to_Q x) (Z_to_Q y).
Proof.
 intros [| x| x] [| y| y]; trivial;
  [ apply Z_to_Qmult_POS
  | apply Z_to_Qmult_POS_NEG
  | rewrite Zmult_comm; rewrite Qmult_sym; apply Z_to_Qmult_POS_NEG
  | apply Z_to_Qmult_NEG ].
Qed.

Lemma Z_to_Q_S:forall k, Z_to_Q (Z_of_nat (S k))=Qplus k Qone.
Proof.
 induction k; trivial.
 rewrite inj_S; unfold Z.succ; rewrite Z_to_Qplus; rewrite IHk;
 unfold Z_to_Q at 2; simpl; fold Qone; ring.
Qed.

Lemma Z_to_Q_min_one:Z_to_Q (-1)%Z= Qopp Qone.
Proof.
 reflexivity.
Qed.

Lemma Qlt_Zero_Qminus : forall x y : Q, Qlt Zero (Qminus y x) -> Qlt x y.
Proof.
 intros x y H; replace x with (Qplus x Zero); [ idtac | ring ];
            replace y with (Qplus x (Qminus y x));
            [ idtac | ring ]; unfold Qlt in |- *; apply Qgt_plus;
            assumption.
Qed.

Lemma Z_to_Qlt : forall x y : Z, (x < y)%Z -> Qlt x y.
Proof.
 intros x y H.
 apply Qlt_Zero_Qminus.
 generalize (Z.lt_gt _ _ H); clear H; intro H.
 case (Zcompare_Gt_spec _ _ H).
 intros p Hp.
 rewrite <- Z_to_Qminus.
 unfold Zminus in |- *.
 rewrite Hp.
 unfold Z_to_Q in |- *.
 apply Qlt_zero_pos.
Qed.

Lemma lt_Z_to_Q : forall x y : Z, Qlt (Z_to_Q x) (Z_to_Q y) -> (x < y)%Z.
Proof.
 intros x y H.
 case (Z_dec' x y).
 intros [H1| H1]; trivial.
 apply False_ind.
 apply Qlt_irreflexive with x.
 apply Qlt_transitive with y; trivial.
 apply Z_to_Qlt; assumption.
 intro H1.
 apply False_ind.
 rewrite H1 in H.
 generalize H.
 apply Qlt_irreflexive.
Qed.

Lemma pos_Z_to_Q : forall x : Z, Qlt Zero (Z_to_Q x) -> (0 < x)%Z.
Proof.
 intros x H.
 apply lt_Z_to_Q; assumption.
Qed.

Lemma neg_Z_to_Q : forall x : Z, Qlt (Z_to_Q x) Zero -> (x < 0)%Z.
Proof.
 intros x H.
 apply lt_Z_to_Q; assumption.
Qed.

Lemma Qlt_le_weak : forall x y : Q, Qlt x y -> Qle x y.
Proof.
 intros x y H.
 unfold Qle in |- *.
 intro H2; apply Qlt_irreflexive with x; apply Qlt_transitive with y;
  assumption.
Qed.

Lemma Z_to_Qle : forall x y : Z, (x <= y)%Z -> Qle x y.
Proof.
 intros x y H.
 case (Z_le_lt_eq_dec _ _ H); intro H1.
 apply Qlt_le_weak; apply Z_to_Qlt; assumption.
 rewrite H1; unfold Qle in |- *; apply Qlt_irreflexive.
Qed.

Lemma Z_to_Q_pos : forall x : Z, (0 < x)%Z -> Qlt Zero x.
Proof.
 intros x H.
 replace Zero with (Z_to_Q 0); trivial.
 apply Z_to_Qlt; assumption.
Qed.

Lemma Z_to_Q_neg : forall x : Z, (x < 0)%Z -> Qlt x Zero.
Proof.
 intros x H.
 replace Zero with (Z_to_Q 0); trivial.
 apply Z_to_Qlt; assumption.
Qed.

Lemma Z_to_Q_nonneg : forall x : Z, (0 <= x)%Z -> Qle Zero x.
Proof.
 intros x H.
 replace Zero with (Z_to_Q 0); trivial.
 apply Z_to_Qle; assumption.
Qed.

Lemma Z_to_Q_nonpos : forall x : Z, (x <= 0)%Z -> Qle x Zero.
Proof.
 intros x H.
 replace Zero with (Z_to_Q 0); trivial.
 apply Z_to_Qle; assumption.
Qed.

Lemma Z_to_Q_not_eq : forall a b : Z, a <> b -> Z_to_Q a <> Z_to_Q b.
Proof.
 intros a b Hab HabQ; apply Hab; apply eq_Z_to_Q; assumption.
Qed.

Lemma Qmult_Z_plus_Z_dL :
 forall (a b : Z) (p : Qpositive),
 Qplus (Qmult (Z_to_Q a) (Qpos (dL p))) (Z_to_Q b) =
 Qmult (Qplus (Qmult (Z_to_Q (a + b)) (Qpos p)) (Z_to_Q b))
   (Qinv (Qplus (Qpos p) Qone)).
Proof.
 intros; rewrite Qmult_Z_dL.
 rewrite Z_to_Qplus; field; discriminate.
Qed.

Lemma Qinv_0 : forall q : Q, Qinv q = Zero -> q = Zero.
Proof.
 intros [| qp | qp ] Hqp; try trivial; discriminate Hqp.
Qed.

Lemma Qmult_resp_nonzero :
 forall x y : Q, x <> Zero -> y <> Zero -> Qmult x y <> Zero.
Proof.
 intros x y Hx Hy Hxy; generalize (Q_integral _ _ Hxy); intros [H| H];
  [ apply Hx | apply Hy ]; assumption.
Qed.

Hint Resolve Qmult_resp_nonzero.

Lemma Qlt_mult_pos_pos :
 forall x y : Q, Qlt Zero x -> Qlt Zero y -> Qlt Zero (Qmult x y).
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; simpl in |- *;
            auto with *; [ inversion Hy | inversion Hx ].
Qed.

Lemma Qlt_mult_neg_pos :
 forall x y : Q, Qlt x Zero -> Qlt Zero y -> Qlt (Qmult x y) Zero.
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; simpl in |- *;
            auto with *; [ inversion Hx | inversion Hy ].
Qed.

Hint Resolve Qlt_mult_pos_pos Qlt_mult_neg_pos.

Lemma Qlt_plus_pos_pos :
 forall x y : Q, Qlt Zero x -> Qlt Zero y -> Qlt Zero (Qplus x y).
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; simpl in |- *;
            auto with *; [ inversion Hy | inversion Hx | inversion Hx ].
Qed.

Hint Resolve Qlt_plus_pos_pos.

(** This lemma also holds for q2=Zero, due to our definition of (Qinv Zero):=Zero,
    Perhaps it is not right to state it like this but anyways it is true *)
Lemma Qdiv_num_denom :
 forall q1 q2 p : Q,
 p <> Zero -> Qmult q1 (Qinv q2) = Qmult (Qmult q1 p) (Qinv (Qmult q2 p)).
Proof.
intros q1 [| qp| qp] p Hp;
 (simpl in |- *; ring) || (field; split; discriminate || assumption).
Qed.

Lemma Qinv_1 : forall q : Q, Qlt Zero (Qinv q) -> Qlt Zero q.
Proof.
 intros [| q| q] Hq; trivial; inversion Hq.
Qed.

Lemma Qinv_2 : forall q : Q, Qlt (Qinv q) Zero -> Qlt q Zero.
Proof.
 intros [| q| q] Hq; trivial; inversion Hq.
Qed.

Lemma Qinv_pos : forall q : Q, Qlt Zero q -> Qlt Zero (Qinv q).
Proof.
 intros [| q| q] Hq; simpl in |- *; trivial; inversion Hq.
Qed.

Lemma Qmult_one_right : forall x : Q, Qmult x Qone = x.
Proof.
 intro q; rewrite Qmult_sym; apply Qmult_one_left.
Qed.

Lemma Qpos_POS_1 :
 forall (m : Z) (qp : Qpositive), Z_to_Q m = Qpos qp -> (0 < m)%Z.
Proof.
 intros m qp Hm; apply pos_Z_to_Q; rewrite Hm; apply Qlt_zero_pos.
Qed.

Lemma Qneg_NEG_1 :
 forall (m : Z) (qp : Qpositive), Z_to_Q m = Qneg qp -> (m < 0)%Z.
Proof.
 intros m qp Hm; apply neg_Z_to_Q; rewrite Hm; apply Qlt_neg_zero.
Qed.

Lemma Qopp_Qpos : forall q : Qpositive, Qneg q = Qopp (Qpos q).
Proof.
 trivial.
Qed.

Lemma Qopp_Qneg : forall q : Qpositive, Qpos q = Qopp (Qneg q).
Proof.
 trivial.
Qed.

Lemma Qopp_linear :
 forall (a b : Z) (q : Qpositive),
 Qplus (Qmult (Z_to_Q (- a)) (Qpos q)) (Z_to_Q (- b)) =
 Qopp (Qplus (Qmult (Z_to_Q a) (Qpos q)) (Z_to_Q b)).
Proof.
 intros a b q; repeat rewrite Zopp_eq_mult_neg_1;
            repeat rewrite Z_to_Qmult; repeat rewrite <- Qmult_assoc;
            rewrite (Qmult_sym (-1)%Z); repeat rewrite Qmult_assoc;
            repeat rewrite <- Q_distr_left;
            replace (Z_to_Q (-1)) with (Qopp Qone);
            [ ring | reflexivity ].
Qed.

Lemma Qopp_resp_nonzero : forall x : Q, x <> Zero -> Qopp x <> Zero.
Proof.
 intros [| qx| qx] H; discriminate || Falsum.
Qed.

(** This also holds for q=Zero so we don't exclude that case *)
Lemma Qinv_Qopp : forall q : Q, Qinv (Qopp q) = Qopp (Qinv q).
Proof.
 intros [| q| q]; reflexivity.
Qed.

Lemma Qmult_Qopp_left : forall x y : Q, Qmult (Qopp x) y = Qopp (Qmult x y).
Proof.
 intros [| qx| qx] [| qy| qy]; reflexivity.
Qed.

Lemma Qpositive_dec_One : forall p : Qpositive, {p = One} + {p <> One}.
Proof.
 intro p; exact (Qpositive_eq_dec p One).
Defined.

Lemma Q_zerop : forall x : Q, {x = Zero} + {x <> Zero}.
Proof.
 intros [| px| px]; solve [ left; trivial | right; discriminate ].
Qed.

Lemma Qinv_resp_nonzero : forall x : Q, x <> Zero -> Qinv x <> Zero.
Proof.
 intros [| px| px] Hx; solve [ Falsum | discriminate ].
Qed.

Lemma Qlt_zero_one : Qlt Zero Qone.
Proof.
 unfold Qone in |- *; apply Qlt_zero_pos.
Qed.

Hint Resolve Qlt_zero_one.

Lemma Z_to_Qpositive_Q_tail_pos :
 forall (a : Z) (Ha : (0 < a)%Z), Z_to_Qpositive a Ha = Q_tail a.
Proof.
 intros [| px| px] Hx; discriminate Hx || reflexivity.
Qed.

Lemma Q_tail_Qinv : forall x : Q, Q_tail (Qinv x) = Qpositive_inv (Q_tail x).
Proof.
 intros [| px| px]; trivial.
Qed.

Lemma Q_tail_Qmult :
 forall x y : Q,
 x <> Zero ->
 y <> Zero -> Q_tail (Qmult x y) = Qpositive_mult (Q_tail x) (Q_tail y).
Proof.
 intros [| px| px] [| py| py] Hx Hy; trivial; Falsum.
Qed.

Lemma Q_tail_Qplus_pos :
 forall x y : Q,
 Qlt Zero x ->
 Qlt Zero y -> Q_tail (Qplus x y) = Qpositive_plus (Q_tail x) (Q_tail y).
Proof.
 intros [| px| px] [| py| py] Hx Hy; trivial; solve
            [ inversion Hx | inversion Hy ].
Qed.

Lemma Q_tail_Qplus_neg :
 forall x y : Q,
 Qlt x Zero ->
 Qlt y Zero -> Q_tail (Qplus x y) = Qpositive_plus (Q_tail x) (Q_tail y).
Proof.
 intros [| px| px] [| py| py] Hx Hy; trivial; solve
            [ inversion Hx | inversion Hy ].
Qed.

Lemma Qplus_zero_right : forall n : Q, Qplus n Zero = n.
Proof.
 intros; field.
Qed.

Lemma Qmult_zero_right : forall x : Q, Qmult x Zero = Zero.
Proof.
 intros; field.
Qed.

Lemma Qle_Qpositive_le_pos :
 forall x y : Qpositive, Qle (Qpos x) (Qpos y) -> Qpositive_le x y.
Proof.
 intros x y H.
 case (Qpositive_le_dec x y); intros H1; trivial; apply False_ind; apply H;
  constructor; assumption.
Qed.

Lemma Qle_Qpositive_le_neg :
 forall x y : Qpositive, Qle (Qneg x) (Qneg y) -> Qpositive_le y x.
Proof.
 intros x y H.
 case (Qpositive_le_dec y x); intros H1; trivial; apply False_ind; apply H;
  constructor; assumption.
Qed.

Lemma Qle_lt_eq_dec : forall x y : Q, Qle x y -> {Qlt x y} + {x = y}.
Proof.
 intros [| x| x] [| y| y] Hxy;
  try solve
   [ right; reflexivity
   | left; auto with *
   | right; auto with *
   | apply False_rec; apply Hxy; auto with * ];
  [ generalize (Qle_Qpositive_le_pos _ _ Hxy)
  | generalize (Qle_Qpositive_le_neg _ _ Hxy) ]; clear Hxy;
  intro Hxy;
  match goal with
  | id1:(Qpositive_le ?X1 ?X2) |- _ =>
      case (Qpositive_le_dec X2 X1); intro H;
       [ right; apply f_equal with Qpositive; apply Qpositive_le_antisym;
          assumption
       | left; constructor; assumption ]
  end.
Qed.

Lemma Qle_lt_trans : forall x y z : Q, Qle x y -> Qlt y z -> Qlt x z.
Proof.
 intros [| x| x] [| y| y] [| z| z] Hxy Hyz; trivial; try QltCleanAbsurdCases;
  case (Qle_lt_eq_dec _ _ Hxy); intro Hxy';
  [ apply Qlt_transitive with (Qpos y)
  | rewrite Hxy'
  | apply Qlt_transitive with (Qneg y)
  | rewrite Hxy' ]; assumption.
Qed.

Lemma Qlt_le_trans : forall x y z : Q, Qlt x y -> Qle y z -> Qlt x z.
Proof.
 intros [| x| x] [| y| y] [| z| z] Hxy Hyz; trivial; try QltCleanAbsurdCases;
  case (Qle_lt_eq_dec _ _ Hyz); intro Hyz';
  [ apply Qlt_transitive with (Qpos y)
  | rewrite <- Hyz'
  | apply Qlt_transitive with (Qneg y)
  | rewrite <- Hyz' ]; assumption.
Qed.

Lemma Qle_trans : forall x y z : Q, Qle x y -> Qle y z -> Qle x z.
Proof.
 intros x y z Hxy Hyz Hxz; apply Hyz; apply Qlt_le_trans with x; assumption.
Qed.

Lemma Qlt_plus_plus :
 forall a b c d : Q, Qlt a b -> Qlt c d -> Qlt (Qplus a c) (Qplus b d).
Proof.
 intros a b c d Hab Hcd.
 apply Qlt_transitive with (Qplus b c); unfold Qlt in |- *;
  [ rewrite (Qplus_sym a); rewrite (Qplus_sym b) | idtac ];
  apply Qgt_plus; assumption.
Qed.

Lemma Qle_lt_reg :
 forall a b c d : Q, Qle a b -> Qlt c d -> Qlt (Qplus a c) (Qplus b d).
Proof.
 intros a b c d Hab Hcd.
 case (Qle_lt_eq_dec _ _ Hab); intro Hab';
  [ apply Qlt_plus_plus | rewrite Hab'; unfold Qlt in |- *; apply Qgt_plus ];
  assumption.
Qed.

Lemma Qlt_le_reg :
 forall a b c d : Q, Qlt a b -> Qle c d -> Qlt (Qplus a c) (Qplus b d).
Proof.
 intros a b c d Hab Hcd; rewrite (Qplus_sym a); rewrite (Qplus_sym b);
  apply Qle_lt_reg; assumption.
Qed.

Lemma Qlt_le_reg_pos :
 forall b d : Q, Qlt Zero b -> Qle Zero d -> Qlt Zero (Qplus b d).
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qlt_le_reg; assumption.
Qed.

Lemma Qle_lt_reg_pos :
 forall b d : Q, Qle Zero b -> Qlt Zero d -> Qlt Zero (Qplus b d).
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qle_lt_reg; assumption.
Qed.

Lemma Qlt_le_reg_neg :
 forall b d : Q, Qlt b Zero -> Qle d Zero -> Qlt (Qplus b d) Zero.
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qlt_le_reg; assumption.
Qed.

Lemma Qle_lt_reg_neg :
 forall b d : Q, Qle b Zero -> Qlt d Zero -> Qlt (Qplus b d) Zero.
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qle_lt_reg; assumption.
Qed.

Lemma Qle_plus_plus :
 forall a b c d : Q, Qle a b -> Qle c d -> Qle (Qplus a c) (Qplus b d).
Proof.
 intros a b c d Hab Hcd.
 apply Qle_trans with (Qplus b c); unfold Qlt in |- *;
  [ rewrite (Qplus_sym a); rewrite (Qplus_sym b) | idtac ];
  [ case (Qle_lt_eq_dec _ _ Hab) | case (Qle_lt_eq_dec _ _ Hcd) ];
  intro H_;
  [ apply Qlt_le_weak; apply Qle_lt_reg;
     [ unfold Qle in |- *; apply Qlt_irreflexive | assumption ]
  | rewrite H_; unfold Qle in |- *; apply Qlt_irreflexive
  | apply Qlt_le_weak; apply Qle_lt_reg;
     [ unfold Qle in |- *; apply Qlt_irreflexive | assumption ]
  | rewrite H_; unfold Qle in |- *; apply Qlt_irreflexive ].
Qed.

Lemma Qle_plus_pos_pos :
 forall x y : Q, Qle Zero x -> Qle Zero y -> Qle Zero (Qplus x y).
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qle_plus_plus; assumption.
Qed.

Lemma Qle_plus_neg_neg :
 forall x y : Q, Qle x Zero -> Qle y Zero -> Qle (Qplus x y) Zero.
Proof.
 intros b d Hb Hd; replace Zero with (Qplus Zero Zero); trivial;
  apply Qle_plus_plus; assumption.
Qed.

Lemma Qle_mult_nonneg_nonneg :
 forall x y : Q, Qle Zero x -> Qle Zero y -> Qle Zero (Qmult x y).
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; try QltCleanAbsurdCases;
  simpl in |- *; intro H_; inversion H_.
Qed.

Lemma Qle_mult_nonpos_nonneg :
 forall x y : Q, Qle x Zero -> Qle Zero y -> Qle (Qmult x y) Zero.
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; try QltCleanAbsurdCases;
  simpl in |- *; intro H_; inversion H_.
Qed.

Lemma Qle_mult_nonneg_nonpos :
 forall x y : Q, Qle Zero x -> Qle y Zero -> Qle (Qmult x y) Zero.
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; try QltCleanAbsurdCases;
  simpl in |- *; intro H_; inversion H_.
Qed.

Lemma Qle_mult_nonpos_pos:
 forall x y : Q, Qle x Zero -> Qlt Zero y -> Qle (Qmult x y) Zero.
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; try QltCleanAbsurdCases;
  simpl in |- *; intro H_; inversion H_.
Qed.

Lemma Qle_mult_neg_nonneg :
 forall x y : Q, Qlt x Zero -> Qle Zero y -> Qle (Qmult x y) Zero.
Proof.
 intros [| x| x] [| y| y] Hx Hy; trivial; try QltCleanAbsurdCases;
  simpl in |- *; intro H_; inversion H_.
Qed.

Lemma Qle_reflexive:forall x, Qle x x.
Proof.
 intro x; unfold Qle; apply Qlt_irreflexive.
Qed.

Hint Resolve Qplus_zero_right Qlt_le_reg_pos Qle_lt_reg_pos Qlt_le_reg
  Qle_lt_reg Qlt_le_weak Qlt_le_reg_neg Qle_lt_reg_neg Qle_plus_pos_pos
  Qle_plus_neg_neg Qle_mult_nonneg_nonneg Qle_mult_nonneg_nonpos
  Qle_mult_nonpos_nonneg Qle_mult_nonpos_pos Qle_mult_neg_nonneg
  Qle_reflexive.

Lemma Qpos_not_lt_Zero : forall x, ~ Qlt (Qpos x) Zero.
Proof.
intros x Hc; apply (Qlt_irreflexive Zero); apply Qlt_transitive with (Qpos x);trivial.
Qed.

Lemma Qlt_dec_Qpos : forall x y, {~ Qlt (Qpos y) (Qpos x)} + {Qlt (Qpos y) (Qpos x)}.
  intros x y; case Qpositive_le_dec with x y; intro H'; [left;intro H; inversion H; contradiction | right;unfold Qlt; constructor; trivial].
Qed.

Lemma Zero_not_lt_Qneg : forall x, ~ Qlt Zero (Qneg x).
Proof.
intros x Hc; apply (Qlt_irreflexive Zero); apply Qlt_transitive with (Qneg x);trivial.
Qed.

Lemma Qpos_not_lt_Qneg : forall x y, ~ Qlt (Qpos y) (Qneg x).
Proof.
intros x y Hc; apply (Qlt_irreflexive (Qneg x)); apply Qlt_transitive with (Qpos y); trivial.
Qed.

Lemma Qlt_dec_Qneg : forall x y, {~ Qlt (Qneg y) (Qneg x)} + {Qlt (Qneg y) (Qneg x)}.
Proof.
intros x y; case Qpositive_le_dec with y x; intro H'; [left;intro H; inversion H; contradiction | right;unfold Qlt; constructor; trivial].
Qed.

Lemma Q_le_lt_dec:forall (x y:Q), {Qle x y}+{Qlt y x}.
Proof.
  intros [|x|x] [|y|y]; unfold Qle; try (right; trivial || fail).
  left; apply Qlt_irreflexive.
  left; apply Qpos_not_lt_Zero.
  apply Qlt_dec_Qpos.
  left; apply Zero_not_lt_Qneg.
  left; apply Qpos_not_lt_Qneg.
  apply Qlt_dec_Qneg.
Qed.

Lemma Qle_dec:forall (x y:Q), {Qle x y}+{~(Qle x y)}.
Proof.
 intros x y.
 case (Q_le_lt_dec x y);
 intros; [ left | right ] ; trivial.
 intros H'; apply H'; trivial.
Qed.

Lemma Qlt_dec:forall (x y:Q), {Qlt x y}+{~(Qlt x y)}.
Proof.
 intros x y.
 case (Q_le_lt_dec y x);
 intros; [ right | left ] ; trivial.
Qed.

Lemma Qtrichotomy_inf:forall x y,{Qlt x y}+{x=y}+{Qlt y x}.
Proof.
 intros x y.
 case (Q_le_lt_dec x y); intros H;
 [ case (Qle_lt_eq_dec x y H); intros H0; left;[left|right]
 | right
 ]; trivial.
Qed.

Lemma Qle_dec_weak:forall (x y:Q), {Qle x y}+{(Qle y x)}.
Proof.
 intros x y; case (Q_le_lt_dec x y); intros; [ left | right ] ; trivial; apply Qlt_le_weak; trivial.
Qed.

Lemma not_Qeq_inf : forall x y : Q, x <> y -> {Qlt x y} + {Qlt y x}.
Proof.
 intros x y Hxy; destruct (Q_le_lt_dec x y) as [H|H]; try tauto;
 left; destruct (Qle_lt_eq_dec _ _ H) as [H'|H']; trivial; contradiction.
Qed.

Lemma Qlt_stepl:forall x y z, Qlt x y -> x=z -> Qlt z y.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Lemma Qlt_stepr:forall x y z, Qlt x y -> y=z -> Qlt x z.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Lemma Qle_stepl:forall x y z, Qle x y -> x=z -> Qle z y.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Lemma Qle_stepr:forall x y z, Qle x y -> y=z -> Qle x z.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Lemma Qneq_stepl:forall (x y z:Q), x<>y -> x=z -> z<>y.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Lemma Qneq_stepr:forall (x y z:Q), x<>y -> y=z -> x<>z.
Proof.
 intros x y z H_lt H_eq; subst; assumption.
Qed.

Declare Left Step Qlt_stepl.
Declare Right Step Qlt_stepr.
Declare Left Step Qle_stepl.
Declare Right Step Qle_stepr.
Declare Left Step Qneq_stepl.
Declare Right Step Qneq_stepr.

(** Properties of Qsgn *)

Lemma Qsgn_1: forall x:Q,{(Qsgn x) = 0}+{(Qsgn x) = 1}+{(Qsgn x) = (-1)%Z}.
Proof.
 intros [|x|x]; simpl; auto.
Qed.

Lemma Qsgn_2 : forall x : Q, Qsgn x = 0%Z -> x = Zero.
Proof.
 intros [| x| x] Hx; trivial; inversion Hx.
Qed.

Lemma Qsgn_7 : forall x : Q, Qlt Zero x -> Qsgn x = 1%Z.
Proof.
 intros [| x| x] Hx; trivial; inversion Hx.
Qed.

Lemma Qsgn_8 : forall x : Q, Qlt x Zero -> Qsgn x = (-1)%Z.
Proof.
 intros [| x| x] Hx; trivial; inversion Hx.
Qed.

Lemma Qsgn_9 : forall x : Q, Qsgn x = 1%Z -> Qlt Zero x.
Proof.
 intros [| x| x] Hx; trivial; inversion Hx.
Qed.

Lemma Qsgn_10 : forall x : Q, Qsgn x = (-1)%Z -> Qlt x Zero.
Proof.
 intros [| x| x] Hx; trivial; inversion Hx.
Qed.

Lemma Qsgn_15 : forall x y : Q, Qsgn (Qmult x y) = (Qsgn x * Qsgn y)%Z.
Proof.
 intros [| x| x] [| y| y]; trivial.
Qed.

Lemma Qsgn_25 : forall x : Q, Qsgn (Qopp x) = (- Qsgn x)%Z.
Proof.
 intros [| x| x]; trivial.
Qed.

Lemma Qsgn_28 : forall x : Q, Qsgn (Qinv x) = Qsgn x.
Proof.
 intros [| x| x]; trivial.
Qed.

Lemma Qsgn_29 : forall x : Z, Qsgn (Z_to_Q x) = Z.sgn x.
Proof.
 intros [| x| x]; trivial.
Qed.

Lemma Qsgn_30 : forall x y : Q, Qsgn (Qdiv x y) = (Qsgn x * Qsgn y)%Z.
Proof.
 intros [| x| x] [| y| y]; trivial.
Qed.

Lemma Qsgn_31:forall x:Q, Qle x Zero-> Qsgn x <> 1.
Proof.
 intros [|x|x] Hx; try discriminate; apply False_ind; apply Hx; apply Qlt_zero_pos.
Qed.

Lemma Qsgn_32:forall x:Q, Qsgn x <> 1 -> Qle x  Zero.
Proof.
 intros [|x|x] Hx; auto; try apply Qle_reflexive; apply False_ind; apply Hx; reflexivity.
Qed.

Lemma Qsgn_33:forall x:Q, Qle Zero x -> Qsgn x <> (-1)%Z.
Proof.
 intros [|x|x] Hx; try discriminate; apply False_ind; apply Hx; auto.
Qed.

Lemma Qsgn_34:forall x:Q, Qsgn x <> (-1)%Z -> Qle Zero x.
Proof.
 intros [|x|x] Hx; auto; try apply Qle_reflexive; apply False_ind; apply Hx; reflexivity.
Qed.

Hint Resolve Qsgn_2 Qsgn_7 Qsgn_8 Qsgn_9 Qsgn_10 Qsgn_15 Qsgn_25 Qsgn_28
  Qsgn_29 Qsgn_30.

(* Not all of these properties are necessary at the moment. We Uncomment one any time we need it *)
(* Axiom Qsgn_3: (x:Q)~x=Zero->`(Qsgn x) <> 0`. *)
(* Axiom Qsgn_5: (a,b,x,y:Q)~x= Zero->~y=Zero->(Qmult (Qsgn a) x) = (Qmult (Qsgn b) y)->(Qmult (Qsgn a) y) =(Qmult (Qsgn b) x). *)
(* Axiom Qsgn_6: (x:Q)x = Zero->`(Qsgn x) = 0`. *)
(* Axiom Qsgn_11: (x:Q)`(Qsgn x) < 0`->(Qlt x Zero). *)
(* Axiom Qsgn_12: (x:Q)`0 < (Qsgn x)`->(Qlt Zero x). *)
(* Axiom Qsgn_13: (x:Q)`0 <= (Qsgn x)`->(Qle Zero  x). *)
(* Axiom Qsgn_14: (x:Q)`(Qsgn x) <= 0`->(Qle x Zero). *)
(* Axiom Qsgn_16:(x,y:Q)`(Qsgn (Qmult x y)) = 1`->{(Qlt Zero x)/\(Qlt Zero y)}+{(Qlt x Zero)/\(Qlt y Zero)}. *)
(* Axiom Qsgn_17: (x,y:Q)`(Qsgn (Qmult x y)) = (-1)`->{(Qlt Zero x)/\(Qlt y Zero)}+{(Qlt x Zero)/\(Qlt Zero y)}. *)
(* Axiom Qsgn_18: (x,y:Q)`(Qsgn (Qmult x y)) = 0`->{x = Zero}+{y = Zero}. *)
(* Axiom Qsgn_19: (x,y:Q)`0 < (Qsgn x)+(Qsgn y)`->(Qlt Zero (Qplus x y)). *)
(* Axiom Qsgn_20: (x,y:Q)`(Qsgn x)+(Qsgn y) < 0`->(Qlt (Qplus x y) Zero). *)
(* Axiom Qsgn_21: (x,y:Q)`0 < (Qsgn x)+(Qsgn y)`->(Qle Zero x). *)
(* Axiom Qsgn_22: (x,y:Q)`(Qsgn x)+(Qsgn y) < 0`->(Qle x Zero). *)
(* Axiom Qsgn_23: (x,y:Q)`0 < (Qsgn x)+(Qsgn y)`->(Qle Zero y). *)
(* Axiom Qsgn_24: (x,y:Q)`(Qsgn x)+(Qsgn y) < 0`->(Qle y Zero). *)
(* Axiom Qsgn_26: (x:Q)(Qlt Zero x)->`0 < (Qsgn x)`. *)
(* Axiom Qsgn_27: (x:Q)(Qlt x Zero)->`(Qsgn x) < 0`. *)

Ltac qnat_zero :=  replace (Z_to_Q (Z_of_nat 0)) with Zero;  trivial.
Ltac natq_zero :=  replace Zero with (Z_to_Q (Z_of_nat 0));  trivial.
Ltac qnat_one :=  replace (Z_to_Q (Z_of_nat (S 0))) with Qone;  trivial.
Ltac natq_one :=  replace Qone with (Z_to_Q (Z_of_nat (S 0)));  trivial.
Ltac qnat_S k :=  replace (Z_to_Q (Z_of_nat (S k))) with (Qplus k Qone); [idtac | rewrite Z_to_Q_S; trivial].
Ltac natq_S k :=  try qnat_one; replace (Qplus k Qone) with (Z_to_Q (Z_of_nat (S k))); [idtac | rewrite <- Z_to_Q_S; trivial].
Ltac qnat_S_rec k :=
             try qnat_one; replace (Qplus k Qone) with (Z_to_Q (Z_of_nat (S k))); [idtac | rewrite <- Z_to_Q_S; trivial];
             try qnat_S_rec (k-1).

Ltac natZ_numerals  :=
 match goal with
 | [ |- context [Z0] ] => replace Z0 with (Z_of_nat O); trivial; natZ_numerals
 | [ |- context [(Zpos ?X1)] ] => let v:= eval compute in (Z.abs_nat (Z.pred (Zpos X1))) in
         replace (Zpos X1) with (Z_of_nat (S v)); trivial; natZ_numerals
 | [ |- context [(Zneg ?X1)] ] => let v:= eval compute in (Z.abs_nat (Z.succ (Zpos X1))) in
         replace (Zneg X1) with (Z.opp (Z_of_nat (S v))); trivial; natZ_numerals
 | [ |- _ ] => idtac
 end.


From isla Require Import opsem.

Definition a18278 : isla_trace :=
  Smt (DeclareConst 37%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 37%Z)) Mk_annot :t:
  Smt (DefineConst 40%Z (Manyop (Bvmanyarith Bvadd) [Manyop (Bvmanyarith Bvor) [Manyop (Bvmanyarith Bvand) [Val (Val_Symbolic 37%Z) Mk_annot; Val (Val_Bits (BV 64%N 0xfffffffffffff000%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 64%N 0x4000%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R5" [] (RegVal_Base (Val_Symbolic 40%Z)) Mk_annot :t:
  Smt (DefineConst 41%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 37%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 41%Z)) Mk_annot :t:
  tnil
.