home *** CD-ROM | disk | FTP | other *** search
/ Power Programming / powerprogramming1994.iso / progtool / database / trilogy.arc / TRILOGY.BAS next >
BASIC Source File  |  1988-04-04  |  47KB  |  833 lines
  1. 1 '                         Trilogy.BAS
  2. 2 '
  3. 3 '                       February 2, 1987
  4. 4 '
  5. 5 '                  Copyright (c) 1986 B. J. Ball
  6. 6 '
  7. 7 '
  8. 10 DEFINT A-Z:RECL=256:M.MAX=500:KW.MAX=1500:N.MAX=2000:H.MAX=160
  9. 11 ESC$=CHR$(27):CR$=CHR$(13):BK$=CHR$(8):Q$=CHR$(34)   'frequently used str's
  10. 12 '
  11. 13 'RECL=rec len, M.MAX=#notes, KW.MAX=#keywords, N.MAX=#recrds, H.MAX=hdr.len.
  12. 14 '
  13. 15 DIM ID$(500),REC(500),W$(1532),M(1532),U(2000),S$(10,10)
  14. 20 DIM H(500),H1(500),N(20),P(20),CH$(9),C$(4),B$(1),FP(25)
  15. 21 '
  16. 22 '   ID$( )=identifiers, REC( )=starting rec#, W$( )=kwrds, M( )=mult kwrds
  17. 23 '   DIM ID$( ),REC( ),H( ),H1( ) is M.MAX
  18. 24 '   DIM W$( ) and M( ) is KW.MAX+estimated max #kwds/hdr,DIM U( ) is N.MAX+1
  19. 25 '   S$( , ) and N( ) are used in search strings, FP( ) for the ML routine
  20. 26 '
  21. 30 DEF FN N$(X)=MID$(STR$(X),2):DEF FN SP$(X)=SPACE$(5-LEN(STR$(X)))'format $'s
  22. 35 DEF FN MAX(A,B)=A-(B>A)*(B-A):DEF FN MIN(A,B)=A-(B<A)*(B-A)
  23. 40 ' get configuration data
  24. 45 ON ERROR GOTO 7360
  25. 50   OPEN "i",1,"trilogy.cnf"
  26. 55 ON ERROR GOTO 0
  27. 60 INPUT #1,COLR,FG,BG,BR,ST,EN,UC,DL,H.MAX,KW$:CLOSE
  28. 65 ST$=CHR$(ST):EN$=CHR$(EN):DL$=CHR$(DL):WIDTH 80:SCREEN 0,1
  29. 70 IF COLR THEN COLOR FG,BG,BR
  30. 75 DEF SEG=0:IF (PEEK(1040) AND 48)=48 THEN MONO=1 ELSE MONO=0:DEF SEG
  31. 80 GOSUB 10000                                    'load ML fast-print program
  32. 85 GOSUB 7800                                     'initialization
  33. 90 '                            Display Menu
  34. 100 GOSUB 8020:R1=4:C1=24:MAX=5+4*ACTIVE:LOCATE 23,1,0:IF ACTIVE=0 THEN 130
  35. 110 X.$="Trilogy :   "+RF$+"   "+IDF$+"   "+KF$:R.=23:C.=16:GOSUB 10130
  36. 120 '                           Get user choice
  37. 130 A=0:CHOICE=0:LOCATE R1,C1,0:PRINT CHR$(16)
  38. 140 WHILE CHOICE=0
  39. 150   GOSUB 5820                                  'get char. (and A)
  40. 160   IF A=13 THEN RT=0:CHOICE=R1-3               'accept cursor entry
  41. 170   IF UP AND R1>4 THEN LOCATE R1,C1:PRINT" ":R1=R1-1:LOCATE R1,C1,0:PRINT CHR$(16)
  42. 180   IF DN AND R1<3+MAX THEN LOCATE R1,C1:PRINT" ":R1=R1+1:LOCATE R1,C1,0:PRINT CHR$(16)
  43. 190   IF 48<A AND A<49+MAX THEN CHOICE=A-48       'accept numeric entry
  44. 200 WEND:CLS:LOCATE 4,1,0
  45. 210 IF CHOICE=MAX THEN IF COLR THEN COLOR 7,0,0:CLS:END ELSE CLS:END
  46. 215 IF CHOICE=MAX-1 THEN GOSUB 310:GOTO 240       'make configuration file
  47. 220 ON CHOICE GOSUB 810,1010,1210,1220,3010,2110,2510
  48. 230 '                           Return to menu
  49. 240 IF RT THEN RT=0:CLOSE:GOTO 100                     'direct return
  50. 250 L0=24:C0=1:GOSUB 6070                         'msg - Esc for Menu
  51. 260 A$=INPUT$(1):GOTO 100                         'wait, then return
  52. 300 '**************** Create or Change CNF File *********************
  53. 310 CLS:PRINT "    Enter C for color monitor, M for monochrome    : ";
  54. 320 L=CSRLIN:C=POS(0):X$="CM":IF COLR THEN DF$="C" ELSE DF$="M"
  55. 330 GOSUB 710:IF A$="C" THEN COLR=1 ELSE COLR=0
  56. 340 IF COLR=0 THEN 420
  57. 350 PRINT TAB(16)"Enter color numbers for  foreground : ";:L0=CSRLIN:C0=POS(0)
  58. 360 PRINT TAB(41)"background : ";:L1=CSRLIN:C1=POS(0)
  59. 370 PRINT TAB(45)"border : ";:L2=CSRLIN:C2=POS(0)
  60. 380 L=L0:C=C0:DF$="  ":LSET DF$=FNN$(FG):X$="0123456789101112131415":GOSUB 710:FG=VAL(A$)
  61. 390 L=L1:C=C1:LSET DF$=FNN$(BG):X$="0123456789":GOSUB 710:BG=VAL(A$)
  62. 400 IF FG=BG THEN 770                             'error routine
  63. 410 L=L2:C=C2:LSET DF$=FNN$(BR):GOSUB 710:BR=VAL(A$)
  64. 420 PRINT "Type desired left  header marker and press Enter   : ";
  65. 430 L=CSRLIN:C=POS(0):DF$=CHR$(ST):X$=""
  66. 440 GOSUB 710:IF LEN(A$)>1 THEN 440 ELSE ST$=A$:ST=ASC(A$):IF INSTR(KW$,ST$) THEN 440
  67. 450 PRINT "Type desired right header marker and press Enter   : ";
  68. 460 L=CSRLIN:C=POS(0):DF$=CHR$(EN)
  69. 470 GOSUB 710:IF LEN(A$)>1 THEN 470 ELSE EN$=A$:EN=ASC(A$):IF INSTR(KW$,EN$) THEN 470
  70. 480 PRINT "Enter maximum length to be allowed for headers     : ";
  71. 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$"   "
  72. 500 PRINT "Are keywords allowed to contain spaces (Y/N) ?     : ";
  73. 510 L=CSRLIN:C=POS(0):X$="YN":IF INSTR(KW$," ") THEN DF$="Y" ELSE DF$="N"
  74. 520 GOSUB 710:IF A$="N" THEN  DL=32 ELSE IF INSTR(KW$," ")=0 THEN KW$=" "+KW$
  75. 530 PRINT "Letters, numbers and the three symbols  '-_  are
  76. 540 PRINT "always acceptable in keywords. Type ALL other
  77. 550 PRINT "non-space symbols you wish to allow and press Enter: ";
  78. 560 L=CSRLIN:C=POS(0):DF$="":X$="":GOSUB 710:IF A$="" THEN 570 ELSE KW$="'-_"
  79. 562   FOR I=1 TO LEN(A$):X$=MID$(A$,I,1)
  80. 564      IF INSTR(KW$+"*#",X$) THEN 568 ' * and # are not allowed in keywords
  81. 566      KW$=KW$+X$
  82. 568   NEXT:X$=""
  83. 570 IF INSTR (KW$," ")=0 THEN 610
  84. 580 PRINT"Type the desired keyword delimiter and press Enter : ";
  85. 590 L=CSRLIN:C=POS(0):DL$=CHR$(DL):IF DL$<>" " THEN DF$=DL$ ELSE DF$=","
  86. 600 GOSUB 710:IF LEN(A$)>1 THEN 600 ELSE DL=ASC(A$):DL$=CHR$(DL):IF INSTR(KW$,DL$) THEN 600
  87. 610 PRINT "Shall letters in keywords be converted to capitals ? ";
  88. 620 L=CSRLIN:C=POS(0):X$="YN":IF UC THEN DF$="Y" ELSE DF$="N"
  89. 630 GOSUB 710:IF A$="Y" THEN  UC=1 ELSE UC=0
  90. 640 PRINT:PRINT"   Save these values for automatic use later (Y/N) ? ";
  91. 650 L=CSRLIN:C=POS(0):DF$="Y":X$="YN":GOSUB 710
  92. 660 IF A$="N"THEN 690
  93. 670 OPEN"o",5,"trilogy.cnf":PRINT#5,COLR;FG;BG;BR;ST;EN;UC;DL;H.MAX;KW$:CLOSE 5
  94. 680 IF COLR THEN COLOR FG,BG,BR
  95. 690 RETURN
  96. 700 '------------------ short space-saver sub subs -----------------
  97. 710 LOCATE L,C:PRINT DF$"   ";:LOCATE L,C:LINE INPUT"",A$:IF A$=""THEN A$=DF$:RETURN
  98. 720 IF A$=ESC$ THEN RETURN 100
  99. 730 IF LEN(A$)=1 THEN A=ASC(A$):IF 96<A AND A<123 THEN A=A-32:A$=CHR$(A)
  100. 740 IF X$<>"" THEN IF INSTR(X$,A$)=0 THEN 710
  101. 750 LOCATE L,C:PRINT A$" ";
  102. 760 RETURN
  103. 770 '      Foreground=Background error
  104. 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
  105. 790  '--------------------------------------------------------------
  106. 800 '******************** List Available Files **********************
  107. 810 OP1=-1                                        'OP1 = called from Menu
  108. 820 L0=1:C0=1:GOSUB 6070                          'msg - Esc for Menu
  109. 830 PRINT:PRINT"Press drive letter (A,B,C,D) for list of files";
  110. 840 IF NOT OP1 THEN PRINT ", or press Enter to continue ";
  111. 850 PRINT ": ";:L0=CSRLIN:C0=POS(0):LOCATE L0,C0,1
  112. 860 CH$="AaBbCcDd"+ESC$+CR$                       'acceptable characters
  113. 870 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 870
  114. 880 IF A$=CR$ THEN RT=OP1:OP1=0:GOTO 970          'return
  115. 890 IF A$=ESC$ THEN RT=1:OP1=0:RETURN 240         'return directly to menu
  116. 900 A$=CHR$(ASC(A$) AND 95)                       'convert to upper case
  117. 910 D$=A$+":*.*":PRINT
  118. 920   ON ERROR GOTO 7290
  119. 930 PRINT:IF NOT OP1 THEN PRINT
  120. 940 PRINT "Files on drive "A$" are:":FILES D$
  121. 950   ON ERROR GOTO 0
  122. 960 GOTO 830
  123. 970 RETURN
  124. 1000 '******************** Select TRILOGY files **********************
  125. 1010 CLS:PRINT "Files on default drive/directory are:":PRINT:FILES:PRINT
  126. 1020 X.$="Enter the "+Q$+"generic"+Q$+" name of the desired files : "
  127. 1030 L0=CSRLIN:C0=49:R.=L0:C.=1:GOSUB 10130       'L0,C0 is input location
  128. 1040 X.$="(Generic name must appear with all of the extensions .ID,.KW,.REC)"
  129. 1050 GOSUB 10130
  130. 1060 LX=8:K$="":GOSUB 6280                        'get generic name
  131. 1070 IDF$=K$+".ID":RF$=K$+".REC":KF$=K$+".KW"     'make Trilogy file names
  132. 1080 CLOSE:ACTIVE=0
  133. 1090    ON ERROR GOTO 7220
  134. 1100 OPEN "i",2,IDF$
  135. 1110 OPEN "i",4,KF$
  136. 1120 OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$
  137. 1130    ON ERROR GOTO 0
  138. 1140 CLS:PRINT"Loading "K$ "... ":K$=""
  139. 1150 M=0:WHILE NOT EOF(2):M=M+1:INPUT #2,ID$(M),REC(M):WEND:CLOSE 2
  140. 1160 KW=0:WHILE NOT EOF(4):KW=KW+1:INPUT #4,W$(KW),M(KW):WEND:CLOSE 4
  141. 1170 GET #3,1:RMAX=CVI(U$):ACTIVE=1:RT=1          'RT to bypass "Press key ...
  142. 1180 FOR I=1 TO RMAX:U(I)=1:NEXT                  'mark used sectors
  143. 1190 RETURN
  144. 1200 '********** Create or Update ID and Records Files **************
  145. 1210 NEWFILES=1:F$="Source":GOTO 1230             'create new files
  146. 1220 NEWFILES=0:F$="Update"                       'update old files
  147. 1230 GOSUB 820:PRINT                              'list files if desired
  148. 1240 X.$="Filespec of "+F$+" File  (need not be on default drive) : "
  149. 1250 L0=CSRLIN+1:C0=59:R.=L0:C.=1:GOSUB 10130     'L0,C0 is input loc.
  150. 1260 LX=14:GOSUB 6280:SF$=K$                      'source filespec
  151. 1270 H=INSTR(K$,":"):K$=MID$(K$,H+1):H=INSTR(K$,"."):IF H THEN K$=LEFT$(K$,H-1)
  152. 1280 IF NEWFILES THEN IDF$=K$+".ID":RF$=K$+".REC":KF$=K$+".KW"
  153. 1290 CLOSE:K$="":ACTIVE=0:IF NEWFILES THEN FOR I=1 TO RMAX:U(I)=0:NEXT
  154. 1300     ON ERROR GOTO 7220
  155. 1310 OPEN "i",1,SF$:IF NEWFILES THEN N=1:M=0:KW=0:NN=0 'rcrd#,id#,#kwrds,note#
  156. 1320 IF NEWFILES THEN OPEN "o",2,IDF$ ELSE OPEN IDF$ FOR APPEND AS #2
  157. 1330 OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$
  158. 1340     ON ERROR GOTO 0
  159. 1350 IF NEWFILES=0 THEN GET #3,1:RMAX=CVI(U$):N=RMAX    'max record number
  160. 1360 CLS:X.$="Working on file "+SF$:R.=1:C.=1:GOSUB 10130:A=0
  161. 1370 X.$="Currently processing note number":R.=3:GOSUB 10130
  162. 1380 WHILE A<>ST AND NOT EOF(1):A=ASC(INPUT$(1,1)) AND 127:WEND 'look for hdr
  163. 1390 IF EOF(1) THEN PRINT"Error - no identifiers found.":RETURN
  164. 1400 N=N+1:U(N)=1:GOSUB 1670                      'format first header
  165. 1410 WHILE NOT EOF(1)
  166. 1420   X$="":I=0:I0=0:E=0:HD=0
  167. 1430   WHILE I<RECL-2
  168. 1440    A$=INPUT$(1,1):A=ASC(A$)                  'get one character
  169. 1450    IF A=ST OR A=ST+128 THEN E=1:HD=1         'header so end of note
  170. 1460    IF EOF(1) THEN E=1                        'eof    so end of note
  171. 1470    IF E THEN I0=I:I=RECL-2:GOTO 1490         'exit   if end of note
  172. 1480    X$=X$+A$:I=I+1                            'augment string
  173. 1490   WEND
  174. 1500   IF E THEN GOSUB 6510                       'set end-of-text marker
  175. 1510   N0=N:WHILE U(N) AND N<=N.MAX:N=N+1:WEND    'find 1st unused record > N
  176. 1520   IF N>N.MAX THEN LN=1:GOTO 7500 ELSE U(N)=1 'cannot add any more records
  177. 1530   IF E THEN LSET U$=MKI$(0):GOTO 1550        'end of note
  178. 1540    LSET U$=MKI$(N)                           'note continues on N
  179. 1550   LSET T$=X$:PUT #3,N0                       'write part of note
  180. 1560   IF N0>RMAX THEN RMAX=N0                    'max record # so far
  181. 1570   IF HD AND REPL=0 THEN GOSUB 1670           'get next header if not repl
  182. 1580 WEND
  183. 1590 GOSUB 6920                                   'save keywords and mult's
  184. 1600 IF REPL THEN RETURN                          'just replacing a note
  185. 1610 LSET U$=MKI$(RMAX):PUT #3,1                  'save RMAX in rec file
  186. 1620 IF KW>KW.MAX-32 THEN LN=4:GOTO 7500          'too many keywords possible
  187. 1630 CLOSE:ACTIVE=1                               'housekeeping
  188. 1640 BEEP:BEEP:LOCATE 5,1::PRINT "All Done!"      'guess what?
  189. 1650 RETURN
  190. 1660 '-------------------- Format identifier, Update KW List ----------------
  191. 1670 IF M=M.MAX THEN LN=3:GOTO 7500               'maximum # notes already in
  192. 1680 NN=NN+1:LOCATE 3,33:PRINT NN;                'note being processed
  193. 1690 X$="":ID$="":CNT=0:DF=0                      'DF is delimiter flag
  194. 1700 A$=INPUT$(1,1):A=ASC(A$) AND 127             'get char, strip high bit
  195. 1710 WHILE A<>EN AND NOT EOF(1)                   'A$ <> end-of-hdr marker
  196. 1720   IF UC THEN IF 96<A AND A<123 THEN A=A-32   'lc to caps if UC
  197. 1730   IF INSTR(V1$,CHR$(A)) THEN X$=X$+CHR$(A) ELSE A$=DL$
  198. 1740                     'add valid chars to ID$, change others to delimiters
  199. 1750   IF A$<>DL$ THEN DF=0 ELSE IF DF=0 THEN X$=X$+A$:DF=1 'add one DL$ only
  200. 1760   A$=INPUT$(1,1):A=ASC(A$) AND 127           'next character
  201. 1770   CNT=CNT+1                                  'keep count of chars
  202. 1780   IF CNT>H.MAX THEN LN=2:GOTO 7500           'note error, return
  203. 1790 WEND
  204. 1800 IF X$="" THEN 7430                           'no keywords in identifier
  205. 1810 IF REPL=0 THEN 1830
  206. 1820   Y$=ID$(K):SAME.ID=(X$=Y$):GOSUB 6650       'dec mult's of kwds in Y$
  207. 1830 WHILE X$<>""
  208. 1840   H=INSTR(X$,DL$):IF H=1 THEN X$=MID$(X$,2):GOTO 1840  'strip lead DL$'s
  209. 1850   IF H=0 THEN H=LEN(X$)+1
  210. 1860   W$=LEFT$(X$,H-1):X$=MID$(X$,H+1)
  211. 1870   K$=W$:GOSUB 6590:W$=K$                     'strip lead, trail spaces
  212. 1880   IF W$="" THEN 1900                         'skip if W$ now empty
  213. 1890   ID$=ID$+W$:GOSUB 1980:IF X$<>"" THEN ID$=ID$+DL$  'else add to ID$
  214. 1900 WEND
  215. 1910 L=LEN(ID$):IF RIGHT$(ID$,1)=DL$ THEN ID$=LEFT$(ID$,L-1):GOTO 1910
  216. 1920 IF L=0 THEN 7430                             'no keywords in identifier
  217. 1930 M=M+1:ID$(M)=ID$:REC(M)=N                    'add ID$ and rec.# to arrays
  218. 1940 IF REPL THEN RETURN 5630     'replacing note; will save identifiers later
  219. 1950 WRITE #2,ID$,N                               'add ID$ and rec.# to file
  220. 1960 RETURN
  221. 1970 '------------ Update keyword list with words from ID$ ------------------
  222. 1980 IF W$>W$(KW) THEN KW=KW+1:W$(KW)=W$:M(KW)=1:GOTO 2080 'W$ goes at end
  223. 1990 A=0:B=KW                                     'start binary search
  224. 2000 WHILE B-A>1:C=(A+B)\2                        'halve interval
  225. 2010   IF W$<=W$(C) THEN B=C                      'W$ in lower half
  226. 2020   IF W$>=W$(C) THEN A=C                      'W$ in upper half
  227. 2030 WEND                                         'W$(B-1)<W$<=W$(B)
  228. 2040 IF W$=W$(B) THEN M(B)=M(B)+1:GOTO 2080       'already entered
  229. 2050 KW=KW+1                                      'not duplicate, so:
  230. 2060 FOR J=KW TO B+1 STEP -1:W$(J)=W$(J-1):M(J)=M(J-1):NEXT 'clear place and
  231. 2070 W$(B)=W$:M(B)=1                                        'insert W$, mult 1
  232. 2080 RETURN                                       'get next word, if any
  233. 2100 '************** Print or Display Keyword List ******************
  234. 2110 PRINT "Send keyword list to Screen or to Printer (S/P) ? ";
  235. 2120 L0=CSRLIN:C0=POS(0):GOSUB 6070               'msg - Esc for menu
  236. 2130 CH$="SsPp"+ESC$                              'acceptable characters
  237. 2140 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 2140
  238. 2150 IF A$=ESC$ THEN RT=1:RETURN                  'menu if Esc pressed
  239. 2160 IF A$="S" OR A$="s" THEN 2320                'display keywords
  240. 2170 '--------------------- Print keyword list ------------------------------
  241. 2180   PRINT:PRINT"Check printer, press any key when ready ...";
  242. 2190   A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN ELSE CLS
  243. 2200   LPRINT:LPRINT:L=6
  244. 2210 LPRINT "Keyword list for "IDF$:LPRINT
  245. 2220 H = -INT(-KW/4) 'for four column printout, need min H with 4*H >= KW
  246. 2230 FOR I=1 TO H
  247. 2240   FOR J=0 TO 3
  248. 2250    K=I+J*H : T=20*J +5
  249. 2260    IF K<=KW THEN LPRINT TAB(T);:LPRINT LEFT$(W$(K),18);
  250. 2270   NEXT
  251. 2280   LPRINT:L=L+1:IF L>60 THEN LPRINT CHR$(12):LPRINT:LPRINT:L=4
  252. 2290 NEXT
  253. 2300 RETURN
  254. 2310 '-------------------- Display keyword list -----------------------------
  255. 2320 Z=0:P(Z)=0:WHILE P(Z)<KW:Z=Z+1:P(Z)=80*Z:WEND:P(Z)=KW:Z=1
  256. 2330 CLS:R.=2:C.=27:X.$="Keyword list for "+IDF$:GOSUB 10130
  257. 2340 X.$="**** Esc for menu ****"
  258. 2350 IF KW>80 THEN X.$=X.$+"       (PgUp ,PgDn for other keywords)"
  259. 2360 R.=25:C.=1:GOSUB 10130:LOCATE 4,1,0:X.$=SPACE$(20)
  260. 2370 FOR I=1 TO 20
  261. 2380   FOR J=0 TO 3:R.=I+3:C.=1+20*J:K=P(Z-1)+I+C.-1
  262. 2390     IF K<=KW THEN LSET X.$=LEFT$(W$(K),18):GOSUB 10130
  263. 2400   NEXT
  264. 2410 NEXT
  265. 2420 UP=0:DN=0:WHILE RT+UP+DN=0:GOSUB 5820:WEND   'check for PgUp, PgDn
  266. 2430 IF UP AND Z>1 THEN Z=Z-1:GOTO 2330
  267. 2440 IF DN AND P(Z)<KW THEN Z=Z+1:GOTO 2330
  268. 2450 RETURN                                       'menu if RT, else loop
  269. 2500 '**************** Print or Display Identifiers *******************
  270. 2510 PRINT "Send identifiers list to Screen or to Printer (S/P) ? ";
  271. 2520 L0=CSRLIN:C0=POS(0):GOSUB 6070               'msg - Esc for menu
  272. 2530 CH$="SsPp"+ESC$                              'acceptable characters
  273. 2540 A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 2540
  274. 2550 IF A$=ESC$ THEN RT=1:RETURN                  'menu if Esc pressed
  275. 2560 IF A$="P" OR A$="p" THEN 2770                'print identifiers
  276. 2570 '----------------------- Display Identifiers ---------------------------
  277. 2580 FOR Z=1 TO 10:P(Z)=0:NEXT:Z=0     'P( ) holds # entries on screen
  278. 2590 CLS:L0=1:R.=1:C.=5:P=P(Z):LOCATE ,,0
  279. 2600 WHILE P<M AND L0<21:P=P+1
  280. 2610  X.$=FNN$(P)+FNSP$(P):R.=L0:C.=1:GOSUB 10130:C.=5:Z$=ID$(P)
  281. 2620  WHILE Z$<>""
  282. 2630    IF LEN(Z$)<76 THEN X.$=Z$:R.=L0:GOSUB 10130:Z$="":L0=L0+1:GOTO 2680
  283. 2640    L=75:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND  'last space in Z$ on this line
  284. 2650    X.$=LEFT$(Z$,L-1):R.=L0:GOSUB 10130:L0=L0+1 'break at space
  285. 2660    Z$=MID$(Z$,L+1)                           'remainder of string
  286. 2670  WEND
  287. 2680 WEND
  288. 2690 Z=Z+1:P(Z)=P
  289. 2700 IF P(1)<M THEN R.=24:C.=1:X.$="PgUp,PgDn for other identifiers.":GOSUB 10130
  290. 2710 L0=23:C0=1:GOSUB 6070                        'msg - Esc for Menu
  291. 2720 UP=0:DN=0:WHILE RT+UP+DN=0:GOSUB 5820:WEND   'check for PgUp, PgDn
  292. 2730 IF UP AND Z>1 THEN Z=Z-2:GOTO 2590           'PgUp
  293. 2740 IF DN AND P(Z)<M THEN 2590                   'PgDn
  294. 2750 RETURN
  295. 2760 '------------------------ Printout Identifiers -------------------------
  296. 2770 PRINT:PRINT"Check printer, press any key when ready ...";
  297. 2780   A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN 240 ELSE CLS
  298. 2790 LPRINT:LPRINT:LPRINT "Identifiers for "IDF$:LPRINT:L0=6:K=0
  299. 2800 WHILE K<M:K=K+1
  300. 2810   LPRINT FN N$(K);:Z$=ID$(K)
  301. 2820   WHILE Z$<>""
  302. 2830     IF LEN(Z$)<76 THEN LPRINT TAB(5)Z$:Z$="":L0=L0+1:GOTO 2870
  303. 2840     L=75:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND 'last space in Z$ on this line
  304. 2850     LPRINT TAB(5)LEFT$(Z$,L-1):L0=L0+1       'break at space
  305. 2860     Z$=MID$(Z$,L+1)                          'remainder of string
  306. 2870   WEND
  307. 2880   IF L0>60 THEN LPRINT CHR$(12):LPRINT:LPRINT:L0=4
  308. 2890 WEND
  309. 2900 RETURN
  310. 3000 '************************ Find Notes ***************************
  311. 3010 CLS:GOSUB 6020                               'clear arrays
  312. 3020 X.$="Active file : "+RF$:R.=1:C.=17:GOSUB 10130
  313. 3030 LOCATE 4,1:X.$="Enter Search String or Direct Command:    ( ? for help )":R.=4:C.=1:GOSUB 10130
  314. 3040 L0=5:C0=1:C=1:GOSUB 6070                     'msg - Esc for Menu
  315. 3050 C=1:LOCATE L0,C0,1                           'turn on cursor
  316. 3060 GOSUB 5820:IF RT THEN 240                    'get first character of K$
  317. 3070 IF X$="?" THEN GOSUB 8220:GOTO 3050          'show help screen
  318. 3080 X.$=SPACE$(25):R.=L0+1:C.=1:GOSUB 10130      'erase error message, if any
  319. 3090 K$=X$:LX=79:GOSUB 5910:LOCATE ,,0            'get rest of K$ (max len 79)
  320. 3100 IF RT THEN 240                               'return to menu
  321. 3105 IF INSTR(K$,"?")  THEN GOSUB 8220:GOTO 3050  'show help screen, start over
  322. 3110 GOSUB 6590                                   'strip lead, trail spcs in K$
  323. 3120 IF ER THEN GOSUB 7460:GOTO 3050              'error in K$
  324. 3130 DC=0:IF LEFT$(K$,1)<>"#" THEN 3330           'search string entered
  325. 3140 '----------------------- Direct Command Entered ------------------------
  326. 3150 GOSUB 6110                                   'clean up Direct Command
  327. 3160 IF E THEN GOSUB 7460:GOTO 3050               'error in K$
  328. 3170 IF C$<>"" THEN DC=1:GOTO 4180                'do D,P,F,X,R; return 4010
  329. 3180 K0$=K$:K$=MID$(K$,2):NF=1:Q=0                'delete "#", set num. flag
  330. 3190 WHILE K$<>""
  331. 3200   C=INSTR(K$,","):IF C=0 THEN C=LEN(K$)+1
  332. 3210   L$=LEFT$(K$,C-1):H=INSTR(L$,"-")
  333. 3220   IF H THEN N1$=LEFT$(L$,H-1):N2$=MID$(L$,H+1) ELSE N1$=L$:N2$=N1$
  334. 3230   N1=VAL(N1$):N2=VAL(N2$):IF N1>N2 THEN SWAP N1,N2
  335. 3240   N1=FN MAX(N1,1):N2=FN MIN(N2,M)            'adjust out-of-range entries
  336. 3250   FOR I=1 TO N2-N1+1:H(Q+I)=N1-1+I:NEXT:Q=Q+N2-N1+1
  337. 3260   K$=MID$(K$,C+1)
  338. 3270 WEND
  339. 3280 IF E THEN GOSUB 7460:GOTO 3050               'error in K$
  340. 3290 GOTO 3670                                    'list identifiers # H(1)-H(Q)
  341. 3300 '----------------------- Search String Entered -------------------------
  342. 3310 'Parse S$, creating S$(I,J) for I = 1...N , J = 1...N(I)
  343. 3320 'First remove illegitimate characters and extra spaces, maybe lc to caps
  344. 3330 GOSUB 6020:S$=K$:K$="":X$="":B$(0)=DL$:NF=0:SF=-1'clear arrays, initialize
  345. 3340 FOR J=1 TO LEN(S$):A=ASC(MID$(S$,J,1))
  346. 3350   IF UC THEN IF 96<A AND A<123 THEN A=A-32   'lc to caps if UC
  347. 3360   IF INSTR(V1$,CHR$(A))=0 AND A<>42 THEN A=32'invalids to spaces
  348. 3370   IF A<>32 THEN SF=0                         'clear space flag
  349. 3380   IF NOT SF THEN X$=X$+CHR$(A)               'not repeated space, ok
  350. 3390   IF A=32 THEN SF=-1                         'if space, set flag
  351. 3400 NEXT
  352. 3410 IF X$="" OR X$=" " THEN GOSUB 7460:GOTO 3060 'empty search string
  353. 3412 IF LEFT$(X$,1)=" " THEN X$=MID$(X$,2):GOTO 3412
  354. 3414 IF RIGHT$(X$,1)=" " THEN X$=LEFT$(X$,LEN(X$)-1):GOTO 3414
  355. 3420 '     Now break X$ into substrings
  356. 3430 N=1:C=1
  357. 3440 C1=INSTR(C,X$," AND ")+INSTR(C,X$," and ")
  358. 3450 IF C1>C THEN L1=C1-C:S$(N,1)=MID$(X$,C,L1):C=C1+5:N=N+1:GOTO 3440
  359. 3460 S$(N,1)=MID$(X$,C)
  360. 3470 FOR I=1 TO N:SI$=S$(I,1)
  361. 3480   N(I)=1:IF INSTR(SI$," OR ")+INSTR(SI$," or ")=0 THEN 3520 ELSE C=1:C1=1
  362. 3490   C1=INSTR(C,SI$," OR ")+INSTR(C,X$," or ")
  363. 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
  364. 3510   S$(I,N(I))=MID$(SI$,C)
  365. 3520 NEXT
  366. 3530 '     Check for matches
  367. 3540 FOR P=1 TO M:ID$=DL$+ID$(P)+DL$              'start and end with delimiter
  368. 3550   FOR I=1 TO N:OK=0                          'assume no match at level I
  369. 3560    FOR J=1 TO N(I):S1$=S$(I,J):L=LEN(S1$)
  370. 3570     LS=-(LEFT$(S1$,1)="*"):RS=-(RIGHT$(S1$,1)="*")  '* for wildcards
  371. 3580     S1$=B$(LS)+MID$(S1$,1+LS,L-(LS+RS))+B$(RS)      'modify S1$ for search
  372. 3590     IF INSTR(ID$,S1$) THEN OK=-1:J=N(I)      'exit if match found
  373. 3600    NEXT J:IF NOT OK THEN I=N                 'S$(I,J) flunks, so ID$ does
  374. 3610   NEXT I  :IF NOT OK THEN 3630               'ID$ flunked somewhere
  375. 3620   Q=Q+1:H(Q)=P                               'count matches, save ID #'s
  376. 3630 NEXT P
  377. 3640 IF Q=0 THEN M$="No match found."
  378. 3650 IF Q=1 THEN M$="One match found :"
  379. 3660 IF Q>1 THEN M$=STR$(Q)+" Matches found :"
  380. 3670 IF Q=0 THEN M1$="Enter "
  381. 3680 IF Q THEN M1$="Enter numbers (or ranges) plus D,P,F,X,R to Display,Print,File,Delete,Replace."
  382. 3690 M2$="S for new search, Esc for menu."
  383. 3700 IF Q THEN M2$="Enter " + M2$
  384. 3710 IF NF THEN 3840                              'numeric entry, no SS$
  385. 3720 '                   Reconstruct search string
  386. 3730 SS$=""
  387. 3740 FOR I=1 TO N
  388. 3750   IF N>1 AND N(I)>1 THEN SS$=SS$+"("
  389. 3760   FOR J=1 TO N(I)
  390. 3770    SS$=SS$+S$(I,J)
  391. 3780    IF J<N(I) THEN SS$=SS$+" or "
  392. 3790   NEXT
  393. 3800  IF N>1 AND N(I)>1 THEN SS$=SS$+")"
  394. 3810  IF I<N THEN SS$=SS$+" and "
  395. 3820 NEXT
  396. 3830 '                      List matches found
  397. 3840 FOR Z=1 TO 10:P(Z)=0:NEXT:Z=0     'P( ) holds # entries on screen
  398. 3850 CLS:PRINT:LOCATE ,,0
  399. 3860 IF NF THEN PRINT K0$ ELSE PRINT SS$:PRINT:PRINT M$ 'Direct Cmnd. or Srch.$
  400. 3870 PRINT:P=P(Z):L0=CSRLIN
  401. 3880 WHILE P<Q AND L0<21:P=P+1:K=H(P)
  402. 3890  X.$=FNN$(P)+FNSP$(P)+"("+FNN$(K)+")"+FNSP$(K):R.=L0:C.=1:GOSUB 10130:C.=11
  403. 3900  Z$=ID$(K)
  404. 3910   WHILE Z$<>""
  405. 3920    IF LEN(Z$)<70 THEN X.$=Z$:R.=L0:GOSUB 10130:Z$="":L0=L0+1:GOTO 3960
  406. 3930    L=69:WHILE MID$(Z$,L,1)<>" ":L=L-1:WEND   'last space in Z$ on line
  407. 3940    X.$=LEFT$(Z$,L-1):R.=L0:GOSUB 10130:L0=L0+1'break at space
  408. 3950    Z$=MID$(Z$,L+1)                           'remainder of string
  409. 3960   WEND
  410. 3970 WEND
  411. 3980 Z=Z+1:P(Z)=P
  412. 3990 IF P(1)<Q THEN M3$="(PgUp,PgDn for earlier, later matches)"ELSE M3$=""
  413. 4000 IF Q=0 THEN PRINT M1$ M2$ " ";:L0=CSRLIN:C0=POS(0)  ELSE R.=24:C.=1:X.$=M1$:GOSUB 10130
  414. 4010 '              Find out what user wants to do
  415. 4020 IF Q THEN L0=22:C0=1:R.=25:C.=1:X.$=M2$+M3$:GOSUB 10130
  416. 4030 LOCATE L0,C0,1                               'turn on cursor
  417. 4040 GOSUB 5820:IF RT THEN 240                    'get first character of K$
  418. 4050 IF X$="S" OR X$="s" THEN 3010                'new search
  419. 4060 IF UP THEN IF Z>1 THEN Z=Z-2:GOTO 3850 ELSE 4040 'PgUp key pressed
  420. 4070 IF DN THEN IF P(Z)<Q THEN 3850 ELSE 4040         'PgDn key pressed
  421. 4080 LOCATE L0+1,1:PRINT SPC(25);                 'erase error msg.
  422. 4090 C=C0:K$=X$:LX=79:GOSUB 5910                  'get rest of K$ (max len 79)
  423. 4100 IF RT THEN 240                               'return to menu
  424. 4110 '              User entry completed, massage and interpretet it
  425. 4120 GOSUB 6590                                   'strip lead, trail spcs in K$
  426. 4130 IF ER THEN GOSUB 7460:GOTO 4030              'error in K$
  427. 4140 IF K$="S" OR K$="s" THEN 3010                'new search
  428. 4150 G$="":Q1=0:E=0:GOSUB 6110                    'check K$
  429. 4160 IF E THEN GOSUB 7460:GOTO 4030               'error iΘ*K$
  430. 4170 IF C$="" OR INSTR("PFXR",C$)=0 THEN C$="D"   'default is screen
  431. 4180 IF LEFT$(K$,1)="#" THEN K$=MID$(K$,2):BN=1 ELSE BN=0   'BN for "big nums"
  432. 4190 'parse K$, set up H1(1)...H1(Q1) as list of note numbers
  433. 4200 Q1=0:IF BN THEN MX=M ELSE MX=Q               'largest allowed value
  434. 4210 WHILE K$<>""
  435. 4220   C=INSTR(K$,","):IF C=0 THEN C=LEN(K$)+1
  436. 4230   L$=LEFT$(K$,C-1):H=INSTR(L$,"-")
  437. 4240   IF H THEN N1$=LEFT$(L$,H-1):N2$=MID$(L$,H+1) ELSE N1$=L$:N2$=N1$
  438. 4250   N1=VAL(N1$):N2=VAL(N2$):IF N1>N2 THEN SWAP N1,N2
  439. 4260   N1=FN MAX(N1,1):N2=FN MIN(N2,M)            'adjust out-of-range entries
  440. 4270   IF BN=0 AND N2>Q THEN E=1:K$="":GOTO 4300  'error - exit loop
  441. 4280   FOR I=1 TO N2-N1+1:H1(Q1+I)=N1-1+I:NEXT:Q1=Q1+N2-N1+1
  442. 4290   K$=MID$(K$,C+1)
  443. 4300 WEND
  444. 4310 IF E THEN GOSUB 7460:GOTO 4030               'error in K$
  445. 4320 '********* Follow user's instructions Xn list of notes ****************
  446. 4330 IF C$<>"R" OR Q1=1 THEN 4390 ELSE CLS
  447. 4340     'R suffix with more than one note - not allowed
  448. 4350 PRINT"Only one note can be REPLACED with a single command. Press D, P or F
  449. 4360 PRINT"to display, print or file these notes, any other key to start over.
  450. 4370 PRINT:AN$=INPUT$(1)
  451. 4380 IF INSTR("DdPpFf",AN$) THEN C$=CHR$(ASC(AN$) AND 95) ELSE 3010
  452. 4390 GOSUB 6480                                   'open records file
  453. 4400 IF C$<>"F" THEN 4440                         'not filing notes
  454. 4410   PRINT:PRINT "Include note headers in file (Y/N) ? ";
  455. 4420   A$=INPUT$(1):IF A$=ESC$ THEN RT=1:RETURN 240      'menu if Esc pressed
  456. 4430   IF A$="N" OR A$="n" THEN HD=0 ELSE HD=1    'include headers as default
  457. 4440 FOR P=1 TO Q1:IF BN THEN K=H1(P) ELSE K=H(H1(P)) 'notes to be considered
  458. 4450   IF C$="F"AND P=1 THEN GOSUB 6350:IF HD THEN GOSUB 6560   'print header
  459. 4460   IF C$="F"AND P>1 THEN PRINT #4,:PRINT #4,:IF HD THEN GOSUB 6560 'header
  460. 4470   IF C$<>"D" THEN CLS:LOCATE ,,0:PRINT FN N$(K);TAB(5);ID$(K):PRINT
  461. 4480   IF INSTR("PF",C$) THEN PRINT"Sending to ";:IF C$="P" THEN PRINT"printer."         ELSE PRINT "file - "G$"."
  462. 4490   IF C$="D" THEN GOSUB 4610                  'Display
  463. 4500   IF C$="P" THEN FLAG=0:GOSUB 5010           'Print
  464. 4510   IF C$="F" THEN GOSUB 5410                  'File
  465. 4520   IF C$="X" THEN GOSUB 6840                  'Delete
  466. 4530   IF C$="R" THEN REPL=1:GOSUB 5510           'Replace
  467. 4540 NEXT
  468. 4550 ON ERROR GOTO 0   'cancel error trap for printer failure after startup
  469. 4560 IF C$="F" THEN PRINT #4,:PRINT #4,   'in case something is appended later
  470. 4570 CLOSE:K$=""
  471. 4580 IF C$="X" THEN GOSUB 6920:GOSUB 7000:DC=1 'rewrite KF$ and IDF$,rtrn 4010
  472. 4590 IF DC THEN 3010 ELSE 3840  'new search if Direct Command or Deletion
  473. 4600 '************************ Display Note ***************************
  474. 4610 CLS
  475. 4620 PRINT FN N$(K);:Z$=ID$(K)
  476. 4630 WHILE Z$<>""
  477. 4640  IF LEN(Z$)<76 THEN PRINT TAB(5)Z$:Z$="":L=L+1:GOTO 4680
  478. 4650  J=75:WHILE MID$(Z$,J,1)<>" ":J=J-1:WEND     'last space in Z$ on line
  479. 4660  PRINT TAB(5)LEFT$(Z$,J-1):L=L+1             'break at space
  480. 4670  Z$=MID$(Z$,J+1)                             'remainder of string
  481. 4680 WEND
  482. 4690 R=REC(K)                                     'K = num. of note to display
  483. 4700 GET #3,R:R=CVI(U$):H=INSTR(T$,"~")           'look for end-of-text marker
  484. 4710 IF H=0 THEN H=LEN(T$)+1                      'if none, use all of T$
  485. 4720 FOR I=1 TO H-1                               'omit eot mark and end spaces
  486. 4730    A$=MID$(T$,I,1):A=ASC(A$) AND 127         'get char., strip high bit
  487. 4740    IF A<32 AND A<>13 AND A<>9 THEN 4770      'skip controls and LF's
  488. 4750    PRINT CHR$(A);
  489. 4760    IF A=13 AND CSRLIN>20 THEN GOSUB 4830:IF AB THEN I=H-1     'exit loop
  490. 4770 NEXT
  491. 4780 IF AB THEN AB=0:GOTO 4810            'abandon this note, get next (if any)
  492. 4790 IF R THEN 4700                               'note continues on sector R
  493. 4800 GOSUB 4830
  494. 4810 RETURN
  495. 4820 '                   Screen full or End of note
  496. 4830 IF R>0 OR I<H THEN MM$="Note continues ":X$=" A to abort," ELSE MM$="   End of note ":X$=""
  497. 4840 LOCATE 23,1:PRINT MM$:AB=0
  498. 4850 PRINT"Press P or F to print or file note,"X$" any other key to continue.";
  499. 4860 L0=23:C0=16:GOSUB 6070:LOCATE ,,1            'msg - Esc for Menu;cursor on
  500. 4870 CH$="PFA":A$=INPUT$(1)                       'CH$ = special characters
  501. 4880 IF A$=ESC$ THEN RT=1:RETURN 240              'menu if Esc pressed
  502. 4890 A$=CHR$(ASC(A$) AND 95):IF INSTR(CH$,A$) AND I<H THEN AB=1 'set abort flag
  503. 4900 IF A$="P"THEN CLS:FLAG=-1:GOSUB 6480:GOSUB 5010:FLAG=0:CLOSE      'print
  504. 4910 IF A$="F"THEN GOSUB 6350:GOSUB 6560:GOSUB 5410:CLOSE 4  '#4 is note file
  505. 4920 CLS:RETURN
  506. 5000 '*********************** Printout Note ************************
  507. 5010 IF NOT FLAG AND P>1 THEN 5120                'question user 1st time only
  508. 5020   PRINT "Start new page (Y/N) ?";
  509. 5030    CH$="YyNn"+ESC$                           'acceptable characters
  510. 5040    A$=INPUT$(1):IF INSTR(CH$,A$)=0 THEN 5040
  511. 5050    IF A$=ESC$ THEN RT=1:RETURN 240           'menu if Esc pressed
  512. 5060   LOCATE ,1:PRINT SPACE$(30);:LOCATE ,1      'erase message
  513. 5070   IF A$="Y" OR A$="y" THEN D=0:PGF=1         'D=line count,PGF=page flag
  514. 5080   PRINT:PRINT "Check printer";
  515. 5090   IF A$="Y" OR A$="y" THEN PRINT ", set top of form."; ELSE PRINT ".";
  516. 5100   PRINT "   Press any key when ready ...";
  517. 5110   K$=INPUT$(1):IF K$=ESC$ THEN RT=1:RETURN 240 ELSE CLS
  518. 5120 IF PGF=1 THEN FOR J=1 TO 4:LPRINT:NEXT:D=5   'first page
  519. 5130 IF PGF=0 THEN FOR J=1 TO 2:LPRINT:NEXT:D=D+2 'continuation page
  520. 5140 LPRINT FN N$(K);:Z$=ID$(K)
  521. 5150 WHILE Z$<>""
  522. 5160  IF LEN(Z$)<76 THEN LPRINT TAB(5)Z$:Z$="":D=D+1:GOTO 5200
  523. 5170  J=75:WHILE MID$(Z$,J,1)<>" ":J=J-1:WEND     'last space in Z$ on line
  524. 5180  LPRINT TAB(5)LEFT$(Z$,J-1):D=D+1            'break at space
  525. 5190  Z$=MID$(Z$,J+1)                             'remainder of string
  526. 5200 WEND
  527. 5210 R=REC(K)                                     'K = num. of note to print
  528. 5220 GET #3,R:R=CVI(U$):H=INSTR(T$,"~")           'look for end-of-text marker
  529. 5230 IF H=0 THEN H=LEN(T$)+1
  530. 5240 FOR I=1 TO H-1                               'ignore trailing spaces in T$
  531. 5250   PGF=0                                      'clear page flag
  532. 5260   A$=MID$(T$,I,1):A=ASC(A$) AND 127          'get char., strip high bit
  533. 5270   IF A=10 THEN LPRINT:D=D+1
  534. 5280   IF D>60 THEN PGF=2:GOSUB 5350:GOTO 5310    'new page
  535. 5290   IF A<32 AND A<>9 THEN 5310                 'skip controls and LF's
  536. 5300   LPRINT CHR$(A);                            'else print character
  537. 5310 NEXT:IF R THEN 5220                          'note cont on sector R if R>0
  538. 5320 IF PGF=0 AND D>55 THEN GOSUB 5350:PGF=2      'page; can't get 5 lines more
  539. 5330 RETURN
  540. 5340 '------------------- start new page ------------------------------------
  541. 5350 LPRINT CHR$(12):FOR J=1 TO 4:LPRINT:NEXT:D=5:RETURN
  542. 5400 '************************* File Note **************************
  543. 5410 R=REC(K)                                     'K = num. of note to file
  544. 5420 GET #3,R:R=CVI(U$):H=INSTR(T$,"~")           'look for end-of-text marker
  545. 5430 IF H=0 THEN H=LEN(T$)+1
  546. 5440 FOR I=1 TO H-1                               'ignore trailing spaces in T$
  547. 5450    A$=MID$(T$,I,1):PRINT #4,A$;              'else put it back like it was
  548. 5460 NEXT
  549. 5470 IF R THEN 5420
  550. 5480 RETURN
  551. 5500 '************************* Replace Note **************************
  552. 5510 CLS:PRINT "Files on default drive/directory are:":PRINT:FILES:PRINT
  553. 5520 PRINT "Enter filespec of file containing replacement note : ";
  554. 5530 L0=CSRLIN:C0=POS(0)                          'input location
  555. 5540 LX=14:GOSUB 6280:SF$=K$:K$="":ID=0:PRINT     'get filespec
  556. 5550    ON ERROR GOTO 7220
  557. 5560 CLOSE 1:OPEN "i",1,SF$
  558. 5570    ON ERROR GOTO 0
  559. 5580 CLS:N=REC(K):LOCATE 4,4:PRINT"Working ... "; 'replacing note #K
  560. 5590   WHILE A<>ST AND NOT EOF(1):A=ASC(INPUT$(1,1)) AND 127:WEND 'look for hdr
  561. 5600   IF EOF(1) THEN PRINT"Error - no identifier. Please check file.":GOTO 250
  562. 5610   M0=M:M=K-1                                 'need "M" for ID$ subroutine
  563. 5620   GOSUB 1690                                 'format ID$, update KWs
  564. 5630   M=M0                                       'restore value of M
  565. 5640   IF NOT SAME.ID THEN GOSUB 6920:GOSUB 7000  'rewrite KF$ and IDF$
  566. 5650 GET #3,1 : RM=CVI(U$)                        'current max record number
  567. 5660 FOR I=N TO RM:U(I)=1:NEXT                    'mark used sectors
  568. 5670 GOSUB 1410                                   'replace note
  569. 5680 IF RMAX>RM THEN LSET U$=MKI$(RMAX):PUT #3,1  'update max sector number
  570. 5690 IF KW>KW.MAX-32 THEN LN=4:GOTO 7500          'too many keywords possible
  571. 5700 LOCATE 4,4:PRINT "Note replaced.":CLOSE:REPL=0  'clear flag
  572. 5710 RETURN
  573. 5800 '********************* Utility Subroutines ***********************
  574. 5810 '            Single Character input routine
  575. 5820 WHILE INKEY$<>"":WEND:UP=0:DN=0              'clear
  576. 5830 X$=INKEY$:IF X$="" THEN 5830                 'get one keypress
  577. 5840 IF LEN(X$)=1 THEN A=ASC(X$):GOTO 5880        'ordinary key
  578. 5850    A=ASC(MID$(X$,2))                         'control key
  579. 5860    IF A=72 OR A=73 THEN UP=1                 'PgUp or up arrow
  580. 5870    IF A=80 OR A=81 THEN DN=1                 'PgDn or down arrow
  581. 5880 IF A=27 OR (A=13 AND K$="") THEN RT=1 ELSE RT=0 'return-to-menu flag
  582. 5890 RETURN
  583. 5900 '            String input routine
  584. 5910 L=LEN(K$):KK$="":R.=L0:C.=C0:X.$=SPACE$(LX):GOSUB 10130:LOCATE L0,C0,1:PRINT K$;
  585. 5920 WHILE INKEY$<>"":WEND                        'clear buffer
  586. 5930 WHILE L<LX
  587. 5940   KK$=INPUT$(1):IF KK$=CR$ OR KK$=ESC$ THEN L=LX:GOTO 5990   'exit loop
  588. 5950   IF KK$<>BK$ THEN 5980 ELSE IF L=0 THEN 5990
  589. 5960     'backspace key pressed
  590. 5970     C=POS(0)-1:LOCATE,C:PRINT" ";:L=L-1:K$=LEFT$(K$,L):LOCATE ,C:GOTO 5990
  591. 5980   PRINT KK$;:K$=K$+KK$:L=L+1
  592. 5990 WEND:IF KK$=ESC$ THEN K$="":RT=1
  593. 6000 RETURN
  594. 6010 '            Clear arrays for new search string input
  595. 6020 FOR I=1 TO 10:N(I)=0:FOR P=1 TO 10:S$(I,P)="":NEXT:NEXT
  596. 6030 FOR P=1 TO Q:H(P)=0:NEXT:FOR P=1 TO Q1:H1(P)=0:NEXT
  597. 6040 P=0:Q=0:Q1=0:BN=0
  598. 6050 RETURN
  599. 6060 '            Print message : Esc = Menu
  600. 6070 R.=25:C.=1:X.$="**** Esc for Menu ****":GOSUB 10130
  601. 6080 LOCATE L0,C0,0
  602. 6090 RETURN
  603. 6100 '            Massage numeric entry string (direct command)
  604. 6110 E=0:IF LEFT$(K$,1)="#" THEN X$=MID$(K$,2):K$="#" ELSE X$=K$:K$=""
  605. 6120 IF X$="" THEN E=1:RETURN                     'error - reenter
  606. 6130 C$=RIGHT$(X$,1):IF C$<"0" OR C$>"9" THEN X$=LEFT$(X$,LEN(X$)-1)
  607. 6140 IF X$="" THEN E=1:RETURN                     'error - reenter
  608. 6150 C$=CHR$(ASC(C$) AND 95)                      'convert to upper case
  609. 6160 IF INSTR("DPFRX",C$)=0 THEN C$=""            'only allowable suffixes
  610. 6170 FOR I=1 TO LEN(X$):A$=MID$(X$,I,1)
  611. 6180   IF INSTR(V0$,A$) THEN K$=K$+A$
  612. 6190 NEXT
  613. 6200 IF RIGHT$(K$,1)="," OR RIGHT$(K$,1)="-" THEN K$=LEFT$(K$,LEN(K$)-1)
  614. 6210 IF K$="" THEN E=1
  615. 6220 RETURN
  616. 6230 '            Show help screen
  617. 6240 GOSUB 8230:LOCATE 21,1:PRINT "Enter search string or Direct Command:"
  618. 6250 L0=22:C0=1:X$=""
  619. 6260 RETURN
  620. 6270 '            Filespec input (set location L0,C0 before calling)
  621. 6280 GOSUB 6070:LOCATE ,,1                        'msg - Esc for Menu
  622. 6290 GOSUB 5910:IF RT THEN RETURN 240
  623. 6300 FOR I=1 TO LEN(K$):A=ASC(MID$(K$,I,1))
  624. 6310   IF 96<A AND A<123 THEN MID$(K$,I,1)=CHR$(A-32)   'convert K$ to uc
  625. 6320 NEXT
  626. 6330 RETURN
  627. 6340 '            Get filespec, open file for saving note
  628. 6350 CLS:X.$="Enter drive (A,B,C,D) to contain new note files : "
  629. 6360 R.=1:C.=1:GOSUB 10130
  630. 6370 LOCATE 1,51:K$=INPUT$(1):IF K$=ESC$ THEN RT=1:RETURN 240   'menu
  631. 6380 K$=CHR$(ASC(K$) AND 95):IF INSTR("ABCD",K$)=0 THEN 6370
  632. 6390 PRINT:D$=K$:K$="":DR$=D$+":*.*":FILES DR$:PRINT   'list files on drive K$
  633. 6400 PRINT "Enter name of file to contain notes : ";:L0=CSRLIN:C0=POS(0):PRINT
  634. 6410 PRINT "(Notes will be APPENDED if file already exists)
  635. 6420 LX=14:GOSUB 6280:G$=K$:K$="":IF INSTR(G$,":")=0 THEN G$=D$+":"+G$
  636. 6430   ON ERROR GOTO 7220
  637. 6440 CLOSE 4:OPEN G$ FOR APPEND AS #4
  638. 6450   ON ERROR GOTO 0
  639. 6460 RETURN
  640. 6470 '            Open records file
  641. 6480 CLOSE 3:OPEN "r",3,RF$,RECL : FIELD #3, RECL-2 AS T$, 2 AS U$
  642. 6490 RETURN
  643. 6500 '            Set end-of-text marker
  644. 6510 A$=RIGHT$(X$,1):IF A$="" THEN 6530 ELSE A=ASC(A$)
  645. 6520 IF A<33 THEN X$=LEFT$(X$,LEN(X$)-1):GOTO 6510
  646. 6530 X$=X$+"~"
  647. 6540 RETURN
  648. 6550 '            Print header on filed note
  649. 6560 PRINT #4,:PRINT #4,ST$ ID$(K) EN$
  650. 6570 RETURN
  651. 6580 '            Strip lead, trail spaces from K$, set error flag if K$=""
  652. 6590 ER=0
  653. 6600 WHILE LEFT$(K$,1)=" ":K$=MID$(K$,2):WEND
  654. 6610 WHILE RIGHT$(K$,1)=" ":K$=LEFT$(K$,LEN(K$)-1):WEND
  655. 6620 IF K$="" THEN ER=1                           'error - nothing left
  656. 6630 RETURN
  657. 6640 '            Decrement multiplicities of keywords in Y$
  658. 6650 WHILE Y$<>""
  659. 6660   H=INSTR(Y$,DL$):IF H=0 THEN H=LEN(Y$)+1
  660. 6670   Z$=LEFT$(Y$,H-1):Y$=MID$(Y$,H+1)           'Z$=keyword in Y$
  661. 6680   GOSUB 6730                                 'find B so that K$(B)=Z$
  662. 6690   M(B)=M(B)-1                                '       and decrement M(B)
  663. 6700 WEND
  664. 6710 RETURN
  665. 6720 '            Find Z$ in KWD list
  666. 6730 A=0:B=KW                                     'start binary search
  667. 6740 WHILE B-A>1:C=(A+B)\2                        'halve interval
  668. 6750   IF Z$<=W$(C) THEN B=C                      'z$ in lower half
  669. 6760   IF Z$>=W$(C) THEN A=C                      'z$ in upper half
  670. 6770 WEND                                         'should have W$(B)=Z$
  671. 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
  672. 6790 RETURN
  673. 6800 '            Delete W$(J) from KWD list
  674. 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
  675. 6820 RETURN
  676. 6830 '            Delete note #K from active files
  677. 6840 R=REC(K)                                     'K = num. of note to delete
  678. 6850 WHILE R:GET #3,R:U(R)=0:R=CVI(U$):WEND       'make sectors available
  679. 6860 Y$=ID$(K):GOSUB 6650                         'dec M(J) for K$(J) in Y$
  680. 6870 FOR I=K TO M-1                               'delete ID$(K),REC(K)
  681. 6880   ID$(I)=ID$(I+1):REC(I)=REC(I+1)
  682. 6890 NEXT:ID$(M)="":REC(M)=0:M=M-1
  683. 6900 RETURN
  684. 6910 '            Write keyword file and array
  685. 6920 CLOSE 4:OPEN "o",4,KF$:J=0
  686. 6930 FOR I=1 TO KW
  687. 6940   IF M(I)<1 THEN 6970                        'skip deleted kwds
  688. 6950   WRITE #4,W$(I);M(I)                        'M(I) = multiplicity
  689. 6960   J=J+1:W$(J)=W$(I):M(J)=M(I)                'update arrays W$( ), M( )
  690. 6970 NEXT:KW=J:CLOSE 4
  691. 6980 RETURN
  692. 6990 '            Write identifier file
  693. 7000 CLOSE 2:OPEN "o",2,IDF$
  694. 7010 FOR I=1 TO M
  695. 7020   WRITE #2,ID$(I);REC(I)                     'REC(I) = starting record #
  696. 7030 NEXT:CLOSE 2
  697. 7040 RETURN
  698. 7200 '********************** Error traps *****************************
  699. 7210 '            Trap for filespec error
  700. 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
  701. 7230 IF ERL=1100 OR ERL=1110 OR ERL=1120 THEN RESUME 1060
  702. 7240 IF ERL=1310 OR ERL=1320 OR ERL=1330 THEN RESUME 1260
  703. 7250 IF ERL=5560 THEN RESUME 5540
  704. 7260 IF ERL=6440 THEN RESUME 6420
  705. 7270 ON ERROR GOTO 0
  706. 7280 '            Trap for open drive door, blank disk, etc.
  707. 7290 IF ERR<>53 AND ERR<>71 THEN 7310
  708. 7300   PRINT "No file on drive "A$:RESUME 830
  709. 7310 ON ERROR GOTO 0
  710. 7320 '            Printer failure during printout
  711. 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
  712. 7340 ON ERROR GOTO 0
  713. 7350 '            Configuration file missing
  714. 7360 CLS:IF ERR<>53 THEN 7410
  715. 7370 COLR=1:FG=15:BG=1:BR=1:ST=123:EN=125:UC=1:DL=32:KW$="'-_" 'defaults
  716. 7380 PRINT"Configuration file missing. Do you wish to create one now (Y/N) ? ";
  717. 7390 A$=INPUT$(1):IF A$="Y"OR A$="y" THEN GOSUB 310:GOTO 7400
  718. 7392 PRINT"Are you using a color monitor (Y/N) ?":A$=INPUT$(1)
  719. 7394 IF INSTR("YyNn",A$)=0 THEN 7390
  720. 7396 IF A$="N" OR A$="n" THEN COLR=0
  721. 7400 RESUME 65
  722. 7410 ON ERROR GOTO 0
  723. 7420 '            No keywords error
  724. 7430 PRINT:PRINT "Error - no keywords in Identifier"M+1
  725. 7440 GOTO 250                                     'return to menu
  726. 7450 '            Error in direct command
  727. 7460 BEEP:LOCATE L0+1,1
  728. 7470 PRINT"Error - please reenter.";
  729. 7480 RETURN
  730. 7490 '            Error in source file, or too many of something
  731. 7500 CLS:ON LN GOSUB 7600,7640,7690,7720:GOTO 7510
  732. 7510 GOSUB 6920:GOSUB 7000                        'save keywords and ID$'s
  733. 7520 LSET U$=MKI$(RMAX):PUT #3,1                  'save RMAX in rec file
  734. 7530 IF LN<>2 THEN PRINT:PRINT "Warning : DO NOT add to this file; you might lose it.
  735. 7540 PRINT:PRINT"Notes have been correctly entered up to and including #"FNN$(M)", with header :"
  736. 7550 PRINT:PRINT ST$ ID$(M) EN$:IF REPL THEN REPL=0:PRINT:PRINT "Also, Note #"FNN$(K)" has been replaced with "SF$"."
  737. 7560 CLOSE:ACTIVE=1                               'housekeeping
  738. 7570 GOTO 250                                     'return to Menu
  739. 7580 '---------- Sub-Subs for last error routine --------------
  740. 7590 'LN = 1  (N >= N.MAX)
  741. 7600 PRINT "Records file filled."
  742. 7610 IF E=0 THEN K=M:GOSUB 6840                   'delete note M if incomplete
  743. 7620 RETURN
  744. 7630 'LN = 2  (CNT > H.MAX)
  745. 7640 PRINT "Error -identifier too long. Check for missing ";
  746. 7650 PRINT Q$ EN$ Q$" or unwanted "Q$ ST$ Q$" in note"M
  747. 7660 PRINT"with header beginning :":PRINT:PRINT ST$ LEFT$(X$,159):PRINT:M=M-1
  748. 7670 RETURN
  749. 7680 'LN = 3  (M > M.MAX)
  750. 7690 PRINT "Only"M.MAX"notes are allowed; you have already used your quota."
  751. 7700 RETURN
  752. 7710 'LN = 4  (KW > KW.MAX)
  753. 7720 PRINT "Only"KW.MAX"keywords are allowed; you have"KW"already."
  754. 7730 PRINT "One more note might add too many keywords.
  755. 7740 RETURN
  756. 7800 '******************** String Initialization ***********************
  757. 7810 XS$=" SEARCH STRING format (max 79 characters) :
  758. 7820 YS$="     (A1 or A2 or ... or An) and (B1 or B2 or ... or Bm) and ...  ...
  759. 7830 ZS$="  (The A's and B's are keywords; parentheses are optional)
  760. 7840 PS$="    A Direct Command consists of the symbol # followed by a list "
  761. 7850 QS$=" of numbers (or ranges of numbers) identifying notes to be found."
  762. 7860 RS$=" For example, #2-5,7,10,15-20  and  #3,5,9,10,30-33 P are valid. "
  763. 7870 TS$=" The numbers refer to positions of the notes in the Source File. "
  764. 7880 US$=" Use D,P,F,X,R to Display, Print, File, Delete or Replace notes. "
  765. 7890 UC$="ABCDEFGHIJKLMNOPQRSTUVWXYZ":LC$="abcdefghijklmnopqrstuvwxyz"
  766. 7900 V0$="?0123456789,-"                          'valid in Direct Commands
  767. 7910 V1$=UC$+MID$(V0$,2,10)+KW$                   'valid in keywords
  768. 7920 IF UC=0 THEN V1$=LC$+V1$                     'valid in kwds if lc allowed
  769. 7940 RETURN
  770. 8000 '******************* Screen Print Routines ************************
  771. 8010 '            Menus
  772. 8020 CLS:LOCATE ,,0:X.$="Menu":R.=1:C.=34:GOSUB 10130
  773. 8030 X.$="1 List files available":R.=4:C.=26:GOSUB 10130
  774. 8040 X.$="2 SELECT Trilogy files":GOSUB 10130
  775. 8050 X.$="3 CREATE Trilogy files":GOSUB 10130
  776. 8060 IF ACTIVE=0 THEN 8120
  777. 8070 X.$="4 UPDATE Trilogy files":GOSUB 10130
  778. 8080 X.$="5 SEARCH Trilogy files":GOSUB 10130
  779. 8090 X.$="6 List keywords":GOSUB 10130
  780. 8100 X.$="7 List identifiers":GOSUB 10130
  781. 8120 X.$="8 Set defaults":IF ACTIVE THEN GOSUB 10130 ELSE MID$(X.$,1)="4":GOSUB 10130
  782. 8130 X.$="9 Exit program":IF ACTIVE THEN GOSUB 10130 ELSE MID$(X.$,1)="5":GOSUB 10130
  783. 8140 C.=13:IF ACTIVE THEN R.=16 ELSE R.=11
  784. 8150 X.$=CHR$(201)+STRING$(47,205)+CHR$(187):GOSUB 10130
  785. 8160 X.$=CHR$(186)+" Use the arrow keys "+CHR$(24)+CHR$(25)+" to position the marker, "+CHR$(186):GOSUB 10130
  786. 8170 X.$=CHR$(186)+" press  Enter  to select the indicated option. "+CHR$(186):GOSUB 10130
  787. 8180 X.$=CHR$(186)+"  (Or just press the number of your choice.)   "+CHR$(186):GOSUB 10130
  788. 8190 X.$=CHR$(200)+STRING$(47,205)+CHR$(188):GOSUB 10130
  789. 8200 RETURN
  790. 8210 '            Help Screen (Search String entry)
  791. 8220 CLS:LOCATE ,,0:R.=3:C.=1
  792. 8230 X.$=CHR$(218)+STRING$(75,196)+CHR$(191):GOSUB 10130
  793. 8240 X.$=CHR$(179)+XS$+STRING$(32,32)+CHR$(179):GOSUB 10130
  794. 8250 X.$=CHR$(179)+STRING$(75,32)+CHR$(179):GOSUB 10130
  795. 8260 X.$=CHR$(179)+YS$+STRING$(6,32)+CHR$(179):GOSUB 10130
  796. 8270 X.$=CHR$(179)+STRING$(75,32)+CHR$(179):GOSUB 10130
  797. 8280 X.$=CHR$(179)+ZS$+STRING$(17,32)+CHR$(179):GOSUB 10130
  798. 8290 X.$=CHR$(192)+STRING$(75,196)+CHR$(217):GOSUB 10130
  799. 8300 R.=R0.+1:C.=6
  800. 8310 X.$=CHR$(218)+STRING$(65,196)+CHR$(191):GOSUB 10130
  801. 8320 X.$=CHR$(179)+PS$+CHR$(179):GOSUB 10130
  802. 8330 X.$=CHR$(179)+QS$+CHR$(179):GOSUB 10130
  803. 8340 X.$=CHR$(179)+STRING$(65,32)+CHR$(179):GOSUB 10130
  804. 8350 X.$=CHR$(179)+RS$+CHR$(179):GOSUB 10130
  805. 8360 X.$=CHR$(179)+STRING$(65,32)+CHR$(179):GOSUB 10130
  806. 8370 X.$=CHR$(179)+TS$+CHR$(179):GOSUB 10130
  807. 8380 X.$=CHR$(179)+US$+CHR$(179):GOSUB 10130
  808. 8390 X.$=CHR$(192)+STRING$(65,196)+CHR$(217):GOSUB 10130
  809. 8400 R.=21:C.=1:X.$="Enter search string or Direct Command:":GOSUB 10130
  810. 8410 L0=22:C0=1:RETURN
  811. 9990 '********* Load ML display program in array FP( ) **************
  812. 10000 I=0:N0=0:N1=26:X$="":FP=VARPTR(FP(0)):GOSUB 10060
  813. 10010 IF MONO THEN FOR I=1 TO 13:READ X$:NEXT      'no need to wait for retrace
  814. 10020 N0=27:N1=35+13*(1-MONO):GOSUB 10060
  815. 10030 IF MONO THEN POKE FP+12,&HB0:POKE FP+30,&HFC 'change scrn buffer, jmp adr
  816. 10040 RETURN
  817. 10050 'read part of data, poke into array
  818. 10060 FOR I=N0 TO N1:READ X$:POKE FP+I,VAL("&h"+X$):NEXT
  819. 10070 RETURN
  820. 10080 '************* Data for Fast Print Routines ********************
  821. 10090 DATA 55,8B,EC,06,8B,76,08,8B,  44,02,BB,00,B8,8E,C3,8A
  822. 10100 DATA 0C,B5,00,8B,76,06,8B,3C,  8B,F0,FC,BA,DA,03,EC,A8
  823. 10110 DATA 01,75,FB,EC,A8,01,74,FB,  A4,47,E2,F2,07,5D,CA,04,  00
  824. 10120 '************** Print X.$ at location (R.,C.) ******************
  825. 10130 IF X.$="" THEN RETURN
  826. 10140 IF R.<>0 THEN R0.=R. ELSE R.=R0.+1:R0.=R.   'increment row as default
  827. 10150 IF C.<>0 THEN C0.=C. ELSE C.=C0.-(C0.=0):C0.=C. 'retain column as default
  828. 10160 L.=160*(R.-1)+2*(C.-1)
  829. 10170 R.=0:C.=0:FP=VARPTR(FP(0))
  830. 10180 CALL ABSOLUTE(X.$,L.,FP)
  831. 10190 RETURN
  832. 
  833.