|
程序如下：（包括两个程序：LPLACE.LISP 和 UNDO.LISP）
LPLACE.LISP
(defun lplace(/ m n insblk insang inspt olyr)
(if (and (not undo_init) (equal -1 (load "undo.lsp" -1)))
(progn (alert "Error:\n Cannot find UNDO.LSP.") (exit))
);if
(err_init '("CMDECHO" "OSMODE" "BLIPMODE" "REGENMODE") T '(setq l_s nil))
(var_set '(("CMDECHO" 0) ("OSMODE" 0) ("BLIPMODE" 0) ("REGENMODE" 0)))
;; Get information
(cond ((numberp light_scale)) (T (setq light_scale 1)))
(cond (light_layer) (T (setq light_layer (getvar "CLAYER"))))
(prompt (strcat "\n默认图层：\"" light_layer "\"。" ))
(prompt (strcat "\n默认比例：\"" (rtos light_scale 2 2) "\"。"))
(cond
((= (cdar (laychk light_layer)) "No")
(laychk (setq light_layer (getvar "CLAYER")))
(prompt (strcat "\n图层被设为当前层：\"" light_layer "\"。" ))
)
); cond
(while (not insblk)
(initget "Layer Scale Name")
(setq insblk (getkword "\n图层 L / 比例 S / 图块名 N："))
(cond
((= "Scale" insblk)
(initget 6)
(setq light_scale
(cond ((getreal (strcat "\n请输入图块比例：<"
(rtos light_scale 2 2)
"> ")))
(T light_scale)
); cond
insblk nil
); setq
)
((= "Layer" insblk)
(setq olyr light_layer insblk nil)
(setq light_layer (getstring (strcat "\n请选择图层：<"
light_layer "> ")))
(cond ((= light_layer "") (setq light_layer olyr)))
(cond ((= (cdar (laychk light_layer )) "No")
(setq light_layer olyr)
(prompt (strcat "\n图层仍为：\"" light_layer "\"。" )))
); cond
)
(T
(cond
((= (getvar "INSNAME") "")
(setq insblk (getstring "\n请输入图块名："))
(cond ((tblsearch "BLOCK" insblk) (setvar "INSNAME" insblk))
(T (setq insblk nil))); cond
)
(T
(setq insblk (getstring (strcat "\n请输入图块名：<"
(getvar "INSNAME") "> ")))
(cond ((= insblk "") (setq insblk (getvar "INSNAME")))); cond
(cond ((tblsearch "BLOCK" insblk) (setvar "INSNAME" insblk))
(T (setq insblk nil))); cond
)
); cond
(cond (insblk) (T (prompt "\n无效的图块！"))); cond
)
); cond
); while
(setq insang (getangle "\n请输入图块的角度：<0> "))
(cond ((not insang) (setq insang 0)))
(setq inspt (gettrs))
(setq n 0)
(while (< n (length inspt))
(setq m 0)
(while (< m (length (car inspt)))
(apply '(lambda (iname ilayer ipoint iscale iangle)
(entmake (list (cons 0 "INSERT")
(cons 2 iname)
(cons 8 ilayer)
(cons 10 ipoint)
(cons 41 iscale)
(cons 42 iscale)
(cons 43 iscale)
(cons 50 iangle)
)
); entmake
); lambda
(list insblk light_layer (nth m (nth n inspt)) light_scale insang)
); apply
(setq m (1+ m))
); while
(setq n (1+ n))
); while
(initget 1 "Yes No")
(cond ((= "Yes" (getkword "\n是否需要连线 ？(Y/N) "))
(connect insblk insang light_scale inspt))
); cond
(layres)
(err_restore)
(princ)
); defun lplace
(defun gettrs(/ ulpt lrpt row col inspt deltax deltay n)
(initget 1)
(setq ulpt (getpoint "\n请选择右上角："))
(initget 1)
(setq lrpt (getcorner ulpt "\n请选择左下角："))
(grdraw ulpt (list (nth 0 lrpt) (nth 1 ulpt)) 2 1)
(grdraw (list (nth 0 lrpt) (nth 1 ulpt)) lrpt 2 1)
(grdraw lrpt (list (nth 0 ulpt) (nth 1 lrpt)) 2 1)
(grdraw (list (nth 0 ulpt) (nth 1 lrpt)) ulpt 2 1)
(initget 7)
(setq row (getint "\n请输入行数："))
(initget 7)
(setq col (getint "\n请输入列数："))
(setq deltax (/ (- (car lrpt) (car ulpt)) col)
deltay (/ (- (cadr ulpt) (cadr lrpt)) row)
); setq
;; Try to find the transformer of points
(repeat col
; new_first_row = (cons ((old_point) - deltax) old_first_row
(cond (inspt
((lambda (x)
(setq inspt (subst (cons (list (- (nth 0 (car x)) deltax)
(nth 1 (car x))
(nth 2 (car x))) x)
x
inspt))
); lambda
(car inspt))
)
(T
(setq inspt (list (list (list (- (nth 0 lrpt) (/ deltax 2.0))
(- (nth 1 ulpt) (/ deltay 2.0))
(nth 2 ulpt))))); setq
)
); cond
(setq n 0)
(while (< n (1- row))
; new_row_information = (cons new_list old_row_information)
; or (subst new_row_information old_row_information)
; new_list = (car old_row_information) - deltay
(apply
'(lambda (x y)
(cond ( y
(setq inspt (subst (cons (list (nth 0 (car x))
(- (nth 1 (car x)) deltay)
(nth 2 (car x))) y)
y
inspt))
)
(T (setq inspt (append inspt (list (cons (list (nth 0 (car x))
(- (nth 1 (car x)) deltay)
(nth 2 (car x)) ) y))))
)
); cond
); lambda
(list (nth n inspt) (nth (1+ n) inspt))
)
(setq n (1+ n))
); while
); repeat
inspt
); defun gettrs
(defun turntrs(otrs / ntrs m n)
(setq n 0)
(while (< n (length otrs))
((lambda (x)
(setq m (1- (length x)))
(while (>= m 0)
(cond
(ntrs
((lambda (y)
(if y
(setq ntrs (subst (cons (nth m x) y)
y
ntrs))
(setq ntrs (append ntrs (list (cons (nth m x) y))))
); if
); lambda
(nth (- (length x) m 1) ntrs) ; new row information
)
)
(T (setq ntrs (list (list (nth m x)))))
); cond
(setq m (1- m))
); while
); lambda
(nth n otrs)
)
(setq n (1+ n))
); while
ntrs
); defun turntrs
(defun connect(insblk insang inscale inspt / fp blkinf flag temp ppair hor m n offset )
; fetch available information of blocks
((lambda (f)
(cond
(f
(setq fp (open f "r") temp (read-line fp))
(while (and temp (not blkinf))
((lambda(x)
(if (and (listp x) x)
(if (= (strcase (cdr (assoc 0 x))) (strcase insblk))
(setq blkinf x))
); if
); lambda
(read temp)
)
(setq temp (read-line fp))
); while
(close fp)
)
(T (alert "无法打开文件 \"LIGHT.INI\" ！"))
); cond
); lambda
(findfile "LIGHT.INI")
)
(cond
(blkinf
(cond (wire_layer) (T (setq wire_layer (getvar "CLAYER"))))
(prompt (strcat "\n默认图层：\"" wire_layer "\"。" ))
(cond
((= (cdar (laychk wire_layer)) "No")
(laychk (setq wire_layer (getvar "CLAYER")))
(prompt (strcat "\n图层被设为当前层：\"" wire_layer "\"。" ))
)
); cond
(while (not flag)
(initget 1 "Layer Hor Ver")
(setq flag (getkword "\n图层 L / 垂直 V / 水平 H："))
(cond
((= "Layer" flag)
(setq temp wire_layer flag nil)
(setq wire_layer (getstring (strcat "\n请选择图层：<"
wire_layer "> ")))
(cond ((= wire_layer "") (setq wire_layer temp)))
(cond
((= (cdar (laychk wire_layer )) "No")
(setq wire_layer temp)
(prompt (strcat "\n图层仍为：\"" wire_layer "\"。" ))
)
); cond
)
((= "Hor" flag) (setq hor T))
((= "Ver" flag) (setq inspt (turntrs inspt)) (setq hor nil))
); cond
); while
(setq offset '(1 2 3 4))
(repeat (fix (+ (/ (* insang 2) pi) 0.1)) ; Ajust offset according
(setq offset (reverse (cdr (reverse (cons (last offset) offset))))) ; to angle
); repeat
(setq offset
(mapcar
'(lambda (x)
(cdr (assoc x blkinf))
); lambda
(cond (hor (list (nth 0 offset) (nth 2 offset)))
(T (list (nth 1 offset) (nth 3 offset)))) ; cond
); mapcar
); setq
(setq offset (list (* inscale (nth 0 offset)) (* -1 inscale (nth 1 offset))))
((lambda (y)
(cond (hor (setq m 0)) (T (setq m 1))); cond
(cond
((> (nth m (nth 0 y)) (nth m (nth 1 y)))
(setq offset (mapcar '(lambda (x)
(* -1.0 x)
); lambda
offset
); mapcar
); setq
)
); cond
); lambda
(car inspt))
(mapcar
'(lambda (x)
(setq m 0)
(while (< m (1- (length x)))
(setq ppair
(mapcar
'(lambda (x dx)
(cond (hor (list (+ (nth 0 x) dx) (nth 1 x) (nth 2 x)))
(T (list (nth 0 x) (+ (nth 1 x) dx) (nth 2 x)))
); cond
); lambda
(list (nth m x) (nth (1+ m) x)) offset
); mapcar
); setq
(apply '(lambda (llayer spoint epoint)
(entmake (list (cons 0 "LINE")
(cons 8 llayer)
(cons 10 spoint)
(cons 11 epoint)
)
); entmake
); lambda
(list wire_layer (car ppair) (cadr ppair))
); apply
(setq m (1+ m))
); while
); lambda
inspt
); mapcar
)
(T (alert "该图块未被正确配置！"))
); cond
); defun connect
(defun c:lp() (lplace))
(defun c:lplace() (lplace))
UNDO.LISP
(defun mod_att(ent id dxf_item)
(while (and (/= "ATTRIB" (car (entgetf '(0) ent))) (/= id (car (entgetf '(2) ent))))
(setq ent (entnext ent))
); while
((lambda (x)
(mapcar '(lambda (y)
(setq x (subst y (assoc (car y) x) x))
); lambda
dxf_item
); mapcar
(entmod x)
(entupd ent)
); lambda
(entget ent)
)
); defun mod_att
;----------------------------------------------------------------------------
; Check layer status, return a association list which contains layer information
;----------------------------------------------------------------------------
(defun laychk(lay / l_sta)
( (lambda (x)
(if (not l_s)
(setq l_s (list (cons x (logand 5 (cdr (assoc 70 (tblsearch "LAYER" x)))))))
); if
); lambda
(getvar "CLAYER")
)
(if (not (tblsearch "LAYER" lay))
(progn
(initget "Yes No")
(if (= (setq l_sta (getkword "\n图层不存在，是否建立该图层 ？\(Y/N\)")) "Yes")
(progn
(command "_.layer" "n" lay "")
(setq l_sta 0)
); progn
); if
); progn
(progn
(setq l_sta (logand 5 (cdr (assoc 70 (tblsearch "LAYER" lay)))))
(if (= 1 (logand 1 l_sta))
(progn
(initget "Yes No")
(if (= (getkword "\n该图层被冻结，是否解冻 ？\(Y/N\)") "Yes")
(command "_.layer" "t" lay "")
(setq l_sta "No")
); if
); progn
); if
(if (numberp l_sta)
(if (= 4 (logand 4 l_sta)) (command "_.layer" "u" lay "")); if
); if
); progn
); if
( (lambda (x)
(cond
( (not x)
(setq l_s (cons (cons lay l_sta) l_s))
)
( (= "No" (cdr x))
(setq l_s (subst (cons lay l_sta) x l_s))
)
( T l_s)
); cond
); lambda
(assoc lay l_s)
)
); defun chklay
;----------------------------------------------------------------------------
; Restore layer status according to association list l_s
;----------------------------------------------------------------------------
(defun layres()
(setvar "CLAYER" (car (last l_s)))
(repeat (length l_s)
( (lambda(x)
(if (numberp (cdr x))
(progn
(if (= 4 (logand 4 (cdr x)))
(command "_.layer" "lo" (car x) "")
); if
(if (= 1 (logand 1 (cdr x)))
(command "_.layer" "f" (car x) "")
); if
); progn
); if
); lambda
(car l_s)
)
(setq l_s (cdr l_s))
); repeat
); layres
;----------------------------------------------------------------------------
; Get DXF codes
;----------------------------------------------------------------------------
(defun entgetf (index ent)
((lambda (e)
(mapcar '(lambda (x)
(cdr (assoc x e))
); lambda
index) ; internal lambda function
); lambda
(entget ent)
)
); defun entgetf
;----------------------------------------------------------------------------
; Save UNDO status
;----------------------------------------------------------------------------
(defun undo_init (/ cmdecho undo_ctl)
(setq cmdecho (getvar "CMDECHO") undo_ctl (getvar "UNDOCTL")) ; Save the value
(setvar "CMDECHO" 0)
(if (equal 0 undo_ctl) ; Make sure undo is fully enable
(command "_.undo" "_all")
(command "_.undo" "_control" "_all")
)
(if (equal 4 (logand 4 (getvar "UNDOCTL"))) ; Ensure undo auto is off
(command "_.undo" "_auto" "_off")
)
(while (equal 8 (logand 8 (getvar "UNDOCTL"))) ; Place an end mark here
(command "_.undo" "_end")
)
(while (not (equal 8 (logand 8 (getvar "UNDOCTL"))))
(command "_.undo" "_group")
)
(setvar "CMDECHO" cmdecho)
undo_ctl
); defun undo_init
;----------------------------------------------------------------------------
; Restore UNDO status
;----------------------------------------------------------------------------
(defun undo_restore (/ cmdecho)
(if old_undoctl
(progn
(setq cmdecho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (equal 0 (getvar "UNDOCTL")) (command "_.undo" "_all"))
(while (equal 8 (logand 8 (getvar "UNDOCTL")))
(command "_.undo" "_end")
); while
(if (not (equal old_undoctl (getvar "UNDOCTL")))
(progn
(cond
((equal 0 old_undoctl)
(command "_.undo" "_control" "_none")
)
((equal 2 (logand 2 old_undoctl))
(command "_.undo" "_control" "_one")
)
)
(if (equal 4 (logand 4 old_undoctl))
(command "_.undo" "_auto" "_on")
(command "_.undo" "_auto" "_off")
)
)
)
(setq old_undoctl nil)
(setvar "CMDECHO" cmdecho)
)
)
); defun undo_restore
;----------------------------------------------------------------------------
; Save variables
;----------------------------------------------------------------------------
(defun var_save (a)
(setq m_lst '())
(repeat (length a)
(setq m_lst (append m_lst (list (list (car a) (getvar (car a))))))
(setq a (cdr a))
)
); defun var_save
;----------------------------------------------------------------------------
; Set variables
;----------------------------------------------------------------------------
(defun var_set (m_lst)
(repeat (length m_lst)
(setvar (caar m_lst) (cadar m_lst))
(setq m_lst (cdr m_lst))
)
); defun var_set
;----------------------------------------------------------------------------
; Restore variables
;----------------------------------------------------------------------------
(defun var_restore ()
(repeat (length m_lst)
(setvar (caar m_lst) (cadar m_lst))
(setq m_lst (cdr m_lst))
)
); defun var_restore
;----------------------------------------------------------------------------
; Initialize routine
;----------------------------------------------------------------------------
(defun err_init(e_lst u_enable add_fun)
(if err_alive (err_restore)) ; To avoid nested call
(setq err_alive T)
(var_save e_lst) ; Save the modes
(if u_enable (setq old_undoctl (undo_init))) ; Initialize UNDO status
(setq err_old *error* *error* err_main) ; Save the handle of *error*
(if add_fun ; Add the user cleaner
(setq *error* (append (reverse (cdr (reverse *error*)))
(list add_fun (last *error*))
); append
)
)
); defun err_init
;----------------------------------------------------------------------------
; Error routine body
;----------------------------------------------------------------------------
(defun err_main( msg / ) ; Body of error routine
(if (/= msg "Function cancelled") ;If an error (such as CTRL-C) occurs
(princ (strcat "\nError: " s)) ;while this command is active...
)
(while (not (equal (getvar "CMDNAMES") "")) (command nil)) ; Get out of any active command
(if old_undoctl
(progn
(while (not (wcmatch (getvar "CMDNAMES") "*UNDO*")) ; See
(command "_.undo") ; if it's in UNOD command
)
(command "_end")
(command "_.undo" "1")
(while (not (equal (getvar "CMDNAMES") "")) (command nil))
(undo_restore) ; Restore the status of UNDO
)
)
(var_restore) ; Restore the variables
(if err_old (setq *error* err_old err_old nil)) ; Restore the handle of error
(setq err_alive nil)
(princ)
); defun err_main
;----------------------------------------------------------------------------
; Restore error status
;----------------------------------------------------------------------------
(defun err_restore()
(undo_restore) ; Restore the status of UNDO
(var_restore) ; Restore the variables
(if err_old (setq *error* err_old err_old nil)) ; Restore the handle of error
(setq err_alive nil)
(princ)
); defun err_restore | 
发表于 2005-9-6 08:03
置顶卡
变色卡
显身卡
楼主
发表于 2005-9-27 13:28