08-17-2005, 01:47 AM
I pulled out my old Scientific American Computer Recreations book and found this: a fractal aggregation program. It takes a while to run depending on your computer speed, but it creates some neat looking patterns using a totally random algo.
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.
'============================================
'
'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
'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
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 Point(.bcoord.x, .bcoord.y) = 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
PSet (sw / 2, sh / 2), Rgb(GetRandom(100, 255), GetRandom(100, 255), GetRandom(100, 255))
End Sub
'move bugs
Sub MoveBugs
Dim As Integer i, j, k
Dim As Integer cdir
Dim ccoord As coordtype
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 Point(ccoord.x, ccoord.y) <> fbWhite And _
Point(ccoord.x, ccoord.y) <> fbBlack Then
.bcolor = Point(ccoord.x, ccoord.y)
.frozen = True
PlotBug(bugs(i))
Else
'erase old bug
PSet (.bcoord.x, .bcoord.y), 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
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