(defun $qtyd (pt e / da etype sp ep e1 prjd)
  (setq	da    (entget e)
	etype (cdr (assoc 0 da))
  )
  (cond
    ((= etype "LINE")
     (setq sp (cdr (assoc 10 da))
	   ep (cdr (assoc 11 da))
     )
    )
    ((= etype "VERTEX")
     (setq e1 (entnext e)
	   sp (cdr (assoc 10 (entget e)))
	   ep (cdr (assoc 10 (entget e1)))
     )
    )
    (t
     (prompt "\所给实体不是直线!")
     (setq sp nil
	   ep nil
     )
    )
  )
  (if (and sp ep)
    (setq prjd ($qtyd1 pt sp ep))
  )
  prjd
)

(defun $ptoe (pt flst / d pl pr e)
  (pan2v pt)
  (setq	d (* 0.707
	     (/ (* (getvar "pickbox") (getvar "viewsize")) 206.0)
	  )
  )
  (setq d 0.1)
  (setq	pl (polar pt (* 1.25 pi) d)
	pr (polar pt (* 0.25 pi) d)
  )
  ;;(command "line" pl pr "")
  (if flst
	 	(setq e (ssget "c" pl pr flst))
    (setq e (ssget "c" pl pr))
  )
  e
)

(defun $jiajiao	(p1 p2 p3 / d1 d2 d3 pfc cos_v sin_v2 sin_v jiao ang1
		 ang2 ang)
  (setq	ang1 (angle p1 p2)
	ang2 (angle p1 p3)
	ang  (abs (- ang1 ang2))
  )
  (if (> ang pi)
    (setq ang (- (* pi 2.0) ang))
  )
  ang
)

(defun $qtyd1 (pt   sp	 ep   /	   spx	spy  spz  epx  epy  epz	 ptx
	       pty  ptz	 dx   dy   dz	cx   cy	  ct   ce   d	 c
	       prjdx	 prjdy	   prjdz     prjd
	      )
  (setq	spx (car sp)
	spy (cadr sp)
	spz (caddr sp)
	epx (car ep)
	epy (cadr ep)
	epz (caddr ep)
	ptx (car pt)
	pty (cadr pt)
	ptz (caddr pt)
	dx  (- epx spx)
	dy  (- epy spy)
	dz  (- epz spz)
  )
  (setq	ct (+ (* dx ptx) (* dy pty) (* dz ptz))
	ce (+ (* dx spx) (* dy spy) (* dz spz))
	d  (+ (* dx dx) (* dy dy) (* dz dz))
  )
  (if (equal d 0.0 0.001)
    (setq prjd sp)
    (progn
      (setq c (/ (- ct ce) d))
      (setq prjdx (+ spx (* c dx))
	    prjdy (+ spy (* c dy))
	    prjdz (+ spz (* c dz))
      )
      (setq prjd (list prjdx prjdy prjdz))
    )
  )
)

(defun $pfj (p1 p2 p3 / d ang px xx yy zz p)
  (setq	d   (distance p1 p2)
	ang (angle p1 p3)
	px  (polar p1 ang d)
	xx  (* 0.5 (+ (car p2) (car px)))
	yy  (* 0.5 (+ (cadr p2) (cadr px)))
	zz  (* 0.5 (+ (caddr p2) (caddr px)))
	p   (list xx yy zz)
  )
)

(defun $arc_csb	(e_arc
;;;cenp r ang1 ang2 sp ep midp ang len jp
		 / da etype cenp r ang1	ang2 sp	ep midp	ang len	jp p01
		 p02)
  (setq	da    (entget e_arc)
	etype (cdr (assoc 0 da))
  )
  (if (= etype "ARC")
    (setq cenp (cdr (assoc 10 da))
	  r    (cdr (assoc 40 da))
	  ang1 (cdr (assoc 50 da))
	  ang2 (cdr (assoc 51 da))
	  sp   (polar cenp ang1 r)
	  ep   (polar cenp ang2 r)
	  midp (polar cenp (- (angle sp ep) (/ pi 2)) r)
	  len  (* r (rem (+ pi pi (- ang2 ang1)) (+ pi pi)))
	  ang  (/ len r)
	  p01  ($makqx sp cenp)
	  p02  ($makqx ep cenp)
	  jp   (inters sp p01 ep p02 nil)
    )
    (prompt "\n所给实体不是弧!")
  )
  (list cenp r ang1 ang2 sp ep midp ang len jp)
)
(defun $makqx (qd yx / anyp)
  (setq anyp (polar qd (+ (* 0.5 pi) (angle yx qd)) (distance yx qd)))
)




(defun $set_p_on_e (e_pt / etype pt e endpb arc_cs cenp radius ang)
  (setq	pt    (p# (cadr e_pt))
				e     (car e_pt)
				etype (cdr (assoc 0 (entget e)))
				endpb (mapcar 'p# (bg-ypp e))
  )
  (cond
   ((= etype "LINE")
    (setq pt ($qtyd1 pt (car endpb) (cadr endpb)))
   )
   ((= etype "ARC")
    (setq arc_cs ($arc_csb e)
				  cenp	 (car arc_cs)
				  radius (cadr arc_cs)
				  ang	 (angle cenp pt)
				  pt	 (polar cenp ang radius)
    )
   )
   ((or (= etype "POLYLINE") (= etype "LWPOLYLINE"))
    (setq biao (dw-ypp1 e pt))
    (if biao
      (setq pt (car biao))
    )
   )
  )
  pt
)     ;;end of defun


(defun $txt_L (txt txth / c1 l1)
  (if (and (= (type txt) 'STR) (= (type txth) 'REAL))
    (progn
      (setvar "textsize" txth)
      (setq c1 (textbox (list (cons 1 txt)))
	    l1 (- (caadr c1) (caar c1))
      )
    )
  )
)
;;;add 98.8.26
(defun $get_ptb	(p / temp pt ptb st_p)
  (if p
    (setq st_p p
	  temp p
	  ptb  (list p)
    )
    (progn
      (setq temp (getpoint "\n回车退出 / 起点:"))
      (if temp
	(setq st_p temp
	      ptb  (list temp)
	)
	(setq ptb nil)
      )
    )
  )
  (while temp
    (setq pt (getpoint temp "\n回车闭合结束 / 下一点:"))
    (if	(null pt)
	  (if (not (equal st_p temp 0.01))
        (grdraw temp st_p -1)
	  )
      (if (not (equal pt temp 0.01))
	    (if (not (equal pt st_p 0.01))
  	      (progn
	        (grdraw temp pt -1)
	        (setq ptb (cons pt ptb))
	      )
		)
      )
    )
    (setq temp pt)
  )
  (reverse ptb)
)


;;;add 1998.10.26
(defun $p_to_e (str1    str2    glb     int     /       prom1   prom2
                go_on   xz_p    ss      the_ep  oldosm  w_ssl   w_ii
                w_ent   w_dist  w_mind  w_locp
               )
  (if str1
    (setq prom1 (strcat "\n" str1))
    (setq prom1 "\n请点选指定实体:")
  )
  (if str2
    (setq prom2 (strcat "\n" str2))
    (setq prom2 "\n未选中指定实体,请重选!")
  )
  (setq go_on  t
       ;;;; oldosm (getvar "osmode")
  )
  (sa_osmode)
  (if (= (type int) 'INT)
    (setvar "osmode" int)
  )
  (while go_on
    (setq xz_p (getpoint prom1))
    (if xz_p
      (progn
        (setq ss ($ptoe xz_p glb))
        (if ss
          (progn
            (setq w_ssl (sslength ss)
                  go_on nil
            )
            (if (= w_ssl 1)
              (progn
                (setq w_ent (ssname ss 0))
                (setq w_locp ($set_p_on_e (list w_ent xz_p)))
                (setq the_ep (list w_ent w_locp))
              )
              (progn
                (setq w_ii   0
                      w_mind 10000.0
                )
                (while (< w_ii w_ssl)
                  (setq w_ent (ssname ss w_ii))
                  (setq w_locp ($set_p_on_e (list w_ent xz_p)))
                  (setq w_dist (distance w_locp xz_p))
                  (if (< w_dist w_mind)
                    (setq the_ep (list w_ent w_locp)
                          w_mind w_dist
                    )
                  )
                  (setq w_ii (1+ w_ii))
                )
              )
            )
          )
          (prompt prom2)
        )
      )
      (setq the_ep nil
            go_on nil
      )
    )
  )
  (re_osmode)
;;; (setvar "osmode" oldosm)
  the_ep
)


(defun tocom( / lll )
(setq lll (getvar "cmdecho"))
(setvar "cmdecho" 0)
 (command "layer" "s" "PP-COM" "")
 (setvar "cmdecho" lll)
 (princ)
)


;;;modi 1998.06.11
(defun dw-qab (x y / x0 y0 a pa pb aa sca wgjd p1 p00 pp1)
  (setq x0 (getvar "userr4"))
  (setq y0 (getvar "userr2"))
  (setq	sca  1000.0
	p00  (list 0.0 0.0 0.0)
	pp1  (list x0 y0 0.0)
	wgjd (getvar "userr3")
	wgjd (* (/ wgjd 180.0) pi)
  )
  (if (< wgjd 0.0)
    (setq wgjd (+ wgjd (* 2.0 pi)))
  )
  (setq	p1 (polar p00 wgjd (/ (* (- x (car pp1)) 1000.0) sca))
	p1 (polar p1
		  (+ wgjd (/ pi 2.0))
		  (/ (* (- y (cadr pp1)) 1000.0) sca)
	   )
  )
  (list (car p1) (cadr p1))
)					;end of defun
;
(defun dw-spp (s kzm n / s1 s2 s22 s222 q)
  (setq s1 (entget s (list kzm)))
  (setq s2 (assoc -3 s1))
  (setq s22 (cdadr s2))
  (setq s222 (assoc n s22))
  (setq q (cdr s222))
)					;end of defun
;
(defun p# (p) (list (car p) (cadr p) 0.0))
					;
					;
(defun dwglq (bh2b / kk m m1)
  (setq	kk nil
	mm nil
  )
  (foreach m bh2b
    (foreach m1	mm
      (if (equal m1 m 0.001)
	(setq kk t)
      )
    )

    (if	(= kk nil)
      (setq mm (cons m mm))
      (setq kk nil)
    )
  )
  mm
)
(defun intersp (p1 p2 p3 p4 i)
  (if (= i nil)
    (progn
      (setq p1 (p# p1)
	    p2 (p# p2)
	    p3 (p# p3)
	    p4 (p# p4)
      )
      (inters p1 p2 p3 p4 nil)
    )
    (progn
      (setq p1 (p# p1)
	    p2 (p# p2)
	    p3 (p# p3)
	    p4 (p# p4)
      )
      (inters p1 p2 p3 p4)
    )
  )
)					;end of defun
;;
;; If an item is a member of the list, then return its index number, else
;; return nil.
;;
(defun ##getindex (item itemlist / m n)
  (setq n (length itemlist))
  (if (> (setq m (length (member item itemlist))) 0)
    (- n m)
    nil
  )
)

					;
					;
(defun dw-ypp (s / s1 v pp p entb n i etype)
  (setq	entb  (entget s)
	etype (cdr (assoc 0 entb))
  )
  (if (= etype "POLYLINE")
    (while (/= v "SEQEND")
      (setq s (entnext s))
      (setq s1 (entget s))
      (setq p (cdr (assoc 10 s1)))
      (setq p (list (car p) (cadr p) 0.0))
      (setq v (cdr (assoc 0 s1)))
      (if (/= v "SEQEND")
	(setq pp (cons p pp))
      )
    )
    (progn
;;; etype="LWPOLYLINE"  R14
      (if (= etype "LINE");;等高线很少是直线，只是处理函数返回点表
        (progn
           (setq
               p (cdr (assoc 10 entb))
               pp (cons (list (car p) (cadr p) 0.0) pp)
               p (cdr (assoc 11 entb))
               pp (cons (list (car p) (cadr p) 0.0) pp)
           )
        )
        (progn
	      (setq n (cdr (assoc 90 entb))
		    ;i (##getindex (assoc 10 entb) entb)
	      )
	      (repeat n
		(setq p	 (cdr (assoc 10 entb))
		      pp (cons (list (car p) (cadr p) 0.0) pp)
		      ;i	 (+ i 4)
		      entb (cdr (member (assoc 10 entb) entb))
	        )
	      )
        )
      )
    )
  )
  pp
)					;end of defun

(defun lismod (lis nn aa / ns ns1 xlis tc)
  (setq tc nil)
  (if (/= lis nil)
    (progn
      (setq ns	(length lis)
	    ns1	0
      )
      (if (>= ns (- nn 1))
	(progn
	  (cond
	    ((= nn 0)
	     (setq xlis (cons aa (cdr lis)))
	    )				;end of cond1
	    ((= nn (- ns 1))
	     (setq lis	(reverse lis)
		   xlis	(reverse (cons aa (cdr lis)))
	     )
	    )
	    (t
	     (repeat ns
	       (if (/= tc t)
		 (progn
		   (if (/= nn ns1)
		     (setq xlis	(cons (car lis) xlis)
			   lis	(cdr lis)
		     )
		     (setq xlis	(cons aa xlis)
			   lis	(cdr lis)
			   xlis	(append (reverse xlis) lis)
			   tc	t
		     )
		   )
		 )
	       )
	       (setq ns1 (+ ns1 1))
	     )				;end of repeat
	    )				;end of cond3
	  )				;end of cond
	)
      )
    )
  )
  xlis
)					;end of defun
					;
					;
(defun listoa (lis / f lis1)
  (setq f (open "zjwj" "w"))
  (prin1 lis f)
  (princ "\n" f)
  (close f)
  (setq f (open "zjwj" "r"))
  (setq lis1 (read-line f))
  (close f)
  lis1
)
;
(defun lispx (wb / fpb lt pb1 pb2 fpb1 item vmin vmax l1 l2)
  (if wb
    (progn
      (setq lt	nil
	    fpb	wb
      )
      (setq pb1 (mapcar 'car fpb))
      (setq pb2 (mapcar 'cadr fpb))
      (setq fpb1 (mapcar 'list pb2 pb1))
      (setq item (mapcar 'car fpb1))
      (setq vmin (1- (apply 'min item)))
      (while (< vmin (setq vmax (apply 'max item)))
	(setq l1   fpb1
	      item (subst vmin vmax item)
	)
	(while (setq l2 (assoc vmax l1))
	  (setq	l1 (cdr (member l2 l1))
		lt (cons l2 lt)
	  )
	)
      )
      (setq pb1 (mapcar 'car lt))
      (setq pb2 (mapcar 'cadr lt))
      (setq fpb (mapcar 'list pb2 pb1))
    )
    wb
  )
)					;end of defun
					;
					;
					;
(defun pmdist (p1 p2)
  (setq	p1 (list (car p1) (cadr p1) 0.0)
	p2 (list (car p2) (cadr p2) 0.0)
  )
  (distance p1 p2)
)
					;
					;
(defun interss (p1 p2 p3 p4 ss / p01 p11 p12 p13 p14 pt)
  (setq pt (list (/ (+ (car p1) (car p2) (car p3) (car p4)) 4.0)
		 (/ (+ (cadr p1) (cadr p2) (cadr p3) (cadr p4)) 4.0)
		 0.0
           )
  )
  (setq	p1 (list (car p1) (cadr p1) 0.0)
	p2 (list (car p2) (cadr p2) 0.0)
	p3 (list (car p3) (cadr p3) 0.0)
	p4 (list (car p4) (cadr p4) 0.0)
  )
  (setq p11 (list (- (car p1) (car pt)) (- (cadr p1) (cadr pt)) 0.0)
        p12 (list (- (car p2) (car pt)) (- (cadr p2) (cadr pt)) 0.0)
        p13 (list (- (car p3) (car pt)) (- (cadr p3) (cadr pt)) 0.0)
	p14 (list (- (car p4) (car pt)) (- (cadr p4) (cadr pt)) 0.0)
  )
  (if (= ss nil)
    (setq p01 (inters p11 p12 p13 p14 nil))
    (setq p01 (inters p11 p12 p13 p14))
  )
  (if p01
    (setq p01 (list (+ (car p01) (car pt)) (+ (cadr p01) (cadr pt)) 0.0))
    nil
  )
)					;end of defun
;
(defun styrem (/ wb wbg kgb xzm)
  (setq	wb  (tblsearch "style" (getvar "textstyle"))
	wbg (cdr (assoc 40 wb))
	kgb (cdr (assoc 41 wb))
	zxm (strcase(cdr (assoc 2 wb)))
  )
  (if (/= wbg 0.0)
    (progn
      (command "style" "" "" 0.0 "" 0.0 "" "")
      (if (= (logand (getvar "cmdactive") 1) 1)
	(command "")
      )
    )
  )
  kgb
)					;end of defun
					;
					;
;;;mid point of p1 p2
(defun midpt (p1 p2 / x)
  (mapcar '(lambda (x) (/ x 2.0)) (mapcar '+ p1 p2))
)
;;;取子表
;;;date 1997-04-15
;;;parameter:
;;;lis list
;;;start    start postion from 1
;;;num      element number
;;;return value: a sublist contain num elements
(defun sublst (lis start num / l retval)
  (setq	l      (length lis)
	num    (min (1+ (- l start))
		    (if	num
		      num
		      l
		    )
	       )
	start  (1- start)
	retval '()
  )
  (if (<= start l)
    (repeat num
      (setq retval (cons (nth start lis) retval)
	    start  (1+ start)
      )
    )
  )
  (reverse retval)
)
;;; Trims leading and trailing spaces from strings.
(defun strtrim (s)
  (cond
    ((/= (type s) 'str) nil)
    (t (strltrim (strrtrim s)))
  )
)
(defun strltrim	(s)
  (cond
    ((eq s "") s)
    ((/= " " (substr s 1 1)) s)
    (t (strltrim (substr s 2)))
  )
)
;;;
(defun strrtrim	(s)
  (cond
    ((eq s "") s)
    ((/= " " (substr s (strlen s) 1)) s)
    (t (strrtrim (substr s 1 (1- (strlen s)))))
  )
)

;;;
;;;SAVE AND INIT 3 SYS VAR
(defun com_init	(/ lst v retval)
  (setq	lst    '("cmdecho" "blipmode" "angbase")
	v      '(0 0 0)
	retval (mapcar 'getvar lst)
  )
  (mapcar 'setvar lst v)
  retval
)
;;;RESET 3 SYS VAR
(defun com_reset (v)
  (setq lst '("cmdecho" "blipmode" "angbase"))
  (mapcar 'setvar lst v)
  (princ)
)
;;;
(defun eq_ang (ang an1)
  (if (or (< (abs (rem (- ang an1) (* 2 pi))) 0.01)
	  (> (abs (rem (- ang an1) (* 2 pi))) 6.27)
      )
    t
    nil
  )
)
;;;
;;; (ai_table <table name> <bit> )
;;;
;;; Returns a list of items in the specified table.  The bit values have the
;;; following meaning:
;;;  0  List all items in the specified table.
;;;  1  Do not list Layer 0 and Linetype CONTINUOUS.
;;;  2  Do not list anonymous blocks.
;;;         A check against the 70 flag for the following bit:
;;;                  1  anonymous block
;;;  4  Do not list externally dependant items.
;;;         A check against the 70 flag is made for any of the following
;;;         bits, which add up to 48:
;;;                 16  externally dependant
;;;                 32  resolved external or dependant
;;;  8  Do not list Xrefs.
;;;         A check against the 70 flag for the following bit:
;;;                  4  external reference
;;;  16 Add BYBLOCK and BYLAYER items to list.
;;;
(defun ai_table	(table_name bit / tbldata table_list just_name)
  (setq tbldata nil)
  (setq table_list '())
  (setq table_name (strcase table_name))
  (while (setq tbldata (tblnext table_name (not tbldata)))
    (setq just_name (strcase(cdr (assoc 2 tbldata))))
    (cond
      ((= "" just_name))		; Never return null Shape names.
      ((and (= 1 (logand bit 1))
	    (or	(and (= table_name "LAYER") (= just_name "0"))
		(and (= table_name "LTYPE")
		     (= just_name "CONTINUOUS")
		)
	    )
       )
      )
      ((and (= 2 (logand bit 2))
	    (= table_name "BLOCK")
	    (= 1 (logand 1 (cdr (assoc 70 tbldata))))
       )
      )
      ((and (= 4 (logand bit 4))
	    ;; Check for Xref dependents only.
	    (zerop (logand 4 (cdr (assoc 70 tbldata))))
	    (not (zerop (logand 48 (cdr (assoc 70 tbldata)))))

       )
      )
      ((and (= 8 (logand bit 8))
	    (not (zerop (logand 4 (cdr (assoc 70 tbldata)))))
       )
      )
      ;; Vports tables can have similar names, only display one.
      ((member just_name table_list)
      )
      (T (setq table_list (cons just_name table_list)))
    )
  )
  (cond
    ((and (= 16 (logand bit 16))
	  (= table_name "LTYPE")
     )
     (setq table_list
	    (cons "BYBLOCK"
		  (cons "BYLAYER" table_list)
	    )
     )
    )
    (t)
  )
  table_list
)
;;;
(defun gpsseld
       (glb cc key / xh ssz ss p1 p2 ent ns ns1 enb2 wb p01 hh hhc)
  (setq xh t)
  (while xh
    (if	key
      (initget key)
    )
    (setq enb2 (entsel cc))
    (cond
      ((= (type enb2) 'LIST)
       (setq ent (car enb2))
       (setq wb	 (getvar "screensize")
	     hh	 (getvar "viewsize")
	     hhc (getvar "pickbox")
       )
       (setq hh (* (/ hh (cadr wb)) hhc))
       (setq p01 (cadr enb2)
	     wb	 (entget ent)
       )
       (setq p2	(polar p01 (* pi 0.25) (* 1.414 hh))
	     p1	(polar p01 (* pi 1.25) (* 1.414 hh))
       )
       (setq ss (ssget "C" p1 p2 glb))
       (if (= ss nil)
	 (progn
	   (prompt "\n没选中指定实体,重选!")
	   (setq enb2 "")
	 )
	 (setq enb2 (list (ssname ss 0) p01)
	       xh   nil
	 )
       )
      )					;end of cond list
      ((= (type enb2) 'STR)
       (setq xh nil)
      )
      ((= enb2 nil)
       (setq xh nil)
      )
    )
  )
  enb2
)					;end of defun
					;
;;;
(defun bg-ypp (ent / entb etype r pc p1 p2 ptb ans ane)
  (if (= (type ent) 'ENAME)
    (progn
      (setq entb  (entget ent)
	    etype (cdr (assoc 0 entb))
      )
      (cond
	((= etype "ARC")
	 (setq ans (cdr (assoc 50 entb))
	       ane (cdr (assoc 51 entb))
	       r   (cdr (assoc 40 entb))
	       pc  (cdr (assoc 10 entb))
	       p1  (polar pc ans r)
	       p2  (polar pc ane r)
	       ptb (list p2 p1)
	 )
	)
	((= etype "CIRCLE")
	 (setq r   (cdr (assoc 40 entb))
	       pc  (cdr (assoc 10 entb))
	       p1  (polar pc (/ pi 2) r)
	       p2  (polar pc (angle p1 pc) r)
	       ptb (list p2 p1)
	 )
	)
	((= etype "LINE")
	 (setq p1  (cdr (assoc 10 entb))
	       p2  (cdr (assoc 11 entb))
	       ptb (list p2 p1)
	 )
	)
	((wcmatch etype "*POLYLINE")
	 (setq ptb (dw-ypp ent))
	)
      )
    )
  )
  ptb
)
;;;
(defun errnil ()
  (set_tile "error" "")
)					;end of defun
					;
					;
(defun arc_mid (ent / entb p1 p2 r pc)
  (setq	entb (entget ent)
	r    (cdr (assoc 40 entb))
	pc   (cdr (assoc 10 entb))
	p1   (polar pc (cdr (assoc 50 entb)) r)
	p2   (polar pc (cdr (assoc 51 entb)) r)
	p1   (polar pc (- (angle p1 p2) (/ pi 2)) r)
  )
  p1
)
(defun arc_len (ent / r p entb)
  (if (listp ent)
    (setq r (car ent)
	  p (* r (- (caddr ent) (cadr ent)))
    )
    (setq entb (entget ent)
	  r    (cdr (assoc 40 entb))
	  p    (* r (- (cdr (assoc 51 entb)) (cdr (assoc 50 entb))))
    )
  )
  (if (< p 0)
    (setq p (+ (* 2 pi r) p))
  )
  p
)
(defun arc_ang (ent / r p entb)
  (if (listp ent)
    (setq r (car ent)
	  p (* r (- (caddr ent) (cadr ent)))
    )
    (setq entb (entget ent)
	  r    (cdr (assoc 40 entb))
	  p    (* r (- (cdr (assoc 51 entb)) (cdr (assoc 50 entb))))
    )
  )
  (if (< p 0)
    (setq p (+ (* 2 pi r) p))
  )
  (/ p r)
)
;;;subent:POLYLINE or LWPOLYLINE'S ARC SUBENT
(defun parc_mid	(subent / p1 p2 entb v42 r ang pc ent)
  (if (listp subent)
    (setq p1  (car subent)
	  p2  (cadr subent)
	  v42 (caddr subent)
    )
    (progn
      (setq p2 (cdr (assoc 10 (setq entb (entget (entnext subent))))))
      (if (null p2)
	(progn
	  (setq	ent (cdr (assoc -2 entb))
		p2  (cdr (assoc 10 (entget (entnext ent))))
	  )
	)
      )
      (setq entb (entget subent)
	    p1	 (cdr (assoc 10 entb))
	    v42	 (cdr (assoc 42 entb))
      )
    )
  )
  (caddr (parc_pcr p1 p2 v42))
)
					;
					;modi 1998.06.11
;;;subent:POLYLINE or LWPOLYLINE'S ARC SUBENT
;;;POLYLINE:subent's type  is VERTEX
(defun p_arc (subent / p1 p2 entb v42 r ang pc ent ptb)
  (if (listp subent)
    (if	(= (type (car subent)) 'ENAME)
;;;LWPOLYLINE
      (setq ptb	(dw-ypp1 (car subent) (cadr subent))
	    p1	(cadr ptb)
	    p2	(caddr ptb)
	    v42	(cadddr ptb)
      )
      (setq p1	(car subent)
	    p2	(cadr subent)
	    v42	(caddr subent)
      )
    )
    (progn
      (setq p2 (cdr (assoc 10 (setq entb (entget (entnext subent))))))
      (if (null p2)
	(progn
	  (setq	ent (cdr (assoc -2 entb))
		p2  (cdr (assoc 10 (entget (entnext ent))))
	  )
	)
      )
      (setq entb (entget subent)
	    p1	 (cdr (assoc 10 entb))
	    v42	 (cdr (assoc 42 entb))
      )
    )
  )

  (setq	ptb (parc_pcr p1 p2 v42)
	pc  (car ptb)
	r   (cadr ptb)
  )
  (list pc r p1 p2 v42 (caddr ptb))
;;;
)
					;
					;
;;;1998.06.10
(defun parc_pcr	(p1 p2 v42 / ang r pc pm len)
  (if (zerop v42)
    (setq pm  (midpt p1 p2)
	  len (pmdist p1 p2)
    )
    (progn
      (setq ang	(* 4.0 (atan (abs v42)))
	    r	(/ (pmdist p1 p2) 2.0 (sin (* 0.5 ang)))
	    len	(* ang r)
      )
      (if (> v42 0)
	(setq pc (polar p1 (+ (angle p1 p2) (* 0.5 (- pi ang))) r)
	      pm (polar pc (- (angle p1 p2) (/ pi 2)) r)
	)
	(setq pc (polar p1 (- (angle p1 p2) (* 0.5 (- pi ang))) r)
	      pm (polar pc (- (angle p2 p1) (/ pi 2)) r)
	)
      )
    )
  )
  (list pc r pm len)
)
;;;
(defun undo_m (/ temp)
  (setq temp (getvar "undoctl"))
  (cond	((= 13 temp) (command ".undo" "e"))
	((= 0 temp) (command ".undo" "all"))
  )
  (command ".undo" "m")
)
;;;
(defun #undo_init (/ temp)
  (setq temp (getvar "undoctl"))
  (cond	((= 13 temp) (command ".undo" "e"))
	((= 0 temp) (command ".undo" "all"))
  )
)
					;
					;
(defun undo_b (/ temp)
  (setq temp (getvar "undoctl"))
  (if (= 13 temp)
    (command ".undo" "e")
  )
  (initget "U")
  (setq temp (getkword "\n回车退出 / 取消 U:"))
  (if (= temp "U")
    (command ".undo" "b")
  )
)
(defun dtor (ang)
  (* (/ ang 180.0) pi)
)
(defun rtod (ang)
  (* (/ ang pi) 180.0)
)
(defun mentselp	(pt glb ent / sca p1 p2 ss)
  (span pt)
					;(setq sca (* 0.0177 (/ (getvar "viewsize") 206.0)))
  (setq	sca
	 (* 0.0177
	    (/ (getvar "viewsize") (* 0.5 (cadr (getvar "screensize"))))
	 )
  )
  (setq	p2 (polar pt (* pi 0.25) sca)
	p1 (polar pt (* pi 1.25) sca)
  )
  (setq ss (ssget "C" p1 p2 glb))
  (if ss
    (progn
      (if (and ent (ssmemb ent ss))
	(ssdel ent ss)
      )
      (if (> (sslength ss) 0)
	(ssname ss 0)
	nil
      )
    )
    nil
  )
)
;;;
(defun mentselps (pt sca glb ent / p1 p2 ss)
  (span pt)
  (setq	p2 (polar pt (* pi 0.25) sca)
	p1 (polar pt (* pi 1.25) sca)
  )
  (setq ss (ssget "C" p1 p2 glb))
  (if ss
    (progn
      (if (and ent (ssmemb ent ss))
	(ssdel ent ss)
      )
      (if (> (sslength ss) 0)
	(ssname ss 0)
	nil
      )
    )
    nil
  )
)
;;;
(defun d_mark (pt / sca p1 p2)
  (if (and pt (listp pt))
    (progn
					;(setq sca (* 0.707 (/ (* 8 (getvar "viewsize")) 206.0)))
      (setq sca	(* 0.707
		   (/ (* 8 (getvar "viewsize"))
		      (* 0.5 (cadr (getvar "screensize")))
		   )
		)
      )
      (setq p1 (polar pt (* pi 0.25) sca)
	    p2 (polar pt (* pi 1.25) sca)
      )
      (grdraw p1 p2 -1)
      (setq p1 (polar pt (* pi 0.75) sca)
	    p2 (polar pt (* pi 1.75) sca)
      )
      (grdraw p1 p2 -1)
    )
  )
)
					;
					;
(defun scanb (ss / ssx xh ns1)
  (if (= (type ss) 'STR)
    (progn
      (setq ssx "")
      (if (= (read ss) nil)
	(setq xh nil)
	(setq xh  "T"
	      ns1 1
	)
      )
      (while xh
	(if (/= (substr ss ns1 1) " ")
	  (setq ssx (strcat ssx (substr ss ns1 1)))
	)
	(setq ns1 (+ ns1 1))
	(if (> ns1 (strlen ss))
	  (setq xh nil)
	)
      )
    )
  )
  ssx
)					;end of defun
					;
					;

;;; Check current szbjx's value
;;;minlimit is value min limit
;;; error chkecked return t else nil
(defun chknum (minl value / v)
  (setq v (strtrim value))
  (if (and (/= v "") (= "." (substr v 1 1)))
    (setq v (strcat "0" v))
  )
  (cond
    ((null minl)
     (if (or (null v)
	     (wcmatch v "* *,*`.*`.*,*\"*")
;;;3/1/99
	     (not (numberp (read v)))
	 )
       T
       nil
     )
    )
    ((numberp minl)
     (if (or (null v)
	     (wcmatch v "* *,*`.*`.*,*\"*")
;;;3/1/99
	     (not (numberp (read v)))
	     (>= minl (atof v))
	 )
       T
       nil
     )
    )
    ((listp minl)
     (if (or (null v)
	     (wcmatch v "* *,*`.*`.*,*\"*")
;;;3/1/99
	     (not (numberp (read v)))
	     (> (car minl) (atof v))
	     (< (cadr minl) (atof v))
	 )
       T
       nil
     )
    )
    (t T)
  )
)

(defun &sxdw
       (str pt wbg dqfs ang / ns ns1 str2 strb wb pt2 biao kgb dl)
  (setq	ns   (strlen str)
	ns1  1
	str2 ""
	strb nil
	kgb  (styrem)
  )
  (repeat ns
    (if	(and (= (substr str ns1 1) "^") (< ns1 ns))
      (setq strb (cons (list str2 (substr str (+ ns1 1) 1)) strb)
	    str2 (strcat str2 " ")
	    ns1	 (+ ns1 1)
      )
      (setq str2 (strcat str2 (substr str ns1 1)))
    )
    (setq ns1 (+ ns1 1))
  )
  (command "text" "j" dqfs pt wbg (/ (* ang 180.0) pi) str2)
  (if strb
    (progn
      (setq wb	(entget (entlast))
	    pt2	(cdr (assoc 10 wb))
      )
      (foreach biao strb
	(setvar "textsize" wbg)
	(setq wb (textbox (list (cons 1 (car biao))))
	      dl (abs (- (caar wb) (caadr wb)))
	)
	(command "text"
		 (polar	(polar pt2 ang (+ dl (* wbg kgb 0.3)))
			(+ ang (* pi 0.5))
			(* wbg 0.4)
		 )
		 (* wbg 0.5)
		 (/ (* ang 180.0) pi)
		 (cadr biao)
	)
      )
    )
  )
)					;end of defun
;
(defun &gzdkbj (/ ppsptb ppsenb	undo:m is:lin ss ent oldvar olderr flag
		w e is:arc)
  (setq	is:lin	T
	oldvar	(com_init)
	;;;olderr	*error*
	;;;*error*	#line_err
  )
  (pusherr #line_err)
  (while (listp (setq ent (last (#_pline))))
    (if	ent
      (progn
	(setq w (getvar "plinewid"))
	(command ".pedit" (entlast) "" "w" w "")
	(setq ppsenb (cons (entlast) ppsenb))
      )
    )
  )
  (cond
    ((> (length ppsptb) 2)
     (if (/= ent "B")
       (progn
	 (command "pline" (car ppsptb) (last ppsptb) "")
	 (setq ppsenb (cons (entlast) ppsenb)
	       ent    "B"
	 )
       )
     )
     (setq ss (ssadd))
     (foreach e	ppsenb
       (ssadd e ss)
     )
     (if (= ent "B")
       (if is:arc
	 (command ".pedit" (last ppsenb) "j" ss "" "c" "")
	 (progn
	   (ssadd (entlast) ss)
	   (command ".pedit" (last ppsenb) "j" ss "" "")
	 )
       )
       (command ".pedit" (last ppsenb) "j" ss "" "")
     )
     (setq ent (entlast))
    )
    ((/= ppsptb nil)
     (setq ent "")
     (prompt "\n用地范围控制点不能少于三个,重定!")
    )
    (t (setq ent nil))
  )
  (if flag
    (menucmd "s=")
  )
  (if (= flag 2)
    (menucmd "s=")
  )
  ;;;(setq *error* olderr)
  (clr_err)
  (com_reset oldvar)
  ent
)					;end of defun
;;; Play slide
;;;显示\commres\image目录下的幻灯
(defun playsld (sldfn sldkey / x y m_path)
  (setq	x (dimx_tile sldkey)
	y (dimy_tile sldkey)
	m_path (strcat (HY_GetInstallDir) hyszdl_gv_commres_dir "\\" hyszdl_gv_image_dir "\\")
  )
  (start_image sldkey)
  (fill_image 0 0 x y -2)
  (slide_image 0 0 x y (strcat m_path sldfn))
  (end_image)
)
;;;显示绝对路径下的幻灯
(defun play_path_sld (sldfn sldkey / x y)
  (setq	x (dimx_tile sldkey)
	y (dimy_tile sldkey)
  )
  (start_image sldkey)
  (fill_image 0 0 x y -2)
  (slide_image 0 0 x y sldfn)
  (end_image)
)
;;;插入\commres\block目录下的图块
(defun szdl_ins_sysblk (xc_blkn xc_insp xc_xsc xc_yxc xc_rta / m_path w_blkn)
  (setq	m_path (strcat (HY_GetInstallDir) hyszdl_gv_commres_dir)
	m_path (strcat m_path "\\")
	m_path (strcat m_path hyszdl_gv_block_dir)
	m_path (strcat m_path "\\")
	w_blkn (strcat m_path xc_blkn)
  )
  (command "_.insert" w_blkn xc_insp xc_xsc xc_yxc xc_rta)
)
;;; Pass a number and a list and recieve the list back with that item missing.
(defun del_item	(value lis / tmp j n)
  (setq tmp '())
  (setq j 0)
  (foreach n lis
    (if	(/= value j)
      (setq tmp (cons n tmp))
    )
    (setq j (1+ j))
  )
  (reverse tmp)
)
;;;Add an item to a list at current position
(defun add_item_n (pos lis additem / j n tmp)
  (setq	tmp '()
	j   0
  )
  (if (equal '() lis)
    (setq tmp (cons additem tmp))
    (progn
      (foreach n lis
	(if (< pos j)
	  (setq tmp (cons n tmp))
	  (if (= pos j)
	    (setq tmp (cons additem tmp)
		  tmp (cons n tmp)
	    )
	    (setq tmp (cons n tmp))
	  )
	)
	(setq j (1+ j))
      )
      (setq tmp (reverse tmp))
    )
  )
)					;end of defun
					;
					;
(defun qdqpmd (/ pm pn ss aa bb w px pld p1x pru)
  (setq pm (getvar "vsmax"))
  (setq pn (getvar "vsmin"))
  (setq ss (/ (- (car pm) (car pn)) (- (cadr pm) (cadr pn))))
  (setq aa (getvar "viewsize"))
  (setq bb (getvar "viewctr"))
  (setq w (* ss aa))
  (setq px (polar bb pi (/ w 2)))
  (setq pld (polar px (/ pi -2) (/ aa 2)))
  (setq p1x (polar bb 0 (/ w 2)))
  (setq pru (polar p1x (/ pi 2) (/ aa 2)))
  (list pld pru)
)					;end of defun
					;
					;
(defun pdqpmd (pt / wb pld pru zz)
  (setq	wb  (qdqpmd)
	pld (car wb)
	pru (cadr wb)
  )
  (if (or (< (car pt) (car pld))
	  (< (cadr pt) (cadr pld))
	  (> (car pt) (car pru))
	  (> (cadr pt) (cadr pru))
      )
    (setq zz "T")
  )
  zz
)					;end of defun

(defun pt_m2wcs	(pt mat / x y z m n)
  (if (null (caddr pt))
    (setq pt (list (car pt) (cadr pt) 0.0))
  )
  (setq	pt (append pt (list 1.0))
	x  (apply '+ (mapcar '(lambda (m n) (* (car m) n)) mat pt))
	y  (apply '+ (mapcar '(lambda (m n) (* (cadr m) n)) mat pt))
	z  (apply '+ (mapcar '(lambda (m n) (* (caddr m) n)) mat pt))
  )
  (list x y z)
)
;;;设倾角
(defun #setangpt (pt str / y ent entb etype p1 p2 ang mat ent1 p0 nent)
  (initget "V")
  (if (and pt (listp pt))
    (setq
      ang (getangle pt (strcat "\n参考线定方向 V / " str "方向<0>:"))
    )
    (setq ang (getangle (strcat "\n参考线定方向 V / " str "方向<0>:")))
  )
  (cond
    ((null ang)
     (setq ang 0)
    )
    ((= ang "V")
     (setq y t)
     (while y
       (setq ent (nentsel "\n选择方向参考线:"))
       (if ent
	 (progn
	   (if (= (length ent) 4)
	     (setq mat	(caddr ent)
		   nent	ent
	     )
	     (setq mat nil)
	   )
	   (setq p0    (cadr ent)
		 ent   (car ent)
		 entb  (entget ent)
		 etype (cdr (assoc 0 entb))
	   )
	   (cond
	     ((= etype "LWPOLYLINE")
	      (setq entb (dw-ypp1 (if nent
				    nent
				    ent
				  )
				  p0
			 )
	      )
	      (if (and entb (zerop (cadddr entb)))
		(progn
		  (setq	p1 (cadr entb)
			p2 (caddr entb)
		  )
		  (setq	ang (min (angle p1 p2) (angle p2 p1))
			y   nil
		  )
		)
		(progn
		  (beep)
		  (prompt "\n请选直线段!")
		)
	      )
	     )
	     ((= etype "LINE")
	      (setq p1 (cdr (assoc 10 entb))
		    p2 (cdr (assoc 11 entb))
	      )
	      (if mat
		(setq p1 (pt_m2wcs p1 mat)
		      p2 (pt_m2wcs p2 mat)
		)
	      )
	      (setq ang	(min (angle p1 p2) (angle p2 p1))
		    y	nil
	      )
	     )
	     ((= etype "VERTEX")
	      (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
		(progn
		  (setq	p1 (cdr (assoc 10 entb))
			p2 (cdr	(assoc 10 (setq entb (entget (entnext ent))))
			   )
		  )
		  (if (null p2)
		    (progn
		      (setq ent1 (cdr (assoc -2 entb))
			    p2	 (cdr (assoc 10 (entget (entnext ent1))))
		      )
		    )
		  )
		  (if mat
		    (setq p1 (pt_m2wcs p1 mat)
			  p2 (pt_m2wcs p2 mat)
		    )
		  )
		  (setq	ang (min (angle p1 p2) (angle p2 p1))
			y   nil
		  )
		)
		(progn
		  (beep)
		  (prompt "\n请选直线段!")
		)
	      )
	     )
	     (t
	      (beep)
	      (prompt "\n请选直线段!")
	     )
	   )
;;;end of cond

	   (if (numberp ang)
	     (progn
	       (setq p1 (getangle "\n与所选线段夹角<0>:"))
	       (if (null p1)
		 (setq p1 0)
	       )
	       (setq ang (+ ang p1))
	     )
	   )
	   (if pt
	     (progn
	       (if (numberp ang)
		 (progn
		   (setvar "snapang" ang)
		   (setvar "orthomode" 1)
		 )
		 (setq ang (getvar "snapang"))
	       )
	       (setq ang (getangle pt (strcat "\n" str "方向:")))
	       (if (null ang)
		 (setq ang (angle pt (cadr (grread t))))
	       )
	     )
	   )

	 )
	 (setq y nil)
       )
     )
;;;end of while y
    )
    (t)
  )
  (if (not (numberp ang))
    (setq ang (getvar "snapang"))
  )
  (setvar "snapang" ang)
  (setvar "orthomode" 1)
  ang
)

(#ppls "bgtool")

;;;e=*polyline
;;;when e in block,e= the result of nentsel i.e. (subent selectpt convert_matrix mainent)
;;;e=*polyline
;;;when e in block,e= the result of nentsel i.e. (subent selectpt convert_matrix mainent)
(defun dw-ypp1 (e    p0	  /    k70  entb pp2  pp   etype     n	  p1
		p2   pp1  dp   v42  v422 a    a1   a2	mat  wb	  ptb
		ptc  ptm  i    r_cir  sca_tmp
	       )
	(setq sca_tmp (/ 1.0 (DL_GetDrawingFactor)) )
  (setq	k70 (cdr (assoc	70
			   (setq entb (entget (if (listp e)
					                   (car e)
					                   e
					               )
				         )
			   )
		        )    )
  )
  (setq	pp2   (reverse (getplvex e))
				etype (cdr (assoc 0 entb))
  )
;;;----
  (setq	n   0
				pp1 nil
  )
  (while (< n (- (length pp2) 1))
    (setq p1 (nth n pp2)
	  			p2 (nth (+ n 1) pp2)
    )
    (setq pp1 (cons (list (car p2) (car p1) (cadr p2) (cadr p1)) pp1))
    (setq n (+ n 1))
  )
  (setq n 0)
  (while (< n (length pp1))
    (setq pp (nth n pp1))
    (setq p1   (car pp)
				  p2   (cadr pp)
	  			v42  (caddr pp)
	  			v422 (cadddr pp)
    )
    (if (< (pmdist p1 p2) (* 0.001 sca_tmp) )
     t
     (progn
	    (if	(zerop v42)
	      (progn
					(setq i	(interss p1
							 p2
							 p0
							 (polar p0 (+ (/ pi 2) (angle p1 p2)) 1026.0)
							 nil
						)
					)
					(cond
					  ((equal (pmdist p0 p2) 0.0 (* 0.1 sca_tmp))
					   (setq i  p2
									 dp (cons (list (list i p1 p2 0.0) 0.0) dp)
					   )
					  )
					  ((equal (pmdist p0 p1) 0.0 (* 0.1 sca_tmp))
					   (setq i  p1
									 dp (cons (list (list i p1 p2 0.0) 0.0) dp)
					   )
					  )
					  (i
					   (setq a  (angle p1 p2)
									 a1 (angle p1 i)
									 a2 (angle i p2)
					   )
					   (if (or (> (abs (rem (- a2 a1) (* pi 2.0))) 6.27)
									   (< (abs (rem (- a2 a1) (* pi 2.0))) 0.01)
					       )
					     (progn
					       (setq d (pmdist i p0))
					       (setq dp (cons (list (list i p1 p2 0.0) d) dp))
					     )
					   )
					  )
					)
	      )
	      (progn
					(setq wb (parc_pcr p1 p2 v42))
					(setq ptc   (car wb)
					      r_cir (cadr wb)
					      ptm   (caddr wb)
					)
					(if (> v42 0.0)
					  (setq ptb (calali (polar p0 (angle ptc p0) (* 10.26 sca_tmp)) ptc
					                    (list '(0 . "ARC") (cons 40 r_cir) (cons 10 ptc)
					                           (cons 50 (angle ptc p2)) (cons 51 (angle ptc p1))
					                    )
					            )
					  )
					  (setq ptb (calali (polar p0 (angle ptc p0) (* 10.26 sca_tmp)) ptc
					                    (list '(0 . "ARC") (cons 40 r_cir) (cons 10 ptc)
					                           (cons 50 (angle ptc p1)) (cons 51 (angle ptc p2))
					                    )
					            )
					  )
					)
	;				(setq
	;				  ptb (car (HY_LinePLineInt e
	;						     (polar p0 (angle ptc p0) (* 10.26 (dbl)))
	;						     ptc
	;					   )
	;				      )
	;				)
					(foreach ptm ptb
					  (if (equal r_cir (pmdist ptc ptm) (* 0.01 sca_tmp))
					    (setq dp
						   (cons (list (list ptm p1 p2 v42) (pmdist ptm p0)) dp)
					    )
					  )
					)
	      )
	    )
	  ))    ;;end of if (< (pmdist p1 p2) (* 0.001 sca_tmp) )
    (setq n (+ n 1))
  )
  (if (/= dp nil)
    (progn
      (setq dp (lispx dp)
	          wb (caar dp)
      )
      (list (car wb) (cadr wb) (caddr wb) (cadddr wb))
    )
    (progn
					;   (prompt "\n选点位置不明确,重选.")
      nil
    )
  )
)					;end of defun
;;
;;
(defun dw-lypp1	(e p0 / e1 p1 p2 a1 px p etype entb pc r ans ane)
  (if (and e p0 (list p0))
    (progn
;;;18:26 98-11-12
      (setq entb  (entget e)
	    etype (cdr (assoc 0 entb))
      )
      (cond
	((wcmatch etype "*POLYLINE")
	 (dw-ypp1 e p0)
	)
	((= etype "LINE")
	 (setq p1 (p# (cdr (assoc 10 entb)))
	       p2 (p# (cdr (assoc 11 entb)))
	 )
	 (setq a1 (angle p1 p2)
	       p0 (p# P0)
	 )
	 (setq px (polar p0 (+ a1 (/ pi 2)) 1))
	 (setq p (inters p0 px p1 p2 nil))
	 (list p p1 p2)
	)
	((= etype "ARC")
	 (setq pc  (p# (cdr (assoc 10 entb)))
	       r   (cdr (assoc 40 entb))
	       ans (cdr (assoc 50 entb))
	       ane (cdr (assoc 51 entb))
	       p1  (polar pc ans r)
	       p2  (polar pc ane r)
	       p   (polar pc (angle pc p0) r)
	 )
	 (list p p1 p2)
	)
      )
    )
    nil
  )
;;;18:26 98-11-12
)
					;
(defun dw-psc (l / h m m1 dx dy w)
  (setq	h  (getvar "viewsize")
	m  (getvar "vsmax")
	m1 (getvar "vsmin")
	dx (- (car m) (car m1))
	dy (- (cadr m) (cadr m1))
	w  (* (/ dx dy) h)
  )
  (/ w l)
)

(defun &wait_bz	()
  (cond
    ((= ~wait_bzz nil)
     (princ "-")
     (setq ~wait_bzz "\\")
    )
    ((= ~wait_bzz "-")
     (princ "\010")
     (princ ~wait_bzz)
     (setq ~wait_bzz "\\")
    )
    ((= ~wait_bzz "\\")
     (princ "\010")
     (princ ~wait_bzz)
     (setq ~wait_bzz "|")
    )
    ((= ~wait_bzz "|")
     (princ "\010")
     (princ ~wait_bzz)
     (setq ~wait_bzz "/")
    )
    ((= ~wait_bzz "/")
     (princ "\010")
     (princ ~wait_bzz)
     (setq ~wait_bzz "-")
    )
  )
)					;end of defun
;
(defun &cal_tex_dis (wb / bb dist str texh)
  (cond
    ((and (= (type wb) 'LIST) (= (type (car wb)) 'LIST))
     (setq bb	(subst '(50 . 0.0) (assoc 50 wb) wb)
	   bb	(textbox bb)
	   dist	(abs (- (caar bb) (caadr bb)))
     )
    )
    ((= (type wb) 'ENAME)
     (setq bb (entget wb))
     (setq bb	(subst '(50 . 0.0) (assoc 50 bb) bb)
	   bb	(textbox bb)
	   dist	(abs (- (caar bb) (caadr bb)))
     )
    )
    ((= (type wb) 'LIST)
     (setq str	(car wb)
	   texh	(cadr wb)
     )
     (if (= (strlen str) 0)
         (setq dist 0.0)
         (setq  bb (list '(50 . 0.0) (cons 40 texh) (cons 1 str))
                bb	(textbox bb)
	        dist	(abs (- (caar bb) (caadr bb)))
	 )
     )
    )
  )
  dist
)					;end of defun
					;
					;
(defun &view_ptb (ptb / ptb2 xmin ymin xmax ymax)
  (setq	ptb2 (qdqpmd)
	ptb2 (append ptb ptb2)
  )
  (setq	xmin (apply 'min (mapcar 'car ptb2))
	ymin (apply 'min (mapcar 'cadr ptb2))
	xmax (apply 'max (mapcar 'car ptb2))
	ymax (apply 'max (mapcar 'cadr ptb2))
  )
  (if (or (pdqpmd (list xmin ymin 0.0))
	  (pdqpmd (list xmax ymax 0.0))
      )
    (progn
      (command "zoom"
	       "w"
	       (list (- xmin 10.0) (- ymin 10.0) 0.0)
	       (list (+ xmax 10.0) (+ ymax 10.0) 0.0)
      )
      T
    )
    nil
  )
)					;end of defun
(defun &xs_chdsj (ent2 wb / bb ent biao)
  (foreach bb wb
    (if	(and (/= (car bb) -1)
	     (= (type (cdr bb)) 'ENAME)
	     (= (member (cdr bb) enzb) nil)
	)
      (progn
	(setq ent  (cdr bb)
	      biao (entget ent '("*"))
	      enzb (cons ent enzb)
	)
	(print biao)
	(&xs_chdsj ent biao)
      )
    )
  )
)
;;;显示对话框
;;;add by 汪洪涛 02/20/2001
(defun pub_display_dlg (xc_dlg xc_n / w_idcl m_dcl)
  (setq	m_dcl (strcat (HY_GetInstallDir)
		      hyszdl_gv_commres_dir
		      "\\"
		      hyszdl_gv_dcl_dir "\\"
		      xc_dlg
	      )
  )
  (if (< (setq w_idcl (load_dialog m_dcl)) 0)
    (progn
      (alert "对话框装载错误!!!")
      (exit)
    )
  )
  (if (not (new_dialog xc_n w_idcl))
    (progn
      (alert "对话框显示错误!!!")
      (exit)
    )
  )
  w_idcl
)
;;;加载对话框
;;;add by 汪洪涛 02/20/2001
(defun szdl_load_dlg (xc_dlg / w_idcl m_dcl)
  (setq	m_dcl (strcat (HY_GetInstallDir)
		      hyszdl_gv_commres_dir
		      "\\"
		      hyszdl_gv_dcl_dir "\\"
		      xc_dlg
	      )
  )
  (if (< (setq w_idcl (load_dialog m_dcl)) 0)
    (progn
      (alert "对话框装载错误!!!")
      (exit)
    )
  )
  w_idcl
)
;
;;;-----------------------------------------------------------
(princ)

(defun JZZ_DisplayPercent (str1 num1 nummax)
  (prompt (strcat "\r" str1 " " (rtos (* (/ (float (1+ num1)) (float nummax)) 100) 2 0)"%"))
)

;; [2004/02/10 by 董冠军 ]
;; 得到由 lst_zhx 定义的桩号线的最小、最大桩号 $$
(defun zhx_get_minmax ( lst_zhx / elem zh_min zh_max tt tt2 )
	(setq zh_min nil zh_max nil)
	(foreach elem lst_zhx
    (if (= (car elem) "LINE")
      (setq tt (nth 3 elem) tt2 (nth 4 elem) )
      (setq tt (nth 6 elem) tt2 (nth 7 elem) )
    )
    (if (= zh_min nil)
      (setq zh_min (min tt tt2) )
      (setq zh_min (min tt tt2 zh_min) )
    )
    (if (= zh_max nil)
      (setq zh_max (max tt tt2) )
      (setq zh_max (max tt tt2 zh_max) )
    )
	) ;foreach
	(list zh_min zh_max)
)

;; [2004/02/10 by 董冠军 ]
;; 求取实体 ent 与 w_lnkb 中各实体的交点，找到一个，即返回；若无，返回nil $$
(defun zhx_get_inter ( ent w_lnkb / pt ii )
	(setq pt nil ii 0 )
	(while (and (not pt) (< ii (length w_lnkb)))
		(setq pt (car  (HY_QXPMJD ent (cadr (nth ii w_lnkb)))) )
		(setq ii (+ ii 1) )
	)
	pt
)

;;-----------控制点编号里面用到的函数，从规划里面拿过来的--------------------
(defun p_line(p00 ptb)
  (setq ptb (pt_d_px p00 ptb))
  ;;(print ptb)
  (if ptb (setq ptb (mapcar 'cadr ptb)));;;;该语句有时会出错
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;modi 1998.06.03 06.08 06.16 07.07
(defun #gl_vnp (/ ptb p2)
  (setq	ptb (bg-ypp (entlast))
	p2  (car ptb)
  )
  (if (equal p1 p2 0.01)
    (setq p1 (cadr ptb))
    (setq p1 p2)
  )
  p1
)
;;;
(defun #ref_l (/ y ent entb etype p1 p2 ang mat ent1 p0 nent)
  (setq y t)
  (while y
    (setq ent (nentsel "\n选择参考线:"))
    (if	ent
      (progn
	(if (= (length ent) 4)
	  (setq	mat  (caddr ent)
		nent ent
	  )
	)
	(setq p0    (cadr ent)
	      ent   (car ent)
	      entb  (entget ent)
	      etype (cdr (assoc 0 entb))
	)
	(cond
	  ((= etype "LWPOLYLINE")
	   (setq entb (dw-ypp1 (if nent
				 nent
				 ent
			       )
			       p0
		      )
	   )
	   (if (and entb (zerop (cadddr entb)))
	     (progn
	       (setq p1	(cadr entb)
		     p2	(caddr entb)
	       )
	       (setq ang (min (angle p1 p2) (angle p2 p1))
		     y	 nil
	       )
	       (setvar "snapang" ang)
	       (setvar "orthomode" 1)
	     )
	     (prompt "\n请选直线段!")
	   )
	  )
	  ((= etype "LINE")
	   (setq p1 (cdr (assoc 10 entb))
		 p2 (cdr (assoc 11 entb))
	   )
	   (if mat
	     (setq p1 (pt_m2wcs p1 mat)
		   p2 (pt_m2wcs p2 mat)
	     )
	   )
	   (setq ang (min (angle p1 p2) (angle p2 p1))
		 y   nil
	   )
	   (setvar "snapang" ang)
	   (setvar "orthomode" 1)
	  )
	  ((= etype "VERTEX")
	   (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
	     (progn
	       (setq p1	(cdr (assoc 10 entb))
		     p2	(cdr (assoc 10 (setq entb (entget (entnext ent)))))
	       )
	       (if (null p2)
		 (progn
		   (setq ent1 (cdr (assoc -2 entb))
			 p2   (cdr (assoc 10 (entget (entnext ent1))))
		   )
		 )
	       )
	       (if mat
		 (setq p1 (pt_m2wcs p1 mat)
		       p2 (pt_m2wcs p2 mat)
		 )
	       )
	       (setq ang (min (angle p1 p2) (angle p2 p1))
		     y	 nil
	       )
	       (setvar "snapang" ang)
	       (setvar "orthomode" 1)
	     )
	     (progn
	       (beep)
	       (prompt "\n请选直线段!")
	     )
	   )
	  )
	  (t
	   (beep)
	   (prompt "\n请选直线段!")
	  )
	)
      )
      (setq y nil)
    )
  )
)
;;;
(defun #getaep (/ pc)
					;(setq cc "\n回车动态 / 参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 弧终点:")
  (setq cc "\n回车动态 / 弧终点:")
  (initget "Z S D P X R V J F G")
  (if #pgetpt
    (setq p3 (#pgetpt p2 cc))
    (setq p3 (#getpt p2 cc))
  )
  (if (and p3
	   (listp p3)
	   (not (equal p2 p3 0.01))
	   (not (eq_ang (angle p2 p3) (angle p1 p2)))
      )
    (progn
      (undo_m)
      (HY_SV)
      (command "_.arc" p1 p2 p3)
      (HY_RV)
      (setq p1 p3)
    )
    (progn
      (undo_m)
      (prompt "\n弧终点:")
      (HY_SV)
      (command "_.arc" p1 p2 pause)
      (HY_RV)
      (setq p1 (#gl_vnp))
    )
  )

  (if ZB:SX
    (progn
      (setq pc (cdr (assoc 10 (entget (entlast)))))
      (setvar "snapang" (angle pc p1))
      (setvar "orthomode" 1)
    )
  )

  (setq ppsptb (cons p1 ppsptb))

)
;;;设倾角
(defun #setang (/ y ent entb etype p1 p2 ang mat ent1 p0 nent)
  (initget "V")
  (if (and pt (listp pt))
    (setq ang (getangle pt "\n参考线定角度 V / 角度<0>:"))
    (setq ang (getangle "\n参考线定角度 V / 角度<0>:"))
  )
  (cond
    ((null ang)
     (setq ang 0)
    )
    ((= ang "V")
     (setq y t)
     (while y
       (setq ent (nentsel "\n选择角度参考线:"))
       (if ent
	 (progn
	   (if (= (length ent) 4)
	     (setq mat	(caddr ent)
		   nent	ent
	     )
	     (setq mat nil)
	   )
	   (setq p0    (cadr ent)
		 ent   (car ent)
		 entb  (entget ent)
		 etype (cdr (assoc 0 entb))
	   )
	   (cond
	     ((= etype "LWPOLYLINE")
	      (setq entb (dw-ypp1 (if nent
				    nent
				    ent
				  )
				  p0
			 )
	      )
	      (if (and entb (zerop (cadddr entb)))
		(progn
		  (setq	p1 (cadr entb)
			p2 (caddr entb)
		  )
		  (setq	ang (min (angle p1 p2) (angle p2 p1))
			y   nil
		  )
		  (setvar "snapang" ang)
		  (setvar "orthomode" 1)
		)
		(progn
		  (beep)
		  (prompt "\n请选直线段!")
		)
	      )
	     )
	     ((= etype "LINE")
	      (setq p1 (cdr (assoc 10 entb))
		    p2 (cdr (assoc 11 entb))
	      )
	      (if mat
		(setq p1 (pt_m2wcs p1 mat)
		      p2 (pt_m2wcs p2 mat)
		)
	      )
	      (setq ang	(min (angle p1 p2) (angle p2 p1))
		    y	nil
	      )
	     )
	     ((= etype "VERTEX")
	      (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
		(progn
		  (setq	p1 (cdr (assoc 10 entb))
			p2 (cdr	(assoc 10 (setq entb (entget (entnext ent))))
			   )
		  )
		  (if (null p2)
		    (progn
		      (setq ent1 (cdr (assoc -2 entb))
			    p2	 (cdr (assoc 10 (entget (entnext ent1))))
		      )
		    )
		  )
		  (if mat
		    (setq p1 (pt_m2wcs p1 mat)
			  p2 (pt_m2wcs p2 mat)
		    )
		  )
		  (setq	ang (min (angle p1 p2) (angle p2 p1))
			y   nil
		  )
		)
		(progn
		  (beep)
		  (prompt "\n请选直线段!")
		)
	      )
	     )
	     (t
	      (beep)
	      (prompt "\n请选直线段!")
	     )
	   )
;;;end of cond

	   (if (numberp ang)
	     (progn
	       (setq p1 (getangle "\n与所选线段夹角<0>:"))
	       (if (null p1)
		 (setq p1 0)
	       )
	       (setq ang (+ ang p1))
	     )
	   )

	 )
	 (setq y nil)
       )
     )
;;;end of while y
    )
    (t)
  )
  (if (numberp ang)
    (progn
      (setvar "snapang" ang)
      (setvar "orthomode" 1)
    )
    (setq ang (getvar "snapang"))
  )
  ang
)
;;;
;;;modi 1998.06.13
(defun dw-xdzb1 (pxy px1 px2 / h c m m1 dx dy w sc ax)
  (setq h (getvar "viewsize"))
  (setq c (getvar "viewctr"))
  (setq m (getvar "vsmax"))
  (setq m1 (getvar "vsmin"))
  (setq dx (- (car m) (car m1)))
  (setq dy (- (cadr m) (cadr m1)))
  (setq w (* (/ dx dy) h))
  (setq sc (/ w 8.0))
  (setq ax (angle px1 px2))
  (setq ax (* 180.0 (/ ax pi)))
  (szdl_ins_sysblk "usxy" pxy sc sc ax)
)                                       ;end of defun

;;;
(defun dw-pdir
       (pt / p y s e pp a1 a2 p1 p2 px1 px2 py1 py2 a ax ay dx dy)
  (if (or (null pt) (/= (type pt) 'LIST))
    (progn
      (initget 1)
      (setq p (getpoint "\n参照点:"))
    )
    (progn
      (setq p (getpoint "\n回车以上一点参照 / <参照点>:"))
      (if (= p nil)
	(setq p pt)
      )
    )
  )
  (setq pt p)
  (setq	a1 (#setang)
	a2 (+ a1 pi)
  )
  (setq a (rem (min a1 a2) pi))
  (cond	((and (>= a 0.0) (<= a (/ pi 4)))
	 (setq ax a
	       ay (+ a (/ pi 2))
	 )
	)
	((and (>= a (* 0.75 pi)) (<= a pi))
	 (setq ax (+ a pi)
	       ay (+ ax (/ pi 2))
	 )
	)
	((and (>= a (/ pi 2)) (<= a (* 0.75 pi)))
	 (setq ax (- a (/ pi 2))
	       ay a
	 )
	)
	((and (>= a (/ pi 4)) (<= a (* 0.5 pi)))
	 (setq ax (- a (/ pi 2))
	       ay a
	 )
	)
  )
  (setq	px1 (polar p (+ ax pi) 10)
	px2 (polar p ax 10)
  )
  (setq	py1 (polar p (+ ay pi) 10)
	py2 (polar p ay 10)
  )
  (dw-xdzb1 p px1 px2)
  (initget 1)
  (setq dx (getdist "\n横坐标(X1)增量:"))
  (initget 1)
  (setq dy (getdist "\n纵坐标(Y1)增量:"))
  (command "erase" (entlast) "")
  (setq a (angle px1 px2))
  (polar (polar p a dx) (+ a (/ pi 2)) dy)
)					;end of defun
;;;
(defun clljd (pp p1 p2 p3 p4 l1 l2 / wb pt p11 p12 ang ang1 ang2 p01)
  (setq	ang1 (angle p1 p2)
	ang2 (angle p3 p4)
  )
  (if (or (< (abs (rem (- ang1 ang2) pi)) 0.05)
	  (> (abs (rem (- ang1 ang2) pi)) 3.1)
      )
    (prompt "\n两线平行,退出!")
    (progn
      (setq pt (inters p1 p2 p3 p4))
      (if (/= pt nil)
	(cond
	  ((and	(or (< (distance pt p1) 2.0) (< (distance pt p2) 2.0))
		(or (< (distance pt p3) 2.0) (< (distance pt p4) 2.0))
	   )
	   (if (> (distance pt p1) (distance pt p2))
	     (setq ang1 (angle pt p1))
	     (setq ang1 (angle pt p2))
	   )
	   (if (> (abs ang1) (* 2.0 pi))
	     (setq ang1 (rem ang1 (* 2.0 pi)))
	   )
	   (if (> (distance pt p3) (distance pt p4))
	     (setq ang2 (angle pt p3))
	     (setq ang2 (angle pt p4))
	   )
	   (if (> (abs ang2) (* 2.0 pi))
	     (setq ang2 (rem ang2 (* 2.0 pi)))
	   )
	   (cond
	     ((> ang1 ang2)
	      (if (< (- ang1 ang2) pi)
		(setq p1 (polar p1 (- ang1 (/ pi 2.0)) l1)
		      p2 (polar p2 (- ang1 (/ pi 2.0)) l1)
		      p3 (polar p3 (+ ang2 (/ pi 2.0)) l2)
		      p4 (polar p4 (+ ang2 (/ pi 2.0)) l2)
		)
		(setq p1 (polar p1 (+ ang1 (/ pi 2.0)) l1)
		      p2 (polar p2 (+ ang1 (/ pi 2.0)) l1)
		      p3 (polar p3 (- ang2 (/ pi 2.0)) l2)
		      p4 (polar p4 (- ang2 (/ pi 2.0)) l2)
		)
	      )
	     )
	     (t
	      (if (> (- ang2 ang1) pi)
		(setq p1 (polar p1 (- ang1 (/ pi 2.0)) l1)
		      p2 (polar p2 (- ang1 (/ pi 2.0)) l1)
		      p3 (polar p3 (+ ang2 (/ pi 2.0)) l2)
		      p4 (polar p4 (+ ang2 (/ pi 2.0)) l2)
		)
		(setq p1 (polar p1 (+ ang1 (/ pi 2.0)) l1)
		      p2 (polar p2 (+ ang1 (/ pi 2.0)) l1)
		      p3 (polar p3 (- ang2 (/ pi 2.0)) l2)
		      p4 (polar p4 (- ang2 (/ pi 2.0)) l2)
		)
	      )
	     )
	   )				;end of cond
	   (setq p01 (inters p1 p2 p3 p4 nil))
	  )				;end of cond1
	  (t
					;      (initget 1)
					;       (setq p01 (getpoint cc))
	   (setq p01 pp)
	   (setq p01 (list (car p01) (cadr p01) 0.0))
	   (setq p11 (polar p01 (+ ang1 (/ pi 2.0)) 10.0))
	   (setq p11  (inters p1 p2 p01 p11 nil)
		 ang1 (angle p11 p01)
	   )
	   (setq p12 (polar p01 (+ ang2 (/ pi 2.0)) 10.0))
	   (setq p12  (inters p3 p4 p01 p12 nil)
		 ang2 (angle p12 p01)
	   )
	   (setq p1 (polar p1 ang1 l1)
		 p2 (polar p2 ang1 l1)
		 p3 (polar p3 ang2 l2)
		 p4 (polar p4 ang2 l2)
	   )
	   (setq p01 (inters p1 p2 p3 p4 nil))
	  )				;end of cond2
	)				;end of cond
	(progn
	  (setq pt (inters p1 p2 p3 p4 nil))
	  (cond
	    ((and (or (> (distance pt p3) (distance p3 p4))
		      (> (distance pt p4) (distance p3 p4))
		  )
		  (or (> (distance pt p1) (distance p1 p2))
		      (> (distance pt p2) (distance p1 p2))
		  )
	     )
	     (if (> (distance pt p1) (distance p1 p2))
	       (setq p2	p1
		     p1	pt
	       )
	       (setq p1 pt)
	     )
	     (if (> (distance pt p3) (distance p3 p4))
	       (setq p4	p3
		     p3	pt
	       )
	       (setq p3 pt)
	     )
	     (setq ang1	(angle p1 p2)
		   ang2	(angle p3 p4)
	     )
	     (if (> (abs ang1) (* 2.0 pi))
	       (setq ang1 (rem ang1 (* 2.0 pi)))
	     )
	     (if (> (abs ang2) (* 2.0 pi))
	       (setq ang2 (rem ang2 (* 2.0 pi)))
	     )
	     (cond
	       ((> ang1 ang2)
		(if (< (- ang1 ang2) pi)
		  (setq	p1 (polar p1 (- ang1 (/ pi 2.0)) l1)
			p2 (polar p2 (- ang1 (/ pi 2.0)) l1)
			p3 (polar p3 (+ ang2 (/ pi 2.0)) l2)
			p4 (polar p4 (+ ang2 (/ pi 2.0)) l2)
		  )
		  (setq	p1 (polar p1 (+ ang1 (/ pi 2.0)) l1)
			p2 (polar p2 (+ ang1 (/ pi 2.0)) l1)
			p3 (polar p3 (- ang2 (/ pi 2.0)) l2)
			p4 (polar p4 (- ang2 (/ pi 2.0)) l2)
		  )
		)
	       )
	       (t
		(if (> (- ang2 ang1) pi)
		  (setq	p1 (polar p1 (- ang1 (/ pi 2.0)) l1)
			p2 (polar p2 (- ang1 (/ pi 2.0)) l1)
			p3 (polar p3 (+ ang2 (/ pi 2.0)) l2)
			p4 (polar p4 (+ ang2 (/ pi 2.0)) l2)
		  )
		  (setq	p1 (polar p1 (+ ang1 (/ pi 2.0)) l1)
			p2 (polar p2 (+ ang1 (/ pi 2.0)) l1)
			p3 (polar p3 (- ang2 (/ pi 2.0)) l2)
			p4 (polar p4 (- ang2 (/ pi 2.0)) l2)
		  )
		)
	       )
	     )				;end of cond
	     (setq p01 (inters p1 p2 p3 p4 nil))
	    )				;end of cond1
	    (t
					;     (initget 1)
					;     (setq p01 (getpoint cc))
	     (setq p01 pp)
	     (setq p01 (list (car p01) (cadr p01) 0.0))
	     (setq p11 (polar p01 (+ ang1 (/ pi 2.0)) 10.0))
	     (setq p11	(inters p1 p2 p01 p11 nil)
		   ang1	(angle p11 p01)
	     )
	     (setq p12 (polar p01 (+ ang2 (/ pi 2.0)) 10.0))
	     (setq p12	(inters p3 p4 p01 p12 nil)
		   ang2	(angle p12 p01)
	     )
	     (setq p1 (polar p1 ang1 l1)
		   p2 (polar p2 ang1 l1)
		   p3 (polar p3 ang2 l2)
		   p4 (polar p4 ang2 l2)
	     )
	     (setq p01 (inters p1 p2 p3 p4 nil))
	    )				;end of cond2
	  )				;end of cond
	)
      )					;end of if pt
    )
  )					;end of if ping xing
  p01
)					;end of defun

;;;两线定位
(defun #dl_pos (/ loop wb p1 p2	p3 p4 l1 l2 an1	str ptb	pt1 pt2	an2 pt
		ent1 ent2)
  (initget "X")
  (setq wb (#nentsel "\n确定点在两线的哪一夹角内 X / 选择第一条线:"))
  (if (= wb "X")
    (setq str wb
	  wb  (#nentsel "\n选择第一条线:")
    )
  )
  (setq	pt1  (car wb)
	pt2  (cadr wb)
	p3   (caddr wb)
	ent1 (last wb)
  )
  (setq an1 (angle pt1 pt2))
  (initget 7)
  (setq l1 (getdist "\n输入与第一条线的距离:"))

  (setq loop t)
  (while loop
    (setq wb   (#nentsel "\n选择第二条线:")
	  p1   (car wb)
	  p2   (cadr wb)
	  p4   (caddr wb)
	  ent2 (last wb)
	  an2  (angle p1 p2)
    )
    (if	(or (< (abs (rem (- an1 an2) pi)) 0.05)
	    (> (abs (rem (- an1 an2) pi)) 3.1)
	)
      (prompt "\n两线平行,重选!")
      (setq loop nil)
    )
  )
  (initget 7)
  (setq l2 (getdist "\n输入与第二条线的距离:"))

  (if (= str "X")
    (progn
      (setq wb (* 0.707 (/ (* 40 (getvar "viewsize")) 206.0)))
      (setq pt	(inters p1 p2 pt1 pt2 nil)
	    pt1	(polar pt (+ an1 pi) wb)
	    pt2	(polar pt an1 wb)
	    p1	(polar pt (+ an2 pi) wb)
	    p2	(polar pt an2 wb)
      )
      (grdraw pt pt1 4)
      (grdraw pt pt2 4)
      (grdraw pt p1 4)
      (grdraw pt p2 4)

      (initget 1)
      (setq p3 (getpoint "\n确定点在两线的哪一夹角内:"))
      (grdraw pt pt1 0)
      (grdraw pt pt2 0)
      (grdraw pt p1 0)
      (grdraw pt p2 0)
      (redraw ent1 4)
      (redraw ent2 4)
      (setq p1 (clljd p3 pt1 pt2 p1 p2 l1 l2))
    )
    (setq p1 (clljd (midpt p3 p4) pt1 pt2 p1 p2 l1 l2))
  )
  p1
)
;;;      
(defun #nentsel	(cc / y ent entb etype p0 p1 p2 ang mat ent1)
  (setq y t)
  (while y
    (setq ent (nentsel cc))
    (cond
      ((null ent) (prompt "\n没选中线,请重选!"))
      ((= (type ent) 'STR) (setq y nil))
      (t
       (setq entb  (entget (car ent))
	     etype (cdr (assoc 0 entb))
	     p0	   (cadr ent)
       )
       (if (= (length ent) 4)
	 (setq mat (caddr ent))
	 (setq mat nil)
       )
       (cond
	 ((= etype "LWPOLYLINE")
	  (setq	entb (dw-ypp1 (if mat
				ent
				(car ent)
			      )
			      p0
		     )
	  )
	  (if (and entb (zerop (cadddr entb)))
	    (setq p0 (car entb)
		  p1 (cadr entb)
		  p2 (caddr entb)
		  y  nil
	    )
	    (progn
	      (beep)
	      (prompt "\n请选直线段!")
	    )
	  )
	 )
	 ((= etype "LINE")
	  (setq	p1 (cdr (assoc 10 entb))
		p2 (cdr (assoc 11 entb))
	  )
	  (if mat
	    (setq p1 (pt_m2wcs p1 mat)
		  p2 (pt_m2wcs p2 mat)
	    )
	  )
	  (setq	p0 (interss p1
			    p2
			    p0
			    (polar p0 (+ (angle p1 p2) (* pi 0.5)) 1026.0)
			    nil
		   )
		y  nil
	  )
	 )
	 ((= etype "VERTEX")
	  (if (zerop (cdr (assoc 42 entb)))
;;;polyline's line seg
	    (progn
	      (setq p1 (cdr (assoc 10 entb))
		    p2 (cdr
			 (assoc 10 (setq entb (entget (entnext (car ent)))))
		       )
	      )
	      (if (null p2)
		(progn
		  (setq	ent1 (cdr (assoc -2 entb))
			p2   (cdr (assoc 10 (entget (entnext ent1))))
		  )
		)
	      )
	      (if mat
		(setq p1 (pt_m2wcs p1 mat)
		      p2 (pt_m2wcs p2 mat)
		)
	      )
	      (setq p0 (interss
			 p1
			 p2
			 p0
			 (polar p0 (+ (angle p1 p2) (* pi 0.5)) 1026.0)
			 nil
		       )
		    y  nil
	      )
	    )
	    (progn
	      (beep)
	      (prompt "\n请选直线段!")
	    )
	  )
	 )
	 (t
	  (beep)
	  (prompt "\n请选直线段!")
	 )
       )
;;;end of cond t
      )
    )
  )
;;;end of while y
  (if (= (type ent) 'STR)
    ent
    (list (p# p1) (p# p2) (p# p0) (car ent))
  )
)
;;;
(defun #arrow (pt ang xz / sca p1 p2 bl	color p3 p4 p5 p6 p7 p8	pi2 w l
	       color1)
  (if xz
    (setq color	4
	  color1 1
    )
    (setq color	0
	  color1 0
    )
  )
  (setq pi2 (/ pi 2))
  (setq	bl  (* 0.707 (/ (getvar "viewsize") 206.0))
	sca (* 4 bl)
	w   (* 12 bl)
	w2  (* w 0.5)
	l   (* 30 bl)
  )
  (setq	p1 (polar pt (+ ang pi2) (* 0.6 w2))
	p2 (polar pt (- ang pi2) (* 0.6 w2))
  )
  (grdraw p1 p2 color1)
  (setq	p1 (polar pt ang (* 0.6 w2))
	p2 (polar pt (+ ang pi) (* 0.6 w2))
  )
  (grdraw p1 p2 color1)
  (setq	p1 (polar (polar pt (+ pi2 ang) w2) (+ ang pi) (* 0.5 l))
	p2 (polar p1 ang l)
	p3 (polar p1 (- ang pi2) w)
	p4 (polar p3 ang l)
  )
  (grdraw p1 p2 color)
  (grdraw p3 p4 color)

  (setq	p5 (polar p2 (+ ang pi2) w2)
	p6 (polar p4 (- ang pi2) w2)
	p7 (polar pt ang (+ (* 0.5 l) w))
  )
  (grdraw p2 p5 color)
  (grdraw p4 p6 color)
  (grdraw p7 p5 color)
  (grdraw p7 p6 color)


  (setq p8 (polar pt ang (* 0.5 l)))
  (setq	p4 (polar p8 ang sca)
	p2 (polar p8 (+ ang pi) sca)
  )
  (grdraw p4 p2 color)
  (setq	p4 (polar p8 (+ ang pi2) sca)
	p2 (polar p8 (- ang pi2) sca)
  )
  (grdraw p4 p2 color)

  (setq	p5 (polar p5 (+ ang pi) l)
	p6 (polar p6 (+ ang pi) l)
	p7 (polar p7 (+ ang pi) (+ l w w))
  )
  (grdraw p1 p5 color)
  (grdraw p3 p6 color)
  (grdraw p7 p5 color)
  (grdraw p7 p6 color)
  (setq p8 (polar pt (+ ang pi) (* 0.5 l)))
  (setq	p4 (polar p8 ang sca)
	p2 (polar p8 (+ ang pi) sca)
  )
  (grdraw p4 p2 color)

)
;;;
(defun #dir_l (pt / i y e p1 p2 p0 d d0 ang ang1 ang2)
  (setq ang (#setang))
  (setq y t)
  (while y
    (setq e    (#nentsel "\n选距离参照线:")
	  p1   (car e)
	  p2   (cadr e)
	  p0   (caddr e)
	  ang2 (angle p1 p2)
	  ang1 (+ ang2 (/ pi 2))
	  i    (intersp pt (polar pt ang 1) p1 p2 nil)
    )
    (if	(= i nil)
      (prompt "\n两线平行无法定位,重选.")
      (progn
	(setq y	 nil
	      d0 (polar i ang 100)
	)
	(setq ang (angle pt i))
	(span i)
	(#arrow p0 ang 1)
	(setq d0 (getdist "\n距参照线距离<0>:"))
	(if (null d0)
	  (setq d0 0.0)
	)
	(#arrow p0 ang nil)
	(setq ang1 (- ang ang2))
	(if (< ang1 0)
	  (setq ang1 (+ (* 2 pi) ang1))
	)
	(if (> ang1 pi)
	  (setq ang1 (- ang1 pi))
	)
	(if (> ang1 (/ pi 2))
	  (setq ang1 (- pi ang1))
	)

	(setq d (sin ang1))
	(if (zerop d)
	  (setq d 1.0)
	)
	(setq p1 (polar i ang (/ d0 d)))
      )
    )
  )
  p1
)
;;;
(defun #line_err (ccc)
;;  (setvar "cmdecho" 0)
;;  (prompt "*Cancel*")
  (setq flag nil)
;;  (setvar "celtype" "bylayer")
;;  (setvar "cecolor" "bylayer")
  (IF (AND LAST_MARKENT (ENTGET LAST_MARKENT))
    (ENTDEL LAST_MARKENT)
  )
;;  (setq *error* olderr)
;;  (setq olderr nil)
  (re_menu)
;;  (HY_RV)
  (setvar "snapang" 0.0)
;;  (HY_Set1)
  (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;modi 1998.03.09 1998.03.28
(defun #lineb(lay pt / ppsptb ppsenb undo:m is:lin olderr flag fhb)
  (HY_Set0)
  (if (null #_line) (#ppls"#line"))
  (setq is:lin T)
  (pusherr #line_err)
;;  (setq olderr *error*
;;        *error* #line_err
;;  )
  (DL_MakeLayer lay)
  (if pt (setq ppsptb (cons pt ppsptb)))
  (while  (listp (last (setq fhb (#_line))))
  
  )
  (if (and ppsptb (/= (last fhb) "B"))
    (command ".line" (last ppsptb) (car ppsptb) "")
  )
  (if flag (menucmd "s="))
  (if (= flag 2) (menucmd "s="))
 ;;; (setq *error* olderr)
  (clr_err)
  (HY_Set1)
  (princ)
)

;;;zb:sx=T 随线坐标标志
;;;is:lin  线标志
;;;flag    sub menu flag
;;;undo:S  初始 (getvar "undomarks")
;;;ppsptb  点表
;;;ppsenb  实体表
;;;返回值:line  (list ent p1 p2)  
;;;       arc   (list ent p1 p2 p3)
(defun #_line( / p1 p2 p3 loop loop1 ent ss entl ent1 n cc 
  y ll x dx dy p ret_v)   
  
  (setq p1 (car ppsptb))
  
  (if (null p1) (progn
    
    (setq undo:m (HY_ClearUNDO))
    
    (menucmd "s=gline1")
    
    (setq flag 1)
    ;(setq cc "\n回车退出 / 点线定位 P / 两线定位 X / 测量坐标定位 R / 参考点定位 D / 起点:")
    ;(setq cc "\n返回 Q / 回车另起点 / 到点:")
    (setq cc "\n回车退出 / 起点:")
    (initget "D R P X")
    (setq p1 (#getpt nil cc))
    (if (and p1 (listp p1))  (setq ppsptb (cons p1 ppsptb)))

  ))
  (if (and p1 (/= p1 "Q"))
    (progn
      (setq loop t)
      (while loop
        (if (= (length ppsptb) 1) (menucmd "s=gline")) ;;;modi 1998.07.21
        (grtext 15 "       ")
        (setq flag 2)
        (initget "Z S U A B D R F V P X J G")
        ;(setq cc "\n回车退出 / 回退 U / 弧 A / 闭合 B / 方向距离 F / 参考点 D / 参考线 V / 点线定位 P / 两线定位 X / 测量坐标 R / 到点:")
        (if is:lin 
          (setq cc "\n回车退出 / 到点:"
          ;(setq cc "\n返回 Q / 回车另起点 / 到点:"
                p2 (#getpt p1 cc)
          )
          (setq p2 "A")
        )
        (cond 
          ((null p2) 
            (setvar "snapang" 0)
            (setq loop nil is:lin nil is:arc T)
          )
          ((= p2 "A")
            (setq loop1 t is:lin nil is:arc T)
            (while loop1
              ;(setq cc "\n回车直线 / 回退 U / 参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R /圆心 C / 弧终点 E / 弧第二点:")
              (setq cc "\n回车直线 / 圆心 C / 弧终点 E / 弧第二点:")
              (initget "Z S U C E D L R X P J V F B G")
              (setq p2 (#getpt p1 cc))
              (cond 
                ((or (null p2) (= p2 "L")) (setq loop1 nil is:lin T is:arc nil))
                ((= p2 "B") (setq loop1 nil is:lin nil))
                ((listp p2)
                  (#getaep)
                )
                ((= p2 "U"))
                ((= p2 "C")
                  ;(setq cc "\n参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 圆心:")
                  (setq cc "\n圆心:")
                  (initget 1 "Z S D P R X J V F G")
                  (setq p2 (#getpt p1 cc))
                  
                  (initget  "A L")
                  (setq p3 (getkword "\n夹角 A / 弦长 L / <弧终点>: "))
                  (cond 
                    ((= p3 "A")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_C" p2)
                      (prompt "\n夹角: ")
                      (command "_A" pause)
                      (HY_RV)
                    )
                    ((= p3 "L")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_C" p2)
                      (prompt "\n弦长: ")
                      (command "_L" pause)
                      (HY_RV)
                    )
                    (T
                      (setq cc "\n回车动态 / 弧终点:")
                      (initget "Z S D P X R V J F G")
                      (setq p3 (#getpt p1 cc))
                      (if (and p3 (not (equal p1 p3 0.01))
                                  (not (equal p2 p3 0.01))
                          )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_C" p2 p3)
                          (HY_RV)
                        )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_C" p2)
                          (prompt "\n弧终点:")
                          (command pause)
                          (HY_RV)
                        )
                      )

                    )
                  )
                  
                  (setq p1 (#gl_vnp))
                  (setq ppsptb (cons p1 ppsptb))

                  (if ZB:SX (progn
                    (setq pc (cdr (assoc 10 (entget (entlast)))))
                    (setvar "snapang" (angle pc p1))
                    (setvar "orthomode" 1)
                  ))

                )
                ((= p2 "E")
                  ;(setq cc "\n参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 弧终点:")
                  (setq cc "\n弧终点:")
                  (initget 1 "Z S D P X R J V F G")
                  (setq p2 (#getpt p1 cc))
                  
                  (initget  "A L D R")
                  (setq p3 (getkword "\n夹角 A / 方向 D / 半径 R / <圆心>: "))
                  (cond 
                    ((= p3 "A")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n夹角: ")
                      (command "_A" pause)
                      (HY_RV)
                    )
                    ((= p3 "D")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n方向: ")
                      (command "_D" pause)
                      (HY_RV)
                    )
                    ((= p3 "R")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n半径: ")
                      (command "_R" pause)
                      (HY_RV)
                    )
                    (T
                      ;(setq cc "\n回车动态 / 参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 圆心:")
                      (setq cc "\n回车动态 / 圆心:")
                      (initget "Z S D P X R J V F G")
                      (setq p3 (#getpt p2 cc))
                      (if (and p3 (not (equal p2 p3 0.01))
                                  (not (equal p1 p3 0.01))
                          )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_E" p2 p3)
                          (HY_RV)
                        )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_E" p2)
                          (HY_RV)
                          (prompt "\n圆心: ")
                          (command pause)
                        )
                      )
                    )
                  )
                  
                  (setq p1 (#gl_vnp))

                  (if ZB:SX (progn
                    (setq pc (cdr (assoc 10 (entget (entlast)))))
                    (setvar "snapang" (angle pc p1))
                    (setvar "orthomode" 1)
                  ))

                  (setq ppsptb (cons p1 ppsptb))

                )
                (t
                )
              )
              (if (and p2 (listp p2))
                (setq loop1 nil loop nil)
              )
            
            )
          )
          ((and p2 (listp p2) (not (equal p1 p2 0.01)))
            (undo_m)
            (HY_SV)
            (command "line" p1 p2 "")
            (HY_RV)
            (if ZB:SX (progn
              (setvar "snapang" (angle p1 p2))
              (setvar "orthomode" 1)
            ))

            (setq p1 p2)
            (setq ppsptb (cons p1 ppsptb))
            (setq loop nil)
          )
        )
      )
      
      ;(menucmd "s=")
      (if (and p2  ppsptb (>= (getvar "undomarks") undo:m)
             (or (listp p2) (= p2 "B"))
          )
        (progn
          (setq ent (entlast))
          (setq ppsenb (cons ent ppsenb))
          (if is:lin 
            (setq ret_v (list ent (cadr ppsptb) (car ppsptb)))
            (if (= p2 "B")
              (setq ret_v (list ent (car ppsptb) (last ppsptb) "B"))
              (setq ret_v (list ent (cadr ppsptb) (arc_mid ent) (car ppsptb)))
            )
          )
        )
        ;(setq ret_v (if is:lin (list nil) (list 1)))
        (setq ret_v (if is:lin 
                      (list nil) 
                      (if (= p2 "Q") 
                        (list "Q") 
                        ;(list 1)
                        (list 2)
                      )
                    )
        )
      )
    )  ;;;end of if progn
    
    (progn
      (setq ret_v (list 1 ))
    )

  )
  ;(if (= p1 "Q") (setq ret_v (list "Q")))
  ret_v
)
;;;  
(defun #getpt(pt cc / p x y dx dy ang ll etype entb pc)
  (if pt 
    (setq p (getpoint pt cc))
    (setq p (getpoint cc))
  )
  (cond 
    ((= p "G") (setq p (#dir_l pt)))
    ((= p "U")
      (if (or (null u:n) (zerop u:n)) (progn
            (if (= (getvar "undomarks") undo:m)
              (prompt "\n已全部回退!")
              (progn
                (if (= 13 (getvar "undoctl")) (command ".undo" "e"))
                (command "_.undo" "b")
                (setq ppsptb (cdr ppsptb)
                      ppsenb (cdr ppsenb)
                      p1 (car ppsptb)
                )
              )
            )
      ))
    )
    ((= p "Z") (setvar "snapang" 0) (setq ZB:SX nil))
    ((= p "S") 
      (setq ZB:SX T)
      (if (and ppsenb ppsptb (setq entb (entget (car ppsenb))))
        (progn
          (setq etype (cdr (assoc 0 entb)))
          (cond 
            ((= etype "LINE")
              (setvar "snapang" (angle (cadr ppsptb) (car ppsptb)))
              (setvar "orthomode" 1)
            )
            ((= etype "ARC")
              (setq pc (cdr (assoc 10 entb)))
              (setvar "snapang" (angle pc (car ppsptb)))
              (setvar "orthomode" 1)
            )
          )
        )
      )
    )
    ((= p "J") (#setang))
    ((= p "P") (setq p (dw-pdir p1)))
    ((= p "X") (setq p (#dl_pos)))      
    ((= p "R")
      (initget 1)           
      (setq x (getreal "\n横坐标Y:"))
      (initget 1)
      (setq y (getreal "\n纵坐标X:"))
      (setq p (dw-qab x y))
    )    
    ((= p "V") 
      (#ref_l)
      (initget "Z S U B D R F V P X J G Q")
      (if pt 
        (setq p (#getpt pt cc))
        (setq p (#getpt nil cc))
      )
    ) 
    ((= p "D")
      (initget 1)
      (setq p (getpoint "\n参考点:"))
      (prompt "\n可输入@x,y或@r<angle精确定位.")
      (setq dx (getpoint p "\n位置点:"))
      (if dx (setq p dx))
    )   
    ((= p "F")
      (setq ang (#setang))
      (#arrow p1 ang 1)
      (initget 2)
      (setq ll (getdist "\n距离:"))
      (#arrow p1 ang nil)
      (if ll (setq p (polar p1 ang ll))) 
    )     
    ((= p "B")
      (if (and ppsptb ppsenb
               (or (>= (length ppsptb) 3)
                   (= "ARC" (cdr (assoc 0 (entget (car ppsenb)))))
               )
          )
        (progn
          (HY_SV)
          (command ".line" p1 (last ppsptb) "")
          (HY_RV)
          (setvar "snapang" 0)
          (setq loop nil is:lin nil)
        )
        (prompt "\n不能闭合!")
      )
    )
    ((= p "Q") (setq loop nil))
  )      ;end of cond
  (if (and p (listp p))
    (setq p (p# p))
  )
  p
)
;;;
(if (null #line_err) (#ppls"#com_lin"))
(princ)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;1997.12
;;;modi 1998.01.07
;;;modi 1998.01.13 03.09 1998.03.28
(defun #pline(lay / ppsptb ppsenb undo:m is:lin ss ent olderr flag w e is:arc sca LineWide error)
;;  (setq error *error*)
;;  (setq *error* nil)
;;  (HY_Set0)
  (setq ;;;olderr *error*
        ;;;*error* #line_err
        sca (DL_GetDrawingFactor)
        is:lin T
  )
  (pusherr #line_err)
  
  ;;;2002-11-25 14:58修改
  ;;(DL_MakeLayer lay)
  (if (null (tblsearch "LAYER" lay))
    (command "layer" "M" lay "")
    (command "layer" "S" lay "")
  )

;;;;任蔚青修改2003-2-24 11:35　　begin
;;;;(setvar "plinewid" (/ (DL_GetLayerLineWidth lay) sca))
  (setq LineWide (DL_GetLayerLineWidth lay))
  (if (= LineWide nil) (setq LineWide 0.0))
　(setvar "plinewid" (/ LineWide sca))
;;;;任蔚青修改2003-2-24 11:35　　end
  
  (while  (listp (setq ent (last (#_pline))))
    (if ent (progn
      (setq w (getvar "plinewid"))
      (command ".pedit" (entlast) "" "w" w "")
      (setq ppsenb (cons (entlast) ppsenb))
    ))
  )
  (if ppsenb (progn
    (setq ss (ssadd))
    (foreach e ppsenb
      (ssadd e ss)
    )
    (if (= ent "B")
      (if is:arc 
        (command ".pedit" (last ppsenb) "j" ss "" "c" "")
        (progn
          (ssadd (entlast) ss)
          (command ".pedit" (last ppsenb) "j" ss "" "")
        )
      )
      (command ".pedit" (last ppsenb) "j" ss "" "")
    )
    (setq ent (entlast))
  ))
  (if flag (menucmd "s="))
  (if (= flag 2) (menucmd "s="))
  ;;;(setq *error* olderr)
  (if (= ent 1) (setq ent nil))
 ;; (HY_Set1)
  (clr_err)
  ;;;(setq *error* error)
  ent
)
;;;
(defun #plinep(pt / ppsptb ppsenb undo:m is:lin ss ent olderr flag w e is:arc sca)
  (setq ;;;olderr *error*
        ;;;*error* #line_err
        sca (DL_GetDrawingFactor)
        is:lin T
  )
  (pusherr #line_err)
  (if pt (setq ppsptb (cons pt ppsptb)))
  (setvar "plinewid" (/ (DL_GetLayerLineWidth lay) sca))
  (while  (listp (setq ent (last (#_pline))))
    (if ent (progn
      (setq w (getvar "plinewid"))
      (command ".pedit" (entlast) "" "w" w "")
      (setq ppsenb (cons (entlast) ppsenb))
    ))
  )
  (if ppsenb (progn
    (setq ss (ssadd))
    (foreach e ppsenb
      (ssadd e ss)
    )
    (if (= ent "B")
      (if is:arc 
        (command ".pedit" (last ppsenb) "j" ss "" "c" "")
        (progn
          (ssadd (entlast) ss)
          (command ".pedit" (last ppsenb) "j" ss "" "")
        )
      )
      (command ".pedit" (last ppsenb) "j" ss "" "")
    )
    (setq ent (entlast))
  ))
  ;(if flag (menucmd "s="))
  (if (= flag 2) (menucmd "s="))
  ;;;(setq *error* olderr)
  (clr_err)
  (if (= ent 1) (setq ent nil))
  ent
)
;;;zb:sx=T 随线坐标标志
;;;is:lin  线标志
;;;flag    sub menu flag
;;;undo:m  初始 (getvar "undomarks")
;;;ppsptb  点表
;;;ppsenb  实体表
;;;返回值:line  (list ent p1 p2)  
;;;       arc   (list ent p1 p2 p3)
(defun #_pline( / p1 p2 p3 loop loop1 ent ss entl ent1 n cc 
  y ll x dx dy p ret_v)   
  
  (setq p1 (car ppsptb))
  
  (if (null p1) (progn
    (setq undo:m (HY_ClearUNDO))
    (menucmd "s=gline1")
    (setq flag 1)
    ;(setq cc "\n回车退出 / 点线定位 P / 两线定位 X / 测量坐标定位 R / 参考点定位 D / 起点:")
    (setq cc "\n回车退出 / 起点:")
    (initget "D R P X")
    (setq p1 (#pgetpt nil cc))
    (if (and p1 (listp p1))  (setq ppsptb (cons p1 ppsptb)))

  ))
  (if p1
    (progn
      (setq loop t)
      (while loop
        (if (= (length ppsptb) 1)(menucmd "s=gline")) ;;;modi 1998.07.21
        (setq flag 2)
        (initget "Z S U A B D R F V P X J G W")
        ;(setq cc "\n回车退出 / 回退 U / 弧 A / 闭合 B / 方向距离 F / 参考点 D / 参考线 V / 点线定位 P / 两线定位 X / 测量坐标 R / 到点:")
        (if is:lin 
          (setq cc "\n回车退出 / 弧 A / 到点:"
                is:arc nil
                p2 (#pgetpt p1 cc)
          )
          (setq p2 "A" is:arc T)
        )
        (cond 
          ((null p2) 
            (setvar "snapang" 0)
            (setq loop nil is:lin nil)
          )
          ((= p2 "A")
            (setq loop1 t is:lin nil is:arc T)
            (while loop1
              ;(setq cc "\n回车直线 / 回退 U / 参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R /圆心 C / 弧终点 E / 弧第二点:")
              (setq cc "\n回车直线 / 圆心 C / 弧终点 E / 弧第二点:")
              (initget "Z S U C E D L R X P J V F B G")
              (setq p2 (#pgetpt p1 cc))
              (cond 
                ((or (null p2) (= p2 "L")) (setq loop1 nil is:lin T is:arc nil))
                ((= p2 "B") (setq loop1 nil is:lin nil ))
                ((listp p2)
                  (#getaep)
                )
                ((= p2 "U"))
                ((= p2 "C")
                  ;(setq cc "\n参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 圆心:")
                  (setq cc "\n圆心:")
                  (initget 1 "Z S D P R X J V F G")
                  (setq p2 (#pgetpt p1 cc))
                  
                  (initget  "A L")
                  (setq p3 (getkword "\n夹角 A / 弦长 L / <弧终点>: "))
                  (cond 
                    ((= p3 "A")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_C" p2)
                      (prompt "\n夹角: ")
                      (command "_A" pause)
                      (HY_RV)
                    )
                    ((= p3 "L")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_C" p2)
                      (prompt "\n弦长: ")
                      (command "_L" pause)
                      (HY_RV)
                    )
                    (T
                      (setq cc "\n回车动态 / 弧终点:")
                      (initget "Z S D P X R V J F G")
                      (setq p3 (#pgetpt p1 cc))
                      (if (and p3 (not (equal p1 p3 0.01))
                                  (not (equal p2 p3 0.01))
                          )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_C" p2 p3)
                          (HY_RV)
                        )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_C" p2)
                          (prompt "\n弧终点:")
                          (command pause)
                          (HY_RV)
                        )
                      )

                    )
                  )
                  
                  (setq p1 (#gl_vnp))
                  (setq ppsptb (cons p1 ppsptb))

                  (if ZB:SX (progn
                    (setq pc (cdr (assoc 10 (entget (entlast)))))
                    (setvar "snapang" (angle pc p1))
                    (setvar "orthomode" 1)
                  ))

                )
                ((= p2 "E")
                  ;(setq cc "\n参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 弧终点:")
                  (setq cc "\n弧终点:")
                  (initget 1 "Z S D P X R J V F G")
                  (setq p2 (#pgetpt p1 cc))
                  
                  (initget  "A L D R")
                  (setq p3 (getkword "\n夹角 A / 方向 D / 半径 R / <圆心>: "))
                  (cond 
                    ((= p3 "A")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n夹角: ")
                      (command "_A" pause)
                      (HY_RV)
                    )
                    ((= p3 "D")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n方向: ")
                      (command "_D" pause)
                      (HY_RV)
                    )
                    ((= p3 "R")
                      (undo_m)
                      (HY_SV)
                      (command "_.ARC" p1 "_E" p2)
                      (prompt "\n半径: ")
                      (command "_R" pause)
                      (HY_RV)
                    )
                    (T
                      ;(setq cc "\n回车动态 / 参考点 D / 点线定位 P / 两线定位 X / 测量坐标 R / 圆心:")
                      (setq cc "\n回车动态 / 圆心:")
                      (initget "Z S D P X R J V F G")
                      (setq p3 (#pgetpt p2 cc))
                      (if (and p3 (not (equal p2 p3 0.01))
                                  (not (equal p1 p3 0.01))
                          )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_E" p2 p3)
                          (HY_RV)
                        )
                        (progn
                          (undo_m)
                          (HY_SV)
                          (command "_.ARC" p1 "_E" p2)
                          (prompt "\n圆心: ")
                          (command pause)
                          (HY_RV)
                        )
                      )
                    )
                  )
                  
                  (setq p1 (#gl_vnp))

                  (if ZB:SX (progn
                    (setq pc (cdr (assoc 10 (entget (entlast)))))
                    (setvar "snapang" (angle pc p1))
                    (setvar "orthomode" 1)
                  ))

                  (setq ppsptb (cons p1 ppsptb))

                )
                (t
                )
              )
              (if (and p2 (listp p2))
                (setq loop1 nil loop nil)
              )
            
            )
          )
          ((and p2 (listp p2) (not (equal p1 p2 0.01)))
            (undo_m)
            (HY_SV)
            (command "line" p1 p2 "")
            (HY_RV)
            (if ZB:SX (progn
              (setvar "snapang" (angle p1 p2))
              (setvar "orthomode" 1)
            ))

            (setq p1 p2)
            (setq ppsptb (cons p1 ppsptb))
            (setq loop nil)
          )
        )
      )
      
      (if (and p2  ppsptb (>= (getvar "undomarks") undo:m)
             (or (listp p2) (= p2 "B"))
          )
        (progn
          (setq ent (entlast))
          (if is:lin 
            (setq ret_v (list ent (cadr ppsptb) (car ppsptb)))
            (if (= p2 "B")
              (setq ret_v (list ent (car ppsptb) (last ppsptb) "B"))
              (setq ret_v (list ent (cadr ppsptb) (arc_mid ent) (car ppsptb)))
            )
          )
        )
        (setq ret_v (if is:lin (list nil) (list 1)))
      )
    )  ;;;end of if progn
    
    (progn
      (setq ret_v (list 1)) 
    )

  )
  ret_v
)
;;;  
(defun #pgetpt(pt cc / p x y dx dy ang ll etype entb pc sca v42)
  (if pt 
    (setq p (getpoint pt cc))
    (setq p (getpoint cc))
  )
  (cond 
    ((= p "W") 
      (setq sca (DL_GetDrawingFactor))
      (initget 4)
      (setq w (getreal (strcat "\n线宽<" (rtos (* sca (getvar "plinewid")) 2 2) ">:")))
      (if w
        (setvar "plinewid" (/ w sca))
      )
    )
    ((= p "G") (setq p (#dir_l pt)))
    ((= p "U")
            (if (= (getvar "undomarks") undo:m)
              (prompt "\n已全部回退!")
              (progn
                (if (= 13 (getvar "undoctl")) (command ".undo" "e"))
                (command "_.undo" "b")
                (setq ppsptb (cdr ppsptb)
                      ppsenb (cdr ppsenb)
                      p1 (car ppsptb)
                )
              )
            )
    )
    ((= p "Z") (setvar "snapang" 0) (setq ZB:SX nil))
    ((= p "S") 
      (setq ZB:SX T)
;;;modi 1998.06.10
      (if (and ppsenb ppsptb (setq entb (entget (car ppsenb))))
        (progn
          (if (zerop (setq v42 (cdr (assoc 42 entb))))
            (progn  ;;;line seg
              (setvar "snapang" (angle (cadr ppsptb) (car ppsptb)))
              (setvar "orthomode" 1)
            )
            (progn  ;;;arc seg
              ;;;modi1998.06.11
              ;(setq pc (car (p_arc (entnext (car ppsenb)))))
              (setq pc (car (p_arc (list (cadr ppsptb) (car ppsptb) v42) )))

              (setvar "snapang" (angle pc (car ppsptb)))
              (setvar "orthomode" 1)
            )
          )
        )
      )
    )
    ((= p "J") (#setang))
    ((= p "P") (setq p (dw-pdir p1)))
    ((= p "X") (setq p (#dl_pos)))      
    ((= p "R")
      (initget 1)           
      (setq x (getreal "\n横坐标Y:"))
      (initget 1)
      (setq y (getreal "\n纵坐标X:"))
      (setq p (dw-qab x y))
    )    
    ((= p "V") 
      (#ref_l)
      (initget "Z S U B D R F V P X J G")
      (if pt 
        (setq p (#pgetpt pt cc))
        (setq p (#pgetpt cc))
      )
    ) 
    ((= p "D")
      (initget 1)
      (setq p (getpoint "\n参考点:"))
      (prompt "\n可输入@x,y或@r<angle精确定位.")
      (setq dx (getpoint p "\n位置点:"))
      (if dx (setq p dx))
    )   
    ((= p "F")
      (setq ang (#setang))
      (#arrow p1 ang 1)
      (initget 2)
      (setq ll (getdist "\n距离:"))
      (#arrow p1 ang nil)
      (if ll (setq p (polar p1 ang ll))) 
    )     
    ((= p "B")
      (if (and ppsptb ppsenb
               (or (>= (length ppsptb) 3)
                   ;(= "ARC" (cdr (assoc 0 (entget (car ppsenb)))))
                   (if (= (getvar "plinetype") 0)
                      (> (cdr (assoc 42 (entget (entnext (car ppsenb))))) 0)
                      (> (cdr (assoc 42 (entget (car ppsenb)))) 0)
                   )
               )
          )
        (progn
          (if (not is:arc) (progn
            (HY_SV)
            (command ".pline" p1 (last ppsptb) "")
            (HY_RV)
          ))
          (setvar "snapang" 0)
          (setq loop nil is:lin nil)
        )
        (prompt "\n不能闭合!")
      )
    )
  )      ;end of cond
  (if (and p (listp p))
    (setq p (p# p))
  )
  p
)

(defun #pline2(lay / ppsptb ppsenb undo:m is:lin ss ent olderr flag w e is:arc 
											e1 e2 e3 sca pp retb)
  (setq ;;;olderr *error*
        ;;;*error* #line_err
        sca (DL_GetDrawingFactor)
        is:lin T
  )
  (pusherr #line_err)
  (DL_MakeLayer lay)
  (setvar "plinewid" (/ (DL_GetLayerLineWidth lay) sca))
  (while  (listp (setq ent (last (setq pp(#_pline)))))
  		(setq retb (cons (cdr pp) retb))
    (if ent (progn
      (setq w (getvar "plinewid"))
      (command ".pedit" (entlast) "" "w" w "")
      (setq ppsenb (cons (entlast) ppsenb))
    ))
  )
  (if ppsenb (progn
    (setq ss (ssadd))
    (foreach e ppsenb
      (ssadd e ss)
    )
    (if (= ent "B")
      (if is:arc 
        (command ".pedit" (last ppsenb) "j" ss "" "c" "")
        (progn
          (ssadd (entlast) ss)
          (command ".pedit" (last ppsenb) "j" ss "" "")
        )
      )
      (command ".pedit" (last ppsenb) "j" ss "" "")
    )
    (setq ent (entlast))
  ))
  (if flag (menucmd "s="))
  (if (= flag 2) (menucmd "s="))
  ;;;(setq *error* olderr)
  (clr_err)
  (if (= ent 1) (setq ent nil))
  (if ent
    (list ent ppsptb ppsenb)
    nil 
  )
  retb
)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;