Đến nội dung


Hình ảnh
- - - - -

Bạn nào có ý tưởng nào hay về thuật toán để giải quyết vấn đề này không ?


  • Please log in to reply
48 replies to this topic

#21 Skywings

Skywings

    biết lệnh erase

  • Members
  • PipPipPip
  • 102 Bài viết
Điểm đánh giá: 46 (tàm tạm)

Đã gửi 21 April 2013 - 11:39 PM

1) Cảm ơn bác Hà vote :).

2) Cái này ko ý kiến, có thể CAD của bác bị lỗi gì đó.

3) Mình chưa test nhiều trường hợp, nhưng theo yêu cầu đầu bài thì Hội tụ thì ko phải là ko thể. Bác có thể up bản vẽ trường hợp Bác cho là ko hộ tụ để mình ngâm cứu.


  • 1

#22 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 23 April 2013 - 12:29 AM

 

Lâu lắm mới thấy có đề bài hay, bạn vẽ thêm trường hợp tổng quát hơn ấy, như bạn nói có thể có 2*n vùng thì phải mà, lúc đó cách tính như thế nào?

 

Untitled5555.png

Đây là một trường hợp phức tạp hơn. Đó là cùng 1 đường điều phối sẽ cắt đường tích lũy tại nhiều đoạn. Như hình trên là 3 đoạn, khi đó ta phải xá định để đảm bảo W1= W2 và Các đoạn Mi, Ni luôn < L cố định nào đó .


  • 0

#23 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 23 April 2013 - 12:53 AM

Một bài toán hay, lâu rùi mới có hứng thú lại với Lisp ^^. Đây là giải pháp của mình dựa trên thuật toán của các bác đưa ra, nếu viết có luộm thuộm các bác thông cảm :D . Chưa có thời gian test kỹ, các bác dùng thử nhé ^_^ .

* Lưu ý kích thước MN quá nhỏ so với PQ có thể gây ra lỗi xác định diện tích, nếu PQ có nhiều điểm cực tiểu, chương trình chỉ tính toán cho điểm điểm cực tiểu thấp nhất.

(vl-load-com)
(defun c:t1 (/	       AREALST	 ENDPNT	   ENDPNTMN  FROMPNT
	     FUZZ      I0	 I1	   I2	     I3
	     INTPNTS   IX	 IY	   LWP0	     LWP1
	     LWPENT    LWPOBJ	 MN	   MNDIST    MSPACE
	     PNT0      PNT1	 PQ	   S0	     S1
	     S2	       S3	 STARTPNT  STARTPNTMN
	     STARTPNTPQ		 SUB01	   SUB01NEW  SUB32
	     SUB32NEW  THISDRAWING	   TMPLWP    TOPNTX
	     TOPNTY    MAXPOINT	 MINPOINT  ISFLIPED  TMPLWPOBJ
	     BOTPNT    MINMAXPNTS	   TOPPNT
	    )
  ;; Thiet lap
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (setq mspace (vla-get-modelspace thisdrawing))
  (vla-startundomark thisdrawing)
  (setvar "CMDECHO" 0)
  (if (null MNdistSv)
    (setq MNdistSv 5)
  )
  ;; Du lieu dau vao
  (initget (+ 2 4))
  (setq	MNdist (getreal	(strcat	"\nXac dinh chieu dai MN: <"
				(rtos MNdistSv 2 2)
				">"
			)
	       )
  )
  (if (null MNdist)
    (setq MNdist MNdistSv)
    (setq MNdistSv MNdist)
  )
  (while (null
	   (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
	 )
    (setq lwpEnt (car (entsel "\nChon duong cong tich luy: ")))
  )
  (setq lwpObj (vlax-ename->vla-object lwpEnt))
  (setq	startPnt (vlax-curve-getStartPoint lwpObj)
	endPnt	 (vlax-curve-getEndPoint lwpObj)
  )
  ;; Kiem tra diem cuc tieu
  (setq MinMaxPnts (LM:CurveMinMax lwpObj 1e-8))
  (setq	TopPnt (cadr MinMaxPnts)
	BotPnt (car MinMaxPnts)
  )
  (if (or (equal (distance BotPnt startPnt) 0.0 1e-8)
	  (equal (distance BotPnt endPnt) 0.0 1e-8)
      )
    (progn
      (setq tmpLwpObj (vla-mirror
			lwpObj
			(vlax-3d-point startPnt)
			(vlax-3d-point (polar startPnt 0 0.1))
		      )
		      ;; lat bung
      )
      (vla-delete lwpObj)
      (setq lwpObj   tmpLwpObj
	    isFliped 1
      )
      (setq startPnt (vlax-curve-getStartPoint lwpObj)
	    endPnt   (vlax-curve-getEndPoint lwpObj)
      )
    )
  )
  (vla-GetBoundingBox lwpObj 'minpoint 'maxpoint)
  (vla-ZoomWindow (vlax-get-acad-object) minpoint maxpoint)
  ;; Xac dinh duong PQ
  (if (< (cadr startPnt) (cadr endPnt))
    (setq startPntPQ startPnt)
    (setq startPntPQ endPnt)
  )
  (setq	tmpLwp (AddLwpolyline
		 (list startPntPQ (polar startPntPQ 0 1))
		 0
		 mspace
	       )
  )
  (setq intPnts (LM:Intersections tmpLwp lwpObj acExtendThisEntity))
  (if (> (length intPnts) 1)
    (setq PQ (AddLwpolyline intPnts 0 mspace))
    (progn
      (vla-delete tmpLwp)
      (reset)
      (exit)
    )
  )
  (vla-delete tmpLwp)
  ;; Chieu dai doan MN
  (if (= isFliped 1)
    (setq BotPnt (car (LM:CurveMinMax lwpObj 1e-8)))
  )
  (setq	startPntMN (polar BotPnt pi (/ MNdist 2))
	endPntMN   (polar BotPnt 0 (/ MNdist 2))
  )
  (setq MN (AddLwpolyline (list startPntMN endPntMN) 0 mspace))
  ;; Xac dinh 2 duong giong tu MN den PQ
  (setq	pnt0 (vlax-curve-getClosestPointTo PQ startPntMN)
	pnt1 (vlax-curve-getClosestPointTo PQ endPntMN)
  )
  (setq	lwp0 (AddLwpolyline (list startPntMN pnt0) 0 mspace)
	lwp1 (AddLwpolyline (list endPntMN pnt1) 0 mspace)
  )
  ;; Kiem tra dien tich
  (setq AreaLst (CalArea pnt0 startPntMN endPntMN pnt1))
  (setq	s0 (nth 0 AreaLst)
	s1 (nth 1 AreaLst)
	s2 (nth 2 AreaLst)
	s3 (nth 3 AreaLst)
  )
  (if (and (< s0 s1)
	   (< s3 s2)
      )
    (progn
      (alert "Khong the dieu chinh!")
      (reset)
      (exit)
    )
  )
  ;; Can bang so bo 1 cap dien tich
  (textscr)
  (setq iY (- 0 (/ (distance startPntMN pnt0) 20)))
					; buoc nhay phuong doc
  (setq fuzz 0.01)			; do chinh xac dien tich
  (setq	FromPnt	(vlax-3d-point pnt0)
	ToPntY	(vlax-3d-point (polar pnt0 (/ pi 2) iY))
  )
  (while (and (>= (nth 0 AreaLst) (nth 1 AreaLst))
	      (>= (nth 3 AreaLst) (nth 2 AreaLst))
	 )
    (vla-move PQ FromPnt ToPntY)
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
	  pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
  )
  (if (> (- (nth 0 AreaLst) (nth 1 AreaLst))
	 (- (nth 3 AreaLst) (nth 2 AreaLst))
      )
    (setq i0 3
	  i1 2
	  i2 1
	  i3 0
    )
    (setq i0 0
	  i1 1
	  i2 2
	  i3 3
    )
  )
  (setq sub32 (- (nth i3 AreaLst) (nth i2 AreaLst)))
  ;; Can bang dien tich dua tren dich chuyen PQ
  (while (not (equal (- (nth i3 AreaLst) (nth i2 AreaLst)) 0.0 fuzz))
    (vla-move PQ
	      (vlax-3d-point pnt0)
	      (vlax-3d-point (polar pnt0 (/ pi 2) iY))
    )
    (setq pnt0 (polar pnt0 (/ pi 2) iY)
	  pnt1 (polar pnt1 (/ pi 2) iY)
    )
    (setq iX 0.1)			; buoc nhay phuong ngang
    (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
    (setq sub01 (- (nth i0 AreaLst) (nth i1 AreaLst)))
    (setq FromPnt (vlax-3d-point pnt0)
	  ToPntX  (vlax-3d-point (polar pnt0 0 iX))
    )
    ;; Can bang dien tich dua tren dich chuyen MN
    (while (not (equal (- (nth i0 AreaLst) (nth i1 AreaLst)) 0.0 fuzz))
      (vla-move MN FromPnt ToPntX)
      (vla-move lwp0 FromPnt ToPntX)
      (vla-move lwp1 FromPnt ToPntX)
      (setq pnt0       (polar pnt0 0 iX)
	    pnt1       (polar pnt1 0 iX)
	    startPntMN (polar startPntMN 0 iX)
	    endPntMN   (polar endPntMN 0 iX)
      )
      (setq AreaLst (reverse (CalArea pnt0 startPntMN endPntMN pnt1)))
      (setq sub01new (- (nth i0 AreaLst) (nth i1 AreaLst)))
      (if (> (abs sub01new) (abs sub01))
	(setq iX (/ (- 0 iX) 2))
      )
      (setq sub01 sub01new)
      (setq FromPnt (vlax-3d-point pnt0)
	    ToPntX  (vlax-3d-point (polar pnt0 0 iX))
      )
    )
    (setq sub32new (- (nth i3 AreaLst) (nth i2 AreaLst)))
    (if	(> (abs sub32new) (abs sub32))
      (setq iY (/ (- 0 iY) 2))
    )
    (setq sub32 sub32new)
    (print AreaLst)
  )
  (vla-zoomprevious (vlax-get-acad-object))
  (reset)
  (princ)
)
(defun reset ()
  (if (= isFliped 1)
    (progn
      (foreach obj (list lwpObj MN PQ lwp0 lwp1)
	(vla-mirror
	  obj
	  (vlax-3d-point startPnt)
	  (vlax-3d-point (polar startPnt 0 0.1))
	)
	(vla-delete obj)
      )
    )
  )
  (vla-endundomark thisdrawing)
  (graphscr)
)
(defun CalArea (p0 p1 p2 p3 / AreaLst tmpLwp)
  (setq	p0 (polar p0 (* pi 1.25) 0.1)
	p1 (polar p1 (* pi 0.25) 0.1)
	p2 (polar p2 (* pi 0.75) 0.1)
	p3 (polar p3 (* pi 1.75) 0.1)
  )
  (foreach pt (list p0 p1 p2 p3)
    (command ".boundary" pt "")
    (setq tmpLwp (vlax-ename->vla-object (entlast)))
    (setq AreaLst (cons (vlax-get-property tmpLwp 'AREA) AreaLst))
    (vla-delete tmpLwp)
  )
  AreaLst
)
(defun LM:Intersections	(obj1 obj2 mode / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
  (repeat (/ (length l) 3)
    (setq r (cons (list (car l) (cadr l) (caddr l)) r)
	  l (cdddr l)
    )
  )
  (reverse r)
)

(defun AddLwpolyline (lst-pnt layer *model-space* / array-pt myPline)
  (setq	array-pt (list->variantArray
		   (apply 'append (mapcar '3dPnt->2dPnt lst-pnt))
		 )
	myPline	 (vla-AddLightWeightPolyline *model-space* array-pt)
  )
  (vla-put-layer myPline layer)
  myPline
)

(defun list->variantArray (ptsList / arraySpace sArray)
  (setq	arraySpace
	 (vlax-make-safearray
	   vlax-vbdouble
	   (cons 0
		 (- (length ptsList) 1)
	   )
	 )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
  (vlax-make-variant sArray)
)

(defun 3dPnt->2dPnt (3dpt)
  (list (float (car 3dpt)) (float (cadr 3dpt)))
)

(defun LM:CurveMinMax
		      (obj	     fuzz	   /
		       _GetBoundingBoxWithOffset   _GroupByNum
		       _FlattenPoint a		   acdoc
		       acspc	     lst	   obj
		       tmp
		      )

  (defun _GetBoundingBoxWithOffset (obj o / ll ur)
    (
     (lambda (a)
       (mapcar
	 (function
	   (lambda (b)
	     (mapcar
	       (function
		 (lambda © ((eval c) a))
	       )
	       b
	     )
	   )
	 )
	 '(
	   (
	    (lambda (x) (- (caar x) o))
	    (lambda (x) (- (cadar x) o))
	   )
	   (
	    (lambda (x) (+ (caadr x) o))
	    (lambda (x) (- (cadar x) o))
	   )
	   (
	    (lambda (x) (+ (caadr x) o))
	    (lambda (x) (+ (cadadr x) o))
	   )
	   (
	    (lambda (x) (- (caar x) o))
	    (lambda (x) (+ (cadadr x) o))
	   )
	  )
       )
     )
      (mapcar 'vlax-safearray->list
	      (progn (vla-getboundingbox obj 'll 'ur) (list ll ur))
      )
    )
  )

  (defun _GroupByNum (l n / r)
    (if	l
      (cons
	(reverse (repeat n
		   (setq r (cons (car l) r)
			 l (cdr l)
		   )
		   r
		 )
	)
	(_GroupByNum l n)
      )
    )
  )

  (defun _FlattenPoint (p)
    (list (car p) (cadr p) 0.0)
  )

  (setq	acdoc (vla-get-activedocument (vlax-get-acad-object))
	acspc (vlax-get-property
		acdoc
		(if (= 1 (getvar 'CVPORT))
		  'Paperspace
		  'Modelspace
		)
	      )
  )
  (cond
    ((not (vlax-method-applicable-p obj 'GetBoundingBox))
    )
    (t
     (setq tmp
	    (mapcar
	      (function
		(lambda	(x)
		  (apply 'vla-addline (cons acspc (mapcar 'vlax-3D-point x)))
		)
	      )
	      (_GroupByNum
		(mapcar	'_FlattenPoint
			(_GetBoundingBoxWithOffset obj (- fuzz))
		)
		2
	      )
	    )
     )
     (setq lst
	    (mapcar
	      (function
		(lambda	(x)
		  (car
		    (_GroupByNum
		      (vlax-invoke obj 'Intersectwith x acExtendOtherEntity)
		      3
		    )
		  )
		)
	      )
	      tmp
	    )
     )
     (mapcar 'vla-delete tmp)
     lst
    )
  )
)

File bản vẽ test

http://www.cadviet.c.../86115_test.dwg

 

Cảm ơn bạn. Chạy được rùi. Nhưng bạn có thể giúp mình sửa nó để có thể áp dụng vào bài sau được không .

123.png

Yêu cầu: Đó là, cái đường điều phối ta vẽ trước đó, từ đó ta xác định nó cắt tại bao nhiêu điểm, như hình trên thì ta có 5 khối .Sau đó vẫn như yêu cầu trên là tìm vị trí đường điều phối mà cả 5 khối đó đều thỏa mãn các điều kiện như trước (đoạn MN của các khối không bằng nhau nhưng phải <= L cố định ). Sau khi tính xong thì ta phải được một hình hoàn chỉnh như khối 1 ( Có hatch, ghi kích thước ) .


  • 0

#24 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 23 April 2013 - 07:05 AM

1) Cảm ơn bác Hà vote :).

2) Cái này ko ý kiến, có thể CAD của bác bị lỗi gì đó.

3) Mình chưa test nhiều trường hợp, nhưng theo yêu cầu đầu bài thì Hội tụ thì ko phải là ko thể. Bác có thể up bản vẽ trường hợp Bác cho là ko hộ tụ để mình ngâm cứu.

Bạn thử test bản vẽ này xem.

http://www.cadviet.c...dien_tich_1.dwg

Tôi test nó toàn báo lỗi thế này:

Command: T1

Xac dinh chieu dai MN: <900>300

Chon duong cong tich luy:

Command:

Point is directly on an object.

Point is directly on an object.

Point is directly on an object.

Point is directly on an object.; error: Automation Error. Object was erased

 

Còn đây là lisp tôi đã viết: lisp cân bằng diện tích của đường cong tích lũy.

Tuy nhiên cần khẳng định rằng: tùy thuộc dữ liệu đầu vào mà bài toán này có thể hội tụ hoặc không.

 

; Doan Van Ha - CADViet.com - Ngay 22/4/2013
; Chuc nang: C©n b»ng diÖn tich cña ®­êng cong tich luy.
(defun C:HA( / dung len giaso sscp CU lst G P Q M M1 N N1 MP Px GM GN S1 S2 S3 S4 ss12 ss34)
 (setq len (getdist "\nNhap khoang cach MN: "))
 (setq sscp (getreal "\nSai so toi da <0.05>: "))
 (if (not sscp) (setq sscp 0.05)) ;MÆc ®inh 0.05 (tøc 5%). Sai sè cµng nhá th× ch¹y cµng chËm, vµ nhieu khi kh«ng tinh to¸n ®­îc.
 (setq giaso (* len sscp 0.2))
 (setq CU (car (entsel "\nChon duong cong tich luy dang Pline: ")))
 (setq lstCU (vl-sort (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget CU))) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq MP (polar (setq G (Pymin lstCU)) pi len)) ; lÊy MP & G
 (setq P (vlax-curve-getStartpoint CU) Q (vlax-curve-getEndpoint CU)) (if (< (cadr Q) (cadr P)) (setq P Q)) ; lÊy ®iÓm thÊp nhÊt
 (if (< (car P) (car Q)) (setq lst (Giao lstCU P (polar P 0 1E8))) (setq lst (Giao lstCU Q (polar Q 0 1E8)))) ; lÊy list point giao víi Curve
 (setq P (car lst) Q (last lst)) (if (< (car Q) (car P)) (setq Px P P Q Q Px)) ; lÊy ®iÓm bªn tr¸i
 (if (> (car MP) (car P)) (setq P (car (Giao lstCU MP (polar MP (/ pi 2) 1E8)))))
 (while (and (not dung) (> (cadr P) (+ giaso (cadr G))))
  (setq lst (Giao lstCU (setq P (polar P (/ pi -2) giaso)) (polar P 0 1E8)))
  (setq P (car lst) Q (last lst)) (if (< (car Q) (car P)) (setq Px P P Q Q Px)) ; lÊy P vµ Q
  (setq M (list (+ giaso (car P)) (cadr G)) N (polar M 0 len))
  (while (and (not dung) (< (+ giaso (car M)) (car G)) (< (+ giaso (car N)) (car Q)))
   (setq M (polar M 0 giaso) M1 (list (car M) (cadr P)) N (polar M 0 len) N1 (list (car N) (cadr M1))) ; lÊy M, M1, N, N1
   (setq GM (car (Giao lstCU M M1)) GN (car (Giao lstCU N N1))) ; lÊy GM, GN
   (setq S1 (PointArea (cons M1 (LST_P lstCU P GM))))
   (setq S2 (PointArea (cons M (LST_P lstCU GM G))))
   (setq S3 (PointArea (cons N (LST_P lstCU G GN))))
   (setq S4 (PointArea (cons N1 (LST_P lstCU GN Q))))
   (setq ss12 (abs (/ (- S1 S2) (* 0.5 (+ S1 S2)))))
   (setq ss34 (abs (/ (- S3 S4) (* 0.5 (+ S3 S4)))))
   (if (<= (max ss12 ss34) sscp) (progn (LWPoly (list P M1 M N N1 Q)) (setq dung T)))))
 (if (not dung) (alert "Hoac sai so qua nho; \nHoac khoang cach MN qua lon, khong hoi tu nen khong giai duoc.")))
(defun Giao(lst p1 p2 / z pg lst1)
 (setq z -1)
 (repeat (1- (length lst))
  (if (setq pg (inters p1 p2 (nth (setq z (1+ z)) lst) (nth (1+ z) lst))) (setq lst1 (cons pg lst1))))
 lst1)
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a B) (- (* (car a) (cadr B)) (* (car B) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))
(defun LST_P(lst p1 p2 / pt lst lst1)
 (setq lst1 (vl-remove-if '(lambda (pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) (cons p1 (reverse (cons p2 (reverse lst)))))))
(defun Pymin(lst)
 (setq pt (car lst)) (foreach px (cdr lst) (if (< (cadr px) (cadr pt)) (setq pt px))) pt)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))

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


#25 Skywings

Skywings

    biết lệnh erase

  • Members
  • PipPipPip
  • 102 Bài viết
Điểm đánh giá: 46 (tàm tạm)

Đã gửi 23 April 2013 - 06:12 PM

Cập nhật bản sửa lỗi ở bài viết #18

- Cho phép xác định độ chính xác diện tích.

- Giới hạn 100 lần thử để bảo vệ con CPU ko bị bốc khói ^^! Trường hợp này xảy ra khi diện tích tính toán quá lớn trong khi sai số cho phép quá nhỏ!!!

- Sửa lỗi khi tính toán diện tích, hạn chế và bẫy lỗi do lệnh "-boundary" gây ra. Thg này tính khí cũng hơi thất thường, có lúc cái miền to đùng mà ko lấy boundary được >.<!!

- Cải thiện tốc độ x2 ^^.

 

@ bác Hà: đã test bản sửa lỗi trên bản vẽ của bác, chạy hơi lâu một chút do kích thước pline của bác hơi bị bự ^^. Mình đã dùng thử file lisp của bác trên bản vẽ bác cung cấp, nhưng lúc được lúc không. Hay báo lỗi "Hoac sai so qua nho; \nHoac khoang cach MN qua lon, khong hoi tu nen khong giai duoc." mặc dù mình chọn kích thước khá lớn là 300, sai số mặc định. Khi chạy được sai số diện tích cũng khá lớn.

 

@ garupro: trường hợp "phức tạp" bác đưa ra dường như là một bài toán hoàn toàn khác so với trg hợp "đơn giản" ban đầu. Mình có chút thắc mắc:

- Đường tích luỹ là pline "gãy" hay "trơn" (có đoạn cong). Nếu là "gãy" thì có thể bàn tiếp, nếu lỡ "trơn" mà các điểm cực trị lọt vào bụng tròn tròn của nó thì pó tay, ko biết sao xác định tất cả các điểm đó. Bác cao thủ nào có ý tưởng về vấn đề này xin góp ý ^^.

- Theo hình bài số 22, nếu W1 và W2 là từng cặp cân bằng riêng biệt, bài toán le lói hy vọng; còn nếu W1 và W2 là 2 con số cố định cho tất cả các cặp MN thì thiệt tình mình cho là không khả thi với đường PQ cố định, PQ mà di động thì cũng thua vì quá phức tạp. Với trường hợp tổng quát 2*n vùng thì không máy nào chịu nổi, nên có giới hạn số vùng tính toán.

- Với L và đường PQ cố định, chấp nhận một đoạn MN ko thể cân bằng diện tích vì MN có thể lớn L.


  • 1

#26 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 23 April 2013 - 06:34 PM

@ bác Hà: đã test bản sửa lỗi trên bản vẽ của bác, chạy hơi lâu một chút do kích thước pline của bác hơi bị bự ^^. Mình đã dùng thử file lisp của bác trên bản vẽ bác cung cấp, nhưng lúc được lúc không. Hay báo lỗi "Hoac sai so qua nho; \nHoac khoang cach MN qua lon, khong hoi tu nen khong giai duoc." mặc dù mình chọn kích thước khá lớn là 300, sai số mặc định. Khi chạy được sai số diện tích cũng khá lớn.

1). Sai số cần hiểu là sai số tương đối (ví dụ 0.05 là 5%), chứ ai lại lấy sai số tuyệt đối?

2). Tôi test với MN=300 và sai số 0.05 thì nó chạy vô tư.

3). Khi có dòng thông báo ấy không có nghĩa là lỗi => thay sai số hoặc/và kích thước MN để chạy lại.

4). Tôi test lisp của bạn trên bản vẽ tôi gởi với MN=500 => lỗi.

Nói chung, gia số tăng giảm mỗi lần và sai số cho phép bạn nên lấy theo con số tương đối chứ đừng lấy tuyệt đối, bởi kích thước MN có thể là 5 mà cũng có thể là 50000000 (tùy theo tỉ lệ khi vẽ).


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


#27 Skywings

Skywings

    biết lệnh erase

  • Members
  • PipPipPip
  • 102 Bài viết
Điểm đánh giá: 46 (tàm tạm)

Đã gửi 23 April 2013 - 09:04 PM

Cám ơn bác Hà, mình đã hiểu ý bác. Khởi động lại AutoCAD thì dùng đc lisp của bác, hay là bị đụng j đó :wacko: ! Mình đã test lại lisp mình với MN=500, thì vẫn ok, có thể lỗi do sự thất thường của lệnh -boundary chăng :mellow: ?


  • 0

#28 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 23 April 2013 - 09:18 PM

Cám ơn bác Hà, mình đã hiểu ý bác. Khởi động lại AutoCAD thì dùng đc lisp của bác, hay là bị đụng j đó :wacko: ! Mình đã test lại lisp mình với MN=500, thì vẫn ok, có thể lỗi do sự thất thường của lệnh -boundary chăng :mellow: ?

Rất có thể là do lệnh Boundary. Khi mà diện tích này quá nhỏ so với màn hình (do bước nhảy) thì lệnh B này có thể gây lỗi. Một số lệnh khác như Hatch cũng vậy.

Có 1 nguyên tắc mà tất cả người lập trình đều phải chấp nhận, là biết chấp nhận mọi tùy thích của người dùng, kể cả khi họ ngớ ngẩn. Nhưng làm được điều này là cực khó, không cứ là bạn hay tôi mà các lập trình viên chuyên nghiệp cũng vậy


  • 0

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


#29 garupro

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 25 April 2013 - 11:35 PM

Cập nhật bản sửa lỗi ở bài viết #18

- Cho phép xác định độ chính xác diện tích.

- Giới hạn 100 lần thử để bảo vệ con CPU ko bị bốc khói ^^! Trường hợp này xảy ra khi diện tích tính toán quá lớn trong khi sai số cho phép quá nhỏ!!!

- Sửa lỗi khi tính toán diện tích, hạn chế và bẫy lỗi do lệnh "-boundary" gây ra. Thg này tính khí cũng hơi thất thường, có lúc cái miền to đùng mà ko lấy boundary được >.<!!

- Cải thiện tốc độ x2 ^^.

 

@ bác Hà: đã test bản sửa lỗi trên bản vẽ của bác, chạy hơi lâu một chút do kích thước pline của bác hơi bị bự ^^. Mình đã dùng thử file lisp của bác trên bản vẽ bác cung cấp, nhưng lúc được lúc không. Hay báo lỗi "Hoac sai so qua nho; \nHoac khoang cach MN qua lon, khong hoi tu nen khong giai duoc." mặc dù mình chọn kích thước khá lớn là 300, sai số mặc định. Khi chạy được sai số diện tích cũng khá lớn.

 

@ garupro: trường hợp "phức tạp" bác đưa ra dường như là một bài toán hoàn toàn khác so với trg hợp "đơn giản" ban đầu. Mình có chút thắc mắc:

- Đường tích luỹ là pline "gãy" hay "trơn" (có đoạn cong). Nếu là "gãy" thì có thể bàn tiếp, nếu lỡ "trơn" mà các điểm cực trị lọt vào bụng tròn tròn của nó thì pó tay, ko biết sao xác định tất cả các điểm đó. Bác cao thủ nào có ý tưởng về vấn đề này xin góp ý ^^.

- Theo hình bài số 22, nếu W1 và W2 là từng cặp cân bằng riêng biệt, bài toán le lói hy vọng; còn nếu W1 và W2 là 2 con số cố định cho tất cả các cặp MN thì thiệt tình mình cho là không khả thi với đường PQ cố định, PQ mà di động thì cũng thua vì quá phức tạp. Với trường hợp tổng quát 2*n vùng thì không máy nào chịu nổi, nên có giới hạn số vùng tính toán.

- Với L và đường PQ cố định, chấp nhận một đoạn MN ko thể cân bằng diện tích vì MN có thể lớn L.

-Đường tích  lũy là gãy bạn ah, không có đoạn cong , W1,W2 là các cặp khác nhau riêng biệt đối với từng cặp MN, Đường PQ không cố định bạn ah, vẫn có thể di chuyển lên xuống nhưng vẫn đảm bảo số điểm giao với đường tích lũy


  • 0

#30 Skywings

Skywings

    biết lệnh erase

  • Members
  • PipPipPip
  • 102 Bài viết
Điểm đánh giá: 46 (tàm tạm)

Đã gửi 26 April 2013 - 12:56 PM

Nhiều yếu tố động quá -> độ khó tăng theo cấp số nhân so với bài toán ban đầu :wacko: . Hiện tại mình ko có thời gian nghiên cứu tiếp và cũng cảm thấy ko có năng lực đó :mellow: , đành thấy khó mà rút lui, sr bác chủ thớt :) . Hy vọng bác Hà có giải pháp cho bạn hoặc là có bác cao thủ nào đó bỏ ít thời gian dòm ngó bài toán của bạn ^_^ . Good luck ;) !


  • 0

#31 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 26 April 2013 - 01:42 PM

Nhiều yếu tố động quá -> độ khó tăng theo cấp số nhân so với bài toán ban đầu :wacko: . Hiện tại mình ko có thời gian nghiên cứu tiếp và cũng cảm thấy ko có năng lực đó :mellow: , đành thấy khó mà rút lui, sr bác chủ thớt :) . Hy vọng bác Hà có giải pháp cho bạn hoặc là có bác cao thủ nào đó bỏ ít thời gian dòm ngó bài toán của bạn ^_^ . Good luck ;) !

1). Bài toán đầu tiên: có trường hợp vô nghiệm (dù đã có 2 lisp).

2). Bài toán này: có trường hợp vô nghiệm + có cả trường hợp vô số nghiệm (do điều kiện Li <= L cố định) => không thể giải.


  • 0

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


#32 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 26 April 2013 - 05:15 PM

Nếu vô nghiệm thì phải thay đổi L, lúc đó sẽ có khả năng tìm ra.

Với lại nếu có nghiệm thì cũng giải gần đúng theo một độ chính xác nào đó.


  • 0
Clear sky!

MF Rock collection.

#33 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 26 April 2013 - 05:22 PM

Nếu vô nghiệm thì phải thay đổi L, lúc đó sẽ có khả năng tìm ra.

Với lại nếu có nghiệm thì cũng giải gần đúng theo một độ chính xác nào đó.

1). Thay L thì có khả năng tìm ra: OK. Thường là cho nó nhỏ dần đi.

2). Giải gần đúng: OK. Bài toán này nếu biết phương trình đường cong, giải bằng tích phân thì may ra mới có nghiệm chính xác, chứ cad thì thế thôi.

3). Còn vô số nghiệm thì phải xử thế nào? Thật ra là do điều kiện các Li <= L là quá rộng nên mới sinh ra chuyện này!


  • 0

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


#34 Song Nhi

Song Nhi

    biết vẽ rectang

  • Members
  • PipPip
  • 83 Bài viết
Điểm đánh giá: 52 (tàm tạm)

Đã gửi 26 April 2013 - 08:09 PM

Yêu cầu: Đó là, cái đường điều phối ta vẽ trước đó, từ đó ta xác định nó cắt tại bao nhiêu điểm, như hình trên thì ta có 5 khối .Sau đó vẫn như yêu cầu trên là tìm vị trí đường điều phối mà cả 5 khối đó đều thỏa mãn các điều kiện như trước (đoạn MN của các khối không bằng nhau nhưng phải <= L cố định ). Sau khi tính xong thì ta phải được một hình hoàn chỉnh như khối 1 ( Có hatch, ghi kích thước ) .

 

Đối với một khối đã khó (vì bài toán chưa lấy gì chắc chắc đã hội tụ với một giá trị sai số tương đối chấp nhận được 0.5%?!!). Bạn yêu cầu đồng thời năm khối (hoặc sau đó có lẽ nhiều hơn!) + MN <= Const --> khả năng không hội tụ của bài toán được tăng lên theo cấp luỹ thừa (theo quy tắc nhân thì có lẽ như vậy?!!). Trong trường hợp này sao bạn không giới hạn cận dưới cho đoạn MN? Nếu MN dần về 0 thì bài toán xem như có cơ hội hội tụ được nhiều hơn. Tuy nhiên, về mặt lập trình thì lại vất vả hơn, vì số trường hợp thử tăng lên quá nhiều, có vẻ như không tưởng?

Tôi mạo muội đề nghị bạn như thế này không biết có hồ đồ quá không nhé:
Trước hết, bạn dùng LISP (của bác Skywings hoặc bác Doan Van Ha) chạy cho từng khối, với độ chính xác MỊN hơn độ chính xác bạn kì vọng --> đường điều phối cho từng tường hợp. Nhưng vì bài toán của bạn tuỳ vào sai số, có thể vô nghiệm hoặc vô số nghiệm --> Bạn nên chọn đường điều phối nào mà MN nằm tương đối cân bằng với đường cong tích luỹ.

Sau đó, Từ nhóm đường điều phối thu được, bạn cân bằng theo nguyên tắc cân bằng Moment (tôi nói như vậy cho dễ hình dung) với "giá trị lực" là các giá trị diện tích thành phần tương ứng (hoặc chọn tất cả lớn hơn, hoặc chọn tất cả nhỏ hơn tại mỗi khối?!!!)
Hình vẽ minh hoạ như sau:


118347_12345.jpg
 

Nói vòng vòng vậy thôi, mong các bác thư giản và chém nhẹ tay, thật ra trong cách làm trên không có một "đạo lý" nào hết, tự mình "cảm thấy" làm vậy có vẻ được được! Hì hì hì.

 

P/S: Vote 2 bác: Skywings Doan Van Ha vì kiến thức và sự nhiệt tình của các bác!

 

(*) Thật ra là có một "đạo lý" nho nhỏ, nếu thay S1; S2; ... ; Sn bằng các vecto số gia sai số diện tích thành phần tương ứng, đối với mỗi vị trí của MN xác định, nếu đường điều phối (DDP) di chuyển lên trên thì sẽ ứng với một "số gia sai số diện tích", nếu DDP di chuyển xuống dưới sẽ ứng với một "số gia sai số diện tích" khác nữa...

Tuy nhiên, ở đây có 2 điều không hợp lý:

1. Đường PL không có quy luật (hàm số) rõ ràng.

2. "Số gia" (ví dụ: gia tốc...) là "dự đoán" cho cho bước tiếp theo, còn trong trường hợp chúng ta thì giá trị này là do các giá trị cũ mà suy ra (khác nhau về mặt bản chất, một bên là quy luật, một bên là mò mẫm dự đoán?!!!)


  • 3

#35 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 26 April 2013 - 08:59 PM

Tôi cũng vote cho bạn vì đã bỏ công sức ra để đầu tư một comment có khoa học.

Tôi nghĩ, do chủ topic không nói rõ bản chất của y/c này khiến bài toán mông lung, chứ nếu y/c rõ ràng hơn từ vấn đề thực tế thì còn le lói hy vọng.

Có một điều rất mệt: đó là chủ topic lúc đầu chỉ y/c đưa ra giải thuật (chứ không phải lisp), bây giờ nãy sinh những lisp khác, với y/c khó hơn nhưng đầu bài khá mơ hồ.

Tôi vẫn còn ham muốn bài toán này, nhưng chừng nào chủ topic đưa y/c thực tế hơn và rõ ràng hơn thì sẽ quay lại để... khổ với nó.


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

garupro

    biết vẽ circle

  • Members
  • PipPip
  • 34 Bài viết
Điểm đánh giá: 7 (bình thường)

Đã gửi 27 April 2013 - 01:42 PM

Cảm ơn các bạn đã quan tâm và giúp đỡ, nhưng xem chừng yêu cầu của mình hơi cao. Vì vậy mình xin đưa bài toán của mình về đơn giản nhất mong các bạn viết giúp mình để giải quyết nó với (thực ra mình đã làm được với Net nhưng tốc độ chậm quá) nên nhờ các bạn viết dùm mình cái lisp vậy

3566.png

 

Lisp này mình sử dụng kết hợp với Net  nền việc chọn đối tượng nếu có thể thì chọn theo cách nhập Handle của đối tượng đó

Yêu cầu như sau :

Nhập Handle của đường cong tích luỹ

Nhập Handle của đường điều phối (ĐƯờng này mình tự vạch đấy)

Nhập Sai số cho phép

 

Sau đó Lisp sẽ tự làm như sau :Xác định giao điểm của đường điều phối với đường cong tích luỹ phân thành các khối ( ví dụ trong hình là 3 khối)

Xét từng khối 1, ví dụ với khối 1 ta chia ra làm 2. 1 từ điểm A đến cực trị của đường cong ta vẽ đường Line 1 và dịch sang trái hợc phải khi nào W1 = W2 thì dùng lại, tương tự nửa còn lại ta vẽ Line 2 và dịch nó khi W1 = W2 thì dừng sau khi hết 1 khối thì ghi kích thước và hatch như trong hình sau đó chuyển sang khối khác cho đến hết ( Khi dịch chuyển Line sang trái phải hiện luôn cái W1, W2 trên màn hình sau khi chia xong thì xoá)

Trên  diễn đàn mình cũng có 1 lisp chia đa giác thành 2 phần bằng nhau rồi, nhưng không ứng dụng vào bài của mình được. Các bạn giúp mình nha. Không biết tý gì về lisp nên đành làm phiền các bạn vậy .


  • 0

#37 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1431 Bài viết
Điểm đánh giá: 1425 (rất tốt)

Đã gửi 27 April 2013 - 04:28 PM

Cảm ơn các bạn đã quan tâm và giúp đỡ, nhưng xem chừng yêu cầu của mình hơi cao. Vì vậy mình xin đưa bài toán của mình về đơn giản nhất mong các bạn viết giúp mình để giải quyết nó với (thực ra mình đã làm được với Net nhưng tốc độ chậm quá) nên nhờ các bạn viết dùm mình cái lisp vậy

 

...................

Ô hay! đi trên đường cao tốc (Net) mà tốc độ lại chậm ???


  • 0

#38 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 27 April 2013 - 04:46 PM

Ô hay! đi trên đường cao tốc (Net) mà tốc độ lại chậm ???

Đường tốt mà xe cà rịch cà tang thì cũng lê từng bước thôi.  :lol:

Với bài toán này thì tính chính xác luôn, tốc độ sẽ nhanh cực, vì nó... dễ :lol:


  • 0

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


#39 Detailing

Detailing

    biết lệnh imageclip

  • Members
  • PipPipPipPipPipPipPip
  • 667 Bài viết
Điểm đánh giá: 278 (khá)

Đã gửi 27 April 2013 - 11:00 PM

Cảm ơn các bạn đã quan tâm và giúp đỡ, nhưng xem chừng yêu cầu của mình hơi cao. Vì vậy mình xin đưa bài toán của mình về đơn giản nhất mong các bạn viết giúp mình để giải quyết nó với (thực ra mình đã làm được với Net nhưng tốc độ chậm quá) nên nhờ các bạn viết dùm mình cái lisp vậy

 

 

Lisp này mình sử dụng kết hợp với Net  nền việc chọn đối tượng nếu có thể thì chọn theo cách nhập Handle của đối tượng đó

Yêu cầu như sau :

Nhập Handle của đường cong tích luỹ

Nhập Handle của đường điều phối (ĐƯờng này mình tự vạch đấy)

Nhập Sai số cho phép

 

Sau đó Lisp sẽ tự làm như sau :Xác định giao điểm của đường điều phối với đường cong tích luỹ phân thành các khối ( ví dụ trong hình là 3 khối)

Xét từng khối 1, ví dụ với khối 1 ta chia ra làm 2. 1 từ điểm A đến cực trị của đường cong ta vẽ đường Line 1 và dịch sang trái hợc phải khi nào W1 = W2 thì dùng lại, tương tự nửa còn lại ta vẽ Line 2 và dịch nó khi W1 = W2 thì dừng sau khi hết 1 khối thì ghi kích thước và hatch như trong hình sau đó chuyển sang khối khác cho đến hết ( Khi dịch chuyển Line sang trái phải hiện luôn cái W1, W2 trên màn hình sau khi chia xong thì xoá)

Trên  diễn đàn mình cũng có 1 lisp chia đa giác thành 2 phần bằng nhau rồi, nhưng không ứng dụng vào bài của mình được. Các bạn giúp mình nha. Không biết tý gì về lisp nên đành làm phiền các bạn vậy .

xưa giờ mới thấy 1 lisp hay Addin .NET yêu cầu người dùng nhập Handle  :blink:

move line 1 rồi line 2 làm sao? giữ nguyên? hay move? step là bao nhiêu, làm sao tính được area của hình bất kỳ kia (dùng boundary của CAD?)  cách suy nghĩ theo "auto tay" thì có viết bằng ARX nó vẫn chạy mút mùa :D

Have fun!


  • 0

Ideas don't matter, execution does!

1908412_308002392716743_8165279281236341


#40 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 27 April 2013 - 11:12 PM

Tôi chỉ code cho bạn cách chia S thôi, còn ba thứ lăng nhăng như hatch và dimension thì không hứng lắm, với nó còn phụ thuộc sở thích của người dùng.

Cái này chạy tức thì, không cần mò dần, kết quả đúng tuyệt đối.

 

(defun C:HA( / obj1 obj2 ent1 lstg lst1 lst z p1 p2 lstx lstt lstp St Stt pt Sp Spp pp)
 (vl-load-com)
 (setq obj1 (vlax-ename->vla-object (setq ent1 (car (entsel "\nChon duong cong tich luy Pline: ")))))
 (setq obj2 (vlax-ename->vla-object (car (entsel "\nChon duong dieu phoi: "))))
 (setq lstg (vl-sort (LM:Intersections obj1 obj2 acExtendNone) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst1 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent1))))
 (setq lst (vl-sort (append lstg lst1) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst (vl-remove-if '(lambda(pt) (or (< (car pt) (caar lstg)) (> (car pt) (car (last lstg))))) lst))
 (setq z -1)
 (repeat (1- (length lstg))
  (setq p1 (nth (setq z (1+ z)) lstg) p2 (nth (1+ z) lstg))
  (setq lstx (vl-remove-if '(lambda(pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) lst))
  (setq lstt (vl-remove-if '(lambda(pt) (> (car pt) (car (Cuctri lstx)))) lstx))
  (setq lstp (vl-remove-if '(lambda(pt) (< (car pt) (car (Cuctri lstx)))) lstx))
  (setq St (PointArea (cons (list (car (last lstt)) (cadr (car lstt))) lstt)))
  (setq Stt (PointArea (cons (list (car (car lstt)) (cadr (last lstt))) lstt)))
  (setq pt (polar p1 0 (* (/ Stt (+ Stt St)) (- (car (Cuctri lstx)) (car p1)))))
  (setq Sp (PointArea (cons (list (car (car lstp)) (cadr (last lstp))) lstp)))
  (setq Spp (PointArea (cons (list (car (last lstp)) (cadr (car lstp))) lstp)))
  (setq pp (polar p2 pi (* (/ Spp (+ Sp Spp)) (- (car p2) (car (Cuctri lstx))))))
  (LWPoly (list pt (list (car pt) (cadr (Cuctri lstx))) (list (car pp) (cadr (Cuctri lstx))) pp))))
;-----
(defun LM:Intersections(obj1 obj2 mode / lst r)
 (setq lst (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length lst) 3)
  (setq r (cons (list (car lst) (cadr lst) (caddr lst)) r) lst (cdddr lst)))
 r)
(defun Cuctri(lst / p1)
 (if (vl-remove-if '(lambda(pt) (>= (cadr pt) (cadar lst))) lst)
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (< (cadr pt) (cadr p1)) (setq p1 pt))))
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (> (cadr pt) (cadr p1)) (setq p1 pt)))))
 p1)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))
(defun C:HA( / obj1 obj2 ent1 lstg lst1 lst z p1 p2 lstx lstt lstp St Stt pt Sp Spp pp)
 (vl-load-com)
 (setq obj1 (vlax-ename->vla-object (setq ent1 (car (entsel "\nChon duong cong tich luy Pline: ")))))
 (setq obj2 (vlax-ename->vla-object (car (entsel "\nChon duong dieu phoi: "))))
 (setq lstg (vl-sort (LM:Intersections obj1 obj2 acExtendNone) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst1 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent1))))
 (setq lst (vl-sort (append lstg lst1) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst (vl-remove-if '(lambda(pt) (or (< (car pt) (caar lstg)) (> (car pt) (car (last lstg))))) lst))
 (setq z -1)
 (repeat (1- (length lstg))
  (setq p1 (nth (setq z (1+ z)) lstg) p2 (nth (1+ z) lstg))
  (setq lstx (vl-remove-if '(lambda(pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) lst))
  (setq lstt (vl-remove-if '(lambda(pt) (> (car pt) (car (Cuctri lstx)))) lstx))
  (setq lstp (vl-remove-if '(lambda(pt) (< (car pt) (car (Cuctri lstx)))) lstx))
  (setq St (PointArea (cons (list (car (last lstt)) (cadr (car lstt))) lstt)))
  (setq Stt (PointArea (cons (list (car (car lstt)) (cadr (last lstt))) lstt)))
  (setq pt (polar p1 0 (* (/ Stt (+ Stt St)) (- (car (Cuctri lstx)) (car p1)))))
  (setq Sp (PointArea (cons (list (car (car lstp)) (cadr (last lstp))) lstp)))
  (setq Spp (PointArea (cons (list (car (last lstp)) (cadr (car lstp))) lstp)))
  (setq pp (polar p2 pi (* (/ Spp (+ Sp Spp)) (- (car p2) (car (Cuctri lstx))))))
  (LWPoly (list pt (list (car pt) (cadr (Cuctri lstx))) (list (car pp) (cadr (Cuctri lstx))) pp))))
;-----
(defun LM:Intersections(obj1 obj2 mode / lst r)
 (setq lst (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length lst) 3)
  (setq r (cons (list (car lst) (cadr lst) (caddr lst)) r) lst (cdddr lst)))
 r)
(defun Cuctri(lst / p1)
 (if (vl-remove-if '(lambda(pt) (>= (cadr pt) (cadar lst))) lst) ;co cuc tieu
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (< (cadr pt) (cadr p1)) (setq p1 pt))))
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (> (cadr pt) (cadr p1)) (setq p1 pt)))))
 p1)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a B) (- (* (car a) (cadr B)) (* (car B) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))
[/lisp]
(defun C:HA( / obj1 obj2 ent1 lstg lst1 lst z p1 p2 lstx lstt lstp St Stt pt Sp Spp pp)
 (setq obj1 (vlax-ename->vla-object (setq ent1 (car (entsel "\nChon duong cong tich luy Pline: ")))))
 (setq obj2 (vlax-ename->vla-object (car (entsel "\nChon duong dieu phoi: "))))
 (setq lstg (vl-sort (LM:Intersections obj1 obj2 acExtendNone) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst1 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent1))))
 (setq lst (vl-sort (append lstg lst1) '(lambda (e1 e2) (< (car e1) (car e2)))))
 (setq lst (vl-remove-if '(lambda(pt) (or (< (car pt) (caar lstg)) (> (car pt) (car (last lstg))))) lst))
 (setq z -1)
 (repeat (1- (length lstg))
  (setq p1 (nth (setq z (1+ z)) lstg) p2 (nth (1+ z) lstg))
  (setq lstx (vl-remove-if '(lambda(pt) (or (< (car pt) (car p1)) (> (car pt) (car p2)))) lst))
  (setq lstt (vl-remove-if '(lambda(pt) (> (car pt) (car (Cuctri lstx)))) lstx))
  (setq lstp (vl-remove-if '(lambda(pt) (< (car pt) (car (Cuctri lstx)))) lstx))
  (setq St (PointArea (cons (list (car (last lstt)) (cadr (car lstt))) lstt)))
  (setq Stt (PointArea (cons (list (car (car lstt)) (cadr (last lstt))) lstt)))
  (setq pt (polar p1 0 (* (/ Stt (+ Stt St)) (- (car (Cuctri lstx)) (car p1)))))
  (setq Sp (PointArea (cons (list (car (car lstp)) (cadr (last lstp))) lstp)))
  (setq Spp (PointArea (cons (list (car (last lstp)) (cadr (car lstp))) lstp)))
  (setq pp (polar p2 pi (* (/ Spp (+ Sp Spp)) (- (car p2) (car (Cuctri lstx))))))
  (LWPoly (list pt (list (car pt) (cadr (Cuctri lstx))) (list (car pp) (cadr (Cuctri lstx))) pp))))
;-----
(defun LM:Intersections(obj1 obj2 mode / lst r)
 (setq lst (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length lst) 3)
  (setq r (cons (list (car lst) (cadr lst) (caddr lst)) r) lst (cdddr lst)))
 r)
(defun Cuctri(lst / p1)
 (if (vl-remove-if '(lambda(pt) (>= (cadr pt) (cadar lst))) lst) ;co cuc tieu
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (< (cadr pt) (cadr p1)) (setq p1 pt))))
  (progn
   (setq p1 (car lst))
   (foreach pt lst
    (if (> (cadr pt) (cadr p1)) (setq p1 pt)))))
 p1)
(defun LWPoly(lst)
 (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst))) 
   (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun PointArea (lst)
 (/ (abs (apply '+ (mapcar (function (lambda (a B) (- (* (car a) (cadr B)) (* (car B) (cadr a))))) lst (append (cdr lst) (list (car lst)))))) 2.0))
[/lisp]

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