CAD lisp程序

超级详细 (defun *error*(st) (if (and (/= st "Function cancelled") (/= st "quit / exit abort") ) (princ (strcat "错误: " st)) ) (setq *error* old_err) (princ) ) (defun sort (l / lt ltem vmax vmin l1 l2 l3 lt0 ltem0 ltem1 l30 vmax0 vmin0 l10 l20) (setq ltem (mapcar 'car l) ;ltem : 取出l的第一项形成的表 vmin (1- (apply 'min ltem)) ;vmin : 是一个比ltem中最小的数还小的数 ) (while (< vmin (setq vmax (apply 'max ltem))) ;从ltem中取出最大值 (setq l1 l l3 nil ltem (subst vmin vmax ltem)) ;去掉最大值 (while (setq l2 (assoc vmax l1)) ;取出最大值所对应的项 (setq l1 (cdr (member l2 l1))) ;处理相同的值 (setq l3 (cons l2 l3)) ) (progn (setq ltem0 (mapcar 'cadr l3) ltem1 (mapcar 'car l3) l30 (mapcar 'cdr l3) vmin0 (1- (apply 'min ltem0)) ) (while ( (car bp) (car sp)) ; (setq tem bp bp sp sp tem) ; ) (setq ss nil) (if (setq ss (ssget "c" bp sp)) (progn (setq n 0) (repeat (sslength ss) (setq el (entget (ssname ss n))) (if (and (= (dxf 0 el) "LINE") (or (= (dxf 8 el) "WALL") (= (dxf 8 el) "AXIS")) (setq ip (inters bp sp (dxf 10 el) (dxf 11 el))) ) ; ip 交点 (progn (setq lpt (cons ip lpt)) ) ) (setq n (1+ n)) ) ; repeat 找出所有的交点并形成表lpt (if (/= nil lpt) (setq lpt (sort lpt))) ) ) (setq pt0 '(0 0 0)) ;以下9行去掉相同的数据 (foreach pt lpt (if (= ang pi) (setq ang (- ang pi))) (setq di (distance bp (inters bp (polar bp (+ ang (* pi 0.5)) 100) (dxf 10 el) (dxf 11 el) nil))) (setq di (- di 700)) (setq pt1 (polar (car lpt) (+ ang (* pi 0.5)) di)) (command "line" (polar pt1 (+ ang (* pi 1.5)) 700) (polar pt1 (+ ang (* pi 0.5)) 300) "") (command "pline" (polar pt1 (+ ang (* pi 1.25)) 70.7) "w" "50" "50" (polar pt1 (+ ang (* pi 0.25)) 70.7) "") (foreach pt (cdr lpt) (setq pt (polar pt (+ ang (* pi 0.5)) di)) (command "line" (polar pt (+ ang (* pi 1.5)) 700) (polar pt (+ ang (* pi 0.5)) 300) "") (command "pline" (polar pt (+ ang (* pi 1.25)) 70.7) "w" "50" "50" (polar pt (+ ang (* pi 0.25)) 70.7) "") (command "line" pt1 pt "") (setq txt (rtos (setq dis (distance pt1 pt)) 2 0)) (setq len (sqrt (+ (* 115 115) (* (/ dis 2.0) (/ dis 2.0))))) (setq ang1 (atan (/ 115 (/ dis 2.0)))) (command "text" "c" (polar pt1 (+ ang ang1) len) "300" (* (/ ang pi) 180) txt) (setq pt1 pt) ) ) ;;;============================================== ;;; main programm ;;;============================================== (defun C:3dimzs(/ bp sp) (setq old_err *error*) (setvar "CMDECHO" 0) (setvar "BLIPMODE" 0) (command "layer" "m" "dim" "c" "g" "dim" "") (setq bp (getpoint "\n第一点(一般为外墙线上两点): ")) (if (= nil bp) (quit)) (setq sp (getpoint bp "\n第二点: ")) (if (= nil sp) (quit)) (pross bp sp) (princ) )