📄 frmmain.frm
字号:
VERSION 5.00
Object = "{8EF55EF2-9223-4E45-A2A6-71151C884DD2}#1.0#0"; "GA.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmMain
Caption = "G+ Test"
ClientHeight = 8475
ClientLeft = 165
ClientTop = 495
ClientWidth = 11100
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8475
ScaleWidth = 11100
StartUpPosition = 2 'CenterScreen
WindowState = 2 'Maximized
Begin MSComctlLib.Toolbar tb
Align = 1 'Align Top
Height = 660
Left = 0
TabIndex = 5
Top = 0
Width = 11100
_ExtentX = 19579
_ExtentY = 1164
ButtonWidth = 1032
ButtonHeight = 1005
Appearance = 1
ImageList = "img"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 5
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Reset"
ImageIndex = 1
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Step"
ImageIndex = 2
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Con"
ImageIndex = 3
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Evolve"
ImageIndex = 4
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Stop"
ImageIndex = 5
EndProperty
EndProperty
BorderStyle = 1
End
Begin MSComctlLib.ImageList img
Left = 9750
Top = 7620
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 5
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":1BB2
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":248C
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":2D66
Key = ""
EndProperty
BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":3640
Key = ""
EndProperty
BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmMain.frx":3F1A
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.ProgressBar pg
Height = 375
Left = 90
TabIndex = 1
Top = 7800
Width = 9375
_ExtentX = 16536
_ExtentY = 661
_Version = 393216
Appearance = 1
End
Begin GALib.GA g
Height = 975
Left = 4800
TabIndex = 0
Top = 3240
Visible = 0 'False
Width = 975
_Version = 65536
_ExtentX = 1720
_ExtentY = 1720
_StockProps = 0
crossover = 1
algorithm = 2
maxgeneration = 150
notifyafterstep = -1 'True
maximini = -1
pmutation = 0.01
pcrossover = 0.9
nconvergence = 20
pconvergence = 0.99
notifyaftermutation= 0 'False
notifyafterinit = 0 'False
notifyaftercrossover= 0 'False
terminator = 0
elitist = -1 'True
replacepercentage= 0.5
definitializer = 1
defmutator = 1
defgenometype = 1
defselector = 1
defpopsize = 100
End
Begin VB.TextBox txt
BackColor = &H00C0C0C0&
Height = 6645
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 4
Top = 720
Width = 10125
End
Begin VB.PictureBox p
Height = 6690
Left = 105
ScaleHeight = 6630
ScaleWidth = 10095
TabIndex = 6
Top = 735
Visible = 0 'False
Width = 10155
End
Begin VB.Label lbg
Caption = "Generation: 0"
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 255
Left = 90
TabIndex = 3
Top = 7440
Width = 1935
End
Begin VB.Label lbBest
Caption = "0"
BeginProperty Font
Name = "Times New Roman"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 375
Left = 2130
TabIndex = 2
Top = 7440
Width = 1455
End
Begin VB.Menu menu
Caption = "File"
Begin VB.Menu menuExit
Caption = "Exit"
End
End
Begin VB.Menu menuOpt
Caption = "Options"
Begin VB.Menu menuReal
Caption = "Real Number Encoding"
Checked = -1 'True
End
Begin VB.Menu menuBin
Caption = "Binary Encoding"
End
Begin VB.Menu menuSep3
Caption = "-"
End
Begin VB.Menu menuGraphic
Caption = "Graphic View"
End
Begin VB.Menu menuTer
Caption = "Custom Terminator"
End
End
Begin VB.Menu menuEvolve
Caption = "Evolve"
Begin VB.Menu menuReset
Caption = "Reset"
End
Begin VB.Menu menuStep
Caption = "One Step"
End
Begin VB.Menu menuCon
Caption = "Continue"
End
Begin VB.Menu menuEvolve2
Caption = "Evolve"
End
Begin VB.Menu menuStop
Caption = "Stop"
End
End
Begin VB.Menu menuFn
Caption = "Functions"
Begin VB.Menu menuFuns
Caption = "Rastrign"
Index = 0
End
Begin VB.Menu menuFuns
Caption = "Ackley"
Index = 1
End
Begin VB.Menu menuFuns
Caption = "Sphere"
Index = 2
End
Begin VB.Menu menuFuns
Caption = "TSP Circle"
Index = 3
End
Begin VB.Menu menuFuns
Caption = "TSP Random"
Index = 4
End
Begin VB.Menu menuFuns
Caption = "Single Knapsack "
Index = 5
End
Begin VB.Menu menuFuns
Caption = "Binpack"
Index = 6
End
Begin VB.Menu menuFuns
Caption = "Steiner Circle"
Index = 7
End
Begin VB.Menu menuFuns
Caption = "Steiner Weighted"
Index = 8
End
End
Begin VB.Menu menuHelp
Caption = "Help"
Begin VB.Menu menuAbout
Caption = "About"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type POINT
x As Single
y As Single
End Type
Private Type KNAPSACK
p As Long 'profit
w As Long 'weight
End Type
Private m_pts(24) As POINT 'coordinates for TSP problems
Private m_knap(50) As KNAPSACK 'parameters for Knapsack problem
Private m_w(60) As Single 'weights for bin problem
Public m_lFunID As Long 'functionID
Public m_allelesetarr As New AlleleSetArray
Public m_Pop As New population
Public m_bStop As Boolean 'used for custom terminator
Const cstFUNRAS = 0
Const cstFUNACKLEY = 1
Const cstFUNSPHERE = 2
Const cstFUNTSP = 3
Const cstFUNTSP2 = 4
Const cstKNAPSACK = 5
Const cstBIN = 6
Const cstSTEINER = 7
Const cstSTEINER2 = 8
Public Sub Printresult()
'show best 5 solutions
Dim i
Dim lResult As Long, lBins As Long, lWaste As Long
txt.Text = ""
For i = 0 To g.population.Size - 1
If menuReal.Checked = True Then
If m_lFunID <> cstBIN Then
txt.Text = txt.Text + "<" + _
Format(g.population.best(i).Evaluate, "#0.0000") + "> " + _
g.population(i).ToString("=>") + vbCrLf
Else
lResult = g.population.best(i).Evaluate
lBins = lResult / 10000
lWaste = lResult Mod 10000
txt.Text = txt.Text + "<Bins/Wastes:" + CStr(lBins) + "/" + CStr(lWaste) _
+ "> " + g.population(i).ToString("=>") + vbCrLf
End If
Else
txt.Text = txt.Text + "<" + _
Format(g.population.best(i).Evaluate, "#0.0000") + "> " + _
Decoding(g.population(i)) + vbCrLf
txt.Text = txt.Text + Space(8) + g.population(i).ToString + vbCrLf
End If
If i > 5 Then Exit For
Next
p.Refresh
End Sub
Private Sub cmdStep_Click()
'evolve for one step
If g.generation >= g.maxgeneration Then Exit Sub
g.Step
Printresult
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub Form_Load()
init
End Sub
Private Sub menuTer_Click()
If menuTer.Checked = True Then
menuTer.Checked = False
g.terminator = GA_TERMINATEUPONGENERATION
Else
menuTer.Checked = True
g.terminator = GA_CUSTOMTERMINATOR
End If
End Sub
Private Sub tb_ButtonClick(ByVal Button As MSComctlLib.Button)
If Button.Key = "Reset" Then
menuReset_Click
ElseIf Button.Key = "Step" Then
menuStep_Click
ElseIf Button.Key = "Con" Then
menuCon_Click
ElseIf Button.Key = "Evolve" Then
menuEvolve2_Click
ElseIf Button.Key = "Stop" Then
menuStop_Click
End If
Exit Sub
End Sub
Private Sub Form_Resize()
'adjust control size
If Me.ScaleWidth <= 0 Or Me.ScaleHeight <= 0 Then Exit Sub
pg.Left = 0
pg.Width = Me.ScaleWidth
pg.Top = Me.ScaleHeight - pg.Height
lbg.Left = 0
lbg.Top = pg.Top - lbg.Height
lbBest.Left = lbg.Width
lbBest.Top = lbg.Top
txt.Left = pg.Left
txt.Width = pg.Width
txt.Height = lbg.Top - txt.Top
p.Left = txt.Left
p.Top = txt.Top
p.Width = txt.Width
p.Height = txt.Height
p.Refresh
End Sub
Private Sub g_AfterStep(ByVal population As population, var As Variant)
'show information after each generation
Dim n As Long
lbg.Caption = "generation: " + CStr(g.generation)
lbg.Refresh
If g.generation <= pg.Max Then pg.Value = g.generation
n = g.generation
lbBest.Caption = Format(g.population.best(0).Evaluate, "#0.00")
lbBest.Refresh
p.Refresh
'==special for TSP,only a small portion of the population is assigned with custom mutator in order to increase speed
If m_lFunID = cstFUNTSP Or m_lFunID = cstFUNTSP2 Then
Dim i As Long
For i = 0 To g.population.Size - 1
g.population(i).mutator = GA_SWAPMUTATOR
Next
For i = 0 To 10
g.population.best(i).mutator = GA_CUSTOMMUTATOR
g.population.worst(i).mutator = GA_CUSTOMMUTATOR
Next
End If
End Sub
Private Sub g_OnCrossover(ByVal father As GALib.IGenome, ByVal mother As GALib.IGenome, ByVal brother As GALib.IGenome, ByVal sister As GALib.IGenome, var As Variant, result As Long)
'custion crossover for TSP problem
If m_lFunID = cstFUNTSP Or m_lFunID = cstFUNTSP2 Then
TSPCrossover father, mother, brother, sister, var, result
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -