Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
Solved

All posible sequences of 10 playes - URGENT

Posted on 2004-11-01
Medium Priority
236 Views
Hi Experts,
This is probably realy easy but its monday and my heads not working. Here is what i need to achieve;

There are 10 player and they need to play eash other twice in a game of pool hoe can i do a program which randomly selects the payers and makes sure each player has played everyone else?
This needs to be done in VB6 or and Excel spreadsheet.

Regards,

Munzi
0
Question by:munzi79
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

• Help others & share knowledge
• Earn cash & points
• 7
• 6
• 5
• +1

LVL 5

Expert Comment

ID: 12461592
Maybe I am missing something but if everyone has to play everyone else twice what do you need random selection for?

With Excel just draw a grid with Players across top and down the sides.  Knock out the diagonal (player one versus player one, etc.).  Whenever a pair play you tick the relevant crossovers for each.  Two ticks in every square and you're done.

Are you looking to create a play order for the matches randomly (assuming youmonly have one pool table)?

0

Author Comment

ID: 12461981
Sorry RogueSolutions,

Yes, i am looking to create a play order for the matches randomly and yes there is only one pool table.
0

LVL 16

Expert Comment

ID: 12462173
This better not be a school assignment, or I'm in trouble... ;)

Public Players(1 To 10) As String
Public Matches(1 To 90)

Sub Main()

Call PopulatePlayers
Call GenerateMatches
Call OutputMatches("C:\UnshuffledMatches.txt")
Call ShuffleMatches
Call OutputMatches("C:\ShuffledMatches.txt")

End Sub

Sub PopulatePlayers()

Players(1) = "Andy"
Players(2) = "Brian"
Players(3) = "Claire"
Players(4) = "Derek"
Players(5) = "Edward"
Players(6) = "Fred"
Players(7) = "Gerry"
Players(8) = "Hannah"
Players(9) = "Isabel"
Players(10) = "Jim"

End Sub

Sub GenerateMatches()

Match = 0

For Player1 = 1 To 10               'LOOP THROUGH PLAYERS

For Player2 = 1 To 10           'LOOP THROUGH PLAYERS

Match = Match + 1           'INCREMENT MATCHES

If Player2 = Player1 Then Player2 = Player2 + 1
'PLAYER CANNOT PLAY HIMSELF
If Player2 > 10 Then Exit For
'NOT MORE THAN TEN PLAYERS

Matches(Match) = Players(Player1) & " v " & Players(Player2)

Next Player2

Next Player1

End Sub

Sub ShuffleMatches()

For Shuffles = 1 To 10

For Counter = 1 To 90

Randomize Timer

tempStr = Matches(Counter)
tempInt = Int(Rnd * 90) + 1

Matches(Counter) = Matches(tempInt)
Matches(tempInt) = tempStr  'SHUFFLE MATCHES

Next Counter

Next Shuffles

End Sub

Sub OutputMatches(FileName As String)

Open FileName For Output As #1

For Counter = 1 To 90

Print #1, Matches(Counter)

Next Counter

Close #1

End Sub

HTH

J
0

Author Comment

ID: 12462274
Thanks great J,
But i need the to schedule the results in fixtures i.e
Fixture 1
player 1 vs player 2
player3 vs player 4
player 5 vs player 6
player 7 vs player 8
player 9 vs player 10

Fixture 2
player 1 vs player 3
player 2 vs player 4
player 5 vs player 7
player 6 vs player 10
player 9 vs player 8

fixture 3
etc......

Regars,

Munzi
0

LVL 16

Expert Comment

ID: 12462329
The quickest way is to say each fixture consists of 5 random matches, changing OutputMatches as follows:

Sub OutputMatches(FileName As String)

Fixture = 0

Open FileName For Output As #1

For Counter = 1 To 90

If (Counter - 1) / 5 = (Counter - 1) \ 5 Then
Fixture = Fixture + 1
Print #1, vbCrLf & "Fixture " & Fixture
End If

Print #1, Matches(Counter)

Next Counter

Close #1

End Sub

But if everyone has to play on every day, you'll need something more complicated...

J.
0

Author Comment

ID: 12462469
Thans J,

But unfortunatly i need everyone to play on the same day, my appologies for not making this clear earlier.

Regards,

Munzi
0

LVL 16

Expert Comment

ID: 12462675
Then I don't think random matches are your best solution.  Will try to generate a formula...

J.
0

Author Comment

ID: 12462774
Thans J.....
0

LVL 5

Expert Comment

ID: 12462866

Is this a real life thing?

It's just you have 90 matches to get played on one pool table in one day?

Average game of pool - 10mins maybe longer?

900mins of pool = 15 hours pool!

Still an interesting problem ;)

0

Author Comment

ID: 12462985
ummm thats what i thought when i got told this first ;o)
Yes, its a real life situation,

there is going to be 1 fixture per day and everyone must play in each fixture.....
0

LVL 10

Expert Comment

ID: 12463053
Try this:
Create a new project. Place a list box and a command button: List1 and Command1 respectively. Place the following code in it. Run it and press the button. The code should work with any number of players but I am not certain about the fixture headers if an odd number of players was selected.

The initial array building could be made more efficient - I get 90 matches, then jettison half of them and then double the 45 matches, reversing the latter 45's homes and aways.

Option Explicit
Private Players() As String
Private PlayerNames As String

Private Sub Command1_Click()
Players = Split(PlayerNames, ",")
ShufflePlayers
Play
End Sub

Randomize (Timer)
PlayerNames = "Alice,Bob,Charlie,Dave,Eddie,Freda,George,Harry,Ian,Jack"
End Sub

Private Sub ShufflePlayers()
Dim lPlayers() As String
Dim i As Long
Dim j As Long
Dim r As Long

ReDim lPlayers(UBound(Players))

For i = 0 To UBound(Players)
r = Fix(Rnd * UBound(Players))
Do Until lPlayers(r) = vbNullString
r = IIf(r < UBound(Players), r + 1, 0)
Loop
lPlayers(r) = Players(i)
Next

Players = lPlayers
End Sub

Private Sub Play()
Dim i As Long
Dim j As Long
Dim u As Long
Dim p As Long
Dim m1() As Long
Dim m2() As Long
Dim t As Long
Dim c As Long
Dim c2 As Long
Dim f As Long

List1.Clear

u = UBound(Players)
p = u + 1

ReDim m1(p ^ 2 - (p + 1), 1)

For i = 1 To p
For j = 0 To u
t = IIf(j + i < p, j + i, j + i - p)
If j <> t Then
m1(c, 0) = j
m1(c, 1) = t
c = c + 1

End If
Next
Next

c = p \ 2

For i = 0 To 1
For j = 0 To UBound(m1, 1) Step 2
c = c + 1
If c >= p \ 2 Then
f = f + 1
c = 0
End If
If f And 1 Then
List1.AddItem "     " & Players(m1(j, 0)) & "  v  " & Players(m1(j, 1))
Else
List1.AddItem "     " & Players(m1(j, 1)) & "  v  " & Players(m1(j, 0))
End If
Next
Next

End Sub
0

LVL 10

Expert Comment

ID: 12463083
You don't need c2 or m2 variables in it - delete them. I accidentally left them there when I tried something else.
0

LVL 16

Expert Comment

ID: 12463182
Nope, no joy; I don't have my math hat on today...
0

LVL 10

Expert Comment

ID: 12463450
Well I've just tested my solution. It keels over (expectedly) if you give it one name or no names.Otherwise it appears to work for any number of names at least up to 40 (158 fixtures of 20 matches each). If you give it an odd number, one person sits out each of the fixtures.
0

LVL 10

Expert Comment

ID: 12464201
Well I tested it again. I was wrong - how embarassing. It's close but not quite. I'll have to work out that first bit properly.
0

Author Comment

ID: 12471231
fds_fatboy,

Thanks for trying...i have tested it wih four players and it does not seem to work, as you have alreay mentioned....any ideas?

J.....have you got your maths hat on today?

Regards,

Munzi
0

LVL 16

Expert Comment

ID: 12473267
No, I can get it so far, using bitwise logic and it will generate 90 matches, where everyone plays everyone twice but I can't get it to do it so that everyone plays on the same day.

J.
0

LVL 5

Expert Comment

ID: 12473870
I tried a brute force approach and I think it 'should' work.  Basically it will create a random Fixture of 5 matches but then reject it if anyone has played before.  Since you want two matches per 'couple' the theory works OK since P1 vs P2 is one match and P2 vs P1 is the other.

Unfortunately I doubt it could ever solve it fully since the probability keeps getting harder!

Am trying to think how to cross breed this approach with an ordered selection but ...

Start a blank Excel workbook, add a module and paste the code.  It will work with the activesheet (and it will blank it!)

The progress (fixtures found) is shown on the statusbar

Public Sub Matches()

Dim iL      As Integer
Dim iR1     As Integer
Dim iR2     As Integer
Dim bP(10)  As Boolean
Dim iRow    As Integer
Dim iBack   As Integer
Dim bSame   As Boolean

Application.ScreenUpdating = False

ActiveSheet.Cells.ClearContents

iRow = 1
While iRow <= 90

For iL = 1 To 5

iR1 = Int(10 * Rnd + 1)
While bP(iR1)
iR1 = Int(10 * Rnd + 1)
Wend
bP(iR1) = True

iR2 = Int(10 * Rnd + 1)
While bP(iR2) Or iR1 = iR2
iR2 = Int(10 * Rnd + 1)
Wend
bP(iR2) = True

ActiveSheet.Cells(iRow, iL).Value = iR1 & " vs " & iR2

Next

With ActiveSheet.Range(ActiveSheet.Cells(iRow, 1), ActiveSheet.Cells(iRow, 2))

If iRow > 1 Then

For iBack = iRow - 1 To 1 Step -1
bSame = False
For iL = 1 To 5
If Application.WorksheetFunction.CountIf(ActiveSheet.Range("A1:E100"), ActiveSheet.Cells(iRow, iL).Value) > 1 Then
bSame = True
Exit For
End If
Next
If bSame Then
.ClearContents
iRow = iRow - 1
Exit For
End If
Next

End If

End With

For iL = 1 To 10
bP(iL) = False
Next

iRow = iRow + 1
Application.StatusBar = iRow

Wend

Application.ScreenUpdating = True

End Sub

0

LVL 16

Assisted Solution

jimbobmcgee earned 300 total points
ID: 12474672
I've got a brute-force method that definately works; it just keeps generating files until it gets it right (usually in less than 500 attempts -- its quite quick really)

It's based on the bitwise thing I was trying earlier.  The problem I was having was that the logic was able to make sure that a player did not have two matches in the same fixture, but it couldn't force it to create fixtures where everybody played.

It's all to do with the order in which the match list is passed to the sorting function; only certain orders work.  So I created a brute force system, with a randomizer, that just keeps going until it hits a suitable sequence.

It should work for any array of players, even or odd, but gets a bit slow around the 20-mark.  You might have to start it off, go away and come back, as the more players used, the longer it will take.

Here goes:

Public Type FixtureType
Name        As String
Value       As Long
DeleteMe    As Boolean
End Type

Public Players()        As FixtureType
Public Matches()        As FixtureType
Public SavedMatches()   As FixtureType

Public Everyone         As Long
Public DebugCount       As Long
Public TargetFixtures   As Long
Public ActualFixtures   As Long

Private Sub GetPlayerNames()

ReDim Players(1 To 10) As FixtureType   'NOTE: MANUALLY SET UP PLAYER ARRAY
'      WITH THE RIGHT SIZE!!
Players(1).Name = "Andy"
Players(2).Name = "Brian"
Players(3).Name = "Claire"
Players(4).Name = "Derek"
Players(5).Name = "Edward"
Players(6).Name = "Fred"
Players(7).Name = "Gerry"
Players(8).Name = "Hannah"
Players(9).Name = "Isabel"
Players(10).Name = "Jim"

End Sub

Private Sub AssignPlayerValues()

'CREATE BITWISE VALUES FOR EACH PLAYER
'   E.G.    1000000000 FOR PLAYER 1 = &H200 = 512
'           0000000001 FOR PLAYER 2 = &H100 = 256
'           0100000000 FOR PLAYER 3 = &H80  = 128
'           0000000010 FOR PLAYER 4 = &H40  = 64
'           ETC

Everyone = 0

For i = LBound(Players()) To UBound(Players())

Players(i).Value = 2 ^ (((UBound(Players()) + 1) - i) - 1)
Everyone = Everyone + Players(i).Value

Next i

End Sub

Private Sub GenerateMatches()

'USE LOGICAL OR TO CREATE A NUMBER FOR EACH MATCH, BASED ON THE
'VALUES FOR EACH PLAYER PLAYING
'   E.G.    PLAYER 1 v PLAYER 2 = 1100000000 = &H300 = 768
'           PLAYER 3 v PLAYER 4 = 0011000000 = &HC0  = 192
'           PLAYER 2 v PLAYER 1 = 1100000000 = &H300 = 768

Dim MatchCount As Long

MatchCount = 0
For Plr1 = LBound(Players()) To UBound(Players())
For Plr2 = LBound(Players()) To UBound(Players())
If Plr2 = Plr1 Then Plr2 = Plr2 + 1
If Plr2 > UBound(Players()) Then Exit For
MatchCount = MatchCount + 1
Next Plr2
Next Plr1

ReDim SavedMatches(1 To MatchCount) As FixtureType

MatchCount = 0
For Plr1 = LBound(Players()) To UBound(Players())
For Plr2 = LBound(Players()) To UBound(Players())

If Plr2 = Plr1 Then Plr2 = Plr2 + 1
If Plr2 > UBound(Players()) Then Exit For
MatchCount = MatchCount + 1

SavedMatches(MatchCount).Name = Players(Plr1).Name & " v " & Players(Plr2).Name
SavedMatches(MatchCount).Value = Players(Plr1).Value Or Players(Plr2).Value
SavedMatches(MatchCount).DeleteMe = False

Next Plr2
Next Plr1

TargetFixtures = (UBound(SavedMatches()) / (UBound(Players()) / 2)) + _
(2 * Abs(CInt(Not (UBound(Players()) \ 2) = (UBound(Players()) / 2))))

End Sub

Private Sub ShuffleMatches()

'RANDOMIZER AND SHUFFLER, FOR BRUTE FORCE METHOD

Dim tmpMatch As FixtureType

For Counter = 1 To UBound(Matches())

Randomize Timer

tmpMatch.Name = Matches(Counter).Name
tmpMatch.Value = Matches(Counter).Value
tmpMatch.DeleteMe = Matches(Counter).DeleteMe

tempInt = Int(Rnd * UBound(Matches())) + 1

Matches(Counter).Name = Matches(tempInt).Name
Matches(Counter).Value = Matches(tempInt).Value
Matches(Counter).DeleteMe = Matches(tempInt).DeleteMe

Matches(tempInt).Name = tmpMatch.Name
Matches(tempInt).Value = tmpMatch.Value
Matches(tempInt).DeleteMe = tmpMatch.DeleteMe
'SHUFFLE MATCHES

Next Counter

End Sub

Private Sub SortMatches(FileName As String)

'RUN THROUGH MATCHES ASSIGNING TO FIXTURE, OUTPUTTING TO FILENAME

Dim Fixtures    As Long
Dim Count       As Long

ActualFixtures = 1
Count = 0

Open FileName For Output As #1

Do Until UpdateMatchList = 0

Print #1, "Fixture " & ActualFixtures

For i = LBound(Matches()) To UBound(Matches())
Matches(i).DeleteMe = False
Next i

For i = LBound(Matches()) To UBound(Matches())

If MatchMask = Everyone Then Exit For

If (Matches(i).Value And MatchMask) = 0 Then

Matches(i).DeleteMe = True

Print #1, Matches(i).Name & vbTab & _
Matches(i).Value & vbTab & _

For z = UBound(Players()) To LBound(Players()) Step -1
Print #1, CStr(Abs(CInt((MatchMask And Players(z).Value) <> 0)));
Next z
Print #1, ""

Count = Count + 1

End If

Next i

ActualFixtures = ActualFixtures + 1
Print #1, ""

Loop

Print #1, vbCrLf & "Matches: " & Count

Close #1

End Sub

Private Function UpdateMatchList() As Long

'REMOVE ASSIGNED MATCHES FROM MATCH LIST, SO THEY CANNOT BE USED AGAIN

Dim tmpMatches() As FixtureType
Dim MatchCount As Long
tmpMatches() = Matches()

MatchCount = 0

For i = LBound(tmpMatches()) To UBound(tmpMatches())
If tmpMatches(i).DeleteMe = False Then MatchCount = MatchCount + 1
Next i

UpdateMatchList = MatchCount
If MatchCount = 0 Then Exit Function

ReDim Matches(1 To MatchCount) As FixtureType

MatchCount = 0
For i = LBound(tmpMatches()) To UBound(tmpMatches())
If tmpMatches(i).DeleteMe = False Then
MatchCount = MatchCount + 1
Matches(MatchCount).Name = tmpMatches(i).Name
Matches(MatchCount).Value = tmpMatches(i).Value
Matches(MatchCount).DeleteMe = False
End If
Next i

Call ShuffleMatches

End Function

Private Sub Main()

Attempts = 0            'RESET ATTEMPTS COUNTER
ActualFixtures = 0      'RESET FIXTURES COUNT

Call GetPlayerNames
Call AssignPlayerValues
Call GenerateMatches

Debug.Print "Target Fixtures: " & TargetFixtures

Do Until ActualFixtures - 1 = TargetFixtures    'BRUTE FORCE LOOP UNTIL SOLVED

Attempts = Attempts + 1
Debug.Print "Attempt #" & Attempts & ": ";    'SHOW STATUS IN DEBUG WINDOW
Matches() = SavedMatches()       'COPY MATCH LIST TO WORKING LIST, TO SAVE TIME
SortMatches "c:\fixattempts\fixtures." & Format(Attempts, "00000") & ".txt"
'SAVE ATTEMPT TO FILE, BASED ON CURRENT ATTEMPT NUMBER
Debug.Print "Fixtures=" & ActualFixtures - 1  'SHOW STATUS IN DEBUG WINDOW

Loop

MsgBox "Generation completed in " & Attempts & " attempts."     'SHOW RESULTS

End Sub

Good luck!!

HTH

J.
0

LVL 10

Accepted Solution

fds_fatboy earned 450 total points
ID: 12476197
Yes, but look at this:
Not as efficient as it could be (it could be improved) but not all brute force:
Same scenario as before: Form with a list box and command button. It runs with any number over 1 including odds:

Option Explicit
Dim PlayerNames As String
Dim Players() As String
Dim blnOdd As Boolean

Private Sub Command1_Click()
Command1.Enabled = False
ShufflePlayers
Play
Command1.Enabled = True
End Sub

Randomize Timer
PlayerNames = "Alice,Bob,Charlie,Dave,Eddie,Freda,George,Harry,Ian,Jack"

Players = Split(PlayerNames, ",")
If Not UBound(Players) And 1 Then
Players = Split(PlayerNames & ",", ",")
blnOdd = True
End If
End Sub

Private Sub ShufflePlayers()
Dim lPlayers() As String
Dim i As Long
Dim j As Long
Dim r As Long
Dim u As Long

u = UBound(Players) + blnOdd

ReDim lPlayers(UBound(Players))

For i = 0 To u
r = Fix(Rnd * u)
Do Until lPlayers(r) = vbNullString
r = IIf(r < u, r + 1, 0)
Loop
lPlayers(r) = Players(i)
Next

Players = lPlayers
End Sub

Private Sub Play()
Dim i As Long, j As Long, c As Long, t As Long
Dim u As Long, p As Long
Dim m() As Long, pm() As Long
Dim mc As Long
Dim mf As Long, mb As Boolean, mfs As Long
Dim m2() As Long

List1.Clear

u = UBound(Players)
p = u + 1

ReDim m(0 To (p ^ 2 - p) - 1, 2)
ReDim pm(0 To u)

For i = 1 To p
For j = 0 To u Step 2
t = IIf(j + i < p, j + i, j + i - p)
If j <> t Then
m(c, 0) = j
m(c, 1) = t
c = c + 1

End If
Next
For j = 1 To u Step 2
t = IIf(j + i < p, j + i, j + i - p)
If j <> t Then
m(c, 0) = j
m(c, 1) = t
c = c + 1

End If
Next
Next

For i = 0 To 2 * u - 1
DoEvents
List1.AddItem "Fixture " & i + 1
mf = -1

Do
DoEvents
mc = 0
mb = False

mfs = mf
For j = mfs + 1 To UBound(m)
If mc >= p \ 2 Then
Exit For
End If
If m(j, 2) = 0 And pm(m(j, 0)) <= i And pm(m(j, 1)) <= i Then
If Not mb Then
mb = True
mf = j
End If
m(j, 2) = -1
mc = mc + 1
pm(m(j, 0)) = i + 1
pm(m(j, 1)) = i + 1
End If
Next

For j = 0 To mfs
If mc >= p \ 2 Then
Exit For
End If
If m(j, 2) = 0 And pm(m(j, 0)) <= i And pm(m(j, 1)) <= i Then
If Not mb Then
mf = j
End If
m(j, 2) = -1
mc = mc + 1
pm(m(j, 0)) = i + 1
pm(m(j, 1)) = i + 1
End If
Next

If mc < p \ 2 Then
For j = 0 To UBound(m, 1)
If m(j, 2) = -1 Then
m(j, 2) = 0
pm(m(j, 0)) = i
pm(m(j, 1)) = i
End If
Next
If mf = UBound(m) Then
ShuffleMatches m
End If
End If

Loop Until mc >= p \ 2

If UBound(m, 1) > mc Then
ReDim m2(UBound(m, 1) - mc, 2)
Else
ReDim m2(UBound(m, 1), 2)
End If

c = 0
For j = 0 To UBound(m)
If m(j, 2) = -1 Then
If Not (blnOdd And (m(j, 0) = u Or m(j, 1) = u)) Then
List1.AddItem "     " & Players(m(j, 0)) & "  v  " & Players(m(j, 1))
End If
Else
m2(c, 0) = m(j, 0)
m2(c, 1) = m(j, 1)
m2(c, 2) = 0
c = c + 1
End If
Next
m = m2
Next
End Sub

Private Sub ShuffleMatches(ByRef m1() As Long)
Dim m2() As Long

Dim i As Long
Dim j As Long
Dim r As Long
Dim u As Long

u = UBound(m1, 1)

ReDim m2(u, 2)

For i = 0 To u
r = Fix(Rnd * u)
Do Until (m2(r, 0) Or m2(r, 1)) = 0
r = IIf(r < u, r + 1, 0)
Loop
m2(r, 0) = m1(i, 0)
m2(r, 1) = m1(i, 1)
m2(r, 2) = m1(i, 2)
Next

m1 = m2
End Sub

0

Author Comment

ID: 12484613

Munzi
0

Featured Post

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture. Â  There is also a companion Debug Toolbar that looks like the followinâ€¦
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games. Â  The game allows for a choice of who goes first and keeps track of the number of wins forâ€¦
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). Uâ€¦
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can launâ€¦
Suggested Courses
Course of the Month10 days, 3 hours left to enroll