initial shot at a decimals library

diff --git a/extra/decimals/authors.txt b/extra/decimals/authors.txt
new file mode 100644 (file)
index 0000000..b4bd0e7
--- /dev/null
+++ b/extra/decimals/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file

diff --git a/extra/decimals/decimals-tests.factor b/extra/decimals/decimals-tests.factor
new file mode 100644 (file)
index 0000000..bb9e60c
--- /dev/null
+++ b/extra/decimals/decimals-tests.factor
@@ -0,0 +1,51 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations decimals grouping kernel locals math
+math.functions math.order math.ratios prettyprint random
+sequences tools.test ;
+IN: decimals.tests
+
+[ t ] [
+    D: 12.34 D: 00012.34000 =
+] unit-test
+
+: random-test-int ( -- n )
+    10 random 2 random 0 = [ neg ] when ;
+
+: random-test-decimal ( -- decimal )
+    random-test-int random-test-int <decimal> ;
+
+ERROR: decimal-test-failure D1 D2 quot ;
+
+:: (test-decimal-op) ( D1 D2 quot1 quot2 -- ? )
+    D1 D2
+    quot1 [ decimal>ratio >float ] compose
+    [ [ decimal>ratio ] bi@ quot2 call( obj obj -- obj ) >float ] 2bi -.1 ~
+    [ t ] [ D1 D2 quot1 decimal-test-failure ] if ; inline
+
+: test-decimal-op ( quot1 quot2 -- ? )
+    [ random-test-decimal random-test-decimal ] 2dip (test-decimal-op) ; inline
+
+[ t ] [ 1000 [ drop [ D+ ] [ + ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D- ] [ - ] test-decimal-op ] all? ] unit-test
+[ t ] [ 1000 [ drop [ D* ] [ * ] test-decimal-op ] all? ] unit-test
+[ t ] [
+    1000 [
+        drop
+        [ [ 100 D/ ] [ /f ] test-decimal-op ]
+        [ { "kernel-error" 4 f f } = ] recover
+    ] all?
+] unit-test
+
+[ t ] [ 
+    { D: 0. D: .0 D: 0.0 D: 00.00 D: . } all-equal?
+] unit-test
+
+[ t ] [ T{ decimal f 90 0 } T{ decimal f 9 1 } = ] unit-test
+
+[ t ] [ D: 1 D: 2 before? ] unit-test
+[ f ] [ D: 2 D: 2 before? ] unit-test
+[ f ] [ D: 3 D: 2 before? ] unit-test
+[ f ] [ D: -1 D: -2 before? ] unit-test
+[ f ] [ D: -2 D: -2 before? ] unit-test
+[ t ] [ D: -3 D: -2 before? ] unit-test

diff --git a/extra/decimals/decimals.factor b/extra/decimals/decimals.factor
new file mode 100644 (file)
index 0000000..d9bafd4
--- /dev/null
+++ b/extra/decimals/decimals.factor
@@ -0,0 +1,85 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel lexer math
+math.functions math.parser parser sequences splitting
+locals math.order ;
+IN: decimals
+
+TUPLE: decimal { mantissa read-only } { exponent read-only } ;
+
+: <decimal> ( mantissa exponent -- decimal ) decimal boa ;
+
+: >decimal< ( decimal -- mantissa exponent )
+    [ mantissa>> ] [ exponent>> ] bi ; inline
+
+: string>decimal ( string -- decimal )
+    "." split1
+    [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
+    [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
+    [ append string>number ] [ nip length neg ] 2bi <decimal> ; 
+
+: parse-decimal ( -- decimal ) scan string>decimal ;
+
+SYNTAX: D: parse-decimal parsed ;
+
+: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
+: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
+
+: scale-mantissas ( D1 D2 -- m1 m2 exp )
+    [ [ mantissa>> ] bi@ ]
+    [ 
+        [ exponent>> ] bi@
+        [
+            - dup 0 <
+            [ neg 10^ * t ]
+            [ 10^ [ * ] curry dip f ] if
+        ] [ ? ] 2bi
+    ] 2bi ;
+
+: scale-decimals ( D1 D2 -- D1' D2' )
+    [ drop ]
+    [ scale-mantissas <decimal> nip ] 2bi ;
+
+ERROR: decimal-types-expected d1 d2 ;
+
+: guard-decimals ( obj1 obj2 -- D1 D2 )
+    2dup [ decimal? ] both?
+    [ decimal-types-expected ] unless ;
+
+M: decimal equal?
+    {
+        [ [ decimal? ] both? ]
+        [
+            scale-decimals
+            {
+                [ [ mantissa>> ] bi@ = ]
+                [ [ exponent>> ] bi@ = ]
+            } 2&&
+        ]
+    } 2&& ;
+
+M: decimal before?
+    guard-decimals scale-decimals
+    [ mantissa>> ] bi@ < ;
+
+: D-abs ( D -- D' )
+    [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
+
+: D+ ( D1 D2 -- D3 )
+    guard-decimals scale-mantissas [ + ] dip <decimal> ;
+
+: D- ( D1 D2 -- D3 )
+    guard-decimals scale-mantissas [ - ] dip <decimal> ;
+
+: D* ( D1 D2 -- D3 )
+    guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
+
+:: D/ ( D1 D2 a -- D3 )
+    D1 D2 guard-decimals 2drop
+    D1 >decimal< :> e1 :> m1
+    D2 >decimal< :> e2 :> m2
+    m1 a 10^ *
+    m2 /i
+    
+    e1
+    e2 a + - <decimal> ;