(****************************************************************************  IEEE754  :  Paux  Laurent Thery  ******************************************************************************)
Require Export Digit.
Require Export Option.
Require Export Inverse_Image.
Require Export Wf_nat.
Fixpoint exp (n m : nat) {struct m} : nat :=
match m with
| O => 1
| S m' => n * exp n m'
end.
intros n p; elim p; simpl in |- *; auto with arith.
intros n0 H' q; rewrite mult_assoc_reverse; rewrite <- H'; auto.
Qed.
Fixpoint positive_exp (p n : positive) {struct n} : positive :=
match n with
| xH => p
| xO n1 =>
match positive_exp p n1 with
| r =>
(fun (x : positive) (_ : positive -> positive)
(y : positive) => (x * y)%positive) r (
fun x => x) r
end
| xI n1 =>
match positive_exp p n1 with
| r =>
(fun (x : positive) (_ : positive -> positive)
(y : positive) => (x * y)%positive) p (
fun x => x)
((fun (x : positive)
(_ : positive -> positive)
(y : positive) => (x * y)%positive) r (
fun x => x) r)
end
end.
intros p n; elim n; simpl in |- *; auto.
intros p0 H.
repeat
rewrite
(fun (x y : positive) (_ : positive -> positive) =>
nat_of_P_mult_morphism x y); simpl in |- *;
auto.
rewrite ZL6; rewrite expPlus; rewrite H; auto.
intros p0 H.
repeat
rewrite
(fun (x y : positive) (_ : positive -> positive) =>
nat_of_P_mult_morphism x y); simpl in |- *;
auto.
rewrite H; rewrite <- expPlus; rewrite <- ZL6; auto.
rewrite mult_comm; simpl in |- *; auto.
Qed.
Fixpoint Pdiv (p q : positive) {struct p} :
Option positive * Option positive :=
match p with
| xH =>
match q with
| xH => (Some _ 1%positive, None _)
| xO r => (None _, Some _ p)
| xI r => (None _, Some _ p)
end
| xI p' =>
match Pdiv p' q with
| (None, None) =>
match (1 - Zpos q)%Z with
| Z0 => (Some _ 1%positive, None _)
| Zpos r' => (Some _ 1%positive, Some _ r')
| Zneg r' => (None _, Some _ 1%positive)
end
| (None, Some r1) =>
match (Zpos (xI r1) - Zpos q)%Z with
| Z0 => (Some _ 1%positive, None _)
| Zpos r' => (Some _ 1%positive, Some _ r')
| Zneg r' => (None _, Some _ (xI r1))
end
| (Some q1, None) =>
match (1 - Zpos q)%Z with
| Z0 => (Some _ (xI q1), None _)
| Zpos r' => (Some _ (xI q1), Some _ r')
| Zneg r' => (Some _ (xO q1), Some _ 1%positive)
end
| (Some q1, Some r1) =>
match (Zpos (xI r1) - Zpos q)%Z with
| Z0 => (Some _ (xI q1), None _)
| Zpos r' => (Some _ (xI q1), Some _ r')
| Zneg r' => (Some _ (xO q1), Some _ (xI r1))
end
end
| xO p' =>
match Pdiv p' q with
| (None, None) => (None _, None _)
| (None, Some r1) =>
match (Zpos (xO r1) - Zpos q)%Z with
| Z0 => (Some _ 1%positive, None _)
| Zpos r' => (Some _ 1%positive, Some _ r')
| Zneg r' => (None _, Some _ (xO r1))
end
| (Some q1, None) => (Some _ (xO q1), None _)
| (Some q1, Some r1) =>
match (Zpos (xO r1) - Zpos q)%Z with
| Z0 => (Some _ (xI q1), None _)
| Zpos r' => (Some _ (xI q1), Some _ r')
| Zneg r' => (Some _ (xO q1), Some _ (xO r1))
end
end
end.
Definition oZ h := match h with
| None => 0
| Some p => nat_of_P p
end.

Theorem Pdiv_correct :
forall p q,
nat_of_P p =
oZ (fst (Pdiv p q)) * nat_of_P q + oZ (snd (Pdiv p q)) /\
oZ (snd (Pdiv p q)) < nat_of_P q.