core/math/parser/parser.factor

   1 ! Copyright (C) 2004, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math.private namespaces sequences sequences.private
   4 strings arrays combinators splitting math assocs byte-arrays make ;
   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         { CHAR: , f }
  32     } at* [ drop 255 ] unless ; inline
  33
  34 : string>digits ( str -- digits )
  35     [ digit> ] B{ } map-as ; inline
  36
  37 : (digits>integer) ( valid? accum digit radix -- valid? accum )
  38     over [
  39         2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
  40     ] [ 2drop ] if ; inline
  41
  42 : each-digit ( seq radix quot -- n/f )
  43     [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
  44
  45 : digits>integer ( seq radix -- n/f )
  46     [ (digits>integer) ] each-digit ; inline
  47
  48 DEFER: base>
  49
  50 <PRIVATE
  51
  52 SYMBOL: radix
  53 SYMBOL: negative?
  54
  55 : string>natural ( seq radix -- n/f )
  56     over empty? [ 2drop f ] [
  57         [ [ digit> ] dip (digits>integer) ] each-digit
  58     ] if ; inline
  59
  60 : sign ( -- str ) negative? get "-" "+" ? ;
  61
  62 : with-radix ( radix quot -- )
  63     radix swap with-variable ; inline
  64
  65 : (base>) ( str -- n ) radix get base> ;
  66
  67 : whole-part ( str -- m n )
  68     sign split1 [ (base>) ] dip
  69     dup [ (base>) ] [ drop 0 swap ] if ;
  70
  71 : string>ratio ( str radix -- a/b )
  72     [
  73         "-" ?head dup negative? set swap
  74         "/" split1 (base>) [ whole-part ] dip
  75         3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
  76     ] with-radix ;
  77
  78 : string>integer ( str radix -- n/f )
  79     over first-unsafe CHAR: - = [
  80         [ rest-slice ] dip string>natural dup [ neg ] when
  81     ] [
  82         string>natural
  83     ] if ; inline
  84
  85 : dec>float ( str -- n/f )
  86     [ CHAR: , eq? not ] filter
  87     >byte-array 0 suffix (string>float) ;
  88
  89 : hex>float-parts ( str -- neg? mantissa-str expt )
  90     "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
  91
  92 : make-mantissa ( str -- bits )
  93     16 base> dup log2 52 swap - shift ;
  94
  95 : combine-hex-float-parts ( neg? mantissa expt -- float )
  96     dup 2046 > [ 2drop -1/0. 1/0. ? ] [
  97         dup 0 <= [ 1 - shift 0 ] when
  98         [ HEX: 8000,0000,0000,0000 0 ? ]
  99         [ 52 2^ 1 - bitand ]
 100         [ 52 shift ] tri* bitor bitor
 101         bits>double
 102     ] if ;
 103
 104 : hex>float ( str -- n/f )
 105     hex>float-parts
 106     [ "." split1 [ append make-mantissa ] [ drop 16 base> log2 ] 2bi ]
 107     [ + 1023 + ] bi*
 108     combine-hex-float-parts ;
 109
 110 : base>float ( str base -- n/f )
 111     {
 112         { 10 [ dec>float ] }
 113         { 16 [ hex>float ] }
 114         [ "Floats can only be converted from strings in base 10 or 16" throw ]
 115     } case ;
 116
 117 : number-char? ( char -- ? )
 118     "0123456789ABCDEFabcdef." member? ;
 119
 120 : numeric-looking? ( str -- ? )
 121     "-" ?head drop
 122     dup empty? [ drop f ] [
 123         dup first number-char? [
 124             last number-char?
 125         ] [ drop f ] if
 126     ] if ;
 127
 128 PRIVATE>
 129
 130 : string>float ( str -- n/f )
 131     10 base>float ;
 132
 133 : base> ( str radix -- n/f )
 134     over numeric-looking? [
 135         over [ "/." member? ] find nip {
 136             { CHAR: / [ string>ratio ] }
 137             { CHAR: . [ base>float ] }
 138             [ drop string>integer ]
 139         } case
 140     ] [ 2drop f ] if ;
 141
 142 : string>number ( str -- n/f ) 10 base> ;
 143 : bin> ( str -- n/f ) 2 base> ;
 144 : oct> ( str -- n/f ) 8 base> ;
 145 : hex> ( str -- n/f ) 16 base> ;
 146
 147 : >digit ( n -- ch )
 148     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
 149
 150 : positive>base ( num radix -- str )
 151     dup 1 <= [ "Invalid radix" throw ] when
 152     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 153     dup reverse-here ; inline
 154
 155 PRIVATE>
 156
 157 GENERIC# >base 1 ( n radix -- str )
 158
 159 <PRIVATE
 160
 161 : (>base) ( n -- str ) radix get positive>base ;
 162
 163 PRIVATE>
 164
 165 M: integer >base
 166     over 0 = [
 167         2drop "0"
 168     ] [
 169         over 0 > [
 170             positive>base
 171         ] [
 172             [ neg ] dip positive>base CHAR: - prefix
 173         ] if
 174     ] if ;
 175
 176 M: ratio >base
 177     [
 178         dup 0 < negative? set
 179         abs 1 /mod
 180         [ [ "" ] [ (>base) sign append ] if-zero ]
 181         [
 182             [ numerator (>base) ]
 183             [ denominator (>base) ] bi
 184             "/" glue
 185         ] bi* append
 186         negative? get [ CHAR: - prefix ] when
 187     ] with-radix ;
 188
 189 : fix-float ( str -- newstr )
 190     {
 191         {
 192             [ CHAR: e over member? ]
 193             [ "e" split1 [ fix-float "e" ] dip 3append ]
 194         } {
 195             [ CHAR: . over member? ]
 196             [ ]
 197         }
 198         [ ".0" append ]
 199     } cond ;
 200
 201 <PRIVATE
 202
 203 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 204     dup zero?
 205     [ over log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + - ] bi-curry bi* ]
 206     [ 1023 - ] if ;
 207
 208 : mantissa-expt ( float -- mantissa expt )
 209     [ 52 2^ 1 - bitand ]
 210     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 211     mantissa-expt-normalize ;
 212
 213 : float>hex-sign ( bits -- str )
 214     -0.0 double>bits bitand zero? "" "-" ? ;
 215
 216 : float>hex-value ( mantissa -- str )
 217     16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ;
 218
 219 : float>hex-expt ( mantissa -- str )
 220     10 >base "p" prepend ;
 221
 222 : float>hex ( n -- str )
 223     double>bits
 224     [ float>hex-sign ] [
 225         mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
 226     ] bi 3append ;
 227
 228 : float>decimal ( n -- str )
 229     (float>string)
 230     [ 0 = ] trim-tail >string
 231     fix-float ;
 232
 233 : float>base ( n base -- str )
 234     {
 235         { 10 [ float>decimal ] }
 236         { 16 [ float>hex ] }
 237         [ "Floats can only be converted to strings in base 10 or 16" throw ]
 238     } case ;
 239
 240 PRIVATE>
 241
 242 : float>string ( n -- str )
 243     10 float>base ;
 244
 245 M: float >base
 246     {
 247         { [ over fp-nan? ] [ 2drop "0/0." ] }
 248         { [ over 1/0. =  ] [ 2drop "1/0." ] }
 249         { [ over -1/0. = ] [ 2drop "-1/0." ] }
 250         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
 251         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
 252         [ float>base ]
 253     } cond ;
 254
 255 : number>string ( n -- str ) 10 >base ;
 256 : >bin ( n -- str ) 2 >base ;
 257 : >oct ( n -- str ) 8 >base ;
 258 : >hex ( n -- str ) 16 >base ;
 259
 260 : # ( n -- ) number>string % ;