Author Topic: Automatic Nesting for lisp?  (Read 20280 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 2829
  • Marko Ribar, architect
Re: Automatic Nesting for lisp?
« Reply #60 on: June 11, 2021, 11:29:46 AM »
Quote
I've added error handler, calculation of UNDO steps after finish and changed order of generating "l" list of (bp dx dy) so that when first pass of (main) function finishes it checks from lower left corner of main boundary for "bp"s again and not as it was from upper right to lower left... That's one thing in main routine "nesting.lsp" and I tried to make additional "nesting-new.lsp" with (process2rec) function that would try to implement checking of relation of 2 rectangles in processing nesting - all I could think of is that with this checking it's sometimes different choice of processing order of entities from list "el"... Marc's example with bigger main boundary is solvable by "nesting-new.lsp" and first DWG is somewhat better with original "nesting.lsp"... If someone has something new based on "nesting.lsp" it would be good to try to improve it, or post an opinion of what could be better and (or) relevant to this topic... Thanks for attention...

Here is "nesting-new.lsp" (look on previous page for "nesting.lsp")
http://www.theswamp.org/index.php?topic=52260.msg605093#msg605093


Code - Auto/Visual Lisp: [Select]
  1. (defun c:nesting-new ( / *error* car-sort insiderec process2rec process main adoc cmde ss s i e minpt maxpt dx dy el lw bp l ll al ka kb f )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if cmde
  6.       (setvar 'cmdecho cmde)
  7.     )
  8.     (if adoc
  9.       (vla-endundomark adoc)
  10.     )
  11.     (if m
  12.       (prompt m)
  13.     )
  14.     (princ)
  15.   )
  16.  
  17.   (defun car-sort ( lst cmp / rtn )
  18.     (setq rtn (car lst))
  19.     (foreach itm (cdr lst)
  20.       (if (apply cmp (list itm rtn))
  21.         (setq rtn itm)
  22.       )
  23.     )
  24.     rtn
  25.   )
  26.  
  27.   (defun insiderec ( ll ur p )
  28.     (and
  29.       (< (car ll) (car p) (car ur))
  30.       (< (cadr ll) (cadr p) (cadr ur))
  31.     )
  32.   )
  33.  
  34.   (defun process2rec ( e el / dx1 dy1 dx2 dy2 ddxy1 ddxy2 ddxy3 ddxy4 ddxy5 ddxy6 ddxy7 ddxy8 a1 a2 a3 a4 a5 a6 a7 a8 r )
  35.     (if (and e (> (length el) 1))
  36.       (progn
  37.         (setq dx1 (caadr e))
  38.         (setq dy1 (cadadr e))
  39.         (foreach ee (vl-remove e el)
  40.           (setq dx2 (caadr ee))
  41.           (setq dy2 (cadadr ee))
  42.           (setq ddxy1 (list (+ dx1 dx2) (max dy1 dy2))) ;;; right side e normal ee normal
  43.           (setq ddxy2 (list (+ dx1 dy2) (max dy1 dx2))) ;;; right side e normal ee rotated
  44.           (setq ddxy3 (list (+ dy1 dx2) (max dx1 dy2))) ;;; right side e rotated ee normal
  45.           (setq ddxy4 (list (+ dy1 dy2) (max dx1 dx2))) ;;; right side e rotated ee rotated
  46.           (setq ddxy5 (list (max dx1 dx2) (+ dy1 dy2))) ;;; up side e normal ee normal
  47.           (setq ddxy6 (list (max dx1 dy2) (+ dy1 dx2))) ;;; up side e normal ee rotated
  48.           (setq ddxy7 (list (max dy1 dx2) (+ dx1 dy2))) ;;; up side e rotated ee normal
  49.           (setq ddxy8 (list (max dy1 dy2) (+ dx1 dx2))) ;;; up side e rotated ee rotated
  50.           (mapcar 'set '(a1 a2 a3 a4 a5 a6 a7 a8) (mapcar '(lambda ( x ) (* (car x) (cadr x))) (list ddxy1 ddxy2 ddxy3 ddxy4 ddxy5 ddxy6 ddxy7 ddxy8)))
  51.           (setq r (cons (list (- a1 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy1 "1") r))
  52.           (setq r (cons (list (- a2 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy2 "2") r))
  53.           (setq r (cons (list (- a3 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy3 "3") r))
  54.           (setq r (cons (list (- a4 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy4 "4") r))
  55.           (setq r (cons (list (- a5 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy5 "5") r))
  56.           (setq r (cons (list (- a6 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy6 "6") r))
  57.           (setq r (cons (list (- a7 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy7 "7") r))
  58.           (setq r (cons (list (- a8 (* dx1 dy1) (* dx2 dy2)) (list e ee) ddxy8 "8") r))
  59.         )
  60.         (car-sort r '(lambda ( a b ) (if (= (car a) (car b)) (< (* (car (caddr a)) (cadr (caddr a))) (* (car (caddr b)) (cadr (caddr b)))) (< (car a) (car b)))))
  61.       )
  62.     )
  63.   )
  64.  
  65.   (defun process ( el bp dx dy / e1 e2 dd1 dd2 e r )
  66.     (if (= 8 (logand 8 (getvar 'undoctl)))
  67.       (vla-endundomark adoc)
  68.     )
  69.     (vla-startundomark adoc)
  70.     (setq ka (1+ ka))
  71.     (setq kb (1+ kb))
  72.     (setq f nil)
  73.     (if (> (length el) 1)
  74.       (progn
  75.         (foreach e el
  76.           (setq r (cons (process2rec e el) r))
  77.         )
  78.         (setq r (car-sort
  79.                   (vl-remove-if '(lambda ( x )
  80.                                    (or
  81.                                      (minusp (- dx (car (caddr x))))
  82.                                      (minusp (- dy (cadr (caddr x))))
  83.                                    )
  84.                                  ) r
  85.                   ) '(lambda ( a b ) (< (min (- dx (car (caddr a))) (- dy (cadr (caddr a)))) (min (- dx (car (caddr b))) (- dy (cadr (caddr b))))))))
  86.       )
  87.     )
  88.     (if r
  89.       (if (or (= (last r) "1") (= (last r) "2") (= (last r) "5") (= (last r) "6"))
  90.         (progn
  91.           (setq e (caadr r))
  92.           (if
  93.             (not
  94.               (and
  95.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 1e-3 1e-3)))) al))
  96.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (caadr e) 0.0) (list -1e-3 1e-3)))) al))
  97.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 0.0 (cadadr e)) (list 1e-3 -1e-3)))) al))
  98.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (caadr e) (cadadr e)) (list -1e-3 -1e-3)))) al))
  99.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (* (caadr e) 0.5) (* (cadadr e) 0.5))))) al))
  100.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (car x))) al))
  101.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list (- (caadr x) (caar x)) 0.0)))) al))
  102.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (cadr x))) al))
  103.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list 0.0 (- (cadadr x) (cadar x)))))) al))
  104.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list (* (- (caadr x) (caar x)) 0.5) (* (- (cadadr x) (cadar x)) 0.5))))) al))
  105.               )
  106.             )
  107.             (setq e nil)
  108.           )
  109.         )
  110.         (progn
  111.           (setq e (caadr r))
  112.           (if
  113.             (not
  114.               (and
  115.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 1e-3 1e-3)))) al))
  116.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (cadadr e) 0.0) (list -1e-3 1e-3)))) al))
  117.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 0.0 (caadr e)) (list 1e-3 -1e-3)))) al))
  118.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (cadadr e) (caadr e)) (list -1e-3 -1e-3)))) al))
  119.                 (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (* (cadadr e) 0.5) (* (caadr e) 0.5))))) al))
  120.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (cadadr e) (caadr e))) (car x))) al))
  121.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (cadadr e) (caadr e))) (mapcar '+ (car x) (list (- (caadr x) (caar x)) 0.0)))) al))
  122.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (cadadr e) (caadr e))) (cadr x))) al))
  123.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (cadadr e) (caadr e))) (mapcar '+ (car x) (list 0.0 (- (cadadr x) (cadar x)))))) al))
  124.                 (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (cadadr e) (caadr e))) (mapcar '+ (car x) (list (* (- (caadr x) (caar x)) 0.5) (* (- (cadadr x) (cadar x)) 0.5))))) al))
  125.               )
  126.             )
  127.             (setq e nil)
  128.           )
  129.           (if e
  130.             (setq f t)
  131.           )
  132.         )
  133.       )
  134.     )
  135.     (if (null e)
  136.       (progn
  137.         (setq e1 (car-sort
  138.                    (vl-remove-if '(lambda ( x )
  139.                                     (or
  140.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list 1e-3 1e-3)))) al)
  141.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (caadr x) 0.0) (list -1e-3 1e-3)))) al)
  142.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list 0.0 (cadadr x)) (list 1e-3 -1e-3)))) al)
  143.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (caadr x) (cadadr x)) (list -1e-3 -1e-3)))) al)
  144.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (* (caadr x) 0.5) (* (cadadr x) 0.5))))) al)
  145.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (caadr x) (cadadr x))) (car y))) al)
  146.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (caadr x) (cadadr x))) (mapcar '+ (car y) (list (- (caadr y) (caar y)) 0.0)))) al)
  147.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (caadr x) (cadadr x))) (cadr y))) al)
  148.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (caadr x) (cadadr x))) (mapcar '+ (car y) (list 0.0 (- (cadadr y) (cadar y)))))) al)
  149.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (caadr x) (cadadr x))) (mapcar '+ (car y) (list (* (- (caadr y) (caar y)) 0.5) (* (- (cadadr y) (cadar y)) 0.5))))) al)
  150.                                       (minusp (- dx (caadr x)))
  151.                                       (minusp (- dy (cadadr x)))
  152.                                     )
  153.                                   ) el
  154.                    ) '(lambda ( a b ) (< (min (- dx (caadr a)) (- dy (cadadr a))) (min (- dx (caadr b)) (- dy (cadadr b)))))))
  155.         (setq e2 (car-sort
  156.                    (vl-remove-if '(lambda ( x )
  157.                                     (or
  158.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list 1e-3 1e-3)))) al)
  159.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (cadadr x) 0.0) (list -1e-3 1e-3)))) al)
  160.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list 0.0 (caadr x)) (list 1e-3 -1e-3)))) al)
  161.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (cadadr x) (caadr x)) (list -1e-3 -1e-3)))) al)
  162.                                       (vl-some '(lambda ( y ) (insiderec (car y) (cadr y) (mapcar '+ bp (list (* (cadadr x) 0.5) (* (caadr x) 0.5))))) al)
  163.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (cadadr x) (caadr x))) (car y))) al)
  164.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (cadadr x) (caadr x))) (mapcar '+ (car y) (list (- (caadr y) (caar y)) 0.0)))) al)
  165.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (cadadr x) (caadr x))) (cadr y))) al)
  166.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (cadadr x) (caadr x))) (mapcar '+ (car y) (list 0.0 (- (cadadr y) (cadar y)))))) al)
  167.                                       (vl-some '(lambda ( y ) (insiderec bp (mapcar '+ bp (list (cadadr x) (caadr x))) (mapcar '+ (car y) (list (* (- (caadr y) (caar y)) 0.5) (* (- (cadadr y) (cadar y)) 0.5))))) al)
  168.                                       (minusp (- dx (cadadr x)))
  169.                                       (minusp (- dy (caadr x)))
  170.                                     )
  171.                                   ) el
  172.                    ) '(lambda ( a b ) (< (min (- dx (cadadr a)) (- dy (caadr a))) (min (- dx (cadadr b)) (- dy (caadr b)))))))
  173.         (cond
  174.           ( (and e1 e2)
  175.             (setq dd1 (min (- dx (caadr e1)) (- dy (cadadr e1))))
  176.             (setq dd2 (min (- dx (cadadr e2)) (- dy (caadr e2))))
  177.             (if (< dd1 dd2)
  178.               (setq e e1)
  179.               (progn
  180.                 (vla-rotate (vlax-ename->vla-object (car e2)) (vlax-3d-point (caddr e2)) (* 0.5 pi))
  181.                 (vla-move (vlax-ename->vla-object (car e2)) (vlax-3d-point '(0 0)) (vlax-3d-point (mapcar '+ '(0 0) (list (cadadr e2) 0.0))))
  182.                 (setq e (subst (list (cadadr e2) (caadr e2)) (cadr e2) e2))
  183.               )
  184.             )
  185.           )
  186.           ( (and e1 (null e2))
  187.             (setq e e1)
  188.           )
  189.           ( (and e2 (null e1))
  190.             (vla-rotate (vlax-ename->vla-object (car e2)) (vlax-3d-point (caddr e2)) (* 0.5 pi))
  191.             (vla-move (vlax-ename->vla-object (car e2)) (vlax-3d-point '(0 0)) (vlax-3d-point (mapcar '+ '(0 0) (list (cadadr e2) 0.0))))
  192.             (setq e (subst (list (cadadr e2) (caadr e2)) (cadr e2) e2))
  193.           )
  194.         )
  195.       )
  196.     )
  197.     e
  198.   )
  199.  
  200.   (defun main ( el bp dx dy )
  201.     (if (setq e (process el bp dx dy))
  202.       (progn
  203.         (if f
  204.           (progn
  205.             (vla-rotate (vlax-ename->vla-object (car e)) (vlax-3d-point (caddr e)) (* 0.5 pi))
  206.             (vla-move (vlax-ename->vla-object (car e)) (vlax-3d-point '(0 0)) (vlax-3d-point (mapcar '+ '(0 0) (list (cadadr e) 0.0))))
  207.             (setq e (subst (list (cadadr e) (caadr e)) (cadr e) e))
  208.           )
  209.         )
  210.         (setq al (cons (list bp (mapcar '+ bp (list (caadr e) (cadadr e)))) al))
  211.         (setq l (append l (list (list (mapcar '+ bp (list (caadr e) 0.0)) (- dx (caadr e)) dy))))
  212.         (setq l (append l (list (list (mapcar '+ bp (list 0.0 (cadadr e))) dx (- dy (cadadr e))))))
  213.         (setq l (append l (list (list (mapcar '+ bp (list (caadr e) (cadadr e))) (- dx (caadr e)) (- dy (cadadr e))))))
  214.         (setq l (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal (car x) y 1e-6)) (mapcar 'car al))) l))
  215.         (if
  216.           (and
  217.             (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 1e-3 1e-3)))) (cdr al)))
  218.             (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (caadr e) 0.0) (list -1e-3 1e-3)))) (cdr al)))
  219.             (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list 0.0 (cadadr e)) (list 1e-3 -1e-3)))) (cdr al)))
  220.             (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (caadr e) (cadadr e)) (list -1e-3 -1e-3)))) (cdr al)))
  221.             (not (vl-some '(lambda ( x ) (insiderec (car x) (cadr x) (mapcar '+ bp (list (* (caadr e) 0.5) (* (cadadr e) 0.5))))) (cdr al)))
  222.             (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (car x))) (cdr al)))
  223.             (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list (- (caadr x) (caar x)) 0.0)))) (cdr al)))
  224.             (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (cadr x))) (cdr al)))
  225.             (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list 0.0 (- (cadadr x) (cadar x)))))) (cdr al)))
  226.             (not (vl-some '(lambda ( x ) (insiderec bp (mapcar '+ bp (list (caadr e) (cadadr e))) (mapcar '+ (car x) (list (* (- (caadr x) (caar x)) 0.5) (* (- (cadadr x) (cadar x)) 0.5))))) (cdr al)))
  227.           )
  228.           (progn
  229.             (vla-move (vlax-ename->vla-object (car e)) (vlax-3d-point (caddr e)) (vlax-3d-point bp))
  230.             (setq el (vl-remove-if '(lambda ( x ) (eq (car x) (car e))) el))
  231.             (cond
  232.               ( (process el (mapcar '+ bp (list (caadr e) 0.0)) (- dx (caadr e)) dy)
  233.                 (vl-cmdf "_.undo" "_b")
  234.                 (setq kb (1- kb))
  235.                 (main el (mapcar '+ bp (list (caadr e) 0.0)) (- dx (caadr e)) dy)
  236.               )
  237.               ( (process el (mapcar '+ bp (list 0.0 (cadadr e))) dx (- dy (cadadr e)))
  238.                 (vl-cmdf "_.undo" "_b")
  239.                 (setq kb (1- kb))
  240.                 (main el (mapcar '+ bp (list 0.0 (cadadr e))) dx (- dy (cadadr e)))
  241.               )
  242.               ( (process el (mapcar '+ bp (list (caadr e) (cadadr e))) (- dx (caadr e)) (- dy (cadadr e)))
  243.                 (vl-cmdf "_.undo" "_b")
  244.                 (setq kb (1- kb))
  245.                 (main el (mapcar '+ bp (list (caadr e) (cadadr e))) (- dx (caadr e)) (- dy (cadadr e)))
  246.               )
  247.               ( t el )
  248.             )
  249.           )
  250.           el
  251.         )
  252.       )
  253.       el
  254.     )
  255.   )
  256.  
  257.   (if (= 8 (logand 8 (getvar 'undoctl)))
  258.     (vla-endundomark adoc)
  259.   )
  260.   (setq cmde (getvar 'cmdecho))
  261.   (setvar 'cmdecho 0)
  262.   (setq ka 0)
  263.   (setq kb 0)
  264.   (if
  265.     (and
  266.       (not (prompt "\nSelect parts for nesting..."))
  267.       (setq ss (ssget "_:L"))
  268.       (not (prompt "\nPick boundary RECTANGLE..."))
  269.       (setq s (ssget "_+.:E:S" (list '(0 . "LWPOLYLINE") '(90 . 4) '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  270.     )
  271.     (progn
  272.       (repeat (setq i (sslength ss))
  273.         (setq e (ssname ss (setq i (1- i))))
  274.         (vla-getboundingbox (vlax-ename->vla-object e) 'minpt 'maxpt)
  275.         (mapcar 'set '(minpt maxpt) (mapcar 'safearray-value (list minpt maxpt)))
  276.         (setq dx (- (car maxpt) (car minpt)))
  277.         (setq dy (- (cadr maxpt) (cadr minpt)))
  278.         (setq el (cons (list e (list dx dy) minpt) el))
  279.       )
  280.       (setq lw (ssname s 0))
  281.       (vla-getboundingbox (vlax-ename->vla-object lw) 'minpt 'maxpt)
  282.       (mapcar 'set '(minpt maxpt) (mapcar 'safearray-value (list minpt maxpt)))
  283.       (setq dx (- (car maxpt) (car minpt)))
  284.       (setq dy (- (cadr maxpt) (cadr minpt)))
  285.       (setq bp minpt)
  286.       (setq el (main el bp dx dy))
  287.       (while (and el (setq ll (car l)))
  288.         (setq l (cdr l))
  289.         (mapcar 'set '(bp dx dy) ll)
  290.         (setq el (main el bp dx dy))
  291.       )
  292.       (prompt "\nType \"UNDO\" ") (princ ka) (prompt " for back if you are using AutoCAD...")
  293.       (prompt "\nType \"UNDO\" ") (princ kb) (prompt " for back if you are using BricsCAD...")
  294.     )
  295.   )
  296.   (*error* nil)
  297. )
  298.  

Regards, M.R.
« Last Edit: June 12, 2021, 08:11:17 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1336
  • Marco
Re: Automatic Nesting for lisp?
« Reply #61 on: July 15, 2021, 09:53:13 AM »
Marko, I tried your program, this is the result:

ribarm

  • Gator
  • Posts: 2829
  • Marko Ribar, architect
Re: Automatic Nesting for lisp?
« Reply #62 on: July 15, 2021, 11:21:33 AM »
Look Marc', there were many attempts for this problem for solution to be found, but all up to now, they were just attempts... I believe that you can get your example solved with my previously posted code and picked smaller rectangle... But that's all... When there are more rectangles that vary in sizes, the task complicate enourmously... I was able to write 2 more algorithms that were similar, but not for nesting - they are for packing in 2d and 3d... I can only say that when you code for this, you must not apply both 2d entities along with 3d ones - they have their geometry specific properties and although you can have 3d algorithm - it does not mean it can be applicable for all... There were some attempts in history called "guilotine cutting" - meaning that when you cut, you can make knife go only straight until piece is choped... Also there were some called non-guilotine where you can position pieces differently than straight, but this thing also complicates tasks... There is online solution finder for big outiline where you can put integer up to 1000 units in both directions and search for all equal smaller pieces where largest piece size is smaller integer than smaller size of outline... Algorithm is probably the best you can use, but the code is hidden from public... For testing here is the link : http://lagrange.ime.usp.br/~lobato/packing/run/index.php
You may also want to read about nesting problems more - there are some articles on www, but I didn't find an ALISP example(s)... So, if you have a time and you are interested in this problem, you can dedicate your time and code for solutions... But be informed that task although may look simple and easy, actually involves deeper understanding of basic geometry and high math skills... So good luck (what can I say different...)...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1336
  • Marco
Re: Automatic Nesting for lisp?
« Reply #63 on: July 15, 2021, 11:36:15 AM »
Thanks for your long answer and for your time  :-), i don't think i will try i don't have the mathematical basis to do it.  :nerdyembarassed:

vink8023

  • Mosquito
  • Posts: 4
Re: Automatic Nesting for lisp?
« Reply #64 on: September 15, 2021, 10:15:03 PM »
Reply to animated gif... Not 100% sure, but this is my simple version... Should work with imaginary rectangular bounding boxes like posted gif, but my version is using one single rectangle for entity where nesting is expected...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:nesting ( / *adoc* ss s bndr minp maxp w h i e eminp emaxp ew eh el x y bp ell elll )
  2.  
  3.  
  4.   (prompt "\nSelect nesting 2D entities...")
  5.   (setq ss (ssget "_:L"))
  6.   (prompt "\nPick boundary rectangle to nest to...")
  7.   (setq s (ssget "_+.:E:S" (list '(0 . "LWPOLYLINE") '(90 . 4) '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  8.   (setq bndr (ssname s 0))
  9.   (vla-getboundingbox (vlax-ename->vla-object bndr) 'minp 'maxp)
  10.   (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp)))
  11.   (setq w (- (car maxp) (car minp)))
  12.   (setq h (- (cadr maxp) (cadr minp)))
  13.   (repeat (setq i (sslength ss))
  14.     (setq e (ssname ss (setq i (1- i))))
  15.     (vla-getboundingbox (vlax-ename->vla-object e) 'eminp 'emaxp)
  16.     (mapcar 'set '(eminp emaxp) (mapcar 'safearray-value (list eminp emaxp)))
  17.     (setq ew (- (car emaxp) (car eminp)))
  18.     (setq eh (- (cadr emaxp) (cadr eminp)))
  19.     (setq el (cons (list eminp ew eh e) el))
  20.   )
  21.   (setq el (vl-sort el '(lambda ( a b ) (if (equal (caddr a) (caddr b) 1e-3) (< (cadr a) (cadr b)) (< (caddr a) (caddr b))))))
  22.   (while
  23.     (and
  24.       (car el)
  25.       (<
  26.         (cond
  27.           ( (null x) (setq x 0.0 y 0.0) x )
  28.           ( (> (+ x (cadar el)) w)
  29.             (setq x 0.0)
  30.             (foreach e elll
  31.               (setq ell (vl-remove e ell))
  32.             )
  33.             (setq elll ell)
  34.             (vl-some
  35.              '(lambda ( e )
  36.                 (if (< (cadar el) (car e))
  37.                   (setq y (+ (cadr e) (caddr (caddr e))))
  38.                 )
  39.               )
  40.               (reverse ell)
  41.             )
  42.             x
  43.           )
  44.           ( t
  45.             (if
  46.               (not
  47.                 (vl-some
  48.                  '(lambda ( e )
  49.                     (if (< (+ x (cadar el)) (car e))
  50.                       (setq y (+ (cadr e) (caddr (caddr e))))
  51.                     )
  52.                   )
  53.                   (reverse ell)
  54.                 )
  55.               )
  56.               (vl-some
  57.                '(lambda ( e )
  58.                   (if (or (< (+ x (cadar el)) (car e)) (< (+ x 1e-3) (car e)))
  59.                     (setq y (+ (cadr e) (caddr (caddr e))))
  60.                   )
  61.                 )
  62.                 (vl-sort ell '(lambda ( a b ) (> (car a) (car b))))
  63.               )
  64.             )
  65.             x
  66.           )
  67.         )
  68.         w
  69.       )
  70.       (or (< (+ y (caddar el)) h) (equal (+ y (caddar el)) h 1e-3))
  71.     )
  72.     (if (= x 0.0)
  73.       (setq bp (list (car minp) (+ y (cadr minp)) 0.0))
  74.       (setq bp (list (+ x (car minp)) (+ y (cadr minp)) 0.0))
  75.     )
  76.     (setq x (+ x (cadar el)))
  77.     (vla-move (vlax-ename->vla-object (cadddr (car el))) (vlax-3d-point (caar el)) (vlax-3d-point bp))
  78.     (setq ell (cons (list x y (car el)) ell))
  79.     (setq el (cdr el))
  80.   )
  81.   (vla-endundomark *adoc*)
  82.   (princ)
  83. )
  84.  

Regards, M.R.

How to modify the program to add spacing between parts and between materials and parts?

BIGAL

  • Swamp Rat
  • Posts: 1097
  • 40 + years of using Autocad
Re: Automatic Nesting for lisp?
« Reply #65 on: September 16, 2021, 08:45:41 PM »
The simplest way is draw a dummy line say from the corners for the gap required, should work, NOT TESTED !
A man who never made a mistake never made anything

vink8023

  • Mosquito
  • Posts: 4
Re: Automatic Nesting for lisp?
« Reply #66 on: September 16, 2021, 08:56:26 PM »
This is exactly what I wanted
« Last Edit: September 16, 2021, 09:02:27 PM by vink8023 »

vink8023

  • Mosquito
  • Posts: 4
Re: Automatic Nesting for lisp?
« Reply #67 on: September 16, 2021, 09:12:12 PM »
Reply to animated gif... Not 100% sure, but this is my simple version... Should work with imaginary rectangular bounding boxes like posted gif, but my version is using one single rectangle for entity where nesting is expected...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:nesting ( / *adoc* ss s bndr minp maxp w h i e eminp emaxp ew eh el x y bp ell elll )
  2.  
  3.  
  4.   (prompt "\nSelect nesting 2D entities...")
  5.   (setq ss (ssget "_:L"))
  6.   (prompt "\nPick boundary rectangle to nest to...")
  7.   (setq s (ssget "_+.:E:S" (list '(0 . "LWPOLYLINE") '(90 . 4) '(-4 . "<or") '(70 . 1) '(70 . 129) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
  8.   (setq bndr (ssname s 0))
  9.   (vla-getboundingbox (vlax-ename->vla-object bndr) 'minp 'maxp)
  10.   (mapcar 'set '(minp maxp) (mapcar 'safearray-value (list minp maxp)))
  11.   (setq w (- (car maxp) (car minp)))
  12.   (setq h (- (cadr maxp) (cadr minp)))
  13.   (repeat (setq i (sslength ss))
  14.     (setq e (ssname ss (setq i (1- i))))
  15.     (vla-getboundingbox (vlax-ename->vla-object e) 'eminp 'emaxp)
  16.     (mapcar 'set '(eminp emaxp) (mapcar 'safearray-value (list eminp emaxp)))
  17.     (setq ew (- (car emaxp) (car eminp)))
  18.     (setq eh (- (cadr emaxp) (cadr eminp)))
  19.     (setq el (cons (list eminp ew eh e) el))
  20.   )
  21.   (setq el (vl-sort el '(lambda ( a b ) (if (equal (caddr a) (caddr b) 1e-3) (< (cadr a) (cadr b)) (< (caddr a) (caddr b))))))
  22.   (while
  23.     (and
  24.       (car el)
  25.       (<
  26.         (cond
  27.           ( (null x) (setq x 0.0 y 0.0) x )
  28.           ( (> (+ x (cadar el)) w)
  29.             (setq x 0.0)
  30.             (foreach e elll
  31.               (setq ell (vl-remove e ell))
  32.             )
  33.             (setq elll ell)
  34.             (vl-some
  35.              '(lambda ( e )
  36.                 (if (< (cadar el) (car e))
  37.                   (setq y (+ (cadr e) (caddr (caddr e))))
  38.                 )
  39.               )
  40.               (reverse ell)
  41.             )
  42.             x
  43.           )
  44.           ( t
  45.             (if
  46.               (not
  47.                 (vl-some
  48.                  '(lambda ( e )
  49.                     (if (< (+ x (cadar el)) (car e))
  50.                       (setq y (+ (cadr e) (caddr (caddr e))))
  51.                     )
  52.                   )
  53.                   (reverse ell)
  54.                 )
  55.               )
  56.               (vl-some
  57.                '(lambda ( e )
  58.                   (if (or (< (+ x (cadar el)) (car e)) (< (+ x 1e-3) (car e)))
  59.                     (setq y (+ (cadr e) (caddr (caddr e))))
  60.                   )
  61.                 )
  62.                 (vl-sort ell '(lambda ( a b ) (> (car a) (car b))))
  63.               )
  64.             )
  65.             x
  66.           )
  67.         )
  68.         w
  69.       )
  70.       (or (< (+ y (caddar el)) h) (equal (+ y (caddar el)) h 1e-3))
  71.     )
  72.     (if (= x 0.0)
  73.       (setq bp (list (car minp) (+ y (cadr minp)) 0.0))
  74.       (setq bp (list (+ x (car minp)) (+ y (cadr minp)) 0.0))
  75.     )
  76.     (setq x (+ x (cadar el)))
  77.     (vla-move (vlax-ename->vla-object (cadddr (car el))) (vlax-3d-point (caar el)) (vlax-3d-point bp))
  78.     (setq ell (cons (list x y (car el)) ell))
  79.     (setq el (cdr el))
  80.   )
  81.   (vla-endundomark *adoc*)
  82.   (princ)
  83. )
  84.  

Regards, M.R.


 
Nesting of parts to add spacing

vink8023

  • Mosquito
  • Posts: 4
Re: Automatic Nesting for lisp?
« Reply #68 on: September 16, 2021, 09:14:40 PM »
How to use your code to write a program that looks like a GIF image

xnaldo

  • Mosquito
  • Posts: 1
Re: Automatic Nesting for lisp&#38;#65311;
« Reply #69 on: February 21, 2022, 11:48:37 AM »
Did you find a way to insert space between elements to nest in order to represent kerf ?

ribarm

  • Gator
  • Posts: 2829
  • Marko Ribar, architect
Re: Automatic Nesting for lisp&#38;#65311;
« Reply #70 on: June 24, 2022, 06:23:35 AM »
Here is one short revision, but may be interesing to digest...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:packing ( / proc func p pp q rec w h s l a aa xx yy xo yo pl x ll ip vv n )
  2.   (setq p (getpoint "\nPoint : "))
  3.   (setq q (getcorner p "\nPoint : "))
  4.   (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)))))
  5.   (setq pp p)
  6.   (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)))))
  7.   (setq w (abs (- (car p) (car q))))
  8.   (setq h (abs (- (cadr p) (cadr q))))
  9.   (setq s (ssget "_:L" (list (cons 0 "LWPOLYLINE") (cons 90 4) (cons -4 "&=") (cons 70 1) (cons -4 "<not") (cons -4 "<>") (cons 42 0.0) (cons -4 "not>"))))
  10.   (setq l (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
  11.   (setq l (mapcar (function (lambda ( e / x ) (setq x (entget e)) (list e (list (abs (- (car (cdr (assoc 10 x))) (car (cdr (assoc 10 (cdr (member (assoc 10 (cdr (member (assoc 10 x) x))) x))))))) (abs (- (cadr (cdr (assoc 10 x))) (cadr (cdr (assoc 10 (cdr (member (assoc 10 (cdr (member (assoc 10 x) x))) x))))))))))) l))
  12.   (setq a (mapcar (function (lambda ( e ) (* (car (cadr e)) (cadr (cadr e))))) l))
  13.   (setq l (mapcar (function (lambda ( e b ) (list (car e) (cadr e) b))) l a))
  14.   (setq a (* w h))
  15.   (setq aa (apply (function +) (mapcar (function caddr) l)))
  16.   (if (< aa a)
  17.     (progn
  18.       (setq l (vl-sort l (function (lambda ( a b ) (if (= (car (cadr a)) (car (cadr b))) (> (cadr (cadr a)) (cadr (cadr b))) (> (car (cadr a)) (car (cadr b))))))))
  19.       (setq yy 0.0)
  20.       (while (and l (< (+ yy (cadr (cadr (car l)))) h))
  21.         (setq xx 0.0)
  22.         (while (and l (< (+ xx (car (cadr (car l)))) w))
  23.           (defun proc nil
  24.             (setq pl (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget (car (car l)))))
  25.             (setq pl (vl-sort pl (function (lambda ( a b ) (if (= (cadr (cdr a)) (cadr (cdr b))) (< (car (cdr a)) (car (cdr b))) (< (cadr (cdr a)) (cadr (cdr b))))))))
  26.             (setq pl (list (car pl) (cadr pl) (cadddr pl) (caddr pl)))
  27.             (setq pp (list (if (= xx 0.0) 0.0 xx) (if (= yy 0.0) 0.0 yy)))
  28.             (setq vv (mapcar (function -) (cdr (car pl)) pp))
  29.             (setq pl (mapcar (function (lambda ( x ) (cons 10 (mapcar (function -) (cdr x) vv)))) pl))  
  30.             (entmod (mapcar (function (lambda ( x ) (if (= (car x) 10) (nth (setq n (if (not n) 0 (1+ n))) pl) x))) (entget (car (car l)))))
  31.             (setq n nil)
  32.           )
  33.           (proc)
  34.           (defun func nil
  35.             (not (vl-some (function (lambda ( q ) (equal (list (car ip) (cadr ip)) q 1e-6))) (apply (function append) (mapcar (function cadr) ll))))
  36.           )
  37.           (setq x (entget (car (car l))))
  38.           (setq ll (cons (list (car (car l)) (mapcar (function cdr) (vl-remove-if (function (lambda ( dxf ) (/= (car dxf) 10))) x)) (* (abs (- (car (cdr (assoc 10 x))) (car (cdr (assoc 10 (cdr (member (assoc 10 (cdr (member (assoc 10 x) x))) x))))))) (abs (- (cadr (cdr (assoc 10 x))) (cadr (cdr (assoc 10 (cdr (member (assoc 10 (cdr (member (assoc 10 x) x))) x))))))))) ll))
  39.           (if
  40.             (vl-some
  41.               (function
  42.                 (lambda ( e )
  43.                   (or
  44.                     (if (and (setq ip (inters (cadddr (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( dxf ) (/= (car dxf) 10))) x)))) (car pl) (cadddr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (car pl) (cadddr (cadr e)) (caddr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (car pl) (caddr (cadr e)) (cadr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (car pl) (cadddr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip)
  45.                     (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadddr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadddr (cadr e)) (caddr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (caddr pl) (caddr (cadr e)) (cadr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadddr pl) (caddr pl) (cadr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip)
  46.                     (if (and (setq ip (inters (caddr pl) (cadr pl) (cadddr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (caddr pl) (cadr pl) (cadddr (cadr e)) (caddr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (caddr pl) (cadr pl) (caddr (cadr e)) (cadr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (caddr pl) (cadr pl) (cadr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip)
  47.                     (if (and (setq ip (inters (cadr pl) (car pl) (cadddr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadr pl) (car pl) (cadddr (cadr e)) (caddr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadr pl) (car pl) (caddr (cadr e)) (cadr (cadr e)))) (not (func))) (setq ip nil) ip) (if (and (setq ip (inters (cadr pl) (car pl) (cadr (cadr e)) (car (cadr e)))) (not (func))) (setq ip nil) ip)
  48.                   )
  49.                 )
  50.               ) (cdr ll)
  51.             )
  52.             (if ip
  53.               (progn
  54.                 (setq yy (cadr ip))
  55.                 (proc)
  56.               )
  57.             )
  58.           )
  59.           (if (and yo (> (cadr (cadr (car l))) yo))
  60.             (setq yo (cadr (cadr (car l))))
  61.           )
  62.           (if (not yo)
  63.             (setq yo (cadr (cadr (car l))))
  64.           )
  65.           (if (not xo)
  66.             (setq xo (car (cadr (car l))))
  67.           )
  68.           (setq xx (+ xx xo))
  69.           (setq xo nil)
  70.           (setq l (cdr l))
  71.         )
  72.         (if l
  73.           (setq yy (+ yy yo))
  74.         )
  75.         (setq yo nil)
  76.       )
  77.     )
  78.   )
  79.   (setq l (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))
  80.   (foreach e l
  81.     (vla-move (vlax-ename->vla-object e) (vlax-3d-point (list 0.0 0.0 0.0)) (vlax-3d-point p))
  82.   )
  83.   (princ)
  84. )
  85.  

Regards, M.R.
« Last Edit: June 27, 2022, 07:24:34 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1336
  • Marco
Re: Automatic Nesting for lisp&#38;#65311;
« Reply #71 on: June 24, 2022, 10:40:46 AM »
Here is one short revision, but may be interesing to digest...
...
Regards, M.R.
Tested on my sample:

ScottMC

  • Newt
  • Posts: 145
Re: Automatic Nesting for lisp&#65311;
« Reply #72 on: June 25, 2022, 03:30:51 PM »
Seems just offsetting.. and making a block for the space outside would work, ** do/just name the blocks individually.. used vink8023's <[Thanks] plus it accepts blocks circles...  nice!