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