Tweet
Code:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' Circles.bas by Jordi Vallès version 1a 04/09/2008 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' In a rectangular area filled with a number of non-intersecting circles with ' radius variable or fixed, find the biggest possible circle to fit in without ' intersecting other circles or draw outside the boundary of the space. ' ' This kind of problems are titled as "kissing circles" or "kissing coins" by ' several authors. ' ' Interesting information about 2D Circle Packing can be found on: ' Mathworld Wolfram CirclePacking ' ' Operation: ' Click 'Reset' to sow at random graphic area with circles. This button only ' is needed if 'Number of Circles' or 'Fixed Circle Size' have been changed. ' Click 'Start' to start the search cycle. ' After some moments, depending of accuracy selected, a red circle will appear, ' that is the best and biggest circle the program has found so far. ' Click 'Cancel' to cancel the current search and return to wait for a new ' action operator. ' Tooltips are available on all controls to help operation. ' ' See statistics and compare with different parameter values with same ' map of circles. ' ' All relevant data is displayed on Log window. This window can be erased ' and saved as text file with unique name in current directory. Also ' contents can be selected, totally or partial, with mouse and set on ' clipboard for general use. ' ' This program can be used as "framework" to experiment with algorithms and ' methods to play with packing problems. Several math refinements can be ' explored. On a future a revised version of this program can use more ' elaborated search methods. ' ' At start time the data collected on InitialData procedure is used and shown. ' This data can be set by user to experiment with specific combinations and ' parameters. ' ' Part of source used here comes from: ' Dave Navarro, Borje Hagsten, Eros Olmi, Petr Schreiber, Erik Christensen, ' Eddy Van Esch, Chris Holbrook, etc. ' Additionally, thanks to Michael Mattias and Semen Matusovski for explanations ' on several old PB forum entries related with PB Threads on Graphics. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' - Program developed and tested with PowerBASIC for Windows (PB/Win 8.04) on ' PC HP Pavilion m7760 1.80 GHz with Windows Vista Home Premium. ' - Only PB Graphic package is used to show information generated by program. ' - 04/10/2008 Recompiled and tested with PB 9.00. '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ ' SED_PBWIN #COMPILE EXE "Circles.exe" #DIM ALL #INCLUDE "Win32Api.inc" #INCLUDE "CommCtrl.inc" '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %ID_RESET = 1010 %ID_START = 1020 %ID_CANCEL = 1030 %ID_GRAPHIC = 1040 %ID_TOP = 1050 %ID_BOT = 1060 %ID_NDISKS = 1070 %ID_MAXRAD = 1080 %ID_STEPF = 1090 %ID_SAVE = 1100 %ID_ENUM = 1110 %ID_FIXRAD = 1120 %ID_PREC1 = 1130 %ID_PREC2 = 1140 %ID_PREC3 = 1150 %ID_CONSOLE = 1160 %ID_CLOG = 1170 %ID_DEBUG = 1180 %MINRADIUS = 15 'minimum radius for variable circles %MAXRADIUS = 45 'maximum radius for variable circles %DEFRADIUS = 25 'default radius for fixed circles %INITCIRCLE = 90 'default size for circle to be insert %NUMCIRCLES = 20 'number of circles as default %STEPFACTOR = 2 'step value to be used on first main loop %CANVAS = &hEEFAFA??? 'RGB(250,250,238) %LTLINES = &hEAEAEA??? 'RGB(234,234,234) $TITLE = "Best fit circle - 1a (framework)" 'title on caption '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ MACRO Form0(D,L) = RSET$(FORMAT$(D,"#,"),L) MACRO Form2(D,L) = RSET$(FORMAT$(D,"#0.00"),L) MACRO Form6(D,L) = RSET$(FORMAT$(D,"#0.000000"),L) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DECLARE FUNCTION MakeFontEx(BYVAL FontName AS STRING, BYVAL PointSize AS LONG, BYVAL fBold AS LONG, _ BYVAL fItalic AS LONG, BYVAL fUnderline AS LONG) AS DWORD DECLARE FUNCTION EnumCharSet(elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, BYVAL FontType AS LONG, CharSet AS LONG) AS LONG DECLARE FUNCTION CirclesDoNotIntersect(BYVAL diskX1 AS SINGLE, BYVAL diskY1 AS SINGLE, BYVAL diskR AS SINGLE) AS LONG DECLARE FUNCTION WorkingAll(BYVAL hWnd AS DWORD) AS LONG DECLARE FUNCTION CurrentTimeInSeconds() AS DOUBLE DECLARE SUB OutString(txtMsg AS STRING, OPTIONAL BYVAL forceRedraw AS LONG) DECLARE SUB SetToolTipText(hTool AS DWORD, ID AS LONG, BYVAL txt AS STRING) '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ TYPE TCIRCLE X AS SINGLE 'X position Y AS SINGLE 'Y position R AS SINGLE 'radius END TYPE '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GLOBAL hDlg, hThread AS DWORD 'dialog and console handlers GLOBAL hFont1, hFont2 AS DWORD 'handlers for fonts used here GLOBAL rWs, rHs AS SINGLE 'size of main canvas, needed of calculations as Single GLOBAL Circ() AS tCircle 'main program array GLOBAL bestX, bestY, bestR AS SINGLE 'red disk values obtained GLOBAL initCircle AS SINGLE 'red disk initial radius GLOBAL stepFactor AS SINGLE 'step value for pass 1 GLOBAL precision AS SINGLE 'accuracy on search GLOBAL numCircles AS LONG 'number of circles defined GLOBAL eNum, fixRad AS LONG GLOBAL emergencyStop AS LONG GLOBAL aToolTipText AS ASCIIZ * 256 GLOBAL hToolTip AS DWORD '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION PBMAIN () AS LONG LOCAL signature AS ASCIIZ * 120 LOCAL rW, rH AS LONG '--- 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 '--- create dialog window --- DIALOG NEW PIXELS, 0, $TITLE, , , 784, 460, %WS_CAPTION OR %WS_SYSMENU, 0 TO hDlg CONTROL ADD GRAPHIC, hDlg, %ID_GRAPHIC,"", 3, 3, 502, 402, %WS_BORDER OR %SS_NOTIFY CONTROL GET CLIENT hDlg, %ID_GRAPHIC TO rW, rH 'get client (canvas) size GRAPHIC SCALE (0, 0) - (rW, rH) 'scale to pixel coordinate system 'convert canvas size to single values to avoid extra conversions during process rWs = rW : rHs = rH GRAPHIC ATTACH hDlg, %ID_GRAPHIC, REDRAW GRAPHIC FONT "Arial", 7, 0 GRAPHIC COLOR %BLACK, %CANVAS 'canvas colors GRAPHIC CLEAR CONTROL ADD BUTTON, hDlg, %ID_RESET, "Reset", 490, 418, 60, 32 CONTROL ADD BUTTON, hDlg, %ID_START, "Start", 552, 418, 60, 32 CONTROL ADD BUTTON, hDlg, %ID_CANCEL, "Cancel", 614, 418, 60, 32 CONTROL ADD BUTTON, hDlg, %ID_TOP, "top", 698, 412, 40, 22 CONTROL ADD BUTTON, hDlg, %ID_BOT, "bot", 698, 434, 40, 22 CONTROL ADD BUTTON, hDlg, %ID_SAVE, "save", 740, 412, 40, 22 CONTROL ADD BUTTON, hDlg, %ID_CLOG, "clear", 740, 434, 40, 22 CONTROL ADD CHECKBOX,hDlg, %ID_ENUM, "enumerate circles", 280, 408, 102, 16 CONTROL ADD CHECKBOX,hDlg, %ID_FIXRAD, "fixed circle size", 280, 424, 102, 16 CONTROL ADD CHECKBOX,hDlg, %ID_DEBUG, "debug mode", 280, 440, 102, 16 CONTROL ADD LABEL, hDlg, -1, "accuracy", 416, 405, 60, 14 CONTROL ADD OPTION, hDlg, %ID_PREC1, "0.5", 420, 419, 40, 14, %WS_GROUP CONTROL ADD OPTION, hDlg, %ID_PREC2, "0.2", 420, 432, 40, 14 CONTROL ADD OPTION, hDlg, %ID_PREC3, "0.1", 420, 445, 40, 14 CONTROL SET OPTION hDlg, %ID_PREC1, %ID_PREC1, %ID_PREC3 CONTROL ADD LABEL, hDlg, -2, "# circles (10-50)", 1, 412, 100, 14 CONTROL ADD TEXTBOX, hDlg, %ID_NDISKS, "20", 80, 410, 30, 18, _ %ES_NUMBER OR %ES_CENTER, %WS_EX_CLIENTEDGE CONTROL ADD LABEL, hDlg, -3, "step factor (1-5)", 1, 434, 100, 14 CONTROL ADD TEXTBOX, hDlg, %ID_STEPF, "2", 80, 432, 30, 18, _ %ES_NUMBER OR %ES_CENTER, %WS_EX_CLIENTEDGE CONTROL ADD LABEL, hDlg, -4, "initial radius of circle", 126, 410, 108, 14 CONTROL ADD LABEL, hDlg, -5, "to be fit on this space", 126, 422, 108, 14 CONTROL ADD LABEL, hDlg, -6, "(from 180 to 60 pixels)", 126, 434, 108, 14 CONTROL ADD TEXTBOX, hDlg, %ID_MAXRAD, "90", 230, 420, 30, 18, _ %ES_NUMBER OR %ES_CENTER, %WS_EX_CLIENTEDGE CONTROL ADD TEXTBOX, hDlg, %ID_CONSOLE, "", 510, 3, 270, 402, _ %ES_READONLY OR %ES_WANTRETURN OR %ES_MULTILINE OR %ES_NOHIDESEL OR %WS_VSCROLL, %WS_EX_STATICEDGE '--- fonts not standard --- hFont1 = MakeFontEx("Lucida Console", 9, %FW_NORMAL, %FALSE, %FALSE) 'small size fixed pitch CONTROL SEND hDlg, %ID_CONSOLE, %WM_SETFONT, hFont1, 0 hFont2 = MakeFontEx("MS Sans Serif", 9, %FW_BOLD, %FALSE, %FALSE) 'standard font in bold CONTROL SEND hDlg, %ID_START, %WM_SETFONT, hFont2, 0 CONTROL SEND hDlg, %ID_RESET, %WM_SETFONT, hFont2, 0 CONTROL SEND hDlg, %ID_CANCEL, %WM_SETFONT, hFont2, 0 '--- tooltips support --- hToolTip = CreateWindowEx(BYVAL 0, "tooltips_class32", "", %TTS_ALWAYSTIP, _ ' Or %TTS_BALLOON, _ 0, 0, 0, 0, BYVAL hDlg, BYVAL 0, GetModuleHandle(BYVAL %NULL), BYVAL 0) DIALOG SEND hToolTip, %TTM_SETMAXTIPWIDTH, 0, 200 '200 seems appropriate DIALOG SEND hToolTip, %TTM_SETDELAYTIME, %TTDT_AUTOPOP, 3000 '3000 = 3 seconds '--- tooltips text --- SetToolTipText hToolTip, %ID_TOP, "Go to top of Log board" SetToolTipText hToolTip, %ID_BOT, "Go to bottom of Log board" SetToolTipText hToolTip, %ID_SAVE, "Save on file with a unique name the entire contents of Log board" SetToolTipText hToolTip, %ID_CLOG, "Erase all contents of Log board" SetToolTipText hToolTip, %ID_CANCEL, "Cancel current calculation and return to wait an action operator" SetToolTipText hToolTip, %ID_START, "Starts calculations trying to search the best fit big circle" SetToolTipText hToolTip, %ID_RESET, "Creates at random a new set of circles based on defined parameters" SetToolTipText hToolTip, %ID_PREC1, "Set the precision to fit in 0.5 pixel, used on search pass 2. It's fast" SetToolTipText hToolTip, %ID_PREC2, "Set the precision to fit in 0.2 pixels, used on search pass 2. Takes some time" SetToolTipText hToolTip, %ID_PREC3, "Set the precision to fit in 0.1 pixels, used on search pass 2. It's slow" SetToolTipText hToolTip, %ID_NDISKS, "Number of circles to be created on 2D space. Needs a Reset" SetToolTipText hToolTip, %ID_STEPF, "Step value used on main loop of search in pass 1" SetToolTipText hToolTip, %ID_ENUM, "Enumerate all circles" SetToolTipText hToolTip, %ID_FIXRAD, "Use same radius for all circles. Needs a Reset" SetToolTipText hToolTip, %ID_MAXRAD, "Initial radius of circle to be fit on this space without intersecting " + _ "other circles or outside the boundary of this 2D space." SetToolTipText hToolTip, %ID_CONSOLE, "Log board. All relevant data related or obtained during program " + _ "process is written here. This information can be saved on a file or " + _ "selected and set on clipboard." SetToolTipText hToolTip, %ID_GRAPHIC, "2D graphic space" DIALOG SHOW MODAL hDlg CALL DlgProc END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ CALLBACK FUNCTION DlgProc() AS LONG LOCAL buffer AS STRING LOCAL iLb AS LOGBRUSH STATIC lineCount, result, iBrushBlue AS LONG SELECT CASE AS LONG CBMSG CASE %WM_INITDIALOG CONTROL DISABLE CBHNDL, %ID_CANCEL iLb.lbStyle = %WHITE_BRUSH iLb.lbColor = %WHITE iBrushBlue = CreateBrushIndirect(iLb) emergencyStop = %TRUE numCircles = %NUMCIRCLES stepFactor = %STEPFACTOR initCircle = %INITCIRCLE precision = 0.5 CALL CanvasCleaner(%TRUE, %TRUE) CALL InitialData 'only if needed CALL DrawCircles(%FALSE) CASE %WM_CTLCOLORSTATIC SELECT CASE GetDlgCtrlID(CBLPARAM) CASE %ID_CONSOLE SetBkMode CBWPARAM, %OPAQUE SetTextColor CBWPARAM, RGB(0,0,120) FUNCTION = iBrushBlue : EXIT FUNCTION END SELECT CASE %WM_COMMAND SELECT CASE CBCTL CASE %ID_PREC1 : precision = 0.5 CASE %ID_PREC2 : precision = 0.2 CASE %ID_PREC3 : precision = 0.1 CASE %ID_ENUM : CONTROL GET CHECK CBHNDL, %ID_ENUM TO eNum : CALL DrawCircles(%TRUE) CASE %ID_FIXRAD : CONTROL GET CHECK CBHNDL, %ID_FIXRAD TO fixRad CASE %ID_MAXRAD CONTROL GET TEXT CBHNDL, %ID_MAXRAD TO buffer initCircle = VAL(buffer) CASE %ID_STEPF CONTROL GET TEXT CBHNDL, %ID_STEPF TO buffer stepFactor = VAL(buffer) CASE %ID_TOP CONTROL SEND hDlg, %ID_CONSOLE, %EM_GETLINECOUNT, 0, 0 TO lineCount CONTROL SEND hDlg, %ID_CONSOLE, %EM_LINESCROLL, 0, -lineCount CASE %ID_BOT CONTROL SEND hDlg, %ID_CONSOLE, %EM_GETLINECOUNT, 0, 0 TO lineCount CONTROL SEND hDlg, %ID_CONSOLE, %EM_LINESCROLL, 0, lineCount CASE %ID_NDISKS CONTROL GET TEXT CBHNDL, %ID_NDISKS TO buffer numCircles = VAL(buffer) CASE %ID_CANCEL IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN emergencyStop = %TRUE OutString $CRLF + "= = = = = = Cancelled = = = = = =" + $CRLF, %TRUE CONTROL ENABLE CBHNDL, %ID_START CONTROL ENABLE CBHNDL, %ID_RESET CONTROL DISABLE CBHNDL, %ID_CANCEL END IF CASE %ID_START IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN CONTROL ENABLE CBHNDL, %ID_CANCEL CONTROL DISABLE CBHNDL, %ID_START CONTROL DISABLE CBHNDL, %ID_RESET IF UBOUND(Circ) < 5 THEN EXIT FUNCTION IF (stepFactor > 5) OR (stepFactor < 1) THEN 'check limits stepfactor stepFactor = %STEPFACTOR CONTROL SET TEXT CBHNDL, %ID_STEPF, LTRIM$(STR$(%STEPFACTOR)) CONTROL REDRAW CBHNDL, %ID_STEPF END IF CONTROL SET TEXT CBHNDL, %ID_NDISKS, LTRIM$(STR$(UBOUND(Circ))) IF (initCircle > 180) OR (initCircle < 60) THEN 'check limits red circle initCircle = %INITCIRCLE CONTROL SET TEXT CBHNDL, %ID_MAXRAD, LTRIM$(STR$(%INITCIRCLE)) CONTROL REDRAW CBHNDL, %ID_MAXRAD END IF emergencyStop = %FALSE CALL CanvasCleaner(%FALSE, %FALSE) CALL DrawCircles(%FALSE) THREAD CREATE WorkingAll(hDlg) TO hThread THREAD CLOSE hThread TO result END IF CASE %ID_RESET IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN CONTROL GET TEXT CBHNDL, %ID_NDISKS TO buffer numCircles = VAL(buffer) IF (numCircles > 50) OR (numCircles < 10) THEN 'check limits num circles numCircles = %NUMCIRCLES CONTROL SET TEXT CBHNDL, %ID_NDISKS, LTRIM$(STR$(%NUMCIRCLES)) END IF CONTROL GET TEXT CBHNDL, %ID_MAXRAD TO buffer initCircle = VAL(buffer) IF (initCircle > 160) OR (initCircle < 60) THEN 'check limits red circle initCircle = %INITCIRCLE CONTROL SET TEXT CBHNDL, %ID_MAXRAD, LTRIM$(STR$(%INITCIRCLE)) END IF CALL CanvasCleaner(%TRUE, %TRUE) CALL GenerateCircles CALL DrawCircles(%FALSE) END IF CASE %ID_CLOG IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN CONTROL SET TEXT hDlg, %ID_CONSOLE, "" CONTROL REDRAW hDlg, %ID_CONSOLE END IF CASE %ID_SAVE : CALL SaveLog END SELECT CASE %WM_NCACTIVATE STATIC hWndSaveFocus AS DWORD IF ISFALSE CBWPARAM THEN hWndSaveFocus = GetFocus() ELSEIF hWndSaveFocus THEN SetFocus(hWndSaveFocus) hWndSaveFocus = 0 END IF CASE %WM_DESTROY IF hFont1 THEN DeleteObject hFont1 IF hFont2 THEN DeleteObject hFont2 END SELECT END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB DrawCircles(drawbestfit AS LONG) REGISTER j AS LONG LOCAL sx, sy AS LONG LOCAL txt AS STRING FOR j = 1 TO numCircles GRAPHIC ELLIPSE (Circ(j).X-Circ(j).R,Circ(j).Y-Circ(j).R) - (Circ(j).X+Circ(j).R,Circ(j).Y+Circ(j).R), -1, %WHITE IF eNum THEN 'enumerate disks ? txt = LTRIM$(STR$(j)) GRAPHIC TEXT SIZE txt TO sx, sy GRAPHIC SET POS (Circ(j).X-sx/2, Circ(j).Y-sy/2) GRAPHIC PRINT txt END IF NEXT j IF drawbestfit THEN GRAPHIC ELLIPSE (bestX-bestR,bestY-bestR) - (bestX+bestR,bestY+bestR), %RED, %LTLINES, 5 txt = "r=" + Form2(bestR, 5) GRAPHIC TEXT SIZE txt TO sx, sy GRAPHIC SET POS (bestX-sx/2, bestY-sy/2) GRAPHIC PRINT txt END IF GRAPHIC REDRAW END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB GenerateCircles() 'Generate random non-interseding circles. 'Save the circles center and radius on array. 'Check that a given circle does not intersect or exists inside another circle. REGISTER j AS LONG LOCAL radius, middleX, middleY AS SINGLE REDIM Circ(1 TO numCircles) AS TCIRCLE RANDOMIZE TIMER FOR j = 1 TO numCircles DO radius = IIF(fixrad, %DEFRADIUS, RND(%MINRADIUS, %MAXRADIUS)) 'if fixed 25, variable see values middleX = RND(radius, rWs-radius) 'coordinates inside our 2D space middleY = RND(radius, rHs-radius) ' " " " " " LOOP UNTIL CirclesDoNotIntersect(middleX, middleY, radius) = %TRUE Circ(j).X = middleX Circ(j).Y = middleY Circ(j).R = radius NEXT j END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION CirclesDoNotIntersect(BYVAL bX1 AS SINGLE, BYVAL bY1 AS SINGLE, BYVAL bR AS SINGLE) AS LONG 'Calculate if two circles intersect. Returns TRUE (no intersection) or FALSE (circles intersect) 'Method: distance between two centerpoints must be bigger or equal to the sum of their radius REGISTER j AS LONG LOCAL distance AS SINGLE FUNCTION = %TRUE FOR j = 1 TO UBOUND(Circ()) IF NOT (Circ(j).X = 0 AND Circ(j).Y = 0 AND Circ(j).R = 0) THEN distance = SQR(((bX1-Circ(j).X) ^2) + ((bY1-Circ(j).Y) ^2)) IF distance >= (bR + Circ(j).R) THEN 'no intersection, to next circle ELSE FUNCTION = %FALSE EXIT FOR END IF END IF NEXT j END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB CanvasCleaner(wantRedim AS LONG, wantRedraw AS LONG) REGISTER j AS LONG GRAPHIC CLEAR IF wantRedim THEN REDIM Circ(0) AS tCircle FOR j = 0 TO 24 GRAPHIC LINE (j*20, 00) - (j*20, 500), %LTLINES GRAPHIC LINE (00, j*20) - (500, j*20), %LTLINES NEXT IF wantRedraw THEN GRAPHIC REDRAW END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION WorkingAll(BYVAL hWnd AS DWORD) AS LONG REGISTER j AS LONG LOCAL fits, conta1, conta2, conta3, conta4, cdebug AS LONG LOCAL i1s, j1s, i2s, j2s, stpF, stepFactor2 AS SINGLE LOCAL wmin, wmax, hmin, hmax, radius1, radius2 AS SINGLE LOCAL T1, T2, T3 AS DOUBLE LOCAL txt AS STRING STATIC ntest AS LONG INCR ntest CONTROL GET CHECK hDlg, %ID_DEBUG TO cdebug stpF = StepFactor stepFactor2 = stepFactor * 2 'to avoid repetitive operations on loops OutString "= = = Starting test number:" + STR$(ntest) + " = = =" OutString "Map:" + $CRLF + "Circle X Y R" FOR j = 1 TO UBOUND(Circ) txt = txt + Form0(j,4) + Form0(Circ(j).X,7) + Form0(Circ(j).Y,6) + Form0(Circ(j).R,5) + $CRLF NEXT j txt = txt + "= = = = = = = = = = = = = = = = = =" + $CRLF + $CRLF txt = txt + "--- Start measurement ---" + $CRLF + "step 1 ..." OutString txt, %TRUE 'starts a new internal thread for graphics inside this working thread 'seems unnecessary but needed to make long time loops interrumpibles 'with possibility to display on graphics window during process GRAPHIC ATTACH hDlg, %ID_GRAPHIC, REDRAW 'starts new trhread SLEEP 1 'after some tests I decided divide the search in two stages ' - first with force brute brute to find aproximation ' - second is also brute but with some refinemets to find exact the value expected 'in the two steps the outer loop starts with maximum value with a step negative '===== Step 1 ===== ''''' 'uses brute force by excess search method ' T1 = CurrentTimeInSeconds ' radius1 = initCircle ' DO WHILE radius1 > 10.0 ' wmin = radius1 : wmax = rHs - radius1 ' hmin = radius1 : hmax = rWs - radius1 ' FOR j1s = wmin TO wmax 'wmin to wmax ' INCR conta1 ' IF emergencyStop THEN GOTO DoExit 'cancel ??? ' FOR i1s = hmin TO hmax 'hmin to hmax ' INCR conta2 ' IF CirclesDoNotIntersect(i1s, j1s, radius1) = %FALSE THEN ITERATE FOR ' IF stpF > 1 THEN ' radius1 = radius1 + stpF ' stpF = 1 ' EXIT, EXIT ' END IF ' bestX = i1s : bestY = j1s : bestR = radius1 ' CALL CanvasCleaner(%FALSE, %FALSE) ' CALL DrawCircles(%TRUE) ' SLEEP 1 ' fits = %TRUE ' EXIT, EXIT, EXIT ' NEXT j1s ' NEXT i1s ' radius1 = radius1 - stpF ' LOOP ''''' IF emergencyStop THEN GOTO DoExit 'cancel ??? OutString "step 2 ...", %TRUE IF fits THEN T2 = CurrentTimeInSeconds IF bestR >= initCircle THEN txt = "=== BEST FIT FALSE ===" + $CRLF txt = txt + "=== initial circle is too small ===" + $CRLF txt = txt + "=== = = = = End of test = = = = ===" + $CRLF OutString txt, %TRUE ELSE '===== Step 2 ===== ''''' 'proof by exhaustion is the method used (brute force refined) ' fits = %FALSE ' 'recovers stepfactor used on previous step and apply precision ' FOR radius2 = radius1+1 TO radius1 STEP -Precision ' wmin = radius2 : wmax = rHs - radius2 ' hmin = radius2 : hmax = rWs - radius2 ' FOR j2s = wmin TO wmax STEP precision 'wmin to wmax ' INCR conta3 ' IF emergencyStop THEN GOTO DoExit 'cancel ??? ' IF j2s > j1s + stepfactor2+1 THEN EXIT 'stop, unneeded search on wide ' FOR i2s = hmin TO hmax STEP precision 'hmin To hmax ' INCR conta4 ' IF i2s > i1s + stepfactor2+1 THEN EXIT 'stop, undeeded search on high' IF CirclesDoNotIntersect(i2s, j2s, radius2) = %FALSE THEN ITERATE FOR bestX = i2s : bestY = j2s : bestR = radius2 ' CALL CanvasCleaner(%FALSE, %FALSE) ' CALL DrawCircles(%TRUE) ' fits = %TRUE ' SLEEP 1 'to visual effect ' IF fits THEN EXIT, EXIT, EXIT ' NEXT j2s ' NEXT i2s ' NEXT radius2 ''''' T3 = CurrentTimeInSeconds OutString "--- End measurement ---" + $CRLF IF bestR >= initCircle THEN txt = "=== BEST FIT FALSE ===" + $CRLF txt = txt + "=== something is bad, try again ===" + $CRLF txt = txt + "=== = = = = End of test = = = = ===" + $CRLF OutString txt, %TRUE ELSE txt = "--- Statistics about test:" + STR$(nTest) + " ---" + $CRLF txt = txt + "Number of circles drawn :" + STR$(UBOUND(Circ)) + $CRLF txt = txt + "Pixels precision requested : " + Form2(precision, 3) + $CRLF txt = txt + "Step factor used on Step1 :" + STR$(stepFactor) + $CRLF txt = txt + "Max radius of circle to fit :" + STR$(initCircle) + $CRLF + $CRLF txt = txt + " Best fit circle:" + $CRLF txt = txt + " X " + Form2(bestX, 7) + $CRLF txt = txt + " Y " + Form2(bestY, 7) + $CRLF txt = txt + " Radius" + Form2(bestR, 7) + $CRLF + $CRLF txt = txt + "Iterations j1s : " + Form0(conta1, 10) + $CRLF txt = txt + "Iterations i1s : " + Form0(conta2, 10) + $CRLF txt = txt + "Iterations j2s : " + Form0(conta3, 10) + $CRLF txt = txt + "Iterations i2s : " + Form0(conta4, 10) + $CRLF txt = txt + "Iterations total : " + Form0(conta2+conta4, 10) + $CRLF + $CRLF txt = txt + "Time spent pass 1 : " + Form6(T2 - T1, 9) + " secs" + $CRLF txt = txt + "Time spent pass 2 : " + Form6(T3 - T2, 9) + " secs" + $CRLF txt = txt + "Time spent total : " + Form6(T3 - T1, 9) + " secs" + $CRLF + $CRLF IF cdebug THEN txt = txt + "radius1 : " + Form2(radius1,6) + " radius2 : " + Form2(radius2,6) + $CRLF txt = txt + "I1S : " + Form2(i1s,6) + " I2S : " + Form2(i2s,6) + $CRLF txt = txt + "J1S : " + Form2(j1s,6) + " J2S : " + Form2(j2s,6) + $CRLF + $CRLF END IF txt = txt + "=== = = = = = End of test = = = ===" + $CRLF OutString txt, %TRUE END IF END IF ELSE txt = "=== IT SHOULD NOT HAPPEN ===" + $CRLF txt = txt + "=== something is bad, try again ===" + $CRLF txt = txt + "=== = = = = End of test = = = = ===" + $CRLF OutString txt, %TRUE END IF DoExit: emergencyStop = %TRUE CONTROL ENABLE hDlg, %ID_RESET CONTROL ENABLE hDlg, %ID_START CONTROL DISABLE hDlg, %ID_CANCEL BEEP END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB OutString(txtMsg AS STRING, OPTIONAL BYVAL forceRedraw AS LONG) 'based on code of Eros Olmi LOCAL redrawCntl, lineCount AS LONG LOCAL tmpStr AS STRING RedrawCntl = %FALSE IF UCASE$(LEFT$(txtMsg, 8)) = "[MSGBOX]" THEN MSGBOX RIGHT$(txtMsg, LEN(txtMsg) - 8) ELSE 'if single char passed, repeat it for 80, ie lines/separators IF LEN(txtMsg) = 1 THEN txtMsg = REPEAT$(35, txtMsg) 'adjusted to actual window redrawCntl = %TRUE END IF 'if no string passed, than blank the text area IF LEN(txtMsg) > 0 THEN CONTROL GET TEXT hDlg, %ID_CONSOLE TO tmpStr tmpStr = tmpStr + txtMsg IF LEN(txtMsg) > 0 THEN tmpStr = tmpStr + $CRLF CONTROL SET TEXT hDlg, %ID_CONSOLE, tmpStr END IF IF redrawCntl = %TRUE OR forceRedraw = %TRUE THEN CONTROL REDRAW hDlg, %ID_CONSOLE CONTROL SEND hDlg, %ID_CONSOLE, %EM_GETLINECOUNT, 0, 0 TO lineCount CONTROL SEND hDlg, %ID_CONSOLE, %EM_LINESCROLL, 0, lineCount END IF END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION EnumCharSet(elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, BYVAL FontType AS LONG, CharSet AS LONG) AS LONG 'Get type of character set - ansi, symbol.. a must for some fonts. CharSet = elf.elfLogFont.lfCharSet END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION MakeFontEx(BYVAL FontName AS STRING, BYVAL PointSize AS LONG, BYVAL fBold AS LONG, _ BYVAL fItalic AS LONG, BYVAL fUnderline AS LONG) AS DWORD 'Create a desirable font and return its handle. Original code by Dave Navarro 'Note: any font created with MakeFontEx should also be destroyed with DeleteObject LOCAL hfDC AS DWORD LOCAL CharSet, CyPixels AS LONG hfDC = GetDC(%HWND_DESKTOP) CyPixels = GetDeviceCaps(hfDC, %LOGPIXELSY) EnumFontFamilies hfDC, BYVAL STRPTR(FontName), CODEPTR(EnumCharSet), BYVAL VARPTR(CharSet) ReleaseDC %HWND_DESKTOP, hfDC PointSize = 0 - (PointSize * CyPixels) \ 72 FUNCTION = CreateFont(PointSize, 0, _ 'height, width(default=0) 0, 0, _ 'escapement(angle), orientation fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700) fItalic, _ 'Italic fUnderline, _ 'Underline %FALSE, _ 'StrikeThru CharSet, %OUT_TT_PRECIS, _ %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _ %FF_DONTCARE, BYCOPY FontName) END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ FUNCTION CurrentTimeInSeconds() AS DOUBLE 'This function returns the number of seconds since midnight as a Double-precision 'floating-point value. Original code by Erik Christensen. 'Can be simplified for modern PCs only. STATIC PerfFreq AS QUAD, Res AS LONG, Prec AS LONG, First AS LONG, TimeCorrection AS DOUBLE LOCAL t1 AS QUAD, ta AS DOUBLE IF ISFALSE First THEN 'Get, in counts per second, the current performance-counter frequency 'if supported by your hardware. Res = QueryPerformanceFrequency(PerfFreq) 'determine precision IF Res THEN Prec = CEIL(LOG10(PerfFreq)) QueryPerformanceCounter t1 ta = ROUND(CDBL(t1) / CDBL(PerfFreq), Prec) 'find time correction to obtain number of seconds past midnight. TimeCorrection = TIMER - ta FUNCTION = ta + TimeCorrection First = %TRUE : EXIT FUNCTION END IF First = %TRUE END IF 'measure current time IF Res THEN 'if possible use this: QueryPerformanceCounter t1 FUNCTION = ROUND(CDBL(t1) / CDBL(PerfFreq), Prec) + TimeCorrection END IF END FUNCTION '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB SetToolTipText(hToolTip AS DWORD, ID AS LONG, BYVAL txt AS STRING) LOCAL hLocalDlg AS DWORD LOCAL ti AS TOOLINFO aToolTipText = txt hLocalDlg = GetParent(hToolTip) ti.cbSize = LEN(ti) ti.uFlags = %TTF_SUBCLASS OR %TTF_IDISHWND ti.hWnd = hLocalDlg ti.uId = GetDlgItem(hLocalDlg, ID) ti.lpszText = VARPTR(aToolTipText) SendMessage hToolTip, %TTM_ADDTOOL, 0, VARPTR(ti) END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB SaveLog() 'Save entire Log to file with a unique name in current directory LOCAL f AS INTEGER LOCAL fname, buffer AS STRING 'create an unique filename fname = "B" + MID$(DATE$,3,4) + TIME$ + ".txt" fname = REMOVE$(fname, ANY ":") CONTROL GET TEXT hDlg, %ID_CONSOLE TO buffer IF LEN(buffer) < 200 THEN EXIT SUB 'if less than 200 chars, nothing to do f = FREEFILE OPEN fname FOR OUTPUT AS f PRINT# f, "*** Created on " + DATE$ + " at " + TIME$ + " ***" + $CRLF PRINT# f, buffer CLOSE f END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ SUB InitialData() REGISTER j AS LONG LOCAL i AS LONG numCircles = VAL(READ$(1)) REDIM Circ(1 TO numCircles) AS tCircle FOR j = 1 TO DATACOUNT-1 STEP 3 INCR i Circ(i).X = VAL(READ$(j+1)) Circ(i).Y = VAL(READ$(j+2)) Circ(i).R = VAL(READ$(j+3)) NEXT j 'Is user responsability to maintain coherent data if is modified 'First line is the numCircles and indicates the amount of next DATA lines 'Rest of lines has the format X,Y and Radius in entire pixel values 'This data is appropriate to experiment with specific input data 'More input data can be collected from previous saved Log 'To remember: NO write comments on DATA lines ' Data 20 ' Data 418, 288, 41 ' Data 133, 155, 36 ' Data 119, 64, 35 ' Data 396, 93, 21 ' Data 332, 122, 23 ' Data 268, 269, 30 ' Data 452, 199, 44 ' Data 75, 297, 33 ' Data 364, 30, 18 ' Data 27, 112, 21 ' Data 207, 108, 22 ' Data 98, 212, 19 ' Data 144, 272, 32 ' Data 392, 355, 30 ' Data 446, 16, 16 ' Data 230, 324, 23 ' Data 39, 41, 15 ' Data 345, 319, 22 ' Data 372, 231, 16 ' Data 344, 274, 17 ' Data 20 ' Data 275, 215, 42 ' Data 352, 369, 17 ' Data 35, 195, 25 ' Data 28, 247, 26 ' Data 310, 131, 22 ' Data 401, 205, 25 ' Data 431, 358, 25 ' Data 186, 329, 30 ' Data 192, 105, 36 ' Data 395, 267, 36 ' Data 291, 64, 15 ' Data 346, 37, 33 ' Data 188, 229, 19 ' Data 280, 101, 17 ' Data 138, 301, 24 ' Data 447, 142, 20 ' Data 478, 261, 15 ' Data 50, 111, 27 ' Data 293, 337, 32 ' Data 474, 312, 18 DATA 20 DATA 189, 315, 19 DATA 182, 187, 15 DATA 322, 277, 20 DATA 131, 347, 22 DATA 107, 65, 37 DATA 65, 239, 18 DATA 332, 100, 34 DATA 360, 218, 26 DATA 36, 108, 28 DATA 255, 42, 31 DATA 391, 274, 36 DATA 28, 367, 23 DATA 120, 214, 37 DATA 82, 319, 28 DATA 87, 146, 18 DATA 421, 191, 31 DATA 463, 300, 19 DATA 391, 341, 25 DATA 225, 119, 44 DATA 466, 38, 32 END SUB '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ 'eof