Đế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

#41 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 15 June 2012 - 07:54 PM

1). Ý tưởng của bạn gần trùng với ý tưởng đã viết trong lisp.
2). Bạn gởi cái bản vẽ đó lên. Bây giờ nếu có sự cố thì chỉ sửa chút thôi.
P/S (14h50 15/6/2012): cách giải bài toán tổng quát xem link ở đây:
http://www.cadviet.c...=0

Mình đã tải code tổng quát của bạn và chạy thử. Với hình trong file mình up lần 1, có điều lạ :
- Khi chạy trên cad2002, nó kg tìm đc vị trí, trên cad2006, 2010 thì đc
- Với file mình up lên sau đây, cái hình mới, cả các đời cad đều "Buồn quá". Bạn xem lại giúp
http://www.cadviet.c.../37170_h1_1.dwg
  • 0

#42 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 15 June 2012 - 08:14 PM

Hế hề hế,
Bác có thể cho biết rõ hơn nó cho ra cái kết quả thế nào không ạ??? Mình đã test trên bản vẽ bác gửi thì thấy Ok như hình đã post mà....

Cám ơn bác. Mình chạy thử code của bác, nếu cho kc giữa 2 đối tượng nhỏ thì nó chạy khá lâu, kg thể ứng dụng thực tế. Khi mình cho kc lớn hơn cho nó chạy nhanh thì nó kg tìm đc. Còn cho kc =4 thì đúng là cho kq giống của bác.
Mình nghĩ cái cách của bác có cái hay là nó sẽ tìm đc trong TH tổng quát. Tuy nhiên, câu hỏi kc giữa 2 đối tượng thì khó trả lời quá, chính mình là tác giả cái hình còn chưa biết trả lời sao cho phù hợp. Có thể bác nên cho CT tự quyết định cái kc này thì hơn. Thêm nữa, khi chạy CT việc cho thấy quá trình chạy trên màn hình đồ họa và trên dòng lệnh sẽ ngốn khá nhiều thời gian, bác nên cho nó chạy một các im lặng thì sẽ nhanh hơn. Nếu bác có thể hạn chế vùng kiểm tra nhỏ hơn thì sẽ tiết kiệm đc nhiều hơn
  • 0

#43 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 15 June 2012 - 09:51 PM

Mình đã tải code tổng quát của bạn và chạy thử. Với hình trong file mình up lần 1, có điều lạ :
- Khi chạy trên cad2002, nó kg tìm đc vị trí, trên cad2006, 2010 thì đc
- Với file mình up lên sau đây, cái hình mới, cả các đời cad đều "Buồn quá". Bạn xem lại giúp
http://www.cadviet.c.../37170_h1_1.dwg

Câu 1: tiếc là không có đủ 3 cad để test.
Câu 2: có sự nhầm lẫn khi chuyển từ code cũ sang code mới.
Đã sửa, vẫn link cũ ở topic bên kia.
  • 1

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


#44 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 16 June 2012 - 01:38 AM

Câu 1: tiếc là không có đủ 3 cad để test.
Câu 2: có sự nhầm lẫn khi chuyển từ code cũ sang code mới.
Đã sửa, vẫn link cũ ở topic bên kia.

Cám ơn bạn.
Có lẽ bạn đã chỉnh sửa gì đó làm cho thời gian chạy hình 1 chậm hơn (từ 3" đã tăng lên 13") dù cả 2 hình đều chạy đc. Nếu như bạn có hứng thú thì thử tiếp tục suy nghĩ xem có cải thiện đc tốc độ hơn kg vì mình nghĩ đây là một ứng dụng rất hay. Mình sẽ tiếp tục test các TH khác nữa để kiểm tra xem.

Mình có một số ý tưởng về việc vận dụng phương pháp chia ô ứng dụng trong ngành bản đồ, mình sẽ lần lượt đưa ra để nhờ các bạn giúp sức và tham khảo.
  • 0

#45 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 16 June 2012 - 11:46 AM

Cám ơn bạn.
Có lẽ bạn đã chỉnh sửa gì đó làm cho thời gian chạy hình 1 chậm hơn (từ 3" đã tăng lên 13") dù cả 2 hình đều chạy đc. Nếu như bạn có hứng thú thì thử tiếp tục suy nghĩ xem có cải thiện đc tốc độ hơn kg vì mình nghĩ đây là một ứng dụng rất hay. Mình sẽ tiếp tục test các TH khác nữa để kiểm tra xem.
Mình có một số ý tưởng về việc vận dụng phương pháp chia ô ứng dụng trong ngành bản đồ, mình sẽ lần lượt đưa ra để nhờ các bạn giúp sức và tham khảo.

1). Chậm hơn tí là do tôi sửa nx từ 50 lên 100. Tôi đã sửa thêm mấy tí nữa cho gọn lisp. Bạn down lại lisp ở link cũ bên kia nhé.
2). Bạn cứ post y/c mới lên. Hy vọng sẽ có người giúp. Chủ đề của bạn cũng khá lý thú vì có những ứng dụng hay trong thực tế.
3). Yêu cầu mới nên post ở trang bên kia thì phù hợp với chủ đề hơn là post ở đây 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.


#46 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 16 June 2012 - 05:34 PM

@TNM : sao k phải là topic tìm giải thuật r bác code lại bằng ARX ^^ ?
  • 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


#47 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 17 June 2012 - 12:53 AM

1). Chậm hơn tí là do tôi sửa nx từ 50 lên 100. Tôi đã sửa thêm mấy tí nữa cho gọn lisp. Bạn down lại lisp ở link cũ bên kia nhé.
2). Bạn cứ post y/c mới lên. Hy vọng sẽ có người giúp. Chủ đề của bạn cũng khá lý thú vì có những ứng dụng hay trong thực tế.
3). Yêu cầu mới nên post ở trang bên kia thì phù hợp với chủ đề hơn là post ở đây bạn ạ.

@ Ketxu : Có lẽ còn lâu mình mới chuyển code Lisp qua Arx mặc dù rất muốn. Ngay chính đọc trên Lisp mình còn chưa hiểu vì các bạn đi nhanh quá, toàn những hàm vl, vla ... những cái này mình thua. Nếu như các bạn nói rõ ý tưởng và chỉ sd các hàm và kiểu dữ liệu chuẩn may ra mình còn có cửa hiểu đc.
@ Ha : Lúc viết yêu cầu ở đây mình kg nghĩ đến sẽ nêu những ý tưởng tiếp theo nên đặt tên nó hơi bị hạn hẹp. Thực ra những suy nghĩ của mình nó đi hơi sâu vào ngành nên cũng sẽ ít người quan tâm. Tuy nhiên, những ý tưởng đó là do mình chắc lọc ra đc sau những tháng ngày trằn trọc nên mình nêu ra lỡ có bạn nào đang nghĩ tới có thể tham khảo để phát triển thêm. Về phần mình hiện nay cũng kg còn trẻ nữa và kiến thức cũng hạn hẹp nên cũng khó thực hiện những gì mình muốn, chỉ tham gia cho vui và cũng chia sẽ những gì mình đúc kết đc thôi. Được sự ủng hộ của các bạn, mình sẽ tiếp tục.

- Ý tiếp theo mình muốn các bạn giúp đỡ là :

Chủ đề 3 : Từ danh sách toạ độ đỉnh các HCN, khi cung cấp một điểm, hãy chỉ ra nhanh nhất điểm đó thuộc hay nằm trong HCN nào

Giải thích thêm : Căn cứ cái list tọa độ đỉnh của HCN từ giải thuật "chia ô" do bác Thai và bác Bình viết, khi cung cấp một điểm, hãy chỉ ra ngay vị trí nó nằm trong HCN nào, nếu trùng cạnh hay đỉnh HCN thì chỉ ra 2 hoặc 4 hình HCN (có thể chỉ vị trí hay tên HCN cũng đc). Cái này rất cần tốc độ vì sẽ phục vụ cho ý tưởng tiếp theo. Cám ơn các bạn
  • 0

#48 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 17 June 2012 - 06:42 PM

Trong 2 cái lisp chia ô của 2 bác, tôi lấy lisp của bác Thai, sau đó bổ sung "Chủ đề 3" cho bạn.
Lisp trả về list các ename chứa điểm nhập vào (1; 2 hoặc 4).
Về tốc độ: nó chỉ tăng thêm ep_xi_lon so với lisp gốc.
Hy vọng bạn hài lòng.

(defun C:HA()
(setq p (getpoint "\nPick point: "))
(setq lst1 '())
(command "zoom" "e")
(princ "\nChuong trinh dang chay. Xin vui long doi...\n")
(setq entlst (mapcar '(lambda (x) (MakeRectang (car x) (cadr x))) (select-c (getvar "extmin") (getvar "extmax") 500 '((0 . "LINE")))))
(foreach ent entlst
(if (not (HA:InOut ent p))
(setq lst1 (cons ent lst1))))
lst1)
(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))))))
(defun MakeRectang (p1 p2)
(entmakex (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 70 1)
(cons 10 p1) (cons 10 (list (car p1) (cadr p2))) (cons 10 p2) (cons 10 (list (car p2) (cadr p1))))))
(defun HA:InOut (ent p / lst tt z n)
(setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
tt ((lambda (n) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list n n n))) (float (length lst)))
lst (vl-sort lst '(lambda (a B) (> (angle tt a) (angle tt B))))
lst (append lst (list (car lst))))
(setq z 0)
(repeat (1- (length lst))
(if (< (sin (- (angle p (nth z lst)) (angle p (nth (1+ z) lst)))) -1e-14) (setq n T))
(setq z (1+ z)))
n)

  • 1

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


#49 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 17 June 2012 - 09:45 PM

Trong 2 cái lisp chia ô của 2 bác, tôi lấy lisp của bác Thai, sau đó bổ sung "Chủ đề 3" cho bạn.
Lisp trả về list các ename chứa điểm nhập vào (1; 2 hoặc 4).
Về tốc độ: nó chỉ tăng thêm ep_xi_lon so với lisp gốc.
Hy vọng bạn hài lòng.


(defun C:HA()
(setq p (getpoint "\nPick point: "))
(setq lst1 '())
(command "zoom" "e")
(princ "\nChuong trinh dang chay. Xin vui long doi...\n")
(setq entlst (mapcar '(lambda (x) (MakeRectang (car x) (cadr x))) (select-c (getvar "extmin") (getvar "extmax") 500 '((0 . "LINE")))))
(foreach ent entlst
(if (not (HA:InOut ent p))
(setq lst1 (cons ent lst1))))
lst1)
(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))))))
(defun MakeRectang (p1 p2)
(entmakex (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 70 1)
(cons 10 p1) (cons 10 (list (car p1) (cadr p2))) (cons 10 p2) (cons 10 (list (car p2) (cadr p1))))))
(defun HA:InOut (ent p / lst tt z n)
(setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
tt ((lambda (n) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list n n n))) (float (length lst)))
lst (vl-sort lst '(lambda (a B) (> (angle tt a) (angle tt B))))
lst (append lst (list (car lst))))
(setq z 0)
(repeat (1- (length lst))
(if (< (sin (- (angle p (nth z lst)) (angle p (nth (1+ z) lst)))) -1e-14) (setq n T))
(setq z (1+ z)))
n)

Cám ơn bạn đã trả lời rất nhanh.
Mình sẽ đưa lên ý tưởng tiếp theo sau khi đã sd code của bạn trong các bài toán của mình
  • 0

#50 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 17 June 2012 - 10:12 PM


;--------------------------------------------------------------- CAC HAM CHINH
;----- Ham luu bien toan cuc khi chia o.
(defun C:HA1()
(command "zoom" "e")
(princ "\nChuong trinh dang chay. Xin vui long doi...\n")
(setq entlst (mapcar '(lambda (x) (MakeRectang (car x) (cadr x))) (select-c (getvar "extmin") (getvar "extmax") 500 '((0 . "LINE"))))))
(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))))))
;----- Ham kiem tra HCN
(defun C:HA2()
(setq p (getpoint "\nPick point: "))
(setq lst1 '())
(foreach ent entlst
(if (not (HA:InOut ent p))
(setq lst1 (cons ent lst1))))
lst1)
;--------------------------------------------------------------- CAC HAM PHU
(defun MakeRectang (p1 p2)
(entmakex (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 70 1)
(cons 10 p1) (cons 10 (list (car p1) (cadr p2))) (cons 10 p2) (cons 10 (list (car p2) (cadr p1))))))
(defun HA:InOut (ent p / lst tt z n)
(setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
tt ((lambda (n) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list n n n))) (float (length lst)))
lst (vl-sort lst '(lambda (a B) (> (angle tt a) (angle tt B))))
lst (append lst (list (car lst))))
(setq z 0)
(repeat (1- (length lst))
(if (< (sin (- (angle p (nth z lst)) (angle p (nth (1+ z) lst)))) -1e-14) (setq n T))
(setq z (1+ z)))
n)

  • 1

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


#51 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 18 June 2012 - 12:55 AM


;--------------------------------------------------------------- CAC HAM CHINH
;----- Ham luu bien toan cuc khi chia o.
(defun C:HA1()
(command "zoom" "e")
(princ "\nChuong trinh dang chay. Xin vui long doi...\n")
(setq entlst (mapcar '(lambda (x) (MakeRectang (car x) (cadr x))) (select-c (getvar "extmin") (getvar "extmax") 500 '((0 . "LINE"))))))
(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))))))
;----- Ham kiem tra HCN
(defun C:HA2()
(setq p (getpoint "\nPick point: "))
(setq lst1 '())
(foreach ent entlst
(if (not (HA:InOut ent p))
(setq lst1 (cons ent lst1))))
lst1)
;--------------------------------------------------------------- CAC HAM PHU
(defun MakeRectang (p1 p2)
(entmakex (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 70 1)
(cons 10 p1) (cons 10 (list (car p1) (cadr p2))) (cons 10 p2) (cons 10 (list (car p2) (cadr p1))))))
(defun HA:InOut (ent p / lst tt z n)
(setq lst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent)))
tt ((lambda (n) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list n n n))) (float (length lst)))
lst (vl-sort lst '(lambda (a B) (> (angle tt a) (angle tt B))))
lst (append lst (list (car lst))))
(setq z 0)
(repeat (1- (length lst))
(if (< (sin (- (angle p (nth z lst)) (angle p (nth (1+ z) lst)))) -1e-14) (setq n T))
(setq z (1+ z)))
n)

Cám ơn bạn. Sau khi xem kỹ code của bạn mình đã tách ra đc rồi. Bạn cho mình hỏi, có thể kg vẽ các HCN ra màn hình đc kg, có nghĩa là căn cứ vào hàm của bác Thai, sau khi có danh sach tọa độ đỉnh của HCN thì dùng luôn cho việc tìm kiểm chứ kg cần vẽ ra HCN (kể cả việc vẽ rồi xóa cũng kg nên). Ý mình muốn trả về 2 đỉnh của HCN có đc kg (thay vì trả về ename của nó, việc kg vẽ HCN thì hay hơn).
  • 0

#52 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 18 June 2012 - 06:30 AM

Những yêu cầu của bạn đều làm được. Hôm nay tôi bận đi công tác sớm, nếu đến tối nay mà chưa có ai giúp bạn thì tôi sẽ giúp.
  • 1

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


#53 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 18 June 2012 - 11:30 PM

Bạn test xem đúng yêu cầu không nhé.

(defun C:HA1()
(command "zoom" "e")
(princ "\nChuong trinh dang chay. Xin vui long doi...\n")
(setq hcnlst (mapcar '(lambda (x) (list (car x) (cadr x))) (select-c (getvar "extmin") (getvar "extmax") 500 '((0 . "LINE"))))))
(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))))))
(defun C:HA2()
(setq p (getpoint "\nPick point: "))
(setq lst1 '())
(foreach hcn hcnlst
(if (not (HA:InOut hcn p))
(setq lst1 (cons hcn lst1))))
lst1)
(defun HA:InOut (hcn p / lst tt z n)
(setq lst (list
(list (car (cadr hcn)) (cadr (cadr hcn)))
(car hcn)
(list (car (car hcn)) (cadr (cadr hcn)))
(cadr hcn)))
(setq z 0)
(repeat (1- (length lst))
(if (< (sin (- (angle p (nth z lst)) (angle p (nth (1+ z) lst)))) -1e-14) (setq n T))
(setq z (1+ z)))
n)

  • 1

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


#54 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 20 June 2012 - 12:24 AM

Cám ơn bạn Ha đã hỗ trợ hết mình. Hôm nay mình có vđ này nhờ các bạn thử xem. Do đây kg phải là một ý tưởng bị bí nên mình kg đưa thành một chủ đề. Vđ thế này : Mình có down trên DD Cadviet một Lisp kg rõ của bạn nào (xin thứ lỗi), nó có chức năng tìm giao điểm của các đoạn thẳng (và nhiều loại đường khác) và đánh vào đó một Block, tuy nhiên, mình thay vào đó 1 point cho nó nhanh. Hiện tại nó chạy với bv mình đưa lên dưới đấy mất 3'43'', bạn nào có thể sd Lisp này và nâng cấp sao cho nó có thể chạy dưới 20''. Xin các bạn thử xem, đây là một vđ cải thiện tốc độ. Cám ơn các bạn.

(defun c:ChenGiao ( / lis)
(setq TapChon (ssget)
;TenBlock "ddhsb1"
lis nil
)
;(if (tblsearch "block" TenBlock)
;(progn
(setq SoDoiTuong (sslength TapChon) cs1 0)
(repeat SoDoiTuong
(setq DoiTuong1 (ssname TapChon cs1) cs2 (+ cs1 1))
(repeat (- SoDoiTuong cs1 1)
(setq DoiTuong2 (ssname TapChon cs2) TapGiaoDiem (GiaoDT DoiTuong1 DoiTuong2) cs2 (+ cs2 1))
(setq lis (append lis tapgiaodiem))
(print TapGiaoDiem)
(foreach Diem TapGiaoDiem (command "_.point" diem))
;(foreach Diem TapGiaoDiem (entmake (list (cons 0 "insert") (cons 2 TenBlock) (cons 10 Diem))))
)
(setq cs1 (+ cs1 1))
)
;)
;(princ "Khong co ten block")
;)
lis
)

(defun GiaoDT (ent1 ent2)
(setq ob1 (vlax-ename->vla-object ent1) ob2 (vlax-ename->vla-object ent2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
(if g (progn
(setq kq nil sd (fix (/ (length g) 3)))
(repeat sd
(setq kq (append kq (list (list (car g) (cadr g) (caddr g)))) g (cdddr g))
)
kq
) nil)
)
(vl-load-com)
Đây là bản vẽ
http://www.cadviet.c...170_ttline2.dwg
  • 0

#55 Thaistreetz

Thaistreetz

    biết lệnh adcenter

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

Đã gửi 20 June 2012 - 06:34 AM

- Bác bỏ hàm (princ tapgiaodiem) đi, hoặc có thể viết lại thành thế này (if tapgiaodiem (princ tapgiaodiem)). Để như hiện tại thì mỗi vòng lặp tìm giao điểm nó lại thực hiện1 lần princ, hàm này cực chậm nếu in nội dung ra màn hình.
- Thay hàm (command "point"...) bằng 1 hàm entmake hoặc 1 hàm vla để tạo point.
2 việc làm này có thể tăng tốc độ lên đáng kể.
  • 1

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


#56 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 20 June 2012 - 03:30 PM

- Bác bỏ hàm (princ tapgiaodiem) đi, hoặc có thể viết lại thành thế này (if tapgiaodiem (princ tapgiaodiem)). Để như hiện tại thì mỗi vòng lặp tìm giao điểm nó lại thực hiện1 lần princ, hàm này cực chậm nếu in nội dung ra màn hình.
- Thay hàm (command "point"...) bằng 1 hàm entmake hoặc 1 hàm vla để tạo point.
2 việc làm này có thể tăng tốc độ lên đáng kể.

Tham khảo ý của bạn, mình đã chỉnh một ít. Code đã chỉnh lại ở đây :

(vl-load-com)
(defun c:ChenGiao ( / lis)
(setq TapChon (ssget) lis nil)
(setq SoDoiTuong (sslength TapChon) cs1 0)
(repeat SoDoiTuong
(setq DoiTuong1 (ssname TapChon cs1) cs2 (+ cs1 1))
(repeat (- SoDoiTuong cs1 1)
(setq DoiTuong2 (ssname TapChon cs2) TapGiaoDiem (GiaoDT DoiTuong1 DoiTuong2) cs2 (+ cs2 1))
(foreach Diem TapGiaoDiem (if (null (member diem lis)) (progn
(setq lis (append lis (list diem)))
(entmake (list (cons 0 "point") (cons 10 diem)))
)))
)
(setq cs1 (+ cs1 1))
)
)
(defun GiaoDT (ent1 ent2)
(setq ob1 (vlax-ename->vla-object ent1) ob2 (vlax-ename->vla-object ent2))
(setq g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone)))
(if (/= (vlax-safearray-get-u-bound g 1) -1)
(setq g (vlax-safearray->list g))
(setq g nil)
)
(if g (progn
(setq kq nil sd (fix (/ (length g) 3)))
(repeat sd
(setq kq (append kq (list (list (car g) (cadr g) (caddr g)))) g (cdddr g))
)
kq
) nil)
)

Tốc độ bây giờ còn 30'', nhưng mình muốn các bạn viết thử sao cho tốc độ còn khoảng dưới 3'' (tức =10% tùy máy). Đó là với bản vẽ nhỏ, với bản vẽ lớn như mình up lên ở trang đầu, mình chạy thử trong 5h chỉ đc 20%, có nghĩa nếu chạy xong phải mất từ 20-25h, nhưng các bạn thử viết cho nó chạy trong khoảng dưới 5' (tức giảm khoảng 240-300 lần) thôi xem sao.
  • 0

#57 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 20 June 2012 - 04:51 PM

Tốc độ bây giờ còn 30'', nhưng mình muốn các bạn viết thử sao cho tốc độ còn khoảng dưới 3'' (tức =10% tùy máy). Đó là với bản vẽ nhỏ, với bản vẽ lớn như mình up lên ở trang đầu, mình chạy thử trong 5h chỉ đc 20%, có nghĩa nếu chạy xong phải mất từ 20-25h, nhưng các bạn thử viết cho nó chạy trong khoảng dưới 5' (tức giảm khoảng 240-300 lần) thôi xem sao.

Bài tập cô cho hả bạn ơ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


#58 Thaistreetz

Thaistreetz

    biết lệnh adcenter

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

Đã gửi 20 June 2012 - 05:35 PM

Lisp này chậm khủng khiếp như vậy là do phương pháp tìm giao không hợp lý. hoặc bác TRUNGNGAMY áp dụng lisp này cho nhu cầu trên là không hợp lý.
- tác giả cho lặp n lần với n là số đối tượng của tập hợp. mỗi lần lặp lấy ra 1 đối tượng.
- với mỗi lần lặp lại duyệt lại toàn bộ số đối tượng của tập hợp xem có anh nào giao với đối tượng được chọn của bước lặp trước không. <= Chậm chính là ở đây.
Với cách làm như thế này thì số lần phải duyệt đối tương sẽ bằng bình phương của số đối tượng. Vì vậy không thể dùng với số lượng đối tượng lớn.
1 vd để thấy sự chênh lệch khủng khiếp khi số đối tượng tăng lên: chênh lệch số lần phải lặp giữa 200 đối tượng và 100 đối tượng là: 200x200 - 100x100 = 30000 lần lặp.

mình đưa giải pháp khắc phục, các bước làm như sau:
- cho lặp tập chọn n lần với n là số đối tượng của tập chọn. mỗi lần lặp lấy ra 1 đối tượng.
- với mỗi lần lặp, lấy tọa độ BB của đối tượng rồi (ssget "c") trong khoảng BB đó.
- lặp danh sách đối tượng vừa chọn rồi tìm giao của từng đối tượng với đối tượng lặp ở bước 1.
Với tính chất bản vẽ như của bác TRUNGNGAMY thì có thể khẳng định sẽ giảm khoảng > 90% số lần phải lặp so với lisp trên. bản vẽ càng nhiều đối tượng thì tỷ lệ giảm càng tăng, thậm chí có thể giảm tới 99,99% nếu số lượng đối tượng đủ lớn.
Với số lượng đối tượng nhỏ, phương pháp này sẽ không hiệu quả hơn phương pháp trước, thậm chí cũng có thể chậm hơn. Minh từng viết 1 lisp tìm kiếm các text cao độ trên bình đồ và xóa các text đè lên nhau chỉ để lại 1 text (mục đích cho bản vẽ thông thoáng dễ đọc), thuật toán cũng tương tự thế này.
  • 2

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


#59 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 20 June 2012 - 08:16 PM

Bài tập cô cho hả bạn ơi :)

Ket lúc này đâm ra hay nghi ngờ nhỉ. Xem như là đố vui đi. Nếu sau 1 ngày mà các bạn chưa đưa lên ra thì mình sẽ có đáp án.
Mình có một số ý tưởng hay (đối với riêng mình) nhưng kg thể viết hết đc, có những thứ phải có sự trợ giúp của các bạn sau đó mình mới tạo ra đc những ứng dụng hữu ích. Mình chỉ tím cách kích thích các bạn viết những Lisp hay, sưu tầm, vận dụng và chỉ ra cho các bạn thấy những ứng dụng hữu ích của nó để các bạn cảm thấy thích thú với những sáng tạo xuất thần của mình (có thể nó chỉ có ích trong lĩnh vực của mình).
Do mình viết Lisp và Arx từ rất lâu nên những gì cần thiết trong công việc mình đã viết gần như là đầy đủ, tất nhiên có cái chưa hay. Những gì mình đưa lên nhờ các bạn mình cần những ý tưởng mang tính đột phá để thay đổi cái cũ mình đang có (hoài bão thôi chứ chưa chắc có thời gian thực hiện). Nhưng chung quy có lẽ giải trí là chính

P/S : Xin giải thích câu : "các bạn cảm thấy thích thú với những sáng tạo xuất thần của mình " : mình ở đây chính là các bạn
  • 1

#60 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

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

Đã gửi 20 June 2012 - 10:24 PM

Viết lisp đạt tốc độ cao thì bao giờ cũng khó. Rất chờ đợi những sáng tạo xuất thần của bác. Nếu phân tích thì như bác Thai đã phân tích, và có thể bổ sung thêm một vài thứ nữa. Dù sao tôi vẫn thích những vấn đề mà bác đã đưa ra. Chỉ tiếc là nếu bác nói đề toán là "đố vui" hoặc "thảo luận" thì mọi việc sẽ nhẹ nhàng hơn.
Tôi cũng góp 1 cái (thay lời phân tích), giải đố để giải trí cho vui. Chạy trên bản vẽ bác gởi (#54), trên máy tui, trên cad2007, thì mất tầm 5".

(vl-load-com)
(defun C:HA ( / ss lst i j objlst obj pt start)
(setq ss (ssget '((0 . "LINE"))))
(setq start (getvar "millisecs"))
(setq i (sslength ss))
(setq objlst (SS->objlst ss))
(while (> (setq j (1- i) i (1- i)) -1)
(setq obj (nth i objlst))
(while (> (setq j (1- j)) -1)
(if (setq pt (vlax-Invoke obj "IntersectWith" (nth j objlst) 0))
(if (not (member pt lst))
(progn
(setq lst (cons pt lst))
(entmake (list (cons 0 "POINT") (cons 10 pt))))))))
(princ (strcat (rtos (/ (- (getvar "millisecs") start)1000.0) 2) " giay."))
(princ))
(defun SS->objlst (ss / i lst)
(repeat (setq i (sslength ss))
(setq lst (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) lst))))
P/S (16h30' - 21/6/2012): bổ sung thêm phần loại bỏ các điểm giao trùng nhau.
  • 1

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