绘制地形图坡角线LISP程序，坡线可以是*POLYLINE、SPLINE...

百花草

命令：dxt

功能：绘制地形图

配合xdrx_api使用

注意：目前本程序限制，坡角线和坡顶线须封闭，即端点重合
坡顶线和坡角线可以是*polyline,spline

|;

(defun c:dxt (/ $set_param $set_data1 $set_data2 $draw_line ptl5 e1 e2 pte ptd)
(defun $set_param (/ dxt_dist dxt_color)
(if (not #dxt_color)
(setq #dxt_color 5)
)
(if (not #dxt_dist)
(setq #dxt_dist 5.0)
)
(initget 6)
(if (setq dxt_dist (getreal (strcat "\n请输入间距<" (rtos #dxt_dist 2 2)
">:"
)
)
)
(setq #dxt_dist dxt_dist)
)
(initget 6)
(if (setq dxt_color (getint (strcat "\n请输入短线颜色号<" (itoa #dxt_color)
">:"
)
)
)
(setq #dxt_color dxt_color)
)
)
(defun $draw_line (pte ptd / n)
(xdrx_setmark)
(foreach n pte
(if (> (apply
'distance
(cdr n)
) 0.01 ;;短线限制值
)
(xdrx_line1 (cadr n) (polar (cadr n) (apply
'angle
(cdr n)
) (car n)
)
)
)
)
(xdrx_setsstodb (xdrx_getss) 0)
(while (xdrx_getentdata 0)
(xdrx_modent 62 #dxt_color)
)
(foreach n ptd
(if (> (apply
'distance
n
) 0.01 ;;短线限制值
)
(apply
'xdrx_line1
n
)
)
)
)
(defun $set_data1 (/ ptl ptl1 dist n ptl2 ptl4 ptl5 ptl3)
(setq pnt (cadr e1)
e1 (car e1)
e2 (car e2)
)
(setq ptl (xdrx_getpointatdist e1 #dxt_dist)
ptl1 (apply
'xdrx_getnearpt
(cons pnt (list (car ptl) (last ptl)))
)
ptl1 (if (equal (last ptl) (car ptl1) 1e-5)
(reverse ptl)
ptl
)
)
(setq dist (distance (car ptl1) (cadr ptl1)))
(foreach n ptl1
(setq ptl2 (cons (mapcar
'+
(mapcar
'(lambda (x)
(* dist x)
)
(cadr (xdrx_getperpline e1 n t))
)
n
) ptl2
)
)
)
(setq ptl2 (reverse ptl2)
ptl3 (mapcar
'list
ptl1
ptl2
)
)
(foreach n ptl3
(setq ptl4 (cons (car (xdrx_getinters n e2 1)) ptl4))
)
(setq ptl4 (reverse ptl4))
(setq ptl5 (mapcar
'list
ptl4
ptl1
)
)
)
(defun $set_data2 (ptl5 / i ptf d1 ptg)
(setq i 0)
(foreach n ptl5
(if (= 0 (rem i 2))
(setq ptd (cons n ptd))
(setq pte (cons n pte))
)
(setq i (1+ i))
)
(setq ptd (reverse ptd)
pte (reverse pte)
ptf ptd
)
(while (cdr ptf)
(setq d1 (/ (+ (apply
'distance
(car ptf)
) (apply
'distance
(cadr ptf)
)
) 4
)
)
(setq ptg (cons d1 ptg))
(setq ptf (cdr ptf))
)
(setq ptg (reverse ptg)
pte (mapcar
'cons
ptg
pte
)
)
) ; main program
(if (and
(and
(setq e1 (xdrx_entsel "\n请点取坡角线<退出>:" '((0 . "*polyline,spline"))))
(progn
(redraw (car e1) 3)
t
)
)
(and
(setq e2 (xdrx_entsel "\n请点取破顶线<退出>:" '((0 . "*polyline,spline"))))
(progn
(redraw (car e2) 3)
t
)
)
)
(progn
(xdrx_begin '("cmdecho" 0))
(xdrx_ucson)
($set_param)
(setq ptl5($set_data1))
($set_data2 ptl5)
($draw_line pte ptd)
(redraw e1 4)
(redraw e2 4)
(xdrx_ucsoff)
(xdrx_end)
)
)
(princ)
)

倾心思梦

谢谢分享！

一笑二哥

谢谢分享！