Đến nội dung


Hình ảnh
* * * - - 17 Bình chọn

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


  • Please log in to reply
2851 replies to this topic

#81 Ar_Chanwoo

Ar_Chanwoo

    biết lệnh break

  • Members
  • PipPipPipPip
  • 224 Bài viết
Điểm đánh giá: 38 (tàm tạm)

Đã gửi 26 March 2008 - 11:05 AM

Vấn đề không nằm ở file LISP mà nằm ở file xdtf.INI
Có một ký tự bất thường

*0*Caymb*C:\Thuvien\Thuvien\caymb
*1*DÇm*C:\Thuvien\Thuvien\Dam <-- tại dòng này
*2*Khung*C:\Thuvien\Thuvien\Khung
*3*Lanhto*C:\Thuvien\Thuvien\Lanhto
*7*LinhTinh*C:\ThuVien\Thuvien\Linhtinh
Fix lại cái này đi nha.

Cảm ơn bạn đã quan tâm! Mình Fix lại rồi nhưng không đc ! Bạn đọc lisp rồi chỉ chỗ sai cho mình với ! Mà hình như tên gốc của file INI không phải là xdtf.INI thì phải ! Mình lấy từ đâu về dùng bây giờ thấy ko dùng đc ! Vẫn mở đc giao diên của hộp thoại nhưng sau đó cad bị đơ luôn ! Còn lỗi bạn nói là do bị Font chữ ! Mong bạn giúp đỡ!
  • 0

#82 h2c

h2c

    biết vẽ ellipse

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

Đã gửi 28 March 2008 - 01:45 PM

Mình vừa viết xong lisp này để copy đối tượng align theo đường thẳng cho trước với khoảng cách xác định theo phương đứng . Nhưng mà có cái gì đó sai trong dòng command copy .
(defun c:FG()
(setq
OBJ (entsel "\nSelect object :")
LI (entget (car (entsel "\nSelect line :")))
P1 (cdr(assoc 10 LI))
P2 (cdr(assoc 11 LI))
x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
goc (atan (- y2 y1) (- x2 x1))
BP (getpoint "\nBase point :")
DI (getreal "\nVertical distance : ")
SB (getint "\nNumber of step :")
n 0
)
(while (< n SB)
(setq BP1 (polar BP goc (/ DI (cos goc))))
(command "copy" OBJ BP BP BP1 "")
(setq BP BP1)
(setq OBJ entlast)
(setq n (+ n 1))
)
(princ)
)
Cám ơn mọi người .
  • 0

#83 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 28 March 2008 - 04:20 PM

Mình vừa viết xong lisp này để copy đối tượng align theo đường thẳng cho trước với khoảng cách xác định theo phương đứng . Nhưng mà có cái gì đó sai trong dòng command copy .

(defun c:FG()
(setq
OBJ (entsel "\nSelect object :")
LI (entget (car (entsel "\nSelect line :")))
P1 (cdr(assoc 10 LI))
P2 (cdr(assoc 11 LI))
x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
goc (atan (- y2 y1) (- x2 x1))
BP (getpoint "\nBase point :")
DI (getreal "\nVertical distance : ")
SB (getint "\nNumber of step :")
n 0
)
(while (< n SB)
(setq BP1 (polar BP goc (/ DI (cos goc))))
(command "copy" OBJ BP BP BP1 "")
(setq BP BP1)
(setq OBJ entlast)
(setq n (+ n 1))
)
(princ)
)

Cám ơn mọi người .

A- Lỗi ở những chỗ đánh dấu đỏ

B- Chương trình đã sửa, giữ nguyên cấu trúc và thuật giải của bạn:

;;;-----------------------------------------------
(defun c:FG()
(setq
OBJ (entsel "\nSelect object :")
LI (entget (car (entsel "\nSelect line :")))
P1 (cdr (assoc 10 LI))
P2 (cdr (assoc 11 LI))
x1 (car P1)
y1 (cadr P1)
x2 (car P2)
y2 (cadr P2)
goc (atan (- y2 y1) (- x2 x1))
BP (getpoint "\nBase point :")
DI (getreal "\nVertical distance : ")
SB (getint "\nNumber of step :")
n 0
oldos (getvar "osmode")
)
(setvar "osmode" 0)
(while (< n SB)
(setq BP1 (polar BP goc (/ DI (sin goc))))
(command "copy" OBJ "" BP BP1 "")
(setq BP BP1)
(setq OBJ (entlast))
(setq n (+ n 1))
)
(setvar "osmode" oldos)
(princ)
)
;;;-----------------------------------------------


C- Chương trình lập theo ý ssg để bạn tham khảo:

;;;-----------------------------------------------
(defun c:FG2( / obj Li Di Sb P1 p2 goc n oldos P3)
(setq
OBJ (ssget)
LI (entget (car (entsel "\nSelect line :")))
DI (getreal "\nVertical distance : ")
SB (getint "\nNumber of step :")
P1 (cdr (assoc 10 LI))
P2 (cdr (assoc 11 LI))
goc (angle P1 P2)
n 1
oldos (getvar "osmode")
)
(if (> goc pi) (setq goc (- goc pi)))
(setvar "osmode" 0)
(repeat SB
(setq P3 (polar P1 goc (* (/ DI (sin goc)) n)))
(command "copy" OBJ "" P1 P3 "")
(setq n (1+ n))
)
(setvar "osmode" oldos)
(princ)
)
;;;-----------------------------------------------

Những khác biệt và góp ý thêm:
1) OBJ dùng ssget, bạn có thể chọn được nhiều đối tượng nếu cần. Các đối tượng được highlight, user dễ nhìn hơn (dùng entsel cũng có hightlight nhưng bạn phải thêm hàm redraw)
2) Dùng angle lấy góc đơn giản hơn, chỉ cần bổ sung thêm tình huống nếu goc > 180 độ
3) Khi số lần lặp đã xác định trước, dùng repeat nói chung là hay hơn while
4) Yêu cầu nhập Base point là không cần thiết
5) Đừng bao giờ quên disable osmode trước khi gọi các command liên quan đến thao tác vẽ
6) Tập thói quen thiết lập Local Variables như là programmer chuyên nghiệp
7) Nên thận trọng hơn trong thao tác, đừng để những lỗi cú pháp không đáng có. Một biện pháp hữu hiệu giảm thiểu lỗi là hãy viết thật rõ ràng, mạch lạc, những chỗ ra vô đầu dòng tuân theo trật tự nhất quán. Bạn có thể dùng Visual Lisp Editor để hỗ trợ
từ viết chương trình, check lỗi đến chạy thử.
  • 1

#84 h2c

h2c

    biết vẽ ellipse

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

Đã gửi 29 March 2008 - 08:27 AM

Cám ơn ssg . Nhưng cho mình hỏi là tại sao phải tạo local variable . Khi mình thử del dòng khai báo variable đi thì nó vẫn chạy tốt mà ( đây mới là chỗ mình khó hiểu ) ? Nên trước giờ mình ít khi nào khai báo như thế lắm , mong bạn giải thích thêm . Thanks .
  • 0

#85 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 29 March 2008 - 08:51 AM

Cám ơn ssg . Nhưng cho mình hỏi là tại sao phải tạo local variable . Khi mình thử del dòng khai báo variable đi thì nó vẫn chạy tốt mà ( đây mới là chỗ mình khó hiểu ) ? Nên trước giờ mình ít khi nào khai báo như thế lắm , mong bạn giải thích thêm . Thanks .

Bạn xem ở đây, trong bài 2 mình có phân tích khá kỹ về cái này:
http://www.cadviet.com/forum/Huong-dan-lap...Lisp-t2480.html

Một thử nghiệm nhỏ: chạy chương trình trên của bạn không khai báo local variables. Khi kết thúc, bạn nhập dòng sau vào Command: (setq X SB) -> kết quả trả về là SB mà bạn vừa chạy chương trình. Điều đó nghĩa là, chương trình của bạn đã kết thúc nhưng bạn vẫn chiếm dụng memory của máy tính, bắt nó phải tốn chỗ để nhớ cái giá trị không còn cần thiết cho ai nữa.
Nếu khai báo local variable, khi thực hiện xong function đó, memory được giải phóng khỏi tất cả các biến mà bạn đã khai báo sau dấu /
Ngoài ra, khi bạn lập một chương trình lớn, số lượng variables rất nhiều, chính bạn cũng không thể nhớ hết và không kiểm soát nổi chúng. Có khả năng chúng sẽ làm sai lệch kết quả chạy chương trình mà bạn không hề hay biết, đặc biệt là trong các biểu thức điều kiện trong vòng while hoặc if.
Ví dụ, sau biểu thức trên, bạn nhập tiếp: (if SB (alert "Do you need me now?")). May mà nó hỏi, còn nó im lặng làm những trò gì dại dột thì bạn lãnh đủ!
  • 2

#86 proconeng86

proconeng86

    biết lệnh break

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

Đã gửi 03 April 2008 - 08:54 AM

cho em hỏi cái này. Em có 1 lisp nhưng không hiểu ý nghĩa của nó. Bác nào giải đáp giúp em với :


(defun C:ECO ()
(start_timer)
(create_layer_table)
(if (= explode_plines? "Y")
(explode_plines))
(economize_by_layer)
(if (= compress? "Y")
(compress_by_layer))
(restore_layers)
(if (= compress? "Y")
(explode_1segment_plines))
(stop_timer))

(defun start_timer ()
(setq deleted 0
c_date (getvar "cdate")
s_date (getvar "tdusrtimer")
dwg (getvar "dwgname")
explode_plines? (strcase (userstr (if explode_plines? explode_plines? "Y")
"Explode polylines before beginning?"))
compress? (strcase (userstr (if compress? compress? "Y")
"Join touching lines into multi-segment polylines?")))
(princ (strcat "\nStarting to process drawing " dwg " on " (parse_time c_date))))
(defun stop_timer ()
(setq e_date (getvar "tdusrtimer")
t_secs (* 86400.0 (- e_date s_date))
hrs (fix (/ t_secs 3600.0))
mns (fix (/ (- t_secs (* hrs 3600.0)) 60.0))
secs (- t_secs (+ (* hrs 3600.0) (* mns 60.0))))
(if (null (setq fil (open (strcat dwg ".eco") "a")))
(progn (princ (strcat "\nCouldn't open " dwg ".eco for writing.
Writing to current directory instead."))
(setq fil (open (strcat dwg ".eco") "a"))))
(princ "\nECONOMIZE active for ")
(princ (strcat "\nStarted processing drawing " dwg " on " (parse_time c_date)) fil)
(princ "\nECONOMIZE v. 2.1 active for " fil)
(if (> hrs 0.0)
(princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ") fil))
(if (> mns 0.0)
(princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ") fil))
(princ (strcat (rtos secs 2 3) " seconds.") fil)
(princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines.") fil)
(princ "\n--------" fil)
(close fil)
(if (> hrs 0.0)
(princ (strcat (itoa hrs) " hour" (if (> hrs 1) "s" "") ", ")))
(if (> mns 0.0)
(princ (strcat (itoa mns) " minute" (if (> mns 1) "s" "") ", ")))
(princ (strcat (rtos secs 2 3) " seconds."))
(princ (strcat "\nFile: " dwg ": Deleted a total of " (itoa deleted) " redundant lines."))
(princ))

(defun economize_by_layer ()
(setq c_lay (getvar "clayer"))
; (setvar "regenmode" 0)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(setvar "osmode" 0)
(foreach lyr (mapcar 'car lyrs)
(if (and (setq lines (ssget "x" (list (cons 0 "LINE")
(cons 8 lyr)))
*lines* lines)
(setq lines_l (sslength lines)))
(process_lines lyr)))
(command "layer" "t" "*" "on" "*" "s" c_lay ""))

(defun create_layer_table ()
(setq c_lay (getvar"clayer")
lyr_data (tblnext "layer" t)
lyr_nm (cdr (assoc 2 lyr_data))
lyr_thawed? (cdr (assoc 70 lyr_data))
lyr_on? (cdr (assoc 62 lyr_data))
lyrs (list (list lyr_nm lyr_thawed? lyr_thawed?)))
(while (setq lyr_data (tblnext "layer"))
(setq lyr_nm (cdr (assoc 2 lyr_data))
lyr_thawed? (cdr (assoc 70 lyr_data))
lyr_on? (cdr (assoc 62 lyr_data))
lyrs (cons (list lyr_nm lyr_thawed? lyr_on?) lyrs))))

(defun freeze_all_but (layr)
(command "layer" "t" layr "on" layr "s" layr) ;; Thaw working layer
(foreach l (aux_remove layr (mapcar 'car lyrs)) ;; Freeze all others
(command "f" l))
(command ""))

; (70 . 64) thawed
; (70 . 65) frozen
; (62 . 7) on
; (62 . -7) off

(defun restore_layers ()
(command "layer")
(setq c_lay_data (assoc c_lay lyrs)
lyr_thawed? (cadr c_lay_data)
lyr_on? (caddr c_lay_data))
(if (= lyr_thawed? 65)
(command "f" c_lay)
(command "t" c_lay))
(if (> lyr_on? 0)
(command "on" c_lay)
(command "off" c_lay))
(command "s" c_lay)
(foreach lr (aux_remove c_lay_data lyrs);; read layer data
(setq lyr_nm (car lr) ;; from layer property table
lyr_thawed? (cadr lr)
lyr_on? (caddr lr))
(if (= lyr_thawed? 65)
(command "f" lyr_nm)
(command "t" lyr_nm))
(if (> lyr_on? 0)
(command "on" lyr_nm)
(command "off" lyr_nm)))
(command ""))

(defun process_lines (layr / incr)
(freeze_all_but layr)
(if lines (progn (terpri)
(setq incr 0
ssl (sslength lines)
l_deleted 0)
(repeat ssl
(setq ln (ssname lines incr))
(princ (strcat "\rProcessing line "
(itoa (1+ incr)) " of "
(itoa lines_l)
" on layer " layr))
(if (and ln (ssmemb ln *lines*))
(compile ln))
(setq incr (1+ incr)))))
(princ (strcat "\t\tDeleted " (itoa l_deleted) " redundant lines.")))

(defun compile (lin / ld *lin_ss ptlst ext_pts i sl)
(if lin
(progn (setq lin* lin
ld (get_line_data lin)
lin_ss (ssget "c" *p1* *p2*)
*lin_ss* (ss2enamlist lin_ss)
*lin_ss (filter_non-colinear_segments lin *lin_ss*)
ptlst (create_ptlst *lin_ss))
(if (and *lin_ss
(> (sslength *lin_ss) 1))
(progn (setq ext_pts (extreme_pts ptlst)
lin1 (ssname *lin_ss 0)
*lin1 (entget lin1)
lyr (cdr (assoc 8 *lin1)))
(if (and *lin_ss
(setq *ssl (sslength *lin_ss)))
(progn (setq deleted (+ deleted *ssl)
l_deleted (+ l_deleted *ssl))
(command "erase" *lin_ss "")
(command "layer" "m" lyr "")
(command "line" (car ext_pts)
(cadr ext_pts) "")))
T)))))

(defun create_ptlst (ss / i sl l1 *l1 n1 n2 pts)
(cond ((null ss) nil)
((/= (type ss) 'PICKSET) nil)
((< (setq sl (sslength ss)) 2) nil)
(T (setq i 1
sl (sslength ss)
l1 (ssname ss 0)
*l1 (entget l1)
n1 (cdr (assoc 10 *l1))
n2 (cdr (assoc 11 *l1))
pts (list n1 n2))
(repeat (1- sl)
(setq l1 (ssname ss i)
*l1 (entget l1)
n1 (cdr (assoc 10 *l1))
n2 (cdr (assoc 11 *l1)))
(if (null (member n1 pts))
(setq pts (append pts (list n1))))
(if (null (member n2 pts))
(setq pts (append pts (list n2))))
(setq i (1+ i)))
pts)))

(defun filter_non-colinear_segments (lin enamlst / l sl)
(cond ((or (null enamlst)
(null lin)) nil)
(T (foreach l enamlst
(if (and l ;; if line isn't parallel to test line,
(not (colinear lin l))) ;; delete it from set
(ssdel l lin_ss) ;; of lines to be processed
(ssdel l *lines*))) ;; else, assume it will be erased.
lin_ss)))

(defun extreme_pts (pt_list)
(cond ((or (null pt_list)
(< (length pt_list) 2)) nil) ;; termination condition
((= (length pt_list) 2) pt_list) ;; only 2 pts in list
(T (setq n1 (car pt_list) ;; find extreme points
n2 (cadr pt_list))
(cond ((v-orient n1 n2)
(setq plst (mapcar 'xy pt_list)
rev_p (mapcar 'reverse plst)
y_coords (mapcar 'car rev_p)
min_y (apply 'min y_coords)
max_y (apply 'max y_coords)
_n1 (assoc min_y rev_p)
_n2 (assoc max_y rev_p)
*n1 (reverse _n1)
*n2 (reverse _n2)))
((h-orient n1 n2)
(setq plst (mapcar 'xy pt_list)
x_coords (mapcar 'car plst)
min_x (apply 'min x_coords)
max_x (apply 'max x_coords)
*n1 (assoc min_x plst)
*n2 (assoc max_x plst)))
((setq direct (diagonal n1 n2))
(setq plst (mapcar 'xy pt_list)
rev_p (mapcar 'reverse plst)
x_coords (mapcar 'car plst)
y_coords (mapcar 'car rev_p)
min_x (apply 'min x_coords)
max_x (apply 'max x_coords)
min_y (apply 'min y_coords)
max_y (apply 'max y_coords))
(if (= direct 'LLUR) ; if we got this far, DIRECT is non-nil
(setq *n1 (list min_x min_y)
*n2 (list max_x max_y))
(setq *n1 (list max_x min_y)
*n2 (list min_x max_y)))))
(list *n1 *n2))))

(defun get_line_data (line)
(setq elist (entget line)
*p1* (cdr (assoc 10 elist))
*p2* (cdr (assoc 11 elist))
*ang1* (angle *p1* *p2*)
h_pi* (/ pi 2.0)))

(defun colinear (lin1 lin2 / line1 line2)
(if (and lin1 lin2
(setq line1 (entget lin1))
(setq line2 (entget lin2))
(setq l1p1 (cdr (assoc 10 line1)))
(setq l1p2 (cdr (assoc 11 line1)))
(setq l2p1 (cdr (assoc 10 line2)))
(setq l2p2 (cdr (assoc 11 line2)))
(setq ang1 (rad2deg (angle l1p1 l1p2)))
(setq ang2a (rad2deg (angle l2p1 l2p2)))
(setq ang2b (rad2deg (angle l2p2 l2p1))))
(progn (if (not (equal l1p1 l2p1))
(setq ang3 (rad2deg (angle l1p1 l2p1)))
(setq ang3 nil))
(if (not (equal l1p1 l2p2))
(setq ang4 (rad2deg (angle l1p1 l2p2)))
(setq ang3 nil))
(and (or (= ang1 ang2a) ; pass the test for parallelism
(= ang1 ang2b))
(or (= ang2a ang3) ; pass the test that one point
(= ang2b ang3) ; on the segment is colinear with
(= ang2a ang4) ; the test segment
(= ang2b ang4))))))

(defun ~= (actual_value test_value tolerance) ;;fuzzy equality
(if (and actual_value test_value tolerance)
(<= (abs (- actual_value test_value)) tolerance)))

(defun DEG2RAD (ang)
(* pi (/ ang 180.000000)))

(defun RAD2DEG (ang)
(* ang (/ 360 (* pi 2.000000))))

(defun pos-in-list (item lst)
(if (null (member item lst))
nil
(- (length lst) (length (cdr (member item lst))))))

(defun 2D-TO-3D (pt elev) ;; Construct 3D point with elev as Z coordinate
(if pt (append (xy pt) (list elev))
(append (getpoint "\nFirst point: ") (list elev))))

(defun XY (pt) ;; convert 3D point to 2D
(list (car pt) (cadr pt)))

;; find closest point in node list "nodes" to point "pt"'
(defun closest (pt nodes)
(nth
(1- (pos-in-list
(apply 'min (mapcar '(lambda (node) (distance pt node)) nodes))
(mapcar '(lambda (node) (distance pt node)) nodes)))
nodes))

(defun v-orient (p1 p2) ;;are two points in a basically vertical relationship?
(> (abs (- (cadr p1) (cadr p2)))
(abs (- (car p1) (car p2)))))

(defun vertical (p1 p2)
(= (car p1) (car p2)))

(defun horizontal (p1 p2)
(= (cadr p1) (cadr p2)))

(defun h-orient (p1 p2) ;;are two points in a horizontal relationship?
(< (abs (- (cadr p1) (cadr p2)))
(abs (- (car p1) (car p2)))))

(defun diagonal (p1 p2 / ang1)
(setq ang1 (rad2deg (angle p1 p2)))
(cond ((or (= ang1 45.0)
(= ang1 225.0)) 'LLUR) ;; return direction of vector
((or (= ang1 135.0)
(= ang1 315.0)) 'LRUL) ;; return direction of vector
(T nil))) ;; else, nil

(defun left-to-right (p1 p2) ;;is vector P1 P2 pointing to right?
(and (h-orient p1 p2)
(<= (car p1) (car p2))))

(defun right-to-left (p1 p2) ;;is vector P1 P2 pointing to left?
(and (h-orient p1 p2)
(> (car p1) (car p2))))

(defun top-to-bottom (p1 p2) ;;is vector P1 P2 pointing down?
(and (v-orient p1 p2)
(> (cadr p1) (cadr p2))))

(defun bottom-to-top (p1 p2) ;;is vector P1 P2 pointing up?
(and (v-orient p1 p2)
(<= (cadr p1) (cadr p2))))

;; convert a selection set to a list of entity lists
(defun ss2enamlist (ss / entlist ctr)
(if ss (progn
(setq ctr 0)
(repeat (sslength ss)
(progn (setq entlist (cons (ssname ss ctr) entlist))
(setq ctr (1+ ctr)))))) (if entlist entlist))

;(defun ~= (actual_value test_value tolerance) ;;fuzzy equality
; (and (<= actual_value (+ test_value tolerance))
; (>= actual_value (- test_value tolerance))))

(defun aux_remove (atm lst)
(cond ((null lst) nil)
((null (member atm lst)) lst)
((equal atm (car lst)) (cdr lst))
(t (append (reverse (cdr (member atm (reverse lst))))
(cdr (member atm lst))))))

(defun parse_time (cdate / date_str year month day hour min secs date)
(if cdate
(setq date_str (rtos cdate 2 6)
year (substr date_str 3 2)
month (substr date_str 5 2)
day (substr date_str 7 2)
hour (substr date_str 10 2)
min (substr date_str 12 2)
secs (substr date_str 14 2)
date (strcat month "/" day "/" year " " hour ":" min ":" secs))))

(defun explode (str / firstchr *str*) ;; iterative text explosion
(if (null str) nil
(repeat (strlen str)
(progn
(setq *str* (cons (setq firstchr (substr str 1 1)) *str*))
(setq str (substr str 2))))) (reverse *str*))

(defun concat (lst / str)
(if (or (null lst)
(/= (type lst) 'LIST)) nil
(apply 'strcat lst)))

;;; Compresser v. 2.0

(defun explode_plines ()
(setvar "cmdecho" 0)
(setq plns (ssget "x" '((0 . "POLYLINE"))))
(if plns (progn (setq lngth (sslength plns)
i 0)
(terpri)
(repeat lngth
(setq pln (ssname plns i))
(princ (strcat "\rExploding polyline "
(itoa (1+ i))
" of " (itoa lngth)))
(command "explode" pln)
(setq i (1+ i)))))
(princ))

(defun explode_1segment_plines ()
(setvar "cmdecho" 0)
(setq plns (ssget "x" '((0 . "POLYLINE"))))
(if plns (progn (setq lngth (sslength plns)
i 0)
(terpri)
(repeat lngth
(setq pln (ssname plns i))
(princ (strcat "\rAnalyzing polyline "
(itoa (1+ i))
" of " (itoa lngth)))
(setq num_verts (length (collect_vertices pln)))
(if (< num_verts 3)
(progn (princ "\rExploding")
(command "explode" pln)))
(setq i (1+ i)))))
(princ))

(defun compress_by_layer ()
(foreach lyr (mapcar 'car lyrs)
(if (and (setq lines (ssget "x" (list (cons 0 "LINE")
(cons 8 lyr)))
*lines* lines)
(setq lines_l (sslength lines)))
(compress_lines lyr))))

(defun compress_lines (layr)
(freeze_all_but layr)
(princ (strcat "\nCompiling lines on layer " layr "\n"))
(while (and (setq lines (ssget "x" (list (cons 0 "LINE") (cons 8 layr))))
(> (setq ssl (sslength lines)) 0)
(setq line1 (ssname lines 0)))
(princ "\rProcessing ")
(princ line1)
(command "pedit" line1 "y" "j" lines "" "x")))

(defun collect_vertices (ent / *ent* pt pts)
(if (= (cdr (assoc 0 (setq *ent* (entget ent)))) "POLYLINE")
(progn (setq ent (entnext ent))
(while (setq *ent* (entget ent) pt (cdr (assoc 10 *ent*)))
(setq pts (cons pt pts)
ent (entnext ent))))
(princ "\ncollect_vertices: not a POLYLINE."))
(if pts pts))

(defun userstr (dflt prmpt / var) ;;DFLT and PRMPT are strings
(setq var (getstring (if (and dflt (/= dflt ""))
(strcat prmpt " <" dflt ">: ")
(strcat prmpt ": "))))
(cond ((/= var "") var)
((and dflt (= var "")) dflt)
(T (*error* "no default given"))))

  • 0

#87 proconeng86

proconeng86

    biết lệnh break

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

Đã gửi 03 April 2008 - 10:58 AM

sao lisp của em mặc dù lệnh đó vẫn thực hiện được nhưng xong nó vẫn hiện lên :" Unknown command "TS". Press F1 for help "
  • 0

#88 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 16 April 2008 - 02:59 PM

(defun c:f0 ()
(setq bkflcu (getvar "filletrad"))
(setvar "filletrad" 0)
(command ".fillet" )
(setvar "filletrad" bkflcu)
(Princ))


Cho mình hỏi sao cái lisp của mình như vầy không chạy được. Nếu bỏ dòng màu đỏ đi thì được nhưng không đúng ý muốn.
Mục đích muốn dùng lệnh FILLET với tham số bán kính bằng 0 sau đó trả lại tham số bán kính chi lệnh FILLET.
Mong mọi người giúp !!!!!!!!!!!!
  • 0

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#89 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 17 April 2008 - 07:38 AM

(defun c:f0 ()
(setq bkflcu (getvar "filletrad"))
(setvar "filletrad" 0)
(command ".fillet" )
(setvar "filletrad" bkflcu)
(Princ))


Cho mình hỏi sao cái lisp của mình như vầy không chạy được. Nếu bỏ dòng màu đỏ đi thì được nhưng không đúng ý muốn.
Mục đích muốn dùng lệnh FILLET với tham số bán kính bằng 0 sau đó trả lại tham số bán kính chi lệnh FILLET.
Mong mọi người giúp !!!!!!!!!!!!

Lý do: (command "fillet" ...) chưa hoàn thành vì chưa đủ các arguments cần thiết. Khi đó, Acad sẽ tiếp tục thực hiện các biểu thức lisp tiếp theo, tương tự như phương thức transparent (mình đã từng phân tích cái này ở đâu đó rồi không nhớ nữa). Đây là tính năng rất hay, cho phép bạn thực hiện command lặp lại, với số lần lặp chưa xác định trước chỉ với vài dòng code đơn giản. Bạn tìm lại một số chương trình anh Hoành đã post lên, ví dụ như trình vẽ các bậc thang sẽ thấy rõ hơn.
Quay lại trường hợp của bạn, khi chưa hoàn thành command fillet, các biểu thức lisp sau đó vẫn tiếp tục được thực hiện, trong đó có (setvar "filletrad" bkflcu). Đến khi kết thúc, trình lisp trả điều khiển lại cho Acad, nó sẽ làm tiếp lệnh fillet đang dở dang, và tất nhiên là với bán kính bkflcu như hồi đầu.
Tóm lại, chương trình của bạn được thực thi hoàn toàn đúng, chỉ có điều là không đúng với mục đích của bạn. Với cách này là không được rồi, bạn có thể dùng cách sau (hoặc tự nghĩ ra những cách khác phù hợp với mục đích sử dụng của bạn):


(defun c:f0 ( / oldfill oldos)
(setq
oldfill (getvar "filletrad")
oldos (getvar "osmode")
)
(setvar "filletrad" 0)
(setvar "osmode" 512)
(command "fillet"
(getpoint "\nPick at first object:")
(getpoint "\nPick at second object:")
)
(setvar "filletrad" oldfill)
(setvar "osmode" oldos)
(princ)
)

  • 1

#90 smilingman82

smilingman82

    biết vẽ arc

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

Đã gửi 06 May 2008 - 07:48 PM

cho tớ hỏi mã dxf về chiều dài length của line ,pline là gì nhỉ . Trong sách líp chỉ thống kê chung chung , ko ghi rõ code lengthen ....ván đề là tớ mún gán length của các line được chọn là 1 biến ,,,,cậu có thể trả lời hộ tớ kô
  • 0

#91 Nguyen Hoanh

Nguyen Hoanh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 4105 Bài viết
Điểm đánh giá: 4495 (đỉnh cao)

Đã gửi 06 May 2008 - 09:34 PM

cho tớ hỏi mã dxf về chiều dài length của line ,pline là gì nhỉ . Trong sách líp chỉ thống kê chung chung , ko ghi rõ code lengthen ....ván đề là tớ mún gán length của các line được chọn là 1 biến ,,,,cậu có thể trả lời hộ tớ kô

Không có mã dxf về chiều dài của line và pline.

mã Lisp tính chiều dài line và pline, bạn hãy xem ở đây: http://www.cadviet.c...uong-t2020.html
  • 0

#92 missone's

missone's

    biết vẽ rectang

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

Đã gửi 10 May 2008 - 01:19 AM

Mọi người cho em hỏi chút- là khi em áp dụng lệnh ND- copy đối tượng và khi paste thì nó đè lên đối tượng (text) khác- em đã appload thành công- gõ lệnh ND thì nó hiện thông báo sau:
- Command: nd
Chon chu muon chinh.
Select objects: 1 found
1 was filtered out.
Select objects:
Em chọn đối tượng mà không được!
Lisp này em thấy post đã lâu- but giờ em mới dùng đến- em tìm lại bài viết đó mà ko thấy! Em xin post lại đoạn Code cho các bác được rõ: Em xin cam on!

(defun c:ND (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (cond
(ss (sslength ss))
(t 0)
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

(prompt "\nChon chu muon chinh.")
(setq ssEname (ssget '((0 . "TEXT"))))
(if (not ssEname)
(prompt "\nChua chon duoc doi tuong.")
(progn
(prompt "\nChon chu lam chuan.")
(setq lstEname (ss2ent ssEname))
(setq Newtext (car (entsel)))
(setq Newtext (entget Newtext))
(setq Newtext (assoc 1 Newtext))
(setq Newtext (cdr Newtext))
(setq Newlist (cons '1 Newtext))

(foreach Ename lstEname
(setq Elist (entget Ename))
(setq Oldlist (assoc 1 Elist))
(setq Oldtext (cdr Oldlist))
(setq Elist (subst Newlist Oldlist Elist))
(entmod Elist)
)
) ; end progn
) ; end if
(princ)
)
  • 0
neverforever

#93 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 10 May 2008 - 06:58 AM

Mọi người cho em hỏi chút- là khi em áp dụng lệnh ND- copy đối tượng và khi paste thì nó đè lên đối tượng (text) khác- em đã appload thành công- gõ lệnh ND thì nó hiện thông báo sau:
- Command: nd
Chon chu muon chinh.
Select objects: 1 found
1 was filtered out.
Select objects:
Em chọn đối tượng mà không được!
Lisp này em thấy post đã lâu- but giờ em mới dùng đến- em tìm lại bài viết đó mà ko thấy! Em xin post lại đoạn Code cho các bác được rõ: Em xin cam on!

(defun c:ND (/ Ename Elist Msg Oldtext Oldlist Newtext Newlist)
(defun ss2ent (ss / sodt index lstent)
(setq
sodt (cond
(ss (sslength ss))
(t 0)
)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)

(prompt "\nChon chu muon chinh.")
(setq ssEname (ssget '((0 . "TEXT"))))
(if (not ssEname)
(prompt "\nChua chon duoc doi tuong.")
(progn
(prompt "\nChon chu lam chuan.")
(setq lstEname (ss2ent ssEname))
(setq Newtext (car (entsel)))
(setq Newtext (entget Newtext))
(setq Newtext (assoc 1 Newtext))
(setq Newtext (cdr Newtext))
(setq Newlist (cons '1 Newtext))

(foreach Ename lstEname
(setq Elist (entget Ename))
(setq Oldlist (assoc 1 Elist))
(setq Oldtext (cdr Oldlist))
(setq Elist (subst Newlist Oldlist Elist))
(entmod Elist)
)
) ; end progn
) ; end if
(princ)
)


Bạn sửa dòng tô đỏ trên như sau và thử lại:
(setq ssEname (ssget '((0 . "TEXT,MTEXT"))))
  • 1

#94 missone's

missone's

    biết vẽ rectang

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

Đã gửi 10 May 2008 - 09:01 PM

Bạn sửa dòng tô đỏ trên như sau và thử lại:
(setq ssEname (ssget '((0 . "TEXT,MTEXT"))))

Em đã làm như bác và đã thành công- hehee. Thanks bác nhiều nha!
  • 0
neverforever

#95 smilingman82

smilingman82

    biết vẽ arc

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

Đã gửi 10 May 2008 - 10:32 PM

Không có mã dxf về chiều dài của line và pline.

mã Lisp tính chiều dài line và pline, bạn hãy xem ở đây: http://www.cadviet.com/forum/tinh-tong-chi...uong-t2020.html

thank bác ......bác cho hỏi thêm nhá : bi h mún chỉnh sửa lệnh cuả CAD đc k , các lệnh CAD có lưu trong thư mục nào k, có edit để hiệu chỉnh như một lisp d ko ...cám ơn bác tr nhá ...VD CAD có lệnh line >>>> mình sửa nội dung của lệnh đó được không , cái này m hỏi chỉ để hiểu sâu thêm thôi .thank
  • 0

#96 nguyenthuan

nguyenthuan

    Chưa sử dụng CAD

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

Đã gửi 10 May 2008 - 10:35 PM

xin chào mọi người!
Thấy mấy huynh nói về lisp hay quá nên kẻ hèn này đọc sách mấy hôm nay để học cho biết với mọi người.Ngay từ khi viết thử code này để học hỏi thôi (vì viết theo sách) nhưng cũng không chạy được ,mặc dù mình thấy nó rất bình thường .Không biết hỏi ai để bắt đầu từ những cái sai cơ bản này nên mạo mụi nhờ các huynh chỉ giúp .
-------------------------------

(defun c:drawline (/pt1 pt2)
(setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)
(if (and pt1 pt2)
(command "_.line" pt1 pt2"")
(princ "\nInvalid or missing points!")
)
(princ)
)

----------------------------------
không hiểu sao khi chạy nó báo lỗi này
; error: too few arguments
Mong nhận được giải đáp nhanh chóng để có thể tìm hiểu tiếp về cái này.
  • 0

#97 nguyenthuan

nguyenthuan

    Chưa sử dụng CAD

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

Đã gửi 10 May 2008 - 10:39 PM

À quên nhân đây nhờ các huynh chỉ giúp

(setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)

tại sao getpoint hàng trên thì không cần pt1 ,nhưng getpoint hàng tiếp theo lại có pt1 .2 cái này khác nhau như thế nào ạ
  • 0

#98 h2c

h2c

    biết vẽ ellipse

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

Đã gửi 10 May 2008 - 11:04 PM

À quên nhân đây nhờ các huynh chỉ giúp


(setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)

tại sao getpoint hàng trên thì không cần pt1 ,nhưng getpoint hàng tiếp theo lại có pt1 .2 cái này khác nhau như thế nào ạ

Khi có pt1 ở dòng 2 thì cad sẽ có 1 đường nối từ pt1 đến cursor của bạn trong quá trình bạn chọn điểm thứ 2 , cái này để trực quan hơn thôi .
  • 0

#99 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 12 May 2008 - 04:54 PM

xin chào mọi người!
Thấy mấy huynh nói về lisp hay quá nên kẻ hèn này đọc sách mấy hôm nay để học cho biết với mọi người.Ngay từ khi viết thử code này để học hỏi thôi (vì viết theo sách) nhưng cũng không chạy được ,mặc dù mình thấy nó rất bình thường .Không biết hỏi ai để bắt đầu từ những cái sai cơ bản này nên mạo mụi nhờ các huynh chỉ giúp .

(defun c:drawline (/pt1 pt2)
(setq pt1 (getpoint "\nCho diem dau cua line")
pt2 (getpoint pt1 "\nCho diem thu 2 cua line")
)
(if (and pt1 pt2)
(command "_.line" pt1 pt2"")
(princ "\nInvalid or missing points!")
)
(princ)
)

không hiểu sao khi chạy nó báo lỗi này
; error: too few arguments
Mong nhận được giải đáp nhanh chóng để có thể tìm hiểu tiếp về cái này.

Lỗi ở các chỗ màu đỏ. Bạn thiếu 2 dấu cách (space). Góp ý:
1) Bạn mới bắt đầu, hãy tập thói quen thận trọng và chuẩn xác khi coding. Với kiểu lỗi này, khi bạn lập 1 chương trình tương đối dài sẽ không kiểm nổi đâu!
2) Những chỗ ra vô đầu dòng nhất quán theo một quy luật rõ ràng sẽ giúp bạn giảm thiểu nhiều lỗi không đáng có. Ví dụ như sau:


(defun c:drawline (/ pt1 pt2)
(setq
pt1 (getpoint "\nFirst point: ")
pt2 (getpoint pt1 "\nSecond point: ")
)
(if (and pt1 pt2)
(command "_.line" pt1 pt2 "")
(princ "\nInvalid or missing points!")
)
(princ)
)


Cái "à quên" của bạn, h2c đã giải đáp chính xác.
  • 0

#100 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 12 May 2008 - 05:08 PM

thank bác ......bác cho hỏi thêm nhá : bi h mún chỉnh sửa lệnh cuả CAD đc k , các lệnh CAD có lưu trong thư mục nào k, có edit để hiệu chỉnh như một lisp d ko ...cám ơn bác tr nhá ...VD CAD có lệnh line >>>> mình sửa nội dung của lệnh đó được không , cái này m hỏi chỉ để hiểu sâu thêm thôi .thank

1) Nội dung lệnh CAD nằm trong file acad.exe. Không ai chỉnh sửa được trừ... AutoDesk!
2) Bạn có thể sửa tên lệnh (bằng S::STARTUP) hoặc tên lệnh tắt của CAD (trong file acad.pgp). Tuy nhiên, theo ssg, việc này không khuyến khích vì nó chẳng mang lại lợi ích gì ngoài việc làm rối tung mọi thứ lên!
  • 0