(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*i $Id$ i*)
(** * Normalisation functions for rational numbers. *)
Require Export Znumtheory.
Require Export Zgcd_old.
Require Export QArith_base.
(** First, a function that (tries to) build a positive back from a Z. *)
Definition Z2P (z : Z) :=
match z with
| Z0 => 1%positive
| Zpos p => p
| Zneg p => p
end.
(** A simple cancelation by powers of two *)
Fixpoint Pfactor_twos (p p':positive) {struct p} : (positive*positive) :=
match p, p' with
| xO p, xO p' => Pfactor_twos p p'
| _, _ => (p,p')
end.
Definition Qfactor_twos (q:Q) :=
let (p,q) := q in
match p with
| Z0 => 0
| Zpos p => let (p,q) := Pfactor_twos p q in (Zpos p)#q
| Zneg p => let (p,q) := Pfactor_twos p q in (Zneg p)#q
end.
Hint Resolve Qfactor_twos_correct.
(** Simplification of fractions using [Zgcd]. This version can compute within Coq. *)
Definition Qred (q:Q) :=
let (q1,q2) := Qfactor_twos q in
let (r1,r2) := snd (Zggcd q1 (Zpos q2)) in r1#(Z2P r2).
Add Morphism Qred : Qred_comp.
(** Another version, dedicated to extraction *)
Definition Qred_extr (q : Q) :=
let (q1, q2) := Qfactor_twos q in
let (p,_) := Zggcd_spec_pos (Zpos q2) (Zle_0_pos q2) q1 in
let (r2,r1) := snd p in r1#(Z2P r2).
Add Morphism Qred_extr : Qred_extr_comp.
Definition Qplus' (p q : Q) := Qred (Qplus p q).
Definition Qmult' (p q : Q) := Qred (Qmult p q).

Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).