5 *TV255
   10 MODE7
   20 *FX21
   30 VDU23,1,0;0;0;0;
   31 title0$="                      "
   32 title1$="     w3____p p 00     "
   34 title2$="     5 *z:jzj jjj     "
   36 title3$="    |||||||||||||     "
   40 B=132
   50 C1=145:C2=147
   60 C3=131:C4=129:F3=C3:F4=C4
   70 C5=129:C6=131
   80 REPEAT:VDU(30)
   90 IF F3=C3 F3=C4 ELSE F3=C3
  100 IF F3=C3 F4=C4
  110 IF F3=C4 F4=C3
  120 PRINTCHR$(B)CHR$(157)
  130 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"
  140 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"
  150 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*  "CHR$(156)CHR$(C2)title0$CHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"
  160 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*  "CHR$(156)CHR$(C2)title0$CHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*"
  170 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*  "CHR$(156)CHR$(C2)title1$CHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"
  180 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*  "CHR$(156)CHR$(C2)title2$CHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*"
  190 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*  "CHR$(156)CHR$(C1)title3$CHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"
  200 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*";"                            "CHR$(F4)"*"CHR$(F3)"*"
  210 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"CHR$(C6)"     1...Run Program       "CHR$(F3)"*"CHR$(F4)"*"
  220 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*";"                            "CHR$(F4)"*"CHR$(F3)"*"
  230 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"CHR$(C6)"     2...Display Source    "CHR$(F3)"*"CHR$(F4)"*"
  240 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*";"                            "CHR$(F4)"*"CHR$(F3)"*"
  250 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"CHR$(C6)"     3...How To Forth      "CHR$(F3)"*"CHR$(F4)"*"
  260 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*";"                            "CHR$(F4)"*"CHR$(F3)"*"
  270 PRINTCHR$(B)CHR$(157)CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"
  280 PRINTCHR$(B)CHR$(157)CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"CHR$(F4)"*"CHR$(F3)"*"
  290 PRINTCHR$(B)CHR$(157)
  300 RESTORE
  310 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  330 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  350 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  370 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  390 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  410 READ A$:PRINTCHR$(B)CHR$(157)CHR$(C6)A$
  430 PRINTCHR$(B)CHR$(157);
  440 A$=INKEY$(2)
  450 IF ASC(A$)<0 A$=" "
  460 UNTIL INSTR("123",A$)
  470 :
  472 IF A$="1":OSCLI"EXEC FORTHLD":END
  480 IF A$="2":F$="worm"
  490 IF A$="3":F$="Ftext"
  500 :
  510 DATA"            Forth 79               "
  522 DATA"           ----------              "
  564 DATA"                                   "
  565 DATA"                                   "
  566 DATA"                                   "
  567 DATA"                                   "
  570 :
  572 buffer=&4000
  574 bufsize=&3000
  580 HIMEM=buffer
  590 DIMcode 400,scr%(20)
  600 ONERROR RUN
  610 *FX4,1
  620 PROCassemble
  630 REMPROCfile
  650 F%=OPENIN F$
  660 REM"Colour toggles on c
  670 ?&74=1:?&72=130
  680 B%=&900:times%=0:back%=0:new%=0
  690 div=EXT#F%/100
  700 :
  710 REPEAT
  720 new%=1:PROCld
  730 REPEAT
  740 start%=G%:?&73=0:scol%=?&72
  750 REPEAT
  760 CALL gline
  770 UNTIL ?&73=24 OR G%>=T%
  780 IF ?&73<>24:REPEAT:PRINTSTRING$(40," ");:?&73=?&73+1:UNTIL ?&73=24
  790 depth=(bufsize*(times%-1)+G%-buffer)/div
  800 REPEAT
  810 PRINTTAB(0,24)CHR$(157)CHR$(132);
  820 IF depth<10 PRINT" ";
  830 IF depth<100 PRINT" ";
  840 PRINTSTR$(INT(depth))"%";
  850 IF EOF#F% AND G%>=T% PRINTCHR$(136)" Any Key Finishes or B,[  "; ELSE PRINT"  Any Key  [,],B,F or P    ";
  860 IFstart%=buffer:VDU7:E%=1:PRINT"(TOB) ";
  870 IFE%=0:IFG%>=T%:VDU7:E%=1:PRINT"(BOB) ";
  880 IFE%:E%=0 ELSE PRINT"      ";
  890 PRINTTAB(0,24);
  900 *FX21
  910 K%=GET:G$=CHR$(K%)
  920 IF K%=136 OR K%=139 PROCback1
  930 IF K%=137 OR K%=138 PROCforward1
  940 IFINSTR("Bb",G$) PROCjumpback
  950 IFINSTR("Ff",G$) PROCjumpforward
  960 IFINSTR("Cc",G$) PROCcolour
  970 IFINSTR("Pp",G$) PROCprtScreen
  980 UNTIL K%
  990 UNTILG%>=T%
 1000 UNTILEOF#F%
 1010 :
 1020 CLOSE#F%
 1030 *FX4,0
 1040 RUN
 1050 END
 1060 :
 1070 DEFPROCcolour
 1080 ?&74=?&74 EOR 1
 1090 IF ?&74 ?&72=130 ELSE ?&72=0
 1100 G%=start%
 1110 ENDPROC
 1120 :
 1130 DEFPROCcolminus
 1140 ?&72=?&72-1
 1150 IF?&72=132:?&72=131
 1160 IF?&72=129:?&72=134
 1170 ENDPROC
 1180 :
 1190 DEFPROCcolplus
 1200 ?&72=?&72+1
 1210 IF?&72=132:?&72=133
 1220 IF?&72=135:?&72=130
 1230 ENDPROC
 1240 :
 1250 DEFPROCld
 1260 IFback% times%=times%-1:PTR#F%=scr%(times%)
 1270 IFnew%:times%=times%+1:scr%(times%)=PTR#F%
 1280 IF EXT#F%-PTR#F%>(bufsize-1) H%=bufsize ELSE H%=EXT#F%-PTR#F%
 1290 PRINTTAB(0,24)CHR$(157)CHR$(132)" Loading Please Wait                ";TAB(0,24);
 1300 A%=4
 1310 X%=B% MOD 256
 1320 Y%=B% DIV 256
 1330 B%?0=F%
 1340 B%!1=buffer
 1350 B%!5=H%
 1360 CALL&FFD1
 1370 D%=0:back%=0:new%=0:G%=buffer:T%=G%+H%+D%
 1380 IF PTR#F%=EXT#F% ENDPROC
 1390 S%=&6FFF
 1400 REPEAT
 1410 D%=D%+1
 1420 S%=S%+1
 1430 R%=BGET#F%
 1440 ?S%=R%
 1450 UNTIL?S%=13 AND ?(S%-1)=13
 1460 S%?1=&FF
 1470 T%=G%+H%+D%
 1480 ENDPROC
 1490 :
 1500 DEFPROCfile
 1510 REPEAT
 1520 *.
 1530 PRINT'"Filename :";
 1540 INPUT F$
 1550 IF LEFT$(F$,1)="*" OSCLI+F$
 1560 UNTILLEFT$(F$,1)<>"*"
 1570 ENDPROC
 1580 :
 1590 DEFPROCback1
 1600 IFstart%=buffer:IFtimes%>1:G$="B":ENDPROC
 1610 IFstart%=buffer:K%=0:ENDPROC
 1620 ?&72=scol%
 1630 IF?&74:IF?start%=13:PROCcolminus
 1640 VDU30:G%=start%-1
 1650 REPEAT:G%=G%-1:UNTIL ?G%=13 OR G%=&3000
 1660 IF G%<>buffer:G%=G%+1
 1670 ENDPROC
 1680 :
 1690 DEFPROCforward1
 1700 IFG%>=T%:G$="F":ENDPROC
 1710 ?&72=scol%
 1720 VDU30:G%=start%-1
 1730 REPEAT:G%=G%+1:UNTIL ?G%=13
 1740 G%=G%+1
 1750 IF?&74:IF ?G%=13 PROCcolplus
 1760 ENDPROC
 1770 :
 1780 DEFPROCjumpback
 1790 IFG%<=(buffer+&600) AND times%=1:G%=buffer:ENDPROC
 1800 IFG%>(buffer+&600):G%=G%-&600:REPEAT:G%=G%-1:UNTIL ?G%=13 OR G%=buffer:ENDPROC
 1810 back%=1
 1820 PROCld:G%=&6A00:REPEAT:G%=G%-1:UNTIL ?G%=13
 1830 ENDPROC
 1840 :
 1850 DEFPROCjumpforward
 1860 IFG%>(T%-&380):ENDPROC
 1870 G%=G%+&300
 1880 REPEAT:G%=G%+1:UNTIL?G%=13
 1890 ENDPROC
 1900 :
 1910 DEFPROCprtScreen
 1920 U%=start%:E%=0:cnt%=0:VDU2
 1930 REPEAT
 1940 REPEAT
 1950 A%=?U%
 1960 IFA%=141:E%=1
 1970 IFA%>126:A%=32
 1980 IFA%>31:VDU1,A%
 1990 U%=U%+1
 2000 UNTIL?U%=13 OR U%>T%
 2010 IFE%:REPEAT:U%=U%+1:UNTIL?U%=13:cnt%=cnt%+1:VDU1,13:E%=0
 2020 cnt%=cnt%+1:VDU1,13
 2030 UNTILcnt%=24 OR U%>T%
 2040 VDU1,13,3:K%=0
 2050 ENDPROC
 2060 :
 2070 DEFPROCerror
 2080 CLOSE#F%
 2090 *FX4,0
 2100 PRINT
 2110 ENDPROC
 2120 :
 2130 DEFPROCassemble
 2140 FOR I%=0 TO 2 STEP 2
 2150 P%=code
 2160 [OPTI%
 2170 .gline
 2180 LDX &74:STX &76
 2190 LDA &72:JSR &FFEE
 2200 .loopa
 2210 JSR get
 2220 CMP #13:BEQ a2
 2230 CMP #126:BCS a1
 2240 CMP #32:BCC a1
 2250 JSR &FFEE:INC &76
 2260 .a1
 2270 LDX &76:CPX #40:BNE loopa
 2280 INC &7F
 2290 .a2
 2300 LDX &74:BEQ a3
 2310 JSR seeatg:CMP #13:BNE a3
 2320 LDX &7F:BEQ d2
 2330 LDA &404:PHA
 2340 JSR get:JSR seeatg
 2350 LDX &41C:BNE d1:DEC &41D
 2360 .d1
 2370 DEC &41C
 2380 TAX:PLA:STA &404
 2390 CPX #13:BNE a3
 2400 .d2
 2410 JSR chcol
 2420 .a3
 2430 LDX #0:STX &7F
 2440 LDA &404:CMP #13:BNE a4
 2450 LDA #32
 2460 .cloop
 2470 LDX &76:CPX #40:BEQ a4
 2480 JSR &FFEE:INC &76:BNE cloop
 2490 .a4
 2500 LDA &404:CMP #13:BEQ a5
 2510 CMP #32:BEQ a5:JSR back
 2520 .a5
 2530 INC &73
 2540 RTS
 2550 \ ******* subroutines ********
 2560 .get
 2570 LDX &41C:STX &80
 2580 LDX &41D:STX &81
 2590 LDY #0:LDA (&80),Y:STA &404
 2600 INC &41C:BNE g1:INC &41D
 2610 .g1
 2620 RTS
 2630 .seeatg
 2640 LDX &41C:STX &80
 2650 LDX &41D:STX &81
 2660 LDY #0:LDA (&80),Y
 2670 RTS
 2680 .chcol
 2690 INC &72:LDX &72
 2700 CPX #132:BNE c1
 2710 LDY #133:STY &72
 2720 .c1
 2730 CPX #135:BNE c2
 2740 LDY #130:STY &72
 2750 .c2
 2760 RTS
 2770 .back
 2780 JSR seeatg
 2790 CMP #32:BEQ b0
 2800 CMP #13:BNE b2
 2810 .b0
 2820 INC &41C:BNE b1:INC &41D
 2830 .b1
 2840 RTS
 2850 .b2
 2860 LDX &41C:STX &82:LDX &41D:STX &83
 2870 LDX #0:STX &75
 2880 .loopb1
 2890 LDY #2
 2900 .b3
 2910 LDX &41C:BNE b4:DEC &41D
 2920 .b4
 2930 DEC &41C:DEY:BNE b3
 2940 JSR get:INC &75:DEC &76
 2950 CMP #32:BEQ b6
 2960 LDX &76:CPX &74:BNE loopb1
 2970 .b5
 2980 LDX #0:STX &75
 2990 LDX &82:STX &41C
 3000 LDX &83:STX &41D
 3010 JSR seeatg:CMP #13:BNE b6
 3020 INC &41C:BNE b6:INC &41D
 3030 .b6
 3040 LDX &75:BEQ b7:LDA #127
 3050 .loopb2
 3060 JSR &FFEE:DEC &75:BNE loopb2
 3070 JSR &FFE7
 3080 .b7
 3090 RTS
 3100 ]NEXT:ENDPROC