Đến nội dung


Hình ảnh
5 stars - based on 24598 reviews
- - - - -

Generate Non-Overlapping Polygons From A Set Of [Lwpoly]Lines


  • Please log in to reply
5 replies to this topic

#1 snowman.hms

snowman.hms

    biết vẽ pline

  • Members
  • PipPip
  • 64 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 28 March 2017 - 02:23 PM

This is my first draft for the program (Lwpoly without bulges)

Any one has some ideas? :)

 

http://www.cadviet.c...141948_test.dwg


  • 1

#2 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5543 Bài viết
Điểm đánh giá: 2669 (tuyệt vời)

Đã gửi 28 March 2017 - 04:07 PM

Hồi trước có đọc thuật toán về thứ này nhưng chưa đụng vào công việc nên chưa nghiên cứu.

Gởi bạn xem liệu có tốt hơn không nhé

http://www.cadviet.c...ondetection.pdf?


  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Và đừng làm điều ngược lại.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#3 snowman.hms

snowman.hms

    biết vẽ pline

  • Members
  • PipPip
  • 64 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 01 April 2017 - 09:47 AM

Thank you!

 Im using the algorithm from this site: https://blog.reactow...directed-graph/

 

But im havin some bulge to speeding up some sub function :)


  • 0

#4 snowman.hms

snowman.hms

    biết vẽ pline

  • Members
  • PipPip
  • 64 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 03 April 2017 - 04:22 PM

i've Fixed the bugs.

new result be:

Command: tt
Select objects:
 Time to Get Edges : 16.00 ms.
 Time to calculate edges : 6599 ms
 Times to process edges : 7285.0000 ms
Number of vertex: 22772.
Number of Edges : 45006.
 Times to calculate polygons : 20390.0000 ms
 Times to Create polygons : 9578.0000 ms
 Total time is : 46754.0000 ms
Total: 22235 polygons found./
 

Bài viết đã được chỉnh sửa nội dung bởi snowman.hms: 03 April 2017 - 04:24 PM

  • 0

#5 HoaVien

HoaVien

    biết vẽ ellipse

  • Members
  • PipPip
  • 55 Bài viết
Điểm đánh giá: 14 (tàm tạm)

Đã gửi 03 April 2017 - 08:21 PM

He he ...

Mem này quên tiếng Việt rùi !

 

Chắc là do ngâm cứu LISP nhiều quá !


  • 0

#6 snowman.hms

snowman.hms

    biết vẽ pline

  • Members
  • PipPip
  • 64 Bài viết
Điểm đánh giá: 30 (tàm tạm)

Đã gửi 05 April 2017 - 05:23 PM

(defun _getedges (lst / e enx l typ 3d->2d dxf t0)
  (defun 3d->2d (3dpt) (list (car 3dpt) (cadr 3dpt)))
  (defun dxf (i el) (cdr (assoc i el)))
  (setq t0 (getvar "MilliSecs"))
  (foreach e lst
    (setq enx (entget e))
    (cond ((= (setq typ (dxf 0 enx)) "LINE")
	   (setq l (cons (list (list (3d->2d (dxf 10 enx)) (3d->2d (dxf 11 enx)))) l))
	  )
	  ((= typ "LWPOLYLINE") (setq l (cons (_Lw2Params enx) l)))
    )
  )
  (princ (strcat "\n\tTime to Get Edges : " (rtos (- (getvar "MilliSecs") t0) 2 2) " ms."))
  (apply (function append) l)
)
(defun _Lw2Params (el / caaddddr cdaddddr rtn cls)
  (defun caaddddr (l) (caar (cddddr l)))
  (defun cdaddddr (l) (cdar (cddddr l)))
  (if (= 1 (cdr (assoc 70 el)))
    (setq cls t)
  )
  (setq el (member (assoc 10 el) el))
  (while (= 10 (caaddddr el))
    (setq rtn (cons (list (cdar el) (cdaddddr el)) rtn)
	  el  (cddddr el)
    )
  )
  (if cls
    (setq rtn (cons (list (cdar el) (car (last rtn))) rtn))
  )
  (reverse rtn)
)
(defun _sortxy (l)
  (vl-sort l
	   (function (lambda (a b)
		       (if (equal (car a) (car b) 1e-3)
			 (<= (cadr a) (cadr b))
			 (< (car a) (car b))
		       )
		     )
	   )
  )
)
(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)
(defun ff1 (l fuz / e e1 l1 l2 t0 p a)
  (setq	t0 (getvar "MilliSecs")
	a  (/ 1 fuz)
  )
  (foreach e l (setq l1 (cons (_sortxy e) l1)))
  (setq	l  (vl-sort l1 (function (lambda (a b) (<= (caar a) (caar b)))))
	l1 nil
  )
  (while (setq e (car l))
    (setq l (cdr l))
    (while (and (setq e1 (car l)) (>= (car (last e)) (caar e1)))
      (setq l (cdr l))
      (if (setq p (inters (car e) (last e) (car e1) (last e1)))
	(setq e	 (vl-list* (car e) p (cdr e))
	      e1 (vl-list* (car e1) p (cdr e1))
	)
      )
      (setq l1 (cons e1 l1))
    )
    (if	l1
      (progn (foreach a l1 (setq l (cons a l)))
	     (setq l2 (cons (_UniqueFuzz (_sortxy e) fuz) l2)
		   l1 nil
	     )
      )
      (setq l2 (cons (_UniqueFuzz (_sortxy e) fuz) l2))
    )
  )
  (setq	l2 (apply (function append) (mapcar (function _grouppair) l2))
	l2 (vl-sort l2 (function (lambda (a b) (<= (caar a) (caar b)))))
	l1 nil
  )
  (setq	l2 (mapcar (function
		     (lambda (x)
		       (mapcar (function (lambda (p) (list (/ (fix (* (car p) a)) a) (/ (fix (* (cadr p) a)) a)))) x)
		     )
		   )
		   l2
	   )
  )
  (setq l2 (_UniqueFuzz l2 fuz))
  (princ "\n\tTime to calculate edges : ")
  (princ (- (getvar "MilliSecs") t0))
  (princ " ms\n")
  l2
)
(defun _grouppair (l / r)
  (if (cdr l)
    (cons (list (car l) (cadr l)) (_grouppair (cdr l)))
  )
)
(defun _UniqueFuzz (l f / x r)
  ;; l - list of "sorted" edges
  (while (setq x (car l))
    (setq l (cdr l))
    (while (and l (equal x (car l) fuz)) (setq l (cdr l)))
    (cond ((equal (car x) (cadr x) fuz))
	  ((setq r (cons x r)))
    )
  )
  (reverse r)
)
(defun sort_adj-ccw (p l lp / ang<2pi pi/2)
  (defun ang<2pi (a) (rem (+ pi pi a) (+ pi pi)))
  (setq	p    (nth p lp)
	l    (mapcar '(lambda (x) (cons x (nth x lp))) l)
	pi/2 (/ pi 2.)
  )
  (mapcar 'car
	  (vl-sort l
		   (function
		     (lambda (x y) (< (ang<2pi (+ pi/2 (angle p (cdr x)))) (ang<2pi (+ pi/2 (angle p (cdr y))))))
		   )
	  )
  )
)
(defun safearray-get (ar i) (read (vlax-safearray-get-element ar i)))
(defun safearray-put (ar i v) (vlax-safearray-put-element ar i (vl-prin1-to-string v)))
(defun get-neighbors (p GB) (safearray-get GB p))
(defun remove-neighbor (p n GB) (safearray-put GB p (vl-remove n (safearray-get GB p))))
(defun remove-chain (l GB / a b)
  (if (setq a (car l))
    (progn (foreach b (get-neighbors a GB)
	     (remove-neighbor a b GB)
	     (remove-neighbor b a GB)
	     (if (not (cadr (vl-remove a (get-neighbors b GB))))
	       (remove-chain (cons b (cdr l)) GB)
	       (remove-chain (cdr l) GB)
	     )
	   )
    )
  )
)
(defun nth- (a l)
  (if (= a (car l))
    (last l)
    (nth (1- (vl-position a l)) l)
  )
)
(defun f1 (a GB / a1 c c1 l1 l2 CC)
  (if (and (setq l1 (get-neighbors a GB)) (cadr l1))
    (progn (setq a1 a
		 l2 l1
	   )
	   (while (cadr l1)
	     (setq b  (car l1)
		   a  a1
		   c1 (list b a)
		   l1 (cdr l1)
	     )
	     (while (and (setq c (get-neighbors b GB)) (setq c (nth- a c)) (/= c (car l1)) (not (vl-position c c1)))
	       (setq c1	(cons c c1)
		     a	b
		     b	c
	       )
	     )
	     (if (and (>= (length c1) 2) (= (car l1) c))
	       (setq c1	(cons (car l1) c1)
		     cc	(cons c1 cc)
	       )
	     )
	   )
	   (mapcar '(lambda (x)
		      (remove-neighbor x a1 GB) ;(remove-neighbor a1 x GB)
		    )
		   l2
	   )
    )
  )
  cc
)
(defun f2 (le / lp lpi l1 l2 l3 l4 p t0)
  (setq t0 (getvar "MilliSecs"))
  (setq le (vl-sort le
                    (function (lambda (x y)
                                (if (equal (caar x) (caar y) 1e-3)
                                  (<= (cadar x) (cadar y))
                                  (< (caar x) (caar y))
                                )
                              )
                    )
           )
        lp  (apply (function append) le)
        lp  (vl-sort lp
                     (function (lambda (x y)
                                 (if (= (car x) (car y))
                                   (<= (cadr x) (cadr y))
                                   (< (car x) (car y))
                                 )
                               )
                     )
            )
        l1  nil
  )
  (while (setq p (car lp))    
    (if	(equal p (car l1) 1e-3)
      (setq lp (cdr lp))
      (setq l1 (cons p l1)
	    lp (cdr lp)
      )
    )
  )
  (setq lp  (reverse l1)
        lpi (vl-sort-i lp
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        l4  lp
        l1  (mapcar (function car) le)
        l2  (mapcar (function cadr) le)
        l1 (f3 l1 lp)
        l2 (f3 l2 lp)
        le (mapcar (function list) l1 l2)
  )
  (princ (strcat "\n\tTime to process edges : "
                 (rtos (- (getvar "MilliSecs") t0))
                 " ms\n"
         )
  )
  (list lp lpi le)
)
(defun f3 (l1 l2 / p i j l3 li)
  (setq li (vl-sort-i l1
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        l1 (vl-sort l1
                       (function (lambda (x y)
                                   (if (= (car x) (car y) )
                                     (<= (cadr x) (cadr y))
                                     (< (car x) (car y))
                                   )
                                 )
                       )
            )
        i  0
        l3 nil
  )
  (while (setq j 0
               p (car l1)
         )
    (while (and (equal (car p) (caar l1) 1e-3)
                (equal (cadr p) (cadar l1) 1e-3)
           )
      (setq j  (1+ j)
            l1 (cdr l1)
      )
    )
    (while (if (equal (car p) (caar l2) 1e-2)
             (not (equal (cadr p) (cadar l2) 1e-2))
             t
           )
      (setq i  (1+ i)
            l2 (cdr l2)
      )
    )
    (repeat j (setq l3 (cons i l3)))
  )
  (mapcar (function cdr)
          (vl-sort (mapcar (function cons) li (reverse l3))
                   (function (lambda (a b) (<= (car a) (car b))))
          )
  )
)
(defun _Lwpoly (lr lst cl)
  (entmakex (apply 'append
		   (list (list '(0 . "LWPOLYLINE")
			       (cons 100 "AcDbEntity")
			       (cons 8 lr)
			       (cons 62 cl)
			       (cons 100 "AcDbPolyline")
			       (cons 90 (length lst))
			       (cons 38 (caddr (trans '(0 0 0) 1 (trans '(0. 0. 1.) 1 0))))
			       (cons 70 1)
			 )
			 (mapcar '(lambda (x) (list 10 (car x) (cadr x))) lst)
			 (list (cons 210 (trans '(0. 0. 1.) 1 0)))
		   )
	    )
  )
)
(defun c:tt (/ l lp lpi le c cc t0 t1 t2 n GB GD GV i n tm)
  (progn (repeat 3 (gc))
	 (setq t0  (getvar "MilliSecs")
               L   (F2
		     (ff1 (_getedges (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget))))) 1e-3)
		   )
               t1 (getvar "MilliSecs")
	       lp  (car l)
	       lpi (cadr l)
	       le  (caddr l)
	       cc  nil
	       c   nil	       
	 )
	 (princ (strcat "\nNumber of vertex: " (itoa (length lp)) "."))
	 (princ (strcat "\nNumber of Edges : " (itoa (length le)) "."))
	 (setq n  (length lpi)
	       GB (vlax-make-safearray vlax-vbstring (cons 0 (1- n)))
	 )
	 (mapcar (function (lambda (x y)
			     (safearray-put GB x (cons y (safearray-get GB x)))
			     (safearray-put GB y (cons x (safearray-get GB y)))
			   )
		 )
		 (mapcar (function car) le)
		 (mapcar (function cadr) le)
	 )
	 (setq lb (mapcar (function read) (vlax-safearray->list GB))
	       i  -1
	       tm nil
	 )
	 (repeat n (setq i (1+ i)) (setq tm (cons (sort_adj-ccw i (nth i lb) lp) tm)))
	 (setq lb (reverse tm)
	       tm nil
	       i  -1
	 )
	 (mapcar (function (lambda (x) (safearray-put GB (setq i (1+ i)) x))) lb)
	 (if (setq i  -1
		   tm (vl-remove nil
				 (mapcar (function (lambda (x)
						     (setq i (1+ i))
						     (if (= (length x) 1)
						       i
						     )
						   )
					 )
					 lb
				 )
		      )
	     )
	   (remove-chain tm GB)
	 )
	 (foreach p lpi (setq c (f1 p GB)) (setq cc (cons c cc)))
	 (princ (strcat "\n\tTime to calculate polygons : " (rtos (- (setq t2 (getvar "MilliSecs")) t1)) " ms\n"))
	 (if cc
	   (progn (setq cc (vl-remove nil (apply 'append cc)))
		  (mapcar (function (lambda (c) (_Lwpoly "tmpp" (mapcar '(lambda (x) (nth x lp)) c) 44))) cc)
		  (princ (strcat "\n\tTime to Create polygons : " (rtos (- (getvar "MilliSecs") t2)) " ms\n"))
                  (princ (strcat "\n\tTotal time is : " (rtos (- (getvar "MilliSecs") t0)) " ms\n"))
		  (princ (strcat "\nTotal: " (itoa (length cc)) " polygons found./"))
	   )
	   (princ "\nThere is no Cycle found!")
	 )
  )
  (princ)
)

  • 0