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

[Nhờ trợ giúp] BÀI TOÁN XỬ LÝ DANH SÁCH

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

ndtnv    396

Ban đầu xem video tôi cũng nghĩ là thanhduan2407 làm theo thật toán bài hatch kín

Xem bài hatch kín trong link, chỉ cần loại bỏ region lớn nhất
Tìm boundingbox của region
Vẽ 1 xline đứng qua trung điểm đường chéo hcn
Lấy trung điểm 2 giao điểm của xline và region

Nếu có trên 2 giao điểm, lấy trung điểm đoạn lớn nhất nằm trong region (đoạn thứ 1, 3 ..)

Nếu dùng hàm lấy centroid có thể text nằm ra ngoài region nếu lõm

(vlax-get obj 'Centroid)

  • 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
thanhduan2407    226

 

Xem bài hatch kín trong link, chỉ cần loại bỏ region lớn nhất

Tìm boundingbox của region

Vẽ 1 xline đứng qua trung điểm đường chéo hcn

Lấy trung điểm 2 giao điểm của xline và region

Nếu có trên 2 giao điểm, lấy trung điểm đoạn lớn nhất

 

Em dùng lệnh Hatchkin thấy tốc độ nó chậm quá anh ạ

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
thanhduan2407    226
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/page-2
(defun FiltReg (rg / el i j n r rt ss)
    (setq i -1 n (1- (length rg)) el (entlast))
    (repeat n
        (setq i (1+ i) j n r nil)
        (while (and (not r) (> j i))
            (setq ss (ssadd))
            (vla-copy (vlax-ename->vla-object(car(nth i rg))))
            (setq ss (ssadd (entlast) ss))
            (vla-copy (vlax-ename->vla-object(car(nth j rg))))
            (setq ss (ssadd (entlast) ss))
            (vl-cmdf "INTERSECT" ss "")
            (if (not (eq el (entlast)))
                (progn
                    (setq r (nth i rg))
                    (setq rt (append rt (list r)))
                    (entdel (entlast)))
            )
            (setq j (1- j))
        )
    )
    rt
)

(defun c:hatchkin(/)
  (princ "\nChon Cac Line, Polyline, Arc, Circle, Spline Hoac Ellipse De Tao Polyline Kin")
  (if (setq chonlinepolyline (ssget '((-4 . "<OR")(0 . "LINE")(0 . "CIRCLE")(0 . "SPLINE")(0 . "ARC")(0 . "ELLIPSE")(0 . "*POLYLINE")(-4 . "OR>"))))
    (progn   
      (setq chonpolyline (ssadd))
      (setq lsppolyline nil)
      (setq i 0)
      (repeat (sslength chonlinepolyline)
      (taopolyline (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
               (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
              10000)) "0" 1)
    (ssadd (entlast) chonpolyline)
    (setq lsppolyline (append lsppolyline (list (ACET-GEOM-OBJECT-POINT-LIST (ssname chonlinepolyline i)
                              (/ (vlax-curve-getdistatparam (ssname chonlinepolyline i) (vlax-curve-getendparam (ssname chonlinepolyline i)))
                             10000)))))
    (setq i (+ i 1))
    )
      (setq lspgiaodiem (LM:IntersectionsInSet chonpolyline))
      (setq chonline (ssadd))
      (setq lspchonline nil)
      (setq lsp2diemline nil)
      (foreach lsp lsppolyline
    (foreach diemgiao lspgiaodiem
      (setq lsp (DDH:pointtolsppoint diemgiao lsp))
      )
    (setq i 0)
    (repeat (- (length lsp) 1)
      (setq lsp2diemline (append lsp2diemline (list (list (nth i lsp) (nth (+ i 1) lsp)))))
      (setq i (+ i 1))
      )
    )
      (setq lsp2diemline (LM:Uniqueline lsp2diemline))
      (foreach line lsp2diemline
    (entmakex (list '(0 . "LINE")
            (cons 10 (car line))
            (cons 11 (cadr line))
            ))
    (ssadd (entlast) chonline)
    (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast)))))
    )
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
    (progn
      (command "ERASE" chonline "")
      (command "ERASE" chonpolyline "")
      (setq lspxetbien nil)
      (foreach tungregion lsptongregion
        (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
        )
      (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
        (setq rt (FiltReg lspxetbien))
      (foreach r rt
            (setq lspxetbien (vl-remove r lspxetbien))
        (entdel (car r))
      )
;;;      (setq dientichtong 0.00)
;;;      (foreach dientich (cdr lspxetbien)
;;;        (setq dientichtong (+ dientichtong (cadr dientich)))
;;;        )
;;;      (if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
;;;        (entdel (car (car lspxetbien)))
;;;        )
      (setq mau 0)
      (foreach xetpl lspxetbien
	  (setq Ename1 (car xetpl))
          (setq DTich (rtos (cadr xetpl) 2 3))
          (wtxt DTich (mid Ename1) 25 0 "L" 2)
	  (entdel Ename1)
        )
      )
    )
      )
    )
 (princ lspxetbien)
 (Princ)
  )
 
(defun taopolyline (lst layer mau / x )
  (entmakex
    (append (list (cons 0 "LWPOLYLINE")
		  (cons 100 "AcDbEntity")
		  (cons 100 "AcDbPolyline")
		  (cons 90 (length lst))
		  (cons 70 0)
		  (cons 66 1)
		  (cons 8 layer)
		  (cons 62 mau)
		  )
	    (mapcar (function (lambda (x) (cons 10 x))) lst)
	    )
    )  
  )

(defun LM:intersectionsinset ( sel / id1 id2 ob1 ob2 rtn )
    (repeat (setq id1 (sslength sel))
        (setq ob1 (vlax-ename->vla-object (ssname sel (setq id1 (1- id1)))))
        (repeat (setq id2 id1)
            (setq ob2 (vlax-ename->vla-object (ssname sel (setq id2 (1- id2))))
                  rtn (cons (LM:intersections ob1 ob2 acextendnone) rtn)
            )
        )
    )
    (apply 'append (reverse rtn))
)

(defun DDH:pointtolsppoint (pointchen lsppointchen / vitrichen ii)
  (setq iii 0)
  (repeat (- (length lsppointchen) 1)
    (if (and (> (distance pointchen (nth (+ iii 1) lsppointchen)) 0.001)
	     (> (distance pointchen (nth iii lsppointchen)) 0.001)
	     )
      (progn
	(if (<= (abs (- (distance (nth iii lsppointchen) (nth (+ iii 1) lsppointchen))
			(+ (distance pointchen (nth (+ iii 1) lsppointchen))
			   (distance pointchen (nth iii lsppointchen))
			   )
			))
		     0.001)
	  (setq vitrichen (+ iii 1))
	  )
	)
      )
    (setq iii (+ iii 1))
    )
  (setq lsppointchen (LM:InsertNth pointchen vitrichen lsppointchen))
  )

(defun LM:InsertNth ( x n l )
  ((lambda ( k )
     (apply 'append
	    (mapcar '(lambda ( a ) (if (= n (setq k (1+ k))) (list x a) (list a))) l)
	    )
     )
    -1
    )
  )
(defun LM:Uniqueline ( l )
  (if l (cons (car l)
	      (LM:Uniqueline
		(vl-remove-if '(lambda (x) (or (and (equal (car x) (car (car l)))
						    (equal (cadr x) (cadr (car l))))
					       (and (equal (car x) (cadr (car l)))
						    (equal (cadr x) (car (car l))))
					       )
				 ) (cdr l))
		))))



(defun mid (ent / p1 p2)
	(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
	(setq p1 (vlax-safearray->list p1)
				p2 (vlax-safearray->list p2)
				pt (mapcar '+ p1 p2)
				pt (mapcar '* pt '(0.5 0.5 0.5))
	)
	pt
)

(defun wtxt (string Point Height Ang justify Color / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (cons 62 Color)		 
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
       		((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 point)))))
        	((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
        	((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
        	((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
        	((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
        	((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
        	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
        	((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
        	((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
        	((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
        	((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
        	((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)

Em đã sửa nhưng tốc độ nó rùa quá. Nhờ các bác chỉ giáo dù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
tien2005    97

lisp chạy chậm là đúng rồi vì nó phải xử lý các đối tượng circle, arc, spline,...

trong lisp  hatchkin.lsp thì dòng lệnh (setq lspchonline (append lspchonline (list (vlax-ename->vla-object (entlast))))) tương đương với việc bạn chọn các line (trong file bạn đính kèm) rồi chuyển thành object

 

thay đoạn

(foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion) (vlax-get-property tungregion 'area)))))
	    )

bằng đoạn (phần tử thứ 3 là tọa độ trọng tâm region)

(foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion)
							    (vlax-get-property tungregion 'area)
							    (vlax-safearray->list (vlax-variant-value (vlax-get-property tungregion 'centroid)))
							    ))))
	    
	    )

sau đó bạn xử lý tiếp nhé

Với file bạn up lên mình test bằng lisp của bạn mất ~6s, tính theo lisp hatchkin.lsp sau khi đã bỏ các phần thừa  thì mất ~0.4s

  • 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
thanhduan2407    226

Việc loại bỏ vùng bao ngoài hình như hơi lâu anh ạ. Em sửa thì bị sai hàm FiltReg. Mong anh tìm giúp ạ. Đúng là nó chạy nhanh thật. Em thích quá anh ạ. ^^

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
tien2005    97

đây nè bạn

(defun CV:ss-to-list (ss vla / n e l)
  (if ss
    (progn
      (setq n (sslength ss))
      (while (setq e (ssname ss (setq n (1- n))))
	(setq l	(cons (if vla
			(vlax-ename->vla-object e)
			e
		      )
		      l
		)
	)
      )
    )
  )
)
(defun c:hatchkin( / ACDOC LSPCHONLINE LSPTONGREGION LSPXETBIEN MAU MS SS TI X)
  ;(vl-load-com)
  (princ "\nChon Cac Line")
  (command ".undo" "be")
  (if (setq ss (ssget '((0 . "LINE"))))
    (progn
      (setq ti (car (_VL-TIMES)))
      (setq lspchonline (CV:ss-to-list ss t))
      
      (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
      (setq ms (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
      (if (setq lsptongregion (vlax-invoke ms 'AddRegion lspchonline))
	(progn
	  (setq lspxetbien nil)
	  (foreach tungregion lsptongregion
	    (setq lspxetbien (append lspxetbien (list (list (vlax-vla-object->ename tungregion)
							    (vlax-get-property tungregion 'area)
							    (vlax-safearray->list (vlax-variant-value (vlax-get-property tungregion 'centroid)))
							    ))))
	    
	    )
	  
	  (setq lspxetbien (vl-sort lspxetbien (function (lambda (e1 e2) (> (cadr e1) (cadr e2))))))
	  ;(setq dientichtong 0.00)
	  ;(foreach dientich (cdr lspxetbien)
	   ; (setq dientichtong (+ dientichtong (cadr dientich)))
	    ;)
	  ;(if (<= (abs (- (cadr (car lspxetbien)) dientichtong)) 0.0001)
	   ; (entdel (car (car lspxetbien)))
	    ;)
	  
	  ;xoa doi tuong tong dien tich
	  (if (equal (* (apply '+(mapcar'(lambda (x) (cadr x)) lspxetbien))0.5) (cadr (car lspxetbien)) 1e-8)
	    (entdel (car (car lspxetbien)))
	    )
	  
	  (setq mau 1)
	  (foreach xetpl (cdr lspxetbien)
	    (if (>= mau 7)
	      (setq mau 1)
	      )
	    (entmakex (list (cons 0 "TEXT")
                  (cons 10  (caddr xetpl))
                  (cons 40 12)
                  (cons 1  (rtos(cadr xetpl) 2 5))))
	    
	    ;(command "hatch" "" "" "" (car xetpl) "")
	    (entdel (car xetpl))
	    ;(command "change" (entlast) "" "p" "c" mau "")
	    (setq mau (+ mau 1))
	    )
	  ;(mapcar'(lambda (x) (vla-delete x)) lsptongregion)
	  )
	)
      (princ (strcat "\nThoi gian thuc hien chuong trinh la: "
		 (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
		 " secs."
	 )
  )
      )
    )
  (command ".undo" "e")
  (princ)
  )
  • 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
thanhduan2407    226

Hôm qua trước khi đi ngủ em sửa xong rồi anh ạ. Tuy nhiên vẫn còn chưa thực hiện được việc loại vùng bao ngoài. Anh xem có cách nào 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
tien2005    97

đoạn code này đã xoá rồi

;xoa doi tuong tong dien tich
	  (if (equal (* (apply '+(mapcar'(lambda (x) (cadr x)) lspxetbien))0.5) (cadr (car lspxetbien)) 1e-8)
	    (entdel (car (car lspxetbien)))
	    )

nếu chưa xoá là do độ chính xác cao quá, có thể giảm xuống 1e-3 chẳng hạ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
Doan Van Ha    2.676

Sửa giùm bạn TD cho nó gọn.

Test trên bản vẽ của TD hết 0.1", trên bản vẽ của TRUNGNGAMY với 59.966 objects hết 53" (chưa kiểm tra kết quả đầy đủ).

Nếu chọn 1 thuật toán khác thì khả dĩ (?), chứ nếu chọn kiểu add region thì rất khó để rút ngắn thời gian, bởi đã test thì thấy hơn 95% thời gian là dành cho việc add region.

 

; Test tren ban ve TD (0.1"), ban ve TrungNgaMy (53")
(vl-load-com)
(defun CV:ss-to-list (ss vla / n e l)
 (if ss
  (progn
   (setq n (sslength ss))
   (while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (if vla (vlax-ename->vla-object e) e) l))))))
(defun c:hatchkin( / ss ti acDoc msp lstobj lst)
 (princ "\nChon Cac Line")
 (command ".undo" "be")
 (if (setq ss (ssget '((0 . "LINE"))))
  (progn
   (setq ti (car (_vl-times)))
   (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
   (setq msp (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
   (if (setq lstobj (vlax-invoke msp 'AddRegion (CV:ss-to-list ss T)))
(progn
     (setq lst (mapcar '(lambda(obj) (list obj (vlax-get obj 'area) (vlax-get obj 'centroid))) lstobj))
     (setq lst (vl-sort lst '(lambda (e1 e2) (> (cadr e1) (cadr e2)))))
     (mapcar '(lambda(x) (entmake (list '(0 . "TEXT") (cons 10 (caddr x)) '(40 . 1) (cons 1 (rtos (cadr x) 2 5))))) (cdr lst))
(mapcar 'vla-delete lstobj)))))
 (command ".undo" "e")
 (princ (strcat "\nThoi gian thuc hien chuong trinh la: " (rtos (/ (- (car (_vl-times)) ti) 1000.) 2 4) " secs."))
 (princ))
  • 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ảnh báo!

Rảnh rỗi ngồi test thử Lisp trên (#35) với 2 bản vẽ: của Thanhduan và của TrungNgaMy. Kết quả thật nguy hiểm:

- Với bản vẽ của Thanhduan (592 Lines): lisp chạy đúng

- Với bản vẽ của TrungNgaMy (39.966 Lines): lisp chạy sai.

Lý do sai: tự sinh rất nhiều region bao trùm lên nhau. Có thể kiểm chứng điều này bằng cách đừng xóa các region được tạo ra.

Do không biết cơ chế tạo region như thế nào nên không thể giải thích được lý do. Hy vọng có bạn hiểu sâu hơn sẽ giải thích rõ.

  • 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
tien2005    97

Tôi đã test và nhận thấy bản vẽ của TrungNgaMy lisp chạy sai là do chúng ta chọn 1 lần gồm nhiều vùng rời rạc bị ngăn cách bởi các con đường, kênh, sông... Để rõ hơn xem hình minh họa

3202_region.jpg

 

khi chạy lisp tôi chọn cả 2 vùng và kết quả đạt được là các region và text màu xanh. Ở đây vùng 1 bị sai do lisp đã ghi luôn diện tích tổng của vùng 1, vùng 2 vẫn đúng

Nguyên nhân là khi chạy lisp sẽ tạo ra các region và 2 region tổng của 2 vùng, sau khi tính toán và sắp xếp thì lisp cắt bỏ diện tích lớn nhất (ở đây là region tổng của vùng 2) và bắt đầu ghi kết quả của các vùng còn lại trong đó có region tổng của vùng 1

 

Do đó để có kết quả tin cậy thì nên chọn từng vùng cho mỗi lần tính toán

  • 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
thanhduan2407    226

Em nghiên cứu và làm được như ý muốn.

Các bác cho em nhận xét như vậy đã ổn chưa ạ?

(vl-load-com)
(defun CV:ss-to-list (ss vla / n e l)
  (if ss
    (progn
      (setq n (sslength ss))
      (while (setq e (ssname ss (setq n (1- n))))
	(setq l	(cons (if vla
			(vlax-ename->vla-object e)
			e
		      )
		      l
		)
	)
      )
    )
  )
)
(defun c:90 (/  ACDOC LST LST1 LSTOBJ MSP OBJ SS TAMVUNG TI )
(princ "\nChon Cac Line")
(command ".undo" "be")
(if (setq ss (ssget '((0 . "LINE"))))
	(progn
		(or *Caochu* (setq *Caochu* 0.2))
		(setq Caochu (getreal (strcat  "\nNh\U+1EADp chi\U+1EC1u cao Text ghi di\U+1EC7n t\U+00EDch <" (rtos *Caochu* 2 2)  ">: " )))
		(if (not Caochu)(setq Caochu *Caochu*)(setq *Caochu* Caochu))
		(setq ti (car (_vl-times)))
		(or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
		(setq msp (vlax-get acDoc
				  (if (= 1 (getvar 'cvport))
				    'paperspace
				    'modelspace
				  )
			  )
		)
	  	(if (setq lstobj (vlax-invoke msp 'AddRegion (CV:ss-to-list ss T)))
			(progn
				(setq	lst (mapcar '(lambda (obj) (list obj  (vlax-get obj 'area) (vlax-get obj 'centroid) )) lstobj))
				(setq	lst (vl-sort lst '(lambda (e1 e2) (< (cadr e1) (cadr e2)))) )
				(setq lst1 (TD:EraseVungGiao lst))
				(setq lst1 (SortTDTam lst1))
			  	(foreach xetpl lst1
				  	(setq TamVung (_cen (vlax-vla-object->ename (car xetpl))))
				  	(wtxt (rtos (cadr xetpl) 2 3) TamVung 2.5 0 "TC" 2)
				)
				(mapcar 'vla-delete lstobj)
			)
		)
	)
)
(command ".undo" "e")
(princ (strcat "\nTh\U+1EDDi gian th\U+1EF1c hi\U+1EC7n ch\U+01B0\U+01A1ng tr\U+00ECnh l\U+00E0: " (rtos (/ (- (car (_vl-times)) ti) 1000.) 2 4) " gi\U+00E2y"))
(princ)
)

(defun TD:EraseVungGiao(l / )
  (if l
    (cons (car l)
	  (TD:EraseVungGiao  (vl-remove-if '(lambda (x) (insideregion-p  (car (car l)) (car x)) ) (cdr l)))
    )
  )
)


(defun wtxt (string Point Height Ang justify Color / Lst)
 (setq Lst (list '(0 . "TEXT")
   (cons 10 point)
   (cons 40 Height)
   (cons 1 string)
   (cons 62 Color)		 
   (if Ang (cons 50 Ang))
   (cons 7 (if Style Style (getvar "Textstyle"))))
  justify (strcase justify))
 (cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
       		((= justify "L") (setq Lst (append Lst (list (cons 72 0)(cons 73 0) (cons 10 point)))))
        	((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
        	((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
        	((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
        	((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
        	((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))   
        	((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
        	((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
        	((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
        	((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
        	((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
        	((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
 (entmake Lst)
)

;;;;;;;;;;SAP XEP THEO X , NEU X BANG NHAU THI SAP XEP THEO Y;;;;
(defun SortTDTam (lstPnt /)
  (setq  Lts-Sort (vl-sort (vl-sort lstPnt '(lambda (e1 e2) (< (cadr (caddr e1)) (cadr (caddr e2))))) '(lambda (e1 e2)(< (car (caddr e1)) (car (caddr e2))))))
  Lts-Sort
)

(defun _cen (v / p1 p2 p u)
        (vla-getboundingbox (setq v (vlax-ename->vla-object v)) 'p1 'p2)
        (setq p (mapcar '* (mapcar '+ (vlax-safearray->list p1) (vlax-safearray->list p2)) '(0.5 0.5 0.5)))
    (setq u (entmakex (list '(0 . "LINE") (cons 10 p)(cons 11 (polar p (/ pi 2) 1)))))
    (setq    p    (vlax-invoke v 'IntersectWith (vlax-ename->vla-object u) 2)    )
    (entdel u)
    (list (car p) (/ (+ (cadr p)(nth 4 p))2) (caddr p))
)



(defun insideregion-p (rg1 rg2 / a b c d e r)
  (vla-getboundingbox rg1 'a 'b)
  (vla-getboundingbox rg2 'c 'd)
  (and (apply
	 'and
	 (apply	'mapcar
		(cons '<= (mapcar 'vlax-safearray->list (list c a b d)))
	 )
       )
       (progn (setq e (vla-copy rg2))
	      (vla-boolean e acunion (vla-copy rg1))
	      (setq r (equal (vla-get-area rg2) (vla-get-area e) 1e-8))
	      (vla-delete e)
	      r
       )
  )
)

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

1). Hàm SortTDTam không cần thiết. Đồng thời viết theo kiểu 2 lần sort sẽ rất tốn time.

2). Thêm cái hàm TD:EraseVungGiao làm tốc độ giảm đáng kể. Test trên bản vẽ của TrungNgaMy thì nổ laptop luôn!  <_<

3). Các bài toán dạng này khó mà giải quyết triệt để bằng ngôn ngữ Lisp. Đành phải chia từng vùng nhỏ để tính S thôi.

  • 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
thanhduan2407    226

 

 

 Hàm SortTDTam không cần thiết. Đồng thời viết theo kiểu 2 lần sort sẽ rất tốn time.

Hàm đó em đưa vào phục vụ mục đích của mình anh ạ! Đó là việc đánh số thửa.

Đúng là tốc độ đã giảm rất nhiề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

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


×