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

[ketxu 2.984]

Đã dính vào command thì ketxu Vote phương án Interset Region, nhẹ nhàng, đỡ đau đầu ^^

[Doan Van Ha 3.202]

Viết giúp chú theo PA2 của anh Gia_bach (PA1 anh Gia_bach xét thiếu các đỉnh).

Không biết số ent màu hồng có nhiều không, chứ dùng PA command hơi ì ạch nếu số lượng đủ lớn.

(defun C:HA(/ old ent lst ds1 ds2)
 (command "undo" "be")
 (setq old (entlast))
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (setq lst (#SS->List  (ssget)))
 (mapcar '(lambda(e) (command "copy" e "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) "")) lst)
 (setq ds1 (GetNewEnts old) old (entlast)) 
 (repeat (length lst) (command "copy" ent "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) ""))
 (setq ds2 (GetNewEnts old) i -1)
 (repeat (length ds1)
  (command "INTERSECT" (nth (setq i (1+ i)) ds1) (nth i ds2) ""))
 (command "undo" "e") (princ))
(defun GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)        ; list ename
(defun #SS->List (ss / i lst) (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))

[thanhduan2407 272]

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

Đã dính vào command thì ketxu Vote phương án Interset Region, nhẹ nhàng, đỡ đau đầu ^^

Em viết dùm anh phương án này với nhé! Hii

[thanhduan2407 272]

1 giờ} trướ}c, Doan Van Ha đã nói:

Viết giúp chú theo PA2 của anh Gia_bach (PA1 anh Gia_bach xét thiếu các đỉnh).

Không biết số ent màu hồng có nhiều không, chứ dùng PA command hơi ì ạch nếu số lượng đủ lớn.

 

• ha.lsp
  
• [✎]
   

(defun C:HA(/ old ent lst ds1 ds2)
 (command "undo" "be")
 (setq old (entlast))
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (setq lst (#SS->List  (ssget)))
 (mapcar '(lambda(e) (command "copy" e "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) "")) lst)
 (setq ds1 (GetNewEnts old) old (entlast)) 
 (repeat (length lst) (command "copy" ent "" "none" '(0 0) "none" '(0 0)) (command "region" (entlast) ""))
 (setq ds2 (GetNewEnts old) i -1)
 (repeat (length ds1)
  (command "INTERSECT" (nth (setq i (1+ i)) ds1) (nth i ds2) ""))
 (command "undo" "e") (princ))
(defun GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)        ; list ename
(defun #SS->List (ss / i lst) (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))

 

 

Bác Doan Van Ha viết OK rồi ạ!  :D

 

[tien2005 242]

Bạn tham khảo lips hatch vùng kính của các đối tượng giao nhau ở đây xem có giup được gì không, mình thấy nó cũng tượng tự với y/c của Bạn

 

http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/page-2

[thanhduan2407 272]

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

Bạn tham khảo lips hatch vùng kính của các đối tượng giao nhau ở đây xem có giup được gì không, mình thấy nó cũng tượng tự với y/c của Bạn

 

http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/page-2

Cảm ơn bác @tien2005 ! Em sẽ nghiên cứu thêm gợi ý của bác

[ndtnv 481]

(defun C:TestRegion (/ s r o i t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (setq i (vla-boolean e acIntersection o))
    )
    (-(getvar "MilliSecs") t0)
)

Test với bản vẽ có ô lưới = 1/10 của bv bạn đưa lên, có 540 region mất khoảng 1.5s

Nếu dùng select các ô có giao với region gốc time còn giảm

Trường hợp region có nhiều vùng, dùng lisp region=>pline, rồi region lại có lẽ lâu hơn 1 chút

BOUNDARY.dwg

[thanhduan2407 272]

4 phút trước, ndtnv đã nói:

 

(defun C:TestRegion (/ s r o i t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (setq i (vla-boolean e acIntersection o))
    )
    (-(getvar "MilliSecs") t0)
)


 

Test với bản vẽ có ô lưới = 1/10, 540 region mất khoảng 1.5s

Nếu dùng select các ô có giao với region gốc time còn giảm

Trường hợp region có nhiều vùng, dùng lisp region=>pline, rồi region lại có lẽ lâu hơn 1 chút

BOUNDARY.dwg

Em đã lỡ bấm quá nhiều Like rồi nên giờ không biết bấm Like bác kiểu gì nữa. Cảm ơn bác rất nhiều. Hii

[thanhduan2407 272]

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

(defun C:TestRegion (/ s r o i t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (setq i (vla-boolean e acIntersection o))
    )
    (-(getvar "MilliSecs") t0)
)

Test với bản vẽ có ô lưới = 1/10 của bv bạn đưa lên, có 540 region mất khoảng 1.5s

Nếu dùng select các ô có giao với region gốc time còn giảm

Trường hợp region có nhiều vùng, dùng lisp region=>pline, rồi region lại có lẽ lâu hơn 1 chút

BOUNDARY.dwg

Bác cho em hỏi 1 chút! Làm thế nào lấy được danh sách các region ấy sau khi tìm acIntersection?

Em muốn tóm được nó và biển nó thành Polyline..

[Doan Van Ha 3.202]

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

Bác cho em hỏi 1 chút! Làm thế nào lấy được danh sách các region ấy sau khi tìm acIntersection?

Em muốn tóm được nó và biển nó thành Polyline..

Trong lisp HA có hàm GetNewEnts sờ sờ ra đó mà?

[thanhduan2407 272]

3 giờ trước, ndtnv đã nói:

• testregion.lsp
  
• [✎]
   

(defun C:TestRegion (/ s r o i t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (setq i (vla-boolean e acIntersection o))
    )
    (-(getvar "MilliSecs") t0)
)

Test với bản vẽ có ô lưới = 1/10 của bv bạn đưa lên, có 540 region mất khoảng 1.5s

Nếu dùng select các ô có giao với region gốc time còn giảm

Trường hợp region có nhiều vùng, dùng lisp region=>pline, rồi region lại có lẽ lâu hơn 1 chút

BOUNDARY.dwg

Em chào anh ndtnv !

Em nhận ra, khi vùng 1 giao với vùng 2 tạo ra n vùng nhưng chỉ có 1 region duy nhất. Khi Explode Region đó ra thì nó sẽ tạo thành 2 region.

Đây là bản vẽ Test.

P/s: Bác DVH: Cháu có dùng hàm của bác nhưng chắc cháu chưa biết cách lấy nên danh sách vẫn trả về nil bác ạ!

Cháu thử cả của bác và của anh ndtnv cùng 1 kết quả là Region chồng Region.

 

Link: http://www.mediafire.com/file/4gkok3u3ue5iywa/BAN_VE_TEST.dwg/file

 

[Doan Van Ha 3.202]

1). Cách dùng hàm GetNewEnts để lấy lst các đối tượng được tạo ra sau 1 loạt lệnh nào đó:

- (setq ent (entlast))

- Làm 1 loạt lệnh...

- (setq lst (GetNewEnts ent))

2). Đúng là cả 2 lisp đều cho ra 1 region dính chùm. Không cần dùng lisp, chỉ dùng command region 2 đối tượng liên quan cũng có kết quả tương tự. Có lẽ do bản chất lệnh region nó thế

[thanhduan2407 272]

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

1). Cách dùng hàm GetNewEnts để lấy lst các đối tượng được tạo ra sau 1 loạt lệnh nào đó:

- (setq ent (entlast))

- Làm 1 loạt lệnh...

- (setq lst (GetNewEnts ent))

2). Đúng là cả 2 lisp đều cho ra 1 region dính chùm. Không cần dùng lisp, chỉ dùng command region 2 đối tượng liên quan cũng có kết quả tương tự. Có lẽ do bản chất lệnh region nó thế

Dạ vâng bác! Nhưng kết quả vẫn trả về nil bác ạ!

Cháu cũng sử dụng hàm tương tự của bác nhưng kq nó về nil. Bực mình lắm bác ạ

[quocmanh04tt 635]

Mình tham gia đề xuất 1 PA (dùng command):

 Xét từng ô lưới:

* Trong từng ô lưới (có 4 đỉnh) kiểm tra những đỉnh nào nằm trong Pline kín (trong mỗi đỉnh này có đặc điểm riêng ll, ul, ur và lr)

* Sẽ có 4 trường hợp: 1, 2, 3 hoặc 4 đỉnh nằm trong pline kín

- Nếu 1 đỉnh: xét xem là ll hay tl... polar điểm này về phía 3 điểm còn lại 1 khoảng nhỏ, dùng lệnh BOUNDARY để tạo BOUNDARY

- Nếu 4 đỉnh thì chỉ cần lấy tâm của ô lưới -> BOUNDARY

- 2 hay 3 thì xét các BOUNDARY được tạo ra có trùng toạ độ hay không (điểm pick tương tự trường hợp 1)...

- Trường hợp không có đỉnh nào, mà lưới và pline kín giao nhau thì lấy tất cả điểm giao và những điểm của pline nằm trong ô lưới => sort các điểm theo pline kín và tạo Boundary.

 

 

[thanhduan2407 272]

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

Mình tham gia đề xuất 1 PA (dùng command):

 Xét từng ô lưới:

* Trong từng ô lưới (có 4 đỉnh) kiểm tra những đỉnh nào nằm trong Pline kín (trong mỗi đỉnh này có đặc điểm riêng ll, ul, ur và lr)

* Sẽ có 4 trường hợp: 1, 2, 3 hoặc 4 đỉnh nằm trong pline kín

- Nếu 1 đỉnh: xét xem là ll hay tl... polar điểm này về phía 3 điểm còn lại 1 khoảng nhỏ, dùng lệnh BOUNDARY để tạo BOUNDARY

- Nếu 4 đỉnh thì chỉ cần lấy tâm của ô lưới -> BOUNDARY

- 2 hay 3 thì xét các BOUNDARY được tạo ra có trùng toạ độ hay không (điểm pick tương tự trường hợp 1)...

- Trường hợp không có đỉnh nào, mà lưới và pline kín giao nhau thì lấy tất cả điểm giao và những điểm của pline nằm trong ô lưới => sort các điểm theo pline kín và tạo Boundary.

 

 

Em ngóng. Em đã xào nấu mấy cái trước và đạt được ý muốn rồi.

Chờ phương án 1 của bác . Hii

 

[ndtnv 481]

Muốn kết quả là PLINE

(defun C:TestRegion (/ s r o i k ssa t0)
    (setq s (vlax-ename->vla-object(car (entsel))))
    (setq r (mapcar 'vlax-ename->vla-object
                                    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "REGION")(8 . "LUOI"))))))))
    (setq t0 (getvar "MilliSecs"))
    (foreach e r
        (setq o (vla-copy s))
        (vla-boolean e acIntersection o)
        (if (> (vla-get-Area e) 0)
            (progn
                (setq i (vlax-vla-object->ename e))
                (vl-cmdf "._EXPLODE" i "")
                (if (setq ss (ssget "P" '((0 . "REGION"))))
                    (progn
                        (setq k 0)
                        (repeat (sslength ss)
                            (vl-cmdf "._EXPLODE" (ssname ss k) "" "")
                            (vl-cmdf "._PEDIT" "M" "P" "" "J" "" "" )
                            (setq k (1+ k))
                            )
                        )
                    (vl-cmdf "._PEDIT" "M" "P" "" "J" "" "" )
                )
            )
        )
    )
    (-(getvar "MilliSecs") t0)
)

 

Chạy bài 540 REGION mất 10s

Nếu vẫn muốn kq là REGION :

ss <> nil : không thực hiện các lệnh trong if

ss = nil: undo bước (vl-cmdf "._EXPLODE" i "")

 

P/s: Biến PEDITACCEPT = 1

 

[Doan Van Ha 3.202]

PÁ này hôm qua viết rồi, nhưng chạy chậm và phụ thuộc mức độ vi phân (trong lisp lấy n=20), bù lại là tránh tạo Region dính cặp.

(defun C:HA1(/ ds)
 (command "undo" "be")
 (setq ent (car (entsel "\nChon Pline mau trang: ")))
 (princ "\nChon tat ca o vuong mau hong: ")
 (foreach e (setq lst (#SS->List  (ssget)))
  (setq lstpt (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))))
  (setq ll (list (apply 'min (mapcar 'car lstpt)) (apply 'min (mapcar 'cadr lstpt))) ur (list (apply 'max (mapcar 'car lstpt)) (apply 'max (mapcar 'cadr lstpt))))
  (setq n 20 dta (/ (- (car ur) (car ll)) n) x (- (car ll) dta) en (entlast) ds nil)
  (repeat n
   (setq x (+ x dta) y (- (cadr ll) dta))
   (repeat n
    (setq y (+ y dta))
    (setq p (list x y))
    (if (and (HA:Insidep1 p ent) (HA:Insidep2 p ds))  (progn (command "BOUNDARY" p "") (setq ds (GetNewEnts en)))))))
 (command "undo" "e") (princ))
;; KiÓm tra ®iÓm Pt lµ n»m trong/ngoµi Polygon. Tr¶ vª T/nil nªu Pt n»m trong/ngoµi Ent. Modify by HA - 07/09/2013.
(defun HA:Insidep1 (pt ent / obj1 obj2 obj3 big small flag)
 (vl-load-com)
 (setq obj1 (vlax-ename->vla-object ent))
 (setq obj2 (car (vlax-invoke obj1 'Offset 1E-3)))
 (setq obj3 (car (vlax-invoke obj1 'Offset -1E-3)))
 (if (> (vla-get-Area obj2)(vla-get-Area obj3))
  (setq big obj2 small obj3)
  (setq big obj3 small obj2))
 (setq flag (> (distance pt (vlax-curve-getClosestPointTo big pt)) (distance pt (vlax-curve-getClosestPointTo small pt))))
 (mapcar '(lambda(x) (progn (vla-Delete x) (vlax-release-object x))) (list big small))
 flag)
(defun HA:Insidep2 (pt ds / ent flag1)
 (setq flag1 T)
 (while (and ds flag1)
  (setq ent (car ds) ds (cdr ds)) 
  (if (HA:Insidep1 pt ent) (setq flag1 nil)))
 flag1)
(defun GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)        ; list ename
(defun #SS->List (ss / i lst) (repeat (setq i (sslength ss)) (setq lst (cons (ssname ss (setq i (1- i))) lst))))

[quocmanh04tt 635]

Làm theo phương án của miền, kết quả gần như tức thì! Với file ở trên, máy Core i5 -7400-3Ghz thời gian 0.094s. Có khi thì 0.078s.

[thanhduan2407 272]

Sau khi được sự hỗ trợ của các  bác em đã hoàn thành xong mục đích của mình hôm qua rồi.

Cảm ơn các anh các bác đã hỗ trợ.

https://www.youtube.com/watch?v=IY-oQSBYcIQ

[huunhantvxdts 195]

Nhờ các Bác giúp đỡ với 2 đối tượng gần nhau trong 1 phạm vi đủ nhỏ nhưng không giao nhau thì hàm sau nó không còn đúng

(setq gd (vlax-invoke (vlax-ename->vla-object enxt) 'IntersectWith (vlax-ename->vla-object obj2) acExtendNone))

các Bác có cách nào chỉ lấy tọa độ của những điểm giao nhau thôi.

Cám ơn các Bác

[quocmanh04tt 635]

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

Nhờ các Bác giúp đỡ với 2 đối tượng gần nhau trong 1 phạm vi đủ nhỏ nhưng không giao nhau thì hàm sau nó không còn đúng

(setq gd (vlax-invoke (vlax-ename->vla-object enxt) 'IntersectWith (vlax-ename->vla-object obj2) acExtendNone))

các Bác có cách nào chỉ lấy tọa độ của những điểm giao nhau thôi.

Cám ơn các Bác

 

Ặc ặc... Có lẽ phải nhờ đến pháp sư...!

[quocmanh04tt 635]

@huunhantvxdts

Thử cái này xem có ổn không???

(defun c:tt  (/ e1 e2 gd)
  (if (and (setq e1 (car (entsel "\nObject 1: ")))
           (setq e2 (car (entsel "\nObject 2: ")))
           (setq gd (vlax-invoke
                      (vlax-ename->vla-object e1)
                      'IntersectWith
                      (vlax-ename->vla-object e2)
                      acExtendNone))
           (zerop (distance (vlax-curve-getClosestPointTo e1 gd nil)
                            (vlax-curve-getClosestPointTo e2 gd nil))))
    gd
    nil))

P/s: Lisp trên với trường hợp 1 điểm giao, nhiều điểm giao thì làm tương tự.

[huunhantvxdts 195]

10 phút trước, quocmanh04tt đã nói:

@huunhantvxdts

Thử cái này xem có ổn không???

(defun c:tt  (/ e1 e2 gd)
  (if (and (setq e1 (car (entsel "\nObject 1: ")))
           (setq e2 (car (entsel "\nObject 2: ")))
           (setq gd (vlax-invoke
                      (vlax-ename->vla-object e1)
                      'IntersectWith
                      (vlax-ename->vla-object e2)
                      acExtendNone))
           (zerop (distance (vlax-curve-getClosestPointTo e1 gd nil)
                            (vlax-curve-getClosestPointTo e2 gd nil))))
    gd
    nil))

P/s: Lisp trên với trường hợp 1 điểm giao, nhiều điểm giao thì làm tương tự.

Cám ơn Bác để mình kiểm tra

[huunhantvxdts 195]

qua quá trình chạy mình thấy các điểm đó thường nằm trên đối tượng thứ 2 vậy nên khi có kết quả 1 list điểm, ta đem các điểm đó đo khoảng cách đến đối tượng 1 cái nào bằng 0 ta lấy. Các Bác xem có ổn không???

[quocmanh04tt 635]

1 phút trước, huunhantvxdts đã nói:

qua quá trình chạy mình thấy các điểm đó thường nằm trên đối tượng thứ 2 vậy nên khi có kết quả 1 list điểm, ta đem các điểm đó đo khoảng cách đến đối tượng 1 cái nào bằng 0 ta lấy. Các Bác xem có ổn không???

Nếu không giao thực thì nó không nằm trên đối tượng nào cả, ngược lại thì nó nằm trên cả 2.