Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Đăng nhập để thực hiện theo  
daolinhvn

Nhờ Giúp Đỡ Viết Lisp

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

daolinhvn    1

Xin được nhờ các bác trên diễn đàn giúp đỡ!

 

Bài toán em xin được sơ họa như sau:http://www.cadviet.com/upfiles/5/96359_sketch_2.dwg

 

Đoạn thẳng nằm trong pline kín. Sau khi nhập lệnh ta được:

1. array đoạn thẳng xuống biên duới pline kín

2. Các đoạn thẳng phải được kéo dài đến biên pline kín

3. Khoảng cách giữa 2 điểm bất kì của đoạn thẳng array với đường biên dưới < khoảng a cho trước.

 

Xin được gỡ rối và chân thành cảm ơn!

  • Vote giảm 1

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

 Vâng! Em xin up lên mediafire, nhờ bác giúp e: http://www.mediafire.com/download/osa71d81pllykk9/Sketch.dwg

Hề hề hề,

Dùng thử cái này coi sao nhé,

 

http://www.cadviet.com/upfiles/5/5194_mucop.lsp

 

Lưu ý chống chỉ định:

1/- Pline kín là đa giác lõm.

 

3/- Khoảng cách array nhỏ hơn kích thước  ô chọn của con trỏ màn hình Cad.

(defun c:muco (/ a b c p h pls pls1 p1 p2 ss e ssl e1 k1 k2 pc pd pc1 pd1)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq a (car (entsel "\n Chon pline gioi han"))
          b (car (entsel "\n Chon pline nguon"))
          p (getpoint "\n Chon diem goc")
          h (getdist "\n Chon khoang cach array: ") )
(command "undo" "be")
(command "xline" "v" p "")
(setq c (entlast))
(setq pls (acet-geom-intersectwith c a 0)
         pls (vl-sort pls '(lambda (x y) (< (cadr x) (cadr y))))  
         p1 (car pls)
         p2 (last pls) )
(while (< (cadr p1) (- (cadr p2) h))
     (setq p1 (polar p1 (/ pi 2) h))
     (command "copy" b "" p p1)
    
)
(setq ss (ssadd)
          e (entnext c) )
(while e
       (ssadd e ss)
       (setq e (entnext e))
)
(setq ssl (acet-ss-to-list ss))
(foreach e ssl
      (setq e1 (vlax-ename->vla-object e))
      (if (setq pls1 (acet-geom-intersectwith e a 0))
          (progn
                    (setq k1 (vlax-curve-getparamatpoint e1 (car pls1))
                               pd (vlax-curve-getstartpoint e1)
                               pc (vlax-curve-getendpoint e1)  )
                   (if (cadr pls1)
                       (progn
                             (command "trim" a "" pd "")
                             (command "trim" a "" pc "")
                       )
                       (if (cpip pc a)
                            (command "trim" a "" pd "")
                            (command "trim" a "" pc "")
                       )
                  )
                  (setq pd1 (vlax-curve-getstartpoint e1)
                            pc1 (vlax-curve-getendpoint e1)  )
                  (if (equal pc1 pc 0.001)
                       (command "extend" a "" pc "")
                  )
                  (if (equal pd1 pd 0.001)
                       (command "extend" a "" pd "")
                  )
         )
         (progn
                 (setq pd (vlax-curve-getstartpoint e1)
                           pc (vlax-curve-getendpoint e1)   )
                 (command "extend" a "" pd pc "")
         )
     )
)
(command "erase" b c "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cpip (p  e /  c pls p1 p2 )
(vl-load-com)
(command "xline" "v" p "")
(setq c (entlast))
(setq pls (acet-geom-intersectwith c e 0)
         pls (vl-sort pls '(lambda (x y) (< (cadr x) (cadr y))))  
         p1 (car pls)
         p2 (last pls) )
(command "erase" c "")
(if (and (< (cadr p1) (cadr p)) (< (cadr p) (cadr p2))) t nil)
 
)
Chỉnh sửa theo phamthanhbinh
Sửa lại điều kiện kiểm tra điểm trong hay ngoài pline kín.
  • Vote tăng 1

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
pphung183    425

Rút gọn chút :)  :

(defun c:muc (/ lwpline a b p h c pls p1 p2 ss e ssl lst)
(defun lwpline (lst)
(if (> (length lst) 1) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")
'(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) )
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) lst) )))) ;;;;;
(setq a (car (entsel "\n Chon pline gioi han")) b (car (entsel "\n Chon pline nguon")))
(setq p (cadr (acet-geom-vertex-list b)) h (getdist "\n Chon khoang cach array: "))
(command "undo" "be") (command "xline" "v" "non" p "") (setq c (entlast))
(setq pls (acet-geom-intersectwith c a 2) p1 (cadr pls) p2 (car pls))
(while (< (cadr p1) (- (cadr p2) h)) (setq p1 (polar p1 (/ pi 2) h))
(command "copy" b "" "non" p "non" p1) ) (setq ss (ssadd) e (entnext c))
(while e (ssadd e ss) (setq e (entnext e)) ) (setq ssl (acet-ss-to-list ss))
(foreach e ssl 
(setq pls (acet-geom-intersectwith a e 2) lst (acet-geom-vertex-list e))
(setq lst (append (list (car pls)) (reverse (cdr (reverse (cdr lst)))) (list (cadr pls)))) 
(lwpline lst) (command "erase" e "") )
(command "erase" b c "") (command "undo" "e") (princ))

  • Vote tăng 2

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
daolinhvn    1

 

Hề hề hề,

Dùng thử cái này coi sao nhé,

 

http://www.cadviet.com/upfiles/5/5194_mucop.lsp

 

Lưu ý chống chỉ định:

1/- Pline kín là đa giác lõm.

2/- Pline nguồn chỉ có 1 đoạn đơn

3/- Khoảng cách array nhỏ hơn kích thước  ô chọn của con trỏ màn hình Cad.

(defun c:muco (/ a b c p h pls pls1 p1 p2 ss e ssl e1 k1 k2 pc pd pc1 pd1)
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq a (car (entsel "\n Chon pline gioi han"))
          b (car (entsel "\n Chon pline nguon"))
          p (getpoint "\n Chon diem goc")
          h (getdist "\n Chon khoang cach array: ") )
(command "undo" "be")
(command "xline" "v" p "")
(setq c (entlast))
(setq pls (acet-geom-intersectwith c a 0)
         pls (vl-sort pls '(lambda (x y) (< (cadr x) (cadr y))))  
         p1 (car pls)
         p2 (last pls) )
(while (< (cadr p1) (- (cadr p2) h))
     (setq p1 (polar p1 (/ pi 2) h))
     (command "copy" b "" p p1)
    
)
(setq ss (ssadd)
          e (entnext c) )
(while e
       (ssadd e ss)
       (setq e (entnext e))
)
(setq ssl (acet-ss-to-list ss))
(foreach e ssl
      (setq e1 (vlax-ename->vla-object e))
      (if (setq pls1 (acet-geom-intersectwith e a 0))
          (progn
                    (setq k1 (vlax-curve-getparamatpoint e1 (car pls1))
                               pd (vlax-curve-getstartpoint e1)
                               pc (vlax-curve-getendpoint e1)  )
                   (if (cadr pls1)
                       (progn
                             (command "trim" a "" pd "")
                             (command "trim" a "" pc "")
                       )
                       (if (and (< 0 k1) (< k1 1))
                            (command "trim" a "" pd "")
                            (command "trim" a "" pc "")
                       )
                  )
                  (setq pd1 (vlax-curve-getstartpoint e1)
                            pc1 (vlax-curve-getendpoint e1)  )
                  (if (equal pc1 pc 0.001)
                       (command "extend" a "" pc "")
                  )
                  (if (equal pd1 pd 0.001)
                       (command "extend" a "" pd "")
                  )
         )
         (progn
                 (setq pd (vlax-curve-getstartpoint e1)
                           pc (vlax-curve-getendpoint e1)   )
                 (command "extend" a "" pd pc "")
         )
     )
)
(command "erase" b c "")
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)

 

Em cảm ơn bác! Bác có thể giúp em thêm truờng hợp đa giác lõm được ko ạ!

  • Vote tăng 1
  • Vote giảm 1

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

 

Rút gọn chút :)  :

(defun c:muc (/ lwpline a b p h c pls p1 p2 ss e ssl lst)
(defun lwpline (lst)
(if (> (length lst) 1) (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity")
'(100 . "AcDbPolyline") (cons 90 (length lst)) '(70 . 0) )
(mapcar '(lambda (p) (list 10 (car p) (cadr p))) lst) )))) ;;;;;
(setq a (car (entsel "\n Chon pline gioi han")) b (car (entsel "\n Chon pline nguon")))
(setq p (cadr (acet-geom-vertex-list b)) h (getdist "\n Chon khoang cach array: "))
(command "undo" "be") (command "xline" "v" "non" p "") (setq c (entlast))
(setq pls (acet-geom-intersectwith c a 2) p1 (cadr pls) p2 (car pls))
(while (< (cadr p1) (- (cadr p2) h)) (setq p1 (polar p1 (/ pi 2) h))
(command "copy" b "" "non" p "non" p1) ) (setq ss (ssadd) e (entnext c))
(while e (ssadd e ss) (setq e (entnext e)) ) (setq ssl (acet-ss-to-list ss))
(foreach e ssl 
(setq pls (acet-geom-intersectwith a e 2) lst (acet-geom-vertex-list e))
(setq lst (append (list (car pls)) (reverse (cdr (reverse (cdr lst)))) (list (cadr pls)))) 
(lwpline lst) (command "erase" e "") )
(command "erase" b c "") (command "undo" "e") (princ))

 

Hề hề hề,

 Cám ơn bác Pphung183 đã chỉ ra một hướng giải quyết khác. Tuy nhiên bác chưa cho chống chỉ định. Tỷ như đoạn pline nguồn là đoạn gấp khúc có nhiều hơn 3 đỉnh và khi copy xuống thì phần dư ra bên ngoài pline kín có hơn một đỉnh thì việc vẽ lại pline này sẽ không ổn lắm. Vả lại cũng chưa rõ pls và lst có cùng trật tự hay không bác ạ.

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

Em cảm ơn bác! Bác có thể giúp em thêm truờng hợp đa giác lõm được ko ạ!

Hề hề hề,

Với đa giác lõm thì vấn đề sẽ phức tạp hơn khá nhiều bởi số điểm giao cắt của một xline với đa giác lõm có thể nhiều hơn 2 và việc xét điểm nằm trong đa giác cũng không đơn giản. Khả năng của mình chưa thể giải quyết được bạn ạ.

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
pphung183    425

Hề hề hề,

 Cám ơn bác Pphung183 đã chỉ ra một hướng giải quyết khác. Tuy nhiên bác chưa cho chống chỉ định. Tỷ như đoạn pline nguồn là đoạn gấp khúc có nhiều hơn 3 đỉnh và khi copy xuống thì phần dư ra bên ngoài pline kín có hơn một đỉnh thì việc vẽ lại pline này sẽ không ổn lắm. Vả lại cũng chưa rõ pls và lst có cùng trật tự hay không bác ạ.

Nếu pline nguồn là đoạn gấp khúc có nhiều hơn 3 đỉnh thì cho thêm điều kiện vào để có cùng trật tự

(if (< (distance (cadr pls) (car lst)) (distance (cadr pls) (last lst)))

(setq lst (append (list (cadr pls)) (reverse (cdr (reverse (cdr lst)))) (list (car pls))))

(setq lst (append (list (car pls)) (reverse (cdr (reverse (cdr lst)))) (list (cadr pls)))) )

Chắc cũng có khả năng là có đỉnh lồi ra phần đường bao kín . Lisp trên giải quyết tốt cho Pline là đoạn thẳng hoặc 2 đoạn gấp khúc như bản vẽ của chủ thớt :)

  • Vote tăng 2

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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×