Nhờ viết lisp (nối đường line có điều kiên)

[dinhtv1301 3]

Xin chào các anh chị 

Trong quá trình làm em gặp phải vấn đề khá khó khăn trong việc nối các đường line thành 1 đường polyline với điều kiện (em mô tả ở hình vẽ)

Nhờ các anh các chị giúp viết 1 lisp e với ạ

Trân trọng cảm ơn!

file cad.dwg

[gia_bach 1.551]

dùng lệnh OVERKILL và JOIN là đc, cần gì tới LISP.

[dinhtv1301 3]

ý mình ở đây là xóa các đỉnh thừa đi ah

XDPL 1.lsp ở đây e có 1 lisp nhưng chỉ áp dụng cho pline khép kin ạ, còn pline hở e ko dùng dc

[thanhduan2407 272]

Của bạn đây! Áp dụng với Polyline. 

(defun C:XDTHPL	(/ LTSPLINE SSPLINE X) ;;;XDTHPL
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (command "undo" "begin")
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	Gocchenh
	 (LM:GetXWithDefault
	   getreal
	   "\nNh\U+1EADp g\U+00F3c ch\U+00EAnh v\U+1EDBi 180 \U+0111\U+1ED9 (1,2,3...10 \U+0111\U+1ED9) \U+0111\U+01B0\U+1EE3c coi l\U+00E0 th\U+1EB3ng h\U+00E0ng:  "
	   '*Gocchenh0*
	   0.0
	 )
  )
  (setq ssPline (ssget '((0 . "*POLYLINE"))))
  (if ssPline
    (progn
      (setq LtsPline (LM:ss->ent ssPline))
      (mapcar '(lambda (x) (XDTHPL x Gocchenh)) LtsPline)
    )
  )
  (setvar "OSMODE" Olmode)
  (command "undo" "end")
  (princ)
)

(defun XDTHPL (pl delta180 / ANG1 ANG2 BUL1 BUL2 BULST CERALST1	CERALST2 ELST ELST1 ELST2 ELST3	I K M N	NBUL OBUL PLOB PLST PLST1 RA REC1 VTT1 VTT2)
  (setq	plst  (acet-geom-vertex-list pl)
	plob  (vlax-ename->vla-object pl)
	elst  (entget pl)
	bulst (list)
	plst1 plst
	elst1 (list)
	elst2 (list)
	elst3 (list)
  )
  (foreach a elst
    (if	(= (car a) 42)
      (setq bulst (append bulst (list (cdr a))))
    )
  )
  (setq	k (vl-position (cons 10 (reverse (cdr (reverse (car plst))))) elst)
	i 0
  )
  (while (< i k)
    (setq elst1	(append elst1 (list (nth i elst)))
	  i	(1+ i)
    )
  )
  (foreach vrt (if (= (cdr (assoc 70 elst)) 1)
		 (reverse (cdr (reverse plst)))
		 plst
	       )
    (setq k (vl-position (cons 10 (reverse (cdr (reverse vrt)))) elst))
    (setq elst2	(append	elst2
			(list
			  (list (nth k elst) (nth (+ k 1) elst) (nth (+ k 2) elst) (nth (+ k 3) elst))
			)
		)
    )
  )
  (setq m (cdr (assoc 90 elst)))
  (foreach vrt plst
    (setq i (vl-position vrt plst))
    (if	(> i 0)
      (progn
	(setq vtt1 (vlax-curve-getFirstDeriv
		     plob
		     (vlax-curve-getParamAtPoint plob (nth (1- i) plst))
		   )
	)
	(setq vtt2 (vlax-curve-getFirstDeriv plob (vlax-curve-getParamAtPoint plob vrt)))
	(setq bul1 (nth (1- i) bulst)
	      bul2 (nth i bulst)
	)
	(setq ang1 (angle '(0 0 0) vtt1)
	      ang2 (angle '(0 0 0) vtt2)
	)
	(if (and (= bul1 0.0)
		 (= bul2 0.0)
		 (or (equal ang1 ang2 (* pi (/ delta180 180.0)))
		     (equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))
		 )
		 (nth (1+ i) plst)
	    )
	  (setq	plst1 (vl-remove vrt plst1)
		m     (1- m)
	  )
	)

	(if (and (/= bul2 0.0) (/= bul1 0.0))
	  (progn
	    (setq ceralst1 (bulgecenter bul1 (nth (1- i) plst) (nth i plst))
		  ceralst2 (bulgecenter bul2 (nth i plst) (nth (1+ i) plst))
	    )
	    (if	(and (equal (car ceralst1) (car ceralst2) 1e-8)
		     (equal (last Ceralst1) (last ceralst2) 1e-8)
		)
	      (setq plst1 (vl-remove vrt plst1)
		    m	  (1- m)
	      )
	    )
	  )
	)
      )
    )
  )
  (if (= (cdr (assoc 70 elst)) 1)
    (setq plst1 (reverse (cdr (reverse plst1))))
  )
  (foreach vrt plst1
    (foreach rec elst2
      (if (equal (cdar rec) (reverse (cdr (reverse vrt))) 1e-8)
	(setq elst3 (append elst3 (list rec)))
      )
    )
  )
  (foreach rec elst3
    (if	(/= (setq obul (cdr (last rec))) 0.0)
      (progn
	(setq k	   (vl-position rec elst3)
	      n	   (vl-position obul bulst)
	      ra   (car (bulgecenter obul (nth n plst) (nth (1+ n) plst)))
	      nbul (bulge ra (nth k plst1) (nth (1+ k) plst1))
	)
	(if (< obul 0)
	  (setq nbul (- 0 nbul))
	)
	(setq rec1  (subst (cons 42 nbul) (assoc 42 rec) rec)
	      elst3 (subst rec1 rec elst3)
	)
      )
    )
  )
  (foreach rec elst3
    (setq elst1 (append elst1 rec))
  )
  (setq elst (append elst1 (list (cons 210 '(0.0 0.0 1.0)))))
  (setq elst (subst (cons 90 m) (assoc 90 elst) elst))
  (entmod elst)
)
(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun BulgeCenter (bulge p1 p2 / delta chord radius center)
  (setq	delta	(* (atan bulge) 4)
	chord	(distance p1 p2)
	radius	(/ chord (sin (/ delta 2)) 2)
	center	(polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
	Ceralst	(list center radius)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bulge (cen p1 p2 / anp)
  (setq	anp (atan (/ (distance p1 p2) 2 (distance cen (midpt p1 p2))))
	bul (/ (sin (/ anp 2)) (cos (/ anp 2)))
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun midpt (p1 p2)
  (setq pt (mapcar '(lambda (x y) (/ (+ x y) 2)) p1 p2))
)

(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)

 

[dinhtv1301 3]

em bị lổi này là sao nhỉ, nên e ko dùng được ạ

 

[dinhtv1301 3]

lisp có dùng trên LWPOLYLINE không bác

 

[thanhduan2407 272]

Sao lại nhập 180 độ?  179 hay 181 so với 180 là chênh 1 độ. Nó bảo nhập góc chênh thì nhập 1,2,3.....chứ

Nó áp dụng với LWPolyline.

[Doan Van Ha 3.200]

12 phút trước, thanhduan2407 đã nói:

Sao lại nhập 180 độ?  179 hay 181 so với 180 là chênh 1 độ. Nó bảo nhập góc chênh thì nhập 1,2,3.....chứ

Nó áp dụng với LWPolyline.

Dùng 2 hàm này khá nguy hiểm. Tuy là equal nhưng bản chất chưa hẳn equal:

(equal ang1 ang2 (* pi (/ delta180 180.0)))
(equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))

[thanhduan2407 272]

2 phút trước, Doan Van Ha đã nói:

Dùng 2 hàm này khá nguy hiểm. Tuy là equal nhưng bản chất chưa hẳn equal:

(equal ang1 ang2 (* pi (/ delta180 180.0)))
(equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))

Dạ. Cháu cảm ơn bác Hạ nhiều.

[thiep 365]

 

Vào lúc 6/4/2020 tại 09:31, dinhtv1301 đã nói:

Xin chào các anh chị 

Trong quá trình làm em gặp phải vấn đề khá khó khăn trong việc nối các đường line thành 1 đường polyline với điều kiện (em mô tả ở hình vẽ)

Nhờ các anh các chị giúp viết 1 lisp e với ạ

Trân trọng cảm ơn!

file cad.dwg

Đề bài cứ tưởng đơn giản nhưng phức tạp, vì đôi khi join các đối tượng vừa có line vừa có arc rồi xoá bớt các nút nằm thẳng hàng. Hoặc đơn giản chỉ xoá bớt các nút trên polyline nằm thẳng hàng, polyline có thể không có arc hoặc có arc. Lisp join có điều kiện thực hiện như trên clip này:

 

[ngokiet 169]

1 giờ} trướ}c, thiep đã nói:

 

Đề bài cứ tưởng đơn giản nhưng phức tạp, vì đôi khi join các đối tượng vừa có line vừa có arc rồi xoá bớt các nút nằm thẳng hàng. Hoặc đơn giản chỉ xoá bớt các nút trên polyline nằm thẳng hàng, polyline có thể không có arc hoặc có arc. Lisp join có điều kiện thực hiện như trên clip này:

 

2 arc liên tiếp có R và center xấp xỉ nhau có được không bác.

[thiep 365]

11 phút trước, ngokiet đã nói:

2 arc liên tiếp có R và center xấp xỉ nhau có được không bác.

@ngokiet được luôn, miễn là nó nối tiếp nhau, đại khái: điểm đầu của đối tượng này nối điểm cuối của đối tượng kia. R và center_point không quan trọng . Lisp đang hoàn thiện, sẽ up lên cho mọi người.

[Biet ve CAD 258]

Vào lúc 6/4/2020 tại 10:34, gia_bach đã nói:

dùng lệnh OVERKILL và JOIN là đc, cần gì tới LISP.

Làm theo cách bác @gia_bachgợi ý là ok mà, nhanh gọn nhẹ

1. dùng lisp chọn đối tượng

2. dùng lệnh PE rồi join

3. sau đó overkill là ngon lành ( bước này sẽ xóa tất cả các điểm cùng nằm trên 1 line)

[Biet ve CAD 258]

Mình làm thử đoạn lisp này, áp dụng cho các đối tượng liền nhau ( cách nhau 1 khoảng 0.1) và dùng cho 1 cụm các đối tượng đó

(defun C:jp ( / o)
  (setq o (getvar 'PEDITACCEPT))
  (setvar 'PEDITACCEPT 1)
  (vl-cmdf "PEDIT" "M" (ssget) "" "J" 0.1 "")
  (vl-cmdf "-OVERKILL"  (entlast) "" "O" 0.1 "D")
  (setvar 'PEDITACCEPT o)
  )

 

[dinhtv1301 3]

4 giờ trước, thiep đã nói:

 

Đề bài cứ tưởng đơn giản nhưng phức tạp, vì đôi khi join các đối tượng vừa có line vừa có arc rồi xoá bớt các nút nằm thẳng hàng. Hoặc đơn giản chỉ xoá bớt các nút trên polyline nằm thẳng hàng, polyline có thể không có arc hoặc có arc. Lisp join có điều kiện thực hiện như trên clip này:

 

bác có lisp này không cho e xin với

thank you!

[thiep 365]

Lisp này, như gộp chung cả 2 lệnh Join và Overkill.

Trong lisp có 2 biến fuz1 và fuz2:

Fuz1 là dung sai khoảng cách rời rạc để nối các đối tượng Line, Arc, lwpolyline lại với nhau, trong lisp Thiệp cho = "0.0"

Fuz2 là sai số để so sánh 1 node (p2) nằm ngoài đoạn thẳng (p1-p3) với 1 góc (p2 p1 p3) rất nhỏ nào đó. Trong lisp, Thiệp cho Fuz2=0.003

Trong lệnh Overkill cũng có dung sai, nhưng tôi thử nhiều lần với 1 góc Grad rất nhỏ 1/100.000.000 mà nó cũng không nhận ra. Ví dụ: 1 điểm p2 ở khoảng giữa đoạn thẳng p1-p3 dài 200km nằm chênh với đoạn thẳng p1-p3 này là 1mm, lệnh Overkill không nhận ra để kill nó đi. Lisp Thiệp viết làm được điều này với dung sai fuz2.

(defun DXF (code en) (cdr (assoc code (entget en))))
(defun c:jdk (/       ss1     ent     obj     polst1  polst2  ss1     ss2
              v1      v2      scalar_prod     ent-lst lst_bul bul1    bul2
              n       po1     po2     po3
             )
    (command "undo" "be")
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (setq ss1 (ssget '((0 . "LINE,*POLYLINE,ARC"))))
    (if ss1
        (progn
            (setq Fuz1 "0.0")
            (if (> (sslength ss1) 1)
                (progn
                    (mapcar '(lambda (x) (setq lst (cons (dxf 0 x) lst)))
                            (setq
                                ent-lst (vl-remove-if 'listp
                                                      (mapcar 'cadr (ssnamex ss1))
                                        )
                            )
                    )
                    (setq ss1 (ssadd))
                    (foreach ent ent-lst
                        (if (or (eq (dxf 0 ent) "ARC") (eq (dxf 0 ent) "LINE"))
                            (progn (command "_pedit" ent "" "")
                                   (setq ss1 (ssadd (entlast) ss1))
                            )
                            (setq ss1 (ssadd ent ss1))
                        )
                    )
                    (command "_.pedit" "M" ss1 "" "J" Fuz1 "")
                    (setq ent (entlast))
                )
                (setq ent (ssname ss1 0))
            )
            (setq fuz2 3e-3)
            (setq obj (vlax-ename->vla-object ent))
            (setq lst_bul nil)
            (setq polst1 (acet-geom-vertex-list ent))
            (setq n 0)
            (foreach po polst1
                (if (/= (setq bul (vla-GetBulge obj n)) 0.0)
                    (setq lst_bul (append lst_bul (List (cons (trans po 1 0) (list bul)))))
                )
                (setq n (+ n 1))
            )
            
            (setq polst1 (acet-list-remove-duplicates  polst1  nil))
            (setq polst2 polst1)
            (setq n 0)
            (while (<= n (- (length polst1) 2))
                (setq po1 (trans (nth n polst1) 1 0)
                      po2 (nth (+ n 1) polst1)
                      po3 (nth (+ n 2) polst1)
                )
                (if po2 (setq po2 (trans (nth (+ n 1) polst1) 1 0)))
                (if po3 (setq po3 (trans (nth (+ n 2) polst1) 1 0)))
                (setq bul1 (vla-GetBulge obj (vlax-curve-getParamAtpoint obj po1))
                      bul2 (vla-GetBulge obj (vlax-curve-getParamAtpoint obj po2))
                )
                
                (cond ((and (/= bul1 0.0) (= bul2 0.0) po3) (setq n (+ n 1)))
                      ((and (/= bul2 0.0) po3) (setq n (+ n 2)))
                      ((and (= bul1 0.0) (= bul2 0.0) po3)
                       (setq v1 (mapcar '- po1 po2)
                             v2 (mapcar '- po3 po2)
                       )
                       (setq scalar_prod (- (* (car v1) (cadr v2))
                                            (* (cadr v1) (car v2))
                                         )
                       )
                       (if (equal scalar_prod 0 fuz2) ;_
                           (setq polst2 (vl-remove po2 polst2))
                       )
                       (setq n (+ n 1))
                      )
                      (T (setq n (+ n 1)))
                )
            )
            (acet-lwpline-make (list polst2))
            (entdel ent)
            (setq obj (vlax-ename->vla-object (entlast)))
            (mapcar '(lambda (lst)
                         (vla-setBulge obj
                                       (vlax-curve-getParamAtpoint obj (car lst))
                                       (cadr lst)
                         )
                     )
                    lst_bul
            )
        ) ;_
    ) ;_
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (princ)
)