Đến nội dung


Hình ảnh
- - - - -

[Yêu cầu] Nhờ viết lisp tạo nhanh wipeout


  • Please log in to reply
61 replies to this topic

#41 anonmyous

anonmyous

    biết vẽ arc

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

Đã gửi 26 April 2012 - 11:52 AM

Em cảm ơn bác Doan Van Ha nhiều nhé. Mà lúc nãy quên mất, không nhờ viết luôn cả cái thao tác ngược lại phức tạp hơn biến từ wipeout thành poly line với. Bác xem có giúp đc e luôn ko với?


Chọn Wipe Out -> Explode
PEdit -> Chọn đoạn bất kì trên cái mớ vừa bẻ -> [ENTER] -> J -> P -> [Enter] -> Done
Có cần phải LISP ko nhỉ
  • 0

#42 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 27 April 2012 - 04:45 PM

VẬY LÀ BÓ TAY HẢ BÁC. CÓ CÁCH NÀO K?

Hề hề hề,
Gửi bạn đoạn code dùng để chuyển LWpolyline có chứ phần đoạn cong về LWpolyline gồm toàn phân đoạn thẳng và từ đó bạn có thể áp dụng vào cái lisp của mình.


(defun c:getppl (/ en par pob pa ppl)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq en (car (entsel "\n chon lwpolyline can chuyen ")))
(setq ppl (list)
par 0
pob (vlax-ename->vla-object en) )
(while (< par (vlax-curve-getendparam pob))
(setq pa (vlax-curve-getpointatparam pob par)
ppl (append ppl (list pa))
par (+ par 0.1) )
)
(setq ppl (append ppl (list (vlax-curve-getendpoint pob))))
ppl
(command "pline")
(foreach p ppl
(command p)
)
(command "")
(command "erase" en "")
(setvar "osmode" oldos)
(princ)
)
Hy vọng bạn hài lòng.

Bài viết đã được chỉnh sửa nội dung bởi phamthanhbinh: 28 April 2012 - 12:24 AM
Chỉnh sửa lại lisp theo góp ý của bác Ketxu và ĐoanVanHa

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

#43 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 27 April 2012 - 05:02 PM

Bác Bình ơi! Các đoạn arc nó biến thành đoạn thẳng nối 2 đầu mút của arc thì không ngon lắm nhỉ. Vi phân arc làm nhiều đoạn thì chính xác cao hơn bác nhỉ.
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#44 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 27 April 2012 - 08:30 PM

Bác Bình ơi! Các đoạn arc nó biến thành đoạn thẳng nối 2 đầu mút của arc thì không ngon lắm nhỉ. Vi phân arc làm nhiều đoạn thì chính xác cao hơn bác nhỉ.

Hề hề hề,
Bác DoanVanHa à, bác chưa đọc kỹ lisp của mình hay sao ấy. Mình tuy chưa chia nhỏ cung lắm nhưng cũng đã chia nó thành 10 phần rồi mà bác. (cái biến par mỗi lần lặp chỉ tăng lên 0.1 thôi mà). Do vậy nếu muốn chính xác hơn có thể giảm nhỏ cái gia số này. Nhưng mình nghĩ chia như vậy cũng tạm ổn rồi do các cung này thường không quá lớn.(Góc chắn cung có nhẽ là nhỏ hơn 180 độ) nên khi đó mỗi phần chia sẽ nhỏ hơn 18 độ và có thể chấp nhận dây cung trùng với cung được mà.
Nếu mà chia nhỏ quá (tỷ như gia số của biến par là 0.001 ) thì e lisp chạy hơi lâu bác ạ.
Đây chỉ là một bước gợi ý về giải pháp thôi, còn lại thì người dùng có thể tự hiệu chỉnh lisp theo yêu cầu độ chính xác của mình sẽ tốt hơn, đúng không bác. Mình cũng chưa biết cái độ chính xác cần thiết phải bao nhiêu mà.
Hề hề hề, mong bác xem lại.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#45 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 27 April 2012 - 09:34 PM

Đây bác ơi!
1). File Cad:
http://www.cadviet.c...oi_bac_binh.dwg
2). Hình vẽ:
Hình đã gửi
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#46 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 27 April 2012 - 10:55 PM

Đây bác ơi!
1). File Cad:
http://www.cadviet.c...oi_bac_binh.dwg
2). Hình vẽ:

Hề hề hề,
Mình chưa hiểu vì sao lại bị vậy bác ạ. Cũng cái bản vẽ bác gửi, mình test lại thì nó ra cái ni:Hình đã gửi

Vậy phải chăng có biến hệ thống nào đó của bác khác với của mình???
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#47 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 27 April 2012 - 10:58 PM

Sao có command mà k có "osmode" hay "non" đâu bác nhỉ ^^
  • 3

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#48 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 27 April 2012 - 11:07 PM

Sao có command mà k có "osmode" hay "non" đâu bác nhỉ ^^

Hoan hô Ketxu đã phát hiện ra: do osmode!
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#49 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 28 April 2012 - 12:34 AM

Sao có command mà k có "osmode" hay "non" đâu bác nhỉ ^^

Hề hề hề,
Đúng là cái biến này mình hay bị quên do Cad của mình đặt biến Osmode thường trực là 0.
Việc dùng thằng "non" của bác mình có đọc được trong một topic nào đó nhưng thấy nó hơi lôi thôi do nó chỉ có tác dụng phát một và thực sự là mình cũng chưa quen dùng nó nên hơi ..... sợ bác ạ.
Tỷ như khi dùng trong vòng lặp (foreach p ppl ....... ) thì phải dùng là (command "non" p) hử bác???
Mình đã sửa lại lisp ở bài post trước (cho nó đỡ tốn đất ý mà), bác thử check lại xem còn sai sót gì không nhé.
À tiện đây mình hỏi luôn là vì sao khi mình dùng (while (<= par (vlax-curve-getendparam pob)) thì với par (+ par 0.1) nó lại bị sót thằng end point của đối tượng bác nhỉ??? Tức là khi biến par có giá trị bằng với (vlax-curve-getenparam pob) thì hàm điều kiện lặp trên đây trả về nil.
Mình cũng đã thử sửa là (while (<= par (+ (vlax-curve-getendparam pob) 0.001)) thì cái điểm end point lại trả về là nil. Tức là thằng (vlax-curve-getpointatparam pob par) này trả về nil khi biến par bằng với giá trị của (vlax-curve-getendparam pob) bác ạ.
Vì thế mình chơi kiểu chuối là bỏ béng thằng này đi và chỉ lặp (while (< par (vlax-curve-getendparam pob)) rồi nhét nó vào cuối của ppl bằng:
(setq ppl (append ppl (list (vlax-curve-getendpoint pob))))
Bác có thể giải thích cho mình lý do rõ hơn được không???
Cám ơn bác nhiều,
Hề hề hế,
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#50 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 28 April 2012 - 07:42 AM

1). Việc dùng thằng "non"...
2). À tiện đây mình hỏi luôn là vì sao khi mình dùng (while (<= par (vlax-curve-getendparam pob)) thì với par (+ par 0.1) nó lại bị sót thằng end point của đối tượng bác nhỉ??? Tức là khi biến par có giá trị bằng với (vlax-curve-getenparam pob) thì hàm điều kiện lặp trên đây trả về nil.
Mình cũng đã thử sửa là (while (<= par (+ (vlax-curve-getendparam pob) 0.001)) thì cái điểm end point lại trả về là nil. Tức là thằng (vlax-curve-getpointatparam pob par) này trả về nil khi biến par bằng với giá trị của (vlax-curve-getendparam pob) bác ạ.
Vì thế mình chơi kiểu chuối là bỏ béng thằng này đi và chỉ lặp (while (< par (vlax-curve-getendparam pob)) rồi nhét nó vào cuối của ppl bằng:
(setq ppl (append ppl (list (vlax-curve-getendpoint pob))))
Bác có thể giải thích cho mình lý do rõ hơn được không???
Cám ơn bác nhiều,
Hề hề hế,

1). Khi dùng command, ở đâu có point thì trước nó phải có "non". VD: (command "move" (entlast) "" "non" p1 "non" p2)
Trong lisp của bác chỉ cần (command "non" p) là đủ. Tuy nhiên trường hợp này không nên dùng "non" vì nó lặp nhiều lần, làm chậm lisp, trong khi osnap bên ngoài thì chỉ xử 1 lần.
2). Việc chia curve này là 1 phép tính gần đúng nên điểm cuối cùng của phép chia có khi không trùng điểm cuối cùng của curve bác ạ. Tôi đã gặp sự cố này 1 lần rồi, và bác Gia bách đã phân tích như thế tôi thấy cũng hợp lý (trong mục "các lỗi thường gặp trong lập trình" í). Vì vậy, biện pháp củ chuối của bác là rất khoa học chứ không chuối chút nào cả, và tôi cũng đã dùng củ chuối này rồi đó).
  • 2

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#51 binhtl88

binhtl88

    Chưa sử dụng CAD

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

Đã gửi 28 August 2012 - 09:21 AM

Quick code


;Doan Van Ha - CADViet.com - Ngay 04/4/2012
;Muc dich: Convert cac Lwpolyline duoc chon thanh cac Wipeout.
(defun C:HA1( / cmd entlst xoa)
(command "undo" "be")
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE")))))))
(initget "X K") (setq xoa (getkword "\n[Xoa/Khong xoa] pline cu <X>: "))
(if (= xoa "K") (setq xoa "N") (setq xoa "Y"))
(foreach ent entlst
(setq lst (acet-geom-vertex-list ent))
(cond
((= 1 (cdr (assoc 70 (entget ent))))
(command "wipeout" "p" ent xoa))
((and (= 0 (cdr (assoc 70 (entget ent)))) (equal (car lst) (last lst) 1E-8))
(entmod (subst (cons 70 1) (assoc 70 (entget ent)) (entget ent)))
(command "wipeout" "p" ent xoa))))
(setvar "cmdecho" cmd)
(command "undo" "end")
(princ))
P/S (17h15' ngày 05/4/2012): Hiệu chỉnh để wipeout được với cả Lwpolyline kín nhưng open.

Anh ơi nhưng dùng lệnh này như thế nào ạ? e load lisp xòn ko biết thế nào nữa
  • 0

#52 congzui

congzui

    biết vẽ circle

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

Đã gửi 10 October 2012 - 05:14 PM

@ Doan Van Ha

Bac Doan Van Ha oi. Mình muốn cách nào để che giống như trong file đính kèm mà không phải dùng lệnh trim.

Thanks
  • 0

#53 congzui

congzui

    biết vẽ circle

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

Đã gửi 10 October 2012 - 05:18 PM

Sorry mình chưa upload file. File link bên dưới
http://www.cadviet.c.../3/50632_01.dwg
  • 0

#54 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 10 October 2012 - 06:11 PM

Bạn tải lisp từ link này (anh Ketxu hợp tác với nước ngoài). Load. Dùng lệnh OB2WO. Nhưng không như ý tuyệt đối được.
http://xaydungit.vn/...79#post14880779
  • 0

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#55 congzui

congzui

    biết vẽ circle

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

Đã gửi 11 October 2012 - 02:58 PM

Bạn tải lisp từ link này (anh Ketxu hợp tác với nước ngoài). Load. Dùng lệnh OB2WO. Nhưng không như ý tuyệt đối được.
http://xaydungit.vn/...79#post14880779

Doan Van Ha ơi, với yêu cầu file CAD link ở trên, Ha sử dụng lisp của Ketxu làm được không? Sao mình che không được. Nếu Ha làm được xin chỉ giáo nhé
  • 0

#56 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 11 October 2012 - 03:12 PM

Tôi đã test rồi mới giới thiệu cho bạn chứ. Chỉ có 2 điều:
1). Cái đường trục nằm ngang, sau khi wipeout, bạn cần vẽ lại.
2). Phần đường cong: không che tuyệt đối. Lý do: khi wipeout người ta chỉ làm gần đúng bằng cách vi phân đường cong thành từng đoạn nhỏ.
  • 1

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#57 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 October 2012 - 03:18 PM

Do bài toán của bạn dở chừng, thằng che thằng k che.
- Nếu chỉ cần kết quả mà k cần giữ nguyên gốc
+ Lisp : Rỗi thì mình có thể giúp bạn k che đường tim, còn tạm thời bạn cứ .... vẽ lại hoặc set top draw order cho nó ^^
+ Tay : extrim

- Nêú cần kết quả + gốc + thuận tiện :
Bạn nghiên cứu 3 chủ đề : Wipeout + Draw Order + Stretch Dynamic Block. Đảm bảo làm một lần sướng luôn :D
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#58 congzui

congzui

    biết vẽ circle

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

Đã gửi 11 October 2012 - 04:05 PM

Tôi đã test rồi mới giới thiệu cho bạn chứ. Chỉ có 2 điều:
1). Cái đường trục nằm ngang, sau khi wipeout, bạn cần vẽ lại.
2). Phần đường cong: không che tuyệt đối. Lý do: khi wipeout người ta chỉ làm gần đúng bằng cách vi phân đường cong thành từng đoạn nhỏ.


Mình vẫn không làm được
Các bước mình làm như sau:
Command: ob2wo
Select objects: Sau đó mình chọn đường polyline
Select objects: 1 found
Enter
Delete source objects: (yes/no): mình chọn yes hoặc no đều không nhìn thấy polyline này che polyline kia
Không biết cần chọn gì thêm không? Xin chỉ giáo
  • 0

#59 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5447 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 11 October 2012 - 04:17 PM

Ái dà! Nó còn 1 dòng lỗi nữa mà bạn không thông báo.
; error: bad function: #<SUBR @098d7b68 -lambda->
Thôi thì, đành lấy cái này vậy. Cũng chính là lisp đó, tôi down về rồi sửa gì để hết lỗi thì bây giờ quên mất. Bạn dùng nó nhé!

;;; OB2WO (gile) -Gilles Chanteau- 10/03/07
;;; UPDATE BY KETXU (04/04/2012)
;;; Creates a "Wipeout" from an object (circle, ellipse, or polyline with arcs)
;;; Works whatever the current ucs and object OCS
;http://xaydungit.vn/diendan/showthread.php?7784-Wipe-PLine-v%C3%A0-b%E1%BA%ADt-t%E1%BA%AFt-nhanh-Wipeout&p=14880779#post14880779
;----- Chuyen ss thanh cac Wipeout.
(defun c:ob2wo (/ ent lst nor ss)
(vl-load-com)
(if (setq ss (ssget (list (cons 0 "CIRCLE,ELLIPSE,LWPOLYLINE"))))
(progn
(vla-StartundoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(initget "Yes No")
(setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))
(foreach ent (ST:Ss->ListEnt ss)
(setq lst (ent2ptlst ent))
(setq nor (cdr (assoc 210 (entget ent))))
(makeWipeout lst nor)
(if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel ent))
)
(vla-EndundoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
)
)
)
;----- Bat/Tat qua lai giua Wipeout va Pline
;; WOF (gile)
;; Toggles wipeout frames
(defun c:wof (/ elst)
(cond
((and
(setq elst (dictsearch (namedobjdict) "ACAD_WIPEOUT_VARS"))
(ssget "x" '((0 . "WIPEOUT,INSERT")))
)
(entmod (subst (cons 70 (boole 6 (cdr (assoc 70 elst)) 1)) (assoc 70 elst) elst))
(vlax-for obj (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object)))
(vla-update obj)
)
)
(T (princ "\nHave no wipeout object !"))
)
(princ)
)
;----- Chuyen cac Wipeout thanh Pline
;; WO2PL (gile)
;; Re-creates a wipeout boundary (lwpolyline)
(defun c:wo2pl (/ ss n wo elst pts norm ans)
(if (setq ss (ssget '((0 . "WIPEOUT"))))
(progn
(initget "Yes No")
(setq ans (getkword "\nDelete source object? [Yes/No] <No>: "))
(foreach wo (ST:Ss->ListEnt ss)
(setq
elst (entget wo)
norm (vunit (v^v (cdr (assoc 11 elst)) (cdr (assoc 12 elst))))
pts (wipeout2plst wo)
)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts))
(cons 38 (caddr (trans (car pts) 0 norm)))
'(70 . 1)
(cons 210 norm)
)
(mapcar '(lambda (pt)
(setq pt (trans pt 0 norm))
(list 10 (car pt) (cadr pt))
)
pts
)
)
)
(if (or (not ans) (wcmatch (strcase ans) "YES"))(entdel wo))
(princ)
)))
)
;;==================SUB ROUTINES==================;;
;; returns the wipeout point list (WCS)
(defun wipeout2plst (wo / elst u v mat)
(setq elst (entget wo)
u (cdr (assoc 11 elst))
v (cdr (assoc 12 elst))
mat (list u (mapcar '- v) '(0. 0. 1.))
)
(mapcar
'(lambda (p)
(mapcar '+
(mxv (trp mat) p)
(mapcar '(lambda (x y) (/ (+ x y) 2.)) u v)
(cdr (assoc 10 elst))
)
)
(cdr
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 14)) elst)
)
)
)
)
;; Transpose a matrix Doug Wilson
(defun trp (m)
(apply 'mapcar (cons 'list m))
)
;; Apply a transformation matrix to a vector by Vladimir Nesterovsky
(defun mxv (m v)
(mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
)
;; V^V
;; Returns the cross product of 2 vectors
(defun v^v (v1 v2)
(list (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
(- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
(- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
)
)
;; VUNIT
;; Returns the single unit vector
(defun vunit (v)
((lambda (l)
(if (/= 0 l)
(mapcar (function (lambda (x) (/ x l))) v)
)
)
(distance '(0 0 0) v)
)
)


;;; ENT2PTLST
;;; Returns the vertices list of the polygon figuring the curve object
;;; Coordinates defined in OCS

(defun ent2ptlst (ent / obj dist n lst p_lst prec)
(vl-load-com)
(if (= (type ent) 'ENAME)
(setq obj (vlax-ename->vla-object ent))
)
(cond
((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
50
)
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
(vlax-get obj 'Normal)
)
lst
)
)
)
)
(T
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 42)
)
)
(entget ent)
)
)
(while p_lst
(setq
lst
(cons
(append (cdr (assoc 10 p_lst))
(list (cdr (assoc 38 (entget ent))))
)
lst
)
)
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 25 (sqrt (abs (cdadr p_lst))))))
dist (/ (- (if (cdaddr p_lst)
(vlax-curve-getDistAtPoint
obj
(trans (cdaddr p_lst) ent 0)
)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
(vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst (cons
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
(* dist (setq n (1+ n)))
)
)
0
ent
)
lst
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
lst
)


;;; MakeWipeout creates a "wipeout" from a points list and the normal vector of the object

(defun MakeWipeout (pt_lst nor / dxf10 max_dist cen dxf_14)
(if (not (member "acwipeout.arx" (arx)))
(arxload "acwipeout.arx")
)
(setq dxf10 (list (apply 'min (mapcar 'car pt_lst))
(apply 'min (mapcar 'cadr pt_lst))
(caddar pt_lst)
)
)
(setq
max_dist
(float
(apply 'max
(mapcar '- (apply 'mapcar (cons 'max pt_lst)) dxf10)
)
)
)
(setq cen (mapcar '+ dxf10 (list (/ max_dist 2) (/ max_dist 2) 0.0)))
(setq
dxf14 (mapcar
'(lambda (p)
(mapcar '/
(mapcar '- p cen)
(list max_dist (- max_dist) 1.0)
)
)
pt_lst
)
)
(setq dxf14 (reverse (cons (car dxf14) (reverse dxf14))))
(entmake (append (list '(0 . "WIPEOUT")
'(100 . "AcDbEntity")
'(100 . "AcDbWipeout")
'(90 . 0)
(cons 10 (trans dxf10 nor 0))
(cons 11 (trans (list max_dist 0.0 0.0) nor 0))
(cons 12 (trans (list 0.0 max_dist 0.0) nor 0))
'(13 1.0 1.0 0.0)
'(70 . 7)
'(280 . 1)
'(71 . 2)
(cons 91 (length dxf14))
)
(mapcar '(lambda (p) (cons 14 p)) dxf14)
)
)
)

(defun ST:Ss->ListEnt (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
)
)

  • 1

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#60 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 11 October 2012 - 04:45 PM

Lỗi tag PHP của 4room VBB tự động xóa bỏ dấu ' đằng trước chữ (lambda ... ở hàm gần cuối nên sinh ra vậy. Ketxu đã sửa tag thành code cho an toàn (lần sau dùng funtion cho lành ^^)
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC