{block 18}
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

{block 19}

{block 20}

{block 21}

{block 22}

{block 23}

{block 24}
macro
swap
168B 2, C28B0689 , ;
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, , ;

{block 25}
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!

{block 26}
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 ;

{block 27}

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

{block 28}
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 ;

{block 29}
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

{block 30}
colors etc
block
100 * ;
white
FFFFFF color ;
red
FF0000 color ;
green
FF00 color ;
blue
FF color ;
silve
r 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 31}

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
keybo
ard displays keypad and stack

{block 32}
dump x 200000 y 201200
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

{block 33}
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

{block 34}
icons empty macro
@w
8B66 3, ;
!w
a! 28966 3, drop ;
*byte
C486 2, ; forth ic 0 cu 15F
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 ;
curso
r 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

{block 35}
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
curso
r draw red box for cursor
ok
background task to continually draw icon, icon number at top 4210752 4210752 4210752

{block 36}
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 ,

{block 37}
edit icon

{block 38}
PNG empty w 36 h 20 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 ;

{block 39}

{block 40}
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 * * + ;
deflat
e 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 ;

{block 41}

{block 42}
crc macro
2/s
?lit E8C1 2, 1, ;
1@
8A 2, ; forth ad1 BDA2 ad2 BDD8
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! ;

{block 43}

{block 44}
DOS file
blks
256 * ;
w/c
18 blks ;
buffe
r 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 ;

{block 45}

blks
n-n size in blocks to words
w/c
-n words per cylinder
buffe
r -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

{block 46}
north bridge empty macro
4@
dup ED 1, ;
4!
EF 1, drop ; forth dev 3B00
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

{block 47}

{block 48}
ASCII macro
1@
8A 2, ; forth
string
pop ;
cf-ii
string 6F747200 , 696E6165 , 79636D73 , 7766676C , 62707664 , 71757868 , 336A7A6B , 37363534 , 2D313938 , 2F322E30 , 2B213A3B , 3F2C2A40 ,
ch
7FFFFF0 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
7FFFFE0 + ii-cf + 1@ FF and ;

{block 49}

{block 50}
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 + ;
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 ;

{block 51}

{block 52}
LAN empty 3F8 54 load init
no
block 4 * 1024 ;
send
no for dup 1@ xmit 1 + next drop ;
receiv
e no for rcv over 1! 1 + next drop ;
no
18 7 18 * ;
back
up no for dup send 1 + next drop ;
accept
no for dup receive 1 + next drop ;

{block 53}
4210752 4210752 4210752

{block 54}
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 ;
1152
00 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 ;

{block 55}

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

1152
00 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

{block 56}
hexagon empty col 0 del 202020
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

{block 57}
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

{block 58}
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 ,

{block 59}

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

{block 60}

{block 61}

{block 62}
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 + ;

{block 63}