[Đố vui] Bài toán chia đất, cũ mà hay!

[tannguyen291 135]

Thật ra bài toán này đã có trên diễn đàn 14 năm trước rồi không có ý gì cả chỉ là muốn xem sức viết lisp của anh em sau 15 năm thay đổi nhiều như thế nào.

Bài cũ: 

 

test với lisp ngày ấy.

Vì ngày ấy còn nhiều hạn chế về các hàm vla và các nguồn thông tin tham khảo nên chúng ta không đánh giá gì cả nhé.

Anh em thử viết một chương trình mới chạy với tốc độ max speed, lệnh càng ngắn, càng đơn giản càng tốt:

Tôi trước: 86 dòng code, 2 hàm phụ trợ.

Anh em cùng thử sức nào!

Hứa thứ 4 trả bài nhưng mấy hôm không vào được cadviet nay gửi anh em tham khảo ạ.

(defun c:chiadat (/ ent ang ms array obj lst centr are numb lstsolid minpt maxpt)
  (setq 
    ent (vlax-ename->vla-object (car (entsel "\nSelect Pline close!")))
    ang (getangle "\nAngle slice!")
    numb (getint "\nNumber slice")
    ms (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
    ent (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))
    ent (vlax-safearray-get-element (vlax-variant-value (vla-addregion ms ent)) 0)
    obj (vla-AddExtrudedSolid ms ent 1 0)
    are (/ (vla-get-volume obj) numb)
  )
  (vla-delete ent)
  (acet-ui-progress "Working" (1- numb))
  (repeat (1- numb)
    (setq centr (vlax-get obj 'Centroid))
    (vla-rotate obj (vlax-3d-point centr) (vlax-make-variant (- ang)))
    (vla-getboundingbox obj 'minpt 'maxpt)
    (setq 
      maxpt (- (vlax-safearray-get-element maxpt 1) (vlax-safearray-get-element minpt 1))
      minpt (- (/ maxpt 2) (/ maxpt numb))
      lst (if (equal 0 minpt 1e-2) '(-0.2 0.2) (list (* 0.9 minpt ) (* 1.1 minpt)))
    )
    (vla-rotate obj (vlax-3d-point centr) (vlax-make-variant ang))
    (while (/= 'VLA-OBJECT (type (car lst)))
      (setq lst (tn_noisuydientich obj ang lst centr are ))
    )
    (vla-delete obj)
    (setq 
      obj (cadr lst)
      lstsolid (cons (car lst) lstsolid)
      numb (1- numb)
    )
    (acet-ui-progress (length lstsolid))
  )
  (if (not lstsolid) (vla-delete obj))
  (foreach item (append (cdr lst) lstsolid )
    (vla-SectionSolid item (vlax-3d-point 0 0 0) (vlax-3d-point 1 0 0) (vlax-3d-point 0 1 0))
    (vla-delete item)
  )
  (acet-ui-progress)
  (princ)
)

(defun tn_noisuydientich ( obj ang n pt area / n1 n2 lst1 lst2 nx )
  (setq n1 (car n) n2 (cadr n))
  (while (not (setq lst1 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) n1) ang)))
    (setq n1 (* n1 0.75))
  )
  (while (not (setq lst2 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) n2) ang)))
    (setq n2 (* n2 0.75))
  )
  (cond
    ( (equal (cdar lst1) area 1e-4)
      (mapcar '(lambda (x y) (vla-delete (car x)) (car y)) lst2 lst1)
    )
    ( (equal (cdar lst2) area 1e-4)
      (mapcar '(lambda (x y) (vla-delete (car x)) (car y)) lst1 lst2)
    )
    ( (not
        (setq 
          nx (mapcar '(lambda (x) (vla-delete (car x))) (append lst1 lst2))
          nx (/ (+ (* area n1) (* (cdar lst2) n1 -1) (* n2 (cdar lst1)) (* -1 area n2) ) (- (cdar lst1) (cdar lst2)))
          lst1 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) nx) ang)
        )
      )
      (list n1 (/ (+ nx n2) 2))
    )
    ( (equal (cdar lst1) area 1e-4) (mapcar 'car lst1))
    ( (< area (cdar lst1))
      (mapcar '(lambda (x) (vla-delete (car x))) lst1)
      (vl-sort (list nx n2) '<)
    )
    ( (mapcar '(lambda (x) (vla-delete (car x))) lst1)
      (vl-sort (list n1 nx) '<)
    )
  )
)

(defun tn_SliceSolid (obj pt ang / p1 p2 so1 so2 )
  (setq so1 (vla-copy obj))
  (if (setq so2 (vla-SliceSolid so1 (vlax-3d-point pt) (vlax-3d-point (polar pt ang 1)) (vlax-3d-point (mapcar '+ pt '(0 0 1))) :vlax-true))
    (mapcar '(lambda (x) (cons x (vla-get-volume x))) (list so1 so2))
    (vla-delete so1)
  )
)

 

[limfx 21]

12 giờ trước, tannguyen291 đã nói:

Thật ra bài toán này đã có trên diễn đàn 14 năm trước rồi không có ý gì cả chỉ là muốn xem sức viết lisp của anh em sau 15 năm thay đổi nhiều như thế nào.

Bài cũ: 

 

test với lisp ngày ấy.

Vì ngày ấy còn nhiều hạn chế về các hàm vla và các nguồn thông tin tham khảo nên chúng ta không đánh giá gì cả nhé.

Anh em thử viết một chương trình mới chạy với tốc độ max speed, lệnh càng ngắn, càng đơn giản càng tốt:

Tôi trước: 86 dòng code, 2 hàm phụ trợ.

Anh em cùng thử sức nào!

Anh post code lên trước em xem sao rồi học làm theo

[tannguyen291 135]

12 phút trước, limfx đã nói:

Anh post code lên trước em xem sao rồi học làm theo

Bạn thể hiện bút lực của mình đi chứ, để thứ 4 mình sẽ post code. Tiêu chí đánh giá. Lisp ngắn gọn dễ hiểu, chương trình chạy nhanh, ổn định, có khản năng phát triển về sau.

[cuongtk2 342]

Chạy 00:00:00.00 ai viết cho nổi. Giả sử bạn cần chia theo 4/10, có 1 đường // với vệt cắt qua centroid (trọng tâm) chia diện tích đường bao thành 2 phần bằng nhau thì bên trái hay bên phải đường này đều tồn tại 1 đường thoả mãn yêu cầu.  Và đường lấy được 4/10 đó có thể chia ranh giới không lồi nhiều hơn 2 phần. Rõ ràng đây là một bài toán có từ 0 đến 2 nghiệm. 

[tannguyen291 135]

4 giờ trước, cuongtk2 đã nói:

Chạy 00:00:00.00 ai viết cho nổi. Giả sử bạn cần chia theo 4/10, có 1 đường // với vệt cắt qua centroid (trọng tâm) chia diện tích đường bao thành 2 phần bằng nhau thì bên trái hay bên phải đường này đều tồn tại 1 đường thoả mãn yêu cầu.  Và đường lấy được 4/10 đó có thể chia ranh giới không lồi nhiều hơn 2 phần. Rõ ràng đây là một bài toán có từ 0 đến 2 nghiệm. 

Thật ra lisp của em không hoàn toàn giống với lisp gốc. Chỉ tương tự thôi ạ. Lisp của em chia đất thành các ô có diện tích bằng nhau. Đường cắt có góc được nhập ban đầu. Kết quả trả về là region. Lisp chạy với phương thức nội suy. Không phải kiểm thử liên tục nên chạy rất nhanh ạ

[cuongtk2 342]

Chia thành lưới hình vuông rồi dùng phép đếm với point-in-polyline à em.

[tannguyen291 135]

10 giờ trước, cuongtk2 đã nói:

Chia thành lưới hình vuông rồi dùng phép đếm với point-in-polyline à em.

không anh. em dùng nội suy. ví dụ pt1 là tâm pline. pt2 là 1 điểm giả định mới. Diện tích do đường cắt qua pt1 là a1 qua pt2 là a2. dùng nội suy distance pt1 pt2 và A1 A2 tính ra ptx điểm có đường cắt qua vị trí có area cần cắt. Ax nếu không bằng area thì lặp lại tiếp tục nội suy. Thông thường chỉ cần 2 -4 lần nội suy là tính ra được điểm chính xác.

[limfx 21]

Get diện tích At, cho độ lệch diện tích as, Em dùng vòng lặp while cho đường chia tiến dần theo cạnh, tính được diện tích at, so sánh ax =At/2: (equal ax at as)  và lặp dần. Phương án này sao anh ?

 

[ketxu 2.984]

Đặt gạch hóng. 80 dòng code thì quá tuyệt r. Bài toán này m theo dõi Kim project làm thấy ổn, và có nhiều method. Nhưng để sử dụng ngôn ngữ Lisp thì khó mà tối ưu :)

[tannguyen291 135]

Gợi ý 1 chút hàm nội suy như thế này

Pt1 Pt2 tự đặt.

D1 = distance pt0 pt1 

D2 = distance pt0 pt2

 

công thức nội suy: (D1 - Dx) / ( Dx -D2) = (A1 - Ax) / (Ax - A2) 

Chỉ có Dx chưa biết nên tính được PTx

Nếu hình đơn giản có thể chỉ cần nội suy 1 lần. hình phức tạp cần nội suy nhiều lần hơn. Tuy nhiên sẽ không mất nhiều thời gian. 

Sử dụng tịnh tiến kiểm thử sẽ rất lâu.

[tannguyen291 135]

2 giờ trước, ketxu đã nói:

Đặt gạch hóng. 80 dòng code thì quá tuyệt r. Bài toán này m theo dõi Kim project làm thấy ổn, và có nhiều method. Nhưng để sử dụng ngôn ngữ Lisp thì khó mà tối ưu :)

thật ra 90% lisp là vla rồi bác. Thuần common lisp vẫn làm được nhưng viết dài hơn nhiều.

lisp của em có chức năng chia đất thành các ô đều nhau Chứ k giống lệnh gốc. 

Nếu số lượng ô đất cần chia nhỏ dưới 10 thì lisp chạy nhanh. Trên 20 là cũng lâu lâu đó ạ. :)) cải tiến thêm chắc phải mấy chục dòng code nữa. :)

[cuongtk2 342]

Công thức đó chỉ đúng trên 1 segment thẳng, vì vậy nội suy sai. Nên nội suy theo khối tâm của hệ 2 chất điểm https://vatlydaicuong.com/khoi-tam

[tannguyen291 135]

37 phút trước, cuongtk2 đã nói:

Công thức đó chỉ đúng trên 1 segment thẳng, vì vậy nội suy sai. Nên nội suy theo khối tâm của hệ 2 chất điểm https://vatlydaicuong.com/khoi-tam

vâng đúng rồi bác. Chỉ đúng với segment thẳng. Nhưng cũng gần chính xác. 

ví dụ pt1 pt2 không cùng 1 segment nội suy được pt3. So sánh diện tích vẫn chưa đúng thì tiếp tục nội suy lần nữa với pt2 pt3 để tìm ptx thì sẽ chính xác ạ.

Nếu là đường cong sẽ nội suy nhiều lần hơn tuy nhiên khoảng các giữa 2 điểm nội suy liên tục thu ngắn lại nên số lần kiểm thử sẽ không lớn như kiểm thử tịnh tiến. 

[limfx 21]

Em thấy việc thử dần lisp vẫn chạy nhanh, theo cách anh nhanh nữa chắc chết luôn KKK

[tannguyen291 135]

22 phút trước, limfx đã nói:

Em thấy việc thử dần lisp vẫn chạy nhanh, theo cách anh nhanh nữa chắc chết luôn KKK

bạn vẫn cảm thấy nhanh thì scale hình lên 10000 lần xem có nhanh nữa không hoặc vẫn nhanh thì up code để mọi ng cùng xem :))

hoặc có thể làm nó khó hơn nữa :))

[snowman.hms 59]

What about this?

[cuongtk2 342]

@snowman.hms Tân nó chia đất mà, trường hợp đó hầu như chia chác hết rồi mới ra hình như thế. Thường gặp gần như hình thang thôi.

[limfx 21]

Đúng là lisp chia nhỏ tịnh tiến khi tăng độ chính xác lên là rất chậm. Có phát sinh một số lỗi khi chọn cạnh khác nhau: lệnh A2A

(defun c:A2A ()
  (setq modelSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
  (setq as 5)
  (if (and (setq pl (entsel "\nSelect pline"))
	   (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car pl))))));and
    (progn
      (setq plo (vlax-ename->vla-object (car pl)))
      (if (eq :vlax-false (vla-get-Closed plo)) (vla-put-Closed plo :vlax-true))
      (setq pt (vlax-curve-getclosestpointto plo (cadr pl)))
      (setq ang (angle '(0 0 0) (vlax-curve-getfirstderiv plo (setq par (vlax-curve-getparamatpoint plo pt)))))
      (setq lpar (- (vlax-curve-getdistatparam plo (fix par)) (vlax-curve-getdistatparam plo (1+ (fix par)))))
      (setq At (vla-get-area plo))
      (if (and (not (initget 7))
          (setq Ax (/ At 2))
          (< Ax At));and
          (progn
	    (setq Ap 0.0)
	    (setq pin (/ as 500.0))
	    (setq i -1.0)
	    (while (and (not (equal Ax Ap as))
                        (setq pAp (vlax-curve-getPointatParam plo (* pin (setq i (1+ i))))))
	      (setq lstin nil)
	      (setq Li (vla-addLine modelSpace (vlax-3D-Point pAp) (vlax-3D-Point (polar pAp ang lpar))))
	      (setq pli (vlax-variant-value (vla-IntersectWith plo Li acExtendThisEntity)))
	      (vla-Delete Li)
	      (if (> (vlax-safearray-get-u-bound pli 1) 0)
		   (progn
		     (setq tempt (vlax-safearray->list pli))
		     (while (not (zerop (length tempt)))
                       (setq lstin (cons (list (car tempt) (cadr tempt) (caddr tempt)) lstin))
                       (setq  tempt (cdddr  tempt))
	             );while
		   );progn
	       );if
	       (if (> (length lstin) 1)
                 (progn
                   (setq parlstin (vl-sort (mapcar'(lambda (p) (vlax-curve-getParamatPoint plo p)) lstin) '<))
		   (setq spar (1+ (fix (car parlstin))))
		   (setq parli (list (car parlstin) (cadr parlstin)))
		   (while (< spar (cadr parlstin))
                     (setq parlstin (append parlstin (list spar)))
	             (setq spar (1+ spar))
	           );while
		   (setq pApLst (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x)))
                     (mapcar '(lambda (p) (vlax-curve-getPointatParam plo p)) (vl-sort parlstin '<)))))
		   (setq boAplst (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (1- (length pApLst)))) pApLst)))
		   (setq boAp (vla-AddLightWeightPolyline modelSpace boAplst))
		   (vla-put-Closed boAp :vlax-true)
		   (setq Ap (vla-get-Area boAp))
                   (or (equal Ax Ap as) (vla-Delete boAp))
		 );progn
	      );if
	    );while
	  );progn
      );if 
    );progn  
  );if
  (print "limfx")
);end

 

[tannguyen291 135]

Sory anh em mấy hôm nay không hiểu sao không vào được cadviet. Hứa thứ 4 trả bài. Nay đã thứ 5 rồi. :))

Vào lúc 13/11/2023 tại 17:31, snowman.hms đã nói:

What about this?

Cái này chia bình thường thôi bác.

[tannguyen291 135]

Vào lúc 13/11/2023 tại 11:31, ketxu đã nói:

Đặt gạch hóng. 80 dòng code thì quá tuyệt r. Bài toán này m theo dõi Kim project làm thấy ổn, và có nhiều method. Nhưng để sử dụng ngôn ngữ Lisp thì khó mà tối ưu :)

em đã trả bài tại đầu trang ạ.

[limfx 21]

Vào lúc 11/11/2023 tại 23:29, tannguyen291 đã nói:

Thật ra bài toán này đã có trên diễn đàn 14 năm trước rồi không có ý gì cả chỉ là muốn xem sức viết lisp của anh em sau 15 năm thay đổi nhiều như thế nào.

Bài cũ: 

 

test với lisp ngày ấy.

Vì ngày ấy còn nhiều hạn chế về các hàm vla và các nguồn thông tin tham khảo nên chúng ta không đánh giá gì cả nhé.

Anh em thử viết một chương trình mới chạy với tốc độ max speed, lệnh càng ngắn, càng đơn giản càng tốt:

Tôi trước: 86 dòng code, 2 hàm phụ trợ.

Anh em cùng thử sức nào!

Hứa thứ 4 trả bài nhưng mấy hôm không vào được cadviet nay gửi anh em tham khảo ạ.

(defun c:chiadat (/ ent ang ms array obj lst centr are numb lstsolid minpt maxpt)
  (setq 
    ent (vlax-ename->vla-object (car (entsel "\nSelect Pline close!")))
    ang (getangle "\nAngle slice!")
    numb (getint "\nNumber slice")
    ms (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
    ent (vlax-safearray-fill (vlax-make-safearray vlax-vbObject '(0 . 0)) (list ent))
    ent (vlax-safearray-get-element (vlax-variant-value (vla-addregion ms ent)) 0)
    obj (vla-AddExtrudedSolid ms ent 1 0)
    are (/ (vla-get-volume obj) numb)
  )
  (vla-delete ent)
  (acet-ui-progress "Working" (1- numb))
  (repeat (1- numb)
    (setq centr (vlax-get obj 'Centroid))
    (vla-rotate obj (vlax-3d-point centr) (vlax-make-variant (- ang)))
    (vla-getboundingbox obj 'minpt 'maxpt)
    (setq 
      maxpt (- (vlax-safearray-get-element maxpt 1) (vlax-safearray-get-element minpt 1))
      minpt (- (/ maxpt 2) (/ maxpt numb))
      lst (if (equal 0 minpt 1e-2) '(-0.2 0.2) (list (* 0.9 minpt ) (* 1.1 minpt)))
    )
    (vla-rotate obj (vlax-3d-point centr) (vlax-make-variant ang))
    (while (/= 'VLA-OBJECT (type (car lst)))
      (setq lst (tn_noisuydientich obj ang lst centr are ))
    )
    (vla-delete obj)
    (setq 
      obj (cadr lst)
      lstsolid (cons (car lst) lstsolid)
      numb (1- numb)
    )
    (acet-ui-progress (length lstsolid))
  )
  (if (not lstsolid) (vla-delete obj))
  (foreach item (append (cdr lst) lstsolid )
    (vla-SectionSolid item (vlax-3d-point 0 0 0) (vlax-3d-point 1 0 0) (vlax-3d-point 0 1 0))
    (vla-delete item)
  )
  (acet-ui-progress)
  (princ)
)

(defun tn_noisuydientich ( obj ang n pt area / n1 n2 lst1 lst2 nx )
  (setq n1 (car n) n2 (cadr n))
  (while (not (setq lst1 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) n1) ang)))
    (setq n1 (* n1 0.75))
  )
  (while (not (setq lst2 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) n2) ang)))
    (setq n2 (* n2 0.75))
  )
  (cond
    ( (equal (cdar lst1) area 1e-4)
      (mapcar '(lambda (x y) (vla-delete (car x)) (car y)) lst2 lst1)
    )
    ( (equal (cdar lst2) area 1e-4)
      (mapcar '(lambda (x y) (vla-delete (car x)) (car y)) lst1 lst2)
    )
    ( (not
        (setq 
          nx (mapcar '(lambda (x) (vla-delete (car x))) (append lst1 lst2))
          nx (/ (+ (* area n1) (* (cdar lst2) n1 -1) (* n2 (cdar lst1)) (* -1 area n2) ) (- (cdar lst1) (cdar lst2)))
          lst1 (tn_SliceSolid obj (polar pt (+ ang (/ pi 2)) nx) ang)
        )
      )
      (list n1 (/ (+ nx n2) 2))
    )
    ( (equal (cdar lst1) area 1e-4) (mapcar 'car lst1))
    ( (< area (cdar lst1))
      (mapcar '(lambda (x) (vla-delete (car x))) lst1)
      (vl-sort (list nx n2) '<)
    )
    ( (mapcar '(lambda (x) (vla-delete (car x))) lst1)
      (vl-sort (list n1 nx) '<)
    )
  )
)

(defun tn_SliceSolid (obj pt ang / p1 p2 so1 so2 )
  (setq so1 (vla-copy obj))
  (if (setq so2 (vla-SliceSolid so1 (vlax-3d-point pt) (vlax-3d-point (polar pt ang 1)) (vlax-3d-point (mapcar '+ pt '(0 0 1))) :vlax-true))
    (mapcar '(lambda (x) (cons x (vla-get-volume x))) (list so1 so2))
    (vla-delete so1)
  )
)

 

Quá nhanh quá hay anh, cảm ơn anh!

[Doan Van Ha 3.191]

Đây là bài toán hoàn toàn khác đề bài với bài toán của SSG ban đầu.
Ở đó chia đôi theo biểu thức S1/(S1+S2) = k

Còn ở đây là chia n phần bằng nhau?

[tannguyen291 135]

19 phút trước, Doan Van Ha đã nói:

Đây là bài toán hoàn toàn khác đề bài với bài toán của SSG ban đầu.
 Ở đó chia đôi theo biểu thức S1/(S1+S2) = k

 Còn ở đây là chia n phần bằng nhau?

vâng đúng r bác. Bài của em không giống hoàn toàn với bài ban đầu. Tuy nhiên với công thức nội suy như vậy chỉ cần đơn giản lại lệnh 1 chút chức năng sẽ giống với bài toán ban đầu. 

[sam8xd 47]

Về phương thức thì vẫn phải tịnh tiến thử dần, tuy nhiên khoảng cách tịnh tiến cứ lấy chênh diện tích chia cho chiều dài đường cắt thì sẽ giảm thiểu được số lần tịnh tiến thôi

 

[tannguyen291 135]

8 phút trước, sam8xd đã nói:

Về phương thức thì vẫn phải tịnh tiến thử dần, tuy nhiên khoảng cách tịnh tiến cứ lấy chênh diện tích chia cho chiều dài đường cắt thì sẽ giảm thiểu được số lần tịnh tiến thôi

bác xem lisp của em. Không dùng phương thức tịnh tiến. Với hình vẽ của bác khá đơn giản có lẽ chỉ cần nội suy 1 lần là ra kết quả. Bác thử với các hình lớn nhỏ khác nhau, pline cong méo đủ kiểu lisp của bác chạy như thế nào ??? có thể show code cho mọi người cùng xem.