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

pkohut · « **Reply #210 on:** February 27, 2023, 07:41:01 AM »

Quote from: ribarm on February 27, 2023, 07:04:43 AM

@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...

Where are the code comments?
Want speed - get out of lisp.
Want speed - keep nested loops to a minimum.
Want speed - don't do heavy calculations deep in the loops.
Want speed - don't do if checks deep in the loops.
Want speed - learn algorithms and data structures.

ribarm · « **Reply #211 on:** February 27, 2023, 07:58:43 AM »

Quote from: pkohut on February 27, 2023, 07:41:01 AM

Quote from: ribarm on February 27, 2023, 07:04:43 AM

@Lee, @Daniel, @Gilles, @Evgeniy, @Owen, @Highflybird, ... and others, tell me how to continue, but not to loose speed too much...

Where are the code comments?
Want speed - get out of lisp.
Want speed - keep nested loops to a minimum.
Want speed - don't do heavy calculations deep in the loops.
Want speed - don't do if checks deep in the loops.
Want speed - learn algorithms and data structures.

Why do you need code comments?
For other opinions I agree, but not my field of knowledge...
It could be written in lisp for sure to be fast enough - look at chlh_jd's example...
The problem is that complexity may grow - ultimate roofs - 100 and more vertices...

If you test it, you'll see what it do till now... The problem arises with widening code - finding correct solution based on offsetting...

ribarm · « **Reply #212 on:** February 28, 2023, 01:19:58 PM »

And here is it classical example of how topic get overcrowded with other new ones...

Have someone thought ab this examples, especially the ones posted at cadtutor.net - download section...

I would like to see something new that may be better than my attempts...

M.R.

pkohut · « **Reply #213 on:** February 28, 2023, 02:48:52 PM »

Quote from: ribarm on February 28, 2023, 01:19:58 PM

And here is it classical example of how topic get overcrowded with other new ones...

Have someone thought ab this examples, especially the ones posted at cadtutor.net - download section...

I would like to see something new that may be better than my attempts...

M.R.

Fair enough. Your playground, your rules. Take my non-lisp ball to another field.

ribarm · « **Reply #214 on:** March 01, 2023, 10:18:03 AM »

ribarm · « **Reply #215 on:** March 06, 2023, 10:53:05 AM »

To all users, or else watching...

Can this routine here in attachment work faster with ultimate roof example, and not to depend on PC hardware architecture configuration...

I am not searching translation to ARX, BRX, (but I suppose it would be perfect) or something else, though and DLL for latest versions of Auto/BricsCAD would be very welcomed, I also need tweaks if someone operates with *.LSP on higher level of intelligence...

Link for ultimate roof DWG : https://www.theswamp.org/index.php?topic=41837.msg613477#msg613477

ribarm · « **Reply #216 on:** March 06, 2023, 12:11:08 PM »

Letter to programmer masters...

Quote

Is my routine hardware dependent... (roof2d-new-new-offset.lsp)... If so, which is mostly the case, then the job is done... I don't know how to tweak for ultimate roofs (100 and more vertices)... If it doesn't depend on the hardware, then let someone more expert than me take a look... It doesn't matter if it's *.lsp, *.arx, *.brx, * .dll... it's only important that it works optimally, which I doubt... I don't know, if you care, ask around, maybe by chance a solution for slowness will be found... I took all the parameters into circulation and matched them with each other ... Perhaps I should have left something out, but then not all the tests would have passed... See what you can do, if you have the time and interest...

Testing *.DWG is in attachment...

ribarm · « **Reply #217 on:** March 07, 2023, 10:35:30 AM »

ribarm · « **Reply #218 on:** March 11, 2023, 11:56:24 AM »

I've found some workaround... It was all the time in front of my(ours) nose...
As for the ultimate roofs, test for 1 full rotation of vertices, so if it is not found the first time, trim one of the sides of the lwpoly, turn it closed through palette, which changes the initial vertex... After a bit of hacking in this way, 2droof-final.lsp should find solution within 1 to 2 seconds... Just don't forget that errm doesn't even need to iterate... The solution should be solvable during the first iteration of errn...

New update is here : https://www.cadtutor.net/forum/files/file/36-hipped-roof-routines/

ribarm · « **Reply #219 on:** July 20, 2023, 02:02:40 PM »

I had some spare time, so I've coded for smaller more concise version... But how story goes, what is short and quick it's more lackable... Still if someone want's to connect and improve, here is it...

Code - Auto/Visual Lisp: [Select]

(defun c:roof-new ( / *error* unit rlw offd inside-p collinear-p unique chkcircinside mc subprocess1 subprocess2 subprocess process done lw lwi lwx lwo ent enti lil lix lwnl ch el p1 p2 pp ppp ipp ippl vll vlli tll iplst iplstt iplsttt lst lstt ) ;;; cad, doc, spc, lay, vlll, vllli, tlll, tmp, f - global variables ;;;
 
  (vl-load-com)
 
  (defun *error* ( m )
    (if (and lwi (not (vlax-erased-p lwi)))
      (entdel lwi)
    )
    (if (and enti (not (vlax-erased-p enti)))
      (entdel enti)
    )
    (if (setq ppp (unique ppp))
      (foreach pp ppp
        (if (not (vl-some '(lambda ( x ) (and (not (equal (car x) pp 1e-6)) (not (equal (cadr x) pp 1e-6)) (not (equal (car x) (cadr x) 1e-6)) (collinear-p (car x) pp (cadr x)))) lil))
          (entmake (list (cons 0 "POINT") (cons 10 pp) (cons 62 1)))
        )
      )
    )
    (if (= ch "No")
      (while (setq el (entnext el))
        (if (and el (not (vlax-erased-p el)))
          (entdel el)
        )
      )
    )
    (if lil
      (foreach li lil
        (if (vl-some '(lambda ( x ) (and (not (equal (car li) x 1e-6)) (not (equal (cadr li) x 1e-6)) (not (equal (car li) (cadr li) 1e-6)) (collinear-p (car li) x (cadr li)))) ppp)
          (setq lil (vl-remove li lil))
          (if (vl-some '(lambda ( x ) (equal x (car li) 1e-6)) ppp)
            (entmake (list (cons 0 "LINE") (cons 10 (car li)) (cons 11 (cadr li)) (cons 62 3)))
          )
        )
      )
    )
    (command-s "_.-OVERKILL" "_ALL" "_T" "_Y" "" "")
    (if (= 8 (logand 8 (getvar 'undoctl)))
      (vla-endundomark doc)
    )
    (prompt "\nIf you want to start again on different sample, make sure you nil flag f : (setq f nil vlll nil vllli nil tlll nil tmp nil) ...")
    (if m
      (prompt m)
    )
    (princ)
  )
 
  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-6))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )
 
  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
                ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
                ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
                ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
                ((= (car a1) 210) (setq x6 (cons a1 x6)))
                (t (setq x1 (cons a1 x1)))
          )
        )
        (entmod (append (reverse x1)
                  (append (apply 'append
                            (apply 'mapcar
                              (cons 'list
                                (list x2
                                  (cdr (reverse (cons (car x3) (reverse x3))))
                                  (cdr (reverse (cons (car x4) (reverse x4))))
                                  (cdr (reverse (cons (car x5) (reverse x5))))
                                )
                              )
                            )
                          )
                          x6
                  )
                )
        )
        (entupd lw)
      )
    )
  )
 
  (defun offd ( sign ip tl / dl )
    (setq dl (mapcar '(lambda ( x )
                        (distance ip
                          (inters
                            ip
                            (polar ip (+ (* 0.5 pi) (angle (car x) (cadr x))) 1.0)
                            (car x)
                            (polar (car x) (angle (car x) (cadr x)) 1.0)
                            nil
                          )
                        )
                      ) tl
              )
    )
    (vl-some '(lambda ( x )
               (if
                 (>
                   (-
                     (length dl)
                     (length (vl-remove-if '(lambda ( y ) (equal x y 1.0)) dl))
                   ) 2
                 )
                 x
               )
             ) (vl-sort dl sign)
    )
  )
 
  (defun inside-p ( p lw lwi )
    (< (distance p (vlax-curve-getclosestpointto lwi p)) (distance p (vlax-curve-getclosestpointto lw p)))
  )
 
  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )
 
  (defun unique ( pl )
    (if pl
      (cons (car pl)
            (unique
              (vl-remove-if
                '(lambda ( x )
                   (equal x (car pl) 1e-6)
                 )
                (cdr pl)
              )
            )
      )
    )
  )
 
  (defun chkcircinside ( pp tll / d ci ipp ippl tst )
    (if (and pp tll)
      (progn
        (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 pp) (cons 40 (offd (function <) pp tll)))))
        (if (setq ipp (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object ent) acextendnone))
          (progn
            (while ipp
              (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
              (setq ipp (cdddr ipp))
            )
            (if (or (not ippl) (vl-every '(lambda ( x ) (inside-p x ent enti)) (apply 'append (mapcar '(lambda ( x ) (list (vlax-curve-getpointatparam ci (- x 0.1)) (vlax-curve-getpointatparam ci (+ x 0.1)))) (mapcar '(lambda ( x ) (vlax-curve-getparamatpoint ci x)) ippl)))))
              (setq tst t)
            )
          )
          (setq tst t)
        )
        (if (and ci (not (vlax-erased-p ci)))
          (entdel ci)
        )
      )
    )
    tst
  )
 
  (defun mc ( p lw / ci pl mp )
    (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 1.0))))
    (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
    (if (and ci (not (vlax-erased-p ci)))
      (entdel ci)
    )
    (setq mp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (list (car pl) (cadr pl)) (list (nth 3 pl) (nth 4 pl))))
    (list p mp)
  )
 
  (defun subprocess1 ( vl vli / ip ) ;;; iplst - lexical global variable
    (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
                          (if
                            (and
                              (setq ip (inters p1 p2 p3 p4 nil))
                              (inside-p ip ent enti)
                              (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
                              (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
                              (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
                              (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
                            )
                            (list ip (list p1 p3))
                            (list nil nil)
                          )
                        )
                        vl
                        vli
                        (append (cdr vl) (list (car vl)))
                        (append (cdr vli) (list (car vli)))
                )
    )
  )
 
  (defun subprocess2 ( p lw vl vli / ip lst lstt ) ;;; iplst - lexical global variable
    (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
                          (if
                            (and
                              (setq ip (inters p1 p2 p3 p4 nil))
                              (inside-p ip ent enti)
                              (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
                              (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
                              (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
                              (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
                            )
                            (list ip (list p1 p3))
                            (list nil nil)
                          )
                        )
                        vl
                        vli
                        (repeat (length vl) (setq lst (cons (car (mc p lw)) lst)))
                        (repeat (length vl) (setq lstt (cons (cadr (mc p lw)) lstt)))
                )
    )
  )
 
  (defun subprocess ( iplst / p1 p2 pp1 pp2 k i dd )
    (setq iplst (vl-remove-if '(lambda ( x ) (or (null (car x)) (null (cadr x)))) iplst))
    (setq iplstoffd (mapcar '(lambda ( x ) (if (and (car x) (cadr x))
                                             (list
                                               (mapcar '+ '(0.0 0.0) (car x))
                                               (mapcar '(lambda ( y ) (mapcar '+ '(0.0 0.0) y)) (cadr x))
                                               (offd (function <) (mapcar '+ '(0.0 0.0) (car x)) tlll)
                                             )
                                             (list nil nil nil)
                                           )
                             ) iplst
                    )
    )
    (setq iplstoffd (vl-remove-if '(lambda ( x ) (null (caddr x))) iplstoffd))
    (setq iplstoffd (vl-sort iplstoffd '(lambda ( a b ) (< (caddr a) (caddr b)))))
    (foreach ipd iplstoffd
      (if (not tmp)
        (setq tmp (offd (function <) (car ipd) tlll))
      )
      (if (and ipd (chkcircinside (car ipd) tlll) (<= tmp (setq tmp (offd (function <) (car ipd) tlll))))
        (progn
          (setq ppp (cons (car ipd) ppp))
          (if
            (and
              (setq p1
                (vl-some '(lambda ( x )
                  (if
                    (equal
                      (unit (mapcar '- (car ipd) x))
                      (unit (mapcar '- (car ipd) (caadr ipd)))
                      1e-6
                    )
                    x
                  )
                ) vll
                )
              )
              (setq pp1
                (vl-some '(lambda ( x )
                  (if
                    (equal
                      (unit (mapcar '- (car ipd) x))
                      (unit (mapcar '- (car ipd) p1))
                      1e-6
                    )
                    x
                  )
                ) vlll
                )
              )
            )
            (setq lil (cons (list (car ipd) pp1) lil))
            (if p1
              (setq lil (cons (list (car ipd) p1) lil))
              (setq lil (cons (list (car ipd) (caadr ipd)) lil))
            )
          )
          (if
            (and
              (setq p2
                (vl-some '(lambda ( x )
                  (if
                    (equal
                      (unit (mapcar '- (car ipd) x))
                      (unit (mapcar '- (car ipd) (cadadr ipd)))
                      1e-6
                    )
                    x
                  )
                ) vll
                )
              )
              (setq pp2
                (vl-some '(lambda ( x )
                  (if
                    (equal
                      (unit (mapcar '- (car ipd) x))
                      (unit (mapcar '- (car ipd) p2))
                      1e-6
                    )
                    x
                  )
                ) vlll
                )
              )
            )
            (setq lil (cons (list (car ipd) pp2) lil))
            (if p2
              (setq lil (cons (list (car ipd) p2) lil))
              (setq lil (cons (list (car ipd) (cadadr ipd)) lil))
            )
          )
          (setq k 1e-4 i 0)
          (while
            (and
              (caddr ipd)
              (setq dd (- (caddr ipd) (* k (setq i (1+ i)))))
              (setq lwnl (vl-catch-all-apply
                'vlax-invoke
                (list (vlax-ename->vla-object lw) 'offset (- dd))
              ))
              (if (vl-catch-all-error-p lwnl)
                (/= i 10)
              )
            )
          )
          (if (not (vl-catch-all-error-p lwnl))
            (setq lwnl (mapcar 'vlax-vla-object->ename lwnl))
            lwnl
          )
          (if (and (not (vl-catch-all-error-p lwnl)) (= (length lwnl) 1))
            (setq iplstt (cons (list (car ipd) (car lwnl)) iplstt))
          )
        )
      )
    )
    (setq tmp nil)
    lwnl
  )
 
  (defun process ( lw / lwi lwx vl vli iplst tl ipd iplstoffd p1 p2 pp lwnl ) ;;; vll ; vlli ; tll ; lwnl ; ppp ; iplstt - lexical global variables ;;;
    (if lw
      (progn
        (setq vl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw)))))
        (if (not vll)
          (setq vll vl)
        )
        (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
        (setq vli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lwi))))
        (if (not vlli)
          (setq vlli vli)
        )
        (setq tl (mapcar '(lambda ( a b ) (list a b)) vl (append (cdr vl) (list (car vl)))))
        (if (not tll)
          (setq tll tl)
        )
        (setq iplst (subprocess1 vl vli))
        (subprocess iplst)
        (setq iplst nil)
        (foreach pp iplstt
          (setq iplsttt (append iplsttt (subprocess2 (car pp) (cadr pp) vl vli)))
        )
        (subprocess iplsttt)
        (if (and lwi (not (vlax-erased-p lwi)))
          (entdel lwi)
        )
        lwnl
      )
    )
  )
 
  (or cad (progn (vl-load-com) (setq cad (vlax-get-acad-object))))
  (or doc (setq doc (vla-get-activedocument cad)))
  (or spc (setq spc (vla-get-block (setq lay (vla-get-activelayout doc)))))
 
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark doc)
  )
  (vla-startundomark doc)
  (if
    (and
      (setq lw (car (entsel "\nPick boundary closed polygonal LWPOLYLINE with only straight segments...")))
      (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE")
      (= 1 (logand 1 (cdr (assoc 70 lwx))))
      (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
      (setq el (entlast) ent lw)
    )
    (progn
      (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
      (if (> (vlax-curve-getarea lwi) (vlax-curve-getarea lw))
        (setq lw (rlw lw)) ;;; force main lwpolyline CCW - counter clockwise ;;;
      )
      (setq enti (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object ent) 'offset -1e-3))))
      (if (and lwi (not (vlax-erased-p lwi)))
        (entdel lwi)
      )
      (if (not f)
        (progn
          (setq vlll (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget ent))))
          (setq vllli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget enti))))
          (setq tlll (mapcar '(lambda ( a b ) (list a b)) vlll (append (cdr vlll) (list (car vlll)))))
          (setq f t)
        )
      )
      (initget "Yes No")
      (setq ch (cond ((getkword "\nDo you want points-offsets-lines or just lines [Yes / No] <Yes> - there are some lacks with just lines, so HIT ENTER : ")) ( "Yes" )))
      (while (not done)
        (if
          (and
            (not (vl-catch-all-error-p (setq lwnl (vl-catch-all-apply 'process (list lw)))))
            lwnl
          )
          (while (and (not done) (setq lww (car lwnl)))
            (setq lwnl (vl-remove lww lwnl))
            (setq lwo lww)
            (setq lwnl (vl-catch-all-apply 'process (list lww)))
            (if (vl-catch-all-error-p lwnl)
              (setq done t)
              (if (eq (car lwnl) lwo)
                (setq done t)
              )
            )
          )
          (setq done t)
        )
      ) ;;; main engine ;;;
    )
  )
  (*error* nil)
)
 

Regards, M.R.

ribarm · « **Reply #220 on:** July 21, 2023, 11:26:03 AM »

The lack that I see now and before is that that's built-in offset command... When I offset inside through point for example drawn inside point "P", offset LWPOLYLINE may pass and may not pass through and in that case usually it breaks to a few more smaller LWPOLYLINES...
So now problem consist in solving this task, upon solving and applying in my lastly posted code, solution should be successfuly created...

Any ideas are very welcomed...
Thanks for reading, M.R.

ribarm · « **Reply #221 on:** July 21, 2023, 12:41:49 PM »

I've created sub (offset-inside), but it doesn't help, especially as I don't quite know how to combine it with real offset command function...

Code: [Select]

THE CODE IS SOMEWHAT WORSE THAN PREVIOUSLY POSTED, SO I REMOVED IT FROM SITE...

So, who want's to find solution in his own manner is welcomed to step in...
M.R.

ribarm · « **Reply #222 on:** August 03, 2023, 02:04:42 PM »

I just wanted to put this topic back at top of list so it remains as not solved challenge... It should work fast and follow offset inside paths...
My latest version is example of short and efficient code, but it just gives partial ridge lines... Like I said, someone with more experiences should step in and try to correct it...
So long from me...
See you these days if you have something...

ribarm · « **Reply #223 on:** August 07, 2023, 02:32:23 PM »

I don't see any feedback...
What should I change in posted code... (C:ROOF-NEW)

Thanks for your advices if there are any newly ones...

ribarm · « **Reply #224 on:** August 08, 2023, 01:30:57 AM »

I've changed a bit, so now it looks better, but it goes in ~~infinite loops~~ and doesn't do what I predicted - from smallest offset then first just a little larger offset where points are met, and so on, so on... It seems that this topic is not so interesting, but now I feel that I am close to finish correct... It's just that PC doesn't want to operate as expected...

Code - Auto/Visual Lisp: [Select]

(defun c:roof-new-new ( / *error* unit rlw offd inside-p collinear-p unique chkcircinside mc preprocess1 preprocess2 rem-vllvlli subprocess process done lw lwi lwx lwo ent enti lil lix lwnl ch el p1 p2 pp ppp ipp ippl vll vlli tll iplst lst ) ;;; cad, doc, spc, lay, vlll, vllli, tlll, f - global variables ;;;
 
  (vl-load-com)
 
  (defun *error* ( m )
    (if (and lwi (not (vlax-erased-p lwi)))
      (entdel lwi)
    )
    (if (and enti (not (vlax-erased-p enti)))
      (entdel enti)
    )
    (if (setq ppp (unique ppp))
      (foreach pp ppp
        (if (not (vl-some '(lambda ( x ) (and (not (equal (car x) pp 1e-6)) (not (equal (cadr x) pp 1e-6)) (not (equal (car x) (cadr x) 1e-6)) (collinear-p (car x) pp (cadr x)))) lil))
          (entmake (list (cons 0 "POINT") (cons 10 pp) (cons 62 1)))
        )
      )
    )
    (if (= ch "No")
      (while (setq el (entnext el))
        (if (and el (not (vlax-erased-p el)))
          (entdel el)
        )
      )
    )
    (if lil
      (foreach li lil
        (if (vl-some '(lambda ( x ) (and (not (equal (car li) x 1e-6)) (not (equal (cadr li) x 1e-6)) (not (equal (car li) (cadr li) 1e-6)) (collinear-p (car li) x (cadr li)))) ppp)
          (setq lil (vl-remove li lil))
          (if (vl-some '(lambda ( x ) (equal x (car li) 1e-6)) ppp)
            (entmake (list (cons 0 "LINE") (cons 10 (car li)) (cons 11 (cadr li)) (cons 62 3)))
          )
        )
      )
    )
    (command-s "_.-OVERKILL" "_ALL" "_T" "_Y" "" "")
    (if (= 8 (logand 8 (getvar 'undoctl)))
      (vla-endundomark doc)
    )
    (prompt "\nIf you want to start again on different sample, make sure you nil flag f : (setq f nil vlll nil vllli nil tlll nil) ...")
    (if m
      (prompt m)
    )
    (princ)
  )
 
  (defun unit ( v / d )
    (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-6))
      (mapcar '(lambda ( x ) (/ x d)) v)
    )
  )
 
  (defun rlw ( lw / e x1 x2 x3 x4 x5 x6 )
    ;; by ElpanovEvgeniy
    (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
      (progn
        (foreach a1 e
          (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
                ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
                ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
                ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
                ((= (car a1) 210) (setq x6 (cons a1 x6)))
                (t (setq x1 (cons a1 x1)))
          )
        )
        (entmod (append (reverse x1)
                  (append (apply 'append
                            (apply 'mapcar
                              (cons 'list
                                (list x2
                                  (cdr (reverse (cons (car x3) (reverse x3))))
                                  (cdr (reverse (cons (car x4) (reverse x4))))
                                  (cdr (reverse (cons (car x5) (reverse x5))))
                                )
                              )
                            )
                          )
                          x6
                  )
                )
        )
        (entupd lw)
      )
    )
  )
 
  (defun offd ( sign ip tl / dl )
    (setq dl (mapcar '(lambda ( x )
                        (distance ip
                          (inters
                            ip
                            (polar ip (+ (* 0.5 pi) (angle (car x) (cadr x))) 1.0)
                            (car x)
                            (polar (car x) (angle (car x) (cadr x)) 1.0)
                            nil
                          )
                        )
                      ) tl
              )
    )
    (vl-some '(lambda ( x )
               (if
                 (>
                   (-
                     (length dl)
                     (length (vl-remove-if '(lambda ( y ) (equal x y 0.05)) dl))
                   ) 2
                 )
                 x
               )
             ) (vl-sort dl sign)
    )
  )
 
  (defun inside-p ( p lw lwi )
    (< (distance p (vlax-curve-getclosestpointto lwi p)) (distance p (vlax-curve-getclosestpointto lw p)))
  )
 
  (defun collinear-p ( p1 p p2 )
    (equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
  )
 
  (defun unique ( pl )
    (if pl
      (cons (car pl)
            (unique
              (vl-remove-if
                '(lambda ( x )
                   (equal x (car pl) 1e-6)
                 )
                (cdr pl)
              )
            )
      )
    )
  )
 
  (defun chkcircinside ( pp tll / d ci ipp ippl tst )
    (if (and pp tll)
      (progn
        (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 pp) (cons 40 (offd (function <) pp tll)))))
        (if (setq ipp (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object ent) acextendnone))
          (progn
            (while ipp
              (setq ippl (cons (list (car ipp) (cadr ipp) (caddr ipp)) ippl))
              (setq ipp (cdddr ipp))
            )
            (if (or (not ippl) (vl-every '(lambda ( x ) (inside-p x ent enti)) (apply 'append (mapcar '(lambda ( x ) (list (vlax-curve-getpointatparam ci (- x 0.1)) (vlax-curve-getpointatparam ci (+ x 0.1)))) (mapcar '(lambda ( x ) (vlax-curve-getparamatpoint ci x)) ippl)))))
              (setq tst t)
            )
          )
          (setq tst t)
        )
        (if (and ci (not (vlax-erased-p ci)))
          (entdel ci)
        )
      )
    )
    tst
  )
 
  (defun mc ( p lw / ci pl mp )
    (setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 p) (cons 40 1.0))))
    (setq pl (vlax-invoke (vlax-ename->vla-object ci) 'intersectwith (vlax-ename->vla-object lw) acextendnone))
    (if (and ci (not (vlax-erased-p ci)))
      (entdel ci)
    )
    (setq mp (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) (list (car pl) (cadr pl)) (list (nth 3 pl) (nth 4 pl))))
    (list p mp)
  )
 
  (defun preprocess1 ( vl vli / ip ) ;;; iplst - lexical global variable
    (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
                          (if
                            (and
                              (setq ip (inters p1 p2 p3 p4 nil))
                              (inside-p ip ent enti)
                              (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
                              (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
                              (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
                              (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
                            )
                            (list ip (list p1 p3))
                            (list nil nil)
                          )
                        )
                        vl
                        vli
                        (append (cdr vl) (list (car vl)))
                        (append (cdr vli) (list (car vli)))
                )
    )
    iplst
  )
 
  (defun preprocess2 ( vl vli / ip ) ;;; iplst - lexical global variable
    (setq iplst (mapcar '(lambda ( p1 p2 p3 p4 / ip )
                          (if
                            (and
                              (setq ip (inters p1 p2 p3 p4 nil))
                              (inside-p ip ent enti)
                              (equal (unit (mapcar '- ip p1)) (unit (mapcar '- p2 p1)) 1e-6)
                              (equal (unit (mapcar '- ip p3)) (unit (mapcar '- p4 p3)) 1e-6)
                              (inside-p (mapcar '+ p1 (mapcar '* (unit (mapcar '- ip p1)) (list 1e-2 1e-2))) ent enti)
                              (inside-p (mapcar '+ p3 (mapcar '* (unit (mapcar '- ip p3)) (list 1e-2 1e-2))) ent enti)
                            )
                            (list ip (list p1 p3))
                            (list nil nil)
                          )
                        )
                        vl
                        vli
                        (mapcar '(lambda ( x ) (car (mc (caar lil) (car lwnl)))) vl)
                        (mapcar '(lambda ( x ) (cadr (mc (caar lil) (car lwnl)))) vli)
                )
    )
    iplst
  )
 
  (defun rem-vllvlli ( lil lwnl )
    (if (vl-some '(lambda ( x ) (equal x (cadr (car lil)) 1e-2)) vll)
      (progn
        (setq vll (vl-remove-if '(lambda ( x ) (equal (cadr (car lil)) x 1e-2)) vll))
        (setq vlli (vl-remove-if '(lambda ( x ) (equal (cadr (car lil)) x 1e-2)) vlli))
      )
    )
    (if (vl-some '(lambda ( x ) (equal x (cadr (cadr lil)) 1e-2)) vll)
      (progn
        (setq vll (vl-remove-if '(lambda ( x ) (equal (cadr (cadr lil)) x 1e-2)) vll))
        (setq vlli (vl-remove-if '(lambda ( x ) (equal (cadr (cadr lil)) x 1e-2)) vlli))
      )
    )
  )
 
  (defun subprocess ( iplst / p1 p2 pp1 pp2 )
    (setq iplst (vl-remove-if '(lambda ( x ) (or (null (car x)) (null (cadr x)))) iplst))
    (setq iplstoffd (mapcar '(lambda ( x ) (if (and (car x) (cadr x))
                                             (list
                                               (mapcar '+ '(0.0 0.0) (car x))
                                               (mapcar '(lambda ( y ) (mapcar '+ '(0.0 0.0) y)) (cadr x))
                                               (offd (function <) (mapcar '+ '(0.0 0.0) (car x)) tlll)
                                             )
                                             (list nil nil nil)
                                           )
                             ) iplst
                    )
    )
    (setq iplstoffd (vl-remove-if '(lambda ( x ) (null (caddr x))) iplstoffd))
    (setq iplstoffd (vl-sort iplstoffd '(lambda ( a b ) (< (caddr a) (caddr b)))))
    (if (not (vl-position (car iplstoffd) lst))
      (setq ipd (car iplstoffd) lst (cons ipd lst))
      (progn
        (setq iplstoffd (cdr (member (car lst) iplstoffd)))
        (setq ipd (car iplstoffd) lst (cons ipd lst))
      )
    )
    (if (and ipd (chkcircinside (car ipd) tlll))
      (progn
        (setq ppp (cons (car ipd) ppp))
        (if
          (and
            (setq p1
              (vl-some '(lambda ( x )
                (if
                  (equal
                    (unit (mapcar '- (car ipd) x))
                    (unit (mapcar '- (car ipd) (caadr ipd)))
                    1e-6
                  )
                  x
                )
              ) vll
              )
            )
            (setq pp1
              (vl-some '(lambda ( x )
                (if
                  (equal
                    (unit (mapcar '- (car ipd) x))
                    (unit (mapcar '- (car ipd) p1))
                    1e-6
                  )
                  x
                )
              ) vlll
              )
            )
          )
          (setq lil (cons (list (car ipd) pp1) lil))
          (if p1
            (setq lil (cons (list (car ipd) p1) lil))
            (setq lil (cons (list (car ipd) (caadr ipd)) lil))
          )
        )
        (if
          (and
            (setq p2
              (vl-some '(lambda ( x )
                (if
                  (equal
                    (unit (mapcar '- (car ipd) x))
                    (unit (mapcar '- (car ipd) (cadadr ipd)))
                    1e-6
                  )
                  x
                )
              ) vll
              )
            )
            (setq pp2
              (vl-some '(lambda ( x )
                (if
                  (equal
                    (unit (mapcar '- (car ipd) x))
                    (unit (mapcar '- (car ipd) p2))
                    1e-6
                  )
                  x
                )
              ) vlll
              )
            )
          )
          (setq lil (cons (list (car ipd) pp2) lil))
          (if p2
            (setq lil (cons (list (car ipd) p2) lil))
            (setq lil (cons (list (car ipd) (cadadr ipd)) lil))
          )
        )
        (if
          (and
            (caddr ipd)
            (setq lwnl (vl-catch-all-apply
              'vlax-invoke
              (list (vlax-ename->vla-object lw) 'offset (- (caddr ipd)))
            ))
          )
          (if (and lwnl (not (vl-catch-all-error-p lwnl)))
            (setq lwnl (mapcar 'vlax-vla-object->ename lwnl))
            (setq done t)
          )
        )
        (cond
          ( (and lwnl (not (vl-catch-all-error-p lwnl)) (= (length lwnl) 1))
            (rem-vllvlli lil lwnl)
          )
          ( (and lwnl (not (vl-catch-all-error-p lwnl)) (> (length lwnl) 1))
            (setq lwnl (vl-sort lwnl '(lambda ( a b ) (< (distance (car ipd) (vlax-curve-getclosestpointto a (car ipd))) (distance (car ipd) (vlax-curve-getclosestpointto b (car ipd)))))))
            (rem-vllvlli lil lwnl)
          )
        )
      )
    )
    lwnl
  )
 
  (defun process ( lw / lwi lwx vl vli iplst tl lwnl ) ;;; vll, vlli, tll, lwnl, ppp, done - lexical global variables ;;;
    (if lw
      (progn
        (setq vl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (setq lwx (entget lw)))))
        (if (not vll)
          (setq vll vl)
        )
        (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
        (setq vli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lwi))))
        (if (not vlli)
          (setq vlli vli)
        )
        (setq tl (mapcar '(lambda ( a b ) (list a b)) vl (append (cdr vl) (list (car vl)))))
        (if (not tll)
          (setq tll tl)
        )
        (repeat (* 5 (length vll))
          (setq iplst nil)
          (setq iplst (preprocess1 vll vlli))
          (subprocess iplst)
          (setq iplst nil)
          (setq iplst (preprocess2 vll vlli))
          (subprocess iplst)
        )
        (if (and lwi (not (vlax-erased-p lwi)))
          (entdel lwi)
        )
        lwnl
      )
    )
  )
 
  (or cad (progn (vl-load-com) (setq cad (vlax-get-acad-object))))
  (or doc (setq doc (vla-get-activedocument cad)))
  (or spc (setq spc (vla-get-block (setq lay (vla-get-activelayout doc)))))
 
  (if (= 8 (logand 8 (getvar 'undoctl)))
    (vla-endundomark doc)
  )
  (vla-startundomark doc)
  (if
    (and
      (setq lw (car (entsel "\nPick boundary closed polygonal LWPOLYLINE with only straight segments...")))
      (= (cdr (assoc 0 (setq lwx (entget lw)))) "LWPOLYLINE")
      (= 1 (logand 1 (cdr (assoc 70 lwx))))
      (vl-every '(lambda ( x ) (= 0.0 (cdr x))) (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
      (setq el (entlast) ent lw)
    )
    (progn
      (setq lwi (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object lw) 'offset -1e-3))))
      (if (> (vlax-curve-getarea lwi) (vlax-curve-getarea lw))
        (setq lw (rlw lw)) ;;; force main lwpolyline CCW - counter clockwise ;;;
      )
      (setq enti (vlax-vla-object->ename (car (vlax-invoke (vlax-ename->vla-object ent) 'offset -1e-3))))
      (if (and lwi (not (vlax-erased-p lwi)))
        (entdel lwi)
      )
      (if (not f)
        (progn
          (setq vlll (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget ent))))
          (setq vllli (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget enti))))
          (setq tlll (mapcar '(lambda ( a b ) (list a b)) vlll (append (cdr vlll) (list (car vlll)))))
          (setq f t)
        )
      )
      (initget "Yes No")
      (setq ch (cond ( (getkword "\nDo you want points-offsets-lines or just lines [Yes / No] <Yes> : ") ) ( "Yes" )))
      (while (not done)
        (if
          (and
            (not (vl-catch-all-error-p (setq lwnl (vl-catch-all-apply 'process (list lw)))))
            lwnl
          )
          (while (and (not done) (setq lww (car (vl-sort lwnl '(lambda ( a b ) (> (vlax-curve-getarea a) (vlax-curve-getarea b)))))))
            (setq lwnl (vl-remove lww lwnl))
            (setq lwo lww)
            (setq lwnl (vl-catch-all-apply 'process (list lww)))
            (if (vl-catch-all-error-p lwnl)
              (setq done t)
              (if (eq (car lwnl) lwo)
                (setq done t)
              )
            )
          )
          (setq done t)
        )
      ) ;;; main engine ;;;
    )
  )
  (*error* nil)
)
 

Regards, M.R.

News:

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

pkohut

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

pkohut

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof

ribarm

Re: ==={Challenge}===Find the ridge lines of sloped roof