boid.bas

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

    'add forces
                NewY = NewY + boid.DesireAlignY
                NewX = NewX + boid.DesireAlignX
                
                NewY = NewY + boid.DesireCentreY
                NewX = NewX + boid.DesireCentreX
                
                NewY = NewY + boid.DesireSeparateY
                NewX = NewX + boid.DesireSeparateX
            Else
            
                NewY = boid.Y
                NewX = boid.X
                
                NewY = NewY + boid.DesireAvoidY * 10
                NewX = NewX + boid.DesireAvoidX * 10
              
            End If

            If NewX = boid.X And NewY = boid.Y Then
                'Stop
            Else
            
'add direction
                NewY = NewY + (Sin((boid.direction)) * boid.speed)
                NewX = NewX + (Cos((boid.direction)) * boid.speed)
    
'get new dir
                'If boid.Y - NewY = 0 Then NewY = NewY + 1
                
                If (boid.X - NewX) <> 0 Then
                    NewDir = Abs(Atn((boid.Y - NewY) / (boid.X - NewX)))
                Else
                    NewDir = Atn(90)
                End If
    
'add static turn
                If boid.X > NewX Then
                    If boid.Y > NewY Then
                        NewDir = Abs(NewDir) + PI
                    Else
                        NewDir = PI - Abs(NewDir)
                    End If
                Else
                    If boid.Y > NewY Then
                        NewDir = (PI2) - Abs(NewDir)
                    Else
                        NewDir = Abs(NewDir)
                    End If
                End If
     
'check for max allowed turn
                If boid.direction > NewDir Then
                
                    If (boid.direction - NewDir) > PI Then
                        Diff = ((PI2) - (boid.direction - NewDir))
                        If Diff > MaxTurn Then
                            Diff = MaxTurn
                        End If
                        boid.direction = boid.direction + Diff
                    Else
                        Diff = (boid.direction - NewDir)
                        If Diff > MaxTurn Then
                            Diff = MaxTurn
                        End If
                        boid.direction = boid.direction - Diff
                    End If
                    
                Else
                
                    If (NewDir - boid.direction) > PI Then
                    
                        Diff = ((PI2) - (NewDir - boid.direction))
                        If Diff > MaxTurn Then
                            Diff = MaxTurn
                        End If
                        boid.direction = boid.direction - Diff
                        
                    Else
                        Diff = (NewDir - boid.direction)
                        If Diff > MaxTurn Then
                            Diff = MaxTurn
                        End If
                        boid.direction = boid.direction + Diff
                    End If
                End If
                
                
                If boid.direction > (PI2) Then
                    boid.direction = boid.direction - (PI2)
                End If
                If boid.direction < 0 Then
                    boid.direction = boid.direction + (PI2)
                End If
                            
            End If
            
            boid.NewY = boid.Y + boid.speed * Sin(boid.direction)
            boid.NewX = boid.X + boid.speed * Cos(boid.direction)




'================================================================================
'================================================================================
'================================================================================
'    If boid.CentreDist = 0 Then Stop

        Select Case boid.CentreDist
        Case Is < SensorDist
            If Abs(boid.DesireCentreTurn - boid.direction) > PI Then
                boid.speed = boid.speed - 0.1
                boid.Colour = vbRed
            Else
                boid.speed = boid.speed + 0.1
                boid.Colour = vbGreen
            End If
        Case Is > SensorDist
                boid.speed = boid.speed + 0.1
                boid.Colour = vbGreen
        End Select

'================================================================================
'================================================================================
'================================================================================

        Do
            If boid.direction > (PI2) Then boid.direction = boid.direction - (PI2)
            If boid.direction < 0 Then boid.direction = boid.direction + (PI2)
            
            If boid.speed > 10 Then
                boid.speed = 10
                boid.Colour = &HC000&
            End If
            
            If boid.speed < 5 Then
                boid.speed = 5
                boid.Colour = &H40C0&
            End If
            
        Loop While (boid.direction > (PI2)) Or (boid.direction < 0)

'================================================================================
'================================================================================
'================================================================================

        If Enclosed = False Then
        
            If boid.X < 0 Then boid.X = iWidth
            If boid.X > iWidth Then boid.X = 0
            
            If boid.Y < 0 Then boid.Y = iHeight
            If boid.Y > iHeight Then boid.Y = 0
        
        Else
        
            If boid.X > iWidth Then
                boid.X = iWidth
                Select Case boid.direction
                Case 0 To PI / 2
                    boid.direction = PI - boid.direction
                Case PI + PI / 2 To PI2
                    boid.direction = PI + (PI2 - boid.direction)
                Case Else
                    'Stop
                End Select
            End If
                
            If boid.X < 0 Then
                boid.X = 0
                Select Case boid.direction
                Case PI / 2 To PI
                    boid.direction = PI - boid.direction
                Case PI To PI + PI / 2
                    boid.direction = PI2 - (boid.direction - PI)
                Case Else
                    'Stop
                End Select
            End If
                
            If boid.Y > iHeight Then
                boid.Y = iHeight
                Select Case boid.direction
                Case PI / 2 To PI
                    boid.direction = PI + (PI - boid.direction)
                Case 0 To PI
                    boid.direction = PI2 - boid.direction
                Case Else
                    'Stop
                End Select
            End If
                
            If boid.Y < 0 Then
                boid.Y = 0
                Select Case boid.direction
                Case PI To PI + PI / 2
                    boid.direction = PI - (boid.direction - PI)
                Case PI + PI / 2 To PI2
                    boid.direction = PI2 - boid.direction
                Case Else
                    'Stop
                End Select
            End If
        End If
        
'================================================================================
'================================================================================
'================================================================================

Next
    
End Sub

Sub RandDir(flock As Collection)
Dim boid As BoidClass

    For Each boid In flock
        boid.direction = Rnd * 360
    Next
    
End Sub

Function SegCirInt(X1 As Integer, Y1 As Integer, X2 As Integer, Y2 As Integer, X3 As Integer, Y3 As Integer, r As Integer) As Single
Dim a As Double
Dim b As Double
Dim intClosestPointX As Double
Dim intClosestPointY As Double
Dim cpDist As Single
Dim result As Double
Dim lngX1 As Long
Dim lngX2 As Long
Dim lngX3 As Long
Dim lngY1 As Long
Dim lngY2 As Long
Dim lngY3 As Long


    lngX1 = X1
    lngX2 = X2
    lngX3 = X3
    lngY1 = Y1
    lngY2 = Y2
    lngY3 = Y3
    
'check if closest point of line to centre of the object is less than the radius
'of the object

    a = (lngX3 - lngX1) * (lngX2 - lngX1) + (lngY3 - lngY1) * (lngY2 - lngY1)
    b = (lngX2 - lngX1) * (lngX2 - lngX1) + (lngY2 - lngY1) * (lngY2 - lngY1)
    
    result = a / b
    
    If (result > 0) And (result < 1) Then
    'closest point is between the start and end points of the line
    'so now check the distance to the centre of the object
    
        intClosestPointX = X1 + (X2 - X1) * result
        intClosestPointY = Y1 + (Y2 - Y1) * result
        
        cpDist = Sqr(((intClosestPointX - X3) * (intClosestPointX - X3)) + ((intClosestPointY - Y3) * (intClosestPointY - Y3)))
        If cpDist < r Then
            SegCirInt = cpDist
        Else
            SegCirInt = 0
        End If
    Else
    'closest point is outside the start and end points
    'Now check if either end of the line is inside the circle
    
        'check end of line
        cpDist = Sqr((lngX2 - lngX3) * (lngX2 - lngX3) + (lngY2 - lngY3) * (lngY2 - lngY3))
        If cpDist < r Then
            SegCirInt = cpDist
        Else
            'check  start of line
            cpDist = Sqr((lngX1 - lngX3) * (lngX1 - lngX3) + (lngY1 - lngY3) * (lngY1 - lngY3))
            If cpDist < r Then
                SegCirInt = cpDist
            Else
                SegCirInt = 0
            End If
        End If
        
    End If
    
    
End Function

Function LineCirInt(X1, Y1, X2, Y2, X3, Y3, r) As Boolean
Dim a As Long
Dim b As Long
Dim c As Double
Dim result As Long

    a = ((X2 - X1) * (X2 - X1)) + ((Y2 - Y1) * (Y2 - Y1))
    b = 2 * ((X2 - X1) * (X1 - X3) + (Y2 - Y1) * (Y1 - Y3))
    c = (X3 * X3) + (Y3 * Y3) + (X1 * X1) + (Y1 * Y1) - 2 * (X3 * X1 + Y3 * Y1) - (r * r)
    
    result = (b * b) - 4 * a * c
    
    If result > 0 Then
        LineCirInt = True
    Else
        LineCirInt = False
    End If
    
    
End Function