core/math/parser/parser.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math.private namespaces make sequences strings
   4 arrays combinators splitting math assocs ;
   5 IN: math.parser
   6
   7 : digit> ( ch -- n )
   8     H{
   9         { CHAR: 0 0 }
  10         { CHAR: 1 1 }
  11         { CHAR: 2 2 }
  12         { CHAR: 3 3 }
  13         { CHAR: 4 4 }
  14         { CHAR: 5 5 }
  15         { CHAR: 6 6 }
  16         { CHAR: 7 7 }
  17         { CHAR: 8 8 }
  18         { CHAR: 9 9 }
  19         { CHAR: A 10 }
  20         { CHAR: B 11 }
  21         { CHAR: C 12 }
  22         { CHAR: D 13 }
  23         { CHAR: E 14 }
  24         { CHAR: F 15 }
  25         { CHAR: a 10 }
  26         { CHAR: b 11 }
  27         { CHAR: c 12 }
  28         { CHAR: d 13 }
  29         { CHAR: e 14 }
  30         { CHAR: f 15 }
  31     } at ;
  32
  33 : string>digits ( str -- digits )
  34     [ digit> ] { } map-as ;
  35
  36 : digits>integer ( seq radix -- n )
  37     0 swap [ swapd * + ] curry reduce ;
  38
  39 DEFER: base>
  40
  41 <PRIVATE
  42
  43 SYMBOL: radix
  44 SYMBOL: negative?
  45
  46 : sign ( -- str ) negative? get "-" "+" ? ;
  47
  48 : with-radix ( radix quot -- )
  49     radix swap with-variable ; inline
  50
  51 : (base>) ( str -- n ) radix get base> ;
  52
  53 : whole-part ( str -- m n )
  54     sign split1 >r (base>) r>
  55     dup [ (base>) ] [ drop 0 swap ] if ;
  56
  57 : string>ratio ( str -- a/b )
  58     "-" ?head dup negative? set swap
  59     "/" split1 (base>) >r whole-part r>
  60     3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
  61
  62 : valid-digits? ( seq -- ? )
  63     {
  64         { [ dup empty? ] [ drop f ] }
  65         { [ f over memq? ] [ drop f ] }
  66         [ radix get [ < ] curry all? ]
  67     } cond ;
  68
  69 : string>integer ( str -- n/f )
  70     "-" ?head swap
  71     string>digits dup valid-digits?
  72     [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
  73
  74 PRIVATE>
  75
  76 : base> ( str radix -- n/f )
  77     [
  78         CHAR: / over member? [
  79             string>ratio
  80         ] [
  81             CHAR: . over member? [
  82                 string>float
  83             ] [
  84                 string>integer
  85             ] if
  86         ] if
  87     ] with-radix ;
  88
  89 : string>number ( str -- n/f ) 10 base> ;
  90 : bin> ( str -- n/f ) 2 base> ;
  91 : oct> ( str -- n/f ) 8 base> ;
  92 : hex> ( str -- n/f ) 16 base> ;
  93
  94 : >digit ( n -- ch )
  95     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
  96
  97 : integer, ( num radix -- )
  98     dup 1 <= [ "Invalid radix" throw ] when
  99     [ /mod >digit , ] keep over 0 >
 100     [ integer, ] [ 2drop ] if ;
 101
 102 PRIVATE>
 103
 104 GENERIC# >base 1 ( n radix -- str )
 105
 106 <PRIVATE
 107
 108 : (>base) ( n -- str ) radix get >base ;
 109
 110 PRIVATE>
 111
 112 M: integer >base
 113     [
 114         over 0 < [
 115             swap neg swap integer, CHAR: - ,
 116         ] [
 117             integer,
 118         ] if
 119     ] "" make reverse ;
 120
 121 M: ratio >base
 122     [
 123         [
 124             dup 0 < dup negative? set [ "-" % neg ] when
 125             1 /mod
 126             >r dup zero? [ drop ] [ (>base) % sign % ] if r>
 127             dup numerator (>base) %
 128             "/" %
 129             denominator (>base) %
 130         ] "" make
 131     ] with-radix ;
 132
 133 : fix-float ( str -- newstr )
 134     {
 135         {
 136             [ CHAR: e over member? ]
 137             [ "e" split1 >r fix-float "e" r> 3append ]
 138         } {
 139             [ CHAR: . over member? ]
 140             [ ]
 141         }
 142         [ ".0" append ]
 143     } cond ;
 144
 145 M: float >base
 146     drop {
 147         { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
 148         { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
 149         { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
 150         { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
 151         [ float>string fix-float ]
 152     } cond ;
 153
 154 : number>string ( n -- str ) 10 >base ;
 155 : >bin ( n -- str ) 2 >base ;
 156 : >oct ( n -- str ) 8 >base ;
 157 : >hex ( n -- str ) 16 >base ;
 158
 159 : # ( n -- ) number>string % ;