retroforth/source/interfaces/io/floatingpoint.forth
crc f7a0698486 source tree reorganizations
FossilOrigin-Name: 654eda2d23299be894f94e8b615e7432de6a3bd5dbb6f4caa454cc20e65a510b
2019-05-02 16:25:16 +00:00

185 lines
5.8 KiB
Forth

~~~
{{
'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 ;
~~~