### Author Topic: ==={Challenge}===Find the ridge lines of sloped roof  (Read 90208 times)

0 Members and 1 Guest are viewing this topic.

#### pkohut

• Bull Frog
• Posts: 474 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #210 on: February 27, 2023, 07:41:01 AM »

@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...

Want speed - get out of lisp.
Want speed - keep nested loops to a minimum.
Want speed - don't do heavy calculations deep in the loops.
Want speed - don't do if checks deep in the loops.
Want speed - learn algorithms and data structures.

New tread (not retired) - public repo at https://github.com/pkohut ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #211 on: February 27, 2023, 07:58:43 AM »

@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...

Want speed - get out of lisp.
Want speed - keep nested loops to a minimum.
Want speed - don't do heavy calculations deep in the loops.
Want speed - don't do if checks deep in the loops.
Want speed - learn algorithms and data structures.

Why do you need code comments?
For other opinions I agree, but not my field of knowledge...
It could be written in lisp for sure to be fast enough - look at chlh_jd's example...
The problem is that complexity may grow - ultimate roofs - 100 and more vertices...

If you test it, you'll see what it do till now... The problem arises with widening code - finding correct solution based on offsetting...
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #212 on: February 28, 2023, 01:19:58 PM »
And here is it classical example of how topic get overcrowded with other new ones...

I would like to see something new that may be better than my attempts...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture) #### pkohut

• Bull Frog
• Posts: 474 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #213 on: February 28, 2023, 02:48:52 PM »
And here is it classical example of how topic get overcrowded with other new ones...

I would like to see something new that may be better than my attempts...

M.R.

Fair enough.  Your playground, your rules.  Take my non-lisp ball to another field. New tread (not retired) - public repo at https://github.com/pkohut ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #214 on: March 01, 2023, 10:18:03 AM »  Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #215 on: March 06, 2023, 10:53:05 AM »
To all users, or else watching...

Can this routine here in attachment work faster with ultimate roof example, and not to depend on PC hardware architecture configuration...

I am not searching translation to ARX, BRX, (but I suppose it would be perfect) or something else, though and DLL for latest versions of Auto/BricsCAD would be very welcomed, I also need tweaks if someone operates with *.LSP on higher level of intelligence...

Link for ultimate roof DWG : https://www.theswamp.org/index.php?topic=41837.msg613477#msg613477
« Last Edit: March 10, 2023, 02:45:15 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #216 on: March 06, 2023, 12:11:08 PM »
Letter to programmer masters...
Quote
Is my routine hardware dependent... (roof2d-new-new-offset.lsp)... If so, which is mostly the case, then the job is done... I don't know how to tweak for ultimate roofs (100 and more vertices)... If it doesn't depend on the hardware, then let someone more expert than me take a look... It doesn't matter if it's *.lsp, *.arx, *.brx, * .dll... it's only important that it works optimally, which I doubt... I don't know, if you care, ask around, maybe by chance a solution for slowness will be found... I took all the parameters into circulation and matched them with each other ... Perhaps I should have left something out, but then not all the tests would have passed... See what you can do, if you have the time and interest...

Testing *.DWG is in attachment...
« Last Edit: March 10, 2023, 01:57:40 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #217 on: March 07, 2023, 10:35:30 AM »   Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #218 on: March 11, 2023, 11:56:24 AM »
I've found some workaround... It was all the time in front of my(ours) nose...
As for the ultimate roofs, test for 1 full rotation of vertices, so if it is not found the first time, trim one of the sides of the lwpoly, turn it closed through palette, which changes the initial vertex... After a bit of hacking in this way, 2droof-final.lsp should find solution within 1 to 2 seconds... Just don't forget that errm doesn't even need to iterate... The solution should be solvable during the first iteration of errn...

New update is here : https://www.cadtutor.net/forum/files/file/36-hipped-roof-routines/
« Last Edit: March 20, 2023, 12:15:27 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #219 on: July 20, 2023, 02:02:40 PM »
I had some spare time, so I've coded for smaller more concise version... But how story goes, what is short and quick it's more lackable... Still if someone want's to connect and improve, here is it...

Code - Auto/Visual Lisp: [Select]
1. (defun c:roof-new ( / *error* unit rlw offd inside-p collinear-p unique chkcircinside mc subprocess1 subprocess2 subprocess process done lw lwi lwx lwo ent enti lil lix lwnl ch el p1 p2 pp ppp ipp ippl vll vlli tll iplst iplstt iplsttt lst lstt ) ;;; cad, doc, spc, lay, vlll, vllli, tlll, tmp, f - global variables ;;;
2.
3.
4.   (defun *error* ( m )
5.     (if (and lwi (not (vlax-erased-p lwi)))
6.       (entdel lwi)
7.     )
8.     (if (and enti (not (vlax-erased-p enti)))
9.       (entdel enti)
10.     )
11.     (if (setq ppp (unique ppp))
12.       (foreach pp ppp
13.         (if (not (vl-some '(lambda ( x ) (and (not (equal (car x) pp 1e-6)) (not (equal (cadr x) pp 1e-6)) (not (equal (car x) (cadr x) 1e-6)) (collinear-p (car x) pp (cadr x)))) lil))
14.           (entmake (list (cons 0 "POINT") (cons 10 pp) (cons 62 1)))
15.         )
16.       )
17.     )
18.     (if (= ch "No")
19.       (while (setq el (entnext el))
20.         (if (and el (not (vlax-erased-p el)))
21.           (entdel el)
22.         )
23.       )
24.     )
25.     (if lil
26.       (foreach li lil
27.         (if (vl-some '(lambda ( x ) (and (not (equal (car li) x 1e-6)) (not (equal (cadr li) x 1e-6)) (not (equal (car li) (cadr li) 1e-6)) (collinear-p (car li) x (cadr li)))) ppp)
28.           (setq lil (vl-remove li lil))
29.           (if (vl-some '(lambda ( x ) (equal x (car li) 1e-6)) ppp)
30.             (entmake (list (cons 0 "LINE") (cons 10 (car li)) (cons 11 (cadr li)) (cons 62 3)))
31.           )
32.         )
33.       )
34.     )
35.     (command-s "_.-OVERKILL" "_ALL" "_T" "_Y" "" "")
36.     (if (= 8 (logand 8 (getvar 'undoctl)))
37.       (vla-endundomark doc)
38.     )
39.     (prompt "\nIf you want to start again on different sample, make sure you nil flag f : (setq f nil vlll nil vllli nil tlll nil tmp nil) ...")
40.     (if m
41.       (prompt m)
42.     )
43.     (princ)
44.   )
45.
46.   (defun unit ( v / d )
47.     (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-6))
48.       (mapcar '(lambda ( x ) (/ x d)) v)
49.     )
50.   )
51.
52.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
53.     ;; by ElpanovEvgeniy
54.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
55.         (foreach a1 e
56.           (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
57.                 ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
58.                 ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
59.                 ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
60.                 ((= (car a1) 210) (setq x6 (cons a1 x6)))
61.                 (t (setq x1 (cons a1 x1)))
62.           )
63.         )
64.         (entmod (append (reverse x1)
65.                               (cons 'list
66.                                 (list x2
67.                                   (cdr (reverse (cons (car x3) (reverse x3))))
68.                                   (cdr (reverse (cons (car x4) (reverse x4))))
69.                                   (cdr (reverse (cons (car x5) (reverse x5))))
70.                                 )
71.                               )
72.                             )
73.                           )
74.                           x6
75.                   )
76.                 )
77.         )
78.         (entupd lw)
79.       )
80.     )
81.   )
82.
83.   (defun offd ( sign ip tl / dl )
84.     (setq dl (mapcar '(lambda ( x )
85.                         (distance ip
86.                             ip
87.                             (polar ip (+ (* 0.5 pi) (angle (car x) (cadr x))) 1.0)
88.                             (car x)
89.                             (polar (car x) (angle (car x) (cadr x)) 1.0)
90.                             nil
91.                           )
92.                         )
93.                       ) tl
94.               )
95.     )
96.     (vl-some '(lambda ( x )
97.                (if
98.                  (>
99.                    (-
100.                      (length dl)
101.                      (length (vl-remove-if '(lambda ( y ) (equal x y 1.0)) dl))
102.                    ) 2
103.                  )
104.                  x
105.                )
106.              ) (vl-sort dl sign)
107.     )
108.   )
109.
110.   (defun inside-p ( p lw lwi )
111.   )
112.
113.   (defun collinear-p ( p1 p p2 )
114.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
115.   )
116.
117.   (defun unique ( pl )
118.     (if pl
119.       (cons (car pl)
120.             (unique
121.               (vl-remove-if
122.                 '(lambda ( x )
123.                    (equal x (car pl) 1e-6)
124.                  )
125.                 (cdr pl)
126.               )
127.             )
128.       )
129.     )
130.   )
131.
132.   (defun chkcircinside ( pp tll / d ci ipp ippl tst )
133.     (if (and pp tll)
134.         (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 pp) (cons 40 (offd (function <) pp tll)))))
135.         (if (setq ipp (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object ent) acextendnone))
136.             (while ipp
137.               (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
138.               (setq ipp (cdddr ipp))
139.             )
140.             (if (or (not ippl) (vl-every '(lambda ( x ) (inside-p x ent enti)) (apply 'append (mapcar '(lambda ( x ) (list (vlax-curve-getpointatparam ci (- x 0.1)) (vlax-curve-getpointatparam ci (+ x 0.1)))) (mapcar '(lambda ( x ) (vlax-curve-getparamatpoint ci x)) ippl)))))
141.               (setq tst t)
142.             )
143.           )
144.           (setq tst t)
145.         )
146.         (if (and ci (not (vlax-erased-p ci)))
147.           (entdel ci)
148.         )
149.       )
150.     )
151.     tst
152.   )
153.
154.   (defun mc ( p lw / ci pl mp )
155.     (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 1.0))))
156.     (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
157.     (if (and ci (not (vlax-erased-p ci)))
158.       (entdel ci)
159.     )
160.     (setq mp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (list (car pl) (cadr pl)) (list (nth 3 pl) (nth 4 pl))))
161.     (list p mp)
162.   )
163.
164.   (defun subprocess1 ( vl vli / ip ) ;;; iplst - lexical global variable
165.     (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
166.                           (if
167.                             (and
168.                               (setq ip (inters p1 p2 p3 p4 nil))
169.                               (inside-p ip ent enti)
170.                               (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
171.                               (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
172.                               (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
173.                               (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
174.                             )
175.                             (list ip (list p1 p3))
176.                             (list nil nil)
177.                           )
178.                         )
179.                         vl
180.                         vli
181.                         (append (cdr vl) (list (car vl)))
182.                         (append (cdr vli) (list (car vli)))
183.                 )
184.     )
185.   )
186.
187.   (defun subprocess2 ( p lw vl vli / ip lst lstt ) ;;; iplst - lexical global variable
188.     (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
189.                           (if
190.                             (and
191.                               (setq ip (inters p1 p2 p3 p4 nil))
192.                               (inside-p ip ent enti)
193.                               (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
194.                               (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
195.                               (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
196.                               (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
197.                             )
198.                             (list ip (list p1 p3))
199.                             (list nil nil)
200.                           )
201.                         )
202.                         vl
203.                         vli
204.                         (repeat (length vl) (setq lst (cons (car (mc p lw)) lst)))
205.                         (repeat (length vl) (setq lstt (cons (cadr (mc p lw)) lstt)))
206.                 )
207.     )
208.   )
209.
210.   (defun subprocess ( iplst / p1 p2 pp1 pp2 k i dd )
211.     (setq iplst (vl-remove-if '(lambda ( x ) (or (null (car x)) (null (cadr x)))) iplst))
212.     (setq iplstoffd (mapcar '(lambda ( x ) (if (and (car x) (cadr x))
213.                                              (list
214.                                                (mapcar '+ '(0.0 0.0) (car x))
215.                                                (mapcar '(lambda ( y ) (mapcar '+ '(0.0 0.0) y)) (cadr x))
216.                                                (offd (function <) (mapcar '+ '(0.0 0.0) (car x)) tlll)
217.                                              )
218.                                              (list nil nil nil)
219.                                            )
220.                              ) iplst
221.                     )
222.     )
223.     (setq iplstoffd (vl-remove-if '(lambda ( x ) (null (caddr x))) iplstoffd))
224.     (setq iplstoffd (vl-sort iplstoffd '(lambda ( a b ) (< (caddr a) (caddr b)))))
225.     (foreach ipd iplstoffd
226.       (if (not tmp)
227.         (setq tmp (offd (function <) (car ipd) tlll))
228.       )
229.       (if (and ipd (chkcircinside (car ipd) tlll) (<= tmp (setq tmp (offd (function <) (car ipd) tlll))))
230.           (setq ppp (cons (car ipd) ppp))
231.           (if
232.             (and
233.               (setq p1
234.                 (vl-some '(lambda ( x )
235.                   (if
236.                       (unit (mapcar '- (car ipd) x))
237.                       (unit (mapcar '- (car ipd) (caadr ipd)))
238.                       1e-6
239.                     )
240.                     x
241.                   )
242.                 ) vll
243.                 )
244.               )
245.               (setq pp1
246.                 (vl-some '(lambda ( x )
247.                   (if
248.                       (unit (mapcar '- (car ipd) x))
249.                       (unit (mapcar '- (car ipd) p1))
250.                       1e-6
251.                     )
252.                     x
253.                   )
254.                 ) vlll
255.                 )
256.               )
257.             )
258.             (setq lil (cons (list (car ipd) pp1) lil))
259.             (if p1
260.               (setq lil (cons (list (car ipd) p1) lil))
261.               (setq lil (cons (list (car ipd) (caadr ipd)) lil))
262.             )
263.           )
264.           (if
265.             (and
266.               (setq p2
267.                 (vl-some '(lambda ( x )
268.                   (if
269.                       (unit (mapcar '- (car ipd) x))
271.                       1e-6
272.                     )
273.                     x
274.                   )
275.                 ) vll
276.                 )
277.               )
278.               (setq pp2
279.                 (vl-some '(lambda ( x )
280.                   (if
281.                       (unit (mapcar '- (car ipd) x))
282.                       (unit (mapcar '- (car ipd) p2))
283.                       1e-6
284.                     )
285.                     x
286.                   )
287.                 ) vlll
288.                 )
289.               )
290.             )
291.             (setq lil (cons (list (car ipd) pp2) lil))
292.             (if p2
293.               (setq lil (cons (list (car ipd) p2) lil))
295.             )
296.           )
297.           (setq k 1e-4 i 0)
298.             (and
300.               (setq dd (- (caddr ipd) (* k (setq i (1+ i)))))
301.               (setq lwnl (vl-catch-all-apply
302.                 (list (vlax-ename->vla-object lw) 'offset (- dd))
303.               ))
304.               (if (vl-catch-all-error-p lwnl)
305.                 (/= i 10)
306.               )
307.             )
308.           )
309.           (if (not (vl-catch-all-error-p lwnl))
310.             (setq lwnl (mapcar 'vlax-vla-object->ename lwnl))
311.             lwnl
312.           )
313.           (if (and (not (vl-catch-all-error-p lwnl)) (= (length lwnl) 1))
314.             (setq iplstt (cons (list (car ipd) (car lwnl)) iplstt))
315.           )
316.         )
317.       )
318.     )
319.     (setq tmp nil)
320.     lwnl
321.   )
322.
323.   (defun process ( lw / lwi lwx vl vli iplst tl ipd iplstoffd p1 p2 pp lwnl ) ;;; vll ; vlli ; tll ; lwnl ; ppp ; iplstt - lexical global variables ;;;
324.     (if lw
325.         (setq vl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw)))))
326.         (if (not vll)
327.           (setq vll vl)
328.         )
329.         (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
330.         (setq vli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lwi))))
331.         (if (not vlli)
332.           (setq vlli vli)
333.         )
334.         (setq tl (mapcar '(lambda ( a b ) (list a b)) vl (append (cdr vl) (list (car vl)))))
335.         (if (not tll)
336.           (setq tll tl)
337.         )
338.         (setq iplst (subprocess1 vl vli))
339.         (subprocess iplst)
340.         (setq iplst nil)
341.         (foreach pp iplstt
342.           (setq iplsttt (append iplsttt (subprocess2 (car pp) (cadr pp) vl vli)))
343.         )
344.         (subprocess iplsttt)
345.         (if (and lwi (not (vlax-erased-p lwi)))
346.           (entdel lwi)
347.         )
348.         lwnl
349.       )
350.     )
351.   )
352.
353.   (or doc (setq doc (vla-get-activedocument cad)))
354.   (or spc (setq spc (vla-get-block (setq lay (vla-get-activelayout doc)))))
355.
356.   (if (= 8 (logand 8 (getvar 'undoctl)))
357.     (vla-endundomark doc)
358.   )
359.   (if
360.     (and
361.       (setq lw (car (entsel "\nPick boundary closed polygonal LWPOLYLINE with only straight segments...")))
362.       (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE")
363.       (= 1 (logand 1 (cdr (assoc 70 lwx))))
364.       (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
365.       (setq el (entlast) ent lw)
366.     )
367.       (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
368.       (if (> (vlax-curve-getarea lwi) (vlax-curve-getarea lw))
369.         (setq lw (rlw lw)) ;;; force main lwpolyline CCW - counter clockwise ;;;
370.       )
371.       (setq enti (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object ent) 'offset -1e-3))))
372.       (if (and lwi (not (vlax-erased-p lwi)))
373.         (entdel lwi)
374.       )
375.       (if (not f)
376.           (setq vlll (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget ent))))
377.           (setq vllli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget enti))))
378.           (setq tlll (mapcar '(lambda ( a b ) (list a b)) vlll (append (cdr vlll) (list (car vlll)))))
379.           (setq f t)
380.         )
381.       )
382.       (initget "Yes No")
383.       (setq ch (cond ((getkword "\nDo you want points-offsets-lines or just lines [Yes / No] <Yes> - there are some lacks with just lines, so HIT ENTER : ")) ( "Yes" )))
384.       (while (not done)
385.         (if
386.           (and
387.             (not (vl-catch-all-error-p (setq lwnl (vl-catch-all-apply 'process (list lw)))))
388.             lwnl
389.           )
390.           (while (and (not done) (setq lww (car lwnl)))
391.             (setq lwnl (vl-remove lww lwnl))
392.             (setq lwo lww)
393.             (setq lwnl (vl-catch-all-apply 'process (list lww)))
394.             (if (vl-catch-all-error-p lwnl)
395.               (setq done t)
396.               (if (eq (car lwnl) lwo)
397.                 (setq done t)
398.               )
399.             )
400.           )
401.           (setq done t)
402.         )
403.       ) ;;; main engine ;;;
404.     )
405.   )
406.   (*error* nil)
407. )
408.

Regards, M.R.
« Last Edit: August 07, 2023, 08:30:30 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #220 on: July 21, 2023, 11:26:03 AM »
The lack that I see now and before is that that's built-in offset command... When I offset inside through point for example drawn inside point "P", offset LWPOLYLINE may pass and may not pass through and in that case usually it breaks to a few more smaller LWPOLYLINES...
So now problem consist in solving this task, upon solving and applying in my lastly posted code, solution should be successfuly created...

Any ideas are very welcomed...
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #221 on: July 21, 2023, 12:41:49 PM »
I've created sub (offset-inside), but it doesn't help, especially as I don't quite know how to combine it with real offset command function...

Code: [Select]
`THE CODE IS SOMEWHAT WORSE THAN PREVIOUSLY POSTED, SO I REMOVED IT FROM SITE...`
So, who want's to find solution in his own manner is welcomed to step in...
M.R.
« Last Edit: July 23, 2023, 02:58:13 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #222 on: August 03, 2023, 02:04:42 PM »
I just wanted to put this topic back at top of list so it remains as not solved challenge... It should work fast and follow offset inside paths...
My latest version is example of short and efficient code, but it just gives partial ridge lines... Like I said, someone with more experiences should step in and try to correct it...
So long from me...
See you these days if you have something...
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #223 on: August 07, 2023, 02:32:23 PM »
I don't see any feedback...
What should I change in posted code... (C:ROOF-NEW)

Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #224 on: August 08, 2023, 01:30:57 AM »
I've changed a bit, so now it looks better, but it goes in infinite loops and doesn't do what I predicted - from smallest offset then first just a little larger offset where points are met, and so on, so on... It seems that this topic is not so interesting, but now I feel that I am close to finish correct... It's just that PC doesn't want to operate as expected...

Code - Auto/Visual Lisp: [Select]
1. (defun c:roof-new-new ( / *error* unit rlw offd inside-p collinear-p unique chkcircinside mc preprocess1 preprocess2 rem-vllvlli subprocess process done lw lwi lwx lwo ent enti lil lix lwnl ch el p1 p2 pp ppp ipp ippl vll vlli tll iplst lst ) ;;; cad, doc, spc, lay, vlll, vllli, tlll, f - global variables ;;;
2.
3.
4.   (defun *error* ( m )
5.     (if (and lwi (not (vlax-erased-p lwi)))
6.       (entdel lwi)
7.     )
8.     (if (and enti (not (vlax-erased-p enti)))
9.       (entdel enti)
10.     )
11.     (if (setq ppp (unique ppp))
12.       (foreach pp ppp
13.         (if (not (vl-some '(lambda ( x ) (and (not (equal (car x) pp 1e-6)) (not (equal (cadr x) pp 1e-6)) (not (equal (car x) (cadr x) 1e-6)) (collinear-p (car x) pp (cadr x)))) lil))
14.           (entmake (list (cons 0 "POINT") (cons 10 pp) (cons 62 1)))
15.         )
16.       )
17.     )
18.     (if (= ch "No")
19.       (while (setq el (entnext el))
20.         (if (and el (not (vlax-erased-p el)))
21.           (entdel el)
22.         )
23.       )
24.     )
25.     (if lil
26.       (foreach li lil
27.         (if (vl-some '(lambda ( x ) (and (not (equal (car li) x 1e-6)) (not (equal (cadr li) x 1e-6)) (not (equal (car li) (cadr li) 1e-6)) (collinear-p (car li) x (cadr li)))) ppp)
28.           (setq lil (vl-remove li lil))
29.           (if (vl-some '(lambda ( x ) (equal x (car li) 1e-6)) ppp)
30.             (entmake (list (cons 0 "LINE") (cons 10 (car li)) (cons 11 (cadr li)) (cons 62 3)))
31.           )
32.         )
33.       )
34.     )
35.     (command-s "_.-OVERKILL" "_ALL" "_T" "_Y" "" "")
36.     (if (= 8 (logand 8 (getvar 'undoctl)))
37.       (vla-endundomark doc)
38.     )
39.     (prompt "\nIf you want to start again on different sample, make sure you nil flag f : (setq f nil vlll nil vllli nil tlll nil) ...")
40.     (if m
41.       (prompt m)
42.     )
43.     (princ)
44.   )
45.
46.   (defun unit ( v / d )
47.     (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-6))
48.       (mapcar '(lambda ( x ) (/ x d)) v)
49.     )
50.   )
51.
52.   (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
53.     ;; by ElpanovEvgeniy
54.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
55.         (foreach a1 e
56.           (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
57.                 ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
58.                 ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
59.                 ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
60.                 ((= (car a1) 210) (setq x6 (cons a1 x6)))
61.                 (t (setq x1 (cons a1 x1)))
62.           )
63.         )
64.         (entmod (append (reverse x1)
65.                               (cons 'list
66.                                 (list x2
67.                                   (cdr (reverse (cons (car x3) (reverse x3))))
68.                                   (cdr (reverse (cons (car x4) (reverse x4))))
69.                                   (cdr (reverse (cons (car x5) (reverse x5))))
70.                                 )
71.                               )
72.                             )
73.                           )
74.                           x6
75.                   )
76.                 )
77.         )
78.         (entupd lw)
79.       )
80.     )
81.   )
82.
83.   (defun offd ( sign ip tl / dl )
84.     (setq dl (mapcar '(lambda ( x )
85.                         (distance ip
86.                             ip
87.                             (polar ip (+ (* 0.5 pi) (angle (car x) (cadr x))) 1.0)
88.                             (car x)
89.                             (polar (car x) (angle (car x) (cadr x)) 1.0)
90.                             nil
91.                           )
92.                         )
93.                       ) tl
94.               )
95.     )
96.     (vl-some '(lambda ( x )
97.                (if
98.                  (>
99.                    (-
100.                      (length dl)
101.                      (length (vl-remove-if '(lambda ( y ) (equal x y 0.05)) dl))
102.                    ) 2
103.                  )
104.                  x
105.                )
106.              ) (vl-sort dl sign)
107.     )
108.   )
109.
110.   (defun inside-p ( p lw lwi )
111.   )
112.
113.   (defun collinear-p ( p1 p p2 )
114.     (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
115.   )
116.
117.   (defun unique ( pl )
118.     (if pl
119.       (cons (car pl)
120.             (unique
121.               (vl-remove-if
122.                 '(lambda ( x )
123.                    (equal x (car pl) 1e-6)
124.                  )
125.                 (cdr pl)
126.               )
127.             )
128.       )
129.     )
130.   )
131.
132.   (defun chkcircinside ( pp tll / d ci ipp ippl tst )
133.     (if (and pp tll)
134.         (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 pp) (cons 40 (offd (function <) pp tll)))))
135.         (if (setq ipp (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object ent) acextendnone))
136.             (while ipp
137.               (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
138.               (setq ipp (cdddr ipp))
139.             )
140.             (if (or (not ippl) (vl-every '(lambda ( x ) (inside-p x ent enti)) (apply 'append (mapcar '(lambda ( x ) (list (vlax-curve-getpointatparam ci (- x 0.1)) (vlax-curve-getpointatparam ci (+ x 0.1)))) (mapcar '(lambda ( x ) (vlax-curve-getparamatpoint ci x)) ippl)))))
141.               (setq tst t)
142.             )
143.           )
144.           (setq tst t)
145.         )
146.         (if (and ci (not (vlax-erased-p ci)))
147.           (entdel ci)
148.         )
149.       )
150.     )
151.     tst
152.   )
153.
154.   (defun mc ( p lw / ci pl mp )
155.     (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 1.0))))
156.     (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
157.     (if (and ci (not (vlax-erased-p ci)))
158.       (entdel ci)
159.     )
160.     (setq mp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (list (car pl) (cadr pl)) (list (nth 3 pl) (nth 4 pl))))
161.     (list p mp)
162.   )
163.
164.   (defun preprocess1 ( vl vli / ip ) ;;; iplst - lexical global variable
165.     (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
166.                           (if
167.                             (and
168.                               (setq ip (inters p1 p2 p3 p4 nil))
169.                               (inside-p ip ent enti)
170.                               (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
171.                               (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
172.                               (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
173.                               (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
174.                             )
175.                             (list ip (list p1 p3))
176.                             (list nil nil)
177.                           )
178.                         )
179.                         vl
180.                         vli
181.                         (append (cdr vl) (list (car vl)))
182.                         (append (cdr vli) (list (car vli)))
183.                 )
184.     )
185.     iplst
186.   )
187.
188.   (defun preprocess2 ( vl vli / ip ) ;;; iplst - lexical global variable
189.     (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
190.                           (if
191.                             (and
192.                               (setq ip (inters p1 p2 p3 p4 nil))
193.                               (inside-p ip ent enti)
194.                               (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
195.                               (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
196.                               (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
197.                               (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
198.                             )
199.                             (list ip (list p1 p3))
200.                             (list nil nil)
201.                           )
202.                         )
203.                         vl
204.                         vli
205.                         (mapcar '(lambda ( x ) (car (mc (caar lil) (car lwnl)))) vl)
206.                         (mapcar '(lambda ( x ) (cadr (mc (caar lil) (car lwnl)))) vli)
207.                 )
208.     )
209.     iplst
210.   )
211.
212.   (defun rem-vllvlli ( lil lwnl )
213.     (if (vl-some '(lambda ( x ) (equal x (cadr (car lil)) 1e-2)) vll)
214.         (setq vll (vl-remove-if '(lambda ( x ) (equal (cadr (car lil)) x 1e-2)) vll))
215.         (setq vlli (vl-remove-if '(lambda ( x ) (equal (cadr (car lil)) x 1e-2)) vlli))
216.       )
217.     )
218.     (if (vl-some '(lambda ( x ) (equal x (cadr (cadr lil)) 1e-2)) vll)
219.         (setq vll (vl-remove-if '(lambda ( x ) (equal (cadr (cadr lil)) x 1e-2)) vll))
220.         (setq vlli (vl-remove-if '(lambda ( x ) (equal (cadr (cadr lil)) x 1e-2)) vlli))
221.       )
222.     )
223.   )
224.
225.   (defun subprocess ( iplst / p1 p2 pp1 pp2 )
226.     (setq iplst (vl-remove-if '(lambda ( x ) (or (null (car x)) (null (cadr x)))) iplst))
227.     (setq iplstoffd (mapcar '(lambda ( x ) (if (and (car x) (cadr x))
228.                                              (list
229.                                                (mapcar '+ '(0.0 0.0) (car x))
230.                                                (mapcar '(lambda ( y ) (mapcar '+ '(0.0 0.0) y)) (cadr x))
231.                                                (offd (function <) (mapcar '+ '(0.0 0.0) (car x)) tlll)
232.                                              )
233.                                              (list nil nil nil)
234.                                            )
235.                              ) iplst
236.                     )
237.     )
238.     (setq iplstoffd (vl-remove-if '(lambda ( x ) (null (caddr x))) iplstoffd))
239.     (setq iplstoffd (vl-sort iplstoffd '(lambda ( a b ) (< (caddr a) (caddr b)))))
240.     (if (not (vl-position (car iplstoffd) lst))
241.       (setq ipd (car iplstoffd) lst (cons ipd lst))
242.         (setq iplstoffd (cdr (member (car lst) iplstoffd)))
243.         (setq ipd (car iplstoffd) lst (cons ipd lst))
244.       )
245.     )
246.     (if (and ipd (chkcircinside (car ipd) tlll))
247.         (setq ppp (cons (car ipd) ppp))
248.         (if
249.           (and
250.             (setq p1
251.               (vl-some '(lambda ( x )
252.                 (if
253.                     (unit (mapcar '- (car ipd) x))
254.                     (unit (mapcar '- (car ipd) (caadr ipd)))
255.                     1e-6
256.                   )
257.                   x
258.                 )
259.               ) vll
260.               )
261.             )
262.             (setq pp1
263.               (vl-some '(lambda ( x )
264.                 (if
265.                     (unit (mapcar '- (car ipd) x))
266.                     (unit (mapcar '- (car ipd) p1))
267.                     1e-6
268.                   )
269.                   x
270.                 )
271.               ) vlll
272.               )
273.             )
274.           )
275.           (setq lil (cons (list (car ipd) pp1) lil))
276.           (if p1
277.             (setq lil (cons (list (car ipd) p1) lil))
278.             (setq lil (cons (list (car ipd) (caadr ipd)) lil))
279.           )
280.         )
281.         (if
282.           (and
283.             (setq p2
284.               (vl-some '(lambda ( x )
285.                 (if
286.                     (unit (mapcar '- (car ipd) x))
288.                     1e-6
289.                   )
290.                   x
291.                 )
292.               ) vll
293.               )
294.             )
295.             (setq pp2
296.               (vl-some '(lambda ( x )
297.                 (if
298.                     (unit (mapcar '- (car ipd) x))
299.                     (unit (mapcar '- (car ipd) p2))
300.                     1e-6
301.                   )
302.                   x
303.                 )
304.               ) vlll
305.               )
306.             )
307.           )
308.           (setq lil (cons (list (car ipd) pp2) lil))
309.           (if p2
310.             (setq lil (cons (list (car ipd) p2) lil))
312.           )
313.         )
314.         (if
315.           (and
317.             (setq lwnl (vl-catch-all-apply
318.               (list (vlax-ename->vla-object lw) 'offset (- (caddr ipd)))
319.             ))
320.           )
321.           (if (and lwnl (not (vl-catch-all-error-p lwnl)))
322.             (setq lwnl (mapcar 'vlax-vla-object->ename lwnl))
323.             (setq done t)
324.           )
325.         )
326.         (cond
327.           ( (and lwnl (not (vl-catch-all-error-p lwnl)) (= (length lwnl) 1))
328.             (rem-vllvlli lil lwnl)
329.           )
330.           ( (and lwnl (not (vl-catch-all-error-p lwnl)) (> (length lwnl) 1))
331.             (setq lwnl (vl-sort lwnl '(lambda ( a b ) (< (distance (car ipd) (vlax-curve-getclosestpointto a (car ipd))) (distance (car ipd) (vlax-curve-getclosestpointto b (car ipd)))))))
332.             (rem-vllvlli lil lwnl)
333.           )
334.         )
335.       )
336.     )
337.     lwnl
338.   )
339.
340.   (defun process ( lw / lwi lwx vl vli iplst tl lwnl ) ;;; vll, vlli, tll, lwnl, ppp, done - lexical global variables ;;;
341.     (if lw
342.         (setq vl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw)))))
343.         (if (not vll)
344.           (setq vll vl)
345.         )
346.         (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
347.         (setq vli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lwi))))
348.         (if (not vlli)
349.           (setq vlli vli)
350.         )
351.         (setq tl (mapcar '(lambda ( a b ) (list a b)) vl (append (cdr vl) (list (car vl)))))
352.         (if (not tll)
353.           (setq tll tl)
354.         )
355.         (repeat (* 5 (length vll))
356.           (setq iplst nil)
357.           (setq iplst (preprocess1 vll vlli))
358.           (subprocess iplst)
359.           (setq iplst nil)
360.           (setq iplst (preprocess2 vll vlli))
361.           (subprocess iplst)
362.         )
363.         (if (and lwi (not (vlax-erased-p lwi)))
364.           (entdel lwi)
365.         )
366.         lwnl
367.       )
368.     )
369.   )
370.
371.   (or doc (setq doc (vla-get-activedocument cad)))
372.   (or spc (setq spc (vla-get-block (setq lay (vla-get-activelayout doc)))))
373.
374.   (if (= 8 (logand 8 (getvar 'undoctl)))
375.     (vla-endundomark doc)
376.   )
377.   (if
378.     (and
379.       (setq lw (car (entsel "\nPick boundary closed polygonal LWPOLYLINE with only straight segments...")))
380.       (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE")
381.       (= 1 (logand 1 (cdr (assoc 70 lwx))))
382.       (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
383.       (setq el (entlast) ent lw)
384.     )
385.       (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
386.       (if (> (vlax-curve-getarea lwi) (vlax-curve-getarea lw))
387.         (setq lw (rlw lw)) ;;; force main lwpolyline CCW - counter clockwise ;;;
388.       )
389.       (setq enti (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object ent) 'offset -1e-3))))
390.       (if (and lwi (not (vlax-erased-p lwi)))
391.         (entdel lwi)
392.       )
393.       (if (not f)
394.           (setq vlll (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget ent))))
395.           (setq vllli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget enti))))
396.           (setq tlll (mapcar '(lambda ( a b ) (list a b)) vlll (append (cdr vlll) (list (car vlll)))))
397.           (setq f t)
398.         )
399.       )
400.       (initget "Yes No")
401.       (setq ch (cond ( (getkword "\nDo you want points-offsets-lines or just lines [Yes / No] <Yes> : ") ) ( "Yes" )))
402.       (while (not done)
403.         (if
404.           (and
405.             (not (vl-catch-all-error-p (setq lwnl (vl-catch-all-apply 'process (list lw)))))
406.             lwnl
407.           )
408.           (while (and (not done) (setq lww (car (vl-sort lwnl '(lambda ( a b ) (> (vlax-curve-getarea a) (vlax-curve-getarea b)))))))
409.             (setq lwnl (vl-remove lww lwnl))
410.             (setq lwo lww)
411.             (setq lwnl (vl-catch-all-apply 'process (list lww)))
412.             (if (vl-catch-all-error-p lwnl)
413.               (setq done t)
414.               (if (eq (car lwnl) lwo)
415.                 (setq done t)
416.               )
417.             )
418.           )
419.           (setq done t)
420.         )
421.       ) ;;; main engine ;;;
422.     )
423.   )
424.   (*error* nil)
425. )
426.

Regards, M.R.
« Last Edit: August 10, 2023, 12:53:52 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture) 