Neat stuff from Falcor4's Hard drive image

[+acadiel]

I'll be putting tidbits from DC's HDD image (mostly BASIC programs or documents) in this thread as we find them. His whole drive dump, which Ksarul and I have, is 70 disks.

 

For the first one, here's a name that you all should know. Assembly Object to XB Call Load converter by Paolo Bagnaresi.

1 ! ACE : Assembly Object to   Extended Basic CALL LOADs    Converter      8/3/1984
2 !           By                   Paolo Bagnaresi            Tel.(02)-514.202      Address:
3 !  Via J.F. Kennedy 17      20097 San Donato Milanese        (Milan)- Italy
10 GOTO 40 :: DIM STDEF$(100) :: D$,N$,F$,DEF$,PB$,SC$,RI$,CT$,L$,HEX$,H$,DSC$,DECC$,PROG$
20 CALL LOAD :: CALL INIT :: CALL LINK :: CALL PEEK :: CALL CHAR :: CALL HCHAR :: CALL KEY
30 AUT,N,A,B,C,D,E,F,G,H,I,L,M,N,CT,MS,LS,DBM,DBL,FINELOC,LOC,INIZLOC,INDEF,NDEF,NLINK,NL,NLINE,NST,KY,ST,DEC,PO,Z
40 CALL CLEAR :: CALL SCREEN(16) :: FOR T=0 TO 14 :: CALL COLOR(T,13,16) :: NEXT T :: !@P-
50 CALL CHAR(128,"00282828",131,"000000FF") :: L$=RPT$(CHR$(131),28) :: H$="0123456789ABCDEF" :: CALL CLEAR
60 PB$="By Paolo Bagnaresi             Via J..F.. Kennedy 17         20097 San Donato Milanese   (Milan)- ITALY"
70 DISPLAY AT(1,1):L$:L$: : TAB (13);"ACE": : TAB (14);"by": TAB (7);"Paolo Bagnaresi": TAB (7);"Tel(02)-514..202":"San Donato Milanese-ITALY":L$
80 DISPLAY AT(11,1): TAB (10);"Assembly": TAB (10);"Converter to": TAB (10);"Extended":L$
90 DISPLAY AT(14,1):L$:"ACE converts the Object":"of an Assembly Program into":"an Extended Basic Program..":"The Assembly Program MUST be"
100 DISPLAY AT(19,1):"suitable for Extended Basic":"environment and MUST NOT":"contain any AORG..":L$
110 DISPLAY AT(24,6) BEEP :"Press any key"
120 CALL KEY(0,KY,ST) :: IF ST=0 THEN 120 ELSE CALL CLEAR
130 DISPLAY AT(1,1):L$: TAB (5);"Are the Assembly":"Objects already loaded ?": :"  Answer: (Y/N) N":L$
140 ACCEPT AT(5,17) SIZE(-1) VALIDATE ("YN") BEEP :RI$ :: IF RI$="" THEN 50 ELSE IF RI$="Y" THEN CALL CLEAR :: GOTO 370 ELSE N$="1" :: CT$="Y" :: GOSUB 900
150 DISPLAY AT(6,1):L$:"Insert the diskette with the":"assembly object and enter":"the object progr.. name": :"Name :  ";PROG$:L$
160 DISPLAY AT(22,1):L$:"erase and press ENTER if you": TAB (9);"are through"
170 ACCEPT AT(11,9) SIZE(-10) BEEP :PROG$ :: IF PROG$="" THEN CALL CLEAR :: GOTO 320
180 DISPLAY AT(13,1):"Disk Drive ? (1-3) ";N$:L$ :: ACCEPT AT(13,20) SIZE(-1) VALIDATE ("123") BEEP :N$ :: IF N$="" THEN 130
190 ON ERROR 360 :: CALL LOAD("DSK"&N$&".."&PROG$) :: ON ERROR STOP
200 DISPLAY AT(15,1):"Do you want to check the":"loaded program ? (Y/N) ";CT$:L$ :: ACCEPT AT(16,24) SIZE(-1) VALIDATE ("YN") BEEP :CT$ :: IF CT$="N" THEN 150
210 DISPLAY AT(18,1):"Does the program come back":"to Extended Basic ? (Y/N) Y":L$ :: ACCEPT AT(19,27) SIZE(-1) VALIDATE ("YN") BEEP :SC$
220 IF SC$="Y" THEN 240 ELSE FOR T=1 TO 10 :: DISPLAY AT(21,1) BEEP :"In this case no check":"is possible ":L$:L$
230 FOR I=1 TO 100 :: NEXT I :: CALL HCHAR(21,1,32,96) :: NEXT T :: GOTO 150
240 CALL PEEK(8196,A,B) :: NST=0 :: INDEF=A*256+B :: FOR T=16376 TO INDEF STEP -8 :: NL=T :: GOSUB 870 :: NST=NST+1 :: STDEF$(NST)=DEF$ :: NEXT T
250 CALL CLEAR :: A=0 :: D$="1"
260 DISPLAY AT(1,1):L$:"List of DEFS to choose from":"for checking pourposes":L$
270 FOR T=5 TO 20 STEP 2 :: FOR Z=1 TO 19 STEP 9 :: A=A+1 :: DISPLAY AT(T,Z) BEEP :A;STDEF$(A) :: IF A>=NST THEN 280 ELSE NEXT Z :: NEXT T
280 DISPLAY AT(T+1,1):L$ :: DISPLAY AT(20,1):L$:"DEF No.. ? (1 -";NST;") ":L$:"Press ENTER when finished":L$ :: ACCEPT AT(21,21) VALIDATE (DIGIT) SIZE(-2) BEEP $ :: IF D$<>"" THEN 340
290 CALL CLEAR :: DISPLAY AT(1,1):L$:"Are the programs loaded": :"so far OK.. ? (Y/N) Y":L$ :: ACCEPT AT(4,20) VALIDATE ("YN") SIZE(-1) BEEP :SC$ :: IF SC$="Y" THEN 320
300 DISPLAY AT(6,1):L$:"Unfortunately in this case": :"it's not possible to": :"eliminate just one program": :"but it's necessary to load"
310 DISPLAY AT(15,1):"all the program(s) all ": :"over again..": :"OK? (Y) Y":L$ :: ACCEPT AT(19,9) VALIDATE ("Y") SIZE(-1) BEEP :SC$ :: CALL INIT :: CALL CLEAR :: GOTO 150
320 DISPLAY AT(6,1):L$:"Are all the programs": :"loaded already ? (Y/N) Y":L$ :: ACCEPT AT(9,24) VALIDATE ("YN") SIZE(-1) BEEP :SC$
330 IF SC$="N" OR SC$="" THEN CALL CLEAR :: GOTO 150 ELSE 370
340 A=VAL(D$) :: IF A>NST THEN 280 ELSE CALL LINK(STDEF$(A)) :: GOTO 250
350 ! Error handling
360 FOR T=1 TO 8 :: DISPLAY AT(20,1) BEEP :L$: TAB (6);"Drive error or": TAB (6);"Program name error":L$:L$ :: FOR I=1 TO 100 :: NEXT I :: CALL HCHAR(20,1,32,128) :: NEXT T :: RETURN 150
370 CALL CLEAR
380 ON ERROR 400 :: CALL PEEK(8194,A,B,C,D) :: FINELOC=A*256+B :: NL,INDEF=C*256+D :: GOSUB 870 :: IF ASC(DEF$)=255 THEN 400 ELSE INIZLOC=DBM*256+DBL
390 ON ERROR STOP :: GOTO 430
400 CALL CLEAR :: FOR I=1 TO 10 :: DISPLAY AT(10,1) BEEP :L$:L$:"  The Assembly Programs": :"   have not been loaded": : TAB (10);"LOAD THEM!":L$:L$
410 FOR T=1 TO 100 :: NEXT T :: CALL HCHAR(12,1,32,160) :: NEXT I :: GOSUB 900 :: GOTO 150
420 !Disk-printing routine
430 CALL CLEAR :: GOSUB 790 :: IF F$="" OR N$="" THEN 32767 :: ON ERROR 840 :: GOSUB 920 :: OPEN #2:"DSK"&N$&".."&F$,VARIABLE 163 :: ON ERROR STOP :: N=0
440 !Address of the programmer
450 PRINT #2:CHR$(0)&CHR$(N)&CHR$(131)&CHR$(199)&CHR$(LEN(PB$))&PB$&CHR$(0) :: N=1 :: GOSUB 940
460 !Insert CALL INIT
470 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"INIT"&CHR$(0) :: N=2 :: LOC=INDEF :: GOSUB 940
480 ! DEFs name printing
490 FOR NDEF=INDEF TO 16376 STEP 8
500 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(NDEF)))&STR$(NDEF);
510 FOR LOC=NDEF TO NDEF+6 STEP 2
520 CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
530 NEXT LOC
540 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: NEXT NDEF
550 !Print DEF pointer and FFALM
560 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(8194)))&STR$(8194);
570 FOR LOC=8194 TO 8196 STEP 2
580 CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
590 NEXT LOC
600 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: LOC=9460
610 ! Main program printing
620 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LOAD"&CHR$(183)&CHR$(200)&CHR$(LEN(STR$(LOC)))&STR$(LOC);
630 FOR LOC=LOC TO LOC+20 STEP 2
640 IF LOC>FINELOC THEN 670 :: CALL PEEK(LOC,MS,LS) :: PRINT #2:CHR$(179)&CHR$(200)&CHR$(LEN(STR$(MS)))&STR$(MS)&CHR$(179)&CHR$(200)&CHR$(LEN(STR$(LS)))&STR$(LS);
650 NEXT LOC
660 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940 :: N=N+1 :: IF LOC<=FINELOC THEN 620 ELSE 680
670 PRINT #2:CHR$(182)&CHR$(0) :: GOSUB 940
680 N=N+1
690 ! CALL LINK printing
700 FOR NLINK=INDEF TO 16376 STEP 8 :: NL=NLINK :: GOSUB 870
710 PRINT #2:CHR$(0)&CHR$(N)&CHR$(157)&CHR$(200)&CHR$(4)&"LINK"&CHR$(183)&CHR$(199)&CHR$(LEN(DEF$))&DEF$&CHR$(182)&CHR$(0) :: GOSUB 940
720 N=N+1 :: NEXT NLINK
730 PRINT #2:CHR$(255)&CHR$(255) :: CLOSE #2
740 CALL CLEAR :: DISPLAY AT(5,1) BEEP :L$:"The assembly program ";DEF$: :"has been recorded as a": :"DIS/VAR 163 file.. The name": :"of this file is ";F$:L$
750 DISPLAY AT(14,1):"You can MERGE this file": :"and obtain an Ext..B..Program":L$:"Execute now in command mode:": :">NEW":">MERGE DSK";N$;"..";F$
760 FOR T=1 TO 70 :: DISPLAY AT(23,1) BEEP :">SAVE DSK";N$;"..";SEG$(F$,1,LEN(F$)-3)&"EXT":L$ :: CALL KEY(0,KY,ST) :: IF ST<>0 THEN STOP
770 NEXT T :: END
780 ! Open file: disk drive & name selection
790 DISPLAY AT(1,1):L$:"Name of the last DEF":"of the  assembly programs": :"loaded in memory : ";DEF$:L$
800 F$=DEF$&"MRG" :: DISPLAY AT(8,1):L$:"proposed name for the file": :"Max 10 characters ";F$: :L$ :: ACCEPT AT(11,19) SIZE(-10) BEEP :F$
810 IF F$="" THEN RETURN ELSE IF POS(F$," ",1)>0 OR POS(F$,"..",1)>0 THEN 800
820 DISPLAY AT(14,1):L$:"Disk Drive? (1-3) ";N$:L$ :: ACCEPT AT(15,19) VALIDATE ("123") SIZE(-1) BEEP :N$ :: RETURN
830 ! Sub file error
840 ON ERROR 850 :: CLOSE #2
850 RETURN 430
860 ! call peek DEF names
870 CALL PEEK(NL,E,F,G,H,I,L,DBM,DBL) :: DEF$=CHR$(E)&CHR$(F)&CHR$(G)&CHR$(H)&CHR$(I)&CHR$(L)
880 PO=POS(DEF$," ",1) :: IF PO>0 THEN DEF$=SEG$(DEF$,1,PO-1) :: RETURN ELSE RETURN
890 ! Sub CALL INIT once only
900 IF CT=1 THEN RETURN ELSE CALL INIT :: CT=1 :: RETURN
910 ! Sub # of necessary printings
920 NLINE=ABS(INT(-((FINELOC-9460)/22+(16384-INDEF)/4+3))) :: DISPLAY AT(17,1) BEEP :"The necessary Printing":"operations with Disk Drive": :"(max 172) will be";NLINE:L$
930 IF NLINE>172 THEN FOR T=1 TO 10 :: FOR I=1 TO 90 :: NEXT I :: CALL HCHAR(23,1,32,32) :: DISPLAY AT(22,1) BEEP :L$:"OBJECT SIZE IS TOO  LARGE":L$ :: NEXT T :: STOP ELSE RETURN
940 NLINE=NLINE-1 :: DISPLAY AT(21,1):L$:"# of printings yet to be":"executed will be";NLINE:L$ :: RETURN

[+acadiel]

And another fun one. Typewriter by Extended Software Company.

100 CALL CLEAR :: CALL CHAR(127,"186699A1A1996618") !COPYRIGHT 1981,82,83 EXTENDED SOFTWARE CO.
110 DISPLAY AT(12,2):"Extended Software Company":" 11987 Cedarcreek Drive":" Cincinnati, Ohio 45240" :: DISPLAY AT(23,2):". 1981 VERSION 3..6" :: C$="TYPWRITER"
114 FOR A=28 TO 11 STEP -1 :: B=B+1 :: CALL SOUND(-9,-5,5) :: DISPLAY AT(8,A):SEG$(C$,1,B) :: NEXT A :: !CALL INIT :: CALL LOAD(-31878):: NL=280 :: DIM A$(286)
120 !CALL INIT :: CALL LOAD(-31878):: NL=280 :: DIM A$(286)
122 NL=120 :: DIM A$(126)
130 CALL KEY(5,K,E) :: FOR Z=97 TO 131 :: READ Z$ :: IF Z<123 THEN CALL CHAR(Z,"0000"&Z$) ELSE M$(Z-122)=Z$
150 NEXT Z :: F$=RPT$(" ",150) :: @,G0,G1,G2=1 :: G3=10 :: G4,G5=60 :: @2=2 :: @3=3 :: @4=4 :: @5=5 :: @6=6 :: @9=9 :: @A=21 :: @B=200 :: @0=20 :: FOR R=@ TO 12 :: CALL COLOR(R,@2, :: NEXT R
180 ON BREAK NEXT :: GOTO 500 :: CALL SCREEN :: CALL GCHAR :: CALL HCHAR :: CALL VCHAR :: CALL ERR
190 B$(@),D$,E$,G$,H$,I$,N$,P$,Q$,R$,S$,T$,W$,Z$="" :: _,C,D,F,G,H,I,J,L,M,N,O,P,Q,S,T,U,V,W,X=Y :: CO,D1,D2,L1,L3,LP,P1,P3,QQ,ST,SW=ZL
210 !@P-
500 CALL CLEAR :: CALL SCREEN(@5) :: ON ERROR 11000
510 DISPLAY AT(@3,@9):"TYPWRITER": : : TAB (@9);"MAIN MENU" :: FOR R=@ TO @6 :: DISPLAY AT(R+8,@):CHR$(R+48);"=";M$(R) :: NEXT R :: DISPLAY AT(18,@):"CHOICE?" :: R=18 :: N=6 :: GOSUB 10300 :: CALL CLEAR :: M=I :: DISPLAY AT(@,15):M$(M)
550 ON M GOTO 1000,2000,3000,4000,5000,7000
1000 V=@ :: GOSUB 10000 :: DISPLAY AT(@5,@):"CLEARING MEMORY..": : : :: FOR L=@ TO NL :: A$(L)="" :: NEXT L :: U,L=_ :: G$="" :: DISPLAY AT(@5,@):""
1020 D=@2
1030 CALL SCREEN(@6) :: DISPLAY AT(@,@):M$(;INT(L/@0)+@,M$(@) :: FOR D=D TO @A :: U=U+@ :: DISPLAY AT(D,@):;:"^^^^^^^^^^^^^^^^^^^^^^^^^^^^" :: ACCEPT AT(D,@):A$(U)
1070 CALL KEY(_,K,E) :: IF A$(U)="" THEN U=U-@ :: IF K=11 THEN 8000 ELSE 500
1110 NEXT D :: IF U>NL-@ THEN V=7 :: GOSUB 10000 :: GOTO 4000 ELSE DISPLAY AT(22,@):"" :: L=L+20 :: GOTO 1020
2000 G=_ :: CALL SCREEN(7) :: V=@2 :: GOSUB 10000 :: T$=M$(@2) :: IF G$="" THEN N$="CS1" ELSE N$=G$
2020 GOSUB 10200 :: G$=N$
2100 OPEN #@:G$,INPUT,INTERNAL,FIXED 192 :: FOR L=@ TO NL STEP @6 :: INPUT #@:A$(L),A$(L+@),A$(L+@2),A$(L+@3),A$(L+@4),A$(L+@5) :: CALL KEY(_,K,E) :: IF K=13 OR A$(L)=M$(@9) THEN 2170
2150 S=INT((L+@4)/20+@) :: DISPLAY AT(23,@):"S=";S;"L=";(L+@5)-20*(S-@) :: NEXT L
2170 FOR L=MIN(NL,L+@5) TO @ STEP -@ :: IF A$(L)<>"" AND A$(L)<>M$(@9) THEN U=L :: GOTO 2190
2180 NEXT L
2190 FOR R=U+@ TO NL :: A$(R)="" :: NEXT R :: CLOSE #@
2200 IF G=@6 THEN CALL SCREEN(2) :: L=@ :: GOTO 5140 ELSE 500
3000 D=@2 :: CALL SCREEN(@5) :: DISPLAY AT(@,@):"STARTING AT SCREEN#:" :: R=@ :: C=24 :: N=9 :: GOSUB 10310 :: L=@0*(I-@2) :: IF L>=U THEN 3000 ELSE CALL CLEAR :: DISPLAY AT(@,15):M$(@3) :: GOTO 8500
3010 GOSUB 10010 :: IF K>15 THEN 8500 ELSE 8000
4000 CALL SCREEN(13) :: T$=M$(4) :: IF G$="" THEN IF E$<>"" THEN N$=E$ ELSE N$="CS1" ELSE N$=G$
4010 GOSUB 10200 :: E$=N$ :: OPEN #@:E$,OUTPUT,INTERNAL,FIXED 192 :: FOR L=@ TO U STEP @6 :: CALL KEY(_,K,E) :: IF K=13 OR A$(L)="" THEN 4200
4150 PRINT #@:A$(L),A$(L+@),A$(L+@2),A$(L+@3),A$(L+@4),A$(L+@5) :: S=INT((L+@4)/@0+@) :: DISPLAY AT(23,@):"S=";S;"L=";L+@5-@0*(S-@),L;"OF";U :: NEXT L
4200 PRINT #@:M$(@9),M$(@9),M$(@9),M$(@9),M$(@9),M$(@9) :: CLOSE #@ :: GOTO 500
5000 CALL SCREEN(@2) :: SW,G,O,L3,B=_ :: R$="N" :: C$,D$="" :: IF F=@2 THEN F=_ :: CLOSE #F
5010 DISPLAY AT(@5,@):"WHAT TYPE PRINTER?":"1=RS232,PIO OR TP":"2=SCREEN":"3=FORMAT FOR TI-WRITER":;:;:"CHOICE? ";G0
5020 R=11 :: C=10 :: N=@ :: GOSUB 5307 :: G0=I :: IF I=@3 THEN F=@2 :: G=@5 ELSE IF I=@2 THEN F=_ :: GOTO 5050 ELSE F=@2 :: IF P$="" THEN N$="RS232" ELSE N$=P$
5040 T$=M$(@5) :: GOSUB 10200 :: P$=N$
5050 DISPLAY AT(@5,@):;:;:;:"BEGIN AT SCREEN #:";G1:"LINE #:";G2 :: DISPLAY AT(10,@):"# OF SPACES IN MARGIN:";G3:"# OF CHARACTERS/LINE:";G4:"# OF LINES/PAGE:";G5
5070 R=8 :: C=20 :: N=@2 :: GOSUB 5307 :: IF I>@6 THEN 5070 ELSE G1,S=I
5075 R=@9 :: C=@9 :: GOSUB 5307 :: IF I>@0 THEN 5075 ELSE G2=I :: L=I+@0*(S-@)
5080 R=10 :: C=24 :: GOSUB 5307 :: IF I>79 THEN 5080 ELSE G3,A=I
5085 R=11 :: C=23 :: N=@3 :: GOSUB 5307 :: IF I>227 THEN 5085 ELSE G4,Z=I
5087 R=12 :: C=18 :: GOSUB 5307 :: G5,LP=I :: DISPLAY AT(@,15):M$(@5) :: IF F=@2 THEN IF G=_ AND POS(SEG$(P$,@,@3),"TP",@)=_ THEN OPEN #F:P$,VARIABLE 254,OUTPUT ELSE OPEN #F:P$,OUTPUT
5140 DISPLAY AT(@0,@):M$(@9):">HOLD DOWN SPACE BAR TO HALT":G$:;:
5150 FOR L=L TO U :: CALL KEY(0,K,E) :: IF A$(L)="" OR (E=@ AND K=13) THEN 5310 ELSE IF K=32 THEN 5308
5160 S$=A$(L) :: S=INT((L-@)/@0+@) :: DISPLAY AT(@,@):,M$(M):"S=";S;"L=";L-@0*(S-@),L;"OF";U
5170 IF SEG$(S$,@,@)="@" THEN 5360
5230 IF O=@2 THEN C$=C$&S$ ELSE IF O=@ OR C$="" THEN C$=C$&S$ :: O=_ ELSE C$=C$&" "&S$
5240 IF LEN(C$)>Z-@ THEN GOSUB 5260
5250 NEXT L :: GOTO 5310
5260 FOR J=Z+@ TO @ STEP -@2 :: P=POS(C$," ",J) :: IF P>_ AND P<Z+@2 THEN 5290
5270 NEXT J :: P=Z :: GOTO 5290
5280 IF C$="" THEN RETURN ELSE IF LEN(C$)>Z THEN 5260 ELSE P=LEN(C$)+@ :: SW=@
5290 D$=SEG$(F$,@,A+B)&SEG$(C$,@,P-@) :: IF SW=_ AND R$="Y" THEN P1=@ :: GOSUB 32000
5292 PRINT #F:D$ :: C$=SEG$(C$,P+@,254) :: SW=_
5300 L3=L3+@ :: IF LEN(C$)>Z THEN 5280 ELSE IF F<>_ THEN DISPLAY AT(12,17):L3;"OF";LP
5302 IF L3>=LP THEN L3=_ :: GOSUB 10010
5305 RETURN
5307 ACCEPT AT(R,C) VALIDATE (DIGIT) SIZE(-N) BEEP :I$ :: IF I$="" THEN F=_ :: GOTO 500 ELSE I=VAL(I$) :: RETURN
5308 CALL KEY(_,K,E) :: DISPLAY AT(24,1):"HALTED - PRESS 'C' TO CONT.." :: IF E=1 THEN DISPLAY AT(24,1) :: GOTO 5150 ELSE 5308
5310 GOSUB 5280 :: IF F=@2 THEN F=_ :: CLOSE #@2
5320 GOTO 500
5360 W$=SEG$(S$,@2,@) :: W=POS("LPTCMNSAOJUD",W$,@) :: ON W GOTO 5400,5440,5460,5480,5490,5500,5510,5520,5530,5540,5560,5570
5400 GOSUB 5280 :: PRINT #F:"" :: GOSUB 5300 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5440 H$=SEG$(S$,@4,@B) :: DISPLAY AT(14,@):H$ :: ACCEPT AT(15,@) BEEP :S$ :: GOTO 5170
5460 Y=VAL(SEG$(S$,@3,@3))-@ :: IF O=_ THEN Y=Y-@
5465 IF LEN(C$)<=Y THEN C$=C$&SEG$(F$,@,Y-LEN(C$)) ELSE GOSUB 5280 :: C$=SEG$(F$,@,Y)
5470 S$=SEG$(S$,7,@B) :: GOTO 5170
5480 C$=SEG$(F$,@,INT((Z-LEN(C$)+@)/@2))&C$ :: GOSUB 5280 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5490 GOSUB 5280 :: B=VAL(SEG$(S$,@3,@2)) :: Z=VAL(SEG$(S$,@6,@3)) :: S$=SEG$(S$,10,@B) :: GOTO 5170
5500 GOSUB 5280 :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5510 Y=VAL(SEG$(S$,@3,@3)) :: C$=C$&CHR$(Y) :: S$=SEG$(S$,7,@B) :: GOTO 5170
5520 N$=SEG$(S$,@4,@B) :: G=@6 :: IF N$="R" THEN 2200 ELSE G$=N$ :: GOTO 2100
5530 O=@ :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5540 S$=SEG$(S$,@4,@B) :: IF R$="Y" THEN R$="N" ELSE R$="Y"
5550 GOTO 5170
5560 PRINT #F:SEG$(F$,@,A+B)&C$&CHR$(13); :: C$="" :: S$=SEG$(S$,@4,@B) :: GOTO 5170
5570 S$=SEG$(S$,@4,@B) :: IF O=@2 THEN O=_ ELSE O=@2
5580 GOTO 5170
7000 V,X=6 :: GOSUB 10000 :: END
8000 CALL SCREEN(10) :: DISPLAY AT(@,15):"EDIT MODE" :: DISPLAY AT(23,@2):"""BEGIN""";" TO CONTINUE TEXT" :: IF A$(L+D-@)="" THEN 8450
8010 CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K<@3 OR K>15 THEN 8010
8020 ON K-@3 GOTO 8200,8010,8010,8300,8010,8800,8400,8450,8500,500,8700,8600
8200 X=@6 :: CALL CLEAR :: Z=L+D-@2 :: ZL=L :: DISPLAY AT(@,14):"INSERT MODE" :: FOR I=@ TO @5 :: DISPLAY AT(16+I,@):A$(Z+I) :: IF (Z-@5+I)>_ THEN DISPLAY AT(I+@,@):A$(Z-@5+I)
8220 NEXT I :: FOR I=@ TO MIN(10,NL-U) :: ACCEPT AT(I+@6,@) SIZE(-28):B$(I) :: CALL KEY(_,K,E) :: IF B$(I)="" AND K<>10 THEN 8270
8260 NEXT I
8270 I=I-@ :: FOR L=U+I TO Z+I STEP -@ :: IF L-I<@ THEN 8290
8280 A$(L)=A$(L-I) :: NEXT L
8290 FOR J=@ TO I :: A$(J+Z)=B$(J) :: B$(J)="" :: NEXT J :: L=ZL :: U=U+I :: DISPLAY AT(@,@):M$(,M$(@2) :: GOSUB 10090 :: GOTO 8010
8300 Z=L :: U=U-@ :: FOR L=L+D-@ TO U+@2 :: A$(L)=A$(L+@) :: NEXT L :: L=Z :: GOSUB 10090 :: GOTO 8010
8400 IF A$(L+D)<>"" AND D<@A THEN D=D+@ :: CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K=10 THEN 8400 ELSE IF K=11 THEN 8450 ELSE 8010 ELSE IF D=@A THEN 8500 ELSE 8010
8450 IF D>@2 THEN D=D-@ :: CALL HCHAR(D,@2,30) :: CALL KEY(_,K,E) :: CALL VCHAR(@2,@2,32,@0) :: IF K=11 THEN 8450 ELSE IF K=10 THEN 8400 ELSE 8010 ELSE 8600
8500 D=@2 :: IF L+40<U THEN L=L+@0 :: GOSUB 10090 ELSE 8530
8510 IF K>15 THEN 3010 ELSE 8010
8530 IF L+@0<U THEN L=L+@0 :: D2=U-L+@2 :: GOSUB 10100
8540 IF K>15 THEN 8700 ELSE 8010
8600 D=@A :: IF INT(L/@0)>_ THEN L=L-@0 :: GOSUB 10090 ELSE D=@2
8610 GOTO 8010
8700 L1=INT(U/@0)*@0 :: D,D2=U-L1+@2 :: IF L<INT(U/@0)*20-@0 THEN D2=@A
8710 L=L1 :: GOSUB 10100 :: DISPLAY AT(22,@):;:;:;: :: GOTO 1030
8800 L1=L+D-@ :: ACCEPT AT(D,@) SIZE(-28):A$(L1) :: GOTO 8400
10000 CALL CLEAR :: CALL SCREEN(7) :: DISPLAY AT(2,@):">>>>>>"&M$(V)&"<<<<<":;:;:"CAUTION!":"ANY DOCUMENT IN CONSOLE":"WILL BE ERASED!"
10010 DISPLAY AT(23,@) BEEP :" PRESS ANY KEY TO CONTINUE   OR 'ENTER' FOR MAIN MENU"
10020 CALL KEY(_,K,E) :: IF E<>@ THEN 10020 ELSE IF K=13 THEN 500 ELSE DISPLAY AT(22,1):;:;:;:
10030 D=@2 :: RETURN
10090 D2=@A
10100 DISPLAY AT(@,@) SIZE(10):M$(;INT(L/@0)+@ :: FOR D1=@2 TO D2 :: DISPLAY AT(D1,@):A$(L+D1-@) :: NEXT D1 :: RETURN
10200 DISPLAY AT(@5,@):"ENTER NULL FOR MAIN MENU":;:;:;:;:;:;: :: DISPLAY AT(17,@):"OPEN #1:":N$:;:;:"ENTER DEVICE OPEN STATEMENT (CS1, DSK1..FILENAME, TP..E,  RS232..BA=600..EC, ETC..)"
10208 ACCEPT AT(18,@) SIZE(-28) BEEP :N$ :: IF N$="" THEN 500
10220 DISPLAY AT(@5,@):"" :: DISPLAY AT(@0,@):;:M$(@9):;:;:; :: RETURN
10300 DISPLAY AT(R,@):"CHOICE?" :: C=11
10310 CALL SOUND(100,1569,_) :: CALL GCHAR(R,C,Q)
10320 CALL HCHAR(R,C,30) :: CALL KEY(_,K,E) :: CALL HCHAR(R,C,Q) :: IF E<>@ THEN 10320
10330 CALL HCHAR(R,C,K) :: IF K=13 THEN 500 ELSE I=K-48 :: IF I<@ OR I>N THEN 10300 ELSE RETURN
11000 CALL ERR(CO,Z,Z,Z) :: ON ERROR 11000
11010 DISPLAY AT(11,@): :"CODE=";CO:"SEE X-BASIC MANUAL, PAGE 217WE HAVE JUST ENCOUNTERED AN ERROR.. ": : :: INPUT "'ENTER' TO CONTINUE ":Q$ :: ON ERROR 11060 :: CLOSE #@
11060 ON ERROR 11065 :: F=_ :: CLOSE #@2
11065 ON ERROR 11070 :: CLOSE #@B
11070 ON ERROR 11000 :: RETURN 500
12990 !@P+
13000 DATA 000038484834,40407048483,000038404038,080838484834,0018243C2018,18282038202,38484838083
13010 DATA 202038242424,100030101038,10003010507,404050605048,301010101038,00006C545454,000078484848
13020 DATA 00003048483,70584870404,384848380808,00002830202,00182038083,101038101018,000048484834
13030 DATA 00002424281,000044545428,000028102828,00484830102,000038102038
13040 DATA DOCUMENT Mode,INPUT Document,CONTINUE Mode,SAVE Document,PRINT Document,LEAVE Program
13050 DATA MEMORY NEAR FULL,SCREEN#:,>HOLD DOWN 'ENTER' TO STOP<
32000 IF SEG$(D$,A+B+P1,@)=" " THEN P1=P1+@ :: GOTO 32000 ELSE P3=P1+A+B :: IF POS(D$," ",P3)=_ THEN RETURN
32010 IF LEN(D$)>=A+B+Z THEN RETURN ELSE P3=POS(D$," ",P3+@2) :: IF P3=_ THEN 32000
32020 D$=SEG$(D$,@,P3)&" "&SEG$(D$,P3+@,LEN(D$)) :: GOTO 32010

[+acadiel]

Pascal Directory from Extended Basic (P-Code?) by P.E. Schippnick

100 REM 8410110156
110 REM PASCAL DIRECTORY    FROM EXTENDED BASIC *V2.0*
120 REM BY P.E.SCHIPPNICK              POMONA, CA 91766            (714) 629-8956
130 ON ERROR 1080
140 CALL CHARPAT(76,A$) :: IF SEG$(A$,15,2)="00" THEN GOSUB 1270
150 DEVICE$="PIO"
160 CALL CLEAR
170 DISPLAY AT(12,7):"PASCAL DIRECTORY"
180 OPEN #1:"DSK1..",INPUT,RELATIVE,INTERNAL
190 INPUT #1:DISKNAME$,[1,[2,[3
200 IF [3<>0 THEN 240
210 INPUT #1:FILENAME$,[4,[5,[6
220 IF FILENAME$<>"PASCAL" OR [4<>1 OR [6<>128 THEN 240
230 CLOSE #1 :: GOTO 260
240 CLOSE #1 :: GOSUB 1170
250 GOTO 160
260 OPEN #1:"DSK1..PASCAL",INPUT,DISPLAY,FIXED 128,RELATIVE
270 INPUT "WANT A PRINTOUT? ":I$ :: IF I$="Y" OR I$="y" OR I$="YES" OR I$="yes" OR I$="Yes" THEN F=1
280 IF F=1 THEN PRINT "OUTPUT DEVICE? "&DEVICE$
290 IF F=1 THEN ACCEPT AT(23,16) SIZE(-32) BEEP :DEVICE$
300 IF DEVICE$="" THEN F=0
310 CALL CLEAR
320 IF F=1 THEN OPEN #2:DEVICE$
330 CALL CLEAR
340 IF F=1 THEN IF DEVICE$="TP" THEN F=0 :: Q=2
350 I=1 :: DIM [$(7),DIRECORD$(76),TYPE$(7),MONTH$(11)
360 MONTH$(0)="JAN" :: MONTH$(1)="FEB" :: MONTH$(2)="MAR" :: MONTH$(3)="APR" :: MONTH$(4)="MAY" :: MONTH$(5)="JUN" :: MONTH$(6)="JUL" :: MONTH$(7)="AUG"
370 MONTH$(="SEP" :: MONTH$(9)="OCT" :: MONTH$(10)="NOV" :: MONTH$(11)="DEC"
380 TYPE$(1)="bad" :: TYPE$(2)="code" :: TYPE$(3)="text" :: TYPE$(4)="info" :: TYPE$(5)="data" :: TYPE$(6)="graf" :: TYPE$(7)="foto"
390 A=([5-31)*2 :: LINPUT #1,REC A:[$(0)
400 LINPUT #1:[$(1)
410 LINPUT #1:[$(2)
420 LINPUT #1:[$(3)
430 LINPUT #1:[$(4)
440 LINPUT #1:[$(5)
450 LINPUT #1:[$(6)
460 LINPUT #1:[$(7)
470 USED=ASC(SEG$([$(0),4,1))
480 LAST=USED
490 BLOCKS=ASC(SEG$([$(0),15,1))*256+ASC(SEG$([$(0),16,1))
500 NUMREC=ASC(SEG$([$(0),18,1))
510 DIR$=SEG$([$(0),27,102)
520 FOR DIRLIST=0 TO NUMREC-1
530 DIRECORD$(DIRLIST)=SEG$(DIR$,1,26)
540 DIR$=SEG$(DIR$,27,255)
550 IF I=8 THEN 570
560 IF LEN(DIR$)<128 THEN DIR$=DIR$&[$(I) :: I=I+1
570 NEXT DIRLIST
580 REM
590 PRINT #Q: TAB (7);"PASCAL DIRECTORY": :
600 IF F=1 THEN PRINT #2: TAB (17);"PASCAL DIRECTORY": :
610 PRINT #Q:"VOLUME: ";SEG$([$(0),8,ASC(SEG$([$(0),7,1)))
620 IF F=1 THEN PRINT #2:"VOLUME: ";SEG$([$(0),8,ASC(SEG$([$(0),7,1)))
630 PRINT #Q:"filename"; TAB (16);"size"; TAB (21);"blk"; TAB (25);"type"
640 IF F=1 THEN PRINT #2:"filename"; TAB (18);"size"; TAB (27);"date"; TAB (36);"block"; TAB (42);"type"
650 FOR DIRLIST=0 TO NUMREC-1
660 YEAR=INT(ASC(SEG$(DIRECORD$(DIRLIST),25,1))/2)
670 YEAR$=SEG$("0"&STR$(YEAR),LEN(STR$(YEAR)),2)
680 DAY=INT(ASC(SEG$(DIRECORD$(DIRLIST),26,1))/16)+(ASC(SEG$(DIRECORD$(DIRLIST),25,1))-2*YEAR)*16
690 DAY$=SEG$("0"&STR$(DAY),LEN(STR$(DAY)),2)
700 MONTH=ASC(SEG$(DIRECORD$(DIRLIST),26,1))-INT(ASC(SEG$(DIRECORD$(DIRLIST),26,1))/16)*16
710 FIRST=ASC(DIRECORD$(DIRLIST))*256+ASC(SEG$(DIRECORD$(DIRLIST),2,1))
720 IF FIRST>LAST THEN GOSUB 1010
730 FIRST$=SEG$("  "&STR$(FIRST),LEN(STR$(FIRST)),3)
740 LAST=ASC(SEG$(DIRECORD$(DIRLIST),3,1))*256+ASC(SEG$(DIRECORD$(DIRLIST),4,1))
750 FILELEN=LAST-FIRST
760 USED=USED+FILELEN
770 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
780 TYPE=ASC(SEG$(DIRECORD$(DIRLIST),6,1))
790 NAMELEN=ASC(SEG$(DIRECORD$(DIRLIST),7,1))
800 PRINT #Q:SEG$(DIRECORD$(DIRLIST),8,NAMELEN); TAB (17);FILELEN$; TAB (21);FIRST$; TAB (25);TYPE$(TYPE)
810 IF F=1 THEN PRINT #2:SEG$(DIRECORD$(DIRLIST),8,NAMELEN); TAB (19);FILELEN$; TAB (25);DAY$&"-"&MONTH$(MONTH-1)&"-"&YEAR$; TAB (37);FIRST$; TAB (42);TYPE$(TYPE)&"file"
820 CALL KEY(0,KEY,STATUS) :: IF STATUS<>0 THEN GOSUB 990
830 NEXT DIRLIST
840 FILELEN=BLOCKS-LAST
850 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
860 FIRST$=SEG$("  "&STR$(LAST),LEN(STR$(LAST)),3)
870 PRINT #Q:"< unused >"; TAB (17);FILELEN$; TAB (21);FIRST$
880 IF F=1 THEN PRINT #2:"< unused >"; TAB (19);FILELEN$; TAB (25);"         "; TAB (37);FIRST$
890 PRINT #Q: :: IF F=1 THEN PRINT #2:
900 PRINT #Q:"Blocks free:";BLOCKS-USED
910 IF F=1 THEN PRINT #2:"Blocks free:";BLOCKS-USED
920 PRINT #Q: :: IF F=1 THEN PRINT #2:
930 PRINT "press any key to continue   press Q to quit"
940 CALL KEY(0,KEY,STATUS) :: IF STATUS=0 THEN 940
950 CLOSE #1 :: IF F=1 THEN CLOSE #2 :: F=0
960 IF Q=2 THEN CLOSE #2 :: Q=0
970 IF KEY<>81 AND KEY<>112 THEN 160
980 END
990 CALL KEY(0,KEY,STATUS) :: IF STATUS<1 THEN 990
1000 RETURN
1010 IF LAST=0 THEN RETURN
1020 FILELEN=FIRST-LAST
1030 FILELEN$=SEG$("  "&STR$(FILELEN),LEN(STR$(FILELEN)),3)
1040 FIRST$=SEG$("  "&STR$(LAST),LEN(STR$(LAST)),3)
1050 PRINT #Q:"< unused >"; TAB (17);FILELEN$; TAB (21);FIRST$
1060 IF F=1 THEN PRINT #2:"< unused >"; TAB (19);FILELEN$; TAB (25);"         "; TAB (37);FIRST$
1070 RETURN
1080 CALL ERR(CODE,TYPE,SEVERITY,LINE)
1090 ON ERROR 1080
1100 IF LINE=180 OR LINE=260 THEN 1170
1110 IF LINE>=390 AND LINE<=460 OR LINE=190 OR LINE=210 THEN ERR=1 :: GOTO 1170
1120 IF LINE=320 THEN 1220
1130 CALL SOUND(300,150,0)
1140 PRINT "ERROR #"&STR$(CODE)&" IN LINE";LINE
1150 PRINT "see APPENDIX 'N' page 217"
1160 STOP
1170 PRINT "Please insert PASCAL disk   in DRIVE 1"
1180 PRINT "press any key to continue"
1190 CALL KEY(0,KEY,STATUS) :: IF STATUS=0 THEN 1190
1200 IF ERR=1 THEN RUN
1210 RETURN
1220 PRINT "Please re-enter"
1230 PRINT "OUTPUT DEVICE? "
1240 ACCEPT AT(23,16) BEEP :DEVICE$
1250 IF DEVICE$="" THEN RUN
1260 RETURN
1270 FOR J=65 TO 90 :: CALL CHARPAT(J,A$) :: A$="0000"&SEG$(A$,1,4)&SEG$(A$,7,4)&SEG$(A$,13,4) :: CALL CHAR(J+32,A$) :: NEXT J
1280 RETURN

[+Ksarul]

That last one looks like it is taking the directory data from a UCSD p-System disk and parsing it out to view it in Extended BASIC. I think I've seen mention of this program before, in an old issue of the USUS Newsletter. . .

[atrax27407]

I used Typewriter for several years to print our UG newsletter on a thermal printer.

Edited June 3, 2018 by atrax27407

[+Ksarul]

I actually have an original copy of the Typewriter program on cassette. . .

[ti99iuc]

Nice to have the Dump to this package thanks !

Edited June 3, 2018 by ti99iuc