frmflock.frm

牧羊人的算法的实现

VERSION 5.00
Begin VB.Form frmFlock 
   BackColor       =   &H00000000&
   Caption         =   "Flocking - Arrow keys move the flock"
   ClientHeight    =   5100
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6300
   LinkTopic       =   "Form1"
   ScaleHeight     =   340
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   420
   StartUpPosition =   3  'Windows Default
End
Attribute VB_Name = "frmFlock"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*****************************************************
' Basic Flocking Tutorial. Fiddle with the constants
' below to alter the behaviour of the sheep. Also
' notice how they behave when they fall over the edge
' of the form: They freak out because they're suddenly
' so far away from the flock! Cool :)
'
' As always, feel free to use this code, modify it,
' steal it, whatever! Lucky don't care.
'
' - Lucky
' Lucky's VB Gaming Site
' http://members.home.net/theluckyleper
'*****************************************************

Option Explicit

'Need to declare the timer so we can control the frame rate
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Type SHEEPTYPE
    sngX As Single      'Where is this sheep?
    sngY As Single
    sngXSpeed As Single 'How fast did it last move?
    sngYSpeed As Single
End Type
Dim mudtSheep() As SHEEPTYPE

Dim mintFollowX As Integer  'Where is the flock moving?
Dim mintFollowY As Integer

Dim mlngTimer As Long       'Timer for FPS maintenance
Dim mblnRunning As Boolean  'Render loop control variable

Const MS_PER_FRAME = 25     'How many milliseconds per frame of animation?
Const NUM_SHEEP = 19        'How many sheep will we use?
Const MAX_SPEED_VARIANCE = 0.001    'How fast can a sheep 'accelerate' w.r.t. his neighbour?
Const MIN_SPEED = 0.005     'Min sheep velocity!
Const MAX_SPEED = 0.01      'Max sheep velocity!
Const MIN_SEPERATION = 15   'Minimum distance between neighbouring sheep
Const MAX_NOISE = 250       'Adds a little "jiggle" for realism
Const FOLLOW_AMOUNT = 100   'Speed with which flock will move when arrow keys are pressed

Const CIRCLE_RADIUS = 5     'Size of the circle that represents our sheep

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

    'Move the flock around!
    If KeyCode = vbKeyDown Then mintFollowY = mintFollowY + FOLLOW_AMOUNT
    If KeyCode = vbKeyUp Then mintFollowY = mintFollowY - FOLLOW_AMOUNT
    If KeyCode = vbKeyLeft Then mintFollowX = mintFollowX - FOLLOW_AMOUNT
    If KeyCode = vbKeyRight Then mintFollowX = mintFollowX + FOLLOW_AMOUNT

End Sub

Private Sub Form_Load()

Dim i As Integer
Dim j As Integer
Dim blnSeperation As Boolean

    'Initialize the array
    ReDim mudtSheep(NUM_SHEEP - 1)
    
    'Randomize the locations
    Randomize
    For i = 0 To UBound(mudtSheep)
        blnSeperation = False
        Do While Not (blnSeperation)
            'Try a spot
            mudtSheep(i).sngX = Rnd() * frmFlock.ScaleWidth
            mudtSheep(i).sngY = Rnd() * frmFlock.ScaleHeight
            'Ensure that it's not too close to a pre-existing sheep
            blnSeperation = True
            For j = 0 To i - 1
                If CalcDist(i, j) <= MIN_SEPERATION Then
                    blnSeperation = False
                    Exit For
                End If
            Next j
        Loop
    Next i

    'Show the form
    Me.Show
    
    'Start the main loop
    mblnRunning = True
    Do While mblnRunning
        'Maintain the FPS
        If mlngTimer + MS_PER_FRAME <= GetTickCount() Then
            'Reset the timer
            mlngTimer = GetTickCount()
            'Run the flocking AI
            Flocking_AI
            'Display the sheep
            Display_Sheep
        End If
        'Let windows have a go
        DoEvents
    Loop

End Sub

Private Sub Flocking_AI()

Dim i As Integer
Dim j As Integer
Dim sngDist As Single
Dim sngXSpeed As Single
Dim sngYSpeed As Single
Dim sngXSum As Single
Dim sngYSum As Single
Dim sngXAvg As Single
Dim sngYAvg As Single
Dim sngXDist As Single
Dim sngYDist As Single
Dim sngTmpX As Single
Dim sngTmpY As Single

    'Step through each sheep...
    For i = 0 To UBound(mudtSheep)
        
        'Find speed of nearest neighbour
        sngDist = 0
        For j = 0 To UBound(mudtSheep)
            'Skip the current sheep!
            If j <> i Then
                'Compare this sheep's distance to the closest one so far
                If (sngDist = 0) Or CalcDist(i, j) < sngDist Then
                    'If this sheep is closer, store the distance
                    sngDist = CalcDist(i, j)
                    'And store the speed
                    sngXSpeed = mudtSheep(j).sngXSpeed
                    sngYSpeed = mudtSheep(j).sngYSpeed
                End If
            End If
        Next j
        
        'Let our sheep move as fast as possible
        mudtSheep(i).sngXSpeed = sngXSpeed + MAX_SPEED_VARIANCE
        mudtSheep(i).sngYSpeed = sngYSpeed + MAX_SPEED_VARIANCE
        If mudtSheep(i).sngXSpeed < MIN_SPEED Then mudtSheep(i).sngXSpeed = MIN_SPEED
        If mudtSheep(i).sngYSpeed < MIN_SPEED Then mudtSheep(i).sngYSpeed = MIN_SPEED
        If mudtSheep(i).sngXSpeed > MAX_SPEED Then mudtSheep(i).sngXSpeed = MAX_SPEED
        If mudtSheep(i).sngYSpeed > MAX_SPEED Then mudtSheep(i).sngYSpeed = MAX_SPEED
        
        'Find the center of the flock
        sngXSum = 0
        sngYSum = 0
        For j = 0 To UBound(mudtSheep)
            'Add up all of the values
            sngXSum = sngXSum + mudtSheep(j).sngX
            sngYSum = sngYSum + mudtSheep(j).sngY
        Next j
        'Average the values (and add some positive or negative noise and the "follow" amount)
        sngXAvg = (sngXSum / NUM_SHEEP) + (Rnd() * MAX_NOISE) - (MAX_NOISE / 2) + mintFollowX
        sngYAvg = (sngYSum / NUM_SHEEP) + (Rnd() * MAX_NOISE) - (MAX_NOISE / 2) + mintFollowY
        
        'Move towards the center! (as fast as allowable)
        sngTmpX = mudtSheep(i).sngX
        sngTmpY = mudtSheep(i).sngY
        'Determine the X and Y movement amounts
        sngXDist = sngXAvg - mudtSheep(i).sngX
        sngYDist = sngYAvg - mudtSheep(i).sngY
        'Move the X and Y coords
        mudtSheep(i).sngX = mudtSheep(i).sngX + sngXDist * mudtSheep(i).sngXSpeed
        mudtSheep(i).sngY = mudtSheep(i).sngY + sngYDist * mudtSheep(i).sngYSpeed
        'Test for seperation
        For j = 0 To UBound(mudtSheep)
            If (i <> j) And (CalcDist(i, j) <= MIN_SEPERATION) Then
                'There's another sheep too close, don't move
                mudtSheep(i).sngX = sngTmpX
                mudtSheep(i).sngY = sngTmpY
                Exit For
            End If
        Next j
        
        'Wrap the sheep at the edges of the window
        If mudtSheep(i).sngX > frmFlock.ScaleWidth Then mudtSheep(i).sngX = mudtSheep(i).sngX - frmFlock.ScaleWidth
        If mudtSheep(i).sngX < 0 Then mudtSheep(i).sngX = mudtSheep(i).sngX + frmFlock.ScaleWidth
        If mudtSheep(i).sngY > frmFlock.ScaleHeight Then mudtSheep(i).sngY = mudtSheep(i).sngY - frmFlock.ScaleHeight
        If mudtSheep(i).sngY < 0 Then mudtSheep(i).sngY = mudtSheep(i).sngY + frmFlock.ScaleHeight
        
    Next i

End Sub

Private Function CalcDist(intIndex1 As Integer, intIndex2 As Integer) As Single

    'How far appart are the two sheep that have been indicated?
    CalcDist = Sqr((mudtSheep(intIndex1).sngX - mudtSheep(intIndex2).sngX) ^ 2 + (mudtSheep(intIndex1).sngY - mudtSheep(intIndex2).sngY) ^ 2)

End Function

Private Sub Display_Sheep()

Dim i As Integer

    'Draw our beautiful flock!
    frmFlock.Cls
    For i = 0 To UBound(mudtSheep)
        Circle (mudtSheep(i).sngX, mudtSheep(i).sngY), CIRCLE_RADIUS, vbWhite
    Next i

End Sub


Private Sub Form_Unload(Cancel As Integer)

    'Stop the render loop
    mblnRunning = False

End Sub