Code: Select all
Type Pairings
Pair1 AS UShort
Pair2 AS UShort
END TYPE
DIM iTotalTeams AS UShort
DIM iTotalRounds AS UShort
DIM arPairings() AS Pairings
DIM lEvenTeams AS Boolean
DIM arTeams() AS UShort
DIM iTeam AS UShort
DIM iRound AS UShort
DIM iIndex AS UShort
DIM iHalfTeams AS UShort
DIM uPairings AS Pairings
DIM iPairings AS UShort = 0
DIM iByeTeam AS UShort = 0
iTotalTeams = 12 ' Set to the number of contestants/teams
ERASE arPairings
iTotalRounds = 0
' Three individuals/teams minimum required
If iTotalTeams > 2 THEN
' If total teams is odd, add 1 to make it an even number
lEvenTeams = IIF(iTOtalTeams MOD 2 = 0,True,False)
iTotalTeams = iTotalTeams + IIF(lEvenTeams = True,0,1)
' Total rounds is one less than the number of teams
iTotalRounds = iTotalTeams - 1
' Array offset where second group starts
iHalfTeams = iTotalTeams / 2
' If odd number of teams, randomly pick one to be the phantom bye
If lEvenTeams = False THEN
Randomize ,5
iByeTeam = (INT(1 + Rnd * 100000000) MOD iTotalTeams) + 1
END IF
' Allocate array sizes
REDIM arTeams(0 to iTotalTeams - 1)
REDIM arPairings(0 to ((iTotalRounds * iTotalTeams) / 2) - 1)
' Load Team/Individual ID's
For iIndex = 0 to iHalfTeams - 1
arTeams(iIndex) = iIndex + 1
NEXT iIndex
' Reverse second half Team/Individual ID's
iIndex = iHalfTeams
FOR iTeam = iTotalTeams to iHalfTeams + 1 Step -1
arTeams(iIndex) = iTeam
iIndex = iIndex + 1
NEXT iTeam
' Start the rounds
for iRound = 0 to iTotalRounds - 1
FOR iTeam = 0 to iHalfTeams - 1
' Build the pairing from first and second groups
uPairings.Pair1 = arTeams(iTeam)
uPairings.Pair2 = arTeams(iHalfTeams + iTeam)
' Check for possible bye. When found, set Pair1 = Pair2 to identify
If uPairings.Pair1 = iByeTeam THEN
uPairings.Pair1 = uPairings.Pair2
ELSE
if uPairings.Pair2 = iByeTeam THEN
uPairings.Pair2 = uPairings.Pair1
END IF
END IF
arPairings(iPairings) = uPairings
iPairings = iPairings + 1
NEXT iTeam
' Rotate teams - index 0 is fixed
' Swap index 0 with first ID of second group
SWAP arTeams(0), arTeams(iHalfTeams)
' Rotate index 0 back to beginning
FOR iIndex = iHalfTeams to 1 Step -1
SWAP arTeams(iIndex), arTeams(iIndex - 1)
NEXT iIndex
' Rotate first ID of second group to end
FOR iIndex = iHalfTeams to iTotalTeams - 2
SWAP arTeams(iIndex), arTeams(iIndex + 1)
NEXT iIndex
NEXT iRound
END IF
' Show pairings results
FOR iRound = 1 to iTotalRounds
print ""
print "Round " + str(iRound)
print ""
FOR iTeam = 0 to iHalfTeams - 1
print str(arPairings(iRound * iHalfTeams - iHalfTeams + iTeam).Pair1) + _
IIF(arPairings(iRound * iHalfTeams - iHalfTeams + iTeam).Pair1 = _
arPairings(iRound * iHalfTeams - iHalfTeams + iTeam).Pair2, _
"-Bye","v" + str(arPairings(iRound * iHalfTeams - iHalfTeams + iTeam).Pair2))
NEXT iTeam
NEXT iRound
Print "press q to quit"
Do
Sleep 1, 1
Loop Until Inkey = "q"