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

0 Members and 1 Guest are viewing this topic.

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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

• Water Moccasin
• Posts: 1828
##### 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?

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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]
`(defun c:2droof-MR (/      unique _vl-remove    ridge  onlin-p                    assocon       prelst suflst unit   kr     ll                    pl     pln    poly   rl     tl     v      v1                    v2     vl     vp     vp1    vp2    vpp1   vpp2                    vpl    vrl    vtl    vx                   )   (defun unique (lst)    (if lst      (cons (car lst)            (unique (_vl-remove (car lst) (cdr lst) 1e-6))      )    )  )   (defun _vl-remove (el lst fuzz)    (vl-remove-if      '(lambda (x)         (and (equal (car x) (car el) fuzz)              (equal (cadr x) (cadr el) fuzz)         )       )      lst    )  )   (defun ridge (v1 v2)    (if (not          (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))        )      (mapcar '*              (list -1.0 -1.0 -1.0)              (mapcar '- v1 v2)      )      (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     0.0                     1e-8              )              (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     -0.0                     -1e-8              )          )          (if (equal v1 v2 1e-8)            (polar '(0.0 0.0 0.0)                   (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))                   1.0            )            v2          )        (mapcar '- v1 v2)      )    )  )   (defun onlin-p (p1 p2 p)    (and      (equal (distance p1 p2)             (+ (distance p1 p) (distance p2 p))             1e-6      )      (not (equal (distance p1 p) 0.0 1e-6))      (not (equal (distance p2 p) 0.0 1e-6))    )  )   (defun assocon (SearchTerm Lst func fuzz)    (car      (vl-member-if        (function          (lambda (pair)            (equal SearchTerm (apply func (list pair)) fuzz)          )        )        lst      )    )  )   (defun prelst (lst el / f)    (vl-remove-if      '(lambda (a) (or f (setq f (equal a el 1e-8))))      lst    )  )   (defun suflst (lst el)    (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))  )   (defun unit (v)    (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)  )   (vl-load-com)   (vla-startundomark    (vla-get-activedocument (vlax-get-acad-object))  )   (setq poly         (car           (entsel             "\nPick LWPOLYLINE in WCS oriented CCW and with only straight convex segments-edges"           )         )  )  (setq    vl (mapcar         'cdr         (vl-remove-if-not           '(lambda (x) (= (car x) 10))           (entget poly)         )       )  )  (setq vl (cons (last vl) vl))  (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))  (setq tl (mapcar '(lambda (x) (unit x)) tl))  (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))  (setq rl (mapcar '(lambda (a b) (ridge a b))                   tl                   (cdr (reverse (cons (car tl) (reverse tl))))           )  )  (setq rl (mapcar '(lambda (x) (unit x)) rl))  (setq vrl (mapcar '(lambda (a b) (list a b))                    (cdr (reverse (cons (car vl) (reverse vl))))                    rl            )  )  (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))  (setq pln T)   (defun kr (lst / pl pp)    (setq pl (mapcar '(lambda (a b)                        (inters (car a)                                (mapcar '+ (car a) (cadr a))                                (car b)                                (mapcar '+ (car b) (cadr b))                                nil                        )                      )                     (reverse (cons (car lst) (reverse lst)))                     (cdr (reverse (cons (car lst) (reverse lst))))             )    )    (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))                      vl                      pl                      (cdr vl)              )    )    (setq vpl (apply 'append vpl))    (while (assocon nil vpl 'cadr 1e-6)      (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))    )    (setq pln nil)    (foreach p pl      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))             )            vpl          )        (setq pln (cons p pln))      )    )    (foreach p (reverse pln)      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))             )            vpl          )        (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))      )    )    (setq vx nil)    (foreach p pln      (mapcar '(lambda (x)                 (if (equal (cadr x) p 1e-6)                   (setq vx (cons x vx))                 )               )              vpl      )    )    (setq pln (list (cadar (vl-sort vx                                    '(lambda (a b)                                       (< (distance (car a) (cadr a))                                          (distance (car b) (cadr b))                                       )                                     )                           )                    )              )    )    (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))                  vpl        )      (progn        (foreach l (unique vpl)          (entmake (list '(0 . "LINE")                         (cons 10 (car l))                         (cons 11 (cadr l))                   )          )        )        (setq pln nil)      )    )    (foreach p pln      (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))      (setq vp2             (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)                   vp2             )      )      (if (car vp1)        (entmake (list '(0 . "LINE")                       (cons 10 (caar vp1))                       (cons 11 (cadar vp1))                 )        )      )      (if (car vp2)        (entmake (list '(0 . "LINE")                       (cons 10 (caar vp2))                       (cons 11 (cadar vp2))                 )        )      )      (setq vpp2 (caar vp2))      (setq v2 nil)      (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))        (if (not (null vpp2))          (setq v2 vpp2)        )      )      (if (null v2)        (setq v2 (caar vp2))      )      (setq vpp1 (caar vp1))      (setq v1 nil)      (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))        (if (not (null vpp1))          (setq v1 vpp1)        )      )      (if (null v1)        (setq v1 (caar vp1))      )      (setq pp             (list               p               (unit                 (ridge                   (if                     (cadr                       (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                     )                      (cadr                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                      )                      (cadr (last vtl))                   )                   (cadr (assocon v2 vtl 'car 1e-6))                 )               )             )      )      (setq vrl (if vrl                  (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)                  (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)                )            vrl (if (assocon (caar vp2) vrl 'car 1e-6)                  (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)                )      )      (setq vl (subst p (caar vp1) vl)            vl (subst p (caar vp2) vl)      )    )  )   (while pln (kr vrl))   (vla-endundomark    (vla-get-activedocument (vlax-get-acad-object))  )   (princ)) `

Regards, M.R.

« Last Edit: September 05, 2013, 03:00:02 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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]
`(defun c:2droof-MR (/      unique _vl-remove    ridge  onlin-p                    assocon       prelst suflst unit   kr     ll                    pl     pln    poly   rl     tl     v      v1                    v2     vl     vp     vp1    vp2    vpp1   vpp2                    vpl    vrl    vtl    vx                   )   (defun unique (lst)    (if lst      (cons (car lst)            (unique (_vl-remove (car lst) (cdr lst) 1e-6))      )    )  )   (defun _vl-remove (el lst fuzz)    (vl-remove-if      '(lambda (x)         (and (equal (car x) (car el) fuzz)              (equal (cadr x) (cadr el) fuzz)         )       )      lst    )  )   (defun ridge (v1 v2)    (if (not          (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))        )      (mapcar '*              (list -1.0 -1.0 -1.0)              (mapcar '- v1 v2)      )      (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     0.0                     1e-8              )              (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     -0.0                     -1e-8              )          )        (if (equal v1 v2 1e-8)          (polar '(0.0 0.0 0.0)                 (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))                 1.0          )          v2        )        (mapcar '- v1 v2)      )    )  )   (defun onlin-p (p1 p2 p)    (and      (equal (distance p1 p2)             (+ (distance p1 p) (distance p2 p))             1e-6      )      (not (equal (distance p1 p) 0.0 1e-6))      (not (equal (distance p2 p) 0.0 1e-6))    )  )   (defun assocon (SearchTerm Lst func fuzz)    (car      (vl-member-if        (function          (lambda (pair)            (equal SearchTerm (apply func (list pair)) fuzz)          )        )        lst      )    )  )   (defun prelst (lst el / f)    (vl-remove-if      '(lambda (a) (or f (setq f (equal a el 1e-8))))      lst    )  )   (defun suflst (lst el)    (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))  )   (defun unit (v)    (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)  )   (vl-load-com)   (vla-startundomark    (vla-get-activedocument (vlax-get-acad-object))  )   (setq poly         (car           (entsel             "\nPick LWPOLYLINE in WCS oriented CCW and with only straight convex segments-edges"           )         )  )  (setq    vl (mapcar         'cdr         (vl-remove-if-not           '(lambda (x) (= (car x) 10))           (entget poly)         )       )  )  (setq vl (cons (last vl) vl))  (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))  (setq tl (mapcar '(lambda (x) (unit x)) tl))  (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))  (setq rl (mapcar '(lambda (a b) (ridge a b))                   tl                   (cdr (reverse (cons (car tl) (reverse tl))))           )  )  (setq rl (mapcar '(lambda (x) (unit x)) rl))  (setq vrl (mapcar '(lambda (a b) (list a b))                    (cdr (reverse (cons (car vl) (reverse vl))))                    rl            )  )  (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))  (setq pln T)   (defun kr (lst / pl plnn plnnn pll plll vpx1 vpxp1 vpx2 vpxp2 pp)    (mapcar      '(lambda (a b)         (setq p                (inters (car a)                        (mapcar '+ (car a) (cadr a))                        (car b)                        (mapcar '+ (car b) (cadr b))                        nil                )         )         (setq pl (cons p pl))         (if           (and             (vl-catch-all-apply               'onlin-p               (list (car a) p (mapcar '+ (car a) (cadr a)))             )              (vl-catch-all-apply               'onlin-p               (list (car b) p (mapcar '+ (car b) (cadr b)))             )           )            (setq pll (cons p pll))         )         (if           (and             (vl-catch-all-apply               'onlin-p               (list (mapcar '+ (car a) (cadr a)) p (car a))             )              (vl-catch-all-apply               'onlin-p               (list (mapcar '+ (car b) (cadr b)) p (car b))             )           )            (setq plll (cons p plll))         )       )      (reverse (cons (car lst) (reverse lst)))      (cdr (reverse (cons (car lst) (reverse lst))))    )    (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))                      vl                      (reverse pl)                      (cdr vl)              )    )    (setq vpl (apply 'append vpl))    (while (assocon nil vpl 'cadr 1e-6)      (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))    )    (setq pln nil)    (foreach p pl      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))             )            vpl          )        (setq pln (cons p pln))      )    )    (foreach p (reverse pln)      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))             )            vpl          )        (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))      )    )    (foreach p pl      (setq vpx1 (assocon p vpl 'cadr 1e-6))      (setq vpxp1 (if (last (prelst vpl vpx1))                    (last (prelst vpl vpx1))                    (last vpl)                  )      )      (if (equal (car vpx1) (car vpxp1) 1e-6)        (setq vpxp1 (if (last (prelst vpl vpxp1))                      (last (prelst vpl vpxp1))                      (last vpl)                    )        )      )      (setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))      (setq vpxp2 (if (car (suflst vpl vpx2))                    (car (suflst vpl vpx2))                    (car vpl)                  )      )      (if (equal (car vpx2) (car vpxp2) 1e-6)        (setq vpxp2 (if (car (suflst vpl vpxp2))                      (car (suflst vpl vpxp2))                      (car vpl)                    )        )      )      (if (or (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (car vpxp1) (cadr vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (car vpxp2) (cadr vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (cadr vpxp1) (car vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (cadr vpxp2) (car vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (car vpxp1) (cadr vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (cadr vpxp2) (car vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (cadr vpxp1) (car vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (car vpxp2) (cadr vpxp2)))                          1e-6                   )              )          )        (setq plnn (cons p plnn))      )    )    (foreach p plnn      (if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)        (setq plnnn (cons p plnnn))      )    )    (setq pln (append pln plnnn))    (setq vx nil)    (foreach p pln      (mapcar '(lambda (x)                 (if (equal (cadr x) p 1e-6)                   (setq vx (cons x vx))                 )               )              vpl      )    )    (foreach p plll      (mapcar '(lambda (x)                 (if (equal (cadr x) p 1e-6)                   (setq vx (vl-remove x vx))                 )               )              vx      )    )          (setq pln (list (cadar                      (vl-sort vx                               '(lambda (a b)                                  (< (distance (car a) (cadr a))                                     (distance (car b) (cadr b))                                  )                                )                      )                    )              )    )    (if (eq pln nil)      (setq pln (acet-list-remove-duplicates (mapcar 'cadr vpl) 1e-6))    )    (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))                  vpl        )      (progn        (foreach l (unique vpl)          (entmake (list '(0 . "LINE")                         (cons 10 (car l))                         (cons 11 (cadr l))                   )          )        )        (setq pln nil)      )    )    (if (and (eq vpl nil) (= (length (unique vrl)) 2))      (entmake (list '(0 . "LINE")                     (cons 10 (caar (unique vrl)))                     (cons 11 (caadr (unique vrl)))               )      )    )    (foreach p pln      (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))      (setq vp2             (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)                   vp2             )      )      (if (car vp1)        (entmake (list '(0 . "LINE")                       (cons 10 (caar vp1))                       (cons 11 (cadar vp1))                 )        )      )      (if (car vp2)        (entmake (list '(0 . "LINE")                       (cons 10 (caar vp2))                       (cons 11 (cadar vp2))                 )        )      )      (setq vpp2 (caar vp2))      (setq v2 nil)      (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))        (if (not (null vpp2))          (setq v2 vpp2)        )      )      (if (null v2)        (setq v2 (caar vp2))      )      (setq vpp1 (caar vp1))      (setq v1 nil)      (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))        (if (not (null vpp1))          (setq v1 vpp1)        )      )      (if (null v1)        (setq v1 (caar vp1))      )      (setq pp             (list               p               (unit                 (ridge                   (if                     (cadr                       (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                     )                      (cadr                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                      )                      (cadr (last vtl))                   )                   (cadr (assocon v2 vtl 'car 1e-6))                 )               )             )      )      (setq vrl (if vrl                  (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)                  (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)                )            vrl (if (assocon (caar vp2) vrl 'car 1e-6)                  (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)                )      )      (setq vl (subst p (caar vp1) vl)            vl (subst p (caar vp2) vl)      )    )  )   (while pln (kr vrl))   (vla-endundomark    (vla-get-activedocument (vlax-get-acad-object))  )   (princ)) `

M.R.
« Last Edit: September 06, 2013, 04:36:02 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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]
`(defun 2droof (pol    /      _reml  unique _vl-remove    ridge  onlin-p               assocon       prelst suflst ll     pl     pln    i               rl     tl     v      v1     v2     vl     vp     vp1               vp2    vpp1   vpp2   vpl    vrl    vtl    vx              )   (defun _reml (l1 l2 / a n ls)    (while      (setq n nil            a (car l2)      )       (while (and l1 (null n))         (if (equal a (car l1) 1e-8)           (setq l1 (cdr l1)                 n  t           )           (setq ls (append ls (list (car l1)))                 l1 (cdr l1)           )         )       )       (setq l2 (cdr l2))    )    (append ls l1)  )   (defun unique (lst)    (if lst      (cons (car lst)            (unique (_vl-remove (car lst) (cdr lst) 1e-6))      )    )  )   (defun _vl-remove (el lst fuzz)    (vl-remove-if      '(lambda (x)         (and (equal (car x) (car el) fuzz)              (equal (cadr x) (cadr el) fuzz)         )       )      lst    )  )   (defun ridge (v1 v2)    (if (not          (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))        )      (mapcar '*              (list -1.0 -1.0 -1.0)              (mapcar '- v1 v2)      )      (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     0.0                     1e-8              )              (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))                     -0.0                     -1e-8              )          )        (if (equal v1 v2 1e-8)          (polar '(0.0 0.0 0.0)                 (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))                 1.0          )          v2        )        (mapcar '- v1 v2)      )    )  )   (defun onlin-p (p1 p2 p)    (and      (equal (distance p1 p2)             (+ (distance p1 p) (distance p2 p))             1e-6      )      (not (equal (distance p1 p) 0.0 1e-6))      (not (equal (distance p2 p) 0.0 1e-6))    )  )   (defun assocon (SearchTerm Lst func fuzz)    (car      (vl-member-if        (function          (lambda (pair)            (equal SearchTerm (apply func (list pair)) fuzz)          )        )        lst      )    )  )   (defun prelst (lst el / f)    (vl-remove-if      '(lambda (a) (or f (setq f (equal a el 1e-8))))      lst    )  )   (defun suflst (lst el)    (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))  )   (defun unit (v)    (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)  )   (setq    vl (mapcar         'cdr         (vl-remove-if-not           '(lambda (x) (= (car x) 10))           (entget pol)         )       )  )  (setq vl (cons (last vl) vl))  (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))  (setq tl (mapcar '(lambda (x) (unit x)) tl))  (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))  (setq rl (mapcar '(lambda (a b) (ridge a b))                   tl                   (cdr (reverse (cons (car tl) (reverse tl))))           )  )  (setq rl (mapcar '(lambda (x) (unit x)) rl))  (setq vrl (mapcar '(lambda (a b) (list a b))                    (cdr (reverse (cons (car vl) (reverse vl))))                    rl            )  )  (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))  (setq pln T)   (defun kr (lst / pl plnn plnnn pll plll vpx1 vpxp1 vpx2 vpxp2 pp vxx z)    (mapcar      '(lambda (a b)         (setq p                (inters (car a)                        (mapcar '+ (car a) (cadr a))                        (car b)                        (mapcar '+ (car b) (cadr b))                        nil                )         )         (setq pl (cons p pl))         (if           (and             (vl-catch-all-apply               'onlin-p               (list (car a) p (mapcar '+ (car a) (cadr a)))             )              (vl-catch-all-apply               'onlin-p               (list (car b) p (mapcar '+ (car b) (cadr b)))             )           )            (setq pll (cons p pll))         )         (if           (and             (vl-catch-all-apply               'onlin-p               (list (mapcar '+ (car a) (cadr a)) p (car a))             )              (vl-catch-all-apply               'onlin-p               (list (mapcar '+ (car b) (cadr b)) p (car b))             )           )            (setq plll (cons p plll))         )       )      (reverse (cons (car lst) (reverse lst)))      (cdr (reverse (cons (car lst) (reverse lst))))    )    (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))                      vl                      (reverse pl)                      (cdr vl)              )    )    (setq vpl (apply 'append vpl))    (while (assocon nil vpl 'cadr 1e-6)      (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))    )    (setq pln nil)    (foreach p pl      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))             )            vpl          )        (setq pln (cons p pln))      )    )    (foreach p (reverse pln)      (if (vl-some            '(lambda (x)               (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))             )            vpl          )        (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))      )    )    (foreach p pl      (setq vpx1 (assocon p vpl 'cadr 1e-6))      (setq vpxp1 (if (last (prelst vpl vpx1))                    (last (prelst vpl vpx1))                    (last vpl)                  )      )      (if (equal (car vpx1) (car vpxp1) 1e-6)        (setq vpxp1 (if (last (prelst vpl vpxp1))                      (last (prelst vpl vpxp1))                      (last vpl)                    )        )      )      (setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))      (setq vpxp2 (if (car (suflst vpl vpx2))                    (car (suflst vpl vpx2))                    (car vpl)                  )      )      (if (equal (car vpx2) (car vpxp2) 1e-6)        (setq vpxp2 (if (car (suflst vpl vpxp2))                      (car (suflst vpl vpxp2))                      (car vpl)                    )        )      )      (if (or (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (car vpxp1) (cadr vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (car vpxp2) (cadr vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (cadr vpxp1) (car vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (cadr vpxp2) (car vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (car vpxp1) (cadr vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (cadr vpxp2) (car vpxp2)))                          1e-6                   )              )              (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))                          (unit (mapcar '- (cadr vpxp1) (car vpxp1)))                          1e-6                   )                   (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))                          (unit (mapcar '- (car vpxp2) (cadr vpxp2)))                          1e-6                   )              )          )        (setq plnn (cons p plnn))      )    )    (foreach p plnn      (if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)        (setq plnnn (cons p plnnn))      )    )    (setq pln (append pln plnnn))    (setq vx nil)    (foreach p pln      (mapcar '(lambda (x)                 (if (equal (cadr x) p 1e-6)                   (setq vx (cons x vx))                 )               )              vpl      )    )    (foreach p plll      (mapcar '(lambda (x)                 (if (equal (cadr x) p 1e-6)                   (setq vx (vl-remove x vx))                 )               )              vx      )    )    (if (not (= (length pln) 1))      (setq        pln (list (cadar                    (setq vx (vl-sort vx                                      '(lambda (a b)                                         (< (distance (car a) (cadr a))                                            (distance (car b) (cadr b))                                         )                                       )                             )                    )                  )            )      )    )    (setq i 0)    (if (and vx ppl (not (= (length pln) 1)))      (while        (and (if (< (setq i (1+ i)) (length vx))               T               (progn (setq pln (list (cadr (nth 0 vx)))) nil)             )             (not               (vl-some                 '(lambda (x)                    (equal (list (car x) (cadr x)) (car pln) 1e-6)                  )                 (mapcar 'cadr                         (vl-remove (list (list nil nil) (list nil nil))                                    (_reml ppl vx)                         )                 )               )             )        )         (setq pln (list (cadr (nth i vx))))      )    )    (if (null vx)      (setq pln nil)    )    (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))                  vpl        )      (progn        (foreach l (unique vpl)          (if            (not (vl-some                   '(lambda (x) (equal (list (car l) (cadr l)) x 1e-6))                   ppl                 )            )             (setq z  (entmakex (list '(0 . "LINE")                                      (cons 10 (car l))                                      (cons 11 (cadr l))                                )                      )                   zz (cons z zz)             )          )        )        (setq pln nil)      )    )    (if (and (equal pln (list nil)) (= (length (unique vrl)) 2))      (if (not            (vl-some              '(lambda (x)                 (equal (list (caar (unique vrl)) (caadr (unique vrl)))                        x                        1e-6                 )               )              ppl            )          )        (setq z  (entmakex (list '(0 . "LINE")                                 (cons 10 (caar (unique vrl)))                                 (cons 11 (caadr (unique vrl)))                           )                 )              zz (cons z zz)        )      )    )    (if (equal pln (list nil))      (setq pln nil)    )    (foreach p pln      (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))      (setq vp2             (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)                   vp2             )      )      (if (car vp1)        (if          (not            (vl-some              '(lambda (x) (equal (list (caar vp1) (cadar vp1)) x 1e-6))              ppl            )          )           (setq z  (entmakex (list '(0 . "LINE")                                    (cons 10 (caar vp1))                                    (cons 11 (cadar vp1))                              )                    )                 zz (cons z zz)           )        )      )      (if (car vp2)        (if          (not            (vl-some              '(lambda (x) (equal (list (caar vp2) (cadar vp2)) x 1e-6))              ppl            )          )           (setq z  (entmakex (list '(0 . "LINE")                                    (cons 10 (caar vp2))                                    (cons 11 (cadar vp2))                              )                    )                 zz (cons z zz)           )        )      )      (setq vpp2 (caar vp2))      (setq v2 nil)      (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))        (if (not (null vpp2))          (setq v2 vpp2)        )      )      (if (null v2)        (setq v2 (caar vp2))      )      (setq vpp1 (caar vp1))      (setq v1 nil)      (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))        (if (not (null vpp1))          (setq v1 vpp1)        )      )      (if (null v1)        (setq v1 (caar vp1))      )      (setq pp             (list               p               (unit                 (ridge                   (if                     (cadr                       (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                     )                      (cadr                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))                      )                      (cadr (last vtl))                   )                   (cadr (assocon v2 vtl 'car 1e-6))                 )               )             )      )      (setq vrl (if vrl                  (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)                  (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)                )            vrl (if (assocon (caar vp2) vrl 'car 1e-6)                  (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)                )      )      (setq vl (subst p (caar vp1) vl)            vl (subst p (caar vp2) vl)      )    )  )   (while pln (kr vrl))) (defun c:2droof-MR (/ *error*)   (vl-load-com)   (defun *error* (msg)    (if zz      (setq zz nil)    )    (if poly      (setq poly nil)    )    (vla-endundomark      (vla-get-activedocument (vlax-get-acad-object))    )    (if msg      (prompt msg)    )    (princ)  )   (vla-startundomark    (vla-get-activedocument (vlax-get-acad-object))  )   (setq poly         (car           (entsel             "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"           )         )  )   (2droof poly)   (*error* nil)   (princ)) `

Regards, M.R.
« Last Edit: September 10, 2013, 08:03:36 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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: 919
##### 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:
God helps those who helps themselves.
A little searching goes a long ways.

#### CAB

• Global Moderator
• Seagull
• Posts: 10228
##### 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

#### CAB

• Global Moderator
• Seagull
• Posts: 10228
##### 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

#### CAB

• Global Moderator
• Seagull
• Posts: 10228
##### 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

#### CAB

• Global Moderator
• Seagull
• Posts: 10228
##### 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

#### ribarm

• Water Moccasin
• Posts: 1687
• Marko Ribar, architect
##### 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)