boid.bas

制作这个程序的目的是因为我见过了该程序的相关c、c++、delphi、java版本

Attribute VB_Name = "Module1"
Option Explicit
Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long

Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020         ' (DWORD) dest = source
Public Const SRCINVERT = &H660046       ' (DWORD) dest = source XOR dest
Public Const SRCPAINT = &HEE0086        ' (DWORD) dest = source OR dest
Public Const SRCAND = &H8800C6          ' (DWORD) dest = source AND dest

Public Const PI = 3.1415926
Public Const PI2 = 3.1415926 * 2

Public flock As New Collection
Public objects As New Collection

Public Sub AddBoid(flock As Collection, X As Integer, Y As Integer, ByVal Dir As Integer, Bcol As Long)
'helper function to add Boid to the specified collection (flock)
Dim Colour As Integer
Dim boid As BoidClass
Set boid = New BoidClass

    boid.X = X
    boid.Y = Y
    
    boid.Colour = Bcol
    boid.id = flock.Count
    
    boid.direction = Dir
    boid.speed = 10
    
    flock.Add boid
    Set boid = Nothing
End Sub

Public Sub AddObstacle(objects As Collection, X As Integer, Y As Integer, ByVal Radius As Integer)
Dim obs As ObstacleClass
Set obs = New ObstacleClass

    obs.X = X
    obs.Y = Y
    
    obs.id = objects.Count
    
    obs.Radius = Radius
    
    objects.Add obs
    Set obs = Nothing
    
End Sub

Sub DrawBoid(flock As Collection, Canvas As PictureBox, ShowColours As Boolean, ShowArrow As Boolean, ShowCircle As Boolean)
Dim boid As BoidClass
Dim d As Integer
Dim u%
Dim NewX As Integer
Dim NewY As Integer

Dim XDist As Integer
Dim YDist As Integer

Dim AHx As Integer
Dim AHy As Integer
Dim Theta As Integer
Dim Bcol As Long

    For Each boid In flock

        Theta = boid.direction
        
        If ShowColours = True Then
            Bcol = boid.Colour
        Else
            Bcol = vbBlack
        End If
        
        boid.NewY = boid.Y + (10 * Sin(boid.direction))
        boid.NewX = boid.X + (10 * Cos(boid.direction))
        
        Canvas.Line (boid.X, boid.Y)-(boid.NewX, boid.NewY), Bcol
        
        If ShowCircle Then
            Canvas.Circle (boid.X, boid.Y), 5, Bcol
        End If
        
    'arrow head
        If ShowArrow Then
            AHx = 5 * Cos((Theta + 45))
            AHy = 5 * Sin((Theta + 45))
            Canvas.Line (boid.NewX, boid.NewY)-(boid.NewX - AHx, boid.NewY - AHy), Bcol
            AHx = 5 * Cos((Theta - 45))
            AHy = 5 * Sin((Theta - 45))
            Canvas.Line (boid.NewX, boid.NewY)-(boid.NewX - AHx, boid.NewY - AHy), Bcol
        End If
        
    Next
    Set boid = Nothing


End Sub

Sub DrawObjects(objects As Collection, Canvas As PictureBox)
Dim obs As ObstacleClass
    
    For Each obs In objects

        Canvas.Circle (obs.X, obs.Y), obs.Radius
        
    Next
    Set obs = Nothing


End Sub

Sub DrawForces(flock As Collection, Canvas As PictureBox, SensorDist As Integer, ViewTheta As Single, ShowCentre As Boolean, ShowSep As Boolean, ShowAlign As Boolean, ShowSensor As Boolean, ShowBox As Boolean)
Dim boid As BoidClass
Dim d As Integer
Dim u%

Dim tmpX1 As Integer
Dim tmpY1 As Integer
Dim tmpX2 As Integer
Dim tmpY2 As Integer
Dim tmpX3 As Integer
Dim tmpY3 As Integer
Dim tmpX4 As Integer
Dim tmpY4 As Integer

Dim tmpStart As Single
Dim tmpEnd As Single
Dim HalfTheta As Single

    HalfTheta = ViewTheta / 2
    For Each boid In flock

            If ShowSensor Then
            
                tmpX1 = boid.X + (SensorDist * Cos(boid.direction + HalfTheta))
                tmpY1 = boid.Y + (SensorDist * Sin(boid.direction + HalfTheta))
                tmpX2 = boid.X + (SensorDist * Cos(boid.direction - HalfTheta))
                tmpY2 = boid.Y + (SensorDist * Sin(boid.direction - HalfTheta))
                
                tmpStart = PI2 - (boid.direction + HalfTheta)
                tmpEnd = PI2 - (boid.direction - HalfTheta)
                   
                'Debug.Print tmpStart, tmpEnd
                
                If tmpStart > PI2 Then
                    tmpStart = tmpStart - PI2
                End If
                If tmpStart < 0 Then
                    tmpStart = tmpStart + PI2
                End If
                
                If tmpEnd > PI2 Then
                    tmpEnd = tmpEnd - PI2
                End If
                If tmpEnd < 0 Then
                    tmpEnd = tmpEnd + PI2
                End If
            
                Canvas.Circle (boid.X, boid.Y), SensorDist, vbBlack, tmpStart, tmpEnd
                Canvas.Line (boid.X, boid.Y)-(tmpX1, tmpY1), vbBlack
                Canvas.Line (boid.X, boid.Y)-(tmpX2, tmpY2), vbBlack
                
            End If

            If ShowCentre Then
                Canvas.Line (boid.X, boid.Y)-(boid.X + boid.DesireCentreX * 10, boid.Y + boid.DesireCentreY * 10), vbGreen
            End If
            
            If ShowAlign Then
                Canvas.Line (boid.X, boid.Y)-(boid.X + boid.DesireAlignX * 10, boid.Y + boid.DesireAlignY * 10), vbMagenta
            End If
            
            If ShowSep Then
                Canvas.Line (boid.X, boid.Y)-(boid.X + boid.DesireSeparateX * 10, boid.Y + boid.DesireSeparateY * 10), vbBlue
            End If


'show box used for collision detection

            If ShowBox Then
            'box to the right
                tmpX1 = boid.X + (5 * Cos(boid.direction + PI / 2))
                tmpY1 = boid.Y + (5 * Sin(boid.direction + PI / 2))
                tmpX2 = tmpX1 + (SensorDist * Cos(boid.direction))
                tmpY2 = tmpY1 + (SensorDist * Sin(boid.direction))
    
                If boid.DesireAvoidRight = False Then
                    Canvas.Line (boid.X, boid.Y)-(tmpX1, tmpY1), vbScrollBars
                    Canvas.Line (tmpX1, tmpY1)-(tmpX2, tmpY2), vbScrollBars
                Else
                    Canvas.Line (boid.X, boid.Y)-(tmpX1, tmpY1), vbRed
                    Canvas.Line (tmpX1, tmpY1)-(tmpX2, tmpY2), vbRed
                End If
                
            'box to the left
                tmpX3 = boid.X - (5 * Cos(boid.direction + PI / 2))
                tmpY3 = boid.Y - (5 * Sin(boid.direction + PI / 2))
                tmpX4 = tmpX3 + (SensorDist * Cos(boid.direction))
                tmpY4 = tmpY3 + (SensorDist * Sin(boid.direction))

                If boid.DesireAvoidLeft = False Then
                    Canvas.Line (boid.X, boid.Y)-(tmpX3, tmpY3), vbScrollBars
                    Canvas.Line (tmpX3, tmpY3)-(tmpX4, tmpY4), vbScrollBars
                Else
                    Canvas.Line (boid.X, boid.Y)-(tmpX3, tmpY3), vbRed
                    Canvas.Line (tmpX3, tmpY3)-(tmpX4, tmpY4), vbRed
                End If
                
            'complete box
                Canvas.Line (tmpX2, tmpY2)-(tmpX4, tmpY4), vbScrollBars
            End If
            
    Next
    Set boid = Nothing

End Sub

Public Sub CalcForces(flock As Collection, CentMult As Integer, SepMult As Integer, AliMult As Integer, SensorDist As Integer, ViewTheta As Single)
    
    Dim distance As Integer
    Dim i%
    Dim AveDir As Single
    Dim AveX As Integer
    Dim AveY As Integer
    Dim AveSpeed As Single
    
    Dim boid As BoidClass
    Dim obs As ObstacleClass
    
    Dim otherBoid As BoidClass
        
    Dim ClosestBoid As BoidClass
    
    Dim iLeaderX As Integer
    Dim iLeaderY As Integer
    
    Dim CloseBoidCount As Integer
    Dim GroupCount As Integer
    'Dim CloseBoidCount As Integer
    
    Dim AllDirChange As Single
'    Dim SensorDist As Integer
    
    Dim ClosestDist As Single
    Dim TmpDist As Single
    Dim TooClose As Boolean
    
    Dim TmpWeight As Double
    
    Dim AngDiff As Single
    Dim Angle As Single
    Dim HalfTheta As Single
    
    Dim blnResult As Boolean
    
    Dim X1 As Integer
    Dim Y1 As Integer
    Dim X2 As Integer
    Dim Y2 As Integer
    
    Dim LeftDist As Single
    Dim RightDist As Single
    
'================================================================================
'================================================================================
'================================================================================
    
    'SensorDist = 50
    
    HalfTheta = ViewTheta / 2
    
    AllDirChange = 0
    For Each boid In flock

        ClosestDist = SensorDist * 2
        boid.ClosestDist = 0
        TmpDist = 1000

        boid.AveX = boid.X
        boid.AveY = boid.Y
        boid.AveDir = boid.direction
        boid.AveSpeed = boid.speed
        boid.CentreDist = ClosestDist
        boid.DesireAvoidX = 0
        boid.DesireAvoidY = 0
        boid.DesireAvoidWeight = 0
        boid.DesireAvoidRight = False
        boid.DesireAvoidLeft = False
        CloseBoidCount = 1

        'Get Average information from flockmates in sensor range
        For Each otherBoid In flock

            If boid.id <> otherBoid.id Then 'as long as it's not itself

                distance = Abs(1 + Sqr((boid.X - otherBoid.X) ^ 2 + (boid.Y - otherBoid.Y) ^ 2))
                
                If (boid.X - otherBoid.X) <> 0 Then
                    Angle = Abs(Atn((boid.Y - otherBoid.Y) / (boid.X - otherBoid.X)))
                Else
                    Angle = Abs(Atn(90))
                End If
                
                If boid.X > otherBoid.X Then
                    If boid.Y > otherBoid.Y Then
                        Angle = Angle + PI
                    Else
                        Angle = PI - Angle
                    End If