Record qualifiers are customizable.
Your 'one-pass' rule wasn't adhered to.
Feel free to test and tangle, and please feedback.
Code:
' ***
'-- Moneo's Sorting Challenge.
'-- Explore under QB IDE.
' ***
'-- by ToohTooh, in Istanbul City.
DEFINT A-Z
DECLARE FUNCTION Sort (Record$(), Query() AS ANY, RecLimit, QualifLimit, QryLimit)
CONST NAM = 0, SURNAME = 1, AGE = 2 '>> Record qualifiers
CONST ASCENDING = 0, DESCENDING = 1 '>> Sorting methods
TYPE queryTAG '>> Further info in Sort().
priority AS INTEGER
method AS INTEGER
END TYPE
DIM qry(1) AS queryTAG
'-- Construct a sorting query structure.
qry(0).priority = NAM '>> First, sort NAM field ASCENDING,
qry(0).method = ASCENDING
qry(1).priority = SURNAME '>> ...then, in the case of same NAMs,
qry(1).method = DESCENDING ' go and sort the AGE field DESCENDING.
'-- You may extend qry() further as number of qualifier strings permit.
'-- Further rec() structure info in Sort().
DIM rec$(9, 2) '>> rec$( i, z : z={NAM, SURNAME, AGE} )
'-- Build a fictitious kindergarten list (some are too old!).
' The only odd thing about this structure is that everything is STRING.
rec$(0, NAM) = "KEREM": rec$(0, SURNAME) = "BERKERLER": rec$(0, AGE) = "2"
rec$(1, NAM) = "GONEN": rec$(1, SURNAME) = "GENC": rec$(1, AGE) = "5"
rec$(2, NAM) = "AKGUN": rec$(2, SURNAME) = "AKOVA": rec$(2, AGE) = "7"
rec$(3, NAM) = "CAN": rec$(3, SURNAME) = "TURKER": rec$(3, AGE) = "6"
rec$(4, NAM) = "SARP": rec$(4, SURNAME) = "TAN": rec$(4, AGE) = "3"
rec$(5, NAM) = "KEREM": rec$(5, SURNAME) = "AYAN": rec$(5, AGE) = "5"
rec$(6, NAM) = "BERK": rec$(6, SURNAME) = "SARI": rec$(6, AGE) = "2"
rec$(7, NAM) = "CAN": rec$(7, SURNAME) = "ALP": rec$(7, AGE) = "6"
rec$(8, NAM) = "TUNA": rec$(8, SURNAME) = "KON": rec$(8, AGE) = "4"
rec$(9, NAM) = "CAN": rec$(9, SURNAME) = "YENI": rec$(9, AGE) = "4"
result = Sort(rec$(), qry(), UBOUND(rec$), UBOUND(rec$, 2), UBOUND(qry))
CLS
FOR i = 0 TO 9
PRINT rec$(i, NAM), rec$(i, SURNAME), rec$(i, AGE)
NEXT i
FUNCTION Sort (Record$(), Query() AS queryTAG, RecLimit, QualifLimit, QryLimit)
'-- Based on the simple bubble sort of Microsoft Corporation.
' For the original version, see the BubbleSort() of SORTDEMO.bas.
'-- Heavily modified by ToohTooh for the challenge.
'-- Definitions and examples --
'-- Record$(r, q) is an array which has *two* subscripts:
' r: record index
' q: qualifier depth index.
' DIM Record$(9, 2) tells us that "there will be 10 (0..9) elements which
' all have 3 (0..2) different qualifiers."
'-- Query(i) is a type which has *two* fields: query(i).priority, and
' query(i).method.
' Query(0).priority = MARK -+ First, sort students descending by
' Query(0).method = DESCENDING |_ their MARKs. If some happen to get
' Query(1).priority = AGE | the same marks, then sort those
' Query(1).method = ASCENDING -+ ascending by their AGEs.
' LOGIC: If some older and younger
' students get the same mark, younger
' ones are said to be more successful.
DO
Switch = 0
FOR currentRec = 0 TO (RecLimit - 1)
'--Modification begins
FOR nestQuery = 0 TO QryLimit
priorityField = Query(nestQuery).priority
element$ = Record$(currentRec, priorityField)
successor$ = Record$(currentRec + 1, priorityField)
'-- If two adjacent elements are equal, then continue FOR..NEXT to
' deepen the nestQuery to sort them using a different qualifier.
IF (element$ = successor$) THEN GOTO Continue
'-- First switch to the appropriate sorting logic, and then see if
' a sorting is to be done. Do so, if necessary.
SELECT CASE Query(nestQuery).method
CASE ASCENDING
IF element$ > successor$ THEN
GOSUB DoSwap
Switch = currentRec
END IF
CASE DESCENDING
IF element$ < successor$ THEN
GOSUB DoSwap
Switch = currentRec
END IF
END SELECT
'-- Sorting was either done, or was not necessary.
' Done with the current query pass.
EXIT FOR '>> ...to enter currentRec
Continue:
NEXT nestQuery
'--Modification ends
NEXT currentRec
'-- Sort on next pass only to where the last switch was made.
RecLimit = Switch
LOOP WHILE Switch
Sort = -1 '>> Sort() default.
EXIT FUNCTION
DoSwap: '>> Added to Microsoft code by ToohTooh.
FOR i = 0 TO QualifLimit
'-- Swap all fields of record$.
SWAP Record$(currentRec, i), Record$(currentRec + 1, i)
NEXT
RETURN
END FUNCTION '>> Sort()