Hi Primo,
did you intentionally split the code in two for/next loops as it runs well in a single loop ?
this is simulating the following sand example with some logical errors, it is based on an old code in
https://www.purebasic.fr/english/vie...p?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
Hi Primo,
did you intentionally split the code in two for/next loops as it runs well in a single loop ?
ThinBasic 1.11.6.0 ALPHA - Windows 8.1 x64
Primo,
this looks superb and runs so smooth
Petr
Learn 3D graphics with ThinBASIC, learn TBGL!
Windows 10 64bit - Intel Core i5-3350P @ 3.1GHz - 16 GB RAM - NVIDIA GeForce GTX 1050 Ti 4GB
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
Last edited by primo; 19-01-2020 at 22:18.
Primo,
this code with a single for/next block works well for me:
overall remark : the sand looks natural on the ground but not on the upper obstacles 's edges.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
ThinBasic 1.11.6.0 ALPHA - Windows 8.1 x64
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.
Operating System: Windows 10 Home 64-bit
CPU: Intel Celeron N4000 CPU @ 1.10GHz
Memory: 4.00GB RAM
Graphics: Intel UHD Graphics 600
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
Last edited by ErosOlmi; 22-01-2020 at 07:42.
www.thinbasic.com | www.thinbasic.com/community/ | help.thinbasic.com
Windows 10 Pro for Workstations 64bit - 32 GB - Intel(R) Xeon(R) W-10855M CPU @ 2.80GHz - NVIDIA Quadro RTX 3000
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
Last edited by ErosOlmi; 22-01-2020 at 08:30.
www.thinbasic.com | www.thinbasic.com/community/ | help.thinbasic.com
Windows 10 Pro for Workstations 64bit - 32 GB - Intel(R) Xeon(R) W-10855M CPU @ 2.80GHz - NVIDIA Quadro RTX 3000
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...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.
Bookmarks