noc gw t nnnon
o t9s 352327426 y8 0bs fs srt t r +ee?p r e rf00 ?@ qud ?@ qhs fc73e005 t w@ fdca780d r ulrr fdda7815 r ulrr 22244441 8859147 21195865 drmnn; -60416949 m5wr4bpayn -12176309stws wt rtadnn:s s -661782528 oern r ; 4 -1342175232m5mrvwyetof l 04oted 52896551 *og ttn -ta4 ykemn o7efr0or @!od a? t o 4ktm 8 kiw9ts 90601mlotp 344fe3 -36489660 b1c3ade1 ?!il s 12189695 9 t*is ft + ; 1012 0i :w -1913031712 25358d nm -233 z twy8 -5808369 wtliwa 30 -1632497 a/t;cs
ftrrnrs ?kil wyli?d zi??8 -66984177
k a:f 263256437 fyl r4 ki??8 66c3f974 tn ad tlt oft in -809 abfn; 1 w- ew -i ee r kn s -146417 - t -435441659 ynosd -1193 ti a?isk ???k frs?t8 fffc7f40 -as?@ -273 wxn;wt rt8 rt
vg.t@gege c8 frt wtlwuntk 2d fr??@ 39 mo@ins -6958288
8:wn 2861189 ??woi 8ienr@ ai??, dseik yyl ri a???8 nststs rt
?9iln mngw?d ff360823 -346095617
,ofmws t4esns rk 33512tdt9d tbs c8 15104g wrd nw 490e8triy1+ees tl 8680 y?z rm06ns zias mo@ins -50001232 79725344 mnfosis tlreneggis
0mx3 tmt 4ee6a5sn rr8 8669223
tf2knr3e
lsrno; 109706358 qien rs ki??8 rwn tlsaidga0 e r ex+f; vs y8 ig rf 4es 60 igson 4es is 127143307 4es ic
c rft; mt icsmsontd mt igsm rftd mt igysrird vs ig rfmgad igcoed 250281984 igsonmgad ymtoed -218300416 vg?js ter 7s oie kig.0 ???* -5423243 reuenc abs is ai mo@ins -35117992 ???? -386867069 ???+ 14cc8d24o4es tlt -1995903039 tlo n ws abs ia ee iae ad

all abs 3a ae iadt8 aact*dk rx r?iia am8 vs -89 g rft, ?s -1928557312 if 5ie bs mi??@ igsgsri, ml yctoe 344653824 ???cd ;irer@ ramnto ic f cencorl f mt a2d a0258900 bs 324864ysri6 ?s ie??, -52350984 vs icsanramt il -169962 361480960 ic l tljs ia gl. 361301877 ic
csant; bs 71485065 -56611816 a
,ofmw mw d0 344fe3 uenses vs -1513 esom, *s ?s 75073792 -1913 esom, ol 501765 eiyrt ra?80 is fcoert .sssai,e mn wl.lissai,t mn ??t! @n ?, -1012072448 issri e!seok mi??@ a4158900 mn a0158900 b -1811578111 a
ssai?s mn ??t! 8er?,,7weis s.?@ mlci,s rtf -4609 mlrtt, red -32996081 rami?; ic il tf tb 3019807 etmol s csantid -1392508921
ssai?s mn ??t! 8er?,,f/eis emi?; rtfcb7igs 356352,ofml emn 0 ???cd a@n @
ssrir; i 109706358 wlrtei
ewosramn ic nmn a mltsls ac4823 ic
rwos9ias tfwof*n
ramigos ic
oc wge 80087500 oiakrs bnrst; 496645tamosd il icsanvres -42993020
l efti ml 344fe3 iccsramisd ic oy+ats 80337500 t-gw n mo@ins 4007176lren mn -59339269 mtrnks fdb2e900 asi?; ic fe918e1f
idorq -54721289 ;i??8 ia??, -1916665510 o asel 8e0c1e2 gwr9tl wlatei
?s?re ieeclezias i 950 nt ee 1353 aa 613 ir ir ir 40 ir ir ir ai 147 riani riani nn rinw rinfd 147;dup/dupdropthenbegin?f0if+if1-?f2/timeshlshrr@sticliswap0

if-ifaa!1@1!p@p!2*a,@!nip+xorbinaryandoru+?overpushpopinvertfor*nextnext0next-nexti*endend+!nopalignor!**//mod/modlblk e1khz rpswapbqch o fcbn 1664ends 1664jcur 2jblk 2pos 2tlpos 2tcblind 3state 3state* 3@bjcnt 4jlast 4 -450650112 4caps? 5tlast 5esky 7osx 256y tmute -998054016 eepos 2tlpos 2tcblind 3state 3state* 3@bjcnt 4jlast 4 -450650112 4caps? 5tlast 5esstrt klstup k 256y t

     tpausemacroforthc/flopreadwritenccommanseekreadyactshowloadhere?lit3,2,1,,lessjumpacceptpaderasecopymarkemptemitdigit2emit.h.h.ncrspacedowneditelmrmgraphtextkeybodebuat+atxyfovfifoboxlinecoloroctantsplastunpacempemptclistinultimeblockr@@!+invert*/*/2*2/dupswapnegate-minabsmaxv+writesreadshsavenload+loadblkllsectssuulblk

e1ldvvhelpkhz

     rprtc@rtc!hilocalmssecssplitvframewhiteredgreenbluesilveblackscreen5*cflogonoshoemptylshifrshiftrand3string1@1!dumpiconsprintnorthrtclancolorswoodmandsoundgrethlife

edslimeintcfexhlpcf-iichii-cfchctstqch o frinfocbn 1664ends 1664dataptrsheadstailscb@cb!cbnumcbuftl-tl+hd@hd-hd!hd+jcur 2jblk 2szeqinitqnewqnumqpopqpuspos 2tlpos 2t2tocxtoc?rtocsntocsltocsltcsmxmlmumrmdcblind 3cbstate 3state* 3yellow+txt-txt+imm-imm+mvartxtstx.new.oldstate!jcnt 4jlast 4 -450650112 4bksp?.cux?crncremtemitemitwemitcsdigedigodig.hex.decnnumtxtblucapcaps? 5tcapsexgwcwywcolycolrcolgcolmcolccolbrotlast 5esshortyslongyngsgnvarxrcrrwnuld.wordtnokrippltoctoenddeldelsinsundoundosky 7oskeylstbtogcbtoglastbblkld-blk+blkaccephx 256y t.cellonelinesdumpritlinescmpu+xydatibytefixverqc2toneh1h2h3hhhandepianocetkbombqpuspos 2tlpos 2t2tocxtoc?rtocsntocsltocsltcsmxmlmumrmdcblind 3cbstate 3state* 3yellow+txt-txt+imm-imm+mvartxtstx.new.oldstate!jcnt 4jlast 4 -450650112 4bksp?.cux?crncremtemitemitwemitcsdigedigodig.hex.decnnumtxtblucapcaps? 5tcapsexgwcwywcolycolrcolgcolmcolccolbrotlast 5es

shortyslongyngsgnvarxrcrrwnuld.wordtnokrippltoctoenddeldelsinsundoundosbtogcbtoglastbblkld-blk+blkaccephstrt klstup kszecrs.lineup1upnlinesokgomdmu??hy

     t.cellonelinesdumpritlinescmpu+xydatibytefixnuld.wordtnokmxmlmdmumrtocripplszetoendbpusbpopdeldelsinsundoundosbtogcbtoglastbblkld-blk+blkaccephx

256y t.cellonelinesdumpritlinescmpu+xydatibytefix 33 e0 1196 nc nl 1526324 47698 riell 1526379 riel8 rieg riegt ba55 riegs 174b01 47705 47706 riefl riefd 1526678 1526740 riewd 47712 rieds riev rievs 174cdd rieq 1527067 1527115 rie2s rie3 ba6c rie5s 1527257 rie7 rie7s 1527302 rie8 1527318 rie9s riej riejs rie- riek rie/ rie/s ba78 rie:s rie!s rie+s rie@s 1527718 ao ao ao 1752d7 ao 47304 ao ao ao ao ao ao ao ao ao ao ao riai ao ao ao

ao ao ao 1338 ao ao rn tr ao
rayis ao ao ao ao ao 53a rn-k 1338 ao ao ao ao ao ao ao ao ao ao 46915 ao ao ao ao rn/m 1338 ao ao ao ao ao ao ao ao ao ao ao ao ao ao ao ao tn tf 1072 ee or 562 te rjs t0 t; it
nf nf nn 51 nn 1797 ir 9239 t6 r5s r6s ot oe r!s tns r@s 26ad tnc trn r@ t ; twe 2188 trs rz 2221 ef 10c 7771 243
rz t r
r?s r.s 10d r-s r-s 10051 rieft ba58 rieft rieft rieft riefe rie*s rie, rie, rie,s rie,s
rie? 47743 rie?s ba7f ria ria ria
ria r ria r 1527853 ria o 47746 ria a
ria n ba83 ria s ria c ria f 47751 riar riarr riart riari riars e; e; 1528243
riard e; e; ba8e riar8 riar; 1528345 ba91 riats riatf 47767 riat; riao ba98 riaot ba99 1528660
riaon riaoc riaol baa1 riae8 riae8 riae; riaa 47785 riaae riaae baaa riaaa riaan 1529211 riaas riaac 47789 riaaf 47790 1755e4
riaa; 1529361 riant riant riano riane riana 1529456 rianl riand 1529655 e; rianl 1529769 riai; e; riais e; 1529878 riasn 175876 riam riamn riace riacd 47820 riays rialt rialn rial8 riagt e; e; e; e; riags riagl riaf 1530656 riafe riafl 1275 riaf e; riafl riawe riaws
riawd 175c4e bae2 175ceb riaqs ria0s ria0s e; 1531192 e; riaps e;

riah ria2 ria2s 175d8b ria5 ria5s
ria8 baf0 ria9 riaks ria/s e; baf4 e; riaz e; 1531764 ria@ 1531901 rin t rin o rin n rin n rin n 47876 47877 rin f 1760f0 rinr 1532238 bb0c rinrl 1532352 e; bb06
rinr8 1532449 176249 rinta 47891
rinti rinti rints rintc rintc e; rinr0 rintl 1532622 rint0 1532689 rinot rinot 176376 rinos rino0
rino0
rinea rinef
rina 47913 176593 rinad 176642 rinnl 4fb rinni rinn0 rinit 1533759 rinii 1533841 bb3d rini0 rins rinse rinse e; 1275 rinyn rinml rince rinyt rinye rinyn bb50 bb51 176ae7 ring8 1534740 rinft bb59
rinfd ritj 1519195 rit- 47476
ritzs rit;s 172ff5 rio rio e 1519777
rn.m e; 46943 e; rnzts b75a rn.w rn.h rn.0 1502213 rnz rnzo 1502370 rnzas rnzn 4fb e; rnzi e; 4fb
ralad rnzs rnzm rnzc 1502555 rnzw rnz4 rnz8 46959 rn/t rn/as e; e; e; ad21 e; ralms rn/c
rn/l rn/4 b77e 16f017 rn;r 46977 rn;rs rn;ts rn;os rn;e rn;a rn;as rn;ns 1503567
rn;f rn;w e; ad3a rn;h rn;4 b78e rn;; 1503744 rn: s rn: s rn:r 16f240 rn:t b792 e; ralwd
rn:o 1503892 rn:as 46998 rn:ns 46999 rn:s rn:c rn:l 47004 rn:d rn! rn!os rn!as rn!ns rn!c rn!l b7ab rn!8 rn!@ 1504876 rn+e 47030 rn+ns 1505067 rn+l 1505133
rn+w e; ragcs e; ragls rn@r rn@r 1505460 rn@s rn@y
rn@h rn*ts rn*e rn*n rn*i rn*m e; roows ad7a rag! raf t raf e ad81 ad84 rafrn raftt raftd
raft8 rafo ad8c rafot ad8d

roo0s
roo0s
roo4s roo7s roo9 133e88 rooks 39413 133ec4 1261361 roo:s 1261418 133f7e roo, 1261682 roe i 1261728 roe 0 134117 roere roern 1261960 e; e; 13428c 9a17 roeo 134377 roeoc 9a1f 39458 134466 13447a roeecne-i!d dpi*d gltos8 d99tl drm gd
ggi.i8
qp ; - yse bpi?8 an gqd tlo nf-n s r wtlwu tlorenlv3e r98ri tfl
inml lt 0y8 685 g6snr8 -60293120 344fe3 451f42inml lt 0y8 694 17575,ofml ;eesns mrrd inml 3 o;
o ef mo@ins 26048mw d 344fe3 3c7dinmw d w 0y8 1939
,ofmw 06 rl vs mo@ins 996800crsd rk0 ?; ot 1711851713 dstkn -12189642
wso e
,ofmw ?6 rl k i?d???,
rkslgw .l
oamngf 244 ms+rnl wt t n
aj,c@ ?;+id ovzt, mt t hvayis hyr ti ??@o 4es f4 s rcas?8eor tict cs+ro8 ml e o0rwcn 7816
s23on r wod0fnnn oio8 bdp; -2035456317 r wod8nm
mturai aimtur 2048 1358923 -65536000 iaec y ?!o @ an doagta frrldk rs ???/ rksrasrmitar -825 8nodid ac ag8iae soagics 369098752aianvs 3000b08donk mi??@ 18b900ktm fc0c781ecfe 3c05815e rgl f
?nykn ab?, rj
rjt t8 o!atks k ???6 8keol dpioh

rkslgnu:s r98ridgffs
?na!o ro7?d
is -1047986176 rkdoesori8 e rok nis e ndccss tc t -36645904 e 9nmrnt rksl kagr
rgnu; iaecfie v3nf@ mo@ins -576em1 mw??; 344fe3 fff807fd?rqls inmw?8 w 0y8 12632256 ??mai ,ofmwd ?6 rlks e e ???v mo@ins 1472 qes ; mw??; 344fe3 7f805,?ild ?@rr a s gitgsml t wen riiml
lewgtis t d inmw k wt 0y8 11 t weifdrm
v3ngis mo@ins -36793976 r 0ee@id i?t8l
ramt r9s 12107909ia mw 0 344fe3 oxr8 d k s ???f mo@ins 2098624inml w 0y8 768 ??fni e 4a@ ds r ddprd
odnpe mt t rjemnuvs r9; 15y rj 6c58cb rj nnr 88 r98onddd odnpee vs r
rj alis.l rj lnuv0 r9s 1050896045 gl e
a rnnd r9s 83977901 r9s inmw k w 0y8 67 slrral 45689da rnof tn eoe ti
uod; 71,3il /d?? ewttmgee 344fe3 eimas d a?etos ay??@ v!6g ykeefglantd -1928236230 344fe3 /dd; ex!j!d
,3*rs o4a?, to; mo@ins 18875656iqe b??? 1983493 o!e abs o0 s
bs 1023576832
?wik itki?d ki??8 ???z -2033 odtdid rmn f to!rs uodd of?f k ab?, rj
32517691 o r?g/e bfn?@ -1929229568 t fb witt?es 7??8 re d s 303107849 a i 8
rirn e rct tls rd 4e r;disstcajrt 20013393 421735207 rd 4e r;diss trtrc rd 4e r;diss trt 918544od mnrt; 2048a00
rtrrr d
e r 335544320 a090800 rloto d s r ;iml srs 344fe3 a7en rs ji??l ie rg d 3cef74f0 ma3ioo tory+ee8d ter ter ter tn a tar tel
tes 305 2414 ter tal 2d2100 tar tel
tes tno 2414 12c ta; taa
8tc tac tai
ta; tac 22b7 tof tar

??d 924 ir bmn.0 2334720f-4ns 2355261?crk eoq?d trwrtramn to; m eeyd
ftlo t odn!dfo.ior ie ma
rsnm e upo l 1221869 s-ttitkns ;iajid
nortn0 19011689masd teeo edd
knrcn0 ???, kienr0 ???? 1124451840 rd r 190119450ees mo@ins 25118232 lo??@ 9232 gfrmls ??3ad , -lis ab?, ter te e ad rinml bsnmo8 6eo ab rd r -3721 mnrt:; 8224ff00 raiede mo@ins -2228416 e ki?d ???? 1021881600 .??? @ t9;
l ebs 2344960; t9d
-s t 603456967 r abs to; 286 to; t8tt?ssosd 21005rgs
t; r to, g;t7as lr1gfs /??8 d 0 is f e o t -1784545271 267103561 to, g; ab e8c03100 ???fe -5353 mnrt:; 8224ff00 2wede taiosr a+ f702741f 78b45e to@ glv s b3eal 2350080gf:3 te dg;rm1 gw??; to! t8tolo4ns ttf abm 8 to; 11b ttqy4k3e ???wd to! t8tofso4ns ttf abm 8 to; tos 584007053o4es to; ??g-s ! td,
re t -3353 stw?8 ks t ???fs d8d0c8 r;;iee 319103264 8t s mo@ins -66825592 tnn -471576 d83o8inmlro sn 0y8 -1983705120 213121213e.knti -655884288 ki??8 -1376553655
iwospie ia??, iaeyale e8ffffff -386697911 ???re .lrv0 @rz @
l e 1179d285 inmwnws w 0y8 35 -15729 mio80ees oe+kms ty8siadets/oxtee 0eemo8 oe+kms ty8s?lg0 icci?8 knsmod???k -15753 mw .wd 344fe3 -10566925438ersed 8nmvs 1360863 872931459 20319768 ndn s
tv?seinmw p ?snmo8 473774342 ia t 87752704 tlt 108595828 tles+v3e tle ift4 s r9s 1441792 mo@ins 33555904 k i wr??@ o 32533595 nn r rjt nyr is -17329 ovndid rvs rn ?*7od 4afn; r9s 33581531 ie r -1578565633 ff4fffff c

-15049 cwl@ark ff4fffff s mo@ins -522816 cyl is ff5fffff ovndad r+s rn ??t! ?@o?8 noia?@ tsifta k r ??,k -1745 k3anws ???os -19801 ,ofmwd emn 0 ???cd ;i er@ -2377 krs e; -73 otkrbs fc6fffff 344fe3 ,akrt si??@fylis8 ie??, krs et 250147051 fc6fffff 344fe3 ,akrt si??@cr0;i ie??, +a ie :ia?, -18825 v3nf@ ,akat d??? rt.sa; -17193 ?9ilis remi?; finmgrd w 0y8 63488 tlts+tn:onie 60005mna,f ??t!t *n ?, 48404mgrd 344fe3 fffff805reo4 s : r 60817409 -2065170240 689fc76 ta?kt tlt -78425 +kilis s6m?; fc6fffff 344fe3 tlaretlerendrm tlo if-8e 19000392 +s t wl ; aie -4209 wlatt, re abl : r -5242879 705955271tnds9ers clao, tyn +ee8is 10260 tc ti8 ts tml tms ts tm8 tmt tsl 143 tml ir ir ir n 31 tir rs2 !rt yrt0 a!;eowoacs 12 rt rt rti c8r ir t3 td 11331 tg8 2af9 twe tfl 347 tf8 tfl tw tfe tf 1819 11009 tg8 ir ir ir ir ir ir ir ir 2d0d010b rr rn 722077987 toli ??d ?s d ?@ ??, ??, ??, sr r8 -352210943 ff581d80 eb09b00e .sgn -10986112 10992 wr lrt bs t 2939648te lnggn ?,ogi ; t9ws d r fff807fd s wrd ea t .s t ,ofmwe -1070528887 ter a;syls ?s tlos?snic 763609856 tlt -955614968 0 asisd tlt 92521224 150 406684611 re t 16c1853 150 406160323 r t
vsrons lnnr3l 150 ,ofmfs rmet 0 bs t 2945536f wrs
ta t tolsritwasnrk b??? 2789376; t9d
l e bs t -65536+grk

re??, -236212992 fe3d6d6a 236544 dt9d rf e b 96927744 tol ter te ad?s 2ies ; mi??@ fa8100ia c8 .er8d 2249816 ter 4inml mn 0y8 82477826 si-iae 10796 tla rf 0rs ter
tla rld8de???8 4asf8 ter ,ogeye
oamngf 337 mtywms r o0r@ ds t 1ast8 tle ff36083b -272539908 10780 ter 4mtyd wleyal ffffff94 tg8 4 vs f+caks a+i?d tg8 gl yl
sosle8 -2130152196 ; dciia; 36963808tg8o4ie e 2357309 tie l abm o ter inmfc; w 0y8 1tg8o4ie e 2357309 tie l ns9 o ter ad tieks ki??8
t tles+ 4as 337 -8ije 10784 :st-n -1912602627 344fe3 tlerete atf ie t casntes 101ac5a ml s ??t2n o4a?, tle -1409503747 ca:iae tvztns a8 r mtffr0 8cc28100mt 10ea8300 to! gsnm0 2aec15mw s s o asel e7ebd2

?iw@i i,i?d 7800f ; is ; is ; is ; is
d r8
d r8 ,r?;n d r? d
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t r?b@8 ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 ?o?8t ?s?osr?s ?s ,i?*8 ; is fff3f807 @ ?@8 ?o?8t r; i:d ; is ?w?@d 7f807f?w;?d +m?*d
?iw@i r?-*8 7f807f ?s ?s ?s ?s ?s ?s ?s ?s
d r8
d r8d rs
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t t@i:d ; is ?r?;8 ; is?o@i0 @ ?@8 i/;:l -1
s,rq@ i8 o; i8 o; i8 o; i8 o; ?o?8t ?b@8 ; @ ; is r; is fff3f87f @ ?@8 ?s i8 1f3e0ff @ *;n 8 o@ s r@ o8 s @ os 14680304 s rs s 8 s ; s ; s ; s ; s ; s ; s ; d o8
8 ; +w?om r?b,8 ?s ?s ?s ?s fffbf8ff ?m?*d ; is?o@i4 @ ?@8 @ r@ s ;s ;r?srs s ? o s ; s ; s ; s ; s ; s ; i8 r8 i8 o; mqrm? 7o6oys ,r?i d isoqst o vs 0 ; is ; is ; is ?w?im r?b,8 ?s ?s ?s ?s ?s ?s fffbf8ff /m?*d i8 o; -s ?s e1c0f3 osos;n 1879996446 8 o@
s os
?iw@i r?+*8 ?do, 267390960 fff7f8ff @iw?is ; is ; is ; is ; is ; is ; is ?i?98 r?b*8 ?s ?s ?s ?s ?s ?s fff7f8ff @io?w ; is ; is ; is
?iw@is r?-*8 7f807f ?s ?s ?s ?s ?s ?s ?s ?sr?do,

iv;@8 -267388897 8 o; @ ?d o-9;n 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 /w,om o?b,8 ?sr?s ?s ?s fffbf8ff /m?*d ; is ; is 8 is ?o?8t r?b@8 ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s fff3f8ff @ ?@8 8 r;
8 o; 8 t; 8 ; 8 ; 8 ; 8 ; 8 ; 8 ; 8 ; ?o?8t r?s?os ; is ; is? @id @o?@8 78007 ; is??dr8 ???? ?o?8t r?s?os ; is ; is? om; ? o? ; @ ; is?o@i, @ ?@8;is;os;is;is;is;is;is;is??,r8 ????; is; is; is; is ???? ;i?d ; is ; is@i@ od ?i?*8 ; @ ; is?o@i, @ ?@8 ?o?8t ?b@8 ; is ; is ffc7f807 ?i?*8 7f80ff ?s ?s fff3f8ff @ ?@8 ???? i ?@r; isid r;; ,
d o; r@ id rs 78007 d i ?o?8t r?b@8 ?s ?s ?s ?s fff3f8ff ?o?;n 7f80ff ?s ?s fff3f8ff @ ?@8 ?o?8t r?b@8 ?s ?s ?s ?s fffbf8ff /m?*d ; is ; is?o@i, @ ?@8is ;is ;isis ;is ;is ;is ;is ;is ; ; ?8t -1073221617?w; ?i?,8 ?is ; is ; is ; is,isoqs
8i?:8 ?dod di@ od ,iy;iso?s?@ o; i@ 30720 s o; r n ???? r; i?d? r@
8 i, ?e rs fffff807 ????r; iso8 @id o8; , 8 r@ d o8 r@ o8 s id os 16253176 i d , d ? e is i d , d ? e s ;
is rd i d , d ? e is i d , d ? e is d rd
8 o8 8 o; 8 o;
d r8 s o s

d r8
d r8
d r8
d r8
?o? ?o?@8 d r?ys
d r8
d r8 ?o?8t ?s?os i8 o; -;;,
-;@,
?ir?@
@i ?w 8 i?o@o, @ ?@8o s ; :8t -1073225713
; o; osoqs r 0 i d , d ? e d o8
is rd ?o?8t ?s?os i ii8 is @ ?s
d r;
d
d r8
d r8 ,i?v8 ?o?*8 ?m?@d ?si?s
?sr?s?s ?s?s ?s ?so?s ?s?@ ?y?@e ?i?@8 ;i?:8 ?i?98 ???7 ?sr?s ?s ?s??b? ?i?*8 di?98 ;iy8is ,is@iso?si/s ?sr?s ???? ????
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t ???q 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s ?s ?sr?do, ?o??8 @ ?@8 ???? ???? ; is ; is8i@ od 8i?sis ;i is ; is ; is ???? ???? s o
d r8 8 o; ; i; i -s @ *8t ,r?8t rvb;n 7380f3 ?s ?s i8 o; 7fe07f ?;o, 268374014 ?w ?s m?om?
q@:? /@io,/@ow@i?s?@o?si?sr?so?s
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8
d r8 ?o?8t ???q 7801f ; is ffc7f807 ?o?@8 r; i@e ; isr, is ?o??8 @ ?@8 i8 o;r?do, 1ffe0ff ii/o?d -:@,
s,rb; i8 o; i8 o; i8 o; i8 o; i8 o; ?o?8t ???q 7f80ff ; is ; is ; is ; is ; isr?do, ?o??8 @ ?@8 ?s i8r-do, 1e1e0f3 isobvs -267390961 d r;
d r8
d r8
d r8
d r8
d r8 ; is ; is ; is ; is ; is ; is ; is ; is ; is ???? ???? ?o?8t ???q 7f80ff ; is ; iso?s ;o?so?s ?s ?sr?do, ?o??8 @ ?@8 ???? ???? ; is ; is8i@ od 8i?sis ;i is ; is ; is ; is ; is i8 r8 i8 o; -s i8 -s -s -s -s mqrmq 6r6i d ,r?;n iso7st osos8t 404232216

@i?sis ?i?:8r?so/s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?so/sr?s ,i?*8 8i?98 i8 o; ?s ?sr?do, f3c0ff o-8@8 1010580540 isoqst ; i@ 8 o;
d r8 s o ?i?98 ???7 ?sr?s ?s ?s??b? ?i?*8 ;ibd ; is ; is ; is ; is @i?sis ?i?:8r?so/s ?s ?s?i@i, ,i?:8 r?s?is ?s ?so/sr?s ,i?*8 8i?98 ?s ?s ?s ?s ?s ?s ?s ?s??v? ???? ?s?@ ?s ?s ?s ?s ?s ?s ?s ?s ?s i8 f3c0ff iv;@8 -132155362 8 o@ 8 o; ; i; iso7st o-9;n ffc0f3 i8 i@ ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?s ?sr?do, ?o??8 @ ?@8 ?o?8t ???q 7f80ff ?s ?s ?s ?s ?s ?s ?s ?s/@oo,o?v?8 ?o??8 *m?*d ?o?8t ?o?@8 i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; i8 o; ?o?@8 @ ?@8 s o s o s o s o s o s o s o s o s o s o s o s o ?o?8t ?o?@8 i8 o; i i i i ?o?@t @o?@8 8 i 8 i 8 i ???? ???? ?o?8t ?o?@8 i8 o; i i i i ? o?s ? o?s i i i i i8 o; ?o?@8 @ ?@88i i i8i i i8i i i8i i i8i i i ???? ????8 i8 i8 i8 i8 i ???? ???? 8 i 8 i 8 i ?i?98 ?i?*8 i i i i i8 o; ?o?@8 @ ?@8 ?o?8t ?o?@8 i8 o; 8 i 8 i ?i?98 ?i?*8 i8 o; i8 o; i8 o; ?o?@8 @ ?@8 ???? ????r8 isod ;is ;8 @ d r; s ; r8 od s 3c003 8 is ?o?8t ?o?@8 i8 o; i8 o; i8 o; ?o?@8 ?o?@8 i8 o; i8 o; i8 o; ?o?@8 @ ?@8 ?o?8t ?o?@8 i8 o; i8 o; i8 o; ?w?*d ?m?*d i i i i i8 o; ?o?@8 @ ?@8 ; is ; is ; is ; is ; is ; is ; is ; isr?s ; ?o??8 @ ?@8 ???? ????r?s ?si/so?s ;iy@is sr?8is ? is , is 16711934 8iwsr8
@im;iso?si/s ?sr?s

8 ? 8 ?s s 8 ?s s d i; e ???? ; i?dod ;; od d r; @ od s 78003??drd ???? o r ; osr8 isos is; od d r;
s @ r8 od s 15728760 8 i s rs 8 o; 12288 12288 12288 12288 12288 12288 12288 12288 8 o; 8 o;n nn nn nn nn nn nn nn n 8 o; d rd ; i; ; i@ ; i@ ; i@ ; i@ 8 o@
s osd rs 8 o; 8 o;
d
d r8
d r8
d r8
d r8
d r8 ???? ????
d r8
d r8
d r8
d r8
d r8 ?o?;n od r8
99;is 1978398 1978398 v8@is od r8 ,r?@8seerm rr se l at ?w, l as m rrtseer se s8 s
; r@ r 0n o d?o@ nn ?os n nn n n n n
? r?s
o
o
o
o o
?y?@ ,o?,8 ;i?98 di?sis ?dod , is ? is -2130771713 8i? od @i?v8 ?w?9d ?s?@d nr8 ??9/ isd?iss t
n nd rso n 204475440,r@o d ,rs 50344704 50344704 50344704 50344704 o vs 806105100 o vs -62915521 o vs -62915521 o vs 806105100 o vs 0 tala?; 631383458 631439359 631439359 0 od?, ytt fs trslen
?e lrs ddl w correosfseehi?, ;os o@ od @ r, @ i, ?y?de ???/ ?w??d @ ?,n @ o,
@ ,is r;rs i dte re eer p seer eereer eereer eer te p s d l , dtvsrnn ieru8e fe209f20 p yp s 3a0e320 tvs6 s , fn rsi osd ;
is rd e001 i
d d

i 8 os 8 s -2147287033 8 nos 8os os8 os s is 8 r 0?o@ ?os?o@ ?osi s is n 12288 12288 12288 12288 12288 s n i d 8
d dn 8n nn nn nn nn nd ;
k s o @ ?d s oo t s oo t ; , e y o; y oo y oo ; i, e s o o8 oer re p sne o o8vd o os 65036288 fc118410sast yid eren 8 ?sn o n on rsdo , if 1611463695 3018300n n n nn o n n fff87b00 yds t s o s o s d e ; i 3e007 r; rs d od
; ;id idr; r; i ; r os t
n nd o vs 404232216 c0??d ???? rs n n -2147418109; s os s o s o s i 12288
s o s o s o d d ; ;
s o s o s o d d8 i s os s o s o s i s n
s i
s i
s i
s i
s i
s i
s i
s i
s it t t tt t t tt t t tt t t tt t t tt t t tt t t tt t t t 53197690 6f666b61 20343030 t inn! 20202020t t t tt t t tncheat t itn+s not n- itn+no 61051770 16843011 i ioncs t icvn 808525882 31203836 34b1101 ncht i
nrnbsi t t t it t t tt t t tt t t tt t t tt t t tt t t tt t t t 58948450net ic8 t nf-n inncjn 1931503732 ntn+ci 1919243296 6165766f t t nb 538976288t t t tt t t tt t t t
n3efps 1684960623
e1 rnos nanen- n+cntn 1998597236 tbtoifien-ec 745763952nritnitnonc0i
aat tbs t tpse nannncs

colorforth jul31 chuck moore public domain 20 load 22 load 24 load 26 load 28 load 30 load
dump 32 load ;
icons 34 ld ;
print 38 ld ;
north 46 ld ;
rtc 50 ld ;
lan 52 ld ;
colors 56 ld ;
wood 60 ld ;
mand 64 ld ;
sound 68 ld ;
gr 72 ld ;
eth 130 ld ;
life 226 ld ;
ed 206 ld ;
slime 200 ld ;
int 242 ld ;
cfex 232 load ; new!
hlp logo pause cal e ; mark empt hlp
press the key marked p to see the shadow block ;

hpo 2004 nov 24 colorforth explorer
... this block gets loaded at power up.
dump instant compile version of dump
icons edit the character font icons
print save screen image as a png file to block 270 on the floppy
north north bridge pci chip display
rtc real time clock display
colors 3-axis rgb colour display
wood imitation pine blockboard
mand display the mandeldrot set
sound control the pc speaker
gr graphics - type ok to run the demo
life conways game of life
ed the editor partly converted to colorforth
slime watch out for the slugs!
int 1000 hz timer interrupt
cfex colorforth explorer
help press the space bar to leave the editor, then type the keys indicated in the keypad in the bottom right of the screen, then the space bar to execute the word. type e or 18 edit to run the editor.

macro
?f c021 2, ;
0if 75 2, here ;
+if 78 2, here ;
1- n-n 48 1, ;
?f c021 2, ;
2/ n-n f8d1 2, ;
time -u /dup 310f 2, ;
shl uc-u ?lit e0c1 2, 1, ;
shr uc-u ?lit e8c1 2, 1, ;
r@ /dup 8b 1, c7 1, ;
sti fb 1, ; enable interrupts
cli fa 1, ; disable interrupts forth
emp cli empt ;
empt emp ;
cli cli ;
sti sti ;
nul ;
time time ;

pentium macros:
?f set flags to reflect tos
0if if zero ... then jnz aids in clarity
+if js, this complements the set
1- subtract 1
?f
2/ divide by 2
/dup new name for ?dup . warning ?dup is not the ans version
time return pentium instruction counter
lshift shift u left c places
rshift shift u right c places
r@ copies the top of the return stack to tos
sti enable device interrupts
cli disable them
a,

more macros 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 ;
1@ 8a 2, ;
1! a! 288 2, drop ;
p@ a-n /dup a! ec 1, ;
p! na- a! ee 1, 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 ;
xor 633
binary ?lit if swap 2 + 1, , ; then 2, nip ;
and 623 binary ;
or 60b 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
1@ fetch byte from byte address
1! store byte to byte address
p@ p-n fetch byte from port
p! np store byte to port
@ 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!

even more macros
over /dup 4468b 3, ;
push 50 1, drop ;
pop /dup 58 1, ;
invert n-n d0f7 2, ;
for push begin ;
*next swap
next 75240cff
0next , here invert + 1, 4c483 3, ;
-next 79240cff 0next ;
i /dup 24048b 3, ;
*end swap
end eb 1, here invert + 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 invert 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 ;

- n-n ones complement negate , xor
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

compiled macros forth
block n-n 100 * ;
r@ -n r@ ;
@ a-n @ ;
! an- ! ;
+ nn-n + ;
invert n-n invert ;
*/ nnn-n */ ;
* nn-n * ;
/ nn-n / ;
2* n-n 2* ;
2/ n-n 2/ ;
dup n-nn dup ;
swap nn-nn swap ; arithmetic
negate n-n invert 1 + ;
- nn-n negate + ;
min nn-n less if drop ; then swap drop ;
abs n-u dup negate
max nn-n less if swap then drop ;
v+ vv-v push u+ pop + ;
writes acn cli for write next drop drop ;
reads acn cli for read next drop drop ;
h -a sp 20 + ;
save empt 0 dup nc @ writes /flop ;

these macros may be yellow, others may not
block n-a block number to word address
r@ copies the top of the return stack to stack
@ 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

relative load blocks
nload r@ 100 / 2 + load ;
+load n- r@ 100 / + load ;
blk -a a86 ;
ll blk @ load ;
sect blk @ 18 / dup 18 * block swap ;
ss sect 1 writes /flop ;
uu sect 1 reads /flop ; lblk 64
ld n- dup lblk ! load ;
vv lblk @ edit ;
help lblk @ 1 + edit ; real time clock khz 1200041
rtc@ t-c 70 p! 71 p@ ;
rtc! ct- 70 p! 71 p! ;
hi 10 rtc@ 80 and drop 0if hi ; then ;
lo 10 rtc@ 80 and drop if lo ; then ;
cal hi lo time invert hi lo time + 500 + 1000 / khz ! ;
ms n- khz @ * time + begin dup time invert + drop -if drop ; then end drop ;
secs n- for pause lo hi next ; macro
swapb w-w e086 2, ; forth
split dup swapb ff and swap ff and ;
vframe 1e80000 ;

nload loads the next source block : b+2
+load loads the source block : b+n
blk where the current blk happens to be kept
ll load the current edit blk
ss save the sector containing the current edit block to the floppy disc
lblk holds the last block loaded by
ld
vv edits the last block loaded by ld
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
cal calibrate the processor clock
ms wait for n milliseconds
secs wait for n seconds
swapb swap the two low bytes
split split the low two bytes
vframe byte address of the video frame buffer

colors etc
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 ;
noshow show keyboard ;
empty empt logo ;
lshift uc-u 1f and ?f 0if drop ; then for 1 shl next ;
rshift uc-u 1f and ?f 0if drop ; then for 1 shr next ;
rand32 -n time dup 16 lshift xor ;
string pop ;
1@ a-c 1@ f and ;
1! ac- 1! ;

colors specified as rgb: 888
screen fills screen with current color
at xy set current screen position
box xy lower-right of colored rectangle
5* displays 5 large characters
cf displays colorforth
logo displays colorforth logo
empty also displays the logo
lshift shift u left c places
rshift shift u right c places
show background task executes following code repeatedly
keyboard displays keypad and stack
string returns the address of the string following
rand32 returns a 3 bit random number

dump ascii 48 load names 208 load x 4544 y 2113264
.cell a-a blue dup @ 4 for dup ff and chc emit 100 / next drop white ;
one dup dup @ dup push h. space dup h. pop space swap .cell drop space space space space dup .word drop white cr ;
lines for one 1 + next drop ;
dump x !
r show black screen x @ 15 text lines cr x @ 16 for .cell 1 + next drop keyboard ;
it @ + @ dup h. space ;
lines for white i x it i y it xor 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 xor
byte 4 / dump ;
fix for 0 over ! 1 + next ;
ver 18 block 40 - dump ; 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 : decodes the value as a name and ascii
u increment address
d decrement
ati address of agp graphic registers
byte a byte address dump
fix an-a test word
ver show the kernel version information

app: icons font editor empt macro
@w 8b66 3, ;
!w a! 28966 3, drop ;
*byte c486 2, ; forth ic 76 cu 17
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 blue 80 450 at 96 474 box 80 450 at white ic @ dup emit space dup green . 24 emit 21 emit 2 h.n keyboard ; nload 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 bottom sr 4210752 4210752 4210752

edit icon
+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 xor 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 cfex nul tl tu td tr l u d r -ic nul nul +ic nul nul nul nul nul nul nul toggle nul nul nul nul 2500 , 110160c dup , , 2b000023 , 0 , 2000000 , 0 ,

edit icon
t toggles the current pixel
ludr left up down right
. top row toggles and moves
-+ select icon to edit

print png to disk w 1024 h 768 d 1
frame 1e80000 ; 6 +load 4 +load 2 +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 ;
go 1 d ! 1024 w ! 768 h ! 0 0 at 1024 768 png raw ; go e

print png to disk
frame the video frame buffer
-crc a
crc
wd -a
bys n-a
plte
png awh
at
full
pad
go copy the screen image as a png file to the floppy disk block 270 and up.

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 invert 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, invert 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 36054 ad2 54347
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 invert 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 /flop ;
raw an- 15 swap 2* 2* w/c -1 + + w/c / writes /flop ;
get a size @ 3 + 2/ 2/ cyls reads /flop ;
.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
raw an write raw data to cyl 15 , block 270
put an write file from address
get a read file to address

app: north bridge empty macro
4@ dup ed 1, ;
4! ef 1, drop ; forth dev 2048
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 xor 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 ;
ko show black screen text devs keyboard ;
u 40 dev +! ;
d -64 dev +! ;
test ff00 + a! 4@ ; ok

display the pci interface chip registers

ascii
cf-ii string 0*00 6f747200 , 696e6165 , 79636d73 , 7766676c , 0*10 62707664 , 71757868 , 33323130 , 37363534 , 0*20 2d6a3938 , 2f7a2e6b , 2b213a3b , 3f2c2a40 , 0*30 4f545200 ,
ch fffffff0 and unpack cf-ii + 1@ ff and ;
ii-cf string 0x20 64632a00 , 7271706f , 2b2d6e6d , 2725232e , 0x30 3210 1b1a1918 , 7654 1f1e1d1c , ..98 28292120 , 2f6c6b6a , 0x40 cba@ 3a43352c , gfed 3d3e3440 , kjih 54523744 , onml 3336393c , 0x50 srqp 38314742 , wvut 3f414632 , .zyx 58563b45 , 75745973 , 0x60 cba. a130576 , gfed d0e0410 , kjih 24220714 , onml 306090c , 0x70 srqp 8011712 , wvut f111602 , .zyx 77260b15 , 62617879 ,
chc ffffffe0 + ii-cf + 1@ ff and ;
tst 2000 block dup 4 * -1 + 60 for 1 + 80 i negate + over 1! next drop dump ; qch 51
r c-c qch ! 20 60 for 1 + dup chc qch @ negate + drop 0if pop drop ; then next 7f and ;
info 18 block -64 r + dump ;

convert colorforth chars to and from ascii
cf-ii conversion table
ch convert colorforth character to ascii
ii-cf conversion table
chc convert ascii to colorforth
tst create a table of ascii characters
r scan the ii-cf table to perform cf-ii . used to cross-reference the two tables
info display the cfdos ascii information in the last 256 bytes of block 17 . type u to see more
. note that dump takes a cell address

app: rtc real time clock empt
bcd -c rtc@ 16 /mod 10 * + ;
hms -n lo 4 bcd 100 * 2 bcd + 100 * 0 bcd + ;
ymd -n lo 9 bcd 100 * 8 bcd + 100 * 7 bcd + ;
day -c lo 6 bcd ;
crlf port dump
one n-n dup rtc@ h. space dup . cr ;
lines sn- for one -1 + next drop ;
ok show black screen text 15 16 lines cr ymd . hms . keyboard ; ok

rtc real time clock
. displays the pc clock registers
bcd bcd-n bcd to binary
hms -n hours+mins+secs
ymd -n year+month+day
day -n day of the week
rtc display the real time clock registers
one display one line
lines display n lines starting at s
ok display task

lan empt 3f8 nload 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

app: serial 3f8 2e8 1050 macro
1@ 8a 2, ;
1! a! 288 2, drop ; forth
r 0 + + ;
9600 12 ;
38400 3 ;
115200 1 ;
b/s 83 3 r p! 38400 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 xor 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 ;

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 gd

app: hexagon empt col 4210752 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 xor 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 h. keyboard ; nload 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 cfex 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

app: wood empt x 125810090 y -1123891786 inc 8286477 frame 33554432 dep 39 hole 65056
home 125810090 x ! -1123891786 y ! 8286477 inc ! vframe frame ! 36 dep ! 65056 hole ! ; macro
2! a! 28966 3, drop ;
f* 2ef7 2, 26 shr e2c1 2, 6 1, c20b 2, nip ;
w! a! 28966 3, drop ; forth
wf+ frame @ 2! 2 frame +! ;
om negate ff + ;
o5 om 3 shr 7e0 xor ;
o4 fc and 3 shl 1f xor ;
o3 om f8 and 8 shl 1f xor ;
o2 3 shr f800 xor ;
o1 om fc and 3 shl f800 xor ;
o0 f8 and 8 shl 7e0 xor ;
order jump o0 o1 o2 o3 o4 o5 o0
hue 8 shl 26 / dup ff and swap 8 shr order ;
vlen dup f* swap dup f* + ;
vdup over over ;
vndup push push vdup pop pop ;
itr over dup f* over dup f* negate + push f* 2* pop swap v+ over 2* + 2/ vndup + + ;
data ; 6 +load ok draw h

display an imitation pine blockboard screen
. this is based on a skewed mandelbrot set with modified colors

timing empt macro
out e1e6 2, ; forth
tare time invert 1000 for next time + ;
tare+ time invert push 1000 for dup next c pop time + ;
test tare time + invert 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 invert + 1, ; forth
try time invert 1000 c! loop time + ;;

app: mandelbrot set empt x -179015281 y 134217728 inc 349981 dep 26 frame 33554432 hole 0
home 10000000 767 / dup 1023 * 2/ negate x ! 8000000 y ! inc ! 26 dep ! ; macro
f* 2ef7 2, 26 shr e2c1 2, 6 1, c20b 2, nip ;
2! a! 28966 3, drop ; forth
wf+ frame @ 2! 2 frame +! ;
hue 31416 * ; dup dup + dup dup + + + dup dup + dup dup + + + ; 3142 * ; @ ;
vlen dup f* swap dup f* + ;
vdup over over ;
vndup push push vdup pop pop ;
itr over dup f* over dup f* negate + push f* 2* pop swap v+ ;
x: c- emit 108 emit ;
data text 0 0 at 21 x: x @ . 11 x: y @ . 7 x: inc @ . 6 x: dep @ . ; 2 +load ok draw print h

display the mandelbrot set with modified colors to update quickly

mandelbrot set
o 0 0 dep @ 1 max for vndup itr vdup vlen f0000000 + drop -if *next drop drop hole @ ; then drop drop pop hue ;
mh x @ swap 1024 for o wf+ inc @ u+ next nip ;
mv y @ 768 for mh inc @ negate + next drop ;
+d 2 dep +!
-d -1 dep +! dep @ 1 max dep !
draw vframe frame ! mv data ;
ok c show keyboard ;
l inc @ 1023 8 */ negate x +! draw ;
u inc @ 767 8 */ y +! draw ;
d inc @ 767 8 */ negate y +! draw ;
r inc @ 1023 8 */ x +! draw ;
+z inc @ 3 max dup 1023 8 */ x +! dup 767 8 */ negate y +! 3 4 */ 3 max inc ! draw ;
-z inc @ 10000000 min dup 1023 8 */ negate x +! dup 767 8 */ y +! 4 3 */ inc ! draw ;
hh home draw ;
h pad nul nul cfex nul -d nul nul +d l u d r -z hh nul +z nul nul nul nul nul nul nul nul nul nul nul nul 2500 , 2b000023 , 110160c , 2b001423 , 0 , 0 , 0 ,

convert colorforth chars to and from ascii

app: sounds make a noise tempo 20 mute 0 period 1807
tn ft- tempo @ * swap 660 50 */
hz tf- push 1000 1193 pop */
osc tp- dup period ! split 42 p! 42 p!
tone t- mute @ 0 + drop if drop ; then 4f 61 p! ms 4d 61 p! 20 ms ;
click 1 90 osc ;
t 3 tn ;
q 8 tn ;
c 16 tn ;
2tone 75 q 50 q ;
h1 50 c 54 q 50 q 45 c 60 c ;
h2 40 c 45 q 50 q 50 c 45 c ;
h3 54 c 60 q 54 q 50 c 45 q 40 q 50 t 45 t 50 t 45 t 45 12 tn 40 q 40 32 tn ;
hh
handel h1 h2 h3 ;
piano 55 7 for dup q 3 2 */ next drop ;
cetk 6 c 10 c 8 c 4 c 6 32 tn ;
bomb mute @ 0 + drop if ; then 4f 61 p! 500 for 1000 i invert + split 42 p! 42 p! 1 ms next 4d 61 p! 1 32 tn ; 2tone

sounds : using the pc internal speaker
tempo in ms per 1/8 quaver
mute equals -1 to disable sound
period test only - value sent to hardware
tn ft- play f hz for t * 11 ms
hz tf- play t ms at f hz
osc tp- play t ms of period p
tone t- play the current tone for t ms
click makes a click
t triplet
q quaver
c crotchet
2tone 2 tones
h1
h2
h3
hh
handel part of handels gavotte
piano
cetk close encounters of the third kind
bomb - well sort of ....

relative load blocks
nload r@ 100 / 2 + load ;
+load n- r@ 100 / + load ;
blk -a a86 ;
ll blk @ load ;
myblk -n blk @ 18 / dup 18 * block swap ;
ss myblk 1 writes /flop ;
uu myblk 1 reads /flop ; lblk 212
ld n- dup lblk ! load ;
vv lblk @ edit ;
help lblk @ 1 + edit ; real time clock khz 1200038
rtc@ t-c 70 p! 71 p@ ;
rtc! ct- 70 p! 71 p! ;
hi 10 rtc@ 80 and drop 0if hi ; then ;
lo 10 rtc@ 80 and drop if lo ; then ;
cal hi lo time invert hi lo time + 500 + 1000 / khz ! ;
ms n- khz @ * time + begin dup time invert + drop -if drop ; then end drop ;
secs n- for pause lo hi next ; macro
swapb w-w e086 2, ; forth
split dup swapb ff and swap ff and ;
vframe 1e80000 ;

graphics demo empt macros 2 +load stack 16 +load
utils 84 load copy ;
circles 86 load ;
rand 90 load random ;
lines 92 load ;
htm 102 load html ; 6 +load

a graphics extension package
. type ok after loading this block

added macros macro
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
fill 24 for cr space 5 for rand32 h. space next next ;
matrix show black screen green fill keyboard ;

added macros
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.
matrix what is the matrix?
ver returns the address of the cfdos version - use as ver dump

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 ;
log1 show black screen text cf keyboard ;
ckb black 0 740 at 1023 767 box 800 650 at 1023 740 box ;
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 areafill 28 +load demos 16 +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 ;
ok black screen grads lnes text cf show dotty fillit ckb keyboard ;

new logo
log1 a simple text demo
ok the graphics demo

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

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 -4 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 invert 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 invert 1+ u+ pop invert 1+ + ;
vn push rot less if rot pop -rot ; then -rot pop ; pen 65535 bs 32283202
vloc 2048 * over + + vframe + ;
point 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 ;

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 275326771 rseed -526774649
rand time rsav ! e09a0e87 rseed ! ;
ror d3adc88b , c3c8 2,
random push rseed @ 0 32 for 2* swap 2* swap -if rsav @ xor 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 -360 ay 0 sx 2048 sy 2 lbase 32227338 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 invert 1+ 0 xline invert 1+ 0 swap xline 0 xline ;
art 70 for 71 i invert 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 -173
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 2222119 ppt 0 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 2 +load tfc 14163 fc 11731
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 355761 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.

app: spy empt 3f8 54 load init
ry 5 r p@ ; nload init
buffer 2000 block ; 2000 1 erase buf 0 0 buf !
b! swap ff and + buf @ buffer + ! 1 buf +! ;
dev r2 if dup xmit 100 b! dev ; then ;
pc ?rcv if dup x2 0 b! pc ; then ;
relay s2 st s2! st! dev pc ;
.1 f and digit ;
.byte dup 10 / .1 .1 ;
traffic text buffer buf @ 1 max 400 min for dup @ green 100 ? if red then .byte 1 + next drop ;
ok show black screen relay traffic keyboard ;
k show black screen relay keyboard ;
q 6000 for relay next ;
test st! st ; 84 load

serial 2
r 2f8 + ;
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! ;
x2 5 r p@ 20 and drop if 0 r p! ; then x2 ;
c2 6 r p@ 30 and 30 or drop if c2 ; then x2 ;
s2 6 r p@ xbits ;
s2! 4 r p! ;
r2 5 r p@ 1 and drop if 0 r p@ ; then ;

dynapulse 200m
send pop swap for dup 1@ x2 1 + next drop ;
reset 2 send 2323 ,
1st 12 send 37269a12 , 39027afd , 23c75680 ,

mrtl ramd 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608
mrts ramd
mrts ramd
mrts ramd
mrts ramd
mrts ramd
mrts ramd
mrts ramd
mrts ramd mrts 1412608 mrts 1412608 1412608 mrts 1412608 mrts 1412608 mrts 1412608 mrts 1412608 mrts 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 1412608 m i r md m i r md m i r md m i r md m i r md m i r md

this block is used by the next block as the interrupt vector table.

interrupts
idt 122 block ; macro
1ld n ?lit b9 1, , ;
p! na a! ee 1, drop ;
lidt b 18010f 3, drop ;
2push 5250 2, ;
2pop 585a 2, ;
forth: 2push be5651 3, idt 100 + a, ;
;forth 595e 2, 2pop ;
clear 20e620b0 , ;
8clear a0e620b0 , 20e6 2, ;
i; cf 1, ; forth
!idt a lidt ; here 3b7 2, idt 2* 2* , !idt
interrupt n 2* idt + here ffff and 80000 + over ! here ffff0000 and 8e00 + swap 1 + ! ;
fill an for dup interrupt 1 + next drop ; 0 70 fill
ignore i; 20 8 fill
ignore 2push clear 2pop i; 28 8 fill
ignore 2push 8clear 2pop i; 0 interrupt
0div 7fffffff 1ld i;

idt -a table of 2-word interrupts. edit convenient block number
1ld n load register 1 with literal
lidt load interrupt descriptor table from byte address on stack
2push save registers 0 and 2
2pop restore 2 and 0
forth: save registers used by forth
;forth restore registers used by forth
clear store 20 to port 20 to clear irq 0-7
8clear also 20 to port a0 to clear irq 8-f
i; return from interrupt - restore flags
!idt b execute lidt
interrupt n construct interrupt to here. avoid yellow-green literal with red comment
fill an n entries in default interrupt table
ignore clear the interrupt. doesnt clear the device
0div make divisor +infinity, quotient 0

admtek comet an983b macro
align here 7 and 3 xor drop if nop align ; then ; forth
array pop 2/ 2/ ;
us n khz @ 1000 3 * / * for next ;
r n-a db000000 + 2/ 2/ ;
rom a-n a4 + r @ ;
3rom nnn 4 rom 0 rom dup 16 for 2/ next swap ;
reset 1 0 r ! 1000 us ;
frag 0 , 2000000 , 0 , here 4 + , ;
tx align array frag frag frag frag frag frag
n tx 1 + ;
a tx 2 + ; f 16
fr! f @ + ! ;
first an 0 f ! 20000000 or
send an 1000000 or n fr! a fr! 80000000 tx fr! 4 f +! ;
last an 42000000 or send 1 us
poll -1 8 r ! ;

array -a returns word-aligned address in dictionary
us n delay n microseconds. edit cpu clock rate
r n-a word address of register. edit base address from north pci device configuration
rom a-n fetch 2 bytes of ethernet id
3rom -nnn 3 byte-pairs of id.
reset controller
tx -a transmit descriptor ring
n -a fragment length/control
a -a fragment address
send an fragment into descriptor queue
first an fragment.
last an fragment. start transmission

receive rxp 281880
rx align array 80000000 , 1000600 , 2000 block 4 * dup , here 4 + , 80000000 , 1000600 , 600 + , rx 4 * ,
init reset rx 2 * 2* 18 r receive ! 1 us tx 2 * 2* 20 r transmit ! 1 us 202002 start 30 r ! 1 us 10040 38 r ! sti -1 28 r ! ;
link 3 + @ 2/ 2/ ;
own? @ 0 or drop ;
/int rxp @ 80000000 over ! link own? -if -1 28 r ! then ;
rcvd rx nop
wait dup own? -if link wait ; then dup rxp ! 2 + @ ;
reg dup r @ h. space 2 h.n cr ;
regs b8 reg a0 reg 98 reg 94 reg 78 reg 60 reg 48 10 for dup reg -8 + next drop ;
ok show red screen text regs keyboard ;
rx1 2000 block dump ;
rx2 2000 block 180 + dump ; ok

rx -b receive descriptor ring
init ialize controller. set tx/rx address/on and perfect match
link a-b next link in descriptor ring
own? a is this descriptor owned?
/int give up ownership of received packet , clear interrupt if no packet remains
rcvd -a return address of recieved packet
wait -b till packet received
reg a display register and address
regs display interesting registers
ok diagnostic display

app: ethernet empty 124 load
empty empt logo cli ; macro
w 66 1, ;
w@ 8b 2, ;
w! 289 2, drop ;
*byte c486 2, ; forth 126 load 128 load
n@ w w@ ffff and *byte ;
2! a! w w! ;
n! a! *byte w w! ;
n, *byte 2, ;
string pop ;
packet string -1 dup , 2, 3rom 2, 2, 2, 0 n,
length n packet 12 + n! ;
broadcast -1 dup dup packet nop
3! swap over 2! 2 + swap over 2! 2 + 2! ;
ethernet n length packet 14 first ;
+ethernet -a rcvd 14 + ; 132 load 134 load 136 load 138 load 140 load 142 load 146 load 2a interrupt
serve forth: receive /int 8clear ;forth i; init ok discover

empty redefined to disable interrupts
w 16-bit prefix
w@ b-n fetch 16-bits from byte address
w! nb store 16-bits
*byte n-n swap bytes 0 and 1
n@ b-n fetch 16-bit network-ordered number
2! nb store 16-bit number
n! nb store 16-bit number in network order
n, n compile 16-bit number in network order
string -b returns byte address
packet -b ethernet packet header
dest -b destination field in packet
src -b source field
length n store length into packet
3! nnnb store 3-word mac
ethernet n send header with type/length
@ethernet -b return payload address of received packet

arp for a single correspondent macro
move sdn c189 2, drop c78957 3, drop c68956 3, a4f3 2, 5f5e 2, drop ; forth
. n 1, ;
message string 1 n, 800 n, 6 . 4 . 1 n,
me 3rom 2, 2, 2, ip 0 . 0 . 0 . 0 .
to 0 0 0 2, 2, 2, ip 0 . 0 . 0 . 0 .
sender 8 + ;
target 18 + ;
dir 6 + ;
ip 6 + w@ ;
ar n message dir n! 806 arp ethernet message 28 last ;
arp cli broadcast 1 ar sti ;
-arp b-b dup -2 + n@ 806 or drop if ; then pop drop
me? dup target ip message sender ip or drop if ; then dup sender packet 6 move
query? dup dir n@ 1 or drop if ; then sender message target 10 move 2 ar ;

set ip addresses with edit. normal order, net bytes first
move sdn move n bytes from source to destination. register 1 is used, 6 and 7 are saved
. n compile byte. resembles url punctuation
message -b 28-byte string
me comment marking my mac/ip address
to comment marking correspondent
sender
target
dir -b fields in either message or received message
ip b-n fetch ip address
ar n send query 1, or reply 2
arp broadcast query
-arp b-b return if not arp. otherwise process and skip out.
me? b return if broadcast not for me. save sender only in packet
query? b if a request, reply

ipv4
header align string 4500 n, 0 n, 1 n, 0 n, ff11 n, 0 n, 0 , 0 ,
length n header 2 + n! ;
+id header 4 + dup n@ 1 + swap n! ;
-sum for dup n@ u+ 2 + next drop dup 10000 / + invert ;
sum header 10 + n! ;
checksum 0 sum 0 header 10 -sum sum ;
source header 12 + ;
destination header 16 + ;
ip n-n dup 20 + 800 ethernet length +id checksum header 20 send ;
+ip dup -2 + n@ 800 or drop if pop ; then 20 + ;

set ip addresses with edit. normal order, net bytes first
header -a 40-byte ipv6 header
length n store 2-byte length in header
dest -a 4-byte destination ip address
src -a source ip
ip n send ip header embedded in ethernet packet
+ip b-b skip out if not ip. otherwise return payload address

udp
xid 3rom + + ;
b@ b-n w@ ff and ;
header string xid n, 0 n, 8 n, 0 n, 0 n,
length n 8 + header 4 + n! ;
port header 2 + n! ;
from? over -8 + n@ or drop ;
udp n dup 8 + ip length ;
+udp b-b dup -11 + b@ 17 or drop if pop ; then 8 + ;

b@ b-n fetch byte
header -a 8-byte udp header
length n store length in header
port p set destination port
from? ap udp packet from port p ?
udp n send ip header for n-byte packet
+udp b-b skip out if not udp. otherwise return payload address

dns resolver server 217328196 host 1671948608
msg string 0 , 1 n, 0 2, 0 , 1 n, 1 n,
ptr? dup n@ c000 and c000 or drop ;
skip ptr? if dup b@ if + 1 + skip ; then drop 1 + ; then 2 + ;
length dup negate swap skip + ;
4! a! w! ;
query server @ destination 4! 53 port dup length dup 16 + udp drop header 8 send msg 12 send send msg 12 + 4 last ;
answer dup 12 + skip 4 + swap 6 + n@ ;
resolve a-h 0 host ! query
wait host @ 0 or if ; then drop wait ;
rr+ 8 + dup n@ + 2 + ;
-dns 53 from? if ; then pop drop answer
rr -1 + -if -1 host ! ; then swap skip dup n@ 1 or drop if rr+ swap rr ; then
address 10 + dup w@ host ! ;

assumtions
1 a response contains one entry in the question section
2 the first address in the answer section, if any, sufficiently resolves the query
server name server
host the resolved ip address
skip a-b skip past a domain field
length a-n length of a domain in bytes
query a- send dns query to the dns server
answer a-bn give the answer section and the number of resource records
resolve a-h resolve domain name to host address
wait -h wait for a response from the server
rr+ a-b skip a resource record
-dns dns packet recieved , search for address
rr a-b process resource record
address a-b set the host address

domain names 48 load macro
1! a! 288 2, drop ;
interp /dup f889 2, ; forth
word ch if 1, 1 u+ word ; then drop drop ;
. here 0 1, interp 0 over @ -16 and word 1 u+
words over @ f ? if drop nip swap 1! ; then word 1 u+ words ;
end 0 1, ;
cf string . www . colorforth . com end
google string . www . google . com end
none string . none end

1! xa- write byte at byte address
interp -a word address of next word to be interpreted
word w- compile packed word as ascii characters
. compile counted ascii string
words an- compile extentions words as ascii
end of domain
none test of a non-existant domain

dhcp client
fill for 0 , next ;
msg align string 60101 , xid , 5 fill 3rom 2, 2, 2, 0 2, 50 fill 6382 n, 5363 n, 10135 3, 6030237 , 12 1, . colorforth ff 2, 0 , 3204 n, 0 , ff 1,
eq over over or drop ;
skip over 1 + b@ 2 + u+ ;
find over b@ if eq if ff or if drop skip find ; then then drop drop 2 + ; then drop 1 u+ find ;
your 16 + w@ ;
ack dup 6 find w@ server ! 3 find w@ message target 6 + 4! your dup source 4! message sender 6 + 4! 1 ar ;
-dhcp 67 from? if ; then dup 4 + w@ xid or drop if ; then dup 240 + dup 53 find w@
type 2 or if 7 or drop if ack then drop ; then drop
offer 54 find w@ msg 261 + 4! your msg 267 + 4!
request 272 3604 103 msg 241 + n!
bootp msg 259 + n! broadcast -1 destination 4! 67 port udp header 8 send msg swap last ;
discover 260 ff00 bootp ;

xid -v a unique identifier used in all dhcp correspondence with this client
fill n fill n words
msg the dhcp message , both discover and request are contained , discover is ends at ff 2,
eq xy-xy test equality
skip at-bt skip dhcp option
find at-b find option of type t in option list
your a-h ip address
ack ao server acknowledge , assign your ip , router ip , and dns server ip
-dhcp a receive dhcp packet with xid
type aot recieve offer 2 or ack 5
offer ao recieved an offer , send a request
request request the offered parameters
bootp nt send a discover or request message
discover broadcast a discover message

icmp
header string 800 n, 0 n, 0 ,
icmp dup -34 + b@ 1 or drop if ; then ;
ping 8 ip header 8 last ;

client can get or put blocks to server
payload n-bn 2 bytes were appended to udp header for block number
+put nn send block number. append block as last fragment. packet length distinguishes two messages
it b move 1024 bytes from packet to offset block
-got b-b if a 2-byte message, return. otherwise move block to archive - 300+ - and skip out
receive check and decode received packet. +test returns if true, -test returns if false. otherwise they pop - skip-out - return from receive. resulting stack need not be empty, since /forth will restore pre-interrupt stack. pop must be in a word called by receive, it cant be nested
+get b send requested block from archive
get n send block number to request. interrupt disabled lest reply interfer
put n send block
archive send blocks 0-161 - 9 cylinders icmp dhcp

blocks to/from server
payload n-bn header 8 + n! header 10 ;
+put nn 1026 udp over payload send + block 2* 2* 1024 last ;
it b dup 2 + swap n@ 300 + block 2* 2* 1024 move ;
-got b-b dup -4 + n@ 2 8 + or drop if it pop ; then ;
receive +ethernet -arp +ip +udp -dns -dhcp -got
+get b n@ 300 +put ;
... interrupt-protect words that transmit
get n cli 2 udp payload last sti ;
put n cli 0 +put sti ;
archive 161 for i put 1000 us -next ;

format floppy empt forth hd 1
array pop 2/ 2/ ;
com align array 1202004d , 6c 2,
done 3f4 a! p@ d0 or drop if done ; then ;
byte n ready p! ;
sectors nn-n 18 for over byte hd @ byte dup 18 mod 1 + byte 2 byte 1 + next drop ;
head nn-n dup hd ! 400 * 1202004d + com ! seek com 6 command dup 2* - 1801 + sectors done ;
cylinders n 0 swap for 0 head 1 head 1 + next stop drop ;
format 12 cylinders ;

increase speed from 2 cylinders/s to 3
array -a return next word address
com -a address of command string
done wait till last sector formatted. till ready to read
byte n send byte to fdc when ready
sectors nn-n send 4 format bytes to each of 18 sectors. sector number from 1 to 18
head nn-n set head number. issue seek and format commands. starting sector number depends on cylinder, allowing 2 sector times to step heads. cylinder 1: 17 18 1 2 ... 16. 1801 + adjusts for 1s complement and for unsigned mod
cylinders n format both heads of each cylinder, starting at 0
format standard number of cylinders. smaller is faster

hard disk empt macro use this at your own risk
2/s ?lit f8c1 2, 1, ;
p!+ 42ee 2, ;
1! 91 1, drop ;
insw 1! 97 1, 6df266 3, 97 1, ;
outsw 1! 96 1, 6ff266 3, 96 1, ; forth
2dup over over ;
bsy 1f7 p@ 80 and drop if bsy ; then ;
rdy -n 1f7 p@ 8 and drop if 1f0 a! 256 ; then rdy ;
sector 1f3 a! swap p!+ 8 2/s p!+ 8 2/s p!+ 8 2/s e0 or p!+ drop p!+ drop 2* 2* ;
read an 20 sector 256 for rdy insw next drop ;
write an bsy 30 sector 256 for rdy outsw next drop ; nload

boot: 3f fat0: 5f fat1: 25a5 dir: 2 cl forth: 8e6d cl
reg dup p@ ff and 2 h.n space 3 h.n cr ;
regs 7 for i 1f0 + reg -next ;
ok show blue screen text regs keyboard ;
cl 20 * 4aab + ;
buffer 2000 block ;
?fort dup @ 54524f46 or drop ;
cl0 dup 5 + @ 10000 * swap 6 + @ 16 2/s ffff and or ;
find -n buffer dup 2 cl read 256 for ?fort if 8 + *next drop ; then cl0 pop drop ;
fort 8e6d cl ;
+2 8000 u+ 100 + ;
reads for 2dup read +2 next drop drop ;
writes for 2dup write +2 next drop drop ;
get buffer fort 9 reads ;
cf! 0 fort 2 writes ;

deskjet empty 2 +load
nb 768 3 * ; 4 +load
pixels for pix next drop drop ;
drow string 33622a1b , 622a1b4d , 5730 2,
rpt drow 10 type drop ;
columns for 264 2 erase dup buffer 8 * 768 pixels line rpt rpt 2 + next drop ;
res 300 2, 300 2, 2 2, ;
esci string 306c261b , 6f2a1b4c , 1b4d312e , 3033742a , 2a1b5230 , 55342d72 , 32672a1b 4025736 res res res res 32722a1b , 53343033 , 30722a1b , 722a1b41 , c4362 3,
print esci 37 type f0000000 767 1024 * 2 * + 1024 columns 6 type drop ;
tx string 3f and if 3f or if ; then c0 or ; then ;
text tx map ! print ;
it table map ! print ;

printer macro
p@ ec 1, ;
p! ee 1, ;
@w 8b66 3, ;
@b 8a 2, ;
+a c2ff 2, ;
bts 10ab0f 3, drop ;
2/s ?lit f8c1 2, 1, ; forth
ready p@ 80 and if ; then ready ;
delay for next ;
emit 378 a! p! +a ready +a 8d or p! 30 delay 1 or p! drop ;
type for dup @b emit 1 + next ;
buffer 264 block 4 * ;
string pop ;
!b dup - 7 and a! dup 3 2/s bts 1 + ;
three !b
two !b
one !b
nul drop ;
white ffff and dup ffff or drop if - then ;

deskjet
-nb nb negate u+ ;
bcmy string 10243800 , 3033 , 200022 , 10000011 , c00f , 4003 , 0 , 0 , 8000a , 0 , 800002 , 0 , 4000005 , 0 , 0 , c0000001 ,
ye nb 3 * u+
all over over 3 and jump nul one two three
ma -nb 2 2/s all ;
cy -nb 2 2/s all ;
bl -nb 2 2/s all ; map 1050918
6b c618 and 3 2/s dup 3 2/s or 3c3 and dup 4 2/s or 3f and ;
table string bcmy + @b ;
ex map @ push ;
pix over @w 6b ex ff and if ye ma cy bl then drop 3 + 1024 -2 * u+ ;
arow string 30622a1b , 4d 1,
trbp string 32622a1b , 563838 3,
trbr string 32622a1b , 573838 3,
color 7 type drop nb 8 / type ;
line arow 5 type drop buffer 3 for trbp color next trbr color drop ;

app: x18 simulator empty macro
2/s ?lit f8c1 2, 1, ; forth
state 1fff block ; nload
reset r 26 for 100000 over ! 1 + next drop 180 mem @ ir ! 181 pc ! 0 slot ! ;
un. 5 for 37 emit next ;
undef 100000 ? if drop un. ; then 5 h.n ;
r. a-a dup @ undef cr 1 + ;
stack sp @ 8 for dup ss r. drop -1 + next drop ;
return rp @ 8 for 1 + dup rs r. drop next drop ;
ok show black screen text green return r r. blue r. r. white r. r. green r. r. drop stack keyboard ; reset ok

2/s n shift right n bits
state -a address of state vector for current computer
reset set registers undefined, execute from rom
un. display undefined register
h.n nn display n hex digits of number
undef n bit 20 set means undefined
r. display register
stack display stack, top at top
return display return stack, top at bottom
ok display registers, b a blue, pc ir white

registers
r state ;
b state 1 + ;
ar state 2 + ;
pc state 3 + ;
ir state 4 + ;
t state 5 + ;
s state 6 + ;
slot state 7 + ;
ss 7 and 8 + state + ;
rs 7 and 16 + state + ;
rp state 24 + ;
sp state 25 + ;
mem 2000 block + ; 4 +load 2 +load
s1 ir @ 8 2/s inst ;
s2 ir @ 3 2/s inst ;
s3 0 slot ! ir @ 4 and drop if ret then pc @ mem @ ir ! 1 pc +!
s0 ir @ 13 2/s inst ;
step slot @ jump s0 s1 s2 s3
steps for step next ;

name 26 registers in state vector
ar -a a register. cannot be named a because pentium macro takes precedence
s0-s3 execute instruction from slot 0-3
step execute next instruction
steps n execute n instructions

instructions
nul ;
call pc @ +r
jmp ir @ 1ff and pc ! ;
jz t @ dup or
jc drop if 3 slot ! ; then jmp ;
jns t @ 20000 and jc ;
ret -r pc ! ;
@b b @
@x mem @ +t ;
@+ ar @ 1 ar +! @x ;
n pc @ 1 pc +! @x ;
@a ar @ @x ;
!b b @ 1 b +!
!x -t swap mem ! ;
!+ ar @ 1 ar +! !x ;
!a ar @ !x ;
inst n 1 slot +! 1f and jump jmp jmp call call jz jz jns jns @b @+ n @a !b !+ nul !a -x 2*x 2/x +* orx andx nul +x r@ a@ t@ s@ r! a!x nul t!

define action of each instruction
inst n jump vector for 32 instruction codes

instructions
+r n r @ rp @ 1 + dup rp ! rs ! r ! ;
-r -n r @ rp @ dup rs @ r ! -1 + rp ! ;
+t n t @ s @ sp @ 1 + dup sp ! ss ! s ! t ! ;
-t -n t @ s @ t ! sp @ dup ss @ s ! -1 + sp ! ;
-x t @ 3ffff or t ! ;
2*x t @ 2* 3ffff and t ! ;
2/x t @ dup 20000 and 2* or 2/ t ! ;
+* t @ 1 ? if s @ + then 2/ t ! ;
orx -t t @ or t ! ;
andx -t t @ and t ! ;
+x -t t @ + 3ffff and t ! ;
r@ -r +t ;
a@ ar @ +t ;
t@ t @ +t ;
s@ s @ +t ;
r! -t +r ;
a!x -t ar ! ;
t! -t drop ;

+r n push onto return stack
-r -n pop from return stack
+t n push onto data stack
-t -n pop from data stack
-x some instructions named with terminal x to avoid pentium conflict

app: x18 target compiler empt h 2097556 ip 2097555 slot 2 macro
2*s ?lit e0c1 2, 1, ; forth
memory 2000 block ;
org n memory + dup h ! ip ! 0 slot ! ;
, n h @ ! 1 h +! ;
s3
s0 h @ ip ! 13 2*s , 1 slot ! ;
s1 8 2*s
sn ip @ +! 1 slot +! ;
s2 3 2*s sn ;
i, slot @ jump s0 s1 s2 s3
25x 174 load ; 8 +load 2 +load 4 +load n x18 call class 25x

prototype for target compilers
h address of next available word in target memory
ip address of current instruction word
slot next available instruction slot
2*s n shift left n bits
memory -a host address for target memory
org n set current target memory location
, n compile word into target memory
s0-s3 assemble instruction into slot 0-3
i, assemble instruction into next slot
25x compile code for multicomputer

instructions
nop 1e i, ;
adr n-a slot @ 2 or drop if nop then i, ip @ ;
call defer a 2 adr +! ;
if -a 4 adr ;
-if -a 6 adr ;
then a h @ 1ff and swap +! ;
@+ 8 i, ;
@b 9 i, ;
n defer 8 f@ execute a i, , ;
@ b i, ;
!+ c i, ;
!b d i, ;
! f i, ;
- 10 i, ;
2* 11 i, ;
2/ 12 i, ;
+* 13 i, ;
or 14 i, ;
and 15 i, ;
+ 17 i, ;

words being redefined for the target computer. these pentium words can no longer be executed. although pentium macros still take precedence during compilation, they will no longer be used.
adr n-a assembles instruction, but not in slot 2, where address goes. instruction address left on stack
call deferred to class. executed for target defined words
then a puts address in low 9 bits of previous instruction word
n executed for green short-numbers. all 18-bit target numbers are short. executes white short-number to put interpreted number on stack. then assembles literal instruction with number in next location

instructions
pop 18 i, ;
a 19 i, ;
dup 1a i, ;
over 1b i, ;
push 1c i, ;
a! 1d i, ;
drop 1f i, ;
; 4 ip +! ;

more target instructions
; since it will be executed, it does not conflict with the pentium macro

25x rom 180 org 0 dup - dup - dup - dup - dup - dup - dup - dup - dup push push push push push push push push push a! a nop

target
defer -a pop ;
execute a push ;
class a last 1 + ! ;
f! an sp + ! ;
f@ n-a sp + @ ; ?com 1445 csho 1369
empty empt 0 class csho @ ?com @
functions aa 4 f! 6 f! ;
x18 a 4 f@ ?com ! 6 f@ csho ! 1 f@ functions ;

realtek rtl8139b macro
move sdn c189 2, drop c78957 3, drop c68956 3, a4f3 2, 5f5e 2, drop ; forth
1us 1
us n 550 3 / * for next ;
r n-a 2000000 device 14 + pci + 2/ 2/ ;
rom a-n r @ ;
3rom nnn 4 rom 0 rom dup 16 for 2/ next swap ;
tx -b 2000 block 4 * ;
rx -b tx 1536 + ; ds 1 fr 42
n -a ds @ 10 r + ;
send an fr @ tx + swap dup fr +! move ;
first an n @ 2000 and drop if ds dup @ 1 + 3 and swap ! 0 fr ! send ; then first ;
last an send tx ds @ 20 r + ! fr @ 60 max n ! ;
reset 10000000 34 r ! 100 us ;
init rx 30 r ! 1us reset c000000 34 r ! 1us 8a 44 r ! 3 ds ! fb dup 21 p! a1 p! sti
/int ffff0001 3c r ! ;
rcvd -b 38 r @ dup 10000 / 1fff and fffffff0 + 38 r ! 10 + 1fff and rx 4 + + ;

move sdn move n bytes from source to destination. register 1 is used, 6 and 7 are saved
us n delay n microseconds. edit cpu clock rate
r n-a word address of register
rom a-n fetch 2 bytes of mac
3rom nnn 3 byte-pairs of mac
tx -a transmit buffer. 1536 bytes. fragments must be assembled for transmission
rx -b receive buffer. 8k + 1532 byte overrun
ds -a must cycle thru 4 tx descriptors
fr -a must accumulate fragments in tx buffer
n -a tx status/length. writing starts transmission
send an fragment into transmit buffer
first an fragment. wait till buffer empty
last an fragment. start transmission
reset controller
init ialize controller. set tx/rx address/on and mac/broadcast. enable irq10
rcvd -b received packet. register 38 is 10 bytes before start of next packet. register 3a is end of current packet

display registers
reg a dup r @ h. space 2 h.n cr ;
regs 48 19 for dup reg -4 + next drop ;
ok show red screen text regs keyboard ;

reg a display register and address
regs display interesting registers
ok diagnostic display
48 counter. neat!
44 rx configuration
40 tx configuration
3c interrupt
38 rx count/address
34 command
30 rx 8k ring buffer
2c-20 tx address
1c-10 tx status
c-8 multicast id, unused
4 mac 54
0 mac 3210

ethernet empty 124 load
empty empt logo cli ; macro
w 66 1, ;
w@ 8b 2, ;
w! w 289 2, drop ;
*byte c486 2, ; forth 126 load 128 load
n@ w w@ ffff and *byte ;
2! a! w! ;
n! a! *byte w! ;
n, *byte 2, ;
string pop ;
packet string -1 dup dup 2, 2, 2, 3rom 2, 2, 2, 0 n,
length n packet 12 + n! ;
3! swap over 2! 2 + swap over 2! 2 + 2! ;
ethernet n length packet 14 first ;
+ethernet -a rcvd 14 + ; 132 load 134 load 136 load 138 load 72 interrupt
serve forth receive /int 8clear /forth i; init ok

arp for a single correspondent
. n 1, ;
message string 1 n, 800 n, 6 . 4 . 1 n,
me 3rom 2, 2, 2, ip 0 . 0 . 0 . 2 .
to 0 0 0 2, 2, 2, ip 0 . 0 . 0 . 1 .
sender 8 + ;
target 18 + ;
dir 6 + ;
ip 6 + w@ ;
ar n message dir n! 806 ethernet message 28 last ;
arp cli -1 dup dup packet 3! 1 ar sti ;
-arp b-b dup -2 + n@ 806 or drop if ; then pop drop
me? dup target ip message sender ip or drop if ; then dup sender packet 6 move
query? dup dir n@ 1 or drop if ; then sender message target 10 move 4 ar ;

set ip addresses with edit. normal order, net bytes first
. n compile byte. resembles url punctuation
message -b 28-byte string
me comment marking my mac/ip address
to comment marking correspondent
sender
target
dir -b fields in either message or received message
ip b-n fetch ip address
ar n send query 1, or reply 4
arp broadcast query
-arp b-b return if not arp. otherwise process and skip out.
me? b return if broadcast not for me. save sender only in packet
query? b if a request, reply

ipv6
header string 1000060 , 0 n, 17 . 64 .
to 0 , 0 , 0 , ip 0 . 0 . 0 . 2 .
me 0 , 0 , 0 , ip 0 . 0 . 0 . 1 .
length n header 4 + n! ;
dest header 20 + ;
src header 36 + ;
ip n 86dd ethernet length header 40 send ;
+ip b-b dup -2 + n@ 86dd or drop if pop ; then 40 + ;

udp
b@ b-n w@ ff and ;
header string 0 n, 0 n, 8 n, 0 n, 0 n,
length n 8 + header 4 + n! ;
udp n dup 8 + ip length ;
+udp b-b dup -34 + b@ 17 or drop if pop ; then 8 + ;

b@ b-n fetch byte
header -a 8-byte udp header
length n store length in header
udp n send ip header for n-byte packet
+udp b-b skip out if not udp. otherwise return payload address

app: blocks to/from server
payload n-bn header 8 + n! header 10 ;
+put nn 1026 udp over payload send + block 2* 2* 1024 last ;
it b dup 2 + swap n@ 300 + block 2* 2* 1024 move ;
-got b-b dup -4 + n@ 2 8 + or drop if it pop ; then ;
receive +ethernet -arp +ip +udp -got
+get b n@ 300 +put ;
... interrupt-protect words that transmit
get n cli 2 udp payload last sti ;
put n cli 0 +put sti ;
archive 161 for i put 1000 us -next ;

ipv4
header align string 4500 n, 0 n, 1 n, 0 n, ff00 n, 0 n, 0 , 0 ,
length n 20 + header 2 + n! ;
+id header 4 + dup n@ 1 + swap n! ;
checksum ;
source header 12 + ;
destination header 16 + ;
ip n-n dup 20 + 800 ethernet length +id checksum header 20 send ;

app: howerds test block empt macro
gtend 7e 1, here invert + 1, ;
init b803f0ba , eeee0055 , ; forth
h 1e5 ; h last class macros forths
allot n- h +! ;
mk2 here 10 + ; 40 allot
mk 1e2 ;
class 1e9 ;
macros 1ea ;
forths 1eb ;
mk macros @ mk2 ! forths @ mk2 1 + ! h @ mk2 2 + ! ;
mt mk2 @ macros ! mk2 1 + @ forths ! mk2 2 + @ h ! ;
reload 0 push ;
qkey 3 for i next ; ky 57
key pause 64 p@ 1 and drop if 60 p@ dup 3a - drop -if ky ! ; then drop then key ;
kk key ky @ 57 - drop if kk then ;
pt 3f0 ; here 4 / 12345678 , ,
conf cli init 0 pt p! pt 1 + p@ 1 pt p! pt 1 + p@ ;

kk shows key values . press esc to exit

ir remote empty macro
2/s ?lit f8c1 2, 1, ;
p@ ec 1, ;
p! ee 1, drop ;
1@ 8a 2, ;
1! a! 288 2, drop ; forth
ba 10 /mod 11f a! p! 118 + a! ;
b@ ba 0 p@ ;
b! ba p! ;
us 748 * time + -
till dup time + drop -if till ; then drop ;
ms 1000 * us ;
array pop 2 2/s ;
nul ; onf 3 145 load 146 load 50 load 147 load 148 load 149 load 150 load 151 load 152 load 153 load 155 load 154 load
h pad nul nul accept bye +db -db mute nul +xx -ch jp vcr tv0 dvd cd fm nul nul nul nul nul nul nul nul nul nul nul nul 152500 , 91016 , 11001016 , e0a1002 , 0 , 0 , 0 ,

smsc ircc2.0 ir consumer mode 32 10 b! 0 12 b! 0 20 b!
buffer 200 block 4 * ;
reset 10 7 b! 80 4 b! ;
on 40 5 b! ;
off 2 4 b! 200 ms ;
emit 6 b@ 40 and drop if emit ; then 0 b! ;
rdy 6 b@ 80 and drop ;
get 0 b@ over 1! 1 + ;
bytes for
byte rdy if get dup buffer 4096 + or drop if byte ; then drop pop drop ; then next drop ;
r 200 1 erase 80 dup 4 b! 5 b! buffer 1000000 bytes 0 5 b! ;
word - 4 for dup emit 8 2/s next drop ;
cmd for word next 1
sp for 0 word next ;
rate 22 b! 21 b! ;
sync 80 20 b! ;

app: slime : simple game empt sounds 4 +load macro
@w 8b66 3, ; forth speed 3 alice 13631872 bob 29360752 once 0 da 16 db -16 delay 10 /del 18 off 0 done 0 frame 31981568
mova da @ alice +! ;
movb db @ bob +! ;
qpel a- @ 10000 /mod at frame @ xy @ 10000 /mod swap 400 * + 2 * + @w ffff and 0 + if 1 done ! 1 off ! white bomb then ;
clr 13 65536 * 16 * 320 + alice ! 28 65536 * 16 * 688 + bob ! 16 da ! -16 db ! 0 delay ! 1 off ! 0 done ! 1e80000 frame ! 1 1000 tn
bgnd silver screen 16 16 at black 1008 672 box
draw ffff color alice mova qpel 102 emit red bob movb qpel 101 emit ;
tick off @ 0 + drop if ; then delay @ -1 + delay ! -if /del @ delay ! draw click then ;
b. c- 18 + 2emit ;
ok show silver once @ 0 + drop if clr 0 once ! then silver 0 708 at 600 768 box 48 708 at ffff00 color 104 mute @ 0 + drop if 1 + then 2emit 0 emit speed @ 1 + b. tick keyboard ; nload x ok h

slime empt macro
@w 16bit fetch
speed selected speed
alice 16:16 bit xy coordinate of left slug
bob 16:16 bit xy coordinate of right slug
once is set to initialise the game
mova move alice by the value in da
movb move bob by the value in db
delay counts the ticks for each move
/del the reset value for delay
qpel check for slime coloured pixel
clr set alice and bob to start positions
bgnd draw the background
draw the slugs
tick do this every screen update
ok the screen display

slime keypad
+speed 1
+/-speed speed @ + 0 max 9 min speed ! 10 speed @ invert + dup * 7 + 2 / 2 invert + /del ! ;
-speed -1 +/-speed ;
d 16 65536 * da ! ;
u -16 65536 * da ! ;
r 16 da ! ;
l -16 da ! ;
d2 16 65536 * db ! ;
u2 -16 65536 * db ! ;
r2 16 db ! ;
l2 -16 db ! ;
nul ;
go 0 off ! ;
stop -1 off ! ;
x 1 once ! ;
t off @ 0 + drop if 0 off ! ; then -1 off ! ;
help 203 edit ;
mutet mute @ invert mute ! ;
h pad nul cfex t nul nul nul nul nul l2 u2 d2 r2 x nul stop go nul nul nul nul l u d r -speed help mutet +speed 225 , 0 , 110160c , 19180015 , 0 , 110160c , 2b091423 ,

slime keypad
ludr move alice and bob left up down up
x reset the game
0 stop the game
1 start the game
- decrease the speed
h to see this help screen
m mute the sound - on/off
+ increase the speed
. quit
t toggle on/off
slime: two players control alice and bob. the first to hit any slime or the edges loses.
credits: coded by howerd oakford from an idea by alan crawley and paul chapman
tested: by hannah oakford
type slime to play again

sounds tempo 20 mute 0 period 90
tn ft- tempo @ * swap 660 50 */
hz tf- push 1000 1193 pop */
osc tp- dup period ! split 42 p! 42 p!
tone t- mute @ 0 + drop if drop ; then 4f 61 p! ms 4d 61 p! 20 ms ;
click 1 90 osc ;
t 3 tn ;
q 8 tn ;
c 16 tn ;
2tone 75 q 50 q ;
h1 50 c 54 q 50 q 45 c 60 c ;
h2 40 c 45 q 50 q 50 c 45 c ;
h3 54 c 60 q 54 q 50 c 45 q 40 q 50 t 45 t 50 t 45 t 45 12 tn 40 q 40 32 tn ;
hh
handel h1 h2 h3 ;
piano 55 7 for dup q 3 2 */ next drop ;
cetk 6 c 10 c 8 c 4 c 6 32 tn ;
bomb mute @ 0 + drop if ; then 4f 61 p! 500 for 1000 i invert + split 42 p! 42 p! 1 ms next 4d 61 p! 1 32 tn ;

sounds
tempo in ms per 1/8 quaver
mute equals -1 to disable sound
period test only - value sent to hardware
tn ft- play f hz for t * 11 ms
hz tf- play t ms at f hz
osc tp- play t ms of period p
tone t- play the current tone for t ms
click makes a click
t triplet
q quaver
c crotchet
2tone 2 tones
h1
h2
h3
hh
handel part of handels gavotte
piano
cetk close encounters of the third kind
bomb - well sort of ....

app: colorforth editor empt nload qinit
eddd jblk @ ok h drop ;
edd b- jblk @ jlast ! jblk ! eddd ; blk @ jblk ! 206 jlast ! eddd

the colorforth editor in colorforth

editor circular buffers cbn 0 ends 0
data - cbn @ 1 invert and cbn ! ;
ptrs - cbn @ 1 or cbn ! ;
heads - cbn @ 2 invert and cbn ! ;
tails - cbn @ 2 or cbn ! ;
cb@ -c ends @ cbn @ 8 * rshift ff and ;
cb! c- ff and cbn @ 8 * lshift ends @ ff cbn @ 8 * lshift invert and or ends ! ;
cbnum -n cbn @ heads cb@ tails cb@ - ff and swap cbn ! ;
cbuf -a r@ 100 / 2 + cbn @ 1 and + block ;
tl- -n cbnum ?f drop 0if 0 ; then tails cb@ cbuf + @ cb@ 1 + cb! ;
tl+ n- tails cbnum ff - drop 0if tl- drop then cb@ 1 - cb! cb@ cbuf + ! ;
hd@ -n heads cb@ cbuf + @ ;
hd- -n cbnum 0 - drop 0if 0 ; then hd@ cb@ 1 - cb! ;
hd! n- heads cb@ cbuf + ! ;
hd+ n- cbnum ff - drop 0if tl- drop then heads cb@ 1 + cb! hd! ; 4 +load

cbn bit 0 selects one of two circular buffers. bit 1 selects head or tail value
cb@
cb! read/write a byte to one of the 4 in ends selected by cbn
ptrs selects the pointer buffer
data selects the data buffer
heads selects the head value
tails selects the tail value
cbnum gives the number of items in the currently selected buffer
cbuf returns the address of the start of both buffers - the next 2 blocks
tl+
tl-
hd+
hd- add or subtract from the head or tail of the currently selected buffer
... note the tl- in hd+ . if the buffer is full we remove the oldest from the tail

r emptyay buffer string undo display r i r s r t r l r f r d r 0 r o r ; r r r rr r rt r e r re r ra r rn r ri r a r rc r rl r rf r rd r n r r8 r r; r t r tr r i r to r te r ta r tn r s r ts r tc r tl r tf r c r t0 r t8 r t; r o r l r ot r oo r oe r oa r f r oi r os r oc r ol r d r od r o0 r o8 r o; r 0 r er r et r eo r ee r 8 r en r ei r es r ec r ; r ef r ed r e0 r e8 r r r a r ar r at r ao r rr r aa r an r ai r as r rt r al r af r ad r a0 r ro r a; r n r nr r nt r re r ne r na r nn r ni r ra r nc r nl r nf r nd r rn r n8 r n; r i r ir r ri r io r ie r ia r in r rs r is r ic r il r if r rc r i0 r i8 r i; r s r rl r se r sn r ss r sl r rf r s8 r m r mt r me r rd r ms r ml r md r m8 r r0 r ct r ce r cn r cs r r8 r cd r c8 r y r yt r r; r yn r ys r yl r yd r t r l r lt r le r ln r tr r ll r ld r l8 r g r tt r ge r gn r gs r gl r to r g8 r f r ft r fe r te r fs r fl r fd r f8 r ta r wt r we r wn r ws r tn r wd r w8 r d r ds r ti r vs r p r ps r b r ts r h r hs r x r xs r tc r us r q r qs r 0 r tl r 1 r 1s r 2 r 2s r tf r 3s r 4 r 4s r 5 r td r 6 r 6s r 7 r 7s r t0 r 8s r 9 r 9s r j r t8 r - r -s r k r ks r t; r .s r z r zs r ; r : r !s cccc cccc r !s r + r +s r @ bbbb r @ r ot bbbb r *s

5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5 r oc r ol r d r od r o0 r o8 r o; r 0 r er r et r eo r ee r 8 r en r ei r es r ec r ; r ef r ed r e0 r e8 r r r a r ar r at r ao r rr r aa r an r ai r as r rt r al r af r ad r a0 r ro r a; r n r nr r nt r re r ne r na r nn r ni r ra r nc r nl r nf r nd r rn r n8 r n; r i r ir r ri r io r ie r ia r in r rs r is r ic r il r if r rc r i0 r i8 r i; r s r rl r se r sn r ss r sl r rf r s8 r m r mt r me r rd r ms r ml r md r m8 r r0 r ct r ce r cn r cs r r8 r cd r c8 r y r yt r r; r yn r ys r yl r yd r t r l r lt r le r ln r tr r ll r ld r l8 r g r tt r ge r gn r gs r gl r to r g8 r f r ft r fe r te r fs r fl r fd r f8 r ta r wt r we r wn r ws r tn r wd r w8 r d r ds r ti r vs r p r ps r b r ts r h r hs r x r xs r tc r us r q r qs r 0 r tl r 1 r 1s r 2 r 2s r tf r 3s r 4 r 4s r 5 r td r 6 r 6s r 7 r 7s r t0 r 8s r 9 r 9s r j r t8 r - r -s r k r ks r t; r .s r z r zs r / r o r ; r ;s r : r :s r or r !s r + r +s r @ r ot r * r *s o

display undo string buffer jcur 0 jblk 18
sze -n e0 ;
qinit 0 ends ! 0 ptrs hd! 10000009 data hd! ;
qnew - 0 ptrs hd+ ;
qnum -c ptrs hd@ ;
qpop -n data hd- ptrs hd@ 1 - if hd! ; then hd- drop drop ;
qpush n- data hd+ ptrs hd@ ff - drop 0if drop then ptrs hd@ 1 + hd! 0 pos 1 lpos 0
2toc n-a jblk @ block pos @ + + ;
xtoc? -n 1 2toc @ f and ;
rtocs - jcur @ pos !
ntocs -n 0 2toc @ f and 12 - ?f drop 0if 2 ; then 1 xtoc? ?f drop 0if 1 + then ff and ;
ltocs -n 0 pos !
ltcs pos @ jcur @ - drop -if pos @ lpos ! ntocs pos +! ltcs drop then jcur @ lpos @ - ;
mx n- jcur @ + 0 max 255 min jcur ! ;
ml ltocs negate mx ;
mu 8 for ml next ;
mr rtocs mx ;
md 8 for mr next ; nload

qinit initialises the queue pointers
qnew starts a new string entry
qnum -c number of cells in the top string
qpop -n returns the top cell of the top string
qpush n- stores n in the top string
ntocs number of tokens in the top string
qq n- qnew for qnum @ 100 * 10000009 + qpush next cbnum drop ;
qqq qinit 50 for 5 qq next 3 qq ;
vvv ptrs cbnum data cbnum ;
kk c vvv qpop ptrs hd@ ;
gg cbuf dump ;

editor display cblind 0
cb cblind @ 0 + drop ; state 16 state* 16
yellow ffff00 color ;
+txt white 6d emit space ;
-txt white 6e emit space ;
+imm yellow 58 emit space ;
-imm yellow 59 emit space ;
+mvar yellow 9 emit 11 emit 5 emit 1 emit space ;
txts string 3010100 , 7060504 , 9090901 , f0e0d0c , ;
tx c-c f and txts + 1@ f and ;
.new state @ f and jump nul +imm nul nul nul nul nul nul nul +txt nul nul +mvar nul nul nul ;
.old state* @ f and jump nul -imm nul nul nul nul nul nul nul -txt nul nul nul nul nul nul ;
state! n-* dup 0 + drop 0if drop ; then tx cb 0if drop ; then state @ swap dup state ! - drop if .old .new state @ 0 + if dup state* ! then drop then ; nload

state
state! acts on a change of token type. it ignores extension tokens

editor display macro
@b 8a 2, ; forth jcnt 117 jlast 206 jcol 2
bksp xy @ 22 10000 * negate + xy ! ;
?.cur jcnt @ 1 + 255 min jcnt ! jcur @ jcnt @ negate + 1 + drop 0if ff4040 color bksp 30 emit white then ;
x xy @ 10000 / ;
?cr x 1000 negate + drop -if ; then
ncr xy @ 30 + ffff and 30000 xor xy ! ;
emt ?cr emit ;
emit emt ;
emitw unpack if emit emitw ; then space drop drop ;
emitcs unpack if 48 + emit emitcs ; then space drop drop ;
dig pop + @b ff and emit ;
edig dig 1b1a1918 , 1f1e1d1c , 13052120 , e04100a ,
odig dup f and swap 2/ 2/ 2/ 2/ fffffff and ; nload

ncr new cr -does not get confused with original

capitals hpo 2004 editor display
.hex odig if .hex edig ; then drop edig ;
.dec -1 ? -if negate 35 emit then
n 10 /mod -1 ? if .dec edig ; then drop edig ;
num if c0c000 and color cb if 24 emit 21 emit then .hex space ; then color .dec space ;
txt ffffff color emitw ;
blu ff color emitw ;
cap ffffff color unpack 48 + emit emitw ; caps? 0
caps ffffff color emitcs -1 caps? ! ;
ex bksp caps? @ ?f drop if caps ; then emitw ;
gw ff00 color emitw ;
cw ffff color emitw ;
yw ffff00 color emitw ;
coly 2 jcol ! ;
colr 4 jcol ! ;
colg 5 jcol ! ;
colm 13 jcol ! ;
colc 8 jcol ! ;
colb 14 jcol ! ;
rot 8b045e8b , 46e892e , c38b0689 , c3 1, last 1220107268 nload

caps
caps? is true if the extension token is capitals
txt? returns true if the last token was text
.hex
.dec

editor display
short push dup 2/ 2/ 2/ 2/ 2/ swap 10 and drop pop num ;
ys ffff00 short ;
long push 1 u+ 10 and drop dup @ pop num ;
yn ffff00 long ;
gs ff00 short ;
gn ff00 long ;
var ff00ff color emitw 0 gn ;
x xy @ 10000 / ;
rcr x 0 xor drop if cr then ;
rw xy @ fffcfffd + drop if rcr then ff0000 color cb if 41 emit space then emitw ;
nuld drop ;
.word w- dup -16 and swap f and if 0 caps? ! then dup state! jump ex yw yn rw gw gn gs cw ys txt cap caps var blu nuld nuld ;
t 0 jcnt ! jblk @ block text 3 lm 1024 rm 3 3 at 10 state ! 10 state* !
n dup @ -1 ? if ?.cur .word 1 + n ; then drop drop f state! ; white 103 emit ;
ok show 200040 color screen t keyboard ; nload

capitalsalltheway!

editor aaaa bbbb cccc dddd keypad insertion
ripple a- dup dup @ over 1 + @ rot ! swap 1 + ! ;
toc -a jblk @ block jcur @ + ;
toend -n sze jcur @ - 0 max sze min ;
del toc @ qpush toc toend for dup ripple 1 + next 0 swap ! drop ;
dels jcur @ ?f drop 0if ; then ml qnew rtocs for del next ;
ins n- sze jcur @ - ?f drop -if ; then jblk @ block sze + toend for 1 - dup ripple next ! ;
undo qpop ins ;
undos qnum ?f 0if drop ; then for undo next mr ; ky 25
key pause 64 p@ 1 and drop if 60 p@ dup 3a - drop -if ky ! ; then drop then key ;
lst n- jblk ! ok key drop ; nload

editor main keypad
ripple a- swaps the values at a and a+1
bpush
bpop push and pop the edit stack tbd
del removes the cell at the current cursor
dels removes the extension cells and one non extension coll before the cursor
undo puts back one cell
undos puts back one word which may have extension cells

editor keypad cursor
btog n-n dup 1 and drop if 1 invert and dup jblk ! ; then 1 xor dup jblk ! ;
cbtog cblind @ invert cblind ! ;
lastb n-n jlast @ dup jblk ! swap jlast ! ;
blkld jblk @ fffffffe and -32 + drop -if ; then jblk @ load ;
-blk n-n -2 + 18 max dup jblk ! ;
+blk n-n 2 + 252 min dup jblk ! ;
accep drop cfex ;
h pad nul dels accep undos coly colr colg btog ml mu md mr -blk colm colc +blk colb nul nul nul cbtog nul nul lastb blkld nul nul nul 72515 , 2d0d010b , 110160c , 2b0a0923 , 23a3800 , 3000029 , 3c ,

app: conways game of life empt nload
cell 32 /mod adj adj over over at 16 u+ 16 + box ;
nocell drop ;
draw dup old @ 1 and jump nocell cell
cells 1023 for i draw -next ;
gen 1023 for i tick swap new ! -next 1023 for i new @ i old ! -next ;
loc row @ 32 * col @ + ;
cur loc dup old @ ff * ff0000 + color cell ;
back black screen 303010 color 40 40 at 583 dup box ;
g show back green cells gen keyboard ;
s gen show back blue cells cur keyboard ;
clear 1500 8 erase 16 row ! 16 col ! s ;
t loc old dup @ 1 xor swap ! ;
l -1 col +! col @ 31 and col ! ;
u -1 row +! row @ 31 and row ! ;
d 1 row +! row @ 31 and row ! ;
r 1 col +! col @ 31 and col ! ;
h pad nul nul cfex nul nul nul nul nul l u d r nul nul nul nul glide glid2 glid3 glid4 clear s g t nul nul nul nul 2500 , 0 , 110160c , 0 , 1c1b1a19 , 20d0815 , 0 , clear glide g h

s stop
g go
t toggle the square
ludr left up down right
. press s to stop then draw a shape using ludr and t to toggle
. then press g to go or s to single step
1234 create gliders which move to the four corners counting clockwise from the top left

conways game of life row 16 col 16
old 1500 block + ;
new 1504 block + ;
nul ;
pos swap 32 /mod swap ;
val 32 * + swap over old @ 1 and + ;
up pos swap 31 + 31 and val ;
dn pos swap 1 + 31 and val ;
lt pos 31 + 31 and swap val ;
rt pos 1 + 31 and swap val ;
n 0 ;
s dup old @ 1 and ;
y 1 ;
tick dup 0 up lt dn dn rt rt up up nip jump n n s y n n n n n
adj swap 17 * 40 + ;
st rc- col @ + swap row @ + 32 * + old 1 swap ! ;
glide 0 2 st 0 1 st 0 0 st 1 0 st 2 1 st ;
glid2 0 0 st 0 1 st 0 2 st 1 2 st 2 1 st ;
glid3 0 2 st 1 2 st 2 2 st 2 1 st 1 0 st ;
glid4 0 0 st 1 0 st 2 0 st 2 1 st 1 2 st ;

app: wave audio sb, 8 bit, mono, no dma empt macro
pb@ 0 ec 1, ;
pb! ee 1, drop ;
/8 8f8c1 3, ; forth
+base 220 + ; *
?rd e +base a!
*?rd pb@ 80 ? drop if ; then *?rd ;
?wr c +base a!
*?wr pb@ 80 ? drop if *?wr then ;
dsp@ ?rd a +base a! pb@ ;
dsp! ?wr pb! ;
?init dsp@ aa or drop if ?init ; then ;
0dsp 6 +base a! 1 pb! 30 for pb@ drop next 0 pb! ?init d1 dsp! ; 0dsp
*dac! 10 dsp! dup dsp! /8 ;
dac! *dac! *dac! *dac! *dac! drop ;
length 2 + dup -1 + @ 2/ 2/ ;
?data dup @ 61746164 or drop if length + ?data ; then length ;
sound 100 block 3 + ?data ; *
play for dup @ dac! 1 + next drop ;

pb@ -n get byte from port
pb! n- put byte to port
/8 n-n shift 8 bit right
+base n-n add base adress
?rd wait for dsp read ready
?wr wait for dsp write ready
dsp@ -n read dsp
dsp! n- write dsp
?init wait until initialized
0dsp reset 3 us dsp, turn on speaker
dac! n- write 4 byte to dac
length a-an return length of record
?data a-an search data record
sound -an return address and length of sound data
play an- play sound

app: colorforth explorer empt 208 load strt -2 last 50176
?sze a- dup 256 block - drop ;
crs n- ?f if for cr next ; then drop ;
up1 a-a ?sze +if ; then 100 + dup @ fffffff0 and 5c58bc80 - drop 0if dup last ! ; then up1 ;
.line a- ?sze +if drop ; then cr dup 100 / . 4 for 1 + dup @ .word next drop ;
upn n-a ?f if 0 swap for up1 next ; then 0 ;
lines strt @ negate 0 max crs strt @ 0 max upn 16 strt @ negate 0 max - ?f if for up1 blue dup .line next then drop drop ;
jok show 444444 color screen 240 0 at r@ 100 / block 4 for 1 + dup @ .word next drop 0 color 0 266 at 1023 296 box 0 0 at lines keyboard ;
go strt @ 9 + upn 100 / noshow ld ;
md strt @ 1 - -8 max strt ! ;
mu strt @ 1 + 256 min strt ! ;
??
jed strt @ 9 + upn 100 / dup blk ! ed ;
jh pad nul accept go nul jed nul nul ?? nul nul nul nul md nul nul mu nul nul nul nul nul nul nul nul nul nul nul nul 0 , 2f000004 , 0 , 2b000023 , 0 , 0 , 0 , jok jh

scans the first cell of each block for app: and displays the first 4 words after app:
+
- step through the applications
? displays the applications first shadow block
o loads the application
. requires .word from the editor

app: floppy driver macro
- 35 1, ffffffff , ;
delay e1e6 2, ;
p@ a! dup ec 1, delay ;
p! a! ee 1, delay drop ;
1@ 8a 2, ;
1! a! 288 2, drop ; forth
on 1c 3f2 p! ;
off 0 3f2 p! ;
err -if off warm ; then drop ;
msr 3f4 p@ c0 and ;
out 100000 for msr 80 or drop if *next 0 - ; then 3f5 p! pop drop 0 ;
in 100000 for msr c0 or drop if *next 1 - ; then 3f5 p@ pop drop 0 ;
cmd for out err next ;
conf 0 70 0 13 4 cmd ;
spec 3 a2 3 3 cmd ;
sense 8 1 cmd ; nload off

- ones complement, sets flags
delay dummy write, some hardware seems to need this
on - activate floppy
off - turn motor off, reset fdc
err n - warm start if sf set
msr - n get main status register
out n - ? write a byte to the fifo, return error on timeout
in - n ? read a byte from the fifo, return error on timeout
cmd x n - send n bytes to the fifo
conf - some fdc commands,
spec -
sense - see documentation for details

clrfifo in -if drop ; then drop drop clrfifo ;
clrintr sense in err 80 and drop if clrfifo ; then clrfifo clrintr ;
wait sense in err 80 and drop if clrfifo wait ; then clrfifo ;
cal 0 7 2 cmd wait ;
reset /flop 3 a2 3 3 cmd 0 70 0 13 4 cmd ;
init on pause spec conf clrintr cal ;
xfer for in err over 1! 1 + next drop ;
rd init push ff 1b 12 2 1 0 pop 0 e6 9 cmd block 4 * 400 12 * xfer off ;
readid 0 4a 2 cmd 7 for in err next clrintr ;
version 10 1 cmd in err 90 or drop if 2 - ; then 0 ;

clrfifo - discard all remaining input from the fifo
clrintr - clear all pending interrupts
wait - wait for interrupt
cal - calibrate: move head to track 0
reset - put fdc back to original state
init - initialize controller
xfer a n - reads n bytes from the fifo to byte address a
rd b c - reads cylinder c to block b
readid for debugging
version - ? tests if your fdc supports enhanced commands

bluetoken test test all tokens
tok t-n 11110000 + ;
loc 2000 block ;
set 10 for i 1 - tok loc i + ! next 9 tok loc ! 0 loc 17 + ! loc dump ; set

colours empt pos 15
coll rgb- pos @ 18 * dup dup 100 * swap 10000 * + swap + f8f8f8 and color ;
tab string 0 1, 0 1, 0 1, 111111 , 222222 , 333333 , 444444 , 555555 , 666666 , 777777 , 888888 , 999999 , aaaaaa , bbbbbb , cccccc , dddddd , eeeeee , ffffff , cl 16777215
coll pos @ 1 + 4 * tab + 4 / @ dup cl ! f8f8f8 and color ;
sq col- coll pos @ 64 * dup 32 + 128 at 1 pos +! 92 + 512 box ;
ok show 0 color screen 0 pos ! 15 for sq next keyboard ;

app: timer interrupt empt ticks 4444 interrupts 124 load
!pit 34 43 p! lo a9 40 p! hi 4 40 p! ; !pit
pic1! 21 p! ;
pic2! a1 p! ;
!pic cli init 11 dup 20 p! a0 p! irq 20 pic1! 28 pic2! master 4 pic1! slave 2 pic2! 8086 mode 1 dup pic1! pic2! mask irqs ff pic2! fa pic1! ; !pic 20 interrupt
timer0 forth: 1 ticks +! clear ;forth i; sti
test cli 0 ticks ! 1 secs sti 100 secs cli ;
tm cli 0 ticks ! sti 1000 ms cli ; lblk @ edit

timer interrupt
!pit sets up the programable interval timer to 1 khz for a 1 ms tick
. for a clock of 14.31818 / 12 or 1.19318167 mhz +/- 400 hz this is actually 0.99985 +/- 0.0004 ms or about 0.015 percent fast.
pic1! write an octet to interrupt controller 1
pic2! write an octet to interrupt controller 2
!pic sets up the pic chips
. 20 interrupt is the timer interrupt
timer0 the forth code to run every timer tick
. use sti to enable interrupts, cli to disable
test run a 100 second test to time the timer interrupt with respect to the real time clock.
tm measure cpu ms in timer ticks

sounds jmk tempo 20 mute 0 period 1807
tn ft- tempo @ * swap 660 50 */
hz tf- push 1000 1193 pop */
osc tp- dup period ! split 42 p! 42 p!
tone t- mute @ 0 + drop if drop ; then 4f 61 p! ms 4d 61 p! 20 ms ;
click 1 90 osc ;
t 3 tn ;
q 8 tn ;
c 16 tn ;
2tone 75 q 50 q ;
h1 50 c 54 q 50 q 45 c 60 c ;
h2 40 c 45 q 50 q 50 c 45 c ;
h3 54 c 60 q 54 q 50 c 45 q 40 q 50 t 45 t 50 t 45 t 45 12 tn 40 q 40 32 tn ;
hh
handel h1 h2 h3 ;
piano 55 7 for dup q 3 2 */ next drop ;
cetk 6 c 10 c 8 c 4 c 6 32 tn ;
bomb mute @ 0 + drop if ; then 4f 61 p! 500 for 1000 i - + split 42 p! 42 p! 1 ms next 4d 61 p! 1 32 tn ; 2tone jmt

app: test block : empt 208 load strt -3 lstup 52736
sze 256 block ;
crs n- ?f if for cr next ; then drop ;
up1 a-a dup sze - drop +if ; then 100 + dup @ fffffff0 and 5c58bc80 - drop 0if dup lstup ! ; then up1 then ;
.line a- dup sze - drop +if drop ; then cr dup 100 / . 4 for 1 + dup @ .word next drop ;
upn n-a ?f if 0 swap for up1 next ; then 0 ;
lines strt @ negate 0 max crs strt @ 0 max upn 16 for up1 blue dup .line next drop drop ;
ok show 444444 color screen 240 0 at r@ 100 / block 4 for 1 + dup @ .word next drop 0 color 0 266 at 1023 296 box 0 0 at lines keyboard ;
go strt @ 9 + upn 100 / ld xx ;
md strt @ 1 - -8 max strt ! ;
mu strt @ 1 + 256 min strt ! ;
?? strt @ 9 + upn 100 / 1 + lst xx ;
h pad nul nul accept nul go nul nul ?? nul nul nul nul md nul nul mu nul nul nul nul nul nul nul nul nul nul nul nul 0 , 2f000003 , 0 , 2b000023 , 0 , 0 , 0 , ok h

saving and restoring the dictionary
. allows just-in-time compilation
. the code for 2tone only exists for as long as it is needed

serial terminal empt 52 load 48 load char 65 qchar 0 pos 0
- nn-n negate + ;
0eq n- ?f if 0 0 + drop ; then 1 0 + drop ;
0neq 0 + drop ;
eq nn- - 0eq ;
crr pos @ 1e + ffff and pos ! ;
cls black screen 0 pos ! ;
act qchar @ 0eq if ; then pos @ 10000 /mod swap at blue char @ chc emit xy @ pos ! char @ 13 eq if crr then char @ 12 eq if cls then 0 qchar ! ;
wait pause qchar @ 0neq if wait then ;
ch c- rkey? if rkey ff and char ! -1 qchar ! then ;
ok c cls act 0 pos ! show ch act 0 650 at 202020 color 1024 768 box keyboard ;

the next two blocks are a 256 character 8*8 pixel font
. display characters statically on the screen
. type ok then 65 ch 13 ch 66 ch

;is ??v8;is??d;is
;iso ;isovs 49344 ;iso:s:@,r8ov-v8 ,i-:8 1061097231 ;is; ;iso:s ;is;isdndn is; ;iso:s ;is;isdndn is;
;iso ;isovs -252645136;is;is ;is?@ ?@ ;is;isdn ov8od??,r8 dndn ;is?@ o o;is;isdn is; ;iso:so:?v8;isdndn is; ;iso:so:?v8;isdn;is;iso is;o o o nbno 0 nq:fo 7105790imsr;n o @ 416073216 boors 3b1c361 inuns 12607584 3030180 rsn drso n d 30180?ybo nno -63950848 o on o o, o o 25215072 srsrs 7ninoos 8185590o o i o ,rso 1c06663 ,nno 1c06663 imy -865321956 r8nis qb od 7916556 ffc60301 imyo 403492092 o o o 3c66663 imyo 2093796472 i rs 3158016 o o o on o o fe030180 rsn d , , dddd 30180 c06663 o o 7n+rys 7913694unnodd unnis 2087085820 516915 dn oors 3958464 3333367 508771 is0nt; 520979 is0nt; 492291 dn oors 4089550 ,nnnnn 13421772 1818183 isn n dn n s imyo 2020370150 -ooo 1616929008 -16847162 63636 -17320138 bnon fe363361 115558 ibooois 15753312 fe666663 rbbe 2087085820 -ooo 1893780600 imy e 808498428 isn n unnnnn 7916748 unnnnn 3176652 -21613002 biiis 29582902 63361 imyooo 7876656 rmryrws 60606078 isdnrsn dd t n 404232312 3c0c0bonrde?s rsn n bd inuos 2086691040 451379uod imyo idn n s 7785676uod imsod -262116296 ;o ouof @ no- 1986814176 471859o i o isn n dn 2026687500nboo i 73363o o o i isn n?nn bnf;uid unnn -864550912 imyo 1725693952 -8191005uof r8no- 1994129408 492291do8 7c063o ivsr rsnsdunn inun -859045888 o ims -691666944 nq+dnuo 63361unn @ no- -1728315392 ,otrs 8rso r 1847344 c0c0 c0c0rvso 8 8rso 6e3nvde 521782

;is; ;is ov8od ;is ; ;isovs 49344 ,i-?8 o:s ov8;n 61680 ;is; ?@ ;is ;isovs 65535;is ;is;is o:s;is;is dn ?@
o ;is,is 64764;is o:s;is;is dn;is;is o:s;is;is dn ;is; ;;is;is o:s;is;is dn o o o:sdn is; ???? ???? qv8@ ?-?@
?hjit ????
cn otit ?hjn s-@r8
?-d? -yooy8 ?yyoos momjis
?peue ?y@,e ???? y:,i; ?::: -::: ?q:, vuid
??-os oq-, ??:@ ???? y@,i@ o??, ???? ???? ?-:? q:,i8 ?w:,e
troroy ?dbt q-9@ ?soq8 b@ui ?soooc b@ui
?vui8
oocis@ ?;iu
:sio;
?vui8 io@?
?vunn
-@un ?-:@ s-ooos
?vunn snnnni
?b@? ?-:? ?-:? ?-:? y@,i@ o@?o@ ?::: ?so?@ ??di8 :::: ?q:, -@ui ?-?@
trtroy ?vqj oooos@
?yooo
siooot ?soyot
o:,ni ?8-tn yoootn ?sicit s:iyl ?sryfe s:iyl ?s@,e
o:,ni ?8nned
oooooo
?yoooo q-:; ?v:@ :@,id
?vunn s:oytt
?myoot y:@@ ?sryot r rrro ?ycite tr cotn ?ycitn ociotis ?9jnn
siooot ?s@,e oooooos
?;8j
siooot
?myoot m9:ys
?vuid
q-1n ?v:@
ooooooo
?soooo
ooooooo
?-8- tcititn ?yctt bhqtn ?yytis
s-oooo ?v:@ -wooc ?sryos y:@, ?v-: ----
??i-8 -:@; ?v@, oytim@ ???? ???? ??, ?::@ ???? :v??
?peq sio:;s ?coyot oos??s ?vunn
si-:;
?peun oos??s
?vq8 @,e; ?s@,e oomo?;
i:du motio9 ?myoot qb?@ ?v:@
:@??
s-ooo; ciooo9 ?myti q-:; ?v:@ roo?@ ?ycat oo i?@
?yoooo oos??s
?vunn ytei?; @, j oomo?;
8@8nn mtei?; ?s@,e o@r?, ?si:d qd:, ?::is oooo?@
?peun oooo?@
?-8- tcio?; ?hdt cnio?; ?yytis oooo?@
i:du ni o?@ ?soyis
r,i-@ ?;:@ ?:@, ?:@, 9-:9 ?m,i8 ??hi ???? cim*? ?srocn

o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o

32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32 32
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o
o

o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35 35

1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o o