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

0 Members and 3 Guests are viewing this topic.

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #45 on: September 09, 2013, 02:15:43 PM »
Look, I have trouble with complex plines, so my version maybe isn't so good... I've changed my code and I am posting this version witch will do the job if it's simple solution, otherwise if you wait a little it will blink (erase and make lines) on the place witch is problematical... I'll attach my complex LWPOLYLINE witch can't be solved on this my netbook (I don't have PC at the moment)...

So here is my better blinking version and I strongly suggest that you use this one for now...

Code - Auto/Visual Lisp: [Select]
  1. (defun 2droof (pol  ints   f /      _reml  unique _vl-remove    ridge
  2.                onlin-p       assocon       prelst suflst ll     pl
  3.                pln    i      rl     tl     v      v1     v2     vl
  4.                vp     vp1    vp2    vpp1   vpp2   vpl    vrl    vtl
  5.                vx     p1     p2     pp     ppl    int    lin    p2s
  6.                ss1    sss1   ss2    sss2
  7.               )
  8.  
  9.   (defun _reml (l1 l2 / a n ls)
  10.     (while
  11.       (setq n nil
  12.             a (car l2)
  13.       )
  14.        (while (and l1 (null n))
  15.          (if (equal a (car l1) 1e-8)
  16.            (setq l1 (cdr l1)
  17.                  n  t
  18.            )
  19.            (setq ls (append ls (list (car l1)))
  20.                  l1 (cdr l1)
  21.            )
  22.          )
  23.        )
  24.        (setq l2 (cdr l2))
  25.     )
  26.     (append ls l1)
  27.   )
  28.  
  29.   (defun unique (lst)
  30.     (if lst
  31.       (cons (car lst)
  32.             (unique (_vl-remove (car lst) (cdr lst) 1e-6))
  33.       )
  34.     )
  35.   )
  36.  
  37.   (defun _vl-remove (el lst fuzz)
  38.     (vl-remove-if
  39.       '(lambda (x)
  40.          (and (equal (car x) (car el) fuzz)
  41.               (equal (cadr x) (cadr el) fuzz)
  42.          )
  43.        )
  44.       lst
  45.     )
  46.   )
  47.  
  48.   (defun ridge (v1 v2)
  49.     (if (not
  50.           (minusp (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1))))
  51.         )
  52.       (mapcar '*
  53.               (list -1.0 -1.0 -1.0)
  54.               (mapcar '- v1 v2)
  55.       )
  56.       (if (or (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
  57.                      0.0
  58.                      1e-8
  59.               )
  60.               (equal (- (* (car v1) (cadr v2)) (* (car v2) (cadr v1)))
  61.                      -0.0
  62.                      -1e-8
  63.               )
  64.           )
  65.         (if (equal v1 v2 1e-8)
  66.           (polar '(0.0 0.0 0.0)
  67.                  (+ (angle '(0.0 0.0 0.0) v1) (/ pi 2.0))
  68.                  1.0
  69.           )
  70.           v2
  71.         )
  72.         (mapcar '- v1 v2)
  73.       )
  74.     )
  75.   )
  76.  
  77.   (defun onlin-p (p1 p2 p)
  78.     (and
  79.       (equal (distance p1 p2)
  80.              (+ (distance p1 p) (distance p2 p))
  81.              1e-6
  82.       )
  83.       (not (equal (distance p1 p) 0.0 1e-6))
  84.       (not (equal (distance p2 p) 0.0 1e-6))
  85.     )
  86.   )
  87.  
  88.   (defun assocon (SearchTerm Lst func fuzz)
  89.     (car
  90.       (vl-member-if
  91.         (function
  92.           (lambda (pair)
  93.             (equal SearchTerm (apply func (list pair)) fuzz)
  94.           )
  95.         )
  96.         lst
  97.       )
  98.     )
  99.   )
  100.  
  101.   (defun prelst (lst el / f)
  102.     (vl-remove-if
  103.       '(lambda (a) (or f (setq f (equal a el 1e-8))))
  104.       lst
  105.     )
  106.   )
  107.  
  108.   (defun suflst (lst el)
  109.     (cdr (vl-member-if '(lambda (a) (equal a el 1e-8)) lst))
  110.   )
  111.  
  112.   (defun unit (v)
  113.     (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v)
  114.   )
  115.  
  116.   (setq ppl nil)
  117.   (if zz
  118.     (foreach z zz
  119.       (setq p1  (cdr (assoc 10 (entget z)))
  120.             p2  (cdr (assoc 11 (entget z)))
  121.             pp  (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  122.             ppl (cons pp ppl)
  123.       )
  124.     )
  125.   )
  126.   (if ppl
  127.     (setq ppl (reverse ppl))
  128.   )
  129.   (setq
  130.     vl (mapcar
  131.          'cdr
  132.          (vl-remove-if-not
  133.            '(lambda (x) (= (car x) 10))
  134.            (entget pol)
  135.          )
  136.        )
  137.   )
  138.   (foreach tf f
  139.     (setq vl (reverse (cdr (reverse (cons (last vl) vl)))))
  140.   )
  141.   (setq vl (cons (last vl) vl))
  142.   (setq tl (mapcar '(lambda (a b) (mapcar '- b a)) vl (cdr vl)))
  143.   (setq tl (mapcar '(lambda (x) (unit x)) tl))
  144.   (setq vtl (mapcar '(lambda (a b) (list a b)) vl tl))
  145.   (setq rl (mapcar '(lambda (a b) (ridge a b))
  146.                    tl
  147.                    (cdr (reverse (cons (car tl) (reverse tl))))
  148.            )
  149.   )
  150.   (setq rl (mapcar '(lambda (x) (unit x)) rl))
  151.   (setq vrl (mapcar '(lambda (a b) (list a b))
  152.                     (cdr (reverse (cons (car vl) (reverse vl))))
  153.                     rl
  154.             )
  155.   )
  156.   (setq vrl (cons (last vrl) (reverse (cdr (reverse vrl)))))
  157.   (setq pln T)
  158.  
  159.   (defun kr (lst / pl plnn plnnn pll plll vpx1 vpxp1 vpx2 vpxp2 pp vxx z)
  160.     (mapcar
  161.       '(lambda (a b)
  162.          (setq p
  163.                 (inters (car a)
  164.                         (mapcar '+ (car a) (cadr a))
  165.                         (car b)
  166.                         (mapcar '+ (car b) (cadr b))
  167.                         nil
  168.                 )
  169.          )
  170.          (setq pl (cons p pl))
  171.          (if
  172.            (and
  173.              (vl-catch-all-apply
  174.                'onlin-p
  175.                (list (car a) p (mapcar '+ (car a) (cadr a)))
  176.              )
  177.  
  178.              (vl-catch-all-apply
  179.                'onlin-p
  180.                (list (car b) p (mapcar '+ (car b) (cadr b)))
  181.              )
  182.            )
  183.             (setq pll (cons p pll))
  184.          )
  185.          (if
  186.            (and
  187.              (vl-catch-all-apply
  188.                'onlin-p
  189.                (list (mapcar '+ (car a) (cadr a)) p (car a))
  190.              )
  191.  
  192.              (vl-catch-all-apply
  193.                'onlin-p
  194.                (list (mapcar '+ (car b) (cadr b)) p (car b))
  195.              )
  196.            )
  197.             (setq plll (cons p plll))
  198.          )
  199.        )
  200.       (reverse (cons (car lst) (reverse lst)))
  201.       (cdr (reverse (cons (car lst) (reverse lst))))
  202.     )
  203.     (setq vpl (mapcar '(lambda (a b c) (list (list a b) (list c b)))
  204.                       vl
  205.                       (reverse pl)
  206.                       (cdr vl)
  207.               )
  208.     )
  209.     (setq vpl (apply 'append vpl))
  210.     (while (assocon nil vpl 'cadr 1e-6)
  211.       (setq vpl (vl-remove (assocon nil vpl 'cadr 1e-6) vpl))
  212.     )
  213.     (setq pln nil)
  214.     (foreach p pl
  215.       (if (vl-some
  216.             '(lambda (x)
  217.                (vl-catch-all-apply 'onlin-p (list (car x) (cadr x) p))
  218.              )
  219.             vpl
  220.           )
  221.         (setq pln (cons p pln))
  222.       )
  223.     )
  224.     (foreach p (reverse pln)
  225.       (if (vl-some
  226.             '(lambda (x)
  227.                (vl-catch-all-apply 'onlin-p (list (car x) p (cadr x)))
  228.              )
  229.             vpl
  230.           )
  231.         (setq pln (vl-remove-if '(lambda (x) (equal x p 1e-6)) pln))
  232.       )
  233.     )
  234.     (foreach p pl
  235.       (setq vpx1 (assocon p vpl 'cadr 1e-6))
  236.       (setq vpxp1 (if (last (prelst vpl vpx1))
  237.                     (last (prelst vpl vpx1))
  238.                     (last vpl)
  239.                   )
  240.       )
  241.       (if (equal (car vpx1) (car vpxp1) 1e-6)
  242.         (setq vpxp1 (if (last (prelst vpl vpxp1))
  243.                       (last (prelst vpl vpxp1))
  244.                       (last vpl)
  245.                     )
  246.         )
  247.       )
  248.       (setq vpx2 (assocon p (vl-remove vpx1 vpl) 'cadr 1e-6))
  249.       (setq vpxp2 (if (car (suflst vpl vpx2))
  250.                     (car (suflst vpl vpx2))
  251.                     (car vpl)
  252.                   )
  253.       )
  254.       (if (equal (car vpx2) (car vpxp2) 1e-6)
  255.         (setq vpxp2 (if (car (suflst vpl vpxp2))
  256.                       (car (suflst vpl vpxp2))
  257.                       (car vpl)
  258.                     )
  259.         )
  260.       )
  261.       (if (or (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 '- (car vpxp2) (cadr 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 '- (cadr vpxp2) (car vpxp2)))
  276.                           1e-6
  277.                    )
  278.               )
  279.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
  280.                           (unit (mapcar '- (car vpxp1) (cadr vpxp1)))
  281.                           1e-6
  282.                    )
  283.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
  284.                           (unit (mapcar '- (cadr vpxp2) (car vpxp2)))
  285.                           1e-6
  286.                    )
  287.               )
  288.               (and (equal (unit (mapcar '- (cadr vpx1) (car vpx1)))
  289.                           (unit (mapcar '- (cadr vpxp1) (car vpxp1)))
  290.                           1e-6
  291.                    )
  292.                    (equal (unit (mapcar '- (cadr vpx2) (car vpx2)))
  293.                           (unit (mapcar '- (car vpxp2) (cadr vpxp2)))
  294.                           1e-6
  295.                    )
  296.               )
  297.           )
  298.         (setq plnn (cons p plnn))
  299.       )
  300.     )
  301.     (foreach p plnn
  302.       (if (vl-member-if '(lambda (x) (equal x p 1e-6)) pll)
  303.         (setq plnnn (cons p plnnn))
  304.       )
  305.     )
  306.     (setq pln (append pln plnnn))
  307.     (setq vx nil)
  308.     (foreach p pln
  309.       (mapcar '(lambda (x)
  310.                  (if (equal (cadr x) p 1e-6)
  311.                    (setq vx (cons x vx))
  312.                  )
  313.                )
  314.               vpl
  315.       )
  316.     )
  317.     (foreach p plll
  318.       (mapcar '(lambda (x)
  319.                  (if (equal (cadr x) p 1e-6)
  320.                    (setq vx (vl-remove x vx))
  321.                  )
  322.                )
  323.               vx
  324.       )
  325.     )
  326.     (foreach tf f
  327.       (setq ints (reverse (cdr (reverse (cons (last ints) ints)))))
  328.     )
  329.     (setq f nil)
  330.     (if ints
  331.       (foreach v vx
  332.         (if (vl-some '(lambda (x) (equal x (cadr v) 1e-6)) ints)
  333.           (setq pln (list (cadr v)))
  334.         )
  335.       )
  336.     )
  337.     (if (and ints (not (= (length pln) 1)))
  338.       (foreach v vpl
  339.         (if (vl-some '(lambda (x) (equal x (cadr v) 1e-6)) ints)
  340.           (setq pln (list (cadr v)))
  341.         )
  342.       )
  343.     )
  344.     (if (not (= (length pln) 1))
  345.       (setq
  346.         pln (list (cadar
  347.                     (setq vx (vl-sort vx
  348.                                       '(lambda (a b)
  349.                                          (< (distance (car a) (cadr a))
  350.                                             (distance (car b) (cadr b))
  351.                                          )
  352.                                        )
  353.                              )
  354.                     )
  355.                   )
  356.             )
  357.       )
  358.     )
  359.     (setq i 0)
  360.     (if (and vx ppl (not (= (length pln) 1)))
  361.       (while
  362.         (and (if (< (setq i (1+ i)) (length vx))
  363.                T
  364.                (progn (setq pln (list (cadr (nth 0 vx)))) nil)
  365.              )
  366.              (not
  367.                (vl-some
  368.                  '(lambda (x)
  369.                     (equal (list (car x) (cadr x)) (car pln) 1e-6)
  370.                   )
  371.                  (mapcar 'cadr (vl-remove (list (list nil nil) (list nil nil)) (_reml ppl vx)))
  372.                )
  373.              )
  374.         )
  375.          (setq pln (list (cadr (nth i vx))))
  376.       )
  377.     )
  378.     (if (null vx)
  379.       (setq pln nil)
  380.     )
  381.     (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
  382.                   vpl
  383.         )
  384.       (progn
  385.         (foreach l (unique vpl)
  386.           (if
  387.             (not (vl-some
  388.                    '(lambda (x) (equal (list (car l) (cadr l)) x 1e-6))
  389.                    ppl
  390.                  )
  391.             )
  392.              (setq z  (entmakex (list '(0 . "LINE")
  393.                                       (cons 10 (car l))
  394.                                       (cons 11 (cadr l))
  395.                                 )
  396.                       )
  397.                    zz (cons z zz)
  398.              )
  399.           )
  400.         )
  401.         (setq pln nil)
  402.       )
  403.     )
  404.     (if (and (equal pln (list nil)) (= (length (unique vrl)) 2))
  405.       (if (not
  406.             (vl-some
  407.               '(lambda (x)
  408.                  (equal (list (caar (unique vrl)) (caadr (unique vrl)))
  409.                         x
  410.                         1e-6
  411.                  )
  412.                )
  413.               ppl
  414.             )
  415.           )
  416.         (setq z  (entmakex (list '(0 . "LINE")
  417.                                  (cons 10 (caar (unique vrl)))
  418.                                  (cons 11 (caadr (unique vrl)))
  419.                            )
  420.                  )
  421.               zz (cons z zz)
  422.         )
  423.       )
  424.     )
  425.     (if (equal pln (list nil))
  426.       (setq pln nil)
  427.     )
  428.     (foreach p pln
  429.       (setq vp1 (cons (assocon p vpl 'cadr 1e-6) vp1))
  430.       (setq vp2
  431.              (cons (assocon p (cdr (member (car vp1) vpl)) 'cadr 1e-6)
  432.                    vp2
  433.              )
  434.       )
  435.       (if (car vp1)
  436.         (if
  437.           (not
  438.             (vl-some
  439.               '(lambda (x) (equal (list (caar vp1) (cadar vp1)) x 1e-6))
  440.               ppl
  441.             )
  442.           )
  443.            (setq z  (entmakex (list '(0 . "LINE")
  444.                                     (cons 10 (caar vp1))
  445.                                     (cons 11 (cadar vp1))
  446.                               )
  447.                     )
  448.                  zz (cons z zz)
  449.            )
  450.         )
  451.       )
  452.       (if (car vp2)
  453.         (if
  454.           (not
  455.             (vl-some
  456.               '(lambda (x) (equal (list (caar vp2) (cadar vp2)) x 1e-6))
  457.               ppl
  458.             )
  459.           )
  460.            (setq z  (entmakex (list '(0 . "LINE")
  461.                                     (cons 10 (caar vp2))
  462.                                     (cons 11 (cadar vp2))
  463.                               )
  464.                     )
  465.                  zz (cons z zz)
  466.            )
  467.         )
  468.       )
  469.       (setq vpp2 (caar vp2))
  470.       (setq v2 nil)
  471.       (while (setq vpp2 (car (assocon vpp2 vp2 'cadr 1e-6)))
  472.         (if (not (null vpp2))
  473.           (setq v2 vpp2)
  474.         )
  475.       )
  476.       (if (null v2)
  477.         (setq v2 (caar vp2))
  478.       )
  479.       (setq vpp1 (caar vp1))
  480.       (setq v1 nil)
  481.       (while (setq vpp1 (car (assocon vpp1 vp1 'cadr 1e-6)))
  482.         (if (not (null vpp1))
  483.           (setq v1 vpp1)
  484.         )
  485.       )
  486.       (if (null v1)
  487.         (setq v1 (caar vp1))
  488.       )
  489.       (setq pp
  490.              (list
  491.                p
  492.                (unit
  493.                  (ridge
  494.                    (if
  495.                      (cadr
  496.                        (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
  497.                      )
  498.                       (cadr
  499.                         (last (prelst vtl (assocon v1 vtl 'car 1e-6)))
  500.                       )
  501.                       (cadr (last vtl))
  502.                    )
  503.                    (cadr (assocon v2 vtl 'car 1e-6))
  504.                  )
  505.                )
  506.              )
  507.       )
  508.       (setq vrl (if vrl
  509.                   (subst pp (assocon (caar vp1) vrl 'car 1e-6) vrl)
  510.                   (subst pp (assocon (caar vp1) lst 'car 1e-6) lst)
  511.                 )
  512.             vrl (if (assocon (caar vp2) vrl 'car 1e-6)
  513.                   (subst pp (assocon (caar vp2) vrl 'car 1e-6) vrl)
  514.                 )
  515.       )
  516.       (setq vl (subst p (caar vp1) vl)
  517.             vl (subst p (caar vp2) vl)
  518.       )
  519.     )
  520.   )
  521.  
  522.   (while pln (kr vrl))
  523.  
  524.   (setq ints nil)
  525.   (setq vl nil)
  526.   (setq ppl nil)
  527.   (foreach z zz
  528.     (setq p1  (cdr (assoc 10 (entget z)))
  529.           p2  (cdr (assoc 11 (entget z)))
  530.           pp  (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  531.           ppl (cons pp ppl)
  532.     )
  533.   )
  534.   (setq ppl (reverse ppl))
  535.   (foreach lin1 ppl
  536.     (foreach lin2 (vl-remove lin1 ppl)
  537.       (if (and (not (equal (car lin1) (list nil nil)))
  538.                (not (equal (cadr lin1) (list nil nil)))
  539.                (not (equal (car lin2) (list nil nil)))
  540.                (not (equal (cadr lin2) (list nil nil)))
  541.                (setq int
  542.                       (inters (car lin1) (cadr lin1) (car lin2) (cadr lin2))
  543.                )
  544.                (not (equal int (car lin1) 1e-6))
  545.                (not (equal int (cadr lin1) 1e-6))
  546.                (not (equal int (car lin2) 1e-6))
  547.                (not (equal int (cadr lin2) 1e-6))
  548.           )
  549.         (setq ints (cons int ints))
  550.       )
  551.     )
  552.   )
  553.   (foreach int ints
  554.     (setq ss1 (ssget "_C" int int))
  555.     (setq sss1 (acet-ss-union (list ss1 sss1)))
  556.   )
  557.   (if ints
  558.     (progn
  559.       (setq i -1)
  560.       (while (setq lin (ssname sss1 (setq i (1+ i))))
  561.         (setq p1 (cdr (assoc 10 (entget lin)))
  562.               p2 (cdr (assoc 11 (entget lin)))
  563.               pp (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  564.         )
  565.         (entdel lin)
  566.         (setq zz (vl-remove (nth (vl-position pp ppl) zz) zz))
  567.         (setq p2s (cons p2 p2s))
  568.         (setq ppl nil)
  569.         (foreach z zz
  570.           (setq p1  (cdr (assoc 10 (entget z)))
  571.                 p2  (cdr (assoc 11 (entget z)))
  572.                 pp  (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  573.                 ppl (cons pp ppl)
  574.           )
  575.         )
  576.         (setq ppl (reverse ppl))
  577.       )
  578.       (gc)
  579.       (foreach p2 (acet-list-remove-duplicates p2s 1e-6)
  580.         (setq ss2 (ssget "_C" p2 p2))
  581.         (setq sss2 (acet-ss-union (list ss2 sss2)))
  582.       )
  583.       (setq i -1)
  584.       (while (setq lin (ssname sss2 (setq i (1+ i))))
  585.         (setq p1 (cdr (assoc 10 (entget lin)))
  586.               p2 (cdr (assoc 11 (entget lin)))
  587.               pp (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  588.         )
  589.         (entdel lin)
  590.         (setq zz (vl-remove (nth (vl-position pp ppl) zz) zz))
  591.         (setq ppl nil)
  592.         (foreach z zz
  593.           (setq p1  (cdr (assoc 10 (entget z)))
  594.                 p2  (cdr (assoc 11 (entget z)))
  595.                 pp  (list (list (car p1) (cadr p1)) (list (car p2) (cadr p2)))
  596.                 ppl (cons pp ppl)
  597.           )
  598.         )
  599.         (setq ppl (reverse ppl))
  600.       )
  601.       (setq ff (cons T ff))
  602.       (setq f ff)
  603.       (2droof poly (acet-list-remove-duplicates ints 1e-6) f)
  604.     )
  605.   )
  606. )
  607.  
  608. (defun c:2droof-MR (/ *error*)
  609.  
  610.  
  611.   (defun *error* (msg)
  612.     (if f
  613.       (setq f nil)
  614.     )
  615.     (if ff
  616.       (setq ff nil)
  617.     )
  618.     (if zz
  619.       (setq zz nil)
  620.     )
  621.     (if poly
  622.       (setq poly nil)
  623.     )
  624.     )
  625.     (if msg
  626.       (prompt msg)
  627.     )
  628.     (princ)
  629.   )
  630.  
  631.   )
  632.  
  633.   (setq poly
  634.          (car
  635.            (entsel
  636.              "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
  637.            )
  638.          )
  639.   )
  640.  
  641.   (2droof poly nil nil)
  642.  
  643.   (*error* nil)
  644.  
  645.   (princ)
  646. )
  647.  

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

:)

M.R. on Youtube

krampaul82

  • Guest
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #46 on: September 09, 2013, 02:32:59 PM »
Cab Wrote
LeeMac has invested considerable time and effort in learning to code well. I think he has every right
to recoup something for his investment.  He has shared his talent freely in many threads so I feel
he has given plenty to our community.

Krampaul82 wrote;
Agreed!

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #47 on: September 10, 2013, 08:16:15 AM »
Cab Wrote
LeeMac has invested considerable time and effort in learning to code well. I think he has every right
to recoup something for his investment.  He has shared his talent freely in many threads so I feel
he has given plenty to our community.

Krampaul82 wrote;
Agreed!

I agree with the fact that Lee has every right to recoup, only if his code proves that it's worth... Beside that, in this particular case, my codes that I provided have their purpose to help someone learn something... Although they are not perfect, I believe that Lee said that his version also isn't 100% perfect... Even the code witch uses built-in extrude command can't in all situations do the job... This is difficult task and my engagement was predominantly to help... So that's all, my final - not last blinking code changed to finish execution with all lines that may intersect each other (with blinking version, you can't know when to hit ESC to capture the most solved result)...

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #48 on: February 06, 2014, 03:54:21 AM »
I've changed algorithm and I think this is better till now (from me)... Still there are some lacks, but my example posted above solved successfully...

Code: [Select]
(defun 2droof (pol    /      insidep       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 insidep (pt entn / big flag obj1 obj2 obj3 p1 p2 small)
    (if (and pt entn)
      (progn
        (setq obj1 (vlax-ename->vla-object entn))
        (setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
              obj3 (car (vlax-invoke obj1 'Offset -0.001))
        )
        (if (> (vla-get-area obj2) (vla-get-area obj3))
          (progn
            (set 'big obj2)
            (set 'small obj3)
          )
          (progn
            (set 'big obj3)
            (set 'small obj2)
          )
        )
        (setq p1 (vlax-curve-getClosestPointTo big pt)
              p2 (vlax-curve-getClosestPointTo small pt)
        )
        (if (> (distance pt p1) (distance pt p2))
          (setq flag T)
          (setq flag nil)
        )
        (mapcar (function (lambda (x)
                            (progn
                              (vla-delete x)
                              (vlax-release-object x)
                            )
                          )
                )
                (list big small)
        )
      )
    )
    flag
  )

  (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-8
      )
      (not (equal p1 p 1e-8))
      (not (equal p2 p 1e-8))
    )
  )

  (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 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))
       )
      (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 (reverse (cons (car vl) (reverse 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))
      )
    )
    (setq pln (mapcar '(lambda (x) (if (insidep x pol) x)) pln))
    (setq pln (vl-remove nil pln))
    (setq vx nil)
    (foreach p pln
      (mapcar '(lambda (x)
                 (if (equal (cadr x) p 1e-6)
                   (setq vx (cons x vx))
                 )
               )
              vpl
      )
    )
    (setq vxx vx)
    (if plnz (setq plnzz (cons (car plnz) plnzz)))
    (if (and (not (= (length pln) 1)) vx)
      (progn
        (setq vx (vl-sort vx
                          '(lambda (a b)
                             (< (distance (car a) (cadr a))
                                (distance (car b) (cadr b))
                             )
                           )
                 )
        )
        (if plnz
          (progn
            (setq vx (vl-sort vx
                              '(lambda (a b)
                                 (< (distance (cadr a) (car plnz))
                                    (distance (cadr b) (car plnz))
                                 )
                               )
                     )
            )
            (setq vx (vl-remove-if-not '(lambda (x) (equal (car x) (car plnz) 1e-6)) vx))
            (if (and (eq (length vx) 2)
                     (> (distance (caar vx) (cadar vx))
                        (distance (caadr vx) (cadadr vx))
                     )
                )
              (setq vx (cons (cadr vx) (cons (car vx) (cddr vx))))
            )
            (foreach v vpl
              (if (setq catch (vl-catch-all-apply
                                'onlin-p
                                (list (car v) (cadr v) (car plnz))
                              )
                  )
                (if (vl-catch-all-error-p catch)
                      (setq tst (cons nil tst))
                      (setq tst (cons T tst))
                )
                (setq tst (cons nil tst))
              )
            )
            (setq vxxx (vl-sort vxx
                          '(lambda (a b)
                             (< (distance (car a) (cadr a))
                                (distance (car b) (cadr b))
                             )
                           )
                       )
            )
            (if plnzz
              (foreach p plnzz
                (if (assocon p vxxx 'car 1e-6)
                  (setq
                    vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
                  )
                )
                (if (assocon p vxxx 'car 1e-6)
                  (setq
                    vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
                  )
                )
              )
            )
            (if (or (/= (length vx) 2)
                    (eval (cons 'or tst))
                    (if (and vxxx vx (onlin-p (caar vx) (cadar vxxx) (cadar vx)))
                      (> (distance (caar vx) (cadar vx))
                         (distance (caar vx) (cadar vxxx))
                      )
                      (if (not (null vxxx))
                        (> (distance (caar vx) (cadar vx))
                           (distance (caar vxxx) (cadar vxxx))
                        )
                        nil
                      )
                    )
                )
              (progn
                (if vxxx
                  (setq vx vxxx)
                  (setq vx (vl-sort vxx
                          '(lambda (a b)
                             (< (distance (car a) (cadr a))
                                (distance (car b) (cadr b))
                             )
                           )
                       )
                  )
                )
              )
            )
          )
        )
        (setq pln (list (cadar vx)))
      )
    )
    (setq tst nil)
    (if (null vx)
      (setq pln nil)
    )
    (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
                  vpl
        )
      (if (and (vl-every '(lambda (x) (eq (cadr x) nil)) vpl)
               (eq (length (unique vpl)) 2)
          )
        (progn
          (setq z  (entmakex (list '(0 . "LINE")
                                   (cons 10 (caar (unique vpl)))
                                   (cons 11 (caadr (unique vpl)))
                             )
                   )
                zz (cons z zz)
          )
          (setq pln nil)
        )
        (progn
          (foreach l (unique vpl)
            (setq z  (entmakex (list '(0 . "LINE")
                                     (cons 10 (car l))
                                     (cons 11 (cadr l))
                               )
                     )
                  zz (cons z zz)
            )
          )
          (setq pln nil)
        )
      )
    )
    (if (equal pln (list nil))
      (setq pln nil)
    )
    (setq plnz pln)
    (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)
        (setq z  (entmakex (list '(0 . "LINE")
                                 (cons 10 (caar vp1))
                                 (cons 11 (cadar vp1))
                           )
                 )
              zz (cons z zz)
        )
      )
      (if (car vp2)
        (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* adoc plnz plnzz)

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))

  (defun *error* (msg)
    (if plnz
      (setq plnz nil)
    )
    (if plnzz
      (setq plnzz nil)
    )
    (if zz
      (setq zz nil)
    )
    (if poly
      (setq poly nil)
    )
    (vla-endundomark adoc)
    (if msg
      (prompt msg)
    )
    (princ)
  )

  (vla-startundomark adoc)

  (setq poly
         (car
           (entsel
             "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
           )
         )
  )

  (2droof poly)

  (*error* nil)

  (princ)
)

M.R.
« Last Edit: February 06, 2014, 06:53:03 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

pedroantonio

  • Guest
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #49 on: February 06, 2014, 04:41:43 AM »
Nice job ribarm

GP

  • Newt
  • Posts: 83
  • Vercelli, Italy
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #50 on: February 06, 2014, 10:06:24 AM »
My version.  :-)

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #51 on: February 06, 2014, 10:41:38 AM »
Thank you Gian... I was wondering when I'll get some support... Your code works fantastic...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Fabricio28

  • Swamp Rat
  • Posts: 670
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #52 on: February 06, 2014, 10:45:46 AM »
Thank you Gian...  Your code works fantastic...

x2
 Fantastic!  :-D

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #53 on: February 06, 2014, 06:54:46 PM »
There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...

Code: [Select]
(defun 2droof (pol    /      insidep       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     fl
              )

  (defun insidep (pt entn / big flag obj1 obj2 obj3 p1 p2 small)
    (if (and pt entn)
      (progn
        (setq obj1 (vlax-ename->vla-object entn))
        (setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
              obj3 (car (vlax-invoke obj1 'Offset -0.001))
        )
        (if (> (vla-get-area obj2) (vla-get-area obj3))
          (progn
            (set 'big obj2)
            (set 'small obj3)
          )
          (progn
            (set 'big obj3)
            (set 'small obj2)
          )
        )
        (setq p1 (vlax-curve-getClosestPointTo big pt)
              p2 (vlax-curve-getClosestPointTo small pt)
        )
        (if (> (distance pt p1) (distance pt p2))
          (setq flag T)
          (setq flag nil)
        )
        (mapcar (function (lambda (x)
                            (progn
                              (vla-delete x)
                              (vlax-release-object x)
                            )
                          )
                )
                (list big small)
        )
      )
    )
    flag
  )

  (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-8
      )
      (not (equal p1 p 1e-8))
      (not (equal p2 p 1e-8))
    )
  )

  (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 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))
       )
      (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 (reverse (cons (car vl) (reverse 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))
      )
    )
    (setq pln (mapcar '(lambda (x) (if (insidep x pol) x)) pln))
    (setq pln (vl-remove nil pln))
    (setq vx nil)
    (foreach p pln
      (mapcar '(lambda (x)
                 (if (equal (cadr x) p 1e-6)
                   (setq vx (cons x vx))
                 )
               )
              vpl
      )
    )
    (if (and (null fl) (null plnn)) (setq plnn pln fl t))
    (setq vxx vx)
    (if plnz (setq plnzz (cons (car plnz) plnzz)))
    (if (and (not (= (length pln) 1)) vx)
      (progn
        (setq vx (vl-sort vx
                          '(lambda (a b)
                             (< (distance (car a) (cadr a))
                                (distance (car b) (cadr b))
                             )
                           )
                 )
        )
        (if (car plnn)
          (if (vl-some
                '(lambda (x)
                   (onlin-p (car x) (cadr x) (car plnn))
                 )
                vx
              )
            (if (assocon (car plnn) vx 'cadr 1e-6)
              (setq
                vx (subst (assocon (car plnn) vx 'cadr 1e-6) (car vx) vx)
              )
            )
          )
        )
        (if (and (null plnn) plnz)
          (progn
            (setq vx (vl-sort vx
                              '(lambda (a b)
                                 (< (distance (cadr a) (car plnz))
                                    (distance (cadr b) (car plnz))
                                 )
                               )
                     )
            )
            (setq vx (vl-remove-if-not '(lambda (x) (equal (car x) (car plnz) 1e-6)) vx))
            (if (and (eq (length vx) 2)
                     (> (distance (caar vx) (cadar vx))
                        (distance (caadr vx) (cadadr vx))
                     )
                )
              (setq vx (cons (cadr vx) (cons (car vx) (cddr vx))))
            )
            (foreach v vpl
              (if (setq catch (vl-catch-all-apply
                                'onlin-p
                                (list (car v) (cadr v) (car plnz))
                              )
                  )
                (if (vl-catch-all-error-p catch)
                      (setq tst (cons nil tst))
                      (setq tst (cons T tst))
                )
                (setq tst (cons nil tst))
              )
            )
            (setq vxxx (vl-sort vxx
                          '(lambda (a b)
                             (< (distance (car a) (cadr a))
                                (distance (car b) (cadr b))
                             )
                           )
                       )
            )
            (if plnzz
              (foreach p plnzz
                (if (assocon p vxxx 'car 1e-6)
                  (setq
                    vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
                  )
                )
                (if (assocon p vxxx 'car 1e-6)
                  (setq
                    vxxx (vl-remove (assocon p vxxx 'car 1e-6) vxxx)
                  )
                )
              )
            )
            (if (or (/= (length vx) 2)
                    (eval (cons 'or tst))
                    (if (and vxxx vx (onlin-p (caar vx) (cadar vxxx) (cadar vx)))
                      (> (distance (caar vx) (cadar vx))
                         (distance (caar vx) (cadar vxxx))
                      )
                      (if (not (null vxxx))
                        (> (distance (caar vx) (cadar vx))
                           (distance (caar vxxx) (cadar vxxx))
                        )
                        nil
                      )
                    )
                )
              (progn
                (if vxxx
                  (setq vx (vl-sort vxxx
                            '(lambda (a b)
                               (< (distance (cadr a) (car plnz))
                                  (distance (cadr b) (car plnz))
                               )
                             )
                           )
                  )
                  (setq vx (vl-sort vxx
                            '(lambda (a b)
                               (< (distance (car a) (cadr a))
                                  (distance (car b) (cadr b))
                               )
                             )
                           )
                  )
                )
              )
            )
          )
        )
        (setq plnn (cdr plnn))
        (setq pln (list (cadar vx)))
      )
    )
    (setq tst nil)
    (if (null vx)
      (setq pln nil)
    )
    (if (vl-every '(lambda (x) (equal (cadar vpl) (cadr x) 1e-6))
                  vpl
        )
      (if (and (vl-every '(lambda (x) (eq (cadr x) nil)) vpl)
               (eq (length (unique vpl)) 2)
          )
        (progn
          (setq z  (entmakex (list '(0 . "LINE")
                                   (cons 10 (caar (unique vpl)))
                                   (cons 11 (caadr (unique vpl)))
                             )
                   )
                zz (cons z zz)
          )
          (setq pln nil)
        )
        (progn
          (foreach l (unique vpl)
            (setq z  (entmakex (list '(0 . "LINE")
                                     (cons 10 (car l))
                                     (cons 11 (cadr l))
                               )
                     )
                  zz (cons z zz)
            )
          )
          (setq pln nil)
        )
      )
    )
    (if (equal pln (list nil))
      (setq pln nil)
    )
    (setq plnz pln)
    (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)
        (setq z  (entmakex (list '(0 . "LINE")
                                 (cons 10 (caar vp1))
                                 (cons 11 (cadar vp1))
                           )
                 )
              zz (cons z zz)
        )
      )
      (if (car vp2)
        (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* adoc plnn plnz plnzz)

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))

  (defun *error* (msg)
    (if plnn
      (setq plnn nil)
    )
    (if plnz
      (setq plnz nil)
    )
    (if plnzz
      (setq plnzz nil)
    )
    (if zz
      (setq zz nil)
    )
    (if poly
      (setq poly nil)
    )
    (vla-endundomark adoc)
    (if msg
      (prompt msg)
    )
    (princ)
  )

  (vla-startundomark adoc)

  (setq poly
         (car
           (entsel
             "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
           )
         )
  )

  (2droof poly)

  (*error* nil)

  (princ)
)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #54 on: February 07, 2014, 06:30:28 AM »
Gian Paolo, what ab this one... If it works for you, then please help me... I believe this one is final test...

Please download attachment example...

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

:)

M.R. on Youtube

ElpanovEvgeniy

  • Water Moccasin
  • Posts: 1569
  • Moscow (Russia)
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #55 on: February 07, 2014, 07:26:27 AM »
There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...

Code: [Select]
...

Code: [Select]
(entmakex '((0 . "LWPOLYLINE")
            (100 . "AcDbEntity")
            (410 . "Model")
            (100 . "AcDbPolyline")
            (90 . 10)
            (70 . 1)
            (43 . 0.0)
            (38 . 0.0)
            (39 . 0.0)
            (10 763.88 532.697)
            (10 963.376 567.524)
            (10 886.098 759.253)
            (10 566.259 721.203)
            (10 269.828 475.846)
            (10 63.224 475.846)
            (10 141.075 248.441)
            (10 446.489 368.128)
            (10 446.489 113.793)
            (10 763.88 113.793)
            (210 0.0 0.0 1.0)
           )
)

ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #56 on: February 07, 2014, 08:06:06 AM »
There is more food for thoughts, but this one is the worst... But, perhaps someone find it usable in making good mods...

Code: [Select]
...

Code: [Select]
(entmakex '((0 . "LWPOLYLINE")
            (100 . "AcDbEntity")
            (410 . "Model")
            (100 . "AcDbPolyline")
            (90 . 10)
            (70 . 1)
            (43 . 0.0)
            (38 . 0.0)
            (39 . 0.0)
            (10 763.88 532.697)
            (10 963.376 567.524)
            (10 886.098 759.253)
            (10 566.259 721.203)
            (10 269.828 475.846)
            (10 63.224 475.846)
            (10 141.075 248.441)
            (10 446.489 368.128)
            (10 446.489 113.793)
            (10 763.88 113.793)
            (210 0.0 0.0 1.0)
           )
)

Evgeniy, you used my last code that was wrong... And my previous posted in [ code ][/ code ] tags isn't also much better as I thought... You should return to my earlier posts... Test it with this one :

Code: [Select]
(defun 2droof (pol / insidep _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 insidep (pt entn / big flag obj1 obj2 obj3 p1 p2 small)
    (if (and pt entn)
      (progn
        (setq obj1 (vlax-ename->vla-object entn))
        (setq obj2 (car (vlax-invoke obj1 'Offset 0.001))
              obj3 (car (vlax-invoke obj1 'Offset -0.001))
        )
        (if (> (vla-get-area obj2) (vla-get-area obj3))
          (progn
            (set 'big obj2)
            (set 'small obj3)
          )
          (progn
            (set 'big obj3)
            (set 'small obj2)
          )
        )
        (setq p1 (vlax-curve-getClosestPointTo big pt)
              p2 (vlax-curve-getClosestPointTo small pt)
        )
        (if (> (distance pt p1) (distance pt p2))
          (setq flag T)
          (setq flag nil)
        )
        (mapcar (function (lambda (x)
                            (progn
                              (vla-delete x)
                              (vlax-release-object x)
                            )
                          )
                )
                (list big small)
        )
      )
    )
    flag
  )

  (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 (reverse (cons (car vl) (reverse 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 pln (mapcar '(lambda (x) (if (insidep x pol) x)) pln))
    (setq pln (vl-remove nil pln))
    (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* adoc)

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))

  (defun *error* (msg)
    (if zz
      (setq zz nil)
    )
    (if poly
      (setq poly nil)
    )
    (vla-endundomark adoc)
    (if msg
      (prompt msg)
    )
    (princ)
  )

  (vla-startundomark adoc)

  (setq poly
         (car
           (entsel
             "\nPick closed LWPOLYLINE in WCS oriented CCW and with only straight segments-edges"
           )
         )
  )

  (2droof poly)

  (*error* nil)

  (princ)
)

M.R.

But what ab my example I attached... Can you help...
« Last Edit: February 07, 2014, 08:32:29 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

GP

  • Newt
  • Posts: 83
  • Vercelli, Italy
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #57 on: February 07, 2014, 08:11:44 AM »
Thank you Gian... I was wondering when I'll get some support... Your code works fantastic...

x2
 Fantastic!  :-D

Thanks.  :-)


Gian Paolo, what ab this one... If it works for you, then please help me...

Marko, is the roof of your house?  :-D

It does not work for all polylines.
The program checks that there is not a modeling error after SOLIDEDIT command (function "verify_n").



ribarm

  • Gator
  • Posts: 3255
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #58 on: February 07, 2014, 05:11:41 PM »
Do you happen to know why this kind of errors occur... I've modeled roof under this type of polyline and it is correct solution 100% slope and it is totally possible solution... Actually no matter what type of shape is base this kind of modeling of 3D object is always possible especially when it's an ordinary closed 2d polyline with straight edges... So what is the bug here - seems that ACAD can't always be consistent and from your posted picture it's visible that 2d solution of ridge edges isn't problem - CAD does this correctly (but again I think not always)... The bug is encircled piece from your picture and it's the product of modeling operation which is wrong... Look at my attached DWG; I modeled it differently than CAD - find 2d solution, then make polylines with BPOLY and then normal EXTRUDE which is then SLICEd and at the end these all pieces have been UNIONed into single 3D object... It seems that CAD here have serious bug... Just what seemed to be problem for CAD isn't - 2D solution of ridge edges, and what seems to be pretty simple process making from 2D solution 3D object failed... Really weird...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

GP

  • Newt
  • Posts: 83
  • Vercelli, Italy
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #59 on: February 08, 2014, 05:56:14 AM »
I had already noticed this problem in the test when I was writing the code.
It occurs randomly on particular polylines, I think it's a bug of  SOLIDEDIT.