core/math/parser/parser.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors byte-arrays combinators kernel kernel.private
   3 math namespaces sequences sequences.private splitting strings
   4 make ;
   5 IN: math.parser
   6
   7 : digit> ( ch -- n )
   8     {
   9         { [ dup CHAR: 9 <= ] [ CHAR: 0 -      dup  0 < [ drop 255 ] when ] }
  10         { [ dup CHAR: a <  ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
  11                              [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
  12     } cond ; inline
  13
  14 <PRIVATE
  15
  16 TUPLE: number-parse
  17     { str read-only }
  18     { length fixnum read-only }
  19     { radix fixnum read-only } ;
  20
  21 : <number-parse> ( str radix -- i number-parse n )
  22     [ 0 ] 2dip
  23     [ dup length ] dip
  24     number-parse boa
  25     0 ; inline
  26
  27 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
  28     [ 2over length>> < ] 2dip
  29     [ [ 2over str>> nth-unsafe >fixnum [ 1 + >fixnum ] 3dip ] prepose ] dip if ; inline
  30
  31 : require-next-digit ( i number-parse n quot -- n/f )
  32     [ 3drop f ] (next-digit) ; inline
  33
  34 : next-digit ( i number-parse n quot -- n/f )
  35     [ 2nip ] (next-digit) ; inline
  36
  37 : add-digit ( i number-parse n digit quot -- n/f )
  38     [ [ dup radix>> ] [ * ] [ + ] tri* ] dip next-digit ; inline
  39
  40 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
  41     digit> pick radix>> over > ; inline
  42
  43 : ?make-ratio ( num denom/f -- ratio/f )
  44     [ / ] [ drop f ] if* ; inline
  45
  46 TUPLE: float-parse
  47     { radix read-only }
  48     { point read-only }
  49     { exponent read-only } ;
  50
  51 : inc-point ( float-parse -- float-parse' )
  52     [ radix>> ] [ point>> 1 + ] [ exponent>> ] tri float-parse boa ; inline
  53
  54 : store-exponent ( float-parse n expt -- float-parse' n )
  55     swap [ [ drop radix>> ] [ drop point>> ] [ nip ] 2tri float-parse boa ] dip ; inline
  56
  57 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
  58     [ store-exponent ] [ drop f ] if* ; inline
  59
  60 : ((pow)) ( base x -- base^x )
  61     iota 1 rot [ nip * ] curry reduce ; inline
  62
  63 : (pow) ( base x -- base^x )
  64     dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
  65
  66 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
  67     [ [ inc-point ] 4dip ] dip add-digit ; inline
  68
  69 : make-float-dec-exponent ( float-parse n/f -- float/f )
  70     [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ] [ swap /f ] bi* ; inline
  71
  72 : make-float-bin-exponent ( float-parse n/f -- float/f )
  73     [ drop [ radix>> ] [ point>> ] bi (pow) ]
  74     [ nip swap /f ]
  75     [ drop 2.0 swap exponent>> (pow) * ] 2tri ; inline
  76
  77 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
  78     over exponent>> [
  79         over radix>> 10 =
  80         [ [ [ radix>> ] [ point>> ] bi 0 float-parse boa ] dip ]
  81         [ drop f ] if
  82     ] unless ; inline
  83
  84 : ?make-float ( float-parse n/f -- float/f )
  85     { float-parse object } declare
  86     ?default-exponent
  87     {
  88         { [ dup not ] [ 2drop f ] }
  89         { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
  90         [ make-float-bin-exponent ]
  91     } cond ;
  92
  93 : ?neg ( n/f -- -n/f )
  94     [ neg ] [ f ] if* ; inline
  95
  96 : ?add-ratio ( m n/f -- m+n/f )
  97     dup ratio? [ + ] [ 2drop f ] if ; inline
  98
  99 : @abort ( i number-parse n x -- f )
 100     2drop 2drop f ; inline
 101
 102 : @split ( i number-parse n -- n i number-parse n' )
 103     -rot 0 ; inline
 104
 105 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 106     -rot [ str>> ] [ length>> ] bi 10 number-parse boa 0 ; inline
 107
 108 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
 109      [ drop nip radix>> 0 f float-parse boa ] 3keep ; inline
 110
 111 DEFER: @exponent-digit
 112 DEFER: @mantissa-digit
 113 DEFER: @denom-digit
 114 DEFER: @num-digit
 115 DEFER: @pos-digit
 116 DEFER: @neg-digit
 117
 118 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 119     {
 120         { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
 121         [ @exponent-digit ]
 122     } case ; inline
 123
 124 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
 125     { float-parse fixnum number-parse integer fixnum } declare
 126     digit-in-radix [ [ @exponent-digit-or-punc ] add-digit ] [ @abort ] if ;
 127
 128 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 129     {
 130         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 131         { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
 132         [ @exponent-digit ]
 133     } case ; inline
 134
 135 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 136     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 137
 138 : exponent-char? ( number-parse n char -- number-parse n char ? )
 139     3dup nip swap radix>> {
 140         { 10 [ [ CHAR: e CHAR: E ] dip [ = ] curry either? ] }
 141         [ drop [ CHAR: p CHAR: P ] dip [ = ] curry either? ]
 142     } case ; inline
 143
 144 : or-exponent ( i number-parse n char quot -- n/f )
 145     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 146
 147 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 148     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 149
 150 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 151     {
 152         { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
 153         [ @mantissa-digit ]
 154     } case ; inline
 155
 156 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 157     { float-parse fixnum number-parse integer fixnum } declare
 158     [
 159         digit-in-radix
 160         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 161         [ @abort ] if
 162     ] or-mantissa->exponent ;
 163
 164 : ->mantissa ( i number-parse n -- n/f )
 165     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 166
 167 : ->required-mantissa ( i number-parse n -- n/f )
 168     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 169
 170 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 171     {
 172         { CHAR: , [ [ @denom-digit ] require-next-digit ] }
 173         { CHAR: . [ ->mantissa ] }
 174         [ [ @denom-digit ] or-exponent ]
 175     } case ; inline
 176
 177 : @denom-digit ( i number-parse n char -- n/f )
 178     { fixnum number-parse integer fixnum } declare
 179     digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
 180
 181 : @denom-first-digit ( i number-parse n char -- n/f )
 182     {
 183         { CHAR: . [ ->mantissa ] }
 184         [ @denom-digit ]
 185     } case ; inline
 186
 187 : ->denominator ( i number-parse n -- n/f )
 188     { fixnum number-parse integer } declare
 189     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 190
 191 : @num-digit-or-punc ( i number-parse n char -- n/f )
 192     {
 193         { CHAR: , [ [ @num-digit ] require-next-digit ] }
 194         { CHAR: / [ ->denominator ] }
 195         [ @num-digit ]
 196     } case ; inline
 197
 198 : @num-digit ( i number-parse n char -- n/f )
 199     { fixnum number-parse integer fixnum } declare
 200     digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
 201
 202 : ->numerator ( i number-parse n -- n/f )
 203     { fixnum number-parse integer } declare
 204     @split [ @num-digit ] require-next-digit ?add-ratio ;
 205
 206 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 207     {
 208         { CHAR: , [ [ @pos-digit ] require-next-digit ] }
 209         { CHAR: + [ ->numerator ] }
 210         { CHAR: / [ ->denominator ] }
 211         { CHAR: . [ ->mantissa ] }
 212         [ [ @pos-digit ] or-exponent ]
 213     } case ; inline
 214
 215 : @pos-digit ( i number-parse n char -- n/f )
 216     { fixnum number-parse integer fixnum } declare
 217     digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
 218
 219 : (->radix) ( number-parse radix -- number-parse' )
 220     [ [ str>> ] [ length>> ] bi ] dip number-parse boa ; inline
 221
 222 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 223     [ (->radix) ] curry 2dip ; inline
 224
 225 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 226     [
 227         rot {
 228             { CHAR: b [ drop  2 ->radix require-next-digit ] }
 229             { CHAR: o [ drop  8 ->radix require-next-digit ] }
 230             { CHAR: x [ drop 16 ->radix require-next-digit ] }
 231             { f       [ 3drop 2drop 0 ] }
 232             [ [ drop ] 2dip swap call ]
 233         } case
 234     ] 2curry next-digit ; inline
 235
 236 : @pos-first-digit ( i number-parse n char -- n/f )
 237     {
 238         { CHAR: . [ ->required-mantissa ] }
 239         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 240         [ @pos-digit ]
 241     } case ; inline
 242
 243 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 244     {
 245         { CHAR: , [ [ @neg-digit ] require-next-digit ] }
 246         { CHAR: - [ ->numerator ] }
 247         { CHAR: / [ ->denominator ] }
 248         { CHAR: . [ ->mantissa ] }
 249         [ [ @neg-digit ] or-exponent ]
 250     } case ; inline
 251
 252 : @neg-digit ( i number-parse n char -- n/f )
 253     { fixnum number-parse integer fixnum } declare
 254     digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
 255
 256 : @neg-first-digit ( i number-parse n char -- n/f )
 257     {
 258         { CHAR: . [ ->required-mantissa ] }
 259         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 260         [ @neg-digit ]
 261     } case ; inline
 262
 263 : @first-char ( i number-parse n char -- n/f )
 264     {
 265         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 266         { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
 267         [ @pos-first-digit ]
 268     } case ; inline
 269
 270 PRIVATE>
 271
 272 : base> ( str radix -- n/f )
 273     <number-parse> [ @first-char ] require-next-digit ;
 274
 275 : string>number ( str -- n/f ) 10 base> ; inline
 276
 277 : bin> ( str -- n/f )  2 base> ; inline
 278 : oct> ( str -- n/f )  8 base> ; inline
 279 : dec> ( str -- n/f ) 10 base> ; inline
 280 : hex> ( str -- n/f ) 16 base> ; inline
 281
 282 : string>digits ( str -- digits )
 283     [ digit> ] B{ } map-as ; inline
 284
 285 <PRIVATE
 286
 287 : (digits>integer) ( valid? accum digit radix -- valid? accum )
 288     2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
 289
 290 : each-digit ( seq radix quot -- n/f )
 291     [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
 292
 293 PRIVATE>
 294
 295 : digits>integer ( seq radix -- n/f )
 296     [ (digits>integer) ] each-digit ; inline
 297
 298 : >digit ( n -- ch )
 299     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
 300
 301 <PRIVATE
 302
 303 : positive>base ( num radix -- str )
 304     dup 1 <= [ "Invalid radix" throw ] when
 305     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 306     reverse! ; inline
 307
 308 PRIVATE>
 309
 310 GENERIC# >base 1 ( n radix -- str )
 311
 312 : number>string ( n -- str ) 10 >base ; inline
 313 : >bin ( n -- str ) 2 >base ; inline
 314 : >oct ( n -- str ) 8 >base ; inline
 315 : >hex ( n -- str ) 16 >base ; inline
 316
 317 <PRIVATE
 318
 319 SYMBOL: radix
 320 SYMBOL: negative?
 321
 322 : sign ( -- str ) negative? get "-" "+" ? ;
 323
 324 : with-radix ( radix quot -- )
 325     radix swap with-variable ; inline
 326
 327 : (>base) ( n -- str ) radix get positive>base ;
 328
 329 PRIVATE>
 330
 331 M: integer >base
 332     over 0 = [
 333         2drop "0"
 334     ] [
 335         over 0 > [
 336             positive>base
 337         ] [
 338             [ neg ] dip positive>base CHAR: - prefix
 339         ] if
 340     ] if ;
 341
 342 M: ratio >base
 343     [
 344         dup 0 < negative? set
 345         abs 1 /mod
 346         [ [ "" ] [ (>base) sign append ] if-zero ]
 347         [
 348             [ numerator (>base) ]
 349             [ denominator (>base) ] bi
 350             "/" glue
 351         ] bi* append
 352         negative? get [ CHAR: - prefix ] when
 353     ] with-radix ;
 354
 355 : fix-float ( str -- newstr )
 356     {
 357         {
 358             [ CHAR: e over member? ]
 359             [ "e" split1 [ fix-float "e" ] dip 3append ]
 360         } {
 361             [ CHAR: . over member? ]
 362             [ ]
 363         }
 364         [ ".0" append ]
 365     } cond ;
 366
 367 <PRIVATE
 368
 369 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 370     dup zero?
 371     [ over log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + - ] bi-curry bi* ]
 372     [ 1023 - ] if ;
 373
 374 : mantissa-expt ( float -- mantissa expt )
 375     [ 52 2^ 1 - bitand ]
 376     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 377     mantissa-expt-normalize ;
 378
 379 : float>hex-sign ( bits -- str )
 380     -0.0 double>bits bitand zero? "" "-" ? ;
 381
 382 : float>hex-value ( mantissa -- str )
 383     >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 384     [ "0" ] when-empty "1." prepend ;
 385
 386 : float>hex-expt ( mantissa -- str )
 387     10 >base "p" prepend ;
 388
 389 : float>hex ( n -- str )
 390     double>bits
 391     [ float>hex-sign ] [
 392         mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
 393     ] bi 3append ;
 394
 395 : format-float ( n format -- string )
 396     0 suffix >byte-array (format-float)
 397     dup [ 0 = ] find drop head >string
 398     fix-float ;
 399
 400 : float>base ( n base -- str )
 401     {
 402         { 16 [ float>hex ] }
 403         [ drop "%.16g" format-float ]
 404     } case ; inline
 405
 406 PRIVATE>
 407
 408 : float>string ( n -- str )
 409     10 float>base ; inline
 410
 411 M: float >base
 412     {
 413         { [ over fp-nan? ] [ 2drop "0/0." ] }
 414         { [ over 1/0. =  ] [ 2drop "1/0." ] }
 415         { [ over -1/0. = ] [ 2drop "-1/0." ] }
 416         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
 417         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
 418         [ float>base ]
 419     } cond ;
 420
 421 : # ( n -- ) number>string % ; inline