core/math/parser/parser.factor

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