185 lines
5.8 KiB
Text
185 lines
5.8 KiB
Text
~~~
|
|
{{
|
|
'io:FloatingPoint var
|
|
:identify
|
|
@io:FloatingPoint n:zero? [
|
|
#2 io:scan-for dup n:negative?
|
|
[ drop 'IO_DEVICE_TYPE_0002_NOT_FOUND s:put nl ]
|
|
[ !io:FloatingPoint ] choose ] if ;
|
|
---reveal---
|
|
:io:float-operation identify @io:FloatingPoint io:invoke ;
|
|
}}
|
|
~~~
|
|
|
|
# Floating Point
|
|
|
|
~~~
|
|
:n:to-float (n-_f:-n) #0 io:float-operation ;
|
|
:s:to-float (s-_f:-n) #1 io:float-operation ;
|
|
:f:to-number (f:a-__-n) #2 io:float-operation ;
|
|
:f:to-string (f:n-__-s) s:empty dup #3 io:float-operation ;
|
|
:f:+ (f:ab-c) #4 io:float-operation ;
|
|
:f:- (f:ab-c) #5 io:float-operation ;
|
|
:f:* (f:ab-c) #6 io:float-operation ;
|
|
:f:/ (f:ab-c) #7 io:float-operation ;
|
|
:f:floor (f:ab-c) #8 io:float-operation ;
|
|
:f:ceiling (f:f-f) #9 io:float-operation ;
|
|
:f:sqrt (f:f-f) #10 io:float-operation ;
|
|
:f:eq? (f:ab-c) #11 io:float-operation ;
|
|
:f:-eq? (f:ab-c) #12 io:float-operation ;
|
|
:f:lt? (f:ab-c) #13 io:float-operation ;
|
|
:f:gt? (f:ab-c) #14 io:float-operation ;
|
|
:f:depth (-n) #15 io:float-operation ;
|
|
:f:dup (f:a-aa) #16 io:float-operation ;
|
|
:f:drop (f:a-) #17 io:float-operation ;
|
|
:f:swap (f:ab-ba) #18 io:float-operation ;
|
|
:f:log (f:ab-c) #19 io:float-operation ;
|
|
:f:power (f:ab-c) #20 io:float-operation ;
|
|
:f:sin (f:f-f) #21 io:float-operation ;
|
|
:f:cos (f:f-f) #22 io:float-operation ;
|
|
:f:tan (f:f-f) #23 io:float-operation ;
|
|
:f:asin (f:f-f) #24 io:float-operation ;
|
|
:f:acos (f:f-f) #25 io:float-operation ;
|
|
:f:atan (f:f-f) #26 io:float-operation ;
|
|
:f:push (f:f-) #27 io:float-operation ;
|
|
:f:pop (f:-f) #28 io:float-operation ;
|
|
:f:adepth (-n) #29 io:float-operation ;
|
|
:f:square (f:n-m) f:dup f:* ;
|
|
:f:over (f:ab-aba) f:push f:dup f:pop f:swap ;
|
|
:f:tuck (f:ab-bab) f:dup f:push f:swap f:pop ;
|
|
:f:nip (f:ab-b) f:swap f:drop ;
|
|
:f:drop-pair (f:ab-) f:drop f:drop ;
|
|
:f:dup-pair (f:ab-abab) f:over f:over ;
|
|
:f:rot (f:abc-bca) f:push f:swap f:pop f:swap ;
|
|
:f:positive? (-f__f:a-) #0 n:to-float f:gt? ;
|
|
:f:negative? (-f__f:a-) #0 n:to-float f:lt? ;
|
|
:f:negate (f:a-b) #-1 n:to-float f:* ;
|
|
:f:abs (f:a-b) f:dup f:negative? [ f:negate ] if ;
|
|
:prefix:. (s-__f:-a)
|
|
compiling? [ s:keep ] [ s:temp ] choose &s:to-float class:word ; immediate
|
|
:f:put (f:a-) f:to-string s:put ;
|
|
:f:PI (f:-F) .3.141592 ;
|
|
:f:E (f:-F) .2.718281 ;
|
|
:f:NAN (f:-n) .0 .0 f:/ ;
|
|
:f:INF (f:-n) .1.0 .0 f:/ ;
|
|
:f:-INF (f:-n) .-1.0 .0 f:/ ;
|
|
:f:nan? (f:n-,-f) f:dup f:-eq? ;
|
|
:f:inf? (f:n-,-f) f:INF f:eq? ;
|
|
:f:-inf? (f:n-,-f) f:-INF f:eq? ;
|
|
:f:round (-|f:a-b)
|
|
f:dup f:negative?
|
|
[ .0.5 f:- f:ceiling ]
|
|
[ .0.5 f:+ f:floor ] choose ;
|
|
:f:min (f:nn-n) f:dup-pair f:lt? &f:drop &f:nip choose ;
|
|
:f:max (f:nn-n) f:dup-pair f:gt? &f:drop &f:nip choose ;
|
|
:f:limit (f:nlu-n) f:swap f:push f:min f:pop f:max ;
|
|
:f:between? (f:nlu-n) f:rot f:dup f:push f:rot f:rot f:limit f:pop f:eq? ;
|
|
:f:inc (f:n-n) .1 f:+ ;
|
|
:f:dec (f:n-n) .1 f:- ;
|
|
:f:case (f:ff-,q-)
|
|
f:over f:eq? [ f:drop call #-1 ] [ drop #0 ] choose 0; pop drop-pair ;
|
|
:f:sign (-n|f:a-)
|
|
f:dup .0 f:eq? [ #0 f:drop ] if;
|
|
.0 f:gt? [ #1 ] [ #-1 ] choose ;
|
|
~~~
|
|
|
|
---------------------------------------------------------------
|
|
|
|
# Floating Point Encoding
|
|
|
|
This implements a means of encoding floating point values
|
|
into signed integer cells. The technique is described in
|
|
the paper titled "Encoding floating point numbers to shorter
|
|
integers" by Kiyoshi Yoneda and Charles Childers.
|
|
|
|
This will extend the `f:` vocabulary and adds a new `e:`
|
|
vocabulary.
|
|
|
|
## Code & Commentary
|
|
|
|
Define some constants. The range is slightly reduced from
|
|
the standard integer range as the smallest value is used
|
|
for NaN.
|
|
|
|
~~~
|
|
n:MAX n:dec 'e:MAX const
|
|
n:MAX n:dec n:negate 'e:MIN const
|
|
n:MIN 'e:NAN const
|
|
n:MAX 'e:INF const
|
|
n:MAX n:negate 'e:-INF const
|
|
~~~
|
|
|
|
~~~
|
|
:e:n? (u-f) e:MIN n:inc e:MAX n:dec n:between? ;
|
|
:e:max? (u-f) e:MAX eq? ;
|
|
:e:min? (u-f) e:MIN eq? ;
|
|
:e:zero? (u-f) n:zero? ;
|
|
:e:nan? (u-f) e:NAN eq? ;
|
|
:e:inf? (u-f) e:INF eq? ;
|
|
:e:-inf? (u-f) e:-INF eq? ;
|
|
:e:clip (u-u) e:MIN e:MAX n:limit ;
|
|
~~~
|
|
|
|
Since 32-bit cells take about 9 decimal digits, if you set
|
|
|
|
`[ .1e5 ] &f:E1 set-hook`
|
|
|
|
you will have 5 decimal digits left for the integer part of
|
|
the encoded number, which corresponds to 8 decimal digits
|
|
decoded.
|
|
|
|
Encode/decode words to secure dynamic range. This portion
|
|
is the essence of the method.
|
|
|
|
~~~
|
|
:f:E1 (-|f:-n)_e-unit_in_float hook .1.e5 ; (decimal_digits_to_shift_left
|
|
:f:-shift (|f:n-n)_shift_left f:E1 f:* ;
|
|
:f:+shift (|f:n-n)_shift_right f:E1 f:/ ;
|
|
:f:signed-sqrt (|f:n-n) f:dup f:sign f:abs f:sqrt n:to-float f:* ;
|
|
:f:+encode (|f:n-n) f:signed-sqrt f:-shift ;
|
|
:f:-encode (|f:n-n) f:dup f:sign f:+shift f:dup f:* n:to-float f:* ;
|
|
:f:signed-square (|f:n-n) f:dup f:sign f:dup f:* n:to-float f:* ;
|
|
~~~
|
|
|
|
Deal with special cases.
|
|
|
|
~~~
|
|
:f:to-e (-e|f:n-)
|
|
f:dup f:nan? [ f:drop drop e:NAN ] if;
|
|
f:dup f:inf? [ f:drop drop e:INF ] if;
|
|
f:dup f:-inf? [ f:drop drop e:-INF ] if;
|
|
f:+encode f:round f:to-number e:clip (e
|
|
e:MIN [ f:drop ] case
|
|
e:MAX [ f:drop ] case ;
|
|
|
|
:e:to-f (e-|f:-n)
|
|
e:NAN [ drop f:NAN ] case
|
|
e:INF [ drop f:INF ] case
|
|
e:-INF [ drop f:-INF ] case
|
|
n:to-float f:-encode ;
|
|
~~~
|
|
|
|
~~~
|
|
:f:store (a-|f:n-) [ f:to-e ] dip store ;
|
|
:f:fetch (a-|f:-n) fetch e:to-f ;
|
|
~~~
|
|
|
|
~~~
|
|
:f:dump-stack (-)
|
|
f:depth dup [ f:push ] times
|
|
[ f:pop f:dup f:put sp ] times ;
|
|
:f:dump-astack (-)
|
|
f:adepth dup [ f:pop ] times
|
|
[ f:dup f:put sp f:push ] times ;
|
|
~~~
|
|
|
|
~~~
|
|
:e:put (e-)
|
|
e:MAX [ 'e:MAX s:put ] case
|
|
e:MIN [ 'e:MIN s:put ] case
|
|
#0 [ 'e:0 s:put ] case
|
|
e:NAN [ 'e:NAN s:put ] case
|
|
e:INF [ 'e:INF s:put ] case
|
|
e:-INF [ 'e:-INF s:put ] case
|
|
e:to-f f:put ;
|
|
~~~
|