Tweet
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' PackBalloons.bas by Jordi Vallès version 1b 27/06/2008
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' A graphical entertainment.
'
' Searching information about dynamic graphs for networks I found this algorithm
' from Scott Buckley and after some small modifications and an implementation
' inside a PB DDT suit this is the result.
' Don't know if is useful for something but is curious.
' Sincerely, I understood this routine, but not allways the results obtained.
'
' - Press mouse left button on free area to add balloons to pool.
' - Observe the behaviour after the 37th (approx) balloon when starts the dance
' due to collisions caused by unstability between center distances.
' - With Explode button a balloon is removed at random.
' - Balloons can be numbered using the checkbox "enumerate"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' - Program developed and tested with PowerBASIC for Windows (PB/Win 8.04) on a
' PC HP Pavilion m7760 1.80 GHz with Windows Vista Home Premium.
' - Only PB Graphic package is used to display information generated by program.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' SED_PBWIN
#Compile Exe "PackBalloons.exe"
#Dim All
#Include "Win32Api.inc"
#Include "CommCtrl.inc"
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%IDM_RESET = 1110
%IDM_REMOVE = 1120
%IDM_EXIT = 1130
%IDM_GRAPHIC = 1140
%IDM_INFO1 = 1150
%IDM_ENUM = 1160
%IDM_TIMER = 1210
%IDM_STEP = 1310
%IDM_NSTEPS = 1320
%CANVAS = &hEEFAFA??? 'RGB(250,250,238)
%LTLINES = &hEAEAEA??? 'RGB(234,234,234)
$TITLE = "Packing Balloons - 1b" 'title on caption
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Macro Pi = 3.141592653589793#
Macro NearZero = 0.000000000000001# 'to avoid problems in some divisions
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Declare Function Atn2(X As Double, Y As Double) As Double
Declare Function BalloonsOverlap(ByVal bX1 As Long, ByVal bY1 As Long) As Long
Declare Function DistancePoints(pX1 As Double, pY1 As Double, pX2 As Double, pY2 As Double) As Double
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Global OldGraphicProc As Dword 'old process, used in subclass
Global hTimer, hGraphic As Dword
Global swidth, sheight As Long 'size of main canvas
Global maxColors, enum As Long
Global apX(), apY() As Double
Global apC(), Colors() As Long
Global Radius, Radius4 As Double
Global atime, nBalloons As Long
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function PBMain () As Long
Local hDlg As Dword
Local signature As Asciiz * 90
'~~~ 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
Dialog New Pixels, 0, $TITLE, , , 309, 552, %WS_CAPTION Or %WS_SYSMENU, 0 To hDlg
Control Add Graphic, hDlg, %IDM_GRAPHIC,"", 3, 3, 302, 502, %WS_BORDER Or %SS_NOTIFY
Control Get Client hDlg, %IDM_GRAPHIC To swidth, sheight 'get client (canvas) size
Graphic Scale (0, 0) - (swidth, sheight) 'scale to pixel coordinate system
Graphic Attach hDlg, %IDM_GRAPHIC, Redraw
Graphic Font "Arial", 7, 0
Graphic Color %BLACK, %CANVAS 'canvas colors
Control Add Button, hDlg, %IDM_REMOVE, "Explode 1", 120, 530, 60, 20
Control Add Button, hDlg, %IDM_RESET, "Reset", 182, 530, 60, 20
Control Add Button, hDlg, %IDM_EXIT, "Quit", 244, 530, 60, 20
Control Add Label, hDlg, %IDM_INFO1, "balloons : 0", 120, 510, 80, 14
Control Add CheckBox,hDlg, %IDM_enum, "enumerate", 234, 510, 70, 16
Control Add "msctls_trackbar32", hDlg, %IDM_STEP, "", 2, 510, 110, 20, _
%WS_CHILD Or %TBS_HORZ Or %WS_VISIBLE Or %TBS_BOTTOM Or %WS_TABSTOP Or %TBS_NOTICKS
Control Send hDlg, %IDM_STEP, %TBM_SETRANGE, %TRUE, MakLng(10,100)
Control Send hDlg, %IDM_STEP, %TBM_SETPOS, %TRUE, 30
Control Add Textbox, hDlg, %IDM_NSTEPS, "30", 34, 530, 28, 20, _
%ES_READONLY Or %ES_CENTER, %WS_EX_CLIENTEDGE
Control Add Label, hDlg, -1, "mSecs.", 60, 532, 50, 18
Dialog Show Modal hDlg Call DlgProc
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
CallBack Function DlgProc() As Long
Local i As Long
Select Case As Long CbMsg
Case %WM_INITDIALOG
Control Handle CbHndl, %IDM_GRAPHIC To hGraphic
OldGraphicProc = SetWindowLong(hGraphic, %GWL_WNDPROC, CodePtr(GraphicProc))
Call Initialize(CbHndl)
atime = 30
Case %WM_TIMER
KillTimer CbHndl, hTimer
Call TimerBalloons(CbHndl)
hTimer = SetTimer(CbHndl, %IDM_TIMER, atime, ByVal %NULL)
Case %WM_HSCROLL
Select Case CbLParam
Case GetDlgItem(CbHndl, %IDM_STEP)
Control Send CbHndl, %IDM_STEP, %TBM_GETPOS, 0, 0 To atime
Control Set Text CbHndl, %IDM_NSTEPS, Format$(atime)
End Select
Function = %TRUE
Case %WM_COMMAND
Select Case CbCtl
Case %IDM_RESET : If CbCtlMsg = %BN_CLICKED Then Call Initialize(CbHndl)
Case %IDM_EXIT : If CbCtlMsg = %BN_CLICKED Then Dialog End CbHndl
Case %IDM_enum : Control Get Check CbHndl, %IDM_enum To enum
Case %IDM_REMOVE
If CbCtlMsg = %BN_CLICKED Then 'to explode balloons at random
KillTimer CbHndl, hTimer
If nBalloons > 5 Then
i = Rnd(2,nballoons)
Array Delete apX(i) : Array Delete apY(i) : Array Delete apC(i)
Decr nBalloons
Control Set Text CbHndl, %IDM_INFO1, "balloons : " + Str$(nBalloons)
End If
hTimer = SetTimer(CbHndl, %IDM_TIMER, atime, ByVal %NULL)
End If
End Select
Case %WM_DESTROY
If hTimer Then KillTimer CbHndl, hTimer
If OldGraphicProc Then SetWindowLong hGraphic, %GWL_WNDPROC, OldGraphicProc
End Select
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function GraphicProc(Byval hWnd As Dword, Byval wMsg As Dword, Byval wParam As Dword, Byval lParam As Long) As Long
Select Case wMsg
Case %WM_LBUTTONUP : Call LeftButtonUp(hWnd, wParam, lParam)
End Select
Function = CallWindowProc(OldGraphicProc, hWnd, wMsg, wParam, lParam)
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub LeftButtonUp(Byval hWnd As Dword, Byval wParam As Dword, Byval lParam As Long)
Local pt As POINTAPI
KillTimer hWnd, hTimer
Randomize Timer * nBalloons
GetCursorPos pt
ScreenToClient hWnd, pt
If BalloonsOverlap(pt.X, pt.Y) Then
Incr nBalloons
apX(nBalloons) = pt.X
apY(nBalloons) = pt.Y
apC(nBalloons) = Colors(Rnd(1,maxColors))
End If
Control Set Text GetParent(hWnd), %IDM_INFO1, "balloons : " + Str$(nBalloons)
hTimer = SetTimer(hWnd, %IDM_TIMER, atime, ByVal %NULL)
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub TimerBalloons(hWnd As Dword)
'based from an idea of Scott Buckley
Local i, j, x, y As Long
Local txt As String
Local Angle, cX, cY As Double
If nBalloons <= 1 Then Exit Sub 'skip the first ball at initial
For j = 1 To nBalloons ''''
apY(j) = apY(j) + 5.3 'motion: 5.3 pixels on timestep (non-divisible value) '
If apY(j) < Radius Then apY(j) = Radius '
If apY(j) > sheight - Radius Then apY(j) = sheight - Radius '
If apX(j) < Radius Then apX(j) = Radius '
If apX(j) > swidth - Radius Then apX(j) = swidth - Radius '
For i = 1 To nBalloons '''' '
If i <> j Then 'avoid war against itself ' '
If DistancePoints(apX(j),apY(j), apX(i),apY(i)) < Radius4 Then ' '
Angle = Atn2(apX(j) - apX(i), apY(j) - apY(i)) ' '
cX = (apX(j) + apX(i)) / 2 ' '
cY = (apY(j) + apY(i)) / 2 ' '
apX(j) = cX + (Radius * Cos(Angle)) ' '
apY(j) = cY - (Radius * Sin(Angle)) ' '
apX(i) = cX - (Radius * Cos(Angle)) ' '
apY(i) = cY + (Radius * Sin(Angle)) ' '
End If ' '
End If ' '
Next i '''' '
'this a copy of first part, but necessary for balloons in the inner loop '
If apY(j) < Radius Then apY(j) = Radius '
If apY(j) > sheight - Radius Then apY(j) = sheight - Radius '
If apX(j) < Radius Then apX(j) = Radius '
If apX(j) > swidth - Radius Then apX(j) = swidth - Radius '
Next j ''''
Call CanvasCleaner(%FALSE)
For j = 1 to nBalloons
Graphic Ellipse (apX(j)-Radius,apY(j)-Radius) - (apX(j)+Radius,apY(j)+Radius), -1, apC(j)
If enum Then
txt = Ltrim$(Str$(j))
Graphic Text Size txt To x, y
Graphic Set Pos (apX(j)-x/2, apY(j)-y/2)
Graphic Print txt
End If
Next j
Graphic Redraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub CanvasCleaner(wantRedraw As Long)
Local j As Long
Graphic Clear
For j = 0 To 24
Graphic Line (j*20, 00) - (j*20, 500), %LTLINES
Graphic Line (00, j*20) - (300, j*20), %LTLINES
Next
'suggested by Petr Schreiber
If wantRedraw Then Graphic Redraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub Initialize(hWnd As Dword)
ReDim apX(250), apY(250), apC(250) 'max 250 balloons
Call CanvasCleaner(%TRUE)
Call PrepareColors
Radius = 25 'balloon Radius 25 pixels
Radius4 = (Radius*2)^2 'to save time on process
nBalloons = 1 'first balloon
apX(1) = swidth/2 ' " "
apY(1) = sheight-Radius ' " "
apC(1) = Colors(Rnd(1, maxColors)) ' " "
Control Set Text hWnd, %IDM_INFO1, "balloons : " + Str$(nBalloons)
hTimer = SetTimer(hWnd, %IDM_TIMER, atime, ByVal %NULL)
Graphic Set Pos (44,44)
Graphic Print "Use left button mouse on free area to add balloons."
Graphic Ellipse (apX(1)-Radius,apY(1)-Radius) - (apX(1)+Radius,apY(1)+Radius), -1, apC(1)
Graphic Redraw
End Sub
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Sub PrepareColors()
Local i, j As Long
'array with 96 soft colors to mapping balloons
ReDim Colors(1 To DataCount) As Long
maxColors = UBound(Colors)
For j = 1 To DataCount
Colors(j) = Val(Read$(j))
Next j
'shuffle colors array (by John Gleason)
For j = LBound(Colors) To UBound(Colors)
i = Rnd(j, UBound(Colors))
Swap Colors(j), Colors(i)
Next
'from soft colors chart found on Internet some time ago
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
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function Atn2(X As Double, Y As Double) As Double
'Atn2 optimized version. Simple but sufficient for this purpose.
'Range of the result is 0 to 2Pi radians.
If Y = 0 Then Y = NearZero
Function = (Atn(Abs(X)/Abs(Y)) * Sgn(X) - Pi/2) * Sgn(Y)
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function DistancePoints(pX1 As Double, pY1 As Double, pX2 As Double, pY2 As Double) As Double
Function = (pX1-pX2)*(pX1-pX2) + (pY1-pY2)*(pY1-pY2)
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
Function BalloonsOverlap(ByVal bX1 As Long, ByVal bY1 As Long) As Long
'Calculate if two balloons overlaps when is inserted on pool.
'Returns true (no overlap) or false (balloons overlap)
Local j, distance As Long
Function = %TRUE
For j = 1 To nBalloons 'loop over existing balls
If Not (apX(j) = 0 And apY(j) = 0) Then
distance = Sqr(((bX1-apX(j)) ^2) + ((bY1-apY(j)) ^2))
If distance >= Radius*2 Then
'not overlap, to next ball
Else
Function = %FALSE
Exit For
End If
End If
Next j
End Function
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
'eof
Comment