papa/forth
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Initial contents

Browse Source
This commit is contained in:
David Meyer 2022-02-08 22:14:44 +09:00
parent 45122000e7
commit dcd926c34b
87 changed files with 23606 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
3dplot.4th Executable file
View File

@ -0,0 +1,77 @@
\ 3dplot.4th - Forth source file template
\
\ Copyright 2015 David Meyer <papa@sdf.org> +JMJ
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
\ Print 2-D graph of 3-D function:
\
\ z = f(x,y) = A * exp ((x**2 + y**2) / D) + B*y + C
\
\ Ported from Creative Computing BASIC Games Collection
20 constant PLOTLINES
10 constant PLOTSECTS
PLOTLINES 2 / s>d d>f fconstant RADIUS
: header ( -- ) 25 spaces ." 3DPLOT / SLOTS" cr ;
: line>x ( u -- r ) PLOTLINES 2 / - s>d d>f ;
: col>y ( u -- r ) PLOTSECTS 2 / - s>d d>f ;
: x>upr-hemi ( rx -- ry ) fdup f* RADIUS fdup f* fswap f- fsqrt ;
: x>low-hemi ( rx -- ry ) x>upr-hemi fnegate ;
: xy>z ( rx ry -- rz ) fdrop fdrop 0e0 ;
: 3dplot ( -- )
header cr
PLOTLINES 0 ?do
PLOTSECTS 0 ?do
2 spaces [char] * emit
\ i col>y j line>x x>low-hemi f<
\ i col>y j line>x x>upr-hemi f> or if
\ 3 spaces
\ else
\ 2 spaces [char] * emit
\ then
loop
cr
loop
\ 20 1 u+do
\ i 11 - dup * 100 swap -
\ s>d d>f fsqrt 2e0 f*
\ f>d d>s
\ dup 20 swap - spaces
\ 2* 0 u+do
\ [char] * emit
\ loop
\ cr
\ loop
;
\ Main **************************************************************
cr
3dplot
bye
\ Emacs control *****************************************************
\Local variables:
\mode: forth
\End:

0
LICENSE Normal file → Executable file
View File

5173
Mind.4th Executable file
View File

File diff suppressed because it is too large Load Diff

5173
Mind.F Executable file
View File

File diff suppressed because it is too large Load Diff

0
README.md Normal file → Executable file
View File

53
array.fs Executable file
View File

@ -0,0 +1,53 @@
\ array.fs - Array of cells in Forth
\ 2013 David Meyer <papa@sdf.org> +JMJ
\ Source: Leonard Morgenstern. Arrays in Forth. Len's Forth Tutorial.
\ c. 1996.
\ <http://www.forth.org/svfig/Len/arrays.htm>
\ accessed 2013-10-17.
: array ( n -- ) ( i -- addr )
create cells allot
does> swap cells +
;
\ table - Array of n-cell records
: table ( n len -- ) ( i -- addr )
create dup , * cells allot
does> dup @ swap * cells + \ rot instead of swap?
;
\ Original source from web page ...
: unindexed-array ( n -- ) ( -- a)
create allot ;
80 unindexed-array u-foo \ Make an 80-byte unindexed array
u-foo \ Return the origin addr of u-foo
: array ( n -- ) ( i -- addr)
create cells allot
does> cells + ;
100 array foo \ Make an array with 100 cells
3 foo \ Return address of fourth element
: long-element-array ( n len -- ) ( i -- addr)
create dup , * cells allot
does> dup @ swap * cells + ;
10 5 long-element-array th-room \ Create array for 10 rooms
4 th-room \ Find address of room 4
variable current-offset
: offset ( n -- ) ( addr -- addr')
create current-offset @ ,
does> @ cells + ;
current-offset off \ Set variable to 0
1 offset }descriptor
1 offset }north
1 offset }east
1 offset }south
1 offset }west
\ Examples:
3 th-room }north @ \ Rm# The room north of room 3
4 th-room }descriptor @ execute
\ Print the description of room 4

16
blockimg.txt Executable file
View File

@ -0,0 +1,16 @@
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************
****************************************************************

4
caltech-forth.blink Executable file
View File

@ -0,0 +1,4 @@
Caltech Forth
http://pdp-10.trailing-edge.com/decuslib10-04/01/43,50361/forth.doc.html
Macro Assembler source (Tenex):
http://pdp-10.trailing-edge.com/decuslib10-04/01/43,50361/forth.mac.html

35
cat.fs Executable file
View File

@ -0,0 +1,35 @@
\ cat.fs - String concatenation
variable str
: cat { a1 u1 a2 u2 -- a3 u1+u2 }
here str !
u1 u2 + chars allot
u1 0 u+do
a1 i + @
str i + !
loop
u2 0 u+do
a2 i + @
str u1 + i + !
loop
str u1 u2 +
;
: 3cat { a1 u1 a2 u2 a3 u3 -- a4 u1+u2+u3 }
here str !
u1 u2 u3 + + chars allot
u1 0 u+do
a1 i + @
str i + !
loop
u2 0 u+do
a2 i + @
str u1 i + + !
loop
u3 0 u+do
a3 i + @
str u1 u2 i + + + !
loop
str u1 u2 u3 + +
;

148
cgi-0.fs Executable file
View File

@ -0,0 +1,148 @@
\ cgi.fs - Common Gateway Interface for Forth
\ +JMJ 2013 David Meyer <papa@sdf.org>
\ URI length limits:
\ Standards impose no maximum URI length, but MSIE
\ through version 10 can only handle URIs of 2083
\ characters or less (2048 characters is maximum
\ path length).
\ URI RFC recommends hostname part of URI not
\ exceed 255 characters.
\ Maximum number of key/value pairs in URI query string
\ Max. characters: 2083
\ Query string length: SUM( key-length-n + value-length-n + 2 ) - 1
\ = n * ( key-length-avg + value-length-avg + 2 ) - 1
\ Maximum number of keys achieved when key and values are minimum
\ length - 1 character.
\ 2083 = n * ( 1 + 1 + 2 ) - 1
\ = n * 4 - 1
\ 2084 = n * 4
\ n = 521 <-- Maximum possible number of key/value pairs in query string
variable decode-ptr
variable code-len
variable keystr-ptr
variable keystr-len
variable valstr-ptr
variable valstr-len
\ Is character c a '%'?
: c%? ( c -- f ) [char] % = ;
\ Return hexadecimal value (0-15) of character [0-9A-Fa-f]
\ Returns -1 for invalid character
: chex ( c -- n )
dup [char] 0 [char] 9 1+ within if
[char] 0 - exit
then
dup [char] A [char] F 1+ within if
[char] A - 10 + exit
then
dup [char] a [char] f 1+ within if
[char] a - 10 + exit
then
drop -1 ( Invalid character error )
;
\ Compute value (0-255) of 2-character hexadecimal number
: hexval ( chigh clow -- 16*chigh+clow ) swap 16 * + ;
\ Search string at c-addr1 for character c. If found, set f true and u2 to offset of 1st c in string.
: csearch ( c-addr1 u1 c -- u2 f )
0 2over ( c-addr1 u1 c ui c-addr1 u1 )
+do ( c-addr1 u1 c ui c-addr1 )
swap chars + c@ ( c-addr1 u1 c ci )
i rot rot ( c-addr1 u1 ui+1 c ci )
over = ( c-addr1 u1 ui+1 c fi )
>r swap 2over drop r> ( c-addr1 u1 c ui+1 c-addr1 fi )
\ Exit loop if current char. matches
if leave then ( c-addr1 u1 c ui+1 c-addr1 )
loop
drop 1- rot over ( c-addr1 c u2 u1 u2 )
- 1 > if ( c-addr1 c u2 )
\ Found char. before end of string
true 2swap 2drop ( u2 true )
else
\ Got to end of string
dup chars 2swap rot rot + c@ ( u2 c c2 )
= if
\ End of string matches char.
true ( u2 true )
else
\ No match
false ( u2 false )
then
then
;
\ Decode percent-encoded string
: %decode ( c-code u-code -- c-decode u-decode )
here decode-ptr !
dup chars allot
code-len ! ( c-code )
0 swap 0 ( decode-ofst c-code code-ofst )
begin
dup 1+ code-len @ <=
while
rot >r ( c-code code-ofst )
2dup + c@ c%? if
2dup 2dup + 1 chars + c@ chex
rot rot + 2 chars + c@ chex
2dup 0>= swap 0>= and if
hexval decode-ptr @ r@ + c!
r> 1 chars + rot rot
else
2drop
2dup + decode-ptr @ r@ + 3 cmove
r> 3 chars + rot rot
then
2 chars +
else
2dup + c@ decode-ptr @ r@ + c!
r> 1 chars + rot rot
\ cr ." debug:" decode-ptr @ code-len @ dump
then
1 chars +
repeat
2drop decode-ptr @ swap
;
\ Return value for CGI query string key.
\ Return 0 0 if key not found.
: qskeyval ( c-key u-key-len -- c-value u-value-len )
dup
s" QUERY_STRING" getenv
dup if
rot over swap - 2 < if
\ Query string not long enough for key=value
2drop 2drop 0 0
else
\ search for key string in query
2swap
( c-querystr u-querystr-len c-key u-key-len )
\ Set key search string
here keystr-ptr !
dup 2 + dup keystr-len !
chars dup allot
[char] = swap keystr-ptr @ + !
[char] & keystr-ptr !
keystr-ptr @ 1 chars + swap cmove
( c-querystr u-querystr-len )
\ Check for key at beginning of query string
2dup keystr-ptr @ 1 chars + keystr-len @ 1-
string-prefix? if
\ Extract 1st value string
here valstr-ptr !
else
\ Search query string for full key
then
then
else
\ QUERY_STRING not defined
2swap 2drop rot drop
then
;

169
cgi.fs Executable file
View File

@ -0,0 +1,169 @@
\ cgi.fs - Common Gateway Interface for Forth
\ +JMJ 2013 David Meyer <papa@sdf.org>
\ URI length limits:
\ Standards impose no maximum URI length, but MSIE
\ through version 10 can only handle URIs of 2083
\ characters or less (2048 characters is maximum
\ path length).
\ URI RFC recommends hostname part of URI not
\ exceed 255 characters.
\ Maximum number of key/value pairs in URI query string
\ Max. characters: 2083
\ Query string length: SUM( key-length-n + value-length-n + 2 ) - 1
\ = n * ( key-length-avg + value-length-avg + 2 ) - 1
\ Maximum number of keys achieved when key and values are minimum
\ length - 1 character.
\ 2083 = n * ( 1 + 1 + 2 ) - 1
\ = n * 4 - 1
\ 2084 = n * 4
\ n = 521 <-- Maximum possible number of key/value pairs in query string
require array.fs
variable CGIQUERYSTR \ QUERY_STRING address
variable CGIQUERYLEN \ QUERY_STRING length
521 4 table CGIFIELD
variable decode-ptr
variable code-len
variable keystr-ptr
variable keystr-len
variable valstr-ptr
variable valstr-len
\ Is character c a '%'?
: c%? ( c -- f ) [char] % = ;
\ Return hexadecimal value (0-15) of character [0-9A-Fa-f]
\ Returns -1 for invalid character
: chex ( c -- n )
dup [char] 0 [char] 9 1+ within if
[char] 0 - exit
then
dup [char] A [char] F 1+ within if
[char] A - 10 + exit
then
dup [char] a [char] f 1+ within if
[char] a - 10 + exit
then
drop -1 ( Invalid character error )
;
\ Compute value (0-255) of 2-character hexadecimal number
: hexval ( chigh clow -- 16*chigh+clow ) swap 16 * + ;
\ Search string at c-addr1 for character c. If found, set f true and u2 to offset of 1st c in string.
: csearch ( c-addr1 u1 c -- u2 f )
0 2over ( c-addr1 u1 c ui c-addr1 u1 )
+do ( c-addr1 u1 c ui c-addr1 )
swap chars + c@ ( c-addr1 u1 c ci )
i rot rot ( c-addr1 u1 ui+1 c ci )
over = ( c-addr1 u1 ui+1 c fi )
>r swap 2over drop r> ( c-addr1 u1 c ui+1 c-addr1 fi )
\ Exit loop if current char. matches
if leave then ( c-addr1 u1 c ui+1 c-addr1 )
loop
drop 1- rot over ( c-addr1 c u2 u1 u2 )
- 1 > if ( c-addr1 c u2 )
\ Found char. before end of string
true 2swap 2drop ( u2 true )
else
\ Got to end of string
dup chars 2swap rot rot + c@ ( u2 c c2 )
= if
\ End of string matches char.
true ( u2 true )
else
\ No match
false ( u2 false )
then
then
;
\ Decode percent-encoded string
: %decode ( c-code u-code -- c-decode u-decode )
here decode-ptr !
dup chars allot
code-len ! ( c-code )
0 swap 0 ( decode-ofst c-code code-ofst )
begin
dup 1+ code-len @ <=
while
rot >r ( c-code code-ofst )
2dup + c@ c%? if
2dup 2dup + 1 chars + c@ chex
rot rot + 2 chars + c@ chex
2dup 0>= swap 0>= and if
hexval decode-ptr @ r@ + c!
r> 1 chars + rot rot
else
2drop
2dup + decode-ptr @ r@ + 3 cmove
r> 3 chars + rot rot
then
2 chars +
else
2dup + c@ decode-ptr @ r@ + c!
r> 1 chars + rot rot
\ cr ." debug:" decode-ptr @ code-len @ dump
then
1 chars +
repeat
2drop decode-ptr @ swap
;
\ Return value for CGI query string key.
\ Return 0 0 if key not found.
: qskeyval ( c-key u-key-len -- c-value u-value-len )
dup
s" QUERY_STRING" getenv
dup if
rot over swap - 2 < if
\ Query string not long enough for key=value
2drop 2drop 0 0
else
\ search for key string in query
2swap
( c-querystr u-querystr-len c-key u-key-len )
\ Set key search string
here keystr-ptr !
dup 2 + dup keystr-len !
chars dup allot
[char] = swap keystr-ptr @ + !
[char] & keystr-ptr !
keystr-ptr @ 1 chars + swap cmove
( c-querystr u-querystr-len )
\ Check for key at beginning of query string
2dup keystr-ptr @ 1 chars + keystr-len @ 1-
string-prefix? if
\ Extract 1st value string
here valstr-ptr !
else
\ Search query string for full key
then
then
else
\ QUERY_STRING not defined
2swap 2drop rot drop
then
;
\ 2013/10/21 New start: Following may be useful even if above
\ is discarded ...
create cgiKey 521 allot
create cgiKeyLen 521 allot
create cgiValue 521 allot
create cgiValueLen 521 allot
-1 variable cgiLastField
: cgiParseQuery { a-query u -- }
2dup [char] & scan
;

33
cgitest.cgi_ Executable file
View File

@ -0,0 +1,33 @@
#! /usr/pkg/bin/gforth-fast
\ forthtest.cgi - Test driver for html5cgi.fs
include html5cgi.fs
: main ( -- )
0
s" Document Title" $alloc *title* *head*
0
s" Level 1 Heading" $alloc *h1*
s" Level 2 Heading" $alloc *h2*
s" Level 3 Heading" $alloc *h3*
s" Level 4 Heading" $alloc *h4*
s" Level 5 Heading" $alloc *h5*
s" Level 6 Heading" $alloc *h6*
*body* *html* *http-html5*
;
main
c$type
\ bye

33
chronograph.fs Executable file
View File

@ -0,0 +1,33 @@
\ chronograph.fs
\ Date and time conversion and arithmetic
What I want:
Enter: s" 2005-09-16 18:30:55" jst
Returns: corresponding Unix time (s?, ms?, double?, float?)
Enter: -> mdt
Displays: ISO time string corr. to TOS Unix time in given zone
Enter: s" 06:40:00" today
Returns: Unix time for given time on current date local zone
Enter: now
Returns: current Unix time
(if time kept in ms, use utime instead)
Leap year (Gregorian calendar): years divisible by 4 but not by 100 plus years divisible by 400
: leapyear? ( u -- f )
dup 4 mod
if drop false
else dup 100 mod
if drop true
else 400 mod
if false
else true
then
then
then ;

85
cora-help.txt Executable file
View File

@ -0,0 +1,85 @@
Coraphyco - COnversion RAtios and PHYsical COnstnts in Forth
Words and constants for converting amounts between measurement
units.
GLOSSARY
-> r1 r2 r3 -- cora `convert'
Convert quantity r1 of units r2 to units r3 and display results.
r1 must be floating-point type (append `e' to decimal
representation). r2 and r3 are the base unit conversion factors
for r1 units and target units, respectively. Constants hve been
defined for a wide variety of units (See `help-const').
->E r1 r2 r3 -- cora `convert-E'
Convert quantity r1 of units r2 to units r3 and display results
in engineering notation. See `->'.
MKS r1 r2 -- cora `M-K-S'
Convert quantity r1 of units r2 to units r2 base units (m, kg,
ms, ...) and display results.
C>F r -- cora `C-to-F'
Convert Celcius temperature to Fahrenheit and display result.
F>C r -- cora `F-to-C'
Convert Fahrenheit temperature to Celcius and display result.
HELP -- cora `help'
Display this help text.
CONSTANTS
Linear measure (length/distance) (Standard unit: M))
M meter FT foot NMI nautical mile
KM kilometer IN inch AU astronomical unit
CM centimeter YD yard LY light year
MM millimeter MI mile PC parsec
Mass (standard unit: KG)
KG kilogram MT tonne/metric ton T ton
G gram LB pound OZ ounce
Time (standard unit: MS)
MS millisecond HR hour WK week
S second DAY YR year
MINUTE
Angle (standard unit: radian (dimensionless))
CIRCLE AMIN arc minute ASEC arc second
DEG degree
Area (standard unit: M^2)
M^2 square meter ACRE HECTARE
FT^2 square feet ARE
Volume (standard unit: M^3)
M^3 cubic meter PT pint TBSP tablespoon
CC cubic centimeter FLOZ fluid ounce TSP teaspoon
IN^3 cubic inch BBL petroleum barrel L liter
GAL gallon CUP ML milliliter
QT quart
Speed (standard unit: M/S)
M/S meters per second MACH speed of sound (STP)
C light in vacuum
Acceleration (standard unit: M/S^2)
M/S^2 meters per second per second
GEE standard gravitational acceleration

138
cora.fs Executable file
View File

@ -0,0 +1,138 @@
\ cora.fs -- Coraphyco COnversion RAtios and PHYsical COnstants in Forth
\ Version 1.1
\ 2010/7/13 David Meyer <papa@freeshell.org>
\ Coraphyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ This version is a simple implementation providing Forth constants
\ for conversion and physical quantities and a few words to simplify
\ display and conversion.
\ Display quantity r1 of units r2 in standard unit amount
: mks ( r1 r2 -- ) F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
: -> ( r1 r2 r3 -- ) F/ F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
\ in engineering notation
: ->e ( r1 r2 r3 -- ) F/ F* FE. ;
\ Convert Celcius temperature to Fahrenheit
: c>f ( r -- ) 9e0 f* 5e0 f/ 32e0 f+ f. ;
\ Convert Fahrenheit temperature to Celcius
: f>c ( r -- ) 32e0 f- 5e0 f* 9e0 f/ f. ;
\ Online help
: help ( -- )
( Eventually print/page help file ...
s" /usr/mnt.rom/card/Documents/Cavenet_Files/green/forth/cora-help.txt" r/o open-file throw Value fd-in
begin
line-buffer max-line fd-in read-line throw
while
type
repeat ;
)
cr ." (See file cora-help.txt for help.)"
cr ;
\ Speed (standard unit: m/s (meters per second)
1e0 FCONSTANT m/s \ meters per second (standard)
331.46e0 FCONSTANT mach \ speed of sound in dry air at STP
299792458e0 FCONSTANT c \ light in vacuum
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 FCONSTANT m/s^2 \ meters per second per second (standard)
980665e-5 FCONSTANT gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 FCONSTANT s \ second (standard)
60e0 60e0 F* FCONSTANT hr \ hour
24e0 hr F* FCONSTANT day \ day
\ Use ms as standard time unit to match Forth -
\ Replace s, hr, day above with following:
\ Also switch from float to double}
1e FCONSTANT ms \ millisecond (standard)
1e3 FCONSTANT s \ second
60e s F* FCONSTANT minute \ minute
60e minute F* FCONSTANT hr \ hour
24e hr F* FCONSTANT day \ day
7e day F* FCONSTANT wk \ week
365.25e day F* FCONSTANT yr \ year (average)
: monthms ( uyear umonth -- r )
dup 2 =
;
\ Angular measure (standard unit: radian (dimensionless))
2e0 pi F* FCONSTANT circle
circle 360e0 F/ FCONSTANT deg \ degree
deg 60e0 F/ FCONSTANT amin \ arc minute
amin 60e0 F/ FCONSTANT asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 FCONSTANT m \ meter (standard)
1e3 FCONSTANT km \ kilometer
1e-2 FCONSTANT cm \ centimeter
1e-3 FCONSTANT mm \ millimeter
3048e-4 FCONSTANT ft \ foot
ft 12e0 F/ FCONSTANT in \ inch
3e0 ft F* FCONSTANT yd \ yard
5280e0 ft F* FCONSTANT mi \ mile
1852e0 FCONSTANT nmi \ nautical mile
149597870691e0 FCONSTANT au \ astronomical unit
365.25e0 day F* c F* FCONSTANT ly \ light year
au asec F/ FCONSTANT pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 FCONSTANT m^2 \ square meter (standard)
ft ft F* FCONSTANT ft^2 \ square feet
43560e0 ft^2 F* FCONSTANT acre \ acre
1e2 FCONSTANT are \ are
1e4 FCONSTANT hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 FCONSTANT m^3 \ cubic meter (standard)
1e-6 FCONSTANT cc \ cubic centimeter
in in in F* F* FCONSTANT in^3 \ cubic inch
231e0 in^3 F* FCONSTANT gal \ gallon
gal 4e0 F/ FCONSTANT qt \ quart
qt 2e0 F/ FCONSTANT pt \ pint
pt 16e0 F/ FCONSTANT floz \ fluid ounce
42e0 gal F* FCONSTANT bbl \ petroleum barrel
8e0 floz F* FCONSTANT cup \ cup
cup 16e0 F/ FCONSTANT tbsp \ tablespoon
tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
1e3 cc F* FCONSTANT l \ liter
cc FCONSTANT ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 FCONSTANT kg \ kilogram (standard)
1e-3 FCONSTANT g \ gram
1e3 FCONSTANT mt \ tonne, metric ton
45359237e-8 FCONSTANT lb \ pound
2e3 lb F* FCONSTANT t \ ton
lb 16e0 F/ FCONSTANT oz \ ounce
\ Print opening greeting
cr ." *********************************************************************"
cr ." *** Welcome to Coraphyco. Type `help' for help ***"
cr ." *********************************************************************" cr

103
cora_0.fs Executable file
View File

@ -0,0 +1,103 @@
\ cora.fs -- Cora Phyco package of conversion ratios and physical constants
\ Version 0
\ 2005/9/9 David Meyer
\ Cora Phyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ This version is a simple implementation providing Forth constants
\ for conversion and physical quantities and a few words to simplify
\ display and conversion.
.( Loading Cora Phyco version 0 ... )
\ Display quantity r1 of units r2 in standard unit amount
: mks ( r1 r2 -- ) F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
: -> ( r1 r2 r3 -- ) F/ F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
\ in engineering notation
: ->e ( r1 r2 r3 -- ) F/ F* FE. ;
\ Speed (standard unit: m/s (meters per second)
1e0 FCONSTANT m/s \ meters per second (standard)
331.46e0 FCONSTANT mach \ speed of sound in dry air at STP
299792458e0 FCONSTANT c \ light in vacuum
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 FCONSTANT m/s^2 \ meters per second per second (standard)
980665e-5 FCONSTANT gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 FCONSTANT s \ second (standard)
60e0 60e0 F* FCONSTANT hr \ hour
24e0 hr F* FCONSTANT day \ day
\ Angular measure (standard unit: radian (dimensionless))
2e0 pi F* FCONSTANT circle
circle 360e0 F/ FCONSTANT deg \ degree
deg 60e0 F/ FCONSTANT amin \ arc minute
amin 60e0 F/ FCONSTANT asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 FCONSTANT m \ meter (standard)
1e3 FCONSTANT km \ kilometer
1e-2 FCONSTANT cm \ centimeter
1e-3 FCONSTANT mm \ millimeter
3048e-4 FCONSTANT ft \ foot
ft 12e0 F/ FCONSTANT in \ inch
3e0 ft F* FCONSTANT yd \ yard
5280e0 ft F* FCONSTANT mi \ mile
1852e0 FCONSTANT nmi \ nautical mile
149597870691e0 FCONSTANT au \ astronomical unit
365.25e0 day F* c F* FCONSTANT ly \ light year
au asec F/ FCONSTANT pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 FCONSTANT m^2 \ square meter (standard)
ft ft F* FCONSTANT ft^2 \ square feet
43560e0 ft^2 F* FCONSTANT acre \ acre
1e2 FCONSTANT are \ are
1e4 FCONSTANT hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 FCONSTANT m^3 \ cubic meter (standard)
1e-6 FCONSTANT cc \ cubic centimeter
in in in F* F* FCONSTANT in^3 \ cubic inch
231e0 in^3 F* FCONSTANT gal \ gallon
gal 4e0 F/ FCONSTANT qt \ quart
qt 2e0 F/ FCONSTANT pt \ pint
pt 16e0 F/ FCONSTANT floz \ fluid ounce
42e0 gal F* FCONSTANT bbl \ petroleum barrel
8e0 floz F* FCONSTANT cup \ cup
cup 16e0 F/ FCONSTANT tbsp \ tablespoon
tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
1e3 cc F* FCONSTANT l \ liter
cc FCONSTANT ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 FCONSTANT kg \ kilogram (standard)
1e-3 FCONSTANT g \ gram
1e3 FCONSTANT mt \ tonne, metric ton
45359237e-8 FCONSTANT lb \ pound
2e3 lb F* FCONSTANT t \ ton
lb 16e0 F/ FCONSTANT oz \ ounce
.( done) cr

137
cora_1.fs Executable file
View File

@ -0,0 +1,137 @@
\ cora.fs -- Cora Phyco package of conversion ratios and physical constants
\ Version 1
\ 2005/9/9 David Meyer
\ Cora Phyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ This version creates a word for each measurement unit that both holds the
\ unit's conversion factor and converts the quantity at TOS. Physical constants
\ are represented as Forth constants.
.( Loading Cora Phyco version 1 ...)
\ Pending unit conversion flag
VARIABLE <cvt> FALSE <cvt> !
\ Pending display engineering notation flag
VARIABLE <eng> FALSE <eng> !
\ Store unit conversion factor r as float. On reference convert r1 quantity to
\ r2 standard units or display r1 quantity converted to target units.
: unit ( r "name" -- )
CREATE F,
DOES> ( r1 -- r2| )
<cvt> @
IF F@ F/ <eng> @ IF FE. FALSE <eng> ! ELSE F. THEN FALSE <cvt> !
ELSE F@ F* THEN ;
\ Set conversion flag
: -> ( -- ) TRUE <cvt> ! ;
\ Set conversion and engineering notation flags
: ->e ( -- ) TRUE DUP <cvt> ! <eng> ! ;
\ Physical constants (standard units)
2e0 pi F* FCONSTANT circle \ radians per full circle angle
299792458e0 FCONSTANT c \ speed of light in vacuum (m/s)
\ Speed (standard unit: m/s (meters per second)
1e0 unit m/s \ meters per second (standard)
331.46e0 unit mach \ speed of sound in dry air at STP
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 unit m/s^2 \ meters per second per second (standard)
980665e-5 unit gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 unit s \ second (standard)
60e0 60e0 F* unit hr \ hour
24e0 hr unit day \ day
\ Angular measure (standard unit: radian (dimensionless))
circle 360e0 F/ unit deg \ degree
1e0 deg 60e0 F/ unit amin \ arc minute
1e0 amin 60e0 F/ unit asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 unit m \ meter (standard)
1e3 unit km \ kilometer
1e-2 unit cm \ centimeter
1e-3 unit mm \ millimeter
3048e-4 unit ft \ foot
1e0 ft 12e0 F/ unit in \ inch
3e0 ft unit yd \ yard
5280e0 ft unit mi \ mile
1852e0 unit nmi \ nautical mile
149597870691e0 unit au \ astronomical unit
365.25e0 day c F* unit ly \ light year
1e0 au 1e0 asec F/ unit pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 unit m^2 \ square meter (standard)
1e0 ft 2e0 F** unit ft^2 \ square feet
43560e0 ft^2 unit acre \ acre
1e2 unit are \ are
1e4 unit hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 unit m^3 \ cubic meter (standard)
1e-6 unit cc \ cubic centimeter
1e0 in 3e0 F** unit in^3 \ cubic inch
231e0 in^3 unit gal \ gallon
1e0 gal 4e0 F/ unit qt \ quart
1e0 qt 2e0 F/ unit pt \ pint
1e0 pt 16e0 F/ unit floz \ fluid ounce
42e0 gal unit bbl \ petroleum barrel
8e0 floz unit cup \ cup
1e0 cup 16e0 F/ unit tbsp \ tablespoon
1e0 tbsp 3e0 F/ unit tsp \ teaspoon
1e3 cc unit l \ liter
1e0 cc unit ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 unit kg \ kilogram (standard)
1e-3 unit g \ gram
1e3 unit mt \ tonne, metric ton
45359237e-8 unit lb \ pound
2e3 lb unit t \ ton
1e0 lb 16e0 F/ unit oz \ ounce
\ Temperature (standard system: Kelvin)
1e0 unit kel \ Kelvin (standard)
5e0 9e0 f/ FCONSTANT degfah \ Fahrenheit degree
255.372e0 FCONSTANT 0fah \ 0 degrees Fahrenheit
273.15e0 FCONSTANT 0cel \ 0 degrees Celsius
: fah ( r1 -- r2| )
<cvt> @
IF 0fah F- degfah F/ F. FALSE <cvt> !
ELSE degfah F* 0fah F+ THEN ;
: cel ( r1 -- r2| )
<cvt> @
IF 0cel F- F. FALSE <cvt> !
ELSE 0cel F+ THEN ;
.( done) cr

114
cora_2.fs Executable file
View File

@ -0,0 +1,114 @@
\ cora.fs -- Cora Phyco package of conversion ratios and physical constants
\ Version 1.0
\ 2005/9/9 David Meyer
\ Cora Phyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ This version is a simple implementation providing Forth constants
\ for conversion and physical quantities and a few words to simplify
\ display and conversion.
\ Display quantity r1 of units r2 in standard unit amount
: mks ( r1 r2 -- ) F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
: -> ( r1 r2 r3 -- ) F/ F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
\ in engineering notation
: ->e ( r1 r2 r3 -- ) F/ F* FE. ;
\ Speed (standard unit: m/s (meters per second)
1e0 FCONSTANT m/s \ meters per second (standard)
331.46e0 FCONSTANT mach \ speed of sound in dry air at STP
299792458e0 FCONSTANT c \ light in vacuum
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 FCONSTANT m/s^2 \ meters per second per second (standard)
980665e-5 FCONSTANT gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 FCONSTANT s \ second (standard)
60e0 60e0 F* FCONSTANT hr \ hour
24e0 hr F* FCONSTANT day \ day
\ Use ms as standard time unit to match Forth -
\ Replace s, hr, day above with following:
\ Also switch from float to double}
1e FCONSTANT ms \ millisecond (standard)
1e3 FCONSTANT s \ second
60e s F* FCONSTANT minute \ minute
60e minute F* FCONSTANT hr \ hour
24e hr F* FCONSTANT day \ day
7e day F* FCONSTANT wk \ week
: monthms ( uyear umonth -- r )
dup 2 =
;
\ Angular measure (standard unit: radian (dimensionless))
2e0 pi F* FCONSTANT circle
circle 360e0 F/ FCONSTANT deg \ degree
deg 60e0 F/ FCONSTANT amin \ arc minute
amin 60e0 F/ FCONSTANT asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 FCONSTANT m \ meter (standard)
1e3 FCONSTANT km \ kilometer
1e-2 FCONSTANT cm \ centimeter
1e-3 FCONSTANT mm \ millimeter
3048e-4 FCONSTANT ft \ foot
ft 12e0 F/ FCONSTANT in \ inch
3e0 ft F* FCONSTANT yd \ yard
5280e0 ft F* FCONSTANT mi \ mile
1852e0 FCONSTANT nmi \ nautical mile
149597870691e0 FCONSTANT au \ astronomical unit
365.25e0 day F* c F* FCONSTANT ly \ light year
au asec F/ FCONSTANT pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 FCONSTANT m^2 \ square meter (standard)
ft ft F* FCONSTANT ft^2 \ square feet
43560e0 ft^2 F* FCONSTANT acre \ acre
1e2 FCONSTANT are \ are
1e4 FCONSTANT hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 FCONSTANT m^3 \ cubic meter (standard)
1e-6 FCONSTANT cc \ cubic centimeter
in in in F* F* FCONSTANT in^3 \ cubic inch
231e0 in^3 F* FCONSTANT gal \ gallon
gal 4e0 F/ FCONSTANT qt \ quart
qt 2e0 F/ FCONSTANT pt \ pint
pt 16e0 F/ FCONSTANT floz \ fluid ounce
42e0 gal F* FCONSTANT bbl \ petroleum barrel
8e0 floz F* FCONSTANT cup \ cup
cup 16e0 F/ FCONSTANT tbsp \ tablespoon
tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
1e3 cc F* FCONSTANT l \ liter
cc FCONSTANT ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 FCONSTANT kg \ kilogram (standard)
1e-3 FCONSTANT g \ gram
1e3 FCONSTANT mt \ tonne, metric ton
45359237e-8 FCONSTANT lb \ pound
2e3 lb F* FCONSTANT t \ ton
lb 16e0 F/ FCONSTANT oz \ ounce

138
cora_3.fs Executable file
View File

@ -0,0 +1,138 @@
\ cora.fs -- Coraphyco COnversion RAtios and PHYsical COnstants in Forth
\ Version 1.1
\ 2010/7/13 David Meyer <papa@freeshell.org>
\ Coraphyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ This version is a simple implementation providing Forth constants
\ for conversion and physical quantities and a few words to simplify
\ display and conversion.
\ Display quantity r1 of units r2 in standard unit amount
: mks ( r1 r2 -- ) F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
: -> ( r1 r2 r3 -- ) F/ F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
\ in engineering notation
: ->e ( r1 r2 r3 -- ) F/ F* FE. ;
\ Convert Celcius temperature to Fahrenheit
: c>f ( r -- ) 9e0 f* 5e0 f/ 32e0 f+ f. ;
\ Convert Fahrenheit temperature to Celcius
: f>c ( r -- ) 32e0 f- 5e0 f* 9e0 f/ f. ;
\ Online help
: help ( -- )
( Eventually print/page help file ...
s" /usr/mnt.rom/card/Documents/Cavenet_Files/green/forth/cora-help.txt" r/o open-file throw Value fd-in
begin
line-buffer max-line fd-in read-line throw
while
type
repeat ;
)
cr ." (See file cora-help.txt for help.)"
cr ;
\ Speed (standard unit: m/s (meters per second)
1e0 FCONSTANT m/s \ meters per second (standard)
331.46e0 FCONSTANT mach \ speed of sound in dry air at STP
299792458e0 FCONSTANT c \ light in vacuum
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 FCONSTANT m/s^2 \ meters per second per second (standard)
980665e-5 FCONSTANT gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 FCONSTANT s \ second (standard)
60e0 60e0 F* FCONSTANT hr \ hour
24e0 hr F* FCONSTANT day \ day
\ Use ms as standard time unit to match Forth -
\ Replace s, hr, day above with following:
\ Also switch from float to double}
1e FCONSTANT ms \ millisecond (standard)
1e3 FCONSTANT s \ second
60e s F* FCONSTANT minute \ minute
60e minute F* FCONSTANT hr \ hour
24e hr F* FCONSTANT day \ day
7e day F* FCONSTANT wk \ week
365.25e day F* FCONSTANT yr \ year (average)
: monthms ( uyear umonth -- r )
dup 2 =
;
\ Angular measure (standard unit: radian (dimensionless))
2e0 pi F* FCONSTANT circle
circle 360e0 F/ FCONSTANT deg \ degree
deg 60e0 F/ FCONSTANT amin \ arc minute
amin 60e0 F/ FCONSTANT asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 FCONSTANT m \ meter (standard)
1e3 FCONSTANT km \ kilometer
1e-2 FCONSTANT cm \ centimeter
1e-3 FCONSTANT mm \ millimeter
3048e-4 FCONSTANT ft \ foot
ft 12e0 F/ FCONSTANT in \ inch
3e0 ft F* FCONSTANT yd \ yard
5280e0 ft F* FCONSTANT mi \ mile
1852e0 FCONSTANT nmi \ nautical mile
149597870691e0 FCONSTANT au \ astronomical unit
365.25e0 day F* c F* FCONSTANT ly \ light year
au asec F/ FCONSTANT pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 FCONSTANT m^2 \ square meter (standard)
ft ft F* FCONSTANT ft^2 \ square feet
43560e0 ft^2 F* FCONSTANT acre \ acre
1e2 FCONSTANT are \ are
1e4 FCONSTANT hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 FCONSTANT m^3 \ cubic meter (standard)
1e-6 FCONSTANT cc \ cubic centimeter
in in in F* F* FCONSTANT in^3 \ cubic inch
231e0 in^3 F* FCONSTANT gal \ gallon
gal 4e0 F/ FCONSTANT qt \ quart
qt 2e0 F/ FCONSTANT pt \ pint
pt 16e0 F/ FCONSTANT floz \ fluid ounce
42e0 gal F* FCONSTANT bbl \ petroleum barrel
8e0 floz F* FCONSTANT cup \ cup
cup 16e0 F/ FCONSTANT tbsp \ tablespoon
tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
1e3 cc F* FCONSTANT l \ liter
cc FCONSTANT ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 FCONSTANT kg \ kilogram (standard)
1e-3 FCONSTANT g \ gram
1e3 FCONSTANT mt \ tonne, metric ton
45359237e-8 FCONSTANT lb \ pound
2e3 lb F* FCONSTANT t \ ton
lb 16e0 F/ FCONSTANT oz \ ounce
\ Print opening greeting
cr ." *********************************************************************"
cr ." *** Welcome to Coraphyco. Type `help' for help ***"
cr ." *********************************************************************" cr

276
cora_4.0.fs Executable file
View File

@ -0,0 +1,276 @@
\ cora_4.0.fs -- Coraphyco COnversion RAtios and PHYsical COnstants
\ Version 4.0
\ 2011/6/14 David Meyer <papa@freeshell.org>
\ Coraphyco provides a Forth environment to facilitate conversion of
\ quantities among a large variety of measurement units and systems.
\ Inspired by Frink by Allan Eliasen.
\ Changes in version 4.0
\ - Convert to integer arithmetic from floating-point for
\ portability and usability.
\ - Rewrite user interface to present unique word for each
\ conversion instead of unit-to-base constants and generic
\ conversion word ->.
\ Notes:
\ - On Zaurus, one cell is four bytes, therefore max. single-
\ precision integer is $ffffffff = 4294967295 (unsigned) or
\ $7fffffff = 2147483647 (signed)
\ - NetBSD (SDF) compilation uses eight-byte cells. Max. single-
\ precision integer: $ffffffffffffffff = 18446744073709551615
\ (unsigned), $7fffffffffffffff = 9223372036854775807 (signed)
\ - Largest conversion ratio: parsec:mm (30856775813057300000.)
\ (requires double-precision for integer arith., even on SDF)
: *pi ( n -- PI*n )
\ Chick Moore's multiply-by-pi
355 113 */ ;
\ Volume (standard unit: m^3 (cubic meter))
: cc>m^3 ( n-cc -- m-m^3 ) 1000000 / ;
\ 1e0 FCONSTANT m^3 \ cubic meter (standard)
\ 1e-6 FCONSTANT cc \ cubic centimeter
\ in in in F* F* FCONSTANT in^3 \ cubic inch
\ 231e0 in^3 F* FCONSTANT gal \ gallon
\ gal 4e0 F/ FCONSTANT qt \ quart
\ qt 2e0 F/ FCONSTANT pt \ pint
\ pt 16e0 F/ FCONSTANT floz \ fluid ounce
\ 42e0 gal F* FCONSTANT bbl \ petroleum barrel
\ 8e0 floz F* FCONSTANT cup \ cup
\ cup 16e0 F/ FCONSTANT tbsp \ tablespoon
\ tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
\ 1e3 cc F* FCONSTANT l \ liter
\ cc FCONSTANT ml \ milliliter
\ Distance
: in>cm 254 100 */ ;
: in>ft 12 / ;
: in>km 254 10000000 */ ;
: in>m 254 10000 */ ;
: in>mi 64560 / ;
: in>mm 254 10 */ ;
: in>nmi 254 18520000 */ ;
: in>yd 36 / ;
: ft>cm 774720 100 */ ;
: ft>in 12 * ;
: ft>km 774720 10000000 */ ;
: ft>m 774720 10000 */ ;
: ft>mi 5280 / ;
: ft>mm 774720 10 */ ;
: ft>nmi 774720 18520000 */ ;
: ft>yd 3 / ;
: yd>cm 9144 100 */ ;
: yd>ft 3 * ;
: yd>in 36 * ;
: yd>km 9144 10000000 */ ;
: yd>m 9144 10000 */ ;
: yd>mi 1760 / ;
: yd>mm 9144 10 */ ;
: yd>nmi 9144 18520000 */ ;
: mi>cm 16398240 100 */ ;
: mi>ft 5280 * ;
: mi>in 64560 * ;
: mi>km 16398240 10000000 */ ;
: mi>m 16398240 10000 */ ;
: mi>mm 16398240 10 */ ;
: mi>nmi 16398240 18520000 */ ;
: mi>yd 1760 * ;
: mm>cm 10 / ;
: mm>ft 10 3048 */ ;
: mm>in 10 254 */ ;
: mm>km 1000000 / ;
: mm>m 1000 / ;
: mm>mi 10 16398240 */ ;
: mm>nmi 1852000 / ;
: mm>yd 10 9144 */ ;
: cm>ft 100 3048 */ ;
: cm>in 100 254 */ ;
: cm>km 100000 / ;
: cm>m 100 / ;
: cm>mi 100 16398240 */ ;
: cm>mm 10 * ;
: cm>nmi 185200 / ;
: cm>yd 100 9144 */ ;
: m>cm 100 * ;
: m>ft 10000 3048 */ ;
: m>in 10000 254 */ ;
: m>km 1000 / ;
: m>mi 10000 16398240 */ ;
: m>mm 1000 * ;
: m>nmi 1852 / ;
: m>yd 10000 9144 */ ;
: km>cm 100000 * ;
: km>ft 10000000 3048 */ ;
: km>in 10000000 254 */ ;
: km>m 1000 * ;
: km>mi 10000000 16398240 */ ;
: km>mm 1000000 * ;
: km>nmi 1000 1852 */ ;
: km>yd 10000000 9144 */ ;
: nmi>cm 185200 * ;
: nmi>ft 18520000 3048 */ ;
: nmi>in 18520000 254 */ ;
: nmi>km 1852 1000 */ ;
: nmi>m 1852 * ;
: nmi>mi 18520000 16398240 */ ;
: nmi>mm 1852000 * ;
: nmi>yd 18520000 9144 */ ;
\ Linear measure (standard unit: m (meter))
\ 1e0 FCONSTANT m \ meter (standard)
\ 1e3 FCONSTANT km \ kilometer
\ 1e-2 FCONSTANT cm \ centimeter
\ 1e-3 FCONSTANT mm \ millimeter
\ 3048e-4 FCONSTANT ft \ foot
\ ft 12e0 F/ FCONSTANT in \ inch
\ 3e0 ft F* FCONSTANT yd \ yard
\ 5280e0 ft F* FCONSTANT mi \ mile
\ 1852e0 FCONSTANT nmi \ nautical mile
\ 149597870691e0 FCONSTANT au \ astronomical unit
\ 365.25e0 day F* c F* FCONSTANT ly \ light year
\ au asec F/ FCONSTANT pc \ parsec
\ Display quantity r1 of units r2 in standard unit amount
: mks ( r1 r2 -- ) F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
: -> ( r1 r2 r3 -- ) F/ F* F. ;
\ Convert quantity r1 from r2 units to r3 units and display
\ in engineering notation
: ->e ( r1 r2 r3 -- ) F/ F* FE. ;
\ Convert Celcius temperature to Fahrenheit
: c>f ( r -- ) 9e0 f* 5e0 f/ 32e0 f+ f. ;
\ Convert Fahrenheit temperature to Celcius
: f>c ( r -- ) 32e0 f- 5e0 f* 9e0 f/ f. ;
\ Online help
: help ( -- )
( Eventually print/page help file ...
s" /usr/mnt.rom/card/Documents/Cavenet_Files/green/forth/cora-help.txt" r/o open-file throw Value fd-in
begin
line-buffer max-line fd-in read-line throw
while
type
repeat ;
)
cr ." (See file cora-help.txt for help.)"
cr ;
\ Speed (standard unit: m/s (meters per second)
1e0 FCONSTANT m/s \ meters per second (standard)
331.46e0 FCONSTANT mach \ speed of sound in dry air at STP
299792458e0 FCONSTANT c \ light in vacuum
\ Acceleration (standard unit: m/s^2 (meters per second per second)
1e0 FCONSTANT m/s^2 \ meters per second per second (standard)
980665e-5 FCONSTANT gee \ standard gravitational acceleration
\ Time (standard unit: s (second))
1e0 FCONSTANT s \ second (standard)
60e0 60e0 F* FCONSTANT hr \ hour
24e0 hr F* FCONSTANT day \ day
\ Use ms as standard time unit to match Forth -
\ Replace s, hr, day above with following:
\ Also switch from float to double}
1e FCONSTANT ms \ millisecond (standard)
1e3 FCONSTANT s \ second
60e s F* FCONSTANT minute \ minute
60e minute F* FCONSTANT hr \ hour
24e hr F* FCONSTANT day \ day
7e day F* FCONSTANT wk \ week
365.25e day F* FCONSTANT yr \ year (average)
: monthms ( uyear umonth -- r )
dup 2 =
;
\ Angular measure (standard unit: radian (dimensionless))
2e0 pi F* FCONSTANT circle
circle 360e0 F/ FCONSTANT deg \ degree
deg 60e0 F/ FCONSTANT amin \ arc minute
amin 60e0 F/ FCONSTANT asec \ arc second
\ Linear measure (standard unit: m (meter))
1e0 FCONSTANT m \ meter (standard)
1e3 FCONSTANT km \ kilometer
1e-2 FCONSTANT cm \ centimeter
1e-3 FCONSTANT mm \ millimeter
3048e-4 FCONSTANT ft \ foot
ft 12e0 F/ FCONSTANT in \ inch
3e0 ft F* FCONSTANT yd \ yard
5280e0 ft F* FCONSTANT mi \ mile
1852e0 FCONSTANT nmi \ nautical mile
149597870691e0 FCONSTANT au \ astronomical unit
365.25e0 day F* c F* FCONSTANT ly \ light year
au asec F/ FCONSTANT pc \ parsec
\ Area (standard unit: m^2 (square meter))
1e0 FCONSTANT m^2 \ square meter (standard)
ft ft F* FCONSTANT ft^2 \ square feet
43560e0 ft^2 F* FCONSTANT acre \ acre
1e2 FCONSTANT are \ are
1e4 FCONSTANT hectare \ hectare
\ Volume (standard unit: m^3 (cubic meter))
1e0 FCONSTANT m^3 \ cubic meter (standard)
1e-6 FCONSTANT cc \ cubic centimeter
in in in F* F* FCONSTANT in^3 \ cubic inch
231e0 in^3 F* FCONSTANT gal \ gallon
gal 4e0 F/ FCONSTANT qt \ quart
qt 2e0 F/ FCONSTANT pt \ pint
pt 16e0 F/ FCONSTANT floz \ fluid ounce
42e0 gal F* FCONSTANT bbl \ petroleum barrel
8e0 floz F* FCONSTANT cup \ cup
cup 16e0 F/ FCONSTANT tbsp \ tablespoon
tbsp 3e0 F/ FCONSTANT tsp \ teaspoon
1e3 cc F* FCONSTANT l \ liter
cc FCONSTANT ml \ milliliter
\ Mass (standard unit: kg (kilogram))
1e0 FCONSTANT kg \ kilogram (standard)
1e-3 FCONSTANT g \ gram
1e3 FCONSTANT mt \ tonne, metric ton
45359237e-8 FCONSTANT lb \ pound
2e3 lb F* FCONSTANT t \ ton
lb 16e0 F/ FCONSTANT oz \ ounce
\ Print opening greeting
cr ." *********************************************************************"
cr ." *** Welcome to Coraphyco. Type `help' for help ***"
cr ." *********************************************************************" cr

4
corai.fs Executable file
View File

@ -0,0 +1,4 @@
\ corai.fs - Cora Phyco with integer math
: s>hr ( i -- ) 3600 / ;
: s>day ( i -- )

67
date.fs Executable file
View File

@ -0,0 +1,67 @@
\ date.fs - Date arithmetic Forth module
\
\ Copyright 2015 David Meyer <papa@sdf.org> +JMJ
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
\
\ Source for Julian Day calculation algorithms:
\ "Julian day". Wikipedia The Free Encyclopedia. Modified 2015/9/21.
\ Wikimedia Foundation. Accessed 2015/9/26
\ <https://en.wikipedia.org/wiki/Julian_day>
variable a
variable jy
variable jm
variable n2
variable f
variable e
variable g
variable h
\ jdn - Convert Gregorian date y m d to Julian Day Number
: jdn { y m d -- n }
14 m - 12 / a !
y 4800 + a @ - jy !
m 12 a @ * + 3 - jm !
d
jm @ 153 * 2 + 5 / +
jy @ 365 * +
jy @ 4 / +
jy @ 100 / -
jy @ 400 / +
32045 -
;
\ j>ymd - Convert Julian Day Number to Gregorian date y m d
: j>ymd { j -- y m d }
j 1401 +
j 4 * 274277 + 146097 / 3 * 4 / +
-38 + f !
f @ 4 * 3 + e !
e @ 1461 mod 4 / g !
g @ 5 * 2 + h !
h @ 153 / 2 + 12 mod 1+ ( month -- )
dup 14 swap - 12 / e @ 1461 / + 4716 - swap ( year month -- )
h @ 153 mod 5 / 1+
;
\ j>w1 - Day of week W1 (Sun=0) for JDN
: j>w1 ( n -- w1 )
1+ 7 mod
;
\ dtdiff - Compute difference in days between two Gregorian dates
: dtdiff ( y1 m1 d1 y2 m2 d2 -- n )
jdn n2 !
jdn n2 @ swap -
;

9
dmath.fs Executable file
View File

@ -0,0 +1,9 @@
\ dmath.fs -- double-precision math
\ doubles are stored on stack as two integers, n1 n2
\ d = n1 + 4294967296 * n2
\ Multiplication
: d* ( d1 d2 -- d1*d2 )
\ (n1 + c * n2)(n3 + c * n4)
\ n1*n3 + c*(n2*n3 + n1*n4) + c^2*n2*n4

2
dnw.blink Executable file
View File

@ -0,0 +1,2 @@
DNW's Forth Page
http://www-personal.umich.edu/~williams/archive/forth/forth.html

5
dot-gforth-iza.fs Executable file
View File

@ -0,0 +1,5 @@
\ .gforth.fs - Gforth initialization
include wareki.fs
include yuko.fs
cr

30
double-arith.fs Executable file
View File

@ -0,0 +1,30 @@
\ double-arith.fs - Double-precision arithmetic extensions
\ Copyright 2013 David Meyer <papa@sdf.org> +JMJ
\ Copying and distribution of this file, with or without
\ modification, are permitted in any medium without royalty
\ provided the copyright notice and this notice are preserved.
\ This file is offered as-is, without any warranty.
\ MAXU - Maximum value of unsigned single
s" MAX-U" environment? drop constant MAXU
\ md* - Multiply double by unsigned single (iterative method)
: md* ( d u -- d*u )
0. rot
0 u+do 2over d+ loop
2nip
;
\ mudu* - Multiply unsigned double by unsigned single
: mudu* ( ud u -- ud*u ) tuck * >r m* r> + ;
\ ud* - Multiply two unsigned doubles
: ud* ( ud1 ud2 -- ud1*ud2 )
{ a1 b1 a2 b2 }
a1 a2 um*
MAXU a1 um* b2 mudu* d+
MAXU a2 um* b1 mudu* d+
MAXU MAXU um* b1 mudu* b2 mudu* d+
;

46
f-strings.txt Executable file
View File

@ -0,0 +1,46 @@
Forth Strings
In order to flexibly generate HTML, Forth requires the ability to
construct strings of arbitrary length in memory by concatenating and
nesting multiple string segments.
There are several string-handling Forth modules available, but none
are straightforward, so I'm considering a custom module.
For string concatenation, my first idea was to allocated space
for the combined string for each concatenation, but I'm afraid
generation of a page of HTML in memory would require allocating
several times the final page size as each string segment is combined
and recombined several times into larger and larger sections or the
document.
An alternative idea is to allocate two buffers each of the estimated
maximum page size. Then all concatenations are expressed as appending
and/or prepending strings to the current pafe image. An appended
string could simply be copied to the end of the page buffer. To
prepend a string, the copy buffer would be initialized with the
string, page buffer contents appended, then the resulting combined
string copied back to the page buffer. Would have to track end of
page image within buffer. This would limit memory usage to twice the
estimated maximum page size, but would require a check for buffer
overflow on exceptionally large pages.
Current average size of *.html, *.txt, *.org files in cavenet
green dataset is approx. 2500 bytes. Average word count per file is
24000.
Another alternative: use an array of string addesses and one of
string lengths. Concatenate strings by appending or inserting
compiled string addresses and lengths in their respective arrays.
This would avoid duplication of strings and memory for them. Would
impose maximum on number of string segments that could comprise
a web page.
Taking as an upper estimate each word in a page requiring a start
and an end tag would make an average of approximately 72000 string
segments.
Of course, must ask if complexity of building strings in memory
before printing is justified versus just printing strings in
sequence as they occur in processing.

648
fig_reg.fth Executable file
View File

@ -0,0 +1,648 @@
\ #! /usr/local/bin/pfe -q
\ FIG_reg program to handle forms requests for joining FIG
\ This is an ANS Forth program requiring:
\ 1. The File Access word set.
\ 2. The word CMOVE from the String word set.
\ 3. A system dependent word GETENV to get the specified
\ environment string,
\ GETENV ( str count -- str' count' )
\ 4. The word STDIN to get the file ID of standard input.
\ 5. The words OPEN-PIPE and CLOSE-PIPE to open and close pipes to
\ processes. (These are communicated with via the normal File access
\ words).
\ 6. READ to write to Unix file descriptors (because of a problem with
\ ThisForth 94-09-12).
\ 7. The word : #! \ ; IMMEDIATE
\ (c) Copyright 1994 Everett F. Carter. Permission is granted by the
\ author to use this software for any application provided this
\ copyright notice is preserved.
\ rcsid: %W% %U% %G% EFC
TRUE CONSTANT ?DEBUG
TRUE CONSTANT ThisForth
FALSE CONSTANT PFE
ThisForth [IF]
\ =================== ANS File words for ThisForth =========================
\ file open modes
: R/W S" r+" ;
: R/O S" r" ;
: W/O S" w" ;
: APPEND S" a" ; \ NOT ANS, but necessary
: OPEN-FILE fopen DUP 0= ;
: READ-LINE ( addr u fileid -- u' flag ior )
STREAM
0 SWAP
0 DO
next-char EOL = IF LEAVE THEN
next-char EOF = IF LEAVE THEN
get-char
2 PICK I + C!
1+
LOOP
UNSTREAM
SWAP DROP TRUE 0
;
: READ-FILE ( addr u fileid -- u' flag ) \ a hack
STREAM
0 SWAP
0 DO
next-char EOF = IF LEAVE THEN
get-char
2 PICK I + C!
1+
LOOP
UNSTREAM
SWAP DROP FALSE
;
: REPOSITION-FILE ( d fid -- flag )
ROT ROT DROP 0
fseek
;
: WRITE-FILE ( c-addr u fileid -- ior )
DISPLAY TYPE
0 DISPLAY
TRUE
;
: WRITE-LINE ( c-addr u fileid -- ior )
DISPLAY TYPE CR
0 DISPLAY
TRUE
;
: CLOSE-FILE fclose ;
[THEN]
\ =========================================================================
ThisForth [IF] \ ThisForth version
: OPEN-APPEND
APPEND OPEN-FILE
;
[ELSE]
\ ANS Brute force OPEN-APPEND, depending upon what is under the hood, there may
\ be more efficient definitions
: OPEN-APPEND R/W OPEN-FILE
DUP 0= IF OVER FILE-SIZE
0= IF 3 PICK REPOSITION-FILE DROP THEN
THEN
;
[THEN]
FALSE VALUE bad-status
0 VALUE seq-file
0 VALUE log-file
0 VALUE seq-no
CREATE NEW-LINE-CHARS 2 ALLOT
10 NEW-LINE-CHARS C!
\ 13 NEW-LINE-CHARS 1+ C!
0 VALUE buf-len
0 VALUE input-buffer
VARIABLE scan-ptr
ALIGN
CREATE out-buf 32 ALLOT
\ ============= A String pointer data structure =============================
: string: \ build a counted string
CREATE
0 , \ POINTER to the data
0 , \ the count
DOES>
DUP @ SWAP CELL+ @
;
: $! ( addr count 'str -- ) \ store a string
>BODY
SWAP OVER CELL+ !
!
;
: $len ( addr count -- count )
SWAP DROP
;
: $copy ( addr count 'str -- )
HERE 2 PICK ROT $! \ store string pointer to HERE
HERE SWAP DUP ALLOT
CMOVE
;
: $cat ( addr1 count1 addr2 count2 -- addr count )
2 PICK OVER + DUP >R
HERE >R
ALLOT
2SWAP
R@ SWAP DUP >R CMOVE \ move first string
R> R@ +
SWAP CMOVE \ move the second string
R> R>
;
\ the data fields
string: first-name
string: last-name
string: street
string: city
string: state/prov
string: country
string: postal-code
string: phone
string: e-mail
string: www-page
\ ======================= LOCAL FILE NAMES ================================
string: SEQFILE
string: LOGFILE
string: PROGRAM
string: MAILER
string: HOSTNAME
string: DESTINATION
: init-strings
\ This is the name of the mail program, we are using URL escape codes
\ for quotes which will be converted to actual quotes later
\ S" /usr/ucb/Mail -s %22FIG Membership%22 johnhall@aol.com skip@taygeta.com "
S" /usr/ucb/Mail -s %22FIG Membership%22 skip@taygeta.com "
['] MAILER $copy
S" /usr/local/logs/figreg.seq" ['] SEQFILE $copy
S" /usr/local/logs/figreg.log" ['] LOGFILE $copy
S" %M% V%I%" ['] PROGRAM $copy
S" taygeta.com" ['] HOSTNAME $copy
S" johnhall@aol.com " ['] DESTINATION $copy
;
\ =========================================================================
: acknowledge ( -- )
." <HEADER><TITLE> Forth Interest Group Membership OK "
." </TITLE></HEADER> " CR
." Everything received <B>OK</B><P> " CR
." You will be contacted soon about billing information<P> "
." Your first issue of <I>Forth Dimensions</I> will arrive "
." in four to six weeks. " CR
." Subsequent issues will be mailed to you every other month "
." as they are published -- six issues in all. " CR
." <P><hr> " CR
." Note, dues are not deductible as a charitable contribution for "
." U.S. federal income tax purposes," CR ." but may be deductible as "
." a business expense. " CR
." <P><hr> " CR
." <A HREF=http://www.taygeta.com/fig.html> "
." <IMG SRC=" [CHAR] " EMIT
." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
." ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." > "
." Back to FIG Home page</A>. " CR
." <P> " CR
;
: nack ( -- )
." <HEADER><TITLE> Forth Interest Group Membership NOT OK "
." </TITLE></HEADER> " CR
." Sorry, There seems to be a problem with the form as you filled it out "
." <P><hr> " CR
." <A HREF=http://www.taygeta.com/fig/fig_member.html> "
." <IMG SRC=" [CHAR] " EMIT
." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
." ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." > "
." Back to FIG Membership Form page</A>. " CR
." <P> " CR
;
: sig
." <P><HR><ADDRESS><CENTER> " CR
." Everett F. Carter Jr. -- skip@taygeta.com" CR
." </CENTER></ADDRESS> " CR
;
: atol ( addr count -- d )
>R
0. ROT
R>
>NUMBER
2DROP
;
: atoi ( addr count -- n )
atol DROP
;
: move-chars ( dest src count -- dest count )
>R OVER R@ CMOVE R>
;
: itoa ( n -- addr count ) \ (signed) int to counted string
out-buf aligned SWAP
DUP >R ABS S>D
<# #S R> SIGN #>
move-chars
;
: newline ( fileid -- flag )
NEW-LINE-CHARS 1 ROT WRITE-FILE
;
: update_sequence_number ( -- old_no )
SEQFILE R/W OPEN-FILE ABORT" Unable to open sequence file "
TO seq-file
\ get the current sequence number
PAD 16 seq-file READ-LINE ABORT" file read error "
DROP
PAD SWAP atoi
\ increment the number and store it away
DUP 1+
0. seq-file REPOSITION-FILE DROP
itoa seq-file WRITE-LINE DROP
seq-file CLOSE-FILE DROP
;
: write-env ( -- len )
S" SERVER_PROTOCOL" getenv
DUP 0= IF 2DROP S" HTTP/1.0" THEN TYPE
." 200 OK" CR
." MIME-Version: 1.0" CR
S" SERVER_SOFTWARE" getenv
DUP 0 > IF TYPE CR ELSE 2DROP THEN
." Content-Type: text/html" CR
\ ." Content-Encoding: HTML" CR
\ ." Content-Transfer-Encoding: HTML" CR
CR
S" CONTENT_LENGTH" getenv
DUP IF atoi ELSE 2DROP 0 THEN
;
: plus->space ( addr count -- ) \ convert pluses to spaces
0 ?DO I OVER + C@ [CHAR] + = IF I OVER + BL SWAP C! THEN LOOP
DROP
;
: x2c ( addr count -- n )
HEX
>R 0. ROT R>
>NUMBER
2DROP DROP
DECIMAL
;
: unescape-url ( addr count -- count' )
-1 SWAP
0 ?DO
1+
OVER OVER + \ get &url[x]
2 PICK I + C@ \ get url[y]
DUP ROT C! \ url[x] = url[y]
[CHAR] % = IF \ convert it if it is a % char
OVER I + 1+ 2 x2c \ convert url[y+1]
2 PICK 2 PICK + C! \ and store it at url[x]
3
ELSE
1
THEN
+LOOP
1+ \ adjust count
SWAP DROP
;
: skip-past-equals ( -- )
scan-ptr @ DUP buf-len SWAP ?DO
1+
input-buffer I + C@
[CHAR] = = IF LEAVE THEN
LOOP
scan-ptr !
;
: length-to-ampersand ( -- n )
0
buf-len scan-ptr @ ?DO
input-buffer I + C@
[CHAR] & = IF LEAVE THEN
1+
LOOP
;
: scan ( -- addr count | 0 )
skip-past-equals
length-to-ampersand
DUP 0 > IF
input-buffer scan-ptr @ + \ addr of first char
SWAP \ put count on top
DUP scan-ptr +!
THEN
;
\ get data from input stream (stdin)
\ set BAD-STATUS if it failed
: get-input-data ( addr len -- )
\ STDIN READ-FILE
\ The above SHOULD work, but with ThisForth 94-09-12
\ it doesn't when this is run with no tty attached (as it will be
\ when HTTP invokes it), so instead we are using:
0 READ
DUP 0 <
TO bad-status
TO buf-len
;
: scan-input-data ( -- )
0 scan-ptr !
scan DUP 0 > IF ['] first-name $! THEN
scan DUP 0 > IF ['] last-name $! THEN
scan DUP 0 > IF ['] street $! THEN
scan DUP 0 > IF ['] city $! THEN
scan DUP 0 > IF ['] state/prov $! THEN
scan DUP 0 > IF ['] postal-code $! THEN
scan DUP 0 > IF ['] country $! THEN
scan DUP 0 > IF ['] phone $! THEN
scan DUP 0 > IF ['] e-mail $! THEN
scan DUP 0 > IF ['] www-page $! THEN
\ need a full name
first-name $len 0= last-name $len 0= OR TO bad-status
\ if there is no phone number of e-mail, then there MUST be an
\ address
phone $len 0= e-mail $len 0= AND
IF
street $len 0= city $len 0= OR state/prov $len 0= OR
TO bad-status
THEN
;
: report-field ( addr count handle -- )
OVER 0= IF SWAP DROP SWAP DROP S" (None) " ROT THEN
WRITE-FILE DROP
;
: report ( handle -- )
S" First name: " 2 PICK WRITE-FILE DROP
first-name 2 PICK report-field
S" Last name: " 2 PICK WRITE-FILE DROP
last-name 2 PICK report-field
DUP newline DROP
S" Street : " 2 PICK WRITE-FILE DROP
street 2 PICK report-field
DUP newline DROP
S" City : " 2 PICK WRITE-FILE DROP
city 2 PICK report-field
S" State: " 2 PICK WRITE-FILE DROP
state/prov 2 PICK report-field
DUP newline DROP
S" Country: " 2 PICK WRITE-FILE DROP
country 2 PICK report-field
S" postal-code: " 2 PICK WRITE-FILE DROP
postal-code 2 PICK report-field
DUP newline DROP
S" phone: " 2 PICK WRITE-FILE DROP
phone 2 PICK report-field
DUP newline DROP
S" e-mail: " 2 PICK WRITE-FILE DROP
e-mail 2 PICK report-field
DUP newline DROP
S" WWW page: " 2 PICK WRITE-FILE DROP
www-page 2 PICK report-field
newline DROP
;
: sendmail ( handle -- handle )
S" Here is a new FIG Membership request number: " 2 PICK WRITE-FILE DROP
seq-no itoa 2 PICK WRITE-LINE DROP
S" Received at " 2 PICK WRITE-FILE DROP
PAD 24 timestamp 2 PICK WRITE-FILE DROP
S" from the WWW page on: " 2 PICK WRITE-FILE DROP
HOSTNAME 2 PICK WRITE-LINE DROP
S" Program: " 2 PICK WRITE-FILE DROP
PROGRAM 2 PICK WRITE-LINE DROP
DUP newline DROP
DUP report
;
: fig_reg ( -- )
init-strings
\ fix the mailer string
MAILER unescape-url MAILER DROP SWAP ['] MAILER $!
MAILER DESTINATION $cat ['] MAILER $!
LOGFILE OPEN-APPEND ABORT" Unable to open log file "
TO log-file
update_sequence_number DUP TO seq-no
PAD 24 timestamp log-file WRITE-FILE DROP
S" Sequence number is: " log-file WRITE-FILE DROP
itoa log-file WRITE-FILE DROP
log-file newline DROP
write-env
?DEBUG IF
S" CONTENT LENGTH = " log-file WRITE-FILE DROP
DUP itoa log-file WRITE-FILE DROP
THEN
\ allocate space for the buffer
HERE TO input-buffer
DUP 2 + DUP TO buf-len ALLOT
\ now read characters from the input stream
input-buffer SWAP get-input-data
?DEBUG IF
S" BUF-LEN = " log-file WRITE-FILE DROP
buf-len itoa log-file WRITE-FILE DROP
S" status = " log-file WRITE-FILE DROP
bad-status itoa log-file WRITE-FILE DROP
log-file newline DROP
THEN
input-buffer buf-len plus->space
input-buffer buf-len unescape-url TO buf-len
?DEBUG IF
input-buffer buf-len log-file WRITE-FILE DROP
log-file newline DROP
THEN
scan-input-data
log-file report
bad-status IF nack
ELSE
." Mailer command <" MAILER TYPE ." >" CR
\ open the mail pipe
MAILER W/O OPEN-PIPE
ABORT" Unable to open pipe to mailer "
sendmail
CLOSE-PIPE DROP
acknowledge
THEN
sig
log-file newline DROP
log-file CLOSE-FILE DROP
;
\ auto-startup word
: startup fig_reg bye ;
PFE [IF]
startup
[THEN]

62
forth-app.txt Executable file
View File

@ -0,0 +1,62 @@
Forth Application Presentation -*-org-*-
Date: 2011/11/30
How should an application implemented in Forth be presented to users?
I can think of the following formats.
1. Forth Extension: User invokes application with word(s) in the Forth
interpreter.
* Advantages: Most flexible and portable, immediate debugging.
* Disadvantages: Requires user to have access to shell and Forth
interpreter. User must know how to use Forth
interpreter. Text-only interface.
2. Shell Application: User invokes shell script that starts Forth
interpreter and invokes application.
* Advantages: Low impact on implementation, good portability. User
need not know Forth or Forth interpreter.
* Disadvantages: User must have shell access. Text-only
interface. Debugging requires modulization of
application. Dependency on Forth interpreter interface for
argument handling, environment var's, etc.
3. CGI Application: User invokes application from browser via CGI
script.
* Advantages: User can access application from any platform with
web browser. User needs no knowledge of Forth or
shell. Interface can use text styling and graphics.
* Disadvantages: Requires web server running on application
host. Dependency on Forth interpreter interface for environment
var's, etc. Application must wrap output in HTML. Must finesse
dictionary, stack persistence.
4. GUI Application: Aplication packaged as GUI program invoked on
user's PC.
* Advantages: Easiest access for user. Greatest options for
interface media.
* Disadvantages: Highly dependent on user's platform. Depends on
linking graphics libraries with Forth modules. Requires user to
install application on own PC.
Currently, I don't possess the knowledge to implement pattern 4., and
it has so many disadvantages I doubt it would be worthwhile even if I
could.
Pattern 2. does not offer much meaningful advantage over
pattern 1. (Users who can use the shell are able to learn enough
Forth to invoke the application.)
Therefore, I expect to do initial development as a
pattern 1. application, then make a pattern 3. wrapper for
appropriate aplications.

53
forth-cheat.txt Executable file
View File

@ -0,0 +1,53 @@
Forth Cheat Sheet -*- mode: org; -*-
* 2011/6/9 restart
** Input/output
.s .
** Arithmetic
+ - * / mod negate
/mod ( n m -- nMODm n/m )
** Stack juggling
drop ( x -- )
dup ( x -- x x )
over ( x y -- x y x )
swap ( x y -- y x )
rot ( x y z -- y z x )
nip ( x y -- y )
tuck ( x y -- y x y )
** Operator type prefixes
u: unsigned integer
c: character
d: signed double-cell integer
ud, du: unsigned double-cell integer
2: two cells
m, um: mixed single- and double-cell operations
f: floating point
* Original sheet
Arithmetic :: + - * / mod negate /mod 1+ 1-
Logical/bitwise :: and or xor invert 2/
Comparison :: = <> < > <= >=
Comparison prefix :: 0 u d d0 du f f0
General prefix :: u c d ud du 2 m um f
Parameter :: n u c f a-addr a- c-addr c- xt w,x d ud r
Stack :: .s . drop dup over swap rot 2swap 2drop nip tuck
Conditional :: if...then if...else...then
Loop :: begin...again begin...while...repeat begin...until
Miscellaneous :: assert( see words

5
forth-revisited.txt Executable file
View File

@ -0,0 +1,5 @@
Forth Revisited
I was taking a look at the Coraphyco unit converter program I did in Forth almost five years ago (can't believe it). I'd forgotten how to use the cute little thing, so I'm now determined to learn enough Forth to put in the help commands I've been intending to add all along.
In the process, I started falling in love with this little language again. Maybe Common Lisp can wait? At least I want to include Forth as a tool in my online "world building".

7
forth-script Executable file
View File

@ -0,0 +1,7 @@
#! /usr/local/bin/gforth
\ Forth shell script
." Hello, World!" cr
bye

23
forth.cgi_ Executable file
View File

@ -0,0 +1,23 @@
#!/usr/pkg/bin/perl
$GFORTH = '/arpa/ns/p/papa/bin/gforth-0.7.0';
$query = $ENV{'QUERY_STRING'};
$query =~ s/\+/ /g;
$query =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;
open(RESULT, '-|', "$GFORTH -e '$query CR BYE'") or die "Can't start gforth: $!";
$result = <RESULT>;
chop $result;
print <<END ;
Content type: text/plain
$query ==> $result
END
while (<RESULT>) { print "\t\t$_"; }

2
forthlit.blink Executable file
View File

@ -0,0 +1,2 @@
Forth Literature and Education
http://www.taygeta.com/forthlit.html

29
forthtest.cgi_ Executable file
View File

@ -0,0 +1,29 @@
#! /usr/bin/gforth-fast
\ forthtest.cgi - Test driver for html5cgi.fs
include html5cgi.fs
s" Document Title" $alloc *title* *head*
0
s" Level 1 Heading" $alloc *h1*
s" Level 2 Heading" $alloc *h2*
s" Level 3 Heading" $alloc *h3*
s" Level 4 Heading" $alloc *h4*
s" Level 5 Heading" $alloc *h5*
s" Level 6 Heading" $alloc *h6*
*body* *html* *http-html5*
ctype
bye

32
gcd.fs Executable file
View File

@ -0,0 +1,32 @@
\ gcd.fs -- Compute greatest common divisor (for Gforth manual
\ General Loops Tutorial)
\ David Meyer <papa@freeshell.org> 2010-03-17
: gcd ( n1 n2 -- n3 )
assert( 2dup 0<> swap 0<> and ) \ Parameters are non-zero
2dup < if swap then \ Put parameters in descending order
dup 1+ \ Initialize candidate divisor
begin
1- \ Decrement candidate divisor
2dup mod 0= \ n2 divisible by nc
2over drop 2over nip mod 0= and \ n1 div. by nc
over 1 = or \ nc = 1
until
nip nip
\ dup 1 = if \ Result is 0 for mutual primes
\ drop 0
\ then
;
: euclid ( n1 n2 -- n3 ) \ Calculate GCD with Euclid's
\ method
assert( 2dup 0<> swap 0<> and ) \ Parameters are non-zero
2dup < if swap then \ Put parameters in descending order
begin
dup 0<>
while
tuck mod
repeat
drop \ Simple!
;

57
gforth.cgi_ Executable file
View File

@ -0,0 +1,57 @@
#!/usr/pkg/bin/perl
use CGI;
$GFORTH = '/usr/pkg/bin/gforth';
$CORA = '/meta/p/papa/html/cgi-bin/cora.fs';
$query = CGI->new;
$command = $query->param('command');
print <<END1 ;
Content-type: text/html
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html>
<head>
<title>Gforth Calculator</title>
<meta http-equiv="Content-type" content="text/html;charset=UTF-8">
<!-- <link rel="stylesheet" type="text/css" href="../tir/tir.css"> -->
<style type="text/css">
</style>
</head>
<body>
<h1>Gforth Calculator</h1>
<form action="gforth.cgi" method="post">
Command <input type="text" name="command" size=80 />
<input type="submit" value="Submit" />
</form>
<hr />
END1
if ($command) {
open(RESULT, '-|', "$GFORTH $CORA -e '$command CR S\" D:\" TYPE .S S\" F:\" TYPE F.S CR BYE'") or die "Can't start gforth: $!";
print "<table><tr><td>$command</td><td>==></td><td>";
while (<RESULT>) {
chop $_;
print "$_<br />";
}
print "</td></tr></table>\n";
}
print <<END3 ;
<a href="http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/">Gforth Manual</a><br />
<a href="http://www.forth.com/starting-forth/">Starting Forth</a><br />
<a href="http://prdownloads.sourceforge.net/thinking-forth/thinking-forth-color.pdf?download">Thinking Forth</a><br />
<a href="http://www.complang.tuwien.ac.at/projects/forth.html">Forth Research</a><br />
<a href="http://www.forth.org/">Forth Interest Group</a><br />
<a href="http://www.colorforth.com/">Chuck Moore</a><br />
</body>
</html>
END3

57
gforth_1.cgi_ Executable file
View File

@ -0,0 +1,57 @@
#!/usr/pkg/bin/perl
use CGI;
$GFORTH = '/arpa/ns/p/papa/bin/gforth-0.7.0';
$CORA = '/arpa/ns/p/papa/share/gforth/site-forth/cora.fs';
$query = CGI->new;
$command = $query->param('command');
print <<END1 ;
Content-type: text/html
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">
<html>
<head>
<title>Gforth Calculator</title>
<meta http-equiv="Content-type" content="text/html;charset=UTF-8">
<!-- <link rel="stylesheet" type="text/css" href="../tir/tir.css"> -->
<style type="text/css">
</style>
</head>
<body>
<h1>Gforth Calculator</h1>
<form action="gforth.cgi" method="post">
Command <input type="text" name="command" size=80 />
<input type="submit" value="Submit" />
</form>
<hr />
END1
if ($command) {
open(RESULT, '-|', "$GFORTH $CORA -e '$command CR BYE'") or die "Can't start gforth: $!";
print "<table><tr><td>$command</td><td>==></td><td>";
while (<RESULT>) {
chop $_;
print "$_<br />";
}
print "</td></tr></table>\n";
}
print <<END3 ;
<a href="http://www.complang.tuwien.ac.at/forth/gforth/Docs-html/">Gforth Manual</a><br />
<a href="http://www.forth.com/starting-forth/">Starting Forth</a><br />
<a href="http://prdownloads.sourceforge.net/thinking-forth/thinking-forth-color.pdf?download">Thinking Forth</a><br />
<a href="http://www.complang.tuwien.ac.at/projects/forth.html">Forth Research</a><br />
<a href="http://www.forth.org/">Forth Interest Group</a><br />
<a href="http://www.colorforth.com/">Chuck Moore</a><br />
</body>
</html>
END3

66
gophermap Executable file
View File

@ -0,0 +1,66 @@
1(to nexus) /users/papa sdf.org 70
YOU SEE HERE:
0Mind.4th /users/papa/forth/Mind.4th sdf.org 70
0Mind.F /users/papa/forth/Mind.F sdf.org 70
0array.fs /users/papa/forth/array.fs sdf.org 70
0#head.blosxom# #story.blosxom# 4kad StarryApplet a-mans-a about ais alpha-vms althist aotcx basic basic-21c bible bibtex bin blink blog blogger blogging blogroll blosxom bonmots books busy c c-abc canzoni cave cavemap cc.bas cell certs chem church cl cms content_type.blosxom content_type.writeback cosw cow creacomp cs csliner css ct date.blosxom date.html date.writeback democracy devimg diplomacy disney drupal drut dunnet dw eco ed-ipkg elisp emacs email english feeds filefeed fonts food foot.blosxom foot.html foot.writeback foot.writeback~ forth future games gf glog gopher gophermap gophermap~ gopherspace greek gtd gverse hammurabi head.blosxom head.html head.html~ head.writeback head.writeback~ hello hsk-mod i ibasho it its japan jbo journal js l-abc license life linux lisp loctime lotgd lynx lynx_bookmarks.html media mes metadata mindforth ming motd motdph2 muckman mucku mud music mux narnia neuschwanstein openofc orgblm padcode papascave pbbghub pc perl phlog phlupd phwk pl plan9 pm poems politecon prayers prog prolog pverse q qdstar qdstar-c qdstar-perl quest quiz r2h rcww2010 read reading recipe religion rpn scheme scifi sdf sdfmud sdfpbp sell sh sib site smr softbiz songs splitre squares ssh starasc stars.game start.txt story.blosxom story.html story.html~ story.writeback style teco teco280.tmp teco7919.tmp telehack template test.md.txt test2.txt testdn testup tex tinyhack tinymud tinymush tinyweb tir tirph tirrender.c tirrender.pl tirtest todo tops10 trade train travel twenex twisty unicode unix urbex vcard vms vttrek wiki wikitest_dokuwiki_blog_entry.txt winxp writeback writeback.writeback writing www xfce ykwk zaurus /users/papa/forth/blockimg.txt sdf.org 70
hCaltech Forth URL:http://pdp-10.trailing-edge.com/decuslib10-04/01/43,50361/forth.doc.html
Macro Assembler source (Tenex):
http://pdp-10.trailing-edge.com/decuslib10-04/01/43,50361/forth.mac.html
0cgi-0.fs /users/papa/forth/cgi-0.fs sdf.org 70
0cgi.fs /users/papa/forth/cgi.fs sdf.org 70
0chronograph.fs /users/papa/forth/chronograph.fs sdf.org 70
0Coraphyco - COnversion RAtios and PHYsical COnstnts in Forth /users/papa/forth/cora-help.txt sdf.org 70
0cora.fs /users/papa/forth/cora.fs sdf.org 70
0cora_0.fs /users/papa/forth/cora_0.fs sdf.org 70
0cora_1.fs /users/papa/forth/cora_1.fs sdf.org 70
0cora_2.fs /users/papa/forth/cora_2.fs sdf.org 70
0cora_3.fs /users/papa/forth/cora_3.fs sdf.org 70
0cora_4.0.fs /users/papa/forth/cora_4.0.fs sdf.org 70
0corai.fs /users/papa/forth/corai.fs sdf.org 70
0dmath.fs /users/papa/forth/dmath.fs sdf.org 70
hDNW's Forth Page URL:http://www-personal.umich.edu/~williams/archive/forth/forth.html
0fig_reg.fth /users/papa/forth/fig_reg.fth sdf.org 70
0 /users/papa/forth/forth-app.txt sdf.org 70
0Forth Cheat Sheet -*- mode: org; -*- /users/papa/forth/forth-cheat.txt sdf.org 70
0Forth Revisited /users/papa/forth/forth-revisited.txt sdf.org 70
0forth-script /users/papa/forth/forth-script sdf.org 70
0forth.cgi /users/papa/forth/forth.cgi sdf.org 70
hForth Literature and Education URL:http://www.taygeta.com/forthlit.html
0gcd.fs /users/papa/forth/gcd.fs sdf.org 70
0gforth.cgi /users/papa/forth/gforth.cgi sdf.org 70
0gforth_1.cgi /users/papa/forth/gforth_1.cgi sdf.org 70
0hanoi-he.4th /users/papa/forth/hanoi-he.4th sdf.org 70
0hanoi.4th /users/papa/forth/hanoi.4th sdf.org 70
0hello /users/papa/forth/hello sdf.org 70
0length-units.xls /users/papa/forth/length-units.xls sdf.org 70
0Forth Level 0 Functions /users/papa/forth/level-0.org sdf.org 70
0lf.4th /users/papa/forth/lf.4th sdf.org 70
0life.fs /users/papa/forth/life.fs sdf.org 70
0mailfig.fth /users/papa/forth/mailfig.fth sdf.org 70
hMarcel Hendrix's home-page URL:http://home.iae.nl/users/mhx/index.html
hChuck Moore: Geek of the Week URL:http://www.simple-talk.com/opinion/geek-of-the-week/chuck-moore-geek-of-the-week/
0pf.perl /users/papa/forth/pf.perl sdf.org 70
0random.f /users/papa/forth/random.f sdf.org 70
0Forth Sandbox -*-org-*- /users/papa/forth/sandbox.txt sdf.org 70
0Text screen test patterns /users/papa/forth/scrtest.txt sdf.org 70
0Starting Forth Words -*-org-*- /users/papa/forth/starting-words.txt sdf.org 70
0starting.fs /users/papa/forth/starting.fs sdf.org 70
0sticks.f /users/papa/forth/sticks.f sdf.org 70
0test1.fs /users/papa/forth/test1.fs sdf.org 70
hThoughtful Programming and Forth URL:http://www.ultratechnology.com/forth.htm
0tscript /users/papa/forth/tscript sdf.org 70
0tutorial.fs /users/papa/forth/tutorial.fs sdf.org 70
0twenex-forth.mid /users/papa/forth/twenex-forth.mid sdf.org 70
0TWENEX FORTH WORDS /users/papa/forth/twenex-forth.txt sdf.org 70
0wareki.fs /users/papa/forth/wareki.fs sdf.org 70
0Yuko Development Notes /users/papa/forth/yuko-notes.org sdf.org 70
0yuko-test.fs /users/papa/forth/yuko-test.fs sdf.org 70
0yuko.fs /users/papa/forth/yuko.fs sdf.org 70
1(to nexus) /users/papa sdf.org 70
Anyone who goes to a psychiatrist ought to have his head examined.
-- Samuel Goldwyn

37
hamucalc.fs Executable file
View File

@ -0,0 +1,37 @@
\ hamucalc.fs - HAMURABI game calculator
\ Copyright 2013 David Meyer <papa@sdf.org> +JMJ
\ Copying and distribution of this file, with or without
\ modification, are permitted in any medium without royalty
\ provided the copyright notice and this notice are preserved.
\ This file is offered as-is, without any warranty.
: hamu { pop land grain landpr -- }
pop 20 *
dup cr .\" Grain to feed people:\t" .
land pop 1- 10 * min
dup cr .\" Acres to plant:\t" .
2 * +
grain -
dup 0> if
cr .\" Acres to sell:\t"
landpr 2dup % 0= if
/ .
else
/ 1+ .
then
else
cr .\" Acres to buy:\t"
negate landpr / .
then
cr
;
\ Emacs metadata ...
\ Local variables:
\ mode: forth
\ End:
\ +JMJ

69
hanoi-he.4th Executable file
View File

@ -0,0 +1,69 @@
\ hanoi.4th
\
\ Towers of Hanoi puzzle
\
\ From a posting to comp.lang.forth, 30 May 2002, by Marcel
\ Hendrix and Brad Eckert. According to Marcel Hendrix, the
\ code for the HANOI algorithm was originally posted to clf
\ by Raul Deluth Miller in 1994.
\ ---------------------------------------------------------------------------
\ kForth includes and defs (2002-05-30 K. Myneni)
\
include strings
include ansi
: chars ;
\ ---------------------------------------------------------------------------
\ To run under other ANS Forths, uncomment the defs below:
\ : a@ @ ;
\ : ?allot here swap allot ;
\ : nondeferred ;
variable slowness 1000 slowness ! \ ms delay between screen updates
create PegSPS 3 cells allot \ pointers for three disk stacks
: PegSP ( peg -- addr ) cells PegSPS + ;
: PUSH ( c peg -- ) PegSP tuck a@ c! 1 chars swap +! ;
: POP ( peg -- c ) PegSP -1 chars over +! a@ c@ ;
create PegStacks 30 chars allot \ stack area for up to 10 disks
: PegStack ( peg -- addr ) 10 * PegStacks + ;
: PegClr ( peg -- ) dup PegStack swap PegSP ! ;
: PegDepth ( peg -- depth) dup PegSP @ swap PegStack - ; \ not needed
: ShowDisk ( level diameter peg )
22 * 10 + over - rot 10 swap - at-xy \ position cursor
1+ 2* 0 ?do [char] * emit loop ; \ display the disk
: ShowPeg ( peg -- ) dup >r PegStack
BEGIN r@ PegSP @ over <>
WHILE dup r@ PegStack - over c@ ( addr level diameter )
r@ ShowDisk char+
REPEAT drop r> drop ;
: MAKETAB CREATE dup ?allot over 1- + swap 0 ?do dup >r c! r> 1- loop drop
DOES> + c@ ;
: base3 [ decimal ] 3 base ! ; nondeferred
base3 00 02 01 12 00 10 21 20 decimal 8 maketab TO!
base3 00 21 12 20 00 02 10 01 decimal 8 maketab FRO!
: ShowPegs ( -- ) page 3 0 do i showpeg loop slowness @ ms
key? if key drop 0 11 at-xy ." Stopped" cr abort then ;
: MoveRing ( ring -- ring ) dup to! 3 / pop over fro! 3 mod push
ShowPegs ;
: HANOI ( depth direction -- depth direction ) swap 1- swap
over IF to! recurse to! MoveRing fro! recurse fro!
ELSE MoveRing
THEN swap 1+ swap ;
: PLAY ( depth -- )
3 0 DO i PegClr LOOP \ clear the pegs
dup BEGIN ?dup WHILE 1- dup 0 push REPEAT \ stack up some disks
showpegs 1 HANOI 2drop \ move them
0 11 at-xy ;
4 play

33
hanoi.4th Executable file
View File

@ -0,0 +1,33 @@
( The Towers Of Hanoi )
( FORTH )
( Copyright 1998 Amit Singh. All Rights Reserved. )
( http://hanoi.kernelthread.com )
( )
( Tested under GNU Forth 0.3.0, PFE 0.9.14 )
( Use "gforth <thisfile> -e 'n HANOI bye'" to run )
( hanoi with n disks. Alternatively, load everything )
( and use the HANOI word from within the interpreter. )
: MOVEIT ." move " . ." --> " . CR ; ( to from -- )
: DOHANOI ( to from using n -- )
( T3 <- T1 using T2 )
DUP 0 > ( more disks ? )
IF
1 - ( n <- n - 1 )
2OVER 2OVER ( clone data stack )
>r >r >r >r ( save it to rstack )
1 ROLL 2 ROLL 3 ROLL 3 ROLL ( using from to n-1 )
RECURSE ( T2 <- T1 using T3 )
2r@ SWAP MOVEIT ( to from )
2DROP 2DROP ( empty the stack )
2r> 2r> ( from to n-1 using )
SWAP ( from to using n-1 )
3 ROLL ( to using n-1 from )
SWAP ( to using from n-1 )
RECURSE ( T3 <- T2 using T1 )
THEN ;
: HANOI ( n -- ) ( prepare arguments )
3 1 2 3 ROLL DOHANOI 2DROP 2DROP ;

53
heapstr.fs Executable file
View File

@ -0,0 +1,53 @@
\ heapstr.fs -- Manage character strings in heap memory
\ 2016 David Meyer <papa@sdf.org> +JMJ
: c$type ( c-str -- ) count type ;
: $alloc ( a-str u -- c-heap )
\g Allocate heap space for counted version of string A-STR,U
dup 1+ chars allocate if ( a-str u c-heap)
>r 2drop r> -1 \ Returns string length -1 for alloc. error
else
2dup c! dup >r 1 chars + swap cmove r>
then
;
: c$alloc ( c-str -- c-heap )
\g Allocate heap space for counted string for C-STR
count dup 1+ chars allocate if ( a-str u c-heap)
>r 2drop r> 0 \ Returns 0 c-pointer for alloc. error
else
2dup c!
dup >r 1 chars + swap cmove r>
then
;
: $catcpy { a-str1 u1 a-str2 u2 a-cat ucat -- }
\g Copy characters from STR1 and STR2 to pre-allocated CAT
a-str1 a-cat u1 cmove
a-str2 a-cat u1 chars + u2 cmove
;
: c$cat ( c-str1 c-str2 -- c-cat )
\g Concatenate two counted strings in heap, preserve original strings
count dup >r rot count dup >r 2swap ( a-str1 u1 a-str2 u2 R: u2 u1 )
r> r> + dup 1+ chars allocate if ( a-str1 u1 a-str2 u2 ucat c-cat )
clearstack 0 \ Returns 0 c-pointer for alloc. error
else
tuck c! ( a-str1 u1 a-str2 u2 c-cat )
dup >r count $catcpy r>
then
;
: c$catx ( c-str1 c-str2 ux -- c-cat )
\g Concatenate two counted strings in heap, recycle original strings according to UX: 0 -- recycle STR1 and STR2, 1 -- recycle STR1 only, 2 -- recycle STR2 only
>r 2dup c$cat r> ( c-str1 c-str2 c-cat ux )
dup 2 = if
drop swap free drop nip
else dup 1 = if
drop nip swap free drop
else 0= if
swap free drop
swap free drop
then then then
;

7
hello Executable file
View File

@ -0,0 +1,7 @@
#! /usr/local/bin/gforth
." Hello, World!" cr
bye

4
html.f Executable file
View File

@ -0,0 +1,4 @@
\ html.f
\ determine string length for text + symmetrical open/close tags
: octag 2( a1 u1 a2 u2 -- a1 u1 a2 u2 n ) over nip over 2 * + 5 + ;

65
html.fs Executable file
View File

@ -0,0 +1,65 @@
\ Generate markup to standard output
: [http-html-head] ( -- )
." Content-Type: text/html" cr cr
.\" <!DOCTYPE HTML PUBLIC \"-//W3C/DTD HTML 4.01//EN\" "
.\" \"http://www,w3,org/TR/html4/strict.dtd\">"
." <html><head>"
;
\ (gforth does not support strings with embedded new-line characters)
\ HTML tags: html, head, title, style, meta, body, h1/2/3/4/5/6, p, strong (b), em (i), ul, ol, li, dl, dt, dd, table, thead, tbody, tr, th, td, a
: [<] [char] < emit ;
: [>] [char] > emit ;
: [</] ." </" ;
: [/>] ." />" ;
: "tag" ( -- ) ." tag" ;
: [tag] ( addr u -- ) [<] type [>] ;
: [/tag] ( addr u -- ) [</] type [>] ;
: [tag-$] ( $-addr $-u t-addr t-u -- ) [tag] type ;
: [tag-$/] ( $-addr $-u t-addr t-u -- )
2dup [tag] 2over type [/tag] ;
: [tag+] ( +-addr +-u t-addr t-u -- )
[<] type space type [>] ;
: [tag+$] ( $-addr $-u +-addr +-u t-addr t-u -- )
[<] type space type [>] type ;
: [tag+$/] ( $-addr $-u +-addr +-u t-addr t-u -- )
2dup [<] type space 2over type [>] 2over type [/tag] ;
: [tag/] ( addr u -- ) [<] type space [/>] ;
: "p" ( -- ) s" p" ;
: [p] ( -- ) "p" [tag] ;
: [p-$] ( addr u -- ) [p] type ; \ "p" [tag-$] ;
: [p-$/] ( addr u -- ) "p" [tag-$/] ;
: [p+] ( +-addr +-u -- ) "p" [tag+] ;
: [p+$] ( $-addr $-u +-addr +-u -- ) "p" [tag+$] ;
: [p+$/] ( $-addr $-u +-addr +-u -- ) "p" [tag+$/] ;
: [/p] ( -- ) "p" [/tag] ;
: [p/] ( -- ) "p" [tag/] ;
.( Testing ...) cr
"p" type cr
[p] cr
s" This is a p-$ example." [p-$] cr
s" This is a p-$/ example." [p-$/] cr
s" a1=v1 a2=v2" [p+] cr
s" This is a p+$ example." s" a1=v1 a2=v2" [p+$] cr
s" This is a p+$/ example." s" a1=v1 a2=v2" [p+$/] cr
[/p] cr
[p/] cr
bye
: [html] [<] ." html" [>] ;
: [html-a] ( attr-a u -- ) [<] ." html " type [>] ;
: [/html] ( -- ) [</] ." html" type [>] ;
: [h1] [<] ." html" [>] ;

134
html5cgi.fs Executable file
View File

@ -0,0 +1,134 @@
\ html5cgi.fs -- Generate HTML5 tags for CGI script
\ 2016 David Meyer <papa@sdf.org> +JMJ
\ Tags are generate with words with format *X*, where X usually corresponds to the
\ tag to be generated, and which generally have a stack effect like:
\
\ ( c-prefix c-content [c-attrib ...] -- c-result )
\
\ Where: c-prefix is a pointer to a counted string containing the preceding contents
\ of the current element; 0 when the current tag will be the first
\ contents of the element.
\ c-content is a pointer to the contents for the current tag.
\ c-attrib points to one or more optional strings for tag attributes.
\ c-result points to a string concatenating the prefix contents with the current
\ tag (input strings are recycled to the heap).
\ Supported tags/structure:
\ *http-resp*
\ *html*
\ *head*
\ *title*, *style*, *meta*, *base*
\ *body*
\ *article*, *aside*, *div*, *header*, *footer*, *nav*, *section*
\ *a*, *blockquote* *h1*, *h2*, *h3*, *h4*, *h5*, *h6*, *hr*, *img*, *pre*
\ *map*
\ *area*
\ *p*
\ *b*, *br*, *em*, *strong*
\ *ol*, *ul*
\ *li*
\ *dl*
\ *dt*, *dd*
\ *table*
\ *thead*, *tbody*
\ *tr*
\ *th*, *td*
\ *form*
\ *input*, *label*
include heapstr.fs
s" <b>" $alloc constant C-B
s" </b>" $alloc constant C-/B
s" <blockquote>" $alloc constant C-BQUOTE
s\" </blockquote>\n" $alloc constant C-/BQUOTE
s\" <body>\n" $alloc constant C-BODY
s\" </body>\n" $alloc constant C-/BODY
s\" <br />\n" $alloc constant C-BR
s" <em>" $alloc constant C-EM
s" </em>" $alloc constant C-/EM
s" <h1>" $alloc constant C-H1
s\" </h1>\n" $alloc constant C-/H1
s" <h2>" $alloc constant C-H2
s\" </h2>\n" $alloc constant C-/H2
s" <h3>" $alloc constant C-H3
s\" </h3>\n" $alloc constant C-/H3
s" <h4>" $alloc constant C-H4
s\" </h4>\n" $alloc constant C-/H4
s" <h5>" $alloc constant C-H5
s\" </h5>\n" $alloc constant C-/H5
s" <h6>" $alloc constant C-H6
s\" </h6>\n" $alloc constant C-/H6
s\" <head>\n" $alloc constant C-HEAD
s\" </head>\n" $alloc constant C-/HEAD
s\" <hr />\n" $alloc constant C-HR
s\" <html>\n" $alloc constant C-HTML
s\" </html>\n" $alloc constant C-/HTML
s\" Content-type: text/html\n\n<!DOCTYPE html>\n" $alloc
constant C-HTTP-HTML5
s" <li>" $alloc constant C-LI
s\" </li>\n" $alloc constant C-/LI
s" <ol>" $alloc constant C-OL
s\" </ol>\n" $alloc constant C-/OL
s" <p>" $alloc constant C-P
s\" </p>\n" $alloc constant C-/P
s" <strong>" $alloc constant C-STRONG
s" </strong>" $alloc constant C-/STRONG
s" <title>" $alloc constant C-TITLE
s\" </title>\n" $alloc constant C-/TITLE
s" <ul>" $alloc constant C-UL
s\" </ul>\n" $alloc constant C-/UL
: empty-tag ( c-prefix c-tag -- c-result ) 1 c$catx ;
: simple-tag ( c-prefix c-content c-open c-close -- c-result )
\g Generate tag with format: <X>Tag contents</X>
rot swap 1 c$catx 2 c$catx
over if 0 c$catx else nip then
;
: *blockquote* ( c-prefix c-content -- c-result ) C-BQUOTE C-/BQUOTE simple-tag ;
: *b* ( c-prefix c-content -- c-result ) C-B C-/B simple-tag ;
: *body* ( c-content -- c-body ) C-/BODY 1 c$catx C-BODY swap 2 c$catx ;
: *br* ( c-prefix -- c-result ) C-BR empty-tag ;
: *em* ( c-prefix c-content -- c-result ) C-EM C-/EM simple-tag ;
: *h1* ( c-prefix c-content -- c-result ) C-H1 C-/H1 simple-tag ;
: *h2* ( c-prefix c-content -- c-result ) C-H2 C-/H2 simple-tag ;
: *h3* ( c-prefix c-content -- c-result ) C-H3 C-/H3 simple-tag ;
: *h4* ( c-prefix c-content -- c-result ) C-H4 C-/H4 simple-tag ;
: *h5* ( c-prefix c-content -- c-result ) C-H5 C-/H5 simple-tag ;
: *h6* ( c-prefix c-content -- c-result ) C-H6 C-/H6 simple-tag ;
: *head* ( c-content -- c-result ) C-/HEAD 1 c$catx C-HEAD swap 2 c$catx ;
: *hr* ( c-prefix -- c-result ) C-HR empty-tag ;
: *html* ( c-head c-body -- c-result ) C-/HTML 1 c$catx 0 c$catx C-HTML swap 2 c$catx ;
: *http-html5* ( c-content -- c-result ) C-HTTP-HTML5 swap 2 c$catx ;
: *li* ( c-prefix c-content -- c-result ) C-LI C-/LI simple-tag ;
: *ol* ( c-prefix c-content -- c-result ) C-OL C-/OL simple-tag ;
: *p* ( c-prefix c-content -- c-result ) C-P C-/P simple-tag ;
: *strong* ( c-prefix c-content -- c-result ) C-STRONG C-/STRONG simple-tag ;
: *title* ( c-prefix c-content -- c-result ) C-TITLE C-/TITLE simple-tag ;
: *ul* ( c-prefix c-content -- c-result ) C-UL C-/UL simple-tag ;

304
httags.4th Executable file
View File

@ -0,0 +1,304 @@
: [<] [char] < emit ;
: [>] [char] > emit ;
: [</] ." </" ;
: [/>] ." />" ;
: [tag] ( addr u -- ) [<] type [>] ;
: [/tag] ( addr u -- ) [</] type [>] ;
: [tag-$] ( $-addr $-u t-addr t-u -- ) [tag] type ;
: [tag-$/] ( $-addr $-u t-addr t-u -- )
2dup [tag] 2over type [/tag] ;
: [tag+] ( +-addr +-u t-addr t-u -- )
[<] type space type [>] ;
: [tag+$] ( $-addr $-u +-addr +-u t-addr t-u -- )
[<] type space type [>] type ;
: [tag+$/] ( $-addr $-u +-addr +-u t-addr t-u -- )
2dup [<] type space 2swap type [>] 2swap type [/tag] ;
: [tag/] ( addr u -- ) [<] type space [/>] ;
: $html$ ( -- ) s" html" ;
: [html] ( -- ) $html$ [tag] ;
: [/html] ( -- ) $html$ [/tag] ;
: [html/] ( -- ) $html$ [tag/] ;
: [html-$] ( addr u -- ) $html$ [tag-$] ;
: [html-$/] ( addr u -- ) $html$ [tag-$/] ;
: [html+] ( +-addr +-u -- ) $html$ [tag+] ;
: [html+$] ( addr u +-addr +-u -- ) $html$ [tag+$] ;
: [html+$/] ( addr u +-addr +-u -- ) $html$ [tag+$/] ;
: $head$ ( -- ) s" head" ;
: [head] ( -- ) $head$ [tag] ;
: [/head] ( -- ) $head$ [/tag] ;
: [head/] ( -- ) $head$ [tag/] ;
: [head-$] ( addr u -- ) $head$ [tag-$] ;
: [head-$/] ( addr u -- ) $head$ [tag-$/] ;
: [head+] ( +-addr +-u -- ) $head$ [tag+] ;
: [head+$] ( addr u +-addr +-u -- ) $head$ [tag+$] ;
: [head+$/] ( addr u +-addr +-u -- ) $head$ [tag+$/] ;
: $title$ ( -- ) s" title" ;
: [title] ( -- ) $title$ [tag] ;
: [/title] ( -- ) $title$ [/tag] ;
: [title/] ( -- ) $title$ [tag/] ;
: [title-$] ( addr u -- ) $title$ [tag-$] ;
: [title-$/] ( addr u -- ) $title$ [tag-$/] ;
: [title+] ( +-addr +-u -- ) $title$ [tag+] ;
: [title+$] ( addr u +-addr +-u -- ) $title$ [tag+$] ;
: [title+$/] ( addr u +-addr +-u -- ) $title$ [tag+$/] ;
: $style$ ( -- ) s" style" ;
: [style] ( -- ) $style$ [tag] ;
: [/style] ( -- ) $style$ [/tag] ;
: [style/] ( -- ) $style$ [tag/] ;
: [style-$] ( addr u -- ) $style$ [tag-$] ;
: [style-$/] ( addr u -- ) $style$ [tag-$/] ;
: [style+] ( +-addr +-u -- ) $style$ [tag+] ;
: [style+$] ( addr u +-addr +-u -- ) $style$ [tag+$] ;
: [style+$/] ( addr u +-addr +-u -- ) $style$ [tag+$/] ;
: $meta$ ( -- ) s" meta" ;
: [meta] ( -- ) $meta$ [tag] ;
: [/meta] ( -- ) $meta$ [/tag] ;
: [meta/] ( -- ) $meta$ [tag/] ;
: [meta-$] ( addr u -- ) $meta$ [tag-$] ;
: [meta-$/] ( addr u -- ) $meta$ [tag-$/] ;
: [meta+] ( +-addr +-u -- ) $meta$ [tag+] ;
: [meta+$] ( addr u +-addr +-u -- ) $meta$ [tag+$] ;
: [meta+$/] ( addr u +-addr +-u -- ) $meta$ [tag+$/] ;
: $body$ ( -- ) s" body" ;
: [body] ( -- ) $body$ [tag] ;
: [/body] ( -- ) $body$ [/tag] ;
: [body/] ( -- ) $body$ [tag/] ;
: [body-$] ( addr u -- ) $body$ [tag-$] ;
: [body-$/] ( addr u -- ) $body$ [tag-$/] ;
: [body+] ( +-addr +-u -- ) $body$ [tag+] ;
: [body+$] ( addr u +-addr +-u -- ) $body$ [tag+$] ;
: [body+$/] ( addr u +-addr +-u -- ) $body$ [tag+$/] ;
: $h1$ ( -- ) s" h1" ;
: [h1] ( -- ) $h1$ [tag] ;
: [/h1] ( -- ) $h1$ [/tag] ;
: [h1/] ( -- ) $h1$ [tag/] ;
: [h1-$] ( addr u -- ) $h1$ [tag-$] ;
: [h1-$/] ( addr u -- ) $h1$ [tag-$/] ;
: [h1+] ( +-addr +-u -- ) $h1$ [tag+] ;
: [h1+$] ( addr u +-addr +-u -- ) $h1$ [tag+$] ;
: [h1+$/] ( addr u +-addr +-u -- ) $h1$ [tag+$/] ;
: $h2$ ( -- ) s" h2" ;
: [h2] ( -- ) $h2$ [tag] ;
: [/h2] ( -- ) $h2$ [/tag] ;
: [h2/] ( -- ) $h2$ [tag/] ;
: [h2-$] ( addr u -- ) $h2$ [tag-$] ;
: [h2-$/] ( addr u -- ) $h2$ [tag-$/] ;
: [h2+] ( +-addr +-u -- ) $h2$ [tag+] ;
: [h2+$] ( addr u +-addr +-u -- ) $h2$ [tag+$] ;
: [h2+$/] ( addr u +-addr +-u -- ) $h2$ [tag+$/] ;
: $h3$ ( -- ) s" h3" ;
: [h3] ( -- ) $h3$ [tag] ;
: [/h3] ( -- ) $h3$ [/tag] ;
: [h3/] ( -- ) $h3$ [tag/] ;
: [h3-$] ( addr u -- ) $h3$ [tag-$] ;
: [h3-$/] ( addr u -- ) $h3$ [tag-$/] ;
: [h3+] ( +-addr +-u -- ) $h3$ [tag+] ;
: [h3+$] ( addr u +-addr +-u -- ) $h3$ [tag+$] ;
: [h3+$/] ( addr u +-addr +-u -- ) $h3$ [tag+$/] ;
: $h4$ ( -- ) s" h4" ;
: [h4] ( -- ) $h4$ [tag] ;
: [/h4] ( -- ) $h4$ [/tag] ;
: [h4/] ( -- ) $h4$ [tag/] ;
: [h4-$] ( addr u -- ) $h4$ [tag-$] ;
: [h4-$/] ( addr u -- ) $h4$ [tag-$/] ;
: [h4+] ( +-addr +-u -- ) $h4$ [tag+] ;
: [h4+$] ( addr u +-addr +-u -- ) $h4$ [tag+$] ;
: [h4+$/] ( addr u +-addr +-u -- ) $h4$ [tag+$/] ;
: $h5$ ( -- ) s" h5" ;
: [h5] ( -- ) $h5$ [tag] ;
: [/h5] ( -- ) $h5$ [/tag] ;
: [h5/] ( -- ) $h5$ [tag/] ;
: [h5-$] ( addr u -- ) $h5$ [tag-$] ;
: [h5-$/] ( addr u -- ) $h5$ [tag-$/] ;
: [h5+] ( +-addr +-u -- ) $h5$ [tag+] ;
: [h5+$] ( addr u +-addr +-u -- ) $h5$ [tag+$] ;
: [h5+$/] ( addr u +-addr +-u -- ) $h5$ [tag+$/] ;
: $h6$ ( -- ) s" h6" ;
: [h6] ( -- ) $h6$ [tag] ;
: [/h6] ( -- ) $h6$ [/tag] ;
: [h6/] ( -- ) $h6$ [tag/] ;
: [h6-$] ( addr u -- ) $h6$ [tag-$] ;
: [h6-$/] ( addr u -- ) $h6$ [tag-$/] ;
: [h6+] ( +-addr +-u -- ) $h6$ [tag+] ;
: [h6+$] ( addr u +-addr +-u -- ) $h6$ [tag+$] ;
: [h6+$/] ( addr u +-addr +-u -- ) $h6$ [tag+$/] ;
: $p$ ( -- ) s" p" ;
: [p] ( -- ) $p$ [tag] ;
: [/p] ( -- ) $p$ [/tag] ;
: [p/] ( -- ) $p$ [tag/] ;
: [p-$] ( addr u -- ) $p$ [tag-$] ;
: [p-$/] ( addr u -- ) $p$ [tag-$/] ;
: [p+] ( +-addr +-u -- ) $p$ [tag+] ;
: [p+$] ( addr u +-addr +-u -- ) $p$ [tag+$] ;
: [p+$/] ( addr u +-addr +-u -- ) $p$ [tag+$/] ;
: $strong$ ( -- ) s" strong" ;
: [strong] ( -- ) $strong$ [tag] ;
: [/strong] ( -- ) $strong$ [/tag] ;
: [strong/] ( -- ) $strong$ [tag/] ;
: [strong-$] ( addr u -- ) $strong$ [tag-$] ;
: [strong-$/] ( addr u -- ) $strong$ [tag-$/] ;
: [strong+] ( +-addr +-u -- ) $strong$ [tag+] ;
: [strong+$] ( addr u +-addr +-u -- ) $strong$ [tag+$] ;
: [strong+$/] ( addr u +-addr +-u -- ) $strong$ [tag+$/] ;
: $em$ ( -- ) s" em" ;
: [em] ( -- ) $em$ [tag] ;
: [/em] ( -- ) $em$ [/tag] ;
: [em/] ( -- ) $em$ [tag/] ;
: [em-$] ( addr u -- ) $em$ [tag-$] ;
: [em-$/] ( addr u -- ) $em$ [tag-$/] ;
: [em+] ( +-addr +-u -- ) $em$ [tag+] ;
: [em+$] ( addr u +-addr +-u -- ) $em$ [tag+$] ;
: [em+$/] ( addr u +-addr +-u -- ) $em$ [tag+$/] ;
: $ul$ ( -- ) s" ul" ;
: [ul] ( -- ) $ul$ [tag] ;
: [/ul] ( -- ) $ul$ [/tag] ;
: [ul/] ( -- ) $ul$ [tag/] ;
: [ul-$] ( addr u -- ) $ul$ [tag-$] ;
: [ul-$/] ( addr u -- ) $ul$ [tag-$/] ;
: [ul+] ( +-addr +-u -- ) $ul$ [tag+] ;
: [ul+$] ( addr u +-addr +-u -- ) $ul$ [tag+$] ;
: [ul+$/] ( addr u +-addr +-u -- ) $ul$ [tag+$/] ;
: $ol$ ( -- ) s" ol" ;
: [ol] ( -- ) $ol$ [tag] ;
: [/ol] ( -- ) $ol$ [/tag] ;
: [ol/] ( -- ) $ol$ [tag/] ;
: [ol-$] ( addr u -- ) $ol$ [tag-$] ;
: [ol-$/] ( addr u -- ) $ol$ [tag-$/] ;
: [ol+] ( +-addr +-u -- ) $ol$ [tag+] ;
: [ol+$] ( addr u +-addr +-u -- ) $ol$ [tag+$] ;
: [ol+$/] ( addr u +-addr +-u -- ) $ol$ [tag+$/] ;
: $li$ ( -- ) s" li" ;
: [li] ( -- ) $li$ [tag] ;
: [/li] ( -- ) $li$ [/tag] ;
: [li/] ( -- ) $li$ [tag/] ;
: [li-$] ( addr u -- ) $li$ [tag-$] ;
: [li-$/] ( addr u -- ) $li$ [tag-$/] ;
: [li+] ( +-addr +-u -- ) $li$ [tag+] ;
: [li+$] ( addr u +-addr +-u -- ) $li$ [tag+$] ;
: [li+$/] ( addr u +-addr +-u -- ) $li$ [tag+$/] ;
: $dl$ ( -- ) s" dl" ;
: [dl] ( -- ) $dl$ [tag] ;
: [/dl] ( -- ) $dl$ [/tag] ;
: [dl/] ( -- ) $dl$ [tag/] ;
: [dl-$] ( addr u -- ) $dl$ [tag-$] ;
: [dl-$/] ( addr u -- ) $dl$ [tag-$/] ;
: [dl+] ( +-addr +-u -- ) $dl$ [tag+] ;
: [dl+$] ( addr u +-addr +-u -- ) $dl$ [tag+$] ;
: [dl+$/] ( addr u +-addr +-u -- ) $dl$ [tag+$/] ;
: $dt$ ( -- ) s" dt" ;
: [dt] ( -- ) $dt$ [tag] ;
: [/dt] ( -- ) $dt$ [/tag] ;
: [dt/] ( -- ) $dt$ [tag/] ;
: [dt-$] ( addr u -- ) $dt$ [tag-$] ;
: [dt-$/] ( addr u -- ) $dt$ [tag-$/] ;
: [dt+] ( +-addr +-u -- ) $dt$ [tag+] ;
: [dt+$] ( addr u +-addr +-u -- ) $dt$ [tag+$] ;
: [dt+$/] ( addr u +-addr +-u -- ) $dt$ [tag+$/] ;
: $dd$ ( -- ) s" dd" ;
: [dd] ( -- ) $dd$ [tag] ;
: [/dd] ( -- ) $dd$ [/tag] ;
: [dd/] ( -- ) $dd$ [tag/] ;
: [dd-$] ( addr u -- ) $dd$ [tag-$] ;
: [dd-$/] ( addr u -- ) $dd$ [tag-$/] ;
: [dd+] ( +-addr +-u -- ) $dd$ [tag+] ;
: [dd+$] ( addr u +-addr +-u -- ) $dd$ [tag+$] ;
: [dd+$/] ( addr u +-addr +-u -- ) $dd$ [tag+$/] ;
: $table$ ( -- ) s" table" ;
: [table] ( -- ) $table$ [tag] ;
: [/table] ( -- ) $table$ [/tag] ;
: [table/] ( -- ) $table$ [tag/] ;
: [table-$] ( addr u -- ) $table$ [tag-$] ;
: [table-$/] ( addr u -- ) $table$ [tag-$/] ;
: [table+] ( +-addr +-u -- ) $table$ [tag+] ;
: [table+$] ( addr u +-addr +-u -- ) $table$ [tag+$] ;
: [table+$/] ( addr u +-addr +-u -- ) $table$ [tag+$/] ;
: $thead$ ( -- ) s" thead" ;
: [thead] ( -- ) $thead$ [tag] ;
: [/thead] ( -- ) $thead$ [/tag] ;
: [thead/] ( -- ) $thead$ [tag/] ;
: [thead-$] ( addr u -- ) $thead$ [tag-$] ;
: [thead-$/] ( addr u -- ) $thead$ [tag-$/] ;
: [thead+] ( +-addr +-u -- ) $thead$ [tag+] ;
: [thead+$] ( addr u +-addr +-u -- ) $thead$ [tag+$] ;
: [thead+$/] ( addr u +-addr +-u -- ) $thead$ [tag+$/] ;
: $tbody$ ( -- ) s" tbody" ;
: [tbody] ( -- ) $tbody$ [tag] ;
: [/tbody] ( -- ) $tbody$ [/tag] ;
: [tbody/] ( -- ) $tbody$ [tag/] ;
: [tbody-$] ( addr u -- ) $tbody$ [tag-$] ;
: [tbody-$/] ( addr u -- ) $tbody$ [tag-$/] ;
: [tbody+] ( +-addr +-u -- ) $tbody$ [tag+] ;
: [tbody+$] ( addr u +-addr +-u -- ) $tbody$ [tag+$] ;
: [tbody+$/] ( addr u +-addr +-u -- ) $tbody$ [tag+$/] ;
: $tr$ ( -- ) s" tr" ;
: [tr] ( -- ) $tr$ [tag] ;
: [/tr] ( -- ) $tr$ [/tag] ;
: [tr/] ( -- ) $tr$ [tag/] ;
: [tr-$] ( addr u -- ) $tr$ [tag-$] ;
: [tr-$/] ( addr u -- ) $tr$ [tag-$/] ;
: [tr+] ( +-addr +-u -- ) $tr$ [tag+] ;
: [tr+$] ( addr u +-addr +-u -- ) $tr$ [tag+$] ;
: [tr+$/] ( addr u +-addr +-u -- ) $tr$ [tag+$/] ;
: $th$ ( -- ) s" th" ;
: [th] ( -- ) $th$ [tag] ;
: [/th] ( -- ) $th$ [/tag] ;
: [th/] ( -- ) $th$ [tag/] ;
: [th-$] ( addr u -- ) $th$ [tag-$] ;
: [th-$/] ( addr u -- ) $th$ [tag-$/] ;
: [th+] ( +-addr +-u -- ) $th$ [tag+] ;
: [th+$] ( addr u +-addr +-u -- ) $th$ [tag+$] ;
: [th+$/] ( addr u +-addr +-u -- ) $th$ [tag+$/] ;
: $td$ ( -- ) s" td" ;
: [td] ( -- ) $td$ [tag] ;
: [/td] ( -- ) $td$ [/tag] ;
: [td/] ( -- ) $td$ [tag/] ;
: [td-$] ( addr u -- ) $td$ [tag-$] ;
: [td-$/] ( addr u -- ) $td$ [tag-$/] ;
: [td+] ( +-addr +-u -- ) $td$ [tag+] ;
: [td+$] ( addr u +-addr +-u -- ) $td$ [tag+$] ;
: [td+$/] ( addr u +-addr +-u -- ) $td$ [tag+$/] ;
: $a$ ( -- ) s" a" ;
: [a] ( -- ) $a$ [tag] ;
: [/a] ( -- ) $a$ [/tag] ;
: [a/] ( -- ) $a$ [tag/] ;
: [a-$] ( addr u -- ) $a$ [tag-$] ;
: [a-$/] ( addr u -- ) $a$ [tag-$/] ;
: [a+] ( +-addr +-u -- ) $a$ [tag+] ;
: [a+$] ( addr u +-addr +-u -- ) $a$ [tag+$] ;
: [a+$/] ( addr u +-addr +-u -- ) $a$ [tag+$/] ;
: $div$ ( -- ) s" div" ;
: [div] ( -- ) $div$ [tag] ;
: [/div] ( -- ) $div$ [/tag] ;
: [div/] ( -- ) $div$ [tag/] ;
: [div-$] ( addr u -- ) $div$ [tag-$] ;
: [div-$/] ( addr u -- ) $div$ [tag-$/] ;
: [div+] ( +-addr +-u -- ) $div$ [tag+] ;
: [div+$] ( addr u +-addr +-u -- ) $div$ [tag+$] ;
: [div+$/] ( addr u +-addr +-u -- ) $div$ [tag+$/] ;
: $span$ ( -- ) s" span" ;
: [span] ( -- ) $span$ [tag] ;
: [/span] ( -- ) $span$ [/tag] ;
: [span/] ( -- ) $span$ [tag/] ;
: [span-$] ( addr u -- ) $span$ [tag-$] ;
: [span-$/] ( addr u -- ) $span$ [tag-$/] ;
: [span+] ( +-addr +-u -- ) $span$ [tag+] ;
: [span+$] ( addr u +-addr +-u -- ) $span$ [tag+$] ;
: [span+$/] ( addr u +-addr +-u -- ) $span$ [tag+$/] ;
: $br$ ( -- ) s" br" ;
: [br] ( -- ) $br$ [tag] ;
: [/br] ( -- ) $br$ [/tag] ;
: [br/] ( -- ) $br$ [tag/] ;
: [br-$] ( addr u -- ) $br$ [tag-$] ;
: [br-$/] ( addr u -- ) $br$ [tag-$/] ;
: [br+] ( +-addr +-u -- ) $br$ [tag+] ;
: [br+$] ( addr u +-addr +-u -- ) $br$ [tag+$] ;
: [br+$/] ( addr u +-addr +-u -- ) $br$ [tag+$/] ;
: $hr$ ( -- ) s" hr" ;
: [hr] ( -- ) $hr$ [tag] ;
: [/hr] ( -- ) $hr$ [/tag] ;
: [hr/] ( -- ) $hr$ [tag/] ;
: [hr-$] ( addr u -- ) $hr$ [tag-$] ;
: [hr-$/] ( addr u -- ) $hr$ [tag-$/] ;
: [hr+] ( +-addr +-u -- ) $hr$ [tag+] ;
: [hr+$] ( addr u +-addr +-u -- ) $hr$ [tag+$] ;
: [hr+$/] ( addr u +-addr +-u -- ) $hr$ [tag+$/] ;

252
httags.f Executable file
View File

@ -0,0 +1,252 @@
: $html$ ( -- ) s" html" ;
: [html] ( -- ) $html$ [tag] ;
: [/html] ( -- ) $html$ [/tag] ;
: [html/] ( -- ) $html$ [tag/] ;
: [html-$] ( addr u -- ) $html$ [tag-$] ;
: [html-$/] ( addr u -- ) $html$ [tag-$/] ;
: [html+] ( +-addr +-u -- ) $html$ [tag+] ;
: [html+$] ( addr u +-addr +-u -- ) $html$ [tag+$] ;
: [html+$/] ( addr u +-addr +-u -- ) $html$ [tag+$/] ;
: $head$ ( -- ) s" head" ;
: [head] ( -- ) $head$ [tag] ;
: [/head] ( -- ) $head$ [/tag] ;
: [head/] ( -- ) $head$ [tag/] ;
: [head-$] ( addr u -- ) $head$ [tag-$] ;
: [head-$/] ( addr u -- ) $head$ [tag-$/] ;
: [head+] ( +-addr +-u -- ) $head$ [tag+] ;
: [head+$] ( addr u +-addr +-u -- ) $head$ [tag+$] ;
: [head+$/] ( addr u +-addr +-u -- ) $head$ [tag+$/] ;
: $title$ ( -- ) s" title" ;
: [title] ( -- ) $title$ [tag] ;
: [/title] ( -- ) $title$ [/tag] ;
: [title/] ( -- ) $title$ [tag/] ;
: [title-$] ( addr u -- ) $title$ [tag-$] ;
: [title-$/] ( addr u -- ) $title$ [tag-$/] ;
: [title+] ( +-addr +-u -- ) $title$ [tag+] ;
: [title+$] ( addr u +-addr +-u -- ) $title$ [tag+$] ;
: [title+$/] ( addr u +-addr +-u -- ) $title$ [tag+$/] ;
: $style$ ( -- ) s" style" ;
: [style] ( -- ) $style$ [tag] ;
: [/style] ( -- ) $style$ [/tag] ;
: [style/] ( -- ) $style$ [tag/] ;
: [style-$] ( addr u -- ) $style$ [tag-$] ;
: [style-$/] ( addr u -- ) $style$ [tag-$/] ;
: [style+] ( +-addr +-u -- ) $style$ [tag+] ;
: [style+$] ( addr u +-addr +-u -- ) $style$ [tag+$] ;
: [style+$/] ( addr u +-addr +-u -- ) $style$ [tag+$/] ;
: $meta$ ( -- ) s" meta" ;
: [meta] ( -- ) $meta$ [tag] ;
: [/meta] ( -- ) $meta$ [/tag] ;
: [meta/] ( -- ) $meta$ [tag/] ;
: [meta-$] ( addr u -- ) $meta$ [tag-$] ;
: [meta-$/] ( addr u -- ) $meta$ [tag-$/] ;
: [meta+] ( +-addr +-u -- ) $meta$ [tag+] ;
: [meta+$] ( addr u +-addr +-u -- ) $meta$ [tag+$] ;
: [meta+$/] ( addr u +-addr +-u -- ) $meta$ [tag+$/] ;
: $body$ ( -- ) s" body" ;
: [body] ( -- ) $body$ [tag] ;
: [/body] ( -- ) $body$ [/tag] ;
: [body/] ( -- ) $body$ [tag/] ;
: [body-$] ( addr u -- ) $body$ [tag-$] ;
: [body-$/] ( addr u -- ) $body$ [tag-$/] ;
: [body+] ( +-addr +-u -- ) $body$ [tag+] ;
: [body+$] ( addr u +-addr +-u -- ) $body$ [tag+$] ;
: [body+$/] ( addr u +-addr +-u -- ) $body$ [tag+$/] ;
: $h1$ ( -- ) s" h1" ;
: [h1] ( -- ) $h1$ [tag] ;
: [/h1] ( -- ) $h1$ [/tag] ;
: [h1/] ( -- ) $h1$ [tag/] ;
: [h1-$] ( addr u -- ) $h1$ [tag-$] ;
: [h1-$/] ( addr u -- ) $h1$ [tag-$/] ;
: [h1+] ( +-addr +-u -- ) $h1$ [tag+] ;
: [h1+$] ( addr u +-addr +-u -- ) $h1$ [tag+$] ;
: [h1+$/] ( addr u +-addr +-u -- ) $h1$ [tag+$/] ;
: $h2$ ( -- ) s" h2" ;
: [h2] ( -- ) $h2$ [tag] ;
: [/h2] ( -- ) $h2$ [/tag] ;
: [h2/] ( -- ) $h2$ [tag/] ;
: [h2-$] ( addr u -- ) $h2$ [tag-$] ;
: [h2-$/] ( addr u -- ) $h2$ [tag-$/] ;
: [h2+] ( +-addr +-u -- ) $h2$ [tag+] ;
: [h2+$] ( addr u +-addr +-u -- ) $h2$ [tag+$] ;
: [h2+$/] ( addr u +-addr +-u -- ) $h2$ [tag+$/] ;
: $h3$ ( -- ) s" h3" ;
: [h3] ( -- ) $h3$ [tag] ;
: [/h3] ( -- ) $h3$ [/tag] ;
: [h3/] ( -- ) $h3$ [tag/] ;
: [h3-$] ( addr u -- ) $h3$ [tag-$] ;
: [h3-$/] ( addr u -- ) $h3$ [tag-$/] ;
: [h3+] ( +-addr +-u -- ) $h3$ [tag+] ;
: [h3+$] ( addr u +-addr +-u -- ) $h3$ [tag+$] ;
: [h3+$/] ( addr u +-addr +-u -- ) $h3$ [tag+$/] ;
: $h4$ ( -- ) s" h4" ;
: [h4] ( -- ) $h4$ [tag] ;
: [/h4] ( -- ) $h4$ [/tag] ;
: [h4/] ( -- ) $h4$ [tag/] ;
: [h4-$] ( addr u -- ) $h4$ [tag-$] ;
: [h4-$/] ( addr u -- ) $h4$ [tag-$/] ;
: [h4+] ( +-addr +-u -- ) $h4$ [tag+] ;
: [h4+$] ( addr u +-addr +-u -- ) $h4$ [tag+$] ;
: [h4+$/] ( addr u +-addr +-u -- ) $h4$ [tag+$/] ;
: $h5$ ( -- ) s" h5" ;
: [h5] ( -- ) $h5$ [tag] ;
: [/h5] ( -- ) $h5$ [/tag] ;
: [h5/] ( -- ) $h5$ [tag/] ;
: [h5-$] ( addr u -- ) $h5$ [tag-$] ;
: [h5-$/] ( addr u -- ) $h5$ [tag-$/] ;
: [h5+] ( +-addr +-u -- ) $h5$ [tag+] ;
: [h5+$] ( addr u +-addr +-u -- ) $h5$ [tag+$] ;
: [h5+$/] ( addr u +-addr +-u -- ) $h5$ [tag+$/] ;
: $h6$ ( -- ) s" h6" ;
: [h6] ( -- ) $h6$ [tag] ;
: [/h6] ( -- ) $h6$ [/tag] ;
: [h6/] ( -- ) $h6$ [tag/] ;
: [h6-$] ( addr u -- ) $h6$ [tag-$] ;
: [h6-$/] ( addr u -- ) $h6$ [tag-$/] ;
: [h6+] ( +-addr +-u -- ) $h6$ [tag+] ;
: [h6+$] ( addr u +-addr +-u -- ) $h6$ [tag+$] ;
: [h6+$/] ( addr u +-addr +-u -- ) $h6$ [tag+$/] ;
: $p$ ( -- ) s" p" ;
: [p] ( -- ) $p$ [tag] ;
: [/p] ( -- ) $p$ [/tag] ;
: [p/] ( -- ) $p$ [tag/] ;
: [p-$] ( addr u -- ) $p$ [tag-$] ;
: [p-$/] ( addr u -- ) $p$ [tag-$/] ;
: [p+] ( +-addr +-u -- ) $p$ [tag+] ;
: [p+$] ( addr u +-addr +-u -- ) $p$ [tag+$] ;
: [p+$/] ( addr u +-addr +-u -- ) $p$ [tag+$/] ;
: $strong$ ( -- ) s" strong" ;
: [strong] ( -- ) $strong$ [tag] ;
: [/strong] ( -- ) $strong$ [/tag] ;
: [strong/] ( -- ) $strong$ [tag/] ;
: [strong-$] ( addr u -- ) $strong$ [tag-$] ;
: [strong-$/] ( addr u -- ) $strong$ [tag-$/] ;
: [strong+] ( +-addr +-u -- ) $strong$ [tag+] ;
: [strong+$] ( addr u +-addr +-u -- ) $strong$ [tag+$] ;
: [strong+$/] ( addr u +-addr +-u -- ) $strong$ [tag+$/] ;
: $em$ ( -- ) s" em" ;
: [em] ( -- ) $em$ [tag] ;
: [/em] ( -- ) $em$ [/tag] ;
: [em/] ( -- ) $em$ [tag/] ;
: [em-$] ( addr u -- ) $em$ [tag-$] ;
: [em-$/] ( addr u -- ) $em$ [tag-$/] ;
: [em+] ( +-addr +-u -- ) $em$ [tag+] ;
: [em+$] ( addr u +-addr +-u -- ) $em$ [tag+$] ;
: [em+$/] ( addr u +-addr +-u -- ) $em$ [tag+$/] ;
: $ul$ ( -- ) s" ul" ;
: [ul] ( -- ) $ul$ [tag] ;
: [/ul] ( -- ) $ul$ [/tag] ;
: [ul/] ( -- ) $ul$ [tag/] ;
: [ul-$] ( addr u -- ) $ul$ [tag-$] ;
: [ul-$/] ( addr u -- ) $ul$ [tag-$/] ;
: [ul+] ( +-addr +-u -- ) $ul$ [tag+] ;
: [ul+$] ( addr u +-addr +-u -- ) $ul$ [tag+$] ;
: [ul+$/] ( addr u +-addr +-u -- ) $ul$ [tag+$/] ;
: $ol$ ( -- ) s" ol" ;
: [ol] ( -- ) $ol$ [tag] ;
: [/ol] ( -- ) $ol$ [/tag] ;
: [ol/] ( -- ) $ol$ [tag/] ;
: [ol-$] ( addr u -- ) $ol$ [tag-$] ;
: [ol-$/] ( addr u -- ) $ol$ [tag-$/] ;
: [ol+] ( +-addr +-u -- ) $ol$ [tag+] ;
: [ol+$] ( addr u +-addr +-u -- ) $ol$ [tag+$] ;
: [ol+$/] ( addr u +-addr +-u -- ) $ol$ [tag+$/] ;
: $li$ ( -- ) s" li" ;
: [li] ( -- ) $li$ [tag] ;
: [/li] ( -- ) $li$ [/tag] ;
: [li/] ( -- ) $li$ [tag/] ;
: [li-$] ( addr u -- ) $li$ [tag-$] ;
: [li-$/] ( addr u -- ) $li$ [tag-$/] ;
: [li+] ( +-addr +-u -- ) $li$ [tag+] ;
: [li+$] ( addr u +-addr +-u -- ) $li$ [tag+$] ;
: [li+$/] ( addr u +-addr +-u -- ) $li$ [tag+$/] ;
: $dl$ ( -- ) s" dl" ;
: [dl] ( -- ) $dl$ [tag] ;
: [/dl] ( -- ) $dl$ [/tag] ;
: [dl/] ( -- ) $dl$ [tag/] ;
: [dl-$] ( addr u -- ) $dl$ [tag-$] ;
: [dl-$/] ( addr u -- ) $dl$ [tag-$/] ;
: [dl+] ( +-addr +-u -- ) $dl$ [tag+] ;
: [dl+$] ( addr u +-addr +-u -- ) $dl$ [tag+$] ;
: [dl+$/] ( addr u +-addr +-u -- ) $dl$ [tag+$/] ;
: $dt$ ( -- ) s" dt" ;
: [dt] ( -- ) $dt$ [tag] ;
: [/dt] ( -- ) $dt$ [/tag] ;
: [dt/] ( -- ) $dt$ [tag/] ;
: [dt-$] ( addr u -- ) $dt$ [tag-$] ;
: [dt-$/] ( addr u -- ) $dt$ [tag-$/] ;
: [dt+] ( +-addr +-u -- ) $dt$ [tag+] ;
: [dt+$] ( addr u +-addr +-u -- ) $dt$ [tag+$] ;
: [dt+$/] ( addr u +-addr +-u -- ) $dt$ [tag+$/] ;
: $dd$ ( -- ) s" dd" ;
: [dd] ( -- ) $dd$ [tag] ;
: [/dd] ( -- ) $dd$ [/tag] ;
: [dd/] ( -- ) $dd$ [tag/] ;
: [dd-$] ( addr u -- ) $dd$ [tag-$] ;
: [dd-$/] ( addr u -- ) $dd$ [tag-$/] ;
: [dd+] ( +-addr +-u -- ) $dd$ [tag+] ;
: [dd+$] ( addr u +-addr +-u -- ) $dd$ [tag+$] ;
: [dd+$/] ( addr u +-addr +-u -- ) $dd$ [tag+$/] ;
: $table$ ( -- ) s" table" ;
: [table] ( -- ) $table$ [tag] ;
: [/table] ( -- ) $table$ [/tag] ;
: [table/] ( -- ) $table$ [tag/] ;
: [table-$] ( addr u -- ) $table$ [tag-$] ;
: [table-$/] ( addr u -- ) $table$ [tag-$/] ;
: [table+] ( +-addr +-u -- ) $table$ [tag+] ;
: [table+$] ( addr u +-addr +-u -- ) $table$ [tag+$] ;
: [table+$/] ( addr u +-addr +-u -- ) $table$ [tag+$/] ;
: $thead$ ( -- ) s" thead" ;
: [thead] ( -- ) $thead$ [tag] ;
: [/thead] ( -- ) $thead$ [/tag] ;
: [thead/] ( -- ) $thead$ [tag/] ;
: [thead-$] ( addr u -- ) $thead$ [tag-$] ;
: [thead-$/] ( addr u -- ) $thead$ [tag-$/] ;
: [thead+] ( +-addr +-u -- ) $thead$ [tag+] ;
: [thead+$] ( addr u +-addr +-u -- ) $thead$ [tag+$] ;
: [thead+$/] ( addr u +-addr +-u -- ) $thead$ [tag+$/] ;
: $tbody$ ( -- ) s" tbody" ;
: [tbody] ( -- ) $tbody$ [tag] ;
: [/tbody] ( -- ) $tbody$ [/tag] ;
: [tbody/] ( -- ) $tbody$ [tag/] ;
: [tbody-$] ( addr u -- ) $tbody$ [tag-$] ;
: [tbody-$/] ( addr u -- ) $tbody$ [tag-$/] ;
: [tbody+] ( +-addr +-u -- ) $tbody$ [tag+] ;
: [tbody+$] ( addr u +-addr +-u -- ) $tbody$ [tag+$] ;
: [tbody+$/] ( addr u +-addr +-u -- ) $tbody$ [tag+$/] ;
: $tr$ ( -- ) s" tr" ;
: [tr] ( -- ) $tr$ [tag] ;
: [/tr] ( -- ) $tr$ [/tag] ;
: [tr/] ( -- ) $tr$ [tag/] ;
: [tr-$] ( addr u -- ) $tr$ [tag-$] ;
: [tr-$/] ( addr u -- ) $tr$ [tag-$/] ;
: [tr+] ( +-addr +-u -- ) $tr$ [tag+] ;
: [tr+$] ( addr u +-addr +-u -- ) $tr$ [tag+$] ;
: [tr+$/] ( addr u +-addr +-u -- ) $tr$ [tag+$/] ;
: $th$ ( -- ) s" th" ;
: [th] ( -- ) $th$ [tag] ;
: [/th] ( -- ) $th$ [/tag] ;
: [th/] ( -- ) $th$ [tag/] ;
: [th-$] ( addr u -- ) $th$ [tag-$] ;
: [th-$/] ( addr u -- ) $th$ [tag-$/] ;
: [th+] ( +-addr +-u -- ) $th$ [tag+] ;
: [th+$] ( addr u +-addr +-u -- ) $th$ [tag+$] ;
: [th+$/] ( addr u +-addr +-u -- ) $th$ [tag+$/] ;
: $td$ ( -- ) s" td" ;
: [td] ( -- ) $td$ [tag] ;
: [/td] ( -- ) $td$ [/tag] ;
: [td/] ( -- ) $td$ [tag/] ;
: [td-$] ( addr u -- ) $td$ [tag-$] ;
: [td-$/] ( addr u -- ) $td$ [tag-$/] ;
: [td+] ( +-addr +-u -- ) $td$ [tag+] ;
: [td+$] ( addr u +-addr +-u -- ) $td$ [tag+$] ;
: [td+$/] ( addr u +-addr +-u -- ) $td$ [tag+$/] ;
: $a$ ( -- ) s" a" ;
: [a] ( -- ) $a$ [tag] ;
: [/a] ( -- ) $a$ [/tag] ;
: [a/] ( -- ) $a$ [tag/] ;
: [a-$] ( addr u -- ) $a$ [tag-$] ;
: [a-$/] ( addr u -- ) $a$ [tag-$/] ;
: [a+] ( +-addr +-u -- ) $a$ [tag+] ;
: [a+$] ( addr u +-addr +-u -- ) $a$ [tag+$] ;
: [a+$/] ( addr u +-addr +-u -- ) $a$ [tag+$/] ;

62
lcstr.fs Executable file
View File

@ -0,0 +1,62 @@
\ lcstr.fs -- Long counted string data type
\ 2016 David Meyer <papa@sdf.org> +JMJ
\ Long counted strings (lcstr) are similar to standard counted strings, except
\ that the string length is stored as an unsigned single-precision integer (4
\ bytes) instead of a character (which limits standard counted strings to 255
\ character maximum length). Long counted sting maximum length is
\ 256^4-1 bytes subject to the limit of heap space allocation.
\ Stack effects, variables, etc. representing long counted strings will
\ conventionally start with "L", addresses of long counted strings with "L-".
: lcount ( l-str -- c-str u )
\g Extract pointer C-STR and length U of lcstr L-STR
dup 1 cells + swap @ ;
: ltype ( l-str -- )
\g Output lcstr to standard output
lcount type ;
: lalloc ( c-str u -- l-str )
\g Allocate heap space for lcstr version of string C-STR,U
dup chars 1 cells + allocate if ( a-str u l-str)
drop 2drop 0 \ Returns pointer 0 for alloc. error
else
2dup ! dup >r 1 cells + swap cmove r>
then
;
: clalloc ( c-str -- l-str )
\g Allocate heap space and convery counted string for C-STR tp lcstr
count lalloc ;
: $catcpy { a-str1 u1 a-str2 u2 a-cat ucat -- }
\g Copy characters from STR1 and STR2 to pre-allocated CAT
a-str1 a-cat u1 cmove
a-str2 a-cat u1 chars + u2 cmove
;
: c$cat ( c-str1 c-str2 -- c-cat )
\g Concatenate two counted strings in heap, preserve original strings
count dup >r rot count dup >r 2swap ( a-str1 u1 a-str2 u2 R: u2 u1 )
r> r> + dup 1+ chars allocate if ( a-str1 u1 a-str2 u2 ucat c-cat )
clearstack 0 \ Returns 0 c-pointer for alloc. error
else
tuck c! ( a-str1 u1 a-str2 u2 c-cat )
dup >r count $catcpy r>
then
;
: c$catx ( c-str1 c-str2 ux -- c-cat )
\g Concatenate two counted strings in heap, recycle original strings according to UX: 0 -- recycle STR1 and STR2, 1 -- recycle STR1 only, 2 -- recycle STR2 only
>r 2dup c$cat r> ( c-str1 c-str2 c-cat ux )
dup 2 = if
drop swap free drop nip
else dup 1 = if
drop nip swap free drop
else 0= if
swap free drop
swap free drop
then then then
;

BIN
length-units.xls Executable file
View File

Binary file not shown.

8
level-0.org Executable file
View File

@ -0,0 +1,8 @@
Forth Level 0 Functions
dup drop swap over + - * / /mod min max = and or xor negate abs not
*/ decimal hex octal . n .r cr emit key : ; create , allot if else
then for next i
From: Glen B. Haydon. Levels of
Forth. <http://www.taygeta.com/forthlev.html>

1764
lf.4th Executable file
View File

File diff suppressed because it is too large Load Diff

37
life.fs Executable file
View File

@ -0,0 +1,37 @@
VARIABLE STATEBLK
VARIABLE LIFEBLK
VARIABLE STATEP
\ : -ROT ROT ROT ;
: WRAPY DUP 0< IF DROP 15 THEN DUP 15 > IF DROP 0 THEN ;
: WRAPX DUP 0< IF DROP 63 THEN DUP 63 > IF DROP 0 THEN ;
: WRAP WRAPY SWAP WRAPX SWAP ;
: DECEASED? WRAP 64 * + LIFEBLK @ BLOCK + C@ BL = ;
: LIVING? DECEASED? 0= ;
: (-1,-1) 2DUP 1- SWAP 1- SWAP LIVING? 1 AND ;
: (0,-1) >R 2DUP 1- LIVING? 1 AND R> + ;
: (1,-1) >R 2DUP 1- SWAP 1+ SWAP LIVING? 1 AND R> + ;
: (-1,0) >R 2DUP SWAP 1- SWAP LIVING? 1 AND R> + ;
: (1,0) >R 2DUP SWAP 1+ SWAP LIVING? 1 AND R> + ;
: (-1,1) >R 2DUP 1+ SWAP 1- SWAP LIVING? 1 AND R> + ;
: (0,1) >R 2DUP 1+ LIVING? 1 AND R> + ;
: (1,1) >R 1+ SWAP 1+ SWAP LIVING? 1 AND R> + ;
: NEIGHBORS (-1,-1) (0,-1) (1,-1) (-1,0) (1,0) (-1,1) (0,1) (1,1) ;
: BORN? NEIGHBORS 3 = ;
: SURVIVES? 2DUP LIVING? -ROT NEIGHBORS 2 = AND ;
: LIVES? 2DUP BORN? -ROT SURVIVES? OR ;
: NEWSTATE STATEBLK @ BLOCK UPDATE STATEP ! ;
: STATE! STATEP @ C! 1 STATEP +! ;
: ALIVE [CHAR] * STATE! ;
: DEAD BL STATE! ;
: ITERATE-CELL 2DUP SWAP LIVES? IF ALIVE ELSE DEAD THEN ;
: ITERATE-ROW 0 BEGIN DUP 64 < WHILE ITERATE-CELL 1+ REPEAT DROP ;
: ITERATE-BLOCK 0 BEGIN DUP 16 < WHILE ITERATE-ROW 1+ REPEAT DROP ;
: GENERATION LIFEBLK @ STATEBLK @ LIFEBLK ! STATEBLK ! ;
: ITERATE NEWSTATE ITERATE-BLOCK GENERATION ;
: DONE? KEY [CHAR] Q = ;
: PROMPT CR ." PRESS Q TO EXIT; OTHER KEY TO CONTINUE" ;
: VIEW PAGE LIFEBLK @ LIST PROMPT ;
: LIFE BEGIN VIEW ITERATE DONE? UNTIL ;

649
mailfig.fth Executable file
View File

@ -0,0 +1,649 @@
\ MAILFIG program to handle forms for comments to FIG
\ This is an ANS Forth program requiring:
\ 1. The File Access word set.
\ 2. The words CMOVE and COMPARE from the String word set.
\ 3. A system dependent word GETENV to get the specified
\ environment string,
\ GETENV ( str count -- str' count' )
\ 4. The word STDIN to get the file ID of standard input.
\ 5. The words OPEN-PIPE and CLOSE-PIPE to open and close pipes to
\ processes. (These are communicated with via the normal File access
\ words).
\ 6. READ to write to Unix file descriptors (because of a problem with
\ ThisForth 94-09-12).
\ (c) Copyright 1994 Everett F. Carter. Permission is granted by the
\ author to use this software for any application provided this
\ copyright notice is preserved.
\ rcsid: @(#)mailfig.fth 1.5 10:15:52 11/6/95 EFC
FALSE CONSTANT ?DEBUG
TRUE CONSTANT ThisForth
FALSE CONSTANT PFE
ThisForth [IF]
\ =================== ANS File words for ThisForth =========================
\ file open modes
: R/W S" r+" ;
: R/O S" r" ;
: W/O S" w" ;
: APPEND S" a" ; \ NOT ANS, but necessary
: OPEN-FILE fopen DUP 0= ;
: READ-LINE ( addr u fileid -- u' flag ior )
STREAM
0 SWAP
0 DO
next-char EOL = IF LEAVE THEN
next-char EOF = IF LEAVE THEN
get-char
2 PICK I + C!
1+
LOOP
UNSTREAM
SWAP DROP TRUE 0
;
: READ-FILE ( addr u fileid -- u' flag ) \ a hack
STREAM
0 SWAP
0 DO
next-char EOF = IF LEAVE THEN
get-char
2 PICK I + C!
1+
LOOP
UNSTREAM
SWAP DROP FALSE
;
: REPOSITION-FILE ( d fid -- flag )
ROT ROT DROP 0
fseek
;
: WRITE-FILE ( c-addr u fileid -- ior )
DISPLAY TYPE
0 DISPLAY
TRUE
;
: WRITE-LINE ( c-addr u fileid -- ior )
DISPLAY TYPE CR
0 DISPLAY
TRUE
;
: CLOSE-FILE fclose ;
[THEN]
\ =========================================================================
ThisForth [IF] \ ThisForth version
: OPEN-APPEND
APPEND OPEN-FILE
;
[ELSE]
\ ANS Brute force OPEN-APPEND, depending upon what is under the hood, there may
\ be more efficient definitions
: OPEN-APPEND R/W OPEN-FILE
DUP 0= IF OVER FILE-SIZE
0= IF 3 PICK REPOSITION-FILE DROP THEN
THEN
;
[THEN]
FALSE VALUE bad-status
0 VALUE seq-file
0 VALUE log-file
0 VALUE seq-no
FALSE VALUE cc-req
FALSE VALUE unesc-req
FALSE VALUE strip-plus-req
CREATE NEW-LINE-CHARS 2 ALLOT
10 NEW-LINE-CHARS C!
\ 13 NEW-LINE-CHARS 1+ C!
0 VALUE buf-len
0 VALUE input-buffer
VARIABLE scan-ptr
ALIGN
CREATE out-buf 32 ALLOT
\ ============= A String pointer data structure =============================
: string: \ build a counted string
CREATE
0 , \ POINTER to the data
0 , \ the count
DOES>
DUP @ SWAP CELL+ @
;
: $! ( addr count 'str -- ) \ store a string
>BODY
SWAP OVER CELL+ !
!
;
: $len ( addr count -- count )
SWAP DROP
;
: $copy ( addr count 'str -- )
HERE 2 PICK ROT $! \ store string pointer to HERE
HERE SWAP DUP ALLOT
CMOVE
;
: $cat ( addr1 count1 addr2 count2 -- addr count )
2 PICK OVER + DUP >R
HERE >R
ALLOT
2SWAP
R@ SWAP DUP >R CMOVE \ move first string
R> R@ +
SWAP CMOVE \ move the second string
R> R>
;
\ the data fields
string: name
string: comments
string: e-mail
string: subject
string: request
\ ======================= LOCAL FILE NAMES ================================
string: SEQFILE
string: LOGFILE
string: PROGRAM
string: MAILER
string: HOSTNAME
string: DESTINATION
: init-strings
S" /usr/skip/forth/FIG/figmail.seq" ['] SEQFILE $copy
S" /usr/skip/forth/FIG/figmail.log" ['] LOGFILE $copy
S" mailfig.fth V1.5" ['] PROGRAM $copy
S" taygeta.com" ['] HOSTNAME $copy
\ This is the name of the mail program, we are using URL escape codes
\ for quotes which will be converted to actual quotes later
S" /usr/ucb/Mail -s %22FIG Comments%22 johnhall@aol.com skip@taygeta.com " ['] MAILER $copy
\ S" johnhall@aol.com skip@taygeta.com " ['] DESTINATION $copy
\ S" johnhall@aol.com " ['] DESTINATION $copy
\ DESTINATION S" skip@taygeta.com " $cat ['] DESTINATION $!
\ S" skip@taygeta.com " ['] DESTINATION $copy
;
\ =========================================================================
: acknowledge ( -- )
." <HEADER><TITLE> Mail to Forth Interest Group OK "
." </TITLE></HEADER> " CR
." Everything received <B>OK</B><P> "
." Thanks for the mail!" CR
." <P><hr>" CR
." <A HREF=http://www.taygeta.com/fig.html> "
." <IMG SRC=" [CHAR] " EMIT
." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
." ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." > "
." Back to FIG Home page</A>. " CR
." <P> " CR
;
: nack ( -- )
." <HEADER><TITLE> Mail to Forth Interest Group NOT OK "
." </TITLE></HEADER> " CR
." Sorry, There seems to be a problem with the form as you filled it out "
CR CR
." Is perhaps your name/e-mail missing ?" CR
." <P><hr> " CR
." <A HREF=http://www.taygeta.com/fig/figmail.html> "
." <IMG SRC=" [CHAR] " EMIT
." http://www.taygeta.com/icons/back.xbm" [CHAR] " EMIT
." ALT = " [CHAR] " EMIT ." <--" [CHAR] " EMIT ." > "
." Back to FIG Mailer Form page</A>. " CR
." <P> " CR
;
: sig
." <P><HR><ADDRESS><CENTER> " CR
." Everett F. Carter Jr. -- skip@taygeta.com" CR
." </CENTER></ADDRESS> " CR
;
: atol ( addr count -- d )
>R
0. ROT
R>
>NUMBER
2DROP
;
: atoi ( addr count -- n )
atol DROP
;
: move-chars ( dest src count -- dest count )
>R OVER R@ CMOVE R>
;
: itoa ( n -- addr count ) \ (signed) int to counted string
out-buf aligned SWAP
DUP >R ABS S>D
<# #S R> SIGN #>
move-chars
;
: newline ( fileid -- flag )
NEW-LINE-CHARS 1 ROT WRITE-FILE
;
: update_sequence_number ( -- old_no )
SEQFILE R/W OPEN-FILE ABORT" Unable to open sequence file "
TO seq-file
\ get the current sequence number
PAD 16 seq-file READ-LINE ABORT" file read error "
DROP
PAD SWAP atoi
\ increment the number and store it away
DUP 1+
0. seq-file REPOSITION-FILE DROP
itoa seq-file WRITE-LINE DROP
seq-file CLOSE-FILE DROP
;
: write-env ( -- len )
S" SERVER_PROTOCOL" getenv
DUP 0= IF 2DROP S" HTTP/1.0" THEN TYPE
." 200 OK" CR
." MIME-Version: 1.0" CR
S" SERVER_SOFTWARE" getenv
DUP 0 > IF TYPE CR ELSE 2DROP THEN
." Content-Type: text/html" CR
\ ." Content-Encoding: HTML" CR
\ ." Content-Transfer-Encoding: HTML" CR
CR
S" CONTENT_LENGTH" getenv
DUP IF atoi ELSE 2DROP 0 THEN
;
: plus->space ( addr count -- ) \ convert pluses to spaces
0 ?DO I OVER + C@ [CHAR] + = IF I OVER + BL SWAP C! THEN LOOP
DROP
;
: x2c ( addr count -- n )
HEX
>R 0. ROT R>
>NUMBER
2DROP DROP
DECIMAL
;
: unescape-url ( addr count -- count' )
-1 SWAP
0 ?DO
1+
OVER OVER + \ get &url[x]
2 PICK I + C@ \ get url[y]
DUP ROT C! \ url[x] = url[y]
[CHAR] % = IF \ convert it if it is a % char
OVER I + 1+ 2 x2c \ convert url[y+1]
2 PICK 2 PICK + C! \ and store it at url[x]
3
ELSE
1
THEN
+LOOP
1+ \ adjust count
SWAP DROP
;
: skip-past-equals ( -- )
scan-ptr @ DUP buf-len SWAP ?DO
1+
input-buffer I + C@
[CHAR] = = IF LEAVE THEN
LOOP
scan-ptr !
;
: length-to-ampersand ( -- n )
0
buf-len scan-ptr @ ?DO
input-buffer I + C@
[CHAR] & = IF LEAVE THEN
1+
LOOP
;
: scan-in ( -- addr count | 0 )
skip-past-equals
length-to-ampersand
DUP 0 > IF
input-buffer scan-ptr @ + \ addr of first char
SWAP \ put count on top
DUP scan-ptr +!
THEN
;
\ get data from input stream (stdin)
\ set BAD-STATUS if it failed
: get-input-data ( addr len -- )
\ STDIN READ-FILE
\ The above SHOULD work, but with ThisForth 94-09-12
\ it doesn't when this is run with no tty attached (as it will be
\ when HTTP invokes it), so instead we are using:
0 READ
DUP 0 <
TO bad-status
TO buf-len
;
: scan-input-data ( -- )
0 scan-ptr !
scan-in DUP 0 > IF ['] subject $! THEN
scan-in DUP 0 > IF ['] comments $! THEN
scan-in DUP 0 > IF ['] name $! THEN
scan-in DUP 0 > IF ['] e-mail $! THEN
\ get cc request
scan-in DUP 0 > IF ['] request $! THEN
request 3 MIN S" Yes" compare 0= TO cc-req
\ get strip_plus request
scan-in DUP 0 > IF ['] request $! THEN
request 3 MIN S" Yes" compare 0= TO strip-plus-req
\ get unescape request
scan-in DUP 0 > IF ['] request $! THEN
request 3 MIN S" Yes" compare 0= TO unesc-req
name plus->space
strip-plus-req IF
subject plus->space
comments plus->space
THEN
name unescape-url name DROP SWAP ['] name $!
unesc-req IF
subject unescape-url subject DROP SWAP ['] subject $!
comments unescape-url comments DROP SWAP ['] comments $!
THEN
\ need a name or e-mail
name $len 0= e-mail $len 0= AND TO bad-status
;
: report-field ( addr count handle -- )
OVER 0= IF SWAP DROP SWAP DROP S" (None) " ROT THEN
WRITE-FILE DROP
;
: report ( handle -- )
S" Subject: " 2 PICK WRITE-FILE DROP
subject 2 PICK report-field
DUP newline DROP
S" Comments: " 2 PICK WRITE-FILE DROP
DUP newline DROP
comments 2 PICK report-field
DUP newline DROP
DUP newline DROP
S" Name: " 2 PICK WRITE-FILE DROP
name 2 PICK report-field
DUP newline DROP
S" e-mail: " 2 PICK WRITE-FILE DROP
e-mail 2 PICK report-field
newline DROP
;
: sendmail ( handle -- handle )
DUP report
S" Sequence number: " 2 PICK WRITE-FILE DROP
seq-no itoa 2 PICK WRITE-LINE DROP
S" Received at " 2 PICK WRITE-FILE DROP
PAD 24 timestamp 2 PICK WRITE-FILE DROP
S" from the WWW page on: " 2 PICK WRITE-FILE DROP
HOSTNAME 2 PICK WRITE-LINE DROP
S" Program: " 2 PICK WRITE-FILE DROP
PROGRAM 2 PICK WRITE-LINE DROP
DUP newline DROP
;
: mail_fig ( -- )
init-strings
\ fix the mailer string
MAILER unescape-url MAILER DROP SWAP ['] MAILER $!
MAILER DESTINATION $cat ['] MAILER $!
LOGFILE OPEN-APPEND ABORT" Unable to open log file "
TO log-file
update_sequence_number DUP TO seq-no
PAD 24 timestamp log-file WRITE-FILE DROP
S" Sequence number is: " log-file WRITE-FILE DROP
itoa log-file WRITE-FILE DROP
log-file newline DROP
write-env
?DEBUG IF
S" CONTENT LENGTH = " log-file WRITE-FILE DROP
DUP itoa log-file WRITE-FILE DROP
THEN
\ allocate space for the buffer
HERE TO input-buffer
DUP 2 + DUP TO buf-len ALLOT
\ now read characters from the input stream
input-buffer SWAP get-input-data
?DEBUG IF
S" BUF-LEN = " log-file WRITE-FILE DROP
buf-len itoa log-file WRITE-FILE DROP
S" status = " log-file WRITE-FILE DROP
bad-status itoa log-file WRITE-FILE DROP
log-file newline DROP
THEN
?DEBUG IF
input-buffer buf-len log-file WRITE-FILE DROP
log-file newline DROP
THEN
scan-input-data
log-file report
bad-status IF nack
ELSE
\ open the mail pipe
cc-req IF
MAILER e-mail $cat ['] MAILER $!
THEN
?DEBUG IF
S" Mailer: " log-file WRITE-FILE DROP
MAILER log-file WRITE-FILE DROP
log-file newline DROP
THEN
\ ." Mailer command <" MAILER TYPE ." >" CR
MAILER W/O OPEN-PIPE
ABORT" Unable to open pipe to mailer "
sendmail
CLOSE-PIPE DROP
acknowledge
THEN
sig
log-file newline DROP
log-file CLOSE-FILE DROP
;
\ auto-startup word
: startup mail_fig bye ;
PFE [IF]
startup
[THEN]

2
marcel-hendrix.blink Executable file
View File

@ -0,0 +1,2 @@
Marcel Hendrix's home-page
http://home.iae.nl/users/mhx/index.html

99
mccirc.fs Executable file
View File

@ -0,0 +1,99 @@
\ mccirc.fs - Minecraft circle block calculator
variable lr
cr .( Reading mccirc.fs ... )
: box ( -- ) ." []" ;
: boxes ( u -- ) 0 u+do box loop ;
: prline ( u -- ) cr dup 2 .r space boxes ;
: prline2 ( u1 u2 -- ) cr dup 2 * 2 .r space dup rot swap - 2 * spaces dup boxes ." |" boxes ;
: haxise ( uw ur -- , Print horizontal axis for edge-centered circle
uw: centering field width
ur: circle radius )
cr
tuck 2 * 3 + - 2 / spaces
2 * 1+ dup
0 u+do [char] - emit loop
[char] + emit
0 u+do [char] - emit loop
;
: haxisb ( uw ur -- , Print horizontal axis for block-centered circle
uw: centering field width
ur: circle radius )
cr
tuck 4 * 1+ - 2 / spaces [char] - emit
1- dup
0 u+do ." [-" loop
." [+]"
0 u+do ." -]" loop
[char] - emit
;
: proline ( u -- ) cr dup 2 .r space ." +]" 1- boxes ;
\ mccirce -- Blocks in edge-centered circle with radius ur blocks
: mccirce { ur -- }
ur 0 u+do
0 lr !
ur 0 u+do
\ j dup * i dup * +
\ s>d d>f fsqrt
j 10 * 5 + dup * i 10 * 5 + dup * +
s>d d>f 1e2 f/ fsqrt
f>d d>s ur < if
1 lr +!
then
loop
ur lr @ prline2
loop
cr
;
: mccircei { ur -- }
ur 0 u+do
0 lr !
ur 0 u+do
ur j - 10 * 5 - dup * i 10 * 5 + dup * +
s>d d>f 1e2 f/ fsqrt
f>d d>s ur < if
1 lr +!
then
loop
lr @
dup ur swap prline2
loop
haxise
ur 0 u+do
ur swap prline2
loop
;
\ mccircb -- Blocks in block-centered circle with radius ur blocks
: mccircb { ur -- }
ur 0 u+do
0 lr !
ur 0 u+do
j 10 * 5 + dup * i 10 * 5 + dup * +
s>d d>f 1e2 f/ fsqrt
f>d d>s ur 1+ < if
1 lr +!
then
loop
lr @ i if prline else proline then
loop
cr
;
\ mccirc -- Blocks in circle with diameter ud blocks
: mccirc { ud -- }
ud 2 mod if
ud 2 / 1+ mccircb
else
ud 2 / mccirce
then
;

115
mccurve.fs Executable file
View File

@ -0,0 +1,115 @@
\ mccirc.fs - Minecraft circle block calculator
variable UD \ Plotting circle diameter in blocks
variable UR \ Plotting circle radius in blocks
variable FB \ Plotting circle block-centered flag (FALSE => edge-centered)
variable UW \ Centering field width in characters
variable USC \ Current semi-chord length in blocks
\ Graphic elements
create C-BOX \ [] box
2 c, 91 c, 93 c,
create C-ORGB \ [+] origin (box-centered)
3 c, 91 c, 43 c, 93 c,
create C-AXVB \ [|] vert. axis (box-centered)
3 c, 91 c, 124 c, 93 c,
create C-AXHLB \ [- horiz. axis left (box-centered)
2 c, 91 c, 45 c,
create C-AXHRB \ -] horiz. axis right (box-centered)
2 c, 45 c, 93 c,
create C-ORGE \ + origin (edge-centered)
1 c, 43 c,
create C-AXVE \ | vert. axis (edge-centered)
1 c, 124 c,
create C-AXHE \ -- horiz. axis (edge-centered)
2 c, 45 c, 45 c,
: cstype ( c-elem -- , type counted string C-ELEM )
count type ;
: multype ( u c-elem -- , type counted string C-ELEM U times )
count rot
1 u+do 2dup type loop
type
;
: b>c ( ub -- uc , Convert blocks UB to char. width UC )
2* ;
: chrdblk ( usc -- ub : Calculate blocks in chord UB with semi-chord length USC )
2* FB @ if 1+ then ;
: chord ( uw usc -- : Print horizontal circle chord with length 2*USC centere in field UW chars )
tuck FB @ if 2* 1+ b>c else 2* b>c 1+ then - 2/ ( usc um )
tuck cr spaces ( um usc )
dup C-BOX multype
FB @ if C-AXVB else C-AXVE then cstype
dup C-BOX multype
swap 2 + spaces chrdblk .
;
: haxis ( uw ur -- : Print horizontal axis )
tuck FB @ if 2* 1+ b>c else 2* b>c 1+ then - 2/ ( ur um )
tuck cr spaces dup dup
FB @ if
C-AXHLB multype
C-ORGB cstype
C-AXHRB multype
else
C-AXHE multype
C-ORGE cstype
C-AXHE multype
then
FB @ if swap 2 + spaces chrdblk . else 2drop then
;
: fincircle ( uy ux -- f : Determine if block UX,UY is within circle - Global: UR )
10 * 5 + swap 10 * 5 +
dup * swap dup * +
s>d d>f 1e2 f/ fsqrt f>d d>s
UR @ <
;
: scircle ( ud -- : Plot semicircle with diameter UD blocks -- Globals: UD, UR, FB, UW, USC )
dup UD !
dup 2/ UR !
dup 2 mod FB !
b>c FB @ invert if 1+ then UW !
UW @ UR @ haxis
FB @ invert if UW @ UR @ chord then
UR @ 1 u+do
1 USC !
UR @ 1 u+do
j i fincircle if 1 USC +! then
loop
UW @ USC @ chord
loop
;
: circle ( ud -- : Plot circle with diameter UD blocks -- Globals: UD, UR, FB, UW, USC )
dup UD !
dup 2/ UR !
dup 2 mod FB !
b>c 1+ UW !
UR @ 1 u+do
1 USC !
UR @ 1 u+do
UR @ j - i fincircle if 1 USC +! then
loop
USC @
dup UW @ swap chord
loop
FB @ invert if UW @ UR @ chord then
UW @ UR @ haxis
FB @ invert if UW @ UR @ chord then
UR @ 1 u+do UW @ swap chord loop
;
: hsphere ( ud -- , plot layers of hemisphere with block diameter UD )
;
: ellipse ( umaj umin -- , plot ellipse with major axis UMAJ blocks and minor axis UMIN blocks )
;

113
mccurve0.fs Executable file
View File

@ -0,0 +1,113 @@
\ mccirc.fs - Minecraft circle block calculator
variable UD \ Plotting circle diameter in blocks
variable UR \ Plotting circle radius in blocks
variable FB \ Plotting circle block-centered flag (FALSE => edge-centered)
variable UW \ Centering field width in characters
variable USC \ Current semi-chord length in blocks
\ Graphic elements
create C-BOX \ [.] box
3 c, 91 c, 46 c, 93 c,
create C-ORGB \ [+] origin (box-centered)
3 c, 91 c, 43 c, 93 c,
create C-AXVB \ [|] vert. axis (box-centered)
3 c, 91 c, 124 c, 93 c,
create C-AXHB \ [-] horiz. axis (box-centered)
3 c, 91 c, 45 c, 93 c,
create C-ORGE \ + origin (edge-centered)
1 c, 43 c,
create C-AXVE \ | vert. axis (edge-centered)
1 c, 124 c,
create C-AXHE \ --- horiz. axis (edge-centered)
3 c, 45 c, 45 c, 45 c,
: cstype ( c-elem -- , type counted string C-ELEM )
count type ;
: multype ( u c-elem -- , type counted string C-ELEM U times )
count rot
1 u+do 2dup type loop
type
;
: b>c ( ub -- uc , Convert blocks UB to char. width UC )
3 * ;
: chrdblk ( usc -- ub : Calculate blocks in chord UB with semi-chord length USC )
2* FB @ if 1+ then ;
: chord ( uw usc -- : Print horizontal circle chord with length 2*USC centere in field UW chars )
tuck FB @ if 2* 1+ b>c else 2* b>c 1+ then - 2/ ( usc um )
tuck cr spaces ( um usc )
dup C-BOX multype
FB @ if C-AXVB else C-AXVE then cstype
dup C-BOX multype
swap 2 + spaces chrdblk .
;
: haxis ( uw ur -- : Print horizontal axis )
tuck FB @ if 2* 1+ b>c else 2* b>c 1+ then - 2/ ( ur um )
tuck cr spaces dup dup
FB @ if
C-AXHB multype
C-ORGB cstype
C-AXHB multype
else
C-AXHE multype
C-ORGE cstype
C-AXHE multype
then
FB @ if swap 2 + spaces chrdblk . else 2drop then
;
: fincircle ( uy ux -- f : Determine if block UX,UY is within circle / Global: UR )
10 * 5 + swap 10 * 5 +
dup * swap dup * +
s>d d>f 1e2 f/ fsqrt f>d d>s
UR @ <
;
: scircle ( ud -- : Plot semicircle with diameter UD blocks / Globals: UD, UR, FB, UW, USC )
dup UD !
dup 2/ UR !
dup 2 mod FB !
b>c FB @ invert if 1+ then UW !
UW @ UR @ haxis
FB @ invert if UW @ UR @ chord then
UR @ 1 u+do
1 USC !
UR @ 1 u+do
j i fincircle if 1 USC +! then
loop
UW @ USC @ chord
loop
;
: circle ( ud -- : Plot circle with diameter UD blocks / Globals: UD, UR, FB, UW, USC )
dup UD !
dup 2/ UR !
dup 2 mod FB !
b>c FB @ invert if 1+ then UW !
UR @ 1 u+do
1 USC !
UR @ 1 u+do
UR @ j - i fincircle if 1 USC +! then
loop
USC @
dup UW @ swap chord
loop
FB @ invert if UW @ UR @ chord then
UW @ UR @ haxis
FB @ invert if UW @ UR @ chord then
UR @ 1 u+do UW @ swap chord loop
;
: hsphere ( ud -- , plot layers of hemisphere with block diameter UD )
;
: ellipse ( umaj umin -- , plot ellipse with major axis UMAJ blocks and minor axis UMIN blocks )
;

2
moore-geek.blink Executable file
View File

@ -0,0 +1,2 @@
Chuck Moore: Geek of the Week
http://www.simple-talk.com/opinion/geek-of-the-week/chuck-moore-geek-of-the-week/

21
mymath.fs Executable file
View File

@ -0,0 +1,21 @@
\ mymath.fs - Arithmetic utilities
\
\ Copyright 2018 David Meyer <papa@sdf.org> +JMJ
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
\
\ u** - power (x^y) for unsigned integers
: u** ( u1 u2 -- u1^u2 )
1 swap 0 u+do over * loop nip ;

1888
pf.perl Executable file
View File

File diff suppressed because it is too large Load Diff

16
random.f Executable file
View File

@ -0,0 +1,16 @@
\ random.f
\ Simple random number generator
\ from Leo Brodie, _Starting Forth_
variable rnd \ Holds current result
\ Generate a random integer
: random ( -- u ) rnd @ 31421 * 6927 + dup rnd ! ;
\ Return a randm integer between 0 and u-1
: choose ( u -- 0...u-1 ) random um* nip ;
\ Initialize
: randomize ( -- ) time&date + + + + + rnd ! ;

16
random.fs Executable file
View File

@ -0,0 +1,16 @@
\ random.fs
\ Simple random number generator
\ from Leo Brodie, _Starting Forth_
variable rnd
\ Holds current result
\ Generate a random integer
: random ( -- u ) rnd @ 31421 * 6927 + dup rnd ! ;
\ Return a random integer between 0 and u-1
: choose ( u -- 0...u-1 ) random um* nip ;
\ Initialize
\ : randomize ( -- ) time&date + + + + + rnd ! ;
: randomize ( -- ) utime drop rnd ! ; \ papa 2016-04-19

330
roman.fs Executable file
View File

@ -0,0 +1,330 @@
\ roman.fs - Roman numeral and date words
\
\ Copyright 2018 David Meyer <papa@sdf.org> +JMJ
\
\ Licensed under the Apache License, Version 2.0 (the "License");
\ you may not use this file except in compliance with the License.
\ You may obtain a copy of the License at
\
\ http://www.apache.org/licenses/LICENSE-2.0
\
\ Unless required by applicable law or agreed to in writing, software
\ distributed under the License is distributed on an "AS IS" BASIS,
\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
\ See the License for the specific language governing permissions and
\ limitations under the License.
\
include mymath.fs
0 constant KALENDS
1 constant NONES
2 constant IDES
3 constant NEXTKAL
create NONESDAY 5 , 5 , 7 , 5 , 7 , 5 , 7 , 5 , 5 , 7 , 5 , 5 ,
create IDESDAY 13 , 13 , 15 , 13 , 15 , 13 , 15 , 13 , 13 , 15 , 13 , 13 ,
create EOMDAY 31 , 28 , 31 , 30 , 31 , 30 , 31 , 31 , 30 , 31 , 30 , 31 ,
\ numeral9 - superstring and accessor/printer for roman numerals "9";
\ u = power of 10 [0, 2]
: "numeral9" c" IXXCCM" ;
: numeral9 ( u -- ) 2 * "numeral9" 1+ + 2 type ;
\ numeral5 - superstring and accessor/printer for roman numerals "5";
\ u = power of 10 [0, 2]
: "numeral5" c" VLD" ;
: numeral5 ( u -- ) "numeral5" 1+ + 1 type ;
\ numeral4 - superstring and accessor/printer for roman numerals "4";
\ u = power of 10 [0, 2]
: "numeral4" c" IVXLCD" ;
: numeral4 ( u -- ) 2 * "numeral4" 1+ + 2 type ;
\ numeral1 - superstring and accessor/printer for roman numerals "1";
\ u = power of 10 [0, 3]
: "numeral1" c" IXCM" ;
: numeral1 ( u -- ) "numeral1" 1+ + 1 type ;
\ pvnumeral - type roman numeral for given power of 10 [0, 3] and place value
\ [1, 9]
: pvnumeral ( upow uval -- )
dup 9 = if
drop numeral9
else
dup 4 = if
drop numeral4
else
dup 4 > if
over numeral5
5 -
then
0 u+do dup numeral1 loop
drop
then
then
;
\ romnumeral - print Roman numeral for given number [1, 3999]
: romnumeral ( u -- )
-1 3 -do
10 i u** /mod ( u%10^i u/10^i )
dup if
i swap pvnumeral
else drop
then
1 -loop
drop
;
\ range check
: romnumeral ( u -- )
dup 0>
over 4000 <
and if
romnumeral
else
." ERROR romnumeral: argument out of range: " .
then
;
\ bisyear - Determine if A.D. year is bissextile (leap) year
: bisyear ( uyear -- fbissextile )
dup 4 mod 0= swap
dup 100 mod 0<> swap
400 mod 0=
or and
;
\ knidays - Determine Kalends/Nones/Ides and before-day count for date
: knidays ( bis m d -- ukni uantediem )
dup 1 = if
nip nip KALENDS
else 2dup swap 1- cells NONESDAY + @ 2dup <= if ( bis m d d nd )
swap - 1+ nip nip nip NONES
else 2drop 2dup swap 1- cells IDESDAY + @ 2dup <= if ( bis m d d id )
swap - 1+ nip nip nip IDES
else
2drop over 1- cells EOMDAY + @ ( bis m d eom )
swap - 2 +
swap 2 = rot and if 1+ then
NEXTKAL
then then then
swap
;
\ monthnones - Nones day-of-month
: monthnones ( umonth -- unones )
1- cells NONESDAY + @ ;
\ monthides - Ides day-of-month
: monthides ( umonth -- uides )
1- cells IDESDAY + @ ;
\ monthend - Last day of month
: monthend ( umonth -- ueom )
1- cells EOMDAY + @ ;
\ mdkni - Closest Kalends/Nones/Ides on or following date
: mdkni ( umonth uday -- ukni )
dup 1 = if
2drop KALENDS
else 2dup swap monthnones <= if
2drop NONES
else over monthides <= if
drop IDES
else
drop NEXTKAL
then then then
;
\ antediem - Roman day count before Kalends/Nones/Ides
: antediem ( fbis umonth uday ukni -- uad )
dup KALENDS = if \ Kalends (a.d. always 1)
2drop 2drop 1
else dup NONES = if \ Nones
drop swap monthnones swap - 1+ nip
else IDES = if \ Ides
swap monthides swap - 1+ nip
else \ Next month Kalends
over monthend swap - 2 +
swap 2 = if \ February
swap if 1+ then \ bissextile year
else nip
then
then then then
;
\ kniablat - Print Kalends/Nones/Ides ablative case
: kniablat ( ukni -- )
dup KALENDS = if
." Kalendis "
else dup NONES = if
." Nonis "
else dup IDES = if
." Idebus "
else ." Kalendis " \ Kalends of next month
then then then
drop
;
\ kniaccus - Print Kalends/Nones/Ides accusative case
: kniaccus ( ukni -- )
dup KALENDS = if
." Kalendas "
else dup NONES = if
." Nonas "
else dup IDES = if
." Idus "
else ." Kalendas " \ Kalends of next month
then then then
drop
;
\ monablat - Print Latin month name ablative case
: monablat ( umonth -- )
dup 1 = if
." Januariis "
else dup 2 = if
." Februariis "
else dup 3 = if
." Martiis "
else dup 4 = if
." Aprilibus "
else dup 5 = if
." Maiis "
else dup 6 = if
." Juniis "
else dup 7 = if
." Juliis "
else dup 8 = if
." Augustis "
else dup 9 = if
." Septembribus "
else dup 10 = if
." Octobribus "
else dup 11 = if
." Novembribus "
else dup 12 = if
." Decembribus "
else
." Januariis "
then then then then then then then then then then then then
drop
;
\ monaccus - Print Latin month name accusative case
: monaccus ( umonth -- )
dup 1 = if
." Januarias "
else dup 2 = if
." Februarias "
else dup 3 = if
." Martias "
else dup 4 = if
." Apriles "
else dup 5 = if
." Maias "
else dup 6 = if
." Junias "
else dup 7 = if
." Julias "
else dup 8 = if
." Augustas "
else dup 9 = if
." Septembres "
else dup 10 = if
." Octobres "
else dup 11 = if
." Novembres "
else dup 12 = if
." Decembres "
else
." Januarias "
then then then then then then then then then then then then
drop
;
\ ordaccus - Print Latin ordinal number accusative case [1, 20]
: ordaccus ( unum -- )
dup 1 = if ." primum "
else dup 2 = if ." secundum "
else dup 3 = if ." tertium "
else dup 4 = if ." quartum "
else dup 5 = if ." quintum "
else dup 6 = if ." sextus "
else dup 7 = if ." septimum "
else dup 8 = if ." octavum "
else dup 9 = if ." nonum "
else dup 10 = if ." decimum "
else dup 11 = if ." undecimum "
else dup 12 = if ." duodecimum "
else dup 13 = if ." tertium decimum "
else dup 14 = if ." quartum decimum "
else dup 15 = if ." quintum decimum "
else dup 16 = if ." sextum decimum "
else dup 17 = if ." septimum decimum "
else dup 18 = if ." duodevicensimum "
else dup 19 = if ." undevicensimum "
else dup 20 = if ." vicensimum "
else ." ERROR: ordaccus argument out of range " dup .
then then then then then then then then then then then then then then then then then then then then
drop
;
\ diemense - Print day/month portion of Roman date
: diemense ( fbis umonth ukni uad -- )
dup 1 = if
drop dup kniablat
NEXTKAL = if 1+ then
monablat drop
else dup 2 = if
." pridie "
drop dup kniaccus
NEXTKAL = if 1+ then
monaccus drop
else
." ante diem "
2over 2 = and
over 6 > and
rot dup >r NEXTKAL = and if ( bis m ad ) ( R: kni )
dup 7 = if ." bis " then
1-
then
ordaccus ( bis m ) ( R: kni )
r> dup NEXTKAL = if ( bis m kni )
swap 1+ swap
then
kniaccus
monaccus
drop
then then
;
\ anno - Print year for Roman date format
: anno ( uyear -- )
." anno Domini "
romnumeral
;
\ romdate - print date in Roman format
: romdate ( uday umonth uyear -- )
dup bisyear ( d m y bis )
dup >r ( R: bis )
2swap dup >r ( y bis d m ) ( R: bis m )
swap 2dup mdkni ( y bis m d kni )
dup >r antediem ( y ad ) ( R: bis m kni )
r> swap r> r> swap 2swap ( y bis m kni ad )
diemense ( y )
anno
;
\ hodie - Print current date in Roman format
: hodie ( -- )
cr
time&date ( sec min hour day month year )
romdate
drop drop drop
;

119
romdate.fs Executable file
View File

@ -0,0 +1,119 @@
: ** ( n1 n2 -- n1 ** n2 )
1 swap
0 do swap dup rot * loop
nip
;
: "monthab" c" Januarias FebruariasMartias Apriles Maias Junias Julias Augustas SeptembresOctobres Novembres Decembres Januarias " ;
: monthab 10 * "monthab" 1+ + 10 type space ;
: monthab 0 max 12 min monthab ;
: "romnine" c" IXXCCM" ;
: romnine 2 * "romnine" 1+ + 2 type ;
: romnine 0 max 2 min romnine ;
: "romfour" c" IVXLCD" ;
: romfour 2 * "romfour" 1+ + 2 type ;
: romfour 0 max 2 min romfour ;
: "romfive" c" VLD" ;
: romfive "romfive" 1+ + 1 type ;
: romfive 0 max 2 min romfive ;
: "romunit" c" IXCM" ;
: romunit "romunit" 1+ + 1 type ;
: romunit 0 max 3 min romunit ;
: romplace ( power u -- )
dup 9 = if over romnine 2drop
else
dup 4 = if over romfour 2drop
else
dup 4 > if
over romfive
5 -
then
dup if
0 do romunit loop
else 2drop
then
then
then
;
: thousands 0 do ." M" loop ;
: hundreds
dup 9 = if ." CM" drop
else
dup 4 = if ." CD" drop
else
dup 4 > if
." D"
5 -
then
dup if
0 do
." C"
loop
else drop
then
then
then
;
: tens
dup 9 = if ." XC" drop
else
dup 4 = if ." XL" drop
else
dup 4 > if
." L"
5 -
then
dup if
0 do
." X"
loop
else drop
then
then
then
;
: ones
dup 9 = if ." IX" drop
else
dup 4 = if ." IV" drop
else
dup 4 > if
." V"
5 -
then
dup if
0 do
." I"
loop
else drop
then
then
then
;
: romnum ( u -- )
1000 /mod dup if thousands else drop then
100 /mod dup if hundreds else drop then
10 /mod dup if tens else drop then
dup if ones else drop then
space
;
: romnum ( u -- )
3 0 do
10 i ** /mod
dup if i swap romplace
else drop
then
loop
space
;
: romnum 1 max 3999 min romnum ;

397
rpn-n0-cgi.fs Executable file
View File

@ -0,0 +1,397 @@
#! /usr/pkg/bin/gforth-fast
\ rpn-n0.cgi - RPN Model n0 calculator CGI script
\ Copyright 2013 David Meyer <papa@sdf.org> +JMJ
\ Copying and distribution of this file, with or without
\ modification, are permitted in any medium without royalty
\ provided the copyright notice and this notice are preserved.
\ This file is offered as-is, without any warranty.
\ Global variables ...
variable register-x
variable register-y
variable register-z
variable register-t
variable register-s
variable mode \ 0: ENTER mode; next number will replace X
\ 1: Op mode; next number will push X
\ 2: Input mode; inputing number
variable error
variable query-adr
variable query-len
variable button-adr
variable button-len
\ Level 3 ...
: push-stack ( -- )
register-z @ register-t !
register-y @ register-z !
register-x @ register-y !
;
: rot4 ( a b c d -- d a b c ) swap >r rot rot r> ;
: trunc-fld-key ( c-field ufield ukey -- c-value uvalue )
dup >r - swap r> chars + swap
;
: value-str-chars ( addr u1 -- u2 )
over swap [char] & scan drop swap -
;
\ Level 2 ...
: init-state ( -- )
0 register-x !
0 register-y !
0 register-z !
0 register-t !
0 register-s !
0 mode !
0 button-len !
;
: nprint ( n -- )
s>d swap over dabs <<# #s rot sign #> type #>>
;
: parse-num-fld { c-key ulen a-reg -- }
query-adr @ query-len @ c-key ulen search if
ulen trunc-fld-key
over swap value-str-chars s>number? if
d>s a-reg !
else
2drop 0 a-reg !
then
else
0 a-reg !
then
;
: parse-str-fld { c-key ulen a-value a-vlen -- }
query-adr @ query-len @ c-key ulen search if
ulen trunc-fld-key
over swap value-str-chars
a-vlen ! a-value !
else
2drop 0 a-vlen !
then
;
: pressed-asterisk ( -- )
register-y @ register-x @ *
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-clr ( -- )
0 register-x !
0 register-y !
0 register-z !
0 register-t !
0 register-s !
0 mode !
;
: pressed-clx ( -- )
\ Or should this act like pop/drop?
0 register-x !
0 mode !
;
: pressed-enter ( -- )
push-stack
0 mode !
;
: pressed-minus ( -- )
register-y @ register-x @ -
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-mod ( -- )
register-x @ 0= if
true error !
0 mode !
else
register-y @ register-x @ mod
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
then
;
: pressed-neg ( -- )
register-x @ -1 * register-x !
1 mode !
;
: pressed-num ( u -- )
mode @ case
0 of
2 mode !
endof
1 of
push-stack
2 mode !
endof
2 of
register-x @ 10 * +
endof
endcase
register-x !
;
: pressed-plus ( -- )
register-y @ register-x @ +
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
;
: pressed-rcl ( -- )
push-stack
register-s @ register-x !
1 mode !
;
: pressed-rld ( -- )
register-x @
register-y @ register-x !
register-z @ register-y !
register-t @ register-z !
register-t !
1 mode !
;
: pressed-slash ( -- )
register-x @ 0= if
true error !
0 mode !
else
register-y @ register-x @ /
register-x !
register-z @ register-y !
register-t @ register-z !
1 mode !
then
;
: pressed-sto ( -- )
register-x @ register-s !
1 mode !
;
: pressed-swp ( -- )
register-x @ register-y @
register-x ! register-y !
1 mode !
;
\ Level 1 ...
: calculate ( -- )
button-len @ 0<> if
true case
button-adr @ button-len @ s" ENTER" str= of
pressed-enter
endof
button-adr @ button-len @ s" mod" str= of
pressed-mod
endof
button-adr @ button-len @ s" clx" str= of
pressed-clx
endof
button-adr @ button-len @ s" clr" str= of
pressed-clr
endof
button-adr @ button-len @ s" swp" str= of
pressed-swp
endof
button-adr @ button-len @ s" %2F" str= of
pressed-slash
endof
button-adr @ button-len @ s" rld" str= of
pressed-rld
endof
button-adr @ button-len @ s" *" str= of
pressed-asterisk
endof
button-adr @ button-len @ s" sto" str= of
pressed-sto
endof
button-adr @ button-len @ s" -" str= of
pressed-minus
endof
button-adr @ button-len @ s" rcl" str= of
pressed-rcl
endof
button-adr @ button-len @ s" neg" str= of
pressed-neg
endof
button-adr @ button-len @ s" %2B" str= of
pressed-plus
endof
button-adr @ button-len @ s>unumber?
rot rot d>s >r of
r> pressed-num
endof
endcase
then
;
: parse-query ( -- )
s" QUERY_STRING" getenv
dup 0= if
init-state
else
query-len ! query-adr !
s" s=" register-s parse-num-fld
s" t=" register-t parse-num-fld
s" z=" register-z parse-num-fld
s" y=" register-y parse-num-fld
s" x=" register-x parse-num-fld
s" mode=" mode parse-num-fld
s" button=" button-adr button-len parse-str-fld
then
;
: print-page ( -- )
." Content-Type: text/html"
cr cr .\" <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"
." <html><head><title>RPN Calculator Model n0</title>"
.\" <link rel=\"stylesheet\" type=\"text/css\" href=\"/style/rpn.css\">"
.\" <meta http-equiv=\"Content-type\" content=\"text/html;charset=UTF-8\"></head>"
.\" <body><h1>RPN Calculator Model n0</h1><form id=\"calc\" method=\"get\" action=\"rpn-n0.cgi\"><div class=\""
error @ if .\" disperr\">" else .\" disp\">" then
register-x @ nprint
.\" </div><table><tr><td colspan=2><input class=\"buttontw2\" type=\"submit\" name=\"button\" value=\"ENTER\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"clx\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"clr\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"-\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"7\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"8\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"9\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"+\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"4\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"5\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"6\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"*\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"1\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"2\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"3\" /></td></tr>"
.\" <tr><td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"/\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"mod\" /></td>"
.\" <td><input class=\"buttonwb\" type=\"submit\" name=\"button\" value=\"0\" /></td>"
.\" <td><input class=\"buttontw\" type=\"submit\" name=\"button\" value=\"neg\" /></td></tr>"
.\" <tr><td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"rld\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"swp\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"sto\" /></td>"
.\" <td><input class=\"buttonbw\" type=\"submit\" name=\"button\" value=\"rcl\" /></td></tr></table>"
.\" <div class=\"stat\">"
.\" S<input readonly name=\"s\" value=\""
register-s @ nprint
.\" \" /><br />"
.\" T<input readonly name=\"t\" value=\""
register-t @ nprint
.\" \" /><br />"
.\" Z<input readonly name=\"z\" value=\""
register-z @ nprint
.\" \" /><br />"
.\" Y<input readonly name=\"y\" value=\""
register-y @ nprint
.\" \" /><br />"
.\" X<input readonly name=\"x\" value=\""
register-x @ nprint
\ .\" \" /><input type=\"hidden\" name=\"input\" value=\""
\ input @ nprint
.\" \" /><input type=\"hidden\" name=\"mode\" value=\""
mode @ nprint
.\" \" /></div><div class=\"label\">RPN CALCULATOR n0</div></form>"
.\" <div id=\"inst\">"
." <h3>Instructions</h3>"
.\" <p class=\"instp\">Enter numbers separated by "
." ENTER key, then press operation key to display the result "
." (= key is not needed). Numbers are stored in a "
." LIFO stack (registers X, Y, Z, T). Display shows the last "
." number (input or result) on the stack (register X). "
." Register S is for storing constants.</p>"
.\" <p class=\"instp\"><strong>Stack effects:</strong> "
." (<em>x, y, z, t, s,</em> are current register values.)</p>"
.\" <table><tr><td></td><td class=\"instblk\"><em>op</em></tr>"
.\" <tr><td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"ENTER\" /></td>"
.\" <td class=\"instblk\">(<input class=\"buttontwj\" type=\"button\" disabled value=\"+\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"-\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"*\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"/\" /><input class=\"buttontwj\" type=\"button\" disabled value=\"mod\" />)</td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"neg\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"sto\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"rcl\" /></td></tr>"
.\" <tr><td class=\"instblk\"><em>z</em> &rarr; T<br /><em>y</em> &rarr; Z<br /><em>x</em> &rarr; Y,X</td>"
.\" <td class=\"instblk\"><em>t</em> &rarr; T,Z<br /><em>z</em> &rarr; Y<br /><em>y op x</em> &rarr; X</td>"
.\" <td class=\"instblk\"><em>-x</em> &rarr; X</td>"
.\" <td class=\"instblk\"><em>x</em> &rarr; S</td>"
.\" <td class=\"instblk\"><em>z</em> &rarr; T<br /><em>y</em> &rarr; Z<br /><em>x</em> &rarr; Y<br /><em>s</em> &rarr; X</td></tr></table>"
.\" <table><tr><td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"rld\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttonbwj\" type=\"button\" disabled value=\"swp\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"clx\" /></td>"
.\" <td class=\"instblk\"><input class=\"buttontwj\" type=\"button\" disabled value=\"clr\" /></td></tr>"
.\" <tr><td class=\"instblk\"><em>x</em> &rarr; T<br /><em>t</em> &rarr; Z<br /><em>z</em> &rarr; Y<br /><em>y</em> &rarr; X</td>"
.\" <td class=\"instblk\"><em>x</em> &rarr; Y<br /><em>y</em> &rarr; X</td>"
.\" <td class=\"instblk\">0 &rarr; X</td>"
.\" <td class=\"instblk\">0 &rarr; X,Y,Z,T,S</td></tr></table>"
.\" <p class=\"instp\"><strong>Precision and Fractional Arithmetic:</strong> "
." n0 processes all numbers as single-precision signed integers with a "
." range of -2,147,483,648 to 2,147,483,647. "
." It is possible to perform calculations with fractional "
." numbers by using the technique of "
." <strong>fixed-point arithmetic</strong>: The user multiplies input "
." operands and mentally divides results by appropriate powers of 10 to "
." obtain the required precision.</p></div>"
.\" <p><a href=\"rpn-n0-cgi.fs\">Program source.</a></p>"
." <p>Model n0 is the first of a series of online "
." calculators inspired by the Hewlett-Packard "
." line of slide rule pocket calculators "
." produced in the 1970s (n0 was designed "
." with refrence to the "
.\" <a href=\"http://www.hpmuseum.org/hp35.htm\">HP-35</a> "
." in particular) and the "
.\" <a href=\"http://www.forth.org/whatis.html\">"
." Forth programming language</a> invented by "
.\" <a href=\"http://www.colorforth.com/bio.html\">"
." Chuck Moore</a> in 1968.</p>"
." <p>RPN Calculator Model n0 is powered by "
.\" <a href=\"http://bernd-paysan.de/gforth.html\">Gforth</a> "
s" gforth" environment? if type space then
." on the MetaArray host at "
.\" <a href=\"http://www.sdf.org\">SDF</a>.</p>"
.\" <p class=\"ctr\"><a href=\"http://www.catholic.org/clife/prayers/prayer.php?p=1378\">+JMJ</a></p></div></body></html>"
;
\ Level 0: Main driver ...
false error !
parse-query
calculate
print-page
bye
\ Emacs metadata ...
\ Local variables:
\ mode: forth
\ End:
\ +JMJ

27
sandbox.txt Executable file
View File

@ -0,0 +1,27 @@
Forth Sandbox -*-org-*-
Date: 2011-11-04
A project I think I'll put on a front burner soon is my web-based
Forth programming environment. I've had a prototype[1] online for
several months, and it's already been handy.
Since the purpose is to execute arbitrary code from arbitrary
programmers, security is big concern and should be developed in
parallel with primary functionality. (The interface is currently
secured with HTTP basic authentication, but that will not be
sufficient when made publicly available.)
I have so far identified three technologies I may use to provide
security (probably in combination).
1. wordlists can block access to problematic words within the Forth
environment.
2. Plash is a user program that creates a restricted sandbox
environment and executes a specified program in the sandbos
3. Host the program in an isolated virtual server (VPS).
[1]: <http://papa.sdf.org/papa/cgi-bin/gforth.cgi>

40
scrtest.txt Executable file
View File

@ -0,0 +1,40 @@
Text screen test patterns
20x70 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
19x69 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

195
starting-words.txt Executable file
View File

@ -0,0 +1,195 @@
Starting Forth Words -*-org-*-
<pre>
Forth words introduced by chapter in "Starting Forth"[1].
* 1. Fundamental Forth
|-------------+--------------+----------------------------------------|
| : xxx yyy ; | -- | Create word xxx with definition yyy |
| CR | -- | Carriage return on terminal |
| SPACES | n -- | Print n spaces on terminal |
| SPACE | -- | Print one space on terminal |
| EMIT | c -- | Print character ASCII c on terminal |
| ." xxx" | -- | Print character string xxx on terminal |
| + | n1 n2 -- sum | Addition |
| . | n -- | Pop n from stack and print |
|-------------+--------------+----------------------------------------|
* 2. How to Get Results
|-------+----------------------+----------------------------------|
| + | n1 n2 -- sum | Adds |
| - | n1 n2 -- diff | Subtracts n1 - n2 |
| * | n1 n2 -- prod | Multiplies |
| / | n1 n2 -- quot | Divides n1 / n2 (int. quotient) |
| /MOD | n1 n2 -- rem quot | n2 / n2 remainder & quotient |
| MOD | n1 n2 -- rem | n1 / n2 remainder |
| SWAP | n1 n2 -- n2 n1 | Reverse top two stack items |
| DUP | n -- n n | Duplicate top stack item |
| OVER | n1 n2 -- n1 n2 n1 | Copy second stack item to top |
| ROT | n1 n2 n3 -- n2 n3 n1 | Rotate third stack item |
| DROP | n -- | Discard top stack item |
| .S | -- | Stack print (non-destructive) |
| 2SWAP | d1 d2 -- d2 d1 | Reverse top two pairs of numbers |
| 2DUP | d -- d d | Duplicate top pair of numbers |
| 2OVER | d1 d2 -- d1 d2 d1 | Copy second pair to top |
| 2DROP | d -- | Discard top pair |
|-------+----------------------+----------------------------------|
* 3. The Editor (and Staff)
|---------------+-----------+----------------------------------------|
| USE xxx | -- | Use file xxx as Forth "disk" |
| LIST | n -- | List disk block n |
| LOAD | n -- | Compile disk block n |
| ( xxx) | -- | Comment |
| UPDATE | -- | Mark current block modified |
| EMPTY-BUFFERS | -- | Mark all blocks unmodified |
| BLOCK | u -- addr | Swap-in block u from mass storage |
| INCLUDE xxx | -- | Compile text file xxx |
| FORGET xxx | -- | Remove definitions from xxx onward |
| MARKER xxx | -- | Set dictionary restore point |
| | | (Executing xxx will remove later defs. |
|---------------+-----------+----------------------------------------|
* 4. Decisions, Decisions ...
|----------------------+----------+-----------------------------------------|
| IF xxx THEN | IF: f -- | Execute xxx if f true (non-zero) |
| IF xxx ELSE yyy THEN | IF: f -- | Execute xxx if f true, yyy if false (0) |
|----------------------+----------+-----------------------------------------|
|-------------+---------------+-----------------------------------|
| = | n1 n2 -- f | Test n1 = n2 |
| - | n1 n2 -- diff | (Equiv. to test n1 != n2) |
| < | n1 n2 -- f | Test n1 < n2 |
| > | n1 n2 -- f | Test n1 > n2 |
| 0= | n -- f | Test n = 0 |
| 0< | n -- f | Test n < 0 |
| 0> | n --f | Test n > 0 |
| AND | n1 n2 -- and | Logical and |
| OR | n1 n2 -- or | Logical or |
| ?DUP | 0 -- 0 | Duplicate if n non-zero |
| | n -- n n | |
| ABORT" xxx" | f -- | If f true, abort with message xxx |
| ?STACK | -- f | True if stack underflow |
| INVERT | f -- f | Logical not |
|-------------+---------------+-----------------------------------|
* 5. The Philosophy of Fixed Point
|--------+----------------------+-------------------------------------------|
| 1+ | n -- n+1 | Add one |
| 1- | n -- n11 | Subtract one |
| 2+ | n -- n+2 | Add two |
| 2- | n -- n-2 | Subtract two |
| 2* | n -- n*2 | Mult. by two/Bit shift left |
| 2/ | n -- n/1 | Div. by two/Bit shift right |
| ABS | n -- n-abs | Absolute value |
| NEGATE | n -- -n | Reverse sign |
| MIN | n1 n2 -- min | Minimum |
| MAX | n1 n2 -- max | Maximum |
| >R | n -- | Pop to return stack |
| R> | -- n | Push from return stack |
| I | -- n | Push copy of return stack top |
| R@ | -- n | Push copy of return stack top |
| J | n -- n+1 | Push copy of return stack 3rd item |
| */ | n1 n2 n3 -- quot | n1*n2/n3 (intermed. result double-length) |
| */MOD | n1 n2 n3 -- rem quot | n1*n2/n3 remainder, quotient |
|--------+----------------------+-------------------------------------------|
* 6. Throw It For a Loop
|----------------------------+--------------------+--------------------------------|
| DO xxx LOOP | DO: limit index -- | Execute xxx limit-index times |
| DO xxx +LOOP | DO: limit index -- | Execute xxx incrementing by n |
| | +LOOP: n -- | from index to limit |
| BEGIN xxx UNTIL | UNTIL: f -- | Repeat xxx until f true |
| BEGIN xxx WHILE yyy REPEAT | WHILE: f -- | Repeat xxx, then yyy if f true |
|----------------------------+--------------------+--------------------------------|
|-------+------------+----------------------------------------------------------|
| LEAVE | -- | Terminate loop immediately |
| U.R | u width -- | Print u right-justified in field width |
| PAGE | -- | Clear terminal and move cursor to upper left-hand corner |
| QUIT | -- | Terminate task (supress "ok") |
| XX | -- | Clear stacks (undefined word) |
|-------+------------+----------------------------------------------------------|
* 7. A Number of Kinds of Numbers
|-----------+---------------------+------------------------------------------------|
| U. | u -- | Print unsigned number |
| UM* | u1 u2 -- ud | Return product of u1, u2 (single -> double) |
| UM/MOD | ud u1 -- u2 u3 | Divide double by single, return single-length |
| | | quotient, remainder |
| U< | u1 u2 -- f | Return u1<u2 |
| HEX | -- | Hexadecimal mode |
| OCTAL | -- | Octal mode |
| DECIMAL | -- | Decimal mode |
| <# xxx #> | d -- addr u | Format unsigned double to string |
| # | -- | Insert low digit in number format |
| #S | -- | Insert rest of high digits in format |
| c HOLD | -- | Insert ASCII code c in format |
| [CHAR] a | -- c | Return ASCII code for character a |
| SIGN | n -- n | Insert minus sign in format if n<0 |
| D+ | d1 d2 -- d-sum | Add (double-length) |
| D- | d1 d2 -- d-diff | Subtract (double-length) |
| DABS | d -- d-abs | Absolute value (double-length) |
| DNEGATE | d -- -d | Reverse sign (double-length) |
| DMAX | d1 d2 -- d-max | Maximum (double-length) |
| DMIN | d1 d2 -- d-min | Minimum (double-length) |
| D= | d1 d2 -- f | Test d1=d2 (double-length) |
| D0= | d -- f | Test d=0 (double-length) |
| D< | d1 d2 -- f | Test d1<d2 (double-length) |
| DU< | ud1 ud2 -- f | Test ud1<ud2 (double-length unsigned) |
| D.R | d width -- | Print d right-justified in field width |
| M+ | d n -- d-sum | Add d+n (mixed precision) |
| SM/REM | d n1 -- n2 n3 | Divide d/n1 giving symmetric quot. n3, rem. n2 |
| FM/MOD | d n1 -- n2 n3 | Divide d/n1 giving floored quot. n3, rem. n2 |
| M* | n1 n2 -- d-prod | Multiply n1*n2 giving double-length |
| M*/ | d n1 n2 -- d-result | d*n1/n2 giving double-length |
|-----------+---------------------+------------------------------------------------|
* 8. Variables, Constants, and Arrays
|---------------+--------------+------------------------------------------------|
| CONSTANT xxx | n -- | Create constant xxx with value n |
| | xxx: -- n | xxx returns n |
| VARIABLE xxx | -- | Create variable xxx |
| | xxx: -- addr | xxx returns var. address |
| CREATE xxx | -- | Create dictionary entry xxx |
| | xxx: -- addr | xxx returns entry address |
| ! | n addr -- | Store n at addr |
| @ | addr -- n | Return contents of addr |
| ? | addr -- | Print contents of addr |
| +! | n addr -- | Add n to contents of addr |
| ALLOT | n -- | Extend prev. dict. entry by n bytes |
| CELL | -- n | Returns number of bytes per cell |
| CELLS | n -- bytes | Returns bytes in n cells |
| , | n -- | Compile n into next cell in dict. |
| C! | b addr -- | Store 8-bit value b in addr |
| C@ | addr -- b | Return 8-bit val. b from addr |
| FILL | addr n b -- | Fill n bytes of mem. with b starting from addr |
| BASE | -- addr | Variable containing current numeric base |
| 2CONSTANT xxx | d -- | Create double-length constant xxx |
| | xxx: -- d | |
| 2VARIABLE xxx | -- | Create double-length variable xxx |
| | xxx: -- addr | |
| 2! | d addr -- | Store double-length at addr |
| 2@ | addr -- d | Fetch double-length fro addr |
| C, | b -- | Compile b into next byte in dict. |
| DUMP | addr u -- | Display u bytes of mem. starting from addr |
| ERASE | addr n -- | Fill n bytes of mem. with 0 starting from addr |
|---------------+--------------+------------------------------------------------|
* Notes
[1] Leo Brodie. Starting Forth. Forth, Inc. 2003.
http://www.forth.com/starting-forth/index.html
accessed Nov. 1, 2011.
</pre>

101
starting.fs Executable file
View File

@ -0,0 +1,101 @@
\ starting.fs - Exercises from "Stating Forth" by Leo Brodie
\ 7. A Number of Kinds of Numbers
\ .DATE - Print double-length as date
: .date ( d -- )
<# # # [char] / hold # # [char] / hold #s #> type space ;
\ 8. Variables, Constants, and Arrays
\ Exercise 1.
variable pies
variable frozen-pies
: bake-pie ( -- ) 1 pies +! ;
: eat-pie ( -- )
pies @ 0= if
." What pie?" cr
else
-1 pies +!
." Thank you!" cr
then
;
\ Exercise 2.
: freeze-pies ( -- )
pies @ frozen-pies ! 0 pies !
;
\ Exercise 3.
: .base ( -- ) base @ dup decimal . base ! ;
\ Exercise 4.
variable places
2 places !
: m. ( s|d -- )
tuck dabs
<#
places @ dup -1 <> if
0 ?do # loop
[char] . hold
else
drop s>d
then
#s rot sign #> type space
;
\ Exercise 6.
\ Tic-tac-toe application
create pos 9 allot
create symb 9 allot
: u>c ( u -- c ) 49 + ;
: clear ( -- )
pos 9 erase
9 0 do i dup u>c swap symb + c! loop
;
: hline ( -- ) cr space ." ---------" ;
: vbar ( -- ) space ." | " ;
: row ( c1 c2 c3 -- ) cr space emit vbar emit vbar emit ;
: display ( -- )
3 0 do
i 0= invert if hline then \ Print horiz. line before rows 2, 3
i 3 * symb + \ Addr. of 1st symbol in row
dup 1+ c@ \ 2nd symbol in row
over 2 + c@ \ 3rd symbol in row
swap rot c@ \ Arrange symbols 3 2 1, 1st symbol
row
loop cr
;
: symbol ( n -- c ) 1 = if [char] X else [char] O then ;
: move ( n-player u-position -- )
1- 2dup \ Offset in pos, symb
pos + dup \ pos addr.
c@ 0= if \ Test pos contents
c! \ Store pos
symb + swap \ symb addr.
symbol swap \ Getplayer symbol
c! \ Store symb
else
drop drop cr ." Position " 1+ . ." already taken."
drop
then
;
: x! ( u-position -- ) 1 swap move display ;
: o! ( u-position -- ) -1 swap move display ;

78
sticking.fs Executable file
View File

@ -0,0 +1,78 @@
\ sticking.fs
\ After "23 Matches" in Ahl, _Basic Computer Games_
\ Ahl attributes the original to Bob Albrecht
\ Version 2: Improved Forth strategy and output display -- jdm 2016
cr .( Reading sticking.fs ... )
\ Random number generator
include random.fs
\ Rules of the game
: rules ( -- )
cr ." SticKing"
cr
cr ." The game starts with 23 sticks. "
." By turns, you and Forth take"
cr ." from 1 to 3 sticks. "
." Whoever takes the last stick loses."
cr ." You will have to be lucky to beat me!"
cr
cr ." You take sticks by entering: n STICKS"
cr ." where n is 1, 2, or 3"
cr ;
\ Display sticks
: .sticks ( n -- ) 0 ?do ." |" loop ;
\ Report remaining sticks
: left ( sticks taken -- left ) - dup cr .sticks space dup . ." left." ;
\ The fates of Forth
: you-win ( sticks -- ) drop ." You win! " ;
: forth-wins ( sticks -- ) ." Forth took " 1- . cr ." 1 left - sorry!" ;
: 4-play ( sticks -- sticks left ) ." Forth took "
dup 4 mod dup
0= if drop 3
else 3 = if 2
else 1
then then
dup . left ;
\ My esteemed opponent
: computer ( sticks -- left| )
cr
dup 1 = if you-win else
dup 5 < if forth-wins else
4-play
then then ;
\ First play
: coin ( 23 -- n )
2 choose
cr ." A coin has been flipped: "
if ." Heads, Forth is first." computer
else ." Tails, you start."
then ;
\ Confine n between min and max
: clamp ( n min max -- n ) rot min max ;
\ May take between 1 and 3 sticks, leaving at least 1
: legal ( sticks try -- sticks taken ) over 1- 3 min 1 swap clamp ;
\ My play
: programmer ( sticks try -- left ) legal left ;
\ 1 Round
: sticks ( sticks try -- left| ) programmer computer ;
\ Alias for STICKS
: stick ( sticks try -- left| ) sticks ;
: game ( -- ) rules 23 dup cr .sticks randomize coin ;
cr .( Ready. To play, enter: GAME)

73
sticks.f Executable file
View File

@ -0,0 +1,73 @@
\ sticks.f
\ After "23 Matches" in Ahl, _Basic Computer Games_
\ Ahl attributes the original to Bob Albrecht
cr .( Reading sticks.f)
\ random number generator
s" random.f" included
\ Rules of the game
: rules ( -- )
cr ." Sticks"
cr
cr ." The game starts with 23 sticks. "
." By turns, you and Forth take"
cr ." from 1 to 3 sticks. "
." Whoever takes the last stick loses."
cr
cr ." You take sticks by entering: n STICKS"
cr ." where n is 1, 2, or 3"
cr ;
\ Display sticks
: .sticks ( n -- ) 0 ?do ." |" loop ;
\ Report remaining sticks
: left ( sticks taken -- left )
- dup cr .sticks space dup . ." left." ;
\ The fates of Forth
: you-win ( sticks -- ) drop ." You win! " ;
: forth-wins ( sticks -- )
." Forth took " 1- .
cr ." 1 left - sorry!" ;
: 4-play ( sticks -- left )
." Forth took " 3 choose 1+ dup . left ;
\ My esteemed opponent
: computer ( sticks -- left| )
cr
dup 1 = if you-win else
dup 5 < if forth-wins else
4-play
then then ;
\ First play
: coin ( 23 -- n )
2 choose
cr ." A coin has been flipped: "
if ." Heads, Forth is first." computer
else ." Tails, you start."
then ;
\ Confine n between min and max
: clamp ( n min max -- n ) rot min max ;
\ May take between 1 and 3 sticks, leaving at least 1
: legal ( sticks try -- sticks taken )
over 1- 3 min 1 swap clamp ;
\ My play
: programmer ( sticks try -- left ) legal left ;
\ 1 Round
: sticks ( sticks try -- left| ) programmer computer ;
\ Alias for STICKS
: stick ( sticks try -- left| ) sticks ;
: game ( -- )
rules 23 dup cr .sticks randomize coin ;
cr .( Ready. To play, enter: GAME)

70
sticks.fs Executable file
View File

@ -0,0 +1,70 @@
\ sticks.fs
\ After "23 Matches" in Ahl, _Basic Computer Games_
\ Ahl attributes the original to Bob Albrecht
cr .( Reading sticks.fs ... )
\ Random number generator
include random.fs
\ Rules of the game
: rules ( -- )
cr ." Sticks"
cr
cr ." The game starts with 23 sticks. "
." By turns, you and Forth take"
cr ." from 1 to 3 sticks. "
." Whoever takes the last stick loses."
cr
cr ." You take sticks by entering: n STICKS"
cr ." where n is 1, 2, or 3"
cr ;
\ Display sticks
: .sticks ( n -- ) 0 ?do ." |" loop ;
\ Report remaining sticks
: left ( sticks taken -- left ) - dup cr .sticks space dup . ." left." ;
\ The fates of Forth
: you-win ( sticks -- ) drop ." You win! " ;
: forth-wins ( sticks -- ) ." Forth took " 1- . cr ." 1 left - sorry!" ;
: 4-play ( sticks -- sticks left ) ." Forth took " 3 choose 1+ dup . left ;
\ My esteemed opponent
: computer ( sticks -- left| )
cr
dup 1 = if you-win else
dup 5 < if forth-wins else
4-play
then then ;
\ First play
: coin ( 23 -- n )
2 choose
cr ." A coin has been flipped: "
if ." Heads, Forth is first." computer
else ." Tails, you start."
then ;
\ Confine n between min and max
: clamp ( n min max -- n ) rot min max ;
\ May take between 1 and 3 sticks, leaving at least 1
: legal ( sticks try -- sticks taken ) over 1- 3 min 1 swap clamp ;
\ My play
: programmer ( sticks try -- left ) legal left ;
\ 1 Round
: sticks ( sticks try -- left| ) programmer computer ;
\ Alias for STICKS
: stick ( sticks try -- left| ) sticks ;
: game ( -- ) rules 23 dup cr .sticks randomize coin ;
cr .( Ready. To play, enter: GAME)

14
tag4thgen.sh Executable file
View File

@ -0,0 +1,14 @@
#!/bin/sh
for e in html head title style meta body h1 h2 h3 h4 h5 h6 p strong em ul ol li dl dt dd table thead tbody tr th td a div span
do
echo ": \$$e\$ ( -- ) s\" $e\" ;"
echo ": [$e] ( -- ) \$$e\$ [tag] ;"
echo ": [/$e] ( -- ) \$$e\$ [/tag] ;"
echo ": [$e/] ( -- ) \$$e\$ [tag/] ;"
echo ": [$e-$] ( addr u -- ) \$$e\$ [tag-$] ;"
echo ": [$e-$/] ( addr u -- ) \$$e\$ [tag-$/] ;"
echo ": [$e+] ( +-addr +-u -- ) \$$e\$ [tag+] ;"
echo ": [$e+$] ( $-addr $-u +-addr +-u -- ) \$$e\$ [tag+$] ;"
echo ": [$e+$/] ( $-addr $-u +-addr +-u -- ) \$$e\$ [tag+$/] ;"
done

9
termtest.4th Executable file
View File

@ -0,0 +1,9 @@
\ termtest.4th - test pattern for terminal display
: termtest ( -- )
s" -----1---------2---------3---------4---------5---------6-------"
24 1 u+do i . 2 spaces 2dup type cr loop
;
termtest
bye

3
test1.fs Executable file
View File

@ -0,0 +1,3 @@
\ Tell how many items are on the stack
: DEPTH? ( -- ) DEPTH . ;

2
thoughtful.blink Executable file
View File

@ -0,0 +1,2 @@
Thoughtful Programming and Forth
http://www.ultratechnology.com/forth.htm

10
tscript Executable file
View File

@ -0,0 +1,10 @@
#! /usr/local/bin/gforth
: main ( -- )
." Hello, World!" cr
." I'm tscript." cr ;
main
bye

13
tutorial.fs Executable file
View File

@ -0,0 +1,13 @@
: min1
2dup 2dup > rot rot < rot swap or rot rot or and ;
: min2
2dup > 1+ roll nip ;
\ ... or is it "<"?
: gcd
2dup < if swap then
begin
tuck mod dup 0=
until
drop ;

2274
twenex-forth.mid Executable file
View File

File diff suppressed because it is too large Load Diff

136
twenex-forth.txt Executable file
View File

@ -0,0 +1,136 @@
TWENEX FORTH WORDS
DUP
SWAP
ROLL
PICK
DROP
OVER
ROT
-DUP
?DUP
LEVEL
DEPTH
FLOAT
+
-
*
/
^
F+
F-
F*
F/
FIX
MOD
/MOD
0=
0=_
0<
0<=
0>
0>=
EXCHANGE
JSYS
=
=_
<
<=
>
>=
FLUSH
TRACE
@
!
+!
-!
FILL
'
'#
]
QUIT
<#
#
HOLD
#N
SIGN
#S
#>
HOME
CR
CLEAR
SPACE
SPACES
EMIT
TYPE
[TYPE]
KEY
?TERMINAL
EXPECT
[EXPECT]
C@
C!
C>
C<
.
.R
F.
."
:"
(")
["]
VLIST
(
ABS
MINUS
+-
1+
1-
MAX
MIN
SINE
COSINE
ROOT
LN
<-,,
SW,,AP
,,->
AND
OR
NOT
XOR
EXECUTE
FORGET
:
;
<BUILDS
DOES>
,
ALLOT
LOAD
[LOAD]
UNLOAD
DECIMAL
OCTAL
BINARY
IF
ELSE
THEN
DO
LOOP
+LOOP
I
J
IJ..N
RUNT
REPEAT
UNTIL
CMOVE
[CMOVE]
HERE
LEAVE
ERROR
[NUMBER]
WHILE
BEGIN
END

103
wareki.fs Executable file
View File

@ -0,0 +1,103 @@
\ wareki.fs - Display WAREKI and Anno Domini corresponding years
\ +JMJ 2013 David Meyer <papa@sdf.org>
\ help-wareki - Display module help
: help-wareki ( -- )
cr ." WAREKI" cr
." Display Japanese era years corresponding to A.D. years and" cr
." vice versa." cr
." HEISEI ( u -- ) Display A.D. year corresponding to Heisei era year." cr
." MEIJI ( u -- ) Display A.D. year corresponding to Meiji era year." cr
." NENGO ( u -- ) Display Japanese year in Meiji, Taishou, Shouwa," cr
." or Heisei eras corresponding to A.D. year." cr
." SHOWA ( u -- ) Display A.D. year corresponding to Shouwa era year." cr
." TAISHO ( u -- ) Display A.D. year corresponding to Taishou era year." cr
;
\ nengo - Display NENGO for A.D. (Meiji, Taishou, Shouwa,
\ Heisei eras only)
: nengo ( u -- )
dup 1868 < if
." ERROR: Year precedes MEIJI era " drop
else
dup 1868 = if
." MEIJI GANNEN (Sep 8 -) " drop
else
dup 1912 < if
." MEIJI " 1867 - .
else
dup 1912 = if
." MEIJI 45/TAISHO GANNEN (Jul 30-) " drop
else
dup 1926 < if
." TAISHO " 1911 - .
else
dup 1926 = if
." TAISHO 15/SHOWA GANNEN (Dec 25-) " drop
else
dup 1989 < if
." SHOWA " 1925 - .
else
dup 1989 = if
." SHOWA 64/HEISEI GANNEN (Jan 8-) " drop
else
." HEISEI " 1988 - .
then
then
then
then
then
then
then
then
;
\ meiji - Display A.D. for Meiji era NENGO.
: meiji ( u -- )
dup 0= if
." ERROR: NENGO < 1 " drop
else
dup 45 > if
." ERROR: NENGO > 45 " drop
else
." AD " 1867 + .
then
then
;
\ taisho - Display A.D. for Taishou era NENGO.
: taisho ( u -- )
dup 0= if
." ERROR: NENGO < 1 " drop
else
dup 15 > if
." ERROR: NENGO > 15 " drop
else
." AD " 1911 + .
then
then
;
\ showa - Display A.D. for Shouwa era NENGO.
: showa ( u -- )
dup 0= if
." ERROR: NENGO < 1 " drop
else
dup 64 > if
." ERROR: NENGO > 64 " drop
else
." AD " 1925 + .
then
then
;
\ heisei - Display A.D. for Heisei era NENGO.
: heisei ( u -- )
dup 0= if
." ERROR: NENGO < 1 " drop
else
." AD " 1988 + .
then
;
cr ." Type 'help-wareki' for help"

155
yuko-notes.org Executable file
View File

@ -0,0 +1,155 @@
Yuko Development Notes
* Purpose
To replace Cora Phyco with unit conversion system using primarily
integer arithmetic.
* Style
Instead of Cora Phyco-style
conversion-constants-with-universal-converter, use more conventional
function-per-unit-pair style. Results not prnted but left on top of
stack for user to print or use in further calculation.
Reduce supported units to minimum necessary to reduce number of
functions to program.
Reduce all ratios to lowest terms to reduce chance of overflow.
* Conversion Ratios
The statement "The ratio of unit A to unit B is x:y" means that for a
given quantity, the magnitude of the quantity measured in unit A and
the magnitude of the same quantity measured in unit B are in the
ratio x:y. (NOT the ratio of the quantities of 1 unit of A and 1 unit
of B.)
** Linear measure
Units: mm, in, ft, m, km, mi
*** Defined ratios
| in:mm | 10:254 = 5:127 |
| m:mm | 1:1000 |
| km:m | 1:1000 |
| ft:in | 1:12 |
| mi:ft | 1:5280 |
*** Derived ratios
| km:mm | 1:1000000 |
| mi:in | 1:63360 |
| ft:mm | 5:1524 |
| mi:mm | 1:1609344 |
| m:in | 127:5000 |
| km:in | 127:5000000 |
| m:ft | 381:1250 |
| km:ft | 381:1250000 |
| mi:m | 5000:8047863 |
| mi:km | 5000000:8047863 |
** Time
Units: s, min, hr, day, yr
| 60 s = 1 min | 60/1 | min>s | 60 * |
| | | s>min | 60 / |
| 3600 s = 1 hr | 3600/1 | hr>s | 3600 * |
| | | s>hr | 3600 / |
| 86400 s = 1 day | 86400/1 | day>s | 86400 * |
| | | s>day | 86400 / |
| 30780000 s = 1 yr | 30780000/1 | yr>s | 30780000 * |
| | | s>yr | 30780000 / |
| 60 min = 1 hr | 60/1 | hr>min | 60 * |
| | | min>hr | 60 / |
| 1440 min = 1 day | 1440/1 | day>min | 1440 * |
| | | min>day | 1440 / |
| 24 hr = 1 day | 24/1 | day>hr | 24 * |
| | | hr>day | 24 / |
| 513000 min = 1 yr | 513000/1 | yr>min | 513000 * |
| | | min>yr | 513000 / |
| 4 yr = 1425 day | | | |
| | s | min | hr | day | yr |
|-----+---------+----------+--------+---------+----------|
| s | - | 60:1 | 3600:1 | 86400:1 | X |
| min | 1:60 | - | 60:1 | 1440:1 | 525960:1 |
| hr | 1:3600 | 1:60 | - | 24:1 | 8766:1 |
| day | 1:86400 | 1:1440 | 1:24 | - | 1461:4 |
| yr | X | 1:525960 | 1:8766 | 4:1461 | - |
| s>min | 60 / | | min>s | 60 * |
| s>hr | 3600 / | | hr>s | 3600 * |
| s>day | 86400 / | | day>s | 86400 * |
| min>hr | 60 / | | hr>min | 60 * |
| min>day | 1440 / | | day>min | 1440 * |
| min>yr | 525960 / | | yr>min | 525960 * |
| hr>day | 24 / | | day>hr | 24 * |
| hr>yr | 8766 / | | yr>hr | 8766 * |
| day>yr | 4 1461 */ | | yr>day | 1461 4 */ |
** Volume
ML milliliter L liter
TSP teaspoon TBSP tablespoon CUP FLOZ fluid ounce
PT pint QT quart GAL gallon
| 1000 ml = 1 l | 1000:1 |
| 3 tsp = 1 tbsp | 3:1 |
| 2 tbsp = 1 fl oz | 2:1 |
| 48 tsp = 1 cup | 48:1 |
| 8 fl oz = 1 cup | 8:1 |
| 2 cup = 1 pt | 2:1 |
| 2 pt = 1 qt | 2:1 |
| 4 qt = 1 gal | 4:1 |
| 3785.41784 ml = 1 gal | 378541784:100000 |
| | 47317723:12500 |
| (4.93 ml = 1 tsp) | |
| | ml | tsp | tbsp | fl oz | cup | pt | qt | l | gal |
| ml | - | 47317723 | 47317723 | 47317723 | 47317723 | 47317723 | 47317723 | 1000:1 | 47317723 |
| | | :9600000 | :3200000 | :1600000 | :200000 | :100000 | :50000 | | :12500 |
| tsp | 9600000: | - | 3:1 | 6:1 | 48:1 | 96:1 | 192:1 | 9600000000 | 768:1 |
| | 47317723 | | | | | | | :47317723 | |
| tbsp | 3200000: | 1:3 | - | 2:1 | 16:1 | 32:1 | 64:1 | 3200000000 | 256:1 |
| | 47317723 | | | | | | | :47317723 | |
| fl oz | 1600000: | 1:6 | 1:2 | - | 8:1 | 16:1 | 32:1 | 1600000000 | 128:1 |
| | 47317723 | | | | | | | :47317723 | |
| cup | 200000: | 1:48 | 1:16 | 1:8 | - | 2:1 | 4:1 | 200000000 | 16:1 |
| | 47317723 | | | | | | | :47317723 | |
| pt | 100000: | 1:96 | 1:32 | 1:16 | 1:2 | - | 2:1 | 100000000 | 8:1 |
| | 47317723 | | | | | | | :47317723 | |
| qt | 50000: | 1:192 | 1:64 | 1:32 | 1:4 | 1:2 | - | 50000000 | 4:1 |
| | 47317723 | | | | | | | :47317723 | |
| l | 1:1000 | 47317723: | 47317723: | 47317723: | 47317723: | 47317723: | 47317723: | - | 47317723: |
| | | 9600000000 | 3200000000 | 1600000000 | 200000000 | 100000000 | 50000000 | | 12500000 |
| gal | 12500: | 1:768 | 1:256 | 1:128 | 1:16 | 1:8 | 1:4 | 12500000: | - |
| | 47317723 | | | | | | | 47317723 | |
* Double-precision division
dn = nl + m*nh
dn / d = (nl + m*nh)/d
= nl/d + m*nh/d
: dn/ ( d n1 -- n2 ) tuck / rot rot / swap d>s ;
(Thought I would need this for converting between seconds and years,
but not so.)

185
yuko-test.fs Executable file
View File

@ -0,0 +1,185 @@
\ yuko-test.fs - Test driver for Yuko Units Converter
\ 2013 David Meyer <papa@sdf.org>
\ require yuko.fs
: test ( - )
cr ." Starting tests... "
." s>min "
assert( 4199 s>min 69 = )
assert( 4200 s>min 70 = )
assert( 4201 s>min 70 = )
." s>hr "
assert( 251999 s>hr 69 = )
assert( 252000 s>hr 70 = )
assert( 252001 s>hr 70 = )
." s>day "
assert( 6047999 s>day 69 = )
assert( 6048000 s>day 70 = )
assert( 6048001 s>day 70 = )
." min>hr "
assert( 4199 min>hr 69 = )
assert( 4200 min>hr 70 = )
assert( 4201 min>hr 70 = )
." min>day "
assert( 100799 min>day 69 = )
assert( 100800 min>day 70 = )
assert( 100801 min>day 70 = )
." min>yr "
assert( 36817199 min>yr 69 = )
assert( 36817200 min>yr 70 = )
assert( 36817201 min>yr 70 = )
." hr>day "
assert( 1679 hr>day 69 = )
assert( 1680 hr>day 70 = )
assert( 1681 hr>day 70 = )
." hr>yr "
assert( 613619 hr>yr 69 = )
assert( 613620 hr>yr 70 = )
assert( 613621 hr>yr 70 = )
." day>yr "
assert( 29219 day>yr 79 = )
assert( 29220 day>yr 80 = )
assert( 29221 day>yr 80 = )
." min>s "
assert( 69 min>s 4140 = )
assert( 70 min>s 4200 = )
assert( 71 min>s 4260 = )
." hr>s "
assert( 69 hr>s 248400 = )
assert( 70 hr>s 252000 = )
assert( 71 hr>s 255600 = )
." day>s "
assert( 69 day>s 5961600 = )
assert( 70 day>s 6048000 = )
assert( 71 day>s 6134400 = )
." hr>min "
assert( 69 hr>min 4140 = )
assert( 70 hr>min 4200 = )
assert( 71 hr>min 4260 = )
." day>min "
assert( 69 day>min 99360 = )
assert( 70 day>min 100800 = )
assert( 71 day>min 102240 = )
." yr>min "
assert( 69 yr>min 36291240 = )
assert( 70 yr>min 36817200 = )
assert( 71 yr>min 37343160 = )
." day>hr "
assert( 69 day>hr 1656 = )
assert( 70 day>hr 1680 = )
assert( 71 day>hr 1704 = )
." yr>hr "
assert( 69 yr>hr 604854 = )
assert( 70 yr>hr 613620 = )
assert( 71 yr>hr 622386 = )
." yr>day "
assert( 79 yr>day 28854 = )
assert( 80 yr>day 29220 = )
assert( 81 yr>day 29585 = )
." ml>tsp " assert( 47317723 ml>tsp 9600000 = )
." ml>tbsp " assert( 47317723 ml>tbsp 3200000 = )
." ml>floz " assert( 47317723 ml>floz 1600000 = )
." ml>cup " assert( 47317723 ml>cup 200000 = )
." ml>pt " assert( 47317723 ml>pt 100000 = )
." ml>qt " assert( 47317723 ml>qt 50000 = )
." ml>l " assert( 100000 ml>l 100 = )
." ml>gal " assert( 47317723 ml>gal 12500 = )
." tsp>ml " assert( 9600000 tsp>ml 47317723 = )
." tsp>tbsp " assert( 76800 tsp>tbsp 25600 = )
." tsp>floz " assert( 76800 tsp>floz 12800 = )
." tsp>cup " assert( 76800 tsp>cup 1600 = )
." tsp>pt " assert( 76800 tsp>pt 800 = )
." tsp>qt " assert( 76800 tsp>qt 400 = )
." tsp>l " assert( 9600000000 tsp>l 47317723 = )
." tsp>gal " assert( 76800 tsp>gal 100 = )
." tbsp>ml " assert( 3200000 tbsp>ml 47317723 = )
." tbsp>tsp " assert( 25600 tbsp>tsp 76800 = )
." tbsp>floz " assert( 25600 tbsp>floz 12800 = )
." tbsp>cup " assert( 25600 tbsp>cup 1600 = )
." tbsp>pt " assert( 25600 tbsp>pt 800 = )
." tbsp>qt " assert( 25600 tbsp>qt 400 = )
." tbsp>l " assert( 3200000000 tbsp>l 47317723 = )
." tbsp>gal " assert( 25600 tbsp>gal 100 = )
." floz>ml " assert( 1600000 floz>ml 47317723 = )
." floz>tsp " assert( 12800 floz>tsp 76800 = )
." floz>tbsp " assert( 12800 floz>tbsp 25600 = )
." floz>cup " assert( 12800 floz>cup 1600 = )
." floz>pt " assert( 12800 floz>pt 800 = )
." floz>qt " assert( 12800 floz>qt 400 = )
." floz>l " assert( 1600000000 floz>l 47317723 = )
." floz>gal " assert( 12800 floz>gal 100 = )
." cup>ml " assert( 200000 cup>ml 47317723 = )
." cup>tsp " assert( 1600 cup>tsp 76800 = )
." cup>tbsp " assert( 1600 cup>tbsp 25600 = )
." cup>floz " assert( 1600 cup>floz 12800 = )
." cup>pt " assert( 1600 cup>pt 800 = )
." cup>qt " assert( 1600 cup>qt 400 = )
." cup>l " assert( 200000000 cup>l 47317723 = )
." cup>gal " assert( 1600 cup>gal 100 = )
." pt>ml " assert( 100000 pt>ml 47317723 = )
." pt>tsp " assert( 800 pt>tsp 76800 = )
." pt>tbsp " assert( 800 pt>tbsp 25600 = )
." pt>floz " assert( 800 pt>floz 12800 = )
." pt>cup " assert( 800 pt>cup 1600 = )
." pt>qt " assert( 800 pt>qt 400 = )
." pt>l " assert( 100000000 pt>l 47317723 = )
." pt>gal " assert( 800 pt>gal 100 = )
." qt>ml " assert( 50000 qt>ml 47317723 = )
." qt>tsp " assert( 400 qt>tsp 76800 = )
." qt>tbsp " assert( 400 qt>tbsp 25600 = )
." qt>floz " assert( 400 qt>floz 12800 = )
." qt>cup " assert( 400 qt>cup 1600 = )
." qt>pt " assert( 400 qt>pt 800 = )
." qt>l " assert( 50000000 qt>l 47317723 = )
." qt>gal " assert( 400 qt>gal 100 = )
." l>ml " assert( 100 l>ml 100000 = )
." l>tsp " assert( 47317723 l>tsp 9600000000 = )
." l>tbsp " assert( 47317723 l>tbsp 3200000000 = )
." l>floz " assert( 47317723 l>floz 1600000000 = )
." l>cup " assert( 47317723 l>cup 200000000 = )
." l>pt " assert( 47317723 l>pt 100000000 = )
." l>qt " assert( 47317723 l>qt 50000000 = )
." l>gal " assert( 47317723 l>gal 12500000 = )
." gal>ml " assert( 12500 gal>ml 47317723 = )
." gal>tsp " assert( 100 gal>tsp 76800 = )
." gal>tbsp " assert( 100 gal>tbsp 25600 = )
." gal>floz " assert( 100 gal>floz 12800 = )
." gal>cup " assert( 100 gal>cup 1600 = )
." gal>pt " assert( 100 gal>pt 800 = )
." gal>qt " assert( 100 gal>qt 400 = )
." gal>l " assert( 12500000 gal>l 47317723 = )
." All tests successful." cr ;
test
\ +JMJ

271
yuko.fs Executable file
View File

@ -0,0 +1,271 @@
\ yuko.fs -- YUnit KOnverter
\ +JMJ 2013-2014 David Meyer <papa@sdf.org>
\ help-yuko -- Print module help text.
: help-yuko ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO -- YUnit KOnverter"
cr ." YUKO is a Forth module that provides functions for converting between"
cr ." various units of measurement. Most functions take the number of"
cr ." source units of a given quantity as an unsigned integer from the top"
cr ." of the stack and returns the equivalent number of target units."
cr ." Temperature functions take input and output as signed integers."
cr ." See also: HELP-YUKO-LENGTH, HELP-YUKO-MASS, HELP-YUKO-TEMP,"
cr ." HELP-YUKO-TIME, HELP-YUKO-VOLUME, HELP-YUKO-PRICE"
cr
;
\ help-yuko-length -- Print help for length/distance conversions.
: help-yuko-length ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO LENGTH/DISTANCE CONVERSIONS"
cr ." Units: foot (ft), inch (in), kilometer (km), meter (m), mile (mi),"
cr ." millimeter (mm)"
cr ." Conversions: ft>in ft>km ft>m ft>mi ft>mm in>ft in>km in>m in>mi"
cr ." in>mm km>ft km>in km>m km>mi km>mm m>ft m>in m>km m>mi m>mm mi>ft"
cr ." mi>in mi>km mi>m mi>mm mm>ft mm>in mm>km mm>m mm>mi"
cr
;
\ help-yuko-mass -- Print help for mass/weight conversions.
: help-yuko-mass ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO MASS/WEIGHT CONVERSIONS"
cr ." Units: gram (g), kilogram (kg), ounce (oz), pound (lb),"
cr ." troy ounce (ozt)
cr ." Conversions: kg>lb kg>g lb>oz kg>oz g>oz lb>g lb>kg g>kg oz>lb oz>kg"
cr ." oz>g g>lb ozt>g g>ozt"
cr
;
\ help-yuko-temp -- Print help for temperature conversions.
: help-yuko-temp ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO TEMPERATURE CONVERSIONS"
cr ." (Input and output in signed integers.)"
cr ." Units: Celsius degrees (c), Fahrenheit degrees (f)"
cr ." Conversions: c>f f>c"
cr
;
\ help-yuko-time -- Print help for time conversions.
: help-yuko-time ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO TIME CONVERSIONS"
cr ." Units: day, hour (hr), minute (min), second (s), year (yr)"
cr ." Conversions: s>min s>hr s>day min>hr min>day min>yr hr>day hr>yr"
cr ." day>yr min>s hr>s day>s hr>min day>min yr>min day>hr yr>hr yr>day"
cr ." (No second <-> year conversion due to scale difference.)
cr
;
\ help-yuko-volume -- Print help for volume conversions.
: help-yuko-volume ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO VOLUME CONVERSIONS"
cr ." Units: cup, fluid ounce (floz), gallon (gal), liter (l),"
cr ." milliliter (ml), pint (pt), quart (qt), tablespoon (tbsp),"
cr ." teaspoon (tsp)"
cr ." Conversions: cup>floz cup>gal cup>l cup>ml cup>pt cup>qt cup>tbsp"
cr ." cup>tsp floz>cup floz>gal floz>l floz>ml floz>pt floz>qt floz>tbsp"
cr ." floz>tsp gal>cup gal>floz gal>l gal>ml gal>pt gal>qt gal>tbsp"
cr ." gal>tsp l>cup l>floz l>gal l>ml l>pt l>qt l>tbsp l>tsp ml>cup"
cr ." ml>floz ml>gal ml>l ml>pt ml>qt ml>tbsp ml>tsp pt>cup pt>floz pt>gal"
cr ." pt>l pt>ml pt>qt pt>tbsp pt>tsp qt>cup qt>floz qt>gal qt>l qt>ml"
cr ." qt>pt qt>tbsp qt>tsp tbsp>cup tbsp>floz tbsp>gal tbsp>l tbsp>ml"
cr ." tsp>qt tsp>tbsp tbsp>pt tbsp>qt tbsp>tsp tsp>cup tsp>floz tsp>gal"
cr ." tsp>l tsp>ml tsp>pt"
cr
;
\ help-yuko-price -- Print help for price conversions.
: help-yuko-price ( -- )
\ ---------1---------2---------3---------4---------5---------6---------7
cr ." YUKO PRICE CONVERSIONS"
cr ." Units: USD per troy ounce (do), JPY per gram (yg)"
cr ." Conversions: do>yg yg>do"
cr ." (Second argument is JPY:USD exchange rate in JPY per 1000 USD.)"
cr
;
\ LINEAR MEASURE
\ FT foot, IN inch, KM kilometer, M meter, MI mile, MM millimeter
\ All values are unsigned integers.
: ft>in ( u1 -- u2 ) 12 * ;
: ft>km ( u1 -- u2 ) 381 1250000 */ ;
: ft>m ( u1 -- u2 ) 381 1250 */ ;
: ft>mi ( u1 -- u2 ) 5280 / ;
: ft>mm ( u1 -- u2 ) 1524 5 */ ;
: in>ft ( u1 -- u2 ) 12 / ;
: in>km ( u1 -- u2 ) 127 5000000 */ ;
: in>m ( u1 -- u2 ) 127 5000 */ ;
: in>mi ( u1 -- u2 ) 63360 / ;
: in>mm ( u1 -- u2 ) 127 5 */ ;
: km>ft ( u1 -- u2 ) 1250000 381 */ ;
: km>in ( u1 -- u2 ) 5000000 127 */ ;
: km>m ( u1 -- u2 ) 1000 * ;
: km>mi ( u1 -- u2 ) 5000000 8047863 */ ;
: km>mm ( u1 -- u2 ) 1000000 * ;
: m>ft ( u1 -- u2 ) 1250 381 */ ;
: m>in ( u1 -- u2 ) 5000 127 */ ;
: m>km ( u1 -- u2 ) 1000 / ;
: m>mi ( u1 -- u2 ) 5000 8047863 */ ;
: m>mm ( u1 -- u2 ) 1000 * ;
: mi>ft ( u1 -- u2 ) 5280 * ;
: mi>in ( u1 -- u2 ) 63360 * ;
: mi>km ( u1 -- u2 ) 8047863 5000000 */ ;
: mi>m ( u1 -- u2 ) 8047863 5000 */ ;
: mi>mm ( u1 -- u2 ) 1609344 * ;
: mm>ft ( u1 -- u2 ) 5 1524 */ ;
: mm>in ( u1 -- u2 ) 5 127 */ ;
: mm>km ( u1 -- u2 ) 1000000 / ;
: mm>m ( u1 -- u2 ) 1000 / ;
: mm>mi ( u1 -- u2 ) 1609344 / ;
\ MASS/WEIGHT
\ G gram, KG kilogram, LB pound, OZ ounce, OZT troy ounce
\ All values unsigned integers.
\ OZT conversion to/from G only.
: kg>lb ( u1 -- u2 ) 100000000 45359237 */ ;
: kg>g ( u1 -- u2 ) 1000 * ;
: lb>oz ( u1 -- u2 ) 16 * ;
: kg>oz ( u1 -- u2 ) 1600000000 45359237 */ ;
: g>oz ( u1 -- u2 ) 1600000 45359237 */ ;
: lb>g ( u1 -- u2 ) 45359237 100000 */ ;
: lb>kg ( u1 -- u2 ) 45359237 100000000 */ ;
: g>kg ( u1 -- u2 ) 1000 / ;
: oz>lb ( u1 -- u2 ) 16 / ;
: oz>kg ( u1 -- u2 ) 45359237 1600000000 */ ;
: oz>g ( u1 -- u2 ) 45359237 1600000 */ ;
: g>lb ( u1 -- u2 ) 100000 45359237 */ ;
: g>ozt ( u1 -- u2 ) 10000000 311034768 */ ;
: ozt>g ( u1 -- u2 ) 311034768 10000000 */ ;
\ TEMPERATURE
\ C degrees Celsius, F degrees Fahrenheit
\ All values signed integers
: c>f ( n1 -- n2 ) 9 5 */ 32 + ;
: f>c ( n1 -- n2 ) 32 - 5 9 */ ;
\ TIME
\ S second, MIN minute, HR hour, DAY, YR year
\ (No s<->yr conversion due to scale diff.)
\ All values unsigned integers.
: s>min ( u1 -- u2 ) 60 / ;
: s>hr ( u1 -- u2 ) 3600 / ;
: s>day ( u1 -- u2 ) 86400 / ;
: min>hr ( u1 -- u2 ) 60 / ;
: min>day ( u1 -- u2 ) 1440 / ;
: min>yr ( u1 -- u2 ) 525960 / ;
: hr>day ( u1 -- u2 ) 24 / ;
: hr>yr ( u1 -- u2 ) 8766 / ;
: day>yr ( u1 -- u2 ) 4 1461 */ ;
: min>s ( u1 -- u2 ) 60 * ;
: hr>s ( u1 -- u2 ) 3600 * ;
: day>s ( u1 -- u2 ) 86400 * ;
: hr>min ( u1 -- u2 ) 60 * ;
: day>min ( u1 -- u2 ) 1440 * ;
: yr>min ( u1 -- u2 ) 525960 * ;
: day>hr ( u1 -- u2 ) 24 * ;
: yr>hr ( u1 -- u2 ) 8766 * ;
: yr>day ( u1 -- u2 ) 1461 4 */ ;
\ VOLUME (LIQUIDS)
\ ML milliliter TSP teaspoon TBSP tablespoon FLOZ fluid ounce
\ CUP PT pint QT quart L liter GAL gallon
\ All values unsigned integers.
: ml>tsp ( u1 -- u2 ) 9600000 47317723 */ ;
: ml>tbsp ( u1 -- u2 ) 3200000 47317723 */ ;
: ml>floz ( u1 -- u2 ) 1600000 47317723 */ ;
: ml>cup ( u1 -- u2 ) 200000 47317723 */ ;
: ml>pt ( u1 -- u2 ) 100000 47317723 */ ;
: ml>qt ( u1 -- u2 ) 50000 47317723 */ ;
: ml>l ( u1 -- u2 ) 1000 / ;
: ml>gal ( u1 -- u2 ) 12500 47317723 */ ;
: tsp>ml ( u1 -- u2 ) 47317723 9600000 */ ;
: tsp>tbsp ( u1 -- u2 ) 3 / ;
: tsp>floz ( u1 -- u2 ) 6 / ;
: tsp>cup ( u1 -- u2 ) 48 / ;
: tsp>pt ( u1 -- u2 ) 96 / ;
: tsp>qt ( u1 -- u2 ) 192 / ;
: tsp>l ( u1 -- u2 ) 47317723 9600000000 */ ;
: tsp>gal ( u1 -- u2 ) 768 / ;
: tbsp>ml ( u1 -- u2 ) 47317723 3200000 */ ;
: tbsp>tsp ( u1 -- u2 ) 3 * ;
: tbsp>floz ( u1 -- u2 ) 2 / ;
: tbsp>cup ( u1 -- u2 ) 16 / ;
: tbsp>pt ( u1 -- u2 ) 32 / ;
: tbsp>qt ( u1 -- u2 ) 64 / ;
: tbsp>l ( u1 -- u2 ) 47317723 3200000000 */ ;
: tbsp>gal ( u1 -- u2 ) 256 / ;
: floz>ml ( u1 -- u2 ) 47317723 1600000 */ ;
: floz>tsp ( u1 -- u2 ) 6 * ;
: floz>tbsp ( u1 -- u2 ) 2 * ;
: floz>cup ( u1 -- u2 ) 8 / ;
: floz>pt ( u1 -- u2 ) 16 / ;
: floz>qt ( u1 -- u2 ) 32 / ;
: floz>l ( u1 -- u2 ) 47317723 1600000000 */ ;
: floz>gal ( u1 -- u2 ) 128 / ;
: cup>ml ( u1 -- u2 ) 47317723 200000 */ ;
: cup>tsp ( u1 -- u2 ) 48 * ;
: cup>tbsp ( u1 -- u2 ) 16 * ;
: cup>floz ( u1 -- u2 ) 8 * ;
: cup>pt ( u1 -- u2 ) 2 / ;
: cup>qt ( u1 -- u2 ) 4 / ;
: cup>l ( u1 -- u2 ) 47317723 200000000 */ ;
: cup>gal ( u1 -- u2 ) 16 / ;
: pt>ml ( u1 -- u2 ) 47317723 100000 */ ;
: pt>tsp ( u1 -- u2 ) 96 * ;
: pt>tbsp ( u1 -- u2 ) 32 * ;
: pt>floz ( u1 -- u2 ) 16 * ;
: pt>cup ( u1 -- u2 ) 2 * ;
: pt>qt ( u1 -- u2 ) 2 / ;
: pt>l ( u1 -- u2 ) 47317723 100000000 */ ;
: pt>gal ( u1 -- u2 ) 8 / ;
: qt>ml ( u1 -- u2 ) 47317723 50000 */ ;
: qt>tsp ( u1 -- u2 ) 192 * ;
: qt>tbsp ( u1 -- u2 ) 64 * ;
: qt>floz ( u1 -- u2 ) 32 * ;
: qt>cup ( u1 -- u2 ) 4 * ;
: qt>pt ( u1 -- u2 ) 2 * ;
: qt>l ( u1 -- u2 ) 47317723 50000000 */ ;
: qt>gal ( u1 -- u2 ) 4 / ;
: l>ml ( u1 -- u2 ) 1000 * ;
: l>tsp ( u1 -- u2 ) 9600000000 47317723 */ ;
: l>tbsp ( u1 -- u2 ) 3200000000 47317723 */ ;
: l>floz ( u1 -- u2 ) 1600000000 47317723 */ ;
: l>cup ( u1 -- u2 ) 200000000 47317723 */ ;
: l>pt ( u1 -- u2 ) 100000000 47317723 */ ;
: l>qt ( u1 -- u2 ) 50000000 47317723 */ ;
: l>gal ( u1 -- u2 ) 12500000 47317723 */ ;
: gal>ml ( u1 -- u2 ) 47317723 12500 */ ;
: gal>tsp ( u1 -- u2 ) 768 * ;
: gal>tbsp ( u1 -- u2 ) 256 * ;
: gal>floz ( u1 -- u2 ) 128 * ;
: gal>cup ( u1 -- u2 ) 16 * ;
: gal>pt ( u1 -- u2 ) 8 * ;
: gal>qt ( u1 -- u2 ) 4 * ;
: gal>l ( u1 -- u2 ) 47317723 12500000 */ ;
\ PRICE
\ For precious metal price comparisons
\ DO usd per troy oz., YG jpy per g
\ (2nd argument is JPY per 1000 USD)
: do>yg ( u1 u2 -- u3 ) 10000 * 311034768 */ ;
: yg>do ( u1 u2 -- u3 ) 311034768 swap 10000 * */ ;
cr ." Type 'help-yuko' for help"

142
yukoa.fs Executable file
View File

@ -0,0 +1,142 @@
\ yukoa.fs -- Alternate words for YUKO
\ +JMJ 2016 David Meyer <papa@sdf.org>
cr ." Alternate YUKO words: A2B is equivalent to A>B"
: ft2in ft>in ;
: ft2km ft>km ;
: ft2m ft>m ;
: ft2mi ft>mi ;
: ft2mm ft>mm ;
: in2ft in>ft ;
: in2km in>km ;
: in2m in>m ;
: in2mi in>mi ;
: in2mm in>mm ;
: km2ft km>ft ;
: km2in km>in ;
: km2m km>m ;
: km2mi km>mi ;
: km2mm km>mm ;
: m2ft m>ft ;
: m2in m>in ;
: m2km m>km ;
: m2mi m>mi ;
: m2mm m>mm ;
: mi2ft mi>ft ;
: mi2in mi>in ;
: mi2km mi>km ;
: mi2m mi>m ;
: mi2mm mi>mm ;
: mm2ft mm>ft ;
: mm2in mm>in ;
: mm2km mm>km ;
: mm2m mm>m ;
: mm2mi mm>mi ;
: kg2lb kg>lb ;
: kg2g kg>g ;
: lb2oz lb>oz ;
: kg2oz kg>oz ;
: g2oz g>oz ;
: lb2g lb>g ;
: lb2kg lb>kg ;
: g2kg g>kg ;
: oz2lb oz>lb ;
: oz2kg oz>kg ;
: oz2g oz>g ;
: g2lb g>lb ;
: g2ozt g>ozt ;
: ozt2g ozt>g ;
: c2f c>f ;
: f2c f>c ;
: s2min s>min ;
: s2hr s>hr ;
: s2day s>day ;
: min2hr min>hr ;
: min2day min>day ;
: min2yr min>yr ;
: hr2day hr>day ;
: hr2yr hr>yr ;
: day2yr day>yr ;
: min2s min>s ;
: hr2s hr>s ;
: day2s day>s ;
: hr2min hr>min ;
: day2min day>min ;
: yr2min yr>min ;
: day2hr day>hr ;
: yr2hr yr>hr ;
: yr2day yr>day ;
: ml2tsp ml>tsp ;
: ml2tbsp ml>tbsp ;
: ml2floz ml>floz ;
: ml2cup ml>cup ;
: ml2pt ml>pt ;
: ml2qt ml>qt ;
: ml2l ml>l ;
: ml2gal ml>gal ;
: tsp2ml tsp>ml ;
: tsp2tbsp tsp>tbsp ;
: tsp2floz tsp>floz ;
: tsp2cup tsp>cup ;
: tsp2pt tsp>pt ;
: tsp2qt tsp>qt ;
: tsp2l tsp>l ;
: tsp2gal tsp>gal ;
: tbsp2ml tbsp>ml ;
: tbsp2tsp tbsp>tsp ;
: tbsp2floz tbsp>floz ;
: tbsp2cup tbsp>cup ;
: tbsp2pt tbsp>pt ;
: tbsp2qt tbsp>qt ;
: tbsp2l tbsp>l ;
: tbsp2gal tbsp>gal ;
: floz2ml floz>ml ;
: floz2tsp floz>tsp ;
: floz2tbsp floz>tbsp ;
: floz2cup floz>cup ;
: floz2pt floz>pt ;
: floz2qt floz>qt ;
: floz2l floz>l ;
: floz2gal floz>gal ;
: cup2ml cup>ml ;
: cup2tsp cup>tsp ;
: cup2tbsp cup>tbsp ;
: cup2floz cup>floz ;
: cup2pt cup>pt ;
: cup2qt cup>qt ;
: cup2l cup>l ;
: cup2gal cup>gal ;
: pt2ml pt>ml ;
: pt2tsp pt>tsp ;
: pt2tbsp pt>tbsp ;
: pt2floz pt>floz ;
: pt2cup pt>cup ;
: pt2qt pt>qt ;
: pt2l pt>l ;
: pt2gal pt>gal ;
: qt2ml qt>ml ;
: qt2tsp qt>tsp ;
: qt2tbsp qt>tbsp ;
: qt2floz qt>floz ;
: qt2cup qt>cup ;
: qt2pt qt>pt ;
: qt2l qt>l ;
: qt2gal qt>gal ;
: l2ml l>ml ;
: l2tsp l>tsp ;
: l2tbsp l>tbsp ;
: l2floz l>floz ;
: l2cup l>cup ;
: l2pt l>pt ;
: l2qt l>qt ;
: l2gal l>gal ;
: gal2ml gal>ml ;
: gal2tsp gal>tsp ;
: gal2tbsp gal>tbsp ;
: gal2floz gal>floz ;
: gal2cup gal>cup ;
: gal2pt gal>pt ;
: gal2qt gal>qt ;
: gal2l gal>l ;
: do2yg do>yg ;
: yg2do yg>do ;