home *** CD-ROM | disk | FTP | other *** search
/ Between Heaven & Hell 2 / BetweenHeavenHell.cdr / 300 / 294 / diskidx.bas < prev    next >
BASIC Source File  |  1985-08-22  |  8KB  |  219 lines
  1.  
  2.  
  3. 2  '
  4. 4  '
  5. 6  'INDEX  (ver. 3.20)
  6. 8  '
  7. 10 'by Alan Centa
  8. 12 '   504 Ethan Allen Ave.
  9. 14 '   Takoma Park, MD  20912
  10. 26 '
  11. 28 '
  12. 30 '***************************  NOTICE  ***************************
  13. 31 '*  A limited license is granted to all users of this program,  *
  14. 32 '*  to make copies of this program and distribute them to other *
  15. 33 '*  users, on the following conditions:                         *
  16. 34 '*     1. The notices contained in lines 2 through 50  of the   *
  17. 35 '*        program are not to be altered or removed.             *
  18. 36 '*     2. The program is not to be distributed to others in     *
  19. 37 '*        modified form.                                        *
  20. 38 '*     3. No fee is to be charged for copying or distributing   *
  21. 39 '*        the program without an express written agreement with *
  22. 40 '*        the holder of the copyright.                          *
  23. 41 '*                                                              *
  24. 42 '*                 Copyright (c) 1983 Alan Centa                *
  25. 43 '****************************************************************
  26. 44 '
  27. 45 '
  28. 46 '
  29. 47 '
  30. 48 '
  31. 49 '
  32. 100 KEY OFF: WIDTH 80: WIDTH "LPT1:",132: SCREEN 0,0,0,0: CLS
  33. 110 ' MENU for indexing program
  34. 120 FILE$="INDEX32" :FALSE=0 :TRUE=NOT FALSE :QT$=CHR$(34): DRIVE$="A"
  35. 130  DIM D$(80), AC$(1000), AD$(20)
  36. 140  ACCFLAG=0: ADSFLAG=0: NAD=1: NAC=0
  37. 150 '
  38. 160 ' SET UP FUNCTION KEYS TO NUMBERS
  39. 170 KEY 1,"": KEY 2,"": KEY 3,"": KEY 4,"": KEY 5,""
  40. 180 KEY 6,"": KEY 7,"": KEY 8,"": KEY 9,"": KEY 10,"": KEY OFF
  41. 190 '
  42. 200 CLS
  43. 210 COLOR 4:LOCATE 2,6:PRINT "US NEWS - Disk indexing program - VERSION 3.2"
  44. 220 COLOR 7:LOCATE 4,12:PRINT "INDEXING FUNCTIONS AVAILIBLE"
  45. 230 LOCATE 6,3:PRINT "UNSHIFTED": LOCATE 6,35: PRINT "SHIFTED"
  46. 240 LOCATE 7,3,0 :PRINT "1. INDEX NEW DISK"
  47. 250 LOCATE 7,35,0 :PRINT "1. TURN ACCUMULATION ";
  48. 260 IF ACCFLAG=0 THEN PRINT "OFF" ELSE PRINT "ON"
  49. 270 LOCATE 8,3,0 :PRINT "2. RETITLE DISK"
  50. 280 LOCATE 8,35,0 :PRINT "2. TURN AUTO DISPLAY ";
  51. 290 IF ADSFLAG=0 THEN PRINT "OFF" ELSE PRINT "ON"
  52. 300 LOCATE 9,3,0 :PRINT "3. PRINT CURRENT INDEX"
  53. 310 LOCATE 9,35,0 :PRINT "3. PRINT ACCUMULATED INDEX"
  54. 320 LOCATE 10,3,0:PRINT "4. SPACE PRINT"
  55. 330 LOCATE 10,35,0:PRINT "4. SPACE PRINT"
  56. 340 LOCATE 11,3,0:PRINT "5. EJECT PRINT"
  57. 350 LOCATE 11,35,0:PRINT "5. EJECT PRINT"
  58. 360 LOCATE 12,3,0:PRINT "6. SELECT DRIVE"
  59. 370 LOCATE 12,35,0:PRINT "6. CLEAR ACCUMULATION"
  60. 380 'LOCATE 13,3,0:PRINT "7. SAVE INDEX TO A DOS FILE"
  61. 390 'LOCATE 13,35,0:PRINT "7. SAVE ACCUMULATION"
  62. 400 LOCATE 17,3,0:PRINT "ESC KEY - EXIT TO SYSTEM"
  63. 410 '
  64. 420 POKE 106,0 :'CLEAR KYBD BUFFER
  65. 430 K$ = INKEY$:IF K$ <> "" THEN GOTO 420
  66. 440 K$ = INKEY$:IF K$ = "" THEN GOTO 440
  67. 450 ON ERROR GOTO 0  : 'WAS 520
  68. 460 A$=MID$(K$,1,1) :'PRINT A$,ASC(A$)
  69. 470 IF ASC(A$)=0 THEN GOSUB 1470
  70. 480 IF A$="1" THEN GOSUB 760: GOTO 200: 'INDEX DISK
  71. 490 IF A$="!" THEN ACCFLAG=NOT ACCFLAG: GOTO 200 ; 'ACCUM ON/OFF
  72. 500 IF A$="2" THEN GOSUB 1100: GOTO 200: 'RENAME
  73. 510 IF A$="@" THEN ADSFLAG=NOT ADSFLAG: GOSUB 1130 :GOTO 200:  'AUTO DISPLAY
  74. 520 IF A$="3" THEN GOSUB 1260 : GOTO 420: 'PRINT CURRENT
  75. 530 IF A$="#" THEN GOSUB 1590 : GOTO 200: 'PRINT ACCUMULATED
  76. 540 IF A$="4" THEN GOSUB 1380: GOTO 420: 'SPACE PRINTER
  77. 550 IF A$="$" THEN GOSUB 1380: GOTO 420: 'SPACE PRINTER
  78. 560 IF A$="5" THEN GOSUB 1420: GOTO 420: 'EJECT
  79. 570 IF A$="%" THEN GOSUB 1420: GOTO 420: 'EJECT
  80. 580 IF A$="6" THEN GOSUB 1450: GOSUB 760: GOTO 200: 'CHANGE DRIVE
  81. 590 IF A$="^" THEN GOSUB 1940           : GOTO 200: 'CLEAR ACCUMULATION
  82. 600 IF A$="7" THEN
  83. 610 IF A$="&" THEN
  84. 620 IF A$="8" THEN
  85. 630 IF A$="*" THEN
  86. 640 IF A$="9" THEN
  87. 650 IF A$="(" THEN
  88. 660 IF A$="0" THEN
  89. 670 IF A$=")" THEN
  90. 680 IF A$=CHR$(13)THEN LOCATE 20,3,0:PRINT"                         ": GOTO 420
  91. 690 IF A$= CHR$(27) THEN GOTO 740
  92. 700 BEEP: LOCATE 20,3,0:COLOR 22: PRINT " FUNCTION NOT AVAILIBLE"
  93. 710 COLOR 7: GOTO 420
  94. 720 BEEP: LOCATE 20,3,0:COLOR 20: PRINT " DRIVE NOT READY"
  95. 730 COLOR 7: RESUME 210
  96. 740 ON ERROR GOTO 0: CLS: CHAIN "MENU": END
  97. 750 '
  98. 760 'NEW DISKETTE INDEX
  99. 770 PRINT "Enter title of diskette:"
  100. 780 ON ERROR GOTO 720
  101. 790 CLS: FILES DRIVE$+":*.*" :PRINT:PRINT
  102. 800 ON ERROR GOTO 0
  103. 810 I=1: J=1: N=0: A$="":
  104. 820 WHILE SCREEN(I,J)<>0 AND J<78 AND SCREEN(I,J)<>32
  105. 830   WHILE SCREEN(I,J)<>0 AND SCREEN(I,J)<>32
  106. 840      FOR K=9 TO 11
  107. 850        A$=A$+CHR$(SCREEN(I,J+K))
  108. 860      NEXT K
  109. 870      FOR K=0 TO 7
  110. 880        A$=A$+CHR$(SCREEN(I,J+K))
  111. 890      NEXT K
  112. 900      IF ACCFLAG=0 THEN NAC=NAC+1:AC$(NAC)=A$+STR$(NAD)
  113. 910      N=N+1: D$(N)=A$: A$="": I=I+1
  114. 920      WEND
  115. 930   I=1: J=J+13: WEND
  116. 940 PRINT "ENTER DISKETTE NAME:"
  117. 950 C=0 :S=0
  118. 960 ' START OF SHELL METZNER SORT
  119. 970 M=N
  120. 980 M=INT(M/2) :IF M=0 THEN 1090
  121. 990 J=1 :K=N-M
  122. 1000 I=J
  123. 1010 L=I+M :C=C+1
  124. 1020 IF D$(I) <=D$(L) THEN 1060
  125. 1030 SWAP D$(I),D$(L)
  126. 1040 I=I-M
  127. 1050 IF I>0 THEN 1010
  128. 1060 J=J+1
  129. 1070 IF J>K THEN 980
  130. 1080 GOTO 1000
  131. 1090 '
  132. 1100 CLS:BEEP: INPUT "Enter title of diskette:",TITLE$: B$="               "
  133. 1110 NEWNAME=1: AD$(NAD)=TITLE$: NAD=NAD+1
  134. 1120 '
  135. 1130 IF ADSFLAG<>0 THEN RETURN
  136. 1140 'SHOW NAMES ON CURRENT DISK
  137. 1150 CLS: PRINT "Enter title of diskette:";TITLE$+"     "+DATE$
  138. 1160 OLDEXT$=" ":J=0:A$=""
  139. 1170 FOR I=1 TO N
  140. 1180 IF J=INT(J/6)*6 THEN PRINT A$:A$=""
  141. 1190 IF MID$(D$(I),1,3)=OLDEXT$ THEN 1220
  142. 1200 OLDEXT$=MID$(D$(I),1,3):PRINT A$: PRINT
  143. 1210 PRINT "."+OLDEXT$+":": J=0: A$=""
  144. 1220 A$=A$+MID$(D$(I)+B$,4,12):J=J+1
  145. 1230 NEXT I: PRINT A$
  146. 1240 GOSUB 1520: RETURN
  147. 1250 '
  148. 1260 'PRINTING THE INDEX
  149. 1270 OLDEXT$=" ": LPRINT "Diskette: "+TITLE$+"    "+DATE$
  150. 1280 LPRINT:J=0:A$=""
  151. 1290 FOR I=1 TO N
  152. 1300 IF J=INT(J/6)*6 THEN LPRINT A$:A$=""
  153. 1310 IF MID$(D$(I),1,3)=OLDEXT$ THEN 1340
  154. 1320 OLDEXT$=MID$(D$(I),1,3):LPRINT A$: LPRINT:PRINT
  155. 1330 LPRINT "."+OLDEXT$+":": J=0: A$=""
  156. 1340 A$=A$+MID$(D$(I)+B$,4,12):J=J+1
  157. 1350 NEXT I:LPRINT A$
  158. 1360 RETURN
  159. 1370 '
  160. 1380 'SPACE PRINTER
  161. 1390 LPRINT : RETURN
  162. 1400 '
  163. 1410 'EJECT PRINTER
  164. 1420 LPRINT CHR$(12);: RETURN
  165. 1430 '
  166. 1440 'CHANGE DRIVE
  167. 1450 INPUT "ENTER DRIVE LETTER-",DRIVE$:NEWNAME=0:RETURN
  168. 1460 '
  169. 1470 ' INTERPRET FUNCTION KEYS
  170. 1480 A=ASC(MID$(K$,2,1))
  171. 1490 IF A>58 AND A<69 THEN A$=MID$("1234567890",A-58,1)
  172. 1500 IF A>83 AND A<94 THEN A$=MID$("!@#$%^&*()",A-83,1)
  173. 1510 RETURN
  174. 1520 ' ANY KEY TO END
  175. 1530 LOCATE 25,1: PRINT "PRESS ANY KEY TO CONTINUE";
  176. 1540 POKE 106,0 :'CLEAR KYBD BUFFER
  177. 1550 K$ = INKEY$:IF K$ <> "" THEN GOTO 1520
  178. 1560 K$ = INKEY$:IF K$ = "" THEN GOTO 1560
  179. 1570 ON ERROR GOTO 0  : RETURN
  180. 1580 '
  181. 1590 'PRINTING ACCUMULATED DATA
  182. 1600 PRINT "ENTER ACCUMULATION NAME:";
  183. 1610 C=0 :S=0
  184. 1620 ' START OF SHELL METZNER SORT
  185. 1630 M=NAC
  186. 1640 M=INT(M/2) :IF M=0 THEN 1740
  187. 1650 J=1 :K=NAC-M
  188. 1660 I=J
  189. 1670 L=I+M :C=C+1
  190. 1680 IF AC$(I) <=AC$(L) THEN 1720
  191. 1690 SWAP AC$(I),AC$(L)
  192. 1700 I=I-M
  193. 1710 IF I>0 THEN 1670
  194. 1720 J=J+1
  195. 1730 IF J>K THEN 1640 ELSE 1660
  196. 1740 ' ---- END OF S/M SORT
  197. 1750 '
  198. 1760 'PRINTING THE INDEX
  199. 1770 INPUT " ",TITLE$
  200. 1780 'PRINT DISK NAMES
  201. 1790 OLDEXT$=" ": LPRINT          TITLE$+"    "+DATE$
  202. 1800 FOR I=1 TO NAD-1: LPRINT I,AD$(I): NEXT I
  203. 1810 FOR I=1 TO 5 : LPRINT: NEXT I
  204. 1820 '
  205. 1830 OLDEXT$=" ": LPRINT CHR$(12)+TITLE$+"    "+DATE$
  206. 1840 LPRINT:J=0:A$="":B$="            "
  207. 1850 FOR I=1 TO NAC
  208. 1860 IF J=INT(J/6)*6 THEN LPRINT A$:A$=""
  209. 1870 IF MID$(AC$(I),1,3)=OLDEXT$ THEN 1900
  210. 1880 OLDEXT$=MID$(AC$(I),1,3):LPRINT A$: LPRINT:PRINT
  211. 1890 LPRINT "."+OLDEXT$+":": J=0: A$=""
  212. 1900 A$=A$+MID$(AC$(I)+B$,4,14):J=J+1
  213. 1910 NEXT I:LPRINT A$
  214. 1920 RETURN
  215. 1930 '
  216. 1940 ' CLEAR ACCUMULATION
  217. 1950 NAD=1: NAC=0: RETURN
  218. 
  219.