mirror of
https://git.sr.ht/~crc_/retroforth
synced 2024-11-16 19:48:56 +01:00
274 lines
7.3 KiB
Text
274 lines
7.3 KiB
Text
## Helpers
|
|
|
|
~~~
|
|
:s:shout (s-) '!_ s:prepend s:put nl 'Stack_:_ s:put dump-stack nl ;
|
|
{{
|
|
'Depth var
|
|
:message (-)
|
|
'abort_with__trail__invoked s:shout nl
|
|
'Do__reset__to_clear_stack. s:put nl ;
|
|
:put-name (a-) fetch d:lookup-xt
|
|
dup n:-zero? [ d:name s:put nl ] [ drop ] choose ;
|
|
---reveal---
|
|
:trail repeat pop put-name again ;
|
|
:abort (-?) depth !Depth message trail ;
|
|
:s:abort (s-) 's:abort_:_ s:prepend s:put nl abort ;
|
|
}}
|
|
|
|
{{
|
|
:f:dump-astack (-)_dump_alternative_stack
|
|
f:adepth [ [ f:pop ] times ] sip 'fa_ s:put [ f:dup f:put sp f:push ] times ;
|
|
:dump-stacks (-) dump-stack nl f:dump-stack nl f:dump-astack ;
|
|
---reveal---
|
|
:s (-)___Stack dump-stacks ;
|
|
}}
|
|
|
|
{{
|
|
:f:reset (-|float:?-) f:depth [ f:drop ] times ;
|
|
:f:areset (-|alt:?-) f:depth [ f:pop f:drop ] times ;
|
|
:reset.nf (?-|float:?-) reset f:reset f:areset ;
|
|
---reveal---
|
|
:r (?-)__Reset reset.nf ;
|
|
}}
|
|
|
|
~~~
|
|
|
|
## Description
|
|
|
|
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.
|
|
Here `e:` stands for encoded.
|
|
|
|
## 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? (e-f) e:MIN n:inc e:MAX n:dec n:between? ;
|
|
:e:max? (e-f) e:MAX eq? ;
|
|
:e:min? (e-f) e:MIN eq? ;
|
|
:e:zero? (e-f) n:zero? ;
|
|
:e:nan? (e-f) e:NAN eq? ;
|
|
:e:inf? (e-f) e:INF eq? ;
|
|
:e:-inf? (e-f) e:-INF eq? ;
|
|
:e:clip (e-e) e:MIN e:MAX n:limit ;
|
|
~~~
|
|
|
|
Since 32-bit cell takes about 9 decimal digits, if you set
|
|
|
|
`[ .1e5 ] f:E1 set-hook`
|
|
|
|
you will have 4 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 ;
|
|
~~~
|
|
|
|
```
|
|
r .-1234.56789 f:to-e s e:to-f s
|
|
```
|
|
|
|
~~~
|
|
: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 ;
|
|
~~~
|
|
|
|
~~~
|
|
: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 ;
|
|
~~~
|
|
|
|
```
|
|
r .-1234.56789 f:to-e e:put
|
|
```
|
|
|
|
## Higher precision variables
|
|
|
|
Here are words to encode floating point numbers into two cells.
|
|
|
|
Words defined up to this point store
|
|
floating point numbers, which are often 64-bit or 2-cell numbers,
|
|
into signed integers, which are always 32-bit or 1-cell numbers.
|
|
The encoding causes loss in both precision and dynamic range.
|
|
|
|
Words defined below encode floating point numbers into
|
|
two integers occupying two 32-bit cells.
|
|
|
|
Two different ways are implemented:
|
|
|
|
- `w1` uses fixed point encoding.
|
|
Splits a floating point number into the integer and the fraction
|
|
parts to store them in two cells.
|
|
This is faster with a narrower dynamic range.
|
|
- `w2` uses sqrt-encoding described in doc/SqrtEncoding.pdf .
|
|
This is slower with a relatively wider dynamic range,
|
|
but likely not as wide as the original floating point.
|
|
|
|
Since Retro's cells are 32-bit,
|
|
it is more convenient to handle floating point numbers
|
|
encoded into single cells than into pairs of cells.
|
|
For instance, consider using the `a:` words for vectors.
|
|
Hence in many cases the words found by doing
|
|
|
|
'e: d:words-with
|
|
|
|
are suitable.
|
|
However, sometimes a higher precision is desired at a higher cost.
|
|
|
|
These are the same as `f:+encode` and `f:-encode` except that they come
|
|
without `f:-shift` and `f:+shift` .
|
|
|
|
~~~
|
|
:f:+encode.w2 (|f:n-n) f:dup f:sign f:abs f:sqrt n:to-float f:* ;
|
|
:f:-encode.w2 (|f:n-n) f:dup f:sign f:dup f:* n:to-float f:* ;
|
|
~~~
|
|
|
|
```
|
|
r .-12345.6789 f:+encode.w2 s f:-encode.w2 s
|
|
```
|
|
|
|
Split encoded floating point numbers into the integer and the fraction parts.
|
|
The sign goes to the integer part.
|
|
The fractional part is that of the absolute value.
|
|
|
|
~~~
|
|
{{
|
|
:f:+shift9 .1.e-9 f:* ;
|
|
:f:-shift9 .1.e9 f:* ;
|
|
---reveal---
|
|
|
|
:f:+split (-|f:n-fi)_absFrac.-shift9_signedInt
|
|
f:dup f:sign (s|f:_n
|
|
f:abs f:dup f:floor f:swap f:over (s|f:_abs.int_abs_abs.int
|
|
f:- f:-shift9 (s|f:_abs.int_abs.frac.-shift9
|
|
f:swap n:to-float f:* (_|f:_abs.frac.-shift9_signedInt
|
|
;
|
|
|
|
:f:-split (-|f:fi-n)
|
|
f:dup f:sign f:abs (s|f:_abs.frac.-shift9_abs.int
|
|
f:swap f:+shift9 f:+ n:to-float f:* (_|f:_n
|
|
;
|
|
}}
|
|
~~~
|
|
|
|
```
|
|
r .-123456789.0987654321 f:+split s f:-split s
|
|
```
|
|
|
|
From float to double cells w2 .
|
|
And its inverse.
|
|
|
|
~~~
|
|
:f:to-w1 (-fi|f:n-)_frac_sInt f:+split f:to-number f:to-number swap ;
|
|
:w1:to-f (fi-|f:-n) swap n:to-float n:to-float f:-split ;
|
|
:f:to-w2 (-fi|f:n-)_frac_sInt f:+encode.w2 f:to-w1 ;
|
|
:w2:to-f (fi-|f:-n) w1:to-f f:-encode.w2 ;
|
|
~~~
|
|
|
|
```
|
|
r .-123456789.0987654321 f:to-w2 s w2:to-f s
|
|
```
|
|
|
|
`f:var1` and `f:var2` take initial values.
|
|
|
|
~~~
|
|
{{
|
|
:f:SATURATE1 (|f:-n) n:MAX n:to-float ;
|
|
:f:overflow-check1 (|f:n-n)
|
|
f:dup f:abs f:SATURATE1 f:gt?
|
|
[ f:put nl 'f:var1_overflow s:abort ] if ;
|
|
---reveal---
|
|
:f:var1 (s-|f:n-) f:overflow-check1 f:to-w1 rot d:create , , ;
|
|
:f:@1 (a-|f:-n) fetch-next [ fetch ] dip w1:to-f ;
|
|
:f:!1 (a-|f:n-) f:overflow-check1 f:to-w1 rot store-next store ;
|
|
}}
|
|
~~~
|
|
|
|
```
|
|
r
|
|
.-123456789.0987654321 'FVar1 f:var1
|
|
&FVar1 f:@1 s
|
|
r
|
|
.-98765.4321 &FVar1 f:!1
|
|
&FVar1 f:@1 s
|
|
```
|
|
|
|
.-9876543210.123456789 &FVar1 f:@1 (This_test_should__abort
|
|
.1.e20 &FVar1 f:!1 (This_test_should__abort
|
|
|
|
~~~
|
|
{{
|
|
:f:SATURATE2 (|f:-n) n:MAX n:to-float f:dup f:* ;
|
|
:f:overflow-check2 (|f:n-n)
|
|
f:dup f:abs f:SATURATE2 f:gt?
|
|
[ f:put nl 'f:var2_overflow s:abort ] if ;
|
|
---reveal---
|
|
:f:var2 (s-|f:n-) f:overflow-check2 f:to-w2 rot d:create , , ;
|
|
:f:@2 (a-|f:-n) fetch-next [ fetch ] dip w2:to-f ;
|
|
:f:!2 (a-|f:n-) f:overflow-check2 f:to-w2 rot store-next store ;
|
|
}}
|
|
~~~
|
|
|
|
```
|
|
r
|
|
.-123456789.0987654321 'FVar2 f:var2
|
|
&FVar2 f:@2 s
|
|
r
|
|
.-9876543210.123456789 &FVar2 f:!2
|
|
&FVar2 f:@2 s
|
|
```
|
|
|
|
.1.e20 &FVar2 f:!2 (This_test_should_abort
|
|
|