From dcc5ea89c7ab82730305cd53886613c2332a295d Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Mon, 6 Sep 2010 18:42:26 -0700
Subject: [PATCH] math.floating-point: adding double>ratio.

---
 .../floating-point/floating-point-tests.factor | 18 +++++++++++++++++-
 .../math/floating-point/floating-point.factor  | 11 +++++++++++
 2 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/extra/math/floating-point/floating-point-tests.factor b/extra/math/floating-point/floating-point-tests.factor
index 2f13237c9d..0bf09633a4 100644
--- a/extra/math/floating-point/floating-point-tests.factor
+++ b/extra/math/floating-point/floating-point-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test math.floating-point kernel
-math.constants fry sequences math ;
+math.constants fry sequences math random ;
 IN: math.floating-point.tests
 
 [ t ] [ pi >double< >double pi = ] unit-test
@@ -13,3 +13,19 @@ IN: math.floating-point.tests
 [ f ] [ 10. infinity? ] unit-test
 [ f ] [ -10. infinity? ] unit-test
 [ f ] [ 0. infinity? ] unit-test
+
+[ 0 ] [ 0.0 double>ratio ] unit-test
+[ 1 ] [ 1.0 double>ratio ] unit-test
+[ 1/2 ] [ 0.5 double>ratio ] unit-test
+[ 3/4 ] [ 0.75 double>ratio ] unit-test
+[ 12+1/2 ] [ 12.5 double>ratio ] unit-test
+[ -12-1/2 ] [ -12.5 double>ratio ] unit-test
+[ 3+39854788871587/281474976710656 ] [ pi double>ratio ] unit-test
+
+: roundtrip ( n -- )
+    [ '[ _ ] ] keep '[ _ double>ratio >float ] unit-test ;
+
+{ 1 12 123 1234 } [ bits>double roundtrip ] each
+
+100 [ -10.0 10.0 uniform-random-float roundtrip ] times
+
diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor
index e6e92919e2..fb9b258038 100644
--- a/extra/math/floating-point/floating-point.factor
+++ b/extra/math/floating-point/floating-point.factor
@@ -44,3 +44,14 @@ IN: math.floating-point
         [ (double-exponent-bits) 11 on-bits = ]
         [ (double-mantissa-bits) 0 = ]
     } 1&& ;
+
+: check-special ( n -- n )
+    dup fp-special? [ "cannot be special" throw ] when ;
+
+: double>ratio ( double -- a/b )
+    check-special double>bits
+    [ (double-sign) zero? 1 -1 ? ]
+    [ (double-mantissa-bits) 52 2^ / ]
+    [ (double-exponent-bits) ] tri
+    dup zero? [ 1 + ] [ [ 1 + ] dip ] if 1023 - 2 swap ^ * * ;
+