Topic: ==={Challenge}===Find the ridge lines of sloped roof

[ribarm]

This version : https://www.theswamp.org/index.php?topic=41837.msg615983#msg615983
(roof-newest.lsp) is as much as it's possible with custom (_offset) sub... It can almost finish on some of examples, but on some throws nothing and on some throws forest of lines not really related to the code - routine... At the end I am half satisfied with this experimental version and depending on feedbacks topic will become closed... Still any conversion based on this custom (_offset) - *.dll; *.arx is IMHO not desirable, as it can give gibberish of lines, so only those roof2d*.lsp packed in ZIP on www.cadtutor.net in download section - those that gives solution - solutions are IMHO the ones that should be issue for conversion...
Thanks to all nevertheless you participated to challenge or not...

M.R.

[ribarm]

Will someone have a look at (mc) sub function and reply with some better solution... I am out of fuel for thoughts... Link for downloading stuff is the same as I previously posted : https://www.theswamp.org/index.php?topic=41837.msg615983#msg615983
It seems that no one want to participate... Only @Ron replied and I must say - that throwing nothing is connected with shape that mimics MLINE converted to LWPOLYLINE, or crossings of mlinear shapes... But the main task of building solutions is to be applicabe on orthogonal and random shape polygonal LWPOLYLINE...

[ribarm]

I think that my (mc) sub function is half OK - it behave as should, but it's difficult to predict where "mp" point should be in some cases that are complex... Here I am posting (mc) and in attachment is complete *.lsp... I really need help of some guru - master to fix those forest gibberish lines it throws after execution... Thanks for attention, M.R.

Code - Auto/Visual Lisp: [Select]

1.   (defun mc ( p lw / mid ci pl mp p1 p2 p3 p4 pp1 pp2 pp3 pp4 pp )
2.  
3.     (defun mid ( ci p1 p2 / par1 par2 mp )
4.       (setq par1 (+ (* 2 pi) (vlax-curve-getparamatpoint ci p1)) par2 (+ (* 2 pi) (vlax-curve-getparamatpoint ci p2)))
5.       (setq mp (mapcar '+ '(0.0 0.0) (vlax-curve-getpointatparam ci (/ (+ par1 par2) 2.0))))
6.     )
7.  
8.     (if (and (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 0.5)))) lw (not (vlax-erased-p ci)) (not (vlax-erased-p lw)))
9.       (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
10.     )
11.     (if pl
12.       (cond
13.         ( (= (length pl) 12)
14.           (setq p1 (list (car pl) (cadr pl)))
15.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
16.           (setq p3 (list (nth 6 pl) (nth 7 pl)))
17.           (setq p4 (list (nth 9 pl) (nth 10 pl)))
18.           (setq pl (unique (list p1 p2 p3 p4)))
19.           (setq pp (vl-some '(lambda ( x ) (if (= (length (vl-remove-if '(lambda ( y ) (equal x y 1e-6)) (list p1 p2 p3 p4))) 3) x)) pl))
20.         )
21.         ( (= (length pl) 9)
22.           (setq p1 (list (car pl) (cadr pl)))
23.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
24.           (setq p3 (list (nth 6 pl) (nth 7 pl)))
25.           (setq pl (unique (list p1 p2 p3)))
26.           (setq pp (vl-some '(lambda ( x ) (if (= (length (vl-remove-if '(lambda ( y ) (equal x y 1e-6)) (list p1 p2 p3))) 2) x)) pl))
27.         )
28.         ( (= (length pl) 6)
29.           (setq p1 (list (car pl) (cadr pl)))
30.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
31.           (setq pl (unique (list p1 p2)))
32.         )
33.         ( (= (length pl) 3)
34.           (setq mp (list (car pl) (cadr pl)))
35.         )
36.       )
37.     )
38.     (if (and pl (not mp))
39.       (cond
40.         ( (= (length pl) 4)
41.           (setq p1 (car pl))
42.           (setq p2 (cadr pl))
43.           (setq p3 (caddr pl))
44.           (setq p4 (cadddr pl))
45.           (mapcar 'set '(p1 p2 p3 p4) (vl-sort (list p1 p2 p3 p4) '(lambda ( a b ) (< (vlax-curve-getparamatpoint ci a) (vlax-curve-getparamatpoint ci b)))))
46.           (setq pp1 (mid ci p1 p2))
47.           (setq pp2 (mid ci p2 p3))
48.           (setq pp3 (mid ci p3 p4))
49.           (setq pp4 (mid ci p4 p1))
50.           (cond
51.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p1)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
52.               (if (not (equal p pp3 1e-6))
53.                 (setq mp pp3)
54.                 (setq mp p3)
55.               )
56.             )
57.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p2)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
58.               (if (not (equal p pp4 1e-6))
59.                 (setq mp pp4)
60.                 (setq mp p4)
61.               )
62.             )
63.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p3)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
64.               (if (not (equal p pp1 1e-6))
65.                 (setq mp pp1)
66.                 (setq mp p1)
67.               )
68.             )
69.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p4)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
70.               (if (not (equal p pp2 1e-6))
71.                 (setq mp pp2)
72.                 (setq mp p2)
73.               )
74.             )
75.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp1)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
76.               (if (not (equal p pp 1e-6))
77.                 (setq mp pp)
78.                 (setq mp pp3)
79.               )
80.             )
81.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp2)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
82.               (if (not (equal p pp 1e-6))
83.                 (setq mp pp)
84.                 (setq mp pp4)
85.               )
86.             )
87.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp3)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
88.               (if (not (equal p pp 1e-6))
89.                 (setq mp pp)
90.                 (setq mp pp1)
91.               )
92.             )
93.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp4)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
94.               (if (not (equal p pp 1e-6))
95.                 (setq mp pp)
96.                 (setq mp pp2)
97.               )
98.             )
99.           )
100.         )
101.         ( (= (length pl) 3)
102.           (setq p1 (car pl))
103.           (setq p2 (cadr pl))
104.           (setq p3 (caddr pl))
105.           (mapcar 'set '(p1 p2 p3) (vl-sort (list p1 p2 p3) '(lambda ( a b ) (< (vlax-curve-getparamatpoint ci a) (vlax-curve-getparamatpoint ci b)))))
106.           (setq pp1 (mid ci p1 p2))
107.           (setq pp2 (mid ci p2 p3))
108.           (setq pp3 (mid ci p3 p1))
109.           (cond
110.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p1)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
111.               (if (not (equal p pp2 1e-6))
112.                 (setq mp pp2)
113.                 (setq mp p2)
114.               )
115.             )
116.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p2)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
117.               (if (not (equal p pp3 1e-6))
118.                 (setq mp pp3)
119.                 (setq mp p3)
120.               )
121.             )
122.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p p3)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
123.               (if (not (equal p pp1 1e-6))
124.                 (setq mp pp1)
125.                 (setq mp p1)
126.               )
127.             )
128.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp1)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
129.               (if (not (equal p pp 1e-6))
130.                 (setq mp pp)
131.                 (setq mp p3)
132.               )
133.             )
134.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp2)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
135.               (if (not (equal p pp 1e-6))
136.                 (setq mp pp)
137.                 (setq mp p1)
138.               )
139.             )
140.             ( (vl-some '(lambda ( li ) (equal (unit (mapcar '- p pp3)) (unit (mapcar '- p (cadr li))) 1e-6)) lil)
141.               (if (not (equal p pp 1e-6))
142.                 (setq mp pp)
143.                 (setq mp p2)
144.               )
145.             )
146.           )
147.         )
148.         ( (= (length pl) 2)
149.           (setq p1 (car pl))
150.           (setq p2 (cadr pl))
151.           (mapcar 'set '(p1 p2) (vl-sort (list p1 p2) '(lambda ( a b ) (< (vlax-curve-getparamatpoint ci a) (vlax-curve-getparamatpoint ci b)))))
152.           (setq mp (mid ci p1 p2))
153.         )
154.         ( (= (length pl) 1)
155.           (setq mp (car pl))
156.         )
157.       )
158.     )
159.     (if (and ci (not (vlax-erased-p ci)))
160.       (entdel ci)
161.     )
162.     (list p mp)
163.   )
164.  

[ribarm]

This is as far as I get with (mc) sub... Still the complete routine has many lacks, but in essence it's attempt to shorten coding as much as possible and give desired result as much fine as it could with custom (_offset) sub function... In attachment is *.lsp, but you have it also at cadtutor site download section...

Code - Auto/Visual Lisp: [Select]

1.   (defun mc ( p lw lww lwww / mid ci pl pll1 pll2 plll pllll mp p1 p2 p3 p4 p121 p231 p341 p141 p131 p241 p122 p232 p342 p142 p132 p242 pp1 pp2 pp3 pp4 ppp1 ppp2 ppp3 ppp4 )
2.  
3.     (defun mid ( ci p1 p2 / par1 par2 mp )
4.       (setq par1 (+ (* 2 pi) (vlax-curve-getparamatpoint ci p1)) par2 (+ (* 2 pi) (vlax-curve-getparamatpoint ci p2)))
5.       (setq mp (mapcar '+ '(0.0 0.0) (vlax-curve-getpointatparam ci (/ (+ par1 par2) 2.0))))
6.     )
7.  
8.     (if (and (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 0.5)))) lw (not (vlax-erased-p ci)) (not (vlax-erased-p lw)))
9.       (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
10.     )
11.     (setq pll1 (vlax-invoke (vlax-ename->vla-object lww) 'intersectwith (vlax-ename->vla-object lww) acextendnone))
12.     (setq pll1 (groupbynum pll1 3))
13.     (setq pll1 (mapcar '(lambda ( x ) (list (car x) (cadr x))) pll1))
14.     (setq pll2 (vlax-invoke (vlax-ename->vla-object lwww) 'intersectwith (vlax-ename->vla-object lwww) acextendnone))
15.     (setq pll2 (groupbynum pll2 3))
16.     (setq pll2 (mapcar '(lambda ( x ) (list (car x) (cadr x))) pll2))
17.     (setq plll (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lww) acextendnone))
18.     (setq plll (groupbynum plll 3))
19.     (setq plll (mapcar '(lambda ( x ) (list (car x) (cadr x))) plll))
20.     (setq pllll (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lwww) acextendnone))
21.     (setq pllll (groupbynum pllll 3))
22.     (setq pllll (mapcar '(lambda ( x ) (list (car x) (cadr x))) pllll))
23.     (if pl
24.       (cond
25.         ( (= (length pl) 12)
26.           (setq p1 (list (car pl) (cadr pl)))
27.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
28.           (setq p3 (list (nth 6 pl) (nth 7 pl)))
29.           (setq p4 (list (nth 9 pl) (nth 10 pl)))
30.           (mapcar 'set '(p1 p2 p3 p4) (vl-sort (list p1 p2 p3 p4) '(lambda ( a b ) (< (vlax-curve-getparamatpoint ci a) (vlax-curve-getparamatpoint ci b)))))
31.           (if (equal (vlax-curve-getparamatpoint ci p4) (* 2 pi) 1e-6)
32.             (mapcar 'set '(p1 p2 p3 p4) (list p4 p1 p2 p3))
33.           )
34.           (setq p121 (mid ci p1 p2))
35.           (setq p231 (mid ci p2 p3))
36.           (setq p341 (mid ci p3 p4))
37.           (setq p141 (mid ci p1 p4))
38.           (setq p131 (mid ci p1 p3))
39.           (setq p241 (mid ci p2 p4))
40.           (setq p122 (polar p (angle p121 p) 0.5))
41.           (setq p232 (polar p (angle p231 p) 0.5))
42.           (setq p342 (polar p (angle p341 p) 0.5))
43.           (setq p142 (polar p (angle p141 p) 0.5))
44.           (setq p132 (polar p (angle p131 p) 0.5))
45.           (setq p242 (polar p (angle p241 p) 0.5))
46.           (setq pp1 (vl-remove-if-not '(lambda ( x ) (equal x p1 0.1)) plll))
47.           (setq pp2 (vl-remove-if-not '(lambda ( x ) (equal x p2 0.1)) plll))
48.           (setq pp3 (vl-remove-if-not '(lambda ( x ) (equal x p3 0.1)) plll))
49.           (setq pp4 (vl-remove-if-not '(lambda ( x ) (equal x p4 0.1)) plll))
50.           (setq ppp1 (vl-remove-if-not '(lambda ( x ) (equal x p1 0.1)) pllll))
51.           (setq ppp2 (vl-remove-if-not '(lambda ( x ) (equal x p2 0.1)) pllll))
52.           (setq ppp3 (vl-remove-if-not '(lambda ( x ) (equal x p3 0.1)) pllll))
53.           (setq ppp4 (vl-remove-if-not '(lambda ( x ) (equal x p4 0.1)) pllll))
54.           (entdel lw)
55.           (entdel lwww)
56.           (entdel ci)
57.           (setvar 'aperture 25)
58.           (cond
59.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p121)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p121)) pll2)) (not (collinear-pp p121 p (cadar lil))) (not (collinear-pp p121 p (cadadr lil))) (not (equal (distance p1 p2) 1.0 1e-6)))
60.               (setq mp p121)
61.             )
62.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p122)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p122)) pll2)) (not (collinear-pp p122 p (cadar lil))) (not (collinear-pp p122 p (cadadr lil))) (not (equal (distance p1 p2) 1.0 1e-6)))
63.               (setq mp p122)
64.             )
65.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p231)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p231)) pll2)) (not (collinear-pp p231 p (cadar lil))) (not (collinear-pp p231 p (cadadr lil))) (not (equal (distance p2 p3) 1.0 1e-6)))
66.               (setq mp p231)
67.             )
68.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p232)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p232)) pll2)) (not (collinear-pp p232 p (cadar lil))) (not (collinear-pp p232 p (cadadr lil))) (not (equal (distance p2 p3) 1.0 1e-6)))
69.               (setq mp p232)
70.             )
71.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p341)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p341)) pll2)) (not (collinear-pp p341 p (cadar lil))) (not (collinear-pp p341 p (cadadr lil))) (not (equal (distance p3 p4) 1.0 1e-6)))
72.               (setq mp p341)
73.             )
74.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p342)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p342)) pll2)) (not (collinear-pp p342 p (cadar lil))) (not (collinear-pp p342 p (cadadr lil))) (not (equal (distance p3 p4) 1.0 1e-6)))
75.               (setq mp p342)
76.             )
77.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p141)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p141)) pll2)) (not (collinear-pp p141 p (cadar lil))) (not (collinear-pp p141 p (cadadr lil))) (not (equal (distance p1 p4) 1.0 1e-6)))
78.               (setq mp p141)
79.             )
80.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p142)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p142)) pll2)) (not (collinear-pp p142 p (cadar lil))) (not (collinear-pp p142 p (cadadr lil))) (not (equal (distance p1 p4) 1.0 1e-6)))
81.               (setq mp p142)
82.             )
83.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p131)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p131)) pll2)) (not (collinear-pp p131 p (cadar lil))) (not (collinear-pp p131 p (cadadr lil))) (not (equal (distance p1 p3) 1.0 1e-6)))
84.               (setq mp p131)
85.             )
86.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p132)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p132)) pll2)) (not (collinear-pp p132 p (cadar lil))) (not (collinear-pp p132 p (cadadr lil))) (not (equal (distance p1 p3) 1.0 1e-6)))
87.               (setq mp p132)
88.             )
89.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p241)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p241)) pll2)) (not (collinear-pp p241 p (cadar lil))) (not (collinear-pp p241 p (cadadr lil))) (not (equal (distance p2 p4) 1.0 1e-6)))
90.               (setq mp p241)
91.             )
92.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p242)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p242)) pll2)) (not (collinear-pp p242 p (cadar lil))) (not (collinear-pp p242 p (cadadr lil))) (not (equal (distance p2 p4) 1.0 1e-6)))
93.               (setq mp p242)
94.             )
95.             ( (and (= (length pp1) 2) (not (collinear-pp p1 p (cadar lil))) (not (collinear-pp p1 p (cadadr lil))))
96.               (setq mp p1)
97.             )
98.             ( (and (= (length pp2) 2) (not (collinear-pp p2 p (cadar lil))) (not (collinear-pp p2 p (cadadr lil))))
99.               (setq mp p2)
100.             )
101.             ( (and (= (length pp3) 2) (not (collinear-pp p3 p (cadar lil))) (not (collinear-pp p3 p (cadadr lil))))
102.               (setq mp p3)
103.             )
104.             ( (and (= (length pp4) 2) (not (collinear-pp p4 p (cadar lil))) (not (collinear-pp p4 p (cadadr lil))))
105.               (setq mp p4)
106.             )
107.             ( (and (= (length pp1) 1) (= (length ppp1) 1) (not (collinear-pp p1 p (cadar lil))) (not (collinear-pp p1 p (cadadr lil))))
108.               (setq mp p1)
109.             )
110.             ( (and (= (length pp2) 1) (= (length ppp2) 1) (not (collinear-pp p2 p (cadar lil))) (not (collinear-pp p2 p (cadadr lil))))
111.               (setq mp p2)
112.             )
113.             ( (and (= (length pp3) 1) (= (length ppp3) 1) (not (collinear-pp p3 p (cadar lil))) (not (collinear-pp p3 p (cadadr lil))))
114.               (setq mp p3)
115.             )
116.             ( (and (= (length pp4) 1) (= (length ppp4) 1) (not (collinear-pp p4 p (cadar lil))) (not (collinear-pp p4 p (cadadr lil))))
117.               (setq mp p4)
118.             )
119.             ( (setq mp (vl-some '(lambda ( x ) (if (equal (osnap p "_int") (list (car x) (cadr x) 0.0) 1e-6) x)) (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal x y 1e-6)) (mapcar 'cdr (vl-remove-if '(lambda ( z ) (/= (car z) 10)) (entget lww))))) pll1)))
120.             )
121.           )
122.           (setvar 'aperture ape)
123.         )
124.         ( (= (length pl) 9)
125.           (setq p1 (list (car pl) (cadr pl)))
126.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
127.           (setq p3 (list (nth 6 pl) (nth 7 pl)))
128.           (mapcar 'set '(p1 p2 p3) (vl-sort (list p1 p2 p3) '(lambda ( a b ) (< (vlax-curve-getparamatpoint ci a) (vlax-curve-getparamatpoint ci b)))))
129.           (if (equal (vlax-curve-getparamatpoint ci p3) (* 2 pi) 1e-6)
130.             (mapcar 'set '(p1 p2 p3) (list p3 p1 p2))
131.           )
132.           (setq p121 (mid ci p1 p2))
133.           (setq p231 (mid ci p2 p3))
134.           (setq p131 (mid ci p1 p3))
135.           (setq p122 (polar p (angle p121 p) 0.5))
136.           (setq p232 (polar p (angle p231 p) 0.5))
137.           (setq p132 (polar p (angle p131 p) 0.5))
138.           (setq pp1 (vl-remove-if-not '(lambda ( x ) (equal x p1 0.1)) plll))
139.           (setq pp2 (vl-remove-if-not '(lambda ( x ) (equal x p2 0.1)) plll))
140.           (setq pp3 (vl-remove-if-not '(lambda ( x ) (equal x p3 0.1)) plll))
141.           (setq ppp1 (vl-remove-if-not '(lambda ( x ) (equal x p1 0.1)) pllll))
142.           (setq ppp2 (vl-remove-if-not '(lambda ( x ) (equal x p2 0.1)) pllll))
143.           (setq ppp3 (vl-remove-if-not '(lambda ( x ) (equal x p3 0.1)) pllll))
144.           (entdel lw)
145.           (entdel lwww)
146.           (entdel ci)
147.           (setvar 'aperture 25)
148.           (cond
149.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p121)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p121)) pll2)) (not (collinear-pp p121 p (cadar lil))) (not (collinear-pp p121 p (cadadr lil))) (not (equal (distance p1 p2) 1.0 1e-6)))
150.               (setq mp p121)
151.             )
152.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p122)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p122)) pll2)) (not (collinear-pp p122 p (cadar lil))) (not (collinear-pp p122 p (cadadr lil))) (not (equal (distance p1 p2) 1.0 1e-6)))
153.               (setq mp p122)
154.             )
155.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p131)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p131)) pll2)) (not (collinear-pp p131 p (cadar lil))) (not (collinear-pp p131 p (cadadr lil))) (not (equal (distance p1 p3) 1.0 1e-6)))
156.               (setq mp p131)
157.             )
158.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p132)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p132)) pll2)) (not (collinear-pp p132 p (cadar lil))) (not (collinear-pp p132 p (cadadr lil))) (not (equal (distance p1 p3) 1.0 1e-6)))
159.               (setq mp p132)
160.             )
161.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p231)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p231)) pll2)) (not (collinear-pp p231 p (cadar lil))) (not (collinear-pp p231 p (cadadr lil))) (not (equal (distance p2 p3) 1.0 1e-6)))
162.               (setq mp p231)
163.             )
164.             ( (and (or (vl-some '(lambda ( x ) (collinear-p p x p232)) pll1) (vl-some '(lambda ( x ) (collinear-p p x p232)) pll2)) (not (collinear-pp p232 p (cadar lil))) (not (collinear-pp p232 p (cadadr lil))) (not (equal (distance p2 p3) 1.0 1e-6)))
165.               (setq mp p232)
166.             )
167.             ( (and (= (length pp1) 2) (not (collinear-pp p1 p (cadar lil))) (not (collinear-pp p1 p (cadadr lil))))
168.               (setq mp p1)
169.             )
170.             ( (and (= (length pp2) 2) (not (collinear-pp p2 p (cadar lil))) (not (collinear-pp p2 p (cadadr lil))))
171.               (setq mp p2)
172.             )
173.             ( (and (= (length pp3) 2) (not (collinear-pp p3 p (cadar lil))) (not (collinear-pp p3 p (cadadr lil))))
174.               (setq mp p3)
175.             )
176.             ( (and (= (length pp1) 1) (= (length ppp1) 1) (not (collinear-pp p1 p (cadar lil))) (not (collinear-pp p1 p (cadadr lil))))
177.               (setq mp p1)
178.             )
179.             ( (and (= (length pp2) 1) (= (length ppp2) 1) (not (collinear-pp p2 p (cadar lil))) (not (collinear-pp p2 p (cadadr lil))))
180.               (setq mp p2)
181.             )
182.             ( (and (= (length pp3) 1) (= (length ppp3) 1) (not (collinear-pp p3 p (cadar lil))) (not (collinear-pp p3 p (cadadr lil))))
183.               (setq mp p3)
184.             )
185.             ( (setq mp (vl-some '(lambda ( x ) (if (equal (osnap p "_int") (list (car x) (cadr x) 0.0) 1e-6) x)) (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (equal x y 1e-6)) (mapcar 'cdr (vl-remove-if '(lambda ( z ) (/= (car z) 10)) (entget lww))))) pll1)))
186.             )
187.           )
188.           (setvar 'aperture ape)
189.         )
190.         ( (= (length pl) 6)
191.           (setq p1 (list (car pl) (cadr pl)))
192.           (setq p2 (list (nth 3 pl) (nth 4 pl)))
193.           (setq p12 (mid ci p1 p2))
194.           (if (and (equal p1 p2 1e-6) (not (collinear-pp p1 p (cadar lil))) (not (collinear-pp p1 p (cadadr lil))))
195.             (setq mp p1)
196.           )
197.           (if (not mp)
198.             (setq mp p12)
199.           )
200.         )
201.         ( (= (length pl) 3)
202.           (setq mp (list (car pl) (cadr pl)))
203.         )
204.       )
205.     )
206.     (if (and ci (not (vlax-erased-p ci)))
207.       (entdel ci)
208.     )
209.     (list p mp)
210.   )
211.  

Regards, M.R.

[ribarm]

Can someone analyze my roof.lsp attached in previous post further more... In some cases works fine, but in some not - some lines are missing, or calculated point is wrong... Still I am satisfied and like it is, but strongly believe that it could be brought to almost excellent - this way it's mark is good...

[ribarm]

I don't have feedbacks...
@Ron, have you tested latest one called just : roof.lsp...

[ribarm]

This one is short and it's based on EXTRUDE - TAPER option... Very much like Gian Paolo Cattaneo's, but it's shorter and I think just a little more reliable...

Code - Auto/Visual Lisp: [Select]

1. (defun c:roof-simple ( / *error* ucsf cmd ape osm ang ch delob el ell k lin linn p p1 p2 pl pll enx pp ss sss ssn vs ti )
2.  
3.   (defun *error* ( m )
4.     (if delob
5.       (setvar 'delobj delob)
6.     )
7.     (if osm
8.       (setvar 'osmode osm)
9.     )
10.     (if ape
11.       (setvar 'aperture ape)
12.     )
13.     (if ucsf
14.       (if command-s
15.         (command-s "_.ucs" "_p")
16.         (vl-cmdf "_.ucs" "_p")
17.       )
18.     )
19.     (if (= 8 (logand 8 (getvar 'undoctl)))
20.       (if command-s
21.         (command-s "_.undo" "_e")
22.         (vl-cmdf "_.undo" "_e")
23.       )
24.     )
25.     (if cmd
26.       (setvar 'cmdecho cmd)
27.     )
28.     (if m
29.       (prompt m)
30.     )
31.     (princ)
32.   )
33.  
34.   (setq cmd (getvar 'cmdecho))
35.   (setvar 'cmdecho 0)
36.   (setq delob (getvar 'delobj))
37.   (setq osm (getvar 'osmode))
38.   (setvar 'osmode 0)
39.   (setq ape (getvar 'aperture))
40.   (setvar 'aperture 15)
41.   (if (= 0 (getvar 'worlducs))
42.     (progn
43.       (vl-cmdf "_.ucs" "_w")
44.       (setq ucsf t)
45.     )
46.   )
47.   (if (= 8 (logand 8 (getvar 'undoctl)))
48.     (vl-cmdf "_.undo" "_e")
49.   )
50.   (vl-cmdf "_.undo" "_m")
51.   (setq pll (entsel "\nPick closed polygonal LWPOLYLINE with straight segments..."))
52.   (if (and pll (= (cdr (assoc 0 (setq enx (entget (car pll))))) "LWPOLYLINE") (= 1 (logand 1 (cdr (assoc 70 enx)))) (vl-every '(lambda ( x ) (= (cdr x) 0.0)) (vl-remove-if '(lambda ( x ) (/= (car x) 42)) enx)))
53.     (progn
54.       (setq pl (car pll))
55.       (setq pp (cadr pll))
56.       (setq p (getpoint "\nPick point inside picked 2d polyline"))
57.       (setq p (list (car p) (cadr p) 1e-3))
58.       (initget "2D 3D")
59.       (setq ch (cond ( (getkword "\nEnter choice [2D / 3D] < 2D > : ") ) ("2D")))
60.       (setq ti (car (_vl-times)))
61.       (if (= ch "2D")
62.         (progn
63.           (setvar 'delobj 0)
64.           (vl-cmdf "_.zoom" "_v")
65.           (setq vs (getvar 'viewsize))
66.           (vl-cmdf "_.zoom" "_p")
67.           (setq el (entlast))
68.           (vl-cmdf "_.extrude" pl "" "_t" 45.0 0.1)
69.           (while (< 0 (getvar 'cmdactive))
70.             (vl-cmdf "")
71.           )
72.           (vl-cmdf "_.solidedit" "_f" "_m" p "" (list 0.0 0.0 0.0) (list 0.0 0.0 vs))
73.           (while (< 0 (getvar 'cmdactive))
74.             (vl-cmdf "")
75.           )
76.           (vl-cmdf "_.solidedit" "_b" "_p" (entlast))
77.           (while (< 0 (getvar 'cmdactive))
78.             (vl-cmdf "")
79.           )
80.           (while (setq el (entnext el))
81.             (if (and (= (cdr (assoc 0 (entget el))) "3DSOLID") (not (eq el (ssname (ssget (osnap pp "_nea") '((0 . "3DSOLID"))) 0))))
82.               (entdel el)
83.               (setq ell el)
84.             )
85.           )
86.           (if (= (cdr (assoc 0 (entget ell))) "3DSOLID")
87.             (progn
88.               (setvar 'delobj 1)
89.               (setq el (entlast))
90.               (vl-cmdf "_.xedges" "_l")
91.               (while (< 0 (getvar 'cmdactive))
92.                 (vl-cmdf "")
93.               )
94.               (entdel ell)
95.               (setq sss (ssadd) ss (ssadd))
96.               (while (setq el (entnext el))
97.                 (ssadd el ss)
98.               )
99.               (repeat (setq ssn (sslength ss))
100.                 (setq lin (ssname ss (setq ssn (1- ssn))))
101.                 (if (and (= (caddr (cdr (assoc 10 (entget lin)))) 0.0) (= (caddr (cdr (assoc 11 (entget lin)))) 0.0))
102.                   (entdel lin)
103.                   (progn
104.                     (setq p1 (cdr (assoc 10 (entget lin))))
105.                     (setq p2 (cdr (assoc 11 (entget lin))))
106.                     (setq p1 (list (car p1) (cadr p1) 0.0))
107.                     (setq p2 (list (car p2) (cadr p2) 0.0))
108.                     (entmod (subst (cons 10 p1) (assoc 10 (entget lin)) (entget lin)))
109.                     (setq linn (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget lin)) (entget lin)))))))
110.                     (ssadd linn sss)
111.                   )
112.                 )
113.               )
114.               (repeat (setq ssn (sslength sss))
115.                 (setq lin (ssname sss (setq ssn (1- ssn))))
116.                 (repeat (setq k ssn)
117.                   (setq linn (ssname sss (setq k (1- k))))
118.                   (if (or (and (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 10 (entget linn))) 1e-6) (equal (cdr (assoc 11 (entget lin))) (cdr (assoc 11 (entget linn))) 1e-6)) (and (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget linn))) 1e-6) (equal (cdr (assoc 11 (entget lin))) (cdr (assoc 10 (entget linn))) 1e-6)))
119.                     (entdel lin)
120.                   )
121.                 )
122.               )
123.             )
124.           )
125.         )
126.         (progn
127.           (setvar 'delobj 0)
128.           (initget 5)
129.           (setq ang (getreal "\nEnter angle of slope of roof in decimal degrees (0 < ang < 90) : "))
130.           (setq ang (rem (- 90.0 ang) 90.0))
131.           (vl-cmdf "_.regen")
132.           (vl-cmdf "_.zoom" "_v")
133.           (setq vs (getvar 'viewsize))
134.           (vl-cmdf "_.zoom" "_p")
135.           (setq el (entlast))
136.           (vl-cmdf "_.extrude" pl "" "_t" ang 0.1)
137.           (while (< 0 (getvar 'cmdactive))
138.             (vl-cmdf "")
139.           )
140.           (vl-cmdf "_.solidedit" "_f" "_m" p "" (list 0.0 0.0 0.0) (list 0.0 0.0 vs))
141.           (while (< 0 (getvar 'cmdactive))
142.             (vl-cmdf "")
143.           )
144.           (vl-cmdf "_.solidedit" "_b" "_p" (entlast))
145.           (while (< 0 (getvar 'cmdactive))
146.             (vl-cmdf "")
147.           )
148.           (while (setq el (entnext el))
149.             (if (and (= (cdr (assoc 0 (entget el))) "3DSOLID") (not (eq el (ssname (ssget (osnap pp "_nea") '((0 . "3DSOLID"))) 0))))
150.               (entdel el)
151.             )
152.           )
153.         )
154.       )
155.       (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 15)) (prompt " milliseconds...")
156.     )
157.   )
158.   (*error* nil)
159. )
160.  

Regards, M.R.
HTH.

[ribarm]

@Lee, @Highflyingbird

I have a question for both : Were you using Taper option of EXTRUDE command (built-in) variant, or pure calculation method...
I am very interested to see if some of you are going to shed some light on my attempts which are good, but pretty slow... So this all could be very basic ground for developing *.arx, or *.dll... And if you don't mind I'd like to see speed comparison, so we need to have all codes public... For me ad my opinion, no one would like to pay anything if routines are slow and not practical which is the case with my versions posted at www.cadtutor.net download section...
Expecting new feedbacks... Topic again overcrowded with new topics...

[BIGAL]

I am impressed with your roof function years ago did a roof for houses programs you enter roof pitch and it uses pface to make 3d Pface roof panels so get the impression of a solid roof. It did only 1 section at a time HIP, GABLE, VALLEY and so on just building each section. Will make an example. It used geometry to work out the roof ridge points in 3D. It may be a simpler way than using extruded solids and merging. Will make some shapes use your roof.lsp to make 2d Line work then try to convert to 3d.

The code is copyrighted. So can not post.

[ribarm]

@It's Alive, aka Daniel,
Can those 3 files be converted from *.lsp to *.arx and not change it's functionality only fasten speed of execution...
I'll be very grateful if that's possible and AFAIK I think that every code is possible to be converted... Am I wrong or right?
Nevertheless, both are copyrighted on me as author, so I can public them as I wish and want whenever I find appropriate...
I am specifically interested in conversion of : roof2d-new-new-new.lsp and roof2d-new-new-solutions.lsp...

Regards, M.R.

[ribarm]

@Daniel,
Am I right or wrong?

[kdub_nz]

@ribarm,
Hi,
The @prefix does not notify the named member here as it does on the AutoCAD forums.
We  are relying on the member visiting the post thread and noticing the posted message.

It may be best to send Daniel a PM with a link to  your post.

//
Generally it is possible to write cpp code to replicate lisp, but the exercise is not a straight forward translation and takes a good understanding of both languages.
Lisp these days is pretty fast , however
some gains may be made by replacing any known bottlrnecks with a call to an wrapped arx method. This will require a thorough analysis of the code blocks that are slow or repeatedly called in loops or for multiple entities.
My belief is that a real return on investment is questionable for code that has minimal usage.
. . . this is exacerbated when working with compiled languages that are version dependant.

Sometimes we spend a lot of time trying to save a couple milliseconds.

This attachment is from one of my favourite sites.
Though comical in nature, it puts the issue in perspective:

[ribarm]

The problem is that I haven't saved any time by shortening the code - roof2d-new-new-new.lsp...
I just used what already was in roof2d-new-new.lsp...
Also the problem is that I have some places where I am using double (foreach) one nested in parent one. This slows things very much and I don't know how to get rid of this snippet... 2droof-final.lsp which can be founded in *.ZIP I posted in download section of www.cadtutor.net works perfectly fast, you just have to unlock it by finding winning combination of loop; errn; errm inputs...

Here I am attaching my testing *.DWG that I used in that purposes - there are simple tasks and there are complex ultimate roof tasks...
So who is willing to do testings on some fast PC, he/she can add new examples...

[ribarm]

@kdub_nz

Thank you for reply... The reason I am asking for conversion to some other language is not saving of couple milliseconds, but couple of 15 minutes, or even more half hours, hours... You can see what I am speaking if you download my previously posted *.dwg and those *.lsp files posted prevoiously in my latest post with attachments with *.lsp files...
Anyway, thanks for noticed working plan graph, although for me not totally understandable... The only person that I know that should be capeable to do conversion are Daniel for *.arx, *.brx and Gilles C. for *.dll and Sean T. also for *.dll... But I am not doing anyones roll-call, just making this topic alive as much as it should be...

Regards and thanks for reading,
M.R.

[kdub_nz]

I'll Translate the graph,

To get a return in 5 years on your time/money spent :

If the routine is used once a day and you can save 5 minutes each usage,
you can spend 6 days working on it.

If the routine is used once a week and you can save 1 minutes each usage,
you can spend 4 hours working on it.

If the routine is used once a month and you can save 5 minutes each usage,
you can spend 5 hours working on it.

some of the results are rounded with poetic licence.

If there are 10 paying users, all the better
As I said, perspective.

added:
Of course, the lessons learnt from programming are invaluable, so usually it's worth the time