frmmain.frm

用遗传算法求解背包问题是南京航空航天大学信息与计算科学专业编写的.本程序利用遗传算法来求解背包问题.采用二进制字符串编码,1表示选择物体,0则不选择. 背包问题描述:在M件物品取出若干件放在空间为

VERSION 5.00
Begin VB.Form frmMain 
   Caption         =   "背包问题的遗传算法解法---作者:陶善文"
   ClientHeight    =   4515
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5550
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   ScaleHeight     =   4515
   ScaleWidth      =   5550
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdQuickSolve 
      Caption         =   "一次搞定"
      Height          =   345
      Left            =   4335
      TabIndex        =   8
      Top             =   45
      Width           =   1080
   End
   Begin VB.Frame Frame2 
      Caption         =   "物体价值"
      Height          =   1590
      Left            =   2805
      TabIndex        =   6
      Top             =   495
      Width           =   2760
      Begin VB.TextBox txtContent 
         ForeColor       =   &H00FF0000&
         Height          =   1305
         Left            =   75
         Locked          =   -1  'True
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   7
         Top             =   210
         Width           =   2595
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "物体体积"
      Height          =   1590
      Left            =   0
      TabIndex        =   4
      Top             =   495
      Width           =   2760
      Begin VB.TextBox txtValue 
         ForeColor       =   &H00FF0000&
         Height          =   1305
         Left            =   75
         Locked          =   -1  'True
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   5
         Top             =   210
         Width           =   2595
      End
   End
   Begin VB.TextBox txtKitContent 
      ForeColor       =   &H00FF0000&
      Height          =   345
      Left            =   825
      Locked          =   -1  'True
      TabIndex        =   3
      Text            =   "Text1"
      Top             =   45
      Width           =   2145
   End
   Begin VB.ListBox lstChromosome 
      Height          =   2400
      Left            =   -15
      TabIndex        =   1
      ToolTipText     =   "各代染色体显示"
      Top             =   2115
      Width           =   5595
   End
   Begin VB.CommandButton cmdSolve 
      Caption         =   "慢慢求解"
      Height          =   345
      Left            =   3120
      TabIndex        =   0
      Top             =   45
      Width           =   1080
   End
   Begin VB.Label Label3 
      Caption         =   "背包体积"
      Height          =   210
      Left            =   30
      TabIndex        =   2
      Top             =   120
      Width           =   795
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const iObjectCount = 49                '背包数
Const iChromosomeCount = 49            '染色体数
Const sngiAberranceProbability = 0.002 '变异率

Dim iValue(iObjectCount) As Integer           '物体价值
Dim iContent(iObjectCount) As Integer         '物体体积
Dim szChromosome(iChromosomeCount) As String  '染色体
Dim iAdaptablity(iChromosomeCount) As Integer '适应度
Dim iProbability(iChromosomeCount) As Single  '选择概率
Dim iKitContent As Integer                    '背包容量
Dim iCurEra As Integer                        '当前种群代数
Dim iAberranceCount As Integer                '可能发生变异的染色体数
Dim iCopyCount As Integer
Dim iSelChromosome1 As Integer
Dim iSelChromosome2 As Integer
Dim i As Integer
'显示物体体积或价值
Public Function Display(txt As TextBox, num() As Integer, iObjcetCount As Integer)
Dim i As Integer

txt.Text = num(0)
For i = 1 To iObjectCount
    txt.Text = txt.Text & "," & num(i)
Next
End Function
'显示染色体
Public Function DisplayChromosome(szChromosome() As String, iChromosomeCount As Integer)
Dim i As Integer

For i = 0 To iChromosomeCount
    lstChromosome.AddItem szChromosome(i)
Next
End Function
'随机初始化染色体
Public Function GetRandChromosomes(szChromosome() As String, iChromosomeCount As Integer)
Dim i As Integer
Dim strTemp As String
Dim iRand As Integer

Randomize
For i = 0 To iChromosomeCount
    For j = 0 To iChromosomeCount
        iRand = Rnd()
        If iRand = 0 Then
           strTemp = "0"
        Else
           strTemp = "1"
        End If
        szChromosome(i) = szChromosome(i) + strTemp
    Next
Next
End Function
'随机初始化物体体积和物体价值
Public Function GetRandValueAndContent(iValue() As Integer, iContent() As Integer, iObjectCount As Integer)
Dim i As Integer
Dim iRand As Integer

Randomize
For i = 0 To iObjectCount
    iRand = Rnd() * 10 + 1
    iValue(i) = iRand
    iRand = Rnd() * 50
    iContent(i) = iRand
Next
End Function
'根据物体体积随机初始背包容量
Public Function GetRandAllContentByContent(iContent() As Integer, iObjectCount As Integer)
Dim i As Integer
Dim iKitContent As Integer

For i = 0 To iObjectCount
    iKitContent = iKitContent + iContent(i)
Next

GetRandAllContentByContent = iKitContent + Rnd() * 50
End Function
'染色体复制
Public Function CopyChromosomes(iProbability() As Single, szChromosome() As String, iChromosomeCount As Integer)
Dim szChromosome2() As String
Dim i As Integer

ReDim szChromosome2(iChromosomeCount)
For i = 0 To iObjectCount
    szChromosome2(i) = szChromosome(SelChromosomeBySelProba(iProbability, iChromosomeCount))
Next

For i = 0 To iChromosomeCount
    szChromosome(i) = szChromosome2(i)
Next
End Function
'根据选择概率选择染色体
Public Function SelChromosomeBySelProba(iProbability() As Single, iChromosomeCount As Integer) As Integer
Dim iAllProbability As Single
Dim i As Integer

Randomize
iAllProbability = iProbability(1)
For i = 0 To iChromosomeCount
    If Rnd() < iAllProbability Then
       SelChromosomeBySelProba = i
       Exit Function
    Else
       iAllProbability = iAllProbability + iProbability(i)
    End If
Next
End Function
'判断染色体是否为活的染色体,即是否满足条件
Public Function IsLiveGene(szChromosome As String, iContent() As Integer, iKitContent As Integer) As Boolean
Dim i As Integer
Dim iCurContent As Integer

For i = 0 To Len(szChromosome) - 1
    If Mid(szChromosome, i + 1, 1) = "1" Then
       iCurContent = iCurContent + iContent(i)
    End If
Next

If iCurContent > iKitContent Then
   IsLiveGene = False
   Exit Function
End If

IsLiveGene = True
End Function
'染色体之间进行杂交
Public Function Cross(szChromosome1 As String, szChromosome2 As String, iObjectCount As Integer)
Dim iGenePos As Integer '杂交基因位
Dim strTemp As String

Randomize
iGenePos = Rnd() * iObjectCount + 1
strTemp = Mid(szChromosome1, iGenePos, 1)
Replace szChromosome1, strTemp, Mid(szChromosome2, iGenePos, 1), 1, -1, vbTextCompare
Replace szChromosome2, Mid(szChromosome2, iGenePos, 1), strTemp, 1, -1, vbTextCompare
End Function
'染色体变异
Public Function Aberrance(szChromosome As String, iObjectCount As Integer)
Dim iGenePos As Integer '将要变异的基因位

Randomize
'While IsLiveGene(szChromosome, iContent, iKitContent) = False
      iGenePos = Rnd() * iObjectCount + 1
      If Mid(szChromosome1, iGenePos, 1) = "0" Then
         Replace szChromosome1, "0", "1", 1, -1, vbTextCompare
      Else
         Replace szChromosome1, "1", "0", 1, -1, vbTextCompare
      End If
'Wend
End Function
'得到染色体适应度
Public Function GetAdaptablity(szChromosome As String, iValue() As Integer, iContent() As Integer, iChromosomeCount As Integer) As Integer
Dim iRet As Integer
Dim i As Integer

If IsLiveGene(szChromosome, iContent, iChromosomeCount) = False Then
   GetAdaptablity = 0
   Exit Function
End If

For i = 0 To Len(szChromosome) - 1
    If Mid(szChromosome, i + 1, 1) = "1" Then
       iRet = iRet + iValue(i)
    End If
Next

GetAdaptablity = iRet
End Function
 '得到染色体选择概率
Public Function GetSelectProbability(iAdaptablity() As Integer, iChromosomeNum As Integer, iChromosomeCount As Integer) As Single
Dim i As Integer
Dim iAllAdaptablity As Long

For i = 0 To iChromosomeCount
    iAllAdaptablity = iAllAdaptablity + iAdaptablity(i)
Next

GetSelectProbability = iAdaptablity(iChromosomeNum) / iAllAdaptablity
End Function
Private Sub cmdQuickSolve_Click()
'杂交,变异
While iCurEra < 50
      '求适应度
      For i = 0 To iChromosomeCount
          iAdaptablity(i) = GetAdaptablity(szChromosome(i), iValue, iContent, iKitContent)
      Next
      
      '求选择概率
      For i = 0 To iChromosomeCount
          iProbability(i) = GetSelectProbability(iAdaptablity, i, iObjectCount)
      Next
      
      '复制
      Call CopyChromosomes(iProbability, szChromosome, iChromosomeCount)
      
      '根据选择概率进行杂交
      For i = 0 To iChromosomeCount / 2
          iSelChromosome1 = SelChromosomeBySelProba(iProbability, iObjectCount)
          iSelChromosome2 = SelChromosomeBySelProba(iProbability, iObjectCount)
          Cross szChromosome(iSelChromosome1), szChromosome(iSelChromosome2), iObjectCount
      Next

      '随机变异
      For i = 0 To iAberranceCount
          Aberrance szChromosome(Rnd()), iObjectCount
      Next
      
      DisplayChromosome szChromosome, iChromosomeCount
      
      iCurEra = iCurEra + 1
Wend
End Sub
Private Sub cmdSolve_Click()
'----------------杂交,变异----------------
'求适应度
For i = 0 To iChromosomeCount
    iAdaptablity(i) = GetAdaptablity(szChromosome(i), iValue, iContent, iKitContent)
Next
      
'求选择概率
For i = 0 To iChromosomeCount
    iProbability(i) = GetSelectProbability(iAdaptablity, i, iObjectCount)
Next
      
'复制
Call CopyChromosomes(iProbability, szChromosome, iChromosomeCount)
      
'根据选择概率进行杂交
For i = 0 To iChromosomeCount / 2
    iSelChromosome1 = SelChromosomeBySelProba(iProbability, iObjectCount)
    iSelChromosome2 = SelChromosomeBySelProba(iProbability, iObjectCount)
    Cross szChromosome(iSelChromosome1), szChromosome(iSelChromosome2), iObjectCount
Next

'随机变异
For i = 0 To iAberranceCount
    Aberrance szChromosome(Rnd()), iObjectCount
Next
      
lstChromosome.Clear
DisplayChromosome szChromosome, iChromosomeCount
      
iCurEra = iCurEra + 1
'-----------------------------------------
End Sub
Private Sub Form_Load()
Call GetRandValueAndContent(iValue, iContent, iObjectCount)      '随机初始化物体容量和价值
iKitContent = GetRandAllContentByContent(iContent, iObjectCount) '根据物体容量随机初始化背包容量
Call GetRandChromosomes(szChromosome, iObjectCount)              '随机初始化初始种群
iAberranceCount = (iObjectCount + 1) * (iObjectCount + 1) * sngiAberranceProbability

txtKitContent.Text = iKitContent           '显示背包容量
Display txtValue, iValue, iObjectCount     '显示物体价值
Display txtContent, iContent, iObjectCount '显示物体体积
End Sub