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