### Author Topic: --={ Challenge }=-- find general solution for collecting multiple loops...  (Read 274 times)

0 Members and 1 Guest are viewing this topic.

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### --={ Challenge }=-- find general solution for collecting multiple loops...
« on: March 18, 2023, 07:34:54 PM »
This my last post is attempt to solve, but those (foreach combos, just I can't manage to visualize better approach...

Thanks for attention, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### d2010

• Bull Frog
• Posts: 302
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #1 on: March 19, 2023, 01:32:03 AM »
The recusive self function , example Consforeach is worst think, because
Why?
Do you known ? How to replace the recursive function with non-rec?
How to increase the speed of stack?
Thanks
God Bless

Code: [Select]
`(defun consforeach ( n )    (if (> n 0)      (progn        '(foreach (read (strcat "e" (itoa n))) ell        (consforeach (1- n))      )    )  )`

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #2 on: March 19, 2023, 04:59:11 AM »
I've constructed some wrapper over external file (strcat (getvar 'tempprefix) "foo.lsp"), but it won't work... Can you check instead of me, maybe I don't see something obvious, cos' result is wrong...

Code - Auto/Visual Lisp: [Select]
1. (defun c:loops ( / *error* consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn )
2.
3.
4.   (defun *error* ( m )
5.     (if (and bound (not (vlax-erased-p bound)))
6.       (entdel bound)
7.     )
8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
9.       (if command-s
10.         (command-s "_.UNDO" "_E")
11.         (vl-cmdf "_.UNDO" "_E")
12.       )
13.     )
14.     (if cmd
15.       (setvar (quote cmdecho) cmd)
16.     )
17.     (if osm
18.       (setvar (quote osmode) osm)
19.     )
20.     (if clay
21.       (setvar (quote clayer) clay)
22.     )
23.     (if pea
24.       (setvar (quote peditaccept) pea)
25.     )
26.     (if m
27.       (prompt m)
28.     )
29.     (princ)
30.   )
31.
32.   (defun consbyblk ( blk / no )
33.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
34.       (if (numberp (setq no (atoi (vla-get-textstring att))))
35.         (setq nolst (cons no nolst))
36.       )
37.     )
38.   )
39.
40.   (defun proc ( p / nolst bound pl ss blk )
41.     (setq bound (car (nentselp p)))
43.     (getstring "\nENTER TO CONTINUE...")
44.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
45.     (entdel bound)
46.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
47.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
48.         (while (< 0 (getvar (quote cmdactive)))
49.           (vl-cmdf "")
50.         )
51.       )
52.     )
53.     (foreach p pl
54.       (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"))))
55.           (setq blk (ssname ss 0))
56.           (consbyblk blk)
57.         )
58.       )
59.     )
60.     (setq nolstt (cons nolst nolstt))
61.   )
62.
63.   (defun process ( ss p )
64.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
65.       (proc p)
66.         (vl-cmdf "_.JOIN" ss)
67.         (while (< 0 (getvar (quote cmdactive)))
68.           (vl-cmdf "")
69.         )
70.         (proc p)
71.       )
72.     )
73.   )
74.
75.   (defun consforeach ( n fn )
76.     (if (> n 0)
77.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
78.         (if (> n 1)
79.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
80.         )
81.         (consforeach (1- n) fn)
82.       )
83.     )
84.   )
85.
86.   (defun closeparen ( n fn )
87.     (if (> n 0)
88.         (write-line ")" fn)
89.         (closeparen (1- n) fn)
90.       )
91.     )
92.   )
93.
94.   (defun conselst ( n fn )
95.     (if (> n 0)
96.         (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
97.         (conselst (1- n) fn)
98.       )
99.     )
100.   )
101.
102.   (defun body ( n fn )
103.     (write-line "(vl-cmdf \"_.UNDO\" \"_G\")" fn)
104.       (conselst n fn)
105.       (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
106.       (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
107.         (write-line "(vl-cmdf \"\")" fn)
108.       (write-line ")" fn)
109.       (write-line "(setq el (entlast) s (ssadd))" fn)
110.       (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
111.       (write-line "(cond" fn)
112.         (write-line "( e" fn)
113.           (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
114.           (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
115.             (write-line "(vl-cmdf \"\")" fn)
116.           (write-line ")" fn)
117.         (write-line ")" fn)
118.         (write-line "( t" fn)
119.           (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
120.           (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
121.             (write-line "(vl-cmdf \"\")" fn)
122.           (write-line ")" fn)
123.         (write-line ")" fn)
124.       (write-line ")" fn)
125.       (write-line "(while (setq el (entnext el))" fn)
126.       (write-line "(ssadd el s)" fn)
127.       (write-line ")" fn)
128.       (write-line "(setq elst nil)" fn)
129.       (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
130.         (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
131.     (write-line ")" fn)
132.     (write-line "(vl-cmdf \"_.UNDO\" \"_B\")" fn)
133.   )
134.
135.   (setq cmd (getvar (quote cmdecho)))
136.   (setvar (quote cmdecho) 0)
137.   (setq osm (getvar (quote osmode)))
138.   (setvar (quote osmode) 0)
139.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
140.       (vl-cmdf "_.LAYER" "_Thaw" "0")
141.       (while (< 0 (getvar (quote cmdactive)))
142.         (vl-cmdf "")
143.       )
144.     )
145.   )
146.   (setq clay (getvar (quote clayer)))
147.   (setvar (quote clayer) "0")
148.   (setq pea (getvar (quote peditaccept)))
149.   (setvar (quote peditaccept) 1)
150.   (if (= 8 (logand 8 (getvar (quote undoctl))))
151.     (vl-cmdf "_.UNDO" "_E")
152.   )
153.   (vl-cmdf "_.UNDO" "_M")
154.   (vl-cmdf "_.-OVERKILL" "_ALL")
155.   (while (< 0 (getvar (quote cmdactive)))
156.     (vl-cmdf "")
157.   )
158.   (vl-cmdf "_.ZOOM" "_Extents")
159.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
160.   (setq el (entlast))
161.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
163.   (while (setq el (entnext el))
165.   )
166.   (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
167.       (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
168.       (while (< 0 (getvar (quote cmdactive)))
169.         (vl-cmdf "")
170.       )
171.     )
172.   )
173.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
174.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
175.       (while (< 0 (getvar (quote cmdactive)))
176.         (vl-cmdf "")
177.       )
178.     )
179.   )
180.   (vl-cmdf "_.REGION" sss "")
181.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
182.   (vl-cmdf "_.UNDO" "_G")
183.   (foreach el ell
184.     (vl-cmdf "_.EXPLODE" el)
185.     (while (< 0 (getvar (quote cmdactive)))
186.       (vl-cmdf "")
187.     )
188.     (setq s (ssget "_P"))
189.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
190.   )
191.   (vl-cmdf "_.UNDO" "_B")
192.   (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))
193.   (entdel el)
194.   (setq nn (length ell))
195.   (while (> nn 2)
196.     (setq nn (1- nn))
197.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
198.     (write-line "(defun foo nil" fn)
199.     (consforeach nn fn)
200.     (body nn fn)
201.     (closeparen nn fn)
202.     (write-line ")" fn)
203.     (close fn)
204.     (while (not (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))))
205.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
206.     (foo)
207.   )
208.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
209.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
210.   )
211.   (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
212.       (vl-cmdf "_.ERASE" sss)
213.       (while (< 0 (getvar (quote cmdactive)))
214.         (vl-cmdf "")
215.       )
216.     )
217.   )
218.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
219.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
220.       (while (< 0 (getvar (quote cmdactive)))
221.         (vl-cmdf "")
222.       )
223.     )
224.   )
225.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
226.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
227.       (while (< 0 (getvar (quote cmdactive)))
228.         (vl-cmdf "")
229.       )
230.     )
231.   )
232.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
233.   (vl-cmdf "_.ERASE" ss)
234.   (while (< 0 (getvar (quote cmdactive)))
235.     (vl-cmdf "")
236.   )
237.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
238.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
239.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
240.     (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
241.   )
242.   (princ nolstt)
243.   (*error* nil)
244. )
245.
« Last Edit: March 20, 2023, 01:09:56 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #3 on: March 19, 2023, 06:54:57 AM »
I've finished... My last updated code is fully operational and working well...

Thanks for attention and taking part in this challenge...
« Last Edit: March 19, 2023, 11:31:47 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #4 on: March 19, 2023, 11:34:08 AM »
I jumped up too early... Challenge is still open... It don't give expected results on just a little wider network...
So...
Happy coding...
See ya when someone finishes...

Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #5 on: March 19, 2023, 01:08:43 PM »
It seems that it would be me that finishes...

Recursive version :

Code - Auto/Visual Lisp: [Select]
1. (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 )
2.
3.
4.   (defun *error* ( m )
5.     (if (and bound (not (vlax-erased-p bound)))
6.       (entdel bound)
7.     )
8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
9.       (if command-s
10.         (command-s "_.UNDO" "_E")
11.         (vl-cmdf "_.UNDO" "_E")
12.       )
13.     )
14.     (if cmd
15.       (setvar (quote cmdecho) cmd)
16.     )
17.     (if osm
18.       (setvar (quote osmode) osm)
19.     )
20.     (if clay
21.       (setvar (quote clayer) clay)
22.     )
23.     (if pea
24.       (setvar (quote peditaccept) pea)
25.     )
26.     (if m
27.       (prompt m)
28.     )
29.     (princ)
30.   )
31.
32.   (defun unique ( lst )
33.     (if lst
34.       (cons
35.         (car lst)
36.         (unique
37.           (vl-remove-if
38.             (function (lambda ( x )
39.               (and
40.                 (= (length (car lst)) (length x))
41.                   (function (lambda ( y )
42.                     (vl-position y (car lst))
43.                   ))
44.                   x
45.                 )
46.               )
47.             ))
48.             (cdr lst)
49.           )
50.         )
51.       )
52.     )
53.   )
54.
55.   (defun consbyblk ( blk / no )
56.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
57.       (if (numberp (setq no (atoi (vla-get-textstring att))))
58.         (setq nolst (cons no nolst))
59.       )
60.     )
61.   )
62.
63.   (defun proc ( p / nolst bound pl ss blk )
64.     (setq bound (car (nentselp p)))
65.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
66.     (entdel bound)
67.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
68.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
69.         (while (< 0 (getvar (quote cmdactive)))
70.           (vl-cmdf "")
71.         )
72.       )
73.     )
74.     (foreach p pl
75.       (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"))))
76.           (setq blk (ssname ss 0))
77.           (consbyblk blk)
78.         )
79.       )
80.     )
81.     (setq nolstt (cons nolst nolstt))
82.   )
83.
84.   (defun process ( ss p )
85.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
86.       (proc p)
87.         (vl-cmdf "_.JOIN" ss)
88.         (while (< 0 (getvar (quote cmdactive)))
89.           (vl-cmdf "")
90.         )
91.         (proc p)
92.       )
93.     )
94.   )
95.
96.   (defun consforeach ( n fn )
97.     (if (> n 0)
98.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
99.         (if (> n 1)
100.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
101.         )
102.         (consforeach (1- n) fn)
103.       )
104.     )
105.   )
106.
107.   (defun closeparen ( n fn )
108.     (if (> n 0)
109.         (write-line ")" fn)
110.         (closeparen (1- n) fn)
111.       )
112.     )
113.   )
114.
115.   (defun conselst ( n fn )
116.     (if (> n 0)
117.         (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
118.         (conselst (1- n) fn)
119.       )
120.     )
121.   )
122.
123.   (defun body ( n fn )
124.     (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn)
125.     (conselst n fn)
126.     (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
127.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
128.     (write-line "(vl-cmdf \"\")" fn)
129.     (write-line ")" fn)
130.     (write-line "(setq el (entlast) s (ssadd))" fn)
131.     (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
132.     (write-line "(cond" fn)
133.     (write-line "( e" fn)
134.     (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
135.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
136.     (write-line "(vl-cmdf \"\")" fn)
137.     (write-line ")" fn)
138.     (write-line ")" fn)
139.     (write-line "( t" fn)
140.     (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
141.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
142.     (write-line "(vl-cmdf \"\")" fn)
143.     (write-line ")" fn)
144.     (write-line ")" fn)
145.     (write-line ")" fn)
146.     (write-line "(while (setq el (entnext el))" fn)
147.     (write-line "(ssadd el s)" fn)
148.     (write-line ")" fn)
149.     (write-line "(setq elst nil)" fn)
150.     (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
151.     (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
152.     (write-line ")" fn)
153.     (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn)
154.   )
155.
156.   (setq cmd (getvar (quote cmdecho)))
157.   (setvar (quote cmdecho) 0)
158.   (setq osm (getvar (quote osmode)))
159.   (setvar (quote osmode) 0)
160.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
161.       (vl-cmdf "_.LAYER" "_Thaw" "0")
162.       (while (< 0 (getvar (quote cmdactive)))
163.         (vl-cmdf "")
164.       )
165.     )
166.   )
167.   (setq clay (getvar (quote clayer)))
168.   (setvar (quote clayer) "0")
169.   (setq pea (getvar (quote peditaccept)))
170.   (setvar (quote peditaccept) 1)
171.   (if (= 8 (logand 8 (getvar (quote undoctl))))
172.     (vl-cmdf "_.UNDO" "_E")
173.   )
174.   (vl-cmdf "_.UNDO" "_M")
175.   (vl-cmdf "_.-OVERKILL" "_ALL")
176.   (while (< 0 (getvar (quote cmdactive)))
177.     (vl-cmdf "")
178.   )
179.   (vl-cmdf "_.ZOOM" "_Extents")
180.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
181.       (vl-cmdf "_.LAYER" "_Thaw" "0water")
182.       (while (< 0 (getvar (quote cmdactive)))
183.         (vl-cmdf "")
184.       )
185.     )
186.   )
187.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
188.       (vl-cmdf "_.LAYER" "_Unlock" "0water")
189.       (while (< 0 (getvar (quote cmdactive)))
190.         (vl-cmdf "")
191.       )
192.     )
193.   )
194.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
195.   (setq el (entlast))
196.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
198.   (while (setq el (entnext el))
200.   )
201.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
202.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
203.       (while (< 0 (getvar (quote cmdactive)))
204.         (vl-cmdf "")
205.       )
206.     )
207.   )
208.   (vl-cmdf "_.REGION" sss "")
209.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
210.   (setq nn (1- (length ell)))
211.   (foreach el ell
212.     (vl-cmdf "_.EXPLODE" el)
213.     (while (< 0 (getvar (quote cmdactive)))
214.       (vl-cmdf "")
215.     )
216.     (setq s (ssget "_P"))
217.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea"))
218.   )
219.   (while (> nn 2)
220.     (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
221.     (setq el (entlast))
222.     (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
224.     (while (setq el (entnext el))
226.     )
227.     (vl-cmdf "_.REGION" sss "")
228.     (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
229.     (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))
230.     (entdel el)
231.     (setq nn (1- nn))
232.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
233.     (write-line "(defun foo nil" fn)
234.     (consforeach nn fn)
235.     (body nn fn)
236.     (closeparen nn fn)
237.     (write-line ")" fn)
238.     (close fn)
239.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
240.     (foo)
241.     (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
242.         (vl-cmdf "_.ERASE" sss)
243.         (while (< 0 (getvar (quote cmdactive)))
244.           (vl-cmdf "")
245.         )
246.       )
247.     )
248.   )
249.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
250.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
251.   )
252.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
253.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
254.       (while (< 0 (getvar (quote cmdactive)))
255.         (vl-cmdf "")
256.       )
257.     )
258.   )
259.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
260.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
261.       (while (< 0 (getvar (quote cmdactive)))
262.         (vl-cmdf "")
263.       )
264.     )
265.   )
266.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
267.   (vl-cmdf "_.ERASE" ss)
268.   (while (< 0 (getvar (quote cmdactive)))
269.     (vl-cmdf "")
270.   )
271.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
272.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
273.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
274.     (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b)))))))
275.   )
276.   (princ nolstt)
277.   (*error* nil)
278. )
279.

Iterative version :

Code - Auto/Visual Lisp: [Select]
1. (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 )
2.
3.
4.   (defun *error* ( m )
5.     (if (and bound (not (vlax-erased-p bound)))
6.       (entdel bound)
7.     )
8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
9.       (if command-s
10.         (command-s "_.UNDO" "_E")
11.         (vl-cmdf "_.UNDO" "_E")
12.       )
13.     )
14.     (if cmd
15.       (setvar (quote cmdecho) cmd)
16.     )
17.     (if osm
18.       (setvar (quote osmode) osm)
19.     )
20.     (if clay
21.       (setvar (quote clayer) clay)
22.     )
23.     (if pea
24.       (setvar (quote peditaccept) pea)
25.     )
26.     (if m
27.       (prompt m)
28.     )
29.     (princ)
30.   )
31.
32.   (defun unique ( lst / a ll )
33.     (while (setq a (car lst))
34.       (if (vl-some (function (lambda ( x ) (and (= (length x) (length a)) (vl-every (function (lambda ( y ) (vl-position y a))) x)))) (cdr lst))
35.         (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)))
36.         (setq ll (cons a ll) lst (cdr lst))
37.       )
38.     )
39.     (reverse ll)
40.   )
41.
42.   (defun consbyblk ( blk / no )
43.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
44.       (if (numberp (setq no (atoi (vla-get-textstring att))))
45.         (setq nolst (cons no nolst))
46.       )
47.     )
48.   )
49.
50.   (defun proc ( p / nolst bound pl ss blk )
51.     (setq bound (car (nentselp p)))
52.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
53.     (entdel bound)
54.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
55.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
56.         (while (< 0 (getvar (quote cmdactive)))
57.           (vl-cmdf "")
58.         )
59.       )
60.     )
61.     (foreach p pl
62.       (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"))))
63.           (setq blk (ssname ss 0))
64.           (consbyblk blk)
65.         )
66.       )
67.     )
68.     (setq nolstt (cons nolst nolstt))
69.   )
70.
71.   (defun process ( ss p )
72.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
73.       (proc p)
74.         (vl-cmdf "_.JOIN" ss)
75.         (while (< 0 (getvar (quote cmdactive)))
76.           (vl-cmdf "")
77.         )
78.         (proc p)
79.       )
80.     )
81.   )
82.
83.   (defun consforeach ( n fn )
84.     (while (> n 0)
85.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
86.         (if (> n 1)
87.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
88.         )
89.       )
90.       (setq n (1- n))
91.     )
92.   )
93.
94.   (defun closeparen ( n fn )
95.     (while (> n 0)
96.       (write-line ")" fn)
97.       (setq n (1- n))
98.     )
99.   )
100.
101.   (defun conselst ( n fn )
102.     (while (> n 0)
103.       (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
104.       (setq n (1- n))
105.     )
106.   )
107.
108.   (defun body ( n fn )
109.     (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn)
110.     (conselst n fn)
111.     (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
112.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
113.     (write-line "(vl-cmdf \"\")" fn)
114.     (write-line ")" fn)
115.     (write-line "(setq el (entlast) s (ssadd))" fn)
116.     (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
117.     (write-line "(cond" fn)
118.     (write-line "( e" fn)
119.     (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
120.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
121.     (write-line "(vl-cmdf \"\")" fn)
122.     (write-line ")" fn)
123.     (write-line ")" fn)
124.     (write-line "( t" fn)
125.     (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
126.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
127.     (write-line "(vl-cmdf \"\")" fn)
128.     (write-line ")" fn)
129.     (write-line ")" fn)
130.     (write-line ")" fn)
131.     (write-line "(while (setq el (entnext el))" fn)
132.     (write-line "(ssadd el s)" fn)
133.     (write-line ")" fn)
134.     (write-line "(setq elst nil)" fn)
135.     (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
136.     (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
137.     (write-line ")" fn)
138.     (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn)
139.   )
140.
141.   (setq cmd (getvar (quote cmdecho)))
142.   (setvar (quote cmdecho) 0)
143.   (setq osm (getvar (quote osmode)))
144.   (setvar (quote osmode) 0)
145.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
146.       (vl-cmdf "_.LAYER" "_Thaw" "0")
147.       (while (< 0 (getvar (quote cmdactive)))
148.         (vl-cmdf "")
149.       )
150.     )
151.   )
152.   (setq clay (getvar (quote clayer)))
153.   (setvar (quote clayer) "0")
154.   (setq pea (getvar (quote peditaccept)))
155.   (setvar (quote peditaccept) 1)
156.   (if (= 8 (logand 8 (getvar (quote undoctl))))
157.     (vl-cmdf "_.UNDO" "_E")
158.   )
159.   (vl-cmdf "_.UNDO" "_M")
160.   (vl-cmdf "_.-OVERKILL" "_ALL")
161.   (while (< 0 (getvar (quote cmdactive)))
162.     (vl-cmdf "")
163.   )
164.   (vl-cmdf "_.ZOOM" "_Extents")
165.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
166.       (vl-cmdf "_.LAYER" "_Thaw" "0water")
167.       (while (< 0 (getvar (quote cmdactive)))
168.         (vl-cmdf "")
169.       )
170.     )
171.   )
172.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
173.       (vl-cmdf "_.LAYER" "_Unlock" "0water")
174.       (while (< 0 (getvar (quote cmdactive)))
175.         (vl-cmdf "")
176.       )
177.     )
178.   )
179.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
180.   (setq el (entlast))
181.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
183.   (while (setq el (entnext el))
185.   )
186.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
187.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
188.       (while (< 0 (getvar (quote cmdactive)))
189.         (vl-cmdf "")
190.       )
191.     )
192.   )
193.   (vl-cmdf "_.REGION" sss "")
194.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
195.   (setq nn (1- (length ell)))
196.   (foreach el ell
197.     (vl-cmdf "_.EXPLODE" el)
198.     (while (< 0 (getvar (quote cmdactive)))
199.       (vl-cmdf "")
200.     )
201.     (setq s (ssget "_P"))
202.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea"))
203.   )
204.   (while (> nn 2)
205.     (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
206.     (setq el (entlast))
207.     (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
209.     (while (setq el (entnext el))
211.     )
212.     (vl-cmdf "_.REGION" sss "")
213.     (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
214.     (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))
215.     (entdel el)
216.     (setq nn (1- nn))
217.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
218.     (write-line "(defun foo nil" fn)
219.     (consforeach nn fn)
220.     (body nn fn)
221.     (closeparen nn fn)
222.     (write-line ")" fn)
223.     (close fn)
224.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
225.     (foo)
226.     (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
227.         (vl-cmdf "_.ERASE" sss)
228.         (while (< 0 (getvar (quote cmdactive)))
229.           (vl-cmdf "")
230.         )
231.       )
232.     )
233.   )
234.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
235.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
236.   )
237.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
238.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
239.       (while (< 0 (getvar (quote cmdactive)))
240.         (vl-cmdf "")
241.       )
242.     )
243.   )
244.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
245.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
246.       (while (< 0 (getvar (quote cmdactive)))
247.         (vl-cmdf "")
248.       )
249.     )
250.   )
251.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
252.   (vl-cmdf "_.ERASE" ss)
253.   (while (< 0 (getvar (quote cmdactive)))
254.     (vl-cmdf "")
255.   )
256.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
257.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
258.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
259.     (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b)))))))
260.   )
261.   (princ nolstt)
262.   (*error* nil)
263. )
264.

HTH.
M.R.
« Last Edit: March 21, 2023, 01:51:21 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Gator
• Posts: 2940
• Marko Ribar, architect
##### Re: --={ Challenge }=-- find general solution for collecting multiple loops...
« Reply #6 on: March 19, 2023, 03:59:41 PM »
I don't quite understand... I have situation where there is no matching between ACAD and BCAD...

Here are results...

Code: [Select]
`;;; 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))|;`
Well, I thought I did it, but you'll never know where rabbit lies...

Marko Ribar, d.i.a. (graduated engineer of architecture)