Tilpasning af algoritme
hej jeg har fået følgende algoritme til at fordele hold til en sportsdag. problemet er at algoritmen er lavet til at fordele 4 hold på hver af de 8 dicipliner. det jeg skal bruge er 6 hold på hver af de 8 dicipliner. jeg har igen/begrænsede evner i Visual Basic, jeg skal bruge programmet i morgen så hurtig hjælp vil virkelig være et plus :)kode er her og under: http://pastebin.com/vTyLg0iT
Public Class Form1
#Region "Setup"
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
txtTeams.Text = "50"
'labInfo.Text = ""
End Sub
Private Sub btnGo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnGo.Click
Dim i As Integer
Dim s As String
s = txtTeams.Text
If IsNumeric(s) Then
i = CInt(s)
If (32 <= i) And (i < 100) Then
LastTeam = i - 1
If i Mod 2 = 0 Then
GoSolution()
Else
MsgBox("Antal hold skal være et lige tal (da der er netop to hold i hver kamp). Evt. må der laves et fantom-hold, der taber alle kampe")
End If
Else
MsgBox("Antal hold skal være mindst 32 og under 100")
End If
Else
MsgBox("Antal hold skal være et heltal")
End If
End Sub
'Private Sub btnExit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnExit.Click
' Me.Close()
'End Sub
#End Region
#Region "Solution - data"
'Dim Sys As New SysLib
Dim Rnd As New Random()
Const LastMatch As Integer = 7
Dim LastTeam As Integer
Dim LastGame As Integer
Dim CntBadMatches As Integer
Dim Repeats As Integer
Private Structure Square
Dim Cnt As Integer
Dim TeamNo() As Integer '0..3 (teams/game)
End Structure
Private Structure Team
Dim Cnt As Integer
Dim Done() As Boolean '0..LastMatch
Dim Seen() As Boolean '0..LastTeam
Dim Plan() As Integer '0..LastGame
End Structure
Dim Teams(99) As Team
Dim Games(7, 25) As Square
Private Sub StructInit()
' txtRes.Text = ""
CntBadMatches = 0
Dim i, j, k As Integer
For i = 0 To 99
With Teams(i)
.Cnt = 0
ReDim .Seen(LastTeam)
For k = 0 To LastTeam
.Seen(k) = False
Next
ReDim .Done(LastMatch)
For k = 0 To LastMatch
.Done(k) = False
Next
ReDim .Plan(LastGame)
For k = 0 To LastGame
.Plan(k) = -1
Next
End With
Next
For i = 0 To 7
For j = 0 To 25
With Games(i, j)
.Cnt = 0
ReDim .TeamNo(3)
For k = 0 To 3
.TeamNo(k) = -1
Next
End With
Next
Next
End Sub
Private Sub GoSolution()
Dim SaveGames As Integer = 99
Dim LastGameOpt As Integer = 99
LastGameOpt = ((LastTeam * 8) \ (4 * 8)) + 1 - 1
LastGame = ((LastTeam * 8) \ (4 * 8)) + 1 - 1 + 4
Repeats = 0
Do While (LastGame > LastGameOpt) Or (CntBadMatches > 0)
Repeats += 1
LastGame = ((LastTeam * 8) \ (4 * 8)) + 1 - 1 + 4
StructInit()
DoSolution()
Dim i, j, k, lg As Integer
'Adjust last game
lg = LastGame
For i = lg To 1 Step -1
k = 0
For j = 0 To LastMatch
k += Games(j, i).Cnt
Next
If k = 0 Then
LastGame = i - 1
Else
Exit For
End If
Next
If Repeats = 1500 Then Exit Do
Loop
PrintSolution()
End Sub
Private Sub PrintSolution()
Dim c As ListBox = TextBox2
Dim i, j, k As Integer
TextBox2.Items.Add("Matches = " & LastMatch + 1)
TextBox2.Items.Add("Teams = " & LastTeam + 1)
TextBox2.Items.Add("Games = " & LastGame + 1)
TextBox2.Items.Add("Reps = " & CntBadMatches)
TextBox2.Items.Add("Loops = " & Repeats)
TextBox2.Items.Add("")
TextBox2.Items.Add("Gameplan")
For i = 0 To LastGame
TextBox2.Items.Add("Game " & i + 1 & ":")
For j = 0 To LastMatch
TextBox2.Items.Add(" D" & j + 1 & " = ")
With Games(j, i)
For k = 0 To 3
Select Case k
Case 1 : TextBox2.Items.Add(",")
Case 2 : TextBox2.Items.Add(",")
Case 3 : TextBox2.Items.Add(",")
End Select
If .TeamNo(k) > -1 Then
TextBox2.Items.Add((.TeamNo(k) + 1).ToString)
Else
TextBox2.Items.Add("_")
End If
Next
End With
Next
TextBox2.Items.Add("")
Next
TextBox2.Items.Add("")
TextBox2.Items.Add("Teamplan")
For i = 0 To LastTeam
TextBox2.Items.Add(" " & i + 1 & ": ")
With Teams(i)
For j = 0 To LastGame
If .Plan(j) > -1 Then
TextBox2.Items.Add("," & (.Plan(j) + 1).ToString)
Else
TextBox2.Items.Add(",_")
End If
Next
If .Cnt < 8 Then TextBox2.Items.Add(" " & .Cnt & " ????")
End With
TextBox2.Items.Add("")
Next
'txtRes.Text = c.ToString
End Sub
#End Region
#Region "Solution - code"
Private Sub DoSolution()
Dim Game, Match As Integer
Dim i, j As Integer
Dim ok As Boolean = False
For Game = 0 To LastGame
For Match = 0 To LastMatch
'Team a,b of this match:
i = GetTeamForMatch(Game, Match)
If i > -1 Then
j = GetTeamForMatch(Game, Match, i)
If j > -1 Then
With Games(Match, Game)
.Cnt += 1
.TeamNo(0) = i
.TeamNo(1) = j
End With
With Teams(i)
.Cnt += 1
.Done(Match) = True
.Seen(j) = True
.Plan(Game) = Match
End With
With Teams(j)
.Cnt += 1
.Done(Match) = True
.Seen(i) = True
.Plan(Game) = Match
End With
End If
End If
'Repeat for team c,d of this match:
i = GetTeamForMatch(Game, Match)
If i > -1 Then
j = GetTeamForMatch(Game, Match, i)
If j > -1 Then
With Games(Match, Game)
.Cnt += 1
.TeamNo(2) = i
.TeamNo(3) = j
End With
With Teams(i)
.Cnt += 1
.Done(Match) = True
.Seen(j) = True
.Plan(Game) = Match
End With
With Teams(j)
.Cnt += 1
.Done(Match) = True
.Seen(i) = True
.Plan(Game) = Match
End With
End If
End If
Next
Next
End Sub
Private Function GetTeamForMatch(ByVal Game As Integer, ByVal Match As Integer, Optional ByVal Opponent As Integer = -1) As Integer
'Search for available team for the optional opponent
'Priority for teams not seen before
Dim i, j, r As Integer
r = -1
i = Rnd.Next(0, LastTeam)
For j = 0 To LastTeam
If i <> Opponent Then 'Don't match ourselves
With Teams(i)
If Not .Done(Match) And .Plan(Game) = -1 Then
If Opponent > -1 Then
If Not .Seen(Opponent) Then
r = i 'Best hit, stop here
Exit For
End If
End If
If r = -1 Then
r = i 'First attempt
If Opponent = -1 Then Exit For
End If
End If
End With
End If
i += 1
i = i Mod (LastTeam + 1)
Next
If r > -1 And Opponent > -1 Then
If Teams(r).Seen(Opponent) Then CntBadMatches += 1
End If
Return r
End Function
#End Region
End Class
