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

0 Members and 2 Guests are viewing this topic. ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #30 on: June 07, 2012, 11:14:20 AM »
One last revision on code :
http://www.theswamp.org/index.php?topic=41837.msg470185#msg470185

(no need for calculation of area of polyline), just use variable VS (getvar 'vievsize) of (vl-cmdf "_.zoom" "v") view for determining Z most limit of moving face with solidedit along z axis...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture) #### GDF ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #31 on: June 08, 2012, 10:12:43 AM »
Very nice. Works perfectly.
Why is there never enough time to do it right, but always enough time to do it over? ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #32 on: September 03, 2013, 09:30:47 AM »
I've just finished my newest version of 2droof... In some cases with unorthogonal edges it is fine, but in some cases it can't construct correct finish apex ridge... Nevertheless as this version is freeware - my code, maybe it can be used to compare results with my version witch uses extrude command...

So here is it... I am waiting to see reactions, maybe someone solve this for orthogonal edges and correct finish and for concave edges...

[EDIT]: Code changed to be working correctly, but only with polylines that have straight unorthogonal convex segments-edges

Code - Auto/Visual Lisp: [Select]
1. (defun c:2droof-MR (/      unique _vl-remove    ridge  onlin-p
2.                     assocon       prelst suflst unit   kr     ll
3.                     pl     pln    poly   rl     tl     v      v1
4.                     v2     vl     vp     vp1    vp2    vpp1   vpp2
5.                     vpl    vrl    vtl    vx
6.                    )
7.
8.   (defun unique (lst)
9.     (if lst
10.       (cons (car lst)
11.             (unique (_vl-remove (car lst) (cdr lst) 1e-6))
12.       )
13.     )
14.   )
15.
16.   (defun _vl-remove (el lst fuzz)
17.     (vl-remove-if
18.       '(lambda (x)
19.          (and (equal (car x) (car el) fuzz)
21.          )
22.        )
23.       lst
24.     )
25.   )
26.
27.   (defun ridge (v1 v2)
28.     (if (not
29.           (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))
30.         )
31.       (mapcar '*
32.               (list -1.0 -1.0 -1.0)
33.               (mapcar '- v1 v2)
34.       )
35.       (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
36.                      0.0
37.                      1e-8
38.               )
39.               (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
40.                      -0.0
41.                      -1e-8
42.               )
43.           )
44.           (if (equal v1 v2 1e-8)
45.             (polar '(0.0 0.0 0.0)
46.                    (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))
47.                    1.0
48.             )
49.             v2
50.           )
51.         (mapcar '- v1 v2)
52.       )
53.     )
54.   )
55.
56.   (defun onlin-p (p1 p2 p)
57.     (and
58.       (equal (distance p1 p2)
59.              (+ (distance p1 p) (distance p2 p))
60.              1e-6
61.       )
62.       (not (equal (distance p1 p) 0.0 1e-6))
63.       (not (equal (distance p2 p) 0.0 1e-6))
64.     )
65.   )
66.
67.   (defun assocon (SearchTerm Lst func fuzz)
68.     (car
69.       (vl-member-if
70.           (lambda (pair)
71.             (equal SearchTerm (apply func (list pair)) fuzz)
72.           )
73.         )
74.         lst
75.       )
76.     )
77.   )
78.
79.   (defun prelst (lst el / f)
80.     (vl-remove-if
81.       '(lambda (a) (or f (setq f (equal a el 1e-8))))
82.       lst
83.     )
84.   )
85.
86.   (defun suflst (lst el)
87.     (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
88.   )
89.
90.   (defun unit (v)
91.     (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
92.   )
93.
94.
95.   )
96.
97.   (setq poly
98.          (car
99.              "\nPick LWPOLYLINE in WCS oriented CCW and with only straight convex segments-edges"
100.            )
101.          )
102.   )
103.   (setq
104.     vl (mapcar
105.          'cdr
106.          (vl-remove-if-not
107.            '(lambda (x) (= (car x) 10))
108.            (entget poly)
109.          )
110.        )
111.   )
112.   (setq vl (cons (last vl) vl))
113.   (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
114.   (setq tl (mapcar '(lambda (x) (unit x)) tl))
115.   (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
116.   (setq rl (mapcar '(lambda (a b) (ridge a b))
117.                    tl
118.                    (cdr (reverse (cons (car tl) (reverse tl))))
119.            )
120.   )
121.   (setq rl (mapcar '(lambda (x) (unit x)) rl))
122.   (setq vrl (mapcar '(lambda (a b) (list a b))
123.                     (cdr (reverse (cons (car vl) (reverse vl))))
124.                     rl
125.             )
126.   )
127.   (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
128.   (setq pln T)
129.
130.   (defun kr (lst / pl pp)
131.     (setq pl (mapcar '(lambda (a b)
132.                         (inters (car a)
133.                                 (mapcar '+ (car a) (cadr a))
134.                                 (car b)
135.                                 (mapcar '+ (car b) (cadr b))
136.                                 nil
137.                         )
138.                       )
139.                      (reverse (cons (car lst) (reverse lst)))
140.                      (cdr (reverse (cons (car lst) (reverse lst))))
141.              )
142.     )
143.     (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
144.                       vl
145.                       pl
146.                       (cdr vl)
147.               )
148.     )
149.     (setq vpl (apply 'append vpl))
150.     (while (assocon nil vpl 'cadr 1e-6)
151.       (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
152.     )
153.     (setq pln nil)
154.     (foreach p pl
155.             '(lambda (x)
156.                (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
157.              )
158.             vpl
159.           )
160.         (setq pln (cons p pln))
161.       )
162.     )
163.     (foreach p (reverse pln)
164.             '(lambda (x)
165.                (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
166.              )
167.             vpl
168.           )
169.         (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
170.       )
171.     )
172.     (setq vx nil)
173.     (foreach p pln
174.       (mapcar '(lambda (x)
175.                  (if (equal (cadr x) p 1e-6)
176.                    (setq vx (cons x vx))
177.                  )
178.                )
179.               vpl
180.       )
181.     )
182.     (setq pln (list (cadar (vl-sort vx
183.                                     '(lambda (a b)
184.                                        (< (distance (car a) (cadr a))
185.                                           (distance (car b) (cadr b))
186.                                        )
187.                                      )
188.                            )
189.                     )
190.               )
191.     )
193.                   vpl
194.         )
195.         (foreach l (unique vpl)
196.           (entmake (list '(0 . "LINE")
197.                          (cons 10 (car l))
199.                    )
200.           )
201.         )
202.         (setq pln nil)
203.       )
204.     )
205.     (foreach p pln
206.       (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
207.       (setq vp2
208.              (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)
209.                    vp2
210.              )
211.       )
212.       (if (car vp1)
213.         (entmake (list '(0 . "LINE")
214.                        (cons 10 (caar vp1))
216.                  )
217.         )
218.       )
219.       (if (car vp2)
220.         (entmake (list '(0 . "LINE")
221.                        (cons 10 (caar vp2))
223.                  )
224.         )
225.       )
226.       (setq vpp2 (caar vp2))
227.       (setq v2 nil)
228.       (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
229.         (if (not (null vpp2))
230.           (setq v2 vpp2)
231.         )
232.       )
233.       (if (null v2)
234.         (setq v2 (caar vp2))
235.       )
236.       (setq vpp1 (caar vp1))
237.       (setq v1 nil)
238.       (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
239.         (if (not (null vpp1))
240.           (setq v1 vpp1)
241.         )
242.       )
243.       (if (null v1)
244.         (setq v1 (caar vp1))
245.       )
246.       (setq pp
247.              (list
248.                p
249.                (unit
250.                  (ridge
251.                    (if
253.                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
254.                      )
256.                         (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
257.                       )
259.                    )
260.                    (cadr (assocon v2 vtl 'car 1e-6))
261.                  )
262.                )
263.              )
264.       )
265.       (setq vrl (if vrl
266.                   (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
267.                   (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
268.                 )
269.             vrl (if (assocon (caar vp2) vrl 'car 1e-6)
270.                   (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
271.                 )
272.       )
273.       (setq vl (subst p (caar vp1) vl)
274.             vl (subst p (caar vp2) vl)
275.       )
276.     )
277.   )
278.
279.   (while pln (kr vrl))
280.
281.   )
282.
283.   (princ)
284. )
285.

Regards, M.R.   « Last Edit: September 05, 2013, 03:00:02 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #33 on: September 03, 2013, 02:10:35 PM »
Code changed little...

Attached is dwg showing where isn't working well...

M.R.
« Last Edit: September 04, 2013, 07:13:00 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #34 on: September 04, 2013, 03:05:37 AM »
Now it's working fine in all cases in witch polyline is drawn CCW and that have straight unorthogonal convex edges-segements...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #35 on: September 05, 2013, 03:01:26 AM »
Now it's working fine in all cases in witch polyline is drawn CCW and that have straight unorthogonal convex edges-segements...

M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #36 on: September 06, 2013, 02:59:33 AM »
Here is my newest version - food for thoughts...

I must warn you, it may produce incorrect results when reaching connections of peripheral tree branches of more complex plines... Also above attached example won't even do anything - it's too complex...

Code - Auto/Visual Lisp: [Select]
1. (defun c:2droof-MR (/      unique _vl-remove    ridge  onlin-p
2.                     assocon       prelst suflst unit   kr     ll
3.                     pl     pln    poly   rl     tl     v      v1
4.                     v2     vl     vp     vp1    vp2    vpp1   vpp2
5.                     vpl    vrl    vtl    vx
6.                    )
7.
8.   (defun unique (lst)
9.     (if lst
10.       (cons (car lst)
11.             (unique (_vl-remove (car lst) (cdr lst) 1e-6))
12.       )
13.     )
14.   )
15.
16.   (defun _vl-remove (el lst fuzz)
17.     (vl-remove-if
18.       '(lambda (x)
19.          (and (equal (car x) (car el) fuzz)
21.          )
22.        )
23.       lst
24.     )
25.   )
26.
27.   (defun ridge (v1 v2)
28.     (if (not
29.           (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))
30.         )
31.       (mapcar '*
32.               (list -1.0 -1.0 -1.0)
33.               (mapcar '- v1 v2)
34.       )
35.       (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
36.                      0.0
37.                      1e-8
38.               )
39.               (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
40.                      -0.0
41.                      -1e-8
42.               )
43.           )
44.         (if (equal v1 v2 1e-8)
45.           (polar '(0.0 0.0 0.0)
46.                  (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))
47.                  1.0
48.           )
49.           v2
50.         )
51.         (mapcar '- v1 v2)
52.       )
53.     )
54.   )
55.
56.   (defun onlin-p (p1 p2 p)
57.     (and
58.       (equal (distance p1 p2)
59.              (+ (distance p1 p) (distance p2 p))
60.              1e-6
61.       )
62.       (not (equal (distance p1 p) 0.0 1e-6))
63.       (not (equal (distance p2 p) 0.0 1e-6))
64.     )
65.   )
66.
67.   (defun assocon (SearchTerm Lst func fuzz)
68.     (car
69.       (vl-member-if
70.           (lambda (pair)
71.             (equal SearchTerm (apply func (list pair)) fuzz)
72.           )
73.         )
74.         lst
75.       )
76.     )
77.   )
78.
79.   (defun prelst (lst el / f)
80.     (vl-remove-if
81.       '(lambda (a) (or f (setq f (equal a el 1e-8))))
82.       lst
83.     )
84.   )
85.
86.   (defun suflst (lst el)
87.     (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
88.   )
89.
90.   (defun unit (v)
91.     (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
92.   )
93.
94.
95.   )
96.
97.   (setq poly
98.          (car
99.              "\nPick LWPOLYLINE in WCS oriented CCW and with only straight convex segments-edges"
100.            )
101.          )
102.   )
103.   (setq
104.     vl (mapcar
105.          'cdr
106.          (vl-remove-if-not
107.            '(lambda (x) (= (car x) 10))
108.            (entget poly)
109.          )
110.        )
111.   )
112.   (setq vl (cons (last vl) vl))
113.   (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
114.   (setq tl (mapcar '(lambda (x) (unit x)) tl))
115.   (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
116.   (setq rl (mapcar '(lambda (a b) (ridge a b))
117.                    tl
118.                    (cdr (reverse (cons (car tl) (reverse tl))))
119.            )
120.   )
121.   (setq rl (mapcar '(lambda (x) (unit x)) rl))
122.   (setq vrl (mapcar '(lambda (a b) (list a b))
123.                     (cdr (reverse (cons (car vl) (reverse vl))))
124.                     rl
125.             )
126.   )
127.   (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
128.   (setq pln T)
129.
130.   (defun kr (lst / pl plnn plnnn pll plll vpx1 vpxp1 vpx2 vpxp2 pp)
131.       '(lambda (a b)
132.          (setq p
133.                 (inters (car a)
134.                         (mapcar '+ (car a) (cadr a))
135.                         (car b)
136.                         (mapcar '+ (car b) (cadr b))
137.                         nil
138.                 )
139.          )
140.          (setq pl (cons p pl))
141.          (if
142.            (and
143.              (vl-catch-all-apply
144.                'onlin-p
145.                (list (car a) p (mapcar '+ (car a) (cadr a)))
146.              )
147.
148.              (vl-catch-all-apply
149.                'onlin-p
150.                (list (car b) p (mapcar '+ (car b) (cadr b)))
151.              )
152.            )
153.             (setq pll (cons p pll))
154.          )
155.          (if
156.            (and
157.              (vl-catch-all-apply
158.                'onlin-p
159.                (list (mapcar '+ (car a) (cadr a)) p (car a))
160.              )
161.
162.              (vl-catch-all-apply
163.                'onlin-p
164.                (list (mapcar '+ (car b) (cadr b)) p (car b))
165.              )
166.            )
167.             (setq plll (cons p plll))
168.          )
169.        )
170.       (reverse (cons (car lst) (reverse lst)))
171.       (cdr (reverse (cons (car lst) (reverse lst))))
172.     )
173.     (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
174.                       vl
175.                       (reverse pl)
176.                       (cdr vl)
177.               )
178.     )
179.     (setq vpl (apply 'append vpl))
180.     (while (assocon nil vpl 'cadr 1e-6)
181.       (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
182.     )
183.     (setq pln nil)
184.     (foreach p pl
185.             '(lambda (x)
186.                (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
187.              )
188.             vpl
189.           )
190.         (setq pln (cons p pln))
191.       )
192.     )
193.     (foreach p (reverse pln)
194.             '(lambda (x)
195.                (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
196.              )
197.             vpl
198.           )
199.         (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
200.       )
201.     )
202.     (foreach p pl
203.       (setq vpx1 (assocon p vpl 'cadr 1e-6))
204.       (setq vpxp1 (if (last (prelst vpl vpx1))
205.                     (last (prelst vpl vpx1))
206.                     (last vpl)
207.                   )
208.       )
209.       (if (equal (car vpx1) (car vpxp1) 1e-6)
210.         (setq vpxp1 (if (last (prelst vpl vpxp1))
211.                       (last (prelst vpl vpxp1))
212.                       (last vpl)
213.                     )
214.         )
215.       )
216.       (setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))
217.       (setq vpxp2 (if (car (suflst vpl vpx2))
218.                     (car (suflst vpl vpx2))
219.                     (car vpl)
220.                   )
221.       )
222.       (if (equal (car vpx2) (car vpxp2) 1e-6)
223.         (setq vpxp2 (if (car (suflst vpl vpxp2))
224.                       (car (suflst vpl vpxp2))
225.                       (car vpl)
226.                     )
227.         )
228.       )
229.       (if (or (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
230.                           (unit (mapcar '- (car vpxp1) (cadr vpxp1)))
231.                           1e-6
232.                    )
233.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
234.                           (unit (mapcar '- (car vpxp2) (cadr vpxp2)))
235.                           1e-6
236.                    )
237.               )
238.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
239.                           (unit (mapcar '- (cadr vpxp1) (car vpxp1)))
240.                           1e-6
241.                    )
242.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
243.                           (unit (mapcar '- (cadr vpxp2) (car vpxp2)))
244.                           1e-6
245.                    )
246.               )
247.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
248.                           (unit (mapcar '- (car vpxp1) (cadr vpxp1)))
249.                           1e-6
250.                    )
251.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
252.                           (unit (mapcar '- (cadr vpxp2) (car vpxp2)))
253.                           1e-6
254.                    )
255.               )
256.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
257.                           (unit (mapcar '- (cadr vpxp1) (car vpxp1)))
258.                           1e-6
259.                    )
260.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
261.                           (unit (mapcar '- (car vpxp2) (cadr vpxp2)))
262.                           1e-6
263.                    )
264.               )
265.           )
266.         (setq plnn (cons p plnn))
267.       )
268.     )
269.     (foreach p plnn
270.       (if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)
271.         (setq plnnn (cons p plnnn))
272.       )
273.     )
274.     (setq pln (append pln plnnn))
275.     (setq vx nil)
276.     (foreach p pln
277.       (mapcar '(lambda (x)
278.                  (if (equal (cadr x) p 1e-6)
279.                    (setq vx (cons x vx))
280.                  )
281.                )
282.               vpl
283.       )
284.     )
285.     (foreach p plll
286.       (mapcar '(lambda (x)
287.                  (if (equal (cadr x) p 1e-6)
288.                    (setq vx (vl-remove x vx))
289.                  )
290.                )
291.               vx
292.       )
293.     )
295.                       (vl-sort vx
296.                                '(lambda (a b)
297.                                   (< (distance (car a) (cadr a))
298.                                      (distance (car b) (cadr b))
299.                                   )
300.                                 )
301.                       )
302.                     )
303.               )
304.     )
305.     (if (eq pln nil)
306.       (setq pln (acet-list-remove-duplicates (mapcar 'cadr vpl) 1e-6))
307.     )
309.                   vpl
310.         )
311.         (foreach l (unique vpl)
312.           (entmake (list '(0 . "LINE")
313.                          (cons 10 (car l))
315.                    )
316.           )
317.         )
318.         (setq pln nil)
319.       )
320.     )
321.     (if (and (eq vpl nil) (= (length (unique vrl)) 2))
322.       (entmake (list '(0 . "LINE")
323.                      (cons 10 (caar (unique vrl)))
324.                      (cons 11 (caadr (unique vrl)))
325.                )
326.       )
327.     )
328.     (foreach p pln
329.       (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
330.       (setq vp2
331.              (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)
332.                    vp2
333.              )
334.       )
335.       (if (car vp1)
336.         (entmake (list '(0 . "LINE")
337.                        (cons 10 (caar vp1))
339.                  )
340.         )
341.       )
342.       (if (car vp2)
343.         (entmake (list '(0 . "LINE")
344.                        (cons 10 (caar vp2))
346.                  )
347.         )
348.       )
349.       (setq vpp2 (caar vp2))
350.       (setq v2 nil)
351.       (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
352.         (if (not (null vpp2))
353.           (setq v2 vpp2)
354.         )
355.       )
356.       (if (null v2)
357.         (setq v2 (caar vp2))
358.       )
359.       (setq vpp1 (caar vp1))
360.       (setq v1 nil)
361.       (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
362.         (if (not (null vpp1))
363.           (setq v1 vpp1)
364.         )
365.       )
366.       (if (null v1)
367.         (setq v1 (caar vp1))
368.       )
369.       (setq pp
370.              (list
371.                p
372.                (unit
373.                  (ridge
374.                    (if
376.                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
377.                      )
379.                         (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
380.                       )
382.                    )
383.                    (cadr (assocon v2 vtl 'car 1e-6))
384.                  )
385.                )
386.              )
387.       )
388.       (setq vrl (if vrl
389.                   (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
390.                   (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
391.                 )
392.             vrl (if (assocon (caar vp2) vrl 'car 1e-6)
393.                   (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
394.                 )
395.       )
396.       (setq vl (subst p (caar vp1) vl)
397.             vl (subst p (caar vp2) vl)
398.       )
399.     )
400.   )
401.
402.   (while pln (kr vrl))
403.
404.   )
405.
406.   (princ)
407. )
408.

M.R.
« Last Edit: September 06, 2013, 04:36:02 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #37 on: September 06, 2013, 10:34:56 PM »
Here is my final code... If it breaks on some point, then you must reconstruct roof solution manually based on received result... This is rare case and it happens with more complex roofs... Note that roof must have one single solution of connected ridges; it will fail if you have small roof dormers as additions to main polyline... Now it should work and with concave plines... Any shape is possible... It solved my earlier situation posted above... Now there is another one - see attachment, but as I said, you'll have to reconstruct solution manually...

[EDIT]: Code finally updated - it should solve in any situation...

Code - Auto/Visual Lisp: [Select]
1. (defun 2droof (pol    /      _reml  unique _vl-remove    ridge  onlin-p
2.                assocon       prelst suflst ll     pl     pln    i
3.                rl     tl     v      v1     v2     vl     vp     vp1
4.                vp2    vpp1   vpp2   vpl    vrl    vtl    vx
5.               )
6.
7.   (defun _reml (l1 l2 / a n ls)
8.       (setq n nil
9.             a (car l2)
10.       )
11.        (while (and l1 (null n))
12.          (if (equal a (car l1) 1e-8)
13.            (setq l1 (cdr l1)
14.                  n  t
15.            )
16.            (setq ls (append ls (list (car l1)))
17.                  l1 (cdr l1)
18.            )
19.          )
20.        )
21.        (setq l2 (cdr l2))
22.     )
23.     (append ls l1)
24.   )
25.
26.   (defun unique (lst)
27.     (if lst
28.       (cons (car lst)
29.             (unique (_vl-remove (car lst) (cdr lst) 1e-6))
30.       )
31.     )
32.   )
33.
34.   (defun _vl-remove (el lst fuzz)
35.     (vl-remove-if
36.       '(lambda (x)
37.          (and (equal (car x) (car el) fuzz)
39.          )
40.        )
41.       lst
42.     )
43.   )
44.
45.   (defun ridge (v1 v2)
46.     (if (not
47.           (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))
48.         )
49.       (mapcar '*
50.               (list -1.0 -1.0 -1.0)
51.               (mapcar '- v1 v2)
52.       )
53.       (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
54.                      0.0
55.                      1e-8
56.               )
57.               (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
58.                      -0.0
59.                      -1e-8
60.               )
61.           )
62.         (if (equal v1 v2 1e-8)
63.           (polar '(0.0 0.0 0.0)
64.                  (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))
65.                  1.0
66.           )
67.           v2
68.         )
69.         (mapcar '- v1 v2)
70.       )
71.     )
72.   )
73.
74.   (defun onlin-p (p1 p2 p)
75.     (and
76.       (equal (distance p1 p2)
77.              (+ (distance p1 p) (distance p2 p))
78.              1e-6
79.       )
80.       (not (equal (distance p1 p) 0.0 1e-6))
81.       (not (equal (distance p2 p) 0.0 1e-6))
82.     )
83.   )
84.
85.   (defun assocon (SearchTerm Lst func fuzz)
86.     (car
87.       (vl-member-if
88.           (lambda (pair)
89.             (equal SearchTerm (apply func (list pair)) fuzz)
90.           )
91.         )
92.         lst
93.       )
94.     )
95.   )
96.
97.   (defun prelst (lst el / f)
98.     (vl-remove-if
99.       '(lambda (a) (or f (setq f (equal a el 1e-8))))
100.       lst
101.     )
102.   )
103.
104.   (defun suflst (lst el)
105.     (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
106.   )
107.
108.   (defun unit (v)
109.     (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
110.   )
111.
112.   (setq
113.     vl (mapcar
114.          'cdr
115.          (vl-remove-if-not
116.            '(lambda (x) (= (car x) 10))
117.            (entget pol)
118.          )
119.        )
120.   )
121.   (setq vl (cons (last vl) vl))
122.   (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
123.   (setq tl (mapcar '(lambda (x) (unit x)) tl))
124.   (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
125.   (setq rl (mapcar '(lambda (a b) (ridge a b))
126.                    tl
127.                    (cdr (reverse (cons (car tl) (reverse tl))))
128.            )
129.   )
130.   (setq rl (mapcar '(lambda (x) (unit x)) rl))
131.   (setq vrl (mapcar '(lambda (a b) (list a b))
132.                     (cdr (reverse (cons (car vl) (reverse vl))))
133.                     rl
134.             )
135.   )
136.   (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
137.   (setq pln T)
138.
139.   (defun kr (lst / pl plnn plnnn pll plll vpx1 vpxp1 vpx2 vpxp2 pp vxx z)
140.       '(lambda (a b)
141.          (setq p
142.                 (inters (car a)
143.                         (mapcar '+ (car a) (cadr a))
144.                         (car b)
145.                         (mapcar '+ (car b) (cadr b))
146.                         nil
147.                 )
148.          )
149.          (setq pl (cons p pl))
150.          (if
151.            (and
152.              (vl-catch-all-apply
153.                'onlin-p
154.                (list (car a) p (mapcar '+ (car a) (cadr a)))
155.              )
156.
157.              (vl-catch-all-apply
158.                'onlin-p
159.                (list (car b) p (mapcar '+ (car b) (cadr b)))
160.              )
161.            )
162.             (setq pll (cons p pll))
163.          )
164.          (if
165.            (and
166.              (vl-catch-all-apply
167.                'onlin-p
168.                (list (mapcar '+ (car a) (cadr a)) p (car a))
169.              )
170.
171.              (vl-catch-all-apply
172.                'onlin-p
173.                (list (mapcar '+ (car b) (cadr b)) p (car b))
174.              )
175.            )
176.             (setq plll (cons p plll))
177.          )
178.        )
179.       (reverse (cons (car lst) (reverse lst)))
180.       (cdr (reverse (cons (car lst) (reverse lst))))
181.     )
182.     (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
183.                       vl
184.                       (reverse pl)
185.                       (cdr vl)
186.               )
187.     )
188.     (setq vpl (apply 'append vpl))
189.     (while (assocon nil vpl 'cadr 1e-6)
190.       (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
191.     )
192.     (setq pln nil)
193.     (foreach p pl
194.             '(lambda (x)
195.                (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
196.              )
197.             vpl
198.           )
199.         (setq pln (cons p pln))
200.       )
201.     )
202.     (foreach p (reverse pln)
203.             '(lambda (x)
204.                (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
205.              )
206.             vpl
207.           )
208.         (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
209.       )
210.     )
211.     (foreach p pl
212.       (setq vpx1 (assocon p vpl 'cadr 1e-6))
213.       (setq vpxp1 (if (last (prelst vpl vpx1))
214.                     (last (prelst vpl vpx1))
215.                     (last vpl)
216.                   )
217.       )
218.       (if (equal (car vpx1) (car vpxp1) 1e-6)
219.         (setq vpxp1 (if (last (prelst vpl vpxp1))
220.                       (last (prelst vpl vpxp1))
221.                       (last vpl)
222.                     )
223.         )
224.       )
225.       (setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))
226.       (setq vpxp2 (if (car (suflst vpl vpx2))
227.                     (car (suflst vpl vpx2))
228.                     (car vpl)
229.                   )
230.       )
231.       (if (equal (car vpx2) (car vpxp2) 1e-6)
232.         (setq vpxp2 (if (car (suflst vpl vpxp2))
233.                       (car (suflst vpl vpxp2))
234.                       (car vpl)
235.                     )
236.         )
237.       )
238.       (if (or (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
239.                           (unit (mapcar '- (car vpxp1) (cadr vpxp1)))
240.                           1e-6
241.                    )
242.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
243.                           (unit (mapcar '- (car vpxp2) (cadr vpxp2)))
244.                           1e-6
245.                    )
246.               )
247.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
248.                           (unit (mapcar '- (cadr vpxp1) (car vpxp1)))
249.                           1e-6
250.                    )
251.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
252.                           (unit (mapcar '- (cadr vpxp2) (car vpxp2)))
253.                           1e-6
254.                    )
255.               )
256.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
257.                           (unit (mapcar '- (car vpxp1) (cadr vpxp1)))
258.                           1e-6
259.                    )
260.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
261.                           (unit (mapcar '- (cadr vpxp2) (car vpxp2)))
262.                           1e-6
263.                    )
264.               )
265.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
266.                           (unit (mapcar '- (cadr vpxp1) (car vpxp1)))
267.                           1e-6
268.                    )
269.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
270.                           (unit (mapcar '- (car vpxp2) (cadr vpxp2)))
271.                           1e-6
272.                    )
273.               )
274.           )
275.         (setq plnn (cons p plnn))
276.       )
277.     )
278.     (foreach p plnn
279.       (if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)
280.         (setq plnnn (cons p plnnn))
281.       )
282.     )
283.     (setq pln (append pln plnnn))
284.     (setq vx nil)
285.     (foreach p pln
286.       (mapcar '(lambda (x)
287.                  (if (equal (cadr x) p 1e-6)
288.                    (setq vx (cons x vx))
289.                  )
290.                )
291.               vpl
292.       )
293.     )
294.     (foreach p plll
295.       (mapcar '(lambda (x)
296.                  (if (equal (cadr x) p 1e-6)
297.                    (setq vx (vl-remove x vx))
298.                  )
299.                )
300.               vx
301.       )
302.     )
303.     (if (not (= (length pln) 1))
304.       (setq
306.                     (setq vx (vl-sort vx
307.                                       '(lambda (a b)
308.                                          (< (distance (car a) (cadr a))
309.                                             (distance (car b) (cadr b))
310.                                          )
311.                                        )
312.                              )
313.                     )
314.                   )
315.             )
316.       )
317.     )
318.     (setq i 0)
319.     (if (and vx ppl (not (= (length pln) 1)))
320.         (and (if (< (setq i (1+ i)) (length vx))
321.                T
322.                (progn (setq pln (list (cadr (nth 0 vx)))) nil)
323.              )
324.              (not
325.                  '(lambda (x)
326.                     (equal (list (car x) (cadr x)) (car pln) 1e-6)
327.                   )
328.                          (vl-remove (list (list nil nil) (list nil nil))
329.                                     (_reml ppl vx)
330.                          )
331.                  )
332.                )
333.              )
334.         )
335.          (setq pln (list (cadr (nth i vx))))
336.       )
337.     )
338.     (if (null vx)
339.       (setq pln nil)
340.     )
342.                   vpl
343.         )
344.         (foreach l (unique vpl)
345.           (if
346.                    '(lambda (x) (equal (list (car l) (cadr l)) x 1e-6))
347.                    ppl
348.                  )
349.             )
350.              (setq z  (entmakex (list '(0 . "LINE")
351.                                       (cons 10 (car l))
353.                                 )
354.                       )
355.                    zz (cons z zz)
356.              )
357.           )
358.         )
359.         (setq pln nil)
360.       )
361.     )
362.     (if (and (equal pln (list nil)) (= (length (unique vrl)) 2))
363.       (if (not
364.               '(lambda (x)
365.                  (equal (list (caar (unique vrl)) (caadr (unique vrl)))
366.                         x
367.                         1e-6
368.                  )
369.                )
370.               ppl
371.             )
372.           )
373.         (setq z  (entmakex (list '(0 . "LINE")
374.                                  (cons 10 (caar (unique vrl)))
375.                                  (cons 11 (caadr (unique vrl)))
376.                            )
377.                  )
378.               zz (cons z zz)
379.         )
380.       )
381.     )
382.     (if (equal pln (list nil))
383.       (setq pln nil)
384.     )
385.     (foreach p pln
386.       (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
387.       (setq vp2
388.              (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)
389.                    vp2
390.              )
391.       )
392.       (if (car vp1)
393.         (if
394.           (not
395.               '(lambda (x) (equal (list (caar vp1) (cadar vp1)) x 1e-6))
396.               ppl
397.             )
398.           )
399.            (setq z  (entmakex (list '(0 . "LINE")
400.                                     (cons 10 (caar vp1))
402.                               )
403.                     )
404.                  zz (cons z zz)
405.            )
406.         )
407.       )
408.       (if (car vp2)
409.         (if
410.           (not
411.               '(lambda (x) (equal (list (caar vp2) (cadar vp2)) x 1e-6))
412.               ppl
413.             )
414.           )
415.            (setq z  (entmakex (list '(0 . "LINE")
416.                                     (cons 10 (caar vp2))
418.                               )
419.                     )
420.                  zz (cons z zz)
421.            )
422.         )
423.       )
424.       (setq vpp2 (caar vp2))
425.       (setq v2 nil)
426.       (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
427.         (if (not (null vpp2))
428.           (setq v2 vpp2)
429.         )
430.       )
431.       (if (null v2)
432.         (setq v2 (caar vp2))
433.       )
434.       (setq vpp1 (caar vp1))
435.       (setq v1 nil)
436.       (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
437.         (if (not (null vpp1))
438.           (setq v1 vpp1)
439.         )
440.       )
441.       (if (null v1)
442.         (setq v1 (caar vp1))
443.       )
444.       (setq pp
445.              (list
446.                p
447.                (unit
448.                  (ridge
449.                    (if
451.                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
452.                      )
454.                         (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
455.                       )
457.                    )
458.                    (cadr (assocon v2 vtl 'car 1e-6))
459.                  )
460.                )
461.              )
462.       )
463.       (setq vrl (if vrl
464.                   (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
465.                   (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
466.                 )
467.             vrl (if (assocon (caar vp2) vrl 'car 1e-6)
468.                   (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
469.                 )
470.       )
471.       (setq vl (subst p (caar vp1) vl)
472.             vl (subst p (caar vp2) vl)
473.       )
474.     )
475.   )
476.
477.   (while pln (kr vrl))
478. )
479.
480. (defun c:2droof-MR (/ *error*)
481.
482.
483.   (defun *error* (msg)
484.     (if zz
485.       (setq zz nil)
486.     )
487.     (if poly
488.       (setq poly nil)
489.     )
490.     )
491.     (if msg
492.       (prompt msg)
493.     )
494.     (princ)
495.   )
496.
497.   )
498.
499.   (setq poly
500.          (car
501.              "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
502.            )
503.          )
504.   )
505.
506.   (2droof poly)
507.
508.   (*error* nil)
509.
510.   (princ)
511. )
512.

Regards, M.R.
« Last Edit: September 10, 2013, 08:03:36 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #38 on: September 07, 2013, 06:06:41 AM »
Found some bug in final code... Now should be OK...

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

• Swamp Rat
• Posts: 971 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #39 on: September 07, 2013, 08:14:57 AM »
M.R.

Your Ridge-Line function works great, you might want to edit your "Allowed" lwpolyline type to also require that the LWPOLYLINE be closed.

NICE WORK.... :kewl: ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #40 on: September 07, 2013, 05:45:07 PM »
Nice work.

Fails on pline closed when start & end point both have a vertex in the list.
Code: [Select]
`(-1 . <Entity name: 78e362b8>)(0 . "LWPOLYLINE")(330 . <Entity name: 7ee6fc10>)(5 . "9D887")(100 . "AcDbEntity")(67 . 0)(410 . "Model")(8 . "0")(100 . "AcDbPolyline")(90 . 7)(70 . 1)(43 . 0.0)(38 . 0.0)(39 . 0.0)(10 2257.34 2328.59)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2447.94 2328.59)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2447.94 2181.56)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2335.75 2181.56)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2335.75 2222.18)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2257.34 2222.18)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2257.34 2328.59)(40 . 0.0)(41 . 0.0)(42 . 0.0)(210 0.0 0.0 1.0)`
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #41 on: September 07, 2013, 05:49:04 PM »
This one is a tough one to solve,
Code: [Select]
`(-1 . <Entity name: 78e36248>)(0 . "LWPOLYLINE")(330 . <Entity name: 7ee6fc10>)(5 . "9D879")(100 . "AcDbEntity")(67 . 0)(410 . "Model")(8 . "0")(100 . "AcDbPolyline")(90 . 8)(70 . 1)(43 . 0.0)(38 . 0.0)(39 . 0.0)(10 2054.14 2133.5)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2054.14 2184.36)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1984.3 2184.36)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1984.3 2328.33)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2201.47 2328.33)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2201.47 2163.63)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2108.51 2163.63)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2108.51 2133.5)(40 . 0.0)(41 . 0.0)(42 . 0.0)(210 0.0 0.0 1.0)`
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #42 on: September 07, 2013, 05:58:15 PM »
I was surprised your routine did well on this flattened version of a very complex roof.
It did leave one extra line, see red.
Code: [Select]
`(-1 . <Entity name: 78e59cf8>)(0 . "LWPOLYLINE")(330 . <Entity name: 78e6dc10>)(5 . "31BF")(100 . "AcDbEntity")(67 . 0)(410 . "Model")(8 . "0")(100 . "AcDbPolyline")(90 . 18)(70 . 1)(43 . 0.0)(38 . 0.0)(39 . 0.0)(10 788.057 1041.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 926.057 1041.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 926.057 883.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1090.06 883.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1090.06 898.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1198.06 898.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1198.06 877.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1410.06 877.583)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1410.06 1355.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1363.56 1355.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1363.56 1369.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1245.56 1369.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1245.56 1355.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1216.06 1355.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 1216.06 1417.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 969.266 1417.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 969.266 1563.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 788.057 1563.58)(40 . 0.0)(41 . 0.0)(42 . 0.0)(210 0.0 0.0 1.0)`
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #43 on: September 07, 2013, 06:03:49 PM »
Here is another one it has trouble with.
Code: [Select]
`(-1 . <Entity name: 78de2858>)(0 . "LWPOLYLINE")(330 . <Entity name: 78df7c10>)(5 . "19F53")(100 . "AcDbEntity")(67 . 0)(410 . "Model")(8 . "TEXT")(100 . "AcDbPolyline")(90 . 10)(70 . 1)(43 . 0.0)(38 . 0.0)(39 . 0.0)(10 2666.24 -241.035)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2433.3 -241.035)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2433.3 111.629)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2666.24 111.629)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2666.24 40.2463)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2990.99 40.2461)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2990.99 -238.486)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2868.57 -238.486)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2868.57 -178.151)(40 . 0.0)(41 . 0.0)(42 . 0.0)(10 2666.24 -178.15)(40 . 0.0)(41 . 0.0)(42 . 0.0)(210 0.0 0.0 1.0)`
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970 ##### Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #44 on: September 08, 2013, 04:23:45 AM »
@ CAB :
Look CAB, yes if you have 2 adjacent vertexes that overlap or start-end vertex overlap, you have to use clean_poly.lsp by gille...
This is explanation for first case...
Second and fourth case that you posted have vertexes created in CW direction... In my code it was explicitly said that vertexes must be CCW... It is assumed that LWPOLYLINE has to be closed also - with "C" - close option...
Your third case it solved correctly, with more than less success... I also said that roof solution must be unique - pline must not have porches that are actually roof dormers - that's why it failed to do it 100% correct...
Also your fourth case and if it was CCW isn't unique single roof solution - you have separate compositions witch are behaving as dormers... So this case also can't be solved with my code 2droof-MR... In this cases it's best to use previously made routine witch uses extrude command (c:roof)...

M.R.
« Last Edit: September 08, 2013, 05:10:40 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture) 