Sort merge Qbasic program
/*================================================================= */
DECLARE FUNCTION Get.Key$ (t$)
COMMON SHARED s&, oo%
max% = 2000: SWork$ = "Sortwork."
DIM SHARED kkk$(1 TO max%), table$(1 TO max%)
DIM SHARED p%(1 TO max%)
DIM SHARED keys.f%(1 TO 30), keys.t%(1 TO 30), keys.ad$(1 TO 30)
PRINT "SortM _________________________________________________ "
PRINT "SortM - Sort and Merge Program"
PRINT "SortM - Input file or Q to quit"; : INPUT fi$
IF fi$ = "Q" THEN END
ON ERROR GOTO File.not.found
OPEN fi$ FOR INPUT AS 1
ON ERROR GOTO 0
PRINT "SortM - Output file or Q to quit <"; fi$; ">"; : INPUT fo$
IF fo$ = "Q" THEN END
IF fo$ = "" THEN fo$ = fi$: GOTO WD
ON ERROR GOTO File.Out.error
OPEN fo$ FOR OUTPUT AS 2
ON ERROR GOTO 0
CLOSE 2
WD:
WD$ = "e:"
PRINT "SortM - Work disk <"; WD$; ">"; : INPUT x$
IF x$ <> "" THEN WD$ = x$
wdSWork$ = WD$ + SWork$
ON ERROR GOTO WD.error
OPEN wdSWork$ + "1" FOR OUTPUT AS 3
ON ERROR GOTO 0
CLOSE 3
KILL wdSWork$ + "*"
PRINT "SortM - 1...5...10...15...20...25...30...35...40...45...50"
LINE INPUT #1, L$: tl% = LEN(L$)
DO WHILE LEN(L$) > 1
PRINT "SortM -(" + MID$(L$, 1, 50) + ")": L$ = MID$(L$, 51): LOOP
CLOSE 1
oo% = 0: M% = 0: Ct& = 0: kk% = 0: s& = 0: kl% = 0
keys.f%(2) = -1
Get.Key.Loop:
kk% = kk% + 1
y% = keys.f%(kk%): IF kk% = 1 AND y% = 0 THEN y% = 1
PRINT "SortM - key"; kk%; " FROM or -1 if no more <"; y%; ">"; : INPUT x%
IF x% = 0 THEN keys.f%(kk%) = y% ELSE keys.f%(kk%) = x%
IF keys.f%(kk%) = -1 THEN GOTO Open.fi
y% = keys.t%(kk%): IF y% = 0 THEN y% = keys.f%(kk%) + 9
PRINT "SortM - key"; kk%; " TO <"; y%; ">"; : INPUT x%
IF x% = 0 THEN keys.t%(kk%) = y% ELSE keys.t%(kk%) = x%
kl% = kl% + keys.t%(kk%) - keys.f%(kk%) + 1
IF keys.t%(kk%) = 0 THEN PRINT "Error": kk% = kk% - 1: GOTO Get.Key.Loop
ad$ = key.ad$(kk%): IF ad$ = "" THEN ad$ = "A"
PRINT "SortM - key"; kk%; " Ascending or Descending <"; ad$; ">"; : INPUT x$
IF x$ = "" THEN keys.ad$(kk%) = ad$ ELSE keys.ad$(kk%) = UCASE$(MID$(x$, 1, 1))
GOTO Get.Key.Loop
Open.fi:
PRINT
PRINT TIME$; " SortM started"
PRINT TIME$; " File", "Recs", "Tot recs", "Tot swaps"
OPEN fi$ FOR INPUT AS 1
f = FRE("")
Read.in:
IF FRE("") < 1000 THEN GOTO sort
E = EOF(1): IF E = -1 THEN CLOSE 1: GOTO sort
IF (oo% + 1) > max% THEN GOTO sort
oo% = oo% + 1
LINE INPUT #1, table$(oo%): kkk$(oo%) = Get.Key$(table$(oo%))
p%(oo%) = oo%: Ct& = Ct& + 1
GOTO Read.in
sort:
IF oo% < 1 THEN GOTO sort.skip
M% = M% + 1
PRINT TIME$;
FOR L% = 2 TO oo%: I% = L%
DO UNTIL I% = 1: Pa% = I% \ 2
IF kkk$(p%(I%)) <= kkk$(p%(Pa%)) THEN EXIT DO
SWAP p%(Pa%), p%(I%): s& = s& + 1: I% = Pa%
LOOP
NEXT L%
FOR L% = oo% TO 2 STEP -1
SWAP p%(1), p%(L%): s& = s& + 1: Ma% = L% - 1: I% = 1
DO: C% = 2 * I%
IF C% > Ma% THEN EXIT DO
IF C% + 1 <= Ma% THEN IF kkk$(p%(C% + 1)) > kkk$(p%(C%)) THEN C% = C% + 1
IF kkk$(p%(I%)) >= kkk$(p%(C%)) THEN EXIT DO
SWAP p%(I%), p%(C%): s& = s& + 1: I% = C%
LOOP
NEXT L%
PRINT M%, oo%, Ct&, s&: f = FRE("")
OPEN wdSWork$ + MID$(STR$(M%), 2) FOR OUTPUT AS 2
FOR L% = 1 TO oo%: PRINT #2, table$(p%(L%)): table$(p%(L%)) = "": kkk$(L%) = "": NEXT
CLOSE #2
sort.skip:
IF LCASE$(INKEY$) = "q" THEN END
IF E = 0 THEN oo% = 0: GOTO Read.in
PRINT TIME$; " Merging"
mi% = 0
Merge.loop:
mi% = mi% + 1
IF mi% = M% THEN GOTO Finish
OPEN wdSWork$ + MID$(STR$(mi% + 0), 2) FOR INPUT AS 1
OPEN wdSWork$ + MID$(STR$(mi% + 1), 2) FOR INPUT AS 2
OPEN wdSWork$ + MID$(STR$(M% + 1), 2) FOR OUTPUT AS 3
LINE INPUT #1, l1$
PRINT TIME$; mi%; " & "; mi% + 1, " to "; M% + 1
Merge.L2:
IF EOF(2) = -1 THEN ii% = 1: L$ = l1$: GOTO Merge.copy
LINE INPUT #2, l2$
Merge.compare:
IF Get.Key$(l1$) > Get.Key$(l2$) THEN PRINT #3, l2$: GOTO Merge.L2
PRINT #3, l1$: IF EOF(1) = 0 THEN LINE INPUT #1, l1$: GOTO Merge.compare
ii% = 2: L$ = l2$
Merge.copy:
PRINT #3, L$: IF EOF(ii%) = 0 THEN LINE INPUT #ii%, L$: GOTO Merge.copy
Merge.close:
CLOSE 1, 2, 3
KILL wdSWork$ + MID$(STR$(mi% + 0), 2)
KILL wdSWork$ + MID$(STR$(mi% + 1), 2)
mi% = mi% + 1: M% = M% + 1
IF LCASE$(INKEY$) = "q" THEN END
GOTO Merge.loop
Finish:
PRINT TIME$; " Records sorted"; Ct&
PRINT "By Alan Marshall, G.P.O. Box 2937, Darwin, Australia"
OPEN wdSWork$ + MID$(STR$(M%), 2) FOR INPUT AS 1
OPEN fo$ FOR OUTPUT AS 3
DO WHILE EOF(1) <> -1: LINE INPUT #1, L$: PRINT #3, L$: LOOP
CLOSE 1, 3: KILL wdSWork$ + "*": END
File.not.found:
FILES "*.*": PRINT fi$; " not found": END
File.Out.error:
PRINT "Error - Output file name("; fo$; ")": END
WD.error:
PRINT "Error - Can not open file SortMWRK.1 on disk ("; WD$; ")": END
FUNCTION Get.Key$ (t$)
k$ = ""
L% = 1
DO WHILE keys.f%(L%) > 0
w$ = MID$(t$, keys.f%(L%), keys.t%(L%) - keys.f%(L%) + 1)
IF keys.ad$(L%) = "D" THEN
FOR x% = 1 TO LEN(w$)
MID$(w$, x%, 1) = CHR$(255 - ASC(MID$(w$, x%, 1)))
NEXT
END IF
k$ = k$ + w$
L% = L% + 1
LOOP
Get.Key$ = k$
END FUNCTION
/*================================================================= */
Contact marshall_alan@hotmail.com
Recycled Books Shed main page
Recycled Books Shed page 2 - photos, links, other things