BEST CUTTING SIZE TO MINIMIZE WASTAGE

[CADSURAY]

20 hours ago, marko_ribar said:

I've played with this topic too... Only problem I see is that list for analyzing is quite huge - over 1000 items... And I didn't used boundary for packing, but arranged all items in single line starting from point 0,0,0 and all up in right direction along X axis of WCS... So here is my code :

 

(defun c:minpolygonrec-nesting-ss ( / minarearectangle graham-scan sort-by-angle-distance dotpr crosspr det unique clockwise-p car-sort _vl-sort s lw lwx bulgs bulge rec pts minrec pt ptt lst jj d ll lr ur ul pre suf )

  (vl-load-com)

  ;;;=======================================================
  ;;;Function : Find the minimum area of encasing rectangle.
  ;;;Arguments : A CCW HULL     
  ;;;Return: The Four points of Rectangle and its Area      
  ;;;=======================================================
  (defun minarearectangle ( ptlist / aa ai bb d1 d2 edge i i1x i1y i2x i2y il inf ix iy j1 j2 mina minh minw norh norm pi1 pi2 pti0 pti1 pti2 ptj1 ptk1 ptm1 pts1 pts2 pts3 pts4 rec1 rec2 rec3 rec4 rect vech vecl vj12 vm12 )
    (setq inf 1e309)       
    (setq mina inf)       ;Initiating the Minimum is infinite
    (setq pti0 (car ptlist))      ;the first point of Hull.
    (setq pts1 (append ptlist (list pti0)))    ;add the first point at back of Hull
    (setq pts2 (cdr (append ptlist ptlist (list pti0))))   ;Construct a loop for the hull
    (setq i 0)        

    ;;Find area of encasing rectangle anchored on each edge.
    (repeat (length ptlist)
      (setq pi1 (car pts1)      
           pi2 (cadr pts1)
           i1x (car pi1)
           i1y (cadr pi1)
           i2x (car pi2)
           i2y (cadr pi2)
           ix (- i2x i1x)
           iy (- i2y i1y)
           il (distance (list ix iy) '(0.0 0.0))
      )

      ;;Find a vertex on on first perpendicular line of support
      (while (> (dotpr ix iy pts2) 0.0)
        (setq pts2 (cdr pts2))
      )

      ;;Find a vertex on second perpendicular line of support
      (if (= i 0)
        (setq pts3 pts2)
      )
      (while (> (crosspr ix iy pts3) 0.0)
        (setq pts3 (cdr pts3))
      )

      ;;Find a vertex on second perpendicular line of support
      (if (= i 0)
        (setq pts4 pts3)
      )
      (while (< (dotpr ix iy pts4) 0.0)
        (setq pts4 (cdr pts4))
      )

      ;;Find distances between parallel and perpendicular lines of support
      (cond
        ( (equal i1x i2x 1e-4)
          (setq d1 (- (caar pts3) i1x)
                d2 (- (cadar pts4) (cadar pts2))
          )
        )
        ( (equal i1y i2y 1e-4)
          (setq d1 (- (cadar pts3) i1y)
                d2 (- (caar pts4) (caar pts2))
          )
        )
        ( t
          (setq aa (det pi1 pi2 (car pts3)))
          (setq d1 (/ aa il))
          (setq j1 (car pts2))
          (setq j2 (list (- (car j1) iy) (+ (cadr j1) ix)))
          (setq bb (det j1 j2 (car pts4)))
          (setq d2 (/ bb il))
        )
      )

      ;;Compute area of encasing rectangle anchored on current edge.
      ;;if the area is smaller than the old Minimum area, then update, and record the width, height and five points.
      (setq ai (abs (* d1 d2)))
      (if (< ai mina)
        (setq mina ai
             minh d1
             minw d2
             pti1 pi1
             pti2 pi2
             ptj1 (car pts2)
             ptk1 (car pts3)
             ptm1 (car pts4)
        )
      )
      (setq pts1 (cdr pts1))
      (setq i (1+ i))
    );_end repeat

    ;;according to the result ,draw the Minimum Area Rectangle
    (setq edge (mapcar '- pti2 pti1))
    (setq vecl (distance edge '(0.0 0.0)))
    (setq norh (abs (/ minh vecl)))

    (setq norm (list (- (cadr edge)) (car edge)))
    (setq vj12 (mapcar '+ ptj1 norm))
    (setq vm12 (mapcar '+ ptm1 norm))
    (setq vech (mapcar '* (list norh norh) norm))

    (setq rec1 (inters pti1 pti2 ptj1 vj12 nil))
    (setq rec4 (inters pti1 pti2 ptm1 vm12 nil))
    (setq rec2 (mapcar '+ rec1 vech))
    (setq rec3 (mapcar '+ rec4 vech))
    (setq rect (list rec1 rec2 rec3 rec4))
    (list rect (* (distance rec1 rec2) (distance rec2 rec3)))
  );_end (minarearectangle ptlist)

  (defun graham-scan ( ptlist / hullpt maxxpt sortpt p q )
    (if (< (length ptlist) 3)
      ptlist
      (progn
        (setq maxxpt (assoc (apply 'max (mapcar 'car ptlist)) ptlist))
        (setq sortpt (sort-by-angle-distance ptlist maxxpt))
        (setq hullpt (list (cadr sortpt) maxxpt))      
        (foreach n (cddr sortpt) 
          (setq hullpt (cons n hullpt))
          (setq p (cadr hullpt))
          (setq q (caddr hullpt))
          (while (and q (> (det n p q) -1e-6))
            (setq hullpt (cons n (cddr hullpt)))
            (setq p (cadr hullpt))
            (setq q (caddr hullpt))
          )
        )
        (reverse hullpt)
      )
    )
  )

  (defun sort-by-angle-distance ( ptlist pt )
    (_vl-sort ptlist
      (function
        (lambda ( e1 e2 / ang1 ang2 )
          (setq ang1 (angle pt e1))
          (setq ang2 (angle pt e2))
          (if (= ang1 ang2)
            (< (distance pt e1) (distance pt e2))
            (< ang1 ang2)
          )
        )
      )
    )
  )

  ;;;= x1*x2 + y1*y2
  (defun dotpr ( ix iy pts / pt1 pt2 )
    (setq pt1 (car pts))
    (setq pt2 (cadr pts))
    (+ (* ix (- (car pt2) (car pt1)))
       (* iy (- (cadr pt2) (cadr pt1)))
    )
  )

  ;;;= x1*y2 - x2*y1
  (defun crosspr ( ix iy pts / pt1 pt2 )
    (setq pt1 (car pts))
    (setq pt2 (cadr pts))
    (- (* ix (- (cadr pt2) (cadr pt1)))
       (* iy (- (car pt2) (car pt1)))
    )
  )

  (defun det ( p1 p2 p3 / x2 y2 )
    (setq x2 (car p2)
         y2 (cadr p2)
    )
    (- (* (- x2 (car p3)) (- y2 (cadr p1)))
       (* (- x2 (car p1)) (- y2 (cadr p3)))
    )
  )

  (defun clockwise-p ( p1 p2 p3 )
    (minusp (- (* (car (mapcar '- p2 p1)) (cadr (mapcar '- p3 p1))) (* (cadr (mapcar '- p2 p1)) (car (mapcar '- p3 p1)))))
  )

  (defun unique ( lst fuzz / a ll )
    (while (setq a (car lst))
      (if (vl-some (function (lambda ( x ) (equal x a fuzz))) (cdr lst))
        (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a fuzz))) (cdr lst)))
        (setq ll (cons a ll) lst (cdr lst))
      )
    )
    (reverse ll)
  )

  (defun car-sort ( lst cmp / rtn )
    (setq rtn (car lst))
    (foreach itm (cdr lst)
      (if (apply cmp (list itm rtn))
        (setq rtn itm)
      )
    )
    rtn
  )

  (defun _vl-sort ( l f / *q* ll ff gg )
    (if (= (type f) 'sym)
      (setq f (eval f))
    )
    (while (setq *q* (car l))
      (setq ll
        (if (null ll)
          (cons *q* ll)
          (cond
            ( (apply f (list (last ll) *q*))
              (append ll (list *q*))
            )
            ( (apply f (list *q* (car ll)))
              (cons *q* ll)
            )
            ( t
              (setq ff nil)
              (setq gg (apply (function append) (append (mapcar (function (lambda ( *xxx* *yyy* ) (if (null ff) (if (apply f (list *q* *yyy*)) (progn (setq ff t) (list *xxx* *q*)) (list *xxx*)) (list *xxx*)))) ll (cdr ll)) (list (list (last ll))))))
              (if (null ff)
                (append ll (list *q*))
                gg
              )
            )
          )
        )
      )
      (setq l (cdr l))
    )
    ll
  )

  (prompt "\nSelect closed LWPOLYLINE polygons on unlocked layer(s)...")
  (setq s (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "&") (70 . 1))))
  (if s
    (repeat (setq i (sslength s))
      (setq lw (ssname s (setq i (1- i))))
      (setq pts (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw)))))
      (setq pts (unique pts 5.0))
      (vla-getboundingbox (vlax-ename->vla-object lw) 'll 'ur)
      (mapcar 'set '(ll ur) (mapcar 'safearray-value (list ll ur)))
      (setq lr (list (car ur) (cadr ll)) ul (list (car ll) (cadr ur)))
      (setq ptt (car-sort pts '(lambda ( a b ) (< (distance ll a) (distance ll b)))))
      (setq pre (vl-member-if '(lambda ( x ) (equal ptt x 1e-3)) pts))
      (setq suf (reverse (cdr (vl-member-if '(lambda ( x ) (equal ptt x 1e-3)) (reverse pts)))))
      (setq pts (append pre suf))
      (if (clockwise-p (car pts) (cadr pts) (caddr pts))
        (setq pts (append (list (car pts)) (reverse (cdr pts))))
      )
      (entupd
        (cdr
          (assoc -1
            (entmod
              (append
                (subst (cons 90 (length pts)) (assoc 90 lwx) (reverse (cdr (member (assoc 10 lwx) (reverse lwx)))))
                (mapcar '(lambda ( x ) (cons 10 x)) pts)
                (list (list 210 0.0 0.0 1.0))
              )
            )
          )
        )
      )
      (setq bulgs (mapcar 'cdr (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) lwx)))
      (while (setq bulge (vl-some '(lambda ( x ) (if (/= x 0.0) x)) bulgs))
        (entupd (cdr (assoc -1 (entmod (subst (cons 42 0.0) (cons 42 bulge) lwx)))))
      )
      (setq minrec (minarearectangle (graham-scan pts)))
      (setq pt (car-sort (car minrec) '(lambda ( a b ) (< (distance ptt a) (distance ptt b)))))
      (setq pre (vl-member-if '(lambda ( x ) (equal pt x 1e-3)) (car minrec)))
      (setq suf (reverse (cdr (vl-member-if '(lambda ( x ) (equal pt x 1e-3)) (reverse (car minrec))))))
      (setq minrec (subst (append pre suf) (car minrec) minrec))
      (if (clockwise-p (car (car minrec)) (cadr (car minrec)) (caddr (car minrec)))
        (setq minrec (subst (list (car (car minrec)) (cadddr (car minrec)) (caddr (car minrec)) (cadr (car minrec))) (car minrec) minrec))
      )
      (setq rec
        (entmakex
          (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            '(100 . "AcDbPolyline")
            '(90 . 4)
            (cons 70 (1+ (* 128 (getvar 'plinegen))))
            '(38 . 0.0)
            (cons 10 (car (car minrec)))
            (cons 10 (cadr (car minrec)))
            (cons 10 (caddr (car minrec)))
            (cons 10 (cadddr (car minrec)))
            '(210 0.0 0.0 1.0)
            '(62 . 3)
          )
        )
      )
      (setq lst (cons (list lw rec pt (angle (car (car minrec)) (cadr (car minrec))) (distance (car (car minrec)) (cadr (car minrec))) (cadr minrec)) lst))
    )
  )
  (setq lst (_vl-sort lst '(lambda ( a b ) (if (equal (last a) (last b) 1e-6) (< (nth 4 a) (nth 4 b)) (< (last a) (last b))))))
  (setq jj -1 d 0.0)
  (foreach rr lst
    (setq jj (1+ jj))
    (vla-rotate (vlax-ename->vla-object (car rr)) (vlax-3d-point (caddr rr)) (- (cadddr rr)))
    ;(vla-rotate (vlax-ename->vla-object (cadr rr)) (vlax-3d-point (caddr rr)) (- (cadddr rr)))
    (vla-move (vlax-ename->vla-object (car rr)) (vlax-3d-point (caddr rr)) (if (= jj 0) (vlax-3d-point (list 0.0 0.0 0.0)) (vlax-3d-point (list (setq d (+ d (nth 4 (nth (1- jj) lst)))) 0.0 0.0))))
    ;(vla-move (vlax-ename->vla-object (cadr rr)) (vlax-3d-point (caddr rr)) (if (= jj 0) (vlax-3d-point (list 0.0 0.0 0.0)) (vlax-3d-point (list d 0.0 0.0))))
  )
  (princ)
)

 

HTH.

M.R.

Regards...

Sir marko_ribar

 

Thank you so much for the elaborate code. I tried it but some error is showing up. 

Attached Screenshot and the file I tried it in.

all layers were unlocked before attempting to run your Code.

 

 

 

 

PLY WASTAGE CALCULATION.dwg