Jag håller på med ett script som ska lotta fram ett spelschema. När jag slumpat fram en match kollar jag om den redan finns. Om den finns skulle jag vilja hoppa tillbaka i koden till slumpningen men jag har inte fått det att fungera. Det verkar som det blir en evighetsloop

<code>
sub slumpa2(obj as object, e as eventargs)
dim lag(5)
lag(0) = "Tibro IK"
lag(1) ="Skövde IK"
lag(2) = "Mariestad Bois"
lag(3) ="Skara IK"
lag(4) ="Leksand"
lag(5) = "Hammarby"
dim i as integer = 1
Dim r As New Random()

dim antal as integer = 0
dim antal1 as integer = 0
dim antal2 as integer = 0
dim antal3 as integer = 0
dim antal4 as integer = 0
dim antal5 as integer = 0
dim antal_matcher as integer = 16
dim match(16,2)
dim match1(antal_matcher)
start: do while i < 16

Dim intHome As Integer = -1
Dim intVisitor As Integer = -1
Dim bolEqual As Boolean = True
Do While bolEqual
intHome = r.Next(0,6)
intVisitor = r.Next(0,6)

If intHome <> intVisitor Then
bolEqual = False
End If
Loop
dim m as string = lag(intHome) &"-"& lag(intVisitor)
dim m1 as string = lag(intVisitor) &"-"& lag(intHome)
dim j as integer
Dim d As Integer
Dim g As Integer
dim k as integer
dim q as integer
for k = 0 to i
dim found as boolean = false
for j = 0 to ubound(match1)

if m = match1(j) or m1 = match1(j) then
found = true
goto start
exit for
end if
next
if not found then
dim tal as integer
if i = 1 then
tal = i
elseif i = 2 then
tal = i -1
else
tal = i-2
end if
For d = tal To i
For g = 0 To 1
If lag(intHome) = match(d, g) or lag(intVisitor) = match(d, g) Then
goto start
else

match(i,0) = lag(intHome)
match(i,1) = lag(intVisitor)
match1(i) = lag(intHome)&" - "& lag(intVisitor)

End If
Next g
Next d


end if
next
response.write(i &"&nbsp;"& match1(i) & "<br />")
i=i+1
loop
antal = UBound(Filter(match1,"Tibro IK")) +1
response.write("<br />Tibro IK "& antal &"<br />")
antal1 = UBound(Filter(match1,"Skövde IK")) +1
response.write("Skövde Ik "& antal1 &"<br />")
antal2 = UBound(Filter(match1,"Mariestad Bois")) +1
response.write("Mariestad "& antal2 &"<br />")
antal3 = UBound(Filter(match1,"Skara IK")) +1
response.write("Skara "& antal3 &"<br />")
antal4 = UBound(Filter(match1,"Leksand")) +1
response.write("Leksand "& antal4 &"<br />")
end sub
</code>

Hej.

För att inte behöva gå igenom din kod för att komma underfund med vad du egentligen vill ha ut scriptet och för att det inte ska bli något missförstånd så beskriv i ord mer detaljerat hur du vill att det ska fungera.

Ska alla lag möta alla (Pool spel)?
Hur många gånger ska de mötas?
Om det är flera möten, ska det vara varannan gång som hemmalag och varannan som borta?
etc

//
Janne

Alla lag ska möta varandra en gång. Lagen får inte spela två matcher i rad. Hemma eller borta spelar ingen roll eftersom det är hockeycuper där alla matcher spelas i samma hall.


Om det är någon som har en färdig lösning för att lotta spelprogram får ni gärna visa den.

Jag skulle skriva det anorlunda:
<code>
Sub slumpa2(ByVal obj As Object, ByVal e As EventArgs)
Dim lag(5)
Dim i As Integer
Dim j As Integer
Dim r As New Random()
Dim intHome As Integer
Dim intVisitor As Integer

Dim antal(5) As Integer
Dim antal_matcher As Integer = 16

Dim match(antal_matcher, 2) As Integer
Dim match1(antal_matcher)

lag(0) = "Tibro IK"
lag(1) = "Skövde IK"
lag(2) = "Mariestad Bois"
lag(3) = "Skara IK"
lag(4) = "Leksand"
lag(5) = "Hammarby"
For i = 1 To antal_matcher
Do
intHome = r.Next(0, 6)
Do
intVisitor = r.Next(0, 6)
Loop While intHome = intVisitor
If i > 1 Then
For j = 1 To i - 1
If match(j, 1) = intHome Then
If match(j, 1) = intVisitor Then
Exit For
Else
Exit Do
End If
ElseIf match(j, 1) = intVisitor Then
If match(j, 1) = intHome Then
Exit For
Else
Exit Do
End If
Else
Exit Do
End If
Next
Else
Exit Do
End If
Loop
antal(intHome) += 1
antal(intVisitor) += 1
match(i, 0) = intHome
match(i, 1) = intVisitor
match1(i) = lag(intHome) & " - " & lag(intVisitor)
Response.Write(i & "&nbsp;" & match1(i) & "<br />" & vbCrLf)
Next

For i = 1 To 5
Response.Write("<br />" & lag(i) & " " & antal(i) & "<br />" & vbCrLf)
Next
End Sub
</code>

Det fungerar tyvärr inte som jag vill. samma lag kan fortfarande spela två matcher i rad och lagen spelar inte samma antal matcher

Hej Andreas,

Mitt svar blev längre än vad inläggen får vara verkar det som...jag delar upp det i två bitar :-)

Del I:

Jag har en lösning som fungerar så som du vill, men den har sina brister:

Brist nr 1) Betydligt mer kod än tidigare kodexempel (som förvisso inte fungerade). Går dock garanterat att optimera.

Brist nr 2) Det är svårare att hitta en lösning för 5 lag än för 25 lag p g a att antalet matcher ökar med O(n^2) när antalet lag ökar. Det innebär att det blir så att säga längre och längre avstånd mellan lagens matcher i listan och mindre risk för att de får två matcher i rad i en slumpad spellista. För 5 lag får jag med min algoritm ibland slumpa om flera tusen gånger (tog några sekunder). Med 6 lag några hundra om jag har otur (tog ~1 sekund). 7 lag eller fler så blir det oftast bara ett par försök innan en lösning hittas (tog ingen tid alls). Det tar alltså längre tid att hitta en lösning för 5 lag än en för 25 lag. Kan du leva med det så fungerar nedanstående :-) Observera att det inte finns någon lösning för n<=4 oavsett algoritm...

Brist nr 3) Jag kodade min lösning i VB.Net så koden är inte 100% kompatibel med ASP-kod. Du kan säkert ändå förstå koden och skriva om den, eller kanske någon annan orkar.

När det gäller koden så skulle jag vilja ändra tankesättet litegrand. Eftersom alla ska möta alla så är ju inte själva matchgenererandet som behöver slumpas, utan matchordningen. Därför skulle jag börja med att generera alla matcher till en array (mGames i min kod nedan) och sedan slumpa om i arrayen. På så sätt blir problemet med ogiltiga matcher, olika antal matcher m m triviala eftersom vi bara genererar giltiga matcher, och vi kan fokusera på det verkliga problemet; att inget lag får spela två matcher i rad :

Först lite deklarationer samt koden som kör allting :

<code>
Private mNumberOfTeams As Integer

' Antal matcher när n st lag möts en gång var är : n(n-1)/2 (dvs ökar proportionellt mot n^2)
' Eftersom jag skrivit koden i VB.Net måste jag dra bort ett från dimensionernas storlek.
' Annars ska dimensionerna vara :
' Dim 1: NumberOfTeams * (NumberOfTeams - 1) / 2
' Dim 2: 2
Private mGames(,) As Integer
ReDim mGames(NumberOfTeams * (NumberOfTeams - 1) / 2 - 1, 1)

' Generera alla giltiga matcher
GenerateGameList()
' Rör om i matchlistan slumpvis. Bör väl göras minst i stoleksordningen
' lika många gånger som antalet matcher, antal lag i kvadrat blir nog bra.
' det motsvarar ju ungefär 2*antalet matcher (se ovan)
RandomizeGames(mNumberOfTeams*mNumberOfTeams)
' Leta upp en korrekt lösning
CreateValidGameList()
</code>

Funktionen som genererar alla giltiga matcher i en array :

<code>
Public Sub GenerateGameList()
Dim i As Integer, j As Integer
Dim match_count As Integer
match_count = 0
For i = 1 To mNumberOfTeams - 1
For j = i + 1 To mNumberOfTeams
' Lag i möter lag j
mGames(match_count, 0) = i
mGames(match_count, 1) = j
match_count = match_count + 1
Next j
Next i
End Sub
</code>

Nästa steg blir att röra om lite i matchordningen. En metod är att slumpa två matcher och sedan byta plats på dessa och göra om detta tillräckligt många gånger.

<code>
Public Sub RandomizeGames(ByVal Count As Integer)
Dim i As Integer
Dim g1 As Integer
Dim g2 As Integer
Dim r As New System.Random

For i = 1 To Count
g1 = r.Next(LBound(mGames), UBound(mGames))
g2 = r.Next(LBound(mGames), UBound(mGames))
SwitchGames(g1, g2)
Next
End Sub

Private Sub SwitchGames(ByVal Game1 As Integer, ByVal Game2 As Integer)
Dim tmp1 As Integer
Dim tmp2 As Integer

tmp1 = mGames(Game1, 0)
tmp2 = mGames(Game1, 1)
mGames(Game1, 0) = mGames(Game2, 0)
mGames(Game1, 1) = mGames(Game2, 1)
mGames(Game2, 0) = tmp1
mGames(Game2, 1) = tmp2
End Sub
</code>

Look out for Part II :-)

/Per Hultqvist

Här kommer Part II:

När detta är gjort så har vi en slumpad spellista, men det är inte säkert att den uppfyller kravet på att ett lag inte får spela två matcher efter varandra så vi måste lösa detta. Vi börjar med att göra en funktion som returnerar true om villkoret är uppfyllt:

<code>
Public Function IsValidGameList() As Boolean
Dim i As Integer

For i = LBound(mGames) To UBound(mGames) - 1
' Kolla om match nr i är giltig (dvs hemmalaget och bortalaget
' spelar inte i matchen före och efter
If IsGameValid(i) = False Then
Return False
Exit Function
End If
Next i
IsValidGameList = True
End Function
</code>

Ovanstående funktion använder några hjälpfunktioner som även används senare i min lösning :

<code>
' Är match nr Game giltig?
Public Function IsGameValid(ByVal Game As Integer)
Return CanGameBeMovedTo(Game, Game)
End Function

' Kan match nr GameFrom flyttas till position GameTo utan att bryta mot dubbelmatchregeln?
Public Function CanGameBeMovedTo(ByVal GameFrom As Integer, ByVal GameTo As Integer)
If CanTeamPlayInGame(mGames(GameFrom, 0), GameTo) = False Or CanTeamPlayInGame(mGames(GameFrom, 1), GameTo) = False Then
Return False
End If
Return True
End Function

' Kontrollerar om laget Team kan spela i matchen Game
' genom att se om de också spelar i Game-1 eller Game+1
Public Function CanTeamPlayInGame(ByVal Team As Integer, ByVal Game As Integer)
If Game = LBound(mGames) Then
If Team = mGames(LBound(mGames) + 1, 0) Or Team = mGames(LBound(mGames) + 1, 1) Then
Return False
End If
ElseIf Game = UBound(mGames) Then
If Team = mGames(UBound(mGames) - 1, 0) Or Team = mGames(UBound(mGames) - 1, 1) Then
Return False
End If
Else
If Team = mGames(Game - 1, 0) Or Team = mGames(Game - 1, 1) Or _
Team = mGames(Game + 1, 0) Or Team = mGames(Game + 1, 1) Then
Return False
End If
End If
Return True
End Function
</code>

Nu finns det några alternativa vägar att gå för att uppfylla kravet på efterföljande matcher för samma lag. Vi kan t ex fortsätta byta plats på matcher slumpvis tills kravet är uppfyllt. Risken är dock att detta tar väldigt lång tid, så en sådan metod är kanske inte jättebra. Mitt förslag är att loopa igenom matcherna från början till slut och använda funktionen IsGameValid ovan för att avgöra om den är OK. Om match nr x inte är ok så loopar vi igenom alla matcher från x+1 till n (=antalet matcher) och kollar om någon av dessa matcher kan byta plats med match nr x. Detta gör vi med funktionen CanGameBeMovedTo. Slutligen lägger jag en loop runt alltihopa ifall ingen lösning hittas, och isåfall slumpar jag om matcherna lite grand igen och testar igen om en lösning kan hittas med ovanstående algoritm.

<code>
Public Sub CreateValidGameList() As Integer
Dim bSolutionFound As Boolean = False
Dim i As Integer
Dim j As Integer
Dim bGameOk As Boolean

While Not bSolutionFound
For i = LBound(mGames) + 1 To UBound(mGames)
' Kan lagen i match nr i spela match nr i utan att bryta mot
' regeln om två efterföljande matcher?
bGameOk = IsGameValid(i)
If Not bGameOk Then
' Nope, försök hitta en senare match som kan byta plats med denna
For j = i + 1 To UBound(mGames)
If CanGameBeMovedTo(i, j) = True And CanGameBeMovedTo(j, i) = True Then
SwitchGames(i, j)
bGameOk = True
Exit For
End If
Next
End If
If bGameOk = False Then Exit For
Next
If bGameOk = False Then
' Ingen lösning hittad, slumpa om listan lite och prova igen
RandomizeGames(UBound(mGames) * 5)
Else
' Lösning hittad!!!
bSolutionFound = True
End If
End While
End Sub
</code>

Lycka till

/Per Hultqvist

Tack så mycket för hjälpen :)

Att det blir för många lag är inga problem. Är det över 10 lag delas dom in i 2 grupper, över 15 delas dom in i 3 osv. Men vad jag vet är det max 12 lag

Ska försöka förstå vad koden gör imorgon.

Jag får några fel vid kompileringen i visual studio

ReDim h:\inetpub\wwwroot\cup\testning.aspx.vb(29): Statement cannot appear outside of a method body.

GenerateGameList() h:\inetpub\wwwroot\cup\testning.aspx.vb(32): Declaration expected.

RandomizeGames h:\inetpub\wwwroot\cup\testning.aspx.vb(36): Declaration expected.

CreateValidGameList() h:\inetpub\wwwroot\cup\testning.aspx.vb(38): Declaration expected.

Public Sub CreateValidGameList() As Integer h:\inetpub\wwwroot\cup\testning.aspx.vb(123): End of statement expected.


En fråga också. Måste jag inte skriva vilka lag som ska vara med någonstans?

Hej igen,

Japp, det var en del sådana problem jag förväntade mig skulle dyka upp när du klipper in det i en asp-sida. Själv skrev jag det som en klass i VB.Net...Men nu har jag skrivit om det som en ASP-sida och koden kommer i de följande två inläggen. Jag har även lagt till hanteringen av lagnamnen.

Sätt alltså ihop koden i detta och nästa inlägg och spara det som en ASP-sida.

<code>

<HTML>
<HEAD>
<%

Dim mNumberOfTeams

'mNumberOfTeams = 8
'Dim mGames(27,2) ' n*(n-1)/2 = 8*7/2 = 28
'Dim mTeamNames(8)

mNumberOfTeams = 5
Dim mGames(9,2) ' n*(n-1)/2 = 5*4/2 = 10
Dim mTeamNames(5)

mTeamNames(1)="Knäckebröhults BK"
mTeamNames(2)="Tre kronor"
mTeamNames(3)="Fyra Kronor"
mTeamNames(4)="Foppas lag"
mTeamNames(5)="NY Rangers"
'mTeamNames(6)="Frölunda"
'mTeamNames(7)="Gurk burk"
'mTeamNames(8)="Team Kanada"

GenerateGameList()
RandomizeGames(100)
CreateValidGameList()
PrintGameList()

Function GenerateGameList()
Dim i
Dim j
Dim match_count
match_count = 0
For i = 1 To mNumberOfTeams - 1
For j = i + 1 To mNumberOfTeams
' Lag i möter lag j
mGames(match_count, 1) = i
mGames(match_count, 2) = j
match_count = match_count + 1
Next
Next
End Function

' Kontrollerar om laget Team kan spela i matchen Game
' genom att se om de också spelar i Game-1 eller Game+1
Function CanTeamPlayInGame(Team,Game)
If Game = LBound(mGames) Then
If Team = mGames(Game + 1, 1) Or Team = mGames(Game + 1, 2) Then
CanTeamPlayInGame = False
exit function
End If
ElseIf Game = UBound(mGames) Then
If Team = mGames(Game - 1, 1) Or Team = mGames(Game - 1, 2) Then
CanTeamPlayInGame = False
exit function
End If
Else
If Team = mGames(Game - 1, 1) Or Team = mGames(Game - 1, 2) Or _
Team = mGames(Game + 1, 1) Or Team = mGames(Game + 1, 2) Then
CanTeamPlayInGame = False
exit function
End If
End If
CanTeamPlayInGame = True
End Function

Function IsGameValid(Game)
' Kolla om hemmalaget i match nr i kan spela i den matchen och sedan
' samma sak för bortalaget
If CanTeamPlayInGame(mGames(Game, 1), Game) = False Or CanTeamPlayInGame(mGames(Game, 2), Game) = False Then
IsGameValid = false
exit function
end if
IsGameValid=true
End Function

Function CanGameBeMovedTo(GameFrom,GameTo)
If CanTeamPlayInGame(mGames(GameFrom, 1), GameTo) = False Or CanTeamPlayInGame(mGames(GameFrom, 2), GameTo) = False Then
CanGameBeMovedTo = false
exit function
End If
CanGameBeMovedTo = true
End Function

</code>

<i></i>

Här kommer resten av koden :

<code>

Sub SwitchGames(Game1, Game2)
Dim tmp1
Dim tmp2

tmp1 = mGames(Game1, 1)
tmp2 = mGames(Game1, 2)
mGames(Game1, 1) = mGames(Game2, 1)
mGames(Game1, 2) = mGames(Game2, 2)
mGames(Game2, 1) = tmp1
mGames(Game2, 2) = tmp2
End Sub

Function IsValidGameList()
Dim i

For i = LBound(mGames) To UBound(mGames)
If IsGameValid(i) = False Then
IsValidGameList = False
Exit Function
End If
Next
IsValidGameList = True
End Function

Sub RandomizeGames(Count)
Dim i
Dim g1
Dim g2
Dim r

randomize timer
For i = 1 To Count
g1 = int(rnd()* ( UBound(mGames)- LBound(mGames)+1)+LBound(mGames))
g2 = int(rnd()* ( UBound(mGames)- LBound(mGames)+1)+LBound(mGames))
SwitchGames g1, g2
Next
End Sub

Sub PrintGameList()
Dim i
For i = LBound(mGames) To UBound(mGames)
Response.Write "<BR>Game " & i & " : " & mTeamNames(mGames(i, 1)) & " - " & mTeamNames(mGames(i, 2))
Next
End Sub

Sub CreateValidGameList()
Dim bSolutionFound
bSolutionFound = False
Dim bGameOk
Dim i
Dim j

Do While Not bSolutionFound
For i = LBound(mGames) + 1 To UBound(mGames)
' Kan lagen i match nr i spela match nr i utan att bryta mot
' regeln om två efterföljande matcher?
bGameOk = IsGameValid(i)
If Not bGameOk Then
' Nope, försök hitta en senare match som kan byta plats med denna
For j = i + 1 To UBound(mGames)
If CanGameBeMovedTo(i, j) = True And CanGameBeMovedTo(j, i) = True Then
SwitchGames i, j
bGameOk = True
Exit For
End If
Next
End If
If bGameOk = False Then Exit For
Next
If bGameOk = False Then
' Ingen lösning hittad, slumpa om listan lite och prova igen
RandomizeGames(UBound(mGames))
Else
' Lösning hittad!!!
bSolutionFound = True
End If
Loop
End Sub

%>
</HEAD>
<BODY>
</BODY>
</HTML>

</code>

Lycka till...

/Per Hultqvist

<i></i>

Märkligt nog fungerar koden nu mycket bättre även när det endast är fem lag. Jag måste ha lyckats rätta någon bugg när jag skrev om det för det går snabbare nu i ASP än vad det gjorde i .Net :-) Men det gör ju ingenting...

/Per Hultqvist

<i></i>

Jag kör ju med codebehind skrivet i vb så jag tycker det är konstigt att det inte fungerade i vs

Tack. Det fungerar när jag kör det som en vanlig asp sída men inte när jag kör det som en aspx.

En fråga till. Skulle man behöva ändra mycket i koden för att slumpa fram tex 3 grupper så att dom spelar var 3:e match och att varje lag endast får spela ett antal matcher/dag?

har inte läst igenom detta men asp och asp skiljer sig en del när det gåller variabel-deklaration:
(kan int asp men)
if test = "ja"
dim i as integer ' om man nu skriver så
endif
då blir i publik


i asp.net
if test = "ja"
dim i as integer
end if

Då kan du inte anropa i utanför if satsen...

Hej Andreas,

Helt otroligt klantigt av mig, jag trodde detta var en ASP-fråga (kollade inte så noga vilket forum det var) så jag la ner en massa tid på att få det att fungera i ASP i st f ASP.Net, vilket hade varit mycket enklare eftersom jag skrev den första lösningen i VB.Net...*SUCK*...klantigt av mig...sorry.

När det gäller att skapa grupper så är det inte mycket extra jobb, eftersom du bara behöver köra den befintliga koden tre gånger (om du vill ha tre grupper) och skapa tre matchscheman och låta dom tre grupperna spela var tredje match t ex.

Att låta lagen spela ett max antal matcher per dag kan bli knepigare om varje lag ska spela lika många matcher per dag. Min metod genererar (troligen) inte en lista som är jämnt fördelad, dvs ett lag kan (teoretiskt) spela de flesta av sina matcher i t ex den första halvan av turneringen (iallafall om antal lag per grupp blir någorlunda stort). Det finns ingen inbyggd "jämn fördelning" av matcherna i min algoritm tyvärr.

Jag har skrivit om koden till ett ASP.Net-projekt (VB.Net som codebehind-språk). Kan jag maila det till dig istället för att slänga in det i forumet? Den här koden är ju ganska specialiserad så jag tror inte den är av allmänt intresse...maila din email-adress i ett imail eller till per_hultqvist@hotmail.com så skickar jag koden...

Jag har gjort en funktion som jag tror löser ditt problem

Funktionen returnerar en sträng som ger dig spellistan

private string GetTournament()
{
Random rnd = new Random();
ArrayList lagLista = new ArrayList();
ArrayList lag = new ArrayList();

//Stoppa lagen i en tombola
lag.Add("Tibro IK");
lag.Add("Skövde IK");
lag.Add("MarieStad Bois");
lag.Add("Skara IK");
lag.Add("Leksand");
lag.Add("Hammarby");

//Dra slumpmässigt lag från tombolan
int iSelectedTeam;
int nrOfLag = lag.Count;
for (int i = 0; i<nrOfLag;i++)
{
iSelectedTeam = rnd.Next(0,lag.Count-1);
lagLista.Add(lag[iSelectedTeam]);
lag.RemoveAt(iSelectedTeam);
}



//Använd permutationer för lösa problemet. Fungerar endast för jämnt antal lag
int N = lagLista.Count;
string sOut = "";
for(int R=1;R<N;R++)
{
sOut += "Möte i omgång " + R.ToString() + "\r\n";
for(int M=1;M<=N/2;M++)
{
int t1 = (M+R-2)%(N-1)+1;
int t2 = ((M==N/2)?1:0)*N + ((M!=N/2)?1:0) * ((N-M+R-2)%(N-1) + 1);
sOut += lagLista[t1-1].ToString() + " - " + lagLista[t2-1].ToString() + "\r\n";
}
sOut += "\r\n";
}

return sOut;
}

Sorry, VB.NET skall det vara

Private Function GetTournament()
Dim rnd As New Random()
Dim lagLista As New ArrayList()
Dim lag As New ArrayList()

'Stoppa lagen i en tombola
lag.Add("Tibro IK")
lag.Add("Skövde IK")
lag.Add("MarieStad Bois")
lag.Add("Skara IK")
lag.Add("Leksand")
lag.Add("Hammarby")

'Dra slumpmässigt lag från tombolan
Dim iSelectedTeam As Integer
Dim nrOfLag As Integer = lag.Count
Dim i As Integer
For i = 0 To nrOfLag - 1
iSelectedTeam = rnd.Next(0, lag.Count - 1)
lagLista.Add(lag(iSelectedTeam))
lag.RemoveAt(iSelectedTeam)
Next i



'Använd permutationer för lösa problemet. Fungerar endast för jämnt antal lag
Dim N As Integer = lagLista.Count
Dim sOut As String = ""
Dim R As Integer
For R = 1 To N - 1
sOut += "Möte i omgång " + R.ToString() + ControlChars.Cr + ControlChars.Lf
Dim M, P1, P2, O As Integer
For M = 1 To N / 2
Dim t1 As Integer = (M + R - 2) Mod (N - 1) + 1
If M = N / 2 Then
P1 = 1
P2 = 0
Else
P1 = 0
P2 = 1
End If

Dim t2 As Integer = P1 * N + P2 * ((N - M + R - 2) Mod (N - 1) + 1)
sOut += lagLista((t1 - 1)).ToString() + " - " + lagLista((t2 - 1)).ToString() + ControlChars.Cr + ControlChars.Lf
Next M
sOut += ControlChars.Cr + ControlChars.Lf
Next R

Return sOut
End Function

Snyggt! Misstänkte att det skulle finnas en mer matematisk, kombinatorisk lösning på problemet men kunde inte komma på någon. Har letat i mina algoritm- och diskret matematik-böcker men inte hittat någonting, och ingenting som förklarar din algoritm heller...har du några referenser att dela med dig? Skulle gärna läsa mer om detta...

Tack. Men jag tror att den koden per gav mig fungerar bättre eftersom din kod inte fungerar med ojämnt antal lag

Sök på google efter permutation.

Du är rolig du :-)
Vassego!

Private Function GetTournament()
Dim rnd As New Random()
Dim lagLista As New ArrayList()
Dim lag As New ArrayList()

'Stoppa lagen i en tombola
lag.Add("Tibro IK")
lag.Add("Skövde IK")
lag.Add("MarieStad Bois")
lag.Add("Skara IK")
lag.Add("Leksand")
lag.Add("Hammarby")
lag.Add("Kiruna") 'Jag la till Kiruna för att få ojämnt antal lag

'Dra slumpmässigt lag från tombolan
Dim iSelectedTeam As Integer
Dim nrOfLag As Integer = lag.Count
Dim i As Integer
For i = 0 To nrOfLag - 1
iSelectedTeam = rnd.Next(0, lag.Count - 1)
lagLista.Add(lag(iSelectedTeam))
lag.RemoveAt(iSelectedTeam)
Next i

'Om ojämnt antal lag lägg till ett dummy som sedan plockas bort i varje omgång
If (lagLista.Count Mod 2) <> 0 Then
lagLista.Add("dummy")
End If


'Använd permutationer för lösa problemet.
Dim N As Integer = lagLista.Count
Dim sOut As String = ""
Dim R As Integer
For R = 1 To N - 1
sOut += "Möte i omgång " + R.ToString() + ControlChars.Cr + ControlChars.Lf
Dim M, P1, P2, O As Integer
For M = 1 To N / 2
Dim t1 As Integer = (M + R - 2) Mod (N - 1) + 1
If M = N / 2 Then
P1 = 1
P2 = 0
Else
P1 = 0
P2 = 1
End If

Dim t2 As Integer = P1 * N + P2 * ((N - M + R - 2) Mod (N - 1) + 1)
If lagLista(t1 - 1) <> "dummy" And lagLista(t2 - 1) <> "dummy" Then
sOut += lagLista((t1 - 1)).ToString() + " - " + lagLista((t2 - 1)).ToString() + ControlChars.Cr + ControlChars.Lf
Else
Dim sLag As String
If lagLista(t1 - 1) = "dummy" Then
sLag = lagLista(t2 - 1).ToString()
Else
sLag = lagLista(t1 - 1).ToString()
End If
sOut += sLag + " står över" + ControlChars.Cr + ControlChars.Lf
End If
Next M
sOut += ControlChars.Cr + ControlChars.Lf
Next R

Return sOut
End Function

Imponerad av era lösningar och fått lite inspiration.
Jag har "roat" mig att att försöka skapa ett program för tävling. Med inmatning av resultat för spelarna
Sen beroende på om det är gruppspel eller Alla mot Alla. Så i förstnämnda fallet kanske de 2 bästa spelarna
till semi, kvart eller till final.

Men nu till Alla mot Alla
Har hittat tabeller på nätet som jag använt, men då har spelordningen varit 1-16,3-7 osv
Men inte lyckats lösa mitt problem
Så jag vill ha min egen spelordning som start

1 Skapar spelordning med grundomgången i en array, beroende på antal spelare
Är det mindre än i nedan, tex bara 16 spelare så deletar jag allt >16

Tabell:={1,2, 3,4, 5,6, 7,8, 9,10, 11,12, 13,14, 15,16, 17,18, 19,20, 21,22, 23,24, 25,26, 27,28, 29,30}
2 Andra omgången skapas ok, dvs om bortamatch så hemma och skapar NyTabell
2,3, 4,1, 6,7, 8,5, 10,11, 12,9, 14,15, 16,13 18,19,20,17
3 Skapat NyTabell från Omgång 2 Sen börjar det bra, men sen går det åt h-e . Borde bli liknande
3,6, 1,5, 7,2, 5,4, 11,8, 9,10, 15,12 13,14
Tilläggas kan nämnas att jag lägger in matcherna i en array ,dvs de som fått en match tilldelad.
Typ 3,6,1,5 enligt ovan och kollar om de skall vara borta från nya omgången

Måste någon få tex två hemmamatcher i rad?
Någon som kan vägleda hur göra?
Alla tips mottages tacksamt
Men min tankeverksamhet klarar inte riktigt detta :-)

Ni kanske får använda stämpeln, "Läst men ej förstått" :)