[Đã xong] Lisp kiểm tra xem 1 Curve nhỏ có thể đặt vào trong Curve lớn hay không?

[Doan Van Ha 3.180]

Xuất phát từ yêu cầu tại topic "Lisp phân nhỏ tập hợp chọn bằng cách chia ô", tôi hoàn thiện cho trường hợp tổng quát để lập topic này.

Lisp có chức năng:

- Kiểm tra xem 1 Curve kín (lớn) có thể chứa được Curve kín (nhỏ) hay không. Curve có thể là Circle, Ellipse, Pline, Spline.

- Khái niệm "chứa" được hiểu là: Curve nhỏ nằm trong Curve lớn; Curve lớn không cắt Curve nhỏ; Curve nhỏ không chứa hoặc cắt bất cứ đối tượng nào trong Curve lớn.

- Kết quả trả về: các vị trí có thể đặt Curve nhỏ (nếu có).

- Lisp này phù hợp để tìm các vị trí trên mặt bằng nhằm có thể bố trí 1 công trình nào đó.

Chú ý đọc thêm các hướng dẫn sử dụng trong lisp.

;Doan Van Ha - CADViet.com - Ngay 15/6/2012
;Muc dich: Check xem Curve_closed lon co the chua 1 Curve_closed nho hay khong, biet Curve nho khong de len bat cu doi tuong nao trong Curve lon.
;Curve nho cang phuc tap (phai vi phan nhieu diem) thi lisp chay cang cham, va nguoc lai. Vidu: Spline thi cham hon Rectangle.
;Thay doi gia tri nx (dang dat 50) de tang/giam do chinh xac. Do chinh xac cang cao thi toc do cang cham.
;Ket qua tra ve: Ve ra cac Curve nho tai cac vi tri co the dat duoc, ma cac Curve nay khong cat lan nhau.
;--------------------------------------------------------------------------------------- HAM CHINH -----------------------------------------------------------------------------
(defun C:HA( / ent entN entT boxT lstT lstN nx ny dx dy x y ttT ptt hso co lstTi p1 p3 q1 q2 q3 q4)
(vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
(while (not (setq objN (vlax-ename->vla-object (setq entN (car (entsel "\nChon Curve lon bao ngoai: ")))))))
(while (not (setq objT (vlax-ename->vla-object (setq entT (car (entsel "\nChon Curve nho se dat vao trong Curve lon: ")))))))
(setq boxN (LM:BoundingBox objN)
      	boxT (LM:BoundingBox objT)
      	p1 (car boxN)
      	p3 (caddr boxN)
      	lstN (LM:Entity->PointList entN)
      	lstT (LM:Entity->PointList entT)
      	ttT (HA:CenCur objT)
      	q1 (polar (polar (nth 0 boxN) 0 (- (car ttT) (car (nth 0 boxT)))) (/ pi 2) (- (cadr ttT) (cadr (nth 1 boxT))))
      	q2 (polar (polar (nth 1 boxN) 0 (- (car ttT) (car (nth 1 boxT)))) (/ pi 2) (- (- (cadr ttT) (cadr (nth 2 boxT)))))
      	q3 (polar (polar (nth 2 boxN) 0 (- (- (car ttT) (car (nth 0 boxT))))) (/ pi 2) (- (- (cadr ttT) (cadr (nth 1 boxT)))))
      	q4 (polar (polar (nth 3 boxN) 0 (- (- (car ttT) (car (nth 1 boxT))))) (/ pi 2) (- (cadr ttT) (cadr (nth 2 boxT))))
      	nx 50
      	ny (1+ (fix (* nx (/ (distance q2 q3) (distance q1 q2)))))
      	dx (/ (distance q1 q2) nx)
      	dy (/ (distance q2 q3) (1- ny))
      	hso (- (sslength (ssget "C" p1 p3)) (sslength (ssget "CP" lstN)))
      	x 0)
(command "zoom" "W" p1 p3)    ;?????
(princ "\nDang tinh toan vong lap. Xin vui long doi...\n")
(repeat (1+ nx)
 (setq y 0)
 (repeat ny
  (setq ptt (polar (polar q1 (/ pi 2) (* y dy)) 0 (* x dx)))
  (setq lstTi (HA:ConvLst lstT ttT ptt))
  (if (= nil (ssget "CP" lstTi))
(progn
	(setq ent (LWPoly lstTi 1))
	(if (/= (- (sslength (ssget "C" p1 p3)) (sslength (ssget "CP" lstN))) hso)
 	(vla-delete (vlax-ename->vla-object ent))
 	(setq co T))))
  (setq y (1+ y)))
 (setq x (1+ x)))
(command "zoom" "p")
(if co
 (alert "\nDa tim duoc vi tri dat Curve(s) nho vao trong Curve lon. \nChuc mung Ban!")
 (alert "\nBuon qua Ban oi! \nKhong co vi tri nao co the dat Curve(s) nho vao trong Curve lon."))
(setvar "cmdecho" cmd) (command "undo" "e") (princ))
;--------------------------------------------------------------------------------------- CAC HAM PHU -----------------------------------------------------------------------------
;----- Get Centroid of 1 Curve.
(defun HA:CenCur (obj / ttc)
(cond
 ((= (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "REGION")
  (setq ttc (vlax-get obj 'Centroid)))
 ((wcmatch (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))) "CIRCLE,ELLIPSE,POLYLINE,LWPOLYLINE,SPLINE")
  (setq ttc (vlax-get (car (vlax-invoke (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) 'addregion (list obj))) 'Centroid))
  (entdel (entlast))))
ttc)
;----- Convert list_toa_do_points tu p1 den p2.
(defun HA:ConvLst (lst p1 p2 / i lst1)
(repeat (setq i (length lst))
 (setq lst1 (cons (polar (nth (setq i (1- i)) lst) (angle p1 p2) (distance p1 p2)) lst1))))
;----- Get list points of Curve (*Line, Arc, Circle, Ellipse, Point).
(defun LM:Entity->PointList ( ent / der di1 di2 di3 elst fun inc lst par rad )
(setq elst (entget ent))
(cond
   	((eq "POINT" (cdr (assoc 0 elst)))
       	(list (cdr (assoc 10 elst))))
   	((eq "LINE" (cdr (assoc 0 elst)))
       	(list (cdr (assoc 10 elst)) (cdr (assoc 11 elst))))
   	((member (cdr (assoc 0 elst)) '("CIRCLE" "ARC"))
       	(setq di1 0.0
             	di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
             	inc (/ di2 (1+ (fix (* 35.0 (/ di2 (cdr (assoc 40 elst)) (+ pi pi))))))
             	fun (if (vlax-curve-isclosed ent) < <=))
       	(while (fun di1 di2)
           	(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                 	di1 (+ di1 inc)))
       	lst)
   	((or (eq (cdr (assoc 0 elst)) "LWPOLYLINE")
           	(and (eq (cdr (assoc 0 elst)) "POLYLINE") (zerop (logand (cdr (assoc 70 elst)) 80))))
       	(setq par 0)
       	(repeat (fix (1+ (vlax-curve-getendparam ent)))
           	(if (setq der (vlax-curve-getsecondderiv ent par))
               	(if (equal der '(0.0 0.0 0.0) 1e-8)
                   	(setq lst (cons (vlax-curve-getpointatparam ent par) lst))
                   	(if (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
                             	di1 (vlax-curve-getdistatparam ent par)
                             	di2 (vlax-curve-getdistatparam ent (1+ par)))
                       	(progn
                           	(setq inc (/ (- di2 di1) (1+ (fix (* 35.0 (/ (- di2 di1) rad (+ pi pi)))))))
                           	(while (< di1 di2)
                               	(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                                     	di1 (+ di1 inc)))))))
           	(setq par (1+ par)))
       	(if (or (vlax-curve-isclosed ent) (equal '(0.0 0.0 0.0) der 1e-8))
           	lst
           	(cons (vlax-curve-getendpoint ent) lst)))
   	((eq (cdr (assoc 0 elst)) "ELLIPSE")
       	(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
             	di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam   ent))
             	di3 (* di2 (/ (+ pi pi) (abs (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent))))))
       	(while (< di1 di2)
           	(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                 	der (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1)))
                 	di1 (+ di1 (/ di3 (1+ (fix (/ 35.0 (/ di3 der (+ pi pi)))))))))
       	(if (vlax-curve-isclosed ent)
           	lst
           	(cons (vlax-curve-getendpoint ent) lst)))
   	((eq (cdr (assoc 0 elst)) "SPLINE")
       	(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
             	di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam   ent))
             	inc (/ di2 25.0))
       	(while (< di1 di2)
           	(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
                 	der (/ (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1))) inc)
                 	di1 (+ di1 (if (equal 0.0 der 1e-10) inc (min inc (/ 1.0 der (* 10. inc)))))))
       	(if (vlax-curve-isclosed ent)
           	lst
           	(cons (vlax-curve-getendpoint ent) lst)))))
;----- Get BoundingBox of Object (chu y: luon luon // XOY bat ke UCS).
(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))))))
;----- Draw Lwpolyline (cls=1: closed; cls=0: open; 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: modify 19h15 16/6/2012