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

MSTG007 · « **Reply #165 on:** September 25, 2018, 07:42:18 AM »

Nice Job!

ribarm · « **Reply #166 on:** September 25, 2018, 07:48:36 AM »

Quote from: MSTG007 on September 25, 2018, 07:42:18 AM

Nice Job!

Thanks...

ribarm · « **Reply #167 on:** October 01, 2018, 09:05:00 AM »

Variations on the same theme... Basically 2droof-final-new.lsp is now the same as 2droof-final-n-m-loop.lsp... I named new lisps by iteration priorities - so n is first which means that it iterates firstly, then m, and last loop... Based on those 3 variable that iterate over and over until process is finished there are 6 combinations... Still I leaved 2droof-final-new.lsp, but now it firstly looks for best loop and then process only that loop... There is also 2droof-final-new-looplst.lsp that looks for all best loops and then process them all - like shorter version of 2droof-final-n-m-loop.lsp... Also I made modifications to 2droof-final-quick.lsp - now it expects correct input combination and reports solution success percentage... All in all main code is unchanged - it still can't solve roof-ultimate-test.dwg... I tested loop=42 which was found by 2droof-final-new.lsp as best and success percentage was only 90/102 found closed ridges boundaries, so it's almost no need for calculations - loop=1, errn=0, errm=0 is 89/102 success... I think based on picture chlh_jd posted that he has something better as my output isn't the same as his, but I think that some new replies won't happen unless there is good will from him as an author...
So long for now from me - everything is in *.lsp form and hopefully you can make mods if you find some lacks in my interventions...
Regards, M.R.

pedroantonio · « **Reply #168 on:** October 01, 2018, 10:08:21 AM »

Hi ribarm. I think that your code for the roofs is perfect. No one will use it for something so complicated like your example.

Nice job

ribarm · « **Reply #169 on:** October 01, 2018, 10:40:58 AM »

I had some mistake in 2droof-final-new.lsp and 2droof-final-new-looplst.lsp, so I reattached *.zip in my previous post... Actually roof-ultimate-test.dwg was tested on 42 loop and it did find best of that loop and that is errn=8 and errm=0... When you test it with 2droof-final-quick.lsp and input those parameters, solution success should be 99/102 with some lines crossing... So routines are good I think now - I just moved one paragraph just after (if (<= errm nnn) (progn ...) ... ) to the end of that progn... I think that with that quick fix it should output result correctly...

ribarm · « **Reply #170 on:** October 01, 2018, 11:06:48 AM »

No that quick fix was wrong... Reattached *.zip, I think that now it's all fine...

[EDIT : One more reattach... Sorry, lack of concentration...]

pedroantonio · « **Reply #171 on:** October 01, 2018, 12:14:08 PM »

You have 9 lisp routins. What lisp is the best to use ?

ribarm · « **Reply #172 on:** October 01, 2018, 01:02:57 PM »

Quote from: Topographer on October 01, 2018, 12:14:08 PM

You have 9 lisp routins. What lisp is the best to use ?

If you don't have time, then this order :
1. 2droof-final-quick.lsp
2. 2droof-final-new.lsp
3. 2droof-final-new-looplst.lsp - I would still avoid 3. and 4. - it's time consuming...
4. 2droof-final-n-m-loop.lsp - you don't know correct combination of errn, errm, loop so you have to wait until you get it, or if not possible until you get best combination of elapsed time...
4-9. other lisps are just variations - you don't know combination so you practically can't figure out which one is the best to apply...

If reference polyline is too complex like roof-ultimate-test.dwg, after 1. and 2., the best is to use my roof-mr-3dlines-convex+concave.vlx posted earlier on page 11...

ribarm · « **Reply #173 on:** October 02, 2018, 07:27:54 AM »

Reattached *.zip, found again some mistakes...

M.R.

ahsattarian · « **Reply #174 on:** December 29, 2020, 01:58:06 PM »

This is Modified of the lisps :

ribarm · « **Reply #175 on:** January 03, 2021, 03:40:20 PM »

Here is one version I wrote, but it's somewhat quirky... The main problem with this is that it's too slow, but I hope it's good for studying... We'll be grateful if someone could improve it...

Regards, all the best, M.R.

Code - Auto/Visual Lisp: [Select]

(defun c:2droof ( / unique mid clockwise-p LM:Inside-p processpla distp2t removesingles findipinterschilds processtxtipl process lw ti n pl tl tlo pla plaa ipl ipll ipldtl ipldtlo ip p1p2 tt t1 t2 a f lil txtipl tll d al iplo p pal fff ipp lipl dd ippp ipo )
 
  (defun unique ( l )
    (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l))))
  )
 
  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
  )
 
  (defun clockwise-p ( p1 p2 p3 )
    (minusp (sin (- (angle p1 p3) (angle p1 p2))))
  )
 
  (defun LM:Inside-p ( pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp )
 
    (vl-load-com)
 
    (defun unit ( v / d )
      (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
        (mapcar '(lambda ( x ) (/ x d)) v)
      )
    )
 
    (defun v^v ( u v )
      (list
        (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
        (- (* (caddr u) (car v)) (* (car u) (caddr v)))
        (- (* (car u) (cadr v)) (* (cadr u) (car v)))
      )
    )
 
    (defun _GroupByNum ( l n / r )
      (if l
        (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
      )
    )
 
    (if (= (type ent) 'VLA-OBJECT)
      (setq obj ent
            ent (vlax-vla-object->ename ent))
      (setq obj (vlax-ename->vla-object ent))
    )
 
    (if (vlax-curve-isplanar ent)
      (progn
        (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
        (while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (unit (v^v fd1 fd2))))))
        (setq lst
          (_GroupByNum
            (vlax-invoke
              (setq tmp
                (vlax-ename->vla-object
                  (entmakex
                    (list
                      (cons 0 "RAY")
                      (cons 100 "AcDbEntity")
                      (cons 100 "AcDbRay")
                      (cons 10 pt)
                      (cons 11 (trans '(1. 0. 0.) nrm 0))
                    )
                  )
                )
              )
              'IntersectWith obj acextendnone
            ) 3
          )
        )
        (vla-delete tmp)
        ;; gile:
        (and
          lst
          (not (vlax-curve-getparamatpoint ent pt))
          (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
                                                      (setq pa (vlax-curve-getparamatpoint ent p))
                                                      (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                           (trans p- 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                           (trans p+ 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p0 (trans pt 0 nrm))
                                                           (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                      )
                                                    )
                                          ) lst
                            )
                    ) 2
               )
          )
        )
      )
    )
  )
 
  (defun processpla ( pla / ipl pla1 pla2 )
    (setq pla1 pla)
    (foreach p1 pla1
      (setq pla2 (vl-remove p1 pla1))
      (foreach p2 pla2
        (setq ipl (cons (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) ipl))
      )
    )
    (setq ipl (vl-remove-if-not '(lambda ( p ) (LM:Inside-p p lw)) (vl-remove nil ipl)))
  )
 
  (defun distp2t ( p tt )
    (distance p (inters p (polar p (+ (angle (car tt) (cadr tt)) (* 0.5 pi)) 1.0) (car tt) (cadr tt) nil))
  )
 
  (defun removesingles ( l / a )
    (while (setq a (vl-some '(lambda ( x ) (if (= (1- (length l)) (length (vl-remove-if '(lambda ( y ) (equal x y 1e-6)) l))) x)) l))
      (setq l (vl-remove a l))
    )
    l
  )
 
  (defun findipinterschilds ( ip pla / pla1 pla2 r )
    (setq pla1 pla)
    (foreach p1 pla1
      (setq pla2 (vl-remove p1 pla1))
      (foreach p2 pla2
        (if (equal ip (inters (car p1) (polar (car p1) (cadr p1) 1e+99) (car p2) (polar (car p2) (cadr p2) 1e+99) t) 1e-6)
          (setq r (list p1 p2))
        )
      )
    )
    r
  )
 
  (defun processtxtipl ( tl / ipl tl1 tl2 )
    (setq tl1 tl)
    (foreach t1 tl1
      (setq tl2 (vl-remove t1 tl1))
      (foreach t2 tl2
        (setq ipl (cons (inters (car t1) (polar (car t1) (angle (car t1) (cadr t1)) 1.0) (car t2) (polar (car t2) (angle (car t2) (cadr t2)) 1.0) nil) ipl))
      )
    )
    (setq ipl (vl-remove nil ipl))
  )
 
  (defun process nil
    (setq d (car (cadr (car (vl-member-if '(lambda ( x ) (equal (car x) ip 1e-6)) ipldtl)))))
    (if (null d)
      (setq d (car (cadr (car (vl-member-if '(lambda ( x ) (equal (car x) ip 1e-6)) ipldtlo)))))
    )
    (if ip
      (setq p1p2 (findipinterschilds ip pla))
      (setq p1p2 nil)
    )
    (setq f nil)
    (if p1p2
      (progn
        (setq tt (vl-some '(lambda ( x ) (if (and (assoc (car x) p1p2) (assoc (cadr x) p1p2)) (progn (setq f t) x))) tl))
        (if (or (vl-some '(lambda ( x ) (equal (distance ip (car (car p1p2))) (+ (distance ip x) (distance x (car (car p1p2)))) 1e-6)) (vl-remove (car (car p1p2)) (vl-remove ip (mapcar 'car ipldtl)))) (vl-some '(lambda ( x ) (equal (distance ip (car (cadr p1p2))) (+ (distance ip x) (distance x (car (cadr p1p2)))) 1e-6)) (vl-remove (car (cadr p1p2)) (vl-remove ip (mapcar 'car ipldtl)))))
          (setq f nil)
        )
      )
    )
  )
 
  (setq lw (car (entsel)))
  (setq ti (car (_vl-times)))
  (setq n (cdr (assoc 90 (entget lw))))
  (setq pl (mapcar 'cdr (vl-remove-if '(lambda ( x ) (/= (car x) 10)) (entget lw))))
  (setq tl (mapcar '(lambda ( a b ) (list a b)) pl (append (cdr pl) (list (car pl)))))
  (setq tlo tl)
  (setq pla (mapcar '(lambda ( p mp ) (list p (angle p mp))) pl (mapcar '(lambda ( a b ) (if (clockwise-p (car a) (car b) (cadr b)) (mid (polar (cadr a) (angle (cadr a) (car a)) -1.0) (polar (car b) (angle (car b) (cadr b)) -1.0)) (mid (polar (cadr a) (angle (cadr a) (car a)) 1.0) (polar (car b) (angle (car b) (cadr b)) 1.0)))) (cons (last tl) tl) tl)))
  (setq plaa pla)
  (while (> n 0)
    (if (null ipll)
      (setq ipl (processpla plaa))
      (setq ipl (processpla pla))
    )
    (if (equal ipl iplo 1e-6)
      (setq n 0)
    )
    (if fff
      (progn
        (setq pl (mapcar 'car pla))
        (foreach x pl
          (setq lil (cons (list x ip) lil))
        )
        (setq n 0)
      )
      (progn
        (if (null ipll)
          (progn
            (setq ipldtlo (mapcar '(lambda ( p ) (list p (vl-sort (mapcar '(lambda ( tt ) (distp2t p tt)) tlo) '<))) ipl))
            (setq ipldtlo (mapcar '(lambda ( x ) (list (car x) (removesingles (cadr x)))) ipldtlo))
            (setq ipldtlo (vl-remove-if '(lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if '(lambda ( y ) (equal y (car (cadr x)) 1e-6)) (cadr x)))) 3)) ipldtlo))
          )
          (progn
            (setq ipldtl (mapcar '(lambda ( p ) (list p (vl-sort (mapcar '(lambda ( tt ) (distp2t p tt)) tlo) '<))) ipl))
            (setq ipldtl (mapcar '(lambda ( x ) (list (car x) (removesingles (cadr x)))) ipldtl))
            (setq ipldtl (vl-remove-if '(lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if '(lambda ( y ) (equal y (car (cadr x)) 1e-6)) (cadr x)))) 3)) ipldtl))
            (if ipll
              (setq ipldtl (unique (vl-remove-if '(lambda ( x ) (vl-member-if '(lambda ( y ) (equal (car x) y 1e-6)) ipll)) ipldtl)))
            )
          )
        )
        (setq ipldtlo (vl-remove-if '(lambda ( x ) (vl-position (car x) ipll)) ipldtlo))
        (setq ip (car (car (vl-sort ipldtlo '(lambda ( a b ) (< (car (cadr a)) (car (cadr b))))))))
        (setq ipldtlo (vl-remove-if '(lambda ( x ) (equal (car x) ip 1e-6)) ipldtlo))
        (setq d (car (cadr (car (vl-member-if '(lambda ( x ) (equal (car x) ip 1e-6)) ipldtlo)))))
        (setq ipp nil dd nil ipo nil)
        (if (progn (process) (not f))
          (if ipll
            (progn
              (setq ipo ip)
              (foreach y (reverse pal)
                (setq ipp (cons (vl-remove-if-not '(lambda ( x ) (vl-some '(lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6))) (cadr y))) (mapcar 'car (vl-sort ipldtl '(lambda ( a b ) (> (car (cadr a)) (car (cadr b))))))) ipp))
              )
              (setq dd 1e+99)
              (mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (and (< (distance xx y) dd) (not (vl-some '(lambda ( a ) (vl-some '(lambda ( b ) (equal (distance xx a) (+ (distance xx b) (distance b a)) 1e-6)) (vl-remove xx (vl-remove a (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (vl-remove xx (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
            )
          )
        )
        (if (equal ip ipo 1e-6)
          (progn
            (setq dd 1e+99)
            (mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (< (distance xx y) dd) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
          )
        )
        (if (vl-every '(lambda ( x ) (equal ip (inters (car (car pla)) (polar (car (car pla)) (cadr (car pla)) 1.0) (car x) (polar (car x) (cadr x) 1.0) nil) 1e-6)) (cdr pla))
          (setq fff t)
        )
        (setq al nil a nil)
        (process)
        (if (and tt f)
          (progn
            (setq tl (vl-remove tt tl))
            (setq n (1- n))
          )
        )
        (if f
          (progn
            (setq t1 (vl-some '(lambda ( x ) (if (or (assoc (car x) (list (car p1p2))) (assoc (cadr x) (list (car p1p2)))) x)) tl))
            (setq t2 (vl-some '(lambda ( x ) (if (or (assoc (car x) (list (cadr p1p2))) (assoc (cadr x) (list (cadr p1p2)))) x)) tl))
          )
          (setq t1 nil t2 nil)
        )
        (if ip
          (setq ipll (cons ip ipll))
        )
        (if (and t1 t2)
          (progn
            (setq a (angle (inters (car t1) (cadr t1) (car t2) (cadr t2) nil) ip))
            (if a
              (progn
                (setq pla (cons (list ip a) pla))
                (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
                (setq lil (cons (list (car (car p1p2)) ip) lil))
                (setq lil (cons (list (car (cadr p1p2)) ip) lil))
                (setq pal (cons (list ip (list a)) pal))
              )
            )
          )
          (if (and ip (null fff))
            (progn
              (setq lil (cons (list (car (car p1p2)) ip) lil))
              (setq lil (cons (list (car (cadr p1p2)) ip) lil))
              (if (setq p (vl-some '(lambda ( x ) (if (vl-position x plaa) x)) p1p2))
                (progn
                  (setq n (1- n))
                  (setq tll (vl-remove-if-not '(lambda ( x ) (vl-some '(lambda ( y ) (vl-member-if '(lambda ( z ) (equal z p 1e-6)) y)) x)) tlo))
                  (setq tll (car (vl-remove-if-not '(lambda ( x ) (and (vl-member-if '(lambda ( y ) (equal y (car x) 1e-6)) (vl-remove nil (mapcar 'car lil))) (vl-member-if '(lambda ( y ) (equal y (cadr x) 1e-6)) (vl-remove nil (mapcar 'car lil))))) tll)))
                  (setq tl (vl-remove tll tl))
                )
              )
              (setq tll (vl-remove-if-not '(lambda ( x ) (equal d (distp2t ip x) 1e-6)) tl))
              (setq txtipl (processtxtipl tll))
              (setq txtipl (vl-remove-if '(lambda ( x ) (vl-member-if '(lambda ( y ) (equal x y 1e-6)) pl)) txtipl))
              (setq al (mapcar '(lambda ( p ) (angle p ip)) txtipl))
              (setq al (vl-remove-if '(lambda ( x ) (vl-member-if '(lambda ( y ) (equal x (cadr y) 1e-6)) p1p2)) al))
              (setq al (unique al))
              (if al
                (progn
                  (setq pla (append pla (mapcar '(lambda ( a ) (list ip a)) al)))
                  (setq pal (cons (list ip al) pal))
                )
              )
              (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
            )
          )
        )
      )
    )
    (setq iplo ipl)
  )
  (setq lil (vl-remove-if '(lambda ( x ) (equal (car x) (cadr x) 1e-6)) lil))
  (setq lil (unique lil))
  (setq lil (vl-remove-if '(lambda ( x ) (vl-some '(lambda ( y ) (null y)) x)) lil))
  (setq lipl (apply 'append lil))
  (setq lipl (unique (vl-remove-if '(lambda ( x ) (or (= (length (vl-remove x lipl)) (1- (length lipl))) (= (length (vl-remove x lipl)) (- (length lipl) 3)))) lipl)))
  (if lipl
    (setq lil (cons (list (car lipl) (cadr lipl)) lil))
  )
  (foreach li lil
    (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (cadr li))))
  )
  (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  (princ)
)
 

ribarm · « **Reply #176 on:** January 05, 2021, 12:46:02 PM »

I've revised the code a little, but I see that no one is interested... It can't operate with orthogonal shapes, which are typical roof solutions, but it can do simple random polygons - concave+convex... It is horribly slow and it is incorrect with complex shapes like roof-ultimate.dwg I posted... I tested it and with that, but it took almost 4 hours on my slow PC and solution is not even close to existing routine by ch_lhjd... So don't test it until you're 100% sure it's fine...
In my observations, the main problem is finding "ip" point - here is tricky part of the code :

Code: [Select]

...
        (setq ipp nil dd nil ipo nil)
        (if (progn (process) (not f))
          (if ipll
            (progn
              (setq ipo ip)
              (foreach y (reverse pal)
                (setq ipp (cons (vl-remove-if-not '(lambda ( x ) (vl-some '(lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6))) (cadr y))) (mapcar 'car (vl-sort ipldtl '(lambda ( a b ) (> (car (cadr a)) (car (cadr b))))))) ipp))
              )
              (setq dd 1e+99)
              (mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (and (< (distance xx y) dd) (not (vl-some '(lambda ( a ) (vl-some '(lambda ( b ) (equal (distance xx a) (+ (distance xx b) (distance b a)) 1e-6)) (vl-remove xx (vl-remove a (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (vl-remove xx (append (mapcar 'car pal) (mapcar 'car ipldtl)))))) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
            )
          )
        )
        ;;;;; This portion that follows is crucial, but I can't discover how to get correct ip from list ipp - it may be that some of points from ipp are good and some are bad... ;;;;;;
        (if (equal ip ipo 1e-6)
          (progn
            (setq dd 1e+99)
            (mapcar '(lambda ( x y ) (if x (mapcar '(lambda ( xx ) (if (< (distance xx y) dd) (setq dd (distance xx y) ip xx))) x))) ipp (mapcar 'car pal))
          )
        )
...

ribarm · « **Reply #177 on:** January 05, 2021, 05:07:15 PM »

I've changed a code once again just a little, and perhaps this is better, but I doubt...

Code: [Select]

...
        (if (equal ip ipo 1e-6)
          (progn
            (setq ipp (apply 'append ipp))
            (setq ipp (mapcar '(lambda ( p ) (list p (findipinterschilds p pla))) ipp))
            (setq ip (car (car (vl-sort ipp '(lambda ( a b ) (< (+ (distance (car a) (car (mapcar 'car (cadr a)))) (distance (car a) (cadr (mapcar 'car (cadr a))))) (+ (distance (car b) (car (mapcar 'car (cadr b)))) (distance (car b) (cadr (mapcar 'car (cadr b)))))))))))
          )
        )
...

ribarm · « **Reply #178 on:** January 06, 2021, 12:00:33 AM »

Here is how my ultimate-test looks like after almost 5 hours of calculations...
So advice, don't test it on complex samples until algorithm is fully correct...

M.R.

ribarm · « **Reply #179 on:** January 06, 2021, 04:19:01 AM »

I've optimized my version and now it's faster, but not very... At least I did what was possible and I could do...

Code - Auto/Visual Lisp: [Select]

(defun c:2droof ( / unique mid clockwise-p LM:Inside-p processpla distp2t removesingles findipinterschilds processtxtipl process _vl-position car-sort car-vl-member-if lw ti n pl tl tlo pla plaa ipl ipll ipldtl ipldtlo ip p1p2 tt t1 t2 a f lil txtipl tll d al iplo p pal fff ipp lipl dd ippp ipo )
 
  (defun unique ( l )
    (if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
  )
 
  (defun mid ( p1 p2 )
    (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
  )
 
  (defun clockwise-p ( p1 p2 p3 )
    (minusp (sin (- (angle p1 p3) (angle p1 p2))))
  )
 
  (defun LM:Inside-p ( pt ent / unit v^v _GroupByNum fd1 fd2 par lst nrm obj tmp )
 
    (vl-load-com)
 
    (defun unit ( v / d )
      (if (not (equal (setq d (distance '(0.0 0.0 0.0) v)) 0.0 1e-8))
        (mapcar (function (lambda ( x ) (/ x d))) v)
      )
    )
 
    (defun v^v ( u v )
      (list
        (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
        (- (* (caddr u) (car v)) (* (car u) (caddr v)))
        (- (* (car u) (cadr v)) (* (cadr u) (car v)))
      )
    )
 
    (defun _GroupByNum ( l n / r )
      (if l
        (cons (reverse (repeat n (setq r (cons (car l) r) l (cdr l)) r)) (_GroupByNum l n))
      )
    )
 
    (if (= (type ent) 'VLA-OBJECT)
      (setq obj ent
            ent (vlax-vla-object->ename ent))
      (setq obj (vlax-ename->vla-object ent))
    )
 
    (if (vlax-curve-isplanar ent)
      (progn
        (setq fd1 (vlax-curve-getfirstderiv ent (setq par (vlax-curve-getstartparam ent))))
        (while (or (equal fd1 (setq fd2 (vlax-curve-getfirstderiv ent (setq par (+ par 0.001)))) 1e-3) (null (setq nrm (unit (v^v fd1 fd2))))))
        (setq lst
          (_GroupByNum
            (vlax-invoke
              (setq tmp
                (vlax-ename->vla-object
                  (entmakex
                    (list
                      (cons 0 "RAY")
                      (cons 100 "AcDbEntity")
                      (cons 100 "AcDbRay")
                      (cons 10 pt)
                      (cons 11 (trans '(1. 0. 0.) nrm 0))
                    )
                  )
                )
              )
              'IntersectWith obj acextendnone
            ) 3
          )
        )
        (vla-delete tmp)
        ;; gile:
        (and
          lst
          (not (vlax-curve-getparamatpoint ent pt))
          (= 1 (rem (length (vl-remove-if (function (lambda ( p / pa p- p+ p0 )
                                                      (setq pa (vlax-curve-getparamatpoint ent p))
                                                      (and (setq p- (cond ((setq p- (vlax-curve-getPointatParam ent (- pa 1e-8)))
                                                                           (trans p- 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (- (vlax-curve-getEndParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p+ (cond ((setq p+ (vlax-curve-getPointatParam ent (+ pa 1e-8)))
                                                                           (trans p+ 0 nrm)
                                                                          )
                                                                          ((trans (vlax-curve-getPointatParam ent (+ (vlax-curve-getStartParam ent) 1e-8)) 0 nrm)
                                                                          )
                                                                    )
                                                           )
                                                           (setq p0 (trans pt 0 nrm))
                                                           (<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+)))) ;; LM Mod
                                                      )
                                                    )
                                          ) lst
                            )
                    ) 2
               )
          )
        )
      )
    )
  )
 
  (defun processpla ( pla / ipl pla1 pla2 )
    (setq pla1 pla)
    (foreach p1 pla1
      (setq pla2 (vl-remove p1 pla1))
      (foreach p2 pla2
        (setq ipl (cons (inters (car p1) (polar (car p1) (cadr p1) 1.0) (car p2) (polar (car p2) (cadr p2) 1.0) nil) ipl))
      )
    )
    (setq ipl (vl-remove-if-not (function (lambda ( p ) (LM:Inside-p p lw))) (vl-remove nil ipl)))
  )
 
  (defun distp2t ( p tt )
    (distance p (inters p (polar p (+ (angle (car tt) (cadr tt)) (* 0.5 pi)) 1.0) (car tt) (cadr tt) nil))
  )
 
  (defun removesingles ( l / a )
    (while (setq a (vl-some (function (lambda ( x ) (if (= (1- (length l)) (length (vl-remove-if (function (lambda ( y ) (equal x y 1e-6))) l))) x))) l))
      (setq l (vl-remove a l))
    )
    l
  )
 
  (defun findipinterschilds ( ip pla / pla1 pla2 r )
    (setq pla1 pla)
    (foreach p1 pla1
      (setq pla2 (vl-remove p1 pla1))
      (foreach p2 pla2
        (if (equal ip (inters (car p1) (polar (car p1) (cadr p1) 1e+99) (car p2) (polar (car p2) (cadr p2) 1e+99) t) 1e-6)
          (setq r (list p1 p2))
        )
      )
    )
    r
  )
 
  (defun processtxtipl ( tl / ipl tl1 tl2 )
    (setq tl1 tl)
    (foreach t1 tl1
      (setq tl2 (vl-remove t1 tl1))
      (foreach t2 tl2
        (setq ipl (cons (inters (car t1) (polar (car t1) (angle (car t1) (cadr t1)) 1.0) (car t2) (polar (car t2) (angle (car t2) (cadr t2)) 1.0) nil) ipl))
      )
    )
    (setq ipl (vl-remove nil ipl))
  )
 
  (defun process nil
    (setq d (car (cadr (car-vl-member-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtl))))
    (if (null d)
      (setq d (car (cadr (car-vl-member-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtlo))))
    )
    (if ip
      (setq p1p2 (findipinterschilds ip pla))
      (setq p1p2 nil)
    )
    (setq f nil)
    (if p1p2
      (progn
        (setq tt (vl-some (function (lambda ( x ) (if (and (assoc (car x) p1p2) (assoc (cadr x) p1p2)) (progn (setq f t) x)))) tl))
        (if (or (vl-some (function (lambda ( x ) (equal (distance ip (car (car p1p2))) (+ (distance ip x) (distance x (car (car p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (car p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl)))) (vl-some (function (lambda ( x ) (equal (distance ip (car (cadr p1p2))) (+ (distance ip x) (distance x (car (cadr p1p2)))) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x (car (cadr p1p2)) 1e-6))) (vl-remove-if (function (lambda ( x ) (equal x ip 1e-6))) (mapcar (function car) ipldtl)))))
          (setq f nil)
        )
      )
    )
  )
 
  (defun _vl-position ( e l tol / car-vl-member-if )
    (defun car-vl-member-if ( f l / ff r )
      (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
      (vl-some ff l)
      r
    )
    (vl-position (car-vl-member-if (function (lambda ( x ) (equal e x tol))) l) l)
  )
 
  (defun car-sort ( lst cmp / rtn )
    (setq rtn (car lst))
    (foreach itm (cdr lst)
      (if (apply cmp (list itm rtn))
        (setq rtn itm)
      )
    )
    rtn
  )
 
  (defun car-vl-member-if ( f l / ff r )
    (setq ff (function (lambda ( x ) (if (apply f (list x)) (setq r x)))))
    (vl-some ff l)
    r
  )
 
 
;;; main 2droof ;;;
 
  (setq lw (car (entsel "\nPick a closed polygon : ")))
  (setq ti (car (_vl-times)))
  (setq n (cdr (assoc 90 (entget lw))))
  (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw))))
  (setq tl (mapcar (function (lambda ( a b ) (list a b))) pl (append (cdr pl) (list (car pl)))))
  (setq tlo tl)
  (setq pla (mapcar (function (lambda ( p mp ) (list p (angle p mp)))) pl (mapcar (function (lambda ( a b ) (if (clockwise-p (car a) (car b) (cadr b)) (mid (polar (cadr a) (angle (cadr a) (car a)) -1.0) (polar (car b) (angle (car b) (cadr b)) -1.0)) (mid (polar (cadr a) (angle (cadr a) (car a)) 1.0) (polar (car b) (angle (car b) (cadr b)) 1.0))))) (cons (last tl) tl) tl)))
  (setq plaa pla)
  (while (> n 0)
    (if (null ipll)
      (setq ipl (processpla plaa))
      (setq ipl (processpla pla))
    )
    (if (equal ipl iplo 1e-6)
      (setq n 0)
    )
    (if fff
      (progn
        (setq pl (mapcar (function car) pla))
        (foreach x pl
          (setq lil (cons (list x ip) lil))
        )
        (setq n 0)
      )
      (progn
        (if (null ipll)
          (progn
            (setq ipldtlo (mapcar (function (lambda ( p ) (list p (vl-sort (mapcar (function (lambda ( tt ) (distp2t p tt))) tlo) (function <))))) ipl))
            (setq ipldtlo (mapcar (function (lambda ( x ) (list (car x) (removesingles (cadr x))))) ipldtlo))
            (setq ipldtlo (vl-remove-if (function (lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if (function (lambda ( y ) (equal y (car (cadr x)) 1e-6))) (cadr x)))) 3))) ipldtlo))
          )
          (progn
            (setq ipldtl (mapcar (function (lambda ( p ) (list p (vl-sort (mapcar (function (lambda ( tt ) (distp2t p tt))) tlo) (function <))))) ipl))
            (setq ipldtl (mapcar (function (lambda ( x ) (list (car x) (removesingles (cadr x))))) ipldtl))
            (setq ipldtl (vl-remove-if (function (lambda ( x ) (< (- (length (cadr x)) (length (vl-remove-if (function (lambda ( y ) (equal y (car (cadr x)) 1e-6))) (cadr x)))) 3))) ipldtl))
            (if ipll
              (setq ipldtl (unique (vl-remove-if (function (lambda ( x ) (_vl-position (car x) ipll 1e-6))) ipldtl)))
            )
          )
        )
        (setq ipldtlo (vl-remove-if (function (lambda ( x ) (vl-position (car x) ipll))) ipldtlo))
        (setq ip (car (car-sort ipldtlo (function (lambda ( a b ) (< (car (cadr a)) (car (cadr b))))))))
        (setq ipldtlo (vl-remove-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtlo))
        (setq d (car (cadr (car-vl-member-if (function (lambda ( x ) (equal (car x) ip 1e-6))) ipldtlo))))
        (setq ipp nil dd nil ipo nil)
        (if (progn (process) (not f))
          (if ipll
            (progn
              (setq ipo ip)
              (foreach y (reverse pal)
                (setq ipp (cons (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( a ) (or (equal (rem (+ a pi) (* 2 pi)) (angle (car y) x) 1e-6) (equal a (angle (car y) x) 1e-6)))) (cadr y)))) (mapcar (function car) (vl-sort ipldtl (function (lambda ( a b ) (> (car (cadr a)) (car (cadr b)))))))) ipp))
              )
              (setq dd 1e+99)
              (mapcar (function (lambda ( x y ) (if x (mapcar (function (lambda ( xx ) (if (and (< (distance xx y) dd) (not (vl-some (function (lambda ( a ) (vl-some (function (lambda ( b ) (equal (distance xx a) (+ (distance xx b) (distance b a)) 1e-6))) (vl-remove xx (vl-remove a (append (mapcar (function car) pal) (mapcar (function car) ipldtl))))))) (vl-remove xx (append (mapcar (function car) pal) (mapcar (function car) ipldtl)))))) (setq dd (distance xx y) ip xx)))) x)))) ipp (mapcar (function car) pal))
            )
          )
        )
        (if (equal ip ipo 1e-6)
          (progn
            (setq ipp (apply (function append) ipp))
            (setq ipp (mapcar (function (lambda ( p ) (list p (findipinterschilds p pla)))) ipp))
            (setq ip (car (car-sort ipp (function (lambda ( a b ) (< (+ (distance (car a) (car (mapcar (function car) (cadr a)))) (distance (car a) (cadr (mapcar (function car) (cadr a))))) (+ (distance (car b) (car (mapcar (function car) (cadr b)))) (distance (car b) (cadr (mapcar (function car) (cadr b)))))))))))
          )
        )
        (if (vl-every (function (lambda ( x ) (equal ip (inters (car (car pla)) (polar (car (car pla)) (cadr (car pla)) 1.0) (car x) (polar (car x) (cadr x) 1.0) nil) 1e-6))) (cdr pla))
          (setq fff t)
        )
        (setq al nil a nil)
        (process)
        (if (null p1p2)
          (setq ip nil)
        )
        (if (and tt f)
          (progn
            (setq tl (vl-remove tt tl))
            (setq n (1- n))
          )
        )
        (if f
          (progn
            (setq t1 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (car p1p2))) (assoc (cadr x) (list (car p1p2)))) x))) tl))
            (setq t2 (vl-some (function (lambda ( x ) (if (or (assoc (car x) (list (cadr p1p2))) (assoc (cadr x) (list (cadr p1p2)))) x))) tl))
          )
          (setq t1 nil t2 nil)
        )
        (if ip
          (setq ipll (cons ip ipll))
        )
        (if (and t1 t2 ip)
          (progn
            (setq a (angle (inters (car t1) (cadr t1) (car t2) (cadr t2) nil) ip))
            (if a
              (progn
                (setq pla (cons (list ip a) pla))
                (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
                (setq lil (cons (list (car (car p1p2)) ip) lil))
                (setq lil (cons (list (car (cadr p1p2)) ip) lil))
                (setq pal (cons (list ip (list a)) pal))
              )
            )
          )
          (if (and ip (null fff))
            (progn
              (setq lil (cons (list (car (car p1p2)) ip) lil))
              (setq lil (cons (list (car (cadr p1p2)) ip) lil))
              (if (setq p (vl-some (function (lambda ( x ) (if (vl-position x plaa) x))) p1p2))
                (progn
                  (setq n (1- n))
                  (setq tll (vl-remove-if-not (function (lambda ( x ) (vl-some (function (lambda ( y ) (_vl-position p y 1e-6))) x))) tlo))
                  (setq tll (car (vl-remove-if-not (function (lambda ( x ) (and (_vl-position (car x) (vl-remove nil (mapcar (function car) lil)) 1e-6) (_vl-position (cadr x) (vl-remove nil (mapcar (function car) lil)) 1e-6)))) tll)))
                  (setq tl (vl-remove tll tl))
                )
              )
              (setq tll (vl-remove-if-not (function (lambda ( x ) (equal d (distp2t ip x) 1e-6))) tl))
              (setq txtipl (processtxtipl tll))
              (setq txtipl (vl-remove-if (function (lambda ( x ) (_vl-position x pl 1e-6))) txtipl))
              (setq al (mapcar (function (lambda ( p ) (angle p ip))) txtipl))
              (setq al (vl-remove-if (function (lambda ( x ) (_vl-position x (mapcar (function cadr) p1p2) 1e-6))) al))
              (setq al (unique al))
              (if al
                (progn
                  (setq pla (append pla (mapcar (function (lambda ( a ) (list ip a))) al)))
                  (setq pal (cons (list ip al) pal))
                )
              )
              (setq pla (vl-remove (car p1p2) pla) pla (vl-remove (cadr p1p2) pla))
            )
          )
        )
      )
    )
    (setq iplo ipl)
  )
  (setq lil (vl-remove-if (function (lambda ( x ) (equal (car x) (cadr x) 1e-6))) lil))
  (setq lil (unique lil))
  (setq lil (vl-remove-if (function (lambda ( x ) (vl-some (function (lambda ( y ) (null y))) x))) lil))
  (setq lipl (apply (function append) lil))
  (setq lipl (unique (vl-remove-if (function (lambda ( x ) (or (= (length (vl-remove x lipl)) (1- (length lipl))) (= (length (vl-remove x lipl)) (- (length lipl) 3))))) lipl)))
  (if lipl
    (setq lil (cons (list (car lipl) (cadr lipl)) lil))
  )
  (foreach li lil
    (entmake (list '(0 . "LINE") (cons 10 (car li)) (cons 11 (cadr li))))
  )
  (prompt "\nElapsed time : ") (princ (rtos (- (car (_vl-times)) ti) 2 20)) (prompt " milliseconds...")
  (princ)
)
 

News:

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

MSTG007

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

pedroantonio

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

pedroantonio

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

ahsattarian

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