Date: 02-16-2022
Return to Index
created by gbSnippets
'Compiler Comments:
'This code was written to compilete in PBWin10. To compile with PBWin9,
'replace CALL with USING in Array Sort (2 places in code below)
'Compilable Example: (Jose Includes)
#Compiler 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#Include "Win32API.inc"
#Include "win32api.inc"
#Resource "gbsnippets.pbr"
Type PartType
x As Long
y As Long
z As Long
xk As Long
yk As Long
xcenter As Long
ycenter As Long
area As Long
placed As Long
End Type
Global hDlg,hLst,hMenu,hMenuOptions As DWord
Global PL(), PLMin() As PartType 'PartList
Global xRequired,yRequired,xMax,GapFiller As Long
Function PBMain() As Long
Dialog New Pixels, 0, "gbLayout - Placement Utility",300,300,670,520, %WS_OverlappedWindow To hDlg
AddToolbar : AddControls
Dialog Show Modal hDlg Call DlgProc
End Function
Sub StandardPlacement(Flag As Long)
Graphic Clear
ReadPartData
If Flag Then Array Sort PL(1), Call CustomSortDescend 'sort in descending order
PlaceParts_Std
DisplayInfo
Dialog Redraw hDlg
End Sub
CallBack Function DlgProc() As Long
Local i,j,k,m,iLoops,RequiredArea,RequiredX,RequiredY As Long, temp As PartType
Select Case CB.Msg
Case %WM_InitDialog
Settings_INI "get"
StandardPlacement 0
Case %WM_Destroy
Settings_INI "save"
Case %WM_GETMINMAXINFO
If IsFalse(IsIconic(hDlg)) Then
Local MM As MINMAXINFO Ptr
MM=CB.lParam
@MM.ptMinTrackSize.x=400 '<-- Min X size of your window
@MM.ptMinTrackSize.y=400 '<-- Min Y size of your window
@MM.ptMaxTrackSize.x=9999 '<-- Max X size of your window
@MM.ptMaxTrackSize.y=9999 '<-- Max Y size of your window
End If
Case %WM_Command
Select Case CB.Ctl
Case 802 : StandardPlacement 0
Case 803 : StandardPlacement 1
Case 803
Graphic Clear
ReadPartData
Array Sort PL(1), Call CustomSortDescend 'sort in descending order
PlaceParts_Std
DisplayInfo
Dialog Redraw hDlg
Case 804
Randomize Timer
RequiredArea = 99999999 'arbitrarily large starting point
ReadPartData
ReDim PLMin(UBound(PL))
Control Get Check hDlg, 104 To iLoops : iLoops = 1 + iLoops*99 '1 or 100
For k = 1 To iLoops 'iterate placement
Graphic Clear
For i = 1 To UBound(PL)
j = Rnd(1,UBound(PL)) : Swap PL(i),PL(j) 'random swap
Next i
PlaceParts_Std
'keep the results requiring the smallest area
If RequiredArea > (xrequired*yrequired) Then
RequiredArea = xrequired*yrequired 'area
RequiredX = xrequired : RequiredY = yrequired 'dimensions
For M = 0 To UBound(PL) : PLMin(M) = PL(M) : Next M 'part layout
End If
Next k
For M = 0 To UBound(PL) : PL(M) = PLMin(M) : Next M 'restore the minimum layout
Graphic Clear
For i = 1 To UBound(PL) : DrawPart(i) : Next i 'draw minimum layhout
xrequired = RequiredX : yrequired = RequiredY 'restore required dimensions
DrawContainer
DisplayInfo
Dialog Redraw hDlg
End Select
End Select
End Function
Sub ReadPartData
Local temp As String, i,j,pCount As Long
ReDim PL(0) 'zero element not used
'perimeter
Control Get Text hDlg, 200 To temp
xMax = Val(temp)
'part info into array
Control Get Text hDlg, 201 To temp
Dim PData(ParseCount(temp,$CrLf)) As String
Parse temp,PData(),$Crlf
'part dimensions and keepouts
For i = 0 To UBound(PData) 'x - y - qty - xk - yk (xk/yk is optional)
If Trim$(PData(i)) = "" Then Iterate For
pCount = Val(Parse$(PData(i), " ", 3))
ReDim Preserve PL(UBound(PL)+pCount)
For j = UBound(PL)- pCount+1 To UBound(PL)
PL(j).x = Val(Parse$(PData(i), " ", 1))
PL(j).y = Val(Parse$(PData(i), " ", 2))
temp = Parse$(PData(i), " ", 4)
If temp = "" Then PL(j).xk = 10 Else PL(j).xk = Val(temp)
temp = Parse$(PData(i), " ", 5)
If temp = "" Then PL(j).yk = 10 Else PL(j).yk = Val(temp)
PL(j).area = (PL(j).x+PL(j).xk) * (PL(j).y+PL(j).yk)
Next i
Next i
End Sub
Sub PlaceParts_Std
'left to right, then down when xMax is exceeded. as the parts are found in the list
Local i,x,y,xk,yk,xedge,yedge,xcenter,ycenter,xdelta,ydelta As Long
xrequired = 0 : yrequired = 0 : For i = 1 To UBound(PL) : PL(i).placed = 0 : Next i 'initialize
For i = 1 To UBound(PL)
If PL(i).placed = 1 Then Iterate For Else PL(i).placed = 1
x = PL(i).x + 2*PL(i).xk : y = PL(i).y + 2*PL(i).yk 'convenience variables, used in this function
Select Case (xedge+x)
Case < xMax 'keep moving right
xRequired = Max (xedge+x,xRequired)
PL(i).xcenter = xedge + x/2 : PL(i).ycenter = yedge + y/2
If ydelta < y Then ydelta = y
xedge = xedge + x
Case = xMax 'draw here, then next part at left
xRequired = Max (xMax,xRequired)
PL(i).xcenter = xedge + x/2 : PL(i).ycenter = yedge + y/2
If ydelta < y Then ydelta = y
yedge = yedge + ydelta
ydelta = 0
xedge = 0
Case > xMax 'draw this part at left
xRequired = Max (xedge,xRequired)
If GapFiller Then FillGap i,xedge,yedge,ydelta
yedge = yedge + ydelta
PL(i).xcenter = x/2 : PL(i).ycenter = yedge + y/2
ydelta = y
xedge = x
End Select
yRequired = yedge + ydelta
DrawPart(i) 'draw one part at a time
Next i
DrawContainer
End Sub
Sub DrawContainer
Graphic Style 2
Graphic Box (0,0)-(xrequired,yrequired),0,%Red,-2,0
End Sub
Sub DrawPart(i As Long)
Local x1,x2,y1,y2 As Long
x1 = PL(i).xcenter - PL(i).x/2
x2 = PL(i).xcenter + PL(i).x/2
y1 = PL(i).ycenter - PL(i).y/2
y2 = PL(i).ycenter + PL(i).y/2
Graphic Style 0
Graphic Box (x1,y1)-(x2,y2),0,%Blue,-2,0
Graphic Style 2
Graphic Box (x1-PL(i).xk,y1-PL(i).yk)-(x2+PL(i).xk,y2+PL(i).yk),0,%Blue,-2,0
Graphic Set Pos (PL(i).xcenter,PL(i).ycenter)
Graphic Set Pos (x1-PL(i).xk+11,y1-PL(i).yk+12)
Graphic Print Str$(i)
End Sub
Sub DisplayInfo
Local i As Long, temp As String, PartArea, PartPlusArea, eff As Single
ListBox Reset hDlg, 400
ListBox Add hDlg, 400, "Parts: " + Str$(UBound(PL))
ListBox Add hDlg, 400, "Required Area (x*y): " + Format$(xRequired*yRequired,"#,000,000")
ListBox Add hDlg, 400, "Required Size (xy): " + Str$(xRequired) + "x" + Str$(yRequired)
ListBox Add hDlg, 400, ""
ListBox Add hDlg, 400, "Parts List: x-y-z-xcenter-ycenter-area"
For i = 1 To UBound(PL)
PartArea = PartArea + PL(i).x*PL(i).y
PartPlusArea = PartPlusArea + PL(i).area
temp = Str$(i) + " "+ Str$(PL(i).x) + " " + Str$(PL(i).y) + " " + Str$(PL(i).z) + " " _
+ Str$(PL(i).xcenter) + " " + Str$(PL(i).ycenter) + Str$(PL(i).x*PL(i).y)
ListBox Add hDlg, 400, temp
Next i
ListBox Insert hDlg, 400, 4, "Efficiency: " + Format$(PartArea/(xrequired*yrequired)*100,"0")+"%" + " w/o keepout"
ListBox Insert hDlg, 400, 5, "Efficiency+: " + Format$(PartPlusArea/(xrequired*yrequired)*100,"0")+"%" + " w/keepout
End Sub
Function CustomSortAscend(R As PartType, S As PartType) As Long
If R.area < S.area Then Function = -1 : Exit Function
If R.area > S.area Then Function = +1 : Exit Function
End Function
Function CustomSortDescend(R As PartType, S As PartType) As Long
If R.area > S.area Then Function = -1 : Exit Function
If R.area < S.area Then Function = +1 : Exit Function
End Function
Sub FillGap(i As Long, xe As Long, ye As Long, yd As Long)
Local gxMax,gyMax,j,x,y As Long, temp As String
gxMax = xMax - xe
gyMax = yd
For j = UBound(PL) To i+1 Step - 1
If gxMax <= 0 Then Exit For
If PL(j).placed = 1 Then Iterate For
If ((PL(j).x+PL(j).xk) <= gxMax) AND ((PL(j).y+PL(j).yk)<=gyMax) Then
'set part properties
PL(j).xcenter = xe + (PL(j).x+2*PL(j).xk)/2 : PL(j).ycenter = ye + (PL(j).y+2*PL(j).yk)/2
PL(j).placed = 1
DrawPart j
'reduce gapsize (x-only)
gxMax = gxMax - PL(j).x - 2*PL(j).xk
xe = xe + PL(j).x + 2*PL(j).xk
xRequired = Max(xe,xRequired)
temp = temp + Str$(j)
End If
Next i
End Sub
Sub AddToolbar
'add toolbar
Control Add Toolbar, hDlg, 500,"", 0,0,0,0, %CCS_NoMoveY
'create imagelist
ImageList New Icon 16,16,32,3 To hLst
ImageList Add Icon hLst, "open" '1
ImageList Add Icon hLst, "save" '2
ImageList Add Icon hLst, "sortd" '3
'attach imagelist
Toolbar Set ImageList hDlg, 500, hLst, 0
'create buttons
Toolbar Add Button hDlg, 500, 1, 800, %TbStyle_Button, "Open"
Toolbar Add Button hDlg, 500, 2, 801, %TbStyle_Button, "Save"
Toolbar Add Separator hDlg, 500, 20
Toolbar Add Button hDlg, 500, 3, 802, %TbStyle_Button, "Std"
Toolbar Add Button hDlg, 500, 3, 803, %TbStyle_Button, "Sort"
Toolbar Add Button hDlg, 500, 3, 804, %TbStyle_Button, "Rnd"
Toolbar Add Separator hDlg, 500, 20
Toolbar Add Button hDlg, 500, 6, 805, %TbStyle_Check, "Gap"
Toolbar Add Button hDlg, 500, 7, 806, %TbStyle_Check, "Loop"
Toolbar Add Button hDlg, 500, 8, 807, %TbStyle_Check, "Limits"
Toolbar Add Button hDlg, 500, 9, 808, %TbStyle_Check, "Auto"
Toolbar Add Button hDlg, 500, 9, 809, %TbStyle_Check, "Index"
End Sub
Sub AddControls
Local temp As String, style&, Style1&,Style2&
style& = %WS_Child Or %WS_Visible Or %ES_MultiLine Or %WS_VScroll _
Or %ES_AutoVScroll Or %ES_WantReturn Or %WS_TabStop
temp = "20 20 20" & $CrLf & "120 40 5" _
& $CrLf & "40 40 5" + $CrLf + "80 30 5"
Control Add Label, hDlg, 501,"Parts:",10,50,50,15
Control Add TextBox, hDlg, 201,temp, 10,65,200,100,style&
Control Add Label, hDlg, 501,"Max X-Size:",10,170,60,15
Control Add TextBox, hDlg, 200,"400", 10,185,60,20
Control Add Label, hDlg, 503,"Random Iterations:",120,170,100,15
Dim AList(6) As String
Array Assign AList() = "1","25","50","100","250","500","1000"
Style1& = %CBS_DropDownList Or %WS_TabStop Or %WS_VScroll
Style2& = %WS_Ex_Left Or %WS_Ex_ClientEdge
Control Add ComboBox, hDlg,504,AList(),120,185,90,120,Style1&,Style2&
ComboBox Select hDlg, 504, 1
Control Add Label, hDlg, 502,"Results:",10,220,80,15
Control Add ListBox, hDlg, 400,, 10,235,200,250, %WS_TabStop Or %WS_VScroll,%WS_Ex_ClientEdge
Control Add Graphic, hDlg, 300, "", 240,65,800,800
Graphic Attach hDlg, 300
Control Add StatusBar, hDlg, 520,"",0,0,0,0,%CCS_Bottom Or %SBars_SizeGrip
StatusBar Set Parts hDlg, 520, 150, 150, 99999
End Sub
Sub AddMenu()
Menu New Bar To hMenu
Menu New Popup To hMenuOptions
Menu Add Popup, hMenu, "Options", hMenuOptions, %MF_Enabled
'Create Options + Children -------------------------
Menu Add String, hMenuOptions, "one", 1001, %MF_Enabled
Menu Add String, hMenuOptions, "two", 1002, %MF_Enabled
Menu Attach hMenu, hDlg
End Sub
Sub Settings_INI(Task$)
Local x As Long, y As Long
Local xResult As Asciiz*%Max_Path, yResult As Asciiz*%Max_Path
Local temp As Asciiz*%Max_Path, INIFileName As Asciiz*%Max_Path
'defines file name (any file name will work)
INIFileName = Exe.Path$ + "gblayout.ini"
If Task$ = "get" Then
'get dialog top/left from INI file and use to set Dialog location
Getprivateprofilestring "All", "Left", "100", xResult, %Max_Path, INIFileName
Getprivateprofilestring "All", "Top", "100", yResult, %Max_Path, INIFileName
Dialog Set Loc hDlg, Val(xResult$), Val(yResult$) 'left/top
'get dialog width/height from INI file and use to set Dialog size
GetPrivateProfileString "All", "Width", "850", xResult, %Max_Path, INIFileName
GetPrivateProfileString "All", "Height", "700", yResult, %Max_Path, INIFileName
Dialog Set Size hDlg,Val(xResult$), Val(yResult$) 'width/height
' Getprivateprofilestring "All", "RotateX", "1", temp, %Max_Path, INIFileName : RotateX = Val(temp)
' Getprivateprofilestring "All", "LineColor", Str$(%Yellow), temp, %Max_Path, INIFileName : LineColor = Val(temp)
'apply as needed
' Toolbar Set State hDlg, %IDC_ToolbarA, ByCmd 201, %TBState_Checked * PowerOn Or %TBState_Enabled
End If
If Task$ = "save" Then
'save dialog size/location unless minimized or maximized
If IsFalse(IsIconic(hDlg) Or IsZoomed(hDlg)) Then
Dialog Get Loc hDlg To x,y
WritePrivateProfileString "All", "Left", Str$(x), INIFileName
WritePrivateProfileString "All", "Top", Str$(y), INIFileName
Dialog Get Size hDlg To x,y
WritePrivateProfileString "All", "Width", Str$(x), INIFileName
WritePrivateProfileString "All", "Height", Str$(y), INIFileName
End If
' temp = Str$(RotateX) : WritePrivateProfileString "All", "RotateX", temp, INIFileName
' temp = CurrentFileName : WritePrivateProfileString "All", "CurrentFileName", temp, INIFileName
End If
End Sub
'gbs_00578
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm