├── forth-src ├── asm.4th ├── lz77.4th ├── forth2html.4th ├── games │ ├── ocr.4th │ ├── keycal.4th │ ├── queens.4th │ ├── hanoi.4th │ └── magic.4th ├── fsl │ ├── extras │ │ ├── curvefit.4th │ │ ├── zerf.4th │ │ ├── func_Ngauss.4th │ │ ├── four1-test.4th │ │ ├── find.4th │ │ ├── interp-array.4th │ │ ├── noise-test.4th │ │ ├── simpson-nu.4th │ │ ├── qsort.4th │ │ ├── read_xyfile.4th │ │ ├── derivative.4th │ │ ├── four1.4th │ │ └── numerov.4th │ ├── demo │ │ ├── lfex.4th │ │ ├── pfex.4th │ │ ├── 2D_integral_01.4th │ │ └── sigfig-example.4th │ ├── fsl-test-utils.4th │ ├── logistic.4th │ ├── dd │ │ └── test-runge4-dd.4th │ ├── factorl.4th │ ├── expint.4th │ ├── prng.4th │ ├── permcomb.4th │ └── fsl-tester.4th ├── fcalls.4th ├── libs │ ├── x11 │ │ ├── libX11.4th │ │ ├── Xatom.4th │ │ ├── Xft.4th │ │ └── fontcursor.4th │ ├── gmp │ │ ├── libgmp.4th │ │ ├── libmpfr.4th │ │ ├── mpfr-utils.4th │ │ ├── mpfr_airy.4th │ │ ├── mpfr_gamma.4th │ │ ├── mpfr_bessel.4th │ │ ├── mpfr_demo01.4th │ │ └── qmpfr.4th │ ├── blas │ │ └── make.inc │ └── cfitsio │ │ ├── fits-ex2.4th │ │ └── fits-ex1.4th ├── tester.4th ├── hmac-md5-test.4th ├── daq │ ├── gpib │ │ ├── gpib.4th │ │ └── gpib-test.4th │ └── hp │ │ └── hp34401.4th ├── benchmarks │ ├── fib.4th │ ├── sieve.4th │ ├── matrix-mult.4th │ └── bubble-sort.4th ├── closures.4th ├── poems │ ├── poem007.txt │ ├── poem004.txt │ ├── poem003.txt │ ├── poem005.txt │ ├── poem008.txt │ ├── poem002.txt │ ├── poem001.txt │ └── poem006.txt ├── catch-throw-ex.4th ├── x11 │ ├── hello-world-x11.4th │ ├── symfonts-test-x11.4th │ ├── font-properties-x11.4th │ └── banner-x11.4th ├── qm │ ├── iswap.4th │ ├── bket.4th │ └── H2-potnl-pac2010.dat ├── chr_tbl.4th ├── sigfpe.4th ├── speech.4th ├── term.4th ├── dump.4th ├── dummy-comm.4th ├── 3ds.4th ├── ioctl.4th ├── serial-comm.4th ├── system-test │ ├── asm-x86-test.4th │ └── fpzero-test.4th ├── eispack │ └── demo │ │ ├── rsymm-02.4th │ │ ├── rsymm-01.4th │ │ └── rsytr-01.4th ├── struct-ext.4th ├── rs232-switch-test.4th ├── dd-test.4th ├── struct-200x-ext.4th ├── random.4th ├── hexterm.4th ├── rational.4th ├── signals-ex.4th ├── fsm-example.4th ├── macro.4th ├── crc-32-x86.4th ├── pde2.4th ├── jd.4th ├── user.4th ├── struct-200x.4th ├── client.4th ├── dos2unix.4th ├── mlp-telugu.4th ├── slurp-file.4th ├── spinlock-ex.4th ├── textbox.4th ├── ftran-test.4th ├── bifurc-logmap.4th ├── signed-include.4th ├── signal.4th ├── mini-oof.4th ├── mini-oof-demo.4th ├── rs232-switch.4th ├── phyconsts.4th ├── fpu-x86.4th ├── literate-included.fs ├── mc.4th ├── struct.4th └── 3ds-transform.4th ├── doc ├── sl.pdf ├── forth-2012.pdf ├── modular-forth.pdf ├── literate-included.pdf ├── kForth-32 Manual-2.x.pdf └── kForth_NonstandardFeatures.pdf ├── src ├── kfmacros.h └── ForthCompiler.h └── kforth.xpm /forth-src/asm.4th: -------------------------------------------------------------------------------- 1 | asm-x86.4th -------------------------------------------------------------------------------- /doc/sl.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/sl.pdf -------------------------------------------------------------------------------- /doc/forth-2012.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/forth-2012.pdf -------------------------------------------------------------------------------- /forth-src/lz77.4th: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/forth-src/lz77.4th -------------------------------------------------------------------------------- /doc/modular-forth.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/modular-forth.pdf -------------------------------------------------------------------------------- /doc/literate-included.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/literate-included.pdf -------------------------------------------------------------------------------- /forth-src/forth2html.4th: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/forth-src/forth2html.4th -------------------------------------------------------------------------------- /forth-src/games/ocr.4th: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/forth-src/games/ocr.4th -------------------------------------------------------------------------------- /doc/kForth-32 Manual-2.x.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/kForth-32 Manual-2.x.pdf -------------------------------------------------------------------------------- /doc/kForth_NonstandardFeatures.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/doc/kForth_NonstandardFeatures.pdf -------------------------------------------------------------------------------- /forth-src/fsl/extras/curvefit.4th: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mynenik/kForth-32/HEAD/forth-src/fsl/extras/curvefit.4th -------------------------------------------------------------------------------- /forth-src/fcalls.4th: -------------------------------------------------------------------------------- 1 | \ fcalls.4th 2 | \ 3 | 1 CELLS 8 = [IF] 4 | s" fcalls-x86_64.4th" included 5 | [ELSE] 6 | s" fcalls-x86.4th" included 7 | [THEN] 8 | 9 | -------------------------------------------------------------------------------- /forth-src/libs/x11/libX11.4th: -------------------------------------------------------------------------------- 1 | \ libX11.4th 2 | \ 3 | \ Load bindings for the X Windows Xlib Library 4 | \ 5 | 1 CELLS 8 = [IF] 6 | s" libs/x11/libX11_x86_64.4th" included 7 | [ELSE] 8 | s" libs/x11/libX11_x86.4th" included 9 | [THEN] 10 | 11 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/libgmp.4th: -------------------------------------------------------------------------------- 1 | \ libgmp.4th 2 | \ 3 | \ Load bindings for the GNU Mulitprecision Library 4 | \ 5 | 1 CELLS 8 = [IF] 6 | s" libs/gmp/libgmp_x86_64.4th" included 7 | [ELSE] 8 | s" libs/gmp/libgmp_x86.4th" included 9 | [THEN] 10 | 11 | -------------------------------------------------------------------------------- /forth-src/tester.4th: -------------------------------------------------------------------------------- 1 | \ drop-in replacement for John Hayes' tester 2 | 3 | \ This file is in the public domain. NO WARRANTY. 4 | \ Note licensing for ttester 5 | 6 | S" ans-words" INCLUDED 7 | S" ttester" INCLUDED 8 | 9 | : { T{ ; 10 | 11 | : } }T ; 12 | 13 | HEX 14 | -------------------------------------------------------------------------------- /forth-src/hmac-md5-test.4th: -------------------------------------------------------------------------------- 1 | \ test-md5.4th 2 | \ 3 | \ Test proper operation of hmac-md5.4th 4 | \ 5 | include ans-words 6 | include strings 7 | include files 8 | include macro 9 | include hmac-md5 10 | 11 | \ Run tests and exit Forth system 12 | hmac-tests 13 | bye 14 | 15 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/libmpfr.4th: -------------------------------------------------------------------------------- 1 | \ libmpfr.4th 2 | \ 3 | \ Load bindings for the GNU Multi-Precision Floating point library 4 | \ with correct Rounding 5 | \ 6 | 1 CELLS 8 = [IF] 7 | s" libs/gmp/libmpfr_x86_64.4th" included 8 | [ELSE] 9 | s" libs/gmp/libmpfr_x86.4th" included 10 | [THEN] 11 | 12 | -------------------------------------------------------------------------------- /forth-src/daq/gpib/gpib.4th: -------------------------------------------------------------------------------- 1 | \ gpib.4th 2 | \ 3 | \ Loader for Forth to Linux GPIB driver interface 4 | \ 5 | 1 cells 8 = [IF] 6 | cr .( Loading 64-bit GPIB interface. ) cr 7 | include daq/gpib/gpib64 8 | [ELSE] 9 | cr .( Loading 32-bit GPIB interface. ) cr 10 | include daq/gpib/gpib32 11 | [THEN] 12 | 13 | -------------------------------------------------------------------------------- /forth-src/benchmarks/fib.4th: -------------------------------------------------------------------------------- 1 | \ fib.4th 2 | \ 3 | \ Forth benchmark 4 | \ 5 | \ To time the execution, type 6 | \ 7 | \ ms@ 34 fib drop ms@ swap - . 8 | \ 9 | 10 | : fib ( n1 -- n2 ) 11 | dup 2 < if 12 | drop 1 13 | else 14 | dup 15 | 1- recurse 16 | swap 2 - recurse 17 | + 18 | then ; 19 | 20 | : main 34 fib . ; 21 | -------------------------------------------------------------------------------- /forth-src/closures.4th: -------------------------------------------------------------------------------- 1 | \ closures.4th 2 | \ 3 | \ Provides run-time generated unnamed functions which 4 | \ bind runtime-computed value(s). 5 | \ 6 | \ From Ruvim on comp.lang.forth, 10/17/2022 7 | \ https://groups.google.com/g/comp.lang.forth/c/g-Je7CXe6DA/m/rbqXIIe3BQAJ 8 | \ 9 | 10 | : partial1 ( x xt1 -- xt2 ) 11 | 2>r :noname r> r> postpone literal compile, 12 | postpone ; 13 | ; 14 | 15 | : cl[n:d postpone [: ; immediate 16 | : ]cl postpone ;] postpone partial1 ; immediate 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /forth-src/poems/poem007.txt: -------------------------------------------------------------------------------- 1 | poem There Will Come Soft Rains 2 | Sara Teasdale 3 | 4 | There will come soft rains and the smell of the ground, 5 | And swallows circling with their shimmering sound; 6 | 7 | And frogs in the pools singing at night, 8 | And wild plum trees in tremulous white; 9 | 10 | Robins will wear their feathery fire, 11 | Whistling their whims on a low fence-wire; 12 | 13 | And not one will know of the war, not one 14 | Will care at last when it is done. 15 | 16 | Not one would mind, neither bird nor tree, 17 | If mankind perished utterly; 18 | 19 | And Spring herself, when she woke at dawn 20 | Would scarcely know that we were gone. 21 | 22 | fin 23 | 24 | 25 | -------------------------------------------------------------------------------- /forth-src/fsl/demo/lfex.4th: -------------------------------------------------------------------------------- 1 | \ lfex.4th 2 | \ 3 | \ Demonstrate use of polynomial fitting words to 4 | \ fit a straight line to data and determine the 5 | \ slope and y-intercept 6 | \ 7 | include ans-words 8 | include fsl-util 9 | include dynmem 10 | include determ 11 | include polyfit 12 | 13 | \ Set up x and y arrays 14 | 15 | 8 constant NP 16 | 17 | NP FLOAT array x{ 18 | 101.6e 105.0e 113.4e 124.0e 128.3e 133.4e 138.0e 146.3e NP x{ }fput 19 | 20 | NP FLOAT array y{ 21 | 699.6e 712.0e 740.8e 774.8e 792.0e 807.6e 825.2e 852.4e NP y{ }fput 22 | 23 | 2 FLOAT array a{ 24 | 25 | x{ y{ a{ 1 NP polfit fdrop 26 | 27 | cr cr 28 | .( Slope = ) a{ 1 } F@ F. cr 29 | .( y-intercept = ) a{ 0 } F@ F. cr 30 | -------------------------------------------------------------------------------- /forth-src/catch-throw-ex.4th: -------------------------------------------------------------------------------- 1 | \ catch-throw-ex.4th 2 | \ 3 | \ Example of exception handling in Forth using 4 | \ THROW and CATCH. See DPANS94, sec. A.9.6.1.2275 5 | \ 6 | 7 | include ans-words 8 | 9 | : could-fail ( -- char ) 10 | KEY DUP [CHAR] Q = 11 | IF 1 THROW THEN 12 | ; 13 | 14 | : do-it ( a b -- c) 2DROP could-fail ; 15 | 16 | : try-it ( -- ) 17 | 1 2 ['] do-it CATCH IF 18 | 2DROP ." There was an exception" CR 19 | ELSE 20 | ." The character was " EMIT CR 21 | THEN 22 | ; 23 | 24 | : retry-it ( -- ) 25 | BEGIN 26 | 1 2 ['] do-it CATCH 27 | WHILE 28 | 2DROP ." Exception, keep trying" CR 29 | REPEAT 30 | ." The character was " EMIT CR 31 | ; 32 | -------------------------------------------------------------------------------- /forth-src/poems/poem004.txt: -------------------------------------------------------------------------------- 1 | poem Brahma 2 | Ralph Waldo Emerson 3 | 4 | If the red slayer think he slays, 5 | Or if the slain think he is slain, 6 | They know not well the subtle ways 7 | I keep, and pass, and turn again. 8 | 9 | Far or forgot to me is near; 10 | Shadow and sunlight are the same; 11 | The vanished gods to me appear; 12 | And one to me are shame and fame. 13 | 14 | They reckon ill who leave me out; 15 | When me they fly, I am the wings; 16 | I am the doubter and the doubt, 17 | And I the hymn the Brahmin sings. 18 | 19 | The strong gods pine for my abode, 20 | And pine in vain the sacred Seven; 21 | But thou, meek lover of the good! 22 | Find me, and turn thy back on heaven. 23 | 24 | fin 25 | 26 | 27 | -------------------------------------------------------------------------------- /forth-src/poems/poem003.txt: -------------------------------------------------------------------------------- 1 | poem A Summer Day By The Sea 2 | Henry Wadsworth Longfellow 3 | 4 | The sun is set; and in his latest beams 5 | Yon little cloud of ashen gray and gold, 6 | Slowly upon the amber air unrolled, 7 | The falling mantle of the Prophet seems. 8 | From the dim headlands many a light-house gleams, 9 | The street-lamps of the ocean; and behold, 10 | O'erhead the banners of the night unfold; 11 | The day hath passed into the land of dreams. 12 | O summer day beside the joyous sea! 13 | O summer day so wonderful and white, 14 | So full of gladness and so full of pain! 15 | Forever and forever shalt thou be 16 | To some the gravestone of a dead delight, 17 | To some the landmark of a new domain. 18 | 19 | fin 20 | -------------------------------------------------------------------------------- /forth-src/poems/poem005.txt: -------------------------------------------------------------------------------- 1 | poem Evening Star 2 | Edgar Allan Poe 3 | 4 | 'Twas noontide of summer, 5 | And midtime of night, 6 | And stars, in their orbits, 7 | Shone pale, through the light 8 | Of the brighter, cold moon. 9 | 'Mid planets her slaves, 10 | Herself in the Heavens, 11 | Her beam on the waves. 12 | 13 | I gazed awhile 14 | On her cold smile; 15 | Too cold, too cold for me, 16 | There passed, as a shroud, 17 | A fleecy cloud, 18 | And I turned away to thee, 19 | Proud Evening Star, 20 | In thy glory afar 21 | And dearer thy beam shall be; 22 | For joy to my heart 23 | Is the proud part 24 | Thou bearest in Heaven at night, 25 | And more I admire 26 | Thy distant fire, 27 | Than that colder, lowly light. 28 | 29 | fin 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /forth-src/poems/poem008.txt: -------------------------------------------------------------------------------- 1 | poem The Death Of Lincoln 2 | William Cullen Bryant 3 | 4 | OH, slow to smit and swift to spare, 5 | Gentle and merciful and just! 6 | Who, in the fear of God, didst bear 7 | The sword of power, a nation's trust! 8 | 9 | In sorrow by thy bier we stand, 10 | Amid the awe that hushes all, 11 | And speak the anguish of a land 12 | That shook with horror at thy fall. 13 | 14 | Thy task is done; the bond of free; 15 | We bear thee to an honored grave, 16 | Whose proudest monument shall be 17 | The broken fetters of the slave. 18 | 19 | Pure was thy life; its bloddy close 20 | Hath placed thee with the sons of light, 21 | Among the noble host of those 22 | Who perished in the cause of Right 23 | 24 | fin 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /forth-src/x11/hello-world-x11.4th: -------------------------------------------------------------------------------- 1 | \ hello-world-x11.4th 2 | \ 3 | \ The Hello-World program in the simple-frames presentation 4 | \ framework. 5 | \ 6 | \ 7 | include ans-words 8 | include modules 9 | include syscalls 10 | include mc 11 | include asm 12 | include strings 13 | include lib-interface 14 | include libs/x11/libX11 15 | include x11/font-strings-x11 16 | include x11/simple-graphics-x11 17 | include x11/simple-fonts-x11 18 | include x11/simple-typeset-x11 19 | include x11/simple-frames-x11 20 | 21 | Also font-strings-x11 22 | Also simple-graphics-x11 23 | Also simple-fonts-x11 24 | Also simple-typeset-x11 25 | Also simple-frames-x11 26 | 27 | 28 | : frame1 ( -- ) 10 s" Hello World!" place-centered-text ; 29 | 30 | ' frame1 31 | 1 set-frames 32 | start-frames 33 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/zerf.4th: -------------------------------------------------------------------------------- 1 | \ zerf.4th 2 | \ 3 | \ Error function and Complementary Error Function of 4 | \ a complex number. 5 | \ 6 | \ Provides: 7 | \ 8 | \ ZERF 9 | \ ZERFC 10 | \ 11 | \ Krishna Myneni 12 | \ 13 | \ Requires: 14 | \ fsl-util.4th 15 | \ complex.4th 16 | \ zwofz.4th 17 | \ 18 | \ Revisions: 19 | \ 2010-12-08 km created. 20 | \ 2011-09-16 km use Neal Bridges' anonymous modules. 21 | \ 2012-02-19 km use KM/DNW's modules library. 22 | 23 | BEGIN-MODULE 24 | 25 | BASE @ 26 | DECIMAL 27 | 28 | Private: 29 | zvariable eterm 30 | 31 | Public: 32 | 33 | : zerfc ( z1 -- z2 ) 34 | zdup z^2 znegate zexp eterm z! 35 | i* zwofz drop eterm z@ z* ; 36 | 37 | : zerf ( z1 -- z2 ) 38 | 1e 0e zswap zerfc z- ; 39 | 40 | BASE ! 41 | END-MODULE 42 | -------------------------------------------------------------------------------- /forth-src/qm/iswap.4th: -------------------------------------------------------------------------------- 1 | \ iswap.4th 2 | \ 3 | \ iSWAP 2-qubit gate in an n-qubit circuit 4 | \ 5 | \ K. Myneni, 2019-11-13 6 | \ 7 | \ Requires: qcsim.4th 8 | \ 9 | 10 | variable sw_i 11 | variable sw_j 12 | 13 | : U_isw ( i j n -- q ) 14 | >r sw_j ! sw_i ! 15 | one one one one \ -- g1 g2 g3 g4 16 | r> 0 ?DO 17 | I sw_i @ = I sw_j @ = or IF 18 | 2>r P1 swap %x% swap P0 swap %x% swap 2r> 19 | I sw_i @ = IF 20 | P01 swap %x% swap P10 swap %x% swap 21 | ELSE 22 | P10 swap %x% swap P01 swap %x% swap 23 | THEN 24 | ELSE 25 | >r >r >r 26 | I1 swap %x% 27 | I1 r> %x% 28 | I1 r> %x% 29 | I1 r> %x% 30 | THEN 31 | LOOP 32 | >r >r z=i r> z*q z=i r> z*q 33 | q+ q+ q+ ; 34 | 35 | -------------------------------------------------------------------------------- /forth-src/benchmarks/sieve.4th: -------------------------------------------------------------------------------- 1 | \ sieve.4th 2 | \ 3 | \ Forth benchmark 4 | \ 5 | \ To time the benchmark, type 6 | \ 7 | \ time&date main time&date .s 8 | \ 9 | : secs time&date swap 60 * + swap 3600 * + nip nip nip ; 10 | 11 | create flags 8190 allot 12 | variable eflag 13 | 14 | : primes ( -- n ) 15 | flags 8190 1 fill 16 | 0 3 eflag a@ flags 17 | do 18 | i c@ 19 | if 20 | i over + 21 | dup eflag a@ < 22 | if 23 | eflag a@ swap 24 | do 0 i c! dup +loop 25 | else 26 | drop 27 | then 28 | swap 1+ swap 29 | then 30 | 2+ 31 | loop 32 | drop ; 33 | 34 | : benchmark 35 | 0 1000 0 do primes nip loop ; 36 | 37 | 38 | : main 39 | flags 8190 + eflag ! 40 | benchmark . 41 | ; 42 | 43 | \ HPPA/720, 50 MHz: user 3.90s 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/mpfr-utils.4th: -------------------------------------------------------------------------------- 1 | \ mpfr-utils.4th 2 | \ 3 | \ utilities for mpfr types 4 | \ 5 | 6 | create mpstr 256 allot 7 | create mpexp 16 allot 8 | 9 | \ Output a multi-precision float to specified number of digits in 10 | \ base 10 using standard rounding 11 | : mp>str ( amp u -- addr u ) 12 | 2>r mpstr mpexp 10 2r@ swap GMP_RNDN mpfr_get_str drop 13 | mpstr 2r> nip ; 14 | 15 | : mpfr. ( amp u -- ) 16 | mp>str 17 | over c@ [char] - = IF 18 | [char] - emit 19 | 1- swap 1+ swap 20 | THEN 21 | [char] 0 emit [char] . emit type 22 | [char] E emit mpexp @ s>string count type ; 23 | 24 | \ Compare significant digits in string with value in a multi-precision 25 | \ variable. Return 0 if dst agrees to u significant digits; non-zero 26 | \ otherwise 27 | : sdcomp ( addr u amp -- n ) over mp>str compare ; 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /forth-src/x11/symfonts-test-x11.4th: -------------------------------------------------------------------------------- 1 | \ symfonts-test-x11.4th 2 | \ 3 | \ Test use of the Symbol fonts in the simple-frames-x11 4 | \ presentation framework. 5 | \ 6 | \ K. Myneni, 2012-05-01 7 | \ 8 | 9 | include ans-words 10 | include modules 11 | include syscalls 12 | include mc 13 | include asm 14 | include strings 15 | include lib-interface 16 | include libs/x11/libX11 17 | include x11/font-strings-x11 18 | include x11/simple-graphics-x11 19 | include x11/simple-fonts-x11 20 | include x11/simple-typeset-x11 21 | include x11/simple-frames-x11 22 | 23 | Also font-strings-x11 24 | Also simple-graphics-x11 25 | Also simple-fonts-x11 26 | Also simple-typeset-x11 27 | Also simple-frames-x11 28 | 29 | : frame1 30 | medium regular 140 SymbolFonts select-font 31 | 10 s" a^2 + b^2 = g^2" place-centered-text 32 | ; 33 | 34 | ' frame1 35 | 1 set-frames 36 | start-frames 37 | 38 | -------------------------------------------------------------------------------- /forth-src/chr_tbl.4th: -------------------------------------------------------------------------------- 1 | \ Automatic character encoding tables 2 | 3 | \ --------------------------------------------------- 4 | \ (c) Copyright 2001 Julian V. Noble. \ 5 | \ Permission is granted by the author to \ 6 | \ use this software for any application pro- \ 7 | \ vided this copyright notice is preserved. \ 8 | \ --------------------------------------------------- 9 | 10 | \ This is an ANS Forth program using the CORE wordset 11 | 12 | \ Adapted for kForth, 2003-3-10 km 13 | \ Requires ans-words.4th (for defn of CHARS) 14 | 15 | : char_table: ( #chars "table_name" -- ) 16 | CREATE DUP CHARS allot? SWAP 0 FILL 17 | DOES> ( char -- code[c]) 18 | CHARS + C@ ; 19 | 20 | : install ( adr char.n char.1 -- ) \ fast fill 21 | SWAP 1+ SWAP DO 2DUP I CHARS + C! LOOP 2DROP ; 22 | \ end automatic conversion tables 23 | 24 | 25 | -------------------------------------------------------------------------------- /forth-src/poems/poem002.txt: -------------------------------------------------------------------------------- 1 | poem The Road Not Taken 2 | Robert Frost 3 | 4 | Two roads diverged in a yellow wood, 5 | And sorry I could not travel both 6 | And be one traveler, long I stood 7 | And looked down one as far as I could 8 | To where it bent in the undergrowth; 9 | 10 | Then took the other, as just as fair, 11 | And having perhaps the better claim 12 | Because it was grassy and wanted wear, 13 | Though as for that the passing there 14 | Had worn them really about the same, 15 | 16 | And both that morning equally lay 17 | In leaves no step had trodden black. 18 | Oh, I marked the first for another day! 19 | Yet knowing how way leads on to way 20 | I doubted if I should ever come back. 21 | 22 | I shall be telling this with a sigh 23 | Somewhere ages and ages hence: 24 | Two roads diverged in a wood, and I, 25 | I took the one less traveled by, 26 | And that has made all the difference. 27 | 28 | fin 29 | 30 | -------------------------------------------------------------------------------- /forth-src/sigfpe.4th: -------------------------------------------------------------------------------- 1 | \ Test signal handling on SIGFPE 2 | 3 | 1 cells 4 = constant 32bit? 4 | 5 | include ans-words 6 | include modules 7 | include syscalls 8 | include mc 9 | include signal 10 | 11 | 32bit? [IF] 12 | include asm-x86 13 | 14 | \ Generate a SIGFPE signal 15 | CODE test 16 | 1 # eax mov, 17 | ecx ecx xor, 18 | ecx div, 19 | ret, 20 | END-CODE 21 | 22 | [ELSE] 23 | 24 | \ 64-bit machine code to generate SIGFPE 25 | BASE @ 26 | HEX 27 | 48 c7 c0 01 00 00 00 \ 1 # rax mov, 28 | 48 31 c9 \ rcx rcx xor, 29 | 48 f7 f1 \ rcx div, 30 | c3 \ ret, 31 | E 32 | dup MC-Table test-code 33 | MC-Put 34 | BASE ! 35 | 36 | : test ( -- ) test-code call ; 37 | 38 | [THEN] 39 | 40 | \ Install QUIT signal handler for SIGFPE 41 | 42 | ' quit SIGFPE forth-signal drop 43 | 44 | 45 | cr .( Type 'test' to generate SIGFPE ) cr 46 | 47 | 48 | -------------------------------------------------------------------------------- /forth-src/poems/poem001.txt: -------------------------------------------------------------------------------- 1 | poem Because I Could Not Stop for Death 2 | Emily Dickinson 3 | 4 | Because I could not stop for Death, 5 | He kindly stopped for me; 6 | The carriage held but just ourselves 7 | And Immortality. 8 | 9 | We slowly drove, he knew no haste, 10 | And I had put away 11 | My labor, and my leisure too, 12 | For his civility. 13 | 14 | We passed the school, where children strove 15 | At recess, in the ring; 16 | We passed the fields of gazing grain, 17 | We passed the setting sun. 18 | 19 | Or rather, he passed us; 20 | The dews grew quivering and chill, 21 | For only gossamer my gown, 22 | My tippet only tulle. 23 | 24 | We paused before a house that seemed 25 | A swelling of the ground; 26 | The roof was scarcely visible, 27 | The cornice but a mound. 28 | 29 | Since then 'tis centuries, and yet each 30 | Feels shorter than the day 31 | I first surmised the horses' heads 32 | Were toward eternity. 33 | 34 | fin 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/func_Ngauss.4th: -------------------------------------------------------------------------------- 1 | \ func_Ngauss.4th 2 | \ 3 | \ N overlapping Gaussian peaks 4 | \ 5 | \ y = B + SUM_i{ A_i*exp(-(x-mu_i)^2/(2*sig_i^2)) } 6 | \ 7 | \ Parameter array is ordered as follows 8 | \ 9 | \ 0 B baseline 10 | \ 1 A_1 11 | \ 2 mu_1 12 | \ 3 sig_1 13 | \ 4 A_2 14 | \ 5 mu_2 15 | \ 6 sig_2 16 | \ 7 A_3 17 | \ : : 18 | \ : : 19 | \ 20 | \ Notes: 21 | \ 22 | \ 1. Make sure to set the value Npeaks to the number of peaks to be 23 | \ fitted prior to calling functn 24 | 25 | 26 | 0 value Npeaks 27 | 0 ptr params{ 28 | fvariable fx 29 | 0 value idx 30 | 31 | : functn ( fx 'a -- fy ) 32 | TO params{ fx F! 33 | params{ 0 } F@ 34 | Npeaks 0 ?DO 35 | I 3 * 1+ TO idx \ index of first param for each peak 36 | params{ idx 1+ } F@ fx F@ F- FSQUARE 37 | params{ idx 2+ } F@ FSQUARE 2e F* F/ 38 | FNEGATE FEXP 39 | params{ idx } F@ F* 40 | F+ 41 | LOOP 42 | ; 43 | 44 | -------------------------------------------------------------------------------- /forth-src/poems/poem006.txt: -------------------------------------------------------------------------------- 1 | poem The Tyger 2 | William Blake 3 | 4 | Tyger Tyger. burning bright, 5 | In the forests of the night; 6 | What immortal hand or eye. 7 | Could frame thy fearful symmetry? 8 | 9 | In what distant deeps or skies. 10 | Burnt the fire of thine eyes? 11 | On what wings dare he aspire? 12 | What the hand, dare seize the fire? 13 | 14 | And what shoulder, & what art, 15 | Could twist the sinews of thy heart? 16 | And when thy heart began to beat. 17 | What dread hand? & what dread feet? 18 | 19 | What the hammer? what the chain, 20 | In what furnace was thy brain? 21 | What the anvil? what dread grasp. 22 | Dare its deadly terrors clasp? 23 | 24 | When the stars threw down their spears 25 | And watered heaven with their tears: 26 | Did he smile His work to see? 27 | Did he who made the lamb make thee? 28 | 29 | Tyger Tyger burning bright, 30 | In the forests of the night: 31 | What immortal hand or eye, 32 | Dare frame thy fearful symmetry? 33 | 34 | fin 35 | 36 | -------------------------------------------------------------------------------- /forth-src/speech.4th: -------------------------------------------------------------------------------- 1 | \ speech.4th 2 | \ 3 | \ Interface to the "festival" text to speech synthesis program 4 | \ 5 | \ See http://www.cstr.ed.ac.uk/projects/festival/ 6 | \ 7 | \ Copyright (c) 2002 Krishna Myneni, Creative Consulting 8 | \ for Research and Education 9 | \ 10 | \ The executable, or a link to the executable, festival must 11 | \ be in the PATH. 12 | \ 13 | \ Requires: 14 | \ strings.4th 15 | \ files.4th (2002-09-19 version or later) 16 | \ utils.4th 17 | \ 18 | \ Revisions: 19 | \ 20 | \ 2002-09-09 created KM 21 | \ 2002-09-20 added say-again KM 22 | \ 2002-09-22 modified SAY to delete MSGFILE KM 23 | 24 | s" speechmsg.txt" $constant MSGFILE 25 | 26 | : say-file ( a u -- | read the file with the given name) 27 | s" festival --tts " 2swap strcat shell drop ; 28 | 29 | : say ( a u -- | speak the message in the buffer ) 30 | MSGFILE delete-file drop 31 | MSGFILE W/O create-file 32 | abort" Unable to open speech output file." 33 | dup >r write-file drop r> close-file drop 34 | MSGFILE say-file ; 35 | 36 | : say-again ( -- ) 37 | MSGFILE say-file ; 38 | -------------------------------------------------------------------------------- /forth-src/term.4th: -------------------------------------------------------------------------------- 1 | \ term.4th 2 | 3 | include ans-words 4 | include modules 5 | include struct-200x 6 | include struct-200x-ext 7 | include strings 8 | include ansi 9 | include files 10 | 11 | \ Load multiple communications interfaces, and plug one in to 12 | \ the terminal module 13 | 14 | Defer Comm 15 | 16 | include dummy-comm \ Dummy Asynchronous Communications Interface 17 | include serial \ Serial Port I/O Module 18 | include serial-comm \ Serial Communications Interface 19 | \ include other-comm \ Other Communications Interface 20 | 21 | ' dummy-comm IS Comm \ Use the Dummy Interface 22 | include terminal 23 | : dummy-term terminal ; 24 | ' serial-comm IS Comm \ Use the Serial Interface 25 | include terminal 26 | : serial-term terminal ; 27 | 28 | ALSO serial ALSO serial-comm ALSO serial-term 29 | 30 | : term ( -- | start the default terminal ) 31 | COM1 ∋ serial-comm config port ! 32 | B4800 ∋ serial-comm config baud ! 33 | ∋ serial-comm config start 34 | ; 35 | 36 | ALSO Forth 37 | 38 | cr .( Type 'term' to start the default terminal.) 39 | 40 | -------------------------------------------------------------------------------- /forth-src/dump.4th: -------------------------------------------------------------------------------- 1 | \ dump.4th 2 | \ 3 | \ Memory Dump Utility 4 | \ 5 | \ Copyright (c) 1999 Krishna Myneni 6 | \ Creative Consulting for Research and Education 7 | \ 8 | \ This software is provided under the terms of the GNU 9 | \ General Public License. 10 | \ 11 | \ Last Revised: 2019-08-03 12 | \ 13 | 14 | BASE @ 15 | DECIMAL 16 | 17 | create dump_display_buf 20 allot 18 | 19 | : hexchar ( n -- m | return ascii hex char value for n: 0 - 15 ) 20 | dup 9 > IF 10 - [char] A ELSE [char] 0 THEN + ; 21 | 22 | : dump_display_char ( n -- n|'.' ) 23 | dup [char] ! < over [char] ~ > or IF drop [char] . THEN ; 24 | 25 | : .address ( a -- ) base @ swap hex u. base ! ; 26 | 27 | : dump ( a n -- | display n bytes starting at a ) 28 | dup 0> IF 29 | 0 DO 30 | I 16 mod 0= 31 | IF 32 | cr dup .address bl emit [char] : emit 2 spaces 33 | THEN 34 | dup c@ 16 /mod 35 | hexchar emit hexchar emit 36 | 2 spaces 37 | dup c@ dump_display_char 38 | dump_display_buf i 16 mod + c! 39 | i 16 mod 15 = 40 | IF dump_display_buf 16 type THEN 41 | 1+ 42 | LOOP 43 | drop 44 | ELSE 45 | 2drop 46 | THEN ; 47 | 48 | BASE ! 49 | -------------------------------------------------------------------------------- /forth-src/daq/hp/hp34401.4th: -------------------------------------------------------------------------------- 1 | \ hp34401.4th 2 | \ 3 | \ GPIB interface to the HP34401A multimeter 4 | \ 5 | \ Requires: 6 | \ ans-words 7 | \ modules.4th 8 | \ strings.4th 9 | \ gpib.4th 10 | \ 11 | \ Revisions: 12 | \ 13 | \ 3-23-1999 ported from UR/FORTH 14 | \ 6-17-1999 modified to talk to two meters 15 | \ 2011-11-01 km updated to use modular gpib interface 16 | \ 2011-11-03 km make code modular, with interface per unit; 17 | \ add CLEAR member. 18 | \ 2021-05-12 km update stack diagram for CLEAR member. 19 | 20 | Module: hp34401 21 | Begin-Module 22 | 23 | 22 value PRI_ADDR \ default GPIB primary address for meter 24 | 25 | Public: 26 | 27 | : set-pad ( u -- ) to PRI_ADDR ; 28 | : get-pad ( -- u ) PRI_ADDR ; 29 | 30 | \ Clear the meter 31 | : clear ( -- error ) PRI_ADDR ∋ gpib clear_device ; 32 | 33 | \ Return the measured value from meter 34 | : read ( -- ) ( F: -- r ) 35 | PRI_ADDR \ GPIB address of meter 36 | dup 37 | c" READ?" swap ∋ gpib send_command 38 | 18 swap ∋ gpib read_bytes 39 | ∋ gpib in_buf fnumber_buf 1+ 16 cmove 40 | 15 fnumber_buf c! 41 | fnumber_buf string>f ; 42 | 43 | End-Module 44 | 45 | 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /forth-src/dummy-comm.4th: -------------------------------------------------------------------------------- 1 | \ dummy-comm.4th 2 | \ 3 | \ Module for dummy communication functions, to test a 4 | \ generic terminal application that can use various 5 | \ asynchronous communications interfaces. 6 | 7 | \ This module does not have any dependencies on other modules. 8 | 9 | Module: dummy-comm 10 | begin-module 11 | 12 | create dummy-msg 64 allot 13 | s" Dummy Terminal" dummy-msg swap move 14 | 15 | 3000 constant START_DELAY \ delay from open to start of reception 16 | 10 constant RX_DELAY \ 1 character rec'd every 10 ms 17 | 18 | variable start-time 19 | variable last-time 20 | 21 | : total-elapsed ( -- u ) ms@ start-time @ - ; 22 | : rx-elapsed ( -- u ) ms@ last-time @ - ; 23 | 24 | Public: 25 | 26 | variable config 27 | 28 | \ Dummy Open 29 | : open ( aconfig -- ) 30 | drop ms@ dup start-time ! last-time ! 31 | ; 32 | 33 | \ Dummy Get 34 | : get ( -- c ) [char] A ; 35 | 36 | \ Dummy Put 37 | : put ( c -- ) drop ; 38 | 39 | \ Dummy Rx-len 40 | : Rx-len ( -- u ) 41 | 0 42 | total-elapsed START_DELAY > IF 43 | rx-elapsed RX_DELAY > if 44 | drop 1 ms@ last-time ! 45 | then 46 | then ; 47 | 48 | \ Dummy Write 49 | : write ( a u -- ) 2drop ; 50 | 51 | \ Dummy Close 52 | : close ( -- ) ; 53 | 54 | end-module 55 | -------------------------------------------------------------------------------- /forth-src/libs/blas/make.inc: -------------------------------------------------------------------------------- 1 | #################################################################### 2 | # BLAS make include file. # 3 | # March 2007 # 4 | #################################################################### 5 | # 6 | SHELL = /bin/sh 7 | # 8 | # The machine (platform) identifier to append to the library names 9 | # 10 | PLAT = _LINUX 11 | # 12 | # Modify the FORTRAN and OPTS definitions to refer to the 13 | # compiler and desired compiler options for your machine. NOOPT 14 | # refers to the compiler options desired when NO OPTIMIZATION is 15 | # selected. Define LOADER and LOADOPTS to refer to the loader and 16 | # desired load options for your machine. 17 | # 18 | FORTRAN = gfortran 19 | OPTS = -O3 -m32 -shared 20 | DRVOPTS = $(OPTS) 21 | NOOPT = 22 | LOADER = gfortran 23 | LOADOPTS = -shared 24 | # 25 | # The archiver and the flag(s) to use when building archive (library) 26 | # If you system has no ranlib, set RANLIB = echo. 27 | # 28 | ARCH = ar 29 | ARCHFLAGS= cr 30 | # RANLIB = ranlib 31 | RANLIB = echo 32 | # 33 | # The location and name of the Reference BLAS library. 34 | # 35 | # BLASLIB = blas$(PLAT).a 36 | BLASLIB = libblas.so 37 | -------------------------------------------------------------------------------- /forth-src/3ds.4th: -------------------------------------------------------------------------------- 1 | \ 3ds.4th 2 | \ 3 | \ Read 3D models from AutoCad 3ds files 4 | \ 5 | \ Krishna Myneni, Creative Consulting for Research and Education 6 | \ Revisions: 7 | \ 8 | [undefined] struct [IF] s" struct.4th" included [THEN] 9 | [undefined] int16: [IF] s" struct-ext.4th" included [THEN] 10 | 11 | \ Chunk IDs 12 | base @ 13 | HEX 14 | 4d4d constant CHUNK_ID_MAIN 15 | 4d4d constant CHUNK_ID_EDIT 16 | 4000 constant CHUNK_ID_EDIT_OBJECT 17 | 4100 constant CHUNK_ID_EDIT_OBJECT_TRIMESH 18 | 4110 constant CHUNK_ID_VERTEXLIST 19 | 4120 constant CHUNK_ID_POLYGONLIST 20 | 4140 constant CHUNK_ID_MAPPING 21 | base ! 22 | 23 | struct 24 | sfloat: 3ds_Vertex->x 25 | sfloat: 3ds_Vertex->y 26 | sfloat: 3ds_Vertex->z 27 | end-struct 3ds_Vertex% 28 | 29 | struct 30 | int16: 3ds_Polygon->a 31 | int16: 3ds_Polygon->b 32 | int16: 3ds_Polygon->c 33 | end-struct 3ds_Polygon% 34 | 35 | 3ds_Vertex% %size constant VTX_SIZE 36 | 3ds_Polygon% %size constant PGN_SIZE 37 | 38 | : 3ds_Vertex create 3ds_Vertex% %allot drop ; 39 | 40 | : 3ds_Vertex! ( fx fy fz avertex -- ) 41 | dup >r 3ds_Vertex->z sf! r@ 3ds_Vertex->y sf! r> 3ds_Vertex->x sf! ; 42 | 43 | : 3ds_Polygon! ( a b c apolygon -- ) 44 | dup >r 3ds_Polygon->c w! r@ 3ds_Polygon->b w! r> 3ds_Polygon->a w! ; 45 | 46 | 47 | : read-3ds ( a u -- ) 48 | 49 | ; 50 | 51 | -------------------------------------------------------------------------------- /forth-src/ioctl.4th: -------------------------------------------------------------------------------- 1 | \ ioctl.4th 2 | \ 3 | \ Ported from Linux 2.6.x, /usr/include/asm-i386/ioctl.h 4 | \ (for use in Forth interfaces to device drivers) 5 | \ 6 | \ K. Myneni, 2006-08-09 7 | \ 8 | \ Revisions: 9 | \ 10 | 8 constant IOC_NRBITS 11 | 8 constant IOC_TYPEBITS 12 | 14 constant IOC_SIZEBITS 13 | 2 constant IOC_DIRBITS 14 | 15 | 1 IOC_NRBITS LSHIFT 1- constant IOC_NRMASK 16 | 1 IOC_TYPEBITS LSHIFT 1- constant IOC_TYPEMASK 17 | 1 IOC_SIZEBITS LSHIFT 1- constant IOC_SIZEMASK 18 | 1 IOC_DIRBITS LSHIFT 1- constant IOC_DIRMASK 19 | 20 | 0 constant IOC_NRSHIFT 21 | IOC_NRSHIFT IOC_NRBITS + constant IOC_TYPESHIFT 22 | IOC_TYPESHIFT IOC_TYPEBITS + constant IOC_SIZESHIFT 23 | IOC_SIZESHIFT IOC_SIZEBITS + constant IOC_DIRSHIFT 24 | 25 | \ Direction bits 26 | 0 constant IOC_NONE 27 | 1 constant IOC_WRITE 28 | 2 constant IOC_READ 29 | 30 | : _IOC ( dir type nr size -- u ) 31 | IOC_SIZESHIFT lshift swap 32 | IOC_NRSHIFT lshift OR swap 33 | IOC_TYPESHIFT lshift OR swap 34 | IOC_DIRSHIFT lshift OR 35 | ; 36 | 37 | : _IO ( type nr -- u ) IOC_NONE -rot 0 _IOC ; 38 | 39 | : _IOR ( type nr size -- u ) >r IOC_READ -rot r> _IOC ; 40 | 41 | : _IOW ( type nr size -- u ) >r IOC_WRITE -rot r> _IOC ; 42 | 43 | : _IOWR ( type nr size -- u ) >r IOC_READ IOC_WRITE or -rot r> _IOC ; 44 | 45 | -------------------------------------------------------------------------------- /forth-src/serial-comm.4th: -------------------------------------------------------------------------------- 1 | \ serial-comm.4th 2 | \ 3 | \ Module for serial port communication functions. 4 | \ 5 | \ Rev: 2024-02-21 km; use Forth 200x structures 6 | 7 | Module: serial-comm 8 | 9 | ALSO serial \ depends on module serial 10 | 11 | Begin-Module 12 | 13 | variable com 14 | create buf 64 allot 15 | 16 | Public: 17 | 18 | BEGIN-STRUCTURE serial-config% 19 | FIELD: port 20 | FIELD: baud 21 | FIELD: params 22 | END-STRUCTURE 23 | 24 | create config serial-config% allot 25 | 26 | \ Default values for comm port configuration 27 | COM1 config port ! 28 | B9600 config baud ! 29 | s" 8N1" config params swap move 30 | 31 | \ Open and configure the comm port 32 | \ port baud ^str_param 33 | : open ( aconfig -- ) 34 | dup port @ ∋ serial open com ! 35 | dup params com @ swap ∋ serial set-params 36 | baud @ com @ swap ∋ serial set-baud 37 | ; 38 | 39 | \ Get available byte from the comm port 40 | : get ( -- c ) com @ buf 1 ∋ serial read drop buf c@ ; 41 | 42 | \ Put a byte to the comm port 43 | : put ( c -- ) buf c! com @ buf 1 ∋ serial write drop ; 44 | 45 | \ Length of receive queue 46 | : Rx-len ( -- u ) com @ ∋ serial lenrx ; 47 | 48 | \ Write a byte stream to the comm port 49 | : write ( a u -- ) com @ -rot ∋ serial write drop ; 50 | 51 | \ Close the comm port 52 | : close ( -- ) com @ ∋ serial close drop ; 53 | 54 | End-Module 55 | 56 | -------------------------------------------------------------------------------- /forth-src/system-test/asm-x86-test.4th: -------------------------------------------------------------------------------- 1 | \ asm-x86-test.4th 2 | \ 3 | \ Some basic tests to verify that the asm-x86 assembler is functioning 4 | \ correctly within the Forth environment. 5 | \ 6 | \ Copyright (c) 2009 Creative Consulting for Research and Education 7 | \ Provided under the GNU Lesser General Public License (LGPL). 8 | \ 9 | \ Requires kForth v1.5.x: 10 | \ ans-words.4th, ttester.4th, asm-x86.4th, dump.4th, 11 | \ asm-x86-examples.4th 12 | \ 13 | \ Revisions: 14 | \ 2009-10-09 km created 15 | \ 16 | \ 17 | s" ans-words" included 18 | s" ttester" included 19 | s" asm-x86-examples" included 20 | 21 | 22 | DECIMAL 23 | TESTING Use of ADD, MOV, IMUL, 24 | T{ 5 adrop -> }T 25 | T{ 1 2 adrop -> 1 }T 26 | 27 | T{ 16 add5 -> 21 }T 28 | T{ -10 add5 -> -5 }T 29 | 30 | T{ 0 5 add -> 5 }T 31 | T{ 1 -1 add -> 0 }T 32 | T{ -2 -3 add -> -5 }T 33 | 34 | T{ 6 3 mul -> 18 }T 35 | T{ -6 3 mul -> -18 }T 36 | T{ -3 6 mul -> -18 }T 37 | T{ -6 -3 mul -> 18 }T 38 | 39 | 40 | TESTING Use of CXNZ, IF, THEN, DO, LOOP, INC, 41 | 312 v ! 42 | T{ -1 add-loop -> 311 }T 43 | 44 | TESTING Use of BEGIN, WHILE, REPEAT, CMP, <, XOR, 45 | 0 v ! 46 | T{ test1 v @ -> 100 }T 47 | 48 | TESTING Use of LABEL: JMP, >, 49 | 0 v ! 50 | T{ test2 v @ -> 100 }T 51 | 50 v ! 52 | T{ -1 v> -> FALSE }T 53 | T{ 0 v> -> FALSE }T 54 | T{ 50 v> -> FALSE }T 55 | T{ 51 v> -> TRUE }T 56 | -------------------------------------------------------------------------------- /forth-src/fsl/fsl-test-utils.4th: -------------------------------------------------------------------------------- 1 | \ fsl-test-utils 2 | \ 3 | \ Utilities for generating element by element, Hayes-style tests on 4 | \ arrays and matrices: 5 | \ 6 | \ Requires: strings.4th 7 | \ 8 | \ Use: 9 | \ n CompareArrays a{ b{ 10 | \ n m CompareMatrices a{{ b{{ 11 | \ 12 | \ K. Myneni 13 | \ Revisions: 2007-08-25, 2007-09-22, 2007-10-23 14 | 15 | BASE @ DECIMAL 16 | 17 | create s1 64 allot 18 | create s2 64 allot 19 | 20 | \ Generate element by element tests for two fp arrays. 21 | : CompareArrays ( n -- ) 22 | bl word s1 strcpy bl word s2 strcpy 23 | 0 DO 24 | I 0 <# #S #> s" } F@ " strcat 25 | s" t{ " s1 count strcat s" " strcat 2over strcat 26 | s" -> " strcat s2 count strcat s" " strcat 27 | 2swap strcat s" r}t" strcat 28 | evaluate 29 | LOOP 30 | ; 31 | 32 | 33 | 0 value Nrows 34 | 0 value Ncols 35 | \ Generate element by element tests for two fp matrices. 36 | : CompareMatrices ( n m -- ) 37 | to Ncols to Nrows 38 | bl word s1 strcpy bl word s2 strcpy 39 | Nrows 0 DO 40 | Ncols 0 DO 41 | J 0 <# #S #> s" " strcat I 0 <# #S #> strcat s" " strcat s" }} F@ " strcat 42 | s" t{ " s1 count strcat s" " strcat 2over strcat 43 | s" -> " strcat s2 count strcat s" " strcat 44 | 2swap strcat s" r}t" strcat 45 | ( type ) evaluate 46 | LOOP 47 | LOOP 48 | ; 49 | 50 | BASE ! 51 | -------------------------------------------------------------------------------- /src/kfmacros.h: -------------------------------------------------------------------------------- 1 | // kfmacros.h 2 | // 3 | // Useful macros for kForth C and C++ source files, following 4 | // the convention established by DNW in vm-osxppc.s 5 | // 6 | // Copyright (c) 2009--2021, Krishna Myneni 7 | // 8 | // 9 | // This software is provided under the terms of the GNU 10 | // Affero General Public License (AGPL), v3.0 or later. 11 | // 12 | 13 | #define INC_DSP ++GlobalSp; 14 | #define DEC_DSP --GlobalSp; 15 | #define TOS (*GlobalSp) 16 | 17 | #ifndef __NO_FPSTACK__ 18 | #define INC_FSP (GlobalFp = (void*)((byte*)GlobalFp + FpSize)); 19 | #define DEC_FSP (GlobalFp = (void*)((byte*)GlobalFp - FpSize)); 20 | #endif 21 | 22 | #ifndef __FAST__ 23 | 24 | #define INC_DTSP ++GlobalTp; 25 | #define DEC_DTSP --GlobalTp; 26 | #define INC2_DTSP GlobalTp += 2; 27 | #define IS_ADDR (*GlobalTp == OP_ADDR) 28 | #define CHK_ADDR if (*GlobalTp != OP_ADDR) return E_V_NOT_ADDR; 29 | #define STD_IVAL *GlobalTp-- = OP_IVAL; 30 | #define STD_ADDR *GlobalTp-- = OP_ADDR; 31 | #define DROP ++GlobalSp; ++GlobalTp; 32 | 33 | #else 34 | 35 | #define INC_DTSP 36 | #define DEC_DTSP 37 | #define INC2_DTSP 38 | #define IS_ADDR ( FALSE ) 39 | #define CHK_ADDR 40 | #define STD_IVAL 41 | #define STD_ADDR 42 | #define DROP ++GlobalSp; 43 | 44 | #endif 45 | 46 | #define PUSH_IVAL(x) TOS = (x); DEC_DSP STD_IVAL 47 | #define PUSH_ADDR(x) TOS = (x); DEC_DSP STD_ADDR 48 | -------------------------------------------------------------------------------- /forth-src/libs/cfitsio/fits-ex2.4th: -------------------------------------------------------------------------------- 1 | \ fits-ex2.4th 2 | \ 3 | \ Example of reading FITS files, taken from [1] 4 | \ 5 | \ [1] W. Pence, CFITSIO Quick Start Guide, January 2003, p.4. 6 | \ 7 | include ans-words 8 | include modules 9 | include syscalls 10 | include mc 11 | include asm 12 | include strings 13 | include lib-interface 14 | include struct 15 | include struct-ext 16 | include libcfitsio 17 | 18 | \ The following two variables are essential 19 | variable file_fptr \ pointer to the FITS file; defined in fitsio.h 20 | variable status 21 | 22 | \ Program specific data 23 | create card FLEN_CARD allot 24 | variable nkeys 25 | 26 | : fits-ex2 ( c-addr u -- status ) 27 | 0 status ! \ initialize status before calling fitsio routines 28 | $>zstr file_fptr swap READONLY status fits_open_file \ open existing FITS file 29 | cr ." fits_open_file returned " dup . 30 | ABORT" Unable to open the input FITS file!" 31 | 32 | 0 nkeys ! 33 | file_fptr @ nkeys NULL status fits_get_hdrspace 34 | cr ." fits_get_hdrspace returned " . 35 | 36 | cr 37 | nkeys @ 1+ 1 DO 38 | file_fptr @ I card status fits_read_record drop \ read keyword 39 | card zstr>$ type cr 40 | LOOP 41 | 42 | ." END" cr cr 43 | file_fptr @ status fits_close_file drop 44 | 45 | status @ IF 46 | \ stderr status fits_report_error 47 | THEN 48 | 49 | status @ 50 | ; 51 | 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /forth-src/eispack/demo/rsymm-02.4th: -------------------------------------------------------------------------------- 1 | \ rsymm-02.4th 2 | \ 3 | \ Find all eigenvalues and eigenvectors of a real symmetric 4 | \ matrix by tridiagonalizing the matrix and using the implict 5 | \ QL reduction method, per recommended EISPACK path [1]. 6 | \ 7 | \ K. Myneni, 2022-06-16 8 | \ 9 | \ Revisions: 10 | \ 2022-06-18 renamed tred2-ex01.4th to rsymm-02.4th 11 | \ 12 | \ References: 13 | \ 1. Matrix Eigensystem Routines -- EISPACK Guide, 2nd ed., 14 | \ B.T. Smith, J.M. Boyle, B.S. Garbow, Y. Ikebe, V.C. Klema, 15 | \ and C.B. Moler, ISBN 0-387-07546-1, Springer-Verlag, 1976; 16 | \ see sections 2.1.11 and 2.2.3. 17 | 18 | include ans-words 19 | include modules 20 | include fsl/fsl-util 21 | include eispack/tred2 22 | include eispack/imtql2 23 | 24 | cr 25 | .( All eigenvalues and eigenvectors of 4x4 real symmetric matrix.) 26 | cr cr 27 | .( 4 1 -2 2 ) cr 28 | .( 1 2 0 1 ) cr 29 | .( -2 0 3 -2 ) cr 30 | .( 2 1 -2 -1 ) cr 31 | 32 | 4 4 FLOAT MATRIX A{{ 33 | 4.0e0 1.0e0 -2.0e0 2.0e0 34 | 1.0e0 2.0e0 0.0e0 1.0e0 35 | -2.0e0 0.0e0 3.0e0 -2.0e0 36 | 2.0e0 1.0e0 -2.0e0 -1.0e0 37 | 4 4 A{{ }}fput 38 | 39 | 4 FLOAT ARRAY diag{ 40 | 4 FLOAT ARRAY subdiag{ 41 | 4 4 FLOAT MATRIX ot{{ 42 | 43 | 4 4 a{{ diag{ subdiag{ ot{{ tred2 44 | 4 4 diag{ subdiag{ ot{{ imtql2 45 | ?dup [IF] 46 | cr .( IMTQL2 Error ) . cr 47 | [ELSE] 48 | cr .( Eigenvalues: ) 4 diag{ }fprint cr 49 | cr .( Eigenvectors: ) cr 50 | 4 4 ot{{ }}fprint cr 51 | [THEN] 52 | 53 | -------------------------------------------------------------------------------- /forth-src/struct-ext.4th: -------------------------------------------------------------------------------- 1 | \ struct-ext.4th 2 | \ 3 | \ Extension words for creating single byte aligned structures. 4 | \ 5 | \ It is often required to create a structure with contiguous 6 | \ boundaries for its fields. The normal field defining 7 | \ word found in struct.4th automatically adjusts alignment and 8 | \ does not guarantee that successive elements are contiguous 9 | \ in memory. Therefore, defining a structure for a precisely 10 | \ specified format poses a problem. This problem is addressed 11 | \ by providing a set of field creation words which always ensure 12 | \ that successive elements are contiguous in memory. 13 | \ 14 | \ Revisions: 15 | \ 16 | \ 2003-11-03 created by Krishna Myneni 17 | \ 2010-06-22 km added int64: 18 | \ 2019-08-12 km added int128: and qfloat: 19 | \ 20 | \ Requires: 21 | \ 22 | \ ans-words.4th 23 | \ struct.4th 24 | \ 25 | 26 | : byte: 1 1 field ; \ 8-bit value 27 | : int16: 1 2 field ; \ 16-bit integer 28 | : int32: 1 4 field ; \ 32-bit integer 29 | : int64: 1 8 field ; \ 64-bit integer 30 | : int128: 1 16 field ; \ 128-bit integer 31 | : int: int32: ; \ 32-bit integer 32 | : sfloat: 1 4 field ; \ 32-bit (single precision) float 33 | : dfloat: 1 8 field ; \ 64-bit (double precision) float 34 | : qfloat: 1 16 field ; \ 128-bit (quad precision) float 35 | : float: dfloat: ; \ 64-bit float 36 | : buf: ( n -- ) 1 swap field ; \ byte buffer 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /forth-src/games/keycal.4th: -------------------------------------------------------------------------------- 1 | \ keycal.4th 2 | \ 3 | \ Measure keyboard event response time for your system. 4 | \ 5 | \ This program measures the average time between the press of a 6 | \ key and when it is processed by the system. There will be 7 | \ a significant non-zero delay due to processor interrupts, 8 | \ thread priorities, and other operating system factors. 9 | \ 10 | \ Copyright (c) 2003 Krishna Myneni 11 | \ Provided under the GNU General Public License 12 | \ 13 | \ Revisions: 14 | \ 15 | \ 2003-3-2 created km 16 | \ 17 | 18 | 500 constant MAXWAIT \ maximum response time in milliseconds 19 | 20 | variable niter 21 | variable keepwaiting 22 | variable kbresp 23 | 24 | : cal 25 | begin key? until key drop \ wait for key press 26 | 0 niter ! 27 | true keepwaiting ! 28 | 29 | 0 30 | begin 31 | ms@ 32 | begin key? 0= keepwaiting @ and 33 | while ms@ over - MAXWAIT > if false keepwaiting ! then 34 | repeat 35 | keepwaiting @ 36 | while 37 | key drop ms@ swap - + 38 | 1 niter +! 39 | repeat 40 | drop cr 41 | niter @ dup if / dup kbresp ! 42 | ." Average keyboard response time was " . ." ms" cr 43 | ." Number of events = " niter @ . cr 44 | else 45 | 2drop ." No data" cr 46 | then 47 | ; 48 | 49 | cr cr 50 | .( Hold down the spacebar for about 30 seconds and release it ) cr 51 | .( to calibrate the average interruption time for reading a ) cr 52 | .( keyboard event on your system. Type 'cal' to repeat. ) cr cr 53 | 54 | cal 55 | 56 | -------------------------------------------------------------------------------- /forth-src/eispack/demo/rsymm-01.4th: -------------------------------------------------------------------------------- 1 | \ rsymm-01.4th 2 | \ 3 | \ Find eigenvalues of a real symmetric matrix by 4 | \ tridiagonalizing the matrix and using the implict 5 | \ QL reduction method, using an EISPACK "path" [1]. 6 | \ 7 | \ K. Myneni, 2022-06-16 8 | \ 9 | \ Revisions: 10 | \ 2022-06-18 renamed tred1-ex01.4th to rsymm-01.4th 11 | \ 12 | \ References: 13 | \ 1. Matrix Eigensystem Routines -- EISPACK Guide, 2nd ed., 14 | \ B.T. Smith, J.M. Boyle, B.S. Garbow, Y. Ikebe, V.C. Klema, 15 | \ and C.B. Moler, ISBN 0-387-07546-1, Springer-Verlag, 1976; 16 | \ see sections 2.1.12 and 2.2.3. 17 | 18 | include ans-words 19 | include modules 20 | include fsl/fsl-util 21 | include eispack/tred1 22 | include eispack/imtql1 23 | 24 | cr 25 | .( All eigenvalues of 4 x 4 real symmetric matrix ) cr cr 26 | .( 4 1 -2 2 ) cr 27 | .( 1 2 0 1 ) cr 28 | .( -2 0 3 -2 ) cr 29 | .( 2 1 -2 -1 ) cr 30 | 31 | 4 4 FLOAT MATRIX A{{ 32 | 4.0e0 1.0e0 -2.0e0 2.0e0 33 | 1.0e0 2.0e0 0.0e0 1.0e0 34 | -2.0e0 0.0e0 3.0e0 -2.0e0 35 | 2.0e0 1.0e0 -2.0e0 -1.0e0 36 | 4 4 A{{ }}fput 37 | 38 | 4 FLOAT ARRAY diag{ 39 | 4 FLOAT ARRAY subdiag{ 40 | 4 FLOAT ARRAY subdiag2{ 41 | 42 | \ Tridiagonalize the matrix using TRED1, 43 | \ then find its eigenvalues using IMTQL1 44 | 45 | 4 4 A{{ diag{ subdiag{ subdiag2{ tred1 46 | 4 diag{ subdiag{ imtql1 47 | ?dup [IF] 48 | cr .( IMTQL1 Error ) . cr 49 | [ELSE] 50 | cr .( Eigenvalues: ) 4 diag{ }fprint cr 51 | [THEN] 52 | 53 | 54 | 55 | 56 | 57 | 58 | -------------------------------------------------------------------------------- /forth-src/rs232-switch-test.4th: -------------------------------------------------------------------------------- 1 | \ rs232-switch-test.4th 2 | \ 3 | \ Test external two-position switch interfaced through serial port. 4 | \ 5 | include ans-words 6 | include strings 7 | include modules 8 | include struct-200x 9 | include struct-200x-ext 10 | include serial 11 | include rs232-switch 12 | 13 | false value user-abort? 14 | 15 | : test-switch ( -- ) 16 | open-sw ABORT" Unable to open serial port!" 17 | enable-switch 1 ms 18 | read-switch IF 19 | cr ." CTS is raised. Ensure switch is OFF and try again." 20 | cr close-sw drop EXIT 21 | THEN 22 | cr ." Press a key on the keyboard to raise RTS." 23 | BEGIN 1000 usleep key? UNTIL key drop 24 | cr ." Press and hold the push-button switch." 25 | cr ." If there is no effect, press Esc to exit the test." cr 26 | false to user-abort? 27 | BEGIN 28 | 1000 us 29 | key? dup IF 30 | key 27 = and dup 31 | IF true to user-abort? THEN 32 | THEN 33 | 0= 34 | WHILE 35 | read-switch 0= 36 | WHILE 37 | REPEAT 38 | cr ." CTS has been raised (switch is ON)." 39 | cr ." Please release the switch to OFF position." 40 | BEGIN 41 | 1000 usleep 42 | read-switch 0= 43 | UNTIL 44 | cr ." CTS is low (switch is OFF)." 45 | THEN 46 | disable-switch 47 | close-sw drop 48 | user-abort? IF cr ." Test aborted by user!" cr THEN 49 | ; 50 | 51 | 52 | cr cr .( Type 'TEST-SWITCH' to check operation of switch. ) cr 53 | 54 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/four1-test.4th: -------------------------------------------------------------------------------- 1 | \ four1-test.4th 2 | \ 3 | \ Test Forth version of Numerical Recipes routine four1 4 | \ 5 | include ans-words 6 | include fsl/fsl-util 7 | include fsl/complex 8 | include fsl/extras/four1 9 | 10 | 2048 FLOAT array a{ 11 | 2048 FLOAT array b{ 12 | fvariable pulse_height 13 | variable pulse_width 14 | variable start_pulse 15 | variable stop_pulse 16 | 17 | variable ntrials 18 | 1000 ntrials ! 19 | 20 | 1024 constant IMAX 21 | 22 | : setup-pulse ( -- ) 23 | 24 | 100 pulse_width ! 25 | 1e pulse_height f! 26 | 27 | IMAX pulse_width @ - 1- start_pulse ! 28 | IMAX pulse_width @ + 1- stop_pulse ! 29 | 30 | \ Fill array with rectangular pulse data 31 | 32 | IMAX 2* 0 DO 33 | I start_pulse @ > IF 34 | I stop_pulse @ < IF pulse_height f@ ELSE 0e THEN 35 | ELSE 0e THEN 36 | 0e zdup a{ I } z! b{ I } z! 37 | 2 +LOOP 38 | ; 39 | 40 | : print-array ( 'a -- ) 41 | IMAX 2* 0 DO 42 | dup I } F@ F. 2 spaces dup I 1+ } F@ F. cr 43 | 2 +LOOP 44 | drop ; 45 | 46 | : power-spectrum ( 'a -- | print out the power spectrum for given array ) 47 | IMAX 2* 0 DO dup I } z@ |z|^2 F. CR 2 +LOOP 48 | drop ; 49 | 50 | 51 | : verify-four1 ( -- | compute the FFT of the pulse and print its power spectrum ) 52 | setup-pulse 53 | IMAX 1 a{ }four1 54 | \ a{ print-array 55 | a{ power-spectrum 56 | ; 57 | 58 | 59 | : test ( -- | Test the speed of }four1 ) 60 | setup-pulse 61 | ms@ 62 | ntrials @ 0 DO IMAX 1 b{ }four1 LOOP 63 | ms@ swap - . 64 | ; 65 | 66 | -------------------------------------------------------------------------------- /forth-src/eispack/demo/rsytr-01.4th: -------------------------------------------------------------------------------- 1 | \ rsytr-01.4th 2 | \ 3 | \ Find all eigenvalues and eigenvectors of a real symmetric 4 | \ tridiagonal matrix using the implict QL reduction method, 5 | \ per recommended EISPACK path [1]. 6 | \ 7 | \ K. Myneni, 2022-06-18 8 | \ 9 | \ References: 10 | \ 1. Matrix Eigensystem Routines -- EISPACK Guide, 2nd ed., 11 | \ B.T. Smith, J.M. Boyle, B.S. Garbow, Y. Ikebe, V.C. Klema, 12 | \ and C.B. Moler, ISBN 0-387-07546-1, Springer-Verlag, 1976; 13 | \ see section 2.1.15. 14 | \ 15 | include ans-words 16 | include modules 17 | include fsl/fsl-util 18 | include eispack/imtql2 19 | 20 | cr .( All eigenvalues and eigenvectors of real) 21 | cr .( symmetric tridiagonal 3x3 matrix.) cr 22 | cr .( 0 1 0 ) 23 | cr .( 1 0 sqrt2) 24 | cr .( 0 sqrt2 0 ) cr 25 | 26 | 3 FLOAT ARRAY d{ \ input: diagonal output: eigenvalues 27 | 3 FLOAT ARRAY s{ \ input: subdiagonal output: none 28 | 3 3 FLOAT MATRIX z{{ \ input: identity output: eigenvectors 29 | 30 | 2.0e0 fsqrt fconstant sqrt2 31 | 32 | \ Diagonal elements are zero for this example. 33 | \ First element of subdiagonal array is always set to zero. 34 | 0.0e0 0.0e0 0.0e0 3 d{ }fput 35 | 0.0e0 1.0e0 sqrt2 3 s{ }fput 36 | 37 | 1.0e0 0.0e0 0.0e0 38 | 0.0e0 1.0e0 0.0e0 39 | 0.0e0 0.0e0 1.0e0 40 | 3 3 z{{ }}fput \ identity matrix on input 41 | 42 | 3 3 d{ s{ z{{ imtql2 43 | ?dup [IF] 44 | cr .( IMTQL2 Error ) . cr 45 | [ELSE] 46 | cr .( Eigenvalues: ) 3 d{ }fprint cr 47 | cr .( Eigenvectors: ) cr 48 | 3 3 z{{ }}fprint cr 49 | [THEN] 50 | 51 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/find.4th: -------------------------------------------------------------------------------- 1 | \ find.4th 2 | \ 3 | \ Find the element in an array closest to a given value, and 4 | \ return its index. 5 | \ 6 | \ Based on the routine locate() in Numerical Recipes in C, The 7 | \ Art of Scientific Computing, 2nd ed., by W. H. Press, S. A. 8 | \ Teukolsky, W. T. Vetterling, and B. P. Flannery, Cambridge 9 | \ University Press, 1994. 10 | \ 11 | \ Forth version for use with the Forth Scientific Library, 12 | \ by Krishna Myneni 13 | \ 14 | \ Revisions: 15 | \ 2010-10-16 km ported from the xyplot library modules 16 | \ 2011-09-16 km use Neal Bridges' anonymous modules 17 | \ 2012-02-19 km use KM/DNW's modules library 18 | 19 | BEGIN-MODULE 20 | 21 | BASE @ 22 | DECIMAL 23 | 24 | Private: 25 | 26 | 0 ptr findA{ 27 | 0 value findN 28 | 0 value findJ 29 | variable ordering 30 | fvariable findDel1 31 | 32 | Public: 33 | 34 | \ Return index of point with closest x to fx in FLOAT ARRAY 'A 35 | 36 | : }ffind ( fx n 'A -- u | return index 0 <= u < n ) 37 | to findA{ to findN 38 | findA{ 0 } F@ findA{ findN 1- } F@ F< ordering ! 39 | findN 0 40 | BEGIN 41 | 2dup - 1 > 42 | WHILE 43 | 2dup 2>R 44 | + 2/ dup >R 45 | findA{ swap } F@ 46 | fover F<= ordering @ = 47 | R> swap 2R> rot 48 | IF drop swap ELSE nip THEN 49 | REPEAT 50 | nip dup to findJ 51 | findA{ swap } F@ fover F- fabs findDel1 F! 52 | findJ findN 1- < IF 53 | findA{ findJ 1+ } F@ F- fabs 54 | findDel1 F@ F< IF findJ 1+ to findJ THEN 55 | ELSE 56 | fdrop 57 | THEN 58 | findJ ; 59 | 60 | BASE ! 61 | END-MODULE 62 | 63 | 64 | -------------------------------------------------------------------------------- /kforth.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char *kf[] = { 3 | /* width height num_colors chars_per_pixel */ 4 | " 32 32 6 1", 5 | /* colors */ 6 | ". c #000000", 7 | "# c #00ff00", 8 | "a c #7f7f00", 9 | "b c #7f7f7f", 10 | "c c #bfbfbf", 11 | "d c #ffff00", 12 | /* pixels */ 13 | "cccccccccccccccccccccccccccccccc", 14 | "cccccccccccccccccccccccccccccccc", 15 | "cbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb", 16 | "cccccccccccccccccccccccccccccccb", 17 | "cc............................cb", 18 | "cc............................cb", 19 | "cc.ddddddddda..ddddddda.......cb", 20 | "cc...ddddda......ddaaa........cb", 21 | "cc....ddda......dda...........cb", 22 | "cc....ddda.....dda.....da.da..cb", 23 | "cc....ddda....dda.....dddadda.cb", 24 | "cc....ddda...dda....da.da.d.d.cb", 25 | "cc....ddda..dda....dda.ddad.d.cb", 26 | "cc....ddda.dda....d.da........cb", 27 | "cc....dddadda....d..da........cb", 28 | "cc....dddddda....ddddda.......cb", 29 | "cc....dddaddda......da........cb", 30 | "cc....ddda.ddda.....da........cb", 31 | "cc....ddda..ddda..............cb", 32 | "cc....ddda...ddda.............cb", 33 | "cc....ddda....ddda............cb", 34 | "cc....ddda.....ddda...........cb", 35 | "cc....ddda......ddda..........cb", 36 | "cc...dddddaa.....dddaaa.......cb", 37 | "cc.ddddddddda..dddddddda......cb", 38 | "cc............................cb", 39 | "cccccccccccccccccccccccccccccccb", 40 | "cbbbbbbbbbbbbbbbbbbbbbbbbbb##bbb", 41 | "ccccccccccccccccccccccccccc##ccb", 42 | "cbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb", 43 | ".........bccccccccccccb.........", 44 | "..bccccccccccccccccccccccccccb.." 45 | }; 46 | -------------------------------------------------------------------------------- /forth-src/daq/gpib/gpib-test.4th: -------------------------------------------------------------------------------- 1 | \ gpib-test.4th 2 | \ 3 | \ Test kForth interface to the linux-gpib driver using the HP multimeter 4 | \ 5 | \ Revisions: 6 | \ 2011-09-14 km updated to include modules.4th 7 | \ 2011-11-03 km revised to use modular version of hp34401.4th 8 | \ 2021-05-06 km uses gpib64.4th until integrated with gpib.4th 9 | \ 2021-07-15 km updated to use Forth 200x standard data structures 10 | \ 2024-02-26 km use loader, gpib.4th 11 | 12 | include ans-words 13 | include modules 14 | include strings 15 | include files 16 | include struct-200x 17 | include struct-200x-ext 18 | include ioctl 19 | 20 | include daq/gpib/gpib.4th 21 | include daq/hp/hp34401.4th 22 | 23 | : meter1 hp34401 ; 24 | 25 | Also gpib 26 | 27 | cr 28 | .( Opening GPIB driver ... ) 29 | ∋ gpib open dup [IF] .( Error ) . [ELSE] drop .( ok ) [THEN] cr 30 | 31 | .( Getting Board Info ... ) cr 32 | ∋ gpib ibboard_info 33 | 0= [IF] 34 | .( Board Primary Address: ) gpinfo ul@ u. cr 35 | .( Board Secondary Address: ) gpinfo ( cell+) 4 + ul@ u. cr 36 | [ELSE] 37 | .( ibboard Failed. ) cr 38 | [THEN] 39 | cr 40 | .( Initializing GPIB interface ... ) 41 | 42 | ∋ gpib init dup [IF] .( Error ) . [ELSE] drop .( ok ) [THEN] cr 43 | 44 | .( Setting timeout ... ) 45 | 10000000 ∋ gpib ibtmo dup [IF] .( Error ) . [ELSE] drop .( ok ) [THEN] cr 46 | 47 | .( Talking to meter at ADRESS ) ∋ meter1 get-pad . cr 48 | .( Sending CLEAR DEVICE ) ∋ meter1 clear .( ... returns ) . cr 49 | .( Reading meter: result = ) ∋ meter1 read f. cr 50 | .( Closing GPIB ) ∋ gpib close .( ... returns ) . cr 51 | 52 | 53 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/interp-array.4th: -------------------------------------------------------------------------------- 1 | \ interp-array.4th 2 | \ 3 | \ Lineary interpolation for FSL arrays: 4 | \ 5 | \ Assume x1{ and y1{ are arrays of type FLOAT, and contain (x,y) pairs. 6 | \ Further assume ascending order for x1{ values. 7 | \ 8 | \ Given a new set of abcissas x2{, which fall within the domain of x1{, 9 | \ compute a new set of corresponding y2{ values by linear interpolation. 10 | \ 11 | \ Requires: 12 | \ 13 | \ ans-words.4th 14 | \ fsl-util.4th 15 | \ 16 | 17 | 0 ptr x1{ 18 | 0 ptr y1{ 19 | 0 ptr x2{ 20 | 0 ptr y2{ 21 | 22 | 0 VALUE np1 \ number of points in arrays x1{ and y1{ 23 | 0 VALUE np2 \ number of points in arrays x2{ and y2{ 24 | 0 VALUE idx 25 | 26 | FVARIABLE xa 27 | FVARIABLE xb 28 | FVARIABLE ya 29 | FVARIABLE yb 30 | 31 | : interp-array ( 'x1 'y1 np1 'x2 'y2 np2 -- | generate y2 array by linear interpolation ) 32 | TO np2 TO y2{ TO x2{ 33 | TO np1 TO y1{ TO x1{ 34 | 35 | 0 TO idx 36 | 37 | np2 0 ?DO 38 | 39 | x2{ I } F@ 40 | 41 | np1 idx ?DO 42 | FDUP x1{ I } F@ F< IF LEAVE THEN 43 | idx 1+ TO idx 44 | LOOP 45 | 46 | FDROP 47 | 48 | idx np1 1- MIN TO idx 49 | 50 | idx 1- 0 MAX x1{ SWAP } F@ xa F! 51 | idx x1{ SWAP } F@ xb F! 52 | idx 1- 0 MAX y1{ SWAP } F@ ya F! 53 | idx y1{ SWAP } F@ yb F! 54 | 55 | xb F@ xa F@ F= IF \ avoid divide by zero error 56 | ya F@ 57 | ELSE 58 | yb F@ ya F@ F- x2{ I } F@ xa F@ F- F* 59 | xb F@ xa F@ F- F/ ya F@ F+ 60 | THEN 61 | y2{ I } F! 62 | LOOP 63 | ; 64 | 65 | 66 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/noise-test.4th: -------------------------------------------------------------------------------- 1 | \ noise-test.4th 2 | \ 3 | \ Generate random samples to check the probability distribution 4 | \ of the random numbers generated by ran0 and gauss in noise.4th. 5 | \ 6 | \ K. Myneni, 7-30-2001 7 | \ 8 | \ Requires: 9 | \ ans-words.4th 10 | \ fsl-util.4th 11 | \ horner.4th 12 | \ noise.4th 13 | \ 14 | \ Revisions: 15 | \ 2007-11-07 km; revised for new noise.4th (using FSL) 16 | 17 | include ans-words 18 | include fsl/fsl-util 19 | include fsl/horner 20 | include fsl/extras/noise 21 | 22 | 8192 3 FLOAT matrix samples{{ 23 | 24 | : go ( -- | generate the samples matrix) 25 | \ column 0 contains running index 26 | \ column 1 contains samples returned successively from ran0 27 | \ column 2 contains samples returned successively from gauss 28 | 29 | \ initialize IDUM 30 | 31 | time&date drop 30 * 24 * 3600 * swap 24 * 3600 * + 32 | swap 3600 * + swap 60 * + + 33 | negate idum ! 34 | 35 | 8192 0 DO 36 | I s>f samples{{ I 0 }} F! 37 | ran0 samples{{ I 1 }} F! 38 | gauss samples{{ I 2 }} F! 39 | LOOP ; 40 | 41 | ." The word 'go' generates the floating point matrix 'samples{{'" cr 42 | ." Column 0 is a running index" cr 43 | ." Column 1 are samples from a uniform distribution over the interval (0,1)" cr 44 | ." Column 2 are samples from a gaussian distribution (normal distribution)" cr 45 | ." with zero mean and unit variance." cr cr 46 | ." You may write the samples matrix to a file called" 47 | ." samples.dat by typing:" cr cr 48 | ." >file samples.dat 8192 3 samples{{ }}fprint console" cr cr 49 | 50 | go 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | -------------------------------------------------------------------------------- /forth-src/dd-test.4th: -------------------------------------------------------------------------------- 1 | \ dd-test.4th 2 | \ 3 | \ Compute and print the Golden Ratio [1] to 32 significant digits, 4 | \ using the ddarith library and several computing methods. 5 | \ 6 | \ K. Myneni, 2020-09-27 7 | \ 8 | \ 1. http://en.wikipedia.org/wiki/Golden_ratio 9 | 10 | include ans-words 11 | include ddarith 12 | include dd_io 13 | 14 | DECIMAL 15 | 16 | 1e 0e ddconstant DD1.0 17 | 2e 0e ddconstant DD2.0 18 | 3e 0e ddconstant DD3.0 19 | 5e 0e ddconstant DD5.0 20 | 21 | DD3.0 DD2.0 dd/ ddconstant DD3/2 22 | 23 | \ 1. Soln. of quadratic eqn: phi = (1 + sqrt(5))/2 24 | : phi-qu ( F: -- x xx ) 25 | DD5.0 ddsqrt DD1.0 dd+ DD2.0 dd/ ; 26 | 27 | 28 | \ 2. Trigonometric eqn: phi = 2*cos(pi/5) 29 | 0 [IF] 30 | : phi-tr ( F: -- x xx ) 31 | DDPI DD5.0 dd/ ddcos DD2.0 dd* ; \ no ddcos available at present 32 | ; 33 | [THEN] 34 | 35 | \ 3. Continued square root: phi = sqrt(1 + sqrt(1 + sqrt(1 + ... 36 | : phi-cs ( nterms -- ) ( F: -- x xx ) 37 | >r DD2.0 ddsqrt 38 | r> 0 ?DO DD1.0 dd+ ddsqrt LOOP ; 39 | 40 | \ 4. Continued fraction: phi = 1 + 1/(1 + 1/(1 + 1/... 41 | : phi-cf ( nterms -- ) ( F: -- x xx ) 42 | >r DD3/2 43 | r> 0 ?DO DD1.0 ddswap dd/ DD1.0 dd+ LOOP ; 44 | 45 | 32 set-precision 46 | 47 | cr 48 | cr .( Double Double Arithmetic Demo -- Golden Ratio Calculation to 32 digits ) 49 | cr 50 | cr .( 1. phi = {1 + sqrt[5]}/2 ) 51 | cr phi-qu ddfs. cr 52 | 53 | 0 [IF] 54 | cr .( 2. phi = 2*cos[pi/5] ) 55 | cr phi-tr ddfs. cr 56 | [THEN] 57 | 58 | cr .( 3. phi = sqrt[1 + sqrt[1 + sqrt[1 + ... ) 59 | cr 100 phi-cs ddfs. cr 60 | 61 | cr .( 4. phi = 1 + 1/(1 + 1/(1 + 1/... ) 62 | cr 100 phi-cf ddfs. cr 63 | 64 | 65 | -------------------------------------------------------------------------------- /forth-src/fsl/demo/pfex.4th: -------------------------------------------------------------------------------- 1 | \ pfex.4th 2 | \ 3 | \ Annotated example of using the polynomial fitting routine 4 | \ under kforth. 5 | \ 6 | \ K. Myneni, 5-10-2000 7 | \ 8 | \ Requires: 9 | \ 10 | \ ans-words.4th 11 | \ fsl-util.4th 12 | \ dynmem.4th 13 | \ determ.4th 14 | \ polyfit.4th 15 | \ 16 | \ Revisions: 17 | \ 01-01-2002 cleaned up code KM 18 | \ 09-18-2007 use new polyfit.4th module, with FSL-style arrays KM 19 | \ 05/16/2021 update file paths. KM 20 | \ 21 | \ First load the necessary source files 22 | 23 | include ans-words 24 | include fsl/fsl-util 25 | include fsl/dynmem 26 | include fsl/extras/determ 27 | include fsl/extras/polyfit 28 | 29 | 30 | \ First create the x and y arrays (floating pt) to hold 31 | \ the data to be fitted. 32 | 33 | 10 constant NP ( the number of points we will fit) 34 | 35 | NP FLOAT array x{ 36 | NP FLOAT array y{ 37 | 38 | \ Let's manually put in NP (10) values into the x and y arrays now. 39 | \ I will use the data for y = x^2 40 | 41 | 0e 1e 2e 3e 4e 5e 6e 7e 8e 9e NP x{ }fput 42 | 0e 1e 4e 9e 16e 25e 36e 49e 64e 81e NP y{ }fput 43 | 44 | \ You can verify that the x and y matrices have the correct 45 | \ data in them by printing them out, e.g. 46 | \ 47 | \ 10 x{ }fprint 48 | \ 10 y{ }fprint 49 | 50 | 51 | \ We also need an array to hold the fitted polynomial coefficients. 52 | 53 | 4 FLOAT array coeffs{ 54 | 55 | 56 | \ Now fit the data to a 2nd order polynomial, and print 57 | \ chi-square and the coefficients 58 | 59 | x{ y{ coeffs{ 2 NP polfit 60 | 61 | cr 62 | ." Chi-square = " f. cr 63 | ." The coefficients are: " cr 3 coeffs{ }fprint 64 | 65 | 66 | -------------------------------------------------------------------------------- /forth-src/system-test/fpzero-test.4th: -------------------------------------------------------------------------------- 1 | \ fpzero-test.4th 2 | \ 3 | \ Check whether or not basic operations with floating point signed zero in a 4 | \ Forth system are compatible with IEEE 754 arithmetic 5 | \ 6 | \ Krishna Myneni 7 | \ 8 | \ Revisions: 9 | \ 2009-05-05 km; created 10 | \ 11 | \ Notes: 12 | \ 13 | \ 1. Based on the C program zerosdq.c, from 14 | \ 15 | \ http://www.math.utah.edu/~beebe/software/ieee/#testing-is-necessary 16 | \ 17 | \ 2. This Forth program makes no assumptions about the internal representation 18 | \ of floating point numbers, unlike the original C program, which assumes an 19 | \ IEEE format. 20 | \ 21 | \ 3. Several additional tests are included in the Forth version. 22 | 23 | s" ans-words" included 24 | s" ttester" included 25 | true verbose ! 26 | decimal 27 | 28 | variable #errors 0 #errors ! 29 | 30 | :noname ( c-addr u -- | Keep a cumulative error count ) 31 | 1 #errors +! error1 ; error-xt ! 32 | 33 | -0E 0E 0E F~ [IF] 34 | cr cr .( ** System does not support floating point signed zero. **) 35 | ABORT 36 | [THEN] 37 | 38 | verbose @ [IF] 39 | cr cr .( System supports fp signed zero. ) 40 | [THEN] 41 | 42 | SET-EXACT 43 | 44 | t{ 0E FNEGATE -> -0E }t 45 | t{ -0E FABS -> 0E }t 46 | t{ 0E F0= -> TRUE }t 47 | t{ -0E F0= -> TRUE }t 48 | t{ -0E 0E F< -> FALSE }t 49 | t{ 0E -0E F< -> FALSE }t 50 | t{ -0E 0E F> -> FALSE }t 51 | t{ 0E -0E F> -> FALSE }t 52 | t{ 0E 0E F- -> 0E }t 53 | t{ 0E FNEGATE 0E F- -> -0E }t 54 | t{ 0E 1E F* -> 0E }t 55 | t{ 0E -1E F* -> -0E }t 56 | 57 | verbose @ [IF] 58 | cr .( #ERRORS: ) #errors @ . cr 59 | [THEN] 60 | 61 | 62 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/mpfr_airy.4th: -------------------------------------------------------------------------------- 1 | \ mpfr_airy.4th 2 | \ 3 | \ High precision calculation of Airy function using 4 | \ the MPFR library interface 5 | \ 6 | \ Example: Compute and print Ai(-10.0) to 40 digits 7 | \ 8 | \ -10 0 airy 40 mpfr. 9 | \ 10 | \ K. Myneni, 2013-04-15 11 | \ krishna.myneni@ccreweb.org 12 | \ 13 | \ Notes: 14 | \ 15 | \ 1. The floating point argument to the MPFR library function, 16 | \ mpfr_ai, is computed at high precision from two integer 17 | \ arguments to airy. This method avoids the lower fixed 18 | \ precision (53-bit) of a floating point number parsed by 19 | \ the Forth interpreter. 20 | \ 21 | \ The argument to mpfr_ai, is arg1 * 10^(-arg2), where 22 | \ arg1 and arg2 are the two integers passed to AIRY. 23 | \ 24 | \ Requires: 25 | \ ans-words 26 | \ modules 27 | \ syscalls 28 | \ mc 29 | \ asm 30 | \ strings 31 | \ lib-interface 32 | \ libs/gmp/libmpfr 33 | \ libs/gmp/mpfr-utils (optional) 34 | 35 | \ Set precision before initializing mp vars 36 | 256 mpfr_set_default_prec 37 | 38 | mpfr_t dst 39 | mpfr_t num 40 | mpfr_t sca 41 | 42 | dst mpfr_init 43 | num mpfr_init 44 | sca mpfr_init 45 | 46 | \ Return 10^nscale in a mp var, a 47 | : scale-factor ( nscale a -- a ) 48 | swap >r 49 | dup 10 GMP_RNDN mpfr_set_ui drop 50 | dup dup r> GMP_RNDN mpfr_pow_ui drop ; 51 | 52 | \ Return scaled arg, x = arg/(10^scale) in mp var, a 53 | : scaled-arg ( narg nscale a -- a ) 54 | swap sca scale-factor >r 55 | dup rot GMP_RNDN mpfr_set_si drop 56 | dup dup r> GMP_RNDN mpfr_div drop 57 | ; 58 | 59 | \ Compute the Airy function Ai(x), where x = arg/(10^scale) 60 | : airy ( narg nscale -- a ) 61 | num scaled-arg 62 | dst swap GMP_RNDN mpfr_ai drop 63 | dst ; 64 | 65 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/mpfr_gamma.4th: -------------------------------------------------------------------------------- 1 | \ mpfr_gamma.4th 2 | \ 3 | \ High precision calculation of the real gamma function using 4 | \ the MPFR library interface 5 | \ 6 | \ Example: Compute and print gamma[1.5] to 40 digits 7 | \ 8 | \ 15 1 rgamma 40 mpfr. 9 | \ 10 | \ K. Myneni, 2011-05-17 11 | \ krishna.myneni@ccreweb.org 12 | \ 13 | \ Notes: 14 | \ 15 | \ 1. The floating point argument to the MPFR library function, 16 | \ mpfr_gamma, is computed at high precision from two integer 17 | \ arguments to rgamma. This method avoids the lower fixed 18 | \ precision (53-bit) of a floating point number parsed by 19 | \ the Forth interpreter. 20 | \ 21 | \ The argument to mpfr_gamma, is x = arg1 * 10^(-arg2), where 22 | \ arg1 and arg2 are the two integers passed to rgamma. The first 23 | \ arg may be signed, but arg2 is assumed to be positive. Obviously, 24 | \ the use of single length integers restricts the range of 25 | \ arguments which may be passed to mpfr_gamma. 26 | \ 27 | \ Requires: 28 | \ 29 | \ ans-words 30 | \ modules 31 | \ syscalls 32 | \ mc 33 | \ asm 34 | \ strings 35 | \ lib-interface 36 | \ libs/gmp/libmpfr 37 | \ libs/gmp/mpfr-utils (optional) 38 | 39 | \ Set precision before initializing mp vars 40 | 2048 mpfr_set_default_prec 41 | 42 | mpfr_t dst 43 | mpfr_t num 44 | mpfr_t sca 45 | 46 | dst mpfr_init 47 | num mpfr_init 48 | sca mpfr_init 49 | 50 | \ Compute the gamma function of x = arg/(10^scale) 51 | : rgamma ( narg nscale -- a ) 52 | 1 swap 53 | dup 0> IF 0 DO 10 * LOOP ELSE DROP THEN \ narg 10^scale 54 | sca swap GMP_RNDN mpfr_set_ui drop 55 | num swap GMP_RNDN mpfr_set_si drop 56 | num num sca GMP_RNDN mpfr_div drop 57 | dst num GMP_RNDN mpfr_gamma drop 58 | dst 59 | ; 60 | 61 | 62 | -------------------------------------------------------------------------------- /forth-src/struct-200x-ext.4th: -------------------------------------------------------------------------------- 1 | \ struct-200x-ext.4th 2 | \ 3 | \ Extension words for creating single byte aligned structures. 4 | \ 5 | \ It is often required to create a structure with contiguous 6 | \ boundaries for its fields. The normal field defining 7 | \ words found in struct-200x.4th automatically adjusts alignment 8 | \ and do not guarantee that successive elements are contiguous 9 | \ in memory. Therefore, defining a structure for a precisely 10 | \ specified format poses a problem. This problem is addressed 11 | \ by providing a set of field creation words which always ensure 12 | \ that successive elements are contiguous in memory. 13 | \ 14 | \ Revisions: 15 | \ 16 | \ 2003-11-03 created by Krishna Myneni (for struct.4th) 17 | \ 2010-06-22 km added int64: 18 | \ 2019-08-12 km added int128: and qfloat: 19 | \ 2021-09-13 km ported to Forth 200x structures 20 | \ 2021-09-18 km renamed unaligned fields so that both 21 | \ Forth 200x-like structures can coexist 22 | \ with STRUCT-like structures. 23 | \ Requires: 24 | \ 25 | \ ans-words.4th 26 | \ struct-200x.4th 27 | \ 28 | 29 | \ Aligned fields ( see Forth=2012 standard, A.10.6.2.0763 ) 30 | 31 | 0 [IF] 32 | : BFIELD: CFIELD: ; 33 | : WFIELD: ; 34 | : LFIELD: ; 35 | : XFIELD: ; 36 | : QFIELD: ; 37 | [THEN] 38 | 39 | 40 | \ Unaligned fields 41 | 42 | : +BFIELD 1 +FIELD ; \ 8-bit field 43 | : +WFIELD 2 +FIELD ; \ 16-bit field 44 | : +LFIELD 4 +FIELD ; \ 32-bit field 45 | : +XFIELD 8 +FIELD ; \ 64-bit field 46 | : +int128 16 +FIELD ; \ 128-bit integer 47 | : +SFFIELD 4 +FIELD ; \ 32-bit (single precision) float 48 | : +DFFIELD 8 +FIELD ; \ 64-bit (double precision) float 49 | : +QFFIELD 16 +FIELD ; \ 128-bit (quad precision) float 50 | : +FFIELD 1 FLOATS +FIELD ; \ current floating point size 51 | 52 | -------------------------------------------------------------------------------- /forth-src/random.4th: -------------------------------------------------------------------------------- 1 | \ random.4th 2 | \ 3 | \ Assorted simple pseudo-random number generators 4 | \ for 32-bit and 64-bit Forth systems. 5 | \ 6 | \ Requires ans-words.4th 7 | \ 8 | \ References 9 | \ 1. https://en.wikipedia.org/wiki/Linear_congruential_generator 10 | \ 2. https://nuclear.llnl.gov/CNP/rng/rngman/node4.html 11 | \ 3. See ranqd1 in Numerical Recipes, ch. 7, 2nd ed.; the 12 | \ given test values for seed of 0 may be reproduced 13 | \ from RANDOM under kForth-32. 14 | base @ 15 | decimal 16 | 17 | 1 CELLS 8 = constant 64-bit? 18 | 19 | 64-bit? [IF] 20 | c" 28629335555777941757" number? 2drop 21 | constant LCG_MUL \ [2] 22 | 3037000493 constant LCG_ADD \ [2] 23 | hex ff80000000000000 constant ROL9_MASK 24 | decimal 25 | 55 constant ROL9_RS 26 | [ELSE] 27 | 1664525 constant LCG_MUL \ [3] 28 | 1013904223 constant LCG_ADD \ [3] 29 | hex ff800000 constant ROL9_MASK 30 | decimal 31 | 23 constant ROL9_RS 32 | [THEN] 33 | decimal 34 | 35 | variable seed 36 | 37 | \ from old versions of glibc [1] 38 | : random-aphwb ( -- u ) seed @ 69069 * 1+ dup seed ! ; 39 | 40 | : random ( -- u ) LCG_MUL seed @ * LCG_ADD + dup seed ! ; 41 | 42 | : rol9 ( u1 -- u2 | rotate u1 left by 9 bits ) 43 | dup ROL9_MASK and ROL9_RS rshift swap 9 lshift or ; 44 | 45 | : random2 ( -- u ) LCG_MUL seed @ * LCG_ADD + rol9 dup seed ! ; 46 | 47 | : random2p ( -- u ) 48 | [ 64-bit? ] [IF] 49 | random2 255 and 56 lshift 50 | random2 255 and 48 lshift or 51 | random2 255 and 40 lshift or 52 | random2 255 and 32 lshift or 53 | random2 255 and 24 lshift or 54 | [ELSE] 55 | random2 255 and 24 lshift 56 | [THEN] 57 | random2 255 and 16 lshift or 58 | random2 255 and 8 lshift or 59 | random2 255 and or ; 60 | 61 | 62 | base ! 63 | -------------------------------------------------------------------------------- /forth-src/hexterm.4th: -------------------------------------------------------------------------------- 1 | \ hexterm.4th 2 | \ 3 | \ Hex output terminal for kForth (based on terminal.4th) 4 | \ 5 | \ 6 | \ Requires: 7 | \ 8 | \ ans-words.4th 9 | \ modules.4th 10 | \ struct-200x.4th 11 | \ struct-200x-ext.4th 12 | \ strings.4th 13 | \ ansi.4th 14 | \ serial.4th (module version) 15 | \ 16 | \ Revisions: 17 | \ 2007-08-03 km revised to use new serial.4th, requiring structures 18 | \ 2012-03-17 km revised to use modular version of serial.4th 19 | \ 2024-02-23 km revised to use Forth 200x structures 20 | 21 | include ans-words 22 | include modules 23 | include struct-200x 24 | include struct-200x-ext 25 | include strings 26 | include ansi 27 | include serial 28 | 29 | Also serial 30 | 31 | variable com 32 | create buf 64 allot 33 | 34 | : hexchar ( n -- ) dup 10 < if 48 + emit else 10 - 65 + emit then ; 35 | 36 | : hprint ( n -- ) [char] < emit dup 4 rshift hexchar 37 | 15 and hexchar [char] > emit ; 38 | 39 | 40 | : ht ( -- | terminal emulator ) 41 | \ black background 42 | page 43 | \ green background 44 | \ black foreground 45 | ." Touch Screen Terminal - (Esc) to Exit " cr 46 | \ white foreground 47 | \ black background 48 | 49 | COM1 ∋ serial open com ! 50 | com @ c" 8N1" set-params 51 | com @ B4800 set-baud 52 | 53 | begin 54 | 10000 usleep 55 | com @ lenrx 56 | if 57 | com @ buf 1 ∋ serial read drop 58 | buf c@ hprint 59 | then 60 | key? 61 | if 62 | key 63 | dup 64 | 27 = 65 | if 66 | drop 67 | com @ ∋ serial close 68 | drop 69 | text_normal \ restore normal foreground/background colors 70 | \ page \ clear the screen 71 | exit 72 | then 73 | buf c! 74 | com @ buf 1 ∋ serial write drop 75 | then 76 | again ; 77 | 78 | ." Type 'ht' to start hex terminal on COM1 at 4800, 8N1" 79 | 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /src/ForthCompiler.h: -------------------------------------------------------------------------------- 1 | // ForthCompiler.h 2 | // 3 | // Copyright (c) 1998--2024 Krishna Myneni, 4 | // 5 | // 6 | // This software is provided under the terms of the GNU 7 | // Affero General Public License (AGPL), v3.0 or later. 8 | // 9 | 10 | #ifndef __FORTHCOMPILER_H__ 11 | #define __FORTHCOMPILER_H__ 12 | 13 | #define WSIZE 4 14 | 15 | #define byte unsigned char 16 | #define word unsigned short int 17 | 18 | #define PRECEDENCE_NONE 0 19 | #define PRECEDENCE_IMMEDIATE 1 20 | #define PRECEDENCE_NON_DEFERRED 2 21 | #define EXECUTE_NONE 0 22 | #define EXECUTE_UP_TO 1 23 | #define EXECUTE_CURRENT_ONLY 2 24 | #define TRUE -1 25 | #define FALSE 0 26 | 27 | struct WordTemplate 28 | { 29 | const char* WordName; 30 | word WordCode; 31 | byte Precedence; 32 | }; 33 | 34 | struct WordListEntry 35 | { 36 | char WordName[128]; 37 | word WordCode; 38 | byte Precedence; 39 | void* Cfa; 40 | void* Pfa; 41 | }; 42 | 43 | 44 | class WordList : public vector 45 | { 46 | public: 47 | WordListEntry* GetFromName( const char* ); 48 | WordListEntry* GetFromCfa( void* ); 49 | void RemoveLastWord( void ); 50 | }; 51 | 52 | class Vocabulary : public WordList 53 | { 54 | public: 55 | const char* Name; 56 | Vocabulary (const char* ); 57 | int Initialize (WordTemplate [], int); 58 | }; 59 | 60 | class SearchList : public vector 61 | { 62 | public: 63 | WordListEntry* LocateWord( const char* ); 64 | WordListEntry* LocateCfa( void* ); 65 | }; 66 | 67 | 68 | WordListEntry* IsForthWord (char*); 69 | int ForthCompiler (vector*, long int*); 70 | int ExecutionMethod (int); 71 | // void CompileWord (WordListEntry*); 72 | void OutputForthByteCode (vector*); 73 | void SetForthInputStream (istream&); 74 | void SetForthOutputStream (ostream&); 75 | 76 | #endif 77 | -------------------------------------------------------------------------------- /forth-src/rational.4th: -------------------------------------------------------------------------------- 1 | \ rational.4th 2 | \ 3 | \ Brute force search, optimized to search only within integer bounds 4 | \ surrounding target. 5 | \ 6 | \ Requires: 7 | \ ans-words.4th ( for kForth ) 8 | \ 9 | \ From Rosetta code: 10 | \ https://rosettacode.org/wiki/Convert_decimal_number_to_rational#Forth 11 | \ 12 | \ Examples: 13 | \ 14 | \ 1.618033988e 100 RealToRational swap . . 144 89 15 | \ 3.14159e 1000 RealToRational swap . . 355 113 16 | \ 2.71828e 1000 RealToRational swap . . 1264 465 17 | \ 0.9054054e 100 RealToRational swap . . 67 74 18 | 19 | fvariable besterror 20 | 0 value numtor 21 | 0 value denom 22 | 0 value realscale 23 | false value neg? 24 | 25 | [undefined] ftrunc>s [IF] 26 | : ftrunc>s ( r -- s ) ftrunc f>d d>s ; 27 | [THEN] 28 | 29 | : RationalError ( |r| num den -- rerror ) >r s>f r> s>f f/ f- fabs ; 30 | 31 | : RealToRational ( r den_limit -- numerator denominator ) 32 | 0 to numtor 1 to denom 33 | 9999999e besterror f! \ very large error that will surely 34 | \ be improved upon 35 | 36 | >r \ r -- 37 | fdup f0< to neg? \ save sign for later 38 | fabs 39 | 40 | \ realscale helps set integer bounds around target 41 | fdup ftrunc>s 1+ to realscale 42 | 43 | \ search through possible denominators ( 1 to denlimit) 44 | r> 1+ 1 ?DO 45 | \ |r| -- 46 | \ search through numerator within integer limits bounding 47 | \ the real, e.g. for 3.1419e search only between 3 and 4 48 | I realscale * I realscale 1- * ?DO 49 | fdup I J RationalError 50 | fdup besterror f@ f< IF 51 | besterror f! 52 | I to numtor J to denom 53 | ELSE fdrop 54 | THEN 55 | LOOP 56 | LOOP 57 | fdrop 58 | 59 | numtor neg? IF negate THEN denom 60 | ; 61 | 62 | -------------------------------------------------------------------------------- /forth-src/benchmarks/matrix-mult.4th: -------------------------------------------------------------------------------- 1 | \ .( Loading Matrix Multiplication benchmark...) cr 2 | \ NOTE: This version needs 0.5MB data space 3 | 4 | \ A classical benchmark of an O(n**3) algorithm; Matrix Multiplication 5 | \ 6 | \ Part of the programs gathered by John Hennessy for the MIPS 7 | \ RISC project at Stanford. Translated to forth by Marty Fraeman, 8 | \ Johns Hopkins University/Applied Physics Laboratory. 9 | \ 10 | \ Long-standing bug in "innerproduct" has been fixed -- KM 2007-01-29 11 | \ MM forth2c doesn't have it ! 12 | : mybounds over + swap ; 13 | 14 | \ The following definitions are needed for kForth compatibility KM 12-25-99 15 | \ ==================================== 16 | : align ; 17 | 1 cells constant cell 18 | \ ==================================== 19 | 20 | variable seed 21 | 22 | : initiate-seed ( -- ) 74755 seed ! ; 23 | : random ( -- n ) seed @ 1309 * 13849 + 65535 and dup seed ! ; 24 | 25 | 200 constant row-size 26 | row-size cells constant row-byte-size 27 | 28 | row-size row-size * constant mat-size 29 | mat-size cells constant mat-byte-size 30 | 31 | align create ima mat-byte-size allot 32 | align create imb mat-byte-size allot 33 | align create imr mat-byte-size allot 34 | 35 | : initiate-matrix ( m[row-size][row-size] -- ) 36 | mat-byte-size mybounds do 37 | random dup 120 / 120 * - 60 - i ! 38 | cell +loop 39 | ; 40 | 41 | : innerproduct ( a[row][*] b[*][column] -- int) 42 | 0 row-size 0 do 43 | >r over @ over @ * r> + >r 44 | \ cell+ swap row-byte-size + swap 45 | swap cell+ swap row-byte-size + 46 | r> 47 | loop 48 | >r 2drop r> 49 | ; 50 | 51 | : main ( -- ) 52 | initiate-seed 53 | ima initiate-matrix 54 | imb initiate-matrix 55 | imr ima mat-byte-size mybounds do 56 | imb row-byte-size mybounds do 57 | j i innerproduct over ! cell+ 58 | cell +loop 59 | row-size cells +loop 60 | drop 61 | ; 62 | 63 | 64 | -------------------------------------------------------------------------------- /forth-src/games/queens.4th: -------------------------------------------------------------------------------- 1 | ( * 2 | * LANGUAGE : ANS Forth 3 | * PROJECT : Forth Environments 4 | * DESCRIPTION : famous algorithm, the 8 Queens problem 5 | * CATEGORY : Example 6 | * AUTHOR : Erwin Dondorp, August 19, 1991 7 | * LAST CHANGE : March 6, 1993, Marcel Hendrix, Ansification 8 | * LAST CHANGE : October 13, 1991, Marcel Hendrix 9 | * ) 10 | 11 | \ == kForth requires == 12 | include ans-words 13 | include strings 14 | include ansi 15 | \ ===================== 16 | 17 | \ MARKER -queens 18 | 19 | ( * 20 | 8 Queens problem. 21 | After an implementation in Fys-Forth by Rieks Joosten c.s. 22 | This algorithm is completely I/O-bound. 23 | * ) 24 | 25 | 20 CONSTANT maxq 26 | 27 | 10 VALUE #q \ number of queens (20 max!) 28 | 29 | : CARRAY CREATE CHARS ALLOT 30 | DOES> SWAP CHARS + ; 31 | 32 | maxq 2* CARRAY AA 33 | maxq 2* CARRAY BB 34 | maxq 2* CARRAY CC 35 | maxq 2* CARRAY XX 36 | 37 | 0 VALUE #solutions 38 | 39 | : AT 1+ SWAP 40 | 1- SWAP AT-XY ; 41 | 42 | : CALC.SOLUTIONS #q 0 43 | DO I 2DUP 2DUP - #q 1- + CC C@ ROT ROT + BB C@ AND SWAP AA C@ AND 44 | IF I OVER XX C! I 2DUP + 0 SWAP BB C! 2DUP - #q 1- + 0 SWAP CC C! 45 | 0 SWAP AA C! DUP #q 1- < 46 | IF DUP 1+ RECURSE 47 | ELSE #solutions 1+ TO #solutions 0 0 AT-XY ." Solution: " #solutions . 48 | #q 0 DO CR #q 0 DO ." . " LOOP LOOP 49 | #q 0 DO I DUP XX C@ 3 * 1 + SWAP AT ." X " LOOP 50 | THEN I 2DUP + 1 SWAP BB C! 2DUP - #q 1- + 1 SWAP CC C! 1 SWAP AA C! 51 | THEN 52 | LOOP DROP ; 53 | 54 | 55 | : QUEENS 0 TO #solutions #q 0 56 | DO 1 I AA C! 0 I XX C! 57 | LOOP #q 2* 1- 0 58 | DO 1 I BB C! 1 I CC C! 59 | LOOP PAGE 0 CALC.SOLUTIONS #q #q AT ; 60 | 61 | 62 | : HELP CR ." Enter QUEENS to solve the " #q 1 .R ." -queens problem" ; 63 | 64 | HELP 65 | 66 | 67 | ( * End of Source * ) 68 | -------------------------------------------------------------------------------- /forth-src/signals-ex.4th: -------------------------------------------------------------------------------- 1 | \ signals-ex.4th 2 | \ 3 | \ Examples of signal handling in kForth 4 | \ 5 | \ Copyright (c) 2004--2020 Krishna Myneni 6 | \ 7 | \ Provided under the GNU Affero General Public License 8 | \ (AGPL) v 3.0 or later. 9 | \ 10 | 11 | include ans-words 12 | include signal 13 | 14 | : WINDOW-HANDLER ( n -- ) 15 | DROP ." Window size changed!" CR ; 16 | 17 | : TIMER-HANDLER ( n -- ) 18 | DROP CR TIME&DATE 2DROP DROP 19 | . BL EMIT . BL EMIT . ; 20 | 21 | : TEST1 ( -- ) 22 | decimal 23 | ['] WINDOW-HANDLER SIGWINCH forth-signal drop 24 | ['] TIMER-HANDLER SIGALRM forth-signal drop 25 | CR ." Installed new handlers for SIGWINCH and SIGALRM" 26 | CR ." Try resizing the console --- Use ESC to halt" 27 | 1000 1000 SET-TIMER \ Send SIGALRM to kForth every 1000 ms 28 | BEGIN 29 | KEY 27 = 30 | UNTIL 31 | 32 | SIG_IGN SIGALRM forth-signal DROP \ Stop sending SIGALRM 33 | CR ." Exiting TEST1 -- handler for SIGWINCH is still active" CR 34 | ; 35 | 36 | : GPF-HANDLER ( -- ) 37 | cr ." Protection Fault!" cr ABORT ; 38 | 39 | 0 ptr memAddr 40 | 41 | create inbuf 16 allot 42 | : input-an-address ( -- u ) 43 | 0 s>d inbuf 1 cells 2* accept 44 | inbuf swap >number 2drop d>s ; 45 | 46 | hex 47 | variable v 48 | BE v ! 49 | 50 | : TEST2 51 | hex 52 | ['] GPF-HANDLER SIGSEGV forth-signal . 53 | cr ." Installed handler for SIGSEGV" cr 54 | cr ." Enter any memory address as a hex number and press" 55 | cr ." ENTER to read its value. For example, the address" 56 | cr v u. ." is valid and contains the value 'BE'" cr 57 | BEGIN 58 | cr ." Address: " 59 | input-an-address to memAddr 60 | memAddr c@ 2 spaces . \ will likely generate a Protection Fault 61 | AGAIN 62 | decimal 63 | ; 64 | 65 | cr .( Type 'TEST1 to test SIGALRM and SIGWINCH handlers. ) 66 | cr .( Type 'TEST2' to test the SIGSEGV handler. ) cr cr 67 | 68 | 69 | -------------------------------------------------------------------------------- /forth-src/fsm-example.4th: -------------------------------------------------------------------------------- 1 | \ fsm-example.4th 2 | \ 3 | \ Finite State Machine example in kForth 4 | \ 5 | \ Based on the finite state machine examples in 6 | \ "Finite State Machines in Forth", J. V. Noble, 1995, 7 | \ Journal of Forth Applications and Research. 8 | \ 9 | \ Adapted to kForth by K. Myneni, 9-3-2001 10 | \ 11 | \ Requires: 12 | \ ans-words.4th 13 | \ fsm2.4th 14 | \ 15 | \ Revisions: 16 | \ 2010-05-24 km; include fsm code from fsm2.4th 17 | \ 2011-03-06 km; added Requires: comments. 18 | \ 19 | 20 | \ The defining words for creating state machines 21 | [undefined] fsm: [IF] s" fsm2.4th" included [THEN] 22 | 23 | \ Fixed point number entry example of a finite state machine 24 | \ ( from Noble in J. Forth Appl. and Res.) 25 | 26 | : digit? ( n -- flag ) [char] 0 [char] : within ; 27 | 28 | : dp? ( n -- flag ) [char] . = ; 29 | 30 | : minus? ( n -- flag ) [char] - = ; 31 | 32 | : cat->col# ( c -- n ) 33 | \ Determine the input condition for the entered character 34 | dup digit? 1 and \ digit -> 1 35 | over minus? 2 and + \ - -> 2 36 | swap dp? 3 and + \ dp -> 3 37 | ; \ other -> 0 38 | 39 | 40 | \ Create a finite state machine with 3 states and 4 inputs 41 | \ and define its action table. Each entry in the action table 42 | \ consists of the pair: 43 | \ 44 | \ { word_to_be_executed next_state_number } 45 | 46 | 3 4 fsm: 47 | \ 48 | \ input: 49 | \ 50 | \ other? num? minus? dp? 51 | \ state: 52 | \ 53 | ( 0 ) || drop >0 || emit >1 || emit >1 || emit >2 54 | ( 1 ) || drop >1 || emit >1 || drop >1 || emit >2 55 | ( 2 ) || drop >2 || emit >2 || drop >2 || drop >2 56 | 57 | ;fsm 58 | 59 | : Getafix ( -- | allow user to enter valid fixed point number ) 60 | 0 >state \ initialize the state to zero 61 | begin 62 | key dup 13 <> over 10 <> and 63 | while 64 | dup cat->col# \ determine input condition 65 | \ execute the state machine 66 | repeat 67 | drop ; 68 | 69 | 70 | -------------------------------------------------------------------------------- /forth-src/macro.4th: -------------------------------------------------------------------------------- 1 | \ macro.4th 2 | \ 3 | \ MACRO wordset from Wil Baden's Tool Belt series in 4 | \ Forth Dimensions (FD) Vol. 19, No. 2, July/August 1997. 5 | \ Original code has been modified by Jabari Zakiya to make 6 | \ more efficient MACRO which allows insertion of parameters 7 | \ following the macro. "\" represents place where parameter 8 | \ is inserted. 9 | \ 10 | \ Example: 11 | \ MACRO ?? " IF \ THEN " 12 | \ : FOO .. ?? EXIT .... ; ?? compiles to -- IF EXIT THEN 13 | \ 14 | \ Requires: 15 | \ ans-words.4th (kForth only) 16 | \ 17 | \ Revisions: 18 | \ 19 | \ 2003-02-06 km kForth version created 20 | \ 2004-02-07 km revised def of MACRO for kForth 1.2.0 21 | \ 2011-03-01 km removed requirement of strings.4th 22 | \ 23 | \ For use with ANS Forths, define the following: 24 | \ 25 | \ : NONDEFERRED ; 26 | 27 | [undefined] allot? [IF] : allot? ( u -- a ) here swap allot ; [THEN] 28 | 29 | : PLACE ( caddr n addr -) 2DUP C! CHAR+ SWAP CHARS MOVE ; 30 | : SSTRING ( char "ccc" - addr) WORD COUNT DUP 1+ CHARS ALLOT? PLACE ; 31 | 32 | : split-at-char ( a n char - a k a+k n-k) 33 | >r 2dup 34 | BEGIN 35 | dup 36 | WHILE 37 | over c@ r@ - 38 | ( WHILE 1 /STRING REPEAT THEN) 39 | 0= IF r> drop tuck 2>r - 2r> EXIT THEN 40 | 1 /string 41 | REPEAT 42 | r> drop tuck 2>r - 2r> ; 43 | 44 | 45 | : DOES>MACRO \ Compile the macro, including external parameters 46 | DOES> count 47 | BEGIN 48 | [char] \ split-at-char 49 | 2>r evaluate r@ 50 | WHILE 51 | bl word count evaluate 52 | 2r> 1 /string 53 | REPEAT 54 | 2r> 2drop ; 55 | 56 | : MACRO 57 | CREATE IMMEDIATE NONDEFERRED 58 | CHAR SSTRING DOES>MACRO ; 59 | 60 | 61 | \ Further examples of macros: 62 | \ 63 | \ macro sum() " \ @ \ @ + ." 64 | \ Use: 65 | \ 66 | \ variable a 67 | \ variable b 68 | \ variable c 69 | \ variable d 70 | \ 71 | \ : test sum() a b sum() c d ; 72 | -------------------------------------------------------------------------------- /forth-src/benchmarks/bubble-sort.4th: -------------------------------------------------------------------------------- 1 | .( Loading Bubble Sort benchmark...) cr 2 | 3 | \ A classical benchmark of an O(n**2) algorithm; Bubble sort 4 | \ 5 | \ Part of the programs gathered by John Hennessy for the MIPS 6 | \ RISC project at Stanford. Translated to forth by Marty Fraeman 7 | \ Johns Hopkins University/Applied Physics Laboratory. 8 | 9 | \ MM forth2c doesn't have it ! 10 | : mybounds over + swap ; 11 | 12 | \ The following definitions are needed for kForth 13 | \ ============================================= 14 | 15 | : align ; 16 | 1 cells constant cell 17 | \ ============================================= 18 | 19 | 20 | 21 | variable seed ( -- addr) 22 | 23 | : initiate-seed ( -- ) 74755 seed ! ; 24 | : random ( -- n ) seed @ 1309 * 13849 + 65535 and dup seed ! ; 25 | 26 | 6000 constant elements ( -- int) 27 | 28 | align create list elements cells allot 29 | 30 | : initiate-list ( -- ) 31 | list elements cells + list do random i ! cell +loop 32 | ; 33 | 34 | : dump-list ( -- ) 35 | list elements cells + list do i @ . cell +loop cr 36 | ; 37 | 38 | : verify-list ( -- ) 39 | list elements 1- cells mybounds do 40 | i 2@ > 41 | \ abort" bubble-sort: not sorted" 42 | if ." bubble-sort: not sorted" abort then 43 | cell +loop 44 | ; 45 | 46 | : bubble ( -- ) 47 | ." bubbling..." cr 48 | 1 elements 1 do 49 | list elements i - cells mybounds do 50 | i 2@ > if i 2@ swap i 2! then 51 | cell +loop 52 | loop 53 | ; 54 | 55 | : bubble-sort ( -- ) 56 | initiate-seed 57 | initiate-list 58 | bubble 59 | verify-list 60 | ; 61 | 62 | : bubble-with-flag ( -- ) 63 | 1 elements 1 do 64 | -1 list elements i - cells mybounds do 65 | i 2@ > if i 2@ swap i 2! drop 0 then 66 | cell +loop 67 | if leave then 68 | loop 69 | ; 70 | 71 | : bubble-sort-with-flag ( -- ) 72 | initiate-seed 73 | initiate-list 74 | bubble-with-flag 75 | verify-list 76 | ; 77 | 78 | : main ( -- ) 79 | bubble-sort 80 | \ bubble-sort-with-flag 81 | ; 82 | 83 | 84 | -------------------------------------------------------------------------------- /forth-src/crc-32-x86.4th: -------------------------------------------------------------------------------- 1 | \ crc-32-x86.4th 2 | \ 3 | \ Based on crc-32.f for SwiftForth by 4 | \ Petrus Prawirodidjojo Thu 2001-10-18 5 | \ 6 | \ Modified for asm-x86 under kForth by K. Myneni 7 | \ 8 | \ Revisions: 9 | \ 2001-10-18 -- initial port (non-functional) 10 | \ 2007-01-07 -- working version; required fixes to asm-x86 for 11 | \ proper assembly of byte and word register operands km 12 | \ 2019-09-09 -- revised comments; modified crc32s km 13 | \ 14 | \ Requires: 15 | \ asm-x86.4th 16 | \ 17 | base @ 18 | hex 19 | EDB88320 constant CRC-POLYNOMIAL 20 | 21 | CODE crc32 ( n1 char -- n2 ) 22 | 0 [ebx] eax mov, 23 | TCELL # ebx add, 24 | 0 [ebx] edx mov, \ crc to edx 25 | ebx push, 26 | eax ebx mov, 27 | 8 # ecx mov, \ loop count 28 | DO, 29 | 1 # edx shr, \ shift crc 30 | 1 # bh rcr, 31 | 1 # bl ror, \ shift character 32 | bx ax mov, \ save character 33 | bh bl xor, \ xor 34 | 0<, IF, \ skip if equal 35 | CRC-POLYNOMIAL # edx xor, \ crc-32 polynomial 1 04C1 1DB7 36 | THEN, 37 | ax bx mov, \ restore character 38 | LOOP, \ next bit 39 | ebx pop, 40 | edx 0 [ebx] mov, \ crc to tos 41 | 0 # eax mov, 42 | END-CODE 43 | 44 | 45 | \ accumulate a 32-bit crc 46 | : crc-32 ( n1 c-addr u -- n2 ) 47 | 0 do \ n c-addr 48 | dup >r c@ crc32 r> 1+ loop drop ; 49 | 50 | \ calculate crc-32 of a string 51 | : crc32s ( c-addr u -- n ) 52 | FFFFFFFF -rot crc-32 invert ; 53 | 54 | \ calculate crc-32 for several strings 55 | : test 56 | cr cr ." crc-32" cr 57 | s" An Arbitrary String" 2dup type cr 58 | ." crc-32: " crc32s hex u. decimal ." should be 6FBEAAE7" cr 59 | s" ZYXWVUTSRQPONMLKJIHGFEDBCA" 2dup type cr 60 | ." crc-32: " crc32s hex u. decimal ." should be 99CDFDB2" cr ; 61 | 62 | base ! 63 | 64 | test 65 | 66 | \ end of application, - do not delete - 67 | 68 | 69 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/mpfr_bessel.4th: -------------------------------------------------------------------------------- 1 | \ mpfr_bessel.4th 2 | \ 3 | \ High precision calculation of Bessel functions using 4 | \ the MPFR library interface 5 | \ 6 | \ Example: Compute and print J1(2.44) to 40 digits 7 | \ 8 | \ 244 2 1 rbes-jn 40 mpfr. 9 | \ 10 | \ K. Myneni, 2011-06-25 11 | \ krishna.myneni@ccreweb.org 12 | \ 13 | \ Notes: 14 | \ 15 | \ 1. The floating point argument to the MPFR library functions, 16 | \ mpfr_xn, is computed at high precision from two integer 17 | \ arguments to rbes-xn. This method avoids the lower fixed 18 | \ precision (53-bit) of a floating point number parsed by 19 | \ the Forth interpreter. 20 | \ 21 | \ The argument to mpfr_xn, is arg1 * 10^(-arg2), where 22 | \ arg1 and arg2 are the two integers passed to rbes-xn. 23 | \ 24 | \ Requires: 25 | \ 26 | \ ans-words 27 | \ modules 28 | \ syscalls 29 | \ mc 30 | \ asm 31 | \ strings 32 | \ lib-interface 33 | \ libs/gmp/libmpfr 34 | \ libs/gmp/mpfr-utils (optional) 35 | 36 | \ Set precision before initializing mp vars 37 | 256 mpfr_set_default_prec 38 | 39 | mpfr_t dst 40 | mpfr_t num 41 | mpfr_t sca 42 | 43 | dst mpfr_init 44 | num mpfr_init 45 | sca mpfr_init 46 | 47 | \ Return 10^nscale in a mp var, a 48 | : scale-factor ( nscale a -- a ) 49 | swap >r 50 | dup 10 GMP_RNDN mpfr_set_ui drop 51 | dup dup r> GMP_RNDN mpfr_pow_ui drop ; 52 | 53 | \ Return scaled arg, x = arg/(10^scale) in mp var, a 54 | : scaled-arg ( narg nscale a -- a ) 55 | swap sca scale-factor >r 56 | dup rot GMP_RNDN mpfr_set_si drop 57 | dup dup r> GMP_RNDN mpfr_div drop 58 | ; 59 | 60 | \ Compute the Bessel function J_n(x), where x = arg/(10^scale) 61 | : rbes-jn ( narg nscale n -- a ) 62 | >r num scaled-arg 63 | dst swap r> swap GMP_RNDN mpfr_jn drop 64 | dst ; 65 | 66 | \ Compute the Bessel function Y_n(x), where x = arg/(10^scale) 67 | : rbes-yn ( narg nscale n -- a ) 68 | >r num scaled-arg 69 | dst swap r> swap GMP_RNDN mpfr_yn drop 70 | dst ; 71 | 72 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/simpson-nu.4th: -------------------------------------------------------------------------------- 1 | \ simpson-nu.4th 2 | \ 3 | \ Simpson's Rule Integration for Non-Uniform Abscissas 4 | \ 5 | \ Requires: 6 | \ ans-words 7 | \ modules 8 | 9 | BEGIN-MODULE 10 | 11 | BASE @ 12 | DECIMAL 13 | 14 | [undefined] ]F@ [IF] 15 | : ]F@ ( a idx -- ) ( F: -- r ) 16 | postpone floats postpone + postpone f@ ; immediate 17 | : ]F! ( a idx -- ) ( F: r -- ) 18 | postpone floats postpone + postpone f! ; immediate 19 | [THEN] 20 | 21 | 0 ptr x[ 22 | 0 ptr f[ 23 | 0 ptr h[ 24 | 25 | variable npts 26 | variable nint \ number of intervals will be npts-1 27 | 28 | : alloc-mem ( -- ) 29 | nint @ floats allocate IF -59 throw THEN to h[ 30 | ; 31 | 32 | : free-mem ( -- ) h[ dup IF free THEN drop ; 33 | 34 | fvariable h0 35 | fvariable h1 36 | fvariable hph 37 | fvariable hph2 38 | fvariable hdh 39 | fvariable hmh 40 | 41 | Public: 42 | 43 | \ ax0 and af0 are pointers to start elements in x and f arrays 44 | : simp-nu-integrate ( F: -- integral ) ( ax0 af0 npts -- ) 45 | dup npts ! 1- nint ! to f[ to x[ 46 | alloc-mem 47 | 48 | nint @ 0 DO x[ I 1+ ]f@ x[ I ]f@ f- h[ I ]f! LOOP 49 | 50 | 0.0e0 \ F: sum 51 | nint @ 1 DO 52 | h[ I ]f@ h[ I 1- ]f@ \ F: sum h1 h0 53 | f2dup f+ fdup hph f! fsquare hph2 f! 54 | f2dup f/ hdh f! 55 | f* hmh f! \ F: sum 56 | f[ I 1- ]f@ 2.0e0 hdh f@ f- f* 57 | f[ I ]f@ hph2 f@ hmh f@ f/ f* f+ 58 | f[ I 1+ ]f@ 2.0e0 1.0e0 hdh f@ f/ f- f* f+ 59 | hph f@ f* 6.0e0 f/ f+ 60 | 2 +LOOP 61 | 62 | nint @ 2 mod IF 63 | h[ nint @ 2- ]f@ h0 f! h[ nint @ 1- ]f@ h1 f! 64 | 65 | h1 f@ fsquare 2.0e0 f* h0 f@ h1 f@ f* 3.0e0 f* f+ 66 | h0 f@ h1 f@ f+ 6.0e0 f* f/ 67 | f[ nint @ ]f@ f* f+ 68 | 69 | h1 f@ fsquare h1 f@ h0 f@ f* 3.0e0 f* f+ 70 | h0 f@ 6.0e0 f* f/ 71 | f[ nint @ 1- ]f@ f* f+ 72 | 73 | h1 f@ fdup fsquare f* 74 | h0 f@ fdup h1 f@ f+ f* 6.0e0 f* f/ 75 | f[ nint @ 2- ]f@ f* fnegate f+ 76 | THEN 77 | 78 | free-mem 79 | ; 80 | 81 | BASE ! 82 | END-MODULE 83 | 84 | -------------------------------------------------------------------------------- /forth-src/pde2.4th: -------------------------------------------------------------------------------- 1 | \ pde2.4th 2 | \ 3 | \ Numerically solve the 1-D diffusion equation using the method 4 | \ of finite differences: 5 | \ 6 | \ u_t = D*u_xx 7 | \ 8 | \ K. Myneni, 2013-02-26 9 | \ 10 | \ Revisions: 11 | \ 2013-03-09 km removes unneeded initialization of u_jp in EVOLVE 12 | \ 13 | \ Notes: 14 | \ 15 | \ The function at t=0 is given by, 16 | \ 17 | \ u(x,0) = 1 18 | \ 19 | \ The boundary conditions are: 20 | \ 21 | \ u(10, t) = 20 for t > 0 22 | \ u_x(0, t) = 0 23 | \ 24 | \ References: 25 | \ 26 | \ 1. S.J. Farlow, Partial Differential Equations for Scientists 27 | \ and Engineers, Dover Publications (1982); see Lesson 38. 28 | 29 | fvariable D 0.5e D f! \ Diffusion coefficient 30 | fvariable u_ext 20e u_ext f! 31 | 32 | 0.01e fconstant dx 33 | 4e-5 fconstant dt 34 | 35 | variable nx 36 | 10e dx f/ f>d d>s 1+ nx ! 37 | 38 | create x[ nx @ FLOATS allot 39 | create u_x_0[ nx @ FLOATS allot 40 | create u_j[ nx @ FLOATS allot 41 | create u_jp1[ nx @ FLOATS allot 42 | 43 | \ syntactic sugar for simple fp arrays 44 | : ]F@ ( a u -- ) ( F: -- r) \ ( a n -- r) 45 | FLOATS + f@ ; 46 | : ]F! ( a u -- ) ( F: r -- ) \ ( r a n -- ) 47 | FLOATS + f! ; 48 | 49 | : init ( -- ) 50 | 0e nx @ 0 DO fdup x[ I ]F! dx f+ LOOP fdrop 51 | nx @ 0 DO 1e u_x_0[ I ]F! LOOP 52 | u_x_0[ u_j[ nx @ FLOATS move 53 | ; 54 | init 55 | 56 | fvariable fk 57 | D f@ dt f* dx fdup f* f/ fk f! \ choose dt so that fk < 0.5 58 | 59 | \ Evolve the solution by n time steps, i.e. by an elapsed time 60 | \ of n*dt 61 | 62 | : evolve ( n -- ) 63 | 0 ?DO 64 | nx @ 1- 1 DO 65 | u_j[ I 1+ ]F@ u_j[ I ]F@ 2e f* f- u_j[ I 1- ]F@ f+ fk f@ f* 66 | u_j[ I ]F@ f+ u_jp1[ I ]F! 67 | LOOP 68 | u_jp1[ 1 ]F@ u_jp1[ F! \ b.c.: u_x(0, t) = 0 69 | u_ext f@ u_jp1[ nx @ 1- ]F! \ b.c.: u(10, t) = u_ext 70 | 71 | u_jp1[ u_j[ nx @ FLOATS move 72 | LOOP 73 | ; 74 | 75 | 76 | \ Compute the solution at t=1 77 | ms@ 78 | 25000 evolve 79 | ms@ swap - . 80 | 81 | -------------------------------------------------------------------------------- /forth-src/jd.4th: -------------------------------------------------------------------------------- 1 | \ jd.4th 2 | \ 3 | \ Julian Day and Calendar calculator by Wil Baden 4 | 5 | \ The following definitions are needed for kForth -- K. Myneni, 9-13-2001 6 | \ ----------------------------------------- 7 | : third 2 pick ; 8 | : space 1 spaces ; 9 | : 3drop 2drop drop ; 10 | \ ----------------------------------------- 11 | 12 | ( 13 | In gathering old stuff, I came across the following, written long ago, 14 | which I thought would be of interest. 15 | 16 | The Julian Day is the number of days since 1 January 4713 BC. 17 | ) 18 | 19 | \ Julian Day 20 | 21 | : JD ( dd mm yyyy -- julian-day ) 22 | >R ( dd mm)( R: yyyy) 23 | 3 - DUP 0< IF 12 + R> 1- >R THEN 24 | 306 * 5 + 10 / + ( day) 25 | R@ 1461 4 */ + 1721116 + 26 | DUP 2299169 > IF 27 | 3 + R@ 100 / - R@ 400 / + 28 | THEN 29 | R> DROP ( R: ) 30 | ; 31 | 32 | : BC 1- NEGATE ; 33 | 34 | ( 35 | With this you can print a calendar, good for any month except 36 | October 1582. 37 | ) 38 | 39 | 40 | : CAL ( dd mm yyyy -- ) 41 | 1 third 1+ third JD >R ( R: 1/mm+1/yyyy) 42 | 1 third third JD >R ( R: 1/mm+1/yyyy 1/mm/yyyy) 43 | JD R@ 1- ( dd/mm/yyyy 0/mm/yyyy) 44 | CR R@ 1+ 7 MOD 4 * SPACES 45 | 2R> DO 46 | I over - 3 .R 47 | over I = IF ." *" ELSE SPACE THEN 48 | I 2 + 7 MOD 0= IF CR THEN 49 | LOOP 2DROP ; 50 | 51 | : TODAY ( -- ) 52 | TIME&DATE CAL 3DROP ; 53 | 54 | 55 | \ Here are some test values. 56 | 57 | \ 1 1 4713 BC JD . ( 0 ) 58 | \ 31 12 1 BC JD . ( 1721422 ) 59 | \ 1 1 1 JD . ( 1721423 ) 60 | \ 5 10 1582 JD . ( 2299160 ) 61 | \ 15 10 1582 JD . ( 2299161 ) 62 | \ 1 1 1933 JD . ( 2427074 Merriam-Webster dictionary ) 63 | \ 1 1 1965 JD . ( 2438762 Random House dictionary ) 64 | \ 23 5 1968 JD . ( 2440000 Winning Ways ) 65 | 66 | 67 | 68 | ( 69 | -- 70 | Wil Baden Costa Mesa, California Per neilbawd@earthlink.net 71 | ) 72 | 73 | 74 | -------------------------------------------------------------------------------- /forth-src/user.4th: -------------------------------------------------------------------------------- 1 | \ user.4th 2 | \ 3 | \ Determine user properties on a Linux system: 4 | \ username, user id, group id, actual name, home directory 5 | \ 6 | \ Copyright (c) 2002 Krishna Myneni, 7 | \ Creative Consulting for Research and Education 8 | \ 9 | \ Requires: 10 | \ strings.4th 11 | \ files.4th 12 | \ utils.4th 13 | \ 14 | \ Revisions: 15 | \ 2007-02-27 modified get-username to set EOL in get-username km 16 | 17 | create username 64 allot \ counted string 18 | create user_actual_name 256 allot \ " 19 | create user_home_dir 256 allot \ " 20 | create pwd_line_buf 256 allot 21 | variable user_id 22 | variable group_id 23 | variable pwd_fd 24 | 25 | s" /etc/passwd" $constant SYSTEM_PWD_FILE 26 | 27 | : get-username ( -- a u ) 28 | s" echo $USER > username" shell drop 29 | s" username" R/O open-file 30 | if 31 | \ Unable to open the file, set username to NULL string 32 | drop 0 username ! 33 | else 34 | dup username 1+ 63 rot read-line drop 35 | if username c! else drop 0 username ! then 36 | close-file drop 37 | then 38 | username count ; 39 | 40 | : next_pwd_field ( a u -- a2 u2 a3 u3 ) 41 | \ a3 u3 is the next field value string; a2 u2 is the rest 42 | [char] : scan dup 0= 43 | if 2dup 44 | else 1 /string 2dup [char] : scan dup >r 2swap r> - 45 | then ; 46 | 47 | : get-user-properties ( a u -- ) 48 | username pack 49 | SYSTEM_PWD_FILE R/O open-file 50 | if 51 | \ Unable to open the password file, set actual name to NULL string 52 | drop 0 user_actual_name ! 53 | else 54 | pwd_fd ! 55 | begin 56 | pwd_line_buf 256 pwd_fd @ read-line drop 57 | while 58 | pwd_line_buf swap 59 | username count search 60 | if 61 | \ Found user entry in the password file; parse info 62 | next_pwd_field 2drop 63 | next_pwd_field evaluate user_id ! 64 | next_pwd_field evaluate group_id ! 65 | next_pwd_field user_actual_name pack 66 | next_pwd_field user_home_dir pack 67 | then 68 | 2drop 69 | repeat 70 | drop pwd_fd @ close-file drop 71 | then ; 72 | -------------------------------------------------------------------------------- /forth-src/fsl/logistic.4th: -------------------------------------------------------------------------------- 1 | \ logistic The Logistic function and its first derivative 2 | \ logistic = Exp( c + a x ) / (1 + Exp( c + a x ) ) 3 | \ d_logistic = a Exp( c + a x ) / (1 + Exp( c + a x ) )^2 4 | 5 | \ Forth Scientific Library Algorithm #4 6 | 7 | \ This code conforms with ANS requiring: 8 | \ 1. The Floating-Point word set 9 | \ 10 | 11 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted by the 12 | \ author to use this software for any application provided this 13 | \ copyright notice is preserved. 14 | 15 | \ Revisions: 16 | \ 2007-10-22 km; added automated test code with higher precision 17 | \ reference values, computed using HP 48G calculator, 18 | \ and added more test cases; forced DECIMAL base. 19 | \ 2007-10-27 km; save base, switch to decimal, and restore base. 20 | 21 | cr .( Logistic V1.2c 27 October 2007 EFC ) 22 | BASE @ DECIMAL 23 | 24 | : logistic ( fx fa fc -- fz ) 25 | FROT FROT 26 | F* F+ 27 | FEXP 28 | FDUP 1.0e0 F+ 29 | F/ 30 | ; 31 | 32 | : d_logistic ( fx fa fc -- fz ) 33 | FSWAP FROT 34 | FOVER F* FROT F+ 35 | FEXP 36 | 37 | FDUP 1.0e0 F+ FSQUARE 38 | F/ F* 39 | ; 40 | 41 | BASE ! 42 | 43 | TEST-CODE? [IF] \ test code ============================================== 44 | [undefined] T{ [IF] include ttester [THEN] 45 | BASE @ DECIMAL 46 | 47 | 1e-12 rel-near F! 48 | 1e-12 abs-near F! 49 | set-near 50 | 51 | CR 52 | TESTING LOGISTIC D_LOGISTIC 53 | t{ -1e 1e 0e logistic -> 0.268941421370e r}t 54 | t{ 0e 1e 0e logistic -> 0.5e r}t 55 | t{ 1e 1e 0e logistic -> 0.731058578630e r}t 56 | t{ -3.2e 1.5e 0.2e logistic -> 0.00995180186692e r}t 57 | t{ 0e 1.5e 0.2e logistic -> 0.549833997312e r}t 58 | t{ 3.2e 1.5e 0.2e logistic -> 0.993307149076e r}t 59 | t{ 0e 1e 0e d_logistic -> 0.25e r}t 60 | t{ 3.2e 1.5e 0.2e d_logistic -> 0.00997208500613e r}t 61 | 62 | BASE ! 63 | [THEN] 64 | 65 | -------------------------------------------------------------------------------- /forth-src/x11/font-properties-x11.4th: -------------------------------------------------------------------------------- 1 | \ font-properties-x11.4th 2 | \ 3 | \ Display loaded font properties of fonts used by simple-frames-x11 4 | \ or other loaded fonts 5 | \ 6 | 7 | include ans-words 8 | include modules 9 | include syscalls 10 | include mc 11 | include asm 12 | include strings 13 | include files 14 | include utils 15 | include lib-interface 16 | include libs/x11/Xatom 17 | include libs/x11/libX11 18 | include font-strings-x11 19 | include simple-graphics-x11 20 | include simple-fonts-x11 21 | include simple-typeset-x11 22 | include simple-frames-x11 23 | 24 | Also X11 25 | Also simple-graphics-x11 26 | Also font-strings-x11 27 | Also simple-fonts-x11 28 | Also simple-typeset-x11 29 | Also simple-frames-x11 30 | 31 | variable h 32 | variable w 33 | variable wgt 34 | variable res 35 | variable ptsize 36 | variable subx 37 | variable suby 38 | 39 | \ Display font properties of the font 40 | : print-font-props ( afontstruct -- ) 41 | get-resolution 42 | cr ." Screen resolution: xdpi = " swap . 2 spaces ." ydpi = " . 43 | cr ." current font height (pix) = " current-font-height . 44 | cr 45 | dup XA_X_HEIGHT h XGetFontProperty . ." height(x) = " h ? cr 46 | dup XA_QUAD_WIDTH w XGetFontProperty . ." width(m) = " w ? cr 47 | dup XA_WEIGHT wgt XGetFontProperty . ." weight = " wgt ? cr 48 | dup XA_RESOLUTION res XGetFontProperty . ." resolution = " res ? cr 49 | dup XA_POINT_SIZE ptsize XGetFontProperty . ." point size = " ptsize ? cr 50 | dup XA_SUBSCRIPT_X subx XGetFontProperty . ." sub x = " subx ? cr 51 | dup XA_SUBSCRIPT_Y suby XGetFontProperty . ." sub y = " suby ? cr 52 | 53 | drop 54 | exit-simple-graphics 55 | ; 56 | 57 | : show-font-info ( -- ) 58 | \ perform other graphics setup 59 | extra-graphics-setup 60 | 0 TextFonts1 @font-entry drop print-font-props 61 | ; 62 | 63 | : frame1 ( -- ) ; 64 | 65 | 66 | ' frame1 67 | 1 set-frames 68 | \ override default handlers provided by simple-frames-x11 69 | ' show-font-info IS user-graphics-init 70 | start-frames 71 | 72 | -------------------------------------------------------------------------------- /forth-src/struct-200x.4th: -------------------------------------------------------------------------------- 1 | \ struct-200x.4th 2 | \ 3 | \ Forth 200x standardized Data Structures. 4 | \ 5 | \ Adapted from the reference implementation for Forth 200x 6 | \ structures given in the Structures RfD at the link below: 7 | \ 8 | \ http://www.forth200x.org/structures.html 9 | \ 10 | \ This RfD was accepted by the Forth-200x standards committee 11 | \ in 2007. 12 | 13 | \ Begin definition of a new structure. Use in the form 14 | \ BEGIN-STRUCTURE . At run time returns the 15 | \ size of the structure. 16 | : begin-structure \ -- addr 0 ; -- size 17 | create 18 | \ here 0 0 , 19 | 1 cells allot? 0 2dup swap ! \ mark stack, lay dummy 20 | does> @ ; \ -- rec-len 21 | 22 | \ Terminate definition of a structure. 23 | : end-structure \ addr n -- 24 | swap ! ; \ set len 25 | 26 | \ Create a new field within a structure definition of size n bytes. 27 | : +FIELD \ addr size n <"name"> -- ; Exec: addr -- 'addr 28 | create 29 | over 1 cells allot? ! + 30 | does> 31 | @ + 32 | ; 33 | 34 | \ Create a new field within a structure definition of size 1 CHARS. 35 | : cfield: \ n1 <"name"> -- n2 ; Exec: addr -- 'addr 36 | 1 chars +FIELD 37 | ; 38 | 39 | \ Create a new field within a structure definition of size 1 CELLS. 40 | \ The field is ALIGNED. 41 | : field: \ n1 <"name"> -- n2 ; Exec: addr -- 'addr 42 | aligned 1 cells +FIELD 43 | ; 44 | 45 | \ Create a new field within a structure definition of size 1 FLOATS. 46 | \ The field is FALIGNED. 47 | : ffield: \ n1 <"name"> -- n2 ; Exec: addr -- 'addr 48 | faligned 1 floats +FIELD 49 | ; 50 | 51 | \ Create a new field within a structure definition of size 1 SFLOATS. 52 | \ The field is SFALIGNED. 53 | : sffield: \ n1 <"name"> -- n2 ; Exec: addr -- 'addr 54 | sfaligned 1 sfloats +FIELD 55 | ; 56 | 57 | \ Create a new field within a structure definition of size 1 DFLOATS. 58 | \ The field is DFALIGNED. 59 | : dffield: \ n1 <"name"> -- n2 ; Exec: addr -- 'addr 60 | dfaligned 1 dfloats +FIELD 61 | ; 62 | 63 | -------------------------------------------------------------------------------- /forth-src/client.4th: -------------------------------------------------------------------------------- 1 | \ client.4th 2 | \ 3 | \ A simple client example to complement the simple 4 | \ server example: server.4th 5 | \ 6 | \ Notes: 7 | \ 8 | \ 0. To use, 9 | \ 10 | \ client 11 | \ 12 | \ where ipaddr is the quad numeric address of the server, 13 | \ e.g. ( 192 168 1 101 ) and port is the port number. 14 | \ 15 | \ 1. For more detailed notes, please see the program, server.4th. 16 | \ 17 | \ References: 18 | \ 1. http://www.linuxhowtos.org/C_C++/socket.htm 19 | \ 20 | \ Revisions: 21 | \ 2010-05-14 km created 22 | \ 2016-06-02 km include the modules interface 23 | \ 2019-12-31 km additional comments 24 | 25 | include ans-words 26 | include struct 27 | include struct-ext 28 | include modules 29 | include syscalls 30 | 31 | Also syscalls 32 | 33 | include socket 34 | 35 | 0 value sockfd 36 | 37 | create buffer 256 allot 38 | create serv_addr sockaddr_in% %size allot 39 | 40 | : clear-sockaddr ( a -- ) sockaddr_in% %size erase ; 41 | : type-quoted ( c-addr u -- ) 42 | [char] " dup >r emit type r> emit ; 43 | 44 | : localhost 127 0 0 1 ; \ ip address of the host computer 45 | 46 | : client ( ip1 ip2 ip3 ip4 port -- ) 47 | depth 5 < ABORT" Usage: ip1 ip2 ip3 ip4 port client" 48 | serv_addr clear-sockaddr 49 | htons serv_addr sockaddr_in->sin_port w! 50 | AF_INET serv_addr sockaddr_in->sin_family w! 51 | 52 | \ We don't do host lookup by name; use ip address from stack 53 | dotted.quad htonl serv_addr sockaddr_in->sin_addr ! 54 | 55 | AF_INET SOCK_STREAM 0 socket dup to sockfd 56 | 0< ABORT" ERROR opening socket" 57 | 58 | sockfd serv_addr sockaddr_in% %size connect 59 | 0< ABORT" ERROR connecting to server" 60 | 61 | ." Please enter a request for the server: " 62 | buffer 255 accept >r 63 | sockfd buffer r> write 0< ABORT" ERROR writing to socket" 64 | buffer 256 erase 65 | sockfd buffer 255 read dup 66 | 0< ABORT" ERROR reading from socket" 67 | cr ." Server replies: " buffer swap type-quoted 68 | 69 | sockfd close ABORT" Error closing socket" 70 | cr 71 | ; 72 | 73 | -------------------------------------------------------------------------------- /forth-src/dos2unix.4th: -------------------------------------------------------------------------------- 1 | \ dos2unix.4th 2 | \ 3 | \ Convert DOS text file into a Unix text file. 4 | \ 5 | \ Copyright (c) 2000--2005 Krishna Myneni 6 | \ 7 | \ This software is provided under the GNU General Public 8 | \ License. 9 | \ 10 | \ Required files: 11 | \ strings.4th 12 | \ files(w).4th 13 | \ 14 | \ Usage: 15 | \ dos2unix -- user is prompted to enter input and output names 16 | \ d2u filename -- output file will be named filename.u 17 | \ 18 | \ Revisions: 19 | \ 20 | \ 12-21-2000 fixed null line problem KM 21 | \ 09-28-2005 updated line-by-line due to fix for read-line in files.4th KM 22 | \ 23 | include strings 24 | include files 25 | 26 | create ifname 256 allot 27 | create ofname 256 allot 28 | 29 | variable if_id 30 | variable of_id 31 | 32 | create lbuf 256 allot 33 | 34 | : open-dos-unix-files ( -- | open the input and output files ) 35 | ifname count R/O open-file 36 | if 37 | cr ." Error opening input file: " 38 | ifname count type cr 39 | abort 40 | then 41 | if_id ! 42 | 43 | ofname count R/W create-file 44 | if 45 | cr ." Error opening output file: " 46 | ofname count type cr 47 | if_id @ close-file 48 | abort 49 | then 50 | of_id ! ; 51 | 52 | : line-by-line ( -- | copy from input file to output file, line by line ) 53 | begin 54 | lbuf 256 if_id @ read-line ( -- u flag ior ) 55 | IF 56 | \ Error reading input file 57 | if_id @ close-file drop 58 | of_id @ close-file drop 59 | cr ." Error reading input file" ABORT 60 | ELSE 61 | false = IF 62 | \ Reached end of input file 63 | drop 64 | if_id @ close-file drop 65 | of_id @ close-file drop 66 | exit 67 | THEN 68 | THEN 69 | lbuf swap 1- 0 max 70 | of_id @ write-line drop 71 | again ; 72 | 73 | : dos2unix ( -- ) 74 | ." Enter DOS text file name: " 75 | ifname 1+ 255 accept ifname c! 76 | ." Enter UNIX text file name: " 77 | ofname 1+ 255 accept ofname c! 78 | open-dos-unix-files 79 | line-by-line ; 80 | 81 | : d2u ( -- | same as dos2unix but takes input filename from input stream ) 82 | bl word ifname strcpy 83 | ifname count s" .u" strcat strpck 84 | ofname strcpy 85 | open-dos-unix-files 86 | line-by-line ; 87 | 88 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/qsort.4th: -------------------------------------------------------------------------------- 1 | \ qsort.4th 2 | \ 3 | \ The quicksort algorithm, in Forth, from: 4 | \ 5 | \ http://en.literateprograms.org/Quicksort_%28Forth%29 6 | \ 7 | \ Original code from Wil Baden, circa 1983. 8 | \ 9 | \ This version sorts cell sized values, via a user-specifiable 10 | \ comparison word, "lessthan". 11 | \ 12 | \ 13 | \ Revisions: 14 | \ 2010-07-21 km test code using FSL style arrays and 15 | \ ttester; demonstrate both ascending and 16 | \ descending sort. 17 | 18 | -1 cells constant -cell 19 | [UNDEFINED] cell- [IF] : cell- -cell + ; [THEN] 20 | 21 | defer lessthan ( a b -- flag ) ' < is lessthan 22 | 23 | : mid ( l r -- mid ) over - 2/ -cell and + ; 24 | 25 | : exch ( addr1 addr2 -- ) dup @ >r over @ swap ! r> swap ! ; 26 | 27 | : part ( l r -- l r r2 l2 ) 28 | 2dup mid @ >r ( r: pivot ) 29 | 2dup begin 30 | swap begin dup @ r@ lessthan while cell+ repeat 31 | swap begin r@ over @ lessthan while cell- repeat 32 | 2dup <= if 2dup exch >r cell+ r> cell- then 33 | 2dup > until r> drop ; 34 | 35 | : qsort ( l r -- ) 36 | part swap rot 37 | \ 2over 2over - + < if 2swap then 38 | 2dup < if recurse else 2drop then 39 | 2dup < if recurse else 2drop then ; 40 | 41 | : sort ( array len -- ) 42 | dup 2 < if 2drop exit then 43 | 1- cells over + qsort ; 44 | 45 | 46 | TEST-CODE? [IF] \ test code ============================================== 47 | [undefined] T{ [IF] include ttester.4th [THEN] 48 | BASE @ DECIMAL 49 | 50 | : }iput ( m1 ... m_n n 'a -- | store m1 ... m_n into array of size n ) 51 | swap dup 0 ?DO 1- 2dup 2>r } ! 2r> LOOP 2drop ; 52 | 53 | : }@ ( n a -- m1 ... m_n ) swap 0 ?DO dup I } @ swap LOOP drop ; 54 | 55 | \ Sort an array of ten integers 56 | 10 INTEGER ARRAY test{ 57 | 4 7 1 0 3 9 6 8 2 5 58 | 10 test{ }iput 59 | 60 | CR 61 | TESTING SORT 62 | \ Ascending sort 63 | ' < is lessthan 64 | T{ test{ 10 sort -> }T 65 | T{ 10 test{ }@ -> 0 1 2 3 4 5 6 7 8 9 }T 66 | 67 | \ Descending sort 68 | ' > is lessthan 69 | T{ test{ 10 sort -> }T 70 | T{ 10 test{ }@ -> 9 8 7 6 5 4 3 2 1 0 }T 71 | 72 | \ Restore default meaning of lessthan 73 | ' < is lessthan 74 | 75 | BASE ! 76 | [THEN] 77 | 78 | -------------------------------------------------------------------------------- /forth-src/mlp-telugu.4th: -------------------------------------------------------------------------------- 1 | \ mlp-telugu.4th 2 | \ 3 | \ తెలుగులో ప్రోగ్రామింగ్ చెయ్యి 4 | \ 5 | \ మైనేని కృష్ణ 6 | \ 7 | \ మార్పులు : 8 | \ 13 మే 2017 -- తయారు చేసిన 9 | \ 30 నవంబరు 2019 10 | 11 | synonym వెంటనే immediate 12 | synonym తరువాత postpone 13 | 14 | synonym ఉంటే if 15 | synonym కాదంటే else 16 | synonym అప్పుడు then 17 | synonym మొదలు begin 18 | synonym అయితే while 19 | synonym ఇంకొసారి repeat 20 | synonym మళ్ళీ again 21 | synonym వరకు until 22 | synonym చెయ్యి do 23 | synonym చెయ్యనా ?do 24 | synonym తిరుగు loop 25 | : ఐ తరువాత I ; వెంటనే 26 | : ఙే తరువాత J ; వెంటనే 27 | synonym వదులు leave 28 | synonym [అక్షర] [char] 29 | : చేస్తుంది తరువాత does> ; వెంటనే 30 | synonym ఆపు" abort" 31 | synonym సృజించు create 32 | synonym ఉంచు allot 33 | synonym పదము word 34 | synonym పదాలు words 35 | synonym కనిపెట్టు find 36 | synonym పారేయి drop 37 | synonym 2పారేయి 2drop 38 | synonym డూప్ dup 39 | synonym 2డూప్ 2dup 40 | synonym మార్చు swap 41 | synonym మీద over 42 | synonym రోట్ rot 43 | synonym రోల్ roll 44 | synonym గిల్లు nip 45 | synonym లెక్క count 46 | synonym తుడువు erase 47 | synonym ఖాళీ blank 48 | synonym వెతుకు search 49 | synonym చేరింది included 50 | synonym చేర్చు include 51 | synonym తీసుకొ accept 52 | synonym చూపించు type 53 | synonym మరియు and 54 | synonym కాని or 55 | synonym కాదు invert 56 | synonym ఎక్కువ > 57 | synonym తక్కువ < 58 | synonym సమానం = 59 | synonym పెద్ద max 60 | synonym చిన్న min 61 | synonym మిగత mod 62 | synonym /మిగత /mod 63 | synonym సంఖ్యము >number 64 | synonym అక్షర char 65 | synonym కీ key 66 | synonym కీ? key? 67 | synonym ఎమిట్ emit 68 | synonym మారదు constant 69 | synonym మారేది variable 70 | synonym వెళ్ళు exit 71 | synonym మానేయి quit 72 | synonym ఆపు abort 73 | synonym బై bye 74 | 75 | \ TRUE and FALSE constants 76 | synonym నిజము TRUE 77 | synonym తప్పుడు FALSE 78 | 79 | \ CONSTANTs "sunna" and "padi" 80 | 0 మారదు సున్న 81 | 10 మారదు పది 82 | 83 | \ Examples: 84 | \ 85 | \ VARIABLE "vI" 86 | \ మారేది వి 87 | \ 16 వి ! 88 | \ 89 | \ to-ten ( BEGIN ... UNTIL ) 90 | \ : పది-వరకు ( -- ) సున్న మొదలు 1+ డూప్ . డూప్ పది సమానం వరకు పారేయి ; 91 | \ 92 | \ ten-times ( DO ... LOOP ) 93 | \ : పది-సారిలు ( -- ) 10 0 చెయ్యి ఐ . తిరుగు ; 94 | 95 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/read_xyfile.4th: -------------------------------------------------------------------------------- 1 | \ read_xyfile.4th 2 | \ 3 | \ Utility for reading a two-column ascii file into FSL-type arrays 4 | \ 5 | \ Requires the non-standard word PARSE-FLOATS, which parses a line of 6 | \ text into a sequence of floating point numbers: 7 | \ 8 | \ PARSE-FLOATS ( a u -- r1 r2 ... rn n ) 9 | \ 10 | \ or, for systems with a separate floating stack, 11 | \ 12 | \ PARSE-FLOATS ( a u -- n ) ( F: -- r1 r2 ... rn ) 13 | \ 14 | \ PARSE-FLOATS should return zero for n if the line is empty or 15 | \ contains only whitespace characters. 16 | \ 17 | \ Notes: 18 | \ 19 | \ 1. The input file must be a text file, having two columns of 20 | \ numbers, with the columns separated by a comma, space(s), or a tab. 21 | \ 22 | \ 2. The file may contain comments which are indicated by a '#' in 23 | \ the first column of a line. 24 | \ 25 | \ 3. Empty lines and white space lines are ignored. 26 | \ 27 | \ 4. Return error codes for read_xyfile: 28 | \ 29 | \ 0 -- no error 30 | \ 1 -- unable to open input file 31 | \ 2 -- input file does not conform to specs. 32 | \ 33 | \ Copyright (c) 2007 K. Myneni, 2007-11-21 34 | \ 35 | \ This file may be used for any purpose, as long as the copyright notice 36 | \ above is preserved. 37 | \ 38 | \ Revisions: 39 | \ 2015-02-07 km; fixed reading lines with trailing spaces; 40 | \ drop left over zero on stack. 41 | \ 42 | [undefined] parse-floats [IF] include strings.4th [THEN] 43 | [undefined] open-file [IF] include files.4th [THEN] 44 | 45 | 0 value fid 46 | 0 value idx 47 | create dline 256 allot 48 | 49 | : read_xyfile ( 'x 'y a u -- np ierr ) 50 | R/O open-file ABORT" Unable to open file!" 51 | to fid 52 | 0 to idx 53 | 2>R 54 | BEGIN 55 | dline 255 fid read-line 0= and 56 | WHILE 57 | dline c@ [char] # = IF dline swap cr type \ ignore comment line 58 | ELSE 59 | dline swap parse-floats 60 | CASE 61 | 0 OF ENDOF \ blank line; ignore it 62 | 2 OF 2R@ nip idx } F! 2R@ drop idx } F! 1 idx + to idx ENDOF 63 | fid close-file drop ." Unrecognized junk in file" ABORT 64 | ENDCASE 65 | THEN 66 | REPEAT 67 | drop 68 | fid close-file drop 69 | 2R> 2drop 70 | idx 0 71 | ; 72 | 73 | -------------------------------------------------------------------------------- /forth-src/slurp-file.4th: -------------------------------------------------------------------------------- 1 | \ slurp-file.4th 2 | \ 3 | \ Read the contents of a file into a memory buffer. 4 | \ similar to Gforth's SLURP-FILE 5 | \ 6 | \ SLURP-FILE ( c-addr1 u1 -- c-addr2 u2 ) 7 | \ 8 | \ c-addr1 u1 is the filename string and c-addr2 u2 is the 9 | \ buffer address and size upon success. Errors in SLURP-FILE 10 | \ are thrown for external handling using CATCH. The following 11 | \ throw codes may occur: 12 | \ 13 | \ -73 -70 -69 -66 -62 -59 1 2 14 | \ 15 | \ Program-defined error codes are 1 and 2, file too large, 16 | \ and slurp size does not match requested read size. The 17 | \ value MAX_SLURP may be adjusted below for use with your 18 | \ system. 19 | \ 20 | \ In addition to CATCHing thrown errors, it is up to the 21 | \ user to free the allocated buffer into which the file 22 | \ contents are written, when the buffer is no longer needed. 23 | \ 24 | \ 25 | \ Example: 26 | \ 27 | \ s" m41_inverted_2.png" slurp-file 28 | \ ok 29 | \ .s 30 | \ 31 | \ 1610282 32 | \ addr 140100436811792 33 | \ ok 34 | \ over 16 dump ( reformatted output below ) 35 | \ 36 | \ 7F6BACC4E010 : 89 50 4E 47 0D 0A 1A 0A 37 | \ 00 00 00 0D 49 48 44 52 38 | \ .PNG........IHDR ok 39 | \ 40 | \ swap free 2drop 41 | \ ok 42 | \ 43 | \ 44 | \ Required: 45 | \ ans-words.4th 46 | \ strings.4th 47 | \ files.4th 48 | \ 49 | \ Optional: 50 | \ dump.4th 51 | 52 | 1024 1024 * 64 * value MAX_SLURP \ 64 MB limit 53 | 54 | 0 ptr slurp_buf 55 | variable slurp_fid 56 | variable slurp_size 57 | 58 | : slurp-file ( c-addr1 u1 -- c-addr2 u2) 59 | 0 slurp_size ! 60 | R/O BIN open-file 61 | if -69 throw 62 | then dup slurp_fid ! 63 | file-size 64 | if -66 throw 65 | then 66 | 0<> over MAX_SLURP > or 67 | if 1 throw \ File too large 68 | then dup slurp_size ! allocate 69 | if -59 throw 70 | then to slurp_buf 71 | 0 s>d slurp_fid @ reposition-file 72 | if -73 throw 73 | then slurp_buf slurp_size @ slurp_fid @ read-file 74 | if -70 throw 75 | then slurp_size @ over <> 76 | if 2 throw \ Slurp size and read size do not match 77 | then slurp_buf swap 78 | slurp_fid @ close-file 79 | if -62 throw 80 | then ; 81 | 82 | 83 | -------------------------------------------------------------------------------- /forth-src/spinlock-ex.4th: -------------------------------------------------------------------------------- 1 | \ spinlock-ex.4th 2 | \ 3 | \ Demonstrate mutual exclusion of a resource, shared by two tasks, through 4 | \ the method of spin locking. In this example, the shared resource is not 5 | \ specified; it may be a hardware device, a file, memory, etc. 6 | \ 7 | \ Copyright (c) 2007 Krishna Myneni 8 | \ 9 | \ Requires: 10 | \ signal.4th 11 | \ asm-x86.4th 12 | \ Revisions: 13 | \ 2007-08-25 created km 14 | \ 15 | include ans-words 16 | include modules 17 | include syscalls 18 | include mc 19 | include asm-x86.4th 20 | include signal.4th 21 | 22 | VARIABLE DAQ_IN_USE ( the lock variable ) 23 | VARIABLE START_TIME 24 | VARIABLE SLEEP_TIME ( sleep time in microseconds ) 25 | 300000 SLEEP_TIME ! 26 | 27 | : elapsed ( -- u ) ms@ START_TIME @ - ; 28 | 29 | \ : spin-lock ( a -- ) 30 | \ BEGIN DUP @ 0= UNTIL true SWAP ! ; 31 | 32 | \ assembler spin-lock is different from Forth version above 33 | 34 | CODE spin-lock ( a -- ) 35 | TRUE # eax mov, 36 | 0 [ebx] ecx mov, 37 | BEGIN, 38 | eax 0 [ecx] xchg, 39 | 0<, 40 | WHILE, 41 | REPEAT, 42 | 0 # eax mov, 43 | TCELL # ebx add, 44 | END-CODE 45 | 46 | 47 | \ : unlock ( a -- ) 0 SWAP ! ; 48 | 49 | CODE unlock ( a -- ) 50 | 0 [ebx] ecx mov, 51 | 0 # 0 [ecx] mov, 52 | TCELL # ebx add, 53 | END-CODE 54 | 55 | 56 | : handler ( n -- ) 57 | DROP 58 | DAQ_IN_USE spin-lock 59 | CR elapsed 6 .r ." HANDLER has lock!" 60 | 100 MS ( time to process with shared resource ) 61 | DAQ_IN_USE unlock 62 | ; 63 | 64 | 65 | CR .( Use ESC to halt the test) 66 | 67 | : test ( -- ) 68 | DAQ_IN_USE unlock \ for safety 69 | ['] handler SIGALRM forth-signal drop \ install the handler 70 | 1000 1000 SET-TIMER \ Send SIGALRM to kForth every 1000 ms 71 | ms@ START_TIME ! 72 | BEGIN 73 | KEY? IF 74 | KEY 27 = IF 75 | SIG_IGN SIGALRM forth-signal DROP \ Stop sending SIGALRM 76 | CR ." Exiting test " 77 | EXIT 78 | THEN 79 | THEN 80 | DAQ_IN_USE spin-lock 81 | CR elapsed 6 .r ." test has lock." 82 | 100 MS ( time to process with shared resource ) 83 | DAQ_IN_USE unlock 84 | SLEEP_TIME @ usleep \ relinquish control to the system for a while 85 | AGAIN 86 | ; 87 | 88 | test 89 | 90 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/derivative.4th: -------------------------------------------------------------------------------- 1 | \ 2 | \ derivative.4th 3 | \ 4 | \ Compute the numerical derivative of a series of data values 5 | \ 6 | \ Krishna Myneni, 30 Dec 1989 7 | \ Revisions: 8 | \ 1990-08-30 km; Translated from QuickBasic to VAX FORTRAN 9 | \ 1991-10-02 km; Modified for Microsoft Fortran 5.0 10 | \ 2001-03-30 km; Translated to kForth 11 | \ 2007-06-02 km; use FSL-style array instead of kForth matrix package 12 | \ 2007-11-07 km; update comments 13 | \ 14 | \ Requires: 15 | \ fsl-util.4th 16 | 17 | \ der_m is the n x 2 input matrix with column 0 containing 18 | \ x values and column 1 containing y values. The y values 19 | \ are replaced with the corresponding value of the derivative 20 | \ 21 | 22 | 0 ptr der{{ 23 | 0 value Npts 24 | 25 | fvariable dx1 26 | fvariable dx2 27 | fvariable last_y 28 | 29 | \ derivative returns an integer error code with the following meaning: 30 | \ 0 = no error, derivative computed successfully; 31 | \ 1 = two points have same x value, derivative not computed. 32 | 33 | : derivative ( 'mat npts -- ierr) 34 | 35 | to Npts to der{{ 36 | 37 | \ Compute derivative at first pt with just two points. 38 | 39 | der{{ 1 0 }} F@ der{{ 0 0 }} F@ F- fdup dx1 F! \ x(1) - x(0) 40 | F0= IF 1 EXIT THEN \ exit if dx = 0 between first two pts 41 | der{{ 1 1 }} F@ \ y(2) 42 | der{{ 0 1 }} F@ \ y(1) 43 | fdup last_y F! 44 | F- dx1 F@ F/ der{{ 0 1 }} F! 45 | 46 | \ Calculate derivative with average of forward and backward slopes. 47 | 48 | Npts 1- 1 DO 49 | der{{ I 1+ 0 }} F@ der{{ I 0 }} F@ F- dx1 F! \ dx1 = x(i+1) - x(i) 50 | der{{ I 0 }} F@ der{{ I 1- 0 }} F@ F- dx2 F! \ dx2 = x(i) - x(i-1) 51 | 52 | dx1 F@ F0= dx2 F@ F0= or 53 | IF 1 unloop EXIT THEN 54 | 55 | last_y F@ der{{ I 1 }} F@ \ y(i-1) y(i) 56 | fdup last_y F! fswap F- dx2 F@ F/ 57 | der{{ I 1+ 1 }} F@ last_y F@ F- \ y(i+1) - y(i) 58 | dx1 F@ F/ F+ 2e F/ der{{ I 1 }} F! 59 | 60 | LOOP 61 | 62 | \ Compute derivate at last pt. using two pts. 63 | 64 | der{{ Npts 1- 0 }} F@ der{{ Npts 2 - 0 }} F@ F- fdup dx1 F! 65 | F0= IF 1 EXIT then \ exit if dx = 0 between last two pts 66 | 67 | der{{ Npts 1- 1 }} F@ last_y F@ F- dx1 F@ F/ der{{ Npts 1- 1 }} F! 68 | 69 | 0 \ Derivative computed successfully. 70 | ; 71 | 72 | -------------------------------------------------------------------------------- /forth-src/textbox.4th: -------------------------------------------------------------------------------- 1 | \ textbox.4th 2 | \ 3 | \ Copyright (c) 2003 Krishna Myneni, Creative Consulting for 4 | \ Research and Education 5 | \ 6 | \ Provided under the GNU General Public License 7 | \ 8 | \ Requires: 9 | \ ans-words.4th 10 | \ mini-oof.4th 11 | \ strings.4th 12 | \ ansi.4th 13 | \ 14 | \ Revisions: 15 | \ 2020-02-02 km; use :NONAME 16 | \ 2021-08-27 km; update for revised mini-oof library 17 | 18 | 1 cells constant cell 19 | 20 | object class 21 | cell var tb-col 22 | cell var tb-row 23 | cell var tb-width 24 | cell var tb-height 25 | cell var tb-bkg \ background color 26 | cell var tb-fg \ foreground color 27 | cell var tb-border \ border color 28 | method tb-setcolors 29 | method tb-linexy \ return col and row for start of line 30 | method tb-draw 31 | method tb-init 32 | end-class textbox 33 | 34 | :noname ( o -- ) dup tb-bkg @ background tb-fg @ foreground ; 35 | textbox defines tb-setcolors 36 | 37 | :noname ( n o -- col row ) >r r@ tb-row @ + r> tb-col @ swap ; 38 | textbox defines tb-linexy 39 | 40 | :noname ( o -- ) 41 | >r 42 | r@ tb-setcolors 43 | 0 r@ tb-linexy at-xy 44 | r@ tb-border @ background r@ tb-width @ spaces r@ tb-bkg @ background 45 | r> 46 | dup tb-height @ 1- 1 ?do 47 | dup i swap tb-linexy at-xy 48 | dup tb-border @ background space dup tb-bkg @ background 49 | dup tb-width @ 2- spaces 50 | dup tb-border @ background space dup tb-bkg @ background 51 | loop 52 | dup dup tb-height @ 1- swap tb-linexy at-xy 53 | dup tb-border @ background dup tb-width @ spaces 54 | dup tb-bkg @ background 55 | drop ; 56 | 57 | textbox defines tb-draw 58 | 59 | :noname ( col row width height fg bkg border o -- ) 60 | >r 61 | r@ tb-border ! 62 | r@ tb-bkg ! 63 | r@ tb-fg ! 64 | r@ tb-height ! 65 | r@ tb-width ! 66 | r@ tb-row ! 67 | r> tb-col ! ; 68 | 69 | textbox defines tb-init 70 | 71 | \ Demonstration of text boxes: 72 | 73 | 1 [IF] 74 | textbox new constant tb1 75 | 2 1 8 6 RED WHITE BLUE tb1 tb-init 76 | textbox new constant tb2 77 | 12 4 20 5 YELLOW RED CYAN tb2 tb-init 78 | textbox new constant tb3 79 | 16 12 10 10 BLACK GREEN GREEN tb3 tb-init 80 | 81 | page 82 | tb1 tb-draw 83 | tb2 tb-draw 84 | tb3 tb-draw 85 | text_normal 86 | [THEN] 87 | 88 | 89 | 90 | 91 | 92 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/mpfr_demo01.4th: -------------------------------------------------------------------------------- 1 | \ mpfr_gr.4th 2 | \ 3 | \ Compute and print the Golden Ratio [1] to 77 significant digits, 4 | \ using the GNU MPFR library and four different methods. 5 | \ 6 | \ K. Myneni, 2011-07-07 7 | \ 8 | \ 1. http://en.wikipedia.org/wiki/Golden_ratio 9 | 10 | \ Load library bindings and open the library 11 | 12 | include ans-words 13 | include modules 14 | include syscalls 15 | include mc 16 | include asm 17 | include strings 18 | include lib-interface 19 | include libs/gmp/libmpfr 20 | include libs/gmp/mpfr-utils 21 | 22 | DECIMAL 23 | 24 | \ 1. Soln. of quadratic eqn: phi = (1 + sqrt(5))/2 25 | : phi-qu ( amp -- ) 26 | dup 27 | dup 5 GMP_RNDN mpfr_set_ui drop 28 | 2dup GMP_RNDN mpfr_sqrt drop 29 | 2dup 1 GMP_RNDN mpfr_add_ui drop 30 | 2dup 2 GMP_RNDN mpfr_div_ui drop 31 | 2drop ; 32 | 33 | 34 | \ 2. Trigonometric eqn: phi = 2*cos(pi/5) 35 | : phi-tr ( amp -- ) 36 | dup 37 | dup GMP_RNDN mpfr_const_pi drop 38 | 2dup 5 GMP_RNDN mpfr_div_ui drop 39 | 2dup GMP_RNDN mpfr_cos drop 40 | 2dup 2 GMP_RNDN mpfr_mul_ui drop 41 | 2drop ; 42 | 43 | 44 | \ 3. Continued square root: phi = sqrt(1 + sqrt(1 + sqrt(1 + ... 45 | : phi-cs ( amp nterms -- ) 46 | >r dup 47 | dup 2 GMP_RNDN mpfr_set_ui drop 48 | 2dup GMP_RNDN mpfr_sqrt drop 49 | r> 0 ?do 50 | 2dup 1 GMP_RNDN mpfr_add_ui drop 51 | 2dup GMP_RNDN mpfr_sqrt drop 52 | loop 53 | 2drop ; 54 | 55 | 56 | \ 4. Continued fraction: phi = 1 + 1/(1 + 1/(1 + 1/... 57 | : phi-cf ( amp nterms -- ) 58 | >r dup 59 | dup 3 GMP_RNDN mpfr_set_ui drop 60 | 2dup 2 GMP_RNDN mpfr_div_ui drop 61 | r> 0 ?do 62 | 2dup 1 swap GMP_RNDN mpfr_ui_div drop 63 | 2dup 1 GMP_RNDN mpfr_add_ui drop 64 | loop 65 | 2drop ; 66 | 67 | 68 | 256 mpfr_set_default_prec \ provides 77 sig. decimal digits 69 | mpfr_t gr 70 | gr mpfr_init 71 | 72 | cr 73 | .( MPFR Demo: Compute and print the Golden Ratio to 77 digits using four methods ) 74 | cr 75 | cr .( 1. phi = {1 + sqrt[5]}/2 ) 76 | cr gr phi-qu gr 77 mpfr. cr 77 | 78 | cr .( 2. phi = 2*cos[pi/5] ) 79 | cr gr phi-tr gr 77 mpfr. cr 80 | 81 | cr .( 3. phi = sqrt[1 + sqrt[1 + sqrt[1 + ... ) 82 | cr gr 150 phi-cs gr 77 mpfr. cr 83 | 84 | cr .( 4. phi = 1 + 1/(1 + 1/(1 + 1/... ) 85 | cr gr 182 phi-cf gr 77 mpfr. cr 86 | 87 | 88 | -------------------------------------------------------------------------------- /forth-src/libs/x11/Xatom.4th: -------------------------------------------------------------------------------- 1 | \ Xatom.4th 2 | \ 3 | \ 4 | \ Do not change! Changing this file implies a protocol change! 5 | \ 6 | 1 constant XA_PRIMARY 7 | 2 constant XA_SECONDARY 8 | 3 constant XA_ARC 9 | 4 constant XA_ATOM 10 | 5 constant XA_BITMAP 11 | 6 constant XA_CARDINAL 12 | 7 constant XA_COLORMAP 13 | 8 constant XA_CURSOR 14 | 9 constant XA_CUT_BUFFER0 15 | 10 constant XA_CUT_BUFFER1 16 | 11 constant XA_CUT_BUFFER2 17 | 12 constant XA_CUT_BUFFER3 18 | 13 constant XA_CUT_BUFFER4 19 | 14 constant XA_CUT_BUFFER5 20 | 15 constant XA_CUT_BUFFER6 21 | 16 constant XA_CUT_BUFFER7 22 | 17 constant XA_DRAWABLE 23 | 18 constant XA_FONT 24 | 19 constant XA_INTEGER 25 | 20 constant XA_PIXMAP 26 | 21 constant XA_POINT 27 | 22 constant XA_RECTANGLE 28 | 23 constant XA_RESOURCE_MANAGER 29 | 24 constant XA_RGB_COLOR_MAP 30 | 25 constant XA_RGB_BEST_MAP 31 | 26 constant XA_RGB_BLUE_MAP 32 | 27 constant XA_RGB_DEFAULT_MAP 33 | 28 constant XA_RGB_GRAY_MAP 34 | 29 constant XA_RGB_GREEN_MAP 35 | 30 constant XA_RGB_RED_MAP 36 | 31 constant XA_STRING 37 | 32 constant XA_VISUALID 38 | 33 constant XA_WINDOW 39 | 34 constant XA_WM_COMMAND 40 | 35 constant XA_WM_HINTS 41 | 36 constant XA_WM_CLIENT_MACHINE 42 | 37 constant XA_WM_ICON_NAME 43 | 38 constant XA_WM_ICON_SIZE 44 | 39 constant XA_WM_NAME 45 | 40 constant XA_WM_NORMAL_HINTS 46 | 41 constant XA_WM_SIZE_HINTS 47 | 42 constant XA_WM_ZOOM_HINTS 48 | 43 constant XA_MIN_SPACE 49 | 44 constant XA_NORM_SPACE 50 | 45 constant XA_MAX_SPACE 51 | 46 constant XA_END_SPACE 52 | 47 constant XA_SUPERSCRIPT_X 53 | 48 constant XA_SUPERSCRIPT_Y 54 | 49 constant XA_SUBSCRIPT_X 55 | 50 constant XA_SUBSCRIPT_Y 56 | 51 constant XA_UNDERLINE_POSITION 57 | 52 constant XA_UNDERLINE_THICKNESS 58 | 53 constant XA_STRIKEOUT_ASCENT 59 | 54 constant XA_STRIKEOUT_DESCENT 60 | 55 constant XA_ITALIC_ANGLE 61 | 56 constant XA_X_HEIGHT 62 | 57 constant XA_QUAD_WIDTH 63 | 58 constant XA_WEIGHT 64 | 59 constant XA_POINT_SIZE 65 | 60 constant XA_RESOLUTION 66 | 61 constant XA_COPYRIGHT 67 | 62 constant XA_NOTICE 68 | 63 constant XA_FONT_NAME 69 | 64 constant XA_FAMILY_NAME 70 | 65 constant XA_FULL_NAME 71 | 66 constant XA_CAP_HEIGHT 72 | 67 constant XA_WM_CLASS 73 | 68 constant XA_WM_TRANSIENT_FOR 74 | 75 | 68 constant XA_LAST_PREDEFINED 76 | 77 | -------------------------------------------------------------------------------- /forth-src/libs/cfitsio/fits-ex1.4th: -------------------------------------------------------------------------------- 1 | \ FITS file example 2 | \ 3 | \ from section 2.6 of the manual, CFITSIO User's Reference Guide: 4 | \ An Interface to FITS Format Files for C Programmers, version 3.0., 5 | \ April 2009. See file cfitsio.pdf at 6 | \ 7 | \ http://heasarc.gsfc.nasa.gov/fitsio/ 8 | \ 9 | \ K. Myneni, krishna.myneni@ccreweb.org 10 | \ 11 | include ans-words 12 | include modules 13 | include syscalls 14 | include mc 15 | include asm 16 | include strings 17 | include lib-interface 18 | include struct 19 | include struct-ext 20 | include libcfitsio 21 | include fsl/fsl-util 22 | 23 | variable file_fptr \ pointer to the FITS file; defined in fitsio.h 24 | variable status 25 | 26 | 2variable fpixel 27 | 1 s>d fpixel 2! 28 | 2 value naxis 29 | 2variable nelements 30 | variable exposure 31 | 32 | 2 INTEGER array naxes{ 33 | 300 naxes{ 0 } ! 34 | 200 naxes{ 1 } ! \ image is 300 pixels wide by 200 rows 35 | 36 | 200 300 2 MATRIX array{{ 37 | 38 | : fits-ex1 ( -- status ) 39 | 0 status ! \ initialize status before calling fitsio routines 40 | file_fptr z" testfile.fits" status fits_create_file \ create new file 41 | cr ." fits_create_file returned " dup . 42 | ABORT" Unable to open the output FITS file!" 43 | 44 | \ Create the primary array image (16-bit short integer pixels) 45 | file_fptr @ SHORT_IMG naxis naxes{ 0 } status fits_create_img 46 | cr ." fits_create_image returned " . 47 | 48 | \ Write a keyword; must pass the ADDRESS of the value 49 | 1500 exposure ! 50 | file_fptr @ TLONG z" EXPOSURE" exposure z" Total Exposure Time" status fits_update_key 51 | cr ." fits_update_key returned " . 52 | 53 | \ Initialize the values in the image with a linear ramp function 54 | naxes{ 1 } @ 0 DO 55 | naxes{ 0 } @ 0 DO 56 | I J + array{{ J I }} w! 57 | LOOP 58 | LOOP 59 | naxes{ 0 } @ naxes{ 1 } @ * s>d nelements 2! \ number of pixels to write 60 | 61 | \ Write the array of integers to the image 62 | file_fptr @ TSHORT fpixel 2@ nelements 2@ array{{ 0 0 }} status fits_write_img 63 | cr ." fits_write_img returned " . 64 | 65 | file_fptr @ status fits_close_file \ close the file 66 | cr ." fits_close_file returned " . 67 | \ 0 status @ fits_report_error \ (stderr, status) \ print out any error messages 68 | 69 | status @ 70 | ; 71 | 72 | 73 | -------------------------------------------------------------------------------- /forth-src/ftran-test.4th: -------------------------------------------------------------------------------- 1 | \ Test ftran202 2 | \ 3 | \ K. Myneni, Creative Consulting for Research and Education 4 | \ 5 | \ Revisions: 6 | \ 2010-06-03 km 7 | \ 2010-08-06 km added test for "-x^2" to check consistency with Fortran 8 | 9 | include ans-words 10 | include strings 11 | include fsl/complex \ complex arithmetic package 12 | include fsm2 \ finite state machine 13 | include chr_tbl \ character encoding pkg 14 | 15 | include ftran202 16 | include lists 17 | include ttester 18 | 19 | \ Hayes' style notation for testing equality of list results 20 | 21 | : }list ( ... -- | Compare the stack [expected] contents with the saved [actual] contents) 22 | depth actual-depth @ = IF \ if depths match 23 | depth ?dup IF \ if there is something on the stack 24 | 0 DO \ for each stack item 25 | actual-results i CELLS + a@ \ compare actual with expected 26 | equal NOT IF S" INCORRECT RESULT: " ERROR LEAVE THEN 27 | LOOP 28 | THEN 29 | ELSE \ depth mismatch 30 | s" WRONG NUMBER OF RESULTS: " ERROR 31 | THEN 32 | ; 33 | 34 | : fl" ( -- list ) (f") make-token-list ; 35 | 36 | 37 | CR 38 | TESTING (f") 39 | t{ fl" -x" -> '( x F@ FNEGATE ) }list 40 | t{ fl" x+y" -> '( x F@ y F@ F+ ) }list 41 | t{ fl" x^2+y^2" -> '( x F@ f^2 y F@ f^2 F+ ) }list 42 | t{ fl" a*(b+x)-w" -> '( a F@ b F@ x F@ F+ F* w F@ F- ) }list 43 | t{ fl" a=b*c-d/tanh(w)+abs(x)" -> 44 | '( b F@ c F@ F* d F@ w F@ FTANH F/ F- x F@ FABS F+ a F! ) }list 45 | t{ fl" atan2(x,y)" -> '( x F@ y F@ FATAN2 ) }list 46 | 47 | 48 | fvariable x 49 | fvariable y 50 | 3e x f! 51 | 4e y f! 52 | 53 | 54 | TESTING f$" 55 | t{ f$" -x" -> -3e r}t 56 | t{ f$" 1+x" -> 4e r}t 57 | t{ f$" 1-x" -> -2e r}t 58 | t{ f$" 1/y" -> 0.25e r}t 59 | t{ f$" x^2" -> 9e r}t 60 | t{ f$" -x^2" -> -9e r}t 61 | t{ f$" x+y" -> 7e r}t 62 | t{ f$" x-y" -> -1e r}t 63 | t{ f$" x*y" -> 12e r}t 64 | t{ f$" x/y" -> 0.75e r}t 65 | t{ f$" x^y" -> 81e r}t 66 | 67 | t{ f$" x^2+y" -> 13e r}t 68 | t{ f$" x+y^2" -> 19e r}t 69 | t{ f$" (x+y)^2" -> 49e r}t 70 | t{ f$" x*(x+y)" -> 21e r}t 71 | t{ f$" x^2*(x+y)" -> 63e r}t 72 | t{ f$" x*(x^2+y)" -> 39e r}t 73 | t{ f$" x*(x+y^2)" -> 57e r}t 74 | t{ f$" x*(x^2+y^2)" -> 75e r}t 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /forth-src/fsl/dd/test-runge4-dd.4th: -------------------------------------------------------------------------------- 1 | \ test-runge4-dd.4th 2 | \ 3 | 4 | include ans-words 5 | include strings 6 | include modules 7 | include ddarith 8 | include dd_io 9 | include fsl/fsl-util 10 | include fsl/dynmem 11 | cr .( Loading the Double Double precision RK4 integrator ) 12 | include fsl/dd/runge4-dd 13 | 14 | \ Integrate the Lorenz equations, 15 | \ 16 | \ dx/dt = sig * (y - x) 17 | \ dy/dt = r * x - y - x * z 18 | \ dz/dt = -bp * z + x * y 19 | \ 20 | \ with the following parameters, 21 | \ 22 | \ sig = 16, r = 45.92, bp = 4 23 | \ 24 | \ and the following initial values, 25 | \ 26 | \ x(t = 0) = 0 27 | \ y(t = 0) = 1 28 | \ z(t = 0) = 0 29 | 30 | 1000000 value nsteps 31 | 32 | cr .( Integrate the Lorenz equations in double double precision ) 33 | cr .( using ) nsteps . .( steps and fixed-step RK4 integrator ) 34 | cr 35 | 36 | \ Forth source derivatives 37 | 38 | 16.0E0 0.0E0 ddconstant sig 39 | 4592e 0e 10e 0e -2 dd^n dd* ddconstant r 40 | 4.0E0 0.0E0 ddconstant bp 41 | 42 | 0 ptr der{ 43 | 0 ptr func{ 44 | 45 | : derivs() ( t tt 'u 'dudt -- ) 46 | to der{ to func{ 47 | dddrop \ does not use t 48 | 49 | func{ 1 } dd@ func{ 0 } dd@ dd- sig dd* 50 | der{ 0 } dd! 51 | 52 | func{ 2 } dd@ ddnegate r dd+ 53 | func{ 0 } dd@ dd* 54 | func{ 1 } dd@ dd- 55 | der{ 1 } dd! 56 | 57 | func{ 0 } dd@ func{ 1 } dd@ dd* 58 | func{ 2 } dd@ bp dd* dd- 59 | der{ 2 } dd! 60 | ; 61 | 62 | 63 | 3 DDFLOAT array x{ 64 | 65 | : print-x ( -- ) 66 | x{ 0 } dd@ ddfs. cr 67 | x{ 1 } dd@ ddfs. cr 68 | x{ 2 } dd@ ddfs. cr ; 69 | 70 | DDVARIABLE _dt 71 | 10e 0e -4 dd^n _dt dd! \ 1e-4 in dd format 72 | 73 | : dt _dt dd@ ; 74 | : dt! _dt dd! ; 75 | 76 | defer rk4_init 77 | defer rk4_integrate 78 | defer rk4_done 79 | 80 | 0e 0e ddconstant DD0.0 81 | 1e 0e ddconstant DD1.0 82 | 83 | : lorenz ( nsteps xt -- ) 84 | DD0.0 x{ 0 } dd! DD1.0 x{ 1 } dd! DD0.0 x{ 2 } dd! \ initial conditions 85 | 3 rk4_init 86 | >r 87 | DD0.0 \ t0 88 | r> 0 DO 89 | dt x{ 1 rk4_integrate 90 | LOOP 91 | DDDROP 92 | rk4_done ; 93 | 94 | cr 95 | ' )runge_kutta4_init is rk4_init 96 | ' runge_kutta4_integrate() is rk4_integrate 97 | ' runge_kutta4_done is rk4_done 98 | ms@ nsteps ' derivs() lorenz ms@ swap - . .( ms ) cr 99 | .( x_final = { ) cr print-x .( } ) cr 100 | 101 | -------------------------------------------------------------------------------- /forth-src/fsl/factorl.4th: -------------------------------------------------------------------------------- 1 | \ factorial compute the factorial of a positive integer 2 | 3 | \ Forth Scientific Library Algorithm #14 4 | 5 | \ Note: this word takes a single precision integer and returns a 6 | \ double precision integer 7 | \ 8 | \ This is an ANS Forth program requiring: 9 | \ 1. The word 'SD*' is needed for single precision by double precision 10 | \ integer multiply (double precision result). 11 | \ : SD* ( multiplicand multiplier_double -- product_double ) 12 | \ 2 PICK * >R UM* R> + 13 | \ ; 14 | \ 15 | \ 2. The words 'DOUBLE' and 'ARRAY' to create a 16 | \ 1-dimensional double precision integer array, for the test code. 17 | 18 | \ Note because the factorial function grows rapidly, this function has 19 | \ a range of validity that is dependent upon the number of bits used to 20 | \ represent numbers. For a 32 bit system, input parameters in the range 21 | \ 0..20 are valid. The small range of validity makes this function 22 | \ practical to implement in tabular form for some applications. 23 | 24 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted 25 | \ by the author to use this software for any application provided 26 | \ this copyright notice is preserved. 27 | 28 | \ Revisions: 29 | \ 2005-01-23 cgm; changed ?TEST-CODE to TEST-CODE? 30 | \ 2007-11-29 km; added automated tests and base handling 31 | 32 | CR .( FACTORIAL V1.1 18 October 1994 EFC ) 33 | BASE @ DECIMAL 34 | 35 | : factorial ( n -- d! ) 36 | 1 S>D ROT \ put a double 1 on stack under parameter 37 | 38 | ?DUP IF 39 | 1 SWAP DO I ROT ROT SD* -1 +LOOP 40 | THEN 41 | ; 42 | 43 | BASE ! 44 | 45 | TEST-CODE? [IF] \ test code ============================================= 46 | [undefined] T{ [IF] include ttester.4th [THEN] 47 | BASE @ DECIMAL 48 | 49 | CR 50 | TESTING FACTORIAL 51 | t{ 0 factorial -> 1 s>d }t 52 | t{ 1 factorial -> 1 s>d }t 53 | t{ 2 factorial -> 2 s>d }t 54 | t{ 3 factorial -> 6 s>d }t 55 | t{ 4 factorial -> 24 s>d }t 56 | t{ 5 factorial -> 120 s>d }t 57 | t{ 6 factorial -> 720 s>d }t 58 | t{ 7 factorial -> 5040 s>d }t 59 | t{ 8 factorial -> 40320e f>d }t 60 | t{ 9 factorial -> 362880e f>d }t 61 | t{ 10 factorial -> 3628800e f>d }t 62 | t{ 11 factorial -> 39916800e f>d }t 63 | t{ 12 factorial -> 479001600e f>d }t 64 | 65 | BASE ! 66 | [THEN] 67 | -------------------------------------------------------------------------------- /forth-src/bifurc-logmap.4th: -------------------------------------------------------------------------------- 1 | \ bifurc-logmap.4th 2 | \ 3 | \ Display the bifurcation diagram for a logistic map. 4 | \ 5 | \ Copyright (c) 2011--2012 Krishna Myneni, Creative Consulting for 6 | \ Research & Education, krishna.myneni@ccreweb.org 7 | \ 8 | \ This code is released under the GNU Lesser GPL (LGPL). 9 | \ 10 | \ Revisions: 11 | \ 2011-08-26 km first version. 12 | \ 2011-08-27 km fixed vertical inversion 13 | \ 2012-04-09 km revised to use with modules version of simple-plot 14 | \ 2012-04-19 km revised to use simple-graphics-x11 module 15 | \ 2012-05-04 km revised to add statement: Also X11 16 | \ 17 | \ References: 18 | \ 19 | \ 1. E. Ott, Chaos in Dynamical Systems, 1994, Cambridge Univ. Press, 20 | \ see sec. 2.2, p. 32 ; 21 | 22 | include ans-words 23 | include modules 24 | include syscalls 25 | include mc 26 | include asm 27 | include strings 28 | include lib-interface 29 | include libs/x11/libX11 30 | include x11/simple-graphics-x11.4th 31 | 32 | Also X11 33 | Also simple-graphics-x11 34 | 35 | 500 constant Ntr \ number of transient values 36 | 1000 constant Nseq \ number of values in sequence to plot 37 | 38 | 2.5e fconstant rmin 39 | 4.0e fconstant rmax 40 | rmax rmin f- fconstant delr 41 | 0.001e fconstant rdelta 42 | 43 | \ logistic map 44 | fvariable r 45 | : L ( F: x -- x' ) 1e fover f- f* r f@ f* ; 46 | 47 | \ Generate L map sequence for current r, discarding transient 48 | create L_s Nseq FLOATS allot 49 | 50 | : gen-L_s ( -- ) 51 | 0.5e Ntr 0 DO L LOOP \ first Ntr iterations are discarded 52 | L_s Nseq 0 DO >r L fdup r@ f! r> FLOAT+ LOOP 53 | drop fdrop ; 54 | 55 | XPoint% %size constant XPT_SIZE 56 | create xp XPT_SIZE Nseq * allot 57 | 58 | : XPoint! ( nx ny apoint -- ) rot over XPoint->x w! XPoint->y w! ; 59 | 60 | fvariable fheight 61 | fvariable fwidth 62 | 63 | : scale-point ( F: r x -- ) ( -- ux uy ) 64 | 1e f- fnegate fheight f@ f* fround>s >r 65 | rmin f- delr f/ fwidth f@ f* fround>s r> ; 66 | 67 | : scale-L_s ( -- ) 68 | L_s xp Nseq 0 DO 69 | >r dup >r r f@ r> f@ scale-point r@ Xpoint! 70 | FLOAT+ r> XPT_SIZE + 71 | LOOP 72 | 2drop ; 73 | 74 | : draw-bifurc ( -- ) 75 | get-window-size s>f fheight f! s>f fwidth f! 76 | clear-window 77 | blue foreground 78 | 79 | \ Sweep r from rmin to rmax 80 | delr rdelta f/ fround>s 0 DO 81 | rmin I s>f rdelta f* f+ r f! 82 | gen-L_s 83 | scale-L_s 84 | xp Nseq draw-points 85 | LOOP 86 | ; 87 | 88 | ' draw-bifurc IS redraw-window 89 | 90 | 2 2 simple-graphics 91 | 92 | 93 | 94 | -------------------------------------------------------------------------------- /forth-src/signed-include.4th: -------------------------------------------------------------------------------- 1 | \ signed-include.4th 2 | \ 3 | \ Utility words for loading PGP-signed Forth source 4 | \ code. 5 | \ 6 | \ Krishna Myneni, public key fingerprint: 7 | \ 660c 9cdb 9bb7 2d95 dfe3 a3ba aeaf 69b7 c4e2 3145 8 | \ 9 | \ Last Revised: 22 August 2018 10 | \ 11 | \ Requires: 12 | \ strings.4th 13 | \ 14 | \ Provides: 15 | \ 16 | \ check-pgp-signature ( a u -- b ) 17 | \ -----BEGIN ( -- ) 18 | \ signed-included ( a u -- ) 19 | \ include-signed ( -- ) 20 | \ 21 | \ Notes: 22 | \ 23 | \ 0. The assumption made about PGP-signed Forth source 24 | \ files is that they have been "clearsigned", e.g. 25 | \ 26 | \ $ gpg --clearsign filename 27 | \ 28 | \ 1. If you want to load a PGP-signed Forth source 29 | \ file without doing signature validation, simply use 30 | \ INCLUDED or INCLUDE with the signed file in the 31 | \ usual way. The PGP headers will be ignored. 32 | \ 33 | \ 2. For ANS-Forths, please provide the following equivalent 34 | \ words: 35 | \ 36 | \ strcat ( a1 u1 a2 u2 -- a3 u3 | concatenate strings ) 37 | \ strpck ( a u -- ^str | string to counted string ) 38 | \ system ( ^str -- n | shell command with return code ) 39 | \ 40 | \ A port of strings.4th to ANS Forth is available to 41 | \ provide STRCAT and STRPCK, but SYSTEM or equivalent 42 | \ must be available in your Forth system, as well as 43 | \ gpg or equivalent command line PGP tool. 44 | 45 | 10 constant EOL 46 | 47 | \ For the filename specified by the string, check 48 | \ its PGP signature and return a flag: true if 49 | \ signature is good, false if bad. 50 | : check-pgp-signature ( a u -- b ) 51 | s" gpg --verify " 2swap strcat strpck system 0= ; 52 | 53 | : -----BEGIN ( -- ) 54 | EOL parse 55 | 2dup 56 | s" PGP SIGNED MESSAGE-----" compare 0= if 57 | 2drop refill if EOL parse 2drop then 58 | else 59 | s" PGP SIGNATURE-----" compare 0= if 60 | begin 61 | refill if 62 | EOL parse 63 | s" -----END PGP SIGNATURE-----" 64 | compare 0= 65 | else true then 66 | until 67 | else 68 | 2drop 69 | then 70 | then ; 71 | 72 | \ version of INCLUDED for a PGP-signed file 73 | : signed-included ( a u -- ) 74 | 2dup check-pgp-signature IF 75 | included 76 | else 77 | type ." has an invalid signature!" cr 78 | abort 79 | then ; 80 | 81 | \ version of INCLUDE for a PGP-signed file 82 | : signed-include ( -- ) 83 | bl parse signed-included ; 84 | 85 | -------------------------------------------------------------------------------- /forth-src/libs/x11/Xft.4th: -------------------------------------------------------------------------------- 1 | \ Xft.4th 2 | \ 3 | \ From /usr/include/X11/Xft/Xft.h 4 | \ 5 | \ Original Source Copyright © 2000 Keith Packard 6 | \ 7 | \ Permission to use, copy, modify, distribute, and sell this software and its 8 | \ documentation for any purpose is hereby granted without fee, provided that 9 | \ the above copyright notice appear in all copies and that both that 10 | \ copyright notice and this permission notice appear in supporting 11 | \ documentation, and that the name of Keith Packard not be used in 12 | \ advertising or publicity pertaining to distribution of the software without 13 | \ specific, written prior permission. Keith Packard makes no 14 | \ representations about the suitability of this software for any purpose. It 15 | \ is provided "as is" without express or implied warranty. 16 | \ 17 | \ Forth version by Krishna Myneni, Creative Consulting for Research 18 | \ and Education, http://ccreweb.org 19 | \ 20 | \ Revisions: 21 | \ 22 | z" core" ptr XFT_CORE 23 | z" render" ptr XFT_RENDER 24 | z" xlfd" ptr XFT_XLFD 25 | z" maxglyphmemory" ptr XFT_MAX_GLYPH_MEMORY 26 | z" maxunreffonts" ptr XFT_MAX_UNREF_FONTS 27 | 28 | 29 | struct 30 | int: XftFont->ascent 31 | int: XftFont->descent 32 | int: XftFont->height 33 | int: XftFont->max_advance_width 34 | int: XftFont->charset 35 | int: XftFont->pattern 36 | end-struct XftFont% 37 | 38 | struct 39 | int: XftColor->pixel 40 | int: XftColor->color 41 | end-struct XftColor% 42 | 43 | struct 44 | int: XftCharSpec->ucs4 45 | int16: XftCharSpec->x 46 | int16: XftCharSpec->y 47 | end-struct XftCharSpec% 48 | 49 | struct 50 | int: XftCharFontSpec->font 51 | int: XftCharFontSpec->ucs4 52 | int16: XftCharFontSpec->x 53 | int16: XftCharFontSpec->y 54 | end-struct XftCharFontSpec% 55 | 56 | struct 57 | int: XftGlyphSpec->glyph 58 | int16: XftGlyphSpec->x 59 | int16: XftGlyphSpec->y 60 | end-struct XftGlyphSpec% 61 | 62 | struct 63 | int: XftGlyphFontSpec->font 64 | int: XftGlyphFontSpec->glyph 65 | int16: XftGlyphFontSpec->x 66 | int16: XftGlyphFontSpec->y 67 | end-struct XftGlyphFontSpec% 68 | 69 | \ Defining words for data structures 70 | : XftFont create XftFont% %allot drop ; 71 | : XftColor create XftColor% %allot drop ; 72 | : XftCharSpec create XftCharSpec% %allot drop ; 73 | : XftGlyphSpec create XftGlyphSpec% %allot drop ; 74 | : XftCharFontSpec create XftCharFontSpec% %allot drop ; 75 | : XftGlyphFontSpec create XftGlyphFontSpec% %allot drop ; 76 | 77 | 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /forth-src/qm/bket.4th: -------------------------------------------------------------------------------- 1 | \ bket.4th 2 | \ 3 | \ 3, 4, and 5-qubit basis states 4 | \ 5 | \ Requires: qcsim.4th 6 | \ 7 | 8 | 3 ket |000> |00> |0> %x% |000> -> 9 | 3 ket |001> |00> |1> %x% |001> -> 10 | 3 ket |010> |01> |0> %x% |010> -> 11 | 3 ket |011> |01> |1> %x% |011> -> 12 | 3 ket |100> |10> |0> %x% |100> -> 13 | 3 ket |101> |10> |1> %x% |101> -> 14 | 3 ket |110> |11> |0> %x% |110> -> 15 | 3 ket |111> |11> |1> %x% |111> -> 16 | 17 | 4 ket |0000> |000> |0> %x% |0000> -> 18 | 4 ket |0001> |000> |1> %x% |0001> -> 19 | 4 ket |0010> |001> |0> %x% |0010> -> 20 | 4 ket |0011> |001> |1> %x% |0011> -> 21 | 4 ket |0100> |010> |0> %x% |0100> -> 22 | 4 ket |0101> |010> |1> %x% |0101> -> 23 | 4 ket |0110> |011> |0> %x% |0110> -> 24 | 4 ket |0111> |011> |1> %x% |0111> -> 25 | 4 ket |1000> |100> |0> %x% |1000> -> 26 | 4 ket |1001> |100> |1> %x% |1001> -> 27 | 4 ket |1010> |101> |0> %x% |1010> -> 28 | 4 ket |1011> |101> |1> %x% |1011> -> 29 | 4 ket |1100> |110> |0> %x% |1100> -> 30 | 4 ket |1101> |110> |1> %x% |1101> -> 31 | 4 ket |1110> |111> |0> %x% |1110> -> 32 | 4 ket |1111> |111> |1> %x% |1111> -> 33 | 34 | 5 ket |00000> |0000> |0> %x% |00000> -> 35 | 5 ket |00001> |0000> |1> %x% |00001> -> 36 | 5 ket |00010> |0001> |0> %x% |00010> -> 37 | 5 ket |00011> |0001> |1> %x% |00011> -> 38 | 5 ket |00100> |0010> |0> %x% |00100> -> 39 | 5 ket |00101> |0010> |1> %x% |00101> -> 40 | 5 ket |00110> |0011> |0> %x% |00110> -> 41 | 5 ket |00111> |0011> |1> %x% |00111> -> 42 | 5 ket |01000> |0100> |0> %x% |01000> -> 43 | 5 ket |01001> |0100> |1> %x% |01001> -> 44 | 5 ket |01010> |0101> |0> %x% |01010> -> 45 | 5 ket |01011> |0101> |1> %x% |01011> -> 46 | 5 ket |01100> |0110> |0> %x% |01100> -> 47 | 5 ket |01101> |0110> |1> %x% |01101> -> 48 | 5 ket |01110> |0111> |0> %x% |01110> -> 49 | 5 ket |01111> |0111> |1> %x% |01111> -> 50 | 5 ket |10000> |1000> |0> %x% |10000> -> 51 | 5 ket |10001> |1000> |1> %x% |10001> -> 52 | 5 ket |10010> |1001> |0> %x% |10010> -> 53 | 5 ket |10011> |1001> |1> %x% |10011> -> 54 | 5 ket |10100> |1010> |0> %x% |10100> -> 55 | 5 ket |10101> |1010> |1> %x% |10101> -> 56 | 5 ket |10110> |1011> |0> %x% |10110> -> 57 | 5 ket |10111> |1011> |1> %x% |10111> -> 58 | 5 ket |11000> |1100> |0> %x% |11000> -> 59 | 5 ket |11001> |1100> |1> %x% |11001> -> 60 | 5 ket |11010> |1101> |0> %x% |11010> -> 61 | 5 ket |11011> |1101> |1> %x% |11011> -> 62 | 5 ket |11100> |1110> |0> %x% |11100> -> 63 | 5 ket |11101> |1110> |1> %x% |11101> -> 64 | 5 ket |11110> |1111> |0> %x% |11110> -> 65 | 5 ket |11111> |1111> |1> %x% |11111> -> 66 | 67 | 68 | -------------------------------------------------------------------------------- /forth-src/fsl/expint.4th: -------------------------------------------------------------------------------- 1 | \ expint Real Exponential Integral ACM Algorithm #20 2 | 3 | \ Forth Scientific Library Algorithm #1 4 | 5 | \ Evaluates the Real Exponential Integral, 6 | \ E1(x) = - Ei(-x) = int_x^\infty exp^{-u}/u du for x > 0 7 | \ using a rational approximation 8 | 9 | \ This code conforms with ANS requiring: 10 | \ 1. The Floating-Point word set 11 | \ 12 | 13 | \ Collected Algorithms from ACM, Volume 1 Algorithms 1-220, 14 | \ 1980; Association for Computing Machinery Inc., New York, 15 | \ ISBN 0-89791-017-6 16 | 17 | \ (c) Copyright 1994 Everett F. Carter. Permission is granted by the 18 | \ author to use this software for any application provided the 19 | \ copyright notice is preserved. 20 | \ 21 | \ Ported to kForth with minor revisions by K. Myneni, 2006-11-07 22 | \ Revisions: 23 | \ ? km; removed use of "%" 24 | \ 2007-10-14 km; revised test code to perform automated tests 25 | \ 2007-10-27 km; save base, switch to decimal, and restore base. 26 | 27 | CR .( EXPINT V1.1c 27 October 2007 EFC ) 28 | BASE @ DECIMAL 29 | 30 | : expint ( fx -- expint[x] ) 31 | 32 | FDUP 33 | 1.0e F< IF 34 | FDUP 0.00107857e F* 0.00976004e F- 35 | FOVER F* 36 | 0.05519968e F+ 37 | FOVER F* 38 | 0.24991055e F- 39 | FOVER F* 40 | 0.99999193e F+ 41 | FOVER F* 42 | 0.57721566e F- 43 | FSWAP FLN F- 44 | ELSE 45 | FDUP 8.5733287401e F+ 46 | FOVER F* 47 | 18.059016973e F+ 48 | FOVER F* 49 | 8.6347608925e F+ 50 | FOVER F* 51 | 0.2677737343e F+ 52 | 53 | FOVER 54 | FDUP 9.5733223454e F+ 55 | FOVER F* 56 | 25.6329561486e F+ 57 | FOVER F* 58 | 21.0996530827e F+ 59 | FOVER F* 60 | 3.9584969228e F+ 61 | 62 | FSWAP FDROP 63 | F/ 64 | FOVER F/ 65 | FSWAP -1.0e F* FEXP 66 | F* 67 | 68 | THEN 69 | ; 70 | 71 | BASE ! 72 | 73 | TEST-CODE? [IF] \ test code ============================================= 74 | [undefined] T{ [IF] include ttester [THEN] 75 | BASE @ DECIMAL 76 | 77 | 1e-7 rel-near F! 78 | 1e-7 abs-near F! 79 | set-near 80 | 81 | \ Generate selected E1 values and compare with values 82 | \ from Abramowitz & Stegun, Handbook of Mathematical 83 | \ Functions, Table 5.1 84 | 85 | CR 86 | TESTING expint 87 | t{ 0.5e expint -> 0.5597736e r}t 88 | t{ 1.0e expint -> 0.2193839e r}t 89 | t{ 2.0e expint -> 0.0489005e r}t 90 | t{ 5.0e expint -> 0.001148296e r}t 91 | t{ 10.0e expint -> 0.4156969e-5 r}t 92 | 93 | BASE ! 94 | [THEN] 95 | -------------------------------------------------------------------------------- /forth-src/signal.4th: -------------------------------------------------------------------------------- 1 | \ signal.4th 2 | \ 3 | \ Signals interface for kForth 4 | \ 5 | \ Copyright (C) 2004 Krishna Myneni 6 | \ Provided under the GNU General Public License 7 | \ 8 | \ Revisions: 9 | \ 2004-09-04 created 10 | 11 | 1 constant SIGHUP \ Hangup 12 | 2 constant SIGINT \ Interrupt 13 | 3 constant SIGQUIT \ Quit 14 | 4 constant SIGILL \ Illegal instruction 15 | 5 constant SIGTRAP \ Trace trap 16 | 6 constant SIGABRT \ Abort 17 | 7 constant SIGBUS \ Bus error 18 | 8 constant SIGFPE \ Floating-point exception 19 | 9 constant SIGKILL \ Kill (unblockable) 20 | 10 constant SIGUSR1 \ User-defined 21 | 11 constant SIGSEGV \ Segmentation fault 22 | 12 constant SIGUSR2 \ User-defined 23 | 13 constant SIGPIPE \ Broken pipe 24 | 14 constant SIGALRM \ Alarm clock 25 | 15 constant SIGTERM \ Termination 26 | 16 constant SIGSTKFLT \ Stack fault 27 | 17 constant SIGCHLD \ Child status changed 28 | 18 constant SIGCONT \ Continue execution 29 | 19 constant SIGSTOP \ Stop (unblockable) 30 | 20 constant SIGTSTP \ Keyboard stop 31 | 21 constant SIGTTIN \ Background read from tty 32 | 22 constant SIGTTOU \ Background write to tty 33 | 23 constant SIGURG \ Urgent condition on socket 34 | 24 constant SIGXCPU \ CPU time limit exceeded 35 | 25 constant SIGXFSZ \ File size limit exceeded 36 | 26 constant SIGVTARM \ Virtual alarm clock 37 | 27 constant SIGPROF \ Profiling alarm clock 38 | 28 constant SIGWINCH \ Window size change 39 | 29 constant SIGPOLL \ Pollable event occured 40 | 30 constant SIGPWR \ Power failure restart 41 | 42 | 0 constant SIG_DFL 43 | 1 constant SIG_IGN 44 | 45 | 0 constant ITIMER_REAL 46 | 1 constant ITIMER_VIRTUAL 47 | 2 constant ITIMER_PROF 48 | 49 | 50 | \ Buffer to hold args to SET-ITIMER and GET-ITIMER 51 | CREATE itimerdata 8 CELLS ALLOT 52 | 53 | \ Simplified interface for setup of timer signals 54 | 55 | : ms>usec,sec ( ms -- usec sec | convert milliseconds to sec and usec ) 56 | DUP 1000 / TUCK 1000 * - 1000 * SWAP ; 57 | 58 | : set-timer ( msinterval msnow -- | generate SIGALRM every ms milli-seconds) 59 | ms>usec,sec itimerdata 2 CELLS + 2! 60 | ms>usec,sec itimerdata 2! 61 | ITIMER_REAL itimerdata itimerdata 4 CELLS + SET-ITIMER 62 | ABORT" SET-ITIMER error" ; 63 | 64 | : get-timer ( -- ms | get the countdown value for the real-time timer) 65 | ITIMER_REAL itimerdata GET-ITIMER 66 | ABORT" GET-ITIMER error" 67 | itimerdata 2 CELLS + 2@ 1000 * SWAP 1000 / + ; 68 | 69 | -------------------------------------------------------------------------------- /forth-src/mini-oof.4th: -------------------------------------------------------------------------------- 1 | \ mini-oof.4th 2 | \ 3 | \ Bernd Paysan's simple object-oriented extensions to ANS Forth, 4 | \ adapted to kForth. For example of usage, see mini-oof-demo.4th 5 | \ 6 | \ Glossary: 7 | \ 8 | \ METHOD ( m v "name" -- m' v ) 9 | \ Define a selector. 10 | \ 11 | \ VAR ( m v size "name" -- m v' ) 12 | \ Define a variable with size bytes. 13 | \ 14 | \ CLASS ( class -- class selectors vars ) 15 | \ Start definition of a class. 16 | \ 17 | \ END-CLASS ( class selectors vars "name" -- ) 18 | \ End definition of a class. 19 | \ 20 | \ DEFINES ( xt class "name" -- ) 21 | \ Bind xt to selector "name" in class. 22 | \ 23 | \ NEW ( class -- o ) 24 | \ Create an object of the class. 25 | \ 26 | \ :: ( class "name" -- ) 27 | \ Compile the method for the selector "name" of the 28 | \ class (not immediate!). 29 | \ 30 | \ OBJECT ( -- a-addr ) 31 | \ The base class of all objects. 32 | \ 33 | \ References: 34 | \ 1. Gforth package and docs: 35 | \ https://github.com/forthy42/gforth 36 | \ 37 | \ 2. B. Paysan, Detailed Description of Mini-OOF, 38 | \ https://bernd-paysan.de/mini-oof.html 39 | \ 40 | \ Revisions: 41 | \ 1998-10-24 original code by B. Paysan 42 | \ 2003-02-15 km adapted for kForth 43 | \ 2003-02-27 km changed defn of new to leave object address on stack 44 | \ 2011-03-03 km removed requirement on strings.4th and ans-words.4th 45 | \ for kForth 1.5.x 46 | \ 2021-08-27 km revise defns of NEW and :: for full compatibility 47 | \ with mini-oof.fs from current Gforth package. 48 | 49 | : method ( m v -- m' v) 50 | create over 1 cells allot? ! swap cell+ swap 51 | does> ( ... o -- ... ) @ over a@ + a@ execute ; 52 | : var ( m v size -- m v') 53 | create over 1 cells allot? ! + 54 | does> ( o -- addr) a@ + ; 55 | : class ( class -- class methods vars ) dup 2@ ; 56 | 57 | : cm_undefined true abort" undefined class method called" ; 58 | 59 | : end-class ( class methods vars -- | create the vtable ) 60 | over create allot? dup >r 2dup ! nip cell+ 2dup ! cell+ 61 | swap 2 cells ?DO 62 | ['] cm_undefined over ! cell+ 63 | 1 cells +LOOP drop 64 | cell+ dup cell+ r> rot @ 2 cells /string move ; 65 | 66 | : >vt ( class "name" -- addr ) ' >body @ + ; 67 | : bind ( class "name -- xt ) >vt a@ ; 68 | : defines ( xt class "name" -- ) >vt ! ; \ define a method for a class 69 | : new ( class -- o ) dup @ allocate abort" ALLOCATE failure!" tuck ! ; 70 | : :: ( class "name" -- xt ) bind compile, ; 71 | 72 | create object 2 cells allot? 1 cells over ! cell+ 2 cells swap ! 73 | 74 | 75 | -------------------------------------------------------------------------------- /forth-src/mini-oof-demo.4th: -------------------------------------------------------------------------------- 1 | \ mini-oof-demo.4th 2 | \ 3 | \ Bernd Paysan's example code, with extra annotations, 4 | \ to illustrate use of the mini-oof.4th object-oriented 5 | \ extensions for standard Forth. 6 | \ 7 | \ See: 8 | \ 1. Gforth package and docs; https://github.com/forthy42/gforth 9 | \ 2. https://bernd-paysan.de/mini-oof.html 10 | \ 11 | \ This example shows how to define a class, create objects, 12 | \ create a derived class, override inherited class methods, 13 | \ and use objects. 14 | \ 15 | \ Revisions: 16 | \ 17 | \ 1998-10-24 original code by B. Paysan 18 | \ 2003-02-15 adapted for kForth by K. Myneni 19 | \ 2003-02-27 km use of new changed in mini-oof.4th 20 | \ 2011-03-03 km removed include of ans-words.4th, not needed 21 | \ for kforth 1.5.x. 22 | \ 2021-08-27 km revised for full compatibility with B.P.'s 23 | \ moof-exm.fs (see Ref. 1). 24 | 25 | include ans-words 26 | include mini-oof 27 | include strings 28 | include ansi 29 | 30 | [undefined] cell [IF] 1 cells constant cell [THEN] 31 | 32 | \ Define a button class 33 | 34 | object class 35 | cell var text 36 | cell var len 37 | cell var x 38 | cell var y 39 | method init 40 | method draw 41 | end-class button 42 | 43 | \ Define the methods of the button class 44 | 45 | :noname ( o -- ) >r 46 | r@ x @ r@ y @ at-xy r@ text a@ r> len @ type ; 47 | button defines draw 48 | 49 | :noname ( addr u o -- ) >r 50 | 0 r@ x ! 0 r@ y ! r@ len ! r> text ! ; 51 | button defines init 52 | 53 | \ Now that we have defined the class and the methods, we may 54 | \ create an object of the button class and perform some 55 | \ initialization. 56 | 57 | button new constant foo \ create object 'foo' of class 'button' 58 | s" thin foo" foo init \ call method 'init' for foo 59 | 25 foo x ! 6 foo y ! \ set the x and y coordinates of foo 60 | 61 | 62 | \ Next, we define a new class called 'bold-button' which is 63 | \ derived from the class 'button'. Therefore, it inherits 64 | \ all of the variables and methods from the button class. 65 | \ We will override the method 'draw' in the derived class. 66 | 67 | button class 68 | end-class bold-button \ No new variables or methods in derived class 69 | 70 | : bold text_bold ; 71 | : normal text_normal ; 72 | 73 | :noname bold [ button :: draw ] normal ; 74 | bold-button defines draw \ override method 'draw' 75 | 76 | bold-button new constant bar \ create object 'bar' of class 'bold-button' 77 | s" fat bar" bar init 78 | 28 bar x ! 7 bar y ! 79 | 80 | \ Now we put our objects into action! 81 | 82 | page 83 | foo draw 84 | bar draw 85 | 86 | -------------------------------------------------------------------------------- /forth-src/fsl/demo/2D_integral_01.4th: -------------------------------------------------------------------------------- 1 | \ 2D_integral_01.4th 2 | \ 3 | \ Demonstrate use of re-entrant version of Gauss-Legendre 4 | \ integration to compute a two-dimensional integral. 5 | \ 6 | \ Compute the integral of f(x, y) = x^2 + y^2, over 7 | \ a rectangle: x: 0 -> 2, y: 0 -> 1 8 | \ 9 | \ K. Myneni, 2022-03-25 10 | \ 11 | 12 | include ans-words 13 | include modules 14 | include fsl/fsl-util 15 | include fsl/gauleg 16 | 17 | [undefined] fsquare [IF] : fsquare fdup f* ; [THEN] 18 | 19 | 0e fconstant xmin 20 | 2e fconstant xmax 21 | 0e fconstant ymin 22 | 1e fconstant ymax 23 | 24 | 0.1e fconstant delx 25 | 0.1e fconstant dely 26 | 27 | xmax xmin f- delx f/ ftrunc>s constant nxIntervals 28 | ymax ymin f- dely f/ ftrunc>s constant nyIntervals 29 | 30 | 3 constant nxWeights 31 | 3 constant nyWeights 32 | 33 | nxWeights float array x{ 34 | nxWeights float array wx{ 35 | nyWeights float array y{ 36 | nyWeights float array wy{ 37 | 38 | nxIntervals nxWeights * constant nxTot 39 | nyIntervals nyWeights * constant nyTot 40 | nxTot float array xx{ 41 | nxTot float array wwx{ 42 | nyTot float array yy{ 43 | nyTot float array wwy{ 44 | 45 | : xIntervalLims ( idx -- x1 x2 ) s>f delx f* fdup delx f+ ; 46 | : yIntervalLims ( idx -- y1 y2 ) s>f dely f* fdup dely f+ ; 47 | 48 | : all-weights ( -- ) 49 | nxIntervals 0 DO 50 | x{ wx{ nxWeights I xIntervalLims gauleg 51 | x{ xx{ I nxWeights * } nxWeights floats move 52 | wx{ wwx{ I nxWeights * } nxWeights floats move 53 | LOOP 54 | nyIntervals 0 DO 55 | y{ wy{ nyWeights I yIntervalLims gauleg 56 | y{ yy{ I nyWeights * } nyWeights floats move 57 | wy{ wwy{ I nyWeights * } nyWeights floats move 58 | LOOP ; 59 | 60 | \ Compute all abscissas and weights over all intervals 61 | all-weights 62 | 63 | fvariable xx 64 | : dy_Integrand ( F: y -- x^2+y^2 ) fsquare xx f@ fsquare f+ ; 65 | 66 | : integral_y ( -- r ) 67 | 0.0e0 68 | nyIntervals 0 DO 69 | yy{ I nyWeights * } y{ nyWeights floats move 70 | wwy{ I nyWeights * } wy{ nyWeights floats move 71 | use( dy_Integrand y{ wy{ nyWeights )gl-integrate 72 | f+ 73 | LOOP ; 74 | 75 | : dx_Integrand ( F: x -- r ) 76 | xx f! integral_y ; 77 | 78 | : integral_xy ( -- r ) 79 | 0.0e0 80 | nxIntervals 0 DO 81 | xx{ I nxWeights * } x{ nxWeights floats move 82 | wwx{ I nxWeights * } wx{ nxWeights floats move 83 | use( dx_Integrand x{ wx{ nxWeights )gl-integrate 84 | f+ 85 | LOOP ; 86 | 87 | 88 | cr cr 89 | .( Type 'integral_xy fs.' to compute the 2D integral of )cr 90 | .( the function, f[x, y] = x^2 + y^2, over the rectangular ) cr 91 | .( region: x: 0 -> 2, y: 0 -> 1 ) cr cr 92 | 93 | 94 | -------------------------------------------------------------------------------- /forth-src/games/hanoi.4th: -------------------------------------------------------------------------------- 1 | \ hanoi.4th 2 | \ 3 | \ Towers of Hanoi puzzle 4 | \ 5 | \ From a posting to comp.lang.forth, 30 May 2002, by Marcel 6 | \ Hendrix and Brad Eckert. According to Marcel Hendrix, the 7 | \ code for the HANOI algorithm was originally posted to clf 8 | \ by Raul Deluth Miller in 1994. 9 | \ --------------------------------------------------------------------------- 10 | \ kForth includes and defs (2002-05-30 K. Myneni) 11 | \ 12 | include strings 13 | include ansi 14 | : chars ; 15 | \ --------------------------------------------------------------------------- 16 | \ To run under other ANS Forths, uncomment the defs below: 17 | \ : a@ @ ; 18 | \ : ?allot here swap allot ; 19 | \ : nondeferred ; 20 | 21 | variable slowness 1000 slowness ! \ ms delay between screen updates 22 | create PegSPS 3 cells allot \ pointers for three disk stacks 23 | 24 | : PegSP ( peg -- addr ) cells PegSPS + ; 25 | : PUSH ( c peg -- ) PegSP tuck a@ c! 1 chars swap +! ; 26 | : POP ( peg -- c ) PegSP -1 chars over +! a@ c@ ; 27 | 28 | create PegStacks 30 chars allot \ stack area for up to 10 disks 29 | 30 | : PegStack ( peg -- addr ) 10 * PegStacks + ; 31 | : PegClr ( peg -- ) dup PegStack swap PegSP ! ; 32 | : PegDepth ( peg -- depth) dup PegSP @ swap PegStack - ; \ not needed 33 | 34 | : ShowDisk ( level diameter peg ) 35 | 22 * 10 + over - rot 10 swap - at-xy \ position cursor 36 | 1+ 2* 0 ?do [char] * emit loop ; \ display the disk 37 | 38 | : ShowPeg ( peg -- ) dup >r PegStack 39 | BEGIN r@ PegSP @ over <> 40 | WHILE dup r@ PegStack - over c@ ( addr level diameter ) 41 | r@ ShowDisk char+ 42 | REPEAT drop r> drop ; 43 | 44 | : MAKETAB CREATE dup ?allot over 1- + swap 0 ?do dup >r c! r> 1- loop drop 45 | DOES> + c@ ; 46 | 47 | : base3 [ decimal ] 3 base ! ; nondeferred 48 | base3 00 02 01 12 00 10 21 20 decimal 8 maketab TO! 49 | base3 00 21 12 20 00 02 10 01 decimal 8 maketab FRO! 50 | 51 | 52 | : ShowPegs ( -- ) page 3 0 do i showpeg loop slowness @ ms 53 | key? if key drop 0 11 at-xy ." Stopped" cr abort then ; 54 | 55 | : MoveRing ( ring -- ring ) dup to! 3 / pop over fro! 3 mod push 56 | ShowPegs ; 57 | 58 | : HANOI ( depth direction -- depth direction ) swap 1- swap 59 | over IF to! recurse to! MoveRing fro! recurse fro! 60 | ELSE MoveRing 61 | THEN swap 1+ swap ; 62 | 63 | : PLAY ( depth -- ) 64 | 3 0 DO i PegClr LOOP \ clear the pegs 65 | dup BEGIN ?dup WHILE 1- dup 0 push REPEAT \ stack up some disks 66 | showpegs 1 HANOI 2drop \ move them 67 | 0 11 at-xy ; 68 | 69 | 4 play -------------------------------------------------------------------------------- /forth-src/fsl/prng.4th: -------------------------------------------------------------------------------- 1 | \ Pseudo random number generator in ANS Forth 2 | \ 3 | \ Forth Scientific Library Algorithm #57 4 | \ 5 | \ Leaves a pseudo random number in the range (0,1) 6 | \ on fp stack. 7 | 8 | \ Based on GGUBS algorithm: s' = 16807*s mod (2^32-1) 9 | \ P. Bratley, B.L. Fox and L.E. Schrage, A guide to simulation 10 | \ (Springer, Berlin, 1983). 11 | \ 12 | \ To simplify transport to 16-bit machines the 32-bit 13 | \ modular division is performed by synthetic division: 14 | \ note that 15 | \ 16 | \ bigdiv = divis * m1 + m2 17 | \ 18 | \ so that ( [n] means "largest integer <= n" ) 19 | \ 20 | \ s' = s*m1 - [s*m1/b]*b = m1 * (s - [s/d]*d) - m2 * [s/d] 21 | \ 22 | \ Environmental dependences: 23 | \ 24 | \ 1. assumes at least 32-bit DOUBLEs 25 | \ 2. needs FLOATING and DOUBLE wordsets 26 | \ 27 | \ 28 | \ 29 | \ --------------------------------------------------- 30 | \ (c) Copyright 1998 Julian V. Noble. \ 31 | \ Permission is granted by the author to \ 32 | \ use this software for any application pro- \ 33 | \ vided this copyright notice is preserved. \ 34 | \ --------------------------------------------------- 35 | \ 36 | \ Revisions: 37 | \ 2007-11-28 km; ported to integrated stack systems (kForth); 38 | \ added automated test and base handling. 39 | 40 | CR .( PRNG V1 28 November 2007 JVN ) 41 | BASE @ DECIMAL 42 | 43 | \ MARKER -rand 44 | 45 | 2VARIABLE seed 46 | 47 | 48 | 2147483647e FCONSTANT bigdiv \ 2^31-1 49 | 127773e FCONSTANT divis 50 | 16807e FCONSTANT m1 51 | 2836e FCONSTANT m2 52 | 53 | 54 | : (rand) ( adr -- fseed') 55 | dup >R 2@ D>F ( fseed) 56 | divis FOVER FOVER ( s d s d) 57 | F/ F>D 2>R ( s d [s/d]) 58 | 2R@ D>F ( s d [s/d]) 59 | F* F- ( s-d*[s/d] = s mod d) 60 | m1 F* ( m1*[s mod d]) 61 | 2R> D>F m2 F* F- ( fseed') 62 | FDUP F>D ( fseed' seed') 63 | R> 2! ; \ save seed' 64 | 65 | : prng ( -- frandom#) 66 | seed (rand) bigdiv ( -- fseed 2**31-1) 67 | FSWAP FDUP F0< ( -- 2**31-1 fseed flag) 68 | IF FOVER F+ THEN FSWAP F/ ; 69 | 70 | BASE ! 71 | 72 | TEST-CODE? [IF] \ test code ============================================== 73 | [undefined] T{ [IF] include ttester.4th [THEN] 74 | BASE @ DECIMAL 75 | 76 | : test 1 s>d seed 2! 1000 0 DO prng FDROP LOOP seed 2@ ; 77 | 78 | CR 79 | TESTING PRNG 80 | t{ test -> 522329230 s>d }t 81 | 82 | BASE ! 83 | 84 | [THEN] 85 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/four1.4th: -------------------------------------------------------------------------------- 1 | \ four1.4th 2 | \ 3 | \ Compute Fourier transform of array of complex values 4 | \ 5 | \ This implementation is based on the routine four1() from Numerical Recipes 6 | \ in C, 2nd ed., by W.H. Press, S. A. Teukolsky, W. T. Vetterling, and 7 | \ B. P. Flannery, Cambridge University Press, 1992. 8 | \ 9 | \ Copyright (c) 2001,2006, 2009 Krishna Myneni 10 | \ Original code Copyright (c) Numerical Recipes Software 11 | \ 12 | \ Notes: 13 | \ 14 | \ (0) The input array is an array of type FLOAT; thus, this routine will 15 | \ perform a double precision FFT on most Forth systems. 16 | \ 17 | \ (1) The number of values in the input array must be a power of 2. 18 | \ 19 | \ (2) The transformed data is ordered in the manner described in Press, et. 20 | \ al. 21 | \ 22 | \ Requires: 23 | \ 24 | \ ans-words.4th (for kforth only) 25 | \ fsl-util.4th 26 | \ complex.4th 27 | \ 28 | \ Revisions: 29 | \ 2000-08-16 km; added inverse FFT routine 30 | \ 2006-04-29 km; revised the Copyright statement and Notes. 31 | \ 2007-10-23 km; revised to use FSL arrays; renamed to }four1 32 | \ 2007-10-31 km; revised to use complex library (calculations simplify 33 | \ greatly); re-ordered arguments for consistency with fft 34 | \ word from fft-x86 35 | \ 2009-10-30 km; defined complex constant z=1, which is no longer 36 | \ provided by complex.4th 37 | \ 2023-12-05 km; replaced FDUP F* with FSQUARE 38 | zvariable w 39 | zvariable wp 40 | 1e 0e zconstant z=1 41 | 42 | 0 ptr data{ 43 | 0 value isign 44 | 0 value Nvals 45 | 0 value N 46 | 0 value jj 47 | 0 value mm 48 | 0 value mmax 49 | variable istep 50 | 51 | : }four1 ( nn isign 'a -- | replace 'a with its FFT or inverse FFT ) 52 | TO data{ TO isign 2* TO Nvals 53 | 0 TO jj 54 | 55 | Nvals 0 DO 56 | jj I > IF \ exchange two complex numbers 57 | data{ I } z@ data{ JJ } z@ data{ I } z! data{ JJ } z! 58 | THEN 59 | 60 | Nvals 2/ TO mm 61 | 62 | BEGIN 63 | mm 2 >= jj mm >= and 64 | WHILE 65 | jj mm - TO jj 66 | mm 2/ TO mm 67 | REPEAT 68 | 69 | mm jj + TO jj 70 | 2 +LOOP 71 | 72 | 2 TO mmax 73 | 74 | BEGIN 75 | Nvals mmax > 76 | WHILE 77 | mmax 2* istep ! 78 | 6.28318530717959e0 mmax s>f F/ 79 | isign 0< IF fnegate THEN fdup 80 | 0.5e F* fsin fsquare -2e F* 81 | fswap fsin wp z! 82 | 83 | z=1 w z! 84 | 85 | mmax 0 DO 86 | Nvals I DO 87 | I mmax + TO jj 88 | data{ jj } z@ w z@ z* 89 | zdup data{ I } z@ zswap z- data{ jj } z! 90 | data{ I } z@ z+ data{ I } z! 91 | istep @ +LOOP 92 | 93 | w z@ zdup wp z@ z* z+ w z! 94 | 2 +LOOP 95 | 96 | istep @ TO mmax 97 | REPEAT 98 | ; 99 | -------------------------------------------------------------------------------- /forth-src/fsl/demo/sigfig-example.4th: -------------------------------------------------------------------------------- 1 | \ sigfig-example.fs 2 | \ 3 | \ Illustrate use of SET-PRECISION and FS. to display only 4 | \ the meaningful digits in a calculation of the error 5 | \ function, erf(x). 6 | \ 7 | \ Requires: 8 | \ fsl-util.fs 9 | \ erf.fs 10 | \ 11 | \ K. Myneni, 2011-02-09 12 | \ 13 | \ Revisions: 14 | \ 2011-02-10 km revised the words SIG-FIG and ERF1; SIG-FIG 15 | \ should now be generally applicable. 16 | \ 17 | \ ERF1 has the following maximum relative error in each of the 18 | \ following ranges. We will use this information to output 19 | \ the function with a proper number of significant digits. 20 | \ 21 | \ Max Rel. Error 22 | \ ---------------------------------- 23 | \ x < -6.0 1.0e-16 24 | \ -6.0 <= x < -5.5 3.3e-16 25 | \ -5.5 <= x < -4.0 3.9e-10 26 | \ -4.0 <= x < -2.5 2.8e-6 27 | \ -2.5 <= x < -0.5 2.4e-5 28 | \ -0.5 <= x < 0.1 5.9e-4 29 | \ 0.1 <= x < 2.0 1.8e-4 30 | \ 2.0 <= x < 2.5 1.4e-5 31 | \ 2.5 <= x < 3.1 2.8e-6 32 | \ 3.1 <= x < 3.8 1.5e-7 33 | \ 3.8 <= x < 4.0 1.7e-9 34 | \ 4.0 <= x < 4.4 3.9e-10 35 | \ 4.4 <= x < 5.0 1.5e-11 36 | \ 5.0 <= x < 5.5 6.4e-12 37 | \ 5.5 <= x < 6.0 6.2e-14 38 | \ 6.0 <= x 1.0e-16 39 | 40 | [undefined] f>s [IF] : f>s f>d d>s ; [THEN] 41 | 42 | 15 constant Nintervals 43 | Nintervals FLOAT ARRAY x{ 44 | Nintervals 1+ FLOAT ARRAY err{ 45 | 46 | -6.0e -5.5e -4.0e 47 | -2.5e -0.5e 0.1e 48 | 2.0e 2.5e 3.1e 49 | 3.8e 4.0e 4.4e 50 | 5.0e 5.5e 6.0e 51 | 52 | Nintervals x{ }fput 53 | 54 | 1.0e-16 3.3e-16 3.9e-10 55 | 2.8e-6 2.4e-5 5.9e-4 56 | 1.8e-4 1.4e-5 2.8e-6 57 | 1.5e-7 1.7e-9 3.9e-10 58 | 1.5e-11 6.4e-12 6.2e-14 59 | 1.0e-16 60 | 61 | Nintervals 1+ err{ }fput 62 | 63 | \ Return the maximum relative error in ERF1 for a given argument 64 | : lookup-err ( F: x -- relerr ) 65 | Nintervals 0 DO 66 | fdup x{ I } f@ f< IF 67 | fdrop err{ I } f@ unloop EXIT 68 | THEN 69 | LOOP 70 | fdrop err{ Nintervals } f@ 71 | ; 72 | 73 | \ Return the number of significant figures for the specified 74 | \ result and absolute error; we need a ceiling function! 75 | : sig-fig ( F: result abserr -- ) ( -- u ) 76 | flog fnegate fswap fabs flog f+ 77 | 1e f+ \ really should use FCEIL 78 | f>s ; 79 | 80 | \ Compute Erf(x) using the word ERF1 and output the result 81 | \ to the proper number of significant figures 82 | : erf1. ( F: r -- ) 83 | fdup erf1 84 | fswap lookup-err \ F: erf(x) relerr 85 | fover f* fabs \ F: erf(x) abserr 86 | f2dup sig-fig set-precision 87 | fdrop fs. ; 88 | 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /forth-src/fsl/permcomb.4th: -------------------------------------------------------------------------------- 1 | 2 | \ Forth Scientific Library Algorithm #59 3 | 4 | \ ANS Forth Program. 5 | \ Requiring the Double-Number word set (namely M*/). 6 | \ Requiring .( ?DO \ from the Core Extensions word set. 7 | 8 | \ (c) Copyright 1994 Gordon R Charlton. Permission is granted by 9 | \ the author to use this software for any application provided this 10 | \ copyright notice is preserved. 11 | 12 | \ Revisions: 13 | \ 2007-10-23 km; replaced test code with automated tests 14 | \ 2007-10-27 km; save base, switch to decimal, and restore base 15 | 16 | cr 17 | .( Permutations & Combinations. Version FSL1.0 27th October 1994) cr 18 | .( Gordon Charlton - gordon@charlton.demon.co.uk) cr 19 | cr 20 | 21 | BASE @ DECIMAL 22 | 23 | : mu* ( ud1 u--ud2) TUCK * >R UM* R> + ; 24 | \ 25 | \ multiply unsigned double d1 by unsigned single u giving unsigned double ud2. 26 | 27 | 28 | : perms ( u1 u2--ud) 1 S>D 2SWAP 29 | SWAP 1+ DUP ROT - 30 | ?DO I mu* LOOP ; 31 | \ 32 | \ return nPr, where u1=n u2=r. All arguments are unsigned, result is double. 33 | \ 34 | \ This is an iterative version of the recurrence; 35 | \ r=0 --> nPr = 1 36 | \ r>0 --> nPr = nP(r-1)(n-r+1) 37 | 38 | 39 | VARIABLE temp \ private to combs 40 | 41 | : combs ( u1 u2--ud) 1 S>D 2SWAP 42 | 2DUP - MIN 43 | SWAP temp ! 44 | 1+ 1 ?DO temp @ I M*/ 45 | -1 temp +! 46 | LOOP ; 47 | \ 48 | \ return nCr, where u1=n u2=r. All arguments are unsigned, result is double. 49 | \ 50 | \ This is an iterative version of the recurrence; 51 | \ r=0 --> nCr = 1 52 | \ r>0 --> nCr = nC(r-1)(n-r+1)/r 53 | \ 54 | \ This recurrance was chosen in favour of the more common 55 | \ nCr = n!/(n-r)! r! 56 | \ to avoid excessively large intermediate results. Use of integer maths 57 | \ necessitates that the multiplication be done before the division, to avoid 58 | \ truncation errors, hence the use of M*/, which has a triple length 59 | \ intermediate result. Advantage is taken of the symmetry of the function 60 | \ to minimise the number of iterations. 61 | 62 | BASE ! 63 | \ end of Permutations & Combinations. 64 | 65 | TEST-CODE? [IF] \ test code ============================================== 66 | [undefined] T{ [IF] include ttester.4th [THEN] 67 | BASE @ DECIMAL 68 | 69 | CR 70 | TESTING PERMS COMBS 71 | t{ 7 0 perms -> 1 s>d }t 72 | t{ 7 3 perms -> 210 s>d }t 73 | t{ 7 5 perms -> 2520 s>d }t 74 | t{ 7 7 perms -> 5040 s>d }t 75 | 76 | t{ 7 0 combs -> 1 s>d }t 77 | t{ 7 3 combs -> 35 s>d }t 78 | t{ 7 5 combs -> 21 s>d }t 79 | t{ 7 7 combs -> 1 s>d }t 80 | 81 | BASE ! 82 | [THEN] 83 | 84 | 85 | -------------------------------------------------------------------------------- /forth-src/rs232-switch.4th: -------------------------------------------------------------------------------- 1 | \ rs232-switch.4th 2 | \ 3 | \ External push button switch(es) connected to serial port 4 | \ via RTS/CTS/DSR lines may be queried with this code to 5 | \ find out button status (pushed in/closed or open) of two 6 | \ switches. This is useful in applications when you can't access 7 | \ the keyboard easily. 8 | \ 9 | \ Krishna Myneni, 15 Novermber 2024, krishna.myneni@ccreweb.org 10 | \ 11 | \ PC Serial Port (DB9 connector) Example with 1 switch connected 12 | \ to RTS/CTS lines. 13 | \ 14 | \ 1 DCD <-- ============== 15 | \ 2 RXD <-- \ 1 2 3 4 5 / ( male connector ) 16 | \ 3 TXD --> \ 6 7 8 9 / 17 | \ 4 DTR --> ========= 18 | \ 5 GND 19 | \ 6 DSR <-- SW1 /==== SW3 ==== SW3 20 | \ 7 RTS --> -->===/ -->\ 21 | \ 8 CTS <-- <--1K---==== SW2 <--1K--\==== SW2 22 | \ 9 RI <-- (open/OFF) (closed/ON) 23 | \ 24 | \ There is a 1K resistor in series with pin SW2 on the switch. 25 | \ 26 | \ To use: 27 | \ 1. Open the serial port (COM1 is shown in this example) 28 | \ 2. Enable the switch(es) using RAISE-RTS 29 | \ 3. Wait for short delay (1 millisecond is more than enough) 30 | \ 4. Query the switch(es) using READ-SWITCH 31 | \ 5. Disable the switch(es) using LOWER-RTS 32 | \ 6. Repeat from step 2 as needed 33 | \ 7. Close the serial port 34 | \ 35 | \ Notes: 36 | \ 0. Valid port values are COM1--COM4, USBCOM1--USBCOM2 (see serial.4th). 37 | \ 38 | \ 1. Users on Linux must be members of the dialout group to perform 39 | \ i/o on serial ports. 40 | \ 41 | \ 2. At present there is no way to query the existence of an external 42 | \ switch attached to the serial port. This can be done if we use 43 | \ an additional modem input line e.g. DCD, to read both output 44 | \ terminals of the first three terminal switch. 45 | \ 46 | \ Requires: 47 | \ ans-words 48 | \ modules 49 | \ struct-200x 50 | \ struct-200x-ext 51 | \ strings 52 | \ serial 53 | 54 | Also serial 55 | 56 | base @ 57 | decimal 58 | 59 | hex 60 | 20 constant CTS_LINE 61 | 100 constant DSR_LINE 62 | decimal 63 | 64 | \ SW_PORT can take the values COM1 -- COM4, USBCOM1 -- USBCOM2 65 | COM1 value SW_PORT 66 | 67 | variable com 68 | 69 | : open-sw ( -- ior ) 70 | SW_PORT ∋ serial open com ! 71 | com @ 1 < ; 72 | 73 | : close-sw ( -- ior ) com @ ∋ serial close ; 74 | 75 | \ Return non-zero if switch/switches are closed (ON), 0 otherwise 76 | \ u = hex 20 for CTS 77 | \ u = hex 100 for DSR 78 | \ u = hex 120 for both 79 | : read-switch ( -- u ) 80 | com @ get-modem-bits 81 | dup CTS_LINE and 82 | swap DSR_LINE and or ; 83 | 84 | : enable-switch ( -- ) com @ raise-rts ; 85 | : disable-switch ( -- ) com @ lower-rts ; 86 | 87 | base ! 88 | 89 | -------------------------------------------------------------------------------- /forth-src/fsl/extras/numerov.4th: -------------------------------------------------------------------------------- 1 | \ numerov.4th 2 | \ 3 | \ Integrate the 2nd order differential equation, 4 | \ 5 | \ P''(r) = Q(r)P(r) 6 | \ 7 | \ using the Numerov algorithm. 8 | \ 9 | \ The Numerov algorithm may be expressed by the recurrence 10 | \ relation, 11 | \ 12 | \ F_n+1 = [(2 + 10*T_n)/(1 - T_n)]*F_n - F_n-1 13 | \ 14 | \ where, 15 | \ 16 | \ T_n = (h^2/12)*Q_n 17 | \ 18 | \ F_n = (1 - T_n)*P_n 19 | \ 20 | \ Given the input array, Q_n, and the first two values of the 21 | \ array P, P_0 and P_1, initialized, the recurrence relation 22 | \ is applied to compute the successive values of P_n. 23 | \ 24 | \ 25 | \ References: 26 | \ 27 | \ 1. B. Numerov, Publs. observatoire central astrophys. Russ., 28 | \ v. 2, p. 188 (1933). 29 | \ 30 | \ 2. http://en.wikipedia.org/wiki/Numerov%27s_method 31 | \ 32 | \ 3. Anders Blom, 2002, "Computing algorithms for solving the 33 | \ Schroedinger and Poisson equations", available on the web at 34 | \ http://www.teorfys.lu.se/personal/Anders.Blom/useful/scr.pdf 35 | \ 36 | \ Copyright (c) 2010 Krishna Myneni 37 | \ 38 | \ This code may be used for any purpose, as long as the 39 | \ copyright notice above is preserved. 40 | \ 41 | \ Revisions: 42 | \ 2011-09-16 km; use Neal Bridges' anonymous modules. 43 | \ 2012-02-19 km; use KM/DNW's modules library. 44 | \ 2024-01-11 km; Backwards compatible update to allow passing 45 | \ of arbitrary element addresses of input FSL 46 | \ float arrays. 'P and 'Q, for higher efficiency, 47 | \ and consistency with assembly language version. 48 | BEGIN-MODULE 49 | 50 | BASE @ 51 | DECIMAL 52 | 53 | Private: 54 | 55 | 0 ptr num_Q[ 56 | 0 ptr num_P[ 57 | 58 | 0 ptr num_F[ 59 | 60 | fvariable h^2/12 61 | fvariable T_n-1 62 | fvariable T_n 63 | fvariable T_n+1 64 | 65 | : ]F@ ( a idx -- ) ( F: -- r ) 66 | postpone floats postpone + postpone f@ ; immediate 67 | : ]F! ( a idx -- ) ( F: r -- ) 68 | postpone floats postpone + postpone f! ; immediate 69 | 70 | Public: 71 | 72 | : numerov_integrate ( 'P 'Q n h -- ) 73 | FSQUARE 12e F/ h^2/12 F! 74 | >r to num_Q[ to num_P[ 75 | r@ floats allocate ABORT" numerov_integrate: Unable to allocate mem!" 76 | to num_F[ 77 | \ compute F_0 and F_1 78 | 1e num_Q[ 0 ]F@ h^2/12 F@ F* fdup T_n-1 F! F- num_P[ 0 ]F@ F* num_F[ 0 ]F! 79 | 1e num_Q[ 1 ]F@ h^2/12 F@ F* fdup T_n F! F- num_P[ 1 ]F@ F* num_F[ 1 ]F! 80 | r> 2 DO 81 | num_Q[ I ]F@ h^2/12 F@ F* T_n+1 F! 82 | T_n F@ 10e F* 2e F+ num_F[ I 1- ]F@ F* 1e T_n F@ F- F/ 83 | num_F[ I 2 - ]F@ F- fdup num_F[ I ]F! 84 | 1e T_n+1 F@ F- F/ num_P[ I ]F! 85 | T_n F@ T_n-1 F! T_n+1 F@ T_n F! 86 | LOOP 87 | num_F[ free ABORT" numerov_integrate: Unable to free mem!" 88 | ; 89 | 90 | 91 | BASE ! 92 | END-MODULE 93 | 94 | 95 | 96 | -------------------------------------------------------------------------------- /forth-src/games/magic.4th: -------------------------------------------------------------------------------- 1 | ( * 2 | * LANGUAGE : ANS Forth 3 | * PROJECT : Forth Environments 4 | * DESCRIPTION : Magic squares demo 5 | * CATEGORY : Example 6 | * AUTHOR : Erwin Dondorp, August 19, 1991 7 | * LAST CHANGE : March 6, 1993, Marcel Hendrix, Ansification 8 | * LAST CHANGE : October 10, 1991, Marcel Hendrix 9 | * LAST CHANGE : August 24, 2001, Krishna Myneni, core Ansification 10 | * ) 11 | 12 | \ ----------------------------------------------------------- 13 | : SPACE bl emit ; ( needed for kForth only) 14 | \ ----------------------------------------------------------- 15 | \ MARKER -magic 16 | 17 | DECIMAL 18 | 19 | 20 | ( * 21 | Magic squares by Erwin Dondorp 22 | after a widely known algorithm: 23 | - Start with value one in upper middle cell. 24 | - next cell is one up and to the right, use circular wrap when passing edges 25 | - if this cell is occupied, move one cell down 26 | - if this cell is also occupied, stop 27 | * ) 28 | 29 | VARIABLE ORDER 30 | VARIABLE COL 31 | VARIABLE ROW 32 | 33 | create ADDR 99 dup * cells allot \ allocate maximum needed space 34 | 35 | : MAGIC \ --- <> 36 | ORDER ! 37 | 38 | ORDER @ 1 AND 0= ABORT" Value should be odd" 39 | 40 | ORDER @ 99 > ORDER @ 3 < OR ABORT" Value should be between 3 and 99" 41 | 42 | 43 | ADDR ORDER @ DUP * CELLS ERASE 44 | ORDER @ 2/ COL ! 45 | 0 ROW ! 46 | 47 | ORDER @ DUP * 1+ 1 48 | DO 49 | I ROW @ ORDER @ * COL @ + CELLS ADDR + ! 50 | -1 ROW +! 51 | 1 COL +! 52 | COL @ ORDER @ < INVERT ( >= ) 53 | IF 54 | ORDER @ NEGATE COL @ + COL ! 55 | THEN 56 | ROW @ 0< 57 | IF 58 | ORDER @ ROW @ + ROW ! 59 | THEN 60 | ROW @ ORDER @ * COL @ + CELLS ADDR + @ 61 | IF 62 | 2 ROW +! 63 | -1 COL +! 64 | ROW @ ORDER @ MOD ROW ! 65 | COL @ ORDER @ + ORDER @ MOD COL ! 66 | THEN 67 | LOOP 68 | CR ." Magic square " ORDER @ DUP 1 .R [CHAR] x EMIT . CR 69 | ORDER @ 0 70 | DO 71 | ORDER @ 0 CR 72 | DO 73 | ADDR J CELLS ORDER @ * + I CELLS + @ 74 | ORDER @ DUP * S>D <# #S #> NIP .R SPACE 75 | LOOP 76 | LOOP 77 | CR CR ." Sum = " 78 | ORDER @ DUP DUP * * ORDER @ + 2/ . 79 | ; 80 | 81 | 82 | : HELP CR 83 | ." MAGIC for a magic square n*n" CR 84 | ." must be odd, >= 3, <= 99" CR 85 | ." > 19 will be too wide for the screen" ; 86 | 87 | 88 | HELP CR 89 | 90 | -------------------------------------------------------------------------------- /forth-src/phyconsts.4th: -------------------------------------------------------------------------------- 1 | \ phyconsts.4th 2 | \ 3 | \ Handy definitions for Forth desktop environment 4 | \ 5 | \ References: 6 | \ 1. https://physics.nist.gov/cuu/Constants/index.html 7 | \ 8 | \ Requires: 9 | \ ans-words.4th 10 | \ 11 | \ Revisions: 12 | \ 2020-10-06 km updated for 2019 redefinition of S.I. base units 13 | \ 2023-12-04 km further updates for m_e, m_p, eps0, alpha^-1, 14 | \ J/ev, kg/amu; added mu0; correct units for dnu_Cs. 15 | 16 | BASE @ 17 | DECIMAL 18 | 19 | [undefined] PI [IF] -1e facos fconstant pi [THEN] 20 | [undefined] 2PI [IF] pi 2e f* fconstant 2pi [THEN] 21 | 22 | \ Physical Constants 23 | 24 | 9192631770e fconstant dnu_Cs \ hyperfine interval in Cs133 in Hz (exact) 25 | 299792458e fconstant c \ speed of light in m/s (exact) 26 | 6.62607015e-34 fconstant h \ Planck's constant in J*s (exact) 27 | h 2pi f/ fconstant hbar \ 28 | 1.602176634e-19 fconstant e \ elementary charge in C (exact) 29 | 1.380649e-23 fconstant kB \ Boltzmann's constant in J/K (exact) 30 | 6.02214076e23 fconstant N_A \ Avogadro constant mol^-1 (exact) 31 | 32 | \ Measured Constants 33 | 9.1093837015e-31 fconstant m_e \ electron mass in kg 34 | 1.67262192369e-27 fconstant m_p \ proton mass in kg 35 | 8.8541878128e-12 fconstant eps0 \ vacuum electric permittivity in F/m 36 | 1.25663706212e-6 fconstant mu0 \ vacuum magnetic permeability in N/A^2 37 | 38 | \ Derived Constants 39 | 137.035999084e fconstant alpha^-1 \ inverse fine structure constant 40 | 41 | \ Unit Conversions 42 | 1.602176634e-19 fconstant J/eV \ electron volts -> Joules (exact) 43 | 4.3597447222060e-18 fconstant J/Eh \ Hartree -> Joules 44 | 1.66053906660e-27 fconstant kg/amu \ atomic mass unit -> kilograms 45 | 219474.6314e fconstant cm^-1/Eh \ Hartree to wavenumber conversion 46 | 0.5291772083e fconstant A/a0 \ Bohr radii to Angstroms conversion 47 | 48 | 0 [IF] 49 | .( Defined FCONSTANTs [physical constants in MKS units]: ) CR CR 50 | .( pi ) CR 51 | .( 2pi ) CR 52 | .( dnu_Cs hyperfine transition frequency of Cs-133 [exact]) CR 53 | .( c speed of light [exact]) CR 54 | .( h Planck's constant [exact]) CR 55 | .( hbar ) CR 56 | .( e elementary charge [exact]) CR 57 | .( kB Boltzmann's constant [exact]) CR 58 | .( N_A Avogadro constant [exact]) CR 59 | .( m_e electron mass ) CR 60 | .( m_p proton mass ) CR 61 | .( eps0 permitivitty of free space ) CR 62 | .( alpha^-1 inverse fine structure constant ) CR 63 | CR 64 | .( Conversions between units: ) CR CR 65 | .( J/eV eV -> J ) CR 66 | .( J/Eh Hartree -> J ) CR 67 | .( kg/amu amu -> kg ) CR 68 | .( cm^-1/Eh Hartree -> wavenumber ) CR 69 | .( A/a0 Bohr radius -> Angstroms ) CR 70 | CR CR 71 | [THEN] 72 | 73 | BASE ! 74 | 75 | -------------------------------------------------------------------------------- /forth-src/fpu-x86.4th: -------------------------------------------------------------------------------- 1 | \ fpu-x86.4th 2 | \ 3 | \ Precision control of the x86 Floating Point Unit 4 | \ 5 | \ Derived from C code by Kevin Egan, Brown University. 6 | \ This code is published at: 7 | \ 8 | \ http://www.stereopsis.com/FPU.html 9 | \ 10 | \ ---------------------------------------------------- 11 | 12 | \ bits to set the floating point control word register 13 | \ 14 | \ Sections 4.9, 8.1.4, 10.2.2 and 11.5 in 15 | \ IA-32 Intel Architecture Software Developer's Manual 16 | \ Volume 1: Basic Architecture 17 | \ 18 | \ http://www.intel.com/design/pentium4/manuals/245471.htm 19 | \ 20 | \ http://www.geisswerks.com/ryan/FAQS/fpu.html 21 | \ 22 | \ precision control: 23 | \ 00 : single precision 24 | \ 01 : reserved 25 | \ 10 : double precision 26 | \ 11 : extended precision 27 | \ 28 | \ rounding control: 29 | \ 00 = Round to nearest whole number. (default) 30 | \ 01 = Round down, toward -infinity. 31 | \ 10 = Round up, toward +infinity. 32 | \ 11 = Round toward zero (truncate). 33 | 34 | BASE @ 35 | HEX 36 | 003f constant FPU_CW_EXCEPTION_MASK 37 | 0001 constant FPU_CW_INVALID 38 | 0002 constant FPU_CW_DENORMAL 39 | 0004 constant FPU_CW_ZERODIVIDE 40 | 0008 constant FPU_CW_OVERFLOW 41 | 0010 constant FPU_CW_UNDERFLOW 42 | 0020 constant FPU_CW_INEXACT 43 | 44 | 0300 constant FPU_CW_PREC_MASK 45 | 0000 constant FPU_CW_PREC_SINGLE 46 | 0200 constant FPU_CW_PREC_DOUBLE 47 | 0300 constant FPU_CW_PREC_EXTENDED 48 | 49 | 0c00 constant FPU_CW_ROUND_MASK 50 | 0000 constant FPU_CW_ROUND_NEAR 51 | 0400 constant FPU_CW_ROUND_DOWN 52 | 0800 constant FPU_CW_ROUND_UP 53 | 0c00 constant FPU_CW_ROUND_CHOP 54 | 55 | 1f3f constant FPU_CW_MASK_ALL 56 | 57 | \ -------------------------------------------------------- 58 | variable fpu-control 59 | variable fpu-status 60 | 61 | \ The following CODE words are in kForth's asm-x86 style 62 | \ Modify as needed for your Forth system. 63 | 64 | CODE getFPUStateX86 65 | fpu-control #@ fnstcw, 66 | END-CODE 67 | 68 | CODE setFPUStateX86 69 | fpu-control #@ fldcw, 70 | END-CODE 71 | 72 | CODE getFPUstatusX86 73 | fpu-status #@ fnstsw, 74 | END-CODE 75 | 76 | CODE clearFPUexceptionsX86 77 | fnclex, 78 | END-CODE 79 | 80 | CODE enableFPUinterruptsX86 81 | fneni, 82 | END-CODE 83 | 84 | CODE disableFPUinterruptsX86 85 | fndisi, 86 | END-CODE 87 | 88 | \ -------------------------------------------------------- 89 | 90 | \ Modify the control bits of a given setting, e.g. 91 | \ 92 | \ FPU_CW_PREC_DOUBLE FPU_CW_PREC_MASK modifyFPUStateX86 93 | \ 94 | \ sets double precision mode. 95 | 96 | : modifyFPUStateX86 ( control mask -- ) 97 | dup >r and 98 | getFPUStateX86 99 | fpu-control @ r> invert and or fpu-control ! 100 | setFPUStateX86 101 | ; 102 | 103 | BASE ! 104 | 105 | -------------------------------------------------------------------------------- /forth-src/x11/banner-x11.4th: -------------------------------------------------------------------------------- 1 | \ banner-x11.4th 2 | \ 3 | \ Display an animated message in an X11 Window. 4 | \ 5 | \ The default message is "Happy Mother's Day" -- tailor as desired. 6 | \ 7 | \ Copyright (c) 2012--2020 Krishna Myneni 8 | \ 9 | \ 10 | include ans-words 11 | include modules 12 | include syscalls 13 | include mc 14 | include asm 15 | include strings 16 | include utils 17 | include lib-interface 18 | include libs/x11/libX11 19 | include x11/font-strings-x11 20 | include x11/simple-graphics-x11 21 | include x11/simple-fonts-x11 22 | include x11/simple-frames-x11 23 | 24 | Also font-strings-x11 25 | Also simple-graphics-x11 26 | Also simple-fonts-x11 27 | Also simple-frames-x11 28 | 29 | 30 | s" Happy Mother's Day, Rama" $constant $message 31 | 32 | 33 | 8 constant ncolors 34 | -1e facos fconstant pi 35 | pi 3e f* fconstant XMAX 36 | XMAX 2e f/ fconstant XMAX2 37 | 38 | fvariable dx 39 | create ypos[ 2048 cells allot 40 | create colors[ ncolors cells allot 41 | 42 | : ]@ ( a u -- n ) cells + @ ; 43 | : ]! ( n a u -- ) cells + ! ; 44 | 45 | s" pink" $constant $BKG_COLOR 46 | 0 value bkgcolor 47 | 48 | : setup-colors ( -- ) 49 | red colors[ 0 ]! 50 | blue colors[ 1 ]! 51 | green colors[ 2 ]! 52 | magenta colors[ 3 ]! 53 | grey colors[ 4 ]! 54 | yellow colors[ 5 ]! 55 | cyan colors[ 6 ]! 56 | brown colors[ 7 ]! 57 | 58 | $BKG_COLOR get-color to bkgcolor 59 | bkgcolor set-window-background 60 | ; 61 | 62 | \ The curve along which our banner moves is a decaying sine wave. 63 | : calc-motion-curve ( -- ) 64 | 0e -1.1e 10e 1.1e set-window-limits 65 | XMAX get-window-size drop 66 | dup >r s>f f/ dx f! 67 | 0e 68 | r> 0 DO 69 | fdup fdup fsin fover XMAX2 f/ fnegate fexp f* 70 | uc>wc ypos[ I ]! drop 71 | dx f@ f+ 72 | LOOP 73 | fdrop 74 | 75 | setup-colors 76 | extra-graphics-setup 77 | ; 78 | 79 | variable wdx 80 | variable xpos 81 | true value use_colors? 82 | 83 | : .message ( -- ) 84 | $message 85 | 0 DO 86 | use_colors? IF 87 | colors[ I ncolors mod ]@ foreground 88 | THEN 89 | dup >r 90 | xpos @ ypos[ over ]@ r> 1 draw-text 91 | wdx @ xpos +! 92 | 1+ 93 | LOOP 94 | drop ; 95 | 96 | : frame1 ( -- ) 97 | clear-window 98 | bold italic 240 TextFonts1 select-font 99 | 100 | $message 2dup get-string-box drop 101 | swap / 1+ 2* wdx ! drop 102 | 10 103 | BEGIN 104 | dup xpos ! true to use_colors? .message 105 | flush-window 106 | 80000 usleep 107 | dup xpos ! false to use_colors? bkgcolor foreground .message 108 | 10000 usleep 109 | wdx @ 4 / + 110 | dup get-window-size drop > 111 | UNTIL 112 | drop 113 | 1000000 usleep 114 | exit-simple-graphics 115 | ; 116 | 117 | ' frame1 118 | 1 set-frames 119 | ' calc-motion-curve IS user-graphics-init 120 | start-frames 121 | -------------------------------------------------------------------------------- /forth-src/libs/gmp/qmpfr.4th: -------------------------------------------------------------------------------- 1 | \ qmpfr.4th 2 | \ 3 | \ A small interface for MPFR arithmetic 4 | \ 5 | \ Copyright (c) 2015--202 Krishna Myneni 6 | \ 7 | \ Notation: 8 | \ -------- 9 | \ q an mpfr type, which is an address to a 10 | \ structure containing the multiprecision 11 | \ floating point data. A "q" occupies one 12 | \ cell on the data stack. 13 | \ 14 | \ u an unsigned integer 15 | \ 16 | \ r a double precision floating point number 17 | \ 18 | \ 19 | \ Provides the following arithmetic words: 20 | \ 21 | \ quset qdset qset qdget 22 | \ q+ q- q* q/ 23 | \ qu+ qu- qu* qu/ 24 | \ qd+ qd- qd* qd/ 25 | \ qupow qpow 26 | \ qnegate qabs qsqrt qexp qln qlog10 27 | \ qcos qsin qtan qacos qasin qatan 28 | \ qatan2 29 | \ 30 | \ Prior to declaring and initializing q variables, with 31 | \ mpfr_t and mpfr_init, for use with the above words, 32 | \ execute SET-Q-PRECISION with the number of bits to use 33 | \ for representing real numbers. 34 | \ 35 | \ Requires: 36 | \ libmpfr.4th ( kForth interface to libmpfr.so, version >= 3 ) 37 | \ 38 | 39 | Begin-Module 40 | 41 | 42 | Public: 43 | 44 | : set-q-precision ( ubits -- ) 45 | dup 0> invert IF drop 128 THEN 46 | mpfr_set_default_prec 47 | ; 48 | 49 | : qset ( qdst qsrc -- ) GMP_RNDN mpfr_set drop ; 50 | : quset ( q u -- ) GMP_RNDN mpfr_set_ui drop ; 51 | : qdset ( q r -- ) GMP_RNDN mpfr_set_d drop ; 52 | : qdget ( q -- r ) GMP_RNDN mpfr_get_d ; 53 | 54 | : q+ ( qdst q1 q2 -- ) GMP_RNDN mpfr_add drop ; 55 | : q- ( qdst q1 q2 -- ) GMP_RNDN mpfr_sub drop ; 56 | : q* ( qdst q1 q2 -- ) GMP_RNDN mpfr_mul drop ; 57 | : q/ ( qdst q1 q2 -- ) GMP_RNDN mpfr_div drop ; 58 | 59 | : qu+ ( qdst q u -- ) GMP_RNDN mpfr_add_ui drop ; 60 | : qu- ( qdst q u -- ) GMP_RNDN mpfr_sub_ui drop ; 61 | : qu* ( qdst q u -- ) GMP_RNDN mpfr_mul_ui drop ; 62 | : qu/ ( qdst q u -- ) GMP_RNDN mpfr_div_ui drop ; 63 | 64 | : qd+ ( qdst q r -- ) GMP_RNDN mpfr_add_d drop ; 65 | : qd- ( qdst q r -- ) GMP_RNDN mpfr_sub_d drop ; 66 | : qd* ( qdst q r -- ) GMP_RNDN mpfr_mul_d drop ; 67 | : qd/ ( qdst q r -- ) GMP_RNDN mpfr_div_d drop ; 68 | 69 | : qupow ( qdst q u -- ) GMP_RNDN mpfr_pow_ui drop ; 70 | : qpow ( qdst q1 q2 -- ) GMP_RNDN mpfr_pow drop ; 71 | 72 | : qnegate ( qdst qsrc -- ) GMP_RNDN mpfr_neg drop ; 73 | : qabs ( qdst qsrc -- ) GMP_RNDN mpfr_abs drop ; 74 | : qsqrt ( qdst qsrc -- ) GMP_RNDN mpfr_sqrt drop ; 75 | : qexp ( qdst qsrc -- ) GMP_RNDN mpfr_exp drop ; 76 | : qln ( qdst qsrc -- ) GMP_RNDN mpfr_log drop ; 77 | : qlog10 ( qdst qsrc -- ) GMP_RNDN mpfr_log10 drop ; 78 | : qcos ( qdst qsrc -- ) GMP_RNDN mpfr_cos drop ; 79 | : qsin ( qdst qsrc -- ) GMP_RNDN mpfr_sin drop ; 80 | : qtan ( qdst qsrc -- ) GMP_RNDN mpfr_tan drop ; 81 | : qacos ( qdst qsrc -- ) GMP_RNDN mpfr_acos drop ; 82 | : qasin ( qdst qsrc -- ) GMP_RNDN mpfr_asin drop ; 83 | : qatan ( qdst qsrc -- ) GMP_RNDN mpfr_atan drop ; 84 | : qatan2 ( qdst qy qx -- ) GMP_RNDN mpfr_atan2 drop ; 85 | 86 | 87 | End-Module 88 | 89 | -------------------------------------------------------------------------------- /forth-src/libs/x11/fontcursor.4th: -------------------------------------------------------------------------------- 1 | \ fontcursor.4th 2 | \ 3 | \ Copyright 1987, 1998 The Open Group 4 | \ 5 | \ Permission to use, copy, modify, distribute, and sell this software and its 6 | \ documentation for any purpose is hereby granted without fee, provided that 7 | \ the above copyright notice appear in all copies and that both that 8 | \ copyright notice and this permission notice appear in supporting 9 | \ documentation. 10 | \ 11 | 12 | 154 constant XC_num_glyphs 13 | 0 constant XC_X_cursor 14 | 2 constant XC_arrow 15 | 4 constant XC_based_arrow_down 16 | 6 constant XC_based_arrow_up 17 | 8 constant XC_boat 18 | 10 constant XC_bogosity 19 | 12 constant XC_bottom_left_corner 20 | 14 constant XC_bottom_right_corner 21 | 16 constant XC_bottom_side 22 | 18 constant XC_bottom_tee 23 | 20 constant XC_box_spiral 24 | 22 constant XC_center_ptr 25 | 24 constant XC_circle 26 | 26 constant XC_clock 27 | 28 constant XC_coffee_mug 28 | 30 constant XC_cross 29 | 32 constant XC_cross_reverse 30 | 34 constant XC_crosshair 31 | 36 constant XC_diamond_cross 32 | 38 constant XC_dot 33 | 40 constant XC_dotbox 34 | 42 constant XC_double_arrow 35 | 44 constant XC_draft_large 36 | 46 constant XC_draft_small 37 | 48 constant XC_draped_box 38 | 50 constant XC_exchange 39 | 52 constant XC_fleur 40 | 54 constant XC_gobbler 41 | 56 constant XC_gumby 42 | 58 constant XC_hand1 43 | 60 constant XC_hand2 44 | 62 constant XC_heart 45 | 64 constant XC_icon 46 | 66 constant XC_iron_cross 47 | 68 constant XC_left_ptr 48 | 70 constant XC_left_side 49 | 72 constant XC_left_tee 50 | 74 constant XC_leftbutton 51 | 76 constant XC_ll_angle 52 | 78 constant XC_lr_angle 53 | 80 constant XC_man 54 | 82 constant XC_middlebutton 55 | 84 constant XC_mouse 56 | 86 constant XC_pencil 57 | 88 constant XC_pirate 58 | 90 constant XC_plus 59 | 92 constant XC_question_arrow 60 | 94 constant XC_right_ptr 61 | 96 constant XC_right_side 62 | 98 constant XC_right_tee 63 | 100 constant XC_rightbutton 64 | 102 constant XC_rtl_logo 65 | 104 constant XC_sailboat 66 | 106 constant XC_sb_down_arrow 67 | 108 constant XC_sb_h_double_arrow 68 | 110 constant XC_sb_left_arrow 69 | 112 constant XC_sb_right_arrow 70 | 114 constant XC_sb_up_arrow 71 | 116 constant XC_sb_v_double_arrow 72 | 118 constant XC_shuttle 73 | 120 constant XC_sizing 74 | 122 constant XC_spider 75 | 124 constant XC_spraycan 76 | 126 constant XC_star 77 | 128 constant XC_target 78 | 130 constant XC_tcross 79 | 132 constant XC_top_left_arrow 80 | 134 constant XC_top_left_corner 81 | 136 constant XC_top_right_corner 82 | 138 constant XC_top_side 83 | 140 constant XC_top_tee 84 | 142 constant XC_trek 85 | 144 constant XC_ul_angle 86 | 146 constant XC_umbrella 87 | 148 constant XC_ur_angle 88 | 150 constant XC_watch 89 | 152 constant XC_xterm 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /forth-src/fsl/fsl-tester.4th: -------------------------------------------------------------------------------- 1 | \ fsl-tester.4th 2 | \ 3 | \ Test revised versions of the FSL routines under kForth, 4 | \ using the ttester.4th test harness. 5 | \ 6 | \ K. Myneni, 2007-09-19 7 | \ 8 | \ Revisions: 9 | \ 10 | \ 2007-09-22 km; added gauleg module 11 | \ 2007-10-10 km; added regfalsi 12 | \ 2007-10-12 km; added expint, horner 13 | \ 2007-10-13 km; added polys 14 | \ 2007-10-14 km; added runge4 15 | \ 2007-10-18 km; added gamma 16 | \ 2007-10-22 km; added logistic 17 | \ 2007-10-25 km; added adaptint, elip 18 | \ 2007-11-11 km; added permcombs, gauss 19 | \ 2007-11-25 km; added sph_bes, cubic, crc 20 | \ 2007-11-28 km; added isaac, prng 21 | \ 2007-11-29 km; added factorl, shanks 22 | \ 2007-11-30 km; added pcylfun 23 | \ 2007-12-02 km; added gaussj 24 | \ 2009-06-04 km; added r250 25 | \ 2010-10-21 km; added polrat 26 | \ 2010-12-25 km; added aitken 27 | \ 2010-12-29 km; added lagroots 28 | \ 2011-01-13 km; added erf 29 | \ 2011-01-16 km; added hermite 30 | \ 2011-01-20 km; added dfourier 31 | \ 2011-01-25 km; added elip12 32 | \ 2011-01-29 km; added quadratic 33 | \ 2021-07-22 km; use Forth 200x structures 34 | \ 2023-11-30 km; added shellsrt 35 | include ans-words 36 | include fsl-util 37 | include dynmem 38 | include strings 39 | include struct-200x 40 | include complex 41 | include fsl-test-utils 42 | include ttester 43 | DECIMAL 44 | 45 | true to TEST-CODE? 46 | true verbose ! 47 | 48 | 1 cells 4 = constant 32-bit? 49 | 50 | 32-bit? [IF] 51 | CR CR 52 | include isaac 53 | [THEN] 54 | 55 | CR CR 56 | include prng 57 | 58 | CR CR 59 | include sph_bes 60 | 61 | CR CR 62 | include logistic 63 | 64 | CR CR 65 | include polrat 66 | 67 | CR CR 68 | include expint 69 | 70 | CR CR 71 | include horner 72 | 73 | CR CR 74 | include aitken 75 | 76 | CR CR 77 | include hermite 78 | 79 | CR CR 80 | include elip 81 | 82 | CR CR 83 | include elip12 84 | 85 | CR CR 86 | include polys 87 | 88 | CR CR 89 | include factorl 90 | 91 | CR CR 92 | include gamma 93 | 94 | CR CR 95 | include erf 96 | 97 | CR CR 98 | include pcylfun 99 | 100 | CR CR 101 | include shanks 102 | 103 | CR CR 104 | include hilbert 105 | 106 | CR CR 107 | include lufact 108 | 109 | CR CR 110 | include dets 111 | 112 | CR CR 113 | include backsub 114 | 115 | CR CR 116 | include invm 117 | 118 | CR CR 119 | include gaussj 120 | 121 | CR CR 122 | include dfourier 123 | 124 | CR CR 125 | include adaptint 126 | 127 | CR CR 128 | include gauleg 129 | 130 | CR CR 131 | include quadratic 132 | 133 | CR CR 134 | include cubic 135 | 136 | CR CR 137 | include lagroots 138 | 139 | CR CR 140 | include regfalsi 141 | 142 | CR CR 143 | include runge4 144 | 145 | CR CR 146 | include crc 147 | 148 | CR CR 149 | include permcomb 150 | 151 | CR CR 152 | include gauss 153 | 154 | CR CR 155 | include r250 156 | 157 | CR CR 158 | include shellsrt 159 | 160 | CR CR 161 | bye 162 | -------------------------------------------------------------------------------- /forth-src/literate-included.fs: -------------------------------------------------------------------------------- 1 | \ This file is generated using LyX and Noweb -- Do Not Edit! 2 | \ Please make modifications to the original file, literate-included.lyx 3 | \ Version 1.1 4 | \ Copyright (c) 2010--2011, Krishna Myneni 5 | \ The software given here may be used for any purpose, 6 | \ provided the copyright notice, above, is preserved. 7 | [undefined] strcat [IF] s" strings.fs" included [THEN] 8 | [undefined] 4dup [IF] : 4dup 2over 2over ; [THEN] 9 | [undefined] 4drop [IF] : 4drop 2drop 2drop ; [THEN] 10 | 11 | \ Search the string, $str, for the pattern, $pat. If found, 12 | \ replace $pat with $rep, and return the new string, $new. 13 | 14 | : replace ( $str $pat $rep -- $new ) 15 | 2>r ( $str $pat ) ( r: $rep ) 16 | 4dup search 17 | if ( $str $pat $sub ) ( r: $rep ) 18 | 2rot 2over ( $pat $sub $str $sub ) ( r: $rep ) 19 | drop nip over - ( $pat $sub $left ) ( r: $rep ) 20 | 2r> strcat ( $pat $sub $left+$rep ) 21 | 2>r 2swap nip /string ( $right ) ( r: $left+$rep ) 22 | 2r> 2swap strcat ( $left+$rep+$right ) 23 | else ( $str $pat $sub ) ( r: $rep ) 24 | 4drop 2r> 2drop ( $str ) 25 | then ; 26 | 27 | \ auto selection for those systems which identify themselves 28 | 29 | [DEFINED] gforth [IF] : shell ( caddr u -- retcode ) system $? ; [THEN] 30 | [DEFINED] bigforth [IF] 31 | also dos : shell strpck system ; previous [THEN] 32 | [DEFINED] vfxforth [IF] 33 | Extern: sys-command int system ( char * ); ( cmd -- r ) 34 | : shell strpck 1+ sys-command ; [THEN] 35 | 36 | \ manual selection for other systems 37 | 38 | [UNDEFINED] shell [IF] 39 | 0 [IF] : shell ( caddr u -- retcode ) system $? ; [THEN] \ gforth (older version) 40 | 1 [IF] : shell strpck system ; [THEN] \ kforth 41 | 0 [IF] : shell system RETURNCODE @ ; [THEN] \ iForth 42 | 0 [IF] : shell system ; [THEN] \ pfe 43 | [THEN] 44 | 45 | \ Extract the Forth source (.fs) from a Noweb (.nw) file. 46 | \ Return the full .fs filename. 47 | 48 | : untangle ( anw u1 afs u2 -- afs2 u3 ) 49 | strpck count 2>r strpck count 2r> 50 | \ Execute a shell command to extract a Forth source file from a Noweb file 51 | ( anw u1 afs u2 ) 2>r 52 | s" notangle -R%f2.fs %f1.nw > %f2.fs" 53 | s" %f2" 2r@ replace s" %f1" 2rot replace s" %f2" 2r@ replace 54 | shell 2r> rot ( afs u2 n ) abort" Unable to extract Forth source file!" 55 | s" .fs" strcat ; 56 | 57 | \ INCLUDED for a Noweb file 58 | : nw-included ( anw u1 asrc u2 -- ... ) untangle included ; 59 | : lyx>nw ( alyx u1 -- anw u1 retcode ) 60 | strpck count 61 | 2dup s" .nw" strcat DELETE-FILE drop 62 | 2dup ( afname u ) 63 | s" lyx -e literate " 2swap strcat s" .lyx" strcat shell ( n ) ; 64 | 65 | \ INCLUDED for a LyX (.lyx) file. 66 | : lyx-included ( alyx u1 asrc u2 -- ) 67 | strpck count 2>r 68 | lyx>nw abort" Unable to convert a lyx file to a noweb file!" 69 | 2r> nw-included 70 | ; 71 | -------------------------------------------------------------------------------- /forth-src/qm/H2-potnl-pac2010.dat: -------------------------------------------------------------------------------- 1 | # High-precision calculation of potential energy curve for the ground 2 | # electronic state (1Sigma_g^+) of H_2 from, 3 | # 4 | # K. Pachucki, Phys. Rev. A 82, 032509 (2010) 5 | # 6 | # r is in atomic units, V(r) is in atomic units. 7 | # 8 | 0.10D0 7.1272167311320D0 9 | 0.20D0 2.19780329522618D0 10 | 0.30D0 0.619241659796226D0 11 | 0.40D0 -0.120230341178823D0 12 | 0.50D0 -0.526638758743001D0 13 | 0.60D0 -0.7696354294859092D0 14 | 0.70D0 -0.9220274615274636D0 15 | 0.80D0 -1.0200566663605151D0 16 | 0.90D0 -1.0836432399588343D0 17 | 1.00D0 -1.1245397195468708D0 18 | 1.10D0 -1.1500573677385650D0 19 | 1.20D0 -1.1649352434403099D0 20 | 1.25D0 -1.1694196273909022D0 21 | 1.30D0 -1.1723471490380904D0 22 | 1.32D0 -1.1731387363334793D0 23 | 1.34D0 -1.1737348749583451D0 24 | 1.36D0 -1.1741484985704193D0 25 | 1.38D0 -1.1743916836322532D0 26 | 1.39D0 -1.1744529172784574D0 27 | 1.40D0 -1.1744757142204434D0 28 | 1.41D0 -1.1744613708706800D0 29 | 1.42D0 -1.1744111412392317D0 30 | 1.44D0 -1.1742078365850950D0 31 | 1.46D0 -1.1738750427492034D0 32 | 1.48D0 -1.1734214182920817D0 33 | 1.50D0 -1.1728550795785838D0 34 | 1.55D0 -1.1709949198970180D0 35 | 1.60D0 -1.1685833733714593D0 36 | 1.70D0 -1.1624587268984588D0 37 | 1.80D0 -1.1550687376116094D0 38 | 1.90D0 -1.1468506970296887D0 39 | 2.00D0 -1.1381329571326480D0 40 | 2.10D0 -1.1291638361013193D0 41 | 2.20D0 -1.1201321168492218D0 42 | 2.30D0 -1.1111817652044391D0 43 | 2.40D0 -1.1024226060113263D0 44 | 2.50D0 -1.0939381299558790D0 45 | 2.60D0 -1.0857912373961321D0 46 | 2.70D0 -1.0780284841838287D0 47 | 2.80D0 -1.0706832334814249D0 48 | 2.90D0 -1.0637780088060211D0 49 | 3.00D0 -1.0573262688726617D0 50 | 3.10D0 -1.0513337722680178D0 51 | 3.20D0 -1.045799661432432D0 52 | 3.30D0 -1.040717365351395D0 53 | 3.40D0 -1.0360753951907599D0 54 | 3.50D0 -1.0318580848550934D0 55 | 3.60D0 -1.0280463083797348D0 56 | 3.70D0 -1.024618188410962D0 57 | 3.80D0 -1.021549795533649D0 58 | 3.90D0 -1.018815827696496D0 59 | 4.00D0 -1.0163902529506681D0 60 | 4.20D0 -1.012359959683166D0 61 | 4.40D0 -1.0092565162615862D0 62 | 4.60D0 -1.0068952238227406D0 63 | 4.80D0 -1.0051160061003838D0 64 | 5.00D0 -1.0037856585839706D0 65 | 5.20D0 -1.0027968163112547D0 66 | 5.40D0 -1.0020650572097059D0 67 | 5.60D0 -1.0015252518866137D0 68 | 5.80D0 -1.0011278808524173D0 69 | 6.00D0 -1.0008357076551804D0 70 | 6.50D0 -1.0004005485345376D0 71 | 7.00D0 -1.0001979144800381D0 72 | 7.50D0 -1.0001021061478089D0 73 | 8.00D0 -1.0000556049730730D0 74 | 8.50D0 -1.0000321718328288D0 75 | 9.00D0 -1.0000197818324911D0 76 | 9.50D0 -1.0000128568768268D0 77 | 10.00D0 -1.0000087557460515D0 78 | 10.50D0 -1.0000061899951069D0 79 | 11.00D0 -1.0000045059894362D0 80 | 11.50D0 -1.0000033561745754D0 81 | 12.00D0 -1.0000025459695285D0 82 | 13.00D0 -1.0000015292866698D0 83 | 14.00D0 -1.0000009606807911D0 84 | 15.00D0 -1.0000006254536319D0 85 | 16.00D0 -1.0000004195863122D0 86 | 17.00D0 -1.0000002888262392D0 87 | 18.00D0 -1.0000002033405059D0 88 | 19.00D0 -1.0000001460282368D0 89 | 20.00D0 -1.0000001067401283D0 90 | 91 | -------------------------------------------------------------------------------- /forth-src/mc.4th: -------------------------------------------------------------------------------- 1 | \ mc.4th 2 | \ 3 | \ Machine code buffer allocation and set up for execution. 4 | \ 5 | \ Copyright (c) 2020 Krishna Myneni 6 | \ 7 | \ Provided under the GNU Affero General Public License 8 | \ (AGPL) v3.0 or later. 9 | \ 10 | \ Requires: ans-words.4th modules.4th syscalls.4th 11 | \ 12 | 13 | Also syscalls 14 | BASE @ 15 | HEX 16 | 17 | : align16 ( u1|a1 -- u2|a2 ) 10 /mod swap IF 1+ THEN 4 LSHIFT ; 18 | 19 | \ Page utilities 20 | 1000 constant PAGESIZE \ this should be obtained from the OS config. 21 | PAGESIZE 1- invert constant PAGEMASK 22 | 23 | \ Return true if address range a--a+u crosses a page boundary 24 | : ?PageCross ( a u -- flag ) 25 | over + 1- >r PAGEMASK and r> PAGEMASK and <> ; 26 | 27 | \ Return the start of the next page after a1 28 | : NextPage ( a1 -- a2 ) PAGEMASK and PAGESIZE + ; 29 | 30 | \ Machine code buffer will be a multiple of PAGESIZE bytes 31 | 20 constant MC_NPAGES 32 | PAGESIZE MC_NPAGES * constant MC_BUFSIZE 33 | 0 ptr MC-Here0 34 | 35 | \ Allocate buffer 36 | [DEFINED] _WIN32_ [IF] \ Win32 37 | 0 MC_BUFSIZE MEM_RESERVE MEM_COMMIT or PAGE_READWRITE valloc 38 | [ELSE] \ Linux 39 | 0 MC_BUFSIZE PROT_READ PROT_WRITE or MAP_ANONYMOUS MAP_PRIVATE or 40 | -1 0 mmap 41 | [THEN] 42 | to MC-Here0 43 | 44 | MC-Here0 -1 = [IF] 45 | cr .( Failed to allocate machine code buffer! ) cr 46 | ABORT 47 | [THEN] 48 | 49 | MC-Here0 ptr MC-Here 50 | 51 | \ Use of MC-Allot? must be paired with CREATE 52 | : MC-Allot? ( u -- addr ) 53 | MC-Here over ?PageCross IF MC-Here NextPage to MC-Here THEN 54 | MC-Here dup 1 cells allot? ! 55 | tuck + to MC-Here ; 56 | 57 | \ flag_rw = TRUE, the page is allowed read-executable 58 | \ flag_rw = FALSE, the page is read-writable 59 | \ return true if successful 60 | [DEFINED] _WIN32_ [IF] \ Win32 61 | variable OldProt 62 | : MC-Executable ( a_mc flag_rw -- flag ) 63 | >r PAGEMASK and PAGESIZE 64 | r> IF PAGE_EXECUTE_READ ELSE PAGE_READWRITE THEN 65 | OldProt vprotect 0= ; 66 | [ELSE] \ Linux 67 | : MC-Executable ( a_mc flag_rw -- flag ) 68 | >r PAGEMASK and PAGESIZE 69 | r> IF PROT_EXEC ELSE PROT_READ PROT_WRITE or THEN 70 | mprotect 0= ; 71 | [THEN] 72 | 73 | \ Create a named machine code table, returning the address of 74 | \ the starting address of the machine code buffer. The 75 | \ requested number of bytes, ur, will be adjusted to a multiple 76 | \ of 16 when the buffer is allocated. Executing the table name 77 | \ will return the start address of the machine code buffer. 78 | \ Upon creation, the buffer will be in a read-writable state. 79 | 80 | : MC-Table ( ur "name" -- a_mc ) 81 | create align16 MC-Allot? 82 | does> ( a -- a_mc ) a@ ; 83 | 84 | : MC-Put ( b1 b2 ... b_u u a_mc -- ) 85 | dup false MC-Executable 0= 86 | Abort" Cannot make buffer R/W!" 87 | dup >r 88 | 2dup + 1- nip 89 | swap 0 ?DO 2dup c! 1- nip LOOP drop 90 | r> true MC-Executable 0= 91 | Abort" Cannot make buffer R/X!" ; 92 | 93 | \ Return the executable code address 94 | : >MC-Code ( xt -- a ) >body a@ ; 95 | 96 | BASE ! 97 | Previous 98 | 99 | -------------------------------------------------------------------------------- /forth-src/struct.4th: -------------------------------------------------------------------------------- 1 | \ struct.4th 2 | \ 3 | \ data structures (like C structs) by Anton Ertl, circa 1989, 4 | \ adapted for kForth by K. Myneni, 2003-2-16 5 | \ 6 | \ This file is in the public domain. NO WARRANTY. 7 | \ 8 | \ Usage: 9 | \ 10 | \ Example of defining a structure: 11 | \ 12 | \ struct 13 | \ cell% field x 14 | \ cell% field y 15 | \ end-struct point% 16 | \ 17 | \ Creating an instance of, and initializing the above structure: 18 | \ 19 | \ create p1 point% %allot drop 20 | \ 3 p1 x ! 21 | \ 12 p1 y ! 22 | \ 23 | \ Accessing the members of the structure: 24 | \ 25 | \ p1 x returns the address of member x of p1 26 | \ 27 | \ Determining the size of the structure: 28 | \ 29 | \ point% %size . 30 | \ 31 | \ Determining the alignment of the structure: 32 | \ 33 | \ point% %alignment . 34 | \ 35 | \ For more information regarding this structures package, see 36 | \ 37 | \ http://mips.complang.tuwien.ac.at/forth/objects/structs.html 38 | \ 39 | \ 40 | \ ======= kForth requires ======================= 41 | \ include ans-words ( commented out here, but include in main program file) 42 | \ ================================================ 43 | 44 | : naligned ( addr1 n -- addr2 ) 45 | \ addr2 is the aligned version of addr1 wrt the alignment size n 46 | 1- tuck + swap invert and ; 47 | 48 | : nalign naligned ; \ old name, obsolete 49 | 50 | : dofield ( -- ) 51 | does> ( name execution: addr1 -- addr2 ) 52 | @ + ; 53 | 54 | : dozerofield ( -- ) 55 | immediate 56 | does> ( name execution: -- ) 57 | drop ; 58 | 59 | : create-field ( align1 offset1 align size "name" -- align2 offset2 ) 60 | create swap rot over nalign dup 1 cells allot? ! ( ,) ( align1 size align offset ) 61 | rot + >r nalign r> ; 62 | 63 | : field ( align1 offset1 align size "name" -- align2 offset2 ) 64 | \ name execution: addr1 -- addr2 65 | 2 pick >r \ this uglyness is just for optimizing with dozerofield 66 | create-field 67 | r> if \ offset<>0 68 | dofield 69 | else 70 | dozerofield 71 | then ; 72 | 73 | : end-struct ( align size "name" -- ) 74 | over nalign \ pad size to full alignment 75 | 2constant ; 76 | 77 | \ an empty struct 78 | 1 chars 0 end-struct struct 79 | 80 | \ type descriptors, all ( -- align size ) 81 | 1 aligned 1 cells 2constant cell% 82 | 1 chars 1 chars 2constant char% 83 | 1 faligned 1 floats 2constant float% 84 | 1 dfaligned 1 dfloats 2constant dfloat% 85 | 1 sfaligned 1 sfloats 2constant sfloat% 86 | cell% 2* 2constant double% 87 | 88 | \ memory allocation words 89 | : %alignment ( align size -- align ) 90 | drop ; 91 | 92 | : %size ( align size -- size ) 93 | nip ; 94 | 95 | : %align ( align size -- ) 96 | ( drop here swap nalign here - allot) 2drop ; 97 | 98 | : %allot ( align size -- addr ) 99 | tuck %align ( here swap) allot? ; 100 | 101 | : %allocate ( align size -- addr ior ) 102 | nip allocate ; 103 | 104 | : %alloc ( size align -- addr ) 105 | %allocate throw ; 106 | 107 | -------------------------------------------------------------------------------- /forth-src/3ds-transform.4th: -------------------------------------------------------------------------------- 1 | \ 3ds-transform.4th 2 | \ 3 | \ Transformations on 3d models 4 | \ 5 | \ Copyright (c) 2009 Krishna Myneni, Creative Consulting for Research & Education 6 | \ 7 | \ This code is provided under the GNU Lesser General Public License (LGPL) 8 | \ 9 | \ Revisions: 10 | \ 2009-12-03 km fixed a problem with Rtransform-Vertices 11 | 12 | [UNDEFINED] 3ds_Vertex% [IF] s" 3ds.4th" included [THEN] 13 | 14 | [undefined] fpick [IF] : fpick floats sp@ cell+ + f@ ; [THEN] \ kForth-specific definition 15 | : f3dup 2 fpick 2 fpick 2 fpick ; 16 | 17 | \ View rotation 18 | 19 | \ Object rotation angles (Euler angles) 20 | fvariable phi 21 | fvariable theta 22 | fvariable psi 23 | 24 | fvariable cos_phi 25 | fvariable sin_phi 26 | fvariable cos_theta 27 | fvariable sin_theta 28 | fvariable cos_psi 29 | fvariable sin_psi 30 | 31 | create Rmatrix 9 floats allot 32 | 33 | \ Setup the rotation matrix for the current object rotation angles 34 | : update-rotation-matrix ( -- ) 35 | phi f@ fsincos cos_phi f! sin_phi f! 36 | theta f@ fsincos cos_theta f! sin_theta f! 37 | psi f@ fsincos cos_psi f! sin_psi f! 38 | 39 | cos_psi f@ cos_phi f@ f* cos_theta f@ sin_phi f@ f* sin_psi f@ f* f- 40 | Rmatrix f! 41 | cos_psi f@ sin_phi f@ f* cos_theta f@ cos_phi f@ f* sin_psi f@ f* f+ 42 | [ Rmatrix FLOAT+ ] literal f! 43 | sin_psi f@ sin_theta f@ f* 44 | [ Rmatrix 2 FLOATS + ] literal f! 45 | 46 | sin_psi f@ cos_phi f@ f* cos_theta f@ sin_phi f@ f* cos_psi f@ f* f+ fnegate 47 | [ Rmatrix 3 FLOATS + ] literal f! 48 | sin_psi f@ sin_phi f@ f* fnegate cos_theta f@ cos_phi f@ f* cos_psi f@ f* f+ 49 | [ Rmatrix 4 FLOATS + ] literal f! 50 | cos_psi f@ sin_theta f@ f* [ Rmatrix 5 FLOATS + ] literal f! 51 | 52 | sin_theta f@ sin_phi f@ f* [ Rmatrix 6 FLOATS + ] literal f! 53 | sin_theta f@ cos_phi f@ f* fnegate [ Rmatrix 7 FLOATS + ] literal f! 54 | cos_theta f@ [ Rmatrix 8 FLOATS + ] literal f! 55 | ; 56 | 57 | 58 | \ Rotation transformation of an array of vertices using the current object 59 | \ rotation angles. 60 | \ Input array is a1, output array is a2, and u points will be transformed 61 | fvariable xp 62 | fvariable yp 63 | fvariable zp 64 | 65 | : Rtransform-Vertices ( a1 a2 u -- ) 66 | 0 ?DO 67 | >r >r 68 | r@ 3ds_Vertex->z sf@ r@ 3ds_Vertex->y sf@ r@ 3ds_Vertex->x sf@ 69 | f3dup f3dup 70 | 71 | Rmatrix f@ f* fswap 72 | [ Rmatrix 3 floats + ] literal f@ f* f+ fswap 73 | [ Rmatrix 6 floats + ] literal f@ f* f+ xp f! 74 | 75 | [ Rmatrix 1 floats + ] literal f@ f* fswap 76 | [ Rmatrix 4 floats + ] literal f@ f* f+ fswap 77 | [ Rmatrix 7 floats + ] literal f@ f* f+ yp f! 78 | 79 | [ Rmatrix 2 floats + ] literal f@ f* fswap 80 | [ Rmatrix 5 floats + ] literal f@ f* f+ fswap 81 | [ Rmatrix 8 floats + ] literal f@ f* f+ zp f! 82 | 83 | r> r> dup 2dup 2>r >r 84 | zp f@ r> 3ds_Vertex->z sf! 85 | yp f@ r> 3ds_Vertex->y sf! 86 | xp f@ r> 3ds_Vertex->x sf! 87 | 88 | VTX_SIZE + swap VTX_SIZE + swap 89 | LOOP 90 | 2drop 91 | ; 92 | 93 | --------------------------------------------------------------------------------