SloGro - Fractal Aggregation

[rdc]

This plots the points in different colors based upon distribution within the data set:

Code:

Option Explicit
'============================================
'Richard Clark
'Simulates aggregation of particles as presented
'Computer Recreations in Scientific American
'rickclark58@yahoo.com
'Public Domain: Feel free to use as you want.
'Speed enhancements by Cha0s. Thanks!
'============================================
'

'misc defines
#Define sw 320
#Define sh 240
#Define numbugs 10000
#Define True 1
#Define False 0

'misc consts
Const fbBlack = Rgb(0, 0, 0)
Const fbWhite = Rgb(255, 255, 255)

'movement directions
Enum compass
north = 1
east
south
west
nwest
neast
swest
seast
End Enum

'screen coord type
Type coordtype
x As Integer
y As Integer
End Type

'bug type
Type bugtype
bcolor As Integer
bcoord As coordtype
frozen As Integer
End Type

'main vars
Randomize Timer
Screen 14, 32
Dim Shared bugs(numbugs) As bugtype
Dim Shared titflag As Integer
Dim skey As String
Dim Shared As Integer Ptr scn
Dim Shared As Integer snx, sny
Dim Shared count As Integer
ScreenInfo snx, sny
scn = ScreenPtr
'get a random number between low and high
Function GetRandom(lowerbound, upperbound As Integer) As Integer

  GetRandom = Int((upperbound - lowerbound + 1) * Rnd + lowerbound)

End Function

'returns a coord based on direction
Function GetCoord(direction As Integer, ccoord As coordtype) As coordtype
                  
                  
  Dim rcoord As coordtype

  Select Case direction

    Case north
      rcoord.x = ccoord.x
      rcoord.y = ccoord.y - 1

    Case east
      rcoord.x = ccoord.x + 1
      rcoord.y = ccoord.y

    Case south
      rcoord.x = ccoord.x
      rcoord.y = ccoord.y + 1

    Case west
      rcoord.x = ccoord.x - 1
      rcoord.y = ccoord.y

    Case nwest
      rcoord.x = ccoord.x - 1
      rcoord.y = ccoord.y - 1

    Case neast
      rcoord.x = ccoord.x + 1
      rcoord.y = ccoord.y - 1

    Case swest
      rcoord.x = ccoord.x - 1
      rcoord.y = ccoord.y + 1

    Case seast
      rcoord.x = ccoord.x + 1
      rcoord.y = ccoord.y + 1

  End Select

  Return rcoord  


End Function

'checks to see if screen is full
Function CheckBugs() As Integer
  Dim As Integer i, j
  Dim As Integer cnt
  Dim ret As Integer = True

  For i = 0 To numbugs - 1
    With bugs(i)
      If .frozen = False Then
        ret = False
        Exit For
      End If
    End With
  Next

  Return ret

End Function

'plot a bug
Sub PlotBug(b As bugtype)
  With b
    'PSet (.bcoord.x, .bcoord.y), .bcolor
    scn [.bcoord.y * snx + .bcoord.x] = .bcolor
  End With
End Sub

'clear screen
Sub ClearScreen
  Color , fbBlack
  Cls
End Sub


'generate intial bugs
Sub GenBugs
  Dim As Integer x, y, i, bcolor

  titflag = False
  WindowTitle "SloGro - Working"
  ClearScreen
  For i = 0 To numbugs - 1
    With bugs(i)
      Do
        'get a random location
        .bcoord.x = GetRandom(0, sw - 1)
        .bcoord.y = GetRandom(0, sh - 1)
      Loop Until scn[.bcoord.x + .bcoord.y * snx] = fbBlack
      'get a random color
      .bcolor = fbWhite
      .frozen = false
      'set the plot
      PlotBug bugs(i)
    End With
  Next
  'plot a colored point in the center
  scn [sw / 2 +  (sh / 2) * snx] = Rgb(GetRandom(1, 254), GetRandom(1, 254), GetRandom(1, 254))
  count = 0
End Sub

'move bugs
Sub MoveBugs
  Dim As Integer i, j, k
  Dim As Integer cdir
  Dim ccoord As coordtype
  
  ScreenLock

  For i = 0 To numbugs - 1
    With bugs(i)
      If .frozen = False Then
        'get a random direction
        cdir = GetRandom(north, seast)
        ccoord = GetCoord(cdir, .bcoord)
        'make sure we don't go off edge
        If ccoord.x > -1 And ccoord.x < sw Then
          If ccoord.y > -1 And ccoord.y < sh Then
            'if bug next to another bug, then freeze
          
            If scn [ccoord.y * snx + ccoord.x] <> fbWhite And scn [ccoord.y * snx + ccoord.x] <> fbBlack Then
              
               count += 1
               If count Mod 50 = 0 Then
                    .bcolor = Rgb(GetRandom(1, 254), GetRandom(1, 254), GetRandom(1, 254))
               Else
                    .bcolor = scn [ccoord.y * snx + ccoord.x]
               End If
               .frozen = True
               PlotBug(bugs(i))
            Else
              'erase old bug
              scn [.bcoord.y * snx + .bcoord.x] = fbBlack
              'draw new bug
              .bcoord.x = ccoord.x
              .bcoord.y = ccoord.y
              PlotBug bugs(i)
            End If
          End If
        End If
      End If
    End With
  Next


  ScreenUnlock

End Sub

SetMouse ,,0

'main code
GenBugs
Do
  skey = Inkey$
  If Not CheckBugs Then
    MoveBugs
  Else
    If Not titflag Then
      WindowTitle "SloGro - Done"
    Else
      titflag = True
    End If
  End If
  If skey = Chr$(32) Then
    GenBugs
  End If
Loop Until skey = Chr$(27)
End