Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
TRUNGNGAMY

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

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

gia_bach    1.442

Lisp Check xem 1 Rectangle có thể đặt gọn vào trong 1 Curve kín hay không, với điều kiện là Rectangle không đè lên bất cứ đối tượng nào.

Chú ý: mức độ chính xác phụ thuộc số lần lặp. Để đạt chính xác càng cao thì lisp càng chạy chậm.

Bác nào có thể góp ý để lisp chạy nhanh hơn thì rất cám ơn (dù đã tìm cách khắc phục rồi).

;Doan Van Ha - CADViet.com - Ngay 13/6/2012
;Muc dich: Check xem 1 Rectangle co the nam gon trong 1 Curve kin hay khong, va Rectangle khong de len bat cu doi tuong nao trong Curve.
(defun C:HA( / ent ent1 ent2 baoN baoT num lxT lyT dx dy x y p1 p2 p3 p4 lst lst4 co)
(vl-load-com)
(while (not (setq ent1 (car (entsel "\nChon Curve bao ngoai: ")))))
(while (not (setq ent2 (car (entsel "\nChon Rectangle: ")))))
(setq baoN (LM:BoundingBox (vlax-ename->vla-object ent1))
  		baoT (LM:BoundingBox (vlax-ename->vla-object ent2))
  		num 50
  		lxT (distance (nth 0 baoT) (nth 1 baoT))
  		lyT (distance (nth 1 baoT) (nth 2 baoT))
  		dx (/ (distance (nth 0 baoN) (nth 1 baoN)) num)
  		dy (/ (distance (nth 1 baoN) (nth 2 baoN)) num)
  		x 0)
(princ "\nDang tinh toan. Vui long doi...\n")
(repeat num
 (setq y 0)
 (repeat num
  (setq p1 (polar (polar (nth 0 baoN) (/ pi 2) (- (* y dy) (* y (/ (- lyT dy) (1- num))))) 0 (- (* x dx) (* x (/ (- lxT dx) (1- num)))))
			p2 (polar p1 0 lxT)
			p3 (polar p2 (/ pi 2) lyT)
			p4 (polar p3 (- pi) lxT)
			lst4 (list p1 p2 p3 p4)
			ent (LWPoly lst4 1)
			lst (LM:ss->ent (HA:Inside2 ent1 100 "C")))
  (if (or (/= (sslength (ssget "CP" lst4)) 1) (not (member ent lst)))
(vla-Delete (vlax-ename->vla-object ent))
(setq co T))
  (setq y (1+ y)))
 (setq x (1+ x)))
(if co
 (alert "\nDa tim duoc (cac) vi tri dat Rectangle. \nNhau di thoi ban oi!")
 (alert "\nBuon qua di thoi. \nKhong co vi tri nao co the dat Rectangle."))
(princ))
;-----
(defun LM:ss->ent (ss / i l) (if ss (repeat (setq i (sslength ss)) (setq l (cons (ssname ss (setq i (1- i))) l)))))
;----- Chän c¸c Objects bªn trong Curve, theo kiÓu "CP" hoÆc "WP".
(defun HA:Inside2 (ent num cw / i j lst)
(cond
 ((vlax-curve-isclosed ent)
  (setq i (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) num) j (- i))
  (repeat num
(setq lst (cons (vlax-curve-getpointatdist ent (setq j (+ j i))) lst)))))
(if (= (strcase cw) "C")
 (ssget "cp" lst)
 (ssget "wp" lst)))
;-----
(defun LM:BoundingBox ( object / lowerleft upperright )
 (if (vlax-method-applicable-p object 'GetBoundingBox)
((lambda ( boundingbox )
   	(mapcar
     	(function
       	(lambda (_functionlist)
         	(mapcar
           	(function
             	(lambda (_function ) ((eval _function) boundingbox)))
           	_functionlist)))
	'((caar   cadar) (caadr  cadar)
       	(caadr cadadr) (caar  cadadr))))
 	(mapcar 'vlax-safearray->list
   	(progn
     	(vla-getBoundingBox object 'lowerleft 'upperright) (list lowerleft upperright))))))
;----- cls=1: ®ãng; cls=0: më. (by Thai)
(defun LWPoly (lst cls)
(entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))

P/S: 22h30 13/6/2012: đang update liên tục để tăng tốc độ nếu có thể.

Giải pháp dùng BoundingBox chỉ áp dụng cho rectang nằm ngang (vuông góc với trục tọa độ).

 

T/hợp rectang không vuông góc với trục tọa độ thì chưa tính hết các t/hợp có thể có.

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
gia_bach    1.442

Nếu cần thì thêm dòng chuyển UCS nữa.

Đổi tọa độ cũng chỉ áp dụng đuợc cho t/hợp chỉ tịnh tiến (move) rectang.

 

T/hợp quay rectang (rotate) thì ...?

 

PS : Tôi chỉ nêu bài toán tổng quát, không biết chủ topic có yêu cầu như thế không nữa ?!

  • 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
Doan Van Ha    2.676

Cám ơn bác Gia_Bach về phát hiện này. Trước mắt, nếu Rectangle nằm ở vị trí đặc biệt thì chắc phải Rotate tất cả bản vẽ, rồi dùng lisp, sau đó Rotate trở lại.

Đang nghĩ xem có phương án nào tốt hơn không.

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
TRUNGNGAMY    91

Cám ơn bác Gia_Bach về phát hiện này. Trước mắt, nếu Rectangle nằm ở vị trí đặc biệt thì chắc phải Rotate tất cả bản vẽ, rồi dùng lisp, sau đó Rotate trở lại.

Đang nghĩ xem có phương án nào tốt hơn không.

@Gia_Bach : Nếu xét cả TH tổng quá thì rất tốt, tuy nhiên thấy hơi khó nên mình chưa đưa ra.

Đã test code của bác Ha, cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều, bác có thể nói rõ hơn phương pháp của bác để xem mình có góp ý đc gì để cải tiến tốc độ kg

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
ketxu    2.649

@Gia_Bach : Nếu xét cả TH tổng quá thì rất tốt, tuy nhiên thấy hơi khó nên mình chưa đưa ra.

Đã test code của bác Ha, cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều, bác có thể nói rõ hơn phương pháp của bác để xem mình có góp ý đc gì để cải tiến tốc độ kg

Thật thú vị ^^ Cách giải của bác Hạ là chia ngay BoundingBox thành ô nxn, sau đó đặt HCN vào từng mút để kiểm tra. Với cách làm này thì sẽ đi lần lượt từng ô và tất nhiên đối tượng bao không nhất thiết phải kín

 

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
phamthanhbinh    3.123

@Gia_Bach : Nếu xét cả TH tổng quá thì rất tốt, tuy nhiên thấy hơi khó nên mình chưa đưa ra.

Đã test code của bác Ha, cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều, bác có thể nói rõ hơn phương pháp của bác để xem mình có góp ý đc gì để cải tiến tốc độ kg

Hề hề hề,

Đây là lisp mình thử làm theo cách củ chuối nhất nên khá chậm. Tuy nhiên cũng có được kết quả. Để tăng tốc độ lisp thì mình thấy hơi khó do sử dụng việc quét qua lưới điểm theo khoảng cách do người dùng tự chọn và nhập vào.

Nguyên tắc giải thuật của mình là, từ vùng chọn offset theo 1/2 kích thước nhỏ của hình chữ nhật để lấy vùng tâm có thể của hình chữ nhật đặt vào. Tạo một lưới điểm với khoảng cách được người dùng lựa chọn. (nếu muốn nhanh có thể tăng khoảng cách này một cách hợp lý). Từ lưới điểm này lần lượt copy và rotate HCN về mỗi điểm trên lưới. Số bước quay ở đây phụ thuộc vào biến lệch. Tùy người dùng có thể điều chỉnh giá trị của biến này để có được kết quả nhanh hơn. Tiếp theo kiểm tra xem HCN này có chứa đối tượng nào hay không và xử lý.

Kết quả trả về một list các tọa độ của các HCN có thể đặt được trong vùng chọn.

Từ list này vẽ lại các HCN đó.

Lisp:


(defun c:arr  ( / oldos en pls h d en0 a pg en1 plst ssdt b xlst ylst xmin xmax ymin ymax kc ssp pls2 pls1
                       goc lech plst1 )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(setq en (car (entsel "\n Chon doi tuong polyline goc" )))
(setq pls (acet-geom-vertex-list en)
  		h (distance (nth 0 pls) (nth 1 pls))
  		d (distance (nth 1 pls) (nth 2 pls))  )
(command "copy" en "" (nth 3 pls) (nth 3 pls))
(setq en0 (entlast))
(command "undo" "be")
(command "region" en "")
(setq a (entlast))
(setq pg (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object a) 'centroid ))) )
;;;;(setq pg (vlax-safearray->list (vlax-variant-value (vla-get-centroid (vlax-ename->vla-object a)))))

(setq en1 (car (entsel "\n Chon  polyline duong bao"))
         plst (acet-geom-vertex-list en1)
         ssdt (acet-ss-to-list (ssget "wp" plst (list (cons 0 "lwpolyline") (cons 70 1))))  
)
(command "offset" (/ (min h d) 2) en1 (getpoint "\n Pick diem trong vung chon") "")
(setq b (entlast)
         plst (acet-geom-vertex-list B)  
         xlst (vl-sort (mapcar '(lambda (x) (car x)) plst) '<)
         ylst (vl-sort (mapcar '(lambda (x) (cadr x)) plst) '<)
         xmin (car xlst) xmax (last xlst) ymin (car ylst) ymax (last ylst)
         kc (getreal "\n Nhap khoang cach toi thieu giua hai doi tuong: ")  
         xlst (list xmin) ylst (list ymin)   )
(while (<= xmin xmax)
         (setq xmin (+ xmin (/ kc 2))
          		xlst (append xlst (list xmin))   )
)
(while (<= ymin ymax)
         (setq ymin (+ ymin (/ kc 2))
                   ylst (append ylst (list ymin))  )
)
(setq xlst (append xlst (list xmax))
		ylst (append ylst (list ymax))   )

(foreach x xlst
         (foreach y ylst
        		(setq pls1 (append pls1 (list (list x y 0.0))))
        		(command "point" (list x y 0.0))
         )
)

(setq ssp (acet-ss-to-list (ssget "cp" plst (list (cons 0 "point")))))
(setq pls2 (list))
(foreach p ssp
  	(setq pls2 (append pls2 (list (cdr (assoc 10 (entget p)))))  )
)
;;;;(command "region" en1 "")
;;;;(setq b (entlast))
;;;;(foreach s ssdt
     ;;;(command "region" s "")
;;; (setq c (entlast))
     ;;;(command "subtract" b "" c "")
     ;;;(setq b (entlast) )
;;;)
;;;;;(command "boundary" (getpoint "\n Pick diem trong vung chon") "")
;;;;;(setq b (entlast)
         ;;;;;plst (acet-geom-vertex-list B)  )

(command "undo" "e")
(command "undo" 1)
(command "undo" "be")
(setq goc 0 lech 10
         plst1(list)   )
(foreach p pls2
       (while (< goc 180)
             (command "copy" en0 "" pg p)
             (setq b (entlast))        
             (command "rotate" b "" p goc)
             (setq b (entlast)
              		pls (acet-geom-vertex-list B)
              		n (sslength (ssget "cp" pls))   )
    		(if (> n 1)
                 (command "erase" b "")
                 (progn
              		(setq plst1 (append plst1 (list pls)))
              		(command "erase" b "")  
        		)
    		)
    		(setq goc (+ goc lech))
  	)
  	(setq goc 0)
)
(foreach lst plst1
(acet-pline-make (list lst))
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)

)

 

Đây là hình ảnh kết quả sau khi chạy lisp với khoảng cách lưới là 4/2=2 và giá trị biến lệch là 10 như trong lisp. Thời gian chạy mất 60 phút.

5194_chon_vi_tri.jpg

 

Rất mong mọi người góp ý thêm.

Khi tăng khoảng cách lưới điểm là 8/2=4 thì lisp chỉ chạy mất 6 phút nhưng kết quả cho ra ít hơn khá nhiều.

  • Vote tăng 2

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
Doan Van Ha    2.676

Mệt! Câu đầu tiên phải nói là mệt! Và quá mệt!

Vài lời tâm sự khi viết xong lisp này:

1). Cám ơn bác Gia_Bach đã phát hiện hàm LM:BoundingBox của Lee Mac.

2). Cám ơn Ketxu đã động viện bằng 3 từ "thật thú vị".

3). Cám ơn tất cả mọi người đã quan tâm.

4). Buồn lắm khi người viết thì "P/S: 22h30 13/6/2012: đang update liên tục để tăng tốc độ nếu có thể." nhưng chủ topic thì "Đã test code của bác Ha, cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều".

5). Để làm được cái lisp đó tôi phải mất nửa ngày, và test trên máy của mình thì mất tầm 30".

6). "bác có thể nói rõ hơn phương pháp của bác để xem mình có góp ý đc gì để cải tiến tốc độ kg". Câu này khó hiểu quá.

7). Tôi ao ước tổng quát hoá bài toán: boundary là 1 curve và rectangle cũng là curve luôn. Và đã làm được, nhưng chạy chậm lắm.

8). Tìm ra giải thuật để giải bài toán của chủ topic đã khó, tìm thêm giải thuật để đẩy nhanh tốc độ càng khó hơn.

9). Cuối cùng, là điều an ủi: viết xong lisp này thì học hỏi được nhiều điều (test bản vẽ trên máy mình thì mất tầm 5-10").

;Doan Van Ha - CADViet.com - Ngay 13-14/6/2012
;Muc dich: Check xem Curve_closed co the chua 1 Rectangle hay khong, biet Rectangle khong de len bat cu doi tuong nao trong Curve.
;Co the mo rong de xet Curve nam trong Curve, nhung lisp se chay cham hon.
(defun C:HA( / entN entT baoN baoT lstT lstN nx ny lxT lyT dx dy x y lstN lstT ttT hso co ptt lstTi)
(vl-load-com)
(while (not (setq objN (vlax-ename->vla-object (setq entN (car (entsel "\nChon Curve bao ngoai: ")))))))
(while (not (setq objT (vlax-ename->vla-object (setq entT (car (entsel "\nChon Rectangle: ")))))))
(setq baoN (LM:BoundingBox objN)
  		baoT (LM:BoundingBox objT)
  		lstN  (LISTP_CURVE objN 100)
  		lstT (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget entT)))
  		ttT (TTC objT)
  		lxT (distance (nth 0 baoT) (nth 1 baoT))
  		lyT (distance (nth 1 baoT) (nth 2 baoT))
  		nx 50
  		ny (* nx (fix (/ lxT lxT)))
  		dx (/ (distance (nth 0 baoN) (nth 1 baoN)) nx)
  		dy (/ (distance (nth 1 baoN) (nth 2 baoN)) ny)
  		hso (- (sslength (ssget "CP" baoN)) (sslength (ssget "CP" lstN)))
  		x 0)
(princ "\nDang tinh toan. Vui long doi...\n")
(repeat nx
 (setq y 0)
 (repeat ny
  (setq ptt (polar (polar (nth 0 baoN) (/ pi 2) (- (* y dy) (* y (/ (- lyT dy) (1- ny))))) 0 (- (* x dx) (* x (/ (- lxT dx) (1- nx))))))
  (setq lstTi (CTD lstT ttT ptt))
  (if (= nil (ssget "CP" lstTi))
(progn
(LWPoly lstTi 1)
(if (/= (- (sslength (ssget "CP" baoN)) (sslength (ssget "CP" lstN))) hso)
 	(vla-delete (vlax-ename->vla-object (entlast)))
 	(setq co T))))
  (setq y (1+ y)))
 (setq x (1+ x)))
(if co
 (alert "\nDa tim duoc vi tri dat Rectangle(s). \nNhau di thoi ban oi!")
 (alert "\nBuon qua di thoi. \nKhong co vi tri nao co the dat Rectangle(s)."))
(princ))
;----- Get Centroid of Curve.
(defun TTC (obj / tt)
(cond
 ((= (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "REGION")
  (setq tt (vlax-get obj 'Centroid)))
 ((wcmatch (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "CIRCLE,ELLIPSE,POLYLINE,LWPOLYLINE,SPLINE")
  (setq tt (vlax-get (car (vlax-invoke (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) 'addregion (list obj))) 'Centroid))
  (entdel (entlast))))
tt)
;-----
(defun CTD (lst p1 p2 / lst1)
(foreach n lst
 (setq lst1 (cons (polar n (angle p1 p2) (distance p1 p2)) lst1)))
lst1)
;----- Get list points of Curve (*Line, Arc) theo sè l­îng (num) point. by HA.
(defun LISTP_CURVE (obj num / step dis lst)
(setq step (/ (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)) (1- num))
  		dis 0)
(repeat (1- num)
 (setq lst (cons (vlax-curve-getPointAtDist Obj dis) lst)
       	dis (+ step dis)))
(reverse (cons (vlax-curve-getEndPoint Obj) lst)))
;----- Chän c¸c Objects bªn trong Curve closed, theo kiÓu "CP" hoÆc "WP".
(defun HA:Inside2 (ent num cw / i j lst)
(setq i (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) num) j (- i))
(repeat num
 (setq lst (cons (vlax-curve-getpointatdist ent (setq j (+ j i))) lst)))
(if (= (strcase cw) "C")
 (ssget "cp" lst)
 (ssget "wp" lst)))
;-----
(defun LM:BoundingBox (obj / ll ur)
 (if (vlax-method-applicable-p obj 'GetBoundingBox)
((lambda (boundingbox)
   	(mapcar
     	(function
       	(lambda (_functionlist)
         	(mapcar
           	(function
             	(lambda (_function) ((eval _function) boundingbox)))
           	_functionlist)))
		'((caar cadar) (caadr cadar)
       	(caadr cadadr) (caar cadadr))))
 	(mapcar 'vlax-safearray->list
   	(progn
     	(vla-getBoundingBox obj 'll 'ur) (list ll ur))))))
;----- cls=1: ®ãng; cls=0: më. (by Thai)
(defun LWPoly (lst cls)
(entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))

  • Vote tăng 2

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
phamthanhbinh    3.123

Mệt! Câu đầu tiên phải nói là mệt! Và quá mệt!

Vài lời tâm sự khi viết xong lisp này:

1). Cám ơn bác Gia_Bach đã phát hiện hàm LM:BoundingBox của Lee Mac.

2). Cám ơn Ketxu đã động viện bằng 3 từ "thật thú vị".

3). Cám ơn tất cả mọi người đã quan tâm.

4). Buồn lắm khi người viết thì "P/S: 22h30 13/6/2012: đang update liên tục để tăng tốc độ nếu có thể." nhưng chủ topic thì "Đã test code của bác Ha, cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều".

5). Để làm được cái lisp đó tôi phải mất nửa ngày, và test trên máy của mình thì mất tầm 30".

6). "bác có thể nói rõ hơn phương pháp của bác để xem mình có góp ý đc gì để cải tiến tốc độ kg". Câu này khó hiểu quá.

7). Tôi ao ước tổng quát hoá bài toán: boundary là 1 curve và rectangle cũng là curve luôn. Và đã làm được, nhưng chạy chậm lắm.

8). Tìm ra giải thuật để giải bài toán của chủ topic đã khó, tìm thêm giải thuật để đẩy nhanh tốc độ càng khó hơn.

9). Cuối cùng, là điều an ủi: viết xong lisp này thì học hỏi được nhiều điều (test bản vẽ trên máy mình thì mất tầm 5-10").

 

Hề hề hề,

Minh test thử lisp của bác thì thấy nó chạy cũng khá nhanh. Tuy nhiên lisp chỉ trả ra kết quả một vị trí duy nhất.

Nếu chỉ xét vị trí của HCN tịnh tiến thì lisp của minh chạy cũng khá ổn, (tuong đương với tốc độ lisp của bác), tuy kết quả có khác nhau tí đỉnh.

Mình chưa đọc kỹ lisp của bác song thấy nó khá là khó vì bác dùng khá nhiều hàm vla, vlax ... là cái mà minh còn chưa thủng lắm.

Hy vọng mình sẽ hiểu rõ hơn khi có thời gian để ngâm cứu nó.

Chúc bác luôn mạnh và vui.

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
Doan Van Ha    2.676

Bài toán này nếu đã có 1 nghiệm thì sẽ có vô số nghiệm. Bác có tìm ra N nghiệm thì nó vẫn còn vô số nghiệm khác. Cho nên chỉ đưa ra 1 nghiệm trong 1 vùng lân cận của rectangle thôi.

Nếu bác xoá trống hết thì nó chỉ ra nhiều nghiệm trong nhiều vùng đấy bác ạ.

Còn nếu chủ topic đòi hỏi chỉ ra tất cả nghiệm thì thật vô nghĩ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
Thaistreetz    515

:lol: Mình đã thấy ngay từ đầu là bài toán này là nếu có làm được thì việc làm đó cũng vô nghĩa bởi đúng như bác TRUNGNGAMY nhận xét: "cách tìm vị trí thì OK nhưng chạy chậm hơn làm bằng tay nhiều" Vậy mà bác cứ ham hố giờ kêu chán.

 

Bác cứ thử giả thiết nếu công việc của bác gặp phải vấn đề như trên, liệu khi đó bác có nghĩ rằng mình cần viết lisp để làm công việc này hay không? hay tốt hơn là bằng cảm quan, bằng con mắt nghề nghiệp của mình là bác đã tự có thể nhận ra việc liệu có thể đặt được vật thể đó, và nếu đặt được thì đặt ở đâu cho hợp lý nhất. Máy móc không làm thay chúng ta việc này được đâu.

 

Thêm nữa. khi code chạy quá chậm, thay vì cố gắng đến mệt mỏi để sửa thuật toán thì sao bác không nghĩ rằng có thể thay đổi đề bài để ra kết quả nhanh hơn? Với bài toán này hoàn toàn có thể làm được điều đó bằng cách khoanh vùng và loại bỏ những miền chắc chắn ko thể đặt được vật thể trước khi chạy code. :rolleyes:

 

@Bác DVH: vài dòng nhận xét mong bác không tự á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
TRUNGNGAMY    91

@ bác Ha : Đã test thử lisp mới của bác Ha, chỉ mất 3", một cải tiến đáng nể. Tuy nhiên, trong một hình khác thì nó lại báo kg tìm đc vị trí mặc dù có nghiệm. Nếu bạn còn hơi thì mình gởi file để bạn hoàn thiện tiếp, xong rồi lúc nào có dịp thì nhậu xả hơi vậy.

@ bác Bình : đã test nhưng chưa ra kq như mong muốn.

Cám ơn tất cả các bác và thật là có lỗi vì để các bác tổn hao tâm trí quá nhiều.

Có lẽ phải chờ một phương pháp đột phá hơn nữa.

Thấy các bạn có vẻ nản rồi, nếu các bạn hết hứng thú thì phải tạm xếp lại chờ vậy.

Tuy nhiên, mình thử nêu ý kiến của mình xem các bạn có thể kg

- Tạo HCN bao của polyline.

- Chia thành lưới ô vuông nhỏ, lập một ma trận vuông 2 chiều để quản lý các ô vuông này.

- Lần lượt chạy qua các ô và kiểm tra. Đánh dấu =0 nếu ô nằm ngoài polyline hay có vật cản, đánh đấu =1 khi ô nằm trong và trống rỗng.

- Vị trí cần tìm chính là nơi tập trung nhiều ô trống kề nhau nhất, chỉ cần kiếm tra vùng này thôi .

Ý tưởng là vậy, nhưng viết CT thì ... chịu

-

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
phamthanhbinh    3.123

@ bác Ha : Đã test thử lisp mới của bác Ha, chỉ mất 3", một cải tiến đáng nể. Tuy nhiên, trong một hình khác thì nó lại báo kg tìm đc vị trí mặc dù có nghiệm.

@ bác Bình : đã test nhưng chưa ra kq như mong muốn.

Cám ơn tất cả các bác và thật là có lỗi vì để các bác tổn hao tâm trí quá nhiều.

Có lẽ phải chờ một phương pháp đột phá hơn nữa.

Nếu các bạn hết hứng thú thì phải tạm xếp lại chờ vậy.

Tuy nhiên, mình thử nêu ý kiến của mình xem các bạn có thể kg

- Tạo HCN bao của polyline.

- Chia thành lưới ô vuông nhỏ, lập một ma trận vuông 2 chiều để quản lý các ô vuông này.

- Lần lượt chạy qua các ô và kiểm tra. Đánh dấu =0 nếu ô nằm ngoài polyline hay có vật cản, đánh đấu =1 khi ô nằm trong và trống rỗng.

- Vị trí cần tìm chính là nơi tập trung nhiều ô trống kề nhau nhất, chỉ cần kiếm tra vùng này thôi .

Ý tưởng là vậy, nhưng viết CT thì ... chịu

-

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

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
Doan Van Ha    2.676

@ bác Ha : Đã test thử lisp mới của bác Ha, chỉ mất 3", một cải tiến đáng nể. Tuy nhiên, trong một hình khác thì nó lại báo kg tìm đc vị trí mặc dù có nghiệm. Nếu bạn còn hơi thì mình gởi file để bạn hoàn thiện tiếp, xong rồi lúc nào có dịp thì nhậu xả hơi vậy.

...

Tuy nhiên, mình thử nêu ý kiến của mình xem các bạn có thể kg

- Tạo HCN bao của polyline.

- Chia thành lưới ô vuông nhỏ, lập một ma trận vuông 2 chiều để quản lý các ô vuông này.

- Lần lượt chạy qua các ô và kiểm tra. Đánh dấu =0 nếu ô nằm ngoài polyline hay có vật cản, đánh đấu =1 khi ô nằm trong và trống rỗng.

- Vị trí cần tìm chính là nơi tập trung nhiều ô trống kề nhau nhất, chỉ cần kiếm tra vùng này thôi .

Ý tưởng là vậy, nhưng viết CT thì ... chịu

-

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.com/forum/index.php?showtopic=64737&pid=202994&st=0entry202994

  • 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
TRUNGNGAMY    91

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.com/upfiles/3/37170_h1_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
TRUNGNGAMY    91

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

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
Doan Van Ha    2.676

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.

  • 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
TRUNGNGAMY    91

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.

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
Doan Van Ha    2.676

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

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
TRUNGNGAMY    91

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

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
Doan Van Ha    2.676

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)

  • 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
TRUNGNGAMY    91

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

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
Doan Van Ha    2.676
;--------------------------------------------------------------- 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)

  • 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


×