;;;道路交互编辑,集成大部分编辑功能
;;;8/3/00 -- wht --

;;;				=========BEGIN==========道路延伸=========BEGIN==========
;;;全局变量--w,glb,glb1
(defun g_st_road (/	 g_ss	axi_ss glb    glb1   glb2   y
		  undo:m cc	osm    ssb    g_ent  pt	    w  lw    rw
		  g_flag    w_stk_code
		 )
  (if (null $ptoe)
    (#ppls "pppp")
  )
(#ppas "drawroad")
  (setq	glb    '((0 . "LINE,ARC,*POLYLINE") (8 . "Road,Xroad,Axis,Road-1"))
	glb1   '((0 . "LINE,ARC,*POLYLINE") (8 . "Axis"))
	glb2   '((0 . "LINE,ARC,*POLYLINE") (8 . "Road,Xroad"))
	y      t
	undo:m (HY_ClearUNDO)
  )
  (while y
    (sa_osmode)
    (setvar "OSMODE" 1)
    (initget "U")
    (setq cc "\n回车退出 / 回退 U / 点取要延长的道路中心线端点:")
    (setq ssb (g_ptoe cc "\n没选中,请重选!" glb1 1))
    (re_osmode)
;;;   (HY_RV)
;;;   (setvar "OSMODE" osm)
    (cond
      ((= ssb nil) (setq y nil))
      ((= ssb "U")
       (if (= (getvar "undomarks") undo:m)
	 (prompt "\n已全部回退!")
	 (HY_UndoB)
       )
      )
      (t
       (setq g_ent (car ssb)
	     pt	   (cadr ssb)
       w (arx_dllk g_ent pt)
       lw (apply '+ (cadr w))
       rw (apply '+ (caddr w))
       w (+ lw rw)
       )
  (if (and g_ent pt)
	 (progn
	   (szload zh_get_zhn "hy_dlzh")
	   (setq w_stk_code (zh_get_zhn g_ent))
	   (if w_stk_code
	      (progn
	         (setq w_stk_code (substr w_stk_code 6))
	         (Dl_UnDefineStake w_stk_code)
	      )
	   )
	   (g_extend_dl g_ent pt)
	   (setq g_flag (g_undef_zh g_ent))
	  )
	 )
       )
      )
    )
 ;; )
(re_osmode)
 ;;;;(setvar "OSMODE" w_old_osmode)
  (princ)
)
;;;----------------------------------------------------------------------------
(defun g_extend_dl (g_ent pt / p1 p2 etype g_pt g_ang gkd wb v42)
  (setq	p1    (p# (car (bg-ypp g_ent)))
	p2    (p# (last (bg-ypp g_ent)))
	etype (cdr (assoc 0 (entget g_ent)))
  )
  (if (< (distance p1 (p# pt)) (distance p2 (p# pt)))
    (setq g_pt	p1
	  g_ang	(angle p2 p1)
    )
    (setq g_pt	p2
	  g_ang	(angle p1 p2)
    )
  )
  (if g_pt
    (progn
      (cond
	((= etype "LINE")
	 (HY_UndoM)
	 (g_stretch g_ent g_pt)
	)
	((= etype "ARC")
	 (HY_UndoM)
	 (g_tan_extend g_ent g_pt)
	)
	((wcmatch etype "*POLYLINE")
	 (HY_UndoM)
	 (setq wb   (dw-ypp1 g_ent g_pt)
	       g_pt (car wb)
	       v42  (cadddr wb)
	 )
	 (g_tan_extend g_ent g_pt)
	)
      )					;endcond
    )					;endprogn
  )
  (HY_RV)
)
;;;-------------------------------------------------------------------
;;;w-global 路宽
;;; lw - global 左路宽
;;; rw - global 右路宽    
(defun g_stretch (ent pt / p1 p2 cp1 cp2 cp3 cp4 snp ort s_ang ss_x pp ppp ptt)
  (HY_SV)

  (Setq	snp (getvar "SNAPANG")
	ort (getvar "ORTHOMODE")
  )
  (setq	p1 (p# (car (bg-ypp ent)))
	p2 (p# (last (bg-ypp ent)))
  )
  (if (< (distance p1 (p# pt)) (distance p2 (p# pt)))
    (SEtq pt	p1
	  s_ang	(angle p2 p1)
    )
    (SEtq pt	p2
	  s_ang	(angle p1 p2)
    )
  )



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;GDX修改2002/2  
  (setq	 cp1	(polar pt s_ang 0.5)
    ;;cp1	(polar cp1 (+ (* 0.5 pi) s_ang) (+ (* 0.5 w) 0.5))
    cp1	(polar cp1 (+ (* 0.5 pi) s_ang) (+  lw 0.5))
    cp4	(polar cp1 (+ pi s_ang) 1)
    cp3	(polar cp4 (+ (* 1.5 pi) s_ang) (+ w 1))
    cp2	(polar cp3 (+ (* 2 pi) s_ang) 1)
  )
  (setq ss_x (ssget "CP" (list cp1 cp4 cp3 cp2) glb))


;;;;任蔚青修改2002-11-21 11:31，由于stretch道路会改变方向，比如用户在y方向上移动鼠标时
  ;;  (command "stretch" "cp" cp1 cp4 cp3 cp2 "" "" pt)
  (setq pp (getpoint pt))
  (if pp
      (progn
         (setq ptt (polar pt s_ang 1.0))
         (setq ppp (polar pp (+ s_ang (* 0.5 pi)) 1.0))
         (setq pp  (inters pt ptt pp ppp nil))
         (if (and pp (> (distance pp pt) 0.001))
             (command "stretch" "WP" cp1 cp4 cp3 cp2 "" ss_x "" pt pp)
				 )
       );;;progn
   )
;;;;任蔚青修改2002-11-21 11:31，由于stretch道路会改变方向，比如用户在y方向上移动鼠标时

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;GDX修改2002/2 


  (setvar "SNAPANG" s_ang)
  (setvar "ORTHOMODE" 1)
	(setvar "SNAPANG" snp)
  (setvar "ORTHOMODE" ort)
  (HY_RV)
)
;;;------------------------------------------------------------------------
(defun g_tan_extend (ent   pt	 /     snp   ort   p1	 p2    cp1
		     cp2   cp3	 cp4   arc_ss	   l_ang p11   t_ang     pp    ppp   ptt 
		     a_ent
		    )
  (HY_SV)
  (Setq	snp (getvar "SNAPANG")
	ort (getvar "ORTHOMODE")
  )
  (setq	etype (cdr (assoc 0 (entget ent)))
	p1    (p# (car (bg-ypp ent)))
	p2    (p# (last (bg-ypp ent)))
  )
  (if (< (distance p1 pt) (distance p2 pt))
    (SEtq pt p1)
    (SEtq pt p2)
  )


  (setq l_ang (#getepdir ent pt))

;;;;任蔚青修改2002-11-21 13:59

   (setq	 cp1	(polar pt l_ang 0.5)
    cp1	(polar cp1 (+ (* 0.5 pi) l_ang) (+  lw 0.5))
    cp4	(polar cp1 (+ pi l_ang) 1)
    cp3	(polar cp4 (+ (* 1.5 pi) l_ang) (+ w 1))
    cp2	(polar cp3 (+ (* 2 pi) l_ang) 1)
  )
;;;;任蔚青修改2002-11-21 13:59


  (setq arc_ss (ssget "cp" (list cp1 cp2 cp3 cp4) glb))
  (ssdel ent arc_ss)
  (setvar "SNAPANG" l_ang)
  (setvar "ORTHOMODE" 1)


;;;;任蔚青修改2002-11-21 11:51
;;  (command "line" pt)
;;  (command pause)
;;  (setq	p11   (#gl_vnp)
;;	a_ent (entlast)
;;	t_ang (angle pt p11)
;;  )
  (setq pp (getpoint pt))
  (if pp
      (progn
         (setq ptt (polar pt l_ang 1.0))
         (setq ppp (polar pp (+ l_ang (* 0.5 pi)) 1.0))
         (setq pp  (inters pt ptt pp ppp nil))
         (if (and pp (> (distance pp pt) 0.001))
             (progn
                (command "line" pt pp "")
                (setq	p11   pp
											a_ent (entlast)
											t_ang (angle pt p11)
								)
              );;;progn
				 )
       );;;progn
   )
;;;;任蔚青修改2002-11-21 11:51

  (HY_RV)
  (HY_SV)
  (g_dw_dl arc_ss ent pt p11 t_ang)
  (entdel a_ent)
  (setvar "SNAPANG" snp)
  (setvar "ORTHOMODE" ort)
  (HY_RV)
)
;;;------------------------------------------------------------------------
(defun g_dw_dl (ss    ent0  pt	  pe	ang   /	    xdata len	dis
		n     clay  lay	  ent	ent1  hwd   newent	p1
		p2
	       )
  (HY_SV)
  (if ss
    (progn
      (setq xdata (assoc -3 (entget ent0 (list "*")))
	    len	  (sslength ss)
	    dis	  (distance (p# pt) (p# pe))
	    n	  0
	    clay  (getvar "clayer")
      )
      (setq lay (strcase(cdr (assoc 8 (entget ent0)))))
      (setvar "clayer" lay)
      (command ^ "line" pt (polar pt ang dis) "")
      (setq ent1   (entlast)
	    hwd	   (cdr (assoc 5 (entget ent1)))
	    newent (append (entget ent1) (list xdata))
      )
      (entmod newent)
      (HY_KZSJXZ ent1 "DWAPP")
      (HY_KZSJXZ ent1 "DWAPP" 1040 w)
      (HY_KZSJXZ ent1 "DWAPP" 1000 hwd)
      (repeat len
	(HY_SV)
	(SEtq ent   (ssname ss n)
	      xdata (assoc -3 (entget ent (list "*")))
	      lay   (strcase (cdr (assoc 8 (entget ent))))
	      p1    (p# (car (bg-ypp ent)))
	      p2    (p# (last (bg-ypp ent)))
	      n	    (1+ n)
	)
	(if (< (distance p1 pt) (distance p2 pt))
	  (SEtq p0 p1)
	  (SEtq p0 p2)
	)
	(setvar "clayer" lay)
	(command ^ "line" p0 (polar p0 ang dis) "")
	(setq ent1 (entlast))
	(setq newent (append (entget ent1) (list xdata)))
	(entmod newent)
	(HY_KZSJXZ ent1 "DWAPP" 1000 hwd)
	(HY_RV)
      )
      (setvar "clayer" clay)
    )					;endprogn
  )					;endif
)
;;;========================================================================

(defun g_undef_zh (xc_ent / m_regn m_glb m_ss m_len m_n m_ent)
  (szload zh_get_zhn "hy_dlzh")
  (setq m_regn (zh_get_zhn xc_ent))
  (if m_regn
    (progn
      (setq m_glb (list (cons 8 "AXIS") (list -3 (list m_regn)))
	    m_ss  (ssget "x" m_glb)
      )
      (setq m_len (sslength m_ss)
	    m_n	  0
      )
      (repeat m_len
	(setq m_ent (ssname m_ss m_n))
	(HY_KZSJXZ m_ent m_regn)
	(command "_.chprop" m_ent "" "c" "bylayer" "")
	(setq m_n (1+ m_n))
      )
    )
  )
)
;;;=================================================================
(defun g_ptoe (str1 str2 glb int / prom1 prom2 go_on xz_p ss the_ep
	       oldosm)
  (if str1
    (setq prom1 str1)
    (setq prom1 "请点选指定实体:")
  )
  (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
    (initget "U")
    (setq xz_p (getpoint prom1))
    (if	(and xz_p (/= xz_p "U"))
      (progn
	(setq ss ($ptoe xz_p glb))
	(if ss
	  (setq	the_ep (list (ssname ss 0) xz_p)
		go_on  nil
	  )
	  (prompt prom2)
	)
      )
      (progn
	(if (= xz_p "U")
	  (setq	the_ep xz_p
		go_on nil
	  )
	  (setq	the_ep nil
		go_on nil
	  )
	)
      )
    )
  )
  (re_osmode)
 ;;;; (setvar "osmode" oldosm)
  the_ep
)
;;;				=========BEGIN==========道路交互倒角=========BEGIN==========
(defun road_dj (/	   %_olderr   %_entb1	 %_text1    %_rwid1
		%_lay1	   %_p1	      %_relst4	 %_djcsb1   %_oldvar
		%_widb1	   %_text2    %_goon	 %_ent1	    %_p2
		%_ptb1	   %_djcsb2   %_relst1	 %_entb2    %_rwid2
		%_widb2	   %_ent2     %_lay2	 %_ptb2	    %_rhand1
		%_relst2   %_relst3   %_drmax	 %_defr	    %_flag
		%_rd	   %_glb      %_rhand2	 %_poip1    %_poip2
		%_retv     
		%_zhcd %_zhcd2   %_ifSucess
;;;全局变量
		%%%_uctr
;;;回退次数
	       )
  (if (null $set_p_on_e)
    (#ppls "pppp")
  )
  (if (or (null pub_save_var)
	  (null pub_re_var)
      )
    (#ppls "wwpublic")
  )
  (#ppas "drawroad")
  (pusherr %error_handle)
  (pub_save_var)
  (setq	;;;%_olderr *error*
	;;;*error*	 %error_handle
	%_oldvar (com_init)
  )
  (if (%chk_roadnum)
;;;检查图中道路数
    (progn
      (setq %_goon   t
	    %%%_uctr (HY_ClearUNDO)
	    %_text1  "\n回车退出 /回退U /请选择第一条道路中心线:"
	    %_text2  "\n请选择第二条道路中心线:"
      )
      (while %_goon
	(setq %_relst1 (%sele_road %_text1 nil 1)
;;;选择第一条道路
	      %_ent1   (nth 0 %_relst1)
	      %_p1     (nth 1 %_relst1)
	      %_goon   (nth 6 %_relst1)
	)

	(if %_goon
	  (setq	%_relst2 (%sele_road %_text2 %_ent1 2)
;;;选择第二条道路
		%_ent2	 (nth 0 %_relst2)
		%_p2	 (nth 1 %_relst2)
		%_goon	 (nth 6 %_relst2)
	  )
	)
	(if %_goon
	    (progn
	      (HY_UndoM)
		    (setq %_ifSucess (road_jcdl %_ent1 %_p1 %_ent2 %_p2))
	    );;;progn
	)
	(if %_ent1
	  (redraw %_ent1 4)
	)
	(if %_ent2
	  (redraw %_ent2 4)
	)
       ;;取消桩号定义 考虑几种情况：1) ent1定义桩号，ent2没有定义桩号      2) ent2定义桩号，ent1没有定义桩号
       ;;                           3) ent1 、ent2两个都定义了桩号         4) ent1 、ent2都没有定义桩号 
       ;;如果交互倒角成功
       (if (= %_ifSucess t)
            (progn
		(setq %_zhcd (assoc -3 (entget %_ent1 (list "DLZH_*"))))
	        (if (/= %_zhcd nil)
	             (del_stakedef  %_zhcd)
	        )
	        (setq %_zhcd2 (assoc -3 (entget %_ent2 (list "DLZH_*"))))
	        (if(/= %_zhcd2 nil)
	             (del_stakedef  %_zhcd2) 
	        )
	   )   
       );;end--if(= ifSucess t)
       (setq %_ifSucess nil)
      ;;结束
      )
    )
  )
  (com_reset %_oldvar)
  (clr_err)
 ;;;;; (setq *error* %_olderr)
  (pub_re_var)
  (princ)
)

;;;删除桩号定义
(defun del_stakedef(zhcd / %_zhcd %_ss  %_dimapp  %_Dimss  %_ename  %_ee)
      (setq %_zhcd (car (cadr zhcd)))
      (setq %_ss (ssget "x" (list (cons 8 "AXIS") (list -3 (list %_zhcd))) ) )
      (setq %_dimapp (strcat "*_STK_" (substr %_zhcd 6)))
      (setq %_Dimss   (ssget "x" (list (cons 8 "SZ-ZH-DIM") (list -3 (list %_dimapp)))))
      (if (/= %_ss nil)
           (while (> (sslength %_ss) 0)
	          (setq %_ename (ssname %_ss 0))
	          (ssdel %_ename %_ss)
	          (HY_KZSJXZ %_ename %_zhcd)
	          ;;修改中心线颜色
	          (setq %_ee (entget %_ename))
	          (setq %_ee (subst (cons 62 256) (assoc 62 %_ee) %_ee) )
	          (entmod %_ee)
	          ;;
           )
       )
     ;;删除标注
     (if (/= %_Dimss nil)
          (while (> (sslength %_Dimss) 0)
	         (setq %_ename (ssname %_Dimss 0))
	         (ssdel %_ename %_Dimss)
	         (entdel %_ename)
          )
      )
     (Dl_UnDefineStake (substr %_zhcd 6))
)

;;;检查图中道路数,far fun
(defun %chk_roadnum (/ %info %_glb %_roadnum %_text w_fhv)
;;;	(defun %info ( %%_text / ) ;;;提示信息,son fun
;;;    (prompt %%_text)
;;;		(exit)
;;;	)
  (setq	%_glb	  (quote ((8 . "AXIS") (0 . "LINE,ARC")))
	%_roadnum (ssget "x" %_glb)
	%_text	  "\n图中没有足够的道路数,程序退出!"
  )
  (cond
    ((null %_roadnum)
;;;(%info %_text)
     (prompt %_text)
     (setq w_fhv nil)
    )
    ((< (sslength %_roadnum) 2)
;;;(%info %_text)
     (prompt %_text)
     (setq w_fhv nil)
    )
    (t (setq w_fhv t))
  )
  w_fhv
)
;;;选择道路
(defun %sele_road (%%_text  %%_ent   %%_flag  /	       %_loop
		   %_entp   %_widb   %_ent    %_p      %_goon
		   %_entb   %_rwid   %_lay    %_rhand
		  )
  (setq	%_loop t
	%_goon t
  )
  (while %_loop
    (setq %_entp (HY_SelSingleEnt %%_text "LINE,ARC" "AXIS" nil "U"))
    (cond
      ((null %_entp)
       (setq %_loop nil
	     %_goon nil
       )
      )
      ((= %_entp "RETURN")
       (prompt "\n没选中指定实体,请重选!")
      )
      ((and (= %_entp "U") (= %%_flag 1))
       (if (<= (getvar "undomarks") %%%_uctr)
	 (prompt "\n已全部回退!")
	 (progn
	   (if (= 13 (getvar "undoctl"))
	     (command ".undo" "e")
	   )
	   (command ".undo" "b")
	 )
       )
      )
      ((and (= %%_flag 2) (equal (car %_entp) %%_ent))
       (prompt "\n两实体相同,请重选!")
      )
      (t
       (setq %_ent  (car %_entp)
	     %_p    ($set_p_on_e %_entp)
	     %_entb (entget %_ent)
	     %_loop nil
	     %_goon t
       )
       (redraw %_ent 3)

       (setq %_rwid (dw-spp %_ent "DWAPP" 1040))
       (setq %_widb  (arx_dllk %_ent %_p)
	     %_lay   (strcase(cdr (assoc 8 %_entb)))
	     %_rhand (cdr (assoc 5 %_entb))
       )
       (setq
	 %_rwid	(+ (apply '+ (cadr %_widb)) (apply '+ (caddr %_widb)))
       )
      )
    )
  )
  (list %_ent %_p %_entb %_rwid %_widb %_lay %_goon %_rhand)
)

;;;出错函数
(defun %error_handle (msg)
;;  (command "linetype" "s" "bylayer" "")
;;  (setvar "cecolor" "bylayer")
;;  (command ".ucs" "w")
;;  (command ".layer" "s" "PP-COM" "")
  (if %_ent1
    (redraw %_ent1 4)
  )
  (if %_ent2
    (redraw %_ent2 4)
  )
  (HY_RV)
;;  (pub_re_var)
;;  (if (or (= msg "Function cancelled")
;;	  (= msg "quit / exit abort")
;;      )
;;    (princ)
;;    (princ msg)
;;  )
;;  (setq *error* w_olderr)
  (princ)
)
;;;				=========END==========道路交互倒角=========END==========

;;;				=========BEGIN==========中心花坛=========BEGIN==========
;;;------------------------------
;;; 1998.01.17 sat
;;; 中心花坛
;;;------------------------------
(defun zxht (/ dcl_id what x y lay layc rw rn rd rm layr layb)

  (HY_SV)
  (setq	lay  "ROAD"
	layc "AXIS"
	layr "XROAD"
	layb "ROAD,AXIS,XROAD"
  )
  (DL_MakeLayer lay)

  (if (= zxht~rw nil)
    (setq zxht~rw 40.0)
  )
  (if (= zxht~rn nil)
    (setq zxht~rn 30.0)
  )
  (if (= zxht~rd nil)
    (setq zxht~rd 20.0)
  )
  (if (= zxht~lx nil)
    (setq zxht~lx "img1")
  )
  (setq	rw zxht~rw
	rn zxht~rn
	rd zxht~rd
  )
  (setq dcl_id (szdl_load_dlg "@zxht.dcl"))
  (if (not (new_dialog "zxht" dcl_id))
    (exit)
  )
  (playsld "zxht1" "img1")
  (playsld "zxht2" "img2")
  (mode_tile zxht~lx 2)
  (set_tile "rw" (rtos zxht~rw))
  (set_tile "rn" (rtos zxht~rn))
  (set_tile "rd" (rtos zxht~rd))
  (action_tile "rw" "(setq rw (atof $value))")
  (action_tile "rn" "(setq rn (atof $value))")
  (action_tile "rd" "(setq rd (atof $value))")
  (action_tile "img1" "(setq zxht~lx \"img1\")")
  (action_tile "img2" "(setq zxht~lx \"img2\")")

  (action_tile "accept" "(nbrc)")	;***(done_dialog 1)
  (action_tile "cancel" "(done_dialog 0)")
	
  (setq what (start_dialog))
  (unload_dialog dcl_id)
  (if (= what 1)
    (zxht_1)
  )
  (HY_RV)
  (princ)
)
;;------------------------------
(defun nbrc ()

  (cond
    ((or (<= rw 0) (<= rn 0) (< rd 0))
     (beep)
     (set_tile "error" "应: R 〉0.0, r 〉0.0, d ≥ 0")
    )
    ((<= rw rn)
     (beep)
     (set_tile "error" "应: 外圆半径 R 〉内圆半径 r")
    )
    (t
     (setq zxht~rw rw
	   zxht~rn rn
	   zxht~rd rd
	   rm	   (+ rn (* 0.5 (- rw rn)))
     )
     (done_dialog 1)
    )
  )
)
;;------------------------------
(defun zxht_1 (/      undom  dd	    radold ft	  p00	 angb	ptb
	       ss     ang    pt1    pt2	   ptc1	  ptc2	 sst1	sst2
	       e      rwold  ren    layold tmp_ptb tmp_ss del_ss
	      )

  (setq dd (* 0.7 (get_dd)))
  (setq undom (HY_ClearUNDO))
  (setq	radold (getvar "filletrad")
	layold lay
  )
  (setvar "filletrad" rd)

  (setq ft t)
  (while ft
    (sa_osmode)
    (setvar "osmode" 32)
    (initget "U")
    (setq
      p00 (getpoint "\n回车退出 / 取消上次 U / <道路中心线交叉点>:")
    )
    (re_osmode)
  ;;;;  (setvar "osmode" 0)
    (cond
      ((= p00 nil) (setq ft nil))
      ((= p00 "U")
       (if (> (getvar "undomarks") undom)
	 (HY_UndoB)
	 (prompt "\n上次没做.")
       )
      )
      (t
       (setq pt1 (polar p00 (* 0.25 pi) (* 2.0 rw))
	     pt2 (polar p00 (* 1.25 pi) (* 2.0 rw))
	     lay layold
       )
       (command "view" "s" "zxht_0")
       (HY_UndoM)
       (setq flag (zm2pt pt1 pt2))
       (if (setq angb (qq_ang p00 rw lay))
	 
	 (if (<= (length angb) 2)
	   (progn
	     (beep)
	     (prompt "\n不是道路岔口.")
	   )
	   (progn
	     (command "circle" p00 rn)
	     (HY_EntMakeCircle layc p00 rm)
	     (setq erm (entlast))
	     (setq ptb (qq_ptb p00 rm 32))
;;	     (setq ss
;;		    (ssget "f" ptb (list '(0 . "LINE,ARC") (cons 8 layb)))
;;	     )
;;	     
;;	     (if ss
;;	       (progn
;;				 (command "trim" erm "")
;;				 (setq ii 0)
;;				 (repeat (sslength ss)
;;				   (command (list (ssname ss ii) p00))
;;				   (setq ii (1+ ii))
;;				 )				 
;;				 (command "")
;;	       )
;;	     )
	     ;===========================================================================
	     
	     (setq ii 0
		   rwold rw
	     )
	     (while (<= ii 1)
	       (setq ii (1+ ii))
	       (setq ptb (qq_ptb p00 (+ rw 0.5) 32))
	       (setq ss	(ssget "cp"
							       ptb
							       (list '(0 . "LINE,ARC") (cons 8 lay))
									)
			   )
	       (if ss
					 (progn
					   (foreach pt2	angb
					     (setq ptc1	(polar pt2 0.8 (* 0.1 dd))
						   ptc2	(polar pt2 3.9 (* 0.1 dd))
						   sst1	(ssget "c"
							       ptc1
							       ptc2
							       (list '(0 . "CIRCLE,ARC")
								     (list -3 (list lay))
							       )
							)
						   sst2	(ssget "c"
							       ptc1
							       ptc2
							       (list '(0 . "CIRCLE,ARC,LINE")
								     (cons 8 layc)
								     (list -3 (list "DWAPP"))
							       )
							)
					     )
					     (if (and sst1
						      (= (sslength sst1) 1)
						      sst2
						      (= (sslength sst2) 1)
						 )
					       (progn
						 (setq e (ssname sst1 0)
						       e (list e pt2)
						 )
						 
						 (command "trim" ss "" e "")
					       )
					     )
					   )
					   (setq ptb (qq_ptb p00 (+ rw 2) 32))
					   (setq ss
						  (ssget "cp"
							 ptb
							 (list '(0 . "ARC") (list -3 (list lay)))
						  )
					   )
					   
			;;		  任蔚青增加2003-6-21 16:23 begin**********************
			;;		  原因：作完环道后有些多余的路边线没有删除掉
					  (setq tmp_ptb  (qq_ptb p00  rw 32))
					  (setq tmp_ss (ssget "cp"
							 tmp_ptb
							 (list '(0 . "ARC,LINE") (cons 8 lay))
						  )
					  )
				          (setq del_ss (ssadd))
				          (if tmp_ss
				            (progn
				          	(setq i 0)
						(while  (< i (sslength tmp_ss))
						       (setq  e (ssname  tmp_ss i))
						       (if (not (ssmemb e ss))
						           (setq del_ss (ssadd  e del_ss))
						       )
						      (setq i (1+ i))
						)
				            )
				         )
			;;		  任蔚青增加2003-6-21 16:23 end	**********************	   
					   (if ss
					     (zxht_2 ss ptb lay)
					   )
			
					   
			;;                 任蔚青修改2003-6-21 16:24 begin***************************==========		   
			;;		   (setq ptb (qq_ptb p00 (- rw 1) 32))
			;;		
			;;		   (if (= lay layr)
			;;		     (setq
			;;		       ss (ssget "cp"
			;;				 ptb
			;;				 (list '(0 . "ARC,LINE") (cons 8 lay))
			;;			  )
			;;		     )
			;;		     (setq
			;;		       ss (ssget "cp"
			;;				 ptb
			;;				 (list '(0 . "ARC,LINE") (cons 8 lay))
			;;			  )
			;;		     )
			;;;;;18:01 98-11-10
			;;		   )
			;;		   (if ss
			;;		     (command "erase" ss "")
			;;		   )
					   (if del_ss 
					     (command "erase" del_ss "")
					   )
					 )
;;		  任蔚青修改2003-6-21 16:24 end	***************************==========

		 (prompt "\n外圆半径不合适, 没有找到道路.")
	       )
	       (if (and ren (= ii 1))
					 (setq lay  layr
					       rw   (+ rw ren)
					       angb (qq_ang p00 rw lay)
					 )
		 				(setq ii (1+ ii))
	       )
	     )
	     (setq rw rwold)

;;;modi 1998.03.16
	     (if (and erm (entget erm))
	       (progn
;;;任蔚青屏蔽2003-6-21 11:18
;;		 (command ".break"
;;			  erm
;;			  (polar p00 0 rm)
;;			  (polar p00 (dtor 0.01) rm)
;;		 )
		 (HY_KZSJXZ erm "dwapp" 1040 (- rw rn))
	       )
	     )
;;;--------------
	   )
	 )
	 (progn
	   (beep)
	   (prompt "\n没有找到道路中心线.")
	 )
       )
       (if flag
	 (command "view" "r" "zxht_0")
       )
      )
    )
  )
  (setvar "filletrad" radold)
)
;;-----------------------------
;; zxht_2
;;-----------------------------
(defun zxht_2 (ss ptb lay / ii e eb p00	rr an1 an2 p01 p02 pm pm1 pm2
	       fhb e1 e2 p11 p12)
  (if (= zxht~lx "img1")
    (progn

      (setq ii 0)
      (repeat (sslength ss)
	(setq e	  (ssname ss ii)
	      ii  (1+ ii)
	      eb  (entget e)
	      p00 (cdr (assoc 10 eb))
	      rr  (cdr (assoc 40 eb))
	      an1 (cdr (assoc 50 eb))
	      an2 (cdr (assoc 51 eb))
	      p01 (polar p00 an1 rr)
	      p02 (polar p00 an2 rr)
	      pm  (getmid p01 p02)
	      pm  (polar p00 (angle p00 pm) rr)
	)
	(command "break" e pm pm)
      )
      (setq
	ss (ssget "cp" ptb (list '(0 . "ARC") (list -3 (list lay))))
      )
    )
  )

  (setq ii 0)
  (repeat (sslength ss)
    (setq e   (ssname ss ii)
	  eb  (entget e)
	  p00 (cdr (assoc 10 eb))
	  rr  (cdr (assoc 40 eb))
	  an1 (cdr (assoc 50 eb))
	  an2 (cdr (assoc 51 eb))
	  p01 (polar p00 an1 rr)
	  p02 (polar p00 an2 rr)
	  pm  (getmid p01 p02)
	  pm1 (getmid p01 pm)
	  pm1 (polar p00 (angle p00 pm1) rr)
	  pm2 (getmid p02 pm)
	  pm2 (polar p00 (angle p00 pm2) rr)
	  pm  (polar p00 (angle p00 pm) rr)
    )

    (if	(= zxht~lx "img2")		;*** Line
      (progn
	(entdel e)
	(command "line" p01 p02 "")
	(setq e (entlast))
	(HY_KZSJXZ e lay 1000 "A")
	(command "move" e "" (getmid p01 p02) pm)
	(setq eb  (entget e)
	      p11 (cdr (assoc 10 eb))
	      p12 (cdr (assoc 11 eb))
	)
	(entdel e)
      )
    )
    (if	(= zxht~lx "img2")
      (progn
	(hy_EntMakeLine (list p11 pm) lay)
	(setq e (entlast))
	(HY_KZSJXZ e lay 1000 "A")
      )
    )

    (if	(and (setq fhb (arclin p01 lay)) (= (length fhb) 1))
       (do_flt e pm1 (car (car fhb)) (cadr (car fhb)) rd)
    )
    (if	(= zxht~lx "img2")
      (progn
	(hy_EntMakeLine (list p12 pm) lay)
	(setq e (entlast))
	(HY_KZSJXZ e lay 1000 "A")
      )
    )
    (if	(and (setq fhb (arclin p02 lay)) (= (length fhb) 1))
      (do_flt e pm2 (car (car fhb)) (cadr (car fhb)) rd)
    )
    (setq ii (1+ ii))
  )

)
;;-----------------------------------
(defun do_flt (e1 p1 e2 p2 rd / rdmax)
  (setq rdmax (HY_js_f_max e1 p1 e2 p2))
  (if (and rdmax (<= rd rdmax))
    (progn
      (setvar "filletrad" rd)
      (command "fillet" (list e1 p1) (list e2 p2))
    )
    (progn
      (prompt "\n倒角半径不合适, 请用fillet命令手动处理.")
					;(if (= zxht~lx "img2") (entdel e1))
    )
  )
)
;;-----------------------------
;; 取一点ROAD CENTER方向
;; ==>(p1 p2 p3...)
;;-----------------------------
(defun qq_ang (p00 rw lay / ptbb ptb ss ii e eb fhb flag tmp_lx len count)
  (#ppas "drawroad")
  (setvar "clayer" lay)
  (command "circle" p00 rw)
  (setq erw (entlast))
  (HY_KZSJXZ erw lay 1000 "A")
  (setq	ptbb (qq_ptb p00 rw 32)
	ss   (ssget "f"
		    ptbb
		    (list '(0 . "LINE,ARC") (cons 8 layc) '(-3 ("DWAPP")))
	     )
  )

  (if (= ss nil)
    (progn
      (HY_UndoB)
      (setq fhb nil)
    )
    (progn
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	 (ssname ss ii)
	      eb (entget e)
;;;8/3/00 wht---------BEGIN
	)

  (setq w_lkb (arx_dllk e p00)
        w_lx  (car w_lkb)
  )

  (setq tmp_lx (car w_lx))
  (setq len (length tmp_lx))
  (setq flag nil)
  (if (and (> len 0) (>= (length (cadr w_lkb)) len))
     (progn 
        (setq count 0)
        (while (and (< count len) (not flag))
             (if (= (nth count tmp_lx) "R") 
                   (setq w_rxd_rl (= (nth count (cadr w_lkb)))
                         flag     t
                   )
                   (setq count (1+ count))
              )
         )
      )
      
   )
   (if (not flag) (setq w_rxd_rl nil))

   (setq tmp_lx (cadr w_lx))
   (setq len (length tmp_lx))
   (setq flag nil)
   (if (and (> len 0) (>= (length (caddr w_lkb)) len))
     (progn 
        (setq count 0)
        (while (and (< count len) (not flag))
             (if (= (nth count tmp_lx) "R") 
                   (setq w_rxd_rr (= (nth count (caddr w_lkb)))
                         flag     t
                   )
                   (setq count (1+ count))
              )
         )
      )
   )
   (if (not flag) (setq w_rxd_rr nil))
                   
;;	      w_lx  (car w_lkb)
;;	)     
;;	(if (> (length (cadr w_lkb)) w_lx)
;;	  (setq w_rxd_rl (last (cadr w_lkb)))
;;	)
;;	(if (> (length (caddr w_lkb)) w_lx)
;;	  (setq w_rxd_rr (last (caddr w_lkb)))
;;	)
;;	(if (and w_rxd_rl w_rxd_rr)
;;	  (setq ren (max w_rxd_rl w_rxd_rr))
;;	  (setq ren nil)
;;	)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;				(if	ren
;;;					;;--- arc has not.
;;;					(progn
;;;						(setq	ren	(reverse (read ren))
;;;											;;--- global variable.
;;;																				;ren (cadr ren)
;;;						)
;;;						(print ren) (getpoint "ren")
;;;;;;8:18 98-12-31
;;;						(if	(listp (car ren))
;;;							(setq ren (caddr ren))
;;;							(setq ren (cadr ren))
;;;						)
;;;						(print ren) (getpoint "ren")
;;;;;;8:18 98-12-31
;;;						(if	(and (car ren) (cadr ren))
;;;							(setq ren (max (car ren) (cadr ren)))
;;;							(setq ren nil)
;;;						)
;;;					)
;;;				)
;;;8/3/00 wht---------END
	(if (= (cdr (assoc 0 eb)) "LINE")
	  (setq ptb (ipt_la e erw))
	  (setq ptb (ipt_aa e erw))
	)
	(setq fhb (append fhb ptb))
	(setq ii (1+ ii))
      )
      (if (<= (length fhb) 2)
	(HY_UndoB)
	(if (setq ss
		   (ssget "f"
			  ptbb
			  (list '(0 . "LINE,ARC") (cons 8 lay) '(-3 ("DWAPP")))
		   )
	    )
	  (progn
	    (command "trim" erw "")
	    (setq ii 0)
	    (repeat (sslength ss)
	      (command (list (ssname ss ii) p00))
	      (setq ii (1+ ii))
	    )
	    (command "")
	  )
	)
      )
    )
  )
  fhb
)
;;-----------------------------
;;-----------------------------
;; 取点表 (qq_ptb p00 rr nn)
;; p00/rr/nn  -->center/radius/divided
;;-----------------------------
(defun qq_ptb (p00 rr nn / delt ang pt ptb)

  (setq delt (/ (* 2.0 pi) nn))
  (setq ang 0.0)
  (repeat nn
    (setq pt  (polar p00 ang rr)
	  ptb (append ptb (list pt))
	  ang (+ ang delt)
    )
  )
  (append ptb (list (car ptb)))		;*** close
)
;;--------------------------------------
;; ARC's two End point and Center point
;; ==> (pt_center pt_start pt_end)
;;--------------------------------------
(defun arc_pt (e / eb p00 p01 p02 rr an1 an2)
  (setq	eb  (entget e)
	p00 (cdr (assoc 10 eb))
	rr  (cdr (assoc 40 eb))
	an1 (cdr (assoc 50 eb))
	an2 (cdr (assoc 51 eb))
	p01 (polar p00 an1 rr)
	p02 (polar p00 an2 rr)
  )
  (list p00 p01 p02)
)
;;------------------------------
;; from ARC seek LINE
;; ==>((e1 p1))/((e1 p1) (e2 p2))
;;------------------------------
(defun arclin (pt lay / pt1 pt2 sst st1 eet p01 p02 e1 e2 fhb e ii)

  (setq dd (* 0.01 (get_dd)))
  (setq	pt1 (polar pt 0.8 dd)
	pt2 (polar pt 3.9 dd)
	sst (ssget "c"
		   pt1
		   pt2
		   (list '(0 . "LINE,ARC") (cons 8 lay) '(-3 ("DWAPP")))
	    )
  )
  (if (and sst (= (sslength sst) 1))
    (setq fhb (list (ss_ept sst pt)))
    (progn
      (if (setq sst (ssget "c" pt1 pt2 (list '(0 . "ARC") (cons 8 lay))))
	(progn
	  (setq	ii  0
		st1 (ssadd)
	  )
	  (repeat (sslength sst)
	    (setq e  (ssname sst ii)
		  ii (1+ ii)
	    )
	    (if	(not (appft e lay))
	      (setq st1 (ssadd e st1))
	    )
	  )
	  (setq sst st1)
	)
      )
      (if (and sst (= (sslength sst) 1))
	(progn
	  (setq	eet (ssname sst 0)
		fhb (arc_pt eet)
		p01 (nth 1 fhb)
		p02 (nth 2 fhb)
		p01 (get1pt p01 p02 pt "near")
		pt1 (polar p01 0.8 dd)
		pt2 (polar p01 3.9 dd)
		st1 (ssget
		      "c"
		      pt1
		      pt2
		      (list '(0 . "LINE,ARC") (cons 8 lay) '(-3 ("DWAPP")))
		    )
	  )
	  (if (and st1 (= (sslength st1) 1))
	    (setq fhb (list (ss_ept st1 p01)))
	  )
	)
      )
    )
  )
  fhb
)
;;------------------------------
;; ==>(e pt_far)
;;------------------------------
(defun ss_ept (ss pt / e eb p01 p02 p00 rr an1 an2 pm)
  (setq	e  (ssname ss 0)
	eb (entget e)
  )
  (if (= (cdr (assoc 0 eb)) "LINE")
    (setq p01 (cdr (assoc 10 eb))
	  p02 (cdr (assoc 11 eb))
	  pt  (get1pt p01 p02 pt "far")
    )
    (setq p00 (cdr (assoc 10 eb))
	  rr  (cdr (assoc 40 eb))
	  an1 (cdr (assoc 50 eb))
	  an2 (cdr (assoc 51 eb))
	  p01 (polar p00 an1 rr)
	  p02 (polar p00 an2 rr)
	  pm  (getmid p01 p02)
	  pm  (polar p00 (angle p00 pm) rr)
	  pt  (polar pt (angle pt pm) (* 0.5 rr))
    )
  )
  (list e pt)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun setnil ()
  (setq	zxht nil
	nbrc nil
	zxht_1 nil
	zxht_2 nil
	qq_ang nil
	qq_ptb nil
	ang_pt nil
	arclin nil
	ss_ept nil
	do_flt nil
  )
  (princ)
)
;;;				=========END==========中心花坛=========END==========

;;;				=========BEGIN==========交互倒角=========BEGIN==========
;;;modi 8/3/00
(defun #dljhdj (/      loop   loop1  loop2  ent	   ent1	  p1	 p2
		entb   rwid   rwid1  lay    rd	   rdmax  defr	 rxdwid
		uctr
	       )
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (setq	loop t
	uctr (HY_ClearUNDO)
  )
  (while loop
					;(setq ent (HY_SelSingleEnt "\n回车退出 / 回退 U / 点取第一条线或弧:" "LINE,ARC" "*ROAD" nil "U"))
    (setq ent (HY_SelSingleEnt "\n回车退出 / 回退 U / 点取第一条线或弧:"
		       "LINE,ARC"
		       nil
		       nil
		       "U"
	      )
    )
    (cond
      ((= ent "U")
       (if (<= (getvar "undomarks") uctr)
	 (prompt "\n已全部回退!")
	 (progn
	   (if (= 13 (getvar "undoctl"))
	     (command ".undo" "e")
	   )
	   (command ".undo" "b")
	 )
       )
      )
      ((null ent) (setq loop nil))
      ((= ent "RETURN") (prompt "\n没选中指定实体!"))
      (t
       (setq p1	 (cadr ent)
	     ent (car ent)
       )
       (redraw ent 3)
       (setq entb (entget ent))
       (setq rwid (dw-spp ent "DWAPP" 1040)
;;;road width
	     lay  (strcase(cdr (assoc 8 entb)))
       )
       (if (= lay "XROAD")
	 (setq rxdwid (car (dw-spp ent "PP-XROAD" 1010)))
	 (setq rxdwid 0)
       )
       (setq loop1 t)
       (while loop1
	 (setq
	   ent1	(HY_SelSingleEnt "\n点取第二条线或弧:" "LINE,ARC" nil nil "U")
	 )
	 (cond
	   ((null ent1) (setq loop1 nil) (redraw ent 4))
	   ((= ent1 "RETURN") (prompt "\n没选中指定实体!"))
	   ((equal (car ent1) ent) (prompt "\n两实体相同!"))
	   (t
	    (setq p2   (cadr ent1)
		  ent1 (car ent1)
	    )
	    (redraw ent1 3)
	    (setq entb (entget ent1))
	    (setq rwid1	(dw-spp ent1 "DWAPP" 1040)
;;;road width
	    )
	    (if	(and (#is_line ent) (#is_line ent1))
	      (setq rdmax (bj_get_maxr ent p1 ent1 p2))
	      (setq rdmax (HY_js_f_max ent p1 ent1 p2))
	    )
	    (if	(and rwid rwid1 rdmax)
	      (progn
		(setq defr (- (#get_roadr rwid rwid1) rxdwid))
		(if (> defr rdmax)
		  (setq defr nil)
		)
	      )
	      (setq defr nil)
	    )
	    (setq loop2 t)
	    (while loop2
	      (if defr
		(progn
		  (initget 4)
		  (setq	rd (getdist (strcat "\n最大倒角半径为<"
					    (rtos rdmax 2 3)
					    ">,输入倒角半径<"
					    (rtos defr 2 3)
					    ">:"
				    )
			   )
		  )
		  (if (null rd)
		    (setq rd defr)
		  )
		)
		(progn
		  (initget 4)
		  (if rdmax
		    (setq rd (getdist (strcat "\n最大倒角半径为<"
					      (rtos rdmax 2 3)
					      ">,输入倒角半径<0>:"
				      )
			     )
		    )
		    (setq rd (getdist (strcat "\n输入倒角半径<0>:")))
		  )
		  (if (null rd)
		    (setq rd 0)
		  )
		)
	      )
;;;	      (if (and rdmax (> rd rdmax))
;;;		(prompt "\n倒角半径不合适.")
;;;		(setq loop2 nil)
;;;	      )
	      (if (and rdmax (>= rd rdmax))
		(setq rd rdmax)
		;;(prompt "\n倒角半径不合适.")
	      )
	      (setq loop2 nil)
	    )
	    (setvar "filletrad" rd)
	    (HY_UndoM)
	    (command "fillet" (list ent p1) (list ent1 p2))
	    (HY_KZSJXZ (entlast) "dwapp")
;;;;8:25 98-12-17
	    (setq loop1 nil)
	   )
	 )
       )
;;;end of while loop1
      )
    )
  )
  (pub_save_var)
  (princ)
)
;;;				=========END==========交互倒角=========END==========

;;;				=========BEGIN==========切人行道=========BEGIN==========
(defun #rxda2l (/ glb ss p1 p2 ptb len n loop ent)
  (HY_SV)
  (setq	glb  '((0 . "ARC")
	       (8 . "XROAD")
	      )
	loop t
  )
  (prompt "\n***用于将道路交叉口的人行道弧转成直线***")
  (hy_set0)
  (DL_MakeLayer "XROAD")
  (while loop
    (prompt "\n选择要转成直线的人行道弧:")
    (setq ss (ssget glb))
    (if	ss
      (progn
	(HY_UndoM)
	(setq len (sslength ss)
	      n	  0
	)
	(repeat	len
	  (setq	ent (ssname ss n)
		ptb (bg-ypp ent)
		p1  (cadr ptb)
		p2  (car ptb)
	  )
	  (entdel ent)
	  (command ".line" p1 p2 "")
	  (setq n (1+ n))
	)
      )
      (setq loop nil)
    )
  )
  (hy_set1)
  (HY_RV)
  (princ)
)
;;;				=========END==========切人行道=========END==========


;;;				=========END==========交互切角=========END==========

;;;;;王志宇增加2002-11-11 11:04
;;;判断一个点是否在曲线上
(defun pt_on_ent (pt ent / flag pt1 pt2 ent1 typ centre star_ang end_ang)
  (setq ent1 (entget ent))
  (setq kind (cdr (assoc 0 ent1)))
  (if (null pt_on_e)
  	(progn
  		(#ppas "Drawroad")
  		(setq flag t)
  	)
	)
  (setq pt1 (pt_on_e ent pt))
  (if (and pt1 (equal pt pt1 0.01))
  	t
  	nil
  )

)
;;;;求实体和另一条道路中心线交点  
(defun get_point (ent	 ipt	pt     /      ent1   pt0    pt1 pt3
		  pt2	 ss	dist   dist1  len    cont   count1
		  lis	 lis1	radius devide ang ang1 ang2 ang3
		 )
  ;;ent 实体名 ipt两实体交点  pt实体选这点

  (setq ent1 (entget ent))
  (cond
    ((= (cdr (assoc 0 ent1)) "LINE")
     (setq pt1 (cdr (assoc 10 ent1)))
     (setq pt2 (cdr (assoc 11 ent1)))
     (setq ang1 (angle pt ipt)
           ang2 (angle pt1 pt2)
           ang3 (angle pt2 pt1)
     )
     (if (< (abs(- ang1 ang2))(abs(- ang1 ang3)))
       (setq pt1 pt2)
     )
	(&view_ptb (list ipt pt1))
  (setq ss (ssget "F" (list ipt pt1) '((8 . "AXIS"))))
   (if ss
       (progn
	 (setq dist 1000000)
	 (setq dist1 0)
	 (setq len (sslength ss))
	 (setq count 0)
	 (setq pt0 nil)
	 
	 (repeat len
	   
	   (if (= nil(equal ent (ssname ss count)))
	     (progn
	       
	       (setq pt1 (ipt2e ent (ssname ss count)))
	       (setq pt1 (car pt1))
	       
	       (if pt1
		 (progn
		   (setq dist1 (distance pt1 ipt))
		   (if (< dist1 dist)
		     (progn
           (setq dist dist1)
		       (setq pt0 pt1)
		     )
		   )
		   )
		 )
	       
	       
	     )	     
	   )
	   (setq count (1+ count)) 
	 )
;;;;repeat
	 pt0
       )
       nil
     )
    )
    ((= (cdr (assoc 0 ent1)) "ARC")
     (setq radius (cdr (assoc 40 ent1)))
     (setq ang1 (cdr (assoc 50 ent1)))
     (setq centre (cdr (assoc 10 ent1)))
     (setq ang2 (angle centre pt))
     (setq ang (angle centre ipt))
     (if (> (* (- ang ang1) (- ang ang2)) 0)
       (setq ang1 (cdr (assoc 51 ent1)))
     )
	(setq devide (* radius (abs (- (cdr (assoc 50 ent1)) (cdr (assoc 51 ent1))))))
     (setq devide (fix devide))
     
     (setq lis (HY_DivideArc ent devide))     
     (setq len devide)
     (setq lis1 nil)
     (setq count 0)
     (setq len (- len 1))
     (repeat len
       (setq pt1 (nth count lis))
       (setq pt2 (nth (1+ count) lis))
       (setq count (1+ count))
       (&view_ptb (list pt1 pt2))
       (command "line" pt1 pt2"")
       (setq ent2 (entlast))
       (setq ss (ssget "F" (list pt1 pt2) '((8 . "AXIS"))))
       (if ss
	 (progn
	   (setq count1 0)
	   (repeat (sslength ss)	     
	     (if (= nil (equal ent (ssname ss count1)))
	       
	       (if(setq pt3 (ipt2e ent2 (ssname ss count1)))
		 (progn
		   (setq pt3 (car pt3))
		   
		   (setq lis1 (cons pt3 lis1))
		   
		   )
		 )
	       
	     )
	     
	     (setq count1 (1+ count1))

	   )
	 )
       )
       (entdel ent2)
     )
     
     (setq pt0 nil)
     (if lis1
       (progn
	 (setq lis1 (reverse lis1))
					;(setq lis1 (cdr lis1))
	 (setq ang3 10000)
	 (setq len (length lis1))
	 (setq count 0)
	 (repeat len
	   (setq pt (nth count lis1))
	   (setq count (1+ count))
	   (setq ang (angle centre pt))
	   
	   (if (< (* (- ang ang1) (- ang ang2)) 0)
	     (progn
	       
	       (setq ang (abs ang))
	       (if (< ang ang3)
		 (progn
		   (setq ang3 ang)
		   (setq pt0 pt)
		 )
	       )
	     )
	   )
	 )
       )
     )
     pt0
    )
  )
  ;;cond
)
;;;end


;;;断开实体，得到断开实体后的对应新实体
(defun mend (ent ipt / ent1 ent2 p1 pt1 pt2)
  (setq	p1   (cadr ent)
	ent1 (car ent)
  )
  (setq pt1 (get_point ent1 ipt p1))
  (if pt1
    (progn
      (setq ent2 (entlast))
      (setq pt1 (pt_on_e ent1 pt1 ))
      
      ;;;(setq ipt (pt_on_e ent1 ipt))
      (command ".break" (list ent1 pt1) ipt)
      (setq ent2 (entnext ent2))

      (if ent2
	(progn
	  (if (pt_on_ent ipt ent2)
	    (progn
	      (setq ent1 ent2)
	    )
	  )
	  (setq ent (list ent1 p1))
	  ent
	)
	nil
      )
    )
    nil
  )
)
;;;;;王志宇增加2002-11-11 11:04	


(defun dljhqj (/     glb   ss	 loop  uctr  cc	   bzfw	 lay   ent
	       ent1  ent2  loop1 ipt   dis   dist1 dist2 p1    p2
	       enta  entb   entc entd ente pta ptb ptc
	      )
;;;main routine
 (#ppas "drawroad")
  (HY_SV)
  (SETQ	GLB  (QUOTE ((0 . "LINE,ARC")
		    )
	     )
	ss   (ssget "x" glb)
	loop t
  )
  (if ss
    (progn
      (setq uctr (HY_ClearUNDO))
      (while loop
				(setq cc "\n回车退出 / 回退 U / 点取第一条线或弧:")
				(setq ent (HY_SelSingleEnt cc "LINE,ARC" nil nil "U"))
				(cond
				  ((null ent) (setq loop nil))
				  ((= ent "RETURN") (prompt "\n没选中指定实体!"))
				  ((= ent "U") ($undob uctr))
				  (t
				   (setq loop1 t)
				   (while loop1
				     (setq ent1	(HY_SelSingleEnt "\n点取第二条线或弧:"
							 "LINE,ARC"
							 nil
							 nil
							 nil
						)
				     )
				     (cond
				       ((null ent1) (setq loop1 nil) (redraw (car ent) 4))
				       ((= ent1 "RETURN") (prompt "\n没选中指定实体!"))
				       ((equal (car ent1) (car ent)) (prompt "\n两实体相同!"))
				       (t
					(HY_UndoM)
			
			;;;;;王志宇修改2002-11-11 11:04
			     
					(setq enta ent)
					(setq entb ent1)
					(setq ipt (car (ipt2e (car enta) (car entb))))
					(if ipt
					  (progn					
							(if (setq entc (mend enta ipt))
							  (setq ent entc)
							)							
							(if (setq  entc (mend entb ipt))
							  (setq ent1 entc)
							)
				   )
				  )
					
					
					
			;;;王志宇修改2002-11-11 11:04
					(setvar "filletrad" 0)
					
					(command ^^ ".fillet" ent1 ent)
					(setq p1   (cadr ent1)
					      ent1 (car ent1)
					      p2   (cadr ent)
					      ent2 (car ent)
					)
					(setq entb (entget ent1)
					      lay  (strcase(cdr (assoc 8 entb)))
					)
					(setq ipt   (car (ipt2e ent1 ent2))
			;;;;;;    dist1 (#rwid ent1)
					      dist2 (#rwid ent2)
					      dist1 (#get_roadq dist1 dist2)
					      dist2 dist1
					)
					(if ipt
					  (progn
					    (setq p1 (#lend_pos (list ent1 p1) dist1))
					    (setq p2 (#lend_pos (list ent2 p2) dist2))
					    (grdraw p1 ipt 1 -1)
					    (initget 4)
					    (setq
					      dis (getreal (strcat "\n虚线标记处切角长度一<"
								   (rtos dist1 2 2)
								   ">:"
							   )
						  )
					    )
					    (redraw)
					    (if	dis
					      (setq dist1 dis)
					    )
					    (grdraw p2 ipt 1 -1)
					    (initget 4)
					    (prompt (strcat "\n虚线标记处切角长度二为:"
							    (rtos dist2 2 2)
						    )
					    )
					    (setq
					      dis (getreal (strcat "\n虚线标记处切角长度二<"
								   (rtos dist1 2 2)
								   ">:"
							   )
						  )
					    )
					    (redraw)
					    (if	dis
					      (setq dist2 dis)
					      (setq dist2 dist1)
					    )
					    (setq p1 (#lend_pos (list ent1 p1) dist1)
						  p2 (#lend_pos (list ent2 p2) dist2)
					    )			
					    ;;;;以下王志宇11月13日修改
					    (command ".break" (list ent1 p1) p1)
					    (if(pt_on_ent ipt ent1)
					      (entdel ent1)
					      (entdel (entlast))
					    )
					    (command ".break" (list ent2 p2) p2)
					    (if(pt_on_ent ipt  ent2)
					    	(entdel ent2)
					    	(entdel (entlast))
					    )
					    ;;;;以上王志宇11月13日修改
					    (command ".line" p1 p2 "")
					    (setq ent (entlast))
					    (HY_KZSJXZ ent "DWAPP" 8 lay)
					    (HY_KZSJXZ ent "DWAPP")
					    (setq loop1 nil)
					  )
					  (setq loop1 nil)
					)
			;;;end of if ipt  
				       )
				     )
				   )
			
				  )
				)
      )
    )
  )
  (HY_RV)
  (princ)
)

;;;				=========END==========交互切角=========END==========



;;;				=========BEGIN==========修改转弯半径=========BEGIN==========
(defun bj_ch_rdr (/	     w_flt_list	w_fcc	   w_bcc
		  w_ep	     w_ent
		  w_csb	     w_cp	w_old_r	   w_sp
		  w_mp	     w_mang	w_sep	   w_eep
		  w_goon     w_sp_pt	w_sp_ent   w_ep_pt
		  w_ep_ent   w_lkb	w_max_lk   w_smp
		  w_emp	     w_max_r	w_min_r	   w_old_rstr
		  w_new_r    w_zp1	w_zp2	   w_fp1
		  w_fp2	     w_ss1	w_ss2	   w_elast
		  w_ent1     w_ent2	w_cc	   w_next
		  w_max_rstr w_min_rstr	sel_pt
		  w_b        w_ss       w_zhcd     w_ename
		  w_dimapp   w_Dimss    w_ee
		 )
  (szload pub_save_var "wwpublic")
  (szload $p_to_e "pppp")
  (#ppas "drawroad")
  (pub_save_var)
  (setq w_flt_list '((0 . "ARC") (8 . "AXIS") (-3 ("SZDLZYXX"))))
  (setq w_fcc "\n 回车退出 / 选择道路中心线弧:")
  (setq w_bcc "\n 没选中指定实体,请重选!")
 ;;;; (setq w_old_osmode (getvar "osmode"))
  (sa_osmode)
  (setq w_ep ($p_to_e w_fcc w_bcc w_flt_list 512))
  (if w_ep
    (progn
;;;cenp r ang1 ang2 sp ep midp ang len jp
      (setq w_ent   (car w_ep))
      ;;;
      (setq w_b (cdr (assoc -3 (entget w_ent (list "HYSZHHQX*")))))
      (setq w_b (car (mapcar 'car w_b) ))
      (if w_b
      	(HY_KZSJXZ w_ent w_b)
      )
      ;;;
      (setq sel_pt  (cadr w_ep)
	    w_csb   ($arc_csb w_ent)
	    w_cp    (nth 0 w_csb)
	    w_old_r (nth 1 w_csb)
	    w_sp    (nth 4 w_csb)
	    w_ep    (nth 5 w_csb)
	    w_mp    (nth 6 w_csb)
	    w_mang  (angle w_cp w_mp)

      )
      (setq w_flt_list '((0 . "LINE") (8 . "AXIS") (-3 ("SZDLZYXX"))))
      (setq w_sep ($p_search w_ent w_sp w_flt_list))
      (setq w_eep ($p_search w_ent w_ep w_flt_list))
      (setq w_goon t)
      (if (> (length w_sep) 1)
	(progn
	  (#mark w_sp)
	  (prompt "\n标记处相连结的直道路多于一条,不能倒角!")
	  (setq w_goon nil)
	)
      )
      (if (> (length w_eep) 1)
				(progn
				  (#mark w_ep)
				  (prompt "\n标记处相连结的直道路多于一条,不能倒角!")
				  (setq w_goon nil)
				)
      )
      (setq w_sep (car w_sep)
	    w_eep (car w_eep)
      )
      (if (null w_sep)
				(progn
				  (#mark w_sp)
				  (prompt "\n标记处没有相连结的直道路,不能倒角!")
				  (setq w_goon nil)
				)
				(setq w_sp_pt  (car w_sep)
				      w_sp_ent (cadr w_sep)
				)
      )
      (if (null w_sep)
				(progn
				  (#mark w_ep)
				  (prompt "\n标记处没有相连结的直道路,不能倒角!")
				  (setq w_goon nil)
				)
				(setq w_ep_pt  (car w_eep)
				      w_ep_ent (cadr w_eep)
				)
      )
;;;提取路宽
      (setq w_lkb (arx_dllk w_ent sel_pt))
      (setq w_max_lk
	     (max (apply '+ (cadr w_lkb)) (apply '+ (caddr w_lkb)))
      )
      (if (and w_sp_ent w_ep_ent)
      	(progn
      		(setq w_smp (midpt w_sp w_sp_pt)
	    					w_emp (midpt w_ep w_ep_pt)
		      )
		      (setq w_max_r (HY_js_f_max w_sp_ent w_smp w_ep_ent w_ep_pt))
		      (setq w_max_r (fix w_max_r))
		      (setq w_min_r (+ w_max_lk 0.5))
      	)
      )
      
      (if (< w_max_r w_min_r)
				(progn
				  (prompt "\n 转弯处情况复杂,程序不能处理,请用交互倒弧处理!")
				  (setq w_goon nil)
				)
      )
      (if w_goon
				(progn
				  (setq	w_old_rstr (HY_Trim0 (rtos w_old_r 2 3) 1)
								w_min_rstr (HY_Trim0 (rtos w_min_r 2 3) 1)
								w_max_rstr (HY_Trim0 (rtos w_max_r 2 3) 1)
								w_cc	   "\n 输入新的转弯半径("
								w_cc	   (strcat w_cc w_min_rstr "--" w_max_rstr)
				  )
				  (setq w_next t)
				  (while w_next
				    (setq w_new_r (getreal (strcat w_cc ")<" w_old_rstr ">:")))
				    (if	w_new_r
				      (setq w_new_r w_new_r)
							;;;2001/11/23 任蔚青修改
							;;;(setq w_new_r (- w_new_r (rem w_new_r 0.5)))
				      (setq w_new_r w_old_r)
				    )
				    (if (equal w_new_r w_min_r 0.001)
				    	(setq w_new_r w_min_r)
				    )
				    (if (equal w_new_r w_max_r 0.001)
				    	(setq w_new_r w_max_r)
				    )				    
				    (if	(or (< w_new_r w_min_r) (> w_new_r w_max_r))
				      (progn
				      	(princ "\n半径值不在 ")(princ w_min_r)(princ " 和 ")(princ w_max_r)(princ " 之间，请重输!")
				      )
				      (setq w_next nil)
				    )
				  )
				  (if (equal w_new_r w_old_r 0.01)
				    (setq w_new_r nil)
				  )
				  (if w_new_r
				    (progn
				      (HY_UndoM)
			;	      (setvar "osmode" 0)
				      (command "_.view" "s" "bj_chrdrv")
				      (setq w_zp1 (polar w_mp (* 0.25 pi) (* w_max_lk 4))
								    w_zp2 (polar w_mp (* 1.25 pi) (* w_max_lk 4))
							)
				      (zm2pt w_zp1 w_zp2)
				      (setq w_fp1 (polar w_mp w_mang (+ w_max_lk 5.0))
					    			w_fp2 (polar w_mp (+ w_mang pi) (+ w_max_lk 5.0))
				      )
			;;;搜索所有道路边线
				      (setq w_flt_list
					     '((0 . "ARC")
					       (8 . "ROAD,ROAD-1,XROAD")
					       (-3 ("DWAPP"))
					      )
				      )
			;;;外侧所有道路边线
				      (setq w_ss1 (ssget "f" (list w_fp1 w_mp) w_flt_list))
			
			;;;内侧所有道路边线
				      (setq w_ss2 (ssget "f" (list w_fp2 w_mp) w_flt_list))
			;;;修改中心线弧
				      (setvar "filletrad" w_new_r)
				      (command "_.fillet"
					       (list w_sp_ent w_smp)
					       (list w_ep_ent w_emp)
				      )
				      (setq w_elast (entlast))
				      ($trans_xda w_ent w_elast)
				      ;;取消桩号定义
				      (setq w_zhcd (assoc -3 (entget w_elast (list "DLZH_*"))))
				      (if (/= w_zhcd nil)
				        (progn
					      (setq w_zhcd (car (cadr w_zhcd)))
					      (setq w_ss (ssget "x" (list (cons 8 "AXIS") (list -3 (list w_zhcd))) ) )
					      (setq w_dimapp (strcat "*_STK_" (substr w_zhcd 6)))
					      (setq w_Dimss   (ssget "x" (list (cons 8 "SZ-ZH-DIM") (list -3 (list w_dimapp)))))
					      (if (/= w_ss nil)
					        (while (> (sslength w_ss) 0)
				       	          (setq w_ename (ssname w_ss 0))
				 	          (ssdel w_ename w_ss)
					          (HY_KZSJXZ w_ename w_zhcd)
					          ;;修改中心线颜色
					          (setq w_ee (entget w_ename))
					          (setq w_ee (subst (cons 62 256) (assoc 62 w_ee) w_ee) )
					          (entmod w_ee)
					          ;;
				                 )
					       )
				             ;;删除标注
				             (if (/= w_Dimss nil)
				               (while (> (sslength w_Dimss) 0)
				                 (setq w_ename (ssname w_Dimss 0))
				                 (ssdel w_ename w_Dimss)
				                 (entdel w_ename)
				               )
					      )
				             (Dl_UnDefineStake (substr w_zhcd 6))
				          )
			             )
				      
				      ;;
				      (command "_.erase" w_ent "")
				      (while (and w_ss1 (> (sslength w_ss1) 0))
					(setq w_ent1 (ssname w_ss1 0))
					(ssdel w_ent1 w_ss1)
					(act_ch_rdr w_ent1 w_new_r w_old_r)
					(command "_.erase" w_ent1 "")
				      )
				      (while (and w_ss2 (> (sslength w_ss2) 0))
					(setq w_ent2 (ssname w_ss2 0))
					(ssdel w_ent2 w_ss2)
					(act_ch_rdr w_ent2 w_new_r w_old_r)
					(command "_.erase" w_ent2 "")
				      )
				      (command "_.view" "r" "bj_chrdrv")
				    )
				  )
				)
      )
    )
  )
  (pub_re_var)
  (re_osmode)
 ;;;; (setvar "osmode" w_old_osmode)
  (princ)
)

(defun act_ch_rdr (xc_ent    xc_new_r  xc_old_r	 /	   w_csb
		   w_old_r   w_sp      w_ep	 w_rr	   w_new_r
		   w_la	     w_flt_list		 w_sep	   w_eep
		   w_goon    w_sp_pt   w_sp_ent	 w_ep_pt   w_ep_ent
		   w_smp     w_emp     w_elast
		  )
  (setq w_csb ($arc_csb xc_ent))
  (setq	w_old_r	(nth 1 w_csb)
	w_sp	(nth 4 w_csb)
	w_ep	(nth 5 w_csb)
	w_rr	(- w_old_r xc_old_r)
	w_new_r	(+ xc_new_r w_rr)
  )

  (setq w_la (assoc 8 (entget xc_ent)))
  (setq w_flt_list (list (cons 0 "LINE") w_la (list -3 (list "DWAPP"))))
  (setq w_sep ($p_search xc_ent w_sp w_flt_list))
  (setq w_eep ($p_search xc_ent w_ep w_flt_list))
  (setq w_goon t)
  (if (> (length w_sep) 1)
    (setq w_goon nil)
  )
  (if (> (length w_eep) 1)
    (setq w_goon nil)
  )
  (setq	w_sep (car w_sep)
	w_eep (car w_eep)
  )
  (if (null w_sep)
    (setq w_goon nil)
    (setq w_sp_pt  (car w_sep)
	  w_sp_ent (cadr w_sep)
    )
  )
  (if (null w_sep)
    (setq w_goon nil)
    (setq w_ep_pt  (car w_eep)
	  w_ep_ent (cadr w_eep)
    )
  )
  (setq	w_smp (midpt w_sp w_sp_pt)
	w_emp (midpt w_ep w_ep_pt)
  )
  (if w_goon
    (progn
      (setvar "filletrad" w_new_r)
      (command "_.fillet"
	       (list w_sp_ent w_smp)
	       (list w_ep_ent w_emp)
      )
      (setq w_elast (entlast))
      ($trans_xda xc_ent w_elast)
    )
  )
)
;;;				=========END==========修改转弯半径=========END==========
;;;				=========BEGIN==========过街天桥=========BEGIN==========
;;;

(defun bj_gjtq_chkok (/ w_ok)
  (setq	wg_w (get_tile "edit1")
	wg_l (get_tile "edit2")
	wg_d (get_tile "edit3")
	w_ok t
  )
  (cond
    ((not (HY_IsNum wg_l))
     (set_tile "error" "尺寸 L 必须是合法的实数")
     (mode_tile "edit2" 2)
     (setq w_ok nil)
    )
    ((not (HY_IsNum wg_w))
     (set_tile "error" "尺寸 W 必须是合法的实数")
     (mode_tile "edit1" 2)
     (setq w_ok nil)
    )
    ((not (HY_IsNum wg_d))
     (set_tile "error" "尺寸 D 必须是合法的实数")
     (mode_tile "edit3" 2)
     (setq w_ok nil)
    )
  )
  w_ok
)
;;;				=========BEGIN==========道路小桥=========BEGIN==========
;;;

;;;新增加函数 -- 求两根相交直线在某个夹角范围内的最大半径 2001.08.01
(defun bj_get_maxr (xc_ent1  xc_p1    xc_ent2  xc_p2	/
		    w_retr   w_sp1    w_ep1    w_sp2	w_ep2
		    w_intp   w_p1     w_p2     w_jang	w_ang0
		    w_t1     w_t2     w_t
		   )
  (szload $qtyd1 "pppp")
  (setq w_retr 0.0)
  (if (and (#is_line xc_ent1) (#is_line xc_ent2))
    (progn
      (setq w_sp1 (cdr (assoc 10 (entget xc_ent1)))
	    w_ep1 (cdr (assoc 11 (entget xc_ent1)))
	    w_sp2 (cdr (assoc 10 (entget xc_ent2)))
	    w_ep2 (cdr (assoc 11 (entget xc_ent2)))
      )
      (setq w_intp (inters w_sp1 w_ep1 w_sp2 w_ep2))
      (if w_intp
	(progn
	  (setq	w_p1   ($qtyd1 xc_p1 w_sp1 w_ep1)
		w_p2   ($qtyd1 xc_p2 w_sp2 w_ep2)
		w_jang ($jiajiao w_intp w_p1 w_p2)
	  )
	  (setq w_ang0 (angle w_intp w_p1))
	  (if (eq_ang w_ang0 (angle w_intp w_sp1))
	    (setq w_ep1 w_sp1)
	  )
	  (setq w_ang0 (angle w_intp w_p2))
	  (if (eq_ang w_ang0 (angle w_intp w_sp2))
	    (setq w_ep2 w_sp2)
	  )
	  (setq	w_t1 (distance w_intp w_ep1)
		w_t2 (distance w_intp w_ep2)
		w_t  (min w_t1 w_t2)
	  )
	  (setq	w_retr
		 (* w_t (/ (sin (* 0.5 w_jang)) (cos (* 0.5 w_jang))))
	  )
	)
      )
    )
  )
  w_retr
)
;;;新增函数 -- 检查清理小短线 2001.08.01
(defun bj_chk_sline (/	      w_ss     w_maxl	w_slen	 w_ii
		     w_ss_del w_ent    w_elen	w_prom	 w_goon
		     w_ss_add w_ptb    w_edel	w_pt	 w_key
		    )
  (hy_set0)
  (setq w_ss (ssget "x" '((0 . "LINE,ARC,*POLYLINE"))))
  (if w_ss
    (progn
      (setq w_maxl (getreal "\n 请输入小短线最大控制长度<1.0>:"))
      (if (null w_maxl)
	(setq w_maxl 1.0)
      )
      (setq w_slen (sslength w_ss))
      (setq w_ss_del (ssadd))
      (while (> (sslength w_ss) 0)
	(setq w_ent (ssname w_ss 0))
	(ssdel w_ent w_ss)
	(setq w_elen (#entlen w_ent))
	(if (and w_elen (<= w_elen w_maxl))
	    (ssadd w_ent w_ss_del)
	)
      )
    )
    (prompt "\n 没发现小于最大控制长度长度的小短线!")
  )

  (if (and w_ss_del (> (setq w_slen (sslength w_ss_del)) 0))
    (progn
      (szload $jck_zoom_ptb "jck_bkjc")
      (setq
	w_prom (strcat "经过检查，共有 " (itoa w_slen) "个无效实体!")
      )
      (DL_MsgOK w_prom)
      ;;-----------------------------          
      (setq w_goon t)
      (setq w_ss_add (ssadd))
      (while w_goon
	(if (> (sslength w_ss_del) 0)
	  (progn
	    (setq w_ent (ssname w_ss_del 0))
	    (ssdel w_ent w_ss_del)
	    (redraw w_ent 3)
	    (setq w_ptb (bg-ypp w_ent))
	    ($jck_zoom_ptb w_ptb)
	    (setq w_edel (#mark (car w_ptb)))
	    (prompt
	      (strcat "\n 该实体长度 : " (rtos (#entlen w_ent) 2 6))
	    )
	    (initget "A X E")
	    (setq w_key
		   (getkword
		     "\n 退出 X / 全部删除 A / 删除该实体 E / <回车下一实体>:"
		   )
	    )
	    (cond
	      ((null w_key)
	       (ssadd w_ent w_ss_add)
	       (redraw w_ent 4)
	      )
	      ((= w_key "X")
	       (setq w_goon nil)
	       (redraw w_ent 4)
	      )
	      ((= w_key "A")
	       (command "_.erase" w_ent "")
	       (command "_.erase" w_ss_del "")
	       (command "_.erase" w_ss_add "")
	       (setq w_goon nil)
	      )
	      ((= w_key "E")
	       (command "_.erase" w_ent "")
	      )
	    )
	    (command "_.erase" w_edel "")
	  )
	  (progn
	    (setq w_goon nil)
	    (prompt "\n 已经全部处理!")
	  )
	)
      )
    )
  )
  (hy_set1)
  (princ)
)
				

;;;
;;-------------------------------------------            
;; 1999.02.09
;; e --- *POLYLINE
;; pt -- point In Polyline
;; fhb - (flag kd gd p01 p02 ang bg)
;;       flag = T/nil 成功时T
;;-------------------------------------------            
(defun #getpkdn (e pt / flag eb bg kd gd fhb ft p1 p2 pc ptm an1 an2 an3
	       wb ang sca bhbz r_cir v42)
  (setq	eb     (entget e)
	bg     (caddr (cdr (assoc 10 eb)))
	bhbz   (cdr (assoc 70 eb))
	flag   nil
  )
  (if (null bg) (setq bg (cdr (assoc 38 eb))))
  (setq	gd (cdr (assoc 39 eb))
	kd (cdr (assoc 40 eb))
  )
  (setq	wb (dw-ypp1 e pt)
	pt (car wb)
	p1 (cadr wb)
	p2 (caddr wb)
        v42 (cadddr wb)
  )
  (if pt
    (setq ft t)
  )
				;----- pt 为POLYLONE内顶点时不处理 ----------
  (if ft
    (progn
      (setq flag t)
      (if (zerop v42)
	(progn
	  (setq ang (angle p1 p2))
	)
	(progn
;;;modi 1998.10.26
          (setq wb (parc_pcr p1 p2 v42)
                pc (car wb)
                an3 (angle (p# pc) (p# pt)) 
          )
          (if (> v42 0)
            (setq ang (+ an3 (/ pi 2)))
            (setq ang (- an3 (/ pi 2)))
          )
;;;----------------
	)
      )
    )
  )
  (if (= flag nil)
    (setq fhb (list flag))
    (setq fhb (list flag kd gd p1 p2 ang bg v42 pc r_cir))
  )
  fhb
)					;end of defun
;;;求实体ent在pt点切线方向
(defun #getepdir(ent pt / entb p1 p2 etype ptb pc ang)
  (setq entb (entget ent)
        etype (cdr (assoc 0 entb))
  )
  (cond
    ((= etype "LINE")
      (setq ptb (bg-ypp ent)
            p1 (p# (last ptb))
            p2 (p# (car ptb))
            ang (angle p1 p2)
      )
    ) 
    ((= etype "ARC")
;;;      (setq pc (cdr (assoc 10 entb))
;;;            ang (+ (angle pc pt) (/ pi 2))
;;;      )
      (setq pc (cdr (assoc 10 entb))
            ang (- (angle pt pc) (/ pi 2))
      )
    )
    ((wcmatch etype "*POLYLINE")
      (setq ang (nth 5 (#getpkdn ent pt)))
    ) 
    (t
      (prompt"\n实体只能是LINE,ARC,POLYLINE,LWPOLYLINE.")
    )
  )
  ang
)
(defun #get_roadr (w1 w2 / m n fn r maxr minr w)
  (if (null roadr:defv)
    (progn
      (setq fn (strcat (HY_GetInstallDir) hyszdl_gv_commres_dir)
	    fn (strcat fn "\\" hyszdl_gv_dat_dir)
	    fn (strcat fn "\\pp-roadr.tst")
      )
      (if (findfile fn)
	(setq roadr:defv (getdat fn))
	(progn
	  (DL_MsgOK "系统文件被破坏,请重新安装软件! HYSZ_ERROR #010222")
	  (exit)
	)
      )
    )
  )
  (if (> w2 w1)
;;;w1=(max w1 w2)
    (setq m  w1
	  w1 w2
	  w2 m
    )
  )
  (setq m (assoc w1 (cdr roadr:defv)))
  (if m
    (progn
      (setq n (##getindex w2 (setq w (car roadr:defv))))
      (if n
	(setq r (nth (1+ n) m))
      )
    )
  )
  (if (null r)
    (progn
      (if (null w)
	(setq w (car roadr:defv))
      )
      (setq minr (car w)
	    maxr (apply 'max w)
      )
      (if (> w1 maxr)
	(setq w1 maxr)
	(if (< w1 minr)
	  (setq w1 minr)
	)
      )
      (if (< w2 minr)
	(setq w2 minr)
	(if (> w2 maxr)
	  (setq w2 maxr)
	)
      )
      (setq n	0
	    len	(length w)
      )
      (while (and (< n len) (< (nth n w) w1))
	(setq n (1+ n))
      )
      (setq w1 (nth n w))
      (setq n 0)
      (while (and (< n len) (< (nth n w) w2))
	(setq n (1+ n))
      )
      (setq r (nth (1+ n) (assoc w1 (cdr roadr:defv))))
    )
  )
  r
)
;;;
(defun #get_roadq (w1 w2 / m n fn r maxr minr w)
  (if (null roadq:defv)
    (progn
      (setq fn (strcat (HY_GetInstallDir) hyszdl_gv_commres_dir)
	    fn (strcat fn "\\" hyszdl_gv_dat_dir)
	    fn (strcat fn "\\pp-roadq.tst")
      )
      (if (findfile fn)
	(setq roadq:defv (getdat fn))
	(progn
	  (DL_MsgOK "系统文件被破坏,请重新安装软件! HYSZ_ERROR #010222")
	  (exit)
	)
      )
    )
  )
  (if (> w2 w1)
;;;w1=(max w1 w2)
    (setq m  w1
	  w1 w2
	  w2 m
    )
  )
  (setq m (assoc w1 (cdr roadq:defv)))
  (if m
    (progn
      (setq n (##getindex w2 (setq w (car roadq:defv))))
      (if n
	(setq r (nth (1+ n) m))
      )
    )
  )
  (if (null r)
    (progn
      (if (null w)
	(setq w (car roadq:defv))
      )
      (setq minr (car w)
	    maxr (apply 'max w)
      )
      (if (> w1 maxr)
	(setq w1 maxr)
	(if (< w1 minr)
	  (setq w1 minr)
	)
      )
      (if (< w2 minr)
	(setq w2 minr)
	(if (> w2 maxr)
	  (setq w2 maxr)
	)
      )
      (setq n	0
	    len	(length w)
      )
      (while (and (< n len) (< (nth n w) w1))
	(setq n (1+ n))
      )
      (setq w1 (nth n w))
      (setq n 0)
      (while (and (< n len) (< (nth n w) w2))
	(setq n (1+ n))
      )
      (setq r (nth (1+ n) (assoc w1 (cdr roadq:defv))))
    )
  )
  r
)
(defun $p_search (ent p flst / p1 ss_nxt pp_eb ent ssl i ssl ei ppb)
  (setq	p1     (p# p)
	ss_nxt ($ptoe p1 flst)
  )
  (if (null ss_nxt)
    (setq pp_eb nil)
    (progn
      (if ent
	(ssdel ent ss_nxt)
      )
      (setq ssl	  (sslength ss_nxt)
	    i	  0
	    pp_eb nil
      )
      (repeat ssl
	(setq ei  (ssname ss_nxt i)
	      ppb (bg-ypp ei)
	)
	(cond
	  ((equal p1 (p# (car ppb)) 0.01)
	   (setq pp_eb (cons (list (p# (last ppb)) ei) pp_eb))
	  )
	  ((equal p1 (p# (last ppb)) 0.01)
	   (setq pp_eb (cons (list (p# (car ppb)) ei) pp_eb))
	  )
	)
	(setq i (1+ i))
      )
    )
  )
  pp_eb
)

;;;add 09-29-98把ent1的扩展数据传递给ent2
(defun $trans_xda (ent1 ent2 / xda1 da2 xda2 appn_b x_item)
  (if (and (= (type ent1) 'ENAME) (= (type ent2) 'ENAME))
    (progn
      (setq xda1 (assoc -3 (entget ent1 (list "*"))))
      (if xda1
	(progn
	  (setq	da2  (entget ent2)
		xda2 (cdr (assoc -3 (entget ent2 (list "*"))))
	  )
	  (if xda2
	    (setq appn_b (mapcar 'car (cdr xda1)))
	    (foreach x_item xda2
	      (if (not (member (car x_item) appn_b))
		(setq xda1 (append xda1 (list x_item)))
	      )
	    )
	  )
	  (setq xda2 (append da2 (list xda1)))
	  (entmod xda2)
	)
      )
    )
  )
)
;;;
			
