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

Tháng 2 7, 2015

Chào các anh/chị/em!

Em đang viết 1 chương trình tính diện tích hàng loạt dựa trên một thuật toán nhưng em đang vướng ở khâu xử lý danh sách.

Trong file đính kèm em mô tả và có hình vẽ chi tiết nên các bác xem có thể trợ giúp em được cách xử lý không ạ?

Em cảm ơn các bác nhiều!

http://www.cadviet.com/upfiles/4/36665_danh_sach_tao_vung_2.dwg

(defun C:00 (   / FLAT I ID ID+1 L1 L2 LTSREPNT_)
(setq i 0)
(setq l2 (list))
(setq LtsRePnt_ (list '(1 2 3) '(2 6 4 1) '(3 4 5 1) '(4 6 3 2) '(5 7 3) '(6 7 4 2) '(7 5 6)))
(while (< i (- (length LtsRePnt_) 1))
	(setq l1 (list))
  	(setq Flat nil)
  	(setq ID (car (nth i LtsRePnt_)))
  	(setq ID+1 (cadr (nth i LtsRePnt_)))  ;;(LM:sublst LtsRePnt_ 2 (- (length LtsRePnt_) 2))
  	(setq l1 (list ID ID+1))
  	(setq j 0)
  	(while (and (< j (- (length LtsRePnt_) 1)) (< ID ID+1) (>= j i))
	    (progn
	      (foreach Lts1 (LM:sublst LtsRePnt_ (- ID+1 1) (- (length LtsRePnt_) (- ID+1 1)))
		(if (equal (+ (GetVitribyItem ID+1 lts1) 1) (GetVitribyItem ID lts1) )
		    (progn
			(setq ID  ID+1)
		      	(setq ID+1 (mapcar '(lambda (x)(nth (+ (GetVitribyItem ID+1 x) 1)  x)) (LM:sublst LtsRePnt_ (- ID 1) (- (length LtsRePnt_) (- ID 1)))))
			(setq l1 (append (list ID) (list ID+1)))
		    )
		)
;;;	  	(if (not (equal (+ (GetVitribyItem ID+1 lts1) 1) (GetVitribyItem ID lts1) ))
;;;		    (progn
;;;			(setq ID  ID+1)
;;;			(setq ID+1  (nth (- (GetVitribyItem ID lts1) 1)  lts1))
;;;		      	(setq l1 (list ID ID+1))
;;;		    )
;;;		)
	       )
	      )
	      (setq Flat T)
	      (setq j (1+ j))
	 )
	  
	(setq l2 (append l2 (list l1)))
  	(setq i (1+ i))
)
(princ l2)
(textscr)
(princ)
)



;;;;TIM VI TRI TRONG DANH SACH
;;(GetVitribyItem "D" (list 2 3 4 "D" "R" "er"))
(defun GetVitribyItem (Item Ltstim / i )
(setq i 0)
(while (<= i (length Ltstim))
       (if (equal Item (nth i Ltstim))
	   (setq Vtri i)
       )
  	(setq i (1+ i))
)
  Vtri
)

;;;(LM:sublst '(1 2 3 4 5 6 7 8) 2 4)
;;;(LM:sublst '(1 2 3 4 5 6 7 8) 2 nil)
(defun LM:sublst ( lst idx len / rtn )
    (setq len (if len (min len (- (length lst) idx)) (- (length lst) idx))
          idx (+  idx len)
    )
    (repeat len (setq rtn (cons (nth (setq idx (1- idx)) lst) rtn)))
)

Tháng 2 7, 2015

Có mấy ý kiến:

1. Cách rà soát của bạn chỉ tìm ra các "chu trình" chứ không tìm ra các "vùng". Nếu đúng là bạn chỉ cần tìm các chu trình, bạn có thể tìm kiếm với từ khóa "Chu Trình" "Đồ Thị" sẽ thấy rất nhiều.

2. Thuật toán để tìm vùng (nếu có) cần phải dựa vào tương quan giữa các đỉnh với nhau, chứ không đơn thuần chỉ là mảng danh sách. Với những gì mình biết, thuật toán tìm vùng này không có lời giải lý thuyết, buộc phải sử dụng thuật toán loang màu (Flood Fill) - giống như việc ta sử dụng lệnh Hatch hay lệnh Boundary của AutoCAD.

Tháng 2 8, 2015

Cảm ơn anh Nguyen Hoanh đã quan tâm. Đây là thuật toán tạo vùng đã được em lược bỏ và đưa về bài toán xử lý danh sách.

Do em vẫn còn hạn chế về ngôn ngữ và phương thức nên việc tìm được và gán em vẫn chưa thực hiện được. Em cảm ơn anh đã trợ giúp.

Nếu có thời gian rảnh, anh có thể cho em một đoạn code (mẫu bất kỳ) về việc tìm và gán theo vòng lặp được không ạ? Em cũng sẽ tự vận động tìm cách chứ ko ngồi chờ. Em cảm ơn anh.

P/s: Em tìm từ khóa nhưng không tìm dc anh ạ.

Tháng 2 8, 2015

Mình nghĩ lisp kg tạo được danh sách liên kết kiểu 1 hay 2 chiều đâu, chỉ những ngôn ngữ có kiểu dữ liệu con trỏ như C hay pascal mới làm đc. Còn giải thuật tính diện tích trên lisp theo mình có thể thực hiện như sau:

- Chọn ss line

- qua mỗi line lập ds các đỉnh không trùng nhau, mỗi đỉnh nhớ các line qua nó

- lập ds các line, mỗi line mang số thứ tự của 2 đỉnh đã lưu ở trên

- căn cư vào line tìm ra đỉnh, căn cứ vào đỉnh tìm ra line và chọn line phù hợp để đi tiếp, cứ thế lúc nào đỉnh trùng đỉnh thì dừng.

Cách của bạn mình chưa hình dung đc, nếu hay mình cũng sẽ thử. Vài lời góp ý cùng bạn, nếu có gì kg đúng xin miễn chấp.

Tháng 2 9, 2015

Cảm ơn góp ý của bác! Em cũng sắp hoàn thành được rồi bác ạ!

Tháng 2 9, 2015

Và đây là thành quả của em các bác ạ!

Tháng 2 9, 2015

Chúc mừng bạn,

Bạn đã thử với tình huống hình bất kỳ chưa?

Gồm cả tam giác, tứ giác, ngũ giác lẫn lộn?

Vì bài toán tứ giác chỉ là một trường hợp riêng đơn giản của bài toán ban đầu.

Tháng 2 9, 2015

Chúc mừng bác đã gặt hái thành quả sau bao ngày thai nghén.

Tháng 2 9, 2015

Chúc mừng bác đã gặt hái thành quả sau bao ngày thai nghén.

Chúc mừng bạn,

Bạn đã thử với tình huống hình bất kỳ chưa?

Gồm cả tam giác, tứ giác, ngũ giác lẫn lộn?

Vì bài toán tứ giác chỉ là một trường hợp riêng đơn giản của bài toán ban đầu.

Cảm ơn bác Hoành, em Hoanghieu!

Chương trình áp dụng cho tất cả các hình anh ạ!

Tháng 2 9, 2015

- anh Duan có share ko nhỉ ^^

Tháng 2 9, 2015

- anh Duan có share ko nhỉ ^^

Nếu em xin anh sẽ gửi cho.

Tháng 2 10, 2015

Chúc mừng bạn.

Để bạn có điều kiện phát triển và trắc nghiệm mình gởi bạn file một bản đồ địa chính cấp xã nơi mình làm việc. Đây là một công trình do CQ mình trực tiếp thi công. Mình xóa các nội dung không cần thiết, chỉ để lại line và diện tích để bạn kiểm tra, nếu tính tốt file này gần như bạn đã thành công thật sự : http://www.cadviet.com/upfiles/4/37170_detinhdientich.zip

Tháng 2 23, 2015

Tính diện tích với mọi hình anh Hoành ạ!

@Trungngamy: Máy đơ anh ạ

Tháng 2 25, 2015

với các biên là pline, arc, circle, elip, spline thì có tính được không vậy bạn?

Tháng 2 25, 2015

- như clip minh họa nhoc đoán mới xử đc cho line thì phải.

-p/s: đợi anh Duan cải tiến thêm ^^

Tháng 2 25, 2015

-

Tính diện tích với mọi hình anh Hoành ạ!

@Trungngamy: Máy đơ anh ạ

-Cho mình xin code tham khảo nha bạn. Thank truoc

Tháng 2 25, 2015

Và đây là thành quả của em các bác ạ!

Hề hề hề,

Đây là vấn đề ngoại ngạch của mình. song rất ư là phấn khởi chúc mừng bác ThanhDuan đã thành công bước đầu. nếu có thể mong bác chia sẻ cái lisp này để mình mót thêm về thuật toán được sử dụng. Cứ theo ngu ý của mình thì bài toán này không đơn giản và việc giải quyết rốt ráo nó cũng là một nhu cầu của nhiều người....

Tháng 2 25, 2015

với các biên là pline, arc, circle, elip, spline thì có tính được không vậy bạn?

Em mới viết với các đối tượng Line thôi bác ạ! Còn các đối tượng là đường cong thì em chưa viết! Chương trình viết mới dựa trên thuật toán tạo vùng TOPOLOGY của em.

(vl-load-com)
(prompt (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh t\U+00EDnh di\U+1EC7n t\U+00EDch h\U+00E0ng lo\U+1EA1t"
		"\nL\U+1EC7nh: TOPOLOGY"
		"\nNg\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n"
		"\nEmail: heaven2407@gmail.com"
		"\nMobile: 0972.0168.25"
	)
)
;;;(Alert (strcat "\nCh\U+01B0\U+01A1ng tr\U+00ECnh t\U+00EDnh di\U+1EC7n t\U+00EDch h\U+00E0ng lo\U+1EA1t"
;;;		"\nL\U+1EC7nh: TOPOLOGY"
;;;		"\nNg\U+01B0\U+1EDDi vi\U+1EBFt: Nguy\U+1EC5n Th\U+00E0nh Du\U+00E2n"
;;;		"\nEmail: heaven2407@gmail.com"
;;;		"\nMobile: 0972.0168.25"
;;;	)
;;;)
(defun c:99 ( /  LTSAREA LTSGETAREA LTSIDLINE LTSIDPNT LTSLINE LTSPNT LTSPV_ID X S1 S2);;;;TOPOLOGY
(setvar "CMDECHO" 0)
 ;;;;;LAM VIEC VOI POINT
(setq LtsLine (acet-ss-to-list (ssget (list (cons 0 "LINE")))))
  (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 s1 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
 ;;;;;CONVERT, FILTER AND SORT XY
(setq LtsPnt (SortAB (CVLine2Pnt LtsLine)))
 ;;;;GET ID POINT
(setq LtsIDPnt (GetIDPnt LtsPnt))
;;;(mapcar '(lambda(x) (wtxt (rtos (car x) 2 0) (cadr x) 15.0 0 "L" 2)) LtsIDPnt)
 ;;;;DANH SO HIEU VA LOC CANH TRUNG
(setq LtsIDLine (SortAB (GetIDLine LtsLine LtsIDPnt)))
;;; ;;;  ;;;;;LAP QUAN HE GIUA CAC DIEM DUA VAO GOC PHUONG VI
(setq LtsPV_ID (RelationPntIDbyGPV LtsIDPnt LtsIDLine ))
 ;;;;;;  ;;;;;;;;;;;;;;;;TAO VUNG;;;;;;;;;;;;;;;;;;;;;;;;;
(setq LtsArea  (GetAreabyID  LtsPV_ID))
 ;;; ;;;	;;;;;;TINH DIEN TICH VA TOA DO TAM VUNG
(setq LtsGetArea (mapcar '(lambda(x) (GetArea_TamVung x LtsIDPnt)) LtsArea))
(mapcar '(lambda(x) (wtxt (rtos (car x) 2 3) (cadr x) 10 0 "C" 4)) LtsGetArea)
(setq s2 ((lambda (sec) (+ (* 86400 (- sec (fix sec))) 60)) (getvar "DATE")))
(prompt (strcat   "Thoi gian thuc hien chuong trinh la: " (rtos (- s2 s1) 2 3) " giay"))
(princ)
)
  ;;;(RemovePnt (list '(1 3) '(2 3) '(3 5) '(4 8) '(5 6) '(6 34)  '(7 334) '(8 76))  (list '(1 2) '(1 5) '(2 3) '(3 2) '(3 5) '(3 7)))
(defun RemovePnt ( l1 l2  /  I ID ID1 L1A  )
(setq l1a l1)
(foreach v l2
	(setq i 0)
  	(setq ID1 (car v))
	(while (< i  (length l1))
	       (setq ID (car (nth i l1)))
	       (if  (equal ID ID1)
		    (setq l1 (vl-remove (nth i l1) l1))
	       )
	(setq i (1+ i))
	)
)
(setq LtsFilterIDPnt (LM:ListDifference l1a l1))
LtsFilterIDPnt
)


;;;;CONVERT LINE TO POINT AND FILTER 
(defun CVLine2Pnt (LtsLine / L1 P1 P2 )
(setq l1 (list))
(foreach e LtsLine
  	(setq P1 (cdr (assoc 10 (entget e))))
  	(setq P2 (cdr (assoc 11 (entget e))))
  	(setq l1 (append l1 (list P1) (list P2)))
)
(setq LtsPnt1 (TD:FilterDeldup l1 0.000001 ))
LtsPnt1
)
;;;;;;;;;;;LOC DIEM TRUNG;;;;;;;;;;;;;;
(defun TD:FilterDeldup (l fz )
  (if l
    (cons (car l)
	  (TD:FilterDeldup  (vl-remove-if '(lambda (x) (equal x (car l) fz )) (cdr l)) fz)
    )
  )
)


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

(defun SortXT (lstPnt /)
  (setq  Lts-Sort (vl-sort lstPnt  '(lambda (e1 e2)(< (car e1) (car e2)))))
  Lts-Sort
)

(defun SortYT (lstPnt /)
  (setq  Lts-Sort (vl-sort lstPnt  '(lambda (e1 e2)(< (cadr e1) (cadr e2)))))
  Lts-Sort
)

;;;;DANH SO HIEU CHO POINT
(defun GetIDPnt (ss_list / I ID_PNT  )
  (setq i 0)
  (setq LtsIDpnt (list))
  (while (< i (length ss_list))
    (progn
      (setq ID_Pnt (list))
      (setq ID_Pnt (list (+ i 1) (nth i ss_list)))
      (setq LtsIDpnt (append LtsIDpnt (list ID_Pnt)))
    )
    (setq i (1+ i))
  )
  LtsIDpnt
)



;;;;;;;GAN SO HIEU CHO LINE, LOC CANH TRUNG VA SAP XEP
(defun GetIDLine (LtsLine LtsIDPoint / ID1 ID2 L1 L2 L3 P1 P2 X )
(setq l2 (list))
(setq l3 (list))
(foreach e LtsLine
  	(setq l1 (list))
	(setq P1 (cdr (assoc 10 (entget e))))
	(setq P2 (cdr (assoc 11 (entget e))))
  	(setq ID1 (last (vl-remove nil (mapcar '(lambda(x) (if (equal P1 (cadr x) 0.01) (car x) nil)) LtsIDPoint))))
  	(setq ID2 (last (vl-remove nil (mapcar '(lambda(x) (if (equal P2 (cadr x) 0.01) (car x) nil)) LtsIDPoint))))
  	(setq l1 (list ID1 ID2))
  	(setq l2 (list ID2 ID1))
	(setq l3 (append l3 (list l1) (list l2)))
)
(setq LtsIDLine (Remove_SHLineOne (TD:FilterDeldup l3 0.0000001)))
LtsIDLine
)

 ;;;;XOA DANH SACH LINE THEO SO HIEU ID1 VA ID2 ;;;;;;
 ;;;(Remove_LineID 2 3 (setq l (list '(1 2) '(1 5) '(2 3) '(3 2) '(3 5))))
(defun Remove_LineID (ID1 ID2 l1 / )
(vl-remove nil (mapcar '(lambda(x)(if (or (and (equal ID1 (car x)) (equal ID2 (cadr x)))
					  (and (equal ID1 (cadr x)) (equal ID2 (car x)))
				       )
				       nil x)) l1)
)
)


 ;;;;;;;XOA DANH SACH LINE THEO SO HIEU ID DAU TIEN ;;;;;;VD:
 ;;;;;(Remove_SHLineOne  (list '(1 2) '(1 5) '(2 3) '(3 2) '(3 5) '(3 7)))
(defun Remove_SHLineOne (l / ID1 ID2 IDLINE L1 V X)
(foreach v l
	(setq l1 (vl-remove nil (mapcar '(lambda(x) (if (= (car x) (car v)) x nil)) l)))
	(if (= (length l1) 1)
	    (progn
		(setq IDLine (last l1))
	      	(setq ID1 (car IDLine))
	        (setq ID2 (cadr IDLine))
		(setq l (Remove_LineID ID1 ID2 l))
	    )
	)
)
l
)

;;;;;;;;;;;;;;;;;;DOI RADIAN SANG DO;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Rad2Deg (radian / Do)
  (setq Do (/ (* radian 180.0) pi))
)

;;;;;;;;;;;;;;;;;;;;;;RADIAN SANG DO PHUT GIAY ;;;;;;;;;;;;;;;;;;
(defun R2DPG (gocR / DO GIAY PHUT PHUT1 TOANDO)
  (setq DPG (list))
  (setq Toando (Rad2Deg gocR))
  (setq Do (fix Toando))
  (setq Phut1 (* (- Toando Do) 60.0))
  (setq Phut (fix Phut1))
  (setq Giay (atof (rtos (* (- phut1 phut) 60.0) 2 3)))
  (setq DPG (list Do Phut giay))
  DPG
)
(defun D2DPG (Toando / DO GIAY PHUT PHUT1 )
  (setq DPG (list))
  (setq Do (fix Toando))
  (setq Phut1 (* (- Toando Do) 60.0))
  (setq Phut (fix Phut1))
  (setq Giay (atof (rtos (* (- phut1 phut) 60.0) 2 3)))
  (setq DPG (list Do Phut giay))
  DPG
)

;;;;;;;LAP MOI QUAN HE GIUA CAC DIEM THEO GOC PHUONG VI
;;(setq LtsPV_ID (RelationPntIDbyGPV LtsIDPnt LtsIDLine ))
(defun RelationPntIDbyGPV (LtsIDPnt LtsIDLine  / ID ID1 ID2 L1 L2 L2A L2B LTSIDLINE2 LTSIDPOINT1 P1 P2 PV12 X )
(setq LtsIDPoint1 (RemovePnt LtsIDPnt LtsIDLine))
(setq LtsRePnt (list))
(foreach e1 LtsIDPoint1
  	(setq l2a (list))
	(setq ID (car e1))
  	(setq LtsIDLine2 (vl-remove nil (mapcar '(lambda(x) (if (= (car x) ID) x nil)) LtsIDLine)))
  	(foreach  e2 LtsIDLine2
	  (setq l1 (list))
  	  (setq ID1 (car e2))
	  (setq  P1 (GetPntbyID ID1 LtsIDPoint1 ))
	  (setq ID2 (cadr e2))
	  (setq  P2 (GetPntbyID ID2 LtsIDPoint1 ))
	  (setq PV12 (TinhPV P1 P2))
	  (setq l1 (list PV12 ID1 ID2))
	  (setq l2a (append l2a (list l1)))
	  (setq l2b (vl-sort l2a '(lambda (x1 x2) (< (car x1) (car x2)))))
         )
  	  (setq l2 (append (list ID) (mapcar '(lambda(x) (caddr x)) l2b)))
  	  (setq LtsRePnt (append LtsRePnt (list l2)))
)
  LtsRePnt
)

  ;;;;GET POINT BY ID;;;;;;;
(defun GetPntbyID (ID LtsIDPoint2 /  )
(setq PntbyID (last (vl-remove nil (mapcar '(lambda(x) (if (equal ID (car x)) (cadr x) nil)) LtsIDPoint2))))
  PntbyID
)


(defun TinhPV (P1 P2 /  )
  (setq GocPV (rem (- 450.0 (* (angle p1 p2) (/ 1 pi) 180.0)) 360.0))
  GocPV
)


(defun GhepList ( l / l1 ID1 ID2)
(setq l1 (list))
(setq l2 (list))
(setq ID1 (car l))
(setq i 0)
(while (< i (- (length l) 1))
       (setq ID2 (nth (+ i 1) l))
       (setq l1 (list ID1 ID2))
       (setq l2 (append l2 (list l1)))
(setq i (1+ i))
)
l2
)


(defun GetAreabyID ( LtsRePnt_  /  1-VT FLAG ID ID+1 ID+N L1 L2 L3 L6 PTDT V1 VT)
(setq l3 (list))
(setq l4 (list))
(foreach v2  LtsRePnt_
	(setq v1 (GhepList v2))
  	(setq l1 (list))
  	(setq l2 (list))
	(foreach v v1
		(if (and (not (member v l6)) (< (car v) (cadr v)))
			(progn
			  	(setq ID (car v)
				      PTDT (car v)
				    ID+1 (cadr v)
				    Flag T
				    l1 (list ID ID+1)
				)
				(while Flag
				        (setq ID+n (assoc ID+1 LtsRePnt_)   
						vt (vl-position ID ID+n)
					      1-vt (nth (1- vt) ID+n)
				        )
				  	(if (/= ID+1 PTDT)
				        	(if  (/= 1-vt ID+1)
					            (setq l1 (append l1 (list (nth (1- vt) ID+n)))
							 ID ID+1
							 ID+1 (nth (1- vt) ID+n)
							  l6 (append l6  (list (list ID ID+1)))
					            )
						    (if (= 1-vt ID+1)
							(setq l1 (append l1 (list (nth (- (length ID+n) 1) ID+n)))
							      ID ID+1
							      ID+1 (nth (- (length ID+n) 1) ID+n)
							       l6 (append l6  (list (list ID ID+1)))
						        )
						    )
						 )
					     (setq Flag nil)
					  )
				  	  
				)
			  	
	  			(setq l2 (append l2 (list l1)))
	  		)
		  )
	)
  	(setq l3 (append l3 l2))
)
(setq l4 (cdr (SortLength (TD:LoaiVung1 l3))))
l4
)




(defun TD:LoaiVungtrung (l fz)
  (if l
    (cons (car l)
	  (TD:LoaiVungtrung  (vl-remove-if '(lambda (x) (equal (Sort1PT x) (Sort1PT (car l)) fz ) ) (cdr l)) fz)
    )
  )
)

(defun FilterArea ( LtsVung  /  I ID1 ID1A  )
(setq DsArea (TD:LoaiVungtrung LtsVung 0.0001))
(foreach v DsArea
	(setq i 0)
	(while (< i (- (length v) 2))
	       (setq ID1 (nth i v))
	       (setq ID1a (nth (+ i 2) v))
	       (if (equal ID1 ID1a)
		   (setq DsArea (vl-remove v DsArea))
	       )
	(setq i (1+ i))
	)
)
DsArea
)

(defun PV_LineEnd ( Vung LtsIDPnt /   Id_c Id_gc P1 P2 )
(setq Id_c (nth (- (length Vung) 1) Vung))
(setq Id_gc (nth (- (length Vung) 2) Vung))
(setq  P1 (GetPntbyID Id_c LtsIDPnt ))
(setq  P2 (GetPntbyID Id_gc LtsIDPnt ))
(setq PVLineEnd (TinhPV P2 P1))
PVLineEnd
)



;;;(Tachlist (list 4 7 11 12 15 16 13 14 10 8 6 5 3 2 1 4))
;;;====>>>> ((4 7) (7 11) (11 12) (12 15) (15 16) (16 13) (13 14) (14 10) (10 8) (8 6) (6 5) (5 3) (3 2) (2 1) (1 4))

(defun Tachlist ( l / l1 ID1 ID2)
(setq l1 (list))
(setq l2 (list))
(setq i 0)
(while (< i (- (length l) 1))
       (setq ID1 (nth i l))
       (setq ID2 (nth (+ i 1) l))
       (setq l1 (list ID1 ID2))
       (setq l2 (append l2 (list l1)))
(setq i (1+ i))
)
l2
)



(defun Sort1PT (lstPnt /)
  (setq  Lts-Sort1 (vl-sort lstPnt '(lambda (e1 e2) (< e1  e2))))
  Lts-Sort1
)
(defun SortLength (lstPnt /)
  (setq  Lts-Sort1 (vl-sort lstPnt '(lambda (e1 e2) (> (length e1)  (length e2)))))
  Lts-Sort1
)

;;;;;;(LM:ListDifference '(1 2 3 4 5) '(2 4 6 7 8 8 9 888 999 999 9 7 5)  )
(defun LM:ListDifference ( l1 l2 )
  (if l1
    (if (member (car l1) l2)
      (LM:ListDifference (cdr l1) l2)
      (cons (car l1) (LM:ListDifference (cdr l1) l2))
    )
  )
)

;;HAM LAY RA CAC PHAN TU GIONG NHAU TU 2 DANH SACH  
;;;;(TD:ListSemilar '(2 4 6 45 67 76) '(1 2 ) )
(defun TD:ListSemilar ( l1 l2 )
  (if l1
    (if (not (member (car l1) l2))
        (TD:ListSemilar (cdr l1) l2)
        (cons (car l1) (TD:ListSemilar (cdr l1) l2))
    )
  )
)

(defun TD:LoaiVung1 (l / )
  (if l
    (cons (car l)
	  (TD:LoaiVung1  (vl-remove-if '(lambda (x) (TD:ListSemilar (Tachlist x) (Tachlist (car l)) ) ) (cdr l)))
    )
  )
)


(defun GetAreabyLtsID ( LtsID LtsIDPnt / DT1 DT2 I L1 L2 LTSIDPNT LTSPNT P1 P2 PTT X)
(setq l1 (mapcar '(lambda(x) (GetPntbyID x LtsIDPnt)) LtsID))
(setq LtsPnt (append l1 (list (car l1))))
(setq i 0)
(setq DT2 (list))
(setq Dtich 0)
(while (< i (- (length LtsPnt) 1))
  	(setq DT1 (list))
  	(setq P1 (nth i LtsPnt))
  	(setq P2 (nth (+ i 1) LtsPnt))
        (setq DT1 (list (/ (* (+ (cadr P1) (cadr P2)) (- (car P2) (car P1))) 2)))
  	(setq DT2 (append DT2  DT1))
        (setq i (1+ i))
)
(setq Dtich (abs (apply '+ DT2)))
Dtich
)

(defun GetArea_TamVung ( LtsID LtsIDPnt / DT1 I L1 LTSIDPNT LTSXTB LTSYTB P1 P2 X XTB YTB )
(setq Dtich (GetAreabyLtsID  LtsID LtsIDPnt ))
(setq l1 (mapcar '(lambda(x) (GetPntbyID x LtsIDPnt)) LtsID))
(setq Xmin (caar (SortXT l1)))
(setq Xmax (car (last (SortXT l1))))
(setq Ymin (cadar (SortYT l1)))
(setq Ymax (cadr (last (SortYT l1))))
(setq Xtb (/ (+ Xmin Xmax) 2))
(setq Ytb (/ (+ Ymin Ymax) 2))
(setq DT_TV (list Dtich (list Xtb  Ytb  )))
DT_TV
)



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

File Test

http://www.cadviet.com/upfiles/4/36665_test.dwg

Tháng 2 25, 2015

Hề hề hề,

Đây là vấn đề ngoại ngạch của mình. song rất ư là phấn khởi chúc mừng bác ThanhDuan đã thành công bước đầu. nếu có thể mong bác chia sẻ cái lisp này để mình mót thêm về thuật toán được sử dụng. Cứ theo ngu ý của mình thì bài toán này không đơn giản và việc giải quyết rốt ráo nó cũng là một nhu cầu của nhiều người....

Nhờ bác Bình và các anh chị em cùng trao đổi để nâng cấp tăng tốc cho nó với em nhé!

Tháng 2 25, 2015

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

Tháng 2 25, 2015

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

Tháng 2 25, 2015

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

Tháng 2 25, 2015

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

Tháng 2 25, 2015

@thanhduan2407 tham khao bài này http://www.cadviet.com/forum/topic/93584-nho-viet-lisp-hatch-vung-kin-cua-cac-doi-tuong-giao-nhau/page-2

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

Tháng 2 25, 2015

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

Đăng nhập

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

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

thanhduan2407 272

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

Nguyen Hoanh 4.663

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 272

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

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 272

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 272

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

Nguyen Hoanh 4.663

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

trinhhoanghieu090 29

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 272

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

nhoclangbat 392

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 272

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

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 272

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 241

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

nhoclangbat 392

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

minhtu2004 36

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

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 272

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 272

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

ThuyLinh313 156