dtm文件生成等高线 lisp_CAD制图中的等高线拟合lisp程序

(defun c:ni()

(load"qx")

(command"layer""unlock" "dgx" "")

;(command"zoom" "e")

(c:LWPOLYLINE)

(setq ent (ssget "x" '((8 . "dgx")(0 . "POLYLINE"))))

(if ent (progn

(setq long-ent (sslength ent))

(setq num-ent 0)

(write-line"n　　 ***正在拟合等高线.....")

(repeat long-ent

(setq ty (ssname ent num-ent))

;(Setq ty (car (entsel)))

(c:get-yuanma)

(c:get-listnew)

(c:regen-line)

(setq num-ent (1+ num-ent))

)

(write-line"n　　拟合完毕,请检查大拐弯处是否有点线矛盾！")

);progn

(write-line"n 图形中没有等高线")

);if

(print)

)

(defun c:get-yuanma()

(command"pedit" ty "d" "")

(c:max-min)

(Setq data-dgx (entget ty))

(setq tc (assoc 8 data-dgx)

line-type (assoc 6 data-dgx)

width (cdr (assoc 40 data-dgx))

thi (cdr (assoc 39 data-dgx))

color (cdr (assoc 62 data-dgx))

)

)

(defun c:LWPOLYLINE()

(setq ent (ssget"x" '((8 . "dgx")(0 . "LWPOLYLINE"))))

(if ent (progn

(setq long-ent (sslength ent))

(setq num-ent 0)

(repeat long-ent

(setq ty (ssname ent num-ent))

(command"pedit" ty "f" "")

(setq num-ent (1+ num-ent))

)

))

)

(defun c:get-listnew() ;减掉过密顶点

(setq long-new (length list-p))

(Setq p-listnew (list (car list-p)))

(setq num-new 0 k 0)

(setq p1 (nth num-new list-p))

(setq num-new (1+ num-new))

(while (setq p2　(nth num-new list-p))

(setq dis (distance p1 p2))

(if (< dis 5.0) (progn

(setq num-new (1+ num-new))

(while (and (< dis 5.0)(> long-new num-new))

(setq p2　(nth num-new list-p))

(setq dis (distance p1 p2))

(setq num-new (1+ num-new))

)

(setq p-listnew (append p-listnew (list p2)))

);progn

(setq p-listnew (append p-listnew (list p2)))

)

(setq p1 p2)

(setq num-new (1+ num-new))

);while

(setq d-end (distance (last p-listnew) (last list-p)))

(if (/= 0 d-end)

(setq p-listnew (append p-listnew (list (last list-p))))

)

);defun

(defun c:regen-line()

(command"erase" ty "")

(command "pline")

(apply 'command p-listnew)

(command "")

(command"pedit" (entlast) "w" width "s" "")

(command"change" (entlast) "" "p" "t" thi "")

(setq data-line (entget (entlast)))

(setq tc-old (assoc 8 data-line)

line-typeold (assoc 6 data-line)

)

(setq da (subst line-type line-typeold data-line))

(entmod da)

(setq da (subst tc tc-old data-line))

(entmod da)

(if color (command"change" (entlast) "" "p" "c" color ""))

)