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.
Jin Yong

Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

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

Tr.CongSon    41

Chào các anh chị,

Em mới học Lisp,mong mọi người giúp đỡ nhiều ạ

Em có đoạn Code sau

(defun c:CM (/ *error* cla ent-last iferror k lay olderr os pause r ve vec);;;; tao cloud mark;
(setvar "modemacro" "CREATE CLOUD_MARK")
;;; (setvar "CMDECHO" 0)
(command "undo" "BE")
(defun iferror (msg)
(if (= cla nil)
(setq cla "3"))
(if cla (setvar "CLAYER" cla))
(if os (setvar "OSMODE" os))
(setvar "CMDECHO" 1)
(setq *error* olderr)
(princ)
)
(setq lay (tblsearch "layer" "Cloud mark"))
(if (= lay nil)
(command "_layer" "_n" "Cloud mark" "_c" "6" "Cloud mark" ""))
(setq olderr *error*)
(setq *error* iferror)
(graphscr)
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq cla (getvar "CLAYER"))
(setq r (* (getvar "DIMSCALE") 5))
(setq k T)
(while k
(terpri)
(if (= ve nil) (setq ve "Hinh chu nhat"))
(setq vec (strcat "\nVe hinh chu nhat hay duong line? <" ve ">: "))
(setq vec (getstring vec))
(if (= vec "")
(command "_.RECTANGLE")
(command "_.pline"))
(while (= 1 (getvar "cmdactive")) (command pause))
(setq ent-last (entlast))
(setvar "clayer" "Cloud mark")
(command "_.REVCLOUD" "_A" r r "_Object" ent-last "")
)
(setvar "CLAYER" cla)
(setq *error* olderr)
(setvar "OSMODE" os)
(command "undo" "End")
;;; (setvar "CMDECHO" 1)
(princ)
)
 

Code đây em sưu tầm về dung,không hiểu sao mấy hôm trước em dùng bình thường nhưng tự nhiên hôm nay em dùng lại bị lỗi ak

Em chạy từng dòng trong code thì oki nhưng chạy cả  lệnh thì lại bị lỗi ạ

Mong mọi người giải đáp giúp em

Chúc mọi người đầu tuần vui vẻ

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
Tr.CongSon    41

Chào các anh chị,

Em mới học Lisp,mong mọi người giúp đỡ nhiều ạ

Em có đoạn Code sau

(defun c:CM (/ *error* cla ent-last iferror k lay olderr os pause r ve vec);;;; tao cloud mark;

(setvar "modemacro" "CREATE CLOUD_MARK")

;;; (setvar "CMDECHO" 0)

(command "undo" "BE")

(defun iferror (msg)

(if (= cla nil)

(setq cla "3"))

(if cla (setvar "CLAYER" cla))

(if os (setvar "OSMODE" os))

(setvar "CMDECHO" 1)

(setq *error* olderr)

(princ)

)

(setq lay (tblsearch "layer" "Cloud mark"))

(if (= lay nil)

(command "_layer" "_n" "Cloud mark" "_c" "6" "Cloud mark" ""))

(setq olderr *error*)

(setq *error* iferror)

(graphscr)

(setq os (getvar "OSMODE"))

(setvar "OSMODE" 0)

(setq cla (getvar "CLAYER"))

(setq r (* (getvar "DIMSCALE") 5))

(setq k T)

(while k

(terpri)

(if (= ve nil) (setq ve "Hinh chu nhat"))

(setq vec (strcat "\nVe hinh chu nhat hay duong line? <" ve ">: "))

(setq vec (getstring vec))

(if (= vec "")

(command "_.RECTANGLE")

(command "_.pline"))

(while (= 1 (getvar "cmdactive")) (command pause))

(setq ent-last (entlast))

(setvar "clayer" "Cloud mark")

(command "_.REVCLOUD" "_A" r r "_Object" ent-last "")

)

(setvar "CLAYER" cla)

(setq *error* olderr)

(setvar "OSMODE" os)

(command "undo" "End")

;;; (setvar "CMDECHO" 1)

(princ)

)

 

Code đây em sưu tầm về dung,không hiểu sao mấy hôm trước em dùng bình thường nhưng tự nhiên hôm nay em dùng lại bị lỗi ak

Em chạy từng dòng trong code thì oki nhưng chạy cả  lệnh thì lại bị lỗi ạ

Mong mọi người giải đáp giúp em

Chúc mọi người đầu tuần vui vẻ

Mọi người giải thích giúp em với

Chỗ đoạn màu đỏ ,không hiểu sao nó không cho pick điểm mà nó sang thực hiện đoạn xanh luôn ạ

Nhưng em chạy từng dòng code lại không bị lỗi trên,khi chạy cả code thì lại bị như vậy

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
Tr.CongSon    41

Chào các anh chị,

Em có 1 bài toán  như sau,mong anh chị giúp em code vài dòng hoặc giúp em thuật toán ạ,

Em có 1 danh sach các điểm  là

  • lstpoint (p1 p2...pn ) với n>=3 ,đây là danh sách các toạ độ điểm đã được sắp xếp theo hướng tăng dần của toạ độ x
  • Điều em cần là làm sao so sánh được các khoảng cách của các toạ độ lien tiếp nhau có bằng nhau hay không để đo kích thước ạ.

Nếu khác nhau thì gán toạ độ đó vào list : lst1 (loai ra khỏi tập lstpoint)

Nếu  bằng nhau thì gán tọa độ đó vào list : lst2 (loai ra khỏi tập lstpoint)

  • Mục đích của em  là để đo kích thước các lỗ bolt liên tiếp nhau,nếu nó bằng nhau thì edit đường đo kích thước các bolt liên tiếp là ( (n-1)@ khoangcachbolt) giống như biểu diễn bước thép trong xây dựng vậy ạ ,nếu nó không bằng thì đo kích thước từng cặp sai khác đó ạ

Em giải thích vậy mong mọi người giúp,vì công ty em không cho upload file nên đành phải diễn dãi thành lời suông vậy ạ

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
Tue_NV    3.841

Chào các anh chị,

Em có 1 bài toán  như sau,mong anh chị giúp em code vài dòng hoặc giúp em thuật toán ạ,

Em có 1 danh sach các điểm  là

  • lstpoint (p1 p2...pn ) với n>=3 ,đây là danh sách các toạ độ điểm đã được sắp xếp theo hướng tăng dần của toạ độ x
  • Điều em cần là làm sao so sánh được các khoảng cách của các toạ độ lien tiếp nhau có bằng nhau hay không để đo kích thước ạ.

Nếu khác nhau thì gán toạ độ đó vào list : lst1 (loai ra khỏi tập lstpoint)

Nếu  bằng nhau thì gán tọa độ đó vào list : lst2 (loai ra khỏi tập lstpoint)

  • Mục đích của em  là để đo kích thước các lỗ bolt liên tiếp nhau,nếu nó bằng nhau thì edit đường đo kích thước các bolt liên tiếp là ( (n-1)@ khoangcachbolt) giống như biểu diễn bước thép trong xây dựng vậy ạ ,nếu nó không bằng thì đo kích thước từng cặp sai khác đó ạ

Em giải thích vậy mong mọi người giúp,vì công ty em không cho upload file nên đành phải diễn dãi thành lời suông vậy ạ

Chào bạn!

Chỗ dòng màu xanh là mình không hiểu 

"Nếu khác nhau thì gán toạ độ đó vào list : lst1 (loai ra khỏi tập lstpoint)"

Toạ độ đó là toạ độ nào bạn? Khi bạn so sánh kích thước liên tiệp nhau tương ứng với 3 điểm p1, p2, p3

Vậy khác nhau thì gán cả 3 toạ độ p1, p2, p3 vào lst1 sao 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
Tr.CongSon    41

Chào bạn!

Chỗ dòng màu xanh là mình không hiểu 

"Nếu khác nhau thì gán toạ độ đó vào list : lst1 (loai ra khỏi tập lstpoint)"

Toạ độ đó là toạ độ nào bạn? Khi bạn so sánh kích thước liên tiệp nhau tương ứng với 3 điểm p1, p2, p3

Vậy khác nhau thì gán cả 3 toạ độ p1, p2, p3 vào lst1 sao bạn?

Dạ chắc do em trình bày chưa kỹ,ý em muốn gán vào 1 cái list để cần dùng giải quyết đoạn sau ạ (loại ra hay không cũng được )

Do em cũng mới tập tành học lisp nên muốn hỏi cách code để làm các bài toán tương tự sau này

Em trình bày cụ thể như sau ,a Tue_NV xem có cách gì giải quyết được không ạ

Đề: Em có 1 hàng là các điểm (cụ thể là center của bulong) ,em đã sắp xếp theo thứ tự tăng dần theo x hoặc theo y rồi.

Yêu cầu:

  • Vì chưa biết khoảng cách các bolt liên tiếp có bang nhau hay không,nên phải đo kích thước lần lượt từ đầu đến cuối,nếu khoảng cách khác nhau thì đo 1 kích thước qua 2 điểm đó,
  • nếu  bang nhau thì xét tiếp khoảng cách tiếp theo....Cứ tiếp tục như vậy ạ.Bằng nhau thì đo từ điểm đầu đến điểm cuối của các bolt bang nhau này
  • .Nếu khoảng cách tiếp theo khac nhau thì cứ đo kích thước 2 điểm....

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
Tr.CongSon    41

 

Toạ độ đó là toạ độ nào bạn? Khi bạn so sánh kích thước liên tiệp nhau tương ứng với 3 điểm p1, p2, p3

Vậy khác nhau thì gán cả 3 toạ độ p1, p2, p3 vào lst1 sao bạn?

Dạ ,ví dụ em có (1 2 3 4 5 ) điểm

đầu tiên lấy 1 2 3 để so sánh khoảng cách (1->2) và (2->3)

  • Nếu khác nhau thì đo kích thước 1 2 hoặc đưa vào list lst1
  • Nều bang nhau thì lưu vao lst2 rồi lấy tiếp 2 3 so sánh với 3 4
  • nêu bang nhau thì đưa vào lst2 nếu khác nhau thì đo kích thước 2 3 4 rồi edit lại( 2@k/cach)
  • Tiếp tục cho đến hết danh sách ạ

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
snowman.hms    30

;; Arguments:
;; l : list points
;; fuz : fuzz factor
;; Return: list of two elements

(defun _group (l fuz / f a l1 l2)

(defun f (l / x y d rtn)
(repeat (1- (length l))
(setq x (car l)
y (cadr l)
l (cdr l)
d (distance x y)
rtn (cons (list d (list x y)) rtn)
)
)
rtn
)

(setq l (f l))
(setq l (vl-sort l (function (lambda (a b) (>= (car a) (car b))))))
(while l
(setq a (list (car l))
l (cdr l)
)
(foreach x l
(if (equal (caar a) (car x) fuz)
(setq a (cons (cons (car x) (append (cdr x) (cdar a))) (cdr a))
l (vl-remove x l)
)
)
)
(if (< 1 (length (cdar a)))
(setq l1 (cons a l1))
(setq l2 (cons a l2))
)
)
(list (apply 'append l1) (apply 'append l2))
)

Trường hợp của bạn:
(setq lst (_group lstpoint 1e-3)
lst1 (car lst) - cùng khoảng cách
lst2 (cadr lst) - khác khoảng cách
)
  • 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
Tr.CongSon    41
;; Arguments:
;; l   : list points
;; fuz : fuzz factor
;; Return: list of two elements

(defun _group (l fuz / f a l1 l2)

  (defun f (l / x y d rtn)
    (repeat (1- (length l))
      (setq x	(car l)
	    y	(cadr l)
	    l	(cdr l)
	    d	(distance x y)
	    rtn	(cons (list d (list x y)) rtn)
      )
    )
    rtn
  )
  
  (setq l (f l))
  (setq l (vl-sort l (function (lambda (a b) (>= (car a) (car b))))))
  (while l
    (setq a (list (car l))
	  l (cdr l)
    )
    (foreach x l
      (if (equal (caar a) (car x) fuz)
	(setq a	(cons (cons (car x) (append (cdr x) (cdar a))) (cdr a))
	      l	(vl-remove x l)
	)
      )
    )
    (if	(< 1 (length (cdar a)))
      (setq l1 (cons a l1))
      (setq l2 (cons a l2))
    )
  )
  (list (apply 'append l1) (apply 'append l2))
)

Trường hợp của bạn:
(setq lst  (_group lstpoint 1e-3)
      lst1 (car lst)  - cùng khoảng cách
      lst2 (cadr lst)  - khác khoảng cách
)

Lisp chạy ra bị lỗi : bad argument type: 2D/3D point: nil bạn snowman ạ

Để mình kiểm tra sửa lại xem thử được ko

Cảm ơn bạn nhiều!

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
snowman.hms    30

Lisp chạy ra bị lỗi : bad argument type: 2D/3D point: nil bạn snowman ạ

Để mình kiểm tra sửa lại xem thử được ko

Cảm ơn bạn nhiều!

 

bạn gửi lên lstpoint của bạn xem. mình đã test trên máy ok mà!

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
Tr.CongSon    41

bạn gửi lên lstpoint của bạn xem. mình đã test trên máy ok mà!

 Đoạn code mình test đây bạn,nó bị lỗi lst2 ak.Bạn xem lại giúp mình với

Kiểu viết của bạn hơi cao so với trình độ mình nên đang cố đọc cho thấm thử mình sửa được ko.hic

 

(setq lstpt (acet-ss-to-list (ssget '((0 . "CIRCLE") (8 . "Bolt"))))

lstpt (vl-sort lstpt '(lambda (e1 e2)

(< (cadr (assoc 10 (entget e1)))

(cadr (assoc 10 (entget e2))))))

lstpt (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) lstpt)

)

(setq lst (_group lstpt 1e-3)

lst1 (car lst)

lst2 (cadr lst) ;;cai lst 2 nay nil

)

 

File em update có tất cả các trường hợp,

Mọi người giúp em với ạ

http://www.cadviet.com/upfiles/4/142392_do_bolt.dwg

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
Tr.CongSon    41

Lstpoint cua ban ko phai list point!

Code cua ban sai!

Dxf 0 la etype, dxf 10 la insertionpoint nhe :)

 

Listpoint là đoạn này mà bạn

(mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) lstpt)

mã dxf 10 là center của cái circle mà^^

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
snowman.hms    30

Xin lỗi bạn vì vừa rồi  mình ko có máy để test!

Mình đã test trên file của bạn hoàn toàn ok!

mình giải thíc thêm:

- lst1 là list bao gồm các "cặp" có cùng "khoảng cách"

 

- lst2 là list bao gồm các "cặp" có  "khoảng cách" là duy nhất

 

ví dụ

lstpt:

(
    (2784.0 527.0 0.0)
    (2878.5 527.0 0.0)
    (2987.5 527.0 0.0)
    (3082.0 527.0 0.0)
    (3270.5 527.0 0.0)
    (3365.0 527.0 0.0)
    (3492.5 527.0 0.0)
    (3587.0 527.0 0.0)
)
 

--->lst:

 (

    (
        (
            94.5
            (
                (3492.5 527.0 0.0)
                (3587.0 527.0 0.0)
            )
            (
                (3270.5 527.0 0.0)
                (3365.0 527.0 0.0)
            )
            (
                (2987.5 527.0 0.0)
                (3082.0 527.0 0.0)
            )
            (
                (2784.0 527.0 0.0)
                (2878.5 527.0 0.0)
            )
        )
    );---->llst1
    (
        (
            109.0
            (
                (2878.5 527.0 0.0)
                (2987.5 527.0 0.0)
            )
        )
        (
            127.5
            (
                (3365.0 527.0 0.0)
                (3492.5 527.0 0.0)
            )
        )
        (
            188.5
            (
                (3082.0 527.0 0.0)
                (3270.5 527.0 0.0)
            )
        )
    );---->llst2
);---->lst
  • 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
Tr.CongSon    41

 Cảm ơn snowman.hms nhiều,nhưng còn trường hợp 1  trong file mình gởi ở trên  có kcach (70,2@80,70,2@80) thì có cách nào lấy được ko ạ

Em đang sửa của anh cho phù hợp với bài toán cụ thể của em,

Cách dùng hàm cons để tạo danh sách hay thật,lâu nay toàn dùng append không à,

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
Doan Van Ha    2.676

Tặng NS TCS cái này. Thêm mắm muối là tùy bạn, tôi chỉ làm đến phần cơ bản thôi. Đã test 5 trường hợp trên bản vẽ của bạn.

 

(defun C:HA(/ lst)
 (princ "\nChon cac bulon...")
 (setq lst (acet-ss-to-list (ssget '((0 . "CIRCLE") (8 . "Bolt"))))
       lst (vl-sort lst '(lambda (e1 e2) (< (cadr (assoc 10 (entget e1))) (cadr (assoc 10 (entget e2))))))
       lst (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) lst))
 (setq lst (mapcar 'distance lst (cdr lst)))
 (#List:Seplst lst))
(defun #List:Seplst (lst / i it rt tLst)
 (setq i -1)
 (while (setq it (nth (setq i (1+ i)) lst))
  (if (eq (last tLst) it)
   (setq tLst (append tLst (list it)))
   (setq rt (append rt (list tLst)) tLst (list it))))
 (cdr (append rt (list tLst))))
  • 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
Tr.CongSon    41

Cảm ơn a Hạ,

Sẵn tiện cho em hỏi lisp em post ở bài viết #2052 và #2053 bị lỗi gì mà khi chạy cả lisp nó bị lỗi còn chạy từng đoạn code thì không bị ạ

http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/?p=348969

Em cảm ơ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
snowman.hms    30

...sửa ... cho phù hợp với bài toán cụ thể của em,

 

Trả về theo thứ tự trái-> phải và theo định dạng (..(duplicate distance (startpoint endpoint))..) 

(defun C:test ( / l p s spc )
  (setq
    spc	(vlax-get (vla-get-activedocument (vlax-get-acad-object))
		  (if (eq (getvar 'CVPORT) 1)
		    'Paperspace
		    'Modelspace
		  )
	)
  )
  (if
    (and (princ "\nChon cac bulon...")
	 (setq l (acet-ss-to-list (ssget '((0 . "CIRCLE") (8 . "Bolt")))))
	 (setq l (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) l))
	 (setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
    )
     (progn
       (setq l (f l))
       (setq p (getpoint "\nSpecify point for Dimensions..."))
       (foreach	x l
	 (if (< 1 (car x))
	   (setq s (strcat (itoa (car x)) "@" (rtos (cadr x) 2 2)))
	   (setq s (rtos (cadr x) 2 2))
	 )
	 (_dimaligned spc (car (last x)) (cadr (last x)) p s)
       )
     )
  )
  (princ)
)
(defun f (l / a b d tm i l1)
  (setq	l (mapcar '(lambda (a b) (list (distance a b) (list a b))) l (cdr l)))
  (while l
    (setq a  (car l)
	  d  (car a)
	  tm (list (caadr a))
	  l  (cdr l)
	  i  1
    )
    (while (= (car a) (caar l))
      (setq b  (car l)
	    i  (1+ i)
	    tm (cons (cadadr b) tm)
	    l  (cdr l)
      )
    )
    (if	(< 1 i)
      (setq l1 (cons (list i d (list (last tm) (car tm))) l1))
      (setq l1 (cons (vl-list* 1 a) l1))
    )
  )
  (reverse l1)
)
(defun _dimaligned (spc p1 p2 pt str)
  (vlax-put (vlax-invoke spc 'adddimaligned p1 p2 pt) 'textoverride str)
)
Chỉnh sửa theo snowman.hms

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
Doan Van Ha    2.676

Cảm ơn a Hạ,

Sẵn tiện cho em hỏi lisp em post ở bài viết #2052 và #2053 bị lỗi gì mà khi chạy cả lisp nó bị lỗi còn chạy từng đoạn code thì không bị ạ

http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/?p=348969

Em cảm ơn

Thay:

(command "_.RECTANGLE")

Bằng:

(command "_.RECTANGLE" (setq p1 (getpoint "\nP1: ")) (getcorner p1 "\nP2: "))

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
Tr.CongSon    41

;; free lisp from cadviet.com

;;; this lisp was downloaded from

;;; http://www.cadviet.com/forum/topic/14210-hoi-ve-lisp-thuat-toan-y-tuong-coding/page-126

(defun C:test (/ l p s spc)

 (setq

  spc (vlax-get (vla-get-activedocument (vlax-get-acad-object))

         (if (eq (getvar 'CVPORT) 1)

          'Paperspace

          'Modelspace

         )

    )

 );;;Đoạn này có tác dung gì ạ???

 (if

  (and

   (princ "\nChon cac bulon...")

   (setq l (acet-ss-to-list (ssget '((0 . "CIRCLE") (8 . "Bolt")))))

   (setq l (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) l))

   (setq l (vl-sort l '(lambda (a b ) (< (car a) (car b ))))

      p1 (car l)

      p2 (car (reverse l)))

  );;Dòng này em hiểu ^

   (progn

    (setq l (f l))

    (setq p (if (< (setq goc (angle p1 p2)) (/ pi 2))

          (polar p2 (+ goc (/ pi 2))     (* 20 (getvar "dimscale")))

          (polar p1  (- goc (* 3 (/ pi 2))) (* 20 (getvar "dimscale")))));;Dòng này em thêm để tự set điểm đặt dimension

    (foreach x l

     (if (< 1 (car x))

      (progn

        (setq s (strcat (itoa (car x)) "@" (rtos (cadr x) 2 0)))

       (_dimaligned spc (car (last x)) (cadr (last x)) p s)

      )

       (progn

       (setq s (rtos (cadr x) 2 0))

       (_dimaligned spc (car (last x)) (cadr (last x)) p "<>");;Dấu "<>" em tự thêm vào để trở về kích thước that nếu số luợng =1,nhưng còn cách nào khác để dim kích thước thật chỗ này nếu ko dung command ko a??

      )

     )

    )

   )

 )

 (princ)

)

(defun f (l / a b d tm i l1 x)

 (setq l (mapcar '(lambda (a b ) (list (distance a b ) (list a b )))

         l

         (cdr l)

     )

 );;Tạo list gồm ( dis (tọa độ))

 (while l

  (setq a  (car l);;lấy phần tử đầu của l

     d  (car a);;lấy phần tử đầu của a tức là dis 

    tm (list (caadr a));;;Cái này lấy phần tử thứ 2 của thằng a,nhưng em chưa hiểu cái caadr là gộp của car với gì ,em chưa hiểu nguyên tắc ghép-->anh giải thích giúp em ...

     l  (cdr l);;lấy phần tử từ thứ 2 trở đi của l

     i  1

  )

  (while (= (car a) (caar l))

   (setq b  (car l)

      i  (1+ i)

      tm (cons (cadadr b ) tm)

      l  (cdr l)

   )

  );;đoạn while ni để tìm số phần tử going nhau đúng ko ạ,nhưng em chưa hiểu cách thức thực hiện...

  (if (< 1 i)

   (setq l1 (cons (list i d (list (last tm) (car tm))) l1))

   (setq l1 (cons (vl-list* 1 a) l1));;;cái vl-list này có tác dung gì ạ???

  )

 )

 (reverse l1)

)

(defun _dimaligned (spc p1 p2 pt str)

 (vlax-put (vlax-invoke spc 'adddimaligned p1 p2 pt) 'textoverride str);;;vl-invoke có tác dung gì hả a??

 (vlax-put-property (vlax-ename->vla-object (entlast)) 'TextInside -1);;cái này em tự thêm vào để trả về dimension luôn giữa 2 đường going kích thước

)

 

 Cảm ơn snowman.hms & a Hạ nhiều

Em ngồi từ sáng đến chừ nghiên cứu gộp  2 đoạn lisp của 2 anh mà dễ tẩu hỏa nhập ma quá^^

Đang gộp của a Hà để thêm tọa độ tương ứng nữa mà a đã giúp em luôn rồi^^

Em tự tìm hiều code của anh ,nhưng có một số chỗ không hiểu ,và cái thuật toán a làm như thế nào ạ

Mong các anh chị giải thích giúp em với,

Em cảm ơn nhiều!

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
snowman.hms    30

(defun C:test (/ l p s spc)
 (setq
  spc (vlax-get (vla-get-activedocument (vlax-get-acad-object))
         (if (eq (getvar 'CVPORT) 1)
          'Paperspace
          'Modelspace
         )
    )
 );;;Đoạn này có tác dung gì ạ???: trả về vla-object, space hiện hành (model hay paper space)
 (if
  (and
   (princ "\nChon cac bulon...")
   (setq l (acet-ss-to-list (ssget '((0 . "CIRCLE") (8 . "Bolt")))))
   (setq l (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) l))
   (setq l (vl-sort l '(lambda (a b ) (< (car a) (car b ))))
      p1 (car l)
      p2 (car (reverse l)))
  );;Dòng này em hiểu ^
   (progn
    (setq l (f l))
    (setq p (if (< (setq goc (angle p1 p2)) (/ pi 2))
          (polar p2 (+ goc (/ pi 2))     (* 20 (getvar "dimscale")))
          (polar p1  (- goc (* 3 (/ pi 2))) (* 20 (getvar "dimscale")))));;Dòng này em thêm để tự set điểm đặt dimension
    (foreach x l
     (if (< 1 (car x))
      (progn
        (setq s (strcat (itoa (car x)) "@" (rtos (cadr x) 2 0)))
       (_dimaligned spc (car (last x)) (cadr (last x)) p s)
      )
       (progn
       (setq s (rtos (cadr x) 2 0))
       (_dimaligned spc (car (last x)) (cadr (last x)) p "<>");;Dấu "<>" em tự thêm vào để trở về kích thước that nếu số luợng =1,nhưng còn cách nào khác để dim kích thước thật chỗ này nếu ko dung command ko a?? (có thể thêm hàm if trong hàm con để xử lý điều khiển biến đầu vào str của hàm con

      )
     )
    )
   )
 )
 (princ)
)

(defun f (l / a b d tm i l1 x)
 (setq l (mapcar '(lambda (a b ) (list (distance a b ) (list a b )))
         l
         (cdr l)
     )
 );;Tạo list gồm ( dis (tọa độ))

 (while l
  (setq a  (car l);;lấy phần tử đầu của l
     d  (car a);;lấy phần tử đầu của a tức là dis 

    tm (list (caadr a));;;Cái này lấy phần tử thứ 2 của thằng a,nhưng em chưa hiểu cái caadr là gộp của car với gì ,em chưa hiểu nguyên tắc ghép-->anh giải thích giúp em ...

     l  (cdr l);;lấy phần tử từ thứ 2 trở đi của l: lấy phần tử đầu tiên (ca) của phần tử thứ 2 (adr) của a 

     i  1
  )
  (while (= (car a) (caar l)); duyệt phần còn lại của l, với điều kiên lặp là cùng d của phần tử a
   (setq b  (car l)
      i  (1+ i)
      tm (cons (cadadr b ) tm)
      l  (cdr l)
   )
  );;đoạn while ni để tìm số phần tử going nhau đúng ko ạ,nhưng em chưa hiểu cách thức thực hiện... duyệt qua phần còn lại của l, kiểm tra nếu cùng thì kiểm tra tiếp, cho đến khi khác  d thì thôi, mỗi lần nếu tìm được thì tăng biến i và thêm phần tử thứ 2 của phần tử thứ 2 của phần tử tìm thấy (cadadr b) vào tmp, và remove phần tử đầu tiên của l (setq l (cdr l)); trường hợp không tim được thì không làm gì (do nothing)

  (if (< 1 i)
   (setq l1 (cons (list i d (list (last tm) (car tm))) l1))
   (setq l1 (cons (vl-list* 1 a) l1));;;cái vl-list này có tác dung gì ạ??? tạo list từ các phần tử, xem trong help

  )
 )
 (reverse l1)
)
(defun _dimaligned (spc p1 p2 pt str)
 (vlax-put (vlax-invoke spc 'adddimaligned p1 p2 pt) 'textoverride str);;;vl-invoke có tác dung gì hả a?? thực thi một activex method (=vlax-invoke-method)
 (vlax-put-property (vlax-ename->vla-object (entlast)) 'TextInside -1);;cái này em tự thêm vào để trả về dimension luôn giữa 2 đường going kích thước
)

  • 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
Tr.CongSon    41

Lâu ni em toàn tự đọc trên cadviet rồi học theo nên mấy cái snowman.hsm code cao siêu that, (nhưng học được nhiều hàm rất hay ^^)

Cảm ơn anh/chị đã cung cấp kiến thức that hay ,thật bổ ích^^

Chúc anh chị đầu tuần vui vẻ,!

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
Tr.CongSon    41

Chào anh chị,

Em có bài toán như sau,mong anh chị giải đáp giúp ạ,

Em có 1 hoặc 2 hàng bolt bất kỳ (bolt trong cad là circle)

Bằng cách nào ta có thể kiểm tra được center point của bolt nằm về phía nào của đường line cho trước không ạ

Nếu bolt thẳng hàng nhau theo phương đứng hoặc phương ngang thì em so sánh toạ đọ rồi suy ra được,nhưng thẳng hàng theo phương nghiêng bất kỳ thì em không biết làm thế nào

Anh chị có thể cho em thuật toán để tìm hoặc có thể code cho em vài dòng tham khảo được không ạ

Do công ty không cho upload file nên mong anh chị thông cảm ,có thể lấy bolt theo file này ạ (bài # 2511)

http://www.cadviet.vn/download22.html#http://www.cadviet.vn/caddata/?act=download22%23http://www.cadviet.com/upfiles/4/142392_do_bolt.dwg

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
Doan Van Ha    2.676

 Chuyển UCS về để 1 trục của nó trùng với Line, khi đó so sánh X hoặc Y. Chú ý khi chuyển UCS thì phải dùng hàm trans để chuyển tọa độ.

  • 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

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


×