Chuyển đến nội dung
Diễn đàn CADViet
Jin Yong

Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bài được khuyến nghị

Em lại vào nhờ các bác tư vấn giúp em với ạ

Em có 1 Line dài và 1 tập hợp các Line ngắn nằm trên Line dài đó.

Mục đích của em là xoá các Line ngắn đó đi mà chỉ để lại Line dài thôi.

Em đã viết Code thế này rồi nhưng có chỗ nào đó ko ổn, nó ko xoá hết mà chỉ xoá 1 số đối tượng thôi.

Mục đích của em để lọc giảm nhẹ bản vẽ em làm.

Mong các bác chỉ giáo giúp.

Đây là code ạ

(defun c:00 ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  )
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
(setq Lts_Line_OK (TD:Remove-Obj-duplicates Lts_Ename))
(princ)
)



(defun GetPnt (Ma x  /)
(acet-dxf Ma (entget x))
)



(defun GetLineDup (lst / lst1)
(foreach x lst
	(if (not (member x lst1))
		(setq lst1 (append lst1 (list x)))
	)
	(Progn
		(foreach y lst1
			(if (and (equal (angle (GetPnt 10 y) (GetPnt 10 x)) (angle (GetPnt 10 y) (GetPnt 11 y)) 0.0000001)
				 (equal (angle (GetPnt 10 y) (GetPnt 11 x)) (angle (GetPnt 10 y) (GetPnt 11 y)) 0.0000001)
			    )
			    (setq lst1 (vl-remove y lst1))
			)
		)
		(setq lst1 (append lst1 (list x)) )
	)
)
lst1
)


(defun LM:ListDifference ( l1 l2 )
  (vl-remove-if '(lambda ( x ) (member x l2)) l1)
)


(defun LM:RemoveOnce ( l1 l2 )
  (if l1
    (if (equal (car l1) l2)
      (LM:RemoveOnce (cdr l1) l2)
      (cons (car l1) (LM:RemoveOnce (cdr l1) l2))
    )
  )
)

(defun TD:Remove-Obj-duplicates (ss_list /  Lts1 Lts2 )
(vl-load-com)
(setq Lts1  (GetLineDup ss_list ))
(setq Lts2 (LM:ListDifference ss_list Lts1))
(setq Lts3 (LM:RemoveOnce Lts1 ss_list))
(foreach e Lts2
	(entdel e)
)
Lts3
)




http://www.cadviet.com/upfiles/3/36665_xoa_line_1.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tại sao HHVD không dùng lệnh overkill ?

Lệnh Overkill không giải quyết triệt để. Bác hãy test luôn trên file em gửi là biết ngay ạ.

Em đang viết để xóa.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)

 

(defun c:001 ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  )
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (mapcar 'cdr (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2))))))
 
(setq i 0 j 1)
(while (< i (length Lts_KC_Ename_Sort))
  (while (< j (length Lts_KC_Ename_Sort))
    (if (entget (nth i Lts_KC_Ename_Sort))
      (if (entget (nth j Lts_KC_Ename_Sort))
            (if (Tue-geom-3pthanghang (GetPnt 10 (nth i Lts_KC_Ename_Sort)) (GetPnt 11 (nth i Lts_KC_Ename_Sort))
                           (GetPnt 10 (nth j Lts_KC_Ename_Sort)) (GetPnt 11 (nth j Lts_KC_Ename_Sort)))
                        (progn (entdel (nth j Lts_KC_Ename_Sort)) (vl-remove (nth j Lts_KC_Ename_Sort) Lts_KC_Ename_Sort))
            )
       )
      (setq j (length Lts_KC_Ename_Sort))
    )
            (setq j (1+ j))
   )
            (setq i (1+ i) j 1)
)
(princ)
)
(defun GetPnt (Ma x  /)
(acet-dxf Ma (entget x))
)
(defun Tue-geom-3pthanghang(p1 p2 p3 p4 / goc<pi)
  ;;;Ex: (Tue-geom-3pthanghang (getpoint "P1 :") (getpoint "P2 :") (getpoint "P3 :"))
  (defun goc<pi (pt1 pt2 / resgoc)
    (setq resgoc (angle pt1 pt2))
    (while (> resgoc pi) (setq resgoc (- resgoc pi)))
    resgoc
  )
  (if (and (equal (goc<pi p1 p2) (goc<pi p2 p3) 1E-10) (equal (goc<pi p1 p2) (goc<pi p2 p4) 1E-10))
            T nil
  )
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)

Dạ, cái anh Tue_NV chưa được ạ. Nó xóa nhiều thứ quá và vẫn bỏ xót đối tượng.

Cái Code em viết cũng tương đối nhưng cũng xóa không triệt để.

Có gì mong các anh xem và sửa giúp.

Code em viết đây ạ

(vl-load-com)
(defun c:XLT ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  );;;XOA LINE TRUNG
(setvar "CMDECHO" 0)
(progn
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (< (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
)
(setq Lts_Obj (TD:GetLineDup Lts_Ename ))
(setq Lts2 (LM:ListDifference Lts_Ename Lts_Obj ))
(foreach e Lts2
	(entdel e)
)
(alert (strcat "\nDa xoa:  " (rtos (length lts2) 2 0) " doi tuong"))
(princ )
)


(defun GetPnt (Ma x  / P1)
(setq P1 (acet-dxf Ma (entget x)))
(setq P2 (list (car P1) (cadr P1)))
P2
)

;;;;;LOC RA NHUNG DOI TUONG LINE NAM TREN NHAU
(defun TD:GetLineDup (lst / lst1)
(foreach x lst
(if (not (member x lst1))
	(setq lst1 (append lst1 (list x)))
)
(Progn
	(foreach y lst1
		(if (and (equal (+ (distance (GetPnt 10 y) (GetPnt 10 x)) (distance (GetPnt 10 y) (GetPnt 11 x))) (distance (GetPnt 10 x)  (GetPnt 11 x)) 0.05)
			 (equal (+ (distance (GetPnt 11 y) (GetPnt 10 x)) (distance (GetPnt 11 y) (GetPnt 11 x))) (distance (GetPnt 10 x)  (GetPnt 11 x)) 0.05)
			 (equal (angle (GetPnt 10 x) (GetPnt 10 y))  (angle (GetPnt 10 x) (GetPnt 11 x)) 0.0001)
			 (equal (angle (GetPnt 10 x) (GetPnt 11 y))  (angle (GetPnt 10 x) (GetPnt 11 x)) 0.0001)
		    )
		    (setq lst1 (vl-remove y lst1))
		)
	)
	(setq lst1 (append lst1 (list x)) )
)
)
lst1
)


(defun LM:ListDifference ( l1 l2 )
  (vl-remove-if '(lambda ( x ) (member x l2)) l1)
)

File test:  http://www.cadviet.com/upfiles/3/36665_test.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

1). Thế mà bảo em làm được rồi?

2). Có 1 hàm thừa, là hàm để lấy Lts_EnameLine

Hì hì. Tại file em test lúc đầu đơn giản quá nên ko phát hiện ra, lúc sau với test với số lượng lớn và đa dạng thì xảy ra như vậy.

Hàm lấy Lts_Ename để loại cái chiều dài đi cho viết dễ. :D

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Bạn giữ cái lsp ở #1826 và chỉ sửa 1 hàm này.

 

(defun GetLineDup (lst / lst1)
  (setq lst1 (list (car lst)))
  (while lst
    (setq lst (cdr lst)
 x (last lst1))
    (foreach y lst
      (if (or (equal (angle (GetPnt 10 x) (GetPnt 10 y))
 (angle (GetPnt 11 y) (GetPnt 11 x)) 0.0000001)
      (equal (angle (GetPnt 10 x) (GetPnt 11 y))
 (angle (GetPnt 10 y) (GetPnt 11 x)) 0.0000001)
)
(setq lst (vl-remove y lst))
      )
    )
    (setq lst1 (append lst1 (list (car lst))))
  )
)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Bạn giữ cái lsp ở #1826 và chỉ sửa 1 hàm này.

Đã OK. Tuyệt vời anh ạ. Em cũng nghĩ ra cách này rùi nhưng chưa bắt tay vào làm. Hii. 

Cảm ơn anh Tot77, bác Hạ và anh Tue_NV

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Chưa triệt để! Thử vẽ 1 loạt Line nối tiếp nhau và thẳng hàng rồi 00 xem sao nhé.

Hì hì. Em đã thấy dòng điều kiện của anh Tot77 rùi ạ. :D

 

 

(and
     (equal (+ (distance (GetPnt 10 x) (GetPnt 10 y)) (distance (GetPnt 10 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0)
     (equal (+ (distance (GetPnt 10 x) (GetPnt 11 y)) (distance (GetPnt 11 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0)
   ) 

 

Giả sử P3P4 nằm trên đoạn P1P2 thì thỏa mãn 2 điều kiện về khoảng cách.

Sp1p3+Sp3p2 = Sp1p2

Sp1p4+Sp4p2 = Sp1p2

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Chưa triệt để! Thử vẽ 1 loạt Line nối tiếp nhau và thẳng hàng rồi 00 xem sao nhé.

Các line nối tiếp nhau không thuộc đối tượng cần xóa.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Theo cái #1834 thì không xóa, còn #1838 của bạn sửa lại thì tôi không biết.

Điều kiện của tôi ko liên quan gì đến khoảng cách cả, chỉ liên quan tới góc thôi.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Theo cái #1834 thì không xóa, còn #1838 của bạn sửa lại thì tôi không biết.

Điều kiện của tôi ko liên quan gì đến khoảng cách cả, chỉ liên quan tới góc thôi.

 

Đúng là cái lsp của bác ở bài  #1834 chưa triệt để

File test đây bác:

http://www.cadviet.com/upfiles/3/4652_test00.dwg

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
(defun c:XLT( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK  );;;XOA LINE TRUNG
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
(setq Lts_Line_OK (TD:Remove-Obj-duplicates Lts_Ename))
(alert "Xong!")
(princ)
)

(defun GetPnt (Ma x  /)
(acet-dxf Ma (entget x))
)

(defun GetLineDup (lst / lst1)
(setq lst1 (list (car lst)))
(while lst
	(setq lst (cdr lst)
		x (last lst1))
	(foreach y lst
		(if (and
		      (equal (+ (distance (GetPnt 10 x) (GetPnt 10 y)) (distance (GetPnt 10 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.000001)
		      (equal (+ (distance (GetPnt 10 x) (GetPnt 11 y)) (distance (GetPnt 11 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.000001)
		    )
		(setq lst (vl-remove y lst))
		)
	)
	(setq lst1 (append lst1 (list (car lst))))
)
)

(defun LM:ListDifference ( l1 l2 )
  (vl-remove-if '(lambda ( x ) (member x l2)) l1)
)


(defun LM:RemoveOnce ( l1 l2 )
  (if l1
    (if (equal (car l1) l2)
      (LM:RemoveOnce (cdr l1) l2)
      (cons (car l1) (LM:RemoveOnce (cdr l1) l2))
    )
  )
)

(defun TD:Remove-Obj-duplicates (ss_list /  Lts1 Lts2 )
(vl-load-com)
(setq Lts1  (GetLineDup ss_list ))
(setq Lts2 (LM:ListDifference ss_list Lts1))
(setq Lts3 (LM:RemoveOnce Lts1 ss_list))
(foreach e Lts2
	(entdel e)
)
Lts3
)

Cái này thì ổn rồi anh ạ. Hii

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

File test của anh Tue_NV thì ko đúng điều kiện nên nó ko xóa.

Điều kiện chỉ là các đoạn thẳng nằm trong khoảng line dài nhất thôi ạ. vắt chéo nhau thì ko xóa anh ạ.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Em xem có mấy cái Line ngắn (A) trong đoạn Line dài đó em. 

Đúng ra Line ngắn (A) phải xóa => Cái Lsp của em cũng chưa triệt để 

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Bạn thử cái này xem.

 

(defun GetLineDup (lst / lst1)
  (setq lst1 (list (car lst)))
  (while lst
    (setq lst (cdr lst)
 x (last lst1))
    (foreach y lst
      (if (and (equal 0 (distance (GetPnt 10 y)
(vlax-curve-getClosestPointto x (GetPnt 10 y))) 0.00001)
          (equal 0 (distance (GetPnt 11 y)
(vlax-curve-getClosestPointto x (GetPnt 11 y))) 0.00001)
)
(setq lst (vl-remove y lst))
      )
    )
    (setq lst1 (append lst1 (list (car lst))))
  )
)
  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

 

Bạn thử cái này xem.

 

(defun GetLineDup (lst / lst1)
  (setq lst1 (list (car lst)))
  (while lst
    (setq lst (cdr lst)
 x (last lst1))
    (foreach y lst
      (if (and (equal 0 (distance (GetPnt 10 y)
(vlax-curve-getClosestPointto x (GetPnt 10 y))) 0.00001)
          (equal 0 (distance (GetPnt 11 y)
(vlax-curve-getClosestPointto x (GetPnt 11 y))) 0.00001)
)
(setq lst (vl-remove y lst))
      )
    )
    (setq lst1 (append lst1 (list (car lst))))
  )
)

 

Với file test đã gửi của mình thì nó vẫn "u như kỹ" ^_^ (Chưa triệt để) ^_^

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Với file test đã gửi của mình thì nó vẫn "u như kỹ" ^_^ (Chưa triệt để) ^_^

Nhìn xa thì thấy trùng, nhìn gần thì cách nhau 1 khúc <_<  <_<

Ủa mà sao lại dùng polyline? đang nói tới Line mà? Bác Tue chơi khăm quá!! 

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×