home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / sigm / vols200 / vol235 / sort.bas < prev    next >
Encoding:
BASIC Source File  |  1994-07-13  |  8.3 KB  |  320 lines
  1. 1 REM BASICODE 2 ROUTINES DOOR HENK WEVERS
  2. 2 REM NADERE INLICHTINGEN BASICODE
  3. 3 REM NOS, HOBBYSCOOP HILVERSUM  
  4. 5 PRINT CHR$(26);:WIDTH(255)
  5. 10 GOTO 1000
  6. 20 GOTO 1010
  7. 100 PRINT CHR$(26);:RETURN
  8. 110 REM
  9. 111 IF HO>51 THEN HO=51
  10. 112 IF VE>23 THEN VE=23
  11. 113 PRINT CHR$(27);"=";CHR$(VE+32);CHR$(HO+32);
  12. 115 RETURN
  13. 120 HO=PEEK(&HEF5A):VE=PEEK(&HEF5B)-&HF0
  14. 121 VE=VE*2
  15. 122 IF HO>127 THEN HO=HO-128:VE=VE+1
  16. 123 VE=VE-PEEK(&HEF62):IF VE<0 THEN VE=32+VE
  17. 124 RETURN
  18. 200 IN$=INKEY$:RETURN
  19. 210 GOSUB 200:IF IN$="" THEN 210
  20. 211 RETURN
  21. 250 PRINT CHR$(7);:RETURN
  22. 260 RV=RND(1):RETURN
  23. 270 FR=FRE(2):RETURN
  24. 300 SR$=STR$(SR)
  25. 301 Q7=LEN(SR$):IF Q7=0 THEN RETURN
  26. 302 IF RIGHT$(SR$,1)<>" " THEN 304
  27. 303 SR$=LEFT$(SR$,Q7-1):GOTO 301
  28. 304 IF LEFT$(SR$,1)<>" " THEN RETURN
  29. 305 SR$=RIGHT$(SR$,Q7-1):GOTO 301
  30. 310 Q4=SR:IF CN<>0 THEN 316
  31. 312 SR=INT(SR+.5):GOSUB 300:GOTO 330
  32. 316 Q5=SGN(SR):SR=ABS(SR):Q8=INT(SR):Q9=SR-Q8
  33. 318 FOR Q6=1 TO CN:Q9=Q9*10:NEXT Q6
  34. 320 Q9=INT(Q9+.5):SR=Q9:GOSUB 300
  35. 322 Q9$=RIGHT$("00000000000000000000"+SR$,CN)
  36. 324 IF Q8=0 AND Q9=0 THEN Q5=1
  37. 326 SR=Q8:GOSUB 300:IF Q5=-1 THEN SR$="-"+SR$
  38. 328 SR$=SR$+"."+Q9$
  39. 330 IF LEN(SR$)<=CT THEN 334
  40. 332 SR$=LEFT$("********************",CT):GOTO 340
  41. 334 SR$=RIGHT$("                    "+SR$,CT)
  42. 340 SR=Q4:RETURN
  43. 350 LPRINT SR$;:RETURN
  44. 360 LPRINT:RETURN
  45. 1000 A=1000:GOTO 20:REM STRINGRUIMTE
  46. 1010 GOTO 7000:REM INITIALISATIE
  47. 1100 AW=0:REM AANTAL WOORDEN
  48. 1110 HO=0:VE=4+2*AW
  49. 1120 IF AW<5 THEN 1140
  50. 1130 HO=19:VE=2*AW-6
  51. 1140 GOSUB 110
  52. 1150 SR=AW+1:CT=2:CN=0:GOSUB 310
  53. 1160 PRINT SR$;" ";:ML=9:GOSUB 6100:IF A$=""THEN 1220
  54. 1170 GOSUB 2000:IF AW<10 THEN 1110
  55. 1180 GOSUB 4800
  56. 1190 HO=0:VE=22:GOSUB 110
  57. 1200 PRINT"Met <RETURN> start het sorteren...  ";
  58. 1210 GOSUB 210:IF ASC(IN$)<>13 THEN 1210
  59. 1220 IF AW=0 THEN 7040
  60. 1230 GOSUB 2600:REM OVERZICHT
  61. 1240 GOSUB 2300:REM SNELSORTEER
  62. 1250 HO=29:FOR I=1 TO AW
  63. 1260 VE=2*I+1:GOSUB 110:PRINT S$(I):NEXT I
  64. 1270 HO=0:VE=22:GOSUB 110
  65. 1280 PRINT"Wilt U dat nu wat langzamer zien ? ";:GOSUB 6400
  66. 1290 IF Y=0 THEN 1350
  67. 1300 IF Y<0 THEN 1270
  68. 1310 GOSUB 2600:REM OVERZICHT
  69. 1320 GOSUB 3100:REM OPSCHUIVEN
  70. 1330 GOSUB 3300:REM TRAAGSORTEER
  71. 1340 GOSUB 5400:REM SPATIE
  72. 1350 END
  73. 1360 :
  74. 2000 REM SUBR CONTROLEER  WOORD  A$
  75. 2010 LE=0
  76. 2020 FOR VK=1 TO LEN(A$)
  77. 2030 VB=ASC(MID$(A$,VK,1))
  78. 2040 IF VB>64 AND VB<91 THEN 2070
  79. 2050 IF VB>64+HL AND VB<91+HL THEN 2070
  80. 2060 LE=1
  81. 2070 NEXT VK
  82. 2080 IF LE=0 THEN 2110
  83. 2090 OE$="Woord bevat niet alleen maar letters !"
  84. 2100 GOSUB 5000:GOTO 2120
  85. 2110 AW=AW+1:WO$(AW)=A$
  86. 2120 RETURN
  87. 2130 :
  88. 2300 REM SUBR SNELSORTEER
  89. 2310 GOSUB 2800
  90. 2320 IF AW=1 THEN 2400
  91. 2330 FOR I=1 TO AW-1
  92. 2340 FOR J=I+1 TO AW
  93. 2350 IF W$(I)<=W$(J)THEN 2380
  94. 2360 FT$=W$(I):W$(I)=W$(J):W$(J)=FT$
  95. 2370 FT$=S$(I):S$(I)=S$(J):S$(J)=FT$
  96. 2380 NEXT J
  97. 2390 NEXT I
  98. 2400 RETURN
  99. 2410 :
  100. 2600 REM SUBR OVERZICHT
  101. 2610 GOSUB 100:PRINT"Ongesorteerd";
  102. 2620 HO=29:VE=0:GOSUB 110:PRINT"Gesorteerd"
  103. 2630 FOR I=1 TO AW
  104. 2640 HO=0:VE=2*I+1:GOSUB 110:PRINT WO$(I)
  105. 2650 NEXT I
  106. 2660 RETURN
  107. 2670 :
  108. 2800 REM SUBR ZET OM IN HOOFDLETTERS
  109. 2810 FOR I=1 TO AW
  110. 2820 :A$=""
  111. 2830 :FOR J=1 TO LEN(WO$(I))
  112. 2840 ::B=ASC(MID$(WO$(I),J,1))
  113. 2850 ::IF B<96 THEN B=B+HL
  114. 2860 ::A$=A$+CHR$(B)
  115. 2870 :NEXT J
  116. 2880 :W$(I)=A$
  117. 2890 :S$(I)=WO$(I)
  118. 2900 NEXT I
  119. 2910 RETURN
  120. 2920 :
  121. 3100 REM SUBROUTINE SHIFT
  122. 3110 :
  123. 3120 FOR I=1 TO 29:HO=I-1
  124. 3130 :FOR J=1 TO AW
  125. 3140 ::VE=2*J+1:GOSUB 110
  126. 3150 ::PRINT MID$(WO$(J)+LEFT$(LE$,29),I,1);WO$(J)
  127. 3160 :NEXT J
  128. 3170 NEXT I
  129. 3180 RETURN
  130. 3190 :
  131. 3300 REM SUBR TRAAGSORTEER
  132. 3310 :
  133. 3320 GOSUB 2800
  134. 3330 IF AW=1 THEN RETURN
  135. 3340 FOR X=1 TO AW-1
  136. 3350 :B=X
  137. 3360 :FOR Y=X+1 TO AW
  138. 3370 ::IF W$(B)>W$(Y)THEN B=Y
  139. 3380 :NEXT Y
  140. 3390 :IF B>X THEN GOSUB 3600
  141. 3400 NEXT X
  142. 3410 RETURN
  143. 3420 :
  144. 3600 REM SUBR VERWISSEL  X EN  B
  145. 3610 :
  146. 3620 IR=2*X+1:JR=2*B+1
  147. 3630 JC=28-LEN(S$(B))
  148. 3640 IC=JC-LEN(S$(X))-1
  149. 3650 IF X+1=B THEN IC=29
  150. 3660 REM-- SCHUIF S$(B) ERUIT --
  151. 3670 FOR HO=29 TO JC STEP-1
  152. 3680 GOSUB 4200
  153. 3690 VE=JR:GOSUB 110:PRINT S$(B);" "
  154. 3700 NEXT HO
  155. 3710 REM-- SCHUIF S$(X) ERUIT --
  156. 3720 IF IC>28 THEN 3770
  157. 3730 FOR HO=29 TO IC STEP-1
  158. 3740 GOSUB 4200
  159. 3750 VE=IR:GOSUB 110:PRINT S$(X);" "
  160. 3760 NEXT HO
  161. 3770 REM SCHUIF W$(B) OP, W$(X) NEER
  162. 3780 HO=JC:FOR SK=JR TO IR+1 STEP-1
  163. 3790 GOSUB 4200
  164. 3800 VE=SK:GOSUB 110:PRINT LEFT$(LE$,LEN(S$(B)))
  165. 3810 VE=SK-1:GOSUB 110:PRINT S$(B)
  166. 3820 NEXT SK
  167. 3830 HO=IC:FOR SK=IR TO JR-1
  168. 3840 GOSUB 4200
  169. 3850 VE=SK:GOSUB 110:PRINT LEFT$(LE$,LEN(S$(X)))
  170. 3860 VE=SK+1:GOSUB 110:PRINT S$(X):NEXT SK
  171. 3870 REM SCHUIF STRINGS TERUG
  172. 3880 FOR HO=JC TO 28
  173. 3890 GOSUB 4200
  174. 3900 VE=IR:GOSUB 110:PRINT" ";S$(B)
  175. 3910 NEXT HO
  176. 3920 IF IC>28 THEN 3970
  177. 3930 FOR HO=IC TO 28
  178. 3940 GOSUB 4200
  179. 3950 VE=JR:GOSUB 110:PRINT" ";S$(X)
  180. 3960 NEXT HO
  181. 3970 T$=W$(X):W$(X)=W$(B):W$(B)=T$
  182. 3980 T$=S$(X):S$(X)=S$(B):S$(B)=T$
  183. 3990 OX=1:GOSUB 5200
  184. 4000 RETURN
  185. 4010 :
  186. 4200 REM SUBR PAUZE
  187. 4210 :
  188. 4220 OX=.1:GOSUB 5200
  189. 4230 RETURN
  190. 4240 :
  191. 4400 REM SUBR HEADER
  192. 4410 :
  193. 4420 GOSUB 100:HO=10:VE=1:GOSUB 110
  194. 4430 PRINT"ALFABETISCH SORTEREN"
  195. 4435 HO=10:VE=2:GOSUB 110
  196. 4440 PRINT"--------------------"
  197. 4450 RETURN
  198. 4460 :
  199. 4600 REM SUBR INSTRUCTIES
  200. 4610 :
  201. 4620 HO=0:VE=19:GOSUB 110
  202. 4630 PRINT"Druk op RETURN na elk ingevoerd woord"
  203. 4640 PRINT:PRINT"Druk weer op RETURN voor het sorteren."
  204. 4650 RETURN
  205. 4660 :
  206. 4800 REM SUBR WIS ONDERSTE REGELS
  207. 4810 :
  208. 4820 HO=0:FOR VE=19 TO 23
  209. 4830 GOSUB 110:PRINT LE$;
  210. 4840 NEXT VE
  211. 4850 RETURN
  212. 4860 :
  213. 5000 REM SUBR FOUTMELDING OE$
  214. 5010 :
  215. 5020 GOSUB 4800:REM WIS ONDERSTE REGELS
  216. 5030 HO=19-LEN(OE$)/2:VE=20:GOSUB 110:PRINT OE$
  217. 5040 GOSUB 5400:REM SPATIE
  218. 5050 GOSUB 4800:REM WIS ONDERSTE REGELS
  219. 5060 GOSUB 4600:REM INSTRUCTIES
  220. 5070 RETURN
  221. 5080 :
  222. 5200 REM PROC WACHT OX SECONDEN
  223. 5210 :
  224. 5220 FOR OZ=1 TO 100*OX:NEXT
  225. 5230 RETURN
  226. 5240 :
  227. 5400 REM SUBR SPATIE
  228. 5410 :
  229. 5420 HO=2:VE=23:GOSUB 110
  230. 5430 PRINT"Druk op de SPATIEBALK voor vervolg";:GOSUB 5800
  231. 5440 GOSUB 210:IF IN$<>" "THEN 5440
  232. 5450 RETURN
  233. 5460 :
  234. 5600 REM SUBR TITELPAGINA
  235. 5610 :
  236. 5620 GOSUB 100:HO=14:VE=8:GOSUB 110
  237. 5630 PRINT"ALFABETISCH"
  238. 5640 HO=16:VE=11:GOSUB 110
  239. 5650 PRINT"SORTEREN"
  240. 5660 FOR HO=1 TO 1000:GOSUB 200:IF IN$<>""THEN HO=1000
  241. 5670 NEXT HO
  242. 5680 RETURN
  243. 5690 :
  244. 5800 REM SUBR BUFFER LEEGMAKEN
  245. 5810 :
  246. 5820 GOSUB 200:IF IN$<>""THEN 5820
  247. 5830 RETURN
  248. 5840 :
  249. 6100 REM SUBR INVOER VAN EEN STRING
  250. 6110 A$=""
  251. 6120 GOSUB 120:FOR OO=1 TO ML:PRINT" ";:NEXT OO
  252. 6130 GOSUB 110
  253. 6140 GOSUB 5800:REM BUFFER LEGEN
  254. 6150 GOSUB 210:GB=ASC(IN$):IF GB=13 THEN 6260
  255. 6160 IF GB=DL AND A$=""THEN 6150
  256. 6170 IF GB<>DL THEN 6220
  257. 6180 IF LEN(A$)=1 THEN A$="":GOTO 6200
  258. 6190 A$=LEFT$(A$,LEN(A$)-1)
  259. 6200 GOSUB 120:HO=HO-1:GOSUB 110
  260. 6201 PRINT " ";:GOSUB 120:HO=HO-1:GOSUB 110
  261. 6210 GOTO 6140
  262. 6220 IF LEN(A$)=ML OR GB<33 THEN 6250
  263. 6230 IF(GB>127 AND GB<160)THEN 6250
  264. 6240 PRINT IN$;:A$=A$+IN$:GOTO 6150
  265. 6250 GOSUB 250:GOTO 6150
  266. 6260 RETURN
  267. 6270 :
  268. 6400 REM SUBR JA OF NEE
  269. 6410 :
  270. 6420 ML=3:GOSUB 6100
  271. 6430 OB$=LEFT$(A$,1)
  272. 6440 Y=-1
  273. 6450 IF OB$="J"OR OB$="j"THEN Y=1
  274. 6460 IF OB$="N"OR OB$="n"THEN Y=0
  275. 6470 RETURN
  276. 6480 :
  277. 7000 REM INITIALISERING
  278. 7010 DIM WO$(10),W$(10),S$(10)
  279. 7020 LE$="                                       "
  280. 7030 HL=ASC("A")-ASC("a"):IF HL<0 THEN HL=-HL
  281. 7040 GOSUB 100
  282. 7050 GOSUB 5600:GOSUB 4400
  283. 7060 HO=0:VE=7:GOSUB 110:
  284. 7070 PRINT"Tik hoogstens tien woorden in,"
  285. 7080 PRINT"elk met maximaal negen letters."
  286. 7090 PRINT:PRINT"Het maakt niet uit of het HOOFDletters"
  287. 7100 PRINT"of kleine letters zijn."
  288. 7110 PRINT:PRINT"Nadat U de woorden hebt ingetikt, zal"
  289. 7120 PRINT"de computer ze sorteren."
  290. 7121 PRINT:PRINT"Tik nu het karakter in wat U gebruikt"
  291. 7122 PRINT"om een karakter te wissen:";:GOSUB 210
  292. 7123 DL=ASC(IN$)
  293. 7130 GOSUB 5400
  294. 7140 GOSUB 4400:GOSUB 4600
  295. 7150 GOTO 1100
  296. 7160 :
  297. 10000 REM"ALPHABETISCH SORTEREN    "
  298. 10010 :
  299. 10020 REM EEN PROGRAMMA VAN :
  300. 10030 REM"    Andrew Chapman       "
  301. 10040 REM           &
  302. 10050 REM"   Jerry Temple-Fry      "
  303. 10060 REM   (NETHERHALL SCHOOL)
  304. 10070 REM           &
  305. 10080 REM"   Richard G Warner      "
  306. 10090 :
  307. 10100 REM OORSPRONKELIJK GESCHREVEN
  308. 10110 REM        VOOR DE
  309. 10120 REM"BBC model A microcomputer"
  310. 10130 :
  311. 10140 REM VERTAALD NAAR
  312. 10150 REM 'EENVOUDIG' BASIC
  313. 10160 REM EN GESCHIKT GEMAAKT VOOR
  314. 10170 REM"BASICODE-2      door:    "
  315. 10190 REM"       J. Haubrich       "
  316. 10200 REM  DECEMBER 1982
  317. N GESCHIKT GEMAAKT VOOR
  318. 10170 REM"BASICODE-2      door:    "
  319. 10190 REM"       J. Haubrich       "
  320. 10