[原创]：绘制冲模冲子的LISP程序

lgwlgw

这是我一直在用的自已编的绘制冲模冲子的LISP程序，感觉挺好用的，就拿来和大家分享一下。
    以下就是程序内容，不足之处请高手多多指点：
;;;绘制冲模冲子程序
;;;注意：
;;;应用此程序需在CAD中设置相应的图层，否则可能会出错。
(defun trap (errmsg)
  (command "undo" "e")
  (command "u")
  (princ)
  (setvar "osmode" oldosm)
  (setq *error* temperr)
  (princ)
) ;_ 结束defun

(defun ac ()
  (setq ddk (getdist "\n刀口直径："))
  (setq ldk (getdist "\n刀口段长度(不包含圆孤段)：")) ；A冲最小直径段的长度。
  (setq p9 (list (- (car p0) (/ ddk 2)) (- (cadr p0) l0)))
  (setq p10 (list (+ (car p0) (/ ddk 2)) (cadr p9)))
  (setq p7 (list (car p9) (+ (cadr p9) ldk)))
  (setq p8 (list (car p10) (cadr p7)))
  (setq p5 (list (car p3) (+ (cadr p7) (* ddk 1.5))))
  (setq p6 (list (car p4) (cadr p5)))
  (command "rectang" p1 p2)
  (command "pline" p3 p5 p6 p4 "")
  (command "line" p9 p7 "")
  (command "arc" "" p5)
  (command "line" p10 p8 "")
  (command "arc" "" p6)
  (command "line" p7 p8 "")
  (command "line" p9 p10 "")
) ;_ 结束defun

(defun ydc ()
  (initget 1 "T C")
  (setq ans1 (strcase (getkword "\n工作部位形状 [尖头(T)/圆头(C)]：")))
  (setq p5 (list (car p3) (- (cadr p3) (- l0 5))))
  (setq p6 (list (+ (car p5) d) (cadr p5)))
  (setq p7 (list (car p0) (- (cadr p0) l0 (* d 1.5))))
  (if (= ans1 "T")
    (progn
      (command "rectang" p1 p2)
      (command "line" p3 p5 "")
      (command "arc" "" p7)
      (command "line" p4 p6 "")
      (command "arc" "" p7)
      (setq p12 (list (car p7) (- (cadr p7) (/ d 2))))
    ) ;_ 结束progn
  ) ;_ 结束if
  (if (= ans1 "C")
    (progn
      (command "rectang" p1 p2)
      (command "pline" p3 p5 "a" p6 "l" p4 "")
      (setq p12 (list (car p0) (- (cadr p0) l0 d)))
    ) ;_ 结束progn
  ) ;_ 结束if

) ;_ 结束defun

(defun tc ()
  (setq p5 (list (car p3) (- (cadr p3) (- l0 5))))
  (setq p6 (list (+ (car p5) d) (cadr p5)))
  (command "rectang" p1 p2)
  (command "line" p3 p5 p6 p4 "")
) ;_ 结束defun

(defun message ()
  (setq p0 (getpoint "\n插入点："))
  (setq d (getdist "\n冲子直径："))
  (setq l0 (getdist "\n冲子总长："))
  (if (> d 3)
    (setq dt (+ d 3))
    (setq dt (+ d 1.5))
  ) ;_ 结束if
  (setq p1 (polar p0 pi (/ dt 2)))
  (setq p2 (list (+ (car p1) dt) (- (cadr p1) 5)))
  (setq p3 (list (+ (car p1) (/ (- dt d) 2)) (- (cadr p1) 5)))
  (setq p4 (list (- (car p2) (/ (- dt d) 2)) (cadr p2)))
  (setq p11 (list (car p0) (+ (cadr p0) (/ d 2))))
  (setq p12 (list (car p0) (- (cadr p0) l0 (/ d 2))))
) ;_ 结束defun

(defun c:ct (/           ans         ans1  p1    p2           p3         p4    p5    p6
             p7           p8         p9    p10   p11   p12         ddk   ldk   oldosm
             oldlayer         temperr     dt
            )
  (setvar "cmdecho" 0)
  (setq oldosm (getvar "osmode"))
  (setq oldlayer (getvar "clayer"))

  (setq temperr *error*)
  (setq *error* trap)
  (command "undo" "be")

  (setvar "clayer" "con")
  (setvar "osmode" 0)
  (initget 1 "A T D")
  (setq ans (strcase (getkword "\n冲子形状 [(A)冲/(T)冲/引导冲(D)]：")))
  (message)
  (if (= ans "T")
    (tc)
  ) ;_ 结束if
  (if (= ans "A")
    (ac)
  ) ;_ 结束if
  (if (= ans "D")
    (ydc)
  ) ;_ 结束if

  (setvar "clayer" "cen")
  (command "line" p11 p12 "")
  (setvar "clayer" oldlayer)

  (setq *error* temperr)
  (command "undo" "e")
  (command "undo" "be")

  (setvar "osmode" oldosm)
  (setvar "cmdecho" 1)
  (princ)
) ;_ 结束defun