View Full Version : Sand Falling (cellular Automata)
this is simulating the following sand example with some logical errors, it is based on an old code in
https://www.purebasic.fr/english/viewtopic.php?f=12&t=12215
and it is cheating since it is using 2 screens (screen output, and sprite). the screen output is refresh by FlipBuffers() which seems does not affect the sprites.
here i use only a canvas and i'm obligated to use zero the the color of 3 points before the current point in lines 56 to 58. comment it and the sand flow will be lines.
i think the idea is from the cellular automata in which the state of every cell is defined by the cell neighbors, it is hard or impossible to predict the output after some iterations of some initial pattern and rules
there are too many ways to simulate the C.A but i find the PB example is handy to use albeit some errors
Uses "UI"
Begin Const
%ID_Canvas1
%tTimer
End Const
Global numar, samba, pichi, fcolor, frontColor As Long
numar = 200
Type part
x As Long
y As Long
sopas As Byte
End Type
Dim sand(numar) As part
Dim n As Long
For n=1 To numar
sand(n).x=5+Rnd(0,789)
sand(n).y=Rnd(0,200)
Next
Dim hDlg As DWord
Function TBMain()
Dialog New Pixels ,0, "Sand Show ",0,0, 800, 600, %WS_POPUP Or %WS_VISIBLE Or %WS_CAPTION Or %WS_SYSMENU Or %WS_MINIMIZEBOX To hDlg
Control Add Canvas, hDlg, %ID_Canvas1, "", 0, 0, 800, 600, %SS_NOTIFY
Canvas_Attach hDlg, %ID_Canvas1, %TRUE
Canvas_Clear %BLACK
Dialog Show Modal hDlg, Call dlgProc
End Function
CallBack Function dlgProc()
Select Case CBMSG
Case %WM_INITDIALOG
Dialog Set Timer CBHNDL, %tTimer, 5, 0
Canvas_Width(10)
Canvas_Line((280,100),(650,450),Rgb(0,155,20) )
Canvas_Line((0,570),(800,570),Rgb(0,155,20) )
Canvas_Ellipse(100, 300, 200, 400, Rgb(0,155,20),Rgb(0,155,20))
Canvas_Ellipse(100, 125, 200, 325, Rgb(0,0,0),Rgb(0,0,0))
Case %WM_TIMER
SandShow() 'call the sand procedure
Case %WM_CLOSE
Dialog Kill Timer CBHNDL, %tTimer
End Select
End Function
Sub SandShow()
frontColor = Rgb(255,255,0)
For n=1 To numar
'Canvas_SetPixel( [STEP] x1, y1 [, rgbColor])
Canvas_SetPixel(sand(n).x,sand(n).y, frontColor)
Canvas_SetPixel(sand(n).x,sand(n).y-1, Rgb(0,0,0))
Canvas_SetPixel(sand(n).x,sand(n).y-2, Rgb(0,0,0))
Canvas_SetPixel(sand(n).x,sand(n).y-3, Rgb(0,0,0))
If Canvas_GetPixel(sand(n).x,sand(n).y+1)=0 Then
sand(n).y=sand(n).y+1
Else
samba=0
If Canvas_GetPixel(sand(n).x-1,sand(n).y+1)<>0 Then
samba=samba+2
End If
If Canvas_GetPixel(sand(n).x+1,sand(n).y+1)<>0 Then
samba=samba+4
End If
If Canvas_GetPixel(sand(n).x-2,sand(n).y+1)<>0 Then
samba=samba+8
End If
If Canvas_GetPixel(sand(n).x+2,sand(n).y+1)<>0 Then
samba=samba+16
End If
Select Case samba
Case 0
If Rnd(0,1) Then
sand(n).x=sand(n).x+1
Else
sand(n).x=sand(n).x-1
End If
Case 2
sand(n).x=sand(n).x+1
Case 4
sand(n).x=sand(n).x-1
Case 6
If Rnd(0,1) Then
sand(n).x=sand(n).x+1
Else
sand(n).x=sand(n).x-1
End If
Case 8
sand(n).x=sand(n).x+1
Case 10
sand(n).x=sand(n).x+1
Case 14
sand(n).x=sand(n).x+1
Case 16
sand(n).x=sand(n).x-1
Case 20
sand(n).x=sand(n).x-1
Case 22
sand(n).x=sand(n).x-1
Case 26
sand(n).x=sand(n).x+1
Case 28
sand(n).x=sand(n).x-1
Case 30
sand(n).sopas=1
End Select
'Canvas_Redraw
End If
'Canvas_Redraw
Next
'===========================================================
'Canvas_Redraw
For n=1 To numar
If sand(n).sopas Then
'pichi=Rnd(0,55)+200
'FrontColor(Rgb(pichi,pichi,0))
'FrontColor= Rgb(pichi,pichi,0)
FrontColor= Rgb(255,255,0)
Canvas_SetPixel(sand(n).x,sand(n).y, FrontColor )
sand(n).x=5+Rnd(0,789)
sand(n).y=0
sand(n).sopas=0
End If
Next
Canvas_Redraw
End Sub
DirectuX
19-01-2020, 21:05
Hi Primo,
did you intentionally split the code in two for/next loops as it runs well in a single loop ?
Petr Schreiber
19-01-2020, 21:47
Primo,
this looks superb and runs so smooth :o
Petr
Hi DirectuX
without the second loop which begins from line 151 to 165, the sand fall will stop after a few seconds so i think the second loop is working as a charger .
in fact i don't understand the code exactly and have some fuzzy understanding about it, it is like predicting the weather for the next month
DirectuX
19-01-2020, 22:25
Primo,
this code with a single for/next block works well for me:
Uses "UI"
Begin Const
%ID_Canvas1
%tTimer
End Const
Global numar, samba, pichi, fcolor, frontColor As Long
numar = 2000
Type part
x As Long
y As Long
sopas As Byte
End Type
Dim sand(numar) As part
Dim n As Long
For n=1 To numar
sand(n).x=5+Rnd(0,789)
sand(n).y=Rnd(0,200)
Next
Dim hDlg As DWord
Function TBMain()
Dialog New Pixels ,0, "Sand Show ",0,0, 800, 600, %WS_POPUP Or %WS_VISIBLE Or %WS_CAPTION Or %WS_SYSMENU Or %WS_MINIMIZEBOX To hDlg
Control Add Canvas, hDlg, %ID_Canvas1, "", 0, 0, 800, 600, %SS_NOTIFY
Canvas_Attach hDlg, %ID_Canvas1, %TRUE
Canvas_Clear %BLACK
Dialog Show Modal hDlg, Call dlgProc
End Function
CallBack Function dlgProc()
Select Case CBMSG
Case %WM_INITDIALOG
Dialog Set Timer CBHNDL, %tTimer, 0, 0
Canvas_Width(10)
Canvas_Line((280,100),(650,450),Rgb(0,155,20) )
Canvas_Line((0,570),(800,570),Rgb(0,155,20) )
Canvas_Ellipse(100, 300, 200, 400, Rgb(0,155,20),Rgb(0,155,20))
Canvas_Ellipse(100, 125, 200, 325, Rgb(0,0,0),Rgb(0,0,0))
Case %WM_TIMER
SandShow() 'call the sand procedure
Case %WM_CLOSE
Dialog Kill Timer CBHNDL, %tTimer
End Select
End Function
Sub SandShow()
frontColor = Rgb(255,255,0)
For n=1 To numar
'Canvas_SetPixel( [STEP] x1, y1 [, rgbColor])
Canvas_SetPixel(sand(n).x,sand(n).y, frontColor)
Canvas_SetPixel(sand(n).x,sand(n).y-1, Rgb(0,0,0))
Canvas_SetPixel(sand(n).x,sand(n).y-2, Rgb(0,0,0))
Canvas_SetPixel(sand(n).x,sand(n).y-3, Rgb(0,0,0))
If Canvas_GetPixel(sand(n).x,sand(n).y+1)=0 Then
sand(n).y=sand(n).y+1
Else
samba=0
If Canvas_GetPixel(sand(n).x-1,sand(n).y+1)<>0 Then
samba=samba+2
End If
If Canvas_GetPixel(sand(n).x+1,sand(n).y+1)<>0 Then
samba=samba+4
End If
If Canvas_GetPixel(sand(n).x-2,sand(n).y+1)<>0 Then
samba=samba+8
End If
If Canvas_GetPixel(sand(n).x+2,sand(n).y+1)<>0 Then
samba=samba+16
End If
Select Case samba
Case 0
If Rnd(0,1) Then
sand(n).x=sand(n).x+1
Else
sand(n).x=sand(n).x-1
End If
Case 2
sand(n).x=sand(n).x+1
Case 4
sand(n).x=sand(n).x-1
Case 6
If Rnd(0,1) Then
sand(n).x=sand(n).x+1
Else
sand(n).x=sand(n).x-1
End If
Case 8
sand(n).x=sand(n).x+1
Case 10
sand(n).x=sand(n).x+1
Case 14
sand(n).x=sand(n).x+1
Case 16
sand(n).x=sand(n).x-1
Case 20
sand(n).x=sand(n).x-1
Case 22
sand(n).x=sand(n).x-1
Case 26
sand(n).x=sand(n).x+1
Case 28
sand(n).x=sand(n).x-1
Case 30
sand(n).sopas=1
End Select
'Canvas_Redraw
End If
'Canvas_Redraw
If sand(n).sopas Then
'pichi=Rnd(0,55)+200
'FrontColor(Rgb(pichi,pichi,0))
'FrontColor= Rgb(pichi,pichi,0)
FrontColor= Rgb(255,255,0)
Canvas_SetPixel(sand(n).x,sand(n).y, FrontColor )
sand(n).x=5+Rnd(0,789)
sand(n).y=0
sand(n).sopas=0
End If
Next
'===========================================================
'Canvas_Redraw
' For n=1 To numar
' If sand(n).sopas Then
' 'pichi=Rnd(0,55)+200
' 'FrontColor(Rgb(pichi,pichi,0))
' 'FrontColor= Rgb(pichi,pichi,0)
' FrontColor= Rgb(255,255,0)
' Canvas_SetPixel(sand(n).x,sand(n).y, FrontColor )
'
' sand(n).x=5+Rnd(0,789)
' sand(n).y=0
' sand(n).sopas=0
'
' End If
'
' Next
Canvas_Redraw
End Sub'---Script created on 01-19-2020 19:39:15 by
overall remark : the sand looks natural on the ground but not on the upper obstacles 's edges.
I'm always stunned by these "falling sand" games. The code looks so simplistic and short but the result on the screen looks really impressive.
ErosOlmi
22-01-2020, 07:41
Great example.
When I see those big loops in thinBasic, I'm sorry I cannot give to all of you more execution speed due to interpretative nature of thinBasic
Anyway, the following my 2 cents in trying to speed execution:
In the big FOR/NEXT I've used pSand virtual variable to use sand(n) memory location
In this way when we use pSand in reality we are using sand(n)
This gives a little speed because parser doesn't need to parse (idx) index of sand array all the times in every expression
It is not much but is something
Ciao
Eros
Uses "UI"
Begin ControlID
%ID_Canvas1
%tTimer
End ControlID
Global numar, samba, pichi, fcolor, frontColor As Long
numar = 2000
Type part
x As Long
y As Long
sopas As Byte
End Type
Dim sand(numar) As part
Dim n As Long
For n=1 To numar
sand(n).x=5+Rnd(0,789)
sand(n).y=Rnd(0,200)
Next
Dim hDlg As DWord
Function TBMain()
Dialog New Pixels ,0, "Sand Show ",-1,-1, 800, 600, %WS_POPUP Or %WS_VISIBLE Or %WS_CAPTION Or %WS_SYSMENU Or %WS_MINIMIZEBOX To hDlg
Control Add Canvas, hDlg, %ID_Canvas1, "", 0, 0, 800, 600, %SS_NOTIFY
Canvas_Attach hDlg, %ID_Canvas1, %TRUE
Canvas_Clear %BLACK
Dialog Show Modal hDlg, Call dlgProc
End Function
CallBack Function dlgProc()
Select Case CBMSG
Case %WM_INITDIALOG
Canvas_Width(10)
Canvas_Line((280,100),(650,450),Rgb(0,155,20) )
Canvas_Line((0,570),(800,570),Rgb(0,155,20) )
Canvas_Ellipse(100, 300, 200, 400, Rgb(0,155,20),Rgb(0,155,20))
Canvas_Ellipse(100, 125, 200, 325, Rgb(0,0,0),Rgb(0,0,0))
Dialog Set Timer CBHNDL, %tTimer, 0, 0
Case %WM_TIMER
SandShow() 'call the sand procedure
Case %WM_CLOSE
Dialog Kill Timer CBHNDL, %tTimer
End Select
End Function
Sub SandShow()
'---Create a virtual variable to be a proxy for sand(n) when needed
'---This variable doesn't exists in memory, it will use the memory of another
'---variable when needed
static pSand as part at 0
frontColor = Rgb(255,255,255)
For n=1 To numar
'---Set memory location of pSand to the same memory location of sand(n)
'---In this way when we use pSand in reality we are using sand(n)
SetAt(pSand, varptr(sand(n)))
'Canvas_SetPixel( [STEP] x1, y1 [, rgbColor])
Canvas_SetPixel(pSand.x,pSand.y, frontColor)
Canvas_SetPixel(pSand.x,pSand.y-1, Rgb(0,0,0))
Canvas_SetPixel(pSand.x,pSand.y-2, Rgb(0,0,0))
Canvas_SetPixel(pSand.x,pSand.y-3, Rgb(0,0,0))
If Canvas_GetPixel(pSand.x,pSand.y+1) = 0 Then
pSand.y=pSand.y+1
Else
samba=0
If Canvas_GetPixel(pSand.x-1,pSand.y+1)<>0 Then
samba=samba+2
End If
If Canvas_GetPixel(pSand.x+1,pSand.y+1)<>0 Then
samba=samba+4
End If
If Canvas_GetPixel(pSand.x-2,pSand.y+1)<>0 Then
samba=samba+8
End If
If Canvas_GetPixel(pSand.x+2,pSand.y+1)<>0 Then
samba=samba+16
End If
Select Case samba
Case 0
If Rnd(0,1) Then
pSand.x=pSand.x+1
Else
pSand.x=pSand.x-1
End If
Case 2
pSand.x=pSand.x+1
Case 4
pSand.x=pSand.x-1
Case 6
If Rnd(0,1) Then
pSand.x=pSand.x+1
Else
pSand.x=pSand.x-1
End If
Case 8
pSand.x=pSand.x+1
Case 10
pSand.x=pSand.x+1
Case 14
pSand.x=pSand.x+1
Case 16
pSand.x=pSand.x-1
Case 20
pSand.x=pSand.x-1
Case 22
pSand.x=pSand.x-1
Case 26
pSand.x=pSand.x+1
Case 28
pSand.x=pSand.x-1
Case 30
pSand.sopas=1
End Select
'Canvas_Redraw
End If
'Canvas_Redraw
If pSand.sopas Then
'pichi=Rnd(0,55)+200
'FrontColor(Rgb(pichi,pichi,0))
'FrontColor= Rgb(pichi,pichi,0)
'FrontColor= Rgb(255,255,0)
Canvas_SetPixel(pSand.x,pSand.y, FrontColor )
pSand.x=5+Rnd(0,789)
pSand.y=0
pSand.sopas=0
End If
Next
'===========================================================
'Canvas_Redraw
' For n=1 To numar
' If sand(n).sopas Then
' 'pichi=Rnd(0,55)+200
' 'FrontColor(Rgb(pichi,pichi,0))
' 'FrontColor= Rgb(pichi,pichi,0)
' FrontColor= Rgb(255,255,0)
' Canvas_SetPixel(sand(n).x,sand(n).y, FrontColor )
'
' sand(n).x=5+Rnd(0,789)
' sand(n).y=0
' sand(n).sopas=0
'
' End If
'
' Next
Canvas_Redraw
End Sub
ErosOlmi
22-01-2020, 08:28
To get some more execution speed this is another version.
Here I've used thinBasic 1.11.x option to compile some pieces of source code into FreeBasic DLL and execute exported FB functions inside of thinBasic script.
I've put inside Freebasic compiled code just the big "select case" that is quite heavy when parsing script in thinBasic.
In this way it is much faster
#MinVersion 1.11.2
Uses "UI"
Begin ControlID
%ID_Canvas1
%tTimer
End ControlID
Global numar, samba, pichi, fcolor, frontColor As Long
numar = 2000
Type part
x As Long
y As Long
sopas As byte
End Type
Dim sand(numar) As part
Dim n As Long
For n=1 To numar
sand(n).x = 5 + Rnd(0,789)
sand(n).y = Rnd(0,200)
Next
Dim hDlg As DWord
Function TBMain()
Dialog New Pixels ,0, "Sand Show ",-1,-1, 800, 600, %WS_POPUP Or %WS_VISIBLE Or %WS_CAPTION Or %WS_SYSMENU Or %WS_MINIMIZEBOX To hDlg
Control Add Canvas, hDlg, %ID_Canvas1, "", 0, 0, 800, 600, %SS_NOTIFY
Canvas_Attach hDlg, %ID_Canvas1, %TRUE
Canvas_Clear %BLACK
Dialog Show Modal hDlg, Call dlgProc
End Function
CallBack Function dlgProc()
Select Case CBMSG
Case %WM_INITDIALOG
Canvas_Width(10)
Canvas_Line((280,100),(650,450),Rgb(0,155,20) )
Canvas_Line((0,570),(800,570),Rgb(0,155,20) )
Canvas_Ellipse(100, 300, 200, 400, Rgb(0,155,20),Rgb(0,155,20))
Canvas_Ellipse(100, 125, 200, 325, Rgb(0,0,0),Rgb(0,0,0))
Dialog Set Timer CBHNDL, %tTimer, 0, 0
Case %WM_TIMER
SandShow() 'call the sand procedure
Case %WM_CLOSE
Dialog Kill Timer CBHNDL, %tTimer
End Select
End Function
Sub SandShow()
'---Create a virtual variable to be a proxy for sand(n) when needed
'---This variable doesn't exists in memory, it will use the memory of another
'---variable when needed
static pSand as part at 0
frontColor = Rgb(255,255,255)
For n=1 To numar
'---Set memory location of pSand to the same memory location of sand(n)
'---In this way when we use pSand in reality we are using sand(n)
SetAt(pSand, varptr(sand(n)))
Canvas_SetPixel(pSand.x,pSand.y, frontColor)
Canvas_SetPixel(pSand.x,pSand.y-1, Rgb(0,0,0))
Canvas_SetPixel(pSand.x,pSand.y-2, Rgb(0,0,0))
Canvas_SetPixel(pSand.x,pSand.y-3, Rgb(0,0,0))
If Canvas_GetPixel(pSand.x,pSand.y+1) = 0 Then
pSand.y=pSand.y+1
Else
samba=0
If Canvas_GetPixel(pSand.x-1,pSand.y+1)<>0 Then
samba=samba+2
End If
If Canvas_GetPixel(pSand.x+1,pSand.y+1)<>0 Then
samba=samba+4
End If
If Canvas_GetPixel(pSand.x-2,pSand.y+1)<>0 Then
samba=samba+8
End If
If Canvas_GetPixel(pSand.x+2,pSand.y+1)<>0 Then
samba=samba+16
End If
'---Use FreeBasic compiled funtion to get some execution speed
FB_SandFall(pSand, samba, rnd(0,1))
End If
If pSand.sopas Then
Canvas_SetPixel(pSand.x,pSand.y, FrontColor )
pSand.x = 5 + Rnd(0,789)
pSand.y = 0
pSand.sopas = 0
End If
Next
'===========================================================
Canvas_Redraw
End Sub
#compiled "===Sand Fall Select case in FreeBasic==="
'---We have to repeat inside FB code UDT definitions that need to be shared
'...between thinBasic and Freebasic source cose
'---Also Data type must be in common that is never use a data type not supported by both languages
Type part
x As Long
y As Long
sopas As byte
End Type
'---This function will be visible to thinBasic script
function FB_SandFall Cdecl (byref pSand as part, byval samba as long, byval MyRnd as long) As long Export
select case samba
Case 0
If MyRnd Then
pSand.x=pSand.x+1
Else
pSand.x=pSand.x-1
End If
Case 2
pSand.x=pSand.x+1
Case 4
pSand.x=pSand.x-1
Case 6
If MyRnd Then
pSand.x=pSand.x+1
Else
pSand.x=pSand.x-1
End If
Case 8
pSand.x=pSand.x+1
Case 10
pSand.x=pSand.x+1
Case 14
pSand.x=pSand.x+1
Case 16
pSand.x=pSand.x-1
Case 20
pSand.x=pSand.x-1
Case 22
pSand.x=pSand.x-1
Case 26
pSand.x=pSand.x+1
Case 28
pSand.x=pSand.x-1
Case 30
pSand.sopas=1
End Select
end Function
#endcompiled
Thanks Eros, DirectuX
i have found that if we want to increase the falling speed, we change in line 84 for TB v1.11.2 to
pSand.y=pSand.y+2
instead of pSand.y=pSand.y+1
but the sand will begin to make holes in the tilted thick line and will pass through it.
there is some codes in
https://rosettacode.org/mw/index.php?title=Special%3ASearch&search=cellular+automata&go=Go
about the subject such as
One-dimensional cellular automaton
Langton's ant
Wireworld
Forest fire
Conway's Game of Life
and many others, some basic languages have participated.