form1.frm

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

'               If flag Then
'               b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
'               b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
'               End If
'        Loop
'      Else
'        flag = True
'        aX = b.X: aY = b.Y
'        Do While flag
'        b.X = aX + (7 - 14 * Rnd)
'        b.Y = aY + (7 - 14 * Rnd)
'        If Sqr((b.Y - Hives(b.Hive).Y) ^ 2 + (b.X - Hives(b.Hive).X) ^ 2) < 2.5 * Hives(b.Hive).R Then flag = False
'        Loop
'      End If
'    End If
'  End If
'End If
For Each b In Bees
 If b.rate = True Then
 '回巢
    hX = Hives(b.Hive).X
    hY = Hives(b.Hive).Y
     If Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2) < Hives(b.Hive).R Then
       b.rate = False
       Hives(b.Hive).iRsum = Hives(b.Hive).iRsum + 1
     Else
       s = Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2)
       aY = b.Y
       aX = b.X
       b.Y = b.Y + (hY - b.Y) * 7 / s
       b.X = b.X + (hX - b.X) * 7 / s
       j = 1: flag = True
        Do While flag
          flag = False
          If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
            Do While j <= Tsum And flag = False
              If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
              j = j + 1
             Loop
               If flag Then
               b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
               b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
               End If
        Loop
     End If
 Else   'b.rate=false
    If b.Age > 21 Then
       '飞去采蜜
      flag = True: i = Tsum + 1: s = 10000
      Do While flag And i <= Fsum + Tsum

      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < FTs(i).R Then flag = False: j = i: Exit Do
      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < s Then s = Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2): j = i

      i = i + 1
      Loop

      If flag Then
      aY = b.Y
      aX = b.X
      b.Y = b.Y + (FTs(j).Y - b.Y) * 7 / s
      b.X = b.X + (FTs(j).X - b.X) * 7 / s
      j = 1: flag = True
         Do While flag
          flag = False
             If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
             Do While j <= Tsum And flag = False
             If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
             j = j + 1
             Loop
             If flag Then
             b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
             b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
             End If
         Loop
      Else
      b.rate = True
      FTs(j).rate = FTs(j).rate - 1
      Rsum = Rsum - 1
         If FTs(j).rate = 0 Then
         FTs.Remove (j)
         Fsum = Fsum - 1
         End If
      End If
    Else  'b.Age<21
      If Hives(b.Hive).iRsum < iLowRate Then
         '飞去采蜜
         flag = True: i = Tsum + 1: s = 10000
         Do While flag And i <= Fsum + Tsum

         If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < FTs(i).R Then flag = False: j = i: Exit Do
         If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < s Then s = Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2): j = i

         i = i + 1
         Loop

         If flag Then
         aY = b.Y
         aX = b.X
         b.Y = b.Y + (FTs(j).Y - b.Y) * 7 / s
         b.X = b.X + (FTs(j).X - b.X) * 7 / s
         j = 1: flag = True
          Do While flag
           flag = False
             If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
             Do While j <= Tsum And flag = False
             If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
             j = j + 1
             Loop
             If flag Then
             b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
             b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
             End If
          Loop
         Else
          b.rate = True
          FTs(j).rate = FTs(j).rate - 1
          Rsum = Rsum - 1
          If FTs(j).rate = 0 Then
            FTs.Remove (j)
            Fsum = Fsum - 1
          End If
         End If
      Else   'Hives(b.Hive).iRsum > iLowRate
        If Sqr((b.Y - Hives(b.Hive).Y) ^ 2 + (b.X - Hives(b.Hive).X) ^ 2) > 1.5 * Hives(b.Hive).R Then
        ' 回巢
          s = Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2)
          aY = b.Y
          aX = b.X
          b.Y = b.Y + (hY - b.Y) * 7 / s
          b.X = b.X + (hX - b.X) * 7 / s
          j = 1: flag = True
          Do While flag
            flag = False
             If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
             Do While j <= Tsum And flag = False
              If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
              j = j + 1
             Loop
               If flag Then
               b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
               b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
               End If
          Loop
        Else
          flag = True
          aX = b.X: aY = b.Y
          Do While flag
          b.X = aX + (7 - 14 * Rnd)
          b.Y = aY + (7 - 14 * Rnd)
           If Sqr((b.Y - Hives(b.Hive).Y) ^ 2 + (b.X - Hives(b.Hive).X) ^ 2) < 2.5 * Hives(b.Hive).R Then flag = False
          Loop
        End If
      End If
    End If
 End If
Next b
If Dadd Then
i = 1
    Do While i <= Bsum
    Bees(i).Age = Bees(i).Age + 1
        If Bees(i).Age >= 42 Then
        Bees.Remove (i)
        Hives(Bees(i).Hive).iBsum = Hives(Bees(i).Hive).iBsum - 1
        Bsum = Bsum - 1
        Else
        i = i + 1
        End If
    Loop
End If
If Ntime.m = 5 Then
    For i = 1 To Hsum
    If Qbs(i).Alive Then
    Hives(i).iRsum = Hives(i).iRsum - Hives(i).iBsum * 0.02
    If Hives(i).iRsum < 0 Then Hives(i).iRsum = 0
    If Hives(i).iRsum = 0 Then
        j = 1
        Do While j <= Bsum
            If Bees(j).Hive = i And Rnd < 0.1 Then
            
            Hives(Bees(j).Hive).iBsum = Hives(Bees(j).Hive).iBsum - 1
            Bees.Remove (j)
            Bsum = Bsum - 1
            Else
            j = j + 1
            End If
        Loop
        If Hives(i).iBsum = 0 Then Qbs(i).Alive = False: Hives(i).color = RGB(0, 0, 0)
    End If
    End If
    Next i
End If
Frmrefresh
'f = f + 1
'If f Mod 10 = 0 Then Debug.Print f, Timer1.Interval, TimeInl
End Sub

'Public Static Sub bhive()
'  hX = Hives(b.Hive).X
'  hY = Hives(b.Hive).Y
'     If Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2) < Hives(b.Hive).R Then
'       b.rate = False
'       Hives(b.Hive).iRsum = Hives(b.Hive).iRsum + 1
'     Else
'       s = Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2)
'       aY = b.Y
'       aX = b.X
'       b.Y = b.Y + (hY - b.Y) * 7 / s
'       b.X = b.X + (hX - b.X) * 7 / s
'       j = 1: flag = True
'        Do While flag
'          flag = False
'          If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
'            Do While j <= Tsum And flag = False
'              If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
'              j = j + 1
'             Loop
'               If flag Then
'               b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
'               b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
'               End If
'        Loop
'     End If
'End Sub

'
'Public Static Sub cpollen()
'Dim flag As Boolean
'Dim i As Integer
'Dim s As Long
'  flag = True: i = Tsum + 1: s = 10000
'      Do While flag And i <= Fsum + Tsum
'
'      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < FTs(i).R Then flag = False: j = i: Exit Do
'      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < s Then s = Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2): j = i
'
'      i = i + 1
'      Loop
'
'      If flag Then
'      aY = b.Y
'      aX = b.X
'      b.Y = b.Y + (FTs(j).Y - b.Y) * 7 / s
'      b.X = b.X + (FTs(j).X - b.X) * 7 / s
'      j = 1: flag = True
'         Do While flag
'          flag = False
'             If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
'             Do While j <= Tsum And flag = False
'             If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
'             j = j + 1
'             Loop
'             If flag Then
'             b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
'             b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
'             End If
'         Loop
'      Else
'      b.rate = True
'      FTs(j).rate = FTs(j).rate - 1
'      Rsum = Rsum - 1
'         If FTs(j).rate = 0 Then
'         FTs.Remove (j)
'         Fsum = Fsum - 1
'         End If
'      End If
'End Sub

'Public Static Sub bmove()
' If b.rate = True Then
'    hX = Hives(b.Hive).X
'    hY = Hives(b.Hive).Y
'   If Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2) < Hives(b.Hive).R Then
'    b.rate = False
'    Hives(b.Hive).iRsum = Hives(b.Hive).iRsum + 1
'   Else
'    s = Sqr((b.Y - hY) ^ 2 + (b.X - hX) ^ 2)
'    aY = b.Y
'    aX = b.X
'    b.Y = b.Y + (hY - b.Y) * 7 / s
'    b.X = b.X + (hX - b.X) * 7 / s
'    j = 1: flag = True
'    Do While flag
'       flag = False
'       If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
'         Do While j <= Tsum And flag = False
'           If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
'           j = j + 1
'          Loop
'            If flag Then
'            b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
'            b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
'            End If
'    Loop
'   End If
' Else
'   flag = True: i = Tsum + 1: s = 10000
'      Do While flag And i <= Fsum + Tsum
'
'      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < FTs(i).R Then flag = False: j = i: Exit Do
'      If Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2) < s Then s = Sqr((FTs(i).X - b.X) ^ 2 + (FTs(i).Y - b.Y) ^ 2): j = i
'
'      i = i + 1
'      Loop
'
'      If flag Then
'      aY = b.Y
'      aX = b.X
'      b.Y = b.Y + (FTs(j).Y - b.Y) * 7 / s
'      b.X = b.X + (FTs(j).X - b.X) * 7 / s
'      j = 1: flag = True
'         Do While flag
'          flag = False
'             If b.X < 0 Or b.X > 7500 Or b.Y < 0 Or b.Y > 7500 Then flag = True
'             Do While j <= Tsum And flag = False
'             If Sqr((FTs(j).X - b.X) ^ 2 + (FTs(j).Y - b.Y) ^ 2) < FTs(j).R + 20 Then flag = True
'             j = j + 1
'             Loop
'             If flag Then
'             b.X = aX + Int(Rnd * 7) * (3750 - b.X) / Abs(3750 - b.X)
'             b.Y = aY + Int(Sqr(49 - (b.X - aX) ^ 2)) * (Round(Rnd) * 2 - 1)
'             End If
'         Loop
'      Else
'      b.rate = True
'      FTs(j).rate = FTs(j).rate - 1
'      Rsum = Rsum - 1
'         If FTs(j).rate = 0 Then
'         FTs.Remove (j)
'         Fsum = Fsum - 1
'         End If
'      End If
' End If
'End Sub
'
'