Đến nội dung


Hình ảnh
- - - - -

Nhờ Giúp Đỡ Viết Lisp


  • Please log in to reply
8 replies to this topic

#1 daolinhvn

daolinhvn

    biết vẽ line

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

Đã gửi 23 October 2015 - 04:23 PM

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.c...59_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!


  • -1

#2 hiepttr

hiepttr

    Edu level: li10

  • Members
  • PipPipPipPipPipPipPip
  • 1298 Bài viết
Điểm đánh giá: 518 (tốt)

Đã gửi 23 October 2015 - 05:25 PM

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


  • 0

Có vợ dù dữ dù hiền , bạn đều có lợi
_ Nếu vợ hiền, bạn sẽ là người đàn ông sung sướng
_ Nếu vợ dữ, bạn sẽ thành ... triết gia !

Bergson


#3 daolinhvn

daolinhvn

    biết vẽ line

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

Đã gửi 23 October 2015 - 07:32 PM

- 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...ykk9/Sketch.dwg


  • 0

#4 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 24 October 2015 - 02:53 PM

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

Hề hề hề,

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

 

http://www.cadviet.c.../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)
 
)

Bài viết đã được chỉnh sửa nội dung bởi phamthanhbinh: 25 October 2015 - 08:32 PM
Sửa lại điều kiện kiểm tra điểm trong hay ngoài pline kín.

  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#5 pphung183

pphung183

    biết dimstyle

  • Members
  • PipPipPipPipPip
  • 384 Bài viết
Điểm đánh giá: 425 (tốt)

Đã gửi 25 October 2015 - 10:40 AM

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


  • 2

#6 daolinhvn

daolinhvn

    biết vẽ line

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

Đã gửi 25 October 2015 - 11:30 AM

 

Hề hề hề,

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

 

http://www.cadviet.c.../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 ạ!


  • 0

#7 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 25 October 2015 - 08:52 PM

 

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


  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#8 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6009 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 25 October 2015 - 08:57 PM

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


  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#9 pphung183

pphung183

    biết dimstyle

  • Members
  • PipPipPipPipPip
  • 384 Bài viết
Điểm đánh giá: 425 (tốt)

Đã gửi 25 October 2015 - 09:24 PM

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


  • 2