Placement II

Category: Utilities

Date: 03-28-2012

Return to Index


 
'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:
#Compiler PBWin 10
#Compile EXE
#Dim All
#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$ = "getThen
      '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$ = "saveThen
      '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


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm