Đến nội dung


Hình ảnh
* - - - - 1 Bình chọn

[Yêu cầu] Lisp phân nhỏ tập hợp chọn bằng cách chia ô


  • Please log in to reply
102 replies to this topic

#81 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 23 June 2012 - 07:45 AM

Mất 15'' Ha ơi.
@ Thiep : Lisp của bạn vẫn còn lỗi cú pháp, bạn xem lại giúp nhé
Thiep kg cần loại bỏ các kc có ss 0.5. Vì trên bv đó kg có TH như vậy. Chỉ cần khác 0.002m thì xem như là 0 trùng, cứ thoải mái insert vào đó 1 point

Hi NgaMy, với bản vẽ giải thửa của bạn, thiep lợi dụng ở chỗ là các LINE thường chỉ giao nhau ở điểm startpoint hay endpoint, còn nếu cùng lắm là chúng giao nhau hay chưa giao nhau với 1 khoảng cách từ điểm giao đến startpoint hay endpoint ví dụ = 0.002m. Như vậy không cần phải dùng phương thức "IntersectWith" chi cho tốn thời gian, mà chỉ cần tìm điểm startpoint hay endpoint nào gần nhau với sai số max thì loại khỏi cuộc chơi.
  • 0

#82 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 23 June 2012 - 07:48 AM

Mất 15'' Ha ơi.
@ Thiep : Lisp của bạn vẫn còn lỗi cú pháp, bạn xem lại giúp nhé
Thiep kg cần loại bỏ các kc có ss 0.5. Vì trên bv đó kg có TH như vậy. Chỉ cần khác 0.002m thì xem như là 0 trùng, cứ thoải mái insert vào đó 1 point

Lisp của thiep đã chỉnh sửa nhờ sự góp ý của bạn và Thaistreetz, chạy không hơn 0,5" trên máy core ™2 Duo 2.8GHz, 2G Ram
[/codebox] (defun c:cg (/ TapChon entlst lst tg Now Pstart Pend len n)
(setq TapChon (ssget '((0 . "LINE")))
entlst (ACET-SS-TO-LIST TapChon)
lst nil
)
(setq tg (getvar "millisecs"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(command "undo" "be")
(foreach ent entlst
(setq Pstart (vlax-curve-getStartPoint ent)
Pend (vlax-curve-getEndPoint ent)
)
(setq lst (append lst (list Pstart) (list Pend)))
)
(setq lst (ACET-LIST-REMOVE-DUPLICATES lst 0.002))
(setq len (length lst)
r 0.5
n 0)
(foreach Diem lst
(setq p1 (polar Diem 0 r)
p2 (polar Diem (/ pi 2) r)
p3 (polar Diem pi r)
p4 (polar Diem (/ (* 3 pi) 2) r)
lstF (list p1 p2 p3 p4)
)
(setq ss (ssget "CP" lstF '((0 . "*LINE"))))
(if (and ss (> (sslength ss) 1))
(progn
(entmake (list (cons 0 "POINT") (cons 10 Diem)))
(setq n (1+ n))
)
)
)
(alert (strcat " Mat thoi gian la: "
(rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3)
" giay de tao duoc " (itoa n) " points")
)
(command "undo" "en")
(princ n)
(princ)
) [/codebox]
  • 0

#83 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 23 June 2012 - 04:57 PM

Lisp của thiep đã chỉnh sửa nhờ sự góp ý của bạn và Thaistreetz, chạy không hơn 0,5" trên máy core ™2 Duo 2.8GHz, 2G Ram
[/codebox] (defun c:cg (/ TapChon entlst lst tg Now Pstart Pend len n)
(setq TapChon (ssget '((0 . "LINE")))
entlst (ACET-SS-TO-LIST TapChon)
lst nil
)
(setq tg (getvar "millisecs"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(command "undo" "be")
(foreach ent entlst
(setq Pstart (vlax-curve-getStartPoint ent)
Pend (vlax-curve-getEndPoint ent)
)
(setq lst (append lst (list Pstart) (list Pend)))
)
(setq lst (ACET-LIST-REMOVE-DUPLICATES lst 0.002))
(setq len (length lst)
r 0.5
n 0)
(foreach Diem lst
(setq p1 (polar Diem 0 r)
p2 (polar Diem (/ pi 2) r)
p3 (polar Diem pi r)
p4 (polar Diem (/ (* 3 pi) 2) r)
lstF (list p1 p2 p3 p4)
)
(setq ss (ssget "CP" lstF '((0 . "*LINE"))))
(if (and ss (> (sslength ss) 1))
(progn
(entmake (list (cons 0 "POINT") (cons 10 Diem)))
(setq n (1+ n))
)
)
)
(alert (strcat " Mat thoi gian la: "
(rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3)
" giay de tao duoc " (itoa n) " points")
)
(command "undo" "en")
(princ n)
(princ)
) [/codebox]

Cám ơn Thiep. Chạy trên máy của mình, kết quả như sau :
- của Thiep : " Mat thoi gian la: 0.672 giay de tao duoc 879 points"
- của Ha kết hợp PP chia ô : " Mat thoi gian la: 0.578 giay de tao duoc 880 points"
- cua Ha nguyên gốc : " Mat thoi gian la: 13.906 giay de tao duoc 880 points"
- của một bạn kết hợp PP chia ô : " Mat thoi gian la: 1.203 giay de tao duoc 876 points"
Nói chung của Thiep và của bác Ha có kết hợp PP chia ô chạy nhanh nhất và số lượng điểm như nhau. Những PP khác chậm hơn nhưng có số lượng điểm hơi khác. Có thể do hàm tìm giao của Cad cũng kg ổn định.
Đây là code của bác Ha kết hợp PP chia ô của bác Thái.

(defun c:HATG2 ( / lis i dt p1 p2 Tapchon)
(defun GIAOSS-2 (ss / a i j objlst lst)
(setq i (sslength ss))
(setq objlst (SS->objlst-2 ss))
(while (> (setq j (1- i) i (1- i)) -1)
(setq a (nth i objlst))
(while (> (setq j (1- j)) -1)
(setq lst (cons (NHOM3-2 (vlax-invoke a 'IntersectWith (nth j objlst) acExtendNone)) lst))
)
)
lst
; (print (LM:Unique-2 (apply 'append lst)))
)
(defun NHOM3-2 (lst / a B)
(while lst
(repeat 3
(setq a (cons (car lst) a) lst (cdr lst))
)
(setq b (cons (reverse a) B) a nil)
)
(reverse B)
)
(defun SS->objlst-2 (ss / i lst)
(repeat (setq i (sslength ss))
(setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))
)
)
(defun LM:Unique-2 ( l )
(if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
)
(setq tg (getvar "millisecs"))
(setvar "osmode" 0)
(setq lis (select-c (getvar "extmin") (getvar "extmax") 20 '((0 . "LINE"))))
(setq i 0 liskt nil)
(while (< i (length lis))
(setq dt (nth i lis) p1 (car dt) p2 (cadr dt))
(setq TapChon (ssget "c" p1 p2 '((0 . "line"))))
(setq liskt (append liskt (Giaoss-2 TapChon)))
(setq i (1+ i))
)
(setq liskt (LM:Unique-2 (apply 'append liskt)))
(foreach x liskt (entmake (list (cons 0 "POINT") (cons 10 x))))
(print (strcat " Mat thoi gian la: "
(rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3)
" giay de tao duoc " (itoa (length liskt)) " points")
)
)

  • 1

#84 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5679 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 23 June 2012 - 05:42 PM

PP tìm giao của CAD ổn định - không phụ thuộc linetype, góc view. SSget thì ngược lại
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#85 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 23 June 2012 - 08:59 PM

Cám ơn Thiep. Chạy trên máy của mình, kết quả như sau :
- của Thiep : " Mat thoi gian la: 0.672 giay de tao duoc 879 points"
- của Ha kết hợp PP chia ô : " Mat thoi gian la: 0.578 giay de tao duoc 880 points"
- cua Ha nguyên gốc : " Mat thoi gian la: 13.906 giay de tao duoc 880 points"
- của một bạn kết hợp PP chia ô : " Mat thoi gian la: 1.203 giay de tao duoc 876 points"
Nói chung của Thiep và của bác Ha có kết hợp PP chia ô chạy nhanh nhất và số lượng điểm như nhau. Những PP khác chậm hơn nhưng có số lượng điểm hơi khác. Có thể do hàm tìm giao của Cad cũng kg ổn định.
Đây là code của bác Ha kết hợp PP chia ô của bác Thái.


(defun c:HATG2 ( / lis i dt p1 p2 Tapchon)
(defun GIAOSS-2 (ss / a i j objlst lst)
(setq i (sslength ss))
(setq objlst (SS->objlst-2 ss))
(while (> (setq j (1- i) i (1- i)) -1)
(setq a (nth i objlst))
(while (> (setq j (1- j)) -1)
(setq lst (cons (NHOM3-2 (vlax-invoke a 'IntersectWith (nth j objlst) acExtendNone)) lst))
)
)
lst
; (print (LM:Unique-2 (apply 'append lst)))
)
(defun NHOM3-2 (lst / a B)
(while lst
(repeat 3
(setq a (cons (car lst) a) lst (cdr lst))
)
(setq b (cons (reverse a) B) a nil)
)
(reverse B)
)
(defun SS->objlst-2 (ss / i lst)
(repeat (setq i (sslength ss))
(setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))
)
)
(defun LM:Unique-2 ( l )
(if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
)
(setq tg (getvar "millisecs"))
(setvar "osmode" 0)
(setq lis (select-c (getvar "extmin") (getvar "extmax") 20 '((0 . "LINE"))))
(setq i 0 liskt nil)
(while (< i (length lis))
(setq dt (nth i lis) p1 (car dt) p2 (cadr dt))
(setq TapChon (ssget "c" p1 p2 '((0 . "line"))))
(setq liskt (append liskt (Giaoss-2 TapChon)))
(setq i (1+ i))
)
(setq liskt (LM:Unique-2 (apply 'append liskt)))
(foreach x liskt (entmake (list (cons 0 "POINT") (cons 10 x))))
(print (strcat " Mat thoi gian la: "
(rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3)
" giay de tao duoc " (itoa (length liskt)) " points")
)
)

Hi NgaMy, Lisp của bạn còn thiếu 2 hàm con select-c1 và LM:UNIQUE, và cho kết quả là 880 points là chưa chính xác lắm. Chính xác là 879 points. ban đầu lisp của Thiep cho kết quả 881 points, Thiep rất mất thời gian điểm tìm ra nguyên nhân này và phải "mua" thời gian chạy lisp thêm 0,07" nữa đó!
  • 0

#86 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 23 June 2012 - 09:55 PM

Hi NgaMy, Lisp của bạn còn thiếu 2 hàm con select-c1 và LM:UNIQUE, và cho kết quả là 880 points là chưa chính xác lắm. Chính xác là 879 points. ban đầu lisp của Thiep cho kết quả 881 points, Thiep rất mất thời gian điểm tìm ra nguyên nhân này và phải "mua" thời gian chạy lisp thêm 0,07" nữa đó!

Mình cũng dự định tìm thử xem tại sao lại có sự khác nhau đó. Nếu Thiep đã tìm ra rồi thì nói cho mình biết lý do và chỉ ra vị trí của nó để tránh cho những lần khác.
Sau đây là code của hàm select-c (kg phải select-c1) của bác Thai:

(defun select-c (p1 p2 n filter)
(if (setq ss (ssget "c" p1 p2 filter))
(if (< (sslength ss) (abs (setq n (* -1 n))))
(list (list p1 p2))
(if (< n 0)
(append (select-c p1 (list (* 0.5 (+ (car p2) (car p1))) (cadr p2)) n filter)
(select-c p2 (list (* 0.5 (+ (car p2) (car p1))) (cadr p1)) n filter))
(append (select-c p1 (list (car p2) (* 0.5 (+ (cadr p2) (cadr p1)))) n filter)
(select-c p2 (list (car p1) (* 0.5 (+ (cadr p2) (cadr p1)))) n filter))))))
Còn hàm LM:UNIQUE bạn sửa thành LM:UNIQUE-2 luôn. Hàm này do bác Ha viết.

Mình thấy PP của bạn cũng tương đồng với PP chia ô nên mới có kq nhanh như vậy. Có thể mình sẽ test thêm trên một số loại file và dữ liệu khác để biết cx về 2 PP này. Tuy nhiên, PP chia ô thì khó bỏ sót đối tượng (vì tất cà các hình vuông phủ kín đường bao bv), còn PP của bạn khi gặp đối tượng là một cung tròn, một đoạn cong thì kg rõ có cx kg
  • 0

#87 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 23 June 2012 - 10:30 PM

Bác sửa luôn phần khai báo biến và tham số của hàm trên cho em nhé. (p1 p2 n filter) thành (p1 p2 n filter / ss)
Em quên chưa định nghĩa biến ss là biến cục bộ.
  • 1

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#88 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 24 June 2012 - 12:42 AM

Bác sửa luôn phần khai báo biến và tham số của hàm trên cho em nhé. (p1 p2 n filter) thành (p1 p2 n filter / ss)
Em quên chưa định nghĩa biến ss là biến cục bộ.

Cám ơn bác Thai.
@Thiep : Hàm của Thiep như mình đã nói ở trước, nó kg chạy khi có đối tượng kg gối đỉnh vào nhau. Mình đã thử khi vẽ 2 line bất kỳ thì nó kg xét hai line này. Xem sơ qua cách viết của Thiep có lẽ trên bv nếu có line dài nhiều sẽ tốn thời gian hơn PP chia ô vì lúc đó nó sẽ chọn mỗi lần nhiều đối tượng hơn. PP chia ô nói chung sẽ ổn định nhất vì mình đã khống chế số đối tượng cho mỗi lần chọn. Tuy nhiên, vđ nằm ở giải thuật của bác Thai, làm sao tránh đc vòng lặp bị treo vì khi định số đối tượng trong 1 ô, nếu định nhiều quá làm chậm quá trình, định ít quá gây lỗi như đã nêu.
  • 0

#89 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 24 June 2012 - 01:17 PM

Cám ơn Thiep. Chạy trên máy của mình, kết quả như sau :
- của Thiep : " Mat thoi gian la: 0.672 giay de tao duoc 879 points"
- của Ha kết hợp PP chia ô : " Mat thoi gian la: 0.578 giay de tao duoc 880 points"
- cua Ha nguyên gốc : " Mat thoi gian la: 13.906 giay de tao duoc 880 points"
- của một bạn kết hợp PP chia ô : " Mat thoi gian la: 1.203 giay de tao duoc 876 points"
Nói chung của Thiep và của bác Ha có kết hợp PP chia ô chạy nhanh nhất và số lượng điểm như nhau. Những PP khác chậm hơn nhưng có số lượng điểm hơi khác. Có thể do hàm tìm giao của Cad cũng kg ổn định.
Đây là code của bác Ha kết hợp PP chia ô của bác Thái.


(defun c:HATG2 ( / lis i dt p1 p2 Tapchon)
(defun GIAOSS-2 (ss / a i j objlst lst)
(setq i (sslength ss))
(setq objlst (SS->objlst-2 ss))
(while (> (setq j (1- i) i (1- i)) -1)
(setq a (nth i objlst))
(while (> (setq j (1- j)) -1)
(setq lst (cons (NHOM3-2 (vlax-invoke a 'IntersectWith (nth j objlst) acExtendNone)) lst))
)
)
lst
; (print (LM:Unique-2 (apply 'append lst)))
)
(defun NHOM3-2 (lst / a B)
(while lst
(repeat 3
(setq a (cons (car lst) a) lst (cdr lst))
)
(setq b (cons (reverse a) B) a nil)
)
(reverse B)
)
(defun SS->objlst-2 (ss / i lst)
(repeat (setq i (sslength ss))
(setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))
)
)
(defun LM:Unique-2 ( l )
(if l (cons (car l) (LM:Unique-2 (vl-remove (car l) (cdr l)))))
)
(setq tg (getvar "millisecs"))
(setvar "osmode" 0)
(setq lis (select-c (getvar "extmin") (getvar "extmax") 20 '((0 . "LINE"))))
(setq i 0 liskt nil)
(while (< i (length lis))
(setq dt (nth i lis) p1 (car dt) p2 (cadr dt))
(setq TapChon (ssget "c" p1 p2 '((0 . "line"))))
(setq liskt (append liskt (Giaoss-2 TapChon)))
(setq i (1+ i))
)
(setq liskt (LM:Unique-2 (apply 'append liskt)))
(foreach x liskt (entmake (list (cons 0 "POINT") (cons 10 x))))
(print (strcat " Mat thoi gian la: "
(rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3)
" giay de tao duoc " (itoa (length liskt)) " points")
)
)

- Phiền bác Ha xem qua và lồng cái hàm kiểm tra điểm trùng sao cho nó hợp lý khi kết hợp với PP chia ô giúp. Trên bv lớn 42200dt nếu chạy code của bạn kết hợp PP chia ô chỉ mất 26'' nhưng khi mình cố tình thêm code kiểm tra điểm trùng thì nó tăng lên 350''. Có thể do mình chưa hiểu hết code của bác nên cách kết hợp chưa hay, một nữa là khi trên bv lớn thì list nó lớn nên thời gian kiểm tra tăng lên đáng kể.
- PP chia ô kết hợp code của bác hiện là chạy nhanh nhất rồi. Mình test code của Thiep trên bv lớn cũng mất 418''.
Cám ơn bác
  • 0

#90 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 24 June 2012 - 01:44 PM

Bạn gởi bản vẽ 42200 đt lên để dễ kiểm tra. Chiều tôi sẽ cố gắng xem sao. Giờ ngáp quá vì thằng Euro rồi. :lol:
  • 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ờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* 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.


#91 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 24 June 2012 - 03:57 PM

Bạn gởi bản vẽ 42200 đt lên để dễ kiểm tra. Chiều tôi sẽ cố gắng xem sao. Giờ ngáp quá vì thằng Euro rồi. :lol:

Nó ở #6 cùng chủ đề
  • 0

#92 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 24 June 2012 - 09:36 PM

Tiếc là dù tôi đã thêm (vl-load-com) + chép hàm select đầy đủ, nhưng khi chạy nó báo lối như ở #78 nên không thể làm gì được với yêu cầu của bạn.
  • 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ờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* 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.


#93 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 24 June 2012 - 11:00 PM

Cám ơn bác Thai.
@Thiep : Hàm của Thiep như mình đã nói ở trước, nó kg chạy khi có đối tượng kg gối đỉnh vào nhau. Mình đã thử khi vẽ 2 line bất kỳ thì nó kg xét hai line này. Xem sơ qua cách viết của Thiep có lẽ trên bv nếu có line dài nhiều sẽ tốn thời gian hơn PP chia ô vì lúc đó nó sẽ chọn mỗi lần nhiều đối tượng hơn. PP chia ô nói chung sẽ ổn định nhất vì mình đã khống chế số đối tượng cho mỗi lần chọn. Tuy nhiên, vđ nằm ở giải thuật của bác Thai, làm sao tránh đc vòng lặp bị treo vì khi định số đối tượng trong 1 ô, nếu định nhiều quá làm chậm quá trình, định ít quá gây lỗi như đã nêu.

Hi Ngamy, thiep đã chạy thử lisp của bạn có bị lỗi như sau:
* không tạo điểm tại 2 vị trí: (588359.873,1182011.308) và (588557.769,1182018.526)
: lỗi này do hàm intersectWith nó hiểu rằng 2 đoạn thẳng gần song song nhau sẽ gặp nhau ở vô cùng.
* Một số điểm gần như trùng nhau:
- tại vị trí (588434.466,1181927.813) có 2 điểm hầu như gần trùng nhau.
- tại vị trí (588370.820,1181943.243) có 3 điểm hầu như gần trùng nhau.
- tại vị trí (588343.175,1181971.641) có 5 điểm hầu như gần trùng nhau.
: lỗi này cũng do intersectWith tạo ra khi nó hiểu rằng có 3, hay 4 đoạn thẳng hội tụ gần nhau tại 1 điểm mà không gặp nhau tại 1 điểm, thì nó tìm ra nhiều điểm giao như Thiệp đã đề cập bài trước.
Còn Lisp của thiep không chạy khi có đối tượng không gối đỉnh vào nhau, là vì thiep không dùng phương thức intersectWith mà chỉ dùng thuật toán so sánh các điểm gần nhau : có 2 hay nhiều điểm nằm gần nhau trong phạm vi sai số fuzz thì loại bỏ hết chỉ còn 1 điểm để tạo point, hàm (ACET-LIST-REMOVE-DUPLICATES ). Bvẽ của bạn, thiep thử cho sai số fuzz = 0.002, lisp tạo ra 879 points. Sau khi phát hiện lisp của bạn có lỗi, quay lại bản vẽ, thiep phát hiện có 1 cạnh giải thửa có chiều dài 0.0375 (đo sai số chính xác thật!) và thiep thử cho sai số 0.03 thì lisp tạo ra chỉ có 873 points!!! Con số này có lẽ đúng nhất và lisp cũng chỉ chạy có 0,515"
  • 1

#94 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 24 June 2012 - 11:47 PM

@ Thiep : Thực ra mình cần thuật toán cắt nhau, tức 2 đt cắt nhau chứ kg gối đầu vào nhau. Nếu 2 đt gối đầu vào nhau thì dùng thuật toán khác sẽ nhanh hơn. VD :

(defun c:tentpoint( / ss i n name p10 p11 lis1 lis2)
(defun diem( name n)
(cdr (assoc n (entget name)))
)
(setq tg (getvar "millisecs"))
(setq ss (ssget "x" '((0 . "line"))))
(if ss (progn
(setq i 0 L (sslength ss) lis nil n 0)
(while (< i L)
(setq name (ssname ss i))
(setq p10 (diem name 10) p11 (diem name 11))
(if (null (assoc p10 lis1)) (setq lis1 (append lis1 (list (list p10)))) (if (null (assoc p10 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p10)))
(setq lis2 (append lis2 (list (list p10))))))
)
(if (null (assoc p11 lis1)) (setq lis1 (append lis1 (list (list p11)))) (if (null (assoc p11 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p11)))
(setq lis2 (append lis2 (list (list p11))))))
)
(setq i (1+ i))
)
))
(print (strcat " Mat thoi gian la: " (rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3) " giay de tao duoc " (itoa n) " points"))
)
Sau khi chạy thì : " Mat thoi gian la: 0.328 giay de tao duoc 871 points"
@ bác Ha : bác thay dòng 20 ở dòng này thành 50
(setq lis (select-c (getvar "extmin") (getvar "extmax") 20 '((0 . "LINE"))))
tức 1 ô có 20 đt thành 1 ô có 50 đt
  • 1

#95 thiep

thiep

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 369 Bài viết
Điểm đánh giá: 260 (khá)

Đã gửi 25 June 2012 - 07:17 AM

@ Thiep : Thực ra mình cần thuật toán cắt nhau, tức 2 đt cắt nhau chứ kg gối đầu vào nhau. Nếu 2 đt gối đầu vào nhau thì dùng thuật toán khác sẽ nhanh hơn. VD :


(defun c:tentpoint( / ss i n name p10 p11 lis1 lis2)
(defun diem( name n)
(cdr (assoc n (entget name)))
)
(setq tg (getvar "millisecs"))
(setq ss (ssget "x" '((0 . "line"))))
(if ss (progn
(setq i 0 L (sslength ss) lis nil n 0)
(while (< i L)
(setq name (ssname ss i))
(setq p10 (diem name 10) p11 (diem name 11))
(if (null (assoc p10 lis1)) (setq lis1 (append lis1 (list (list p10)))) (if (null (assoc p10 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p10)))
(setq lis2 (append lis2 (list (list p10))))))
)
(if (null (assoc p11 lis1)) (setq lis1 (append lis1 (list (list p11)))) (if (null (assoc p11 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p11)))
(setq lis2 (append lis2 (list (list p11))))))
)
(setq i (1+ i))
)
))
(print (strcat " Mat thoi gian la: " (rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3) " giay de tao duoc " (itoa n) " points"))
)
Sau khi chạy thì : " Mat thoi gian la: 0.328 giay de tao duoc 871 points"
@ bác Ha : bác thay dòng 20 ở dòng này thành 50
(setq lis (select-c (getvar "extmin") (getvar "extmax") 20 '((0 . "LINE"))))
tức 1 ô có 20 đt thành 1 ô có 50 đt

Hi Ngamy, thuật toán của bạn nhanh hơn nhưng bị lỗi: lisp tentpoint không tạo điểm tại 2 vị trí (588354.256,1181945.211) và (588557.766, 1182018.526). Nếu bạn hoàn chỉnh lisp của bạn để tạo thêm 2 điểm ở trên nữa thì đúng 873 điểm!. Lúc đó thời gian chạy lisp sẽ khác ngay.
  • 1

#96 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 25 June 2012 - 10:48 PM

Hi Ngamy, thuật toán của bạn nhanh hơn nhưng bị lỗi: lisp tentpoint không tạo điểm tại 2 vị trí (588354.256,1181945.211) và (588557.766, 1182018.526). Nếu bạn hoàn chỉnh lisp của bạn để tạo thêm 2 điểm ở trên nữa thì đúng 873 điểm!. Lúc đó thời gian chạy lisp sẽ khác ngay.

Việc tìm ra 873 hay 871 thường do sai số nhỏ của một vài điểm tọa độ, việc cho ra kq 871 hay 873 đôi lúc cũng gây khó hiểu. VD với hàm trên nếu mình kiểm tra bẳng tọa độ thì nó tạo 871 đểm, nếu chuyển tọa độ thành chuỗi với 3 số lẽ vẫn cho 871 điểm nhưng với 2 số lẽ cho 873 điểm. Thật khó hiểu. Nhưng thời gian thì kg thay đổi lắm. Từ 0.328 lên 0.360s. Đây là code mới :

(defun c:tendpoint( / ss i n name p10 p11 lis1 lis2 s10 s11)
(defun pointtostr( p)
(strcat (rtos (car p) 2 2) " " (rtos (cadr p) 2 2))
)
(defun diem( name n)
(cdr (assoc n (entget name)))
)
(setq tg (getvar "millisecs"))
(setq ss (ssget "x" '((0 . "line"))))
(if ss (progn
(setq i 0 L (sslength ss) lis1 nil lis2 nil n 0)
(while (< i L)
(setq name (ssname ss i))
(setq p10 (diem name 10) p11 (diem name 11) s10 (pointtostr p10) s11 (pointtostr p11))
(if (null (assoc s10 lis1)) (setq lis1 (append lis1 (list (list s10)))) (if (null (assoc s10 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p10)))
(setq lis2 (append lis2 (list (list s10))))))
)
(if (null (assoc s11 lis1)) (setq lis1 (append lis1 (list (list s11)))) (if (null (assoc s11 lis2)) (progn
(setq n (1+ n))
(entmake (list (cons 0 "POINT") (cons 10 p11)))
(setq lis2 (append lis2 (list (list s11))))))
)
(setq i (1+ i))
)
))
(print (strcat " Mat thoi gian la: " (rtos (/ (- (getvar "millisecs") tg) 1000.0) 2 3) " giay de tao duoc " (itoa n) " points"))
)
Tuy nhiên, code trên chỉ nhanh khi bv nhỏ thôi. Nếu bv lớn việc tạo nhiều list sẽ làm tốc độ giảm đáng kể.
Bây giờ nếu bạn nào cảm thấy đầu óc quá nhàm chán hãy thử tìm giao (chứ kg phải điểm đầu và cuối line, -mình có thể kéo dài các line ra 1 đoạn để chúng chỉ cắt nhau) của bv 42200đt ở #6 sao cho nó có thể chạy với hiệu suất từ 350s (chạy theo code chia ô kết hợp tìm giao của bác Ha mà mình đã post ở #89) giảm đến 250s hay ít hơn nữa (tuỳ máy) , với khoảng 35680 điểm đc tạo. Máy mình đạt đc hiện nay là từ 350s xuống 250s, mình sẽ cố gắng giảm xuống tiếp. Mình sẽ test trên máy mình để đánh giá. Các bạn có thể nhào nặn từ bất cứ code nào tìm đc tính tử đây trở về trước. Bạn nào cảm thấy buốn thì nhào zdô. Sau 3 ngày mình sẽ post đáp án lên
  • 0

#97 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 26 June 2012 - 10:45 PM

Cám ơn tất cả mọi người. Nhờ code của các bạn mình đã nhào nặn xuống dưới 30''. Có lẽ tạm nghỉ ít hôm để tập trung vào công việc. Mình sẽ trở lại với đề tài liên quan và hấp dẫn hơn.
  • 0

#98 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 02 July 2012 - 06:38 PM

Cám ơn tất cả mọi người. Nhờ code của các bạn mình đã nhào nặn xuống dưới 30''. Có lẽ tạm nghỉ ít hôm để tập trung vào công việc. Mình sẽ trở lại với đề tài liên quan và hấp dẫn hơn.

Trước khi nói đến chủ đề mới mình sẽ đưa cái đáp án cũ lên để các bạn tham khảo. Dưới đấy là code tìm và chèn point vào vị trí giao các đối tượng. Khi thực hiện trên bv có 42200đt ở #6 chỉ mất dưới 30''. Có thể đây là kết quả khó có thể đạt đc nếu kg có PP chia ô và một số PP khác. Các bạn có thể thắc mắc tại sao mình cứ quần tới quần lui vđ này, vì nó là nội dung chính (nói cx hơn là công đoạn chính của chủ đề tiếp theo) nên mình muốn nó thật chuẩn và thật nhanh. Đoạn code dưới đây sd PP chia ô của bác Thai, PP tìm giao của bác Ha và một ít công sức của mình.

(vl-load-com)
(defun pointtostr( p)
(strcat (rtos (car p) 2 2) " " (rtos (cadr p) 2 2))
)
;Ham kiem tra vi tri ddiem va HCN
(defun diemvaHCN( p1 p2 p / x y x1 y1 x2 y2 k)
(setq x (car p) y (cadr p) x1 (car p1) y1 (cadr p1) x2 (car p2) y2 (cadr p2))
(if (> x1 x2) (setq k x1 x1 x2 x2 k))
(if (> y1 y2) (setq k y1 y1 y2 y2 k))
(cond
((if (or (< x x1) (< y y1) (> x x2) (> y y2)) 1))
((if (and (> x x1) (< x x2) (> y y1) (< y y2)) -1))
(T 0)
)
)
;Doan nay cua bac Thai
(defun select-c (p1 p2 n filter / ss)
(if (setq ss (ssget "c" p1 p2 filter))
(if (< (sslength ss) (abs (setq n (* -1 n))))
(list (list p1 p2))
(if (< n 0)
(append (select-c p1 (list (* 0.5 (+ (car p2) (car p1))) (cadr p2)) n filter)
(select-c p2 (list (* 0.5 (+ (car p2) (car p1))) (cadr p1)) n filter))
(append (select-c p1 (list (car p2) (* 0.5 (+ (cadr p2) (cadr p1)))) n filter)
(select-c p2 (list (car p1) (* 0.5 (+ (cadr p2) (cadr p1)))) n filter))))))

;Doan nay cua bac Doan Van Ha
(defun c:HATG2 ( / lis lis1 i dt p1 p2 Tapchon lis2 liskt liskt2 n tg x)
(defun GIAOSS-2 (ss / a i j objlst lst)
(setq i (sslength ss))
(setq objlst (SS->objlst-2 ss))
(while (> (setq j (1- i) i (1- i)) -1)
(setq a (nth i objlst))
(while (> (setq j (1- j)) -1)
(setq lst (cons (NHOM3-2 (vlax-invoke a 'IntersectWith (nth j objlst) acExtendNone)) lst))
)
)
lst
; (LM:Unique-2 (apply 'append lst))
)
(defun NHOM3-2 (lst / a B)
(while lst
(repeat 3
(setq a (cons (car lst) a) lst (cdr lst))
)
(setq b (cons (reverse a) B) a nil)
)
(reverse B)
)
(defun SS->objlst-2 (ss / i lst)
(repeat (setq i (sslength ss))
(setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))
)
)
(defun LM:Unique-2 ( l )
(if l (cons (car l) (LM:Unique-2 (vl-remove (car l) (cdr l)))))
)
(setq tg (getvar "millisecs"))
(setvar "osmode" 0)
(setq lis (select-c (getvar "extmin") (getvar "extmax") 30 '((0 . "LINE"))))
(setq i 0 liskt2 nil n 0)
(while (< i (length lis))
(setq dt (nth i lis) p1 (car dt) p2 (cadr dt) liskt nil)
(setq TapChon (ssget "c" p1 p2 '((0 . "line"))))
(setq lis1 (giaoss-2 TapChon))
(setq j 0 L (length lis1))
(foreach x lis1 (if x (progn (setq x (car x))
(cond
((= (diemvaHCN p1 p2 x) 0)
(if (null (ASSOC (pointtostr x) liskt2)) (progn
(setq liskt2 (append liskt2 (LIST (list (pointtostr X)))))
(entmake (list (cons 0 "point") (cons 10 X)))
(setq n (1+ n))
))
)
((< (diemvaHCN p1 p2 x) 0)
(if (null (ASSOC (pointtostr x) liskt)) (progn
(setq liskt (append liskt (LIST (list (pointtostr X)))))
(entmake (list (cons 0 "point") (cons 10 X)))
(setq n (1+ n))
))
)
)
)))
Code trên chỉ có một vđ nhỏ như mình và bác Thai đã nêu ở PP chia ô. Nếu tập chọn kg có đối tượng thì vòng lặp kg thoát. Mình cũng muốn chỉnh lại đoạn này cho nó an toàn hơn nhưng chưa làm đc. Bác Thai hoặc bạn nào có thể thì chỉnh giúp cho nó thoát khi kg chọn đc đt nào.

Chủ đề 4 : Viết Lệnh tạo đường bao tương tự lệnh boundary của Cad (nhưng cách làm hoàn toàn khác).
Tại sao lại viết lại lệnh này khi Cad đã có. Vì những lý do sau :
- Lệnh Cad chạy kg được những TH phức tạp
- Thông tin trả về chưa đầy đủ.
Phần lớn các bạn đều biết lệnh boundary của Cad chỉ tính tốt trong TH các đối tượng tương đối thoáng, còn lại thường báo lỗi. Đã có nhiều lần một số cao thủ muốn viết lại lệnh này nhưng chưa đủ kiên trì. Hôm nay mình muốn nhờ các bạn hỗ trợ hết mình để viết lại lệnh này, thậm chí nó sẽ có thể chạy tốt hơn và nhanh hơn Cad, thông tin đưa về cũng nhiều hơn. Mình sẽ đưa ra một số yêu cầu tương đối khó, mong tìm đc những đoạn code tốt nhất để ráp lại thành một lệnh hoàn chỉnh. Để viết đc lệnh trên cần rất nhiều thứ. Nếu đưa ra nhiều yêu cầu một lúc sẽ làm rối vđ và các bạn cũng ngán. Trước hết mình nhờ các bạn giúp :
- Lập danh sách quản lý tọa độ điểm giao và các đối tượng giao tại điểm này (lưu trong biến toàn cục). Mục đích để truy xuất các đối tượng giao nhau tại một điểm bất kỳ khi cung cấp tọa độ của nó.
Đây là hàm rất quan trọng nên rất cần sự chuẩn xác và tốc độ. Mong các cao thủ ra tay.
Theo mình thì có thể lưu danh sách tọa độ và đối tượng như sau : lis=((p1 h1 h2 h3) (p2 h1 h4 h5) ...) (trong đó pi là tọa độ, hi : mã dxf=5 của đt)
Khi dùng hàm truy xuất có dạng AAA( p lis) (assoc p lis)). Khi gọi (AAA p) -> (p h1 h2 h3)
Đó là suy nghĩ của mình. Còn cách nào hay hơn tùy các bạn.

Thực ra lệnh này trước đây mình đã viết bằng lisp và arx, tuy nhiên mình chỉ đủ sức viết với dữ liệu line và cũng chưa thật tốt, nhưng mình hoàn toàn làm chủ đc nó. Hôm nay có Cadviet hỗ trợ hy vọng sẽ cùng nhau viết đc một lệnh chạy trên nhiều loại đối tượng như lệnh của Cad nhưng mức độ sâu hơn và hoàn chỉnh hơn. Cám ơn các bạn trước.

P/S : Theo góp ý của bác Thai ở dưới, chủ đề này đã được lập riêng ở đây : http://www.cadviet.c...showtopic=65055
  • 0

#99 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 03 July 2012 - 02:28 AM

Code trên chỉ có một vđ nhỏ như mình và bác Thai đã nêu ở PP chia ô. Nếu tập chọn kg có đối tượng thì vòng lặp kg thoát. Mình cũng muốn chỉnh lại đoạn này cho nó an toàn hơn.

Hình như bác có nhầm lẫn gì đó ở đây. trong code đó em có hàm kiểm tra điều kiện tập chọn có đối tượng ngay từ đầu rồi mà
(defun select-c (p1 p2 n filter / ss)
(if (setq ss (ssget "c" p1 p2 filter))

(thân hàm)
))
rõ ràng nếu ss = nil thì hàm kết thúc luôn chứ không có nhảy vào thân hàm để lặp tiếp.

Chủ đề mới này của bác em nghĩ nên tách ra 1 topic riêng được rồi bác ạ. Bác có thể để 1 liên kết đến topic này trong trường hợp có gì đó liên quan. như thế tiện theo dõi hơn.
lệnh boundary đúng là khiến nhiều người phải bức xúc thật. Đây sẽ là vấn đề nhiều người quan tâm, tiêu đề của topic hiện tại không có gì liên quan đến chủ đề này nữa rồi.
em cũng nhiều lần bức xúc quá mà đi mò xem có cách nào thay thế nó không nhưng giờ vẫn chào thua. Hi vọng các bác chung tay làm được. em lót dép hóng, chờ kết quả :D
  • 1

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#100 TRUNGNGAMY

TRUNGNGAMY

    biết lệnh block

  • Members
  • PipPipPipPipPipPip
  • 401 Bài viết
Điểm đánh giá: 91 (tàm tạm)

Đã gửi 09 July 2012 - 01:44 AM

Hình như bác có nhầm lẫn gì đó ở đây. trong code đó em có hàm kiểm tra điều kiện tập chọn có đối tượng ngay từ đầu rồi mà
(defun select-c (p1 p2 n filter / ss)
(if (setq ss (ssget "c" p1 p2 filter))
(thân hàm)
))
rõ ràng nếu ss = nil thì hàm kết thúc luôn chứ không có nhảy vào thân hàm để lặp tiếp.

Có lẽ mình diễn tả kg rõ, ý mình muốn nói là làm thế nào cho hàm này kg bị "treo" khi mình chọn số đối lượng trong 1 ô khá nhỏ như TH đã gặp. Có thể dùng biện pháp nào đó để khắc phục. Vì việc chọn số đối tượng lớn thì an toàn hơn (tuy nhiên cũng chưa chắc là tuyệt đối trong mọi TH) nhưng nó chạy chậm hơn. Phiền bác giúp cho. Cám ơn bác
  • 0