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 string>decimal ;
  22
  23 SYNTAX: D: parse-decimal parsed ;
  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     [ drop ]
  41     [ scale-mantissas <decimal> nip ] 2bi ;
  42
  43 ERROR: decimal-types-expected d1 d2 ;
  44
  45 : guard-decimals ( obj1 obj2 -- D1 D2 )
  46     2dup [ decimal? ] both?
  47     [ decimal-types-expected ] unless ;
  48
  49 M: decimal equal?
  50     {
  51         [ [ decimal? ] both? ]
  52         [
  53             scale-decimals
  54             {
  55                 [ [ mantissa>> ] bi@ = ]
  56                 [ [ exponent>> ] bi@ = ]
  57             } 2&&
  58         ]
  59     } 2&& ;
  60
  61 M: decimal before?
  62     guard-decimals scale-decimals
  63     [ mantissa>> ] bi@ < ;
  64
  65 : D-abs ( D -- D' )
  66     [ mantissa>> abs ] [ exponent>> ] bi <decimal> ;
  67
  68 : D+ ( D1 D2 -- D3 )
  69     guard-decimals scale-mantissas [ + ] dip <decimal> ;
  70
  71 : D- ( D1 D2 -- D3 )
  72     guard-decimals scale-mantissas [ - ] dip <decimal> ;
  73
  74 : D* ( D1 D2 -- D3 )
  75     guard-decimals [ >decimal< ] bi@ swapd + [ * ] dip <decimal> ;
  76
  77 :: D/ ( D1 D2 a -- D3 )
  78     D1 D2 guard-decimals 2drop
  79     D1 >decimal< :> e1 :> m1
  80     D2 >decimal< :> e2 :> m2
  81     m1 a 10^ *
  82     m2 /i
  83
  84     e1
  85     e2 a + - <decimal> ;