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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • 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)

:)

M.R. on Youtube

GDF

  • Water Moccasin
  • Posts: 2081
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?
BricsCAD 2020x64 Windows 10x64

ribarm

  • Gator
  • Posts: 3225
  • 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]
  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)
  20.               (equal (cadr x) (cadr 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.         (function
  71.           (lambda (pair)
  72.             (equal SearchTerm (apply func (list pair)) fuzz)
  73.           )
  74.         )
  75.         lst
  76.       )
  77.     )
  78.   )
  79.  
  80.   (defun prelst (lst el / f)
  81.     (vl-remove-if
  82.       '(lambda (a) (or f (setq f (equal a el 1e-8))))
  83.       lst
  84.     )
  85.   )
  86.  
  87.   (defun suflst (lst el)
  88.     (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
  89.   )
  90.  
  91.   (defun unit (v)
  92.     (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
  93.   )
  94.  
  95.  
  96.   )
  97.  
  98.   (setq poly
  99.          (car
  100.            (entsel
  101.              "\nPick LWPOLYLINE in WCS oriented CCW and with only straight convex segments-edges"
  102.            )
  103.          )
  104.   )
  105.   (setq
  106.     vl (mapcar
  107.          'cdr
  108.          (vl-remove-if-not
  109.            '(lambda (x) (= (car x) 10))
  110.            (entget poly)
  111.          )
  112.        )
  113.   )
  114.   (setq vl (cons (last vl) vl))
  115.   (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
  116.   (setq tl (mapcar '(lambda (x) (unit x)) tl))
  117.   (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
  118.   (setq rl (mapcar '(lambda (a b) (ridge a b))
  119.                    tl
  120.                    (cdr (reverse (cons (car tl) (reverse tl))))
  121.            )
  122.   )
  123.   (setq rl (mapcar '(lambda (x) (unit x)) rl))
  124.   (setq vrl (mapcar '(lambda (a b) (list a b))
  125.                     (cdr (reverse (cons (car vl) (reverse vl))))
  126.                     rl
  127.             )
  128.   )
  129.   (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
  130.   (setq pln T)
  131.  
  132.   (defun kr (lst / pl pp)
  133.     (setq pl (mapcar '(lambda (a b)
  134.                         (inters (car a)
  135.                                 (mapcar '+ (car a) (cadr a))
  136.                                 (car b)
  137.                                 (mapcar '+ (car b) (cadr b))
  138.                                 nil
  139.                         )
  140.                       )
  141.                      (reverse (cons (car lst) (reverse lst)))
  142.                      (cdr (reverse (cons (car lst) (reverse lst))))
  143.              )
  144.     )
  145.     (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
  146.                       vl
  147.                       pl
  148.                       (cdr vl)
  149.               )
  150.     )
  151.     (setq vpl (apply 'append vpl))
  152.     (while (assocon nil vpl 'cadr 1e-6)
  153.       (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
  154.     )
  155.     (setq pln nil)
  156.     (foreach p pl
  157.       (if (vl-some
  158.             '(lambda (x)
  159.                (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
  160.              )
  161.             vpl
  162.           )
  163.         (setq pln (cons p pln))
  164.       )
  165.     )
  166.     (foreach p (reverse pln)
  167.       (if (vl-some
  168.             '(lambda (x)
  169.                (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
  170.              )
  171.             vpl
  172.           )
  173.         (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
  174.       )
  175.     )
  176.     (setq vx nil)
  177.     (foreach p pln
  178.       (mapcar '(lambda (x)
  179.                  (if (equal (cadr x) p 1e-6)
  180.                    (setq vx (cons x vx))
  181.                  )
  182.                )
  183.               vpl
  184.       )
  185.     )
  186.     (setq pln (list (cadar (vl-sort vx
  187.                                     '(lambda (a b)
  188.                                        (< (distance (car a) (cadr a))
  189.                                           (distance (car b) (cadr b))
  190.                                        )
  191.                                      )
  192.                            )
  193.                     )
  194.               )
  195.     )
  196.     (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
  197.                   vpl
  198.         )
  199.       (progn
  200.         (foreach l (unique vpl)
  201.           (entmake (list '(0 . "LINE")
  202.                          (cons 10 (car l))
  203.                          (cons 11 (cadr l))
  204.                    )
  205.           )
  206.         )
  207.         (setq pln nil)
  208.       )
  209.     )
  210.     (foreach p pln
  211.       (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
  212.       (setq vp2
  213.              (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)
  214.                    vp2
  215.              )
  216.       )
  217.       (if (car vp1)
  218.         (entmake (list '(0 . "LINE")
  219.                        (cons 10 (caar vp1))
  220.                        (cons 11 (cadar vp1))
  221.                  )
  222.         )
  223.       )
  224.       (if (car vp2)
  225.         (entmake (list '(0 . "LINE")
  226.                        (cons 10 (caar vp2))
  227.                        (cons 11 (cadar vp2))
  228.                  )
  229.         )
  230.       )
  231.       (setq vpp2 (caar vp2))
  232.       (setq v2 nil)
  233.       (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
  234.         (if (not (null vpp2))
  235.           (setq v2 vpp2)
  236.         )
  237.       )
  238.       (if (null v2)
  239.         (setq v2 (caar vp2))
  240.       )
  241.       (setq vpp1 (caar vp1))
  242.       (setq v1 nil)
  243.       (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
  244.         (if (not (null vpp1))
  245.           (setq v1 vpp1)
  246.         )
  247.       )
  248.       (if (null v1)
  249.         (setq v1 (caar vp1))
  250.       )
  251.       (setq pp
  252.              (list
  253.                p
  254.                (unit
  255.                  (ridge
  256.                    (if
  257.                      (cadr
  258.                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
  259.                      )
  260.                       (cadr
  261.                         (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
  262.                       )
  263.                       (cadr (last vtl))
  264.                    )
  265.                    (cadr (assocon v2 vtl 'car 1e-6))
  266.                  )
  267.                )
  268.              )
  269.       )
  270.       (setq vrl (if vrl
  271.                   (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
  272.                   (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
  273.                 )
  274.             vrl (if (assocon (caar vp2) vrl 'car 1e-6)
  275.                   (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
  276.                 )
  277.       )
  278.       (setq vl (subst p (caar vp1) vl)
  279.             vl (subst p (caar vp2) vl)
  280.       )
  281.     )
  282.   )
  283.  
  284.   (while pln (kr vrl))
  285.  
  286.   )
  287.  
  288.   (princ)
  289. )
  290.  

Regards, M.R.
 8-) 8-) 8-)
« Last Edit: September 05, 2013, 03:00:02 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • 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)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • 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)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • 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)

:)

M.R. on Youtube

ribarm

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

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

:)

M.R. on Youtube

ribarm

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

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • 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. :wink:
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

snownut2

  • Swamp Rat
  • Posts: 971
  • Bricscad 22 Ultimate
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:

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
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
Please support this web site.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
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
Please support this web site.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
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
Please support this web site.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
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
Please support this web site.

ribarm

  • Gator
  • Posts: 3225
  • 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)

:)

M.R. on Youtube