Jump to content
IGNORED

Neat stuff from Falcor4's Hard drive image


acadiel
 Share

Recommended Posts

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

  • Like 2
Link to comment
Share on other sites

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

  • Like 3
Link to comment
Share on other sites

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

  • Like 3
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

Loading...
 Share

  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...