Nhờ Giúp Đỡ Viết Lisp

[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!

[hiepttr 538]

- Không xem được bản vẽ (có lẻ là do lỗi forum => có thể up lên một trang khác)

[daolinhvn 1]

- Không xem được bản vẽ (có lẻ là do lỗi forum => có thể up lên một trang khác)

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

[phamthanhbinh 3.146]

 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 Tháng 10 25, 2015 theo phamthanhbinh
Sửa lại điều kiện kiểm tra điểm trong hay ngoài pline kín.

[pphung183 428]

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

[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 ạ!

[phamthanhbinh 3.146]

 

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

[phamthanhbinh 3.146]

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

[pphung183 428]

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