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