diff --git a/extra/decimals/authors.txt b/extra/decimals/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /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 index 0000000000..bb9e60cfc1 --- /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 ; + +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 index 0000000000..d9bafd43d0 --- /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 } ; + +: ( 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 ; + +: 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 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 ; + +: D+ ( D1 D2 -- D3 ) + guard-decimals scale-mantissas [ + ] dip ; + +: D- ( D1 D2 -- D3 ) + guard-decimals scale-mantissas [ - ] dip ; + +: D* ( D1 D2 -- D3 ) + guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip ; + +:: 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 + - ;