External sort compo?

[Antoni Gual]

My entry for the QB4.5
Same idea, here we skip the reformatting steps, as it is a binary file, and we have only 4 passes of radix sort.

Code:

'Antoni's entry for the QB4.5 category
'QBN Forums External Sort Challenge 5 -2006
'---------------------------------------------
DEFINT A-Z
DECLARE SUB putform (digit%)
DECLARE SUB radix (i%, max%)
DECLARE SUB tallysmall (max%, i%)
DECLARE SUB tallybig (max%)
DECLARE SUB putunf (max%)
DECLARE SUB putstraight (max%)
DECLARE SUB acumbig ()
DECLARE FUNCTION getunf% ()
DECLARE FUNCTION getform% ()

'Qbasic external sort compo entry by Antoni Gual
'uses radix sort

CLEAR
t! = TIMER
'KILL "output.dat"
'data buffers
CONST regsize = 4
CONST passes = 3
CONST numkeys = 255
CONST maxi = 16382
REDIM SHARED s1(maxi) AS LONG
REDIM SHARED s2(maxi) AS LONG

'mem tallies
DIM SHARED c(numkeys)  AS INTEGER
DIM SHARED d(numkeys) AS INTEGER

'file tallies
DIM SHARED cd(numkeys, passes) AS LONG

f1$ = "temp1.dat"
f2$ = "temp2.dat"

'reformat data to right-aligned
OPEN "unsortqb.dat" FOR binary  AS #1
PRINT "Sorting a file of "; LOF(1)\regsize; " records"

'OPEN f1$ FOR binary AS #2

'poke is used to avoid the horrible asc(mid$(a$,i,1))
DEF SEG = VARSEG(s1(0))

'preformat and tally the file offsets

do
     f1 = getform
     tallybig (f1)
     'putstraight (f1)
loop until eof(1)
acumbig
CLOSE
PRINT TIMER - t!
'END

'radix sort
FOR i = 0 TO passes
  if i=0 then
    OPEN "unsortqb.dat" FOR binary  AS #1
  else
      OPEN f1$ FOR binary ACCESS READ AS #1
  end if
    OPEN f2$ FOR binary ACCESS WRITE AS #2
    WHILE NOT EOF(1)
        f1 = getform
        tallysmall f1, i
        radix i, f1
        putform (i)
    WEND
    CLOSE
    PRINT "pass "; i+1; " of 4 "; TIMER - t!
    'END
    SWAP f1$, f2$
NEXT

'format back
NAME f1$ AS "sort.dat"
kill f2$
PRINT : PRINT "File sorted in "; TIMER - t!; "seconds"
SYSTEM

'-------------------------------------------------
SUB acumbig
FOR i = 0 TO passes
i1& = 0
    FOR j = 0 TO numkeys
        i2& = cd(j, i): cd(j, i) = i1&*regsize+1: i1& = i1& + i2&
    NEXT
NEXT
END SUB

'--------------------------------------------
FUNCTION getform
        FOR j = 0 TO maxi
            GET #1,,s1(j)
            IF EOF(1) THEN EXIT FOR
        NEXT
        IF j =< maxi THEN getform = j-1 ELSE getform = maxi
END FUNCTION

'---------------------------------------------
SUB putform (digit)
'copy 10 mem buffers to 10 offsets of temp file
FOR i = 0 TO numkeys
    SEEK #2, cd(i, digit)
    FOR k = d(i) TO c(i) - 1
      PUT #2,,s2(k)
    NEXT
    cd(i, digit)=SEEK(2)
NEXT
END SUB

'----------------------------------------------
SUB putstraight (max)
'copy buffer to disk
FOR k = 0 TO max
     PUT #2,,s1(k)
NEXT
END SUB

'------------------------------------------------
SUB radix (digit, max)
offs& = VARPTR(s1(0)) + digit
FOR j = 0 TO max
    t = PEEK(offs&)
    s2(c(t)) = s1(j)
    c(t) = c(t) + 1
    offs& = offs& + regsize
NEXT
END SUB

'--------------------------------------------------
SUB tallybig (max)
offs& = VARPTR(s1(0))
FOR j = 0 TO max
     FOR k = 0 TO passes
         t = PEEK(offs& + k)
         cd(t, k) = cd(t, k) + 1
     NEXT
     offs& = offs& + regsize
NEXT
END SUB

'--------------------------------------------------
SUB tallysmall (max, digit)
offs& = VARPTR(s1(0)) + digit
ERASE c
FOR j = 0 TO max
         t = PEEK(offs&)
         c(t) = c(t) + 1
         offs& = offs& + regsize
NEXT
i1 = 0
FOR j = 0 TO numkeys
        i2 = c(j): c(j) = i1: d(j) = i1: i1 = i1 + i2
NEXT
END SUB