[LISP程序]：单向轴网lisp程序

crtrccrt

;**单向轴网
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                          ;;
;;  程序名称: 单向轴网                                                      ;;
;;  文件名称: ad.lsp                                                        ;;         
;;  程序功能: 绘制单向轴网                                                  ;;
;;  设计编程: 李长春                         完成日期:                      ;;
;;  程序调试:                                完成日期:                      ;;
;;  程序修改: 李建君、段云                   完成日期:  1998.12.2           ;;
;;  版本序号:                                                               ;;
;;  版权所有: 北京浩辰技术开发公司                                          ;;
;;                                                                          ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;=================================主函数开始=================================
;;名称：c:ad
;;功能：绘制单向轴网
;;输入：无
;;返回：无
(defun c:xxwg1 (/ n rp_lt ds_lt rp_ch id_ch ds_ch num_ls get_pit
              get_lt d_e r_e d_l_r d_l_d d_l_a d_l_rst axisd_line get_ang
              gm1 oang chorth chosnp snp snt pm
           )
(setq olderr *error*)
;;=================================子函数开始=================================
;;名称：*error*
;;功能：错误处理函数，当程序发生错误或用户中断时，平静地退出，并还原状态。
;;输入：无
;;返回：无
(defun *error*(msg)
(command"_.undo" "_end")             ;结束"_.undo" "_group"
(command "redraw")
(foreach each                        ;释放局部变量
'(get_ang  rp_lt   ang0   ang  derr  dis  str  x1  p1  p2  p3  p4  axisd_line            
   get_pit  laynam  ds_lt   ang1   end  len1  sn1  d_e  y1  p5  p6  p7  p8  start  x   
   d_l_rst  num_ls  ds_ch   ang2   vvv  en1   r_e  ds   v1  v2  v3  v4  d_l_a  y
   get_lt   d_l_d   rp_ch   alfa   ppm  len   alf  sn   v5  v6  v7  v8  n gm1
   l_line   d_l_r   id_ch   leng   ppn  pp1   anv  pp0  en  pp  p0  rp  s   i  
   chosnp   chorth  oang    snt0   snt1 snt2  sntc snts osm  snp snt pm
  )
  (set each nil)
)                                    ;foreach end
(setq *error* olderr olderr nil)
;;;crt;;;(_resdwg)                            ;还原系统变量
(princ)
)

;;=================================子函数开始=================================
;;名称：axisd_line
;;功能：绘制轴网线
;;输入：无
;;返回：无
  
(defun axisd_line(/ start alf alfa pp end s l_line i x y rp ds sn en layNam)
  ;;;crt;;;(_inidwg)
  ;;;crt;;;(ChgHtp"AxisD1")
  (initget 1)(setq start(getpoint"\n请输入轴网插入基点:"))
  ;;;crt;;;(ChgHtp "AxisD2")
  (setq pm"\n请输入轴网生成方向:")
   (princ "\n--")(princ start)
   (princ "\n--")(princ pm)
  (setq alf(get_ang start pm))
  (setq alfa(car alf) pp (cadr alf))
  ;;;crt;;;(ChgHtp "AxisD3")
  (setq pm"\n请输入轴线终止点:")
   (princ "\n--")(princ alfa)
   (princ "\n--")(princ start)
   (princ "\n--")(princ pm)
  (setq end(get_pit alfa start pm))
  (grdraw start pp -1)
  (setq s (distance start end))
  (setq l_line (* s (sin (- (angle start end) alfa))))
  (setq layNam (XGtLay "PingMian" "轴线"))
  (setq i 0 x (nth 0 start) y (nth 1 start))
  (setvar"osmode"0)
  (repeat n
   (setq rp (nth i rp_lt) ds (nth i ds_lt))
   (repeat rp
    (setq sn (list x y 0))
    (setq en (list (- x (* l_line (sin alfa))) (+ y (* l_line (cos alfa))) 0))
    (command ".Line" sn en "")
    (setq x (+ x (* ds (cos alfa))) y (+ y (* ds (sin alfa))))
   )
   (setq i (1+ i))
  )
  (setq sn (list x y 0))
  (setq en (list (- x (* l_line (sin alfa))) (+ y (* l_line (cos alfa))) 0))  
  (command ".Line" sn en "")
  (HidHtp)
  (_resdwg)
)

;;=================================子函数开始=================================
;;名称：chorth
;;功能：正交切换
;;输入：无
;;返回：无
(defun chorth()
  (if(=(getvar"orthomode")1)
   (setvar"orthomode"0)
   (setvar"orthomode"1)
  )
)

;;=================================子函数开始=================================
;;名称：oang
;;功能：正交方式角度计算
;;输入：ang 任意角
;;返回：ang 象限角
(defun oang(ang / pi2)
  (setq pi2(/ pi 2))
  (if(=(getvar"orthomode")1)
   (setq ang(*(fix(/(+(/ pi 4)ang)pi2))pi2)p1(polar p0 ang(distance p0 p1)))
  )
ang
)

;;=================================子函数开始=================================
;;名称：chosnp
;;功能：设定捕捉方式
;;输入：无
;;返回：无
(defun chosnp(/ osm snt0 sntc snts snt1 snt2 i)
  (setq osm(getvar"osmode"))
  (if(and(=(car p1)2)(=(cadr p1)6))                ;对象捕捉切换 (F3)
   (if(= osm 0)                 
    (command"'_.ddosnap")
    (if(> osm 16384)
     (setvar"osmode"(- osm 16384))
     (setvar"osmode"(+ osm 16384))
    )
   )
  )
  (if(and(=(car p1)11)(/=(cadr p1)0))              ;鼠标中键或右键加Shift，设捕捉方式
   (progn
    (setq snt(getstring(menucmd"p0=*")))   
    (command"_.osnap"snt)  
   )
  );end of if
  (if(or(= osm 0)(> osm 16384))(setq gm1 4)(setq gm1 0))     ;设捕捉框
  (if(and(=(car p1)2)(=(cadr p1)15))(chorth))      ;调用“正交切换函数”
  (if(null snt)(setq snt""))                     
  (cond
   ((and(=(car p1)2)(>(cadr p1)43))                ;获取捕捉方式字串
    (setq snt0(chr(cadr p1)))
    (setq snt(strcat snt snt0))
    (princ snt0)
   )
   ((and(=(car p1)2)(=(cadr p1)8))                 ;字串回退
    (setq nst(1-(strlen snt)))
    (if(>= nst 0)
     (setq snt(substr snt 1 nst))
    )
    (princ"\010 \010")
   )
                                                  ;检验捕捉方式的合法性
   ((or(and(=(car p1)2)(or(=(cadr p1)13)(=(cadr p1)32)))(and(=(car p1)11)(=(cadr p1)0)))
    (setq snts"_endpoint,_midpoint,_intersection,_appint,_center,_quadrant,_perpendicular,_tangent,_node,_insert,_nearest,_none")
    (setq snt0 snt sntc t i 4)
    (setq snt2 snt snt nil)
    (while sntc
     (if(=(substr snt0 1 1)"_")(setq snt0(substr snt0 2)))
     (if(>=(strlen snt0)i)
      (if(=(substr snt0 i 1)",")
       (progn
        (setq snt1(substr snt0 1(1- i)))
        (if(/=(substr snt1 1 1)"_")(setq snt1(strcat"_"snt1)))
        (setq snt0(substr snt0(1+ i))i 4)
        (if(not(wcmatch snts(strcat"*"snt1"*")))(setq sntc nil))
       )
       (setq i(1+ i))
      )
      (progn
       (if(>=(strlen snt0)3)
        (progn
         (if(/=(substr snt0 1 1)"_")(setq snt0(strcat"_"snt0)))
         (if(wcmatch snts(strcat"*"snt0"*"))
          (progn
           (if(or(and(=(car p1)2)(=(cadr p1)13))(and(=(car p1)11)(=(cadr p1)0)))
           (princ"\nof"))
           (if(and(=(car p1)2)(=(cadr p1)32))
           (princ"of"))
           (setq i nil)(command"_.osnap"snt2)
          )
         )
        )
        (setq sntc nil)
       )
       (setq sntc nil)
      )
     )
    );while end
    (if i(prompt pm))
   )  
  );cond end
)

;;=================================子函数开始=================================
;;名称：snp
;;功能：捕捉点计算
;;输入：pp  任意点
;;返回：pp  捕捉点
  (defun snp(pp / snt osm)
   (setq osm(getvar"osmode"))
   (setq snt"_non")
   (if(>= osm 2048)(setq snt(strcat snt",_appint")osm(- osm 2048)))
   (if(>= osm 1024)(setq snt(strcat snt",_qui")osm(- osm 1024)))
   (if(>= osm  512)(setq snt(strcat snt",_nea")osm(- osm  512)))
   (if(>= osm  256)(setq snt(strcat snt",_tan")osm(- osm  256)))
   (if(>= osm  128)(setq snt(strcat snt",_per")osm(- osm  128)))
   (if(>= osm   64)(setq snt(strcat snt",_ins")osm(- osm   64)))
   (if(>= osm   32)(setq snt(strcat snt",_int")osm(- osm   32)))
   (if(>= osm   16)(setq snt(strcat snt",_qua")osm(- osm   16)))
   (if(>= osm    8)(setq snt(strcat snt",_nod")osm(- osm    8)))
   (if(>= osm    4)(setq snt(strcat snt",_cen")osm(- osm    4)))
   (if(>= osm    2)(setq snt(strcat snt",_mid")osm(- osm    2)))
   (if(>= osm    1)(setq snt(strcat snt",_endp")osm(- osm   1)))
   (if(osnap pp snt)(setq pp(osnap pp snt)))
  pp
  )

;;=================================子函数开始=================================
;;名称：get_ang
;;功能：拖动轴网，确定方向。
;;输入：p0 str 基点 字符串
;;返回：(list(angle p0 pp)pp) 表(角 点)
(defun get_ang(p0 str / dis vvv p1 p2 p3 p4 p5 p6 p7 p8 v1 v2 v3 v4 v5 v6 v7 v8
                         ang ang0 ang1 ang2 leng ppm ppn x y x1 y1 sn en sn1 en1
                         pp pp0
                )
  (princ "\n-->get_ang")
  (princ str)(setq v1 nil i 0 dis 0)
  (repeat n
   (setq rp(nth i rp_lt)ds(nth i ds_lt)dis(+ dis(* ds rp)))
   (setq i(1+ i))
  )
  (setq leng(/ dis 4))
  (if(< leng 3000)(setq leng 3000))
  (princ "\n-->get_ang--1")
  (while(/=(car(setq p1(grread 0 gm1 0)))3)
  (princ "\n-->get_ang--2")
   (chosnp)                                      ;==调用“设定捕捉方式”函数
   (if(=(car p1)5)
    (progn
     (setq p1(snp(cadr p1)))                     ;==调用“捕捉计算函数”
     (setq ang(oang(angle p0 p1)))               ;==调用“正交方式角度计算函数”
     (setq ang1 (+ ang(/ pi 2)))
     (setq ppn (polar p0 ang1 leng))
     (if v1
      (if(>(distance vvv p1) 0.1)
       (progn
        (setq ppm(polar p0 ang2 leng))
        (grdraw p0 ppn -1)          ;消前次第一竖线
        (grdraw p0 ppm -1)          ;画第一竖
       )
      )
      (grdraw p0 ppn -1)            ;首次画第一竖
     )
     (setq i 0 x (nth 0 p0) y (nth 1 p0) dis 0 x1 x y1 y)
     (repeat n
      (setq rp (nth i rp_lt) ds (nth i ds_lt) dis (+ dis (* ds rp)))
      (repeat rp
       (setq x (+ x (* ds (cos ang))) y (+ y (* ds (sin ang))))
       (if v1
        (if (>(distance vvv p1)0.1)
        (setq x1 (+ x1 (* ds (cos ang0))) y1 (+ y1 (* ds (sin ang0))))
        )
       )
       (setq sn (list x y))
       (setq en (polar sn ang1 leng))
       (if v1
        (if (> (distance vvv p1) 0.1)
         (progn
          (setq sn1 (list x1 y1))
          (setq en1 (polar sn1 ang2 leng))
          (grdraw sn1 en1 -1)
          (grdraw sn en -1)
         )
        )
        (grdraw sn en -1)
       )if end
      );repead rp end
      (setq i(1+ i))
     );repeat n end
     (setq pp (polar p0 ang (+ dis 1000)))
     (if v1
      (if (> (distance vvv p1) 0.1)
       (progn
        (setq pp0 (polar p0 ang0 (+ dis 1000)))
        (grdraw p0 pp0 -1)
        (grdraw p0 pp -1)
      ))
      (grdraw p0 pp -1)   ;显示初横线
     )
     (setq ang0 ang ang2 ang1)
     (setq v1 sn vvv p1)
    )
   )
  )   ;while束
  (princ "\n-->get_ang--3")
  (grdraw p0 ppn -1)
  (setq i 0 dis 0 x (nth 0 p0) y (nth 1 p0))
  (setq ang (angle p0 v1) ang1 (+ ang (/ pi 2.0)))
  (repeat n
   (setq rp (nth i rp_lt) ds (nth i ds_lt) dis (+ dis (* ds rp)))
   (repeat rp
    (setq x (+ x (* ds (cos ang))) y (+ y (* ds (sin ang))))
    (setq sn (list x y))
    (setq en (polar sn ang1 leng))
    (grdraw sn en -1)
   )
   (setq i (1+ i))
  )
  (princ "\n<--get_ang")
  (list(angle p0 pp)pp)
)

;;=================================子函数开始=================================
;;名称：get_pit
;;功能：拖动轴网，确定终点。
;;输入：ang p0 str 角度 基点 字符串
;;返回：v1         点
(defun get_pit(ang p0 str / pp0 pp1 p1 p2 p3 p4 p5 p6 p7 p8 v1 v2 v3 v4 v5 v6 v7 v8
                            dis len anv len1 en1 snt)
  (princ str)(setq v1 nil)
  (while(/=(car(setq p1(grread 0 gm1 0)))3)
   (chosnp)                                      ;==调用“设定捕捉方式”函数
   (if(=(car p1)5)
    (progn
     (setq p1(snp(cadr p1)))                     ;==调用“捕捉计算函数”
     (setq len(*(distance p0 p1)(sin(-(angle p0 p1)ang)))anv(+ ang(/ pi 2)))
     (setq pp0 (polar p0 anv len))
     (if v1
      (if (> (distance p1 v1) 0.1)
       (progn
        (setq pp1 (polar p0 anv len1))
        (grdraw p0 pp1 -1)
        (grdraw p0 pp0 -1)
      ))
      (grdraw p0 pp0 -1)
     )
     (setq i 0 dis 0)
     (repeat n
      (setq rp (nth i rp_lt) ds (nth i ds_lt))
      (repeat rp
       (setq dis (+ dis ds))
       (setq sn (polar p0 ang dis))
       (setq en (polar sn anv len))
       (if v1                
        (if(>(distance p1 v1)0.1)
         (progn
          (setq en1(polar sn anv len1))
          (grdraw sn en1 -1)
          (grdraw sn en -1)
        ))
        (grdraw sn en -1)
       )
      )
      (setq i(1+ i))
     )
     (setq len1 len v1 p1)
    )
   )
  )
  (grdraw p0 pp0 -1)
  (setq i 0 dis 0)
  (repeat n
   (setq rp (nth i rp_lt) ds (nth i ds_lt))
   (repeat rp
    (setq dis(+ dis ds))
    (setq sn(polar p0 ang dis))
    (setq en(polar sn anv len))
    (grdraw sn en -1)
   )
   (setq i(1+ i))
  )
  v1
)

(if (/= (getvar "ltscale") 1.0) (setvar "ltscale" 1.0))
(if (/= (getvar "celtscale") 1000.0) (setvar "celtscale" 1000.0))

(princ "\n*绘制一个方向的轴网*=Ad")
;;;crt;;;(XMkLay"PingMian""轴线")(princ)
(command".UNDO""G")
;;;crt;;;(setq ds_lt(Xdxzwd)gm1 4)
;;;crt;;;(setq rp_lt(cadr ds_lt)ds_lt(car ds_lt))
(setq ds_lt (list 3000 2000 1000))
(setq rp_lt (list 1    2    3))
  (princ "\n==")(princ ds_lt)
  (princ "\n==")(princ rp_lt)
(if(>(setq n(length rp_lt))0)(axisd_line))
(command".UNDO""E")
(setq *error* olderr olderr nil)
(princ)
)