factor/extra/decimals/decimals.factor

84 lines
2.1 KiB
Factor
Raw Normal View History

2009-09-22 19:56:59 -04:00
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
2016-04-21 19:59:56 -04:00
USING: accessors combinators.short-circuit kernel lexer locals
math math.functions math.order math.parser sequences splitting ;
2009-09-22 19:56:59 -04:00
IN: decimals
TUPLE: decimal { mantissa read-only } { exponent read-only } ;
2016-04-21 19:59:56 -04:00
C: <decimal> decimal
2009-09-22 19:56:59 -04:00
: >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> ;
2009-09-22 19:56:59 -04:00
: parse-decimal ( -- decimal ) scan-token string>decimal ;
2009-09-22 19:56:59 -04:00
SYNTAX: DECIMAL: parse-decimal suffix! ;
2009-09-22 19:56:59 -04:00
: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
2016-04-21 19:59:56 -04:00
2009-09-22 19:56:59 -04:00
: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
: scale-mantissas ( D1 D2 -- m1 m2 exp )
[ [ mantissa>> ] bi@ ]
[
2009-09-22 19:56:59 -04:00
[ exponent>> ] bi@
[
- dup 0 <
[ neg 10^ * t ]
[ 10^ [ * ] curry dip f ] if
] [ ? ] 2bi
] 2bi ;
: scale-decimals ( D1 D2 -- D1' D2' )
2009-11-05 23:22:21 -05:00
scale-mantissas [ <decimal> ] curry bi@ ;
2009-09-22 19:56:59 -04:00
ERROR: decimal-types-expected d1 d2 ;
: guard-decimals ( obj1 obj2 -- D1 D2 )
2016-04-21 19:59:56 -04:00
2dup [ decimal? ] both? [ decimal-types-expected ] unless ;
2009-09-22 19:56:59 -04:00
M: decimal equal?
{
[ [ decimal? ] both? ]
[
scale-decimals
{
2012-07-21 13:22:44 -04:00
[ [ mantissa>> ] same? ]
[ [ exponent>> ] same? ]
2009-09-22 19:56:59 -04:00
} 2&&
]
} 2&& ;
M: decimal before?
2016-04-21 19:59:56 -04:00
guard-decimals scale-decimals [ mantissa>> ] bi@ < ;
2009-09-22 19:56:59 -04:00
: 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 )
2016-04-21 19:59:56 -04:00
D1 D2 guard-decimals [ >decimal< ] bi@ :> ( m1 e1 m2 e2 )
2009-09-22 19:56:59 -04:00
m1 a 10^ *
m2 /i
2009-09-22 19:56:59 -04:00
e1
e2 a + - <decimal> ;
2009-10-20 23:37:44 -04:00
M: decimal <=>
2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline