Tweet
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' Avalanche.bas by Jordi Vallès version 1b 04/04/2008
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Avalanches simulation.
' Game based on a scientific model of Bak, Tang and Wiesenfeldt (1987).
' A board game based in this theory is comercialized by name DisX.
' see: http://theorie.physik.uni-wuerzburg.de/~kinzel/disx.html
'
' Rules:
' - A particle is added to a randomly selected site of a lattice.
' - If a site is occupied by more than three particles, four of them are
' distributed to the neighbor sites. On the boundary or on the corner only
' three or two discs are distributed, respectively.
' - This process (called avalanche) is repeated until all sites have less
' than four particles.
' - Then a new particle is added to the lattice and a possible new avalanche
' starts if a cell reaches 4 particles.
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - Program based on article about an study related with earthquakes and
' avalanches propagation found on "Investigación y Ciencia" January 2008
' and written by J.M.R.Parrondo. This magazine is the spanish edition of
' "Scientific American".
'
' - This program try to be a demonstration of validity of theory explained by
' authors mentioned with the model of self organization criticaly (SOC) of
' avalanches propagation on 2D. This theory is also applicable to some
' polymerization and crystallization behaviours and probably also on other
' chemical and even a neuronal processes.
'
' - After start program wait a "couple of minutes" to see propagation effects
' to neighbors on considerable avalanches. Some avalanches reach to modify
' several thousand cells.
'
' - This implementation usues two boards of 124x124 cells of 4x4 pixels:
' - Left board shows each cell state and help to see how the color is
' changed by one of two reasons:
' 1) randomly a particle is added to a cell
' 2) changed due an avalanche from a neighbor cell
' any of two reasons can create a new avalanche.
' - Right board indicates with colors the scope of each avalanche. In
' few words cells that has been modified due an avalanche.
'
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - Program developed and tested with PowerBASIC for Windows (PB/Win 8.04)
' on a PC HP Pavilion Media Center m7760 with Windows Vista Home Premium.
' - Only PB Graphic package is used to display information generated by program.
' - Minimum screen size needed is 1024x768 pixels.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' SED_PBWIN
#Compile Exe "Avalanche.exe"
#Dim All
#Register None
%COLS = 124 'an square is more representative, 15376 cells
%ROWS = 124
%CELL = 4 'cell size 4x4
%WIDE = %COLS + 2 '126
%HIGH = %ROWS + 2
%GRIDW = %COLS * %CELL '496
%GRIDH = %ROWS * %CELL
%SHF = %GRIDW + 3 '503 used to place the second board
%SHW = %SHF + %CELL 'to avoid a frequent calcul, save time
'window is ((124+124)*4)+4 = 996 pixels wide
$TITLE = "Avalanche 1b"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%TRUE = 1
%FALSE = 0
%ERROR_ALREADY_EXISTS = 183
Type SECURITY_ATTRIBUTES
nLength As Dword
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Declare Function IsWindow Lib "USER32.DLL" Alias "IsWindow" (ByVal hWnd As Dword) As Long
Declare Function CreateMutex Lib "KERNEL32.DLL" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, _
ByVal bInitialOwner As Long, lpName As Asciiz) As Long
Declare Function GetLastError Lib "KERNEL32.DLL" Alias "GetLastError" () As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Declare Sub Avalanche_Board(row As Long, col As Long)
Declare Sub Distribute_Colors()
Declare Sub Prepare_Colors()
Declare Sub Prepare_Graph()
Declare Sub Initial_Board()
Declare Sub Verify_Avalanche()
Declare Sub Add_Particles()
Declare Sub Draw_History()
Global hWin As Dword
Global board() As Long
Global colors() As Long
Global maps() As Long
Global spoints() As Single
Global totalcells As Long
Global maxavalcells As Long
Global curavalcells As Long
Global numadditions As Long
Global numavalanches As Long
Global drawing As Long
Global maxmaps As Long
Global curmaps As Long
Global flag As Long
Global gsleep As Long
Global xx, ww As Long
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function PBMain() As Long
Local w, h, nrw, nrh, ncw, nch,swaval As Long
Local signature As Asciiz * 50
'~~~ only one instance of this program is allowed ~~~
signature = $TITLE + $TITLE + $TITLE
If CreateMutex(ByVal 0, 1, signature) Then
If GetLastError = %ERROR_ALREADY_EXISTS Then Exit Function
End If
nrw = %GRIDW : nrh = %GRIDH
w = (nrw / %CELL) + 2 : h = (nrh / %CELL) + 2
'Board in memory has 126x126 cells, all cells around the board have the value
'of -1 and mark the perimeter of board game. This size simplify the process.
'Really only the inner 124x124 cells are used to be represented on screen.
totalcells = w * h ' board size = 126 x 126 cells
ww = w * %CELL
Prepare_Colors ' create color arrays
ReDim Board(0 To w, 0 To h)
Mat board() = Con(-1) ' all cells to -1, initially
'~~~ prepare graphic window environment ~~~
Desktop Get Client To ncw, nch
'~~~ check the minimum screen size needed
If ncw < 1024 Then
MsgBox "Minimum screen size needed is 1024x768 pixels"
Exit Function
End If
'~~~ create graphic environment
'dialogs are not needed in this program
Graphic Window $TITLE, (ncw-nrw*2)/2, (nch-nrh)/2, (nrw*2)+3, nrh+76 To hWin
Graphic Attach hWin, 0, ReDraw
Graphic Color colors(5), colors(0)
Graphic Clear
'draw lines separator between two boards and info area too
Graphic Box (nrw,0) - (nrw+3, nrh), , maps(23), -1 ' 3 pixels for vertical line
Graphic Box (0, nrh) - ((nrw*2)+3, nrh+2), , maps(23), -1 ' 2 pixels for horizontal line
'prepare graph chart and starts
Prepare_Graph
Graphic ReDraw
'~~~ prepare appropiate initial program environment ~~~
Randomize Timer ' reset the random number generator
Initial_Board ' populate the board to save time
'~~~ starts the game ~~~
Do ''''' main loop
If IsWindow(hWin) = 0 Then Exit Do ' exit gate <========
Add_Particles ' add particles randomly
Distribute_Colors ' convert to colors
Incr curmaps ' select a color for avalanche board
If curmaps = maxmaps+1 Then curmaps = 1 '
swaval = 0 '
Do ' '''' loop meanwhile some cell in red
Verify_Avalanche ' ' (>3 particles)
Distribute_Colors ' '
Sleep gsleep ' ' release time-slice and see nice visual
If flag Then Incr swaval ' ' effects (see Draw_History Sub)
Loop Until flag = %FALSE ' ''''
If swaval Then Incr numavalanches '
If IsFalse drawing Then ' 'drawing' is a switch to avoid display
drawing = %TRUE ' during first loop
Distribute_Colors '
numavalanches = 0 ' reset all counters after initial sowing
numadditions = 0 '
maxavalcells = 0 '
End If '
Draw_History ' maintain information
Loop '''''
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Distribute_Colors()
'Set color appropiate to each cell according number of particles contained.
'The "drawing" switch is set after the first avalanche, see main loop.
'Note: a cell can have more than 4 particles in a moment due an avalanche and
'two preceding neighbors with 3 particles, in any case is a temporary situation.
Local row, col, clr, x As Long
'To avoid redraw the non-changed cells the changed cells have the new value
'ORed with 8 in order to recognize a change. This method saves a lot of time.
For col= 1 To %COLS
For row = 1 To %ROWS
x = board(row, col)
If x => 8 Then ' this cell has been ORed with 8 ?
x = x And 7 ' if yes, then remove the 8 and draw the
board(row, col) = x ' contents with appropriate color
clr = Choose(x+1, colors(0),colors(1),colors(2),colors(3),colors(4),colors(5),colors(6))
Graphic Box ((row-1)*%CELL, (col-1)*%CELL) - _
(((row-1)*%CELL)+%CELL, ((col-1)*%CELL)+%CELL), , clr, -1
End If
Next row
Next col
If drawing Then Graphic ReDraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Add_Particles()
'Add one particle to a cell randomly selected discarding perimeter cells.
Local row, col, x As Long
Do
x = Rnd(1, totalcells +1)
xx = x * %CELL
col = xx Mod %WIDE
row = (xx \ ww)
If board(row, col) => 0 Then 'discard perimeter cells with -1
board(row, col) = (board(row, col) + 1) Or 8 'set new valued ORed with 8
Incr numadditions
Exit Loop
End If
Loop
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Verify_Avalanche()
'Check all cells for 4 or more particles, if yes this cell is set to zero and
'add one, ORed with 8 to neighbors, discarding the cells on outer perimeter.
Local row, col, x As Long
flag = %FALSE ' reset indicator
For col = 1 To %COLS
For row = 1 To %ROWS
x = board(row, col)
x = x And 7
If x > 3 Then ' check if cell is in critical state
board(row, col) = 0 Or 8
Avalanche_Board row, col
flag = %TRUE ' set avalanche indicator
x = board(row-1, col)
If x => 0 Then ' check next door neighbor cell at left
board(row-1, col) = (x+1) Or 8
Avalanche_Board row-1, col
End If
x = board(row+1, col)
If x => 0 Then ' check next door neighbor cell at right
board(row+1, col) = (x+1) Or 8
Avalanche_Board row+1, col
End If
x = board(row, col-1)
If x => 0 Then ' check above floor neighbor cell
board(row, col-1) = (x+1) Or 8
Avalanche_Board row, col-1
End If
x = board(row, col+1)
If x => 0 Then ' check below floor neighbor cell
board(row, col+1) = (x+1) Or 8
Avalanche_Board row, col+1
End If
End If
Next row
Next col
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Avalanche_Board(row As Long, col As Long)
'Mark the secondary board with all movements of cells involved in a avalanche.
'A cell each call from Verify_Avalanche subroutine.
If drawing Then
Graphic Box (((row-1)*%CELL)+%SHF, (col-1)*%CELL) - _
(((row-1)*%CELL)+%SHW, ((col-1)*%CELL)+%CELL),, maps(curmaps), -1
Incr curavalcells
End If
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Initial_Board()
'Populate board with particles a lot, only the inner 124x124 cells are filled.
'Cells with 4 particles are included in order to accelerate process to first
'avalanche that is not visible yet.
'The "drawing" switch is set after the first avalanche (initial sowing).
Local row, col As Long
For col = 1 To %COLS
For row = 1 To %ROWS
board(row, col) = Rnd(1, 4) Or 8 ' all new values ORed with 8
Next row
Next col
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Draw_History()
Local j As Long
Static counter As Long
'Inform about avalanches and cells
If curavalcells = 0 Then Exit Sub
If curavalcells > maxavalcells Then
maxavalcells = curavalcells
Graphic Set Pos (120,502)
Graphic Print maxavalcells ; " cells"
End If
Graphic Set Pos (120,515)
Graphic Print numavalanches
Graphic Set Pos (120,528)
Graphic Print numadditions
'This values can be changed according your preferences and eyes
'First hundreds of avalanches don't have visual interest.
Incr counter
gsleep = Switch(counter > 800, 2, counter > 400, 1) ' dynamic sleep time
Graphic Set Pos (120,554) ' show current sleep time
Graphic Print gsleep ; " mS"
If curavalcells > 10000 Then ' last big avalanche
Graphic Set Pos (120,541) ' (more than 10K cells)
Graphic Print curavalcells ; " cells"
End If
For j = LBound(spoints) To UBound(spoints) - 1 ' shift all values on array
spoints(j) = spoints(j+1) ' removing the oldest
Next j
spoints(UBound(spoints)) = Log10(curavalcells) * 13 ' add new value to array adjusted
' to graphic grid
Graphic Box (600,502) - (864,568),, colors(8), colors(0) ' draw the actual rectangle
For j = 1 To 4 ' draw horizontal lines
Graphic Line (600,502+(j*+13)) - (864,502+(j*+13)), colors(8)
Next j
For j = LBound(spoints) To UBound(spoints) - 1 ' display all values from array
Graphic Line (601+j,567-spoints(j)) - (601+j,567), colors(7)
Next j
curavalcells = 0
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Prepare_Graph()
Local j As Long
ReDim spoints(0 To 262) As Single 'dimensioning graph array
'Fixed text for all information area.
Graphic Font "Arial", 7, 0
Graphic Set Pos (883,505) : Graphic Print "4"
Graphic Set Pos (883,518) : Graphic Print "3"
Graphic Set Pos (883,531) : Graphic Print "2"
Graphic Set Pos (883,544) : Graphic Print "1"
Graphic Set Pos (883,557) : Graphic Print "0"
Graphic Font "Arial", 8, 0
Graphic Set Pos (10,502) : Graphic Print "Max avalanche:"
Graphic Set Pos (10,515) : Graphic Print "Num avalanches:"
Graphic Set Pos (10,528) : Graphic Print "Num additions:"
Graphic Set Pos (10,541) : Graphic Print "Last big avalanche:"
Graphic Set Pos (10,554) : Graphic Print "Sleep time:"
Graphic Set Pos (270,502) : Graphic Print "Lattice: 124x124 cells of 4x4 pixels"
Graphic Set Pos (868,507) : Graphic Print "10"
Graphic Set Pos (868,520) : Graphic Print "10"
Graphic Set Pos (868,533) : Graphic Print "10"
Graphic Set Pos (868,546) : Graphic Print "10"
Graphic Set Pos (868,559) : Graphic Print "10"
Sleep 1 'take a breath.. before redraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Prepare_Colors()
Local j As Long
ReDim colors(9) As Long
'Colors for board cells on first board (on left) and information area.
colors(0) = &h300000 ' almost black used for cells with 0 particles and backgroud
colors(1) = &hAA5500 ' some blue " " " " 1 "
colors(2) = &h00BB00 ' some green " " " " 2 "
colors(3) = &hEEEE00 ' some cyan " " " " 3 "
colors(4) = &h0000EE ' some red " " " " 4 "
colors(5) = &h00FFFF ' yellow " " " " 5 "
colors(6) = &hEE82EE ' violet " " " " 6 "
colors(7) = &h96FF64 ' green light " " display graph data
colors(8) = &h226622 ' green dark " " " " grid
'Array with 96 soft colors to mapping avalanches on second board (on right).
ReDim maps(1 To DataCount) As Long
maxmaps = UBound(maps)
For j = 1 To DataCount
maps(j) = Val(Read$(j))
Next j
'From soft colors chart found on Internet.
Data 16777215, 16777164, 16777113, 16777062, 16764159, 16764108, 16764057, 16764006
Data 16751103, 16751052, 16751001, 16750950, 16711935, 16711884, 16711833, 16711782
Data 13434879, 13434828, 13434777, 13434726, 13421823, 13421772, 13421721, 13421670
Data 13408767, 13408716, 13408665, 13408614, 13395711, 13395660, 13395609, 13395558
Data 10092543, 10092492, 10092441, 10092390, 10079487, 10079436, 10079385, 10079334
Data 10066431, 10066380, 10066329, 10066278, 10053375, 10053324, 10053273, 10053222
Data 6750207, 6750156, 6750105, 6750054, 6737151, 6737100, 6737049, 6736998
Data 6724095, 6724044, 6723993, 6723942, 6711039, 6710988, 6710937, 6710886
Data 3407871, 3407820, 3407769, 3407718, 3394815, 3394764, 3394713, 3394662
Data 3381759, 3381708, 3381657, 3381606, 3368703, 3368652, 3368601, 3368550
Data 65535, 65484, 65433, 65382, 52479, 52428, 52377, 52326
Data 39423, 39372, 39321, 39270, 26367, 26316, 26265, 26214
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
'eof