(defun c:packing-nesting ( / ftoa proc proc-rot func p pp q rec w h s l a aa xx yy hh pl x ll ip vv minp maxp ) ;;; *gap* - global variable (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun ftoa ( n / m a s b ) (if (numberp n) (progn (setq m (fix ((if (< n 0) - +) n 1e-8))) (setq a (abs (- n m))) (setq m (itoa m)) (setq s "") (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0)))) (setq s (strcat s (itoa b))) (setq a (- (* a 10.0) b)) ) (if (= (type n) 'int) m (if (= s "") m (if (and (= m "0") (< n 0)) (strcat "-" m "." s) (strcat m "." s) ) ) ) ) ) ) (defun proc nil (vla-getboundingbox (vlax-ename->vla-object (car (car l))) (quote minp) (quote maxp)) (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp))) (setq minp (mapcar (function +) minp (list (- (/ *gap* 2.0)) (- (/ *gap* 2.0)))) maxp (mapcar (function +) maxp (list (/ *gap* 2.0) (/ *gap* 2.0)))) (setq pl (list (list (car minp) (cadr minp)) (list (car maxp) (cadr minp)) (list (car maxp) (cadr maxp)) (list (car minp) (cadr maxp)))) (setq pp (list xx yy)) (setq vv (mapcar (function -) (car pl) pp)) (vla-move (vlax-ename->vla-object (car (car l))) (vlax-3d-point (append (car pl) (list 0.0))) (vlax-3d-point (mapcar (function -) (car pl) vv))) (setq minp nil maxp nil) ) (defun proc-rot ( elst ) (foreach e elst (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp)) (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp))) (if (< (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))) (vla-rotate (vlax-ename->vla-object e) (vlax-3d-point (list 0.0 0.0 0.0)) (* 0.5 pi)) ) ) ) (defun func nil (vl-some (function (lambda ( q ) (equal (list (car ip) (cadr ip)) q 1e-6))) (mapcar (function cadr) ll)) ) (initget 4) (setq *gap* (cond ( (getdist (strcat "\nPick or specify gap between pieces <" (ftoa (setq *gap* (if (not *gap*) 0.0 *gap*))) "> : ")) ) ( t *gap* ))) (setq p (getpoint "\nLower Left Point : ")) (setq q (getcorner p "\nUpper Right Point : ")) (mapcar (function set) (list (quote p) (quote q)) (list (list (min (car p) (car q)) (min (cadr p) (cadr q))) (list (max (car p) (car q)) (max (cadr p) (cadr q))) ) ) (setq rec (entmakex (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 4) (cons 70 (1+ (* 128 (getvar 'plinegen)))) (cons 38 0.0) (list 10 (car p) (cadr p)) (list 10 (car q) (cadr p)) (list 10 (car q) (cadr q)) (list 10 (car p) (cadr q))))) (setq p (mapcar (function +) p (list (/ *gap* 2.0) (/ *gap* 2.0))) q (mapcar (function +) q (list (- (/ *gap* 2.0)) (- (/ *gap* 2.0))))) (setq w (abs (- (car p) (car q)))) (setq h (abs (- (cadr p) (cadr q)))) (prompt "\nSelect objects that can and can not be rectangles on unlocked layer(s)...") (setq s (ssget "_:L")) (if (and rec s) (progn (setq l (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))) (proc-rot l) (setq l (mapcar (function (lambda ( e / minp maxp ) (vla-getboundingbox (vlax-ename->vla-object e) (quote minp) (quote maxp)) (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp))) (setq minp (mapcar (function +) minp (list (- (/ *gap* 2.0)) (- (/ *gap* 2.0)))) maxp (mapcar (function +) maxp (list (/ *gap* 2.0) (/ *gap* 2.0)))) (list e (list (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))) ) )) l ) ) (setq a (mapcar (function (lambda ( e ) (* (car (cadr e)) (cadr (cadr e))))) l)) (setq l (mapcar (function (lambda ( e b ) (list (car e) (cadr e) b))) l a)) (setq l (vl-sort l (function (lambda ( a b ) (> (last a) (last b)))))) (setq a (* w h)) (setq aa (apply (function +) (mapcar (function caddr) l))) (if (< aa a) (progn (setq yy 0.0) (while l (if hh (setq yy (+ yy (car (vl-sort hh (function >)))))) (setq xx 0.0 hh nil) (while (and l (<= (+ xx (car (cadr (car l)))) w)) (proc) (vla-getboundingbox (vlax-ename->vla-object (car (car l))) (quote minp) (quote maxp)) (mapcar (function set) (list (quote minp) (quote maxp)) (mapcar (function safearray-value) (list minp maxp))) (setq minp (mapcar (function +) minp (list (- (/ *gap* 2.0)) (- (/ *gap* 2.0)))) maxp (mapcar (function +) maxp (list (/ *gap* 2.0) (/ *gap* 2.0)))) (setq ll (cons (list (car (car l)) (list (list (car minp) (cadr minp)) (list (car maxp) (cadr minp)) (list (car maxp) (cadr maxp)) (list (car minp) (cadr maxp))) (* (- (car maxp) (car minp)) (- (cadr maxp) (cadr minp))) ) ll ) ) (if (vl-some (function ;;; (cdr ll) ;;; (lambda ( e ) (or (if (and (setq ip (inters (cadddr (setq pl (list minp (list (car maxp) (cadr minp)) maxp (list (car minp) (cadr maxp)))) ) (car pl) (cadddr (cadr e)) (car (cadr e)) ) ) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (car pl) (cadddr (cadr e)) (caddr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (car pl) (caddr (cadr e)) (cadr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (car pl) (cadddr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadddr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadddr (cadr e)) (caddr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (caddr pl) (caddr (cadr e)) (cadr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (caddr pl) (cadr pl) (cadddr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (caddr pl) (cadr pl) (cadddr (cadr e)) (caddr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (caddr pl) (cadr pl) (caddr (cadr e)) (cadr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (caddr pl) (cadr pl) (cadr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadr pl) (car pl) (cadddr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadr pl) (car pl) (cadddr (cadr e)) (caddr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadr pl) (car pl) (caddr (cadr e)) (cadr (cadr e)))) (func) ) (setq ip nil) t ) (if (and (setq ip (inters (cadr pl) (car pl) (cadr (cadr e)) (car (cadr e)))) (func) ) (setq ip nil) t ) ) ) ) (cdr ll) ;;; 4x4=16 ;;; ) ;;; if (vl-some) => then vvv ;;; (progn (setq hh (cons (cadr (cadr (car l))) hh)) (proc) ) ;;; else vvv ;;; (progn (setq hh (cons (cadr (cadr (car l))) hh)) (proc) ) ) (setq xx (+ xx (car (cadr (car l))))) (setq l (cdr l)) ) ;;; end (while) ;;; ) ;;; end (while) ;;; ) ) (setq l (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))) (foreach e l (vla-move (vlax-ename->vla-object e) (vlax-3d-point (list 0.0 0.0 0.0)) (vlax-3d-point (list (car p) (cadr p) 0.0))) ;;; move all rectangles from 0,0,0 to Lower Left point of bigger - main frame rectangle ;;; ) ) ) (princ) )