core/math/parser/parser.factor

   1 ! Copyright (C) 2009 Joe Groff, 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors byte-arrays combinators kernel kernel.private
   4 layouts make math math.private namespaces sbufs sequences
   5 sequences.private splitting strings strings.private ;
   6 IN: math.parser
   7
   8 : digit> ( ch -- n )
   9     {
  10         { [ dup CHAR: 9 <= ] [ CHAR: 0 -      dup  0 < [ drop 255 ] when ] }
  11         { [ dup CHAR: a <  ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
  12                              [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
  13     } cond ; inline
  14
  15 ERROR: invalid-radix radix ;
  16
  17 <PRIVATE
  18
  19 TUPLE: number-parse
  20     { str read-only }
  21     { length fixnum read-only }
  22     { radix fixnum read-only } ;
  23
  24 : <number-parse> ( str radix -- i number-parse n )
  25     [ 0 ] 2dip [ dup length ] dip number-parse boa 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+fast ] 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 fixnum 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 [ [ radix>> ] [ point>> ] bi ] 2dip [ 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     [ 1 ] 2dip
  62     [ dup zero? ] [
  63         dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
  64         [ sq ] [ 2/ ] bi*
  65     ] until 2drop ; inline
  66
  67 : (pow) ( base x -- base^x )
  68     integer>fixnum-strict
  69     dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
  70
  71 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
  72     [ [ inc-point ] 4dip ] dip add-digit ; inline
  73
  74 : make-float-dec-exponent ( float-parse n/f -- float/f )
  75     [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ] [ swap /f ] bi* ; inline
  76
  77 : make-float-bin-exponent ( float-parse n/f -- float/f )
  78     [ drop [ radix>> ] [ point>> ] bi (pow) ]
  79     [ nip swap /f ]
  80     [ drop 2.0 swap exponent>> (pow) * ] 2tri ; inline
  81
  82 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
  83     over exponent>> [
  84         over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
  85     ] unless ; inline
  86
  87 : ?make-float ( float-parse n/f -- float/f )
  88     { float-parse object } declare
  89     ?default-exponent
  90     {
  91         { [ dup not ] [ 2drop f ] }
  92         { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
  93         [ make-float-bin-exponent ]
  94     } cond ;
  95
  96 : ?neg ( n/f -- -n/f )
  97     [ neg ] [ f ] if* ; inline
  98
  99 : ?add-ratio ( m n/f -- m+n/f )
 100     dup ratio? [ + ] [ 2drop f ] if ; inline
 101
 102 : @abort ( i number-parse n x -- f )
 103     4drop f ; inline
 104
 105 : @split ( i number-parse n -- n i number-parse n' )
 106     -rot 0 ; inline
 107
 108 : @split-exponent ( i number-parse n -- n i number-parse' n' )
 109     -rot [ str>> ] [ length>> ] bi 10 number-parse boa 0 ; inline
 110
 111 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
 112      [ drop nip radix>> 0 f float-parse boa ] 3keep ; inline
 113
 114 DEFER: @exponent-digit
 115 DEFER: @mantissa-digit
 116 DEFER: @denom-digit
 117 DEFER: @num-digit
 118 DEFER: @pos-digit
 119 DEFER: @neg-digit
 120
 121 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 122     {
 123         { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
 124         [ @exponent-digit ]
 125     } case ; inline
 126
 127 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
 128     { float-parse fixnum number-parse integer fixnum } declare
 129     digit-in-radix [ [ @exponent-digit-or-punc ] add-digit ] [ @abort ] if ;
 130
 131 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
 132     {
 133         { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
 134         { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
 135         [ @exponent-digit ]
 136     } case ; inline
 137
 138 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
 139     @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
 140
 141 : exponent-char? ( number-parse n char -- number-parse n char ? )
 142     pick radix>> {
 143         { 10 [ dup CHAR: e = [ t ] [ dup CHAR: E = ] if ] }
 144         [ drop dup CHAR: p = [ t ] [ dup CHAR: P = ] if ]
 145     } case ; inline
 146
 147 : or-exponent ( i number-parse n char quot -- n/f )
 148     [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
 149
 150 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
 151     [ exponent-char? [ drop ->exponent ] ] dip if ; inline
 152
 153 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
 154     {
 155         { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
 156         [ @mantissa-digit ]
 157     } case ; inline
 158
 159 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
 160     { float-parse fixnum number-parse integer fixnum } declare
 161     [
 162         digit-in-radix
 163         [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
 164         [ @abort ] if
 165     ] or-mantissa->exponent ;
 166
 167 : ->mantissa ( i number-parse n -- n/f )
 168     <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
 169
 170 : ->required-mantissa ( i number-parse n -- n/f )
 171     <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
 172
 173 : @denom-digit-or-punc ( i number-parse n char -- n/f )
 174     {
 175         { CHAR: , [ [ @denom-digit ] require-next-digit ] }
 176         { CHAR: . [ ->mantissa ] }
 177         [ [ @denom-digit ] or-exponent ]
 178     } case ; inline
 179
 180 : @denom-digit ( i number-parse n char -- n/f )
 181     { fixnum number-parse integer fixnum } declare
 182     digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
 183
 184 : @denom-first-digit ( i number-parse n char -- n/f )
 185     {
 186         { CHAR: . [ ->mantissa ] }
 187         [ @denom-digit ]
 188     } case ; inline
 189
 190 : ->denominator ( i number-parse n -- n/f )
 191     { fixnum number-parse integer } declare
 192     @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
 193
 194 : @num-digit-or-punc ( i number-parse n char -- n/f )
 195     {
 196         { CHAR: , [ [ @num-digit ] require-next-digit ] }
 197         { CHAR: / [ ->denominator ] }
 198         [ @num-digit ]
 199     } case ; inline
 200
 201 : @num-digit ( i number-parse n char -- n/f )
 202     { fixnum number-parse integer fixnum } declare
 203     digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
 204
 205 : ->numerator ( i number-parse n -- n/f )
 206     { fixnum number-parse integer } declare
 207     @split [ @num-digit ] require-next-digit ?add-ratio ;
 208
 209 : @pos-digit-or-punc ( i number-parse n char -- n/f )
 210     {
 211         { CHAR: , [ [ @pos-digit ] require-next-digit ] }
 212         { CHAR: + [ ->numerator ] }
 213         { CHAR: / [ ->denominator ] }
 214         { CHAR: . [ ->mantissa ] }
 215         [ [ @pos-digit ] or-exponent ]
 216     } case ; inline
 217
 218 : @pos-digit ( i number-parse n char -- n/f )
 219     { fixnum number-parse integer fixnum } declare
 220     digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
 221
 222 : (->radix) ( number-parse radix -- number-parse' )
 223     [ [ str>> ] [ length>> ] bi ] dip number-parse boa ; inline
 224
 225 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
 226     [ (->radix) ] curry 2dip ; inline
 227
 228 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
 229     [
 230         rot {
 231             { CHAR: b [ drop  2 ->radix require-next-digit ] }
 232             { CHAR: o [ drop  8 ->radix require-next-digit ] }
 233             { CHAR: x [ drop 16 ->radix require-next-digit ] }
 234             { f       [ 3drop 2drop 0 ] }
 235             [ [ drop ] 2dip swap call ]
 236         } case
 237     ] 2curry next-digit ; inline
 238
 239 : @pos-first-digit ( i number-parse n char -- n/f )
 240     {
 241         { CHAR: . [ ->required-mantissa ] }
 242         { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
 243         [ @pos-digit ]
 244     } case ; inline
 245
 246 : @neg-digit-or-punc ( i number-parse n char -- n/f )
 247     {
 248         { CHAR: , [ [ @neg-digit ] require-next-digit ] }
 249         { CHAR: - [ ->numerator ] }
 250         { CHAR: / [ ->denominator ] }
 251         { CHAR: . [ ->mantissa ] }
 252         [ [ @neg-digit ] or-exponent ]
 253     } case ; inline
 254
 255 : @neg-digit ( i number-parse n char -- n/f )
 256     { fixnum number-parse integer fixnum } declare
 257     digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
 258
 259 : @neg-first-digit ( i number-parse n char -- n/f )
 260     {
 261         { CHAR: . [ ->required-mantissa ] }
 262         { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
 263         [ @neg-digit ]
 264     } case ; inline
 265
 266 : @first-char ( i number-parse n char -- n/f )
 267     {
 268         { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
 269         { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
 270         [ @pos-first-digit ]
 271     } case ; inline
 272
 273 : @first-char-no-radix ( i number-parse n char -- n/f )
 274     {
 275         { CHAR: - [ [ @neg-digit ] require-next-digit ?neg ] }
 276         { CHAR: + [ [ @pos-digit ] require-next-digit ] }
 277         [ @pos-digit ]
 278     } case ; inline
 279
 280 PRIVATE>
 281
 282 : string>number ( str -- n/f )
 283     10 <number-parse> [ @first-char ] require-next-digit ;
 284
 285 : base> ( str radix -- n/f )
 286     <number-parse> [ @first-char-no-radix ] require-next-digit ;
 287
 288 : bin> ( str -- n/f )  2 base> ; inline
 289 : oct> ( str -- n/f )  8 base> ; inline
 290 : dec> ( str -- n/f ) 10 base> ; inline
 291 : hex> ( str -- n/f ) 16 base> ; inline
 292
 293 : string>digits ( str -- digits )
 294     [ digit> ] B{ } map-as ; inline
 295
 296 <PRIVATE
 297
 298 : (digits>integer) ( valid? accum digit radix -- valid? accum )
 299     2dup < [ swapd * + ] [ 4drop f 0 ] if ; inline
 300
 301 : each-digit ( seq radix quot -- n/f )
 302     [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
 303
 304 PRIVATE>
 305
 306 : digits>integer ( seq radix -- n/f )
 307     [ (digits>integer) ] each-digit ; inline
 308
 309 : >digit ( n -- ch )
 310     dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
 311
 312 <PRIVATE
 313
 314 CONSTANT: TENS B{
 315     48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
 316     50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
 317     52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
 318     54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
 319     56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
 320 }
 321
 322 CONSTANT: ONES B{
 323     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 324     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 325     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 326     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 327     48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
 328 }
 329
 330 : (two-digit) ( num accum -- num' accum )
 331     [
 332         100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
 333     ] dip [ push ] keep [ push ] keep ; inline
 334
 335 : (one-digit) ( num accum -- num' accum )
 336     [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
 337
 338 : (bignum>dec) ( num accum -- num' accum )
 339     [ over most-positive-fixnum > ]
 340     [ { bignum sbuf } declare (two-digit) ] while
 341     [ >fixnum ] dip ; inline
 342
 343 : (fixnum>dec) ( num accum -- num' accum )
 344     { fixnum sbuf } declare
 345     [ over 10 >= ] [ (two-digit) ] while
 346     [ over zero? ] [ (one-digit) ] until ; inline
 347
 348 GENERIC: (positive>dec) ( num -- str )
 349
 350 M: bignum (positive>dec)
 351     12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
 352
 353 : (count-digits) ( digits n -- digits' )
 354     {
 355         { [ dup 10 < ] [ drop ] }
 356         { [ dup 100 < ] [ drop 1 fixnum+fast ] }
 357         { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
 358         [
 359             dup 1,000,000,000,000 < [
 360                 dup 100,000,000 < [
 361                     dup 1,000,000 < [
 362                         dup 10,000 < [
 363                             drop 3
 364                         ] [
 365                             100,000 >= 5 4 ?
 366                         ] if
 367                     ] [
 368                         10,000,000 >= 7 6 ?
 369                     ] if
 370                 ] [
 371                     dup 10,000,000,000 < [
 372                         1,000,000,000 >= 9 8 ?
 373                     ] [
 374                         100,000,000,000 >= 11 10 ?
 375                     ] if
 376                 ] if fixnum+fast
 377             ] [
 378                 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
 379                 (count-digits)
 380             ] if
 381         ]
 382     } cond ; inline recursive
 383
 384 M: fixnum (positive>dec)
 385     1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
 386
 387 : (positive>base) ( num radix -- str )
 388     dup 1 <= [ invalid-radix ] when
 389     [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
 390     reverse! ; inline
 391
 392 : positive>base ( num radix -- str )
 393     dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
 394
 395 PRIVATE>
 396
 397 GENERIC# >base 1 ( n radix -- str )
 398
 399 : number>string ( n -- str ) 10 >base ; inline
 400
 401 : >bin ( n -- str ) 2 >base ; inline
 402 : >oct ( n -- str ) 8 >base ; inline
 403 : >hex ( n -- str ) 16 >base ; inline
 404
 405 M: integer >base
 406     over 0 = [
 407         2drop "0"
 408     ] [
 409         over 0 > [
 410             positive>base
 411         ] [
 412             [ neg ] dip positive>base CHAR: - prefix
 413         ] if
 414     ] if ;
 415
 416 M: ratio >base
 417     [ [ 0 < ] [ abs 1 /mod ] bi ]
 418     [ [ positive>base ] curry ] bi*
 419     [
 420         [ [ numerator ] [ denominator ] bi ] dip bi@ "/" glue
 421     ] keep rot [ drop ] [
 422         swap call pick "-" "+" ? rot 3append
 423     ] if-zero swap [ CHAR: - prefix ] when ;
 424
 425 <PRIVATE
 426
 427 : fix-float ( str -- newstr )
 428     CHAR: e over member? [
 429         "e" split1 [ fix-float ] dip "e" glue
 430     ] [
 431         CHAR: . over member? [ ".0" append ] unless
 432     ] if ;
 433
 434 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
 435     [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
 436     [ 1023 - ] if-zero ;
 437
 438 : mantissa-expt ( float -- mantissa expt )
 439     [ 52 2^ 1 - bitand ]
 440     [ -0.0 double>bits bitnot bitand -52 shift ] bi
 441     mantissa-expt-normalize ;
 442
 443 : float>hex-sign ( bits -- str )
 444     -0.0 double>bits bitand zero? "" "-" ? ;
 445
 446 : float>hex-value ( mantissa -- str )
 447     >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
 448     [ "0" ] when-empty "1." prepend ;
 449
 450 : float>hex-expt ( mantissa -- str )
 451     10 >base "p" prepend ;
 452
 453 : float>hex ( n -- str )
 454     double>bits
 455     [ float>hex-sign ] [
 456         mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
 457     ] bi 3append ;
 458
 459 : format-string ( format -- format )
 460     0 suffix >byte-array ; foldable
 461
 462 : format-head ( byte-array n -- string )
 463     swap over 0 <string> [
 464         [
 465             [ [ nth-unsafe ] 2keep drop ]
 466             [ set-string-nth-fast ] bi*
 467         ] 2curry each-integer
 468     ] keep ; inline
 469
 470 : format-float ( n format -- string )
 471     format-string (format-float)
 472     dup [ 0 = ] find drop
 473     format-head fix-float ; inline
 474
 475 : float>base ( n radix -- str )
 476     {
 477         { 16 [ float>hex ] }
 478         { 10 [ "%.16g" format-float ] }
 479         [ invalid-radix ]
 480     } case ; inline
 481
 482 PRIVATE>
 483
 484 M: float >base
 485     {
 486         { [ over fp-nan? ] [ 2drop "0/0." ] }
 487         { [ over 1/0. =  ] [ 2drop "1/0." ] }
 488         { [ over -1/0. = ] [ 2drop "-1/0." ] }
 489         { [ over  0.0 fp-bitwise= ] [ 2drop  "0.0" ] }
 490         { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
 491         [ float>base ]
 492     } cond ;
 493
 494 : # ( n -- ) number>string % ; inline