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.parser parser sequences splitting
   5 locals math.order ;
   6 IN: decimals
   7
   8 TUPLE: decimal { mantissa read-only } { exponent read-only } ;
   9
  10 : <decimal> ( mantissa exponent -- decimal ) decimal boa ;
  11
  12 : >decimal< ( decimal -- mantissa exponent )
  13     [ mantissa>> ] [ exponent>> ] bi ; inline
  14
  15 : string>decimal ( string -- decimal )
  16     "." split1
  17     [ [ CHAR: 0 = ] trim-head [ "0" ] when-empty ]
  18     [ [ CHAR: 0 = ] trim-tail [ "" ] when-empty ] bi*
  19     [ append string>number ] [ nip length neg ] 2bi <decimal> ;
  20
  21 : parse-decimal ( -- decimal ) scan-token string>decimal ;
  22
  23 SYNTAX: D: parse-decimal suffix! ;
  24
  25 : decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
  26 : decimal>float ( decimal -- ratio ) decimal>ratio >float ;
  27
  28 : scale-mantissas ( D1 D2 -- m1 m2 exp )
  29     [ [ mantissa>> ] bi@ ]
  30     [
  31         [ exponent>> ] bi@
  32         [
  33             - dup 0 <
  34             [ neg 10^ * t ]
  35             [ 10^ [ * ] curry dip f ] if
  36         ] [ ? ] 2bi
  37     ] 2bi ;
  38
  39 : scale-decimals ( D1 D2 -- D1' D2' )
  40     scale-mantissas [ <decimal> ] curry bi@ ;
  41
  42 ERROR: decimal-types-expected d1 d2 ;
  43
  44 : guard-decimals ( obj1 obj2 -- D1 D2 )
  45     2dup [ decimal? ] both?
  46     [ decimal-types-expected ] unless ;
  47
  48 M: decimal equal?
  49     {
  50         [ [ decimal? ] both? ]
  51         [
  52             scale-decimals
  53             {
  54                 [ [ mantissa>> ] same? ]
  55                 [ [ exponent>> ] same? ]
  56             } 2&&
  57         ]
  58     } 2&& ;
  59
  60 M: decimal before?
  61     guard-decimals scale-decimals
  62     [ 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 2drop
  78     D1 >decimal< :> ( m1 e1 )
  79     D2 >decimal< :> ( m2 e2 )
  80     m1 a 10^ *
  81     m2 /i
  82
  83     e1
  84     e2 a + - <decimal> ;
  85
  86 M: decimal <=>
  87     2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline