;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------
;;; 1998.01.11 wed
;;; 土方网格处理
;;;
;;; 修改记录：
;;; 2002.11.08 fri add by wei
;;; 对特殊的3～6个角点的网格，逐点选取处理
;;;
;;;-----------------------------
(defun t_wgcl (/ laypt bh app kk  ss wgbl)

  (HY_SV)
  (HY_UndoM)
  (setq laypt "PP-TF-PT")

  (initget 6)
  (setq bh (getint "\n输入区域编号<1>:"))
  (if (= bh nil)
    (setq bh 1)
  )
  (setq app (strcat "A" (itoa bh)))

  (if (not (setq wgbl (qqwgbl bh)))
    (prompt "\n该编号区域没有定义。")
    (progn
      (initget "W S")
      (setq kk (getkword "\n逐个手选 S / 开窗选 W / <处理该区域>:"))
      (cond
        ;;ren add 2003-7-14 13:33
        ;;2002.11.08 fri add by wei
        ;;对特殊的3～6个角点的网格，逐点选取处理
        ((= kk "S") 
          (while (hand_CL))
          (setq ss nil)
	       )
        ;;开窗选
        ((= kk "W")
	        (setq ss (ssget (list '(0 . "POINT") (cons 8 laypt) (list -3 (list app)))))
	)
	      ;;处理该区域
	      (t
	  (zoombh bh)
	  (setq	ss (ssget "x"
			  (list	'(0 . "INSERT")
				'(2 . "JSCKD")
				(list -3 (list app))
			  )
		   )
	  )
	  (if ss
	    (command "erase" ss "")
	  )
					;;----- 仅选内点处理 ----------------------------
	  (setq	ss (ssget "x"
			  (list	'(0 . "POINT")
				(cons 8 laypt)
				(list -3 (list app))
			  )
		   )
	  )
	)
      )
      ;;-------------------------------------------------
     (if ss (wgcl_1 ss wgbl app))
    )
  )
  (HY_RV)
)

(defun wgcl_1(ss wgbl app / laypt ii e eb pt ptb ll)
  (if (and ss (> (sslength (setq ss (sscut ss app))) 0))
	(progn
	  (setq laypt "PP-TF-PT")
	  (DL_MakeLayer laypt)
	  (setq ii 0)
	  (repeat (sslength ss)
	    (setq e   (ssname ss ii)
		  eb  (entget e)
		  pt  (cdr (assoc 10 eb))
		  ptb (cons pt ptb)
	    )
	    (setq ii (1+ ii))
	  )

	  (setq ll (* wgbl (cos (* 0.25 pi)))) ;;*** 到中心点长度
	  (foreach pt ptb
	    (if	(not (pdbz pt (* 0.25 pi) ll app))
	      (ptcl pt (* 0.25 pi) wgbl app)
	    )
	    (if	(not (pdbz pt (* 0.75 pi) ll app))
	      (ptcl pt (* 0.75 pi) wgbl app)
	    )
	    (if	(not (pdbz pt (* 1.25 pi) ll app))
	      (ptcl pt (* 1.25 pi) wgbl app)
	    )
	    (if	(not (pdbz pt (* 1.75 pi) ll app))
	      (ptcl pt (* 1.75 pi) wgbl app)
	    )
	  )
	  (prompt "\n可用Undo/Back命令取消上次操作.")
	)
	      ;;(prompt "\n没有选取标高点。")
   )
)
  
;;---------------------------------------
;; 1996.08.30 fri
;; 对指定方向进行处理 ptcl(pt ang bc)
;; pt  -- base point
;; ang -- angle 
;; bc  -- 方格边长
;;---------------------------------------
(defun ptcl (pt	ang bc app / p01 p02 ss ssll pxmin pxmax pymin pymax pmin
	     pmax)

  (setq	p01   (polar pt (+ ang pi) 1e-6)
	p02   (polar pt ang (+ 1e-6 (/ bc (cos (* 0.25 pi)))))
	pxmin (min (car p01) (car p02))
	pxmax (max (car p01) (car p02))
	pymin (min (cadr p01) (cadr p02))
	pymax (max (cadr p01) (cadr p02))
	pmin  (list pxmin pymin 0.0)
	pmax  (list pxmax pymax 0.0)
  )

  (setq	ss (ssget "c"
		  p01
		  p02
		  (list	'(0 . "POINT")
			(cons 8 laypt)
			'(-4 . "<AND")
			'(-4 . ">=,>=,*")
			(cons 10 pmin)
			'(-4 . "<=,<=,*")
			(cons 10 pmax)
			'(-4 . "AND>")
			(list -3 (list app))
		  )
	   )
  )
  (if ss
    (progn
      (setq ssll (sslength ss))
      (cond
					;========================================================        
	((= ssll 3) (pt3cl pt ang bc ss app)) ;*** 区分/分析
	((= ssll 4) (pt4cl pt ang bc ss app))
	((= ssll 5) (pt5cl pt ang bc ss app))
	((= ssll 6) (pt6cl pt ang bc ss app))
	((>= ssll 7) (pt7cl pt ang bc ss app))
					;========================================================      
      )
      (setq ss nil)
    )
  )
  (princ)
)
;;------------------------------
;; 1996.08.30 fri
;; 3 POINT分析 --- pt3cl(ss)
;;------------------------------
(defun pt3cl (pt    ang	  bc	ss   app /	    e1	  e1b	p01   hand1
	      e2    e2b	  p02	hand2 e3    e3b	  p03	hand3 ss
	      bb    p00
	     )

  (setq	e1    (HY_PtName pt 0.0 0.0 0.1 app)
	e1b   (entget e1)
	p01   (cdr (assoc 10 e1b))
	hand1 (cdr (assoc 5 e1b))
  )
  (setq ss (ssdel e1 ss))

  (setq	e2  (ssname ss 0)
	e2b (entget e2)
	p02 (cdr (assoc 10 e2b))

	e3  (ssname ss 1)
	e3b (entget e3)
	p03 (cdr (assoc 10 e3b))
  )
  (if (equal (car p01) (car p02) 1.0e-3)
    (progn
      (setq hand2 (cdr (assoc 5 e2b)))
      (setq hand3 (cdr (assoc 5 e3b)))
    )
    (progn
      (setq hand2 (cdr (assoc 5 e3b)))
      (setq hand3 (cdr (assoc 5 e2b)))
    )
  )
					;----- 规则形状记录 -----------------  
  (if (and hand1 hand2 hand3)
    (progn
      (setq bb (list 3 hand1 hand2 hand3))
      (setq bb (list2s bb))

      (setq p00 (polar pt ang (* bc (cos (* 0.25 pi)))))
      (szdl_ins_sysblk "jsckd" p00 "1" "1" "0")
      (HY_KZSJXZ (entlast) "JSCK" 1000 bb)
      (HY_KZSJXZ (entlast) app 1000 "@")
    )
  )
)
;;------------------------------
;; 1996.08.30 fri
;; 4 POINT分析 --- pt4cl(ss)
;;------------------------------
(defun pt4cl (pt    ang	  bc	ss   app /	    e1	  e1b	p01   hand1
	      e2    e2b	  p02	hand2 e3    e3b	  p03	hand3 e4
	      e4b   p04	  hand4	ss    bb    p00
	     )

  (setq	e1    (HY_PtName pt 0.0 0.0 0.1 app)
	e1b   (entget e1)
	p01   (cdr (assoc 10 e1b))
	hand1 (cdr (assoc 5 e1b))
  )
  (setq ss (ssdel e1 ss))

  (setq	e2  (ssname ss 0)
	e2b (entget e2)
	p02 (cdr (assoc 10 e2b))

	e3  (ssname ss 1)
	e3b (entget e3)
	p03 (cdr (assoc 10 e3b))

	e4  (ssname ss 2)
	e4b (entget e4)
	p04 (cdr (assoc 10 e4b))
  )
  (setq bb (list p02 p03 p04))
					;----- (2) --------------------------------------  
  (foreach pt bb
    (if	(equal (car p01) (car pt) 1.0e-3)
      (progn
	(setq p02 pt)
	(setq e2 (HY_PtName p02 0.0 0.0 0.1 app))
	(setq hand2 (cdr (assoc 5 (entget e2))))
      )
    )
  )
  (setq bb (liscut bb p02))
					;----- (4) --------------------------------------  
  (foreach pt bb
    (if	(equal (cadr p01) (cadr pt) 1.0e-3)
      (progn
	(setq p04 pt)
	(setq e4 (HY_PtName p04 0.0 0.0 0.1 app))
	(setq hand4 (cdr (assoc 5 (entget e4))))
      )
    )
  )
  (setq bb (liscut bb p04))
  (setq p03 (car bb))
  (setq e3 (HY_PtName p03 0.0 0.0 0.1 app))
  (setq hand3 (cdr (assoc 5 (entget e3))))
					;----- 规则形状记录 -----------------  
  (if (and hand1 hand2 hand3 hand4)
    (progn
      (setq bb (list 4 hand1 hand2 hand3 hand4))
      (setq bb (list2s bb))

      (setq p00 (polar pt ang (* bc (cos (* 0.25 pi)))))
      (szdl_ins_sysblk "jsckd" p00 "1" "1" "0")
      (HY_KZSJXZ (entlast) "JSCK" 1000 bb)
      (HY_KZSJXZ (entlast) app 1000 "@")
    )
  )
)
;;------------------------------
;; 1996.08.30 fri
;; 5 POINT分析 --- pt5cl(ss)
;;------------------------------
(defun pt5cl (pt    ang	  bc	ss  app /	    e1	  e1b	p01   hand1
	      e2    e2b	  p02	hand2 e3    e3b	  p03	hand3 e4
	      e4b   p04	  hand4	e5    e5b   p05	  hand5	ang   angt
	      angb  angc  ss	bb    p00   flag  flag1 flag2 angd
	      ange
	     )

  (setq	e1    (HY_PtName pt 0.0 0.0 0.1 app)
	e1b   (entget e1)
	p01   (cdr (assoc 10 e1b))
	hand1 (cdr (assoc 5 e1b))
  )
  (setq ss (ssdel e1 ss))

  (setq	e2  (ssname ss 0)
	e2b (entget e2)
	p02 (cdr (assoc 10 e2b))

	e3  (ssname ss 1)
	e3b (entget e3)
	p03 (cdr (assoc 10 e3b))

	e4  (ssname ss 2)
	e4b (entget e4)
	p04 (cdr (assoc 10 e4b))

	e5  (ssname ss 3)
	e5b (entget e5)
	p05 (cdr (assoc 10 e5b))
  )
  (setq bb (list p02 p03 p04 p05))
					;----- (2) --------------------------------------  
  (foreach pt bb
    (if	(equal (car p01) (car pt) 1.0e-3)
      (progn
	(setq p02 pt)
	(setq e2 (HY_PtName p02 0.0 0.0 0.1 app))
	(setq hand2 (cdr (assoc 5 (entget e2))))
      )
    )
  )
  (setq bb (liscut bb p02))
					;----- (5) --------------------------------------  
  (foreach pt bb
    (if	(equal (cadr p01) (cadr pt) 1.0e-3)
      (progn
	(setq p05 pt)
	(setq e5 (HY_PtName p05 0.0 0.0 0.1 app))
	(setq hand5 (cdr (assoc 5 (entget e5))))
      )
    )
  )
  (setq bb (liscut bb p05))

;;任蔚青修改2003-7-14 17:23--------------
  (setq angb (angle p05 p01)
        angc (angle p01 p02)
  )
  (setq flag (IsClockWise angb angc))
  (if (and (car bb) (cadr bb))
     (progn
     (setq angd (angle p02 (car bb)) 
           ange (angle (car bb) (cadr bb))
           flag1 (IsClockWise angc angd)
           flag2 (IsClockWise angd ange)
     )
     (if (or (and flag flag1 flag2) (and (not flag) (not flag1) (not flag2)))
         (setq p03 (car bb) p04 (cadr bb))
         (setq p04 (car bb) p03 (cadr bb))
     )      
	
                  
     (setq e3    (HY_PtName p03 0.0 0.0 0.1 app)
	   hand3 (cdr (assoc 5 (entget e3)))
	   e4 (HY_PtName p04 0.0 0.0 0.1 app)
	   hand4 (cdr (assoc 5 (entget e4)))
     )  
     ) 
   )               
         
  	 
           
;;  (setq angb (ptang p02))
;;  (foreach pt bb
;;    (setq angt (angle p02 pt))
;;    (foreach ang angb
;;      (setq angc (abs (- angt ang)))
;;      (if (or (equal angc 0.0 1.0e-2)
;;	      (equal angc pi 1.0e-2)
;;	      (equal angc (* 2.0 pi) 1.0e-2)
;;	  )
;;	(progn
;;	  (setq p03 pt)
;;	  (setq e3 (HY_PtName p03 0.0 0.0 0.1 app))
;;	  (setq hand3 (cdr (assoc 5 (entget e3))))
;;	)
;;      )
;;    )
;;  )
;;  (setq bb (liscut bb p03))
;;  (setq p04 (car bb))
;;  (setq e4 (HY_PtName p04 0.0 0.0 0.1 app))
;;  (setq hand4 (cdr (assoc 5 (entget e4))))
;;任蔚青修改2003-7-14 17:23---------------------end


					;----- 规则形状记录 -----------------  
  (if (and hand1 hand2 hand3 hand4 hand5)
    (progn
      (setq bb (list 5 hand1 hand2 hand3 hand4 hand5))
      (setq bb (list2s bb))

      (setq p00 (polar pt ang (* bc (cos (* 0.25 pi)))))
      (szdl_ins_sysblk "jsckd" p00 "1" "1" "0")
      (HY_KZSJXZ (entlast) "JSCK" 1000 bb)
      (HY_KZSJXZ (entlast) app 1000 "@")
    )
  )
)
;;------------------------------
;; 1996.09.02 mon
;; 6 POINT分析 --- pt6cl(ss)
;;------------------------------
(defun pt6cl (pt    ang	  bc	ss  app  /	    e1	  e1b	p01   hand1
	      e2    e2b	  p02	hand2 e3    e3b	  p03	hand3 e4
	      e4b   p04	  hand4	e5    e5b   p05	  hand5	e6    e6b
	      p06   hand6 ss	bb    p00   angb  ang	angt  angc
	     )
  (setq s6 ss)
  (setq	e1    (HY_PtName pt 0.0 0.0 0.1 app)
	e1b   (entget e1)
	p01   (cdr (assoc 10 e1b))
	hand1 (cdr (assoc 5 e1b))
  )
  (setq ss (ssdel e1 ss))

(if (and ss (= (sslength ss) 5))
  (progn
  (setq	e2  (ssname ss 0)
	e2b (entget e2)
	p02 (cdr (assoc 10 e2b))

	e3  (ssname ss 1)
	e3b (entget e3)
	p03 (cdr (assoc 10 e3b))

	e4  (ssname ss 2)
	e4b (entget e4)
	p04 (cdr (assoc 10 e4b))

	e5  (ssname ss 3)
	e5b (entget e5)
	p05 (cdr (assoc 10 e5b))

	e6  (ssname ss 4)
	e6b (entget e6)
	p06 (cdr (assoc 10 e6b))

  )
  (setq bb (list p02 p03 p04 p05 p06))
 )
)
					;----- (2) --------------------------------------  
  (foreach pt bb
    (if	(equal (car p01) (car pt) 1.0e-3)
      (progn
	(setq p02 pt)
	(setq e2 (HY_PtName p02 0.0 0.0 0.1 app))
	(setq hand2 (cdr (assoc 5 (entget e2))))
      )
    )
  )
  (setq bb (liscut bb p02))
				;----- (6) --------------------------------------  
  (foreach pt bb
    (if	(equal (cadr p01) (cadr pt) 1.0e-3)
      (progn
	(setq p06 pt)
	(setq e6 (HY_PtName p06 0.0 0.0 0.1 app))
	(setq hand6 (cdr (assoc 5 (entget e6))))
      )
    )
  )
  (setq bb (liscut bb p06))

  (setq angb (ptang p02))
  (foreach pt bb
    (setq angt (angle p02 pt))
    (foreach ang angb
      (setq angc (abs (- angt ang)))
      (if (or (equal angc 0.0 1.0e-3)
	      (equal angc pi 1.0e-3)
	      (equal angc (* 2.0 pi) 1.0e-3)
	  )
	(progn
	  (setq p03 pt)
	  (setq e3 (HY_PtName p03 0.0 0.0 0.1 app))
	  (setq hand3 (cdr (assoc 5 (entget e3))))
	)
      )
    )
  )
  (setq bb (liscut bb p03))

  (setq angb (ptang p03))
  (foreach pt bb
    (setq angt (angle p03 pt))
    (foreach ang angb
      (setq angc (abs (- angt ang)))
      (if (or (equal angc 0.0 1.0e-3)
	      (equal angc pi 1.0e-3)
	      (equal angc (* 2.0 pi) 1.0e-3)
	  )
	(progn
	  (setq p04 pt)
	  (setq e4 (HY_PtName p04 0.0 0.0 0.1 app))
	  (setq hand4 (cdr (assoc 5 (entget e4))))
	)
      )
    )
  )
  (setq bb (liscut bb p04))
  (setq p05 (car bb))
  (setq e5 (HY_PtName p05 0.0 0.0 0.1 app))
  (setq hand5 (cdr (assoc 5 (entget e5))))
					;----- 规则形状记录 -----------------  
  (if (and hand1 hand2 hand3 hand4 hand5 hand6)
    (progn
      (setq bb (list 6 hand1 hand2 hand3 hand4 hand5 hand6))
      (setq bb (list2s bb))

      (setq p00 (polar pt ang (* bc (cos (* 0.25 pi)))))
      (szdl_ins_sysblk "jsckd" p00 "1" "1" "0")
      (HY_KZSJXZ (entlast) "JSCK" 1000 bb)
      (HY_KZSJXZ (entlast) app 1000 "@")
    )
  )
)
;;------------------------------
;; 1996.09.03 tue
;; >=7 POINT分析 --- pt7cl(ss)
;; 简化为四边形
;;------------------------------
(defun pt7cl (pt    ang	  bc	ss   app /	    e1	  e1b	p01   hand1
	      e2    e2b	  p02	hand2 e3    e3b	  p03	hand3 e4
	      e4b   p04	  hand4	ss    bb    p00
	     )

  (setq	e1    (HY_PtName pt 0.0 0.0 0.1 app)
	e1b   (entget e1)
	p01   (cdr (assoc 10 e1b))
	hand1 (cdr (assoc 5 e1b))
  )
  (setq ss (ssdel e1 ss))

  (setq ii 0)
  (repeat (sslength ss)
    (setq e  (ssname ss ii)
	  eb (entget e)
	  p0 (cdr (assoc 10 eb))
	  bb (cons p0 bb)
    )
    (setq ii (1+ ii))
  )
					;----- (2) --------------------------------------  
  (foreach pt bb
    (if	(equal (car p01) (car pt) 1.0e-3)
      (progn
	(setq p02 pt)
	(setq e2 (HY_PtName p02 0.0 0.0 0.1 app))
	(setq hand2 (cdr (assoc 5 (entget e2))))
      )
    )
  )
  (setq bb (liscut bb p02))
					;----- (4) --------------------------------------  
  (foreach pt bb
    (if	(equal (cadr p01) (cadr pt) 1.0e-3)
      (progn
	(setq p04 pt)
	(setq e4 (HY_PtName p04 0.0 0.0 0.1 app))
	(setq hand4 (cdr (assoc 5 (entget e4))))
      )
    )
  )
  (setq bb (liscut bb p04))

					;(setq bb (mapcar '(lambda(x) (list (distance x p01) x)) bb))
					;(setq bb (ptbxpx bb))
  (setq bb (pt_d_px p01 bb))
  (setq bb (reverse bb))
  (setq bb (car bb))
  (setq p03 (nth 1 bb))
  (setq e3 (HY_PtName p03 0.0 0.0 0.1 app))
  (setq hand3 (cdr (assoc 5 (entget e3))))
					;----- 规则形状记录 -----------------  
  (if (and hand1 hand2 hand3 hand4)
    (progn
      (setq bb (list 4 hand1 hand2 hand3 hand4))
      (setq bb (list2s bb))

      (setq p00 (polar pt ang (* bc (cos (* 0.25 pi)))))
      (szdl_ins_sysblk "jsckd" p00 "1" "1" "0")
      (HY_KZSJXZ (entlast) "JSCK" 1000 bb)
      (HY_KZSJXZ (entlast) app 1000 "@")
    )
  )
)
;;-------------------------------------
;; 1996.08.30 fri
;; 判指定位置是否有标志 pdbz(pt ang dd)
;; pt  -- base point
;; ang -- angle 
;; dd  -- distance
;; return  => T/nil : yes/no
;;-------------------------------------
(defun pdbz (pt ang dd  app / p00 p01 p02 ss)

  (setq	p00 (polar pt ang dd)
	p01 (polar p00 (* 0.25 pi) 0.5)
	p02 (polar p00 (* 1.25 pi) 0.5)
  )
  (setq	ss (ssget "c"
		  p01
		  p02
		  (list	(cons 0 "INSERT")
			(cons 2 "JSCKD")
			(cons -4 "<and")
			(cons -4 ">=,>=,*")
			(cons 10 p02)
			(cons -4 "<=,<=,*")
			(cons 10 p01)
			(cons -4 "and>")
			(list -3 (list app))
		  )
	   )
  )
  (if ss
    t
    nil
  )
)
;;-------------------------------------
;; 1996.08.30 fri
;; 指定点所有LINE的angle ptang(pt)
;; pt  -- base point
;; return  => (ang1 ang2...)
;;-------------------------------------
(defun ptang (pt / layb p01 p02 ss ii e eb ang angb fhb)

  (setq layb "PP-TF-WG,PP-TF-BJ")
  (setq	p01 (polar pt (* 0.25 pi) 1.0e-1)
	p02 (polar pt (* 1.25 pi) 1.0e-1)
  )
  (setq ss (ssget "c" p01 p02 (list (cons 0 "*LINE") (cons 8 layb))))
  (setq ii 0)
  (repeat (sslength ss)
    (setq e  (ssname ss ii)
	  eb (entget e)
    )
    (if	(= (cdr (assoc 0 eb)) "LINE")
      (setq p01	(cdr (assoc 10 eb))
	    p02	(cdr (assoc 11 eb))
	    ang	(angle p01 p02)
      )
      (progn
	(setq fhb (getpkd e pt))
	(if (car fhb)
	  (setq ang (nth 5 fhb))
	)
      )
    )
    (if	(equal ang (* 2.0 pi) 1.0e-2)
      (setq ang 0.0)
    )
    (if	(or (member ang angb) (= ang nil))
      (princ)
      (setq angb (cons ang angb))
    )
    (setq ii (1+ ii))
  )
  angb
)
;;------------------------------
;; 取wgbl
;;------------------------------
(defun qqwgbl (bh / ss ii e h b wgbl)

  (setq ss (ssget "x" (list '(0 . "INSERT") '(-3 ("WGBH")))))
  (if ss
    (progn
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	 (ssname ss ii)
	      h	 (HY_QQ10xx e "WGBH" 1070)
	      b	 (HY_QQ10xx e "WGBH" 1040)
	      ii (1+ ii)
	)
	(if (= bh h)
	  (setq wgbl b)
	)
      )
    )
  )
  wgbl
)
;;------------------------------
;; cut ss's BJ Point
;;------------------------------
(defun sscut (ss  app / sst ii e)
  (setq	sst (ssadd)
	ii  0
  )
  (repeat (sslength ss)
    (setq e  (ssname ss ii)
	  ii (1+ ii)
    )
    (if	(= (HY_QQ10xx e app 1070) 1)
      (setq sst (ssadd e sst))
    )
  )
  sst
)
;;------------------------------
;; zoom w bh
;;------------------------------
(defun zoombh (bh0 / ss ii e bh ptb p1 p2 ll x y z)

  (setq ss (ssget "x" (list (cons 0 "INSERT") '(-3 ("WGBH")))))
  (setq ii 0)
  (repeat (sslength ss)
    (setq e  (ssname ss ii)
	  bh (HY_QQ10xx e "WGBH" 1070)
	  ii (1+ ii)
    )
    (if	(= bh bh0)
    	(progn
	      (setq ptb	(qxdata e "WGBH"))
		(setq     p1	(car ptb)
		    p2	(cadr ptb)
		)
		(setq x (* 1.0 (car p2))
			y (* 1.0 (cadr p2))
			z 0.0
		)
		(setq p2 (list x y z))

		(setq  ll (* 0.1 (HY_PtPMDist p1 p2)))
		(setq      p1	(polar p1 (angle p2 p1) ll)
		    p2	(polar p2 (angle p1 p2) ll)
	      )
	)
    )
  )
  (zm2pt p1 p2)
)
;;ren add 2003-7-14 13:33
;;-----------------------------------------
;;2002.11.08 fri add by wei
;;对特殊的3～6个角点的网格，逐点选取处理
;;app is a global variable
;;-----------------------------------------
(defun hand_CL(/ pt1 pt2 pt3 pt4 pt5 pt6 e1 e2 e3 e4 e5 e6 
                 hand1 hand2 hand3 hand4 hand5 hand6 ft pt bb fhz myapp myapp2)

  (setq ft 0)   ;;角点数
  (setq fhz nil)  ;;返回值，t 时循环进入
  
  (prompt "\n请按顺时针或逆时针方向顺序点取网格的角点(3～6个)")
  ;;
  (setq myapp (strcat app "*"))
  (setq pt1 (getpoint "\n第一点:"))
  (if pt1
    (setq	e1 (HY_PtName pt1 0.0 0.0 2.0 myapp))  
  )
  (if (= e1 nil) (alert "在第一点的位置没有找到网格角点!"))
  ;;
  (if e1
    (progn
      (setq myapp (caadr (assoc -3 (entget e1 (list myapp)))))
  
      (setq pt2 (getpoint "\n第二点:"))
      (if pt2
        (setq	e2 (HY_PtName pt2 0.0 0.0 2.0 myapp))
      )
      (if (= e2 nil) (alert "在第二点的位置没有找到网格角点!"))
  ))
  ;;
  (if e2
    (progn
      (setq pt3 (getpoint "\n第三点:"))
      (if pt3
        (setq	e3 (HY_PtName pt3 0.0 0.0 2.0 myapp))
      )
      (if (= e3 nil) 
        (alert "在第三点的位置没有找到网格角点!")
        (setq ft 3)
      )
  ))
  ;;
  (if e3
    (progn
      (setq pt4 (getpoint "\n回车结束 / 第四点:"))
      (if pt4
        (progn
          (setq	e4 (HY_PtName pt4 0.0 0.0 2.0 myapp))
          (if (= e4 nil) 
            (alert "在第四点的位置没有找到网格角点!")
            (setq ft 4)
          )
        )
      )
  ))
  ;;
  (if e4
    (progn
      (setq pt5 (getpoint "\n回车结束 / 第五点:"))
      (if pt5
        (progn
          (setq	e5 (HY_PtName pt5 0.0 0.0 2.0 myapp))
          (if (= e5 nil) 
            (alert "在第五点的位置没有找到网格角点!")
            (setq ft 5)
          )
        )
      )
  ))
  ;;
  (if e5
    (progn
      (setq pt6 (getpoint "\n回车结束 / 第六点:"))
      (if pt6
        (progn
          (setq	e6 (HY_PtName pt6 0.0 0.0 2.0 myapp))
          (if (= e6 nil) 
            (alert "在第六点的位置没有找到网格角点!")
            (setq ft 6)
          )
        )
      )
  ))
  ;;选点结束  
  (if (>= ft 3)
    (progn
      ;;取角点的handle
      (setq hand1 (cdr (assoc 5 (entget e1))))
      (setq hand2 (cdr (assoc 5 (entget e2))))
      (setq hand3 (cdr (assoc 5 (entget e3))))
      (cond
        ((= ft 3)
          (setq bb (list 3 hand1 hand2 hand3))
          (setq bb (list2s bb))
        )
        ((= ft 4)
          (setq hand4 (cdr (assoc 5 (entget e4))))
          (setq bb (list 4 hand1 hand2 hand3 hand4))
          (setq bb (list2s bb))
        )
        ((= ft 5)
          (setq hand4 (cdr (assoc 5 (entget e4))))
          (setq hand5 (cdr (assoc 5 (entget e5))))
          (setq bb (list 5 hand1 hand2 hand3 hand4 hand5))
          (setq bb (list2s bb))
        )
        ((= ft 6)
          (setq hand4 (cdr (assoc 5 (entget e4))))
          (setq hand5 (cdr (assoc 5 (entget e5))))
          (setq hand6 (cdr (assoc 5 (entget e6))))
          (setq bb (list 6 hand1 hand2 hand3 hand4 hand5 hand6))
          (setq bb (list2s bb))
        )
      )
      ;;
      (setq pt (getpoint "\n计算点位置(区域内中心附近即可):"))
      (if pt
        (progn
          (setvar "clayer" laypt)
          (szdl_ins_sysblk "jsckd" pt "1" "1" "0")
          (HY_kzsjxz (entlast) "JSCK" 1000 bb)
          (HY_kzsjxz (entlast) myapp 1000 "@")
          (setq fhz t)
      ))
  ))
  ;;
  fhz
)
;;;ren add 2003-7-14 16:19 ,判断角度an2在角度an1的顺时针方向还是逆时针方向
;;;返回  T ---  顺时针方向
;;;    nil ---  逆时针方向
(defun IsClockWise( an1 an2 / flag)
	(setq flag nil)
	(if (or (< (abs (rem (- an2 (+ (* pi 0.5) an1)) (* pi 2.0))) (* pi 0.5))
		(> (abs (rem (- an2 (+ (* pi 0.5) an1)) (* pi 2.0))) (* pi 1.5))
	    )
	   (setq flag t)
	)
	flag
)   

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;------------------------------
;;; 1998.01.11 wed
;;; modi 1998.07.06
;;; 标高定义
;;; color :
;;; 只有ZRBG --- Yellow(2)
;;; 只有SJBG --- Blue  (5)
;;; 都    有 --- Red   (1)
;;;------------------------------
(defun t_bgdy (/ dcl_id	what dydx dyfs xpd ypd ckdbg laypt layzr laysj
	       rd laydxpt)

  (HY_SV)
  (DL_ArxLoad "Earthwork")
  (HY_UndoM)
;;  (if (equal (getvar "pdsize") 0.0 0.2)
;;    (progn
;;      (setvar "pdsize" 3.0)
;;      (setvar "pdmode" 35)
;;    )
;;  )
  (setq rd 3.5)				;*** 标志半径 ***

  (setq	laypt	"PP-TF-PT"
	layzr	"PP-DX-DGXZ"
	laysj	"PP-DX-DGXS"
	laydxpt	"PP-DX-PT,PP-SJ-PT"
  )

  (setq	dydx "zr"
	dyfs "czdy"
	xpd  "0.0"
	ypd  "0.0"
	spac ""
  )
  (setq dcl_id (szdl_load_dlg "@bgdy.dcl"))
  (setq what 4)
  (while (> what 1)
    (if	(not (new_dialog "bgdy" dcl_id))
      (exit)
    )

    (set_tile "dydx" dydx)
    (set_tile "dyfs" dyfs)
    (set_tile "xpd" xpd)
    (set_tile "ypd" ypd)

    (if	(/= dyfs "ckd")
;;;modi 1998.07.06
      (mode_tile "tsyj" 1)
    )
;;;					;-------------------
;;;					;---   \"  <--->  "
;;;					;-------------------
    (action_tile "zr" "(setq dydx (get_tile \"dydx\"))")
    (action_tile "sj" "(setq dydx (get_tile \"dydx\"))")

    (action_tile
      "dgx"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 1) (set_tile \"err\" spac))"
    )
    (action_tile
      "lsd"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 1) (set_tile \"err\" spac))"
    )
    (action_tile
      "ckd"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 0))"
    )
    (action_tile
      "czdy"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 1) (set_tile \"err\" spac))"
    )
    (action_tile
      "zddy"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 1) (set_tile \"err\" spac))"
    )
    (action_tile
      "lddy"
      "(progn (setq dyfs (get_tile \"dyfs\")) (mode_tile \"tsyj\" 1) (set_tile \"err\" spac))"
    )

    (action_tile "ckdbg" "(setq ckdbg (get_tile $key))")
    (action_tile "xpd" "(setq xpd   (get_tile $key))")
    (action_tile "ypd" "(setq ypd   (get_tile $key))")

    (action_tile "sm" "(sm)")

    (action_tile "accept" "(done_dialog 3)")
;;;modi 1998.07.04
    (action_tile "cancel" "(done_dialog 0)")
    (action_tile "ptsize" "(done_dialog 2)")

    (setq what (start_dialog))
    (if	(= what 3)

      (if (= dyfs "lddy")
	(bgdy3 dydx)
	(bgdy2 dydx dyfs ckdbg xpd ypd)
      )
    )
    (if	(= what 2)
      (ptsize)
    )
  )
  (HY_RV)
)
;;-------------------------------------
;; 1996.09.14 sat
;; 网格点标高定义
;; dydx = "zr"/"sj" 自然标高/设计标高
;; dyfs = "dgx"/"ckd"/"czdy"/"zddy"/"lddy"
;; ckdbg/xpd/ypd = "xxx.xx"  string
;;-------------------------------------
(defun bgdy2 (dydx  dyfs  ckdbg	xpd   ypd   /	  cc	ss    ii
	      e	    bg2	  ss1	ft    app   bg00  p000	e     eb
	      pt    bg1	  ptb	bg0   et1   et2	  ssdgx	defbg w_triangle
	     )
	     
(defun bgdy2_error (ccc / )
 (DL_Destory_TRiAngle w_triangle)
)

  (if (= dydx "zr")
    (setq cc	 "\n自然标高(m):"
	  laydgx layzr
    )
    (setq cc	 "\n设计标高(m):"
	  laydgx laysj
    )
  )

  (setq fftt t)
  (while fftt
;;;modi 1998.07.06 11:31 99-3-5WBG
    (if	(= dyfs "ckd")
      (progn
	(setq p000 (getpoint "\n输入参考点:"))
	(if (and p000 (listp p000))
	  (if
	    (setq ss (ssget "x" (list '(0 . "point") (cons 8 laypt))))
	     (progn
	     	(pusherr bgdy2_error)
	     	(setq w_triangle (DL_InitTriangle (strcat (strcase dydx) "BG")  laypt))
	     	(setq defbg (GetPtBg_Triangle w_triangle p000))
	     	(if (null defbg)
	     	    (setq defbg (p_ptbg p000
				   (strcat (strcase dydx) "BG")
				   laypt
			   )
	            )
	        )
	        (DL_Destory_TRiAngle w_triangle)
                (clr_err)
                
	       (if (numberp defbg)
		 (progn
		   (setq bg00 (getreal (strcat "\n输入参考点标高<"
					       (rtos defbg 2 2)
					       ">:"
				       )
			      )
		   )
		   (if (null bg00)
		     (setq bg00 defbg)
		   )
		 )
		 (progn
		   (initget 1)
		   (setq bg00 (getreal "\n输入参考点标高:"))
		 )

	       )
	     )
	  )
	)
      )
      (progn
	(prompt "\n选点:<回车退出>")
	(setq ss (ssget (list (cons 0 "POINT") (cons 8 laypt))))
      )
    )
    (if	(or (/= ss nil) bg00)
      (progn
	(setq fftt nil)			;*** only when "czdy"/"zddy" is T
	(cond
					;----- (4) 成组定义 ----------------------------------------
	  ((= dyfs "czdy")
	   (setq fftt t)
	   (initget 1)
	   (setq bg2 (getreal cc))
	   (setq ii 0)
	   (repeat (sslength ss)
	     (setq e  (ssname ss ii)
		   ii (1+ ii)
	     )
	     (modibg dydx e bg2)
	   )
	  )
					;----- (2) 参考点推算 --------------------------------------
	  ((= dyfs "ckd")
	   (setq			;bg00 (atof ckdbg)
	     xpd (/ (atof xpd) 1000.0)
	     ypd (/ (atof ypd) 1000.0)
	   )
	   (prompt "\n选点:<回车退出>")
	   (setq ss (ssget (list (cons 0 "POINT") (cons 8 laypt))))
	   (if ss
	     (progn
					;(setq ss (ssadd e ss) ii 0)
	       (setq ii 0)
	       (repeat (sslength ss)
		 (setq e  (ssname ss ii)
		       ii (1+ ii)
		       eb (entget e)
		       pt (cdr (assoc 10 eb))
		 )
		 (setq bg1 (+ bg00 (* (- (car pt) (car p000)) xpd)))
		 (setq bg1 (+ bg1 (* (- (cadr pt) (cadr p000)) ypd)))
		 (modibg dydx e bg1)
	       )
	     )
	     (progn
	       (prompt "\n没选到标高点, 返回。")
	       (setq fftt nil)
	     )
	   )
	  )
					;----- (4) 逐点定义   --------------------------------------
	  ((= dyfs "zddy")
	   (setq fftt t
		 ptb nil
	   )
	   (setq ii 0)
	   (repeat (sslength ss)
	     (setq e   (ssname ss ii)
		   ii  (1+ ii)
		   eb  (entget e)
		   pt  (cdr (assoc 10 eb))
		   ptb (cons pt ptb)
	     )
	   )
	   (setq ptb (ptbxpx ptb)
		 ptb (ptbypx ptb)
	   )
	   (foreach pt ptb
	     (pan2v pt)			;*** view 判断 ***
	     (setq e (HY_PtName pt 0.0 0.0 1.0))
	     (command "circle" pt rd)
	     (setq et1 (entlast))
	     (command ".line" pt (polar pt 3.6 rd) "")
	     (setq et2 (entlast))
	     (command "change" et1 et2 "" "p" "c" "4" "")

	     (if (= dydx "sj")
					;----- 设计标高 -----------------------------------------
	       (progn
		 (if (setq bg0 (q1040 e "SJBG"))
		   (progn
		     (setq bg2 (getreal (strcat cc "<" (rtos bg0) ">")))
		     (if (= bg2 nil)
		       (setq bg bg0)
		       (setq bg bg2)
		     )
		   )
		   (progn
		     (if (= bg nil)
		       (setq bg 0.0)
		     )
		     (setq bg2 (getreal (strcat cc "<" (rtos bg) ">")))
		     (if (= bg2 nil)
		       (setq bg bg)
		       (setq bg bg2)
		     )
		   )
		 )
		 (HY_KZSJXZ e "SJBG" 1040 bg)
		 (if (q1040 e "ZRBG")
		   (command "change" e "" "p" "c" "1" "")
		   (command "change" e "" "p" "c" "5" "")
		 )
	       )
					;----- 自然标高 -------------------------------------------
	       (progn
		 (setq bg1 (caddr pt))
		 (setq bg2 (getreal (strcat cc "<" (rtos bg1) ">")))
		 (if (= bg2 nil)
		   (setq bg2 bg1)
		 )
		 (HY_KZSJXZ e "ZRBG" 1040 bg2)
		 (if (q1040 e "SJBG")
		   (command "change" e "" "p" "e" bg2 "c" "1" "")
		   (command "change" e "" "p" "e" bg2 "c" "2" "")
		 )
	       )
	     )
	     (command "erase" et1 et2 "")
	   )
	  )
					;----- (1) 由等高线推算标高 ---------------------------
	  ((= dyfs "dgx")
	   (setq
	     ssdgx (ssget "x"
			  (list (cons 0 "*POLYLINE") (cons 8 laydgx))
		   )
	   )
	   (if (= ssdgx nil)
	     (prompt "\n还没有定义等高线!")
	     (progn
	       (p_bgdy ss laydgx dydx)
	     )
	   )
	  )
					;----- (2) 由离散点推算标高 ---------------------------
	  ((= dyfs "lsd")
	   (setq ssdgx
		  (ssget "x" (list (cons 0 "POINT") (cons 8 laydxpt)))
	   )
	   (if (= ssdgx nil)
	     (prompt "\n还没有定义标高离散点!")
	     (progn
	       (setq app (strcase (strcat dydx "BG")))
	       (pusherr bgdy2_error)
	       (setq w_triangle (DL_InitTriangle app laydxpt))
	       (prompt "\n正在计算, 请稍后...")
	       (setq ii 0)
	       (repeat (sslength ss)
		 (HY_Waiting)
		 (princ)
;;;10:03 99-2-2add (princ)
		 (setq e   (ssname ss ii)
		       p00 (cdr (assoc 10 (entget e)))
		 )
		 (setq bg0 (GetPtBg_Triangle w_triangle p00))
		 (if (null bg0) (setq bg0 (p_ptbg p00 app laydxpt)))
		 (modibg dydx e bg0)
		 (setq ii (1+ ii))
	       )
	       (DL_Destory_TRiAngle w_triangle)
	       (clr_err)
	     )
	     
	   )
	  )

	)
      )
      (progn
	(prompt "\n没选到标高点, 返回。")
	(setq fftt nil)
      )
    )

  )					;*** end of
)
;;-------------------------------
;; 1996.09.25 wed
;; 1998.03.04 wed 内外插值
;; 由两点推算标高 bgdy3(dydx)
;;-------------------------------
(defun bgdy3 (dydx  /	  cc	app   ft    fftt  e1	e2    ee
	      e0    p01	  p02	p00   pd    bg01  bg02	bg11  bg22
	      bg0   osold ss  kk
	     )

  ;;;;(setq osold (getvar "osmode"))
  (sa_osmode)
  (setvar "osmode" 8)
  (if (= dydx "zr")
    (setq cc  "\n黄色标志点自然标高(m):"
	  app "ZRBG"
    )
    (setq cc  "\n黄色标志点设计标高(m):"
	  app "SJBG"
    )
  )

  (setq ft t)
  (while ft
    (setq p01 (getpoint "\n回车退出 / <控制标高第一点>:"))
    (if	(= p01 nil)
      (setq ft nil)
      (progn
	(setq e1 (HY_PtName p01 0.0 0.0 1.0))
	(if e1
	  (progn
	    (setq p01 (cdr (assoc 10 (entget e1))))
	    (if	(setq bg01 (HY_QQ10xx e1 app 1040))
	      (princ)
	      (setq bg01 0.0)
	    )
	  )
	  (setq bg01 0.0)
	)
	(command "circle" p01 rd)
	(setq ee (entlast))
	(command "change" ee "" "p" "c" "yellow" "")

	(setq bg11 (getreal (strcat "\n" cc "<" (rtos bg01) ">:")))
	(if (= bg11 nil)
	  (setq bg11 bg01)
	)
	(if e1
	  (modibg dydx e1 bg11)
	)
	(entdel ee)

	(initget 1)
	(setq p02 (getpoint "\控制标高第二点>:"))

	(setq e2 (HY_PtName p02 0.0 0.0 1.0))
	(if e2
	  (progn
	    (setq p02 (cdr (assoc 10 (entget e2))))
	    (if	(setq bg02 (HY_QQ10xx e2 app 1040))
	      (princ)
	      (setq bg02 0.0)
	    )
	  )
	  (setq bg02 0.0)
	)
	(command "circle" p02 rd)
	(setq ee (entlast))
	(command "change" ee "" "p" "c" "yellow" "")

	(setq bg22 (getreal (strcat "\n" cc "<" (rtos bg02) ">:")))
	(if (= bg22 nil)
	  (setq bg22 bg02)
	)
	(if e2
	  (modibg dydx e2 bg22)
	)
	(entdel ee)

	(setq pd  (/ (- bg22 bg11) (HY_PtPMDist p01 p02))
	      ang (angle p01 p02)
	)
	(setq ss (ssget "f" (list p01 p02) (list (cons 0 "POINT") (cons 8 "PP-TF-PT"))))
	(if (and ss (> (sslength ss) 2))
	        (progn
		   (initget "D")
		   (setq kk (getint "\n点取计算插值点 D / <回车 自动内插计算角点>:"))
		)
		(setq kk "D")
	 ;;;   )
        )
	(if (= kk "D")
	    (progn
	    	(setq fftt t)
		(while fftt
		  (setq p00 (getpoint "\n回车返回 / <插值点>:"))
		  (if (= p00 nil)
		    (setq fftt nil)
		    (progn
		      (&vec_cir p00 rd 6 2 nil)
		      (setq pt (HY_LinePMInt p01
				       p02
				       p00
				       (polar p00 (+ ang (* 0.5 pi)) 10.0)
				       nil
			       )
		      )
		      (setq bg0 (+ bg11 (* pd (HY_PtPMDist pt p01))))
		      (prompt (strcat "\n标高值: " (rtos bg0 2 3)))
		      (if (setq e0 (HY_PtName p00 0.0 0.0 0.5))
			(modibg dydx e0 bg0)
		      )
		    )
		  )
		)
	     )
	     (progn
     	      (prompt "\n自动内插计算两点间的网格角点的标高....")
     	      (ssdel e1 ss)
              (ssdel e2 ss)
              (while (> (sslength ss) 0)
                 (setq e0 (ssname ss 0))
                 (setq pt (cdr (assoc 10 (entget e0))))
                 (&vec_cir pt rd 6 2 nil)
                 (setq bg0 (+ bg11 (* pd (HY_PtPMDist pt p01))))
                 (modibg dydx e0 bg0)
                 (ssdel e0 ss)
              )
	     );;;;progn
	 );;(if (= kk "D"))

      )
    )
  )
  (re_osmode)
   (princ)
)
;;;-----------------------------
;;; 1996.08.22 thu
;;; POINT SIZE
;;; pdsize 负值为相对值!
;;;-----------------------------
(defun ptsize (/ pd dd)

  (setq	pd (getreal
	     (strcat "\n点显示大小<" (rtos (setq dd (getvar "pdsize"))) ">:")
	   )
  )
  (if (null pd) (setq pd dd))
      (setvar "pdsize" (+ (abs pd) 1.0e-5))
  
  (if (/= (getvar "pdmode") 35) (setvar "pdmode" 35))
  (prompt "\n白色点标高没有定义; 黄色点仅有自然标高;")
  (prompt "\n蓝色点仅有设计标高; 红色点的标高已全部定义。")
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;------------------------------------------
;;; 1998.01.12 thu
;;; 土方计算
;;; from ZRBG/SJBG ==> 土方量
;;; yhflag ----- 优化控制方式
;;; yh_number -- 初步优化/控制调整
;;;------------------------------------------
(defun t_tfjsa (/ dcl_id what laypt lay0 app kk yh_number lj)

  (HY_SV)
  (HY_UndoM)
  (setq	laypt "PP-TF-PT"
	lay0 "PP-TF-0L"
	yh_number 1
  )
  (DL_MakeLayer lay0)
  (DL_ArxLoad "Earthwork")

  (if (not (setq bhlist (qwgbhb)))
    (progn
      (beep)
      (prompt "\n还没有划分土方网格, 退出.")
      (exit)
    )
  )
  (if (= tfyh~xh nil)
    (setq tfyh~xh "0")
  )
  (if (= tfyh~bh nil)
    (setq tfyh~bh (nth (atoi tfyh~xh) bhlist))
  )
  (setq app (strcat "A" tfyh~bh))
  (init_var)				;*** init. global varibale

  (setq dcl_id (szdl_load_dlg "@t_tfjs.dcl"))
  (setq what 4)
  (while (> what 1)
    (if	(not (new_dialog "t_tfjs" dcl_id))
      (exit)
    )
    (set_t0)
    (act_t0)

    (action_tile "bgtz" "(done_dialog 4)") ;***
    (action_tile "tfjs" "(nbrc)")	;***(done_dialog 2)
    (action_tile "accept" "(done_dialog 3)") ;***(done_dialog 3)
    (action_tile "cancel" "(done_dialog 0)")
    (action_tile "sm" "(sm)")

    (setq what (start_dialog))
    (cond
      ((= what 4) (bgtz_) (setq lj (+ lj tfyh~bgc)))
      ((= what 2) (tfjs_))
      ((= what 3)
       (initget "Y N")
       (setq kk
	      (getkword
		"\n该命令将根据优化结果定义本区域内各点的设计标高, 是否确认(Y/N)?<Y>"
	      )
       )
       (if (/= kk "N")
	 (progn
	   (HY_UndoM)
	   (prompt "\n请稍侯...")
	   (modibg1 app)		;*** modify bg.
	   (prompt "\n可用Undo/Back命令取消上次操作.")
	 )
       )
      )
    )
  )
  (unload_dialog dcl_id)
  (arxunload "Earthwork")
  (prompt "\n可用Undo/Back命令取消上次操作.")
  (HY_RV)
)
;;------------------------------
;; 初始化global variable
;;------------------------------
(defun init_var	()

  (if (= tfyh~bh nil)
    (setq tfyh~bh "0")
  )
  (if (= tfyh~xh nil)
    (setq tfyh~xh "0")
  )

  (if (= tfyh~sxxs nil)
    (setq tfyh~sxxs 1.0)
  )
  (if (= tfyh~ysxs nil)
    (setq tfyh~ysxs 1.0)
  )
  (if (= tfyh~ywqt nil)
    (setq tfyh~ywqt 0.0)
  )
  (if (= tfyh~qt nil)
    (setq tfyh~qt 0.0)
  )
  (if (= tfyh~bgc nil)
    (setq tfyh~bgc 0.0)
  )

  (if (= tfyh~vvww nil)
    (setq tfyh~vvww 0.0)
  )
  (if (= tfyh~vvtt nil)
    (setq tfyh~vvtt 0.0)
  )
  (if (= tfyh~phxs nil)
    (setq tfyh~phxs 0.0)
  )
  (setq lj 0.0)
)
;;------------------------------
(defun set_t0 ()

  (start_list "bh")
  (mapcar 'add_list bhlist)
  (end_list)
  (set_tile "bh" tfyh~xh)

  (set_tile "sxxs" (rtos tfyh~sxxs))
  (set_tile "ysxs" (rtos tfyh~ysxs))
  (set_tile "ywqt" (rtos tfyh~ywqt))
  (set_tile "qt" (rtos tfyh~qt))
  (set_tile "bgc" (rtos tfyh~bgc))
  (set_tile "lj" (strcat "增量累计(m): " (rtos lj 2 3)))

  (if tfyh~vvww
    (set_tile "wf" (rtos tfyh~vvww))
  )
  (if tfyh~vvtt
    (set_tile "tf" (rtos tfyh~vvtt))
  )

  (if (equal (+ tfyh~vvtt tfyh~vvww) 0.0 1)
    (setq tfyh~phxs 0.0)
    (setq tfyh~phxs
	   (abs
	     (/	(* 100
		   (- (+ tfyh~vvtt tfyh~qt) (+ tfyh~vvww tfyh~ywqt))
		)
		(+ tfyh~vvtt tfyh~vvww tfyh~ywqt tfyh~qt)
	     )
	   )
    )
  )
  (set_tile "phxs" (rtos tfyh~phxs))
)
;;------------------------------
(defun act_t0 ()

  (action_tile "bh" "(xbh_)")
  (action_tile
    "sxxs"
    "(setq tfyh~sxxs (atof (get_tile $key)))"
  )
  (action_tile
    "ysxs"
    "(setq tfyh~ysxs (atof (get_tile $key)))"
  )
  (action_tile
    "ywqt"
    "(setq tfyh~ywqt (atof (get_tile $key)))"
  )
  (action_tile "qt" "(setq tfyh~qt   (atof (get_tile $key)))")
  (action_tile
    "bgc"
    "(setq tfyh~bgc  (atof (get_tile $key)))"
  )
)
;;------------------------------
(defun xbh_ ()
  (setq	tfyh~xh	(get_tile $key)
	tfyh~bh	(nth (atoi tfyh~xh) bhlist)
	app	(strcat "A" tfyh~bh)
  )
  (set_t0)
)
;;------------------------------
(defun nbrc ()

  (cond
    ((or (< tfyh~sxxs 1.0) (>= tfyh~sxxs 1.5))
     (beep)
     (set_tile "error" "松散系数不合适(1.0～1.5).")
    )
    ((or (< tfyh~ysxs 0.5) (> tfyh~ysxs 1.0))
     (beep)
     (set_tile "error" "压实系数不合适(0.5～1.0).")
    )
    (t (done_dialog 2))			;***
  )
)
;;------------------------------
;; 优化计算
;;------------------------------
(defun tfjs_ ()
  (zoombh (atoi tfyh~bh))
  (setq app (strcat "A" tfyh~bh))
  (p_tfjs app "SJBG")
)
;;------------------------------
;; 取网格编号LIST
;; 为能计算子区域土方而修改2004-3-19 22:22，任蔚青
;; return ==>("1" "2" ...)/nil
;;------------------------------
(defun qwgbhb (/ ss ii e bh fhb subBH)

  (setq ss (ssget "x" (list (cons 0 "INSERT") '(-3 ("WGBH")))))
  (if ss
    (progn
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	 (ssname ss ii)
	      bh (HY_QQ10xx e "WGBH" 1070)
	      ii (1+ ii)
	)
	(setq subBH (HY_QQ10xx e "SUB" 1070))
	(if (or (null (HY_QQ10xx e "WGBH" 1010)) (null (HY_QQ10xx e "WGBH" 1040)) (member bh fhb)) 
	  (princ)
	  (if subBH (setq fhb (cons (strcat (itoa bh) "-" (itoa subBH)) fhb))
	            (setq fhb (cons (itoa bh) fhb))
	  )
	            
	 ;;; (setq fhb (cons bh fhb))
	)
      )
      ;;;(setq fhb (mapcar 'itoa fhb))
    )
  )
  fhb
)
;;------------------------------
;; 调整标高
;;------------------------------
(defun bgtz_ (/ ss e ii bg0)

  (setq	ss
	 (ssget	"x"
		(list '(0 . "POINT") (list -3 (list app)) '(-3 ("SJBG")))
	 )
  )
  (if ss
    (progn
      (prompt "\n请稍侯...")
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	  (ssname ss ii)
	      bg0 (HY_QQ10xx e "SJBG" 1040)
	      bg0 (+ bg0 tfyh~bgc)
	)
	(HY_KZSJXZ e "SJBG" 1040 bg0)
	(setq ii (1+ ii))
      )
    )
    (prompt
      (strcat "\n" app "区域内的网格点还没有定义设计标高.")
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;------------------------------
;;; 1996.09.14 sat
;;; 土方图面清除 --- tftmqc.lsp
;;;------------------------------
(defun tftmqc (/ dcl_id what bgbz 3dqm tflx tfbz bgpt tfdgx jsbz wxbh)

  (HY_Set0)
  (setq dcl_id (szdl_load_dlg "@tftmqc.dcl"))
  (if (not (new_dialog "tftmqc" dcl_id))
    (exit)
  )

  (action_tile "bgbz" "(setq bgbz (get_tile $key))")
  (action_tile "3dqm" "(setq 3dqm (get_tile $key))")
  (action_tile "tflx" "(setq tflx (get_tile $key))")
  (action_tile "tfbz" "(setq tfbz (get_tile $key))")
  (action_tile "bgpt" "(setq bgpt (get_tile $key))")
  (action_tile "tfdgx" "(setq tfdgx (get_tile $key))")
  (action_tile "jsbz" "(setq jsbz (get_tile $key))")
  (action_tile "wxbh" "(setq wxbh (get_tile $key))")

  (action_tile "sm" "(sm)")
  (action_tile "accept" "(done_dialog 1)")
  (action_tile "cancel" "(done_dialog 0)")

  (setq what (start_dialog))
  (unload_dialog dcl_id)

  (if (= what 1)
    (progn
      (initget "Y N")
      (setq kk (getkword "\n确认清除? (Y/N) :<N>"))
      (if (= kk "Y")
	(tmqc bgbz 3dqm tflx tfbz bgpt tfdgx jsbz wxbh)
      )
    )
  )
  (HY_Set1)
  (princ)
)
;;------------------------------
;; 图面清除 --- tmqc.lsp
;;------------------------------
(defun tmqc (bgbz 3dqm tflx tfbz bgpt tfdgx jsbz wxbh)

  (HY_UndoM)
  (if (= bgbz "1")
    (qcbgbz)
  )
  (if (= 3dqm "1")
    (qc3dqm)
  )
  (if (= tflx "1")
    (qctflx)
  )
  (if (= tfbz "1")
    (qctfbz)
  )
  (if (= bgpt "1")
    (qcbgpt)
  )
  (if (= tfdgx "1")
    (qcdgxa)
  )
  (if (= jsbz "1")
    (qcjsbz)
  )
  (if (= wxbh "1")
    (qcwxbh)
  )
)
;;------------------------------
;; 清除标高标注
;;------------------------------
(defun qcbgbz (/ lay ss)

  (setq lay "PP-TF-BGBZ")
  (setq ss (ssget "x" (list (cons 0 "TEXT") (cons 8 lay))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;-----------------------------
;;; 清除标高定义点
;;;-----------------------------
(defun qcbgpt (/ ss kk cc laypt)

  (setq kk "Y")
  (if (= kk "Y")
    (progn
      (setq laypt "PP-TF-PT")
      (setq ss (ssget "x"
		      (list (cons -4 "<or")

			    (cons -4 "<and")
			    (cons 0 "INSERT")
			    (cons 2 "CKD")
			    (cons -4 "and>")
			    (cons -4 "<and")
			    (cons 0 "POINT")
			    (cons 8 laypt)
			    (cons -4 "and>")

			    (cons -4 "or>")
		      )
	       )
      )
      (if ss
	(progn
	  (command "erase" ss "")
	  (command "redraw")
	)
      )
    )
  )
)
;;;-----------------------------
;;; 清除计算参考标志 qcjsck
;;;-----------------------------
(defun qcjsbz (/ ss kk cc)

  (setq kk "Y")
  (if (= kk "Y")
    (progn
      (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "JSCKD"))))
      (if ss
	(progn
	  (command "erase" ss "")
	  (command "redraw")
	)
      )
    )
  )
)
;;;-----------------------------
;;; 清除土方计算结果 qcjsjg
;;;-----------------------------
(defun qctfbz (/ laytf ss)

  (setq laytf "PP-TF-TFBZ")
  (setq ss (ssget "x" (list (cons 0 "LINE,TEXT") (cons 8 laytf))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;-----------------------------
;;; 清除土方零线 qctflx
;;;-----------------------------
(defun qctflx (/ lay0 ss)

  (setq lay0 "PP-TF-0L")
  (setq ss (ssget "x" (list (cons 0 "LINE") (cons 8 lay0))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;------------------------------
;;; 清除3D面 qc3dqm
;;;------------------------------
(defun qc3dqm (/ lay ss)

  (setq lay "PP-TF-3DZR,PP-TF-3DSJ")
  (setq ss (ssget "x" (list (cons 0 "POLYLINE") (cons 8 lay))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;-----------------------------
;;; 清除所有土方等高线 qcdgxa
;;;-----------------------------
(defun qcdgxa (/ lay ss)

  (setq lay "PP-DX-DGXS,PP-DX-DGXZ")
  (setq ss (ssget "x" (list (cons 0 "*POLYLINE,TEXT") (cons 8 lay))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;-----------------------------
;;; 清除土方网线编号 qcwxbh
;;;-----------------------------
(defun qcwxbh (/ lay ss)

  (setq lay "PP-TF-WXBH")
  (setq ss (ssget "x" (list (cons 0 "LINE,TEXT,CIRCLE") (cons 8 lay))))
  (if ss
    (progn
      (command "erase" ss "")
      (command "redraw")
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------
;;; 1996.12.10 tue
;;; 土方网线编号  tfwxbh.lsp
;;;-----------------------------
(defun t_wxbh (/     lay   hh	 sca   ss    ii	   e	 eb    p00
	       wgbl  ptb   pmin	 pmax  laypt ft	   p000	 dd1   dd2
	       dd1f  dd2f  p01	 p02   ptmp  yyb   ll	 jj
	      )
  (HY_SV)
  (HY_UndoM)
  (setq lay "PP-TF-WXBH")
  (setq laypt "PP-TF-PT")
  (DL_MakeLayer lay)
  (#ppls "@T_BPJS")
   ;;(szload qqwgin "@T_BPJS")
  (setq hh (/ (Dl_GetTextHeight) (DL_GetDrawingFactor)))	;*** text high
  (setq	yyb '("A"   "B"	  "C"	"D"   "E"   "F"	  "G"	"H"   "J"
	      "K"   "L"	  "M"	"N"   "P"   "Q"	  "R"	"S"   "T"
	      "U"   "V"	  "W"	"X"   "Y"
	     )
  )					;***** no "i" "o" "z" *****
  (setq ll (length yyb))

  (initget 6)
  (setq bh (getint "\n输入区域编号<1>:"))
  (if (= bh nil)
    (setq bh 1)
  )
  (setq app (strcat "A" (itoa bh)))

  (if (or (not (setq fhb (qqwgin bh))) (null (nth 0 fhb)) (null (nth 2 fhb)))
    (prompt "\n该编号区域没有定义或没有土方网格。")
    (progn
      (zoomex)
      (setq wgbl (nth 0 fhb)
				    p00	 (nth 2 fhb)
				    pmin (nth 3 fhb)
				    pmax (nth 4 fhb)
	    )
      (if (= wgbl 0.0)
       (prompt "\n自定义网格线不能进行网格线编号。")
	   (progn

					;;;;----- p000 编号原点 -------------------
      (setq p000 (list (car pmin) (cadr pmax))) ;*** left_up point
      (setq dd1 (- (car p000) (car p00)))
      (setq dd2 (- (cadr p000) (cadr p00)))

      (setq dd1f (fix (/ dd1 wgbl))
				    dd2f (fix (/ dd2 wgbl))
				    p01	 (polar p00 0.0 (* dd1f wgbl))
				    p02	 (polar p00 (* 0.5 pi) (* dd2f wgbl))
      )
      (setq p000 (list (car p01) (cadr p02)))
      (if (<= (car p000) (car p00))
	(setq p000 (polar p000 pi wgbl))
      )
      (if (>= (cadr p000) (cadr p00))
	(setq p000 (polar p000 (* 0.5 pi) wgbl))
      )
					;----- 写水平方向编号 -------------------------
      (setq ii 1)
					;(setq ptmp (polar p000 (* 0.5 pi) wgbl))
      (setq ptmp p000)
      (while (< (car ptmp) (car (polar pmax 0.0 wgbl)))
	(wrxx ptmp ii)
	(setq ptmp (polar ptmp 0.0 wgbl))
	(setq ii (1+ ii))
      )
					;----- 写 Y 方向编号 -------------------------
      (setq ii 0)
      (setq jj 0)
					;(setq ptmp (polar p000 pi wgbl))
      (setq ptmp p000)
      (while (> (cadr ptmp) (cadr (polar pmin (* 1.5 pi) wgbl)))
	(wryy ptmp ii jj yyb)
	(setq ptmp (polar ptmp (* 1.5 pi) wgbl))
	(setq ii (1+ ii))
	(setq jj (fix (/ ii (float ll))))
      )
      (prompt "\n可用Undo/Back命令取消上次操作.")
	  );;progn
	 );;;if 
    )
  )
  (HY_RV)
)
;;------------------------------
;; 1996.12.10 tue
;; 写水平方向编号 (wrxx pt ii)
;;------------------------------ 
(defun wrxx (pt ii / rr aa p01 p02)

  (setq	rr (* 1.2 hh)
	aa wgbl
  )
  (setq	p01 (polar pt (* 0.5 pi) aa)
	p02 (polar p01 (* 0.5 pi) rr)
  )
  (command "line" pt p01 "")
  (command "circle" p02 rr)
  (command "text" "j" "mc" p02 hh 0.0 (itoa ii))
  (princ)
)
;;------------------------------------
;; 1996.12.10 tue
;; 写Y方向编号 (wryy pt ii jj yyb)
;;------------------------------------
(defun wryy (pt ii jj yyb / rr aa p01 p02 nn cc)

  (setq	rr (* 1.2 hh)
	aa wgbl
  )
  (setq	p01 (polar pt pi aa)
	p02 (polar p01 pi rr)
  )
  (command "line" pt p01 "")
  (command "circle" p02 rr)
  (setq nn (- ii (* jj ll)))
  (setq cc (nth nn yyb))
  (if (/= jj 0)
    (setq cc (strcat cc (itoa jj)))
  )

  (command "text" "j" "mc" p02 hh 0.0 cc)

  (princ)
)
;;------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;-----------------------------
;;; 1996.08.30 fri
;;; 土方网格3D面  tfwg3d.lsp
;;;-----------------------------
(defun t_3dwg (/ layzr laysj laypt ss ii e exb lx fdbl)

  (HY_SV)
  (HY_UndoM)
  (setq	laypt "PP-TF-PT"
	layzr "PP-TF-3DZR"
	laysj "PP-TF-3DSJ"
  )
;;;  (mk_lay (strcat layzr "," laysj))
  (mk_lay laypt)
  (mk_lay layzr)
  (mk_lay laysj)

  (setq fdbl (getreal "\n为便于观察, 输入高度放大系数:<10.0>"))
  (if (= fdbl nil)
    (setq fdbl 10.0)
  )

  (setq	ss (ssget "x"
		  (list	(cons 0 "INSERT")
			(cons 2 "JSCKD")
			(cons 8 laypt)
			(list -3 '("JSCK"))
		  )
	   )
  )
  (if ss
    (progn
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	  (ssname ss ii)
	      exb (qxdata e "JSCK")
	      lx  (car exb)
	)
	(3dmm lx exb)
	(setq ii (1+ ii))
      )
      (prompt "\n可用Undo/Back命令取消上次操作.")
    )
    (alert
      "\n土方网格处理后才能生成自然标高、设计标高的三维曲面!"
    )
  )
  (HY_RV)
  (princ)
)
;;----------------------------------
;; 1996.08.30 fri
;; n POINT face
;;----------------------------------
(defun 3dmm (num exb / hb entb bgb ptb ii numb pt ptbz)

  (setq hb (cdr exb))
  (setq entb (mapcar 'handent hb))
  (setq bgb (mapcar '(lambda (x) (q1040 x "SJBG")) entb))
  (setq	ptb  (mapcar '(lambda (x) (cdr (assoc 10 (entget x)))) entb)
	ptbz (mapcar '(lambda (x) (z_p (* (caddr x) fdbl) x)) ptb)
  )
					;----- 自然标高面 ----------  
  (mk3dm ptbz layzr)
					;----- 设计标高面 ----------  
  (if (member nil bgb)
    (prompt "\n没有定义设计标高, 不能绘出设计标高曲面。")
    (progn
      (setq ptb	 (mapcar '(lambda (x y) (z_p x y)) bgb ptb)
	    ptbz (mapcar '(lambda (x) (z_p (* (caddr x) fdbl) x)) ptb)
      )
      (mk3dm ptbz laysj)
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ver r14
;;;------------------------------
;;; 1998.01.11 wed
;;;modi 1998.06.13
;;; 土方网格
;;;------------------------------
(defun t_tfwg (/      laybj  laywg  layqx  laypt  fhb	 p00	ent
	       bhmax  e_ckd  wgbl   app	   ptb	  pt	 xmin	xmax
	       ymin   ymax   lmtb   e_0	   ss	  ssss	 e	eb
	       p1     p2     s1	    e1	   e1b	  jj	 p11	p12
	       laybh  layb   uctr   ee     ltmp
	      )

  (HY_Set0)
  (defun tfwg_err (ccc)
    (SETVAR "snapang" 0.0)
    (RE_MENU)
    (IF	(ZEROP (GETVAR "worlducs"))
      (COMMAND "ucs" "")
    )
    (GRTEXT)
    (if	layb
      (#lay "on" layb)
    )
 
    (HY_Set1)
    (PRINC)
  )

  (pusherr tfwg_err)
	
					;(HY_UndoM)
;;;modi 1998.06.13
  (setq uctr (HY_ClearUNDO))
  
;;;---------
  ;;(setvar "pdmode" 35)			;***** point type
  ;;(setvar "pdsize" 2.0)			;***** point size
  (setq	laybj "PP-TF-BJ"
	laywg "PP-TF-WG"
	layqx "PP-TF-DTQ"
	laypt "PP-TF-PT"
	laybh "PP-TF-BH"
  )
 
  (setq fhb (list laybj laywg  layqx laypt laybh))
  (setq ltmp (getlay "*"))
  (foreach lay ltmp
     (if (not (member lay fhb)) (setq layb (cons lay layb)))
  )
  
  (#lay "off" layb)
  (setq wg! 8.0)			;***** 网格常数(8 间距对应屏幕1 units)
					;(setq wg! (/ 1.0 3.175)) ;;;modi 1998.06.12


  (DL_MakeLayer laybj)
  (DL_MakeLayer laywg)
  (DL_MakeLayer layqx)
  (DL_MakeLayer laypt)
  (DL_MakeLayer laybh)
  
  (while (setq fhb (mktfbj))
;;;modi 1998.06.13
    (if	(listp fhb)
      (progn
	(setq p00 (nth 0 fhb)
	      ent (nth 1 fhb)
	)
	(command ".copy" ent "" p00 p00)
	(setq e_0 (ent_last))
	(command ".explode" (entlast))
	(setq ss (get_last e_0))
	(setq bhmax (qqwgbh))
	(setq e_ckd (ins_bh p00 bhmax)
	      app   (strcat "A" (itoa bhmax))
	)
	(setq ii 0)
	(repeat	(sslength ss)
	  (HY_KZSJXZ (ssname ss ii) "BH" 1000 app)
	  (setq ii (1+ ii))
	)
	(setq p00 (getpoint "\n土方网格基点<0,0>:"))
	(if (= p00 nil)
	  (setq p00 '(0 0 0))
	)

	(setq wgbl (getint "\n网格间距(米)<20>:"))
	(if (= wgbl nil)
	  (setq wgbl (* 20.0 wg!))
	  (setq wgbl (* wgbl wg!))
	)

	(setvar "clayer" laywg)
	(command "ucs" "o" p00)
	(setq e_0 (ent_last))
					;(command "hatch" "*net" wgbl 0.0 ent "")
	(command "hatch" "*ppsnet" wgbl 0.0 ent "")
	(setq ss (get_last e_0))
	(command "ucs" "")
	(setq ptb (getvex ent))
	(setq
	      ptb (mapcar 'car ptb)	;***** 边界端点 *****
	)
	(if (equal (car ptb) (last ptb) 0.001)
          (setq ptb (cdr ptb) )
        )
	(HY_KZSJXZ ent app 1000 "@")
	(command "redraw")
;;;modi 1998.06.12
					;(HY_KZSJXZ e_ckd "WGBH" 1040 (/ wgbl 8.0) 1010 p00 1005 (cdr (assoc 5 (entget ent))))
	(HY_KZSJXZ	e_ckd
		"WGBH"
		1040
		(/ wgbl wg!)
		1010
		p00
		1005
		(cdr (assoc 5 (entget ent)))
	)

	(HY_KZSJXZ e_ckd app 1000 "@")
					;----------------------------------------------
					;----- 置POINT     ----------------------------
					;----- 1. 边角点 ------------------------------
	(setvar "clayer" laypt)
					;----- 边界角点记录 ----
	(setq ptb  (ptbxpx ptb)		;***** X sort
	      xmin (car ptb)
	      xmax (last ptb)
	      ptb  (ptbypx ptb)
	      ymin (car ptb)
	      ymax (last ptb)
	      pmin (list (car xmin) (cadr ymin) 0.0)
	      pmax (list (car xmax) (cadr ymax) 0.0)

	      lmtb (list pmin pmax)
	      lmtb (list2s lmtb)
	)
	(HY_KZSJXZ e_ckd "WGBH" 1000 lmtb)
	(zm2pt pmin pmax)
	(foreach pt ptb
	  (command "point" pt)
	  (HY_KZSJXZ (entlast) app 1040 0.25 1070 0) ;**** 0外点标志!
	)
					;----- 2.内部点 ------------------
	(if ss
	  (progn
	    (setq ii 0)
	    (repeat (sslength ss)
	      (HY_KZSJXZ (ssname ss ii) app 1000 "@")
	      (setq ii (1+ ii))
	    )
	    (setq ssss (ssadd))
	    (while (>= (sslength ss) 1)
	      (setq e  (ssname ss 0)
		    eb (entget e)
		    p1 (cdr (assoc 10 eb))
		    p2 (cdr (assoc 11 eb))
	      )
	      (setq ssss (ssadd e ssss))
	      (if (or (not (setq ee (HY_PtName p1 0.0 0.0 0.1)))
	              (null (assoc -3  (entget ee (list app))))
	          )
		(progn
		  (command "point" p1)
		  (HY_KZSJXZ (entlast) app 1040 0.25 1070 0)
					;**** 0外点标志!
		)
	      )
	      (if (or (not (setq ee (HY_PtName p2 0.0 0.0 0.1)))
	              (null (assoc -3  (entget ee (list app))))
	          )
		(progn
		  (command "point" p2)
		  (HY_KZSJXZ (entlast) app 1040 0.25 1070 0)
					;**** 0外点标志!
		)
	      )
	      (if (setq	s1 (ssget "f"
				  (list p1 p2)
				  (list	'(0 . "LINE")
					(cons 8 laywg)
					(list -3 (list app))
				  )
			   )
		  )
		(progn
		  (setq s1 (sscl s1 ssss))
		  (setq jj 0)
		  (repeat (sslength s1)
		    (setq e1  (ssname s1 jj)
			  e1b (entget e1)
			  p11 (cdr (assoc 10 e1b))
			  p12 (cdr (assoc 11 e1b))
			  pt  (inters p1 p2 p11 p12 T)
		    )
		    (if	(or (not (setq ee (HY_PtName pt 0.0 0.0 0.1)))
	              (null (assoc -3  (entget ee (list app))))
	          )
		      (progn
			(command "point" pt)
			(HY_KZSJXZ (entlast) app 1040 1.0 1070 1)
					;**** 1内点标志!
		      )
		    )
		    (if	(= (rem jj 5) 0)
		      (prompt ".")
		    )
		    (setq jj (1+ jj))
		  )
		)
	      )
	      (setq ss (ssdel e ss))
	    )				;*** end of (while ...
	  )
	)
					;(prompt "\n可用Undo/Back命令取消上次操作.")
      )
    )
  )
;;;end of while fhb
  (#lay "on" layb)
  (clr_err)
  (HY_set1)
  (princ)
)
;;------------------------------
;; 1996.08.15 thu
;; 选择集处理 -- sscl(ss ssss)
;; 从SS中去掉SSSS中的元素
;;------------------------------
(defun sscl (ss ssss / ssll ii e ss)

  (setq	ssll (sslength ssss)
	ii   0
  )
  (repeat ssll
    (setq e  (ssname ssss ii)
	  ii (1+ ii)
    )
    (if	(ssmemb e ss)
      (setq ss (ssdel e ss))
    )
  )
  ss
)
;;------------------------------
;; make BJ
;; return -->nil / (list pt ent)
;;------------------------------
(defun mktfbj (/ pt ft ss ent kk fhb)

  (setvar "clayer" laybj)
  (initget "X U")
  (setq	pt
	 (getpoint
	   "\n回车退出 / 回退 U / 选图素构造边界线X /<点取闭合域内任一点>:"
	 )
  )
  (cond
    ((= pt nil) (setq fhb nil))
    ((= pt "U")
     (if (<= (getvar "undomarks") uctr)
       (prompt "\n已全部回退！")
       (HY_UndoB)
     )
     (setq fhb "U")
    )
    ((= pt "X")
     (HY_UndoM)
     (setq ft t)
     (while ft
       (prompt "\n回车或空选返回 /<选择边界图素>:")
       (setq ss	(ssget (list (cons 0 "*LINE,ARC")
			     (cons 8 (strcat laybj "," layqx))
		       )
		)
       )
       (cond
	 ((= ss nil)
	  (setq	ft  nil
		fhb nil
	  )
	 )
	 (t
	  (initget 1)
	  (setq pt (getpoint "\n点取闭合区域内任一点:"))
	  (setq ent (hy_bpoly pt ss))
	  (if ent
	    (progn
	      (redraw ent 3)
	      (initget "Y N")
	      (setq kk (getkword "\n变虚的线是边界线吗(y/n)?<y>:"))
	      (if (= kk "N")
		(progn
		  (entdel ent)
		  (setq ent nil)
		  (print)
		)
		(setq ft  nil
		      fhb (list pt ent)
		)
	      )
	    )
	    (progn
	      (setq ent nil)
	      (print)
	      (prompt "\n选择图素太复杂,不能形成边界线!")
	    )
	  )
	 )
       )				;end of cond ss
     )
    )
    ((= (type pt) 'LIST)
     (HY_UndoM)
     (setq ft t)
     (while ft
       (setq ent (hy_bpoly pt))
       (if ent
	 (progn
	   (redraw ent 3)
	   (initget "Y N")
	   (setq kk (getkword "\n变虚的线是边界线吗(y/n)?<y>:"))
	   (if (= kk "N")
	     (progn
	       (entdel ent)
	       (setq ent nil)
	       (setq pt (getpoint "\n回车退出 /<点取闭合域内任一点>:"))
	       (if (= pt nil)
		 (setq ft nil)
	       )
	     )
	     (setq ft  nil
		   fhb (list pt ent)
	     )
	   )
	 )
	 (progn
	   (prompt
	     "\n边界线太复杂, 请把不必要的图层关闭掉或用其它方式确定边界线.回车返回!"
	   )
	   (getpoint)
	   (setq ft  nil
		 ent nil
	   )
	 )
       )
     )
    )
  )
  fhb
)
;;------------------------------
;; 取网格编号max
;;------------------------------
(defun qqwgbh (/ ss ii e bh bb bhmax ft)

  (setq ss (ssget "x" (list (cons 0 "INSERT") '(-3 ("WGBH")))))
  (if ss
    (progn
      (setq ii 0)
      (repeat (sslength ss)
	(setq e	 (ssname ss ii)
	      bh (HY_QQ10xx e "WGBH" 1070)
	      bb (cons bh bb)
	      ii (1+ ii)
	)
      )
      (setq bhmax (1+ (apply 'max bb)))
    )
    (setq bhmax	1
	  bb	(list 1)
    )
  )
  (setq ft t)
  (while ft
    (initget 6)
    (setq bh (getint (strcat "\n该区域编号<" (itoa bhmax) ">:")))
    (if	(= bh nil)
      (setq bh bhmax
	    ft nil
      )
      (if (member bh bb)
	(progn
	  (beep)
	  (prompt "\n该编号已存在, 不能重复.")
	)
	(setq bhmax bh
	      ft nil
	)
      )
    )
  )
  bhmax
)
;;------------------------------
;; insert BH
;;------------------------------
(defun ins_bh (pt bh / laybh sca rr hh eb e_ckd)

  (setq	laybh "PP-TF-BH"
	sca   (DL_GetDrawingFactor)
	rr    (/ 10.0 sca)
	hh    (* 1.2 rr)
  )
  (HY_mktop laybh pt)
  (HY_EntMakeCircle laybh pt rr)
  (HY_EntMakeText laybh (itoa bh) pt hh 0.0)
  (setq eb (entmake '((0 . "ENDBLK"))))
  (mkins laybh eb pt nil)
  (setq e_ckd (entlast))
  (HY_KZSJXZ e_ckd "WGBH" 1070 bh)
  e_ckd
)
;;------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;ver r14
;;;write yft 99.08.28
;;;渲染处理
;;;光源: dwg3/xr_ligth.dwg
(defun ?xr_cl (/ pt xrss ss1 ent n loop len)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (HY_SV)
					;(setq pt (car (HY_GetScreenLBRT)))
  (setq	ss1 (ssget "x" '((0 . "INSERT,*LINE")))
	pt  nil
  )
  (if ss1
    (progn
      (setq len	 (sslength ss1)
	    n	 0
	    loop t
      )
      (print len)
      (while (and (< n len) loop)
	(setq pt (cdr (assoc 10 (entget (ssname ss1 n)))))
	(print pt)
	(if (and pt (listp pt))
	  (if (not (equal pt '(0.0 0.0 0.0) 1.0))
	    (setq loop nil)
	  )
	)
	(setq n (1+ n))
      )
    )
  )
  (print pt)
  (if (not (and pt (listp pt)))
    (setq pt '(0 0 0))
  )

  (setq xrss (ssget "x" '((2 . "direct"))))
  (if (null xrss)
    (progn
      (szdl_ins_sysblk  "xr_light" pt 1.0 1.0 0.0)
      (setq ent (entlast))
      (command ".explode" ent)
    )
  )
  (setq ss1 (ssget "x" '((8 . "AXIS"))))
  (if ss1
    (progn
      (command ".draworder" ss1 "" "f")
      (if (= (getvar "regenmode") 0)
	(command ".regen")
      )
    )
  )
  (prompt "\n已完成渲染前的预处理,可开始渲染")
  (HY_RV)
  (pub_re_var)
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;1998.02.11
;;;modi 1998.03.07
;;;modi 1998.05.29 1998.06.15
(defun #tfdtq (/ lay hbg lbh ent pt)
  (szload pub_save_var "wwpublic")
  (pub_save_var)
  (szload #pline "pppp")
  (setq lay "PP-TF-DTQ")
  (setq ent (#pline lay))
  (setvar "clayer" lay)
  (#offent ent 0.25 nil 1 1 4)
  (pub_re_var)
  (princ)
)
(defun #offent (ent   offd  newlay	delent	    epent redr	/
		s1    entb  entb2 s2	p1    p2    ang	  ss	ss1
		tq    r	    pc
	       )
  (if ent
    (progn
;;;modi 1998.05.29 1998.06.13
      (setq entb (pl_1s ent)
	    p1	 (nth 6 entb)
	    p2	 (cadr entb)
	    ang	 (caddr entb)
      )
;;;---------------     
      (HY_SV)
      (setvar "offsetdist" offd)
      (command ".offset"
	       ""
	       (list ent p1)
	       (polar p1 (+ ang (/ pi 2)) 0.05)
	       ""
      )
      (if newlay
	(progn
	  (setq s1 (entlast))
	  (command ".change" s1 "" "p" "la" newlay "")
	)
      )
      (if epent
	(progn
	  (command ".explode" (entlast))
	  (if redr
	    (setq ss (ssget "p"))
	  )
	)
      )
      (command ".offset"
	       ""
	       (list ent p1)
	       (polar p1 (+ ang (/ pi -2)) 0.05)
	       ""
      )
      (if newlay
	(progn
	  (setq s2 (entlast))
	  (command ".change" s2 "" "p" "la" newlay "")
	)
      )
      (if epent
	(progn
	  (command ".explode" (entlast))
	  (if redr
	    (setq ss1 (ssget "p"))
	  )
	)
      )
      (if delent
	(entdel ent)
      )
      (if (and epent redr)
	(progn
	  (HY_SSRedraw ss redr)
	  (HY_SSRedraw ss1 redr)
	)
      )
      (HY_RV)
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; modi 1998.03.10 1998.04.18
;;; 2D tree 转 3D tree
;;;-----------------------------
(defun 2dtr3d(/ sca laytr ss ii e eb km p00 num flag)
  ;(HY_SV)
  (HY_SET0)
  (setq sca 10.0)   ;***** 3D tree scale *****
  (setq w_path (HY_GetInstallDir))
;--- 3D tree层 ----------
  (setq laytr "PP-3D-TREE")
  ;(setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "PMTREE*"))))
  (setq ss (ssget "x" (list (cons 0 "INSERT") (cons 2 "B07???"))))
  (if ss
    (progn
      (DL_MakeLayer laytr)
      (setq ii 0)
      (repeat (sslength ss)
        (setq e (ssname ss ii)
              eb (entget e)
              km (strcase(cdr (assoc 2 eb)))
              p00 (cdr (assoc 10 eb))
              ;num (atoi (substr km 7))
              num (- (atoi (substr km 4)) 3)
        )
        (cond
          ((= num -3) (setq flag 9))
          ((or (= num -2) (= num -1)(= num 0))(setq flag 10))
          ((or (= num 13) (= num 16) (= num 17) (= num 18)
               (= num 24) (= num 27) (= num 28) (= num 29))
            (setq flag 1)
          )
          ((or (= num 1) (= num 7) (= num 8) (= num 10) (= num 11) (= num 26))
            (setq flag 2)
          )
          ((or (= num 4) (= num 5) (= num 12)) (setq flag 3))
          ((or (= num 14) (= num 15) (= num 30)) (setq flag 4))
          ((or (= num 19) (= num 23) (= num 25)) (setq flag 6))
          ((or (= num 20) (= num 21) (= num 22)) (setq flag 10))
          ((or (= num 2) (= num 3) (= num 9) (= num 32)) (setq flag 12))
          ((or (= num 6) (= num 31)) (setq flag 13))
        )
        ;;(setq km (strcat (HY_GetInstallDir) "dwg3/3dtr_" (itoa flag)))
        (setq km w_path
              km (strcat km  hyszdl_gv_dwglib_dir "\\")
              km (strcat km  "三维树\\3dtr_" (itoa flag))
        )
        ;(entdel e)
        (if (null (ssget p00
                         (list (cons 0 "INSERT")
                               (cons 8 laytr)
                               (cons 2 (strcat "3dtr_" (itoa flag)))
                         )
                  )
            )
          (command "insert" km p00 "x" sca sca sca 0.0)
        )

        
        (setq ii (1+ ii))
      )
      (command ".layer" "f" "pp-pmtree" "")
    )
    (prompt "\n还没有布置二维树。")
  )
  ;(HY_RV)
  (HY_SET1)
  (princ)
)
;;;
;;; 3D tree 转 2D tree
(defun 3dtr2d(/ ss lay2d lay3d layb)
  ;(setvar "cmdecho" 0)
  (HY_SET0)
  (prompt "\n===== 用于二维树转三维后再恢复为二维树 =====")  
  (setq lay3d "PP-3D-TREE"
        lay2d "PP-PMTREE"
        layb (ai_table "LAYER" 1)
  )
  (if (member lay3d layb)
    (command ".layer" "f" lay3d "")
  )
  (if (member lay2d layb)
    (command ".layer" "t" lay2d "")
  )
  ;(setvar "cmdecho" 1)
  (HY_SET1)
  (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;------------------------------
;;; 1998.02.27 fri
;;; 1999.06.03 thu modify by wei
;;; 地形断面
;;;------------------------------
;;;;modi 98.11.06 yft
(defun t_dxdm (/      laydm  layzr  laysj  laybj  laypt	 pdold	orold
	       p00    p01    p02    ptb	   e	  eb	 ang	jiao
	       sst    pt     p11    p12	   pt1	  pt2	 e1	e1b
	       e2     e2b    fhb    ptbgb  zrbgb  sjbgb	 zrmin	zrmax
	       sjmin  sjmax  bgmin  bgmax  ccc	  aa	 bb	dd
	       hh     ww     iiii   nnnn   oldosmode	 oldosmode1
	       zr_triangle   sj_triangle   fhb1  fhb2)
(defun T_dxdm_error(ccc / )
  (DL_Destory_TRiAngle  zr_triangle)
  (DL_Destory_TRiAngle  sj_triangle)
)
;;;  (setq oldosmode (getvar "osmode"))	;yu
(szload JJ_PSF "szdldx3d")
  (HY_SV)
  (HY_UndoM)
  (setq	laydm "PP-TF-DM"
	layzr "PP-TF-DMZ"
	laysj "PP-TF-DMS"
	laybj "PP-TF-BJ"
	laypt "PP-TF-PT"
  )
;;;  (mk_lay "PP-TF-DM*")
  (mk_lay laydm)
  (mk_lay layzr)
  (mk_lay laysj)
  (mk_lay laybj)
  (mk_lay laypt)

  (setvar "clayer" laydm)
  (setvar "plinewid" 0.0)
;;  (setq pdold (getvar "pdsize"))
;;  (setvar "pdsize" 0.0001)
  (setq orold (getvar "orthomode"))
					;-------------------------------------------------------
  (setq hh (/ (Dl_GetTextHeight) (DL_GetDrawingFactor)))	;*** text high
  (setq ww (DL_GetDimPrec))			;*** 小数位数 ***
  (setq	aa 2.0
	bb 1.0
  )					;*** long/short line
  (setq dd 2)				;*** delt
					;-------------------------------------------------------
  (setq	sst (ssget "x"
		   (list '(0 . "POINT")
			 (cons 8 laypt)
			 '(-3 ("SJBG"))
			 '(-3 ("ZRBG"))
		   )
	    )
  )

  (if (/= sst nil)
  (progn
  ;;;(setq oldosmode1 (getvar "osmode"))	;yu
  ;;;(setvar "osmode" oldosmode)		;yu
  (setq p01 (getpoint "\n剖断位置起点:"))
  ;;;(setvar "osmode" oldosmode1)		;yu
  (if p01
    (progn
      ;;;(setvar "osmode" oldosmode)	;yu
      (initget 1)
      (setq p02 (getpoint p01 "\n到点:"))
      ;;;(setvar "osmode" oldosmode1)	;yu

      (setq ang (angle p01 p02))
      (setvar "snapang" ang)
      (setvar "orthomode" 1)
      (setq ptb (cons p02 (cons p01 ptb)))
      (command ".pline" p01 p02)
      (setq p00	p01
	    p01	p02
      )
      (while (setq p02 (getpoint p01 "\n回车返回 /<到点>:"))
	(command p02)
	(setq p01 p02)
	(setq ptb (cons p01 ptb))
      )
      (command "")
      (setq e (entlast))
      (initget 1)
      (setq ang (getangle p01 "\n剖视方向:"))
      (setq ccc (getstring "\n剖视图编号<1>:"))
      (if (= ccc "")
	(setq ccc "1")
	(setq ccc (strcase ccc))
      )
      (prompt "\n提取标高信息, 请稍候...")
      (jj_psf ptb ang ccc)		;*** 剖视符
      (entdel e)
      (setvar "snapang" 0.0)
      ;;----- two end point ---------------------------
      (if (= (length ptb) 2)		;*** 通常
	(progn
	  (setq ptb (reverse ptb))
	  ;;wei 1999.06.03
	)
	(progn
	  (repeat 2
	    (setq p01 (nth 0 ptb)
		  p02 (nth 1 ptb)
		  sst (ssget "f"
			     (list p01 p02)
			     (list '(0 . "LINE,ARC") (cons 8 laybj))
		      )
	    )
	    (if	(and sst (= (sslength sst) 1))
	      (progn
		(setq e	 (ssname sst 0)
		      eb (entget e)
		)
		(if (= (cdr (assoc 0 eb)) "LINE")
		  (setq	p11 (cdr (assoc 10 eb))
			p12 (cdr (assoc 11 eb))
			pt  (HY_LinePMInt p01 p02 p11 p12 t)
		  )
		  (setq pt (car (cal_ila p01 p02 e)))
		)
		(if pt
		  (setq ptb (cons pt (cdr ptb)))
		)
	      )
	    )
	    (setq ptb (reverse ptb))
	  )
	)
      )
      (setq ptb (mapcar '(lambda (x) (z_p 0.0 x)) ptb))
      (setq ptb (big_h ptb))		;*** 增大
      (if (and (> ang pi) (< ang (* 1.999 pi)))
	(setq ptb (reverse ptb))
      )
      (setq iiii 0
	    nnnn 1
      )
      
      (pusherr T_dxdm_error)
      (setq zr_triangle (DL_InitTriangle "ZRBG" laypt)) 
      (setq sj_triangle (DL_InitTriangle "SJBG" laypt))
      (repeat (length ptb)
	(setq x	    (nth iiii ptb))
	(setq fhb1 (GetPtBg_Triangle zr_triangle x))
	(if (null fhb1) (setq fhb1  (p_ptbg x "ZRBG" laypt)))
	(setq fhb2 (GetPtBg_Triangle sj_triangle x))
	(if (null fhb2) (setq fhb2  (p_ptbg x "SJBG" laypt)))
	(setq ptbgb (cons (list x fhb1 fhb2) ptbgb))
	(HY_Waiting)
	(setq iiii (1+ iiii))
      )
      (DL_Destory_TRiAngle zr_triangle)
      (DL_Destory_TRiAngle sj_triangle)
      (clr_err)
      
      (setq zrbgb (mapcar 'cadr ptbgb)
	    sjbgb (mapcar 'caddr ptbgb)
	    zrmin (apply 'min zrbgb)
	    zrmax (apply 'max zrbgb)
	    sjmin (apply 'min sjbgb)
	    sjmax (apply 'max sjbgb)
	    bgmin (min zrmin sjmin)
	    bgmax (max zrmax sjmax)
      )
      (hz_dm ptbgb bgmin bgmax)
    
    )
  )
 )
 (progn
      (beep)
      (prompt
	"\n土方网格节点的自然标高和设计标高都定义后才能出断面图,程序退出!"
      )
  )
 )
  	
;;  (setvar "pdsize" pdold)
;;  (setvar "orthomode" orold)
  (HY_RV)
)
;;------------------------------
(defun hz_dm (ptbgb bgmin bgmax	/     p000  p001  p002	p003  bgc
	      xs    ii	  ll	y0    bb1   bb2	  p00	p01   p02
	      p03   p04	  zrbg1	zrbg2 sjbg1 sjbg2 dd0	cc1   cc2
	      cc3   fhb
	     )
(szload jj_bc0 "szdldx3d")
  (initget 1)
  (setq p000 (getpoint "\n地形断面左下角位置:"))
  (initget 6)
  (setq xs (getreal "\n竖向放大系数<10.0>:"))
  (if (= xs nil)
    (setq xs 10.0)
  )
  (setq bgmin (- (fix bgmin) 1))
  (setq bgmax (1+ (fix bgmax)))

  (setq	bgc  (- bgmax bgmin)
	p001 (list (car p000) (+ (* xs bgc) (cadr p000)) 0.0)
	y0   (cadr p000)
  )
  (setq	ii  0
	ll  (length ptbgb)
	p00 p000
  )
  (repeat (- ll 1)
    (setq bb1	(nth ii ptbgb)
	  bb2	(nth (+ ii 1) ptbgb)
	  p01	(nth 0 bb1)
	  p02	(nth 0 bb2)
	  zrbg1	(- (nth 1 bb1) bgmin)
	  zrbg2	(- (nth 1 bb2) bgmin)
	  sjbg1	(- (nth 2 bb1) bgmin)
	  sjbg2	(- (nth 2 bb2) bgmin)
	  dd0	(distance p01 p02)
	  p01	(list (car p00) (+ y0 (* zrbg1 xs)) 0.0)
	  p02	(list (+ (car p00) dd0) (+ y0 (* zrbg2 xs)) 0.0)
	  p03	(list (car p00) (+ y0 (* sjbg1 xs)) 0.0)
	  p04	(list (+ (car p00) dd0) (+ y0 (* sjbg2 xs)) 0.0)
	  p00	(polar p00 0.0 dd0)
    )
    (setvar "clayer" layzr)
    (command ".line"
	     (z_p (nth 1 bb1) p01)
	     (z_p (nth 1 bb2) p02)
	     ""
    )
    (setvar "clayer" laysj)
    (command ".line"
	     (z_p (nth 2 bb1) p03)
	     (z_p (nth 2 bb2) p04)
	     ""
    )
    (setq ii (1+ ii))
  )
  (setq	p002 (list (car p00) (cadr p001) 0.0)
	p003 (list (car p00) (cadr p000) 0.0)
  )
  (command ".pline" p000 "w" 0.5 0.5 p001 p002 p003 "c")
  (jj_bc0 p000 p003)
  (jj_bc90 p000 p001 bgmin bgc xs)
  (setq	cc1 (strcat "土方断面图 " ccc "-" ccc)
	cc2 "自然标高曲线"
	cc3 "设计标高曲线"
  )
  (setq p01 (polar p001 (* 0.5 pi) (* 0.7 hh)))
  (command "text" "j" "ML" p01 hh 0.0 cc1)
  (setq	fhb (textbox (list (cons 1 cc1)))
	fhb (abs (- (car (nth 0 fhb)) (car (nth 1 fhb))))
	p01 (polar p01 0.0 (* 1.2 fhb))
  )
  (setvar "clayer" layzr)
  (command "line" p01 (setq p01 (polar p01 0.0 20.0)) "")
  (setq p01 (polar p01 0.0 hh))
  (command "text" "j" "ML" p01 hh 0.0 cc2)

  (setq p01 (polar p01 0.0 (* 1.2 fhb)))
  (setvar "clayer" laysj)
  (command "line" p01 (setq p01 (polar p01 0.0 20.0)) "")
  (setq p01 (polar p01 0.0 hh))
  (command "text" "j" "ML" p01 hh 0.0 cc3)

)
;;------------------------------
;; 增大 (ptb->bigb ptb)
;;------------------------------
(defun big_h (ptb / ii dd0 bigb dd nn p01 p02 ang)

  (setq dd0 10.0)			;*** jianju
  (setq ii 0)
  (repeat (- (length ptb) 1)
    (setq p01  (nth ii ptb)
	  p02  (nth (+ ii 1) ptb)
	  ang  (angle p01 p02)
	  dd   (distance p01 p02)
	  bigb (cons p01 bigb)
	  nn   (fix (/ dd dd0))
    )
    (if	(> nn 2)
      (repeat (- nn 1)
	(setq bigb (cons (setq p01 (polar p01 ang dd0)) bigb))
      )
    )
    (setq bigb (cons p02 bigb))
    (setq ii (1+ ii))
  )
  bigb
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)

