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:
' [URL="http://mathworld.wolfram.com/CirclePacking.html"]Mathworld Wolfram CirclePacking[/URL]
'
' 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