/core/math/parser/parser.factor

  1! (c)2009 Joe Groff bsd license
  2USING: accessors byte-arrays combinators kernel kernel.private
  3make math namespaces sequences sequences.private splitting
  4strings ;
  5IN: 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
 14ERROR: invalid-radix radix ;
 15
 16<PRIVATE
 17
 18TUPLE: 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
 48TUPLE: 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
113DEFER: @exponent-digit
114DEFER: @mantissa-digit
115DEFER: @denom-digit
116DEFER: @num-digit
117DEFER: @pos-digit
118DEFER: @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
279PRIVATE>
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
303PRIVATE>
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
318PRIVATE>
319
320GENERIC# >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
329SYMBOL: radix
330SYMBOL: 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
339PRIVATE>
340
341M: 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
352M: 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
416PRIVATE>
417
418: float>string ( n -- str )
419    10 float>base ; inline
420
421M: 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