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

0 Members and 1 Guest are viewing this topic.

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #135 on: August 07, 2014, 06:04:19 am »
Nice work Ribar  :-)
Thank you for keep the head .

Is there problem in my last post version ?

Check my codes and compare with your - sr.lsp

2droof3d.lsp is updated... Noticed that when points are near to each other and roof is large, routine must zoom to vertices sequences and then zoom previous to view before routine started to operate... It's strongly suggested that complete roof should be on visible screen so that (command "_.zoom" "_w" vert1 vert2) could operate correctly... Someone downloaded version where I forgot to include every vertices sequence - zooming was put inside if condition... I apologize for this it was late yesterday and my concentration was bad... Now fixed...

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

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #136 on: August 10, 2014, 10:49:02 am »
2droof-final.lsp and sr.lsp have been changed... Now should work better and almost every time should output result weather it's good or bad... Only thing is that with complex roofs you should wait for a while... But I did what I could to make it fast enough...

Hope you'll like it...

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

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #137 on: July 29, 2017, 04:15:17 am »
So it's been 3 years I haven't revised this interesting challenge... But I've found some time to revive good old memories... Basically I've written shortened versions, but it still has some issues - 3d solid - surfsculpting is relatively good, but I am though interested if someone can give boost in version with 3d lines... So here are my latest short attempts :

For SURFSCULPT into 3D SOLID ROOF :
Code - Auto/Visual Lisp: [Select]
  1. (defun c:roof-mr ( / *error* unit v^v clockwise-lw gravityceter3d adoc s slope lw a vl tl ucsf regs tll ls lsl ip ipl 3df c p1 p2 p3 p4 scf ss )
  2.  
  3.  
  4.  (defun *error* ( m )
  5.    (if ucsf
  6.      (vl-cmdf "_.UCS" "_P")
  7.    )
  8.    (if adoc
  9.      (vla-endundomark adoc)
  10.    )
  11.    (if m
  12.      (prompt m)
  13.    )
  14.    (princ)
  15.  )
  16.  
  17.  (defun unit ( v )
  18.    (if (not (equal v '(0.0 0.0 0.0) 1e-8))
  19.      (mapcar (function (lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v)))) v)
  20.    )
  21.  )
  22.  
  23.  (defun v^v ( u v )
  24.    (list
  25.      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  26.      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  27.      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  28.    )
  29.  )
  30.  
  31.  (defun clockwise-lw ( lw / minpt maxpt p1 p2 p3 p4 pmax )
  32.    (vla-getboundingbox (vlax-ename->vla-object lw) 'minpt 'maxpt)
  33.    (mapcar (function set) '(minpt maxpt) (mapcar (function safearray-value) (list minpt maxpt)))
  34.    (setq p1 minpt p2 (list (car maxpt) (cadr minpt)) p3 maxpt p4 (list (car minpt) (cadr maxpt)))
  35.    (setq pmax (max p1 p2 p3 p4))
  36.    (cond
  37.      ( (and (= pmax p1) (> p2 p4))
  38.        t
  39.      )
  40.      ( (and (= pmax p2) (> p3 p1))
  41.        t
  42.      )
  43.      ( (and (= pmax p3) (> p4 p2))
  44.        t
  45.      )
  46.      ( (and (= pmax p4) (> p1 p3))
  47.        t
  48.      )
  49.      ( t nil )
  50.    )
  51.  )
  52.  
  53.  (defun gravitycenter3d ( p1 p2 p3 / mid p12 p23 p31 c )
  54.  
  55.    (defun mid ( p1 p2 )
  56.      (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  57.    )
  58.  
  59.    (setq p12 (mid p1 p2))
  60.    (setq p23 (mid p2 p3))
  61.    (setq p31 (mid p3 p1))
  62.    (setq c (inters p12 p3 p1 p23))
  63.  
  64.    c
  65.  
  66.  )
  67.  
  68.  (prompt "\nPick closed LWPOLYLINE POLYGON...")
  69.  (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  70.  (while (not s)
  71.    (prompt "\nMissed or picked wrong entity type...")
  72.    (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  73.  )
  74.  (initget 7)
  75.  (setq slope (getreal "\nSpecify slope angle in decimal degrees : "))
  76.  (setq lw (ssname s 0))
  77.  (setq vl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 (entget lw)))) lw 0))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  78.  (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  79.  (if (clockwise-lw lw)
  80.    (progn
  81.      (setq vl (reverse vl))
  82.      (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  83.    )
  84.  )
  85.  (vla-copy (vlax-ename->vla-object lw))
  86.  (vl-cmdf "_.REGION" (entlast))
  87.  (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
  88.  (setq regs (cons (entlast) regs))
  89.  (vl-cmdf "_.PEDIT" lw "_W" 0.1)
  90.  (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
  91.  (vl-cmdf "_.CONVTOSURFACE" lw "")
  92.  (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
  93.  (setq regs (cons (entlast) regs))
  94.  (if (= (getvar 'worlducs) 0)
  95.    (progn
  96.      (vl-cmdf "_.UCS" "_W")
  97.      (setq ucsf t)
  98.    )
  99.  )
  100.  (foreach tt tl
  101.    (vl-cmdf "_.UCS" "_3P" "_non" (car tt) "_non" (cadr tt) "")
  102.    (vl-cmdf "_.UCS" "_X" slope)
  103.    (setq tll (cons (list tt (trans '(0.0 0.0 1.0) 1 0 t)) tll))
  104.    (vl-cmdf "_.UCS" "_P")
  105.    (vl-cmdf "_.UCS" "_P")
  106.  )
  107.  (foreach ttt tll
  108.    (foreach tttt (vl-remove ttt tll)
  109.      (if (equal (- (caddr (trans (caar tttt) 0 (cadr tttt))) (caddr (trans (caar ttt) 0 (cadr tttt)))) 0.0 1e-6)
  110.        (setq ls (list (caar ttt) (unit (v^v (cadr ttt) (cadr tttt)))) lsl (cons ls lsl))
  111.      )
  112.    )
  113.  )
  114.  (foreach ls lsl
  115.    (foreach lss (vl-remove ls lsl)
  116.      (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  117.        (if (not (vl-member-if (function (lambda ( x ) (equal ip x 1e-6))) ipl))
  118.          (progn
  119.            (setq ipl (cons ip ipl))
  120.            (setq 3df (entmakex (list '(0 . "3DFACE") (cons 10 ip) (cons 11 (car ls)) (cons 12 (car lss)) (cons 13 ip))))
  121.            (setq p1 ip)
  122.            (setq p2 (car ls))
  123.            (setq p3 (car lss))
  124.            (setq p4 ip)
  125.            (cond
  126.              ( (equal p1 p2 1e-8)
  127.                (setq p1 p2 p2 p3 p3 p4)
  128.              )
  129.              ( (equal p2 p3 1e-8)
  130.                (setq p1 p1 p2 p2 p3 p4)
  131.              )
  132.              ( (equal p3 p4 1e-8)
  133.                (setq p1 p1 p2 p2 p3 p3)
  134.              )
  135.              ( (equal p4 p1 1e-8)
  136.                (setq p1 p1 p2 p2 p3 p3)
  137.              )
  138.            )
  139.            (setq c (gravitycenter3d p1 p2 p3))
  140.            (vl-cmdf "_.SCALE" 3df "" "_non" c 1.01)
  141.            (vl-cmdf "_.REGION" 3df)
  142.            (while (< 0 (getvar 'cmdactive)) (vl-cmdf ""))
  143.            (setq scf (/ a (vla-get-area (vlax-ename->vla-object (entlast)))))
  144.            (if (< scf 1.0)
  145.              (setq scf 2.0)
  146.            )
  147.            (vl-cmdf "_.SCALE" (entlast) "" "_non" ip scf)
  148.            (setq regs (cons (entlast) regs))
  149.          )
  150.        )
  151.      )
  152.    )
  153.  )
  154.  (setq ss (ssadd))
  155.  (foreach reg regs
  156.    (ssadd reg ss)
  157.  )
  158.  (vl-cmdf "_.SURFSCULPT" ss "")
  159.  (*error* nil)
  160. )
  161.  

And for 3D LINEs - I want to share this as it isn't so reliable and maybe, and I said just maybe someone who wants to play with it could improve it further more - I tried several times, but unsuccessful... The problem is that when you manually solve roofs you start from all around pline vertices and solve till first touch is detected and then you continue also from all around all until last segment is connected in roof apex point... Computer can't imitate this human action and it starts from one side and continue all up to the end last side - and if result is good then it's pure luck...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:roof-mr ( / *error* unique unit v^v clockwise-lw adoc s slope lw vl tl tll ls lls lss lsl lslx lsll ip ipl lil tst ipx k kk n ucsf )
  2.  
  3.  
  4.  (defun *error* ( m )
  5.    (if ucsf
  6.      (vl-cmdf "_.UCS" "_P")
  7.    )
  8.    (if adoc
  9.      (vla-endundomark adoc)
  10.    )
  11.    (if m
  12.      (prompt m)
  13.    )
  14.    (princ)
  15.  )
  16.  
  17.  (defun unique ( l )
  18.    (if l
  19.      (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal (car l) x 1e-6))) l)))
  20.    )
  21.  )
  22.  
  23.  (defun unit ( v )
  24.    (if (not (equal v '(0.0 0.0 0.0) 1e-8))
  25.      (mapcar (function (lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v)))) v)
  26.    )
  27.  )
  28.  
  29.  (defun v^v ( u v )
  30.    (list
  31.      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  32.      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  33.      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  34.    )
  35.  )
  36.  
  37.  (defun clockwise-lw ( lw / minpt maxpt p1 p2 p3 p4 pmax )
  38.    (vla-getboundingbox (vlax-ename->vla-object lw) 'minpt 'maxpt)
  39.    (mapcar (function set) '(minpt maxpt) (mapcar (function safearray-value) (list minpt maxpt)))
  40.    (setq p1 minpt p2 (list (car maxpt) (cadr minpt)) p3 maxpt p4 (list (car minpt) (cadr maxpt)))
  41.    (setq pmax (max p1 p2 p3 p4))
  42.    (cond
  43.      ( (and (= pmax p1) (> p2 p4))
  44.        t
  45.      )
  46.      ( (and (= pmax p2) (> p3 p1))
  47.        t
  48.      )
  49.      ( (and (= pmax p3) (> p4 p2))
  50.        t
  51.      )
  52.      ( (and (= pmax p4) (> p1 p3))
  53.        t
  54.      )
  55.      ( t nil )
  56.    )
  57.  )
  58.  
  59.  (prompt "\nPick closed LWPOLYLINE POLYGON...")
  60.  (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  61.  (while (not s)
  62.    (prompt "\nMissed or picked wrong entity type...")
  63.    (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  64.  )
  65.  (initget 7)
  66.  (setq slope (getreal "\nSpecify slope angle in decimal degrees : "))
  67.  (setq lw (ssname s 0))
  68.  (setq vl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 (entget lw)))) lw 0))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  69.  (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  70.  (if (clockwise-lw lw)
  71.    (progn
  72.      (setq vl (reverse vl))
  73.      (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  74.    )
  75.  )
  76.  (if (= (getvar 'worlducs) 0)
  77.    (progn
  78.      (vl-cmdf "_.UCS" "_W")
  79.      (setq ucsf t)
  80.    )
  81.  )
  82.  (foreach tt tl
  83.    (vl-cmdf "_.UCS" "_3P" "_non" (car tt) "_non" (cadr tt) "")
  84.    (vl-cmdf "_.UCS" "_X" slope)
  85.    (setq tll (cons (list tt (trans '(0.0 0.0 1.0) 1 0 t)) tll))
  86.    (vl-cmdf "_.UCS" "_P")
  87.    (vl-cmdf "_.UCS" "_P")
  88.  )
  89.  (foreach ttt tll
  90.    (foreach tttt (vl-remove ttt tll)
  91.      (if (equal (- (caddr (trans (caar tttt) 0 (cadr tttt))) (caddr (trans (caar ttt) 0 (cadr tttt)))) 0.0 1e-6)
  92.        (setq ls (list (caar ttt) (unit (v^v (cadr ttt) (cadr tttt)))) lsl (cons ls lsl))
  93.      )
  94.    )
  95.  )
  96.  (foreach ls lsl
  97.    (foreach lss (vl-remove ls lsl)
  98.      (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  99.        (setq ipl (cons ip ipl))
  100.      )
  101.    )
  102.  )
  103.  (while (and lsl (not (equal lsl lsll 1e-6)))
  104.    (setq lsll lsl k -1)
  105.    (while (and (setq k (1+ k)) (< k (length lsl)))
  106.      (setq ls (nth k lsl) kk -1)
  107.      (while (and (setq kk (1+ kk)) (< kk (1- (length lsl))))
  108.        (setq lss (nth kk (vl-remove ls lsl)))
  109.        (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  110.          (if (and (> (caddr ip) 0.0) (not (vl-some (function (lambda ( x ) (or (equal (distance (car ls) ip) (+ (distance (car ls) x) (distance x ip)) 1e-6) (equal (distance (car lss) ip) (+ (distance (car lss) x) (distance x ip)) 1e-6)))) (vl-remove-if (function (lambda ( x ) (or (equal x ip 1e-6) (equal x (car ls) 1e-6) (equal x (car lss) 1e-6)))) ipl))))
  111.            (progn
  112.              (setq tst nil)
  113.              (foreach lsx lsl
  114.                (foreach lssx (vl-remove lsx lsl)
  115.                  (if (setq ipx (inters (car lsx) (mapcar (function +) (car lsx) (cadr lsx)) (car lssx) (mapcar (function +) (car lssx) (cadr lssx)) nil))
  116.                    (if (and (> (caddr ipx) 0.0) (not (equal ipx ip 1e-6)) (or (equal (distance (car lsx) ip) (+ (distance (car lsx) ipx) (distance ipx ip)) 1e-6) (equal (distance (car lssx) ip) (+ (distance (car lssx) ipx) (distance ipx ip)) 1e-6)))
  117.                      (setq tst t)
  118.                    )
  119.                  )
  120.                )
  121.              )
  122.              (if (null tst)
  123.                (progn
  124.                  (if (and (not (equal (car ls) ip 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car ls) ip) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list ip (car ls)) 1e-6))) lil))))
  125.                    (progn
  126.                      (setq lil (cons (list (car ls) ip) lil))
  127.                      (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 ip)))
  128.                    )
  129.                  )
  130.                  (if (and (not (equal (car lss) ip 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car lss) ip) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list ip (car lss)) 1e-6))) lil))))
  131.                    (progn
  132.                      (setq lil (cons (list (car lss) ip) lil))
  133.                      (entmake (list '(0 . "LINE") (cons 10 (car lss)) (cons 11 ip)))
  134.                    )
  135.                  )
  136.                  (setq lsl (vl-remove ls lsl) lsl (vl-remove lss lsl))
  137.                  (setq lslx nil)
  138.                  (if (setq n (unit (v^v (mapcar (function -) ip (car ls)) (mapcar (function -) ip (car lss)))))
  139.                    (setq tll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tll))
  140.                  )
  141.                  (foreach ttt tll
  142.                    (foreach tttt (vl-remove ttt tll)
  143.                      (if
  144.                        (and
  145.                          (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  146.                          (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  147.                        )
  148.                        (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  149.                      )
  150.                    )
  151.                  )
  152.                  ;|
  153.                   (foreach ttt tll
  154.                     (foreach tttt (vl-remove ttt tll)
  155.                       (cond
  156.                         ( (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  157.                           (if (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  158.                             (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  159.                             (setq lls (list ip (unit (v^v (cadr ttt) n))) lslx (cons lls lslx))
  160.                           )
  161.                         )
  162.                         ( (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  163.                           (if (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  164.                             (setq lls (list ip (unit (v^v (cadr tttt) (cadr ttt)))) lslx (cons lls lslx))
  165.                             (setq lls (list ip (unit (v^v (cadr tttt) n))) lslx (cons lls lslx))
  166.                           )
  167.                         )
  168.                       )
  169.                     )
  170.                   )
  171.                   |;
  172.                  (setq lslx (unique lslx))
  173.                  (setq lsl (append lslx lsl))
  174.                )
  175.              )
  176.            )
  177.          )
  178.          (if (or (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr ls) 1e-6) (equal (unit (mapcar (function -) (car lss) (car ls))) (mapcar (function -) (cadr ls)) 1e-6))
  179.            (progn
  180.              (if (and (not (equal (car ls) (car lss) 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car ls) (car lss)) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list (car lss) (car ls)) 1e-6))) lil))))
  181.                (progn
  182.                  (setq lil (cons (list (car ls) (car lss)) lil))
  183.                  (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 (car lss))))
  184.                )
  185.              )
  186.              (setq lsl (vl-remove ls lsl) lsl (vl-remove lss lsl))
  187.            )
  188.          )
  189.        )
  190.      )
  191.    )
  192.  )
  193.  (*error* nil)
  194. )
  195.  

Regards, M.R.
 :-)
« Last Edit: August 06, 2017, 11:15:29 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #138 on: July 30, 2017, 08:19:31 am »
Just a little bit improved and little bigger code - this is just for 3D LINEs version as I am interested in that just...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:roof-mr ( / *error* unique unit v^v clockwise-lw planextriangle-p adoc s slope lw vl tl tll tlll ls lss lsl lslx lsls lslb lsla lsll ip loop ipl lil tst ipx k kk n ucsf p dmin )
  2.  
  3.  
  4.  (defun *error* ( m )
  5.    (if ucsf
  6.      (vl-cmdf "_.UCS" "_P")
  7.    )
  8.    (if adoc
  9.      (vla-endundomark adoc)
  10.    )
  11.    (if m
  12.      (prompt m)
  13.    )
  14.    (princ)
  15.  )
  16.  
  17.  (defun unique ( l )
  18.    (if l
  19.      (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal (car l) x 1e-6))) l)))
  20.    )
  21.  )
  22.  
  23.  (defun unit ( v )
  24.    (if (not (equal v '(0.0 0.0 0.0) 1e-8))
  25.      (mapcar (function (lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v)))) v)
  26.    )
  27.  )
  28.  
  29.  (defun v^v ( u v )
  30.    (list
  31.      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  32.      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  33.      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  34.    )
  35.  )
  36.  
  37.  (defun clockwise-lw ( lw / minpt maxpt p1 p2 p3 p4 pmax )
  38.    (vla-getboundingbox (vlax-ename->vla-object lw) 'minpt 'maxpt)
  39.    (mapcar (function set) '(minpt maxpt) (mapcar (function safearray-value) (list minpt maxpt)))
  40.    (setq p1 minpt p2 (list (car maxpt) (cadr minpt)) p3 maxpt p4 (list (car minpt) (cadr maxpt)))
  41.    (setq pmax (max p1 p2 p3 p4))
  42.    (cond
  43.      ( (and (= pmax p1) (> p2 p4))
  44.        t
  45.      )
  46.      ( (and (= pmax p2) (> p3 p1))
  47.        t
  48.      )
  49.      ( (and (= pmax p3) (> p4 p2))
  50.        t
  51.      )
  52.      ( (and (= pmax p4) (> p1 p3))
  53.        t
  54.      )
  55.      ( t nil )
  56.    )
  57.  )
  58.  
  59.  (defun planextriangle-p ( p1 p2 p3 pt n / unit v^v ntr vli vpe pp1 pp2 px1 px2 ipt ip )
  60.    (setq ntr (unit (v^v (mapcar (function -) p3 p1) (mapcar (function -) p2 p1))))
  61.    (setq vli (unit (v^v ntr n)))
  62.    (if vli
  63.      (progn
  64.        (setq vpe (unit (v^v n vli)))
  65.        (setq pp1 (trans p1 0 vli))
  66.        (setq pp2 (trans p2 0 vli))
  67.        (setq px1 (trans pt 0 vli))
  68.        (setq px2 (trans (mapcar (function +) pt vpe) 0 vli))
  69.        (setq pp1 (mapcar (function +) '(0 0) pp1))
  70.        (setq pp2 (mapcar (function +) '(0 0) pp2))
  71.        (setq px1 (mapcar (function +) '(0 0) px1))
  72.        (setq px2 (mapcar (function +) '(0 0) px2))
  73.        (setq ipt (inters pp1 pp2 px1 px2 nil))
  74.        (if ipt
  75.          (setq ipt (trans ipt vli 0))
  76.        )
  77.        (if
  78.          (or
  79.            (and ipt (setq ip (inters p1 p2 ipt (mapcar (function +) ipt vli) nil)) (not (equal ip p1 1e-6)) (not (equal ip p2 1e-6)) (equal (distance p1 p2) (+ (distance p1 ip) (distance ip p2)) 1e-6))
  80.            (and ipt (setq ip (inters p1 p3 ipt (mapcar (function +) ipt vli) nil)) (not (equal ip p1 1e-6)) (not (equal ip p3 1e-6)) (equal (distance p1 p3) (+ (distance p1 ip) (distance ip p3)) 1e-6))
  81.            (and ipt (setq ip (inters p2 p3 ipt (mapcar (function +) ipt vli) nil)) (not (equal ip p2 1e-6)) (not (equal ip p3 1e-6)) (equal (distance p2 p3) (+ (distance p2 ip) (distance ip p3)) 1e-6))
  82.          )
  83.          t
  84.        )
  85.      )
  86.    )
  87.  )
  88.  
  89.  (prompt "\nPick closed LWPOLYLINE POLYGON...")
  90.  (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  91.  (while (not s)
  92.    (prompt "\nMissed or picked wrong entity type...")
  93.    (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  94.  )
  95.  (initget 7)
  96.  (setq slope (getreal "\nSpecify slope angle in decimal degrees : "))
  97.  (setq lw (ssname s 0))
  98.  (setq vl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 (entget lw)))) lw 0))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  99.  (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  100.  (if (clockwise-lw lw)
  101.    (progn
  102.      (setq vl (reverse vl))
  103.      (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  104.    )
  105.  )
  106.  (if (= (getvar 'worlducs) 0)
  107.    (progn
  108.      (vl-cmdf "_.UCS" "_W")
  109.      (setq ucsf t)
  110.    )
  111.  )
  112.  (foreach tt tl
  113.    (vl-cmdf "_.UCS" "_3P" "_non" (car tt) "_non" (cadr tt) "")
  114.    (vl-cmdf "_.UCS" "_X" slope)
  115.    (setq tll (cons (list tt (trans '(0.0 0.0 1.0) 1 0 t)) tll))
  116.    (vl-cmdf "_.UCS" "_P")
  117.    (vl-cmdf "_.UCS" "_P")
  118.  )
  119.  (foreach ttt tll
  120.    (foreach tttt (vl-remove ttt tll)
  121.      (if (equal (- (caddr (trans (caar tttt) 0 (cadr tttt))) (caddr (trans (caar ttt) 0 (cadr tttt)))) 0.0 1e-6)
  122.        (setq ls (list (caar ttt) (unit (v^v (cadr ttt) (cadr tttt)))) lsl (cons ls lsl))
  123.      )
  124.    )
  125.  )
  126.  (setq dmin 1e+99)
  127.  (foreach ls lsl
  128.    (foreach lss (vl-remove ls lsl)
  129.      (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  130.        (progn
  131.          (if (< (distance (car ls) ip) (distance (car lss) ip))
  132.            (if (< (distance (car ls) ip) dmin)
  133.              (setq p ip dmin (distance (car ls) ip))
  134.            )
  135.            (if (< (distance (car lss) ip) dmin)
  136.              (setq p ip dmin (distance (car lss) ip))
  137.            )
  138.          )
  139.          (setq ipl (cons ip ipl))
  140.        )
  141.      )
  142.    )
  143.  )
  144.  (setq lsls (vl-sort lsl (function (lambda ( a b ) (< (distance p (car a)) (distance p (car b)))))))
  145.  (setq lslb (reverse (cdr (member (car lsls) (reverse lsl)))))
  146.  (setq lsla (member (car lsls) lsl))
  147.  (setq lsl (append lslb lsla))
  148.  (foreach ls lsl
  149.    (foreach lss (vl-remove ls lsl)
  150.      (setq tlll tll)
  151.      (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  152.        (if (and (> (caddr ip) 0.0) (not (vl-some (function (lambda ( x ) (or (equal (distance (car ls) ip) (+ (distance (car ls) x) (distance x ip)) 1e-6) (equal (distance (car lss) ip) (+ (distance (car lss) x) (distance x ip)) 1e-6)))) (vl-remove-if (function (lambda ( x ) (or (equal x (car ls) 1e-6) (equal x (car lss) 1e-6)))) ipl))))
  153.          (if (vl-member-if (function (lambda ( x ) (equal ip x 1e-6))) ipl)
  154.            (progn
  155.              (setq tst nil)
  156.              (if (setq n (unit (v^v (mapcar (function -) ip (car ls)) (mapcar (function -) ip (car lss)))))
  157.                (setq tlll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tlll))
  158.              )
  159.              (foreach ttt tlll
  160.                (if (not (planextriangle-p ip (car ls) (car lss) (caar ttt) (cadr ttt)))
  161.                  (setq tst t)
  162.                )
  163.              )
  164.              (if tst
  165.                (progn
  166.                  (if (and (not (equal (car ls) ip 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car ls) ip) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list ip (car ls)) 1e-6))) lil))))
  167.                    (progn
  168.                      (setq lil (cons (list (car ls) ip) lil))
  169.                      (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 ip)))
  170.                    )
  171.                  )
  172.                  (if (and (not (equal (car lss) ip 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car lss) ip) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list ip (car lss)) 1e-6))) lil))))
  173.                    (progn
  174.                      (setq lil (cons (list (car lss) ip) lil))
  175.                      (entmake (list '(0 . "LINE") (cons 10 (car lss)) (cons 11 ip)))
  176.                    )
  177.                  )
  178.                  (setq lsl (vl-remove ls lsl) lsl (vl-remove lss lsl) lsl (vl-remove (list (car ls) (mapcar (function -) (cadr ls))) lsl) lsl (vl-remove (list (car lss) (mapcar (function -) (cadr lss))) lsl))
  179.                  (setq tlll tll lslx nil)
  180.                  (if (setq n (unit (v^v (mapcar (function -) ip (car ls)) (mapcar (function -) ip (car lss)))))
  181.                    (setq tlll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tlll))
  182.                  )
  183.                  (foreach ttt tlll
  184.                    (foreach tttt (vl-remove ttt tlll)
  185.                      (if
  186.                        (and
  187.                          (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  188.                          (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  189.                        )
  190.                        (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  191.                      )
  192.                    )
  193.                  )
  194.                  ;|
  195.                   (foreach ttt tlll
  196.                     (foreach tttt (vl-remove ttt tlll)
  197.                       (cond
  198.                         ( (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  199.                           (if (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  200.                             (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  201.                             (setq lls (list ip (unit (v^v (cadr ttt) n))) lslx (cons lls lslx))
  202.                           )
  203.                         )
  204.                         ( (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  205.                           (if (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  206.                             (setq lls (list ip (unit (v^v (cadr tttt) (cadr ttt)))) lslx (cons lls lslx))
  207.                             (setq lls (list ip (unit (v^v (cadr tttt) n))) lslx (cons lls lslx))
  208.                           )
  209.                         )
  210.                       )
  211.                     )
  212.                   )
  213.                   |;
  214.                  (setq lslx (unique lslx))
  215.                  (setq lsl (append lslx lsl))
  216.                )
  217.              )
  218.            )
  219.          )
  220.        )
  221.      )
  222.    )
  223.  )
  224.  (setq loop t)
  225.  (while (and lsl loop)
  226.    (if (or (equal lsl lsll 1e-6) (equal (reverse lsl) lsll 1e-6))
  227.      (setq loop nil)
  228.    )
  229.    (setq lsll lsl k -1)
  230.    (while (and (setq k (1+ k)) (< k (length lsl)))
  231.      (setq ls (nth k lsl) kk -1)
  232.      (while (and (setq kk (1+ kk)) (< kk (length (vl-remove ls lsl))))
  233.        (setq lss (nth kk (vl-remove ls lsl)))
  234.        (if (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  235.          (if (and (> (caddr ip) 0.0) (not (vl-some (function (lambda ( x ) (or (equal (distance (car ls) ip) (+ (distance (car ls) x) (distance x ip)) 1e-6) (equal (distance (car lss) ip) (+ (distance (car lss) x) (distance x ip)) 1e-6)))) (vl-remove-if (function (lambda ( x ) (or (equal x ip 1e-6) (equal x (car ls) 1e-6) (equal x (car lss) 1e-6)))) ipl))))
  236.            (progn
  237.              (setq tst nil)
  238.              (foreach lsx lsl
  239.                (foreach lssx (vl-remove lsx lsl)
  240.                  (if (setq ipx (inters (car lsx) (mapcar (function +) (car lsx) (cadr lsx)) (car lssx) (mapcar (function +) (car lssx) (cadr lssx)) nil))
  241.                    (if (and (> (caddr ipx) 0.0) (not (equal ipx ip 1e-6)) (not (equal ipx (car lsx) 1e-6)) (not (equal ipx (car lssx) 1e-6)) (or (equal (distance (car lsx) ip) (+ (distance (car lsx) ipx) (distance ipx ip)) 1e-6) (equal (distance (car lssx) ip) (+ (distance (car lssx) ipx) (distance ipx ip)) 1e-6)))
  242.                      (setq tst t)
  243.                    )
  244.                  )
  245.                )
  246.              )
  247.              (if (null tst)
  248.                (progn
  249.                  (if (and (not (equal (car ls) ip 1e-6)) (not (vl-member-if (function (lambda ( x ) (equal x (list (car ls) ip) 1e-6))) lil)) (not (vl-member-if (function (lambda ( x ) (equal (car ls) x 1e-6))) (mapcar (function car) lil))))
  250.                    (progn
  251.                      (setq lil (cons (list (car ls) ip) lil))
  252.                      (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 ip)))
  253.                    )
  254.                  )
  255.                  (if (and (not (equal (car lss) ip 1e-6)) (not (vl-member-if (function (lambda ( x ) (equal x (list (car lss) ip) 1e-6))) lil)) (not (vl-member-if (function (lambda ( x ) (equal (car lss) x 1e-6))) (mapcar (function car) lil))))
  256.                    (progn
  257.                      (setq lil (cons (list (car lss) ip) lil))
  258.                      (entmake (list '(0 . "LINE") (cons 10 (car lss)) (cons 11 ip)))
  259.                    )
  260.                  )
  261.                  (setq lsl (vl-remove ls lsl) lsl (vl-remove lss lsl) lsl (vl-remove (list (car ls) (mapcar (function -) (cadr ls))) lsl) lsl (vl-remove (list (car lss) (mapcar (function -) (cadr lss))) lsl))
  262.                  (setq tlll tll lslx nil)
  263.                  (if (setq n (unit (v^v (mapcar (function -) ip (car ls)) (mapcar (function -) ip (car lss)))))
  264.                    (setq tlll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tlll))
  265.                  )
  266.                  (foreach ttt tlll
  267.                    (foreach tttt (vl-remove ttt tlll)
  268.                      (if
  269.                        (and
  270.                          (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  271.                          (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  272.                        )
  273.                        (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  274.                      )
  275.                    )
  276.                  )
  277.                  ;|
  278.                   (foreach ttt tlll
  279.                     (foreach tttt (vl-remove ttt tlll)
  280.                       (cond
  281.                         ( (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  282.                           (if (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  283.                             (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  284.                             (setq lls (list ip (unit (v^v (cadr ttt) n))) lslx (cons lls lslx))
  285.                           )
  286.                         )
  287.                         ( (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  288.                           (if (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  289.                             (setq lls (list ip (unit (v^v (cadr tttt) (cadr ttt)))) lslx (cons lls lslx))
  290.                             (setq lls (list ip (unit (v^v (cadr tttt) n))) lslx (cons lls lslx))
  291.                           )
  292.                         )
  293.                       )
  294.                     )
  295.                   )
  296.                   |;
  297.                  (setq lslx (unique lslx))
  298.                  (setq lsl (append lslx lsl))
  299.                )
  300.              )
  301.            )
  302.          )
  303.          (if (or (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr ls) 1e-6) (equal (unit (mapcar (function -) (car lss) (car ls))) (mapcar (function -) (cadr ls)) 1e-6))
  304.            (progn
  305.              (if (and (not (equal (car ls) (car lss) 1e-6)) (not (or (vl-member-if (function (lambda ( x ) (equal x (list (car ls) (car lss)) 1e-6))) lil) (vl-member-if (function (lambda ( x ) (equal x (list (car lss) (car ls)) 1e-6))) lil))))
  306.                (progn
  307.                  (setq lil (cons (list (car ls) (car lss)) lil))
  308.                  (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 (car lss))))
  309.                )
  310.              )
  311.              (setq lsl (vl-remove ls lsl) lsl (vl-remove lss lsl) lsl (vl-remove (list (car ls) (mapcar (function -) (cadr ls))) lsl) lsl (vl-remove (list (car lss) (mapcar (function -) (cadr lss))) lsl))
  312.            )
  313.          )
  314.        )
  315.      )
  316.    )
  317.    (if (not (equal lsl lsll 1e-6))
  318.      (setq loop t)
  319.      (setq lsl (reverse lsl))
  320.    )
  321.  )
  322.  (*error* nil)
  323. )
  324.  
« Last Edit: August 06, 2017, 11:16:05 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #139 on: August 01, 2017, 04:48:59 pm »
This version is also wrong, but in some cases it solves correctly... But it is incredibly slow... Never mind I'll share it for someone that want to investigate it and study...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:roof-mr ( / *error* unique unit v^v clockwise-lw mr_IsPointInside adoc s slope lw vl tl ucsf tll tlll tst lls lsl lslx lsll ip ipx ipll pl pll n loop lil plil vlil )
  2.  
  3.  
  4.  (defun *error* ( m )
  5.    (if ucsf
  6.      (vl-cmdf "_.UCS" "_P")
  7.    )
  8.    (if adoc
  9.      (vla-endundomark adoc)
  10.    )
  11.    (if m
  12.      (prompt m)
  13.    )
  14.    (princ)
  15.  )
  16.  
  17.  (defun unique ( l )
  18.    (if l
  19.      (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal (car l) x 1e-6))) l)))
  20.    )
  21.  )
  22.  
  23.  (defun unit ( v )
  24.    (if (not (equal v '(0.0 0.0 0.0) 1e-8))
  25.      (mapcar (function (lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v)))) v)
  26.    )
  27.  )
  28.  
  29.  (defun v^v ( u v )
  30.    (list
  31.      (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
  32.      (- (* (caddr u) (car v)) (* (car u) (caddr v)))
  33.      (- (* (car u) (cadr v)) (* (cadr u) (car v)))
  34.    )
  35.  )
  36.  
  37.  (defun clockwise-lw ( lw / minpt maxpt p1 p2 p3 p4 pmax )
  38.    (vla-getboundingbox (vlax-ename->vla-object lw) 'minpt 'maxpt)
  39.    (mapcar (function set) '(minpt maxpt) (mapcar (function safearray-value) (list minpt maxpt)))
  40.    (setq p1 minpt p2 (list (car maxpt) (cadr minpt)) p3 maxpt p4 (list (car minpt) (cadr maxpt)))
  41.    (setq pmax (max p1 p2 p3 p4))
  42.    (cond
  43.      ( (and (= pmax p1) (> p2 p4))
  44.        t
  45.      )
  46.      ( (and (= pmax p2) (> p3 p1))
  47.        t
  48.      )
  49.      ( (and (= pmax p3) (> p4 p2))
  50.        t
  51.      )
  52.      ( (and (= pmax p4) (> p1 p3))
  53.        t
  54.      )
  55.      ( t nil )
  56.    )
  57.  )
  58.  
  59.  (defun mr_IsPointInside ( pt ptlst / trianglst ptinsidetriangle-p trl )
  60.  
  61.    (defun trianglst ( ptlst / unique LM:ListClockwise-p clockwise-p l p1 p2 p3 trl )
  62.  
  63.      (defun unique ( l )
  64.        (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  65.      )
  66.  
  67.      ;; List Clockwise-p - Lee Mac
  68.      ;; Returns T if the point list is clockwise oriented
  69.  
  70.      (defun LM:ListClockwise-p ( lst )
  71.        (minusp
  72.          (apply '+
  73.            (mapcar
  74.              (function
  75.                (lambda ( a b )
  76.                  (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  77.                )
  78.              )
  79.              lst (cons (last lst) lst)
  80.            )
  81.          )
  82.        )
  83.      )
  84.  
  85.      (defun clockwise-p ( p1 p2 p3 )
  86.        (< (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
  87.           (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
  88.        )
  89.      )
  90.  
  91.      (setq l ptlst)
  92.      (while (> (length ptlst) 3)
  93.        (setq p1 (car ptlst) p2 (cadr ptlst) p3 (caddr ptlst))
  94.        (cond
  95.          ( (LM:ListClockwise-p ptlst)
  96.            (if
  97.              (and
  98.                (clockwise-p p1 p2 p3)
  99.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  100.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  101.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  102.              )
  103.              (progn
  104.                (setq trl (cons (list p1 p2 p3) trl))
  105.                (setq ptlst (vl-remove p2 ptlst))
  106.                (setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
  107.              )
  108.              (setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
  109.            )
  110.          )
  111.          ( (not (LM:ListClockwise-p ptlst))
  112.            (if
  113.              (and
  114.                (not (clockwise-p p1 p2 p3))
  115.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  116.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  117.                (= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
  118.              )
  119.              (progn
  120.                (setq trl (cons (list p1 p2 p3) trl))
  121.                (setq ptlst (vl-remove p2 ptlst))
  122.                (setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
  123.              )
  124.              (setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
  125.            )
  126.          )
  127.        )
  128.      )
  129.      (setq trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl))
  130.      trl
  131.    )
  132.  
  133.    (defun ptinsidetriangle-p ( pt p1 p2 p3 )
  134.      (or
  135.        (and
  136.          (not
  137.            (or
  138.              (inters pt p1 p2 p3)
  139.              (inters pt p2 p1 p3)
  140.              (inters pt p3 p1 p2)
  141.            )
  142.          )
  143.          (not
  144.            (or
  145.              (> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
  146.              (> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
  147.              (> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
  148.            )
  149.          )
  150.        )
  151.        (equal (distance p1 p2) (+ (distance p1 pt) (distance pt p2)) 1e-8)
  152.        (equal (distance p2 p3) (+ (distance p2 pt) (distance pt p3)) 1e-8)
  153.        (equal (distance p3 p1) (+ (distance p3 pt) (distance pt p1)) 1e-8)
  154.      )
  155.    )
  156.  
  157.    (setq trl (trianglst ptlst))
  158.    (and
  159.      (vl-some (function (lambda ( x ) (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)))) trl)
  160.      (not (vl-some (function (lambda ( a b ) (equal (distance a b) (+ (distance a pt) (distance pt b)) 1e-8))) ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst))))))
  161.    )
  162.  )
  163.  
  164.  (prompt "\nPick closed LWPOLYLINE POLYGON...")
  165.  (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  166.  (while (not s)
  167.    (prompt "\nMissed or picked wrong entity type...")
  168.    (setq s (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "<or") (70 . 1) (70 . 129) (-4 . "or>") (-4 . "<not") (-4 . "<>") (42 . 0.0) (-4 . "not>"))))
  169.  )
  170.  (initget 7)
  171.  (setq slope (getreal "\nSpecify slope angle in decimal degrees : "))
  172.  (setq lw (ssname s 0))
  173.  (setq vl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 (entget lw)))) lw 0))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))))
  174.  (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  175.  (if (clockwise-lw lw)
  176.    (progn
  177.      (setq vl (reverse vl))
  178.      (setq tl (mapcar (function (lambda ( a b ) (list a b))) vl (cdr (reverse (cons (car vl) (reverse vl))))))
  179.    )
  180.  )
  181.  (if (= (getvar 'worlducs) 0)
  182.    (progn
  183.      (vl-cmdf "_.UCS" "_W")
  184.      (setq ucsf t)
  185.    )
  186.  )
  187.  (foreach tt tl
  188.    (vl-cmdf "_.UCS" "_3P" "_non" (car tt) "_non" (cadr tt) "")
  189.    (vl-cmdf "_.UCS" "_X" slope)
  190.    (setq tll (cons (list tt (trans '(0.0 0.0 1.0) 1 0 t)) tll))
  191.    (vl-cmdf "_.UCS" "_P")
  192.    (vl-cmdf "_.UCS" "_P")
  193.  )
  194.  (foreach ttt tll
  195.    (foreach tttt (vl-remove ttt tll)
  196.      (if (equal (- (caddr (trans (caar tttt) 0 (cadr tttt))) (caddr (trans (caar ttt) 0 (cadr tttt)))) 0.0 1e-6)
  197.        (setq lls (list (caar ttt) (unit (v^v (cadr ttt) (cadr tttt)))) lsl (cons lls lsl))
  198.      )
  199.    )
  200.  )
  201.  (setq loop t)
  202.  (while (and lsl loop)
  203.    (if (equal lsl lsll 1e-6)
  204.      (setq loop nil)
  205.    )
  206.    (setq lsll lsl)
  207.    (foreach ls lsl
  208.      (foreach lss (vl-remove ls lsl)
  209.        (if
  210.          (and
  211.            (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  212.            (not (vl-some (function (lambda ( x ) (equal (car x) ip 1e-6))) lsl))
  213.            (not (vl-some (function (lambda ( x ) (equal x ip 1e-6))) ipll))
  214.            (not (equal ip (car ls) 1e-6))
  215.            (not (equal ip (car lss) 1e-6))
  216.            (mr_IsPointInside ip vl)
  217.          )
  218.          (progn
  219.            (setq tlll tll tst nil)
  220.            (foreach lsx lsl
  221.              (foreach lssx (vl-remove lsx lsl)
  222.                (if (setq ipx (inters (car lsx) (mapcar (function +) (car lsx) (cadr lsx)) (car lssx) (mapcar (function +) (car lssx) (cadr lssx)) nil))
  223.                  (if
  224.                    (and
  225.                      (null tst)
  226.                      (> (caddr ipx) 0.0)
  227.                      (not (equal ipx ip 1e-6))
  228.                      (not (equal ipx (car lsx) 1e-6))
  229.                      (not (equal ipx (car lssx) 1e-6))
  230.                      (or
  231.                        (equal (distance (car lsx) ip) (+ (distance (car lsx) ipx) (distance ipx ip)) 1e-6)
  232.                        (equal (distance (car lssx) ip) (+ (distance (car lssx) ipx) (distance ipx ip)) 1e-6)
  233.                      )
  234.                    )
  235.                    (progn
  236.                      (if
  237.                        (or
  238.                          (vl-some (function (lambda ( x ) (or (equal (distance (car ls) (car x)) (+ (distance (car ls) ip) (distance ip (car x))) 1e-6) (equal (distance (car lss) (car x)) (+ (distance (car lss) ip) (distance ip (car x))) 1e-6)))) lsl)
  239.                          (not (vl-some (function (lambda ( x ) (equal ipx x 1e-6))) ipll))
  240.                        )
  241.                        (setq tst t)
  242.                      )
  243.                      (if
  244.                        (or
  245.                          (equal ls lsx 1e-6)
  246.                          (equal ls lssx 1e-6)
  247.                          (equal lss lsx 1e-6)
  248.                          (equal lss lssx 1e-6)
  249.                        )
  250.                        (setq tst nil)
  251.                      )
  252.                      (if
  253.                        (and
  254.                          tst
  255.                          (not (vl-some (function (lambda ( x ) (equal ip x 1e-6))) ipll))
  256.                        )
  257.                        (setq ipll (cons ip ipll))
  258.                      )
  259.                    )
  260.                  )
  261.                )
  262.              )
  263.            )
  264.            (if (not tst)
  265.              (progn
  266.                (setq lslx nil)
  267.                (if (setq n (unit (v^v (cadr ls) (cadr lss))))
  268.                  (setq tlll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tlll))
  269.                )
  270.                (foreach ttt tlll
  271.                  (foreach tttt (vl-remove ttt tlll)
  272.                    (if
  273.                      (and
  274.                        (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  275.                        (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  276.                      )
  277.                      (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  278.                    )
  279.                  )
  280.                )
  281.                (setq lslx (unique lslx))
  282.                (setq lsl (append lslx lsl))
  283.              )
  284.            )
  285.          )
  286.        )
  287.      )
  288.    )
  289.  )
  290.  (foreach ls lsl
  291.    (foreach lss (vl-remove ls lsl)
  292.      (if
  293.        (and
  294.          (not (equal (car ls) (car lss) 1e-6))
  295.          (or
  296.            (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr ls) 1e-6)
  297.            (equal (unit (mapcar (function -) (car ls) (car lss))) (cadr ls) 1e-6)
  298.            (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr lss) 1e-6)
  299.            (equal (unit (mapcar (function -) (car ls) (car lss))) (cadr lss) 1e-6)
  300.          )
  301.          (not (vl-some (function (lambda ( x ) (or (equal (list (car ls) (car lss)) x 1e-6) (equal (list (car ls) (car lss)) (reverse x) 1e-6)))) lil))
  302.        )
  303.        (setq lil (cons (list (car ls) (car lss)) lil))
  304.      )
  305.    )
  306.  )
  307.  (setq lil (append lil tl))
  308.  (foreach p (setq pl (apply (function append) lil))
  309.    (if
  310.      (and
  311.        (not (vl-some (function (lambda ( x ) (equal x p 1e-6))) vl))
  312.        (or
  313.          (> (length (vl-remove-if (function (lambda ( x ) (equal x p 1e-6))) pl)) (- (length pl) 3))
  314.          (if
  315.            (and
  316.              (setq plil (vl-remove-if-not (function (lambda ( x ) (or (equal p (car x) 1e-6) (equal p (cadr x) 1e-6)))) lil))
  317.              (setq vlil (mapcar (function (lambda ( x ) (unit (mapcar (function -) p (car x))))) (mapcar (function (lambda ( x ) (vl-remove-if (function (lambda ( y ) (equal p y 1e-6))) x))) plil)))
  318.              (if (< (length (unique vlil)) (length vlil))
  319.                t
  320.              )
  321.            )
  322.            t
  323.          )
  324.        )
  325.      )
  326.      (setq lsl (vl-remove-if (function (lambda ( x ) (equal (car x) p 1e-6))) lsl) pll (cons p pll))
  327.    )
  328.  )
  329.  (setq pll (unique pll))
  330.  (setq loop t)
  331.  (while (and lsl loop)
  332.    (if (equal lsl lsll 1e-6)
  333.      (setq loop nil)
  334.    )
  335.    (setq lsll lsl)
  336.    (foreach ls lsl
  337.      (foreach lss (vl-remove ls lsl)
  338.        (if
  339.          (and
  340.            (setq ip (inters (car ls) (mapcar (function +) (car ls) (cadr ls)) (car lss) (mapcar (function +) (car lss) (cadr lss)) nil))
  341.            ;(not (vl-some (function (lambda ( x ) (equal x ip 1e-6))) pll))
  342.            (not (vl-some (function (lambda ( x ) (equal (car x) ip 1e-6))) lsl))
  343.            (not (vl-some (function (lambda ( x ) (equal x ip 1e-6))) ipll))
  344.            (not (equal ip (car ls) 1e-6))
  345.            (not (equal ip (car lss) 1e-6))
  346.            (mr_IsPointInside ip vl)
  347.          )
  348.          (progn
  349.            (setq tlll tll tst nil)
  350.            (foreach lsx lsl
  351.              (foreach lssx (vl-remove lsx lsl)
  352.                (if (setq ipx (inters (car lsx) (mapcar (function +) (car lsx) (cadr lsx)) (car lssx) (mapcar (function +) (car lssx) (cadr lssx)) nil))
  353.                  (if
  354.                    (and
  355.                      (null tst)
  356.                      (> (caddr ipx) 0.0)
  357.                      (not (equal ipx ip 1e-6))
  358.                      (not (equal ipx (car lsx) 1e-6))
  359.                      (not (equal ipx (car lssx) 1e-6))
  360.                      (or
  361.                        (equal (distance (car lsx) ip) (+ (distance (car lsx) ipx) (distance ipx ip)) 1e-6)
  362.                        (equal (distance (car lssx) ip) (+ (distance (car lssx) ipx) (distance ipx ip)) 1e-6)
  363.                      )
  364.                    )
  365.                    (progn
  366.                      (if
  367.                        (or
  368.                          (vl-some (function (lambda ( x ) (or (equal (distance (car ls) (car x)) (+ (distance (car ls) ip) (distance ip (car x))) 1e-6) (equal (distance (car lss) (car x)) (+ (distance (car lss) ip) (distance ip (car x))) 1e-6)))) lsl)
  369.                          (not (vl-some (function (lambda ( x ) (equal ipx x 1e-6))) ipll))
  370.                        )
  371.                        (setq tst t)
  372.                      )
  373.  
  374.                      ;(if
  375.                        ;(or
  376.                          ;(equal ls lsx 1e-6)
  377.                          ;(equal ls lssx 1e-6)
  378.                          ;(equal lss lsx 1e-6)
  379.                          ;(equal lss lssx 1e-6)
  380.                        ;)
  381.                        ;(setq tst nil)
  382.                      ;)
  383.  
  384.                      (if
  385.                        (and
  386.                          tst
  387.                          (not (vl-some (function (lambda ( x ) (equal ip x 1e-6))) ipll))
  388.                        )
  389.                        (setq ipll (cons ip ipll))
  390.                      )
  391.                    )
  392.                  )
  393.                )
  394.              )
  395.            )
  396.            (if (not tst)
  397.              (progn
  398.                (setq lslx nil)
  399.                (if (setq n (unit (v^v (cadr ls) (cadr lss))))
  400.                  (setq tlll (vl-remove-if (function (lambda ( x ) (or (equal n (cadr x) 1e-6) (equal (mapcar (function -) n) (cadr x) 1e-6)))) tlll))
  401.                )
  402.                (foreach ttt tlll
  403.                  (foreach tttt (vl-remove ttt tlll)
  404.                    (if
  405.                      (and
  406.                        (equal (- (caddr (trans ip 0 (cadr ttt))) (caddr (trans (caar ttt) 0 (cadr ttt)))) 0.0 1e-6)
  407.                        (equal (- (caddr (trans ip 0 (cadr tttt))) (caddr (trans (caar tttt) 0 (cadr tttt)))) 0.0 1e-6)
  408.                      )
  409.                      (setq lls (list ip (unit (v^v (cadr ttt) (cadr tttt)))) lslx (cons lls lslx))
  410.                    )
  411.                  )
  412.                )
  413.                (setq lslx (unique lslx))
  414.                (setq lsl (append lslx lsl))
  415.              )
  416.            )
  417.          )
  418.        )
  419.      )
  420.    )
  421.  )
  422.  (setq lil nil)
  423.  (foreach ls lsl
  424.    (foreach lss (vl-remove ls lsl)
  425.      (if
  426.        (and
  427.          (not (equal (car ls) (car lss) 1e-6))
  428.          (or
  429.            (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr ls) 1e-6)
  430.            (equal (unit (mapcar (function -) (car ls) (car lss))) (cadr ls) 1e-6)
  431.            (equal (unit (mapcar (function -) (car lss) (car ls))) (cadr lss) 1e-6)
  432.            (equal (unit (mapcar (function -) (car ls) (car lss))) (cadr lss) 1e-6)
  433.          )
  434.          (not (vl-some (function (lambda ( x ) (or (equal (list (car ls) (car lss)) x 1e-6) (equal (list (car ls) (car lss)) (reverse x) 1e-6)))) lil))
  435.        )
  436.        (progn
  437.          (setq lil (cons (list (car ls) (car lss)) lil))
  438.          (entmake (list '(0 . "LINE") (cons 10 (car ls)) (cons 11 (car lss))))
  439.        )
  440.      )
  441.    )
  442.  )
  443.  (*error* nil)
  444. )
  445.  

M.R.
« Last Edit: August 06, 2017, 11:17:35 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #140 on: August 03, 2017, 03:57:26 pm »
There is this game (look into gif)... But it's only for convex polygons, the problem are concave ones... When solution is found correctly with 3D LINES, it's relatively easy to make 3D SOLID from it... For future note, developing general routine that works for both cases with lines in 3D SPACE is IMO the best choice... I tried to add some codes that lead following that path and I wish you success in your study and coding...

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

:)

M.R. on Youtube

HasanCAD

  • Swamp Rat
  • Posts: 1163
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #141 on: August 06, 2017, 04:17:36 am »
WOW

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #142 on: August 08, 2017, 08:40:39 am »
WOW

I've written just another lisp (25KB core + 25KB CAB's - break-with sub incorporated = about 55 KB total) for convex+concave polygon 3dsolid roofs... And it uses modelling operations with final SURFSCULPT... But it's so slow - for complex roofs I thinks it needs 1000??? times longer than ch_lhjd's routine, but if you have supercomputer I think it can solve just about everything, so in that manner it's better... I'll post gif showing it in action and DWG with ultimate test for those developers that have some alternative which ch_lhjd's sr.lsp can't handle, and also EXTRUDE Taper => SOLIDEDIT (EXTRUDE or MOVE) top face upwards built in CAD can't handle correctly, but for mine version I think I need supercomputer to get it...

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

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #143 on: August 08, 2017, 11:32:19 am »
I forgot to show that it also works with porches...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #144 on: August 12, 2017, 03:21:34 pm »
I've speed up my routine (version) and I've made the one that works with islands... Just to see that it's very possible, I'll attach gif...

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

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #145 on: August 14, 2017, 01:40:31 pm »
Another demonstration on my slow PC (using A2014 on Win7)... BTW. A2017 have some sort of bug and can't do it directly - you must save DWG and reopen after cubes are made... IMO it's reasonably fast for this task...

Regards...
« Last Edit: August 16, 2017, 08:43:07 am by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Water Moccasin
  • Posts: 1663
  • Marko Ribar, architect
Re: ==={Challenge}===Find the ridge lines of sloped roof
« Reply #146 on: August 16, 2017, 08:53:53 am »
I've updated my last posted animated gif... Added lower 3DSOLIDs parts around cubes-objects... I think that it's now prettier and theswamp managed to upload gif in 640x512 resolution so now it little bigger (better)...

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

:)

M.R. on Youtube