Adding logs example.

examples/logs.fs

@@ -0,0 +1,96 @@
+#! /usr/bin/env ueforth
+
+also recognizers
+also internals
+
+vocabulary gauss-logs also gauss-logs also gauss-logs definitions
+
+256 constant ~precision
+
+forth definitions
+
+: ~* ( ~ ~ -- ~ ) + ;
+: ~/ ( ~ ~ -- ~ ) - ;
+: ~/1 ( ~ -- ~ ) negate ;
+
+: ~>f ( ~ -- f ) 2e s>f ~precision s>f f/ f** ;
+: f>~ ( f -- ~ ) fln 2e fln f/ ~precision s>f f* 0.5e f+ floor f>s ;
+: ~. ( ~ -- ) ~>f f. ;
+
+gauss-logs definitions
+
+: ~summer ( ~ -- ~ ) ~>f 1e f+ f>~ ;
+: ~differ ( ~ -- ~ ) 1e ~>f f- fabs f>~ ;
+: ~order ( ~ ~ -- ~ ~ ) 2dup max >r min r> ;
+
+0 value entries
+: tabulate
+  begin
+    entries ~summer ,
+    entries ~differ ,
+    1 +to entries
+    entries ~summer entries =
+    entries ~differ entries = and if exit then
+  again
+;
+create table tabulate 
+: ~summer1 ( ~ -- ~ ) dup entries < if 2* cells table + @ then ;
+: ~differ1 ( ~ -- ~ ) dup entries < if 2* 1+ cells table + @ then ;
+
+forth definitions
+
+: ~+ ( ~ ~ -- ~ ) ~order over - ~summer1 + ;
+: ~- ( ~ ~ -- ~ ) ~order over - ~differ1 + ;
+
+gauss-logs definitions
+
+: print-digits   11 0 do i . i s>f f>~ dup . ~. cr loop ;
+: ~dig, ( n -- ) , ;
+create digits ( 1-10 )
+-99999999 ,
+        0 ~dig,
+    65536 ~dig,
+   103872 ~dig,
+   131072 ~dig,
+   152170 ~dig,
+   169408 ~dig,
+   183983 ~dig,
+   196608 ~dig,
+   207744 ~dig,
+   217706 ~dig,
+: dig ( n n -- ~ ) >r cells digits + @ r> * ~precision 65536 */ ;
+: ~>s ( ~ -- n ) ~>f f>s ;
+: s>~ ( n -- ~ ) s>f f>~ ;
+
+0 value result
+0 value places
+0 value fract
+: !digit ( ch -- ) dup [char] 0 < over [char] 9 > or if -1 throw then ;
+: =digit ( ch -- )
+  dup [char] . = if drop -1 to fract exit then
+  !digit
+  [char] 0 - to result ;
+: +digit ( ch -- )
+  dup [char] . = if drop -1 to fract exit then
+  !digit
+  fract if 1 +to places then
+  [char] 0 - result 10 * + to result ;
+: ~conv ( a n -- )
+  >r 1+ dup c@ =digit r>
+  2 - for aft 1+ dup c@ +digit then next
+  drop
+  result s>~ 10 places dig ~/
+  ['] aliteral rectype-num
+;
+: rec-~ ( a n -- )
+  dup 2 < if 2drop rectype-none exit then
+  over c@ [char] ~ <> if 2drop rectype-none exit then
+  0 to fract
+  0 to result
+  0 to places
+  ['] ~conv catch if 2drop rectype-none exit then
+;
+' rec-~ +recognizer
+
+forth definitions
+previous previous previous previous