home *** CD-ROM | disk | FTP | other *** search
1 ' Trilogy.BAS 2 ' 3 ' February 2, 1987 4 ' 5 ' Copyright (c) 1986 B. J. Ball 6 ' 7 ' 10 DEFINT A-Z:RECL=256:M.MAX=500:KW.MAX=1500:N.MAX=2000:H.MAX=160 11 ESC$=CHR$(27):CR$=CHR$(13):BK$=CHR$(8):Q$=CHR$(34) 'frequently used str's 12 ' 13 'RECL=rec len, M.MAX=#notes, KW.MAX=#keywords, N.MAX=#recrds, H.MAX=hdr.len. 14 ' 15 DIM ID$(500),REC(500),W$(1532),M(1532),U(2000),S$(10,10) 20 DIM H(500),H1(500),N(20),P(20),CH$(9),C$(4),B$(1),FP(25) 21 ' 22 ' ID$( )=identifiers, REC( )=starting rec#, W$( )=kwrds, M( )=mult kwrds 23 ' DIM ID$( ),REC( ),H( ),H1( ) is M.MAX 24 ' DIM W$( ) and M( ) is KW.MAX+estimated max #kwds/hdr,DIM U( ) is N.MAX+1 25 ' S$( , ) and N( ) are used in search strings, FP( ) for the ML routine 26 ' 30 DEF FN N$(X)=MID$(STR$(X),2):DEF FN SP$(X)=SPACE$(5-LEN(STR$(X)))'format $'s 35 DEF FN MAX(A,B)=A-(B>A)*(B-A):DEF FN MIN(A,B)=A-(B<A)*(B-A) 40 ' get configuration data 45 ON ERROR GOTO 7360 50 OPEN "i",1,"trilogy.cnf" 55 ON ERROR GOTO 0 60 INPUT #1,COLR,FG,BG,BR,ST,EN,UC,DL,H.MAX,KW$:CLOSE 65 ST$=CHR$(ST):EN$=CHR$(EN):DL$=CHR$(DL):WIDTH 80:SCREEN 0,1 70 IF COLR THEN COLOR FG,BG,BR 75 DEF SEG=0:IF (PEEK(1040) AND 48)=48 THEN MONO=1 ELSE MONO=0:DEF SEG 80 GOSUB 10000 'load ML fast-print program 85 GOSUB 7800 'initialization 90 ' Display Menu 100 GOSUB 8020:R1=4:C1=24:MAX=5+4*ACTIVE:LOCATE 23,1,0:IF ACTIVE=0 THEN 130 110 X.$="Trilogy : "+RF$+" "+IDF$+" "+KF$:R.=23:C.=16:GOSUB 10130 120 ' Get user choice 130 A=0:CHOICE=0:LOCATE R1,C1,0:PRINT CHR$(16) 140 WHILE CHOICE=0 150 GOSUB 5820 'get char. (and A) 160 IF A=13 THEN RT=0:CHOICE=R1-3 'accept cursor entry 170 IF UP AND R1>4 THEN LOCATE R1,C1:PRINT" ":R1=R1-1:LOCATE R1,C1,0:PRINT CHR$(16) 180 IF DN AND R1<3+MAX THEN LOCATE R1,C1:PRINT" ":R1=R1+1:LOCATE R1,C1,0:PRINT CHR$(16) 190 IF 48<A AND A<49+MAX THEN CHOICE=A-48 'accept numeric entry 200 WEND:CLS:LOCATE 4,1,0 210 IF CHOICE=MAX THEN IF COLR THEN COLOR 7,0,0:CLS:END ELSE CLS:END 215 IF CHOICE=MAX-1 THEN GOSUB 310:GOTO 240 'make configuration file 220 ON CHOICE GOSUB 810,1010,1210,1220,3010,2110,2510 230 ' Return to menu 240 IF RT THEN RT=0:CLOSE:GOTO 100 'direct return 250 L0=24:C0=1:GOSUB 6070 'msg - Esc for Menu 260 A$=INPUT$(1):GOTO 100 'wait, then return 300 '**************** Create or Change CNF File ********************* 310 CLS:PRINT " Enter C for color monitor, M for monochrome : "; 320 L=CSRLIN:C=POS(0):X$="CM":IF COLR THEN DF$="C" ELSE DF$="M" 330 GOSUB 710:IF A$="C" THEN COLR=1 ELSE COLR=0 340 IF COLR=0 THEN 420 350 PRINT TAB(16)"Enter color numbers for foreground : ";:L0=CSRLIN:C0=POS(0) 360 PRINT TAB(41)"background : ";:L1=CSRLIN:C1=POS(0) 370 PRINT TAB(45)"border : ";:L2=CSRLIN:C2=POS(0) 380 L=L0:C=C0:DF$=" ":LSET DF$=FNN$(FG):X$="0123456789101112131415":GOSUB 710:FG=VAL(A$) 390 L=L1:C=C1:LSET DF$=FNN$(BG):X$="0123456789":GOSUB 710:BG=VAL(A$) 400 IF FG=BG THEN 770 'error routine 410 L=L2:C=C2:LSET DF$=FNN$(BR):GOSUB 710:BR=VAL(A$) 420 PRINT "Type desired left header marker and press Enter : "; 430 L=CSRLIN:C=POS(0):DF$=CHR$(ST):X$="" 440 GOSUB 710:IF LEN(A$)>1 THEN 440 ELSE ST$=A$:ST=ASC(A$):IF INSTR(KW$,ST$) THEN 440 450 PRINT "Type desired right header marker and press Enter : "; 460 L=CSRLIN:C=POS(0):DF$=CHR$(EN) 470 GOSUB 710:IF LEN(A$)>1 THEN 470 ELSE EN$=A$:EN=ASC(A$):IF INSTR(KW$,EN$) THEN 470 480 PRINT "Enter maximum length to be allowed for headers : "; 490 L=CSRLIN:C=POS(0):DF$=" ":LSET DF$=FNN$(H.MAX):GOSUB 710:H.MAX=VAL(A$):IF H.MAX<70 THEN H.MAX=70:LSET DF$=FNN$(H.MAX):LOCATE L,C:PRINT DF$" " 500 PRINT "Are keywords allowed to contain spaces (Y/N) ? : "; 510 L=CSRLIN:C=POS(0):X$="YN":IF INSTR(KW$," ") THEN DF$="Y" ELSE DF$="N" 520 GOSUB 710:IF A$="N" THEN DL=32 ELSE IF INSTR(KW$," ")=0 THEN KW$=" "+KW$ 530 PRINT "Letters, numbers and the three symbols '-_ are 540 PRINT "always acceptable in keywords. Type ALL other 550 PRINT "non-space symbols you wish to allow and press Enter: "; 560 L=CSRLIN:C=POS(0):DF$="":X$="":GOSUB 710:IF A$="" THEN 570 ELSE KW$="'-_" 562 FOR I=1 TO LEN(A$):X$=MID$(A$,I,1) 564 IF INSTR(KW$+"*#",X$) THEN 568 ' * and # are not allowed in keywords 566 KW$=KW$+X$ 568 NEXT:X$="" 570 IF INSTR (KW$," ")=0 THEN 610 580 PRINT"Type the desired keyword delimiter and press Enter : "; 590 L=CSRLIN:C=POS(0):DL$=CHR$(DL):IF DL$<>" " THEN DF$=DL$ ELSE DF$="," 600 GOSUB 710:IF LEN(A$)>1 THEN 600 ELSE DL=ASC(A$):DL$=CHR$(DL):IF INSTR(KW$,DL$) THEN 600 610 PRINT "Shall letters in keywords be converted to capitals ? "; 620 L=CSRLIN:C=POS(0):X$="YN":IF UC THEN DF$="Y" ELSE DF$="N" 630 GOSUB 710:IF A$="Y" THEN UC=1 ELSE UC=0 640 PRINT:PRINT" Save these values for automatic use later (Y/N) ? "; 650 L=CSRLIN:C=POS(0):DF$="Y":X$="YN":GOSUB 710 660 IF A$="N"THEN 690 670 OPEN"o",5,"trilogy.cnf":PRINT#5,COLR;FG;BG;BR;ST;EN;UC;DL;H.MAX;KW$:CLOSE 5 680 IF COLR THEN COLOR FG,BG,BR 690 RETURN 700 '------------------ short space-saver sub subs ----------------- 710 LOCATE L,C:PRINT DF$" ";:LOCATE L,C:LINE INPUT"",A$:IF A$=""THEN A$=DF$:RETURN 720 IF A$=ESC$ THEN RETURN 100 730 IF LEN(A$)=1 THEN A=ASC(A$):IF 96<A AND A<123 THEN A=A-32:A$=CHR$(A) 740 IF X$<>"" THEN IF INSTR(X$,A$)=0 THEN 710 750 LOCATE L,C:PRINT A$" "; 760 RETURN 770 ' Foreground=Background error 780 IF JEST=0 THEN PRINT:PRINT"Surely you jest! Please make foreground and background colors different.":JEST=1:PRINT:GOTO 350 ELSE PRINT:PRINT"Since this would not be readable, default colors will be used":PRINT:FG=15:BG=1:BR=1:JEST=0:GOTO 420 790 '-------------------------------------------------------------- 800 '******************** List Available Files ********************** 810 OP1=-1 'OP1 = called from Menu 820 L0=1:C0=1:GOSUB 6070 'msg - Esc for Menu 830 PRINT:PRINT"Press drive letter (A,B,C,D) for list of files"; 840 IF NOT OP1 THEN PRINT ", or press Enter to continue "; 850 PRINT ": ";:L0=CSRLIN:C0=POS(0):LOCATE L0,C0,1 860 CH$="AaBbCcDd"+ESC$+CR$ 'acceptable characters 870 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 870 880 IF A$=CR$ THEN RT=OP1:OP1=0:GOTO 970 'return 890 IF A$=ESC$ THEN RT=1:OP1=0:RETURN 240 'return directly to menu 900 A$=CHR$(ASC(A$) AND 95) 'convert to upper case 910 D$=A$+":*.*":PRINT 920 ON ERROR GOTO 7290 930 PRINT:IF NOT OP1 THEN PRINT 940 PRINT "Files on drive "A$" are:":FILES D$ 950 ON ERROR GOTO 0 960 GOTO 830 970 RETURN 1000 '******************** Select TRILOGY files ********************** 1010 CLS:PRINT "Files on default drive/directory are:":PRINT:FILES:PRINT 1020 X.$="Enter the "+Q$+"generic"+Q$+" name of the desired files : " 1030 L0=CSRLIN:C0=49:R.=L0:C.=1:GOSUB 10130 'L0,C0 is input location 1040 X.$="(Generic name must appear with all of the extensions .ID,.KW,.REC)" 1050 GOSUB 10130 1060 LX=8:K$="":GOSUB 6280 'get generic name 1070 IDF$=K$+".ID":RF$=K$+".REC":KF$=K$+".KW" 'make Trilogy file names 1080 CLOSE:ACTIVE=0 1090 ON ERROR GOTO 7220 1100 OPEN "i",2,IDF$ 1110 OPEN "i",4,KF$ 1120 OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$ 1130 ON ERROR GOTO 0 1140 CLS:PRINT"Loading "K$ "... ":K$="" 1150 M=0:WHILE NOT EOF(2):M=M+1:INPUT #2,ID$(M),REC(M):WEND:CLOSE 2 1160 KW=0:WHILE NOT EOF(4):KW=KW+1:INPUT #4,W$(KW),M(KW):WEND:CLOSE 4 1170 GET #3,1:RMAX=CVI(U$):ACTIVE=1:RT=1 'RT to bypass "Press key ... 1180 FOR I=1 TO RMAX:U(I)=1:NEXT 'mark used sectors 1190 RETURN 1200 '********** Create or Update ID and Records Files ************** 1210 NEWFILES=1:F$="Source":GOTO 1230 'create new files 1220 NEWFILES=0:F$="Update" 'update old files 1230 GOSUB 820:PRINT 'list files if desired 1240 X.$="Filespec of "+F$+" File (need not be on default drive) : " 1250 L0=CSRLIN+1:C0=59:R.=L0:C.=1:GOSUB 10130 'L0,C0 is input loc. 1260 LX=14:GOSUB 6280:SF$=K$ 'source filespec 1270 H=INSTR(K$,":"):K$=MID$(K$,H+1):H=INSTR(K$,"."):IF H THEN K$=LEFT$(K$,H-1) 1280 IF NEWFILES THEN IDF$=K$+".ID":RF$=K$+".REC":KF$=K$+".KW" 1290 CLOSE:K$="":ACTIVE=0:IF NEWFILES THEN FOR I=1 TO RMAX:U(I)=0:NEXT 1300 ON ERROR GOTO 7220 1310 OPEN "i",1,SF$:IF NEWFILES THEN N=1:M=0:KW=0:NN=0 'rcrd#,id#,#kwrds,note# 1320 IF NEWFILES THEN OPEN "o",2,IDF$ ELSE OPEN IDF$ FOR APPEND AS #2 1330 OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$ 1340 ON ERROR GOTO 0 1350 IF NEWFILES=0 THEN GET #3,1:RMAX=CVI(U$):N=RMAX 'max record number 1360 CLS:X.$="Working on file "+SF$:R.=1:C.=1:GOSUB 10130:A=0 1370 X.$="Currently processing note number":R.=3:GOSUB 10130 1380 WHILE A<>ST AND NOT EOF(1):A=ASC(INPUT$(1,1)) AND 127:WEND 'look for hdr 1390 IF EOF(1) THEN PRINT"Error - no identifiers found.":RETURN 1400 N=N+1:U(N)=1:GOSUB 1670 'format first header 1410 WHILE NOT EOF(1) 1420 X$="":I=0:I0=0:E=0:HD=0 1430 WHILE I<RECL-2 1440 A$=INPUT$(1,1):A=ASC(A$) 'get one character 1450 IF A=ST OR A=ST+128 THEN E=1:HD=1 'header so end of note 1460 IF EOF(1) THEN E=1 'eof so end of note 1470 IF E THEN I0=I:I=RECL-2:GOTO 1490 'exit if end of note 1480 X$=X$+A$:I=I+1 'augment string 1490 WEND 1500 IF E THEN GOSUB 6510 'set end-of-text marker 1510 N0=N:WHILE U(N) AND N<=N.MAX:N=N+1:WEND 'find 1st unused record > N 1520 IF N>N.MAX THEN LN=1:GOTO 7500 ELSE U(N)=1 'cannot add any more records 1530 IF E THEN LSET U$=MKI$(0):GOTO 1550 'end of note 1540 LSET U$=MKI$(N) 'note continues on N 1550 LSET T$=X$:PUT #3,N0 'write part of note 1560 IF N0>RMAX THEN RMAX=N0 'max record # so far 1570 IF HD AND REPL=0 THEN GOSUB 1670 'get next header if not repl 1580 WEND 1590 GOSUB 6920 'save keywords and mult's 1600 IF REPL THEN RETURN 'just replacing a note 1610 LSET U$=MKI$(RMAX):PUT #3,1 'save RMAX in rec file 1620 IF KW>KW.MAX-32 THEN LN=4:GOTO 7500 'too many keywords possible 1630 CLOSE:ACTIVE=1 'housekeeping 1640 BEEP:BEEP:LOCATE 5,1::PRINT "All Done!" 'guess what? 1650 RETURN 1660 '-------------------- Format identifier, Update KW List ---------------- 1670 IF M=M.MAX THEN LN=3:GOTO 7500 'maximum # notes already in 1680 NN=NN+1:LOCATE 3,33:PRINT NN; 'note being processed 1690 X$="":ID$="":CNT=0:DF=0 'DF is delimiter flag 1700 A$=INPUT$(1,1):A=ASC(A$) AND 127 'get char, strip high bit 1710 WHILE A<>EN AND NOT EOF(1) 'A$ <> end-of-hdr marker 1720 IF UC THEN IF 96<A AND A<123 THEN A=A-32 'lc to caps if UC 1730 IF INSTR(V1$,CHR$(A)) THEN X$=X$+CHR$(A) ELSE A$=DL$ 1740 'add valid chars to ID$, change others to delimiters 1750 IF A$<>DL$ THEN DF=0 ELSE IF DF=0 THEN X$=X$+A$:DF=1 'add one DL$ only 1760 A$=INPUT$(1,1):A=ASC(A$) AND 127 'next character 1770 CNT=CNT+1 'keep count of chars 1780 IF CNT>H.MAX THEN LN=2:GOTO 7500 'note error, return 1790 WEND 1800 IF X$="" THEN 7430 'no keywords in identifier 1810 IF REPL=0 THEN 1830 1820 Y$=ID$(K):SAME.ID=(X$=Y$):GOSUB 6650 'dec mult's of kwds in Y$ 1830 WHILE X$<>"" 1840 H=INSTR(X$,DL$):IF H=1 THEN X$=MID$(X$,2):GOTO 1840 'strip lead DL$'s 1850 IF H=0 THEN H=LEN(X$)+1 1860 W$=LEFT$(X$,H-1):X$=MID$(X$,H+1) 1870 K$=W$:GOSUB 6590:W$=K$ 'strip lead, trail spaces 1880 IF W$="" THEN 1900 'skip if W$ now empty 1890 ID$=ID$+W$:GOSUB 1980:IF X$<>"" THEN ID$=ID$+DL$ 'else add to ID$ 1900 WEND 1910 L=LEN(ID$):IF RIGHT$(ID$,1)=DL$ THEN ID$=LEFT$(ID$,L-1):GOTO 1910 1920 IF L=0 THEN 7430 'no keywords in identifier 1930 M=M+1:ID$(M)=ID$:REC(M)=N 'add ID$ and rec.# to arrays 1940 IF REPL THEN RETURN 5630 'replacing note; will save identifiers later 1950 WRITE #2,ID$,N 'add ID$ and rec.# to file 1960 RETURN 1970 '------------ Update keyword list with words from ID$ ------------------ 1980 IF W$>W$(KW) THEN KW=KW+1:W$(KW)=W$:M(KW)=1:GOTO 2080 'W$ goes at end 1990 A=0:B=KW 'start binary search 2000 WHILE B-A>1:C=(A+B)\2 'halve interval 2010 IF W$<=W$(C) THEN B=C 'W$ in lower half 2020 IF W$>=W$(C) THEN A=C 'W$ in upper half 2030 WEND 'W$(B-1)<W$<=W$(B) 2040 IF W$=W$(B) THEN M(B)=M(B)+1:GOTO 2080 'already entered 2050 KW=KW+1 'not duplicate, so: 2060 FOR J=KW TO B+1 STEP -1:W$(J)=W$(J-1):M(J)=M(J-1):NEXT 'clear place and 2070 W$(B)=W$:M(B)=1 'insert W$, mult 1 2080 RETURN 'get next word, if any 2100 '************** Print or Display Keyword List ****************** 2110 PRINT "Send keyword list to Screen or to Printer (S/P) ? "; 2120 L0=CSRLIN:C0=POS(0):GOSUB 6070 'msg - Esc for menu 2130 CH$="SsPp"+ESC$ 'acceptable characters 2140 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 2140 2150 IF A$=ESC$ THEN RT=1:RETURN 'menu if Esc pressed 2160 IF A$="S" OR A$="s" THEN 2320 'display keywords 2170 '--------------------- Print keyword list ------------------------------ 2180 PRINT:PRINT"Check printer, press any key when ready ..."; 2190 A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN ELSE CLS 2200 LPRINT:LPRINT:L=6 2210 LPRINT "Keyword list for "IDF$:LPRINT 2220 H = -INT(-KW/4) 'for four column printout, need min H with 4*H >= KW 2230 FOR I=1 TO H 2240 FOR J=0 TO 3 2250 K=I+J*H : T=20*J +5 2260 IF K<=KW THEN LPRINT TAB(T);:LPRINT LEFT$(W$(K),18); 2270 NEXT 2280 LPRINT:L=L+1:IF L>60 THEN LPRINT CHR$(12):LPRINT:LPRINT:L=4 2290 NEXT 2300 RETURN 2310 '-------------------- Display keyword list ----------------------------- 2320 Z=0:P(Z)=0:WHILE P(Z)<KW:Z=Z+1:P(Z)=80*Z:WEND:P(Z)=KW:Z=1 2330 CLS:R.=2:C.=27:X.$="Keyword list for "+IDF$:GOSUB 10130 2340 X.$="**** Esc for menu ****" 2350 IF KW>80 THEN X.$=X.$+" (PgUp ,PgDn for other keywords)" 2360 R.=25:C.=1:GOSUB 10130:LOCATE 4,1,0:X.$=SPACE$(20) 2370 FOR I=1 TO 20 2380 FOR J=0 TO 3:R.=I+3:C.=1+20*J:K=P(Z-1)+I+C.-1 2390 IF K<=KW THEN LSET X.$=LEFT$(W$(K),18):GOSUB 10130 2400 NEXT 2410 NEXT 2420 UP=0:DN=0:WHILE RT+UP+DN=0:GOSUB 5820:WEND 'check for PgUp, PgDn 2430 IF UP AND Z>1 THEN Z=Z-1:GOTO 2330 2440 IF DN AND P(Z)<KW THEN Z=Z+1:GOTO 2330 2450 RETURN 'menu if RT, else loop 2500 '**************** Print or Display Identifiers ******************* 2510 PRINT "Send identifiers list to Screen or to Printer (S/P) ? "; 2520 L0=CSRLIN:C0=POS(0):GOSUB 6070 'msg - Esc for menu 2530 CH$="SsPp"+ESC$ 'acceptable characters 2540 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 2540 2550 IF A$=ESC$ THEN RT=1:RETURN 'menu if Esc pressed 2560 IF A$="P" OR A$="p" THEN 2770 'print identifiers 2570 '----------------------- Display Identifiers --------------------------- 2580 FOR Z=1 TO 10:P(Z)=0:NEXT:Z=0 'P( ) holds # entries on screen 2590 CLS:L0=1:R.=1:C.=5:P=P(Z):LOCATE ,,0 2600 WHILE P<M AND L0<21:P=P+1 2610 X.$=FNN$(P)+FNSP$(P):R.=L0:C.=1:GOSUB 10130:C.=5:Z$=ID$(P) 2620 WHILE Z$<>"" 2630 IF LEN(Z$)<76 THEN X.$=Z$:R.=L0:GOSUB 10130:Z$="":L0=L0+1:GOTO 2680 2640 L=75:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND 'last space in Z$ on this line 2650 X.$=LEFT$(Z$,L-1):R.=L0:GOSUB 10130:L0=L0+1 'break at space 2660 Z$=MID$(Z$,L+1) 'remainder of string 2670 WEND 2680 WEND 2690 Z=Z+1:P(Z)=P 2700 IF P(1)<M THEN R.=24:C.=1:X.$="PgUp,PgDn for other identifiers.":GOSUB 10130 2710 L0=23:C0=1:GOSUB 6070 'msg - Esc for Menu 2720 UP=0:DN=0:WHILE RT+UP+DN=0:GOSUB 5820:WEND 'check for PgUp, PgDn 2730 IF UP AND Z>1 THEN Z=Z-2:GOTO 2590 'PgUp 2740 IF DN AND P(Z)<M THEN 2590 'PgDn 2750 RETURN 2760 '------------------------ Printout Identifiers ------------------------- 2770 PRINT:PRINT"Check printer, press any key when ready ..."; 2780 A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN 240 ELSE CLS 2790 LPRINT:LPRINT:LPRINT "Identifiers for "IDF$:LPRINT:L0=6:K=0 2800 WHILE K<M:K=K+1 2810 LPRINT FN N$(K);:Z$=ID$(K) 2820 WHILE Z$<>"" 2830 IF LEN(Z$)<76 THEN LPRINT TAB(5)Z$:Z$="":L0=L0+1:GOTO 2870 2840 L=75:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND 'last space in Z$ on this line 2850 LPRINT TAB(5)LEFT$(Z$,L-1):L0=L0+1 'break at space 2860 Z$=MID$(Z$,L+1) 'remainder of string 2870 WEND 2880 IF L0>60 THEN LPRINT CHR$(12):LPRINT:LPRINT:L0=4 2890 WEND 2900 RETURN 3000 '************************ Find Notes *************************** 3010 CLS:GOSUB 6020 'clear arrays 3020 X.$="Active file : "+RF$:R.=1:C.=17:GOSUB 10130 3030 LOCATE 4,1:X.$="Enter Search String or Direct Command: ( ? for help )":R.=4:C.=1:GOSUB 10130 3040 L0=5:C0=1:C=1:GOSUB 6070 'msg - Esc for Menu 3050 C=1:LOCATE L0,C0,1 'turn on cursor 3060 GOSUB 5820:IF RT THEN 240 'get first character of K$ 3070 IF X$="?" THEN GOSUB 8220:GOTO 3050 'show help screen 3080 X.$=SPACE$(25):R.=L0+1:C.=1:GOSUB 10130 'erase error message, if any 3090 K$=X$:LX=79:GOSUB 5910:LOCATE ,,0 'get rest of K$ (max len 79) 3100 IF RT THEN 240 'return to menu 3105 IF INSTR(K$,"?") THEN GOSUB 8220:GOTO 3050 'show help screen, start over 3110 GOSUB 6590 'strip lead, trail spcs in K$ 3120 IF ER THEN GOSUB 7460:GOTO 3050 'error in K$ 3130 DC=0:IF LEFT$(K$,1)<>"#" THEN 3330 'search string entered 3140 '----------------------- Direct Command Entered ------------------------ 3150 GOSUB 6110 'clean up Direct Command 3160 IF E THEN GOSUB 7460:GOTO 3050 'error in K$ 3170 IF C$<>"" THEN DC=1:GOTO 4180 'do D,P,F,X,R; return 4010 3180 K0$=K$:K$=MID$(K$,2):NF=1:Q=0 'delete "#", set num. flag 3190 WHILE K$<>"" 3200 C=INSTR(K$,","):IF C=0 THEN C=LEN(K$)+1 3210 L$=LEFT$(K$,C-1):H=INSTR(L$,"-") 3220 IF H THEN N1$=LEFT$(L$,H-1):N2$=MID$(L$,H+1) ELSE N1$=L$:N2$=N1$ 3230 N1=VAL(N1$):N2=VAL(N2$):IF N1>N2 THEN SWAP N1,N2 3240 N1=FN MAX(N1,1):N2=FN MIN(N2,M) 'adjust out-of-range entries 3250 FOR I=1 TO N2-N1+1:H(Q+I)=N1-1+I:NEXT:Q=Q+N2-N1+1 3260 K$=MID$(K$,C+1) 3270 WEND 3280 IF E THEN GOSUB 7460:GOTO 3050 'error in K$ 3290 GOTO 3670 'list identifiers # H(1)-H(Q) 3300 '----------------------- Search String Entered ------------------------- 3310 'Parse S$, creating S$(I,J) for I = 1...N , J = 1...N(I) 3320 'First remove illegitimate characters and extra spaces, maybe lc to caps 3330 GOSUB 6020:S$=K$:K$="":X$="":B$(0)=DL$:NF=0:SF=-1'clear arrays, initialize 3340 FOR J=1 TO LEN(S$):A=ASC(MID$(S$,J,1)) 3350 IF UC THEN IF 96<A AND A<123 THEN A=A-32 'lc to caps if UC 3360 IF INSTR(V1$,CHR$(A))=0 AND A<>42 THEN A=32'invalids to spaces 3370 IF A<>32 THEN SF=0 'clear space flag 3380 IF NOT SF THEN X$=X$+CHR$(A) 'not repeated space, ok 3390 IF A=32 THEN SF=-1 'if space, set flag 3400 NEXT 3410 IF X$="" OR X$=" " THEN GOSUB 7460:GOTO 3060 'empty search string 3412 IF LEFT$(X$,1)=" " THEN X$=MID$(X$,2):GOTO 3412 3414 IF RIGHT$(X$,1)=" " THEN X$=LEFT$(X$,LEN(X$)-1):GOTO 3414 3420 ' Now break X$ into substrings 3430 N=1:C=1 3440 C1=INSTR(C,X$," AND ")+INSTR(C,X$," and ") 3450 IF C1>C THEN L1=C1-C:S$(N,1)=MID$(X$,C,L1):C=C1+5:N=N+1:GOTO 3440 3460 S$(N,1)=MID$(X$,C) 3470 FOR I=1 TO N:SI$=S$(I,1) 3480 N(I)=1:IF INSTR(SI$," OR ")+INSTR(SI$," or ")=0 THEN 3520 ELSE C=1:C1=1 3490 C1=INSTR(C,SI$," OR ")+INSTR(C,X$," or ") 3500 IF C1>C THEN L1=C1-C:S$(I,N(I))=MID$(SI$,C,L1):C=C1+4:N(I)=N(I)+1:GOTO 3490 3510 S$(I,N(I))=MID$(SI$,C) 3520 NEXT 3530 ' Check for matches 3540 FOR P=1 TO M:ID$=DL$+ID$(P)+DL$ 'start and end with delimiter 3550 FOR I=1 TO N:OK=0 'assume no match at level I 3560 FOR J=1 TO N(I):S1$=S$(I,J):L=LEN(S1$) 3570 LS=-(LEFT$(S1$,1)="*"):RS=-(RIGHT$(S1$,1)="*") '* for wildcards 3580 S1$=B$(LS)+MID$(S1$,1+LS,L-(LS+RS))+B$(RS) 'modify S1$ for search 3590 IF INSTR(ID$,S1$) THEN OK=-1:J=N(I) 'exit if match found 3600 NEXT J:IF NOT OK THEN I=N 'S$(I,J) flunks, so ID$ does 3610 NEXT I :IF NOT OK THEN 3630 'ID$ flunked somewhere 3620 Q=Q+1:H(Q)=P 'count matches, save ID #'s 3630 NEXT P 3640 IF Q=0 THEN M$="No match found." 3650 IF Q=1 THEN M$="One match found :" 3660 IF Q>1 THEN M$=STR$(Q)+" Matches found :" 3670 IF Q=0 THEN M1$="Enter " 3680 IF Q THEN M1$="Enter numbers (or ranges) plus D,P,F,X,R to Display,Print,File,Delete,Replace." 3690 M2$="S for new search, Esc for menu." 3700 IF Q THEN M2$="Enter " + M2$ 3710 IF NF THEN 3840 'numeric entry, no SS$ 3720 ' Reconstruct search string 3730 SS$="" 3740 FOR I=1 TO N 3750 IF N>1 AND N(I)>1 THEN SS$=SS$+"(" 3760 FOR J=1 TO N(I) 3770 SS$=SS$+S$(I,J) 3780 IF J<N(I) THEN SS$=SS$+" or " 3790 NEXT 3800 IF N>1 AND N(I)>1 THEN SS$=SS$+")" 3810 IF I<N THEN SS$=SS$+" and " 3820 NEXT 3830 ' List matches found 3840 FOR Z=1 TO 10:P(Z)=0:NEXT:Z=0 'P( ) holds # entries on screen 3850 CLS:PRINT:LOCATE ,,0 3860 IF NF THEN PRINT K0$ ELSE PRINT SS$:PRINT:PRINT M$ 'Direct Cmnd. or Srch.$ 3870 PRINT:P=P(Z):L0=CSRLIN 3880 WHILE P<Q AND L0<21:P=P+1:K=H(P) 3890 X.$=FNN$(P)+FNSP$(P)+"("+FNN$(K)+")"+FNSP$(K):R.=L0:C.=1:GOSUB 10130:C.=11 3900 Z$=ID$(K) 3910 WHILE Z$<>"" 3920 IF LEN(Z$)<70 THEN X.$=Z$:R.=L0:GOSUB 10130:Z$="":L0=L0+1:GOTO 3960 3930 L=69:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND 'last space in Z$ on line 3940 X.$=LEFT$(Z$,L-1):R.=L0:GOSUB 10130:L0=L0+1'break at space 3950 Z$=MID$(Z$,L+1) 'remainder of string 3960 WEND 3970 WEND 3980 Z=Z+1:P(Z)=P 3990 IF P(1)<Q THEN M3$="(PgUp,PgDn for earlier, later matches)"ELSE M3$="" 4000 IF Q=0 THEN PRINT M1$ M2$ " ";:L0=CSRLIN:C0=POS(0) ELSE R.=24:C.=1:X.$=M1$:GOSUB 10130 4010 ' Find out what user wants to do 4020 IF Q THEN L0=22:C0=1:R.=25:C.=1:X.$=M2$+M3$:GOSUB 10130 4030 LOCATE L0,C0,1 'turn on cursor 4040 GOSUB 5820:IF RT THEN 240 'get first character of K$ 4050 IF X$="S" OR X$="s" THEN 3010 'new search 4060 IF UP THEN IF Z>1 THEN Z=Z-2:GOTO 3850 ELSE 4040 'PgUp key pressed 4070 IF DN THEN IF P(Z)<Q THEN 3850 ELSE 4040 'PgDn key pressed 4080 LOCATE L0+1,1:PRINT SPC(25); 'erase error msg. 4090 C=C0:K$=X$:LX=79:GOSUB 5910 'get rest of K$ (max len 79) 4100 IF RT THEN 240 'return to menu 4110 ' User entry completed, massage and interpretet it 4120 GOSUB 6590 'strip lead, trail spcs in K$ 4130 IF ER THEN GOSUB 7460:GOTO 4030 'error in K$ 4140 IF K$="S" OR K$="s" THEN 3010 'new search 4150 G$="":Q1=0:E=0:GOSUB 6110 'check K$ 4160 IF E THEN GOSUB 7460:GOTO 4030 'error iΘ*K$ 4170 IF C$="" OR INSTR("PFXR",C$)=0 THEN C$="D" 'default is screen 4180 IF LEFT$(K$,1)="#" THEN K$=MID$(K$,2):BN=1 ELSE BN=0 'BN for "big nums" 4190 'parse K$, set up H1(1)...H1(Q1) as list of note numbers 4200 Q1=0:IF BN THEN MX=M ELSE MX=Q 'largest allowed value 4210 WHILE K$<>"" 4220 C=INSTR(K$,","):IF C=0 THEN C=LEN(K$)+1 4230 L$=LEFT$(K$,C-1):H=INSTR(L$,"-") 4240 IF H THEN N1$=LEFT$(L$,H-1):N2$=MID$(L$,H+1) ELSE N1$=L$:N2$=N1$ 4250 N1=VAL(N1$):N2=VAL(N2$):IF N1>N2 THEN SWAP N1,N2 4260 N1=FN MAX(N1,1):N2=FN MIN(N2,M) 'adjust out-of-range entries 4270 IF BN=0 AND N2>Q THEN E=1:K$="":GOTO 4300 'error - exit loop 4280 FOR I=1 TO N2-N1+1:H1(Q1+I)=N1-1+I:NEXT:Q1=Q1+N2-N1+1 4290 K$=MID$(K$,C+1) 4300 WEND 4310 IF E THEN GOSUB 7460:GOTO 4030 'error in K$ 4320 '********* Follow user's instructions Xn list of notes **************** 4330 IF C$<>"R" OR Q1=1 THEN 4390 ELSE CLS 4340 'R suffix with more than one note - not allowed 4350 PRINT"Only one note can be REPLACED with a single command. Press D, P or F 4360 PRINT"to display, print or file these notes, any other key to start over. 4370 PRINT:AN$=INPUT$(1) 4380 IF INSTR("DdPpFf",AN$) THEN C$=CHR$(ASC(AN$) AND 95) ELSE 3010 4390 GOSUB 6480 'open records file 4400 IF C$<>"F" THEN 4440 'not filing notes 4410 PRINT:PRINT "Include note headers in file (Y/N) ? "; 4420 A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN 240 'menu if Esc pressed 4430 IF A$="N" OR A$="n" THEN HD=0 ELSE HD=1 'include headers as default 4440 FOR P=1 TO Q1:IF BN THEN K=H1(P) ELSE K=H(H1(P)) 'notes to be considered 4450 IF C$="F"AND P=1 THEN GOSUB 6350:IF HD THEN GOSUB 6560 'print header 4460 IF C$="F"AND P>1 THEN PRINT #4,:PRINT #4,:IF HD THEN GOSUB 6560 'header 4470 IF C$<>"D" THEN CLS:LOCATE ,,0:PRINT FN N$(K);TAB(5);ID$(K):PRINT 4480 IF INSTR("PF",C$) THEN PRINT"Sending to ";:IF C$="P" THEN PRINT"printer." ELSE PRINT "file - "G$"." 4490 IF C$="D" THEN GOSUB 4610 'Display 4500 IF C$="P" THEN FLAG=0:GOSUB 5010 'Print 4510 IF C$="F" THEN GOSUB 5410 'File 4520 IF C$="X" THEN GOSUB 6840 'Delete 4530 IF C$="R" THEN REPL=1:GOSUB 5510 'Replace 4540 NEXT 4550 ON ERROR GOTO 0 'cancel error trap for printer failure after startup 4560 IF C$="F" THEN PRINT #4,:PRINT #4, 'in case something is appended later 4570 CLOSE:K$="" 4580 IF C$="X" THEN GOSUB 6920:GOSUB 7000:DC=1 'rewrite KF$ and IDF$,rtrn 4010 4590 IF DC THEN 3010 ELSE 3840 'new search if Direct Command or Deletion 4600 '************************ Display Note *************************** 4610 CLS 4620 PRINT FN N$(K);:Z$=ID$(K) 4630 WHILE Z$<>"" 4640 IF LEN(Z$)<76 THEN PRINT TAB(5)Z$:Z$="":L=L+1:GOTO 4680 4650 J=75:WHILE MID$(Z$,J,1)<>" ":J=J-1:WEND 'last space in Z$ on line 4660 PRINT TAB(5)LEFT$(Z$,J-1):L=L+1 'break at space 4670 Z$=MID$(Z$,J+1) 'remainder of string 4680 WEND 4690 R=REC(K) 'K = num. of note to display 4700 GET #3,R:R=CVI(U$):H=INSTR(T$,"~") 'look for end-of-text marker 4710 IF H=0 THEN H=LEN(T$)+1 'if none, use all of T$ 4720 FOR I=1 TO H-1 'omit eot mark and end spaces 4730 A$=MID$(T$,I,1):A=ASC(A$) AND 127 'get char., strip high bit 4740 IF A<32 AND A<>13 AND A<>9 THEN 4770 'skip controls and LF's 4750 PRINT CHR$(A); 4760 IF A=13 AND CSRLIN>20 THEN GOSUB 4830:IF AB THEN I=H-1 'exit loop 4770 NEXT 4780 IF AB THEN AB=0:GOTO 4810 'abandon this note, get next (if any) 4790 IF R THEN 4700 'note continues on sector R 4800 GOSUB 4830 4810 RETURN 4820 ' Screen full or End of note 4830 IF R>0 OR I<H THEN MM$="Note continues ":X$=" A to abort," ELSE MM$=" End of note ":X$="" 4840 LOCATE 23,1:PRINT MM$:AB=0 4850 PRINT"Press P or F to print or file note,"X$" any other key to continue."; 4860 L0=23:C0=16:GOSUB 6070:LOCATE ,,1 'msg - Esc for Menu;cursor on 4870 CH$="PFA":A$=INPUT$(1) 'CH$ = special characters 4880 IF A$=ESC$ THEN RT=1:RETURN 240 'menu if Esc pressed 4890 A$=CHR$(ASC(A$) AND 95):IF INSTR(CH$,A$) AND I<H THEN AB=1 'set abort flag 4900 IF A$="P"THEN CLS:FLAG=-1:GOSUB 6480:GOSUB 5010:FLAG=0:CLOSE 'print 4910 IF A$="F"THEN GOSUB 6350:GOSUB 6560:GOSUB 5410:CLOSE 4 '#4 is note file 4920 CLS:RETURN 5000 '*********************** Printout Note ************************ 5010 IF NOT FLAG AND P>1 THEN 5120 'question user 1st time only 5020 PRINT "Start new page (Y/N) ?"; 5030 CH$="YyNn"+ESC$ 'acceptable characters 5040 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 5040 5050 IF A$=ESC$ THEN RT=1:RETURN 240 'menu if Esc pressed 5060 LOCATE ,1:PRINT SPACE$(30);:LOCATE ,1 'erase message 5070 IF A$="Y" OR A$="y" THEN D=0:PGF=1 'D=line count,PGF=page flag 5080 PRINT:PRINT "Check printer"; 5090 IF A$="Y" OR A$="y" THEN PRINT ", set top of form."; ELSE PRINT "."; 5100 PRINT " Press any key when ready ..."; 5110 K$=INPUT$(1):IF K$=ESC$ THEN RT=1:RETURN 240 ELSE CLS 5120 IF PGF=1 THEN FOR J=1 TO 4:LPRINT:NEXT:D=5 'first page 5130 IF PGF=0 THEN FOR J=1 TO 2:LPRINT:NEXT:D=D+2 'continuation page 5140 LPRINT FN N$(K);:Z$=ID$(K) 5150 WHILE Z$<>"" 5160 IF LEN(Z$)<76 THEN LPRINT TAB(5)Z$:Z$="":D=D+1:GOTO 5200 5170 J=75:WHILE MID$(Z$,J,1)<>" ":J=J-1:WEND 'last space in Z$ on line 5180 LPRINT TAB(5)LEFT$(Z$,J-1):D=D+1 'break at space 5190 Z$=MID$(Z$,J+1) 'remainder of string 5200 WEND 5210 R=REC(K) 'K = num. of note to print 5220 GET #3,R:R=CVI(U$):H=INSTR(T$,"~") 'look for end-of-text marker 5230 IF H=0 THEN H=LEN(T$)+1 5240 FOR I=1 TO H-1 'ignore trailing spaces in T$ 5250 PGF=0 'clear page flag 5260 A$=MID$(T$,I,1):A=ASC(A$) AND 127 'get char., strip high bit 5270 IF A=10 THEN LPRINT:D=D+1 5280 IF D>60 THEN PGF=2:GOSUB 5350:GOTO 5310 'new page 5290 IF A<32 AND A<>9 THEN 5310 'skip controls and LF's 5300 LPRINT CHR$(A); 'else print character 5310 NEXT:IF R THEN 5220 'note cont on sector R if R>0 5320 IF PGF=0 AND D>55 THEN GOSUB 5350:PGF=2 'page; can't get 5 lines more 5330 RETURN 5340 '------------------- start new page ------------------------------------ 5350 LPRINT CHR$(12):FOR J=1 TO 4:LPRINT:NEXT:D=5:RETURN 5400 '************************* File Note ************************** 5410 R=REC(K) 'K = num. of note to file 5420 GET #3,R:R=CVI(U$):H=INSTR(T$,"~") 'look for end-of-text marker 5430 IF H=0 THEN H=LEN(T$)+1 5440 FOR I=1 TO H-1 'ignore trailing spaces in T$ 5450 A$=MID$(T$,I,1):PRINT #4,A$; 'else put it back like it was 5460 NEXT 5470 IF R THEN 5420 5480 RETURN 5500 '************************* Replace Note ************************** 5510 CLS:PRINT "Files on default drive/directory are:":PRINT:FILES:PRINT 5520 PRINT "Enter filespec of file containing replacement note : "; 5530 L0=CSRLIN:C0=POS(0) 'input location 5540 LX=14:GOSUB 6280:SF$=K$:K$="":ID=0:PRINT 'get filespec 5550 ON ERROR GOTO 7220 5560 CLOSE 1:OPEN "i",1,SF$ 5570 ON ERROR GOTO 0 5580 CLS:N=REC(K):LOCATE 4,4:PRINT"Working ... "; 'replacing note #K 5590 WHILE A<>ST AND NOT EOF(1):A=ASC(INPUT$(1,1)) AND 127:WEND 'look for hdr 5600 IF EOF(1) THEN PRINT"Error - no identifier. Please check file.":GOTO 250 5610 M0=M:M=K-1 'need "M" for ID$ subroutine 5620 GOSUB 1690 'format ID$, update KWs 5630 M=M0 'restore value of M 5640 IF NOT SAME.ID THEN GOSUB 6920:GOSUB 7000 'rewrite KF$ and IDF$ 5650 GET #3,1 : RM=CVI(U$) 'current max record number 5660 FOR I=N TO RM:U(I)=1:NEXT 'mark used sectors 5670 GOSUB 1410 'replace note 5680 IF RMAX>RM THEN LSET U$=MKI$(RMAX):PUT #3,1 'update max sector number 5690 IF KW>KW.MAX-32 THEN LN=4:GOTO 7500 'too many keywords possible 5700 LOCATE 4,4:PRINT "Note replaced.":CLOSE:REPL=0 'clear flag 5710 RETURN 5800 '********************* Utility Subroutines *********************** 5810 ' Single Character input routine 5820 WHILE INKEY$<>"":WEND:UP=0:DN=0 'clear 5830 X$=INKEY$:IF X$="" THEN 5830 'get one keypress 5840 IF LEN(X$)=1 THEN A=ASC(X$):GOTO 5880 'ordinary key 5850 A=ASC(MID$(X$,2)) 'control key 5860 IF A=72 OR A=73 THEN UP=1 'PgUp or up arrow 5870 IF A=80 OR A=81 THEN DN=1 'PgDn or down arrow 5880 IF A=27 OR (A=13 AND K$="") THEN RT=1 ELSE RT=0 'return-to-menu flag 5890 RETURN 5900 ' String input routine 5910 L=LEN(K$):KK$="":R.=L0:C.=C0:X.$=SPACE$(LX):GOSUB 10130:LOCATE L0,C0,1:PRINT K$; 5920 WHILE INKEY$<>"":WEND 'clear buffer 5930 WHILE L<LX 5940 KK$=INPUT$(1):IF KK$=CR$ OR KK$=ESC$ THEN L=LX:GOTO 5990 'exit loop 5950 IF KK$<>BK$ THEN 5980 ELSE IF L=0 THEN 5990 5960 'backspace key pressed 5970 C=POS(0)-1:LOCATE,C:PRINT" ";:L=L-1:K$=LEFT$(K$,L):LOCATE ,C:GOTO 5990 5980 PRINT KK$;:K$=K$+KK$:L=L+1 5990 WEND:IF KK$=ESC$ THEN K$="":RT=1 6000 RETURN 6010 ' Clear arrays for new search string input 6020 FOR I=1 TO 10:N(I)=0:FOR P=1 TO 10:S$(I,P)="":NEXT:NEXT 6030 FOR P=1 TO Q:H(P)=0:NEXT:FOR P=1 TO Q1:H1(P)=0:NEXT 6040 P=0:Q=0:Q1=0:BN=0 6050 RETURN 6060 ' Print message : Esc = Menu 6070 R.=25:C.=1:X.$="**** Esc for Menu ****":GOSUB 10130 6080 LOCATE L0,C0,0 6090 RETURN 6100 ' Massage numeric entry string (direct command) 6110 E=0:IF LEFT$(K$,1)="#" THEN X$=MID$(K$,2):K$="#" ELSE X$=K$:K$="" 6120 IF X$="" THEN E=1:RETURN 'error - reenter 6130 C$=RIGHT$(X$,1):IF C$<"0" OR C$>"9" THEN X$=LEFT$(X$,LEN(X$)-1) 6140 IF X$="" THEN E=1:RETURN 'error - reenter 6150 C$=CHR$(ASC(C$) AND 95) 'convert to upper case 6160 IF INSTR("DPFRX",C$)=0 THEN C$="" 'only allowable suffixes 6170 FOR I=1 TO LEN(X$):A$=MID$(X$,I,1) 6180 IF INSTR(V0$,A$) THEN K$=K$+A$ 6190 NEXT 6200 IF RIGHT$(K$,1)="," OR RIGHT$(K$,1)="-" THEN K$=LEFT$(K$,LEN(K$)-1) 6210 IF K$="" THEN E=1 6220 RETURN 6230 ' Show help screen 6240 GOSUB 8230:LOCATE 21,1:PRINT "Enter search string or Direct Command:" 6250 L0=22:C0=1:X$="" 6260 RETURN 6270 ' Filespec input (set location L0,C0 before calling) 6280 GOSUB 6070:LOCATE ,,1 'msg - Esc for Menu 6290 GOSUB 5910:IF RT THEN RETURN 240 6300 FOR I=1 TO LEN(K$):A=ASC(MID$(K$,I,1)) 6310 IF 96<A AND A<123 THEN MID$(K$,I,1)=CHR$(A-32) 'convert K$ to uc 6320 NEXT 6330 RETURN 6340 ' Get filespec, open file for saving note 6350 CLS:X.$="Enter drive (A,B,C,D) to contain new note files : " 6360 R.=1:C.=1:GOSUB 10130 6370 LOCATE 1,51:K$=INPUT$(1):IF K$=ESC$ THEN RT=1:RETURN 240 'menu 6380 K$=CHR$(ASC(K$) AND 95):IF INSTR("ABCD",K$)=0 THEN 6370 6390 PRINT:D$=K$:K$="":DR$=D$+":*.*":FILES DR$:PRINT 'list files on drive K$ 6400 PRINT "Enter name of file to contain notes : ";:L0=CSRLIN:C0=POS(0):PRINT 6410 PRINT "(Notes will be APPENDED if file already exists) 6420 LX=14:GOSUB 6280:G$=K$:K$="":IF INSTR(G$,":")=0 THEN G$=D$+":"+G$ 6430 ON ERROR GOTO 7220 6440 CLOSE 4:OPEN G$ FOR APPEND AS #4 6450 ON ERROR GOTO 0 6460 RETURN 6470 ' Open records file 6480 CLOSE 3:OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$ 6490 RETURN 6500 ' Set end-of-text marker 6510 A$=RIGHT$(X$,1):IF A$="" THEN 6530 ELSE A=ASC(A$) 6520 IF A<33 THEN X$=LEFT$(X$,LEN(X$)-1):GOTO 6510 6530 X$=X$+"~" 6540 RETURN 6550 ' Print header on filed note 6560 PRINT #4,:PRINT #4,ST$ ID$(K) EN$ 6570 RETURN 6580 ' Strip lead, trail spaces from K$, set error flag if K$="" 6590 ER=0 6600 WHILE LEFT$(K$,1)=" ":K$=MID$(K$,2):WEND 6610 WHILE RIGHT$(K$,1)=" ":K$=LEFT$(K$,LEN(K$)-1):WEND 6620 IF K$="" THEN ER=1 'error - nothing left 6630 RETURN 6640 ' Decrement multiplicities of keywords in Y$ 6650 WHILE Y$<>"" 6660 H=INSTR(Y$,DL$):IF H=0 THEN H=LEN(Y$)+1 6670 Z$=LEFT$(Y$,H-1):Y$=MID$(Y$,H+1) 'Z$=keyword in Y$ 6680 GOSUB 6730 'find B so that K$(B)=Z$ 6690 M(B)=M(B)-1 ' and decrement M(B) 6700 WEND 6710 RETURN 6720 ' Find Z$ in KWD list 6730 A=0:B=KW 'start binary search 6740 WHILE B-A>1:C=(A+B)\2 'halve interval 6750 IF Z$<=W$(C) THEN B=C 'z$ in lower half 6760 IF Z$>=W$(C) THEN A=C 'z$ in upper half 6770 WEND 'should have W$(B)=Z$ 6780 IF W$(B)<>Z$ THEN PRINT:PRINT "Error - keyword "Q$Z$Q$" from identifier"K"not found.":PRINT "Check files.":RETURN 250 'return to menu if error 6790 RETURN 6800 ' Delete W$(J) from KWD list 6810 FOR I=J TO KW-1:W$(I)=W$(I+1):M(I)=M(I+1):NEXT:W$(KW)="":M(KW)=0:KW=KW-1 6820 RETURN 6830 ' Delete note #K from active files 6840 R=REC(K) 'K = num. of note to delete 6850 WHILE R:GET #3,R:U(R)=0:R=CVI(U$):WEND 'make sectors available 6860 Y$=ID$(K):GOSUB 6650 'dec M(J) for K$(J) in Y$ 6870 FOR I=K TO M-1 'delete ID$(K),REC(K) 6880 ID$(I)=ID$(I+1):REC(I)=REC(I+1) 6890 NEXT:ID$(M)="":REC(M)=0:M=M-1 6900 RETURN 6910 ' Write keyword file and array 6920 CLOSE 4:OPEN "o",4,KF$:J=0 6930 FOR I=1 TO KW 6940 IF M(I)<1 THEN 6970 'skip deleted kwds 6950 WRITE #4,W$(I);M(I) 'M(I) = multiplicity 6960 J=J+1:W$(J)=W$(I):M(J)=M(I) 'update arrays W$( ), M( ) 6970 NEXT:KW=J:CLOSE 4 6980 RETURN 6990 ' Write identifier file 7000 CLOSE 2:OPEN "o",2,IDF$ 7010 FOR I=1 TO M 7020 WRITE #2,ID$(I);REC(I) 'REC(I) = starting record # 7030 NEXT:CLOSE 2 7040 RETURN 7200 '********************** Error traps ***************************** 7210 ' Trap for filespec error 7220 IF ERR=52 OR ERR=53 OR ERR=55 OR ERR=64 OR ERR=67 THEN PRINT:PRINT: PRINT:PRINT "Filespec error - please reenter.":PRINT ELSE 7270 7230 IF ERL=1100 OR ERL=1110 OR ERL=1120 THEN RESUME 1060 7240 IF ERL=1310 OR ERL=1320 OR ERL=1330 THEN RESUME 1260 7250 IF ERL=5560 THEN RESUME 5540 7260 IF ERL=6440 THEN RESUME 6420 7270 ON ERROR GOTO 0 7280 ' Trap for open drive door, blank disk, etc. 7290 IF ERR<>53 AND ERR<>71 THEN 7310 7300 PRINT "No file on drive "A$:RESUME 830 7310 ON ERROR GOTO 0 7320 ' Printer failure during printout 7330 IF ERR=24 OR ERR=25 OR ERR=27 THEN PRINT:PRINT" Printer trouble. ";:PRINT "Printout aborted. Press any key to return to menu";:A$=INPUT$(1):RESUME 100 7340 ON ERROR GOTO 0 7350 ' Configuration file missing 7360 CLS:IF ERR<>53 THEN 7410 7370 COLR=1:FG=15:BG=1:BR=1:ST=123:EN=125:UC=1:DL=32:KW$="'-_" 'defaults 7380 PRINT"Configuration file missing. Do you wish to create one now (Y/N) ? "; 7390 A$=INPUT$(1):IF A$="Y"OR A$="y" THEN GOSUB 310:GOTO 7400 7392 PRINT"Are you using a color monitor (Y/N) ?":A$=INPUT$(1) 7394 IF INSTR("YyNn",A$)=0 THEN 7390 7396 IF A$="N" OR A$="n" THEN COLR=0 7400 RESUME 65 7410 ON ERROR GOTO 0 7420 ' No keywords error 7430 PRINT:PRINT "Error - no keywords in Identifier"M+1 7440 GOTO 250 'return to menu 7450 ' Error in direct command 7460 BEEP:LOCATE L0+1,1 7470 PRINT"Error - please reenter."; 7480 RETURN 7490 ' Error in source file, or too many of something 7500 CLS:ON LN GOSUB 7600,7640,7690,7720:GOTO 7510 7510 GOSUB 6920:GOSUB 7000 'save keywords and ID$'s 7520 LSET U$=MKI$(RMAX):PUT #3,1 'save RMAX in rec file 7530 IF LN<>2 THEN PRINT:PRINT "Warning : DO NOT add to this file; you might lose it. 7540 PRINT:PRINT"Notes have been correctly entered up to and including #"FNN$(M)", with header :" 7550 PRINT:PRINT ST$ ID$(M) EN$:IF REPL THEN REPL=0:PRINT:PRINT "Also, Note #"FNN$(K)" has been replaced with "SF$"." 7560 CLOSE:ACTIVE=1 'housekeeping 7570 GOTO 250 'return to Menu 7580 '---------- Sub-Subs for last error routine -------------- 7590 'LN = 1 (N >= N.MAX) 7600 PRINT "Records file filled." 7610 IF E=0 THEN K=M:GOSUB 6840 'delete note M if incomplete 7620 RETURN 7630 'LN = 2 (CNT > H.MAX) 7640 PRINT "Error -identifier too long. Check for missing "; 7650 PRINT Q$ EN$ Q$" or unwanted "Q$ ST$ Q$" in note"M 7660 PRINT"with header beginning :":PRINT:PRINT ST$ LEFT$(X$,159):PRINT:M=M-1 7670 RETURN 7680 'LN = 3 (M > M.MAX) 7690 PRINT "Only"M.MAX"notes are allowed; you have already used your quota." 7700 RETURN 7710 'LN = 4 (KW > KW.MAX) 7720 PRINT "Only"KW.MAX"keywords are allowed; you have"KW"already." 7730 PRINT "One more note might add too many keywords. 7740 RETURN 7800 '******************** String Initialization *********************** 7810 XS$=" SEARCH STRING format (max 79 characters) : 7820 YS$=" (A1 or A2 or ... or An) and (B1 or B2 or ... or Bm) and ... ... 7830 ZS$=" (The A's and B's are keywords; parentheses are optional) 7840 PS$=" A Direct Command consists of the symbol # followed by a list " 7850 QS$=" of numbers (or ranges of numbers) identifying notes to be found." 7860 RS$=" For example, #2-5,7,10,15-20 and #3,5,9,10,30-33 P are valid. " 7870 TS$=" The numbers refer to positions of the notes in the Source File. " 7880 US$=" Use D,P,F,X,R to Display, Print, File, Delete or Replace notes. " 7890 UC$="ABCDEFGHIJKLMNOPQRSTUVWXYZ":LC$="abcdefghijklmnopqrstuvwxyz" 7900 V0$="?0123456789,-" 'valid in Direct Commands 7910 V1$=UC$+MID$(V0$,2,10)+KW$ 'valid in keywords 7920 IF UC=0 THEN V1$=LC$+V1$ 'valid in kwds if lc allowed 7940 RETURN 8000 '******************* Screen Print Routines ************************ 8010 ' Menus 8020 CLS:LOCATE ,,0:X.$="Menu":R.=1:C.=34:GOSUB 10130 8030 X.$="1 List files available":R.=4:C.=26:GOSUB 10130 8040 X.$="2 SELECT Trilogy files":GOSUB 10130 8050 X.$="3 CREATE Trilogy files":GOSUB 10130 8060 IF ACTIVE=0 THEN 8120 8070 X.$="4 UPDATE Trilogy files":GOSUB 10130 8080 X.$="5 SEARCH Trilogy files":GOSUB 10130 8090 X.$="6 List keywords":GOSUB 10130 8100 X.$="7 List identifiers":GOSUB 10130 8120 X.$="8 Set defaults":IF ACTIVE THEN GOSUB 10130 ELSE MID$(X.$,1)="4":GOSUB 10130 8130 X.$="9 Exit program":IF ACTIVE THEN GOSUB 10130 ELSE MID$(X.$,1)="5":GOSUB 10130 8140 C.=13:IF ACTIVE THEN R.=16 ELSE R.=11 8150 X.$=CHR$(201)+STRING$(47,205)+CHR$(187):GOSUB 10130 8160 X.$=CHR$(186)+" Use the arrow keys "+CHR$(24)+CHR$(25)+" to position the marker, "+CHR$(186):GOSUB 10130 8170 X.$=CHR$(186)+" press Enter to select the indicated option. "+CHR$(186):GOSUB 10130 8180 X.$=CHR$(186)+" (Or just press the number of your choice.) "+CHR$(186):GOSUB 10130 8190 X.$=CHR$(200)+STRING$(47,205)+CHR$(188):GOSUB 10130 8200 RETURN 8210 ' Help Screen (Search String entry) 8220 CLS:LOCATE ,,0:R.=3:C.=1 8230 X.$=CHR$(218)+STRING$(75,196)+CHR$(191):GOSUB 10130 8240 X.$=CHR$(179)+XS$+STRING$(32,32)+CHR$(179):GOSUB 10130 8250 X.$=CHR$(179)+STRING$(75,32)+CHR$(179):GOSUB 10130 8260 X.$=CHR$(179)+YS$+STRING$(6,32)+CHR$(179):GOSUB 10130 8270 X.$=CHR$(179)+STRING$(75,32)+CHR$(179):GOSUB 10130 8280 X.$=CHR$(179)+ZS$+STRING$(17,32)+CHR$(179):GOSUB 10130 8290 X.$=CHR$(192)+STRING$(75,196)+CHR$(217):GOSUB 10130 8300 R.=R0.+1:C.=6 8310 X.$=CHR$(218)+STRING$(65,196)+CHR$(191):GOSUB 10130 8320 X.$=CHR$(179)+PS$+CHR$(179):GOSUB 10130 8330 X.$=CHR$(179)+QS$+CHR$(179):GOSUB 10130 8340 X.$=CHR$(179)+STRING$(65,32)+CHR$(179):GOSUB 10130 8350 X.$=CHR$(179)+RS$+CHR$(179):GOSUB 10130 8360 X.$=CHR$(179)+STRING$(65,32)+CHR$(179):GOSUB 10130 8370 X.$=CHR$(179)+TS$+CHR$(179):GOSUB 10130 8380 X.$=CHR$(179)+US$+CHR$(179):GOSUB 10130 8390 X.$=CHR$(192)+STRING$(65,196)+CHR$(217):GOSUB 10130 8400 R.=21:C.=1:X.$="Enter search string or Direct Command:":GOSUB 10130 8410 L0=22:C0=1:RETURN 9990 '********* Load ML display program in array FP( ) ************** 10000 I=0:N0=0:N1=26:X$="":FP=VARPTR(FP(0)):GOSUB 10060 10010 IF MONO THEN FOR I=1 TO 13:READ X$:NEXT 'no need to wait for retrace 10020 N0=27:N1=35+13*(1-MONO):GOSUB 10060 10030 IF MONO THEN POKE FP+12,&HB0:POKE FP+30,&HFC 'change scrn buffer, jmp adr 10040 RETURN 10050 'read part of data, poke into array 10060 FOR I=N0 TO N1:READ X$:POKE FP+I,VAL("&h"+X$):NEXT 10070 RETURN 10080 '************* Data for Fast Print Routines ******************** 10090 DATA 55,8B,EC,06,8B,76,08,8B, 44,02,BB,00,B8,8E,C3,8A 10100 DATA 0C,B5,00,8B,76,06,8B,3C, 8B,F0,FC,BA,DA,03,EC,A8 10110 DATA 01,75,FB,EC,A8,01,74,FB, A4,47,E2,F2,07,5D,CA,04, 00 10120 '************** Print X.$ at location (R.,C.) ****************** 10130 IF X.$="" THEN RETURN 10140 IF R.<>0 THEN R0.=R. ELSE R.=R0.+1:R0.=R. 'increment row as default 10150 IF C.<>0 THEN C0.=C. ELSE C.=C0.-(C0.=0):C0.=C. 'retain column as default 10160 L.=160*(R.-1)+2*(C.-1) 10170 R.=0:C.=0:FP=VARPTR(FP(0)) 10180 CALL ABSOLUTE(X.$,L.,FP) 10190 RETURN 
