Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
40 replies to this topic

#21 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 01:15 PM

Ý tưởng tuyệt vời! khi nào rảnh mình cũng muốn thử viết lisp này :)

 

 

Với em thì có thuật toán nhưng phương thức thực hiện có thể hơi rườm rà chưa tối ưu trong việc xử lý danh sách. Nếu bác nào muốn viết và nâng cấp thì có thể trao đổi với em.


  • 1



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#22 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 25 February 2015 - 03:37 PM

Nếu dùng lisp để giải thuật toán này rất tốn thời gian vì xử lý list của lisp rất chậm đối với các list có nhiều phần tử.

Bài toán TOPOLOGY chỉ thích hợp cho các ngôn ngữ sử dụng mảng, code và thư viện có nhiều trên net.

Theo file mẫu thì lệnh REGION của cad có thể áp dụng cho cả các loại đường cong khác, mọi việc để cad tính toán.

Vị trí của text nằm ra ngoài ở các REGION lõm hoặc hình tam giác, nếu lấy trung điểm của đoạn thẳng đứng trong REGION thì  đẹp hơn


  • 1

#23 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 03:48 PM

Nếu dùng lisp để giải thuật toán này rất tốn thời gian vì xử lý list của lisp rất chậm đối với các list có nhiều phần tử.

Bài toán TOPOLOGY chỉ thích hợp cho các ngôn ngữ sử dụng mảng, code và thư viện có nhiều trên net.

Theo file mẫu thì lệnh REGION của cad có thể áp dụng cho cả các loại đường cong khác, mọi việc để cad tính toán.

Vị trí của text nằm ra ngoài ở các REGION lõm hoặc hình tam giác, nếu lấy trung điểm của đoạn thẳng đứng trong REGION thì  đẹp hơn

Bác có thể nói rõ hơn dc ko ạ?

Vị trí của text nằm ra ngoài ở các REGION lõm hoặc hình tam giác, nếu lấy trung điểm của đoạn thẳng đứng trong REGION thì  đẹp hơn


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#24 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 25 February 2015 - 03:49 PM

@thanhduan2407 tham khao bài này http://www.cadviet.c...iao-nhau/page-2

 

edit lại 1 ít là sẽ có kết quả như mong muốn


  • 0

#25 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 04:09 PM

Nhờ bác 

tien2005 chỉ giáo cho em cách tìm tâm vùng Region được ko ạ? Em cảm ơn bác 
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#26 ndtnv

ndtnv

    biết lệnh minsert

  • Members
  • PipPipPipPipPipPip
  • 437 Bài viết
Điểm đánh giá: 384 (khá)

Đã gửi 25 February 2015 - 04:10 PM

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)


  • 1

#27 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 04:17 PM

 

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 ạ


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#28 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 04:25 PM

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.c...iao-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 ạ


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#29 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 25 February 2015 - 09:35 PM

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


  • 1

#30 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 10:03 PM

Anh có thể cho em xin đoạn mã anh sửa dc ko ạ?


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#31 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 25 February 2015 - 10:21 PM

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


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#32 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 25 February 2015 - 10:41 PM

đâ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)
  )

  • 1

#33 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 26 February 2015 - 06:23 AM

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


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#34 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 26 February 2015 - 09:48 AM

đ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


  • 1

#35 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 26 February 2015 - 02:58 PM

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))

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


#36 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 26 February 2015 - 05:35 PM

Em cảm ơn anh 

tien2005 và bác DOAN VAN HA nhiều. Kết quả  đúng là không tưởng.
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#37 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 27 February 2015 - 03:41 PM

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


  • 2

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


#38 tien2005

tien2005

    biết lệnh properties

  • Members
  • PipPipPipPip
  • 257 Bài viết
Điểm đánh giá: 94 (tàm tạm)

Đã gửi 28 February 2015 - 10:59 AM

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


  • 2

#39 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 995 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 03 March 2015 - 10:42 AM

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
       )
  )
)


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#40 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 03 March 2015 - 11:06 AM

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.


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