module1.bas

模拟蜜蜂采蜜的具有人工生命特性的VB程序 可以作为学习人工生命的一个不错的入门

Attribute VB_Name = "Module1"
Option Explicit
Public Type Stime
 d As Integer
 h As Integer
 m As Integer
End Type
Public Bsum As Long, Hsum As Long, Rsum As Long, Tsum As Integer, Fsum As Long
Public clr(2, 5) As Long
Public Ntime As Stime
Public AvyRate As Integer
Public UpRate As Long, LowRate As Long, iLowRate As Long
Public TimeInl As Long
Public Type Qb
 X As Integer
 Y As Integer
 Hive As Integer
 Alive As Boolean
End Type
Public Qbs() As Qb '蜂王
Public Hives As New Collection
Public Bees As New Collection
Public FTs As New Collection

Public Sub Frmrefresh()
Dim txt As String * 108
txt = ""
Dim i As Integer
With Form1
.txtinfo.Text = ""
.Label2(0).Caption = "蜂巢数:" & Hsum
.Label2(1).Caption = "蜜蜂数：   " & Bsum
.Label2(2).Caption = "花粉数：   " & Rsum
.Label2(3).Caption = "花朵数：  " & Fsum
.Label1.Caption = "第" & Ntime.d & "天    " & Ntime.h & "时"
For i = 1 To Hsum
If Qbs(i).Alive Then
txt = "蜂巢位置(x, y):(" & Hives(i).X & "," & Hives(i).Y & ")       花粉数量：" & Int(Hives(i).iRsum) & "       成员数量：" & Hives(i).iBsum & "      蜂王数量：1      报警水平: " & CStr(Hives(i).iRsum < iLowRate)
Else
txt = "蜂巢位置(x, y):(" & Hives(i).X & "," & Hives(i).Y & ")       花粉数量：" & Int(Hives(i).iRsum) & "       成员数量：" & Hives(i).iBsum & "      蜂王数量：0      报警水平: " & CStr(Hives(i).iRsum < iLowRate)
End If
.txtinfo.Text = .txtinfo.Text & txt
'Debug.Print txt
Next i
'''''''''''''style
.PicG.FillStyle = 0
.PicG.Cls
'.PicG.Circle (7500, 7500), 20
'.PicG.Circle (7500, 0), 20
'.PicG.Circle (0, 7500), 20
'.PicG.Circle (0, 0), 20
For i = 1 To Hsum
.PicG.DrawWidth = 1
.PicG.FillColor = Hives(i).color
.PicG.Circle (Hives(i).X, Hives(i).Y), Hives(i).R, Hives(i).color
''''''qb
.PicG.DrawWidth = 3
If Qbs(i).Alive Then .PicG.PSet (Qbs(i).X, Qbs(i).Y), clr(0, 2)
Next i
.PicG.DrawWidth = 1
.PicG.FillColor = clr(0, 1)
For i = 1 To Tsum
.PicG.Circle (FTs(i).X, FTs(i).Y), FTs(i).R, FTs(i).color
Next i
''''''st
.PicG.FillStyle = 1
'Debug.Print FTs.Count
For i = Tsum + 1 To FTs.Count
.PicG.Circle (FTs(i).X + FTs(i).R * 1.5, FTs(i).Y), FTs(i).R * 1.3, FTs(i).color, , , 4 / 5
.PicG.Circle (FTs(i).X - FTs(i).R * 1.5, FTs(i).Y), FTs(i).R * 1.3, FTs(i).color, , , 4 / 5
.PicG.Circle (FTs(i).X, FTs(i).Y + FTs(i).R * 1.5), FTs(i).R * 1.3, FTs(i).color, , , 5 / 4
.PicG.Circle (FTs(i).X, FTs(i).Y - FTs(i).R * 1.5), FTs(i).R * 1.3, FTs(i).color, , , 5 / 4

Next i
.PicG.DrawWidth = 1
For i = 1 To Bsum
.PicG.PSet (Bees(i).X, Bees(i).Y), clr(0, 0)
Next i
End With
End Sub
Public Sub Creator()
Dim i As Long
Randomize
For i = 1 To Hsum
Creathive (i)
Next i
'For i = 1 To Hsum
'Debug.Print Hives(i).X, Hives(i).Y
'Next i
For i = 1 To Bsum
Creatbee (0)
'Debug.Print ibee.X; ibee.Y; Hives(ibee.Hive).X; Hives(ibee.Hive).Y
Next i
For i = 1 To Tsum
CreatTree (i)
Next i
'For i = 1 To Tsum
'Debug.Print FTs(i).X, FTs(i).Y
'Next i
For i = 1 To Fsum
CreatFlower (i)
Next i
End Sub
Public Sub Creathive(i As Integer)
Dim ihive As New Hive
Dim j As Integer
Dim flag As Boolean
ihive.color = clr(2, Int(Rnd * 5))
ihive.iRsum = Int(400 + 200 * Rnd)
ihive.R = Int(160 + Rnd * 70)
 flag = False
    Do While flag = False
       j = 1: flag = True
       ihive.X = 1250 + Rnd * 5000
       ihive.Y = 1250 + Rnd * 5000
       Do While j < i And flag
       If Int(Sqr((ihive.X - Hives(j).X) ^ 2 + (ihive.Y - Hives(j).Y) ^ 2) - 400) > ihive.R + Hives(j).R Then
       j = j + 1
      
       Else
       flag = False
       End If
       Loop
    Loop
ihive.iBsum = 0
Hives.Add ihive
Qbs(i).Hive = i
Qbs(i).X = ihive.X
Qbs(i).Y = ihive.Y
Qbs(i).Alive = True
End Sub
Public Sub Creatbee(i As Long)

Dim ibee As New Bee
ibee.Age = Int(Rnd * 42)
If i = 0 Then
ibee.Hive = Int(Rnd * Hsum + 1)
Else
ibee.Hive = i
End If
Hives(ibee.Hive).iBsum = Hives(ibee.Hive).iBsum + 1
ibee.rate = False
ibee.X = Hives(ibee.Hive).X + Int((2 - 4 * Rnd) * Hives(ibee.Hive).R)
ibee.Y = Hives(ibee.Hive).Y + Int((2 - 4 * Rnd) * (Hives(ibee.Hive).R - 0.25 * (Hives(ibee.Hive).X - ibee.X) ^ 2 / Hives(ibee.Hive).R))
Bees.Add ibee

End Sub
Public Sub CreatTree(i As Integer)
Dim Tr As New FT
Dim j As Integer
Dim flag As Boolean
Tr.color = RGB(60 + Int(Rnd * 60), 60 + Int(Rnd * 61), 60 + Int(Rnd * 62))
Tr.R = Int(110 + Rnd * 179)
Tr.Istree = True
flag = False
    Do While flag = False
       j = 1: flag = True
       Tr.X = 700 + Rnd * 6100
       Tr.Y = 700 + Rnd * 6100
       Do While j <= Hsum And flag
       If Int(Sqr((Tr.X - Hives(j).X) ^ 2 + (Tr.Y - Hives(j).Y) ^ 2) - 200) > Tr.R + 2 * Hives(j).R Then
       j = j + 1
       Else
       flag = False
       End If
       Loop
       j = 1
       Do While j < i And flag
       If Int(Sqr((Tr.X - FTs(j).X) ^ 2 + (Tr.Y - FTs(j).Y) ^ 2) - 150) > Tr.R + FTs(j).R Then
       j = j + 1
       Else
       flag = False
       End If
       Loop
    Loop
FTs.Add Tr
End Sub
Public Sub CreatFlower(i As Long)
Dim Fl As New FT
Dim j As Long
Dim flag As Boolean
Fl.R = Int(12 + Rnd * 18)
Fl.Istree = False
Fl.color = clr(1, Int(Rnd * 5))
Fl.rate = AvyRate * (1.4 - 0.8 * Rnd)
Rsum = Rsum + Fl.rate
flag = False
    Do While flag = False
       j = 1: flag = True
       Fl.X = 500 + Rnd * 6500
       Fl.Y = 500 + Rnd * 6500
       Do While j <= Hsum And flag
       If Int(Sqr((Fl.X - Hives(j).X) ^ 2 + (Fl.Y - Hives(j).Y) ^ 2) - 360) > 3 * Fl.R + 1.5 * Hives(j).R Then
       j = j + 1
       Else
       flag = False
       End If
       Loop
       j = 1
       Do While j <= Tsum And flag
       If Int(Sqr((Fl.X - FTs(j).X) ^ 2 + (Fl.Y - FTs(j).Y) ^ 2) - 60) > 2.5 * Fl.R + FTs(j).R Then
       j = j + 1
       Else
       flag = False
       End If
       Loop
       Do While j < i + Tsum And flag
       If Int(Sqr((Fl.X - FTs(j).X) ^ 2 + (Fl.Y - FTs(j).Y) ^ 2) - 17) > 2.7 * Fl.R + 2.7 * FTs(j).R Then
       j = j + 1
       Else
       flag = False
       End If
       Loop
    Loop
FTs.Add Fl
End Sub