extra/decimals/decimals.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators.short-circuit kernel lexer math
   4 math.functions math.order math.parser prettyprint.backend
   5 prettyprint.custom prettyprint.sections sequences splitting
   6 strings ;
   7 IN: decimals
   8
   9 TUPLE: decimal { mantissa read-only } { exponent read-only } ;
  10
  11 C: <decimal> decimal
  12
  13 : >decimal< ( decimal -- mantissa exponent )
  14     [ mantissa>> ] [ exponent>> ] bi ; inline
  15
  16 : string>decimal ( string -- decimal )
  17     "." split1
  18     [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
  19     [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
  20     [ append string>number ] [ nip length neg ] 2bi <decimal> ;
  21
  22 : parse-decimal ( -- decimal ) scan-token string>decimal ;
  23
  24 SYNTAX: DECIMAL: parse-decimal suffix! ;
  25
  26 : decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
  27
  28 : decimal>float ( decimal -- float ) decimal>ratio >float ;
  29
  30 : scale-mantissas ( D1 D2 -- m1 m2 exp )
  31     [ [ mantissa>> ] bi@ ]
  32     [
  33         [ exponent>> ] bi@
  34         [
  35             - dup 0 <
  36             [ neg 10^ * t ]
  37             [ 10^ [ * ] curry dip f ] if
  38         ] [ ? ] 2bi
  39     ] 2bi ;
  40
  41 : scale-decimals ( D1 D2 -- D1' D2' )
  42     scale-mantissas [ <decimal> ] curry bi@ ;
  43
  44 ERROR: decimal-types-expected d1 d2 ;
  45
  46 : guard-decimals ( obj1 obj2 -- D1 D2 )
  47     2dup [ decimal? ] both? [ decimal-types-expected ] unless ;
  48
  49 M: decimal equal?
  50     {
  51         [ [ decimal? ] both? ]
  52         [
  53             scale-decimals
  54             {
  55                 [ [ mantissa>> ] same? ]
  56                 [ [ exponent>> ] same? ]
  57             } 2&&
  58         ]
  59     } 2&& ;
  60
  61 M: decimal before?
  62     guard-decimals scale-decimals [ mantissa>> ] bi@ < ;
  63
  64 : D-abs ( D -- D' )
  65     [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
  66
  67 : D+ ( D1 D2 -- D3 )
  68     guard-decimals scale-mantissas [ + ] dip <decimal> ;
  69
  70 : D- ( D1 D2 -- D3 )
  71     guard-decimals scale-mantissas [ - ] dip <decimal> ;
  72
  73 : D* ( D1 D2 -- D3 )
  74     guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
  75
  76 :: D/ ( D1 D2 a -- D3 )
  77     D1 D2 guard-decimals [ >decimal< ] bi@ :> ( m1 e1 m2 e2 )
  78     m1 a 10^ *
  79     m2 /i
  80
  81     e1
  82     e2 a + - <decimal> ;
  83
  84 M: decimal <=>
  85     2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline
  86
  87 M: decimal pprint*
  88     \ DECIMAL: [
  89         [ mantissa>> abs number>string ]
  90         [
  91             exponent>> dup 0 > [ CHAR: 0 <string> append ] [
  92                 dup 0 < [
  93                     abs
  94                     [ CHAR: 0 pad-head ] [ cut-slice* ] bi
  95                     over empty? [ nip "0." prepend ] [ "." glue ] if
  96                 ] [ drop ] if
  97             ] if
  98         ]
  99         [ mantissa>> 0 < [ "-" prepend ] when ] tri text
 100     ] pprint-prefix ;