Falling Sand

Category: Games

Date: 03-28-2012

Return to Index


 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
 
#Debug Error On     'catch array/pointer errors - OFF in production
#Debug Display On   'display untrapped errors   - OFF in production
#Tools Off          'use ON only when needed for Trace/Profile/CallStk
 
#Include "win32api.inc"
 
'use these inside procedures:
'#Debug Print "msg"  'on as-needed basis only
'#Debug Code ON      'ignored in production, use OFF for speed in development testing
 
Type canvas
   st  As Long   '0-empty 1-filled 2-blocked
   clr As Long   'color long integer
End Type
 
   %ID_Timer = 500
   %ID_Graphic = 600
   %MaxP = 40000
   %Empty = %Black
   %Filled = %Red
   %Blocked = %Blue
 
   Global D() As Long   'canvas
   Global TimerInterval As Long, hDlg As DWord
   Global DrawLine As Long, xMax As Long, yMax As Long
 
Function PBMain() As Long
   Randomize Timer
   xMax = 200 : yMax = 200
   Dim D(xMax,yMax)
 
   Dialog New Pixels, 0, "Button Test",300,300,320,260, %WS_OverlappedWindow To hDlg
   Control Add Button, hDlg, 100,"Push", 50,10,100,20
   Control Add Graphic, hDlg, %ID_Graphic, "", 20,40,200,200, %WS_Border Or %SS_Notify
   Control Set Color hDlg, %ID_Graphic, %White, %White
   Graphic Attach hdlg, %ID_Graphic, Redraw
   Graphic Clear %Black
   Initialize
   TimerInterval = 15
   SetTimer(hDlg, %ID_Timer, TimerInterval, 0)
   Dialog Show Modal hDlg Call DlgProc
End Function
 
Sub Initialize
   Dim x As Long, y As Long, i As Long
   'clear all
   For x = 0 To xMax
      For y = 0 To yMax
         'set background
         D(x,y) = %Empty
      Next y
   Next x
 
   'block
   For x = 40 To 90
      For y = 100 To 105
         D(x,y) = %Blocked
         Graphic Set Pixel (x,y), %Blocked
      Next y
   Next x
   For x = 150 To 180
      For y = 100 To 105
         D(x,y) = %Blocked
         Graphic Set Pixel (x,y), %Blocked
      Next y
   Next x
   For x = 80 To 160
      For y = 50 To 55
         D(x,y) = %Blocked
         Graphic Set Pixel (x,y), %Blocked
      Next y
   Next x
End Sub
 
CallBack Function DlgProc() As Long
   Dim XMax As Long, YMax As Long
   Select Case CB.Msg
      Dim x As Long, y As Long
      Case %WM_Timer
         'randomly put particles in the shooter (0 position)
         For x = .3*xMax To .33*xMax : D(x,0) = Rnd(0,1)*%Red : Next i
         For x = .6*xMax To .63*xMax : D(x,0) = Rnd(0,1)*%Green : Next i
         For x = .3*xMax To .33*xMax : D(x,0) = Rnd(0,1)*D(x,0) : Next i
         For x = .6*xMax To .63*xMax : D(x,0) = Rnd(0,1)*D(x,0) : Next i
 
         'relocate all per rules
         For x = 1 To xMax
            For y = yMax-1 To 0 Step -1
               '               'rules - this position gets color from above
 
               If D(x,y) <> %Blocked Then
                  Select Case D(x,y+1)
                     Case %Empty
                        D(x,y+1) = D(x,y)
                        D(x,y) = %Empty
                        Graphic Set Pixel (x,y+1), D(x,y+1)
                     Case %Red, %Green
                        Select Case D(x-1,y+1)
                           Case %Empty
                              D(x-1,y+1) = D(x,y)
                              D(x,y) = %Empty
                              Graphic Set Pixel (x-1,y+1), D(x-1,y+1)
                           Case %Red, %Green
                              Select Case D(x+1,y+1)
                                 Case %Empty
                                    D(x+1,y+1) = D(x,y)
                                    D(x,y) = %Empty
                                    Graphic Set Pixel (x+1,y+1), D(x+1,y+1)
                                 Case %Red, %Green
                              End Select
                        End Select
                  End Select
               End If
            Next y
         Next x
         For x = 1 To xMax
            D(x,ymax) = %Empty
         Next i
         Graphic Redraw
 
      Case %WM_LButtonDown
         DrawLine = 1
      Case %WM_LButtonUp
         Drawline = 0
      Case %WM_SetCursor
         If GetDlgCtrlID(CB.wParam)=%ID_Graphic AND DrawLine = 1 Then
            Dialog Set Text hdlg, "setcursor"
            Dim pt As point
            GetCursorPos pt               'pt has xy screen coordinates
            ScreenToClient CB.wParam, pt       'pt now has client coordinates
            Graphic Ellipse (pt.x,pt.y)-(pt.x+10,pt.y+10), %Blue, %Blue
         End If
      Case %WM_Command
         Select Case CB.Ctl
            Case 100
               If CB.Ctlmsg = %BN_Clicked Then
               End If
         End Select
   End Select
End Function
 
'gbs_00440
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm