Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Debug Error On 'catch array/pointer errors - OFF in production
#Debug Display On 'display untrapped errors - OFF in production
#Tools On 'use ON only when needed for Trace/Profile/CallStk
#Include "Win32API.inc"
#Resource "gbsnippets.pbr"
Type SpriteInfo
w As Long 'width (of enclosing rectangle)
h As Long 'height (of enclosing rectangle)
x As Long 'x-position (upper-left corner)
y As Long 'y-position (upper-left corner)
sx As Long 'distance to move in x direction (speed)
sy As Long 'distance to move in y direction (speed)
frameMax As Long 'total number of available frames For the sprite
frameCurrent As Long 'current Frame #, the one to be displayed
waitMax As Long 'max wait count before changing frames
waitCount As Long 'current wait count (counts Timer Events)
hBMP as DWord 'image handle or arra index of sprite
' these next members are unique to realtime image drawing
Color1 as Long 'fill color
Color2 as Long 'pie fill color
End Type
Global hDlg As DWord, Sprites() As SpriteInfo, canvasW as Long, canvasH as Long
Global TimerInterval as Long, MaxSprites as Long, MaxFrames as Long, hLst as DWord
Global SpriteH as Long, SpriteW as Long, SourceIsImages As Long, hWait as DWord
Global MoveTime$, DrawTime$, DisplayTime$, IntervalTime$, RandomImages As Long
Global UseBitStrings as Long, BitStrings() As String, bmpCanvas$, ShowTrails As Long
%ID_Graphic = 300 : %ID_Timer = 400 : %ID_Label = 400
Function PBMain() As Long
MaxSprites = 100 : TimerInterval = 20 : MaxFrames = 25
SpriteW = 32 : SpriteH = 32 : SourceIsImages = 1
RandomImages = 1 : UseBitStrings = 0
Dim Sprites(5000), BitStrings(5000) 'more than needed
canvasW = 900 : canvasH = 600
Dialog New Pixels, 0, "Sprite Test - Realtime Drawing",400,150,canvasW, canvasH+120, %WS_SysMenu, 0 To hDlg
Dialog Set Icon hDlg, "aainfo"
Control Add Graphic, hDlg, %ID_Graphic,"", 0,120,canvasW,canvasH, %WS_Visible Or %SS_Sunken Or %SS_Notify
Control Add Label, hDlg, 800, "", 40,10,150,80
Control Add Label, hDlg, 815, "Sprite Size", 235,5,50,20
Control Add Label, hDlg, 816, "Timer Interval", 310,5,50,20
Control Add Label, hDlg, 817, "#Sprites", 410,5,50,20
Control Add Label, hDlg, 818, "Max Frames", 480,5,75,20
Control Add Label, hDlg, 818, "Options", 560,5,75,20
Control Add Option, hDlg, 801, "128x", 235,20,45,15, %WS_Group Or %WS_TabStop
Control Add Option, hDlg, 802, "64x", 235,40,40,15
Control Add Option, hDlg, 803, "32x", 235,60,40,15
Control Add Option, hDlg, 804, "4x", 235,80,40,15
Control Set Option hDlg, 803, 801,804
Control Add Option, hDlg, 830, "100ms (10fps)", 310,20,80,15, %WS_Group Or %WS_TabStop
Control Add Option, hDlg, 831, "67ms (15fps)", 310,40,80,15
Control Add Option, hDlg, 832, "50ms (20fps)", 310,60,80,15
Control Add Option, hDlg, 833, "33ms (30fps)", 310,80,80,15
Control Add Option, hDlg, 834, "20ms (50fps)", 310,100,80,15
Control Set Option hDlg, 833, 830,834
Control Add Option, hDlg, 807, "1500",410,20,45,15, %WS_Group Or %WS_TabStop
Control Add Option, hDlg, 808, "1000",410,40,45,15
Control Add Option, hDlg, 809, "500",410,60,45,15
Control Add Option, hDlg, 810, "100",410,80,45,15
Control Add Option, hDlg, 811, "10",410,100,45,15
Control Set Option hDlg, 810, 807,811
Control Add Option, hDlg, 812, "75",480,20,35,15, %WS_Group Or %WS_TabStop
Control Add Option, hDlg, 813, "50",480,40,35,15
Control Add Option, hDlg, 814, "25",480,60,35,15
Control Set Option hDlg, 814, 812,814
Control Add Checkbox, hDlg, 840, "Images", 560,20,120,15
Control Set Check hDlg, 840, SourceIsImages
Control Add Checkbox, hDlg, 841, "(Random)", 580,40,100,15
Control Set Check hDlg, 841, RandomImages
Control Add Checkbox, hDlg, 842, "Bit Strings", 580,60,100,15
Control Add Checkbox, hDlg, 843, "Drawing Thread", 690,20,100,15
Control Add Checkbox, hDlg, 844, "Transparency", 690,40,100,15
Control Add Checkbox, hDlg, 845, "AlphaBlending", 690,60,100,15
Control Add Checkbox, hDlg, 846, "Show Trails", 690,80,100,15
Control Add Button, hDlg, 847, "Clear", 800,80,50,20
Control Add Graphic, hDlg, 850, "", 840,20,32,32, %WS_Border
Graphic Attach hDlg, %ID_Graphic, Redraw
Graphic Color %Black,%White
Graphic Clear
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local i As Long, P as Point
Select Case CB.Msg
Case %WM_InitDialog
CreateImageList
DefineSprites
SetTimer(CB.Hndl, %ID_Timer, TimerInterval, ByVal %NULL) 'uses callback messages
Case %WM_Timer
Local qFreq, qOverhead, qElapsed As Quad
QueryPerformanceFrequency qFreq 'clock frequency
Tix qOverHead : Tix qOverHead : Tix End qOverHead 'Tix overhead (done twice per Intel)
Tix qElapsed : MoveSprites : Tix End qElapsed : MoveTime$ = Format$((qElapsed-qOverHead)*1000/qFreq, "##00.00")
Tix qElapsed : DrawSprites : Tix End qElapsed : DrawTime$ = Format$((qElapsed-qOverHead)*1000/qFreq, "##00.00")
Tix qElapsed : Graphic Redraw : Tix End qElapsed : DisplayTime$ = Format$((qElapsed-qOverHead)*1000/qFreq, "##00.00")
Control Set Text hDlg, 800, Build$("Timer Interval: ", IntervalTime$, " ms", $crlf, $CrLf, "Elapsed Times: ", $CrLf, " Move: ", MoveTime$," ms", $crlf, " Draw: ",DrawTime$," ms", $crlf, " Display: ",DisplayTime$," ms")
Case %WM_Destroy
KillTimer CB.Hndl, %ID_Timer
Case %WM_Command
If CB.Ctl = 801 Then SpriteH=128 : SpriteW=128 : DefineSprites
If CB.Ctl = 802 Then SpriteH=64 : SpriteW=64 : DefineSprites
If CB.Ctl = 803 Then SpriteH=32 : SpriteW=32 : DefineSprites
If CB.Ctl = 804 Then SpriteH=4 : SpriteW=4 : DefineSprites
If CB.Ctl >= 830 AND CB.Ctl <=834 Then
KillTimer CB.Hndl, %ID_Timer
Select Case CB.Ctl
Case 830: TimerInterval = 100
Case 831: TimerInterval = 67
Case 832: TimerInterval = 50
Case 833: TimerInterval = 33
Case 834: TimerInterval = 20
End Select
SetTimer(CB.Hndl, %ID_Timer, TimerInterval, ByVal %NULL) 'uses callback messages
DefineSprites
End If
If CB.Ctl = 806 Then
KillTimer CB.Hndl, %ID_Timer
TimerInterval = 20
SetTimer(CB.Hndl, %ID_Timer, TimerInterval, ByVal %NULL) 'uses callback messages
DefineSprites
End If
If CB.Ctl = 807 Then MaxSprites = 1500 : DefineSprites
If CB.Ctl = 808 Then MaxSprites = 1000 : DefineSprites
If CB.Ctl = 809 Then MaxSprites = 500 : DefineSprites
If CB.Ctl = 810 Then MaxSprites = 100 : DefineSprites
If CB.Ctl = 811 Then MaxSprites = 10 : DefineSprites
If CB.Ctl = 812 Then MaxFrames = 75 : DefineSprites
If CB.Ctl = 813 Then MaxFrames = 50 : DefineSprites
If CB.Ctl = 814 Then MaxFrames = 25 : DefineSprites
If CB.Ctl = 840 Then
SourceIsImages = SourceIsImages XOR 1
Control Set Check hDlg, 840, SourceIsImages
DefineSprites
End If
If CB.Ctl = 841 Then
RandomImages = RandomImages XOR 1
Control Set Check hDlg, 841, RandomImages
DefineSprites
End If
If CB.Ctl = 842 Then
UseBitStrings = UseBitStrings XOR 1
Control Set Check hDlg, 842, UseBitStrings
DefineSprites
End If
If CB.Ctl = 846 Then
ShowTrails = ShowTrails XOR 1
Control Set Check hDlg, 846, ShowTrails
If ShowTrails = 0 Then Graphic Clear
End If
If CB.Ctl = 847 Then Graphic Clear
If CB.Ctl = %ID_Graphic AND CB.Ctlmsg = %STN_Clicked Then
GetCursorPos P 'x and y are in screen coordinates
ScreenToClient hDlg, P 'x and y are now dialog client coordinates
i = SpriteHitTest(P) 'returns first sprite under mouse
If i Then
Graphic Attach hDlg, 850
If Sprites(i).hBMP = 0 Then
Graphic Set Bits BitStrings(i)
Else
Graphic Stretch Sprites(i).hBMP, 0, (0,0)-(Sprites(i).w,Sprites(i).h) To (0,0)-(32,32)
End If
End If
End If
End Select
End Function
Function SpriteHitTest(P as Point) As Long
Local i As Long
For i = 0 to MaxSprites
If (P.x >= Sprites(i).x) AND (P.x <= (Sprites(i).x +Sprites(i).w)) AND (P.y >= (Sprites(i).y+120)) AND (P.y <= (Sprites(i).y + Sprites(i).h) + 120) Then
Dialog Set Text hDlg, "HitTest " + Str$(i)
Function = i : Exit Function
End If
Next
End Function
Sub DrawSprites
Local i as Long, arcStart as Single, arcEnd as Single
Local p as Long Pointer, pStart as Long, s as Long Pointer
Local x as Long, y as Long, sStart as Long
Graphic Attach hDlg, %ID_Graphic, Redraw
If ShowTrails = 0 Then Graphic Clear
If UseBitStrings Then
Graphic Get Bits To bmpCanvas$
p = StrPTR(bmpCanvas$)+8
pStart = p
End If
If SourceIsImages Then
For i = 0 to MaxSprites
If UseBitStrings Then
s = StrPTR(BitStrings(i))+8
sStart = s
' For y = 0 to Sprites(i).h-1
' p = pStart + y*CanvasW*4 + Sprites(i).y*CanvasW*4 + Sprites(i).x*4
' For x = 0 to Sprites(i).w-1
' @p = @s : Incr s : Incr p
' Next x
' Next y
' Graphic Set Bits bmpCanvas$
Else
Graphic Copy Sprites(i).hBMP, 0 To (Sprites(i).x, Sprites(i).y)
End If
Next i
Else
For i = 0 to MaxSprites
Graphic Ellipse (Sprites(i).x, Sprites(i).y)-(Sprites(i).x + Sprites(i).w, Sprites(i).y + Sprites(i).h), %Black, Sprites(i).Color1
arcStart = (Sprites(i).frameCurrent) * 6.28 / Sprites(i).frameMax
arcEnd = (Sprites(i).frameCurrent + 10) * 6.28 / Sprites(i).frameMax
Graphic Pie (Sprites(i).x, Sprites(i).y)-(Sprites(i).x + Sprites(i).w, Sprites(i).y + Sprites(i).h), _
ArcStart, ArcEnd, %Black, Sprites(i).Color2
Next i
End If
End Sub
Sub MoveSprites
Local i As Long
For i = 0 To MaxSprites
Sprites(i).x = Sprites(i).x + Sprites(i).sx
Sprites(i).y = Sprites(i).y + Sprites(i).sy
If Sprites(i).x < 0 Then
Sprites(i).x = 0
Sprites(i).sx = -1 * Sprites(i).sx
ElseIf Sprites(i).x + Sprites(i).w > canvasW Then
Sprites(i).x = canvasW - Sprites(i).w
Sprites(i).sx = -1 * Sprites(i).sx
End If
If Sprites(i).y < 0 Then
Sprites(i).y = 0
Sprites(i).sy = -1 * Sprites(i).sy
ElseIf Sprites(i).y + Sprites(i).h > canvasH Then
Sprites(i).y = canvasH - Sprites(i).h
Sprites(i).sy = -1 * Sprites(i).sy
End If
Incr Sprites(i).waitCount
If Sprites(i).waitCount = Sprites(i).waitMax Then
Sprites(i).waitCount = 0
Sprites(i).frameCurrent = (Sprites(i).frameCurrent + 1) Mod Sprites(i).frameMax
End If
Next i
End Sub
Sub DefineSprites
If MaxSprites > 100 Then DisplayWaitDialog(hDlg)
IntervalTime$ = Format$(1000/TimerInterval,"###0")
Local i As Long, j as Long, hBMP as DWord
Graphic Bitmap New 32,32 To hBMP 'for use whenver random 32x32 icons images are used from *.PBR
Randomize
For i = 0 To MaxSprites
Sprites(i).w = SpriteW
Sprites(i).h = SpriteH
Sprites(i).x = Rnd(0,canvasW-Sprites(i).w)
Sprites(i).y = Rnd(0,canvasH-Sprites(i).h)
Sprites(i).sx = Rnd(2,4)*((-1)^Rnd(1,2))
Sprites(i).sy = Rnd(2,4)*((-1)^Rnd(1,2))
Sprites(i).frameMax = MaxFrames
Sprites(i).frameCurrent = Rnd(0,Sprites(i).frameMax)
Sprites(i).waitMax = 1 'Rnd(1,3)
Sprites(i).waitCount = 0
Sprites(i).Color1 = Rgb(Rnd(0,256), Rnd(0,256), Rnd(0,256)) 'Rnd(0,4000000000)
Sprites(i).Color2 = Rgb(Rnd(0,256), Rnd(0,256), Rnd(0,256)) 'Rnd(0,4000000000)
If Sprites(i).hBMP Then
Graphic Attach Sprites(i).hBMP, 0 : Graphic Bitmap End
End If
If SourceIsImages Then
If RandomImages Then
Graphic Attach hBMP,0
Graphic ImageList (0,0), hLst, Rnd(1,100) ,0,%ILD_Normal
Graphic Bitmap New Sprites(i).w, Sprites(i).h To Sprites(i).hBMP
Graphic Attach Sprites(i).hBMP, 0
Graphic Stretch hBMP, 0, (0,0)-(32,32) To (0,0)-(Sprites(i).w,Sprites(i).h)
Else
Graphic Bitmap Load "cowgirl", Sprites(i).w, Sprites(i).h, %HalfTone To Sprites(i).hBMP
End If
If UseBitStrings Then
Graphic Attach Sprites(i).hBMP, 0
Graphic Get Bits To BitStrings(i)
Graphic Bitmap End
Sprites(i).hBMP = 0
End If
Else
Sprites(i).hBMP = 0
End If
Next i
If hWait Then Dialog End hWait
End Sub
Sub DisplayWaitDialog(hParent as DWord)
Local x As Long, y As Long, w As Long, h As Long, wX As Long, wY As Long
Dialog Get Client hParent To w,h
wX = 150 : wY = 60
x = (w-wX)/2 'gets left position of WaitDialog to center over app
y = (h-wY)/2 'gets top position of WaitDialog to center over app
Dialog New Pixels, hParent, "", x, y, wX, wY, %WS_Popup To hWait
Control Add Label, hWait, %ID_Label, "Please wait ... ", 0, 0, wX, wY, %SS_Center Or %SS_CenterImage Or %WS_Border
Control Set Color hWait, %ID_Label, %Black, %White
Dialog Show Modeless hWait
End Sub
Sub CreateImageList
Local i as Long
ImageList New Icon 32, 32, 24, 100 To hLst 'create imagelist w,h,depth,size
For i = 1 To 100
ImageList Add Icon hLst, "mos" + Format$(i,"000")
Next i
End Sub
'gbs_00453
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm