home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / misc / search.lbr / SEARCH.BZS / SEARCH.BAS
Encoding:
BASIC Source File  |  1993-10-25  |  9.5 KB  |  219 lines
  1. 10 '    *****************************************************
  2.  
  3.     *****          UTILITY  SEARCH  PROGRAM        *****
  4.  
  5.     *****                        *****
  6. 11 '    *****          by Richard Altman        *****
  7.  
  8.     *****          ////  2/6/90  \\\        *****
  9.  
  10.     *****                        *****
  11. 12 '    *****    Copyright (c) 1990 by Richard Altman    *****
  12.  
  13.    ' **************************************************************************
  14. 13 '
  15. 14 '     USER SUPPORTED
  16. 15 '     ==== =========
  17. 16 '
  18. 17 '     This program is user-supported software.  It is copyrighted and cannot
  19. 18 ' be sold for profit (without the author's express written permission),  but
  20. 19 ' it may be copied and distributed for free.
  21. 20 '
  22. 21 '     The  SHAREWARE  concept is a  distribution method  that dispenses with
  23. 22 ' heavy  marketing/advertising costs and gives the user the  opportunity  to
  24. 23 ' try a software program before buying.   Its continued existence depends on
  25. 24 ' each user paying for what he does, in fact, use.
  26. 25 '
  27. 26 '     If you find this program [SEARCH.BAS] useful,  please send the $20 (or
  28. 27 ' more) registration fee directly to the author:
  29. 28 '
  30. 29 '        Richard S. Altman -- P.O. Box 4388 -- Clearlake, CA 95422
  31. 30 '
  32. 31 '      Upon registration,  you will receive a floppy diskette containing the
  33. 32 ' latest version of this program, as well as a printed manual and a COMPILED
  34. 33 ' version.  You will also receive a FREE calendar printing program and other
  35. 34 ' programs by the same author.
  36. 35 '
  37. 36 '      WHEN ORDERING,  please be sure to indicate  single or double  density
  38. 37 ' disk drive,  and the name of the program  [SEARCH.BAS].   Comments on pro-
  39. 38 ' grams are also most welcome!
  40. 39 '
  41. 40 '     Due to  possible unforeseen circumstances,  the above offer is subject
  42. 41 ' to change without notice.
  43. 42 '
  44. 43 '***************************************************************************
  45. 44 '
  46. 45 '    SET UP VARIABLES:       String:   A$-F$, I$
  47.  
  48.     Integer:  G-H, J, T-Z       Single Precision:   K-S
  49.  
  50.  
  51. 46 DEFINT G-J,T-Z:DEFSTR A-F,I:DIM F(24),D(8):E=CHR$(32):A=CHR$(34)
  52. 47 CLS=CHR$(26):CLR=CHR$(24):CX=CHR$(23):PRINT CLS:ESC$=CHR$(27):FE=ESC+"="
  53. 48 FOR X=1 TO 24:F(X)=FE+CHR$(X+31)+E:NEXT:GOSUB 5020:C7=CHR$(7):WIDTH 255
  54. 49 DEF FNF(X,Y)=FE+CHR$(X+31)+CHR$(Y+31):DEF FNRN(X)=INT(RND*X)+1
  55. 50 DEF FNTITLE$(X,M$)=FNF(X,1)+STRING$((80-LEN(M$))/2,12)+M$
  56. 51 FS=STRING$(79,45):F=STRING$(6,32):ON ERROR GOTO 6500
  57. 52 U$=" UTILITY  SEARCH  PROGRAM ":GOSUB 75:GOTO 100
  58. 55 '
  59. 60 PRINT FNF(4,7)X"Line";:IF X<>1 THEN PRINT"s";
  60. 65 PRINT" to SEARCH in `"FLNAME"'"F;FNF(4,60)"Date: "D2$:RETURN
  61. 75 PRINT CLS;FS:L$=FNF(2,25)+E+U$+E:GOSUB 5065:PRINT:PRINT FS:RETURN
  62. 80 '
  63. 100 '    Display Opening Screen
  64. 105 PRINT FNF(7,7)"This program will search your program for any string(s)"
  65. 110 PRINT F"you wish.  To use it, you must:"
  66. 115 PRINT FNF(10,10)"1.  Be sure each line of your program is less than ";
  67. 120 PRINT"245 bytes."FNF(11,10)"2.  Save your program in ";:L$="ASCII format"
  68. 125 GOSUB 5050:PRINT":  ("A"FILENAME"A",A)."
  69. 130 PRINT FNF(12,10)"3.  The Disk must have enough free space for a 2nd ";
  70. 135 PRINT"ASCII copy."FNF(13,10)"4.  Run this SEARCH UTILITY."
  71. 140 L$=FNF(18,10)+"  Are you ready to run the SEARCH Utility ?   (Y/N)  "+C7
  72. 145 PRINT FNF(19,37)"~~~~~~ ~~~~~~~"
  73. 150 GOSUB 5065:PRINT"    ";
  74. 155 GOSUB 6000:IF AK="Y" OR AK=CHR$(13) THEN 165
  75. 160 IF AK="N" THEN PRINT:PRINT:END:GOTO 155 ELSE 155
  76. 165 PRINT FNF(18,10)CX"What is the FILENAME of your program--- ";
  77. 170 INPUT FLNAME:IF FLNAME="" THEN 165
  78. 175 IF RIGHT$(FLNAME,4)<>".BAS" THEN FLNAME=FLNAME+".BAS"
  79. 180 '
  80. 200 '    Check for File's existance
  81. 210 L$=FNF(18,10)+"Checking to see if `"+FLNAME+"' exists...."
  82. 220 GOSUB 5050:PRINT"   "CX;:FOR T=1 TO 750:NEXT
  83. 230 NAME FLNAME AS FLNAME
  84. 240 L1=LEN(FLNAME):A1=FLNAME:FOR X=1 TO L1
  85. 250 IF ASC(MID$(A1,X,1))>90 THEN MID$(A1,X,1)=CHR$(ASC(MID$(A1,X,1))-32)
  86. 260 NEXT:FLNAME=A1:GOSUB 8000
  87. 270 '
  88. 300 '    Check for Long Lines
  89. 310 L$="Checking for over-long lines....":PRINT FNF(20,10)CX;:GOSUB 5050
  90. 320 PRINT"   ";:OPEN "I",1,FLNAME:X=0
  91. 330 IF EOF(1) THEN CLOSE:IF O=1 THEN 1500 ELSE 500
  92. 340 X=X+1:LINE INPUT #1,A
  93. 350 IF O=1 THEN 360 ELSE IF LEN(A)>245 THEN PRINT FNF(6,7)L$;CX;F(8)
  94. 360 IF LEN(A)>245 THEN PRINT"Line "LEFT$(A,INSTR(A," "))"is"LEN(A)"bytes.":O=1
  95. 370 GOTO 330
  96. 380 '
  97. 500 '    Input Search Strings
  98. 505 PRINT F(6)CX;FNF(7,7)"Filename:  "FLNAME"        Today's Date: "D2$
  99. 510 U=9:PRINT F(U)CX;C7
  100. 515 'M=5:D(1)="SEARCH":D(2)="STRING$":D(3)="PRINT":D(4)="FNF(":GOTO 1000
  101. 520 FOR M=1 TO 8:PRINT F(M+U)F"Enter string  #"M"---  ";
  102. 525 BX="":LINE INPUT BX:D(M)=BX:L(M)=LEN(BX)
  103. 530 IF BX="" THEN IF M=1 THEN 520 ELSE PRINT:GOTO 545
  104. 535 NEXT M:PRINT FNF(20,7)"You have reached the maximum of eight searches."
  105. 540 PRINT FNF(22,7)"Press <ANY KEY> to continue.   ";:GOSUB 6000
  106. 545 PRINT F(19)CX:PRINT F;:L$=" Check the above SEARCHES. ":GOSUB 5065
  107. 550 PRINT"    ";:L$=" Are they correct? ":GOSUB 5065:PRINT:PRINT
  108. 555 PRINT F;STRING$(60,45);F(20)STRING$(59,12)"(Y/N)  "C7;
  109. 560 GOSUB 6000:IF AK="Y" OR AK=CHR$(13) THEN 1000
  110. 565 IF AK<>"N" THEN 560
  111. 570 PRINT FNF(22,7)"Press <A> to ABORT `NO' answer and continue."CX
  112. 575 PRINT FNF(23,7)"Press <RETURN> to retype above responses.   ";
  113. 580 GOSUB 6000:IF AK="A" THEN 1000
  114. 585 IF AK=CHR$(13) THEN 510 ELSE 580
  115. 590  '
  116. 1000 '    ====  SEARCH  ====
  117. 1010 OPEN "I",1,FLNAME:PRINT F(6) CX:GOSUB 60:PRINT FS
  118. 1020 XX=X+1:DIM E(X+2):NL=6:NF=1:J=1
  119. 1030 GOSUB 5025:IF EOF(1) THEN 1750
  120. 1040 LINE INPUT #1,A:QL=1:LN=INSTR(A," "):AL=LEFT$(A,LN)
  121. 1050 FOR Q=1 TO M-1:N=1: N=INSTR(N,A,D(Q)):NX=NL
  122. 1060 GOSUB 60:IF N<1 THEN 1110
  123. 1070 IF NL=6 AND NF=1 THEN PRINT F(5)FS;CX
  124. 1080 IF QL=1 THEN E(J)=AL+"--- "+D(Q):PRINT FNF(NL,NF)LEFT$(E(J),38);:QL=2:NL=NL+1:J=J+1:GOTO 1110
  125. 1090 IF NL=6 THEN NK=23:NF=1 ELSE NK=NL-1
  126. 1100 IF QL=2 THEN E(J-1)=E(J-1)+"  "+D(Q):PRINT FNF(NK,NF)LEFT$(E(J-1),38)
  127. 1110 NEXT Q:X=X-1
  128. 1120 IF NL>22 THEN NL=6:NF=40:GOSUB 1200
  129. 1130 GOTO 1030
  130. 1140 '
  131. 1200 '    End of Page Subroutine
  132. 1210 N2=N2+1:IF N2=1 OR N2=3 OR N2=5 OR N2=7 OR N2=9 THEN RETURN
  133. 1220 L$=FNTITLE$(24,"   Press <ANY KEY> to continue the list.   ")
  134. 1230 GOSUB 5020:GOSUB 1240:NL=6:NF=1:GOTO 5025
  135. 1240 AQ=INKEY$:AK=""
  136. 1250 GOSUB 5065:TX=0
  137. 1260 AK=INKEY$:IF AK<>"" THEN RETURN ELSE TX=TX+1:IF TX<150 THEN 1260
  138. 1270 PRINT L$;:TX=0
  139. 1280 AK=INKEY$:IF AK<>"" THEN RETURN ELSE TX=TX+1:IF TX<100 THEN 1280
  140. 1290 GOTO 1250
  141. 1300 '
  142. 1500 '    Some lines need to be shortened.
  143. 1510 PRINT:PRINT:PRINT F;
  144. 1520 L$="  Your program has NOT been searched.   The above lines need to  "
  145. 1530 GOSUB 5065:PRINT:PRINT F;C7;
  146. 1540 L$="  be shortened.  You will have to edit them before continuing.   "
  147. 1550 GOSUB 5065:END:GOTO 555
  148. 1560 '
  149. 1750 GOSUB 5020:Z=22
  150. 1760 '
  151. 2000 '    Search is Finished/ Display Options
  152. 2010 PRINT F(Z):L$=STRING$(79,32):GOSUB 5050:PRINT C7:L$=" OPTIONS: "
  153. 2020 GOSUB 5065:PRINT"  [R]  Repeat List      [Q]  Quit (End Program)     "CX;
  154. 2030 PRINT"[P] Print List";:CLOSE:GOSUB 5025
  155. 2040 GOSUB 6000:IF AK="R" OR AK=CHR$(13) THEN 3000
  156. 2050 IF AK="P" THEN 3500
  157. 2060 IF AK="Q" THEN 4000 ELSE 2040
  158. 2070 '
  159. 3000 '    Repeat List
  160. 3010 GOSUB 75:X=XX-1:GOSUB 60:PRINT FS
  161. 3020 GOSUB 5025:NL=6:NF=1:N2=0
  162. 3030 FOR Y=1 TO J:IF E(Y)="" THEN 3080
  163. 3040 IF NL=6 AND NF=1 THEN PRINT F(5)FS;CX
  164. 3050 PRINT FNF(NL,1)LEFT$(E(Y),38);FNF(NL,40)LEFT$(E(Y+17),38)
  165. 3060 NL=NL+1:IF NL>22 AND E(Y+17)="" THEN 1750
  166. 3070 IF NL>22 THEN NL=6:N2=N2+1:Y=Y+17:GOSUB 1200
  167. 3080 NEXT Y:GOTO 1750
  168. 3090 '
  169. 3500 '    Print List on Printer
  170. 3510 GOSUB 75:X=XX-1:GOSUB 60:PRINT FS:GOSUB 5020
  171. 3520 PRINT FNF(10,7)"SEARCH List is being output to Printer.   ";
  172. 3530 LPRINT ESC$"N"ESC$"!":WIDTH LPRINT 80:JK=J/2
  173. 3540 LPRINT FS:LPRINT"     "FLNAME;TAB(27)U$;TAB(60)"Date: "D2$
  174. 3550 LPRINT FS:LPRINT ESC$"E";ESC$;CHR$(34):WIDTH LPRINT 96
  175. 3560 FOR Y=1 TO JK:IF E(Y)="" THEN 3580
  176. 3570 LPRINT F;E(Y);TAB(45)E(Y+JK)
  177. 3580 NEXT Y:LPRINT CHR$(12):Z=14:GOTO 2000
  178. 3590 '
  179. 4000 '    End Program   ***   Load Original Program
  180. 4010 GOSUB 75:L$=FNF(10,7)+" SEARCH UTILITY FINISHED "+C7
  181. 4020 GOSUB 5065:PRINT"  The original program  `"FLNAME"'"
  182. 4030 PRINT F"remains on the disk in its ASCII format.":PRINT
  183. 4040 PRINT F"It is now being loaded back in.  You should SAVE it back on"
  184. 4050 PRINT F"disk again so it will load faster than the ASCII version."
  185. 4060 GOSUB 5020:CLOSE:PRINT F(17):LOAD FLNAME:END:RUN
  186. 4070 '
  187. 5000 '    *****    Misc. Subroutines
  188. 5005 '
  189. 5010 PRINT ESC"B0";:RETURN:'    Inverse Video ON/OFF
  190. 5015 PRINT ESC"C0";:RETURN:
  191. 5020 PRINT ESC"B4";:RETURN:'    Turn Cursor ON/OFF
  192. 5025 PRINT ESC"C4";:RETURN:
  193. 5030 PRINT ESC"B1";:RETURN:'    Reduced Intensity ON/OFF
  194. 5035 PRINT ESC"C1";:RETURN:
  195. 5040 PRINT ESC"B3";:RETURN:'    Underline ON/OFF
  196. 5045 PRINT ESC"C3";:RETURN:
  197. 5050 GOSUB 5040:PRINT L$;:GOTO 5045:'    Underline L$
  198. 5055 '
  199. 5060 GOSUB 5010:GOSUB 5030:PRINT L$;:GOSUB 5015:GOTO 5035:'    Revrs. Video L$
  200. 5065 GOSUB 5010:PRINT L$;:GOTO 5015:'                BRIGHT Video L$
  201. 5070 '
  202. 6000 '    INKEY$ Subroutines
  203. 6010 K$=INKEY$:AK=""
  204. 6020 AK=INKEY$:IF AK="" THEN 6020
  205. 6030 IF ASC(AK)>96 THEN AK=CHR$(ASC(AK)-32)
  206. 6040 RETURN
  207. 6050 K$=INKEY$:IN=""
  208. 6060 IN=INKEY$:IF IN<>CHR$(13) THEN 6060 ELSE RETURN
  209. 6070 '
  210. 6500 '    ERROR LINE Subroutine
  211. 6510 IF ERR=53 THEN L$=FNF(19,10)+"  ERROR:  File not found.  "+C7:GOSUB 5065:FOR T=1 TO 5000:NEXT:RESUME 165
  212. 6520 IF ERR=58 THEN RESUME 240
  213. 6530 PRINT:PRINT C7"Error"ERR"in Line"ERL:END:RUN
  214. 6540 '
  215. 8000 RESTORE 8080:'    Today's Date CALCULATION  (= D2$)
  216. 8010 FOR X=1 TO 6:READ ID%(X):NEXT
  217. 8020 FOR Y=3 TO 6:ID%=ID%(Y):GOSUB 8050:CV%(Y)=CVAL%:NEXT
  218. 8030 M$=STR$(CV%(5)):D$=STR$(CV%(6)):Y$=STR$(CV%(3))
  219. 8040 D2$=RIGHT$(M$,2)+"/"+RIGHT$(D$,2)+"/"+RIGHT$(Y$,2):RETURN
  220. 8050 OUT 32,ID%:BCD%=INP(36)
  221. 8060 SX=INT(BCD%/16):S1=BCD%-16*SX
  222. 8070 CVAL%=10*SX+S1:RETURN
  223. 8080 DATA 0,0,9,0,7,6
  224. ):RETURN
  225. 8050 OUT 32,ID%:BCD%=INP(36)
  226. 8060 SX=INT(BCD%/16):