ssg

Chủ đề này đã từng post trên diễn đàn nhưng đã mất vì có lần host dữ liệu bị sự cố. Nay có yêu cầu tương tự của bạn tuannguyen, ssg xin post lại. Bài toán: Cho 1 pline kín c và một đường thẳng d cắt c tại ít nhất 2 điểm, chia c thành 2 phần có diện tích S1 và S2. Xác định vị trí đúng của đường d (không thay đổi phương) sao cho S1/(S1+S2) = k (số k<1 tuỳ ý). Hình minh hoạ: Chương trình lisp, lệnh DL (Divide Land): ;;;=========================================== ;;;Chuong trinh chia dien tich pline kin theo ty le va line dinh huong ;;;Copyright by ssg - www.cadviet.com - February 2009 ;;;=========================================== ;;;------------------------------------------------------------------------------- ;;;PUBLIC FUNCTIONS ;;;------------------------------------------------------------------------------- (defun GetMid (p1 p2) ;;;Midpoint: p1, p2 (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)) ) ;;;------------------------------------------------------------------------------- (defun ints (e1 e2 / ob1 ob2 V L1 L2) ;;;Intersections of e1, e2. Return LIST of points ;;;Thank Mr. Hoanh for this function! (setq ob1 (vlax-ename->vla-object e1) ob2 (vlax-ename->vla-object e2) ) (setq V (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendOtherEntity))) (if (/= (vlax-safearray-get-u-bound V 1) -1) (progn (setq L1 (vlax-safearray->list V) L2 nil) (while L1 (setq L2 (append L2 (list (list (car L1) (cadr L1) (caddr L1))))) (repeat 3 (setq L1 (cdr L1))) ) ) (setq L2 nil) ) L2 ) ;;;------------------------------------------------------------------------------- (defun getVert (e / i L) ;;;Return list of all vertex from pline e (setq i 0 L nil) (vl-load-com) (repeat (fix (+ (vlax-curve-getEndParam e) 1)) (setq L (append L (list (vlax-curve-getPointAtParam e i)))) (setq i (1+ i)) ) L ) ;;;------------------------------------------------------------------------------- (defun move_slow (e ag dr) ;;;Move e by angle ag, step dr (command "move" e "" (list 0 0) (polar (list 0 0) ag dr)) ) ;;;-------------------------------------------------------------------------------- (defun sideP (p1 p2 e / p1n p2n) ;;;Check same side of 2 points by line e, return T or nil (command "ucs" "n" "ob" e) (setq p1n (trans p1 0 1) p2n (trans p2 0 1) ) (command "ucs" "p") (>= (* (cadr p1n) (cadr p2n)) 0) ) ;;;-------------------------------------------------------------------------------- ;;;PRIVATE FUNCTIONS ;;;-------------------------------------------------------------------------------- (defun area_DL (p) ;;;Get area. Specify by e0, e1, p ;;;Filtered vertex, same side with p (setq Lf (ints e0 e1)) (foreach x L0 (if (sideP x p e1) (setq Lf (append Lf (list x)))) ) ;;;Convert to curve-param and sort (setq Lpara nil) (foreach x Lf (setq para (vlax-curve-getParamAtPoint e0 x)) (setq Lpara (append Lpara (list para))) ) (setq Lpara (vl-sort Lpara '<)) ;;;Get area (command ".area") (foreach x Lpara (command (vlax-curve-getPointAtParam e0 x))) (command "") (setq S (getvar "area")) ) ;;;-------------------------------------------------------------------------------- (defun data_DL () ;;;Input data and calculate (vl-load-com) (setq e0 (car (entsel "\nChon 1 pline kin:"))) (redraw e0 3) (setq e1 (car (entsel "\nChon duong chia (cat pline it nhat tai 2 diem):")) Li (ints e0 e1) ) (redraw e1 3) (if (< (length Li) 2) (progn (alert "\nKhong tim thay 2 giao diem!") (exit))) (setq i (- (length Li) 1) di (distance (car Li) (nth i Li)) p0 (getpoint "\nPick 1 diem ben trong pline:") k (getreal "\nTy le phan chia tuong ung voi diem pick <0.5>:") ) (if (not k) (setq k 0.5)) (setq S0 (vlax-curve-getArea e0) S1 (* k S0) L0 (getVert e0) ;;;List of all vertex S00 (area_DL p0) St S00 p1 (vlax-curve-getClosestPointTo e1 p0) ag (angle p1 p0) prec 0.00000001 oldos (getvar "osmode") ) (cond ((<= (abs (- S00 S1)) prec) (progn (alert "Duong chia dang nam dung vi tri!") (command "regen") (exit))) ((> S00 S1) (setq flag 1)) ((< S00 S1) (setq flag -1)) ) (setvar "cmdecho" 0) (setvar "osmode" 0) ) ;;;-------------------------------------------------------------------------------- (defun RunDL () (setq OK nil) (while (not OK) (setq Li (ints e0 e1) i (- (length Li) 1) pM (getMid (car Li) (nth i Li)) pN (polar pM ag tol) St (area_DL pN) ) (if (<= (* St flag) (* S1 flag)) (progn (setq flag (* flag -1)) (setq OK T)) (move_slow e1 ag (* flag tol)) ) ) ) ;;;============================================ ;;;MAIN ;;;============================================ ;;;Divide Land (defun C:DL (/ e0 e1 Li i di p0 k tol s0 s1 p1 ag L0 OK Lf x p Lpara para S oldos S00 flag pM pN St prec) (prompt "Chuong trinh chia dien tich pline kin theo ty le va line dinh huong") (data_DL) (alert "Bam OK, duong chia se di chuyen va dao dong\nCu yen chi cho mot chut!") (setq tol (* di 0.01)) (while (> (abs (- St S1)) prec) (runDL) (setq tol (* 0.1 tol))) (alert "FINISH!") (setvar "cmdecho" 1) (setvar "osmode" oldos) (command "regen") (princ) ) ;;;============================================ Diễn giải: Chọn pline kín c, chọn line d, pick 1 điểm bên trong pline, nhập hệ số tỷ lệ k tương ứng với "phần đất" tại điểm pick. Chương trình sẽ di chuyển đường d đến vị trí gần đúng, dao động quanh vị trí đúng và dừng lại khi đạt độ chính xác đến 8 chữ số thập phân. Dùng cái này để chia đất... "từ đường hương hoả" bảo đảm công bằng, khỏi phải kình cãi làm anh chị em mất đoàn kết!

Hoan hô admin và BQT! :lol: Ổn định tổ chức là công việc đầu tiên. Đề nghị BQT công bố tên chủ nhiệm và danh sách các thành viên tham gia xây dựng CADViet Utility. Bước tiếp theo, mời chủ nhiệm ra mắt anh em, kèm theo bản kế hoạch và phân công trách nhiệm cụ thể (bài viết của ssg hôm trước chỉ nêu lên một số vấn đề chung, không phải là bản kế hoạch), cũng như quy chế phối hợp hoạt động giữa các thành viên. Bản thân ssg luôn sẵn sàng, và sẽ cố gắng hoàn thành mọi nhiệm vụ được giao.