home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG055.ARC / PHONE.BAS < prev    next >
BASIC Source File  |  1979-12-31  |  10KB  |  293 lines
  1. 10 REM     ****************************************************
  2. 15 REM     ***                                              ***
  3. 20 REM     ***           INDEXED TELEPHONE FILE             ***
  4. 25 REM     ***                                              ***
  5. 30 REM     ***            WRITTEN IN MBASIC 5.2             ***
  6. 40 REM     ***            BY LES BELL, 6/15/82              ***
  7. 45 REM     ***                                              ***
  8. 50 REM     ***   DOWNLOADED TO KAYPRO, 7/20/83 FROM MICC    ***
  9. 60 REM     ***  PERSEVERED WITH BY ALL WHO CAME IN CONTACT  ***
  10. 65 REM     ***                                              ***
  11. 70 REM     ***      DEBUGGED & MODIFIED BY TODD WRIGHT      ***
  12. 71 REM     ***             (NO APPLAUSE PLEASE)             ***
  13. 75 REM     ***                                              ***
  14. 80 REM     ***       UPLOADED BACK TO MICC 07/24/83         ***
  15. 85 REM     ***                                              ***
  16. 90 REM     ****************************************************
  17. 100 :
  18. 110 REM    INITIALIZATION SECTION
  19. 120 :
  20. 130 DEFINT I - N
  21. 140 DEF FNGXY$(X,Y)=CHR$(27)+"="+CHR$(Y+31)+CHR$(X+31)
  22. 150 DEF FNHT$(A$)=CHR$(27)+")"+A$+CHR$(27)+"("
  23. 160 DEF FNLN$(L)=STRING$(L,95)
  24. 170 HOME$=CHR$(11)
  25. 180 CLS$=CHR$(12)
  26. 190 DIM N$(256), K(256)
  27. 200 TL%=300:            ' TIME DELAY
  28. 210 PRINT CLS$
  29. 220 INPUT "Telephone directory file";F$
  30. 230 IF F$="" THEN F$="TEST"
  31. 240 :
  32. 250 REM    *** READ INDEX FILE ***
  33. 260 :
  34. 270 ON ERROR GOTO 540
  35. 280 OPEN "I",#1,F$+".IND"
  36. 290 N=1
  37. 300 IF EOF(1) THEN CLOSE 1: GOTO 330
  38. 310 INPUT#1,N$(N),K(N)
  39. 320 N = N + 1: GOTO 300
  40. 330 PRINT: PRINT: PRINT N-1;"Records in file"
  41. 340 OPEN "R",#2,F$+".TDR"
  42. 350 FIELD #2,20 AS FM$,20 AS FC$,30 AS FA1$,20 AS FA2$,4 AS FPC$,15 AS FTEL$,19 AS FCT$
  43. 360 :
  44. 370 REM     *** DISPLAY MENU ***
  45. 380 :
  46. 390 PRINT CLS$
  47. 400 PRINT "1 - Add name"
  48. 410 PRINT "2 - Delete name"
  49. 420 PRINT "3 - Find name"
  50. 430 PRINT "4 - Find comment"
  51. 440 PRINT "5 - List file to Video"
  52. 450 PRINT "6 - List file to Printer"
  53. 460 PRINT "7 - Quit and return to CP/M"
  54. 470 PRINT: PRINT "Enter choice:";
  55. 480 A$ = INKEY$
  56. 490 WHILE A$<"1" OR A$ > "7"
  57. 500   A$ = INKEY$
  58. 510 WEND
  59. 520 ON ASC(A$)-48 GOTO 690,1780,1280,2350,1080,2580,600
  60. 530 :
  61. 540 IF ERR=53 THEN CLOSE: PRINT "File does not exist - creating one.": N=1: RESUME 340
  62. 550 PRINT "Error";ERR;"in line";ERL: STOP
  63. 560 :
  64. 570 REM     *** EXIT TO CP/M ***
  65. 580 :
  66. 590 REM WRITE INDEX FILE
  67. 600 GOSUB 1630: GOSUB 2150: REM SORT INDICES AND PACK FILE
  68. 610 OPEN "O",#1,F$+".IND"
  69. 620 FOR I=1 TO N-1: IF K(I) = 0 THEN 640
  70. 630 WRITE#1,N$(I),K(I)
  71. 640 NEXT I
  72. 650 PRINT CLS$: CLOSE:PRINT"Going back to CP/M.... Goodbye, Have a nice day....":SYSTEM
  73. 660 :
  74. 670 REM     *** ROUTINE TO ADD A NAME TO FILE ***
  75. 680 :
  76. 690 IF DELFLG = 1 THEN GOSUB 1630: GOSUB 2150
  77. 700 PRINT CLS$;"Add name to file ":FOR I=1 TO TL%: NEXT I
  78. 710 PRINT CLS$
  79. 720 PRINT FNGXY$(1,3);FNHT$("Surname     : ");FNLN$(20)
  80. 730 PRINT FNHT$("First Name  : ");FNLN$(20)
  81. 740 PRINT FNHT$("Street      : ");FNLN$(30)
  82. 750 PRINT FNHT$("Town/City   : ");FNLN$(20)
  83. 760 PRINT FNHT$("Postcode    : ");FNLN$(4)
  84. 770 PRINT FNHT$("Telephone   : ");FNLN$(15)
  85. 780 PRINT FNHT$("Comment     : ");FNLN$(19)
  86. 790 PRINT FNGXY$(13,3);:INPUT N$
  87. 800 IF N$ = "" THEN GOTO 390
  88. 810 PRINT FNGXY$(13,3);": ";N$;SPACE$(20-LEN(N$))
  89. 820 PRINT FNGXY$(13,4);:INPUT C$
  90. 830 PRINT FNGXY$(13,4);": ";C$;SPACE$(20-LEN(C$))
  91. 840 PRINT FNGXY$(13,5);:INPUT A1$
  92. 850 PRINT FNGXY$(13,5);": ";A1$;SPACE$(30-LEN(A1$))
  93. 860 PRINT FNGXY$(13,6);:INPUT A2$
  94. 870 PRINT FNGXY$(13,6);": ";A2$;SPACE$(20-LEN(A2$))
  95. 880 PRINT FNGXY$(13,7);:INPUT PC$
  96. 890 PRINT FNGXY$(13,7);": ";PC$;SPACE$(16)
  97. 900 PRINT FNGXY$(13,8);:INPUT TEL$
  98. 910 PRINT FNGXY$(13,8);": ";TEL$;SPACE$(15-LEN(TEL$))
  99. 920 PRINT FNGXY$(13,9);:INPUT CT$
  100. 930 PRINT FNGXY$(13,9);": ";CT$;SPACE$(19-LEN(CT$))
  101. 940 REM    *** WRITE RECORD TO DISK ***
  102. 950 LSET FM$ = N$
  103. 960 LSET FC$ = C$
  104. 970 LSET FA1$ = A1$
  105. 980 LSET FA2$ = A2$
  106. 990 LSET FPC$ = PC$
  107. 1000 LSET FTEL$ = TEL$
  108. 1010 LSET FCT$ = CT$
  109. 1020 PUT #2,N
  110. 1030 N$(N) = N$: K(N) = N
  111. 1040 N = N + 1
  112. 1050 GOTO 690
  113. 1060 :
  114. 1070 REM     *** LIST FILE TO CON: ***
  115. 1080 FOR I = 1 TO N-1
  116. 1090 IF K(I) = 0 THEN 1250
  117. 1100 GET #2,K(I)
  118. 1110 PRINT CLS$;I
  119. 1120 PRINT FNGXY$(1,3);FNHT$("Surname     : ");FM$
  120. 1130 PRINT FNHT$("First Name  : ");FC$
  121. 1140 PRINT FNHT$("Street      : ");FA1$
  122. 1150 PRINT FNHT$("Town/City   : ");FA2$
  123. 1160 PRINT FNHT$("Postcode    : ");FPC$
  124. 1170 PRINT FNHT$("Telephone   : ");FTEL$
  125. 1180 PRINT FNHT$("Comment     : ");FCT$
  126. 1190 PRINT FNGXY$(40,24);: PRINT "Hit space bar to hold, ESC to quit";
  127. 1200 FOR J=1 TO TL%
  128. 1210 A$=INKEY$: IF LEN(A$) = 0 THEN 1240
  129. 1220 IF A$ = " " THEN J = 1
  130. 1230 IF A$ = CHR$(27) THEN 390
  131. 1240 NEXT J
  132. 1250 NEXT I
  133. 1260 GOTO 390
  134. 1270 :
  135. 1280 REM    *** ROUTINE TO FIND NAME ***
  136. 1290 :
  137. 1300 PRINT CLS$;"Search file for name"
  138. 1310 PRINT FNGXY$(1,5);:INPUT "Name to find";N$
  139. 1320 REM    *** BINARY SEARCH ON N$(N) ***
  140. 1330 L = 1: U = N - 1: 'SET UPPER AND LOWER BOUNDARIES
  141. 1340 IF U < L THEN 1540
  142. 1350 I = (U + L) \ 2
  143. 1360 IF N$ < N$(I) THEN U = I - 1: GOTO 1340
  144. 1370 IF N$ > N$(I) THEN L = I + 1: GOTO 1340
  145. 1380 GET #2,K(I)
  146. 1390 PRINT FNGXY$(1,3);FNHT$("Surname     : ");FM$
  147. 1400 PRINT FNHT$("First Name  : ");FC$
  148. 1410 PRINT FNHT$("Street      : ");FA1$
  149. 1420 PRINT FNHT$("Town/City   : ");FA2$
  150. 1430 PRINT FNHT$("Postcode    : ");FPC$
  151. 1440 PRINT FNHT$("Telephone   : ");FTEL$
  152. 1450 PRINT FNHT$("Comment     : ");FCT$
  153. 1460 PRINT FNGXY$(40,24);"Hit space to continue, ESC to quit";
  154. 1470 A$ = INKEY$
  155. 1480 WHILE A$ <> " " AND A$ <> CHR$(27)
  156. 1490   A$ = INKEY$
  157. 1500 WEND
  158. 1510 IF A$ = " " THEN I = I + 1:IF I < N THEN 1380
  159. 1520 GOTO 390
  160. 1530 :
  161. 1540 REM     *** UNSUCCESSFUL ***
  162. 1550 :
  163. 1560 PRINT CLS$;"Not found";
  164. 1570 FOR I = 1 TO TL%:NEXT I
  165. 1580 GOTO 390
  166. 1590 REM     *** SORT INDEX ARRAY ***
  167. 1600 :
  168. 1610 GOSUB 1630:GOSUB 2150: GOTO 390
  169. 1620 REM     *** SORT SUBROUTINE ***
  170. 1630 PRINT CLS$;"Sorting index. Please wait"
  171. 1640 M = (N-1)/2
  172. 1650 L = N - M - 1
  173. 1660 FOR J = 1 TO L
  174. 1670  FOR I = J TO 1 STEP -M
  175. 1680    IF N$(I) > N$(I+1) THEN SWAP N$(I), N$(I+1): SWAP K(I), K(I+1)
  176. 1690     PRINT ".";
  177. 1700  NEXT I
  178. 1710 NEXT J
  179. 1720 M = M \ 2
  180. 1730 IF M <> 0 THEN 1650
  181. 1740 RETURN
  182. 1750 :
  183. 1760 REM    *** ROUTINE TO DELETE NAME FROM FILE ***
  184. 1770 :
  185. 1780 PRINT CLS$;"Delete name from file"
  186. 1790 PRINT FNGXY$(1,5);:INPUT "Name to delete";N$
  187. 1800 IF N$=CHR$(13) THEN 390
  188. 1810 REM    *** BINARY SEARCH ON N$(N) ***
  189. 1820 L = 1: U = N - 1: 'SET UPPER AND LOWER BOUNDARIES
  190. 1830 IF U < L THEN 1540
  191. 1840 I = (U + L) \ 2
  192. 1850 IF N$ < N$(I) THEN U = I - 1: GOTO 1830
  193. 1860 IF N$ > N$(I) THEN L = I + 1: GOTO 1830
  194. 1870 IF K(I)=0 THEN 1780
  195. 1880 GET #2,K(I)
  196. 1890 IF LEFT$(FM$,1) = ";" THEN K=K+1:GOTO 1290
  197. 1900 IF LEFT$(FM$,1)=" " THEN PRINT CLS$;"Not found":FOR J = 1 TO TL%:NEXT J:GOTO 390
  198. 1910 PRINT CLS$
  199. 1920 PRINT FNGXY$(1,3);FNHT$("Surname     : ");FM$
  200. 1930 PRINT FNHT$("First Name  : ");FC$
  201. 1940 PRINT FNHT$("Street      : ");FA1$
  202. 1950 PRINT FNHT$("Town/City   : ");FA2$
  203. 1960 PRINT FNHT$("Postcode    : ");FPC$
  204. 1970 PRINT FNHT$("Telephone   : ");FTEL$
  205. 1980 PRINT FNHT$("Comment     : ");FCT$
  206. 1990 PRINT FNGXY$(40,24);"Delete (Y/N/ <S>EARCH FOR NEW NAME>)";
  207. 2000 GOSUB 2070
  208. 2010 IF A$="S" THEN 1780
  209. 2020 IF A$ <> "Y" AND A$ <> "y" THEN I = I + 1:GOTO 1870
  210. 2030 K(I) = 0: DELFLG = 1
  211. 2040 GOTO 390
  212. 2050 :
  213. 2060 REM     *** SUBROUTINE TO RETURN Y/N RESPONSE IN A$ ***
  214. 2070 A$ = INKEY$
  215. 2080 WHILE A$ <> "Y" AND A$ <> "N" AND A$ <> "S"
  216. 2090   A$ = INKEY$
  217. 2100 WEND
  218. 2110 RETURN
  219. 2120 :
  220. 2130 REM     *** PACK RANDOM FILE ***
  221. 2140 :
  222. 2150 PRINT CLS$;"Packing data file.";
  223. 2160 D = 0
  224. 2170 FOR S = 1 TO LOF(2)
  225. 2180 T$=SPACE$(20)
  226. 2190 GET#2,S
  227. 2200 N$ = FM$
  228. 2210 L=1: U=N-1
  229. 2220 IF U<L THEN 2300
  230. 2230 I = (U + L) \ 2
  231. 2240 LSET T$ = N$(I)
  232. 2250 IF N$ < T$ THEN U = I - 1: GOTO 2220
  233. 2260 IF N$ > T$ THEN L = I + 1: GOTO 2220
  234. 2270 IF K(I) = 0 THEN 2300
  235. 2280 D = D + 1
  236. 2290 PUT#2,D:K(I) = D:PRINT ".";
  237. 2300 NEXT S
  238. 2310 DELFLG = 0
  239. 2320 RETURN
  240. 2330 REM     *** FIND COMMENT ***
  241. 2340 :
  242. 2350 PRINT CLS$; "Find comment"
  243. 2360 PRINT FNGXY$(1,5);:INPUT "Comment to search for";CT$
  244. 2370 FOR I=1 TO LOF(2)
  245. 2380 IF K(I) = 0 THEN 2550
  246. 2390 GET #2,K(I)
  247. 2400 IF LEFT$(FCT$,LEN(CT$)) <> CT$ THEN 2550
  248. 2410 PRINT CLS$;
  249. 2420 PRINT FNGXY$(1,3);FNHT$("Surname     : ");FM$
  250. 2430 PRINT FNHT$("First Name  : ");FC$
  251. 2440 PRINT FNHT$("Street      : ");FA1$
  252. 2450 PRINT FNHT$("Town/City   : ");FA2$
  253. 2460 PRINT FNHT$("Postcode    : ");FPC$
  254. 2470 PRINT FNHT$("Telephone   : ");FTEL$
  255. 2480 PRINT FNHT$("Comment     : ");FCT$
  256. 2490 PRINT FNGXY$(40,24);: PRINT "Hit space bar to hold, ESC to quit";
  257. 2500 FOR J=1 TO TL%
  258. 2510 A$=INKEY$: IF LEN(A$) = 0 THEN 2540
  259. 2520 IF A$ = " " THEN J = 1
  260. 2530 IF A$ = CHR$(27) THEN 390
  261. 2540 NEXT J
  262. 2550 NEXT I
  263. 2560 GOTO 390
  264. 2570 :
  265. 2580 REM      *** LIST FILE TO PRINTER ***
  266. 2590 :
  267. 2600 X=132
  268. 2610 PRINT CLS$;"IS PRINTER IN 132 COLUMN MODE (Y/N)";:INPUT PR$
  269. 2620 IF PR$="N" THEN PRINT"PRINTER ASSUMED 80 COLUMN MODE":X=80
  270. 2630 FOR J = 1 TO TL%:NEXT J
  271. 2640 LA=(X/2)-(LEN(F$)+6)
  272. 2650 WIDTH LPRINT X
  273. 2660 LPRINT STRING$(LA,32);"UPDATED ";F$;" LISTING"
  274. 2670 LPRINT : LPRINT
  275. 2680 FOR J = 1 TO N - 1
  276. 2690 IF K(J)=0 THEN 2800
  277. 2700 GET #2,K(J)
  278. 2710 PRINT CLS$;"Printing File ";J;" to Paper....  "
  279. 2720 SP=(20-LEN(FM$)):LPRINT FM$;STRING$(SP,32);
  280. 2730 SP=(20-LEN(FC$)):LPRINT FC$;STRING$(SP,32);
  281. 2740 SP=(30-LEN(FA1$)):LPRINT FA1$;STRING$(SP,32);
  282. 2750 SP=(20-LEN(FA2$)):LPRINT FA2$;STRING$(SP,32);
  283. 2760 SP=(6-LEN(FPC$)):LPRINT FPC$;STRING$(SP,32);
  284. 2770 SP=(16-LEN(FTEL$)):LPRINT FTEL$;STRING$(SP,32);
  285. 2780 SP=(20-LEN(FCT$)):LPRINT FCT$;STRING$(SP,32)
  286. 2790 LPRINT
  287. 2800 NEXT J
  288. 2810 GOTO 390
  289. L$)):LPRINT FTEL$;STRING$(SP,32);
  290. 2780 SP=(20-LEN(FCT$)):LPRINT FCT$;STRING$(SP,32)
  291. 2790 LPRINT
  292. 2800 NEXT J
  293. 28