colorforth jul31 chuck moore public domain 24 load 26 load 28 load 30 load
dump 32 load ;
icons 34 load ;
print 38 load ;
file 44 load ;
north 46 load ;
colors 56 load ; mark empty

macro
swap 687 2, ;
0 ?dup c031 2, ;
if 74 2, here ;
-if 79 2, here ;
a ?dup c28b 2, ;
a! ?lit if ba 1, , ; then d08b 2, drop ;
2* e0d1 2, ;
a, 2* 2* , ;
@ ?lit if ?dup 58b 2, a, ; then 85048b 3, 0 , ;
! ?lit if ?lit if 5c7 2, swap a, , ; then 589 2, a, drop ; then a! 950489 3, 0 , drop ;
nip 4768d 3, ;
+ ?lit if 5 1, , ; then 603 2, nip ;
or 633
binary ?lit if swap 2 + 1, , ; then 2, nip ;
and 623 binary ;
u+ ?lit if 681 2, , ; then 44601 3, drop ;
? ?lit a9 1, , ;

pentium macros: 1, 2, 3, , compile 1-4 bytes
drop lodsd, flags unchanged, why sp is in esi
over sp 4 + @
swap sp xchg
0 0 0 xor, macro 0 identical to number 0
a 2 0 mov, never used?
a! 0 2 mov, unoptimized
@ eax 4 *, unoptimized
! edx 4 *
nop used to thwart look-back optimization
- ones-complement
2*
2/
if jz, flags set, max 127 bytes, leave address
-if jns, same
then fix address - in kernel
push eax push
pop eax pop
u+ add to 2nd number, literal or value
? test bits, set flags, literal only!

macros
over ?dup 4468b 3, ;
push 50 1, drop ;
pop ?dup 58 1, ;
- d0f7 2, ;
for push begin ;
*next swap
next 75240cff
0next , here - + 1, 4c483 3, ;
-next 79240cff 0next ;
i ?dup 24048b 3, ;
*end swap
end eb 1, here - + 1, ;
+! ?lit if ?lit if 581 2, swap a, , ; then 501 2, a, drop ; then a! 950401 3, 0 , drop ;
nop 90 1, ;
align here - 3 and drop if nop align ; then ;
or! a! 950409 3, 0 , drop ;
* 6af0f 3, nip ;
*/ c88b 2, drop f9f72ef7 , nip ;
/mod swap 99 1, 16893ef7 , ;
/ /mod nip ;
mod /mod drop ;

for n push count onto return stack, falls into begin
begin -a current code address - byte
*next aa-aa swap for and if addresses
next a decrement count, jnz to for, pop return stack when done
-next a same, jns - loop includes 0
i -n copy loop index to data stack
end a jmp to begin
+! na add to memory, 2 literals optimized
align next call to end on word boundary
or! na inclusive-or to memory, unoptimized
* mm-p 32-bit product
*/ mnd-q 64-bit product, then quotient
/mod nd-rq remainder and quotient
/ nd-q quotient
mod nd-r remainder
time -n pentium cycle countegas 15240000 to get actual clock rate

compiled macros
2/ f8d1 2, ;
time ?dup 310f 2, ; forth
@ @ ;
! ! ;
+ + ;
*/ */ ;
* * ;
/ / ;
2/ 2/ ;
dup dup ; arithmetic
negate - 1 + ;
min less if drop ; then swap drop ;
abs dup negate
max less if swap then drop ;
v+ vv-v push u+ pop + ;
writes acn for write next drop drop ;
reads acn for read next drop drop ;
oadf qwerty
save 0 dup nc @ writes stop ;

these macros may be white, others may not
@ etc arithmetic
negate n-n when you just cant use -
min nn-n minimum
abs n-u absolute value
max nn-n maximum
v+ vv-v add 2-vectors
nc -a number of cylinders booted
save write colorforth to bootable floppy
oadf save as spelled by qwerty. for typing with blank screen

colors etc
block 100 * ;
white ffffff color ;
red ff0000 color ;
green ff00 color ;
blue ff color ;
silver bfbfbf color ;
black 0 color ;
screen 0 dup at 1024 768 box ;
5* 5 for 2emit next ;
cf 25 dup at red 1 3 c 3 a 5* green 14 2 1 3 3e 5* ;
logo show black screen 800 710 blue box 600 50 at 1024 620 red box 200 100 at 700 500 green box text cf keyboard ;
empty empt logo ;

block n-a block number to word address
colors specified as rgb: 888
screen fills screen with current color
at xy set current screen position
box xy lower-right of colored rectangle
dump compiles memory display
print compiles screen print
icon compiles icon editor
logo displays colorforth logo
show background task executes following code repeatedly
keyboard displays keypad and stack

dump x 77808 y 2102592
one dup @ h. space dup h. cr ;
lines for one -1 + next drop ;
dump x !
r show black screen x @ 15 + 16 text lines keyboard ;
it @ + @ dup h. space ;
lines for white i x it i y it or drop if red then i . cr -next ;
cmp show blue screen text 19 lines red x @ h. space y @ h. keyboard ;
u 16
+xy dup x +! y +! ;
d -16 +xy ;
ati f4100000 ff7fc000 or
byte 4 / dump ;
fix for 0 over ! 1 + next ; dump

does not say empty, compiles on top of application
x -a current address
one a-a line of display
lines an
dump a background task continually displays memory
u increment address
d decrement
ati address of agp graphic registers
byte a byte address dump
fix an-a test word

icons empty macro
@w 8b66 3, ;
!w a! 28966 3, drop ;
*byte c486 2, ; forth ic 80 cu 116
sq xy @ 10000 /mod 16 + swap 16 + box 17 0 +at ;
loc ic @ 16 24 8 */ * 12 block 4 * + ;
0/1 8000 ? if green sq ; then blue sq ;
row dup @w *byte 16 for 0/1 2* next drop -17 16 * 17 +at ;
ikon loc 24 for row 2 + next drop ;
adj 17 * swap ;
cursor cu @ 16 /mod adj adj over over at red 52 u+ 52 + box ;
ok show black screen cursor 18 dup at ikon text ic @ . keyboard ; 36 load ok h

draw big-bits icon
@w a-n fetch 16-bit word from byte address
!w na store same
*byte n-n swap bytes
ic -a current icon
cu -a cursor
sq draw small square
xy -a current screen position, set by at
loc -a location of current icons bit-map
0/1 n-n color square depending on bit 15
row a-a draw row of icon
+at nn relative change to screen position
ikon draw big-bits icon
adj nn-nn magnify cursor position
cursor draw red box for cursor
ok background task to continually draw icon, icon number at top sr 4210752 4210752 4210752

edit
+ic 1 ic +! ;
-ic ic @ -1 + 0 max ic ! ;
bit cu @ 2/ 2/ 2/ 2/ 2* loc + 10000 cu @ f and 1 + for 2/ next *byte ;
toggle bit over @w or swap !w ;
td toggle
d 16
wrap cu @ + 16 24 * dup u+ /mod drop cu ! ;
tu toggle
u -16 wrap ;
tr toggle
r 1 wrap ;
tl toggle
l -1 wrap ;
nul ;
h pad nul nul accept nul tl tu td tr l u d r -ic nul nul +ic nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 110160c dup , , 2b000023 , 0 , 0 , 0 ,

edit icon

png empty w 54 h 32 d 4
frame 1e80000 ; file 42 load 40 load
-crc a here over negate + crc . ;
crc -crc ;
wd -a here 3 and drop if 0 1, wd ; then here 2 2/s ;
bys n-a . here swap , ;
plte 45544c50 48 bys 0 3, ff0000 3, ff00 3, ffff00 3, ff 3, ff00ff 3, ffff 3, ffffff 3, 0 3, c00000 3, c000 3, c0c000 3, c0 3, c000c0 3, c0c0 3, c0c0c0 3, crc ;
png awh d @ / h ! d @ / w ! wd swap 474e5089 , a1a0a0d , ihdr 52444849 13 bys w @ . h @ . 304 , 0 1, crc plte idat 54414449 0 bys swap deflate crc iend 444e4549 0 bys crc wd over negate + ;
at 1024 * + 2* frame + ;
full 4 d ! 0 dup at 1024 768 png ;
pad 1 d ! 46 -9 + 22 * nop 25 -4 + 30 * at 9 22 * nop 4 30 * png ;

lz77 macro
@w 8b66 3, ;
*byte c486 2, ;
!b a! 289 2, drop ; forth
*bys dup 16 2/s *byte swap ffff and *byte 10000 * + ;
. *bys , ;
+or over - and or ;
0/1 10 ? if 1e and 1e or drop if 7 ; then f ; then 0 and ;
4b dup 0/1 9 and over 6 2/s 0/1 a and +or swap 11 2/s 0/1 c and +or 8 or ;
pix dup @w d @ 2* u+ 4b ;
row 1, dup w @ 2/ dup 1 + dup 2, - 2, 0 dup 1, +adl for pix 16 * push pix pop or dup 1, +adl next drop +mod d @ 1024 2 * * + ;
deflate 178 2, 1 0 adl! h @ -1 + for 0 row next 1 row drop ad2 @ *byte 2, ad1 @ *byte 2, here over 4 + negate + *bys over -4 + !b ;

crc macro
2/s ?lit e8c1 2, 1, ;
1@ 8a 2, ; forth ad1 48546 ad2 48600
array -a pop 2 2/s ;
bit n-n 1 ? if 1 2/s edb88320 or ; then 1 2/s ;
fill nn for dup 8 for bit next , 1 + next drop ;
table -a align array 0 256 fill
crc an-n -1 swap for over 1@ over or ff and table + @ swap 8 2/s or 1 u+ next - nip ;
+adl n ff and ad1 @ + dup ad2 @ +
adl! ad2 ! ad1 ! ;
+mod ad1 @ 65521 mod ad2 @ 65521 mod adl! ;

dos file
blks 256 * ;
w/c 18 blks ;
buffer 604 block ;
size -a buffer 0 1 reads buffer 98f + ;
set n ! buffer 0 1 writes ;
cyls n-nn 1 swap w/c -1 + + w/c / ;
put an dup 2* 2* size set cyls writes stop ;
get a size @ 3 + 2/ 2/ cyls reads stop ;
.com 0 63 blocks put ;

blks n-n size in blocks to words
w/c -n words per cylinder
buffer -a 1 cylinder required for floppy dma
size -a locate size of 2nd file. floppy has first filler then file allocated. filler is 2048 bytes, to fill out cylinder 0. names at most 8 letters, all caps. directory starts at buffer 980 +
set n size. file must be larger than your file.
cyls n-nn starting cylinder 1 and number of cylinders
put an write file from address
get a read file to address

north bridge empty macro
4@ dup ed 1, ;
4! ef 1, drop ; forth dev 15104
nb 0 dev ! ;
sb 3800 dev ! ;
agp 800 dev ! ;
ess 6800 dev ! ;
ric 7800 dev ! ;
win 8000 dev ! ;
ati 10000 dev ! ;
add cf8 a! 4! cfc a! ;
q 80000000 + add 4@ ;
en 8004 q -4 and or 4! ;
dv dup 800 * q swap 1 + ;
regs dev @ 19 4 * + 20 for dup q h. space dup h. cr -4 + next drop ;
devs 0 33 for dup q dup 1 + drop if dup h. space drop dup 8 + q dup h. space over h. cr then drop 800 + next drop ;
ok show black screen text regs keyboard ;
u 40 dev +! ;
d -64 dev +! ;
test ff00 + a! 4@ ; ok

ascii macro
1@ 8a 2, ; forth
string pop ;
cf-ii string 6f747200 , 696e6165 , 79636d73 , 7766676c , 62707664 , 71757868 , 336a7a6b , 37363534 , 2d313938 , 2f322e30 , 2b213a3b , 3f2c2a40 ,
ch fffffff0 and unpack cf-ii + 1@ ff and ;
ii-cf string 2a00 , 0 , 2b2d0000 , 2725232e , 1b262224 , 1f1e1d1c , 28292120 , 2f000000 , 3a43355c , 3d3e3440 , 484a3744 , 3336393c , 38314742 , 3f414632 , 493b45 , 0 , a13052c , d0e0410 , 181a0714 , 306090c , 8011712 , f111602 , 190b15 ,
chc ffffffe0 + ii-cf + 1@ ff and ;

clock macro
p@ ec 1, ;
p! ee 1, drop ; forth
ca 70 a! p! 71 a! ;
c@ ca 0 p@ ;
c! ca p! ;
hi 10 c@ 80 and drop if ; then hi ;
lo 0 p@ 80 and drop if lo ; then ;
bcd c@ 16 /mod 10 * + ;
hms0 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
ms drop ;
hms hms0 2 ms dup hms0 or drop if drop hms ; then ;
ymd 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day 6 c@ -1 + ;
cal hi lo time - hi lo time + 748 ;

lan empty 3f8 54 load init
no block 4 * 1024 ;
send no for dup 1@ xmit 1 + next drop ;
receive no for rcv over 1! 1 + next drop ;
no 18 7 18 * ;
backup no for dup send 1 + next drop ;
accept no for dup receive 1 + next drop ;

sr 4210752 4210752 4210752

serial 3f8 2e8 1050 macro
p@ a! dup ec 1, ;
p! a! ee 1, drop ;
1@ 8a 2, ;
1! a! 288 2, drop ; forth
r 0 + + ;
9600 12 ;
115200 1 ;
b/s 83 3 r p! 9600 0 r p! 0 1 r p! 3 3 r p! ;
init b/s 16550 1 2 r p! 0 4 r p! ;
xmit n 5 r p@ 20 and drop if 0 r p! ; then pause xmit ;
cts 6 r p@ 30 and 30 or drop if cts ; then xmit ;
st 6 r p@
xbits 30 and 10 / dup 1 and 2* 2* + 2/ ;
st! 4 r p! ;
?rcv 5 r p@ 1 and drop if 0 r p@ then ;
rcv ?rcv if ; then pause rcv ;

p@ p-n fetch byte from port
p! np store byte to port
1@ a-n fetch byte from byte address
1! na store byte to byte address
r n-p convert relative to absolute port address. base port on stack at compile time. compiled as literal at yellow-green transition
9600
115200 baud-rate divisors. these are names, not numbers
b/s set baud rate. edit to change
init initialize uart
xmit n wait for ready and transmit byte
cts n wait for clear-to-send then xmit
st -n fetch status byte
xbits n-n exchange status bits
st! n store control byte
?rcv fetch byte if ready. set flag to be tested by if
rcv -n wait for ready and fetch byte

hexagon empt col 4227200 del 4210752
lin dup 2/ 2/ dup 2* line ;
hex xy @ 7 and over 2/ for lin 7 + next over for lin next swap 2/ for -7 + lin next drop ;
+del del @ nop
petal and col @ + f8f8f8 and color 100 hex ;
-del del @ f8f8f8 or 80808 + ;
rose 0 +del -176 -200 +at f80000 -del petal 352 -200 +at f80000 +del -264 -349 +at f800 -del petal 176 -200 +at f8 +del -176 98 +at f8 -del petal 176 -200 +at f800 +del ;
ok show black screen 512 282 at rose text col @ h. space del @ ff and . keyboard ; 58 load ok h

draws 7 hexagons. colors differ along red, green and blue axes.
col color of center hexagon
del color difference
lin n draws 1 horizontal line of a hexagon
hex n draws top, center and bottom. slope 7 x to 4 y is 1.750 compared to 1.732
+del n increment color
-del n
petal n draw colored hexagon
rose draw 7 hexagons
ok describe screen. center color at top

pan
in del @ 2* 404040 min del ! ;
out del @ 2/ 80808 max del ! ;
r f80000
+del del @
+col and col @ + f8f8f8 and col ! ;
g f800 +del ;
b f8 +del ;
-r f80000 -del +col ;
-g f800 -del +col ;
-b f8 -del +col ;
nul ;
h pad nul nul accept nul -r -g -b nul r g b nul out nul nul in nul nul nul nul nul nul nul nul nul nul nul nul 250000 , 130d01 dup , , 2b000023 , 0 , 0 , 0 ,

in increment color difference
out decrement it
r
g
b increment center color
-r
-g
-b decrement it
+del redefine with ;
+col change center color
nul ignore
h describe keypad

timing empty macro
out e1e6 2, ; forth
tare time - 1000 for next time + ;
tare+ time - push 1000 for dup next c pop time + ;
test tare time + - 1000 for out next time + ; next 3 loop 5.7 /next 2 /swap 25 swap 7.2 macro
c! c88b 2, drop here ;
loop 49 1, 75 1, e2 here - + 1, ; forth
try time - 1000 c! loop time + ;

for n push count onto return stack, falls into begin
begin -a current code address - byte
*next aa-aa swap for and if addresses
next a decrement count, jnz to for, pop return stack when done
-next a same, jns - loop includes 0
i -n copy loop index to data stack
end a jmp to begin
+! na add to memory, 2 literals optimized
align next call to end on word boundary
or! na inclusive-or to memory, unoptimized
* mm-p 32-bit product
*/ mnd-q 64-bit product, then quotient
/mod nd-rq remainder and quotient
/ nd-q quotient
mod nd-r remainder
time -n pentium cycle counter, calibrate to get actual clock rate

debug type dump 80 load macro
bswap c80f 2, ; forth x 17984
4al a- 4 for dup @b 7f and dup -32 + drop -if drop 2e then chc emit 1+ next drop ;
8alpha 4 * dup 4al 35 emit 4 + 4al ;
two a- dup @ bswap h. 35 emit 1+ @ bswap h. ;
one a-a dup 4 * 7 h.n 46 emit dup 256 / . space dup two space dup 8alpha 1+ 1+ cr ;
lines for one next drop ;
dump x !
r show black screen x @ 16 text lines keyboard ;
u -32 x +! ;
d 32 x +! ;

extend system 74 load macros 76 load fixes 88 load stack
rtc 82 load ;
utils 84 load copy ;
circles 86 load ;
rand 90 load random ;
lines 92 load ;
htm 102 load html ;

added macros macro
?f c021 2, ;
0if 75 2, here ;
+if 78 2, here ;
1+ 40 1, ;
1- 48 1, ;
@b 8a 2, ;
@w 8b66 3, ;
@l 8b 2, ;
!b a! 288 2, drop ;
!w a! 28966 3, drop ;
!l a! 289 2, drop ; forth ywts

added macros
?f set flags to reflect tos
0if jnz aids in clarity
+if js, this complements the set
1+ increment tos
1- decrement tos
@b fetch byte from absolute addr.
@w fetch word from absolute addr.
@l fetch long from absolute addr.
!b store byte in absolute addr.
!w store word in absolute addr.
!l store long in absolute addr.

corrections
h sp 20 + ;
oadf qwerty
save h @ 100000 h ! 0 dup nc @ writes stop h ! ;

corrections
h -a address of dict pointer, see here also
oadf
save changed this to keep the dictionairy in the same area.

new logo
.co 1 3 c 3 a 5* ;
.fo 14 2 1 3 3e 5* ;
cf 27 dup at silver .co .fo 25 dup at red .co green .fo ;
logo show black screen text cf keyboard ;
empty empt logo ; mark
grads 0 128 for i 2* 1- color dup 10 at 5 + dup 120 box next -400 + 128 for 257 i 2* negate + dup 256 * + color dup 10 at 5 + dup 100 box next drop ; circles lines 106 load 94 load
lnes framed 20 for i 2* 40 + 250 584 ff07 circle next filled 30 250 584 f800 circle framed ffff pen ! art 620 120 at 1020 300 frame 5 120 at 405 300 frame ;
logo black screen grads lnes text cf show dotty fillit ckb keyboard ;
empty empt logo ;

new logo
logo defined twice. first empty shows the fancy logo second entered empty shows the plain one. this unloads circles and lines. purely to prevent name space crowding.

ascii
cf-ii addr 6f747200 , 696e6165 , 79636d73 , 7766676c , 62707664 , 71757868 , 33323130 , 37363534 , 2d6a3938 , 2f7a2e6b , 2b213a3b , 3f2c2a40 ,
ch fffffff0 and unpack cf-ii + @b ff and ;
ii-cf addr 2a00 , 0 , 2b2d0000 , 2725232e , 1b1a1918 , 1f1e1d1c , 28292120 , 2f000000 , 3a43352c , 3d3e3440 , 54523744 , 3336393c , 38314742 , 3f414632 , 563b45 , 0 , a130500 , d0e0410 , 24220714 , 306090c , 8011712 , f111602 , 260b15 ,
chc ffffffe0 + ii-cf + @b ff and ;

ascii corrections to
cf-ii and
ii-cf regarding the decimals and the letters k j z

rtc macro
p@ ec 1, ;
p! ee 1, drop ; forth
rtca 70 a! p! 71 a! ;
rtc@ rtca 0 p@ ;
rtc! rtca p! ;
hi 10 rtc@ 80 and drop 0if hi ; then ;
lo 10 rtc@ 80 and drop if lo ; then ;
bcd rtc@ 16 /mod 10 * + ;
hms lo 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
ymd lo 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day lo 6 rtc@ 1- ;
cal hi lo time - hi lo time + ;

rtc real time clock
p@ -n compile: in al,dx
p! n- compile: out dx,al
rtca reg- set up rtc for acces to register
rtc@ reg-n fetch reg from rtc
rtc! n reg- store in rtc register
hi wait till update in progress bit is high
lo wait till uip bit is low
bcd bcd-n bcd to binary
hms -n hours+mins+secs
ymd -n year+month+day
day -n day of the week
cal -n number of cpu clocks per second

utils
copy sf st e7c1f88b , 368b560a , b90ae6c1 , 100 , ad5ea5f3 , c3ad 2,
rcopy sf sl st push dup push swap negate + pop swap pop over + swap for over over copy push 1- pop 1- -next drop drop ;

utils
copy from to- copy from to block numbers. unlike orig copy; no change to blk
rcopy first last to- multiple block copy routine

circles c-cd -8 c-ff 1
point4 4096 * swap 4 * 2dup + 2/ negate bs @ + pen @ over !w over push + pen @ over !w + pen @ over !w pop negate + pen @ swap !w ;
opnts 2dup point4 2dup swap point4 ;
d? c-cd @ ?f drop -if ; then dup - c-cd +! 1- 1 c-ff ! ;
cfl 1+ 1+ push pen @ swap pop 2/ for over over !w 1+ 1+ next drop drop ;
cfl4 4096 * swap 4 * 2dup + 2/ negate bs @ + swap 2dup cfl push + pop cfl ;
fvrt ?f drop if cfl4 0 c-ff ! ; then point4 ;
fpnts 2dup c-ff @ fvrt 2dup swap cfl4 ;
points opnts ;
pntst addr points opnts fpnts ;
framed pntst 1 select ;
filled pntst 2 select ;
circle 0 c-ff ! pen ! 1024 * + 2* vframe + bs ! 0 swap dup negate c-cd !
crcl less if points 1 u+ over c-cd +! d? crcl ; then points drop drop ;

circles
point4 .. all other words are internal.
points acts like a deferred word.
pntst table of calls to different point routines. select alters points
framed set circle to draw outlined circles.
filled set circle to draw filled circles.
circle rxyc- draw circle with radius r center xy in color c

stack juggling + misc.
addr pop ;
rot 8b045e8b , 46e892e , c38b0689 , c3 1,
-rot 8b045e8b , 446892e , c58b1e89 , c3 1,
tuck swap over ;
2swap 87085e8b , 85e891e , c3044687 ,
2over 89f8768d , 5e8b0446 , 8b1e8910 , c30c46 3,
2dup over over ;
v- push - 1+ u+ pop - 1+ + ;
vn push rot less if rot pop -rot ; then -rot pop ;
vframe 1e80000 ; pen 65535 bs 32461510
vloc 2048 * over + + vframe + ;
point vloc pen @ swap !w ;
at? xy @ 10000 /mod swap ;
@r 1+ dup 4 u+ @l + ;
!r 1+ dup push negate -4 + + pop !l ;
select 5 * over + @r swap @r !r ;
ckb black 0 740 at 1024 768 box 800 650 at 1023 740 box ;

stack juggling words. small and fast.
addr -a absolute address
rot abc-bca stack pictures are best ..
-rot abc-cab ..described with letters, in
tuck ab-bab ..this case.
2swap abxy-xyab
2over abxy-abxyab
2dup ab-abab
v- v1v2 - v1-v2 vector subtract.
vn vv-vv sort vectors so x1 is less x2
vframe -addr address of screen.
pen -addr current color.
bs -addr base for elements
vloc xy-a convert xy into addr.
point xy- set point at xy to current pen.
at? -xy return current screen location.
@r a-a get absolute addr from jump/call
!r aa- set jump/call to absolute addr.
select an- select call n from table a. store it in table call 0

random rsav 2107951961 rseed -526774649
rand time rsav ! e09a0e87 rseed ! ;
ror d3adc88b , c3c8 2,
random push rseed @ 0 32 for 2* swap 2* swap -if rsav @ or then next nip 15 ror dup rsav ! abs pop mod ; rand

random
rand - set random variables
ror nm-n rotate n m times right
random n-0..n-1 return a random number range 0..n-1 limited to a 16 bit number.

lines ax -1068 ay 0 sx 2048 sy 2 lbase 32014376 macro
lp 8b02e2c1 , c88bade8 , 205a8bad , 232b8966 , 30578c0 , 185a0302 , 3084203 , ece2105a , ; forth
!base 2048 * over + + vframe + lbase ! ;
bline abs 2* dup ay ! over 2* negate ax ! over negate + swap 1+ pen @ ax a! lp drop ;
?xd 2over 2over v- abs swap abs swap less drop drop -1 if 1+ then ?f drop ;
!sy push ?f pop -if negate then sy ! bline ;
xdom 2swap !base 2 sx ! 2048 !sy ;
ydom swap 2swap swap !base swap 2048 sx ! 2 !sy ;
aline ?xd if vn 2over v- xdom ; then push push swap pop pop swap vn 2over v- ydom ;
line at? 2over aline at ;
frame at? 2over drop over line 2over line 2swap push drop over pop line line ;

line drawing do not mess with variables. they are indexed by lp.
lp macro inner loop for speed. draws point and moves location.
!base x y -- set base address
bline dx dy -- draw a line using bresenham x dominant
?xd v1 v2 -- v1 v2 set flag if line is x-dominant
!sy dy n -- dy store n in sy set sign to match sign of dy
xdom x y dx dy draw an x-dominant line
ydom x y dx dy draw a y-dominant line
aline v1 v2 draw any straight line
line x y draw line from current at to xy. moves at to given xy.
frame xy- trace outline of rectangle with corners at and xy. pen position is not altered.

demos
xlate 384 + 512 u+ ;
xat xlate at ;
xline xlate line ;
4lines over 0 xat 0 over xline over - 1+ 0 xline - 1+ 0 swap xline 0 xline ;
art 70 for 71 i - 1+ + 5 * i 5 * 4lines next ; rand
radius 8 ;
lrc push dup dup + negate pop + random + ;
shade 2over 1+ 1+ 2over drop 1+ 1+ 1+ 0 circle circle ;
dotty filled 100 for radius random dup 397 lrc 621 + over 176 lrc 121 + ffff random shade next ;
blbx black 6 121 at 404 299 box ; xyzz -177
fillit -1 xyzz +! xyzz @ 200 + drop -if blbx 0 xyzz ! then framed 3 for 8 random 2 + dup 398 lrc 6 + over 178 lrc 121 + ffff circle next 6 210 fff0 random afill ;

html0 80 load h-dd 0 ppt 8 macro
2/s ?lit e8c1 2, 1, ; forth
temit h-dd @ !b 1 h-dd +! ;
tspc 20 temit ;
.dc ?f 1 -if - then swap abs
dcl 10 /mod swap 30 + push ?f 0if drop ?f drop -if 2d temit then pop temit ; then dcl pop temit nop ;
.hx 39 over 15 and 30 + less nip if 27 + then push 4 2/s 0if drop pop temit ; then .hx pop temit nop ;
strt dup @b ff and if temit 1+ strt ; then drop drop ;
str: pop strt ;
header str: 6d74683c , 3c0a3e6c , 6b6e696c , 6c657220 , 7974733d , 6873656c , 20746565 , 65707974 , 6574223d , 632f7478 , 20227373 , 66657268 , 3d 1, 6c6f6322 , 6f66726f , 2e687472 , 22737363 , 703c0a3e , a3e 3,
trailer str: 74682f3c , a3e6c6d , 0 1,

html0. block 80 has ascii conversion tables.
h-dd data destination. ppt pre- parsed type.
2/s macro, right shift by n.
temit c- emit char to target.
tspc emit space
.dc n- signed decimal print. recursive!
dcl dec print loop.
.hx n- unsigned hex print. also recursive. both routines have no leading zeroes.
strt a- print bytes from address until first null byte.
str: output what follows up to null byte.
header lay down html header to display blocks. the header is very minimal. it expects colorforth.css in the same directory.
trailer closing html stuff.

html1
.code 1- drop -if ; then str: 6f632f3c , 3e6564 ,
.all str: 646f633c , 6c632065 , 3d737361 , 0 1,
same? ppt @ over ppt ! swap over - 1+ + drop ;
comn same? 0if drop tspc pop drop ; then .code .all ;
.def str: 3e666564 , 20 2,
.com 2 comn str: 3e6d6f63 , 20 2,
.chx 3 comn str: 3e786863 , 20 2,
.exe 4 comn str: 3e657865 , 20 2,
.xhx 5 comn str: 3e786878 , 20 2,
.cpm 6 comn str: 3e6d7063 , 20 2,
.var 7 comn str: 3e726176 , 20 2,
.txt 8 comn str: 3e747874 , 20 2,
.txc 9 comn str: 3e637874 , 20 2,
.tac 10 comn str: 3e636174 , 20 2,

html1
.code n- output /code in brackets if n is larger then 0.
.all common part to start a new code tag.
same? n-o set ppt to the new type. return the old type with flags set from comparison.
comn n- if this is a new tag, close prev tag and print common part. if not: print space and exit caller
.def each of these words correspond to a
.com .. code tag as defined in colorforth.css
.chx .. the numbers are positional, and bare
.exe .. no correspondence to the pre parsed
.xhx .. types. they will output if a change
.cpm .. in tag is required. comn will exit
.var .. by doing a pop-drop if the tag is the
.txt .. same.
.txc
.tac

html2
.str ch if temit .str ; then drop drop ;
bs1 0 ppt ! str: 3e72683c , 6c627b0a , 206b636f , 0 1,
bs2 str: 643c0a7d , 63207669 , 7373616c , 786f623d , a3e 3,
bend ppt @ .code str: 69642f3c , a3e76 ,
.br 1- drop -if ; then str: 3e72623c , a 2,
pp0 .str ;
pp1 .exe .str ;
pp3 ppt @ dup .code .br 1 ppt ! .all .def .str ;
pp4 .com .str ;
pp7 .cpm .str ;
pp9 .txt .str ;
ppa .txc .str ;
ppb .tac .str ;
ppc .var .str 1+ dup @ .com .dc ;

html2
.str n- unpack n and print as ascii.
bs1 clear the type and print html stuff for the start of a block.
bs2 second half of block header.
bend block end html stuff.
.br n- html line break, if n larger then 0
pp0 the preparsed words in a block are
pp1 .. printed by the ppn words. eg pp0 is
pp3 .. word continuation pp1 is for executed
pp4 .. words, etc. they unpack and print.
pp7 .. they also print html tags.
pp9
ppa
ppb
ppc

html3 96 load 98 load 100 load
dbn push 1+ dup @ pop ?f drop ;
sln dup 2/ 2/ 2/ 2/ 2/ swap 16 and drop ;
xnb if .xhx .hx ; then .exe .dc ;
cnb if .chx .hx ; then .com .dc ;
pp2 dbn xnb ;
pp5 dbn cnb ;
pp6 sln cnb ;
pp8 sln xnb ;
ppdo jump pp0 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 ppa ppb ppc ;
index dup 15 and dup push or pop ;
dblk dup bs1 .dc bs2 block begin dup @ ?f 0if drop drop bend ; then index ppdo 1+ end
hbuf 2000 block ;
html hbuf 4 * h-dd ! header swap over for over i - 1+ + over + dblk next drop drop trailer hbuf h-dd @ 3 + 4 / over - 1+ + 3 for tspc next ;

html3
dbn an-an fetch next word. set hex flag.
sln n-n make full word and set hex flag.
xnb n- print n as hex/dec executed number.
cnb n- print n as hex/dec compiled number.
pp2 an-a a double executed number.
pp5 an-a a double compiled number.
pp6 n- a single compiled number.
pp8 n- a single executed number.
ppdo table of words. the index is the pre- parsed type type.
index n-ni extract index from n.
dblk b- print block b in html.
hbuf -a start of buffer.
html bn-al output n blocks starting with block b in html. leaves addr and length on the stack, so it can be saved using file put on a floppy.

simpler and slower bresenham line drawing. for reference. ax -360 ay 0 sy 2 sw 0
bpoint push 2dup sw @ ?f drop if swap then point pop ;
bline abs 2* dup ay ! over 2* negate ax ! over negate + swap 1+ for bpoint ?f +if sy @ u+ ax @ + then ay @ + push 1 u+ pop next drop drop drop ;
?xd 2over 2over v- abs swap abs swap less drop drop -1 if 1+ then ?f drop ;
!sy push ?f pop -if negate then sy ! bline ;
xdom 0 sw ! 1 !sy ;
ydom 1 sw ! 1 !sy ;
aline ?xd if vn 2over v- xdom ; then push push swap pop pop swap vn 2over v- ydom ;

area filling 108 load tfc 22461 fc 24071
pset dup dup @w ffff and tfc @ negate + drop if drop 0 ; then fc @ swap !w 0 1+ ;
bcup dup 2047 and 2- begin -if drop ; then push 2- pset drop pop if 2- *end then drop 2+ ;
ispan pset if ; then push enstak pop ;
xgr dup negate 3 pick + drop ;
nispan dlrlx xgr -if 5drop pop pop pop drop drop drop ; then pset if push nip dup pop then ;
dosp dlrlx jump nispan ispan dlrlxi ;
sha2 over rtre begin dlrlxic -if drop ; then push dosp 2 u+ pop 2- end
sha1 dlr over pset over dlrxil if bcup dlrxil then swap push swap 2+ pop dlrlxi sha2 ?f drop if enstak then 5drop ;
sha begin fst? if fpop sha1 *end then ;
fsln dup bcup swap dup rtre begin -if drop ; then push pset drop if 2+ pop 2- *end then pop drop 2- ;
afill fstini fc ! vloc dup @w ffff and tfc ! fsln over over -2048 u+ -2048 + -2048 -rot fpsh 2048 u+ 2048 + 2048 -rot fpsh sha ;

area filling
pset a-0/1 set pixel at a, if pixel equals tfc. return 0 if not, 1 if pixel was set.
bcup a-a adjust a until left edge is found. limited to screen edge.
ispan stack if the right edge is found.
xgr set neg flag if x is greater then parent-r
nispan exit if beyond right edge of span, else start a new span.
dosp dlrlx - dlrlxi jump table.
sha2 let x go over each pixel and set it or start/end new spans.
sha1 starting at left edge, find the new left edge and init x to next pixel. stack if run into right screen edge while in span.
sha pop the next span and color it.
fsln a-lr starting at screen address a, find the left edge and right edge of the seed line. color it in the process.
afill xyc starting with screen location xy, and color c, fill the color found there with c until the color found changes.

fillstack fstak 369818 fstakn 0
fstini here 2/ 2/ 1024 + fstak ! 0 fstakn ! ;
fpop fstak @ 3 for dup @ swap 1- next fstak ! -3 fstakn +! ;
fpsh 3 for 1 fstak +! fstak @ ! next 3 fstakn +! ;
fst? fstakn @ ?f drop ; fstini macro
pick 86048b 3, ;
2- 1- 1- ;
2+ 1+ 1+ ; forth
5drop drop drop drop drop drop ;
rtre 2047 and negate 2048 + ;
enstak dlrlr - dlrlr 2- 4 pick dup 3 pick + over 3 pick + fpsh over 4 pick negate + 2+ drop -if 4 pick negate dup 3 pick + over 6 pick 2- + fpsh then 2 pick over negate + drop -if 4 pick negate dup 4 pick 2+ + over 3 pick + fpsh then 2+ ;

fillstack: stack of spans to fill.
fstini initialize
fpop pop the next element from the stack
fpsh push element on the stack
fst? set 0 flag if emtpy.
pick copy n from the stack.
2- screen pixels are 2 bytes.
2+
5drop unload forth stack.
rtre a-n return remaining to right screen edge.
enstak dlrlr-dlrlr push a span or element onto the stack. also push a left hand direction reversal and a right hand reversal if needed.

110 term lines macro
2/s ?lit e8c1 2, 1, ; forth
@w @w ffff and ;
ivrom 22 2 * * 156 block 4 * + ;
allot align nop here push for 0 , next pop ; 4000 2 * 4 / allot
cbuf white ; 5 allot 4 / dup
tecd white ; 1 + dup
tecp white ; 1 + dup
bpen white ; 1 + dup
tmode white ; 1 +
escmd white ;
telofs 24 ;
tetofs 20 ;
cwipe at? 12 u+ 22 + black bpen @ ?f drop if white then box ;
bit12 @w 12 for 8000 ? if over pen @ swap !w then 2* 2 u+ next drop ;
22lin rs 22 for over i negate 22 tt 2* + bit12 2048 -12 2 * + + next drop drop ;
ten c cwipe ivrom at? vloc 22lin
space 12 0 +at ;
sfgbg pen @ bpen @ pen ! bpen ! ;

111 term
2/s n shift tos n times right.
@w a-n absolute 16bit fetch. masked.
ivrom c-a index into virtual rom
allot n-a allot n 32b words, leaves byte addr.
cbuf constant addr of double buffer white is phoney. buffer is 16bit/char
tecd term emu cursor display location.
tecp cursor position.
bpen background color, used as a flag.
tmode mode, such as normal, inverse, bold etc
escmd flag for esc mode.
telofs term emu left offset
tetofs term emu top offset
cwipe erase char position to background.
bit12 one scan line of a char.
22lin rs display 22 lines from char rom addr r to screen addr s.
ten c display char c in pen color.
space advance screen loc one char.
sfgbg switch forground and background colors.

112 term
tei sfgbg ten sfgbg ;
teb dup push ivrom at? 1 u+ 1- vloc pop ten 22lin ;
teu push at? pop ten 20 + over 11 + over aline ;
teiu sfgbg teu sfgbg ;
temit cm jump ten tei teb teu teiu ten ten ten
?emit c if dup 7f and swap 8 2/s 7 and temit ; then drop space ;
newc? a-c dup @w swap push dup pop 4000 + over over @w or drop !w ;
1line n telofs over 22 * tetofs + at 80 2 * * cbuf + 80 for i negate 80 + 2* over + newc? ?emit next drop ;
c/l 80 ;
c/win c/l 24 * ;
curs* tecd @ c/l /mod push 12 * telofs + pop 22 * tetofs + 0 + ;
curln 2/ 2/ 6 for dup i negate 6 + + -1 over @ or swap ! next drop ;
cursr curs* vloc 18 for dup curln 2048 + next drop ;
cat? tecp @ c/l /mod swap ;
linum tecp @ c/l / ;
c+- n tecp @ + 0 max c/win -1 + min tecp ! ;
cat lc c/l -1 + min 0 max swap 23 min 0 max c/l * + tecp ! ;
caddr tecp @ 2* cbuf + ;