1 ! Copyright (C) 2009 Joe Groff, 2013 John Benediktsson
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays combinators kernel kernel.private
4 layouts make math math.private sbufs sequences sequences.private
9 PRIMITIVE: (format-float) ( n fill width precision format locale -- byte-array )
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 ]
19 : string>digits ( str -- digits )
20 [ digit> ] B{ } map-as ; inline
23 dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
25 ERROR: invalid-radix radix ;
29 ! magnitude is used only for floats to avoid
30 ! expensive computations when we know that
31 ! the result will overflow/underflow.
32 ! The computation of magnitude starts in
33 ! number-parse and continues in float-parse.
36 { length fixnum read-only }
38 { magnitude fixnum } ;
40 : <number-parse> ( str radix -- i number-parse n )
41 [ 0 ] 2dip [ dup length ] dip 0 number-parse boa 0 ; inline
43 : (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
44 [ 2over length>> < ] 2dip
45 [ [ 2over str>> nth-unsafe >fixnum [ 1 fixnum+fast ] 3dip ] prepose ] dip if ; inline
47 : require-next-digit ( i number-parse n quot -- n/f )
48 [ 3drop f ] (next-digit) ; inline
50 : next-digit ( i number-parse n quot -- n/f )
51 [ 2nip ] (next-digit) ; inline
53 : inc-magnitude ( number-parse -- number-parse' )
54 [ 1 fixnum+fast ] change-magnitude ; inline
56 : ?inc-magnitude ( number-parse n -- number-parse' )
57 zero? [ inc-magnitude ] unless ; inline
59 : (add-digit) ( number-parse n digit -- number-parse n' )
60 [ dup radix>> ] [ * ] [ + ] tri* ; inline
62 : add-digit ( i number-parse n digit quot -- n/f )
63 [ (add-digit) [ ?inc-magnitude ] keep ] dip next-digit ; inline
65 : add-exponent-digit ( i number-parse n digit quot -- n/f )
66 [ (add-digit) ] dip next-digit ; inline
68 : digit-in-radix ( number-parse n char -- number-parse n digit ? )
69 digit> pick radix>> over > ; inline
71 : ?make-ratio ( num denom/f -- ratio/f )
72 ! don't use number= to allow 0. for "1/0."
73 [ dup 0 = [ 2drop f ] [ / ] if ] [ drop f ] if* ; inline
81 : inc-point-?dec-magnitude ( float-parse n -- float-parse' )
82 zero? [ [ 1 fixnum-fast ] change-magnitude ] when
83 [ 1 fixnum+fast ] change-point ; inline
85 : store-exponent ( float-parse n expt -- float-parse' n )
86 swap [ >>exponent ] dip ; inline
88 : ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
89 [ store-exponent ] [ drop f ] if* ; inline
91 : pow-until ( base x -- base^x )
93 dup odd? [ [ [ * ] keep ] [ 1 - ] bi* ] when
95 ] until-zero drop ; inline
97 : (pow) ( base x -- base^x )
99 dup 0 >= [ pow-until ] [ [ recip ] [ neg ] bi* pow-until ] if ; inline
101 : add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
103 dup [ inc-point-?dec-magnitude ] curry 3dip
104 ] dip next-digit ; inline
106 ! IEE754 doubles are in the range ]10^309,10^-324[,
107 ! or expressed in base 2, ]2^1024, 2^-1074].
108 ! We don't need those ranges to be accurate as long as we are
109 ! excluding all the floats because they are used only to
110 ! optimize when we know there will be an overflow/underflow
111 ! We compare these numbers to the magnitude slot of float-parse,
112 ! which has the following behavior:
113 ! ... ; 0.0xxx -> -1; 0.xxx -> 0; x.xxx -> 1; xx.xxx -> 2; ...;
114 ! Also, take some margin as the current float parsing algorithm
115 ! does some rounding; For example,
116 ! 0x1.0p-1074 is the smallest IE754 double, but floats down to
117 ! 0x0.8p-1074 (excluded) are parsed as 0x1.0p-1074
118 CONSTANT: max-magnitude-10 309
119 CONSTANT: min-magnitude-10 -323
120 CONSTANT: max-magnitude-2 1027
121 CONSTANT: min-magnitude-2 -1074
123 : make-float-dec-exponent ( float-parse n/f -- float/f )
124 over [ exponent>> ] [ magnitude>> ] bi +
126 { [ dup max-magnitude-10 > ] [ 3drop 1/0. ] }
127 { [ dup min-magnitude-10 < ] [ 3drop 0.0 ] }
129 [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ]
134 : base2-digits ( digits radix -- digits' )
141 : base2-point ( float-parse -- point )
142 [ point>> ] [ radix>> ] bi base2-digits ; inline
144 : base2-magnitude ( float-parse -- point )
145 [ magnitude>> ] [ radix>> ] bi base2-digits ; inline
147 : make-float-bin-exponent ( float-parse n/f -- float/f )
148 over [ exponent>> ] [ base2-magnitude ] bi +
150 { [ dup max-magnitude-2 > ] [ 3drop 1/0. ] }
151 { [ dup min-magnitude-2 < ] [ 3drop 0.0 ] }
153 [ [ drop 2 ] [ base2-point ] [ exponent>> ] tri - (pow) ]
158 : ?default-exponent ( float-parse n/f -- float-parse' n/f' )
160 over radix>> 10 = [ 0 store-exponent ] [ drop f ] if
163 : ?make-float ( float-parse n/f -- float/f )
164 { float-parse object } declare
167 { [ dup not ] [ 2drop f ] }
168 { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
169 [ make-float-bin-exponent ]
172 : bignum-?neg ( n -- -n )
173 dup first-bignum bignum= [ drop most-negative-fixnum ] [ neg ] if ;
175 : fp-?neg ( n -- -n )
176 double>bits 63 2^ bitor bits>double ;
178 : ?neg ( n/f -- -n/f )
181 { [ dup bignum? ] [ bignum-?neg ] }
182 { [ dup fp-nan? ] [ fp-?neg ] }
187 : ?pos ( n/f -- +n/f )
189 double>bits 63 2^ bitnot bitand bits>double
192 : add-ratio? ( n/f -- ? )
193 dup real? [ dup >integer number= not ] [ drop f ] if ;
195 : ?add-ratio ( m n/f -- m+n/f )
196 dup add-ratio? [ + ] [ 2drop f ] if ; inline
198 : @abort ( i number-parse n x -- f )
201 : @split ( i number-parse n -- n i number-parse' n' )
202 -rot 0 >>magnitude 0 ; inline
204 : @split-exponent ( i number-parse n -- n i number-parse' n' )
205 -rot 10 >>radix 0 ; inline
207 : <float-parse> ( i number-parse n -- float-parse i number-parse n )
208 [ drop nip [ radix>> ] [ magnitude>> ] bi [ 0 f ] dip float-parse boa ] 3keep ; inline
210 : if-skip ( char true false -- )
211 pick ",_" member-eq? [ drop nip call ] [ nip call ] if ; inline
213 DEFER: @exponent-digit
214 DEFER: @mantissa-digit
220 : @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
221 [ [ @exponent-digit ] require-next-digit ] [ @exponent-digit ] if-skip ; inline
223 : @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
224 { float-parse fixnum number-parse integer fixnum } declare
225 digit-in-radix [ [ @exponent-digit-or-punc ] add-exponent-digit ] [ @abort ] if ;
227 : @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
229 { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
230 { CHAR: + [ [ @exponent-digit ] require-next-digit ?pos ] }
231 [ @exponent-digit ?pos ]
234 : ->exponent ( float-parse i number-parse n -- float-parse' n/f )
235 @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
237 : exponent-char? ( number-parse n char -- number-parse n char ? )
239 { 10 [ dup "eE" member-eq? ] }
240 [ drop dup "pP" member-eq? ]
243 : or-exponent ( i number-parse n char quot -- n/f )
244 [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
246 : or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
247 [ exponent-char? [ drop ->exponent ] ] dip if ; inline
249 : @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
250 [ [ @mantissa-digit ] require-next-digit ] [ @mantissa-digit ] if-skip ; inline
252 : @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
253 { float-parse fixnum number-parse integer fixnum } declare
256 [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
258 ] or-mantissa->exponent ;
260 : ->mantissa ( i number-parse n -- n/f )
261 <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
263 : ->required-mantissa ( i number-parse n -- n/f )
264 <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
266 : @denom-digit-or-punc ( i number-parse n char -- n/f )
267 [ [ @denom-digit ] require-next-digit ] [
269 { CHAR: . [ ->mantissa ] }
270 [ [ @denom-digit ] or-exponent ]
274 : @denom-digit ( i number-parse n char -- n/f )
275 { fixnum number-parse integer fixnum } declare
276 digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
278 : @denom-first-digit ( i number-parse n char -- n/f )
280 { CHAR: . [ ->mantissa ] }
284 : ->denominator ( i number-parse n -- n/f )
285 { fixnum number-parse integer } declare
286 @split [ @denom-first-digit ] require-next-digit ?make-ratio ;
288 : @num-digit-or-punc ( i number-parse n char -- n/f )
289 [ [ @num-digit ] require-next-digit ] [
291 { CHAR: / [ ->denominator ] }
296 : @num-digit ( i number-parse n char -- n/f )
297 { fixnum number-parse integer fixnum } declare
298 digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
300 : ->numerator ( i number-parse n -- n/f )
301 { fixnum number-parse integer } declare
302 @split [ @num-digit ] require-next-digit ?add-ratio ;
304 : @pos-digit-or-punc ( i number-parse n char -- n/f )
305 [ [ @pos-digit ] require-next-digit ] [
307 { CHAR: + [ ->numerator ] }
308 { CHAR: / [ ->denominator ] }
309 { CHAR: . [ ->mantissa ] }
310 [ [ @pos-digit ] or-exponent ]
314 : @pos-digit ( i number-parse n char -- n/f )
315 { fixnum number-parse integer fixnum } declare
316 digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
318 : ->radix ( i number-parse n quot radix -- i number-parse n quot )
319 [ >>radix ] curry 2dip ; inline
321 : with-radix-char ( i number-parse n radix-quot nonradix-quot -- n/f )
324 { [ dup "bB" member-eq? ] [ 2drop 2 ->radix require-next-digit ] }
325 { [ dup "oO" member-eq? ] [ 2drop 8 ->radix require-next-digit ] }
326 { [ dup "xX" member-eq? ] [ 2drop 16 ->radix require-next-digit ] }
329 ] 2curry next-digit ; inline
331 : @pos-first-digit ( i number-parse n char -- n/f )
333 { CHAR: . [ ->required-mantissa ] }
334 { CHAR: 0 [ [ @pos-digit ] [ @pos-digit-or-punc ] with-radix-char ] }
338 : @neg-digit-or-punc ( i number-parse n char -- n/f )
339 [ [ @neg-digit ] require-next-digit ] [
341 { CHAR: - [ ->numerator ] }
342 { CHAR: / [ ->denominator ] }
343 { CHAR: . [ ->mantissa ] }
344 [ [ @neg-digit ] or-exponent ]
348 : @neg-digit ( i number-parse n char -- n/f )
349 { fixnum number-parse integer fixnum } declare
350 digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
352 : @neg-first-digit ( i number-parse n char -- n/f )
354 { CHAR: . [ ->required-mantissa ] }
355 { CHAR: 0 [ [ @neg-digit ] [ @neg-digit-or-punc ] with-radix-char ] }
359 : @first-char ( i number-parse n char -- n/f )
361 { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
362 { CHAR: + [ [ @pos-first-digit ] require-next-digit ?pos ] }
363 [ @pos-first-digit ?pos ]
366 : @neg-first-digit-no-radix ( i number-parse n char -- n/f )
368 { CHAR: . [ ->required-mantissa ] }
372 : @pos-first-digit-no-radix ( i number-parse n char -- n/f )
374 { CHAR: . [ ->required-mantissa ] }
378 : @first-char-no-radix ( i number-parse n char -- n/f )
380 { CHAR: - [ [ @neg-first-digit-no-radix ] require-next-digit ?neg ] }
381 { CHAR: + [ [ @pos-first-digit-no-radix ] require-next-digit ?pos ] }
382 [ @pos-first-digit-no-radix ?pos ]
387 : string>number ( str -- n/f )
388 10 <number-parse> [ @first-char ] require-next-digit ;
390 : base> ( str radix -- n/f )
391 <number-parse> [ @first-char-no-radix ] require-next-digit ;
393 : bin> ( str -- n/f ) 2 base> ; inline
394 : oct> ( str -- n/f ) 8 base> ; inline
395 : dec> ( str -- n/f ) 10 base> ; inline
396 : hex> ( str -- n/f ) 16 base> ; inline
401 48 48 48 48 48 48 48 48 48 48 49 49 49 49 49 49 49 49 49 49
402 50 50 50 50 50 50 50 50 50 50 51 51 51 51 51 51 51 51 51 51
403 52 52 52 52 52 52 52 52 52 52 53 53 53 53 53 53 53 53 53 53
404 54 54 54 54 54 54 54 54 54 54 55 55 55 55 55 55 55 55 55 55
405 56 56 56 56 56 56 56 56 56 56 57 57 57 57 57 57 57 57 57 57
409 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
410 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
411 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
412 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
413 48 49 50 51 52 53 54 55 56 57 48 49 50 51 52 53 54 55 56 57
416 : (two-digit) ( num accum -- num' accum )
418 100 /mod [ TENS nth-unsafe ] [ ONES nth-unsafe ] bi
419 ] dip [ push ] keep [ push ] keep ; inline
421 : (one-digit) ( num accum -- num' accum )
422 [ 10 /mod CHAR: 0 + ] dip [ push ] keep ; inline
424 : (bignum>dec) ( num accum -- num' accum )
425 [ over most-positive-fixnum > ]
426 [ { bignum sbuf } declare (two-digit) ] while
427 [ >fixnum ] dip ; inline
429 : (fixnum>dec) ( num accum -- num' accum )
430 { fixnum sbuf } declare
431 [ over 10 >= ] [ (two-digit) ] while
432 [ over zero? ] [ (one-digit) ] until ; inline
434 GENERIC: (positive>dec) ( num -- str )
436 M: bignum (positive>dec)
437 12 <sbuf> (bignum>dec) (fixnum>dec) "" like reverse! nip ; inline
439 : (count-digits) ( digits n -- digits' )
441 { [ dup 10 < ] [ drop ] }
442 { [ dup 100 < ] [ drop 1 fixnum+fast ] }
443 { [ dup 1,000 < ] [ drop 2 fixnum+fast ] }
445 dup 1,000,000,000,000 < [
457 dup 10,000,000,000 < [
458 1,000,000,000 >= 9 8 ?
460 100,000,000,000 >= 11 10 ?
464 [ 12 fixnum+fast ] [ 1,000,000,000,000 /i ] bi*
468 } cond ; inline recursive
470 M: fixnum (positive>dec)
471 1 over (count-digits) <sbuf> (fixnum>dec) "" like reverse! nip ; inline
473 : (positive>base) ( num radix -- str )
474 dup 1 <= [ invalid-radix ] when
475 [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
478 : positive>base ( num radix -- str )
479 dup 10 = [ drop (positive>dec) ] [ (positive>base) ] if ; inline
483 GENERIC#: >base 1 ( n radix -- str )
485 : number>string ( n -- str ) 10 >base ; inline
487 : >bin ( n -- str ) 2 >base ; inline
488 : >oct ( n -- str ) 8 >base ; inline
489 : >hex ( n -- str ) 16 >base ; inline
491 ALIAS: >dec number>string
495 { [ over 0 = ] [ 2drop "0" ] }
496 { [ over 0 > ] [ positive>base ] }
497 [ [ neg ] dip positive>base CHAR: - prefix ]
501 [ >fraction [ /mod ] keep ] [ [ >base ] curry tri@ ] bi*
502 "/" glue over first-unsafe {
504 { CHAR: - [ append ] }
510 : (fix-float) ( str-no-exponent -- newstr )
511 CHAR: . over member? [ ".0" append ] unless ; inline
513 : fix-float ( str exponent-char -- newstr )
515 cut [ (fix-float) ] dip append
516 ] [ (fix-float) ] if* ; inline
518 : mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
519 [ dup log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + neg ] bi ]
522 : mantissa-expt ( float -- mantissa expt )
524 [ -0.0 double>bits bitnot bitand -52 shift ] bi
525 mantissa-expt-normalize ;
527 : bin-float-sign ( bits -- str )
528 -0.0 double>bits bitand zero? "" "-" ? ;
530 : bin-float-value ( str size -- str' )
531 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
532 [ "0" ] when-empty "1." prepend ;
534 : float>hex-value ( mantissa -- str )
535 >hex 13 bin-float-value ;
537 : float>oct-value ( mantissa -- str )
538 4 * >oct 18 bin-float-value ;
540 : float>bin-value ( mantissa -- str )
541 >bin 52 bin-float-value ;
543 : bin-float-expt ( mantissa -- str )
544 10 >base "p" prepend ;
546 : (bin-float>base) ( value-quot n -- str )
548 [ bin-float-sign swap ] [
549 mantissa-expt rot [ bin-float-expt ] bi*
550 ] bi 3append ; inline
552 : bin-float>base ( n base -- str )
554 { 16 [ [ float>hex-value ] swap (bin-float>base) ] }
555 { 8 [ [ float>oct-value ] swap (bin-float>base) ] }
556 { 2 [ [ float>bin-value ] swap (bin-float>base) ] }
560 : format-string ( format -- format )
561 0 suffix >byte-array ; foldable
563 : format-float ( n fill width precision format locale -- string )
565 [ format-string ] 4dip [ format-string ] bi@ (format-float)
568 "C" = [ [ "G" = ] [ "E" = ] bi or CHAR: E CHAR: e ? fix-float ]
572 : float>base ( n radix -- str )
574 { 10 [ "" -1 16 "" "C" format-float ] }
582 { [ over fp-nan? ] [ drop fp-sign "-0/0." "0/0." ? ] }
583 { [ over 1/0. = ] [ 2drop "1/0." ] }
584 { [ over -1/0. = ] [ 2drop "-1/0." ] }
585 { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
586 { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
590 : # ( n -- ) number>string % ; inline
592 : hex-string>bytes ( hex-string -- bytes )
593 dup length 2/ <byte-array> [
595 [ digit> ] 2dip over even? [
596 [ 16 * ] [ 2/ ] [ set-nth-unsafe ] tri*
598 [ 2/ ] [ [ + ] change-nth-unsafe ] bi*
603 : bytes>hex-string ( bytes -- hex-string )
604 dup length 2 * CHAR: 0 <string> [
606 [ 16 /mod [ >digit ] bi@ ]
608 [ [ set-nth-unsafe ] curry bi-curry@ bi* ] tri*