--={ Challenge }=-- find general solution for collecting multiple loops...

Code Red > AutoLISP (Vanilla / Visual)

<< < (2/2)

ribarm:
It seems that it would be me that finishes...
And please download *.DWG from this link to see it working : https://www.theswamp.org/index.php?topic=58155.msg613632#msg613632

Recursive version :

--- Code - Auto/Visual Lisp: ---(defun c:loops ( / *error* unique consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn ) (vl-load-com) (defun *error* ( m ) (if (and bound (not (vlax-erased-p bound))) (entdel bound) ) (if (= 8 (logand 8 (getvar (quote undoctl)))) (if command-s (command-s "_.UNDO" "_E") (vl-cmdf "_.UNDO" "_E") ) ) (if cmd (setvar (quote cmdecho) cmd) ) (if osm (setvar (quote osmode) osm) ) (if clay (setvar (quote clayer) clay) ) (if pea (setvar (quote peditaccept) pea) ) (if m (prompt m) ) (princ) ) (defun unique ( lst ) (if lst (cons (car lst) (unique (vl-remove-if (function (lambda ( x ) (and (= (length (car lst)) (length x)) (vl-every (function (lambda ( y ) (vl-position y (car lst)) )) x ) ) )) (cdr lst) ) ) ) ) ) (defun consbyblk ( blk / no ) (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes)) (if (numberp (setq no (atoi (vla-get-textstring att)))) (setq nolst (cons no nolst)) ) ) ) (defun proc ( p / nolst bound pl ss blk ) (setq bound (car (nentselp p))) (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound)))) (entdel bound) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (foreach p pl (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT")))) (progn (setq blk (ssname ss 0)) (consbyblk blk) ) ) ) (setq nolstt (cons nolst nolstt)) ) (defun process ( ss p ) (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" "")))) (proc p) (progn (vl-cmdf "_.JOIN" ss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (proc p) ) ) ) (defun consforeach ( n fn ) (if (> n 0) (progn (write-line (strcat "(foreach e" (itoa n) " ell") fn) (if (> n 1) (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn) ) (consforeach (1- n) fn) ) ) ) (defun closeparen ( n fn ) (if (> n 0) (progn (write-line ")" fn) (closeparen (1- n) fn) ) ) ) (defun conselst ( n fn ) (if (> n 0) (progn (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn) (conselst (1- n) fn) ) ) ) (defun body ( n fn ) (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn) (conselst n fn) (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line "(setq el (entlast) s (ssadd))" fn) (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn) (write-line "(cond" fn) (write-line "( e" fn) (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line ")" fn) (write-line "( t" fn) (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line ")" fn) (write-line ")" fn) (write-line "(while (setq el (entnext el))" fn) (write-line "(ssadd el s)" fn) (write-line ")" fn) (write-line "(setq elst nil)" fn) (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn) (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn) (write-line ")" fn) (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn) ) (setq cmd (getvar (quote cmdecho))) (setvar (quote cmdecho) 0) (setq osm (getvar (quote osmode))) (setvar (quote osmode) 0) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq clay (getvar (quote clayer))) (setvar (quote clayer) "0") (setq pea (getvar (quote peditaccept))) (setvar (quote peditaccept) 1) (if (= 8 (logand 8 (getvar (quote undoctl)))) (vl-cmdf "_.UNDO" "_E") ) (vl-cmdf "_.UNDO" "_M") (vl-cmdf "_.-OVERKILL" "_ALL") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (vl-cmdf "_.ZOOM" "_Extents") (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water"))))) (progn (vl-cmdf "_.LAYER" "_Unlock" "0water") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (setq el (entlast)) (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0)) (setq sss (ssadd)) (while (setq el (entnext el)) (ssadd el sss) ) (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Freeze" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (vl-cmdf "_.REGION" sss "") (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))))) (setq nn (1- (length ell))) (foreach el ell (vl-cmdf "_.EXPLODE" el) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (setq s (ssget "_P")) (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea")) ) (while (> nn 2) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (setq el (entlast)) (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0)) (setq sss (ssadd)) (while (setq el (entnext el)) (ssadd el sss) ) (vl-cmdf "_.REGION" sss "") (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))))) (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell)) (entdel el) (setq nn (1- nn)) (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w")) (write-line "(defun foo nil" fn) (consforeach nn fn) (body nn fn) (closeparen nn fn) (write-line ")" fn) (close fn) (load (strcat (getvar (quote tempprefix)) "foo.lsp")) (foo) (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss))) (progn (vl-cmdf "_.ERASE" sss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) ) (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp")) (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp")) ) (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Unlock" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))) (vl-cmdf "_.ERASE" ss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (vl-cmdf "_.DRAWORDER" ss "" "_Back") (if (and nolstt (listp nolstt) (listp (car nolstt))) (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))) ) (princ nolstt) (*error* nil))
Iterative version :

--- Code - Auto/Visual Lisp: ---(defun c:loops ( / *error* unique consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn ) (vl-load-com) (defun *error* ( m ) (if (and bound (not (vlax-erased-p bound))) (entdel bound) ) (if (= 8 (logand 8 (getvar (quote undoctl)))) (if command-s (command-s "_.UNDO" "_E") (vl-cmdf "_.UNDO" "_E") ) ) (if cmd (setvar (quote cmdecho) cmd) ) (if osm (setvar (quote osmode) osm) ) (if clay (setvar (quote clayer) clay) ) (if pea (setvar (quote peditaccept) pea) ) (if m (prompt m) ) (princ) ) (defun unique ( lst / a ll ) (while (setq a (car lst)) (if (vl-some (function (lambda ( x ) (and (= (length x) (length a)) (vl-every (function (lambda ( y ) (vl-position y a))) x)))) (cdr lst)) (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (and (= (length x) (length a)) (vl-every (function (lambda ( y ) (vl-position y a))) x)))) (cdr lst))) (setq ll (cons a ll) lst (cdr lst)) ) ) (reverse ll) ) (defun consbyblk ( blk / no ) (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes)) (if (numberp (setq no (atoi (vla-get-textstring att)))) (setq nolst (cons no nolst)) ) ) ) (defun proc ( p / nolst bound pl ss blk ) (setq bound (car (nentselp p))) (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound)))) (entdel bound) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (foreach p pl (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT")))) (progn (setq blk (ssname ss 0)) (consbyblk blk) ) ) ) (setq nolstt (cons nolst nolstt)) ) (defun process ( ss p ) (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" "")))) (proc p) (progn (vl-cmdf "_.JOIN" ss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (proc p) ) ) ) (defun consforeach ( n fn ) (while (> n 0) (progn (write-line (strcat "(foreach e" (itoa n) " ell") fn) (if (> n 1) (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn) ) ) (setq n (1- n)) ) ) (defun closeparen ( n fn ) (while (> n 0) (write-line ")" fn) (setq n (1- n)) ) ) (defun conselst ( n fn ) (while (> n 0) (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn) (setq n (1- n)) ) ) (defun body ( n fn ) (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn) (conselst n fn) (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line "(setq el (entlast) s (ssadd))" fn) (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn) (write-line "(cond" fn) (write-line "( e" fn) (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line ")" fn) (write-line "( t" fn) (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn) (write-line "(while (< 0 (getvar (quote cmdactive)))" fn) (write-line "(vl-cmdf \"\")" fn) (write-line ")" fn) (write-line ")" fn) (write-line ")" fn) (write-line "(while (setq el (entnext el))" fn) (write-line "(ssadd el s)" fn) (write-line ")" fn) (write-line "(setq elst nil)" fn) (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn) (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn) (write-line ")" fn) (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn) ) (setq cmd (getvar (quote cmdecho))) (setvar (quote cmdecho) 0) (setq osm (getvar (quote osmode))) (setvar (quote osmode) 0) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq clay (getvar (quote clayer))) (setvar (quote clayer) "0") (setq pea (getvar (quote peditaccept))) (setvar (quote peditaccept) 1) (if (= 8 (logand 8 (getvar (quote undoctl)))) (vl-cmdf "_.UNDO" "_E") ) (vl-cmdf "_.UNDO" "_M") (vl-cmdf "_.-OVERKILL" "_ALL") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (vl-cmdf "_.ZOOM" "_Extents") (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water"))))) (progn (vl-cmdf "_.LAYER" "_Unlock" "0water") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (setq el (entlast)) (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0)) (setq sss (ssadd)) (while (setq el (entnext el)) (ssadd el sss) ) (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Freeze" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (vl-cmdf "_.REGION" sss "") (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))))) (setq nn (1- (length ell))) (foreach el ell (vl-cmdf "_.EXPLODE" el) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (setq s (ssget "_P")) (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea")) ) (while (> nn 2) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (setq el (entlast)) (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0)) (setq sss (ssadd)) (while (setq el (entnext el)) (ssadd el sss) ) (vl-cmdf "_.REGION" sss "") (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))))) (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell)) (entdel el) (setq nn (1- nn)) (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w")) (write-line "(defun foo nil" fn) (consforeach nn fn) (body nn fn) (closeparen nn fn) (write-line ")" fn) (close fn) (load (strcat (getvar (quote tempprefix)) "foo.lsp")) (foo) (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss))) (progn (vl-cmdf "_.ERASE" sss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) ) (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp")) (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp")) ) (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Unlock" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes"))))) (progn (vl-cmdf "_.LAYER" "_Thaw" "0water nodes") (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) ) ) (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))) (vl-cmdf "_.ERASE" ss) (while (< 0 (getvar (quote cmdactive))) (vl-cmdf "") ) (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water")))) (vl-cmdf "_.DRAWORDER" ss "" "_Back") (if (and nolstt (listp nolstt) (listp (car nolstt))) (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))) ) (princ nolstt) (*error* nil))
HTH.
M.R.

ribarm:
I don't quite understand... I have situation where there is no matching between ACAD and BCAD...

Here are results...

--- Code: ---;;; ACAD
(setq l1 '((11 4 3 12) (3 2 8 7) (12 3 2 1) (4 11 10 5) (5 6 7 3 4) (2 1 12 11 4 3) (3 12 1 2 8 7) (11 10 5 4 3 12) (11 4 5 6 7 3 12) (3 2 8 7 6 5 4) (11 10 5 6 7 3 4) (11 10 5 6 7 3 12) (2 1 12 11 10 5 4 3) (3 2 8 7 6 5 10 11 4) (11 10 5 6 7 8 2 3 12) (10 5 6 7 3 2 1 12 11) (10 5 6 7 8 2 1 12 11) (3 12 1 2 8 7 6 5 10 11 4)))

;;; BCAD
(setq l2 '((5 4 11 10) (12 3 2 1) (7 8 2 3) (11 4 3 12) (3 4 5 6 7) (12 3 7 8 2 1) (5 4 3 12 11 10) (12 11 4 3 2 1) (5 6 7 3 4 11 10) (5 6 7 8 2 3 4) (3 12 11 4 5 6 7) (5 6 7 3 12 11 10) (5 4 3 2 1 12 11 10) (12 11 4 3 7 8 2 1) (3 2 1 12 11 4 5 6 7) (6 7 8 2 3 12 11 4 5) (5 6 7 8 2 3 12 11 10) (12 11 4 5 6 7 8 2 1) (10 5 6 7 8 2 1 12 11) (5 4 3 7 8 2 1 12 11 10)))

(defun unique ( lst )
(if lst
(cons
(car lst)
(unique
(vl-remove-if
(function (lambda ( x )
(and
(= (length (car lst)) (length x))
(vl-every
(function (lambda ( y )
(vl-position y (car lst))
))
x
)
)
))
(cdr lst)
)
)
)
)
)

(setq ll (vl-sort (unique (append l1 l2)) (function (lambda ( a b ) (< (length a) (length b))))))

;;;
;|
((11 4 3 12) (3 2 8 7) (12 3 2 1) (4 11 10 5) (5 6 7 3 4) (2 1 12 11 4 3) (3 12 1 2 8 7) (11 10 5 4 3 12) (11 4 5 6 7 3 12) (3 2 8 7 6 5 4) (11 10 5 6 7 3 4) (11 10 5 6 7 3 12) (2 1 12 11 10 5 4 3) (12 11 4 3 7 8 2 1) (3 2 8 7 6 5 10 11 4) (11 10 5 6 7 8 2 3 12) (10 5 6 7 3 2 1 12 11) (10 5 6 7 8 2 1 12 11) (3 2 1 12 11 4 5 6 7) (6 7 8 2 3 12 11 4 5) (12 11 4 5 6 7 8 2 1) (5 4 3 7 8 2 1 12 11 10) (3 12 1 2 8 7 6 5 10 11 4))
|;

--- End code ---

Well, I thought I did it, but you'll never know where rabbit lies...
:wideeyed:

Navigation

[0] Message Index

[*] Previous page

Go to full version