等高线圆滑拟合

楼主^#

更多发布于：2004-07-15 14:58

将源代码粘贴到写字板里，后缀改为LSP：
(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 ""))
)

喜欢0 评分0

举报回复

shengl 路人甲注册日期2004-09-02 发帖数1 QQ 铜币107枚威望0点贡献值0点银元0个加关注写私信	1楼^# 发布于：2004-09-02 16:09 gis你不是什么语言都搞吧？
	举报回复(0) 喜欢(0) 评分

hexiaoming 路人甲注册日期2003-11-10 发帖数57 QQ 铜币160枚威望0点贡献值0点银元0个加关注写私信	2楼^# 发布于：2004-09-17 11:47 <img src="images/post/smile/dvbbs/em05.gif" />
	举报回复(0) 喜欢(0) 评分

wzjtxz 路人甲注册日期2008-03-01 发帖数7 QQ 铜币121枚威望0点贡献值0点银元0个加关注写私信	3楼^# 发布于：2009-04-19 14:03 在CAD中加载成功后，命令行提示：错误: 参数类型错误: numberp: nil
	举报回复(0) 喜欢(0) 评分

wzjtxz

路人甲

注册日期2008-03-01
发帖数7
QQ
铜币121枚
威望0点
贡献值0点
银元0个

加关注写私信

4楼^#

发布于：2009-04-19 14:05

(defun c:zhxx();转换新线形
(prompt "请选择线: ") (setq object (entsel)) (SETQ SSS (ssget "x" '((-4 . "<OR") (0 . "LWPOLYLINE") (0 . "POLYLINE") (-4 . "OR>")) )) (setq i 0) (if sss (while ( (setq OBJ (ssname sss i)) (huan2) (setq i (+ i 1)) ) ;WHILE ) ;IF SSS
 (setq b (itoa i) ) (setq b1 (strcat "图中共检查修改旧line线划有:" b "条" ) )
)
 (defun huan2() (setvar "CMDECHO" 0) (command"osnap" "off") (setq obj_38 nil) (setq obj_b(entget obj '("SHANXI" "SOUTH"))) (setq obj_la (cdr(assoc 8 obj_b))) (setq obj_lt (cdr(assoc 6 obj_b))) (setq obj_color (cdr(assoc 62 obj_b))) (setq obj_70 (cdr(assoc 70 obj_b))) (setq obj_40 (cdr(assoc 40 obj_b))) (setq obj_38 (cdr(assoc 38 obj_b))) (if(= obj_38 nil) (setq obj_38 (nth 2 (cdr(assoc 10 obj_b)))) ) (setq obj_xdata (assoc -3 obj_b) ) (command "layer" "S" obj_la "") (setq obj_b (qd_b1 obj) ) (setq nnn(length obj_b)) (setq j (- nnn 1)) (if(or(= obj_70 5)(= obj_70 133)) (setq nnn (- nnn 1))) (setq p0(nth j obj_b)) (command "pline") (repeat nnn (setq p1(nth j obj_b)) (command p1) (setq j (- j 1)) ) (if( /= (/ obj_70 2) (/ obj_70 2.0) ) (command p0)) (command) (command"erase" obj "") (if (/= obj_lt nil)(command"change" (entlast) "" "p" "lt" obj_lt "") ) (if (/= obj_color nil) (command"change" (entlast) "" "p" "c" obj_color "") ) (if (/= obj_40 nil) (command"pedit" (entlast) "w" obj_40 "") ) (if (/= obj_38 nil) (command"change" (entlast) "" "p" "e" obj_38 "") )
 (setq object (entget (entlast)))
 (if (/= obj_xdata nil)(progn (setq xdata (list obj_xdata)) (setq nent (append object xdata)) (entmod nent) )) (setq object (entlast) ) )
(defun huan3() (setvar "CMDECHO" 0) (command"osnap" "off") (setq obj_38 nil) (setq obj_b(entget obj '("SHANXI" "SOUTH"))) (setq obj_la (cdr(assoc 8 obj_b))) (setq obj_lt (cdr(assoc 6 obj_b))) (setq obj_color (cdr(assoc 62 obj_b))) (setq obj_70 (cdr(assoc 70 obj_b))) (setq obj_40 (cdr(assoc 40 obj_b))) (setq obj_38 (cdr(assoc 38 obj_b))) (if(= obj_38 nil) (setq obj_38 (nth 2 (cdr(assoc 10 obj_b)))) ) (setq obj_xdata (assoc -3 obj_b) ) (command "layer" "S" obj_la "") 
 (setq obj_b (qd_b1 obj) ) (setq nnn(length obj_b)) (setq j 0) (if(or(= obj_70 5)(= obj_70 133)) (setq nnn (- nnn 1))) (setq p0(nth j obj_b)) (command "pline") (repeat nnn (setq p1(nth j obj_b)) (command p1) (setq j (+ j 1)) ) (if( /= (/ obj_70 2) (/ obj_70 2.0) ) (command p0)) (command) (command"erase" obj "") (if (/= obj_lt nil)(command"change" (entlast) "" "p" "lt" obj_lt "") ) (if (/= obj_color nil) (command"change" (entlast) "" "p" "c" obj_color "") ) (if (/= obj_40 nil) (command"pedit" (entlast) "w" obj_40 "") ) (if (/= obj_38 nil) (command"change" (entlast) "" "p" "e" obj_38 "") )
 (setq object (entget (entlast)))
 (if (/= obj_xdata nil)(progn (setq xdata (list obj_xdata)) (setq nent (append object xdata)) (entmod nent) )) (setq object (entlast) ) )
 (defun qd_b1(obj_1971); 获取新旧线坐标 (setq dxfb_1971(entget obj_1971)) (setq obty_1971 (cdr (assoc 0 dxfb_1971)) ) (SETQ DB_PL '()) (Cond ((= obty_1971 "POLYLINE") (setq obj_1971 (entnext obj_1971)) (setq dxfb_1971 (entget obj_1971)) (setq po_1971 (cdr (assoc 10 dxfb_1971))) (SETQ DB_PL '()) (while (/= (cdr (assoc 0 dxfb_1971)) "SEQEND") (setq po_1971(list (nth 0 po_1971) (nth 1 po_1971) (nth 2 po_1971))) (SETQ DB_PL(APPEND DB_PL (list po_1971))) (setq obj_1971 (entnext obj_1971)) (setq dxfb_1971 (entget obj_1971)) (while(= (cdr (assoc 70 dxfb_1971)) 16) (setq obj_1971 (entnext obj_1971)) (setq dxfb_1971 (entget obj_1971)) ) (setq po_1971 (cdr (assoc 10 dxfb_1971))) ) ) ((= obty_1971 "LWPOLYLINE") (SETQ NNN(length dxfb_1971)) (SETQ K 0) (SETQ DB_PL '()) (REPEAT NNN (SETQ po_1971 (NTH K dxfb_1971)) (if(= (car po_1971) 10) (setq DB_PL(append DB_PL (list (cdr po_1971)))) ) (SETQ K (+ K 1)) ) ) 
 ((= obty_1971 "LINE") (SETQ NNN(length dxfb_1971)) (SETQ K 0) (SETQ DB_PL '()) (REPEAT NNN (SETQ po_1971 (NTH K dxfb_1971)) (if( or (= (car po_1971) 10)(= (car po_1971) 11)) (setq DB_PL(append DB_PL (list (cdr po_1971)))) ) (SETQ K (+ K 1)) ) ) )

 DB_PL )

 (defun c:dgxxg();等高线连接修改 (command "osnap" "off") (prompt "选择实体的断点处") (setq obj1(entsel)) (setq ob_pp (car (cdr obj1))) (setq obja (car obj1)) (SETQ OBJC OBJA) (setq obj_b(entget obja)) (setq obj_la (cdr(assoc 8 obj_b))) (setq obj_lt (cdr(assoc 6 obj_b))) (setq wid (cdr(assoc 40 obj_b))) (setq w38 (cdr(assoc 38 obj_b))) (setq c70 (cdr(assoc 70 obj_b))) (if (= c70 129) (setq c70 1)) (command"linetype" "s" obj_lt "") (command"layer" "s" obj_la "") (setq p1 (list (nth 0 ob_pp) (nth 1 ob_pp))) ; (command "pedit" obja "d" "x") (setq ssb (ssget "x" (LIST (cons 0 "polyline,lwpolyline")(cons 38 w38)(cons 8 obj_la)))) (setq i 0) (if ssb (while ( (plin2a) (setq i 0) (if ssb (while ( (setq ssb nil) (setq vwi (getvar "VIEWSIZE")) (setq pzjl (/ vwi 50))
 (setq zbd nil) (setq zbd (qd_b1 object) ) (setq pb1 (nth 0 zbd)) (setq pb2 (nth (- (length zbd) 1) zbd)) 
 '''''''''''' (setq zbb nil) (setq zbb (qd_b1 obja) ) (if (= c70 1) (setq zbb (append zbb (list (nth 0 zbb)))) ) (if (equal (nth 0 zbb) (nth (- (length zbb) 1) zbb) 1) (setq c70 1)) (setq p1 pb1) (setq i 1) (jdjs) (setq ds i) (setq jda (/ (* (angle (nth (- i 1) zbb) (nth i zbb)) 180) pi)) (setq jdb (/ (* (angle (nth 0 zbd) (nth 1 zbd)) 180) pi)) (setq jdc (- jda jdb)) (if (< jdc 0) (setq jdc (- 0 jdc))) (if (> jdc 180) (setq jdc (- 360 jdc))) (setq xxfz 0) (if (> jdc 90) (progn (setq zbb (reverse zbb)) (setq ds (- (length zbb) ds)) (setq xxfz 1) )) (if (= c70 1) (progn (setq zbs '()) (setq i (- ds 1)) (repeat (- (length zbb) ds) (setq zbs (append zbs (list (nth i zbb)))) (setq i (+ i 1))) (setq i 0) (repeat ds (setq zbs (append zbs (list (nth i zbb)))) (setq i (+ i 1))) (setq zbb zbs) (setq zbs nil) (setq ds 1) ))
 (setq zb '()) (setq i 0) (repeat (- ds 1) (setq zb (append zb (list (nth i zbb)))) (setq i (+ 1 i)) ) (entdel object) (setq i 0) (command "pline") (command (nth (- ds 1) zbb)) (repeat (length zbd) (command (nth i zbd)) (setq i (+ i 1)) ) (command "") (setq object (entlast)) (setq zbd nil) (setq zbd (qd_b1 object) ) (setq jdzb nil) (setq q1 (polar pb2 3.97 pzjl)) (setq q2 (polar pb2 0.83 pzjl)) (setq ssa (ssget "c" q1 q2 (LIST (cons 0 "polyline,lwpolyline")(cons 38 w38)(cons 8 obj_la)))) (if ssa (if (ssmemb object ssa) (setq ssa (ssdel object ssa)) ) ) (if ssa (if (= (sslength ssa) 0) (setq ssa nil))) (if ssa (if (ssmemb obja ssa) (progn '''同一实体 (setq p1 pb2) (setq i ds) (jdjs) (setq ds1 i) (entdel object) (setq i 0) (command "pline") (repeat (- (length zbd) 1) (command (nth i zbd)) (setq i (+ i 1)) ) (command jdzb) (command (nth ds1 zbb))(command "") (setq object (entlast)) (setq zbd nil) (setq zbd (qd_b1 object) ) ) (progn '''不同实体 (setq OBJb (ssname ssa 0)) (setq zbb nil) (setq zbb (qd_b1 objb) ) (setq p1 pb2) (setq i 1) (jdjs) (setq ds1 i) (setq jda (/ (* (angle (nth (- i 1) zbb) (nth i zbb)) 180) pi)) (setq zbdl (- (length zbd) 1)) (setq jdb (/ (* (angle (nth (- zbdl 1) zbd) (nth zbdl zbd)) 180) pi)) (setq jdc (- jda jdb)) (if (< jdc 0) (setq jdc (- 0 jdc))) (if (> jdc 180) (setq jdc (- 360 jdc))) (if (> jdc 90) (progn (setq zbb (reverse zbb)) (setq ds1 (- (length zbb) ds1) ) )) (entdel object) (setq i 0) (command "pline") (repeat (- (length zbd) 1) (command (nth i zbd)) (setq i (+ i 1)) ) (command jdzb) (command (nth ds1 zbb))(command "") (setq object (entlast)) (setq zbd nil) (setq zbd (qd_b1 object) ) (entdel objb) ) ) )
 (command"pedit" object "s" "") (setq obj object)(huan3) (setq obj object) (cd1) (setq object (entlast)) (setq zba nil) (setq zba (qd_b1 object) ) (setq i 1) (repeat (- (length zba) 1) (setq zb (append zb (list (nth i zba)))) (setq i (+ 1 i)) ) (if jdzb (progn (setq i (+ ds1 1)) (repeat (- (- (length zbb) ds1) 1) (setq zb (append zb (list (nth i zbb)))) (setq i (+ 1 i)) ) )) (if (= xxfz 1) (setq zb (reverse zb)) ) (setq i 0) (command "pline") (repeat (length zb) (command (nth i zb)) (setq i (+ i 1)) ) (if (= c70 1) (command "c")(command "")) (if (/= wid nil) (command"pedit" (entlast) "w" wid "") ) (if (/= w38 nil) (command"change" (entlast) "" "p" "e" w38 "") ) (COMMAND "_matchprop" OBJ1 (entlast) "") (command "redraw") (ENTDEL OBJECT) (ENTDEL OBJC ) )
 (defun cd1() (setq obj_40 nil) (setq obj_lt nil) (setq obj_color nil) (setq obj_b(entget obj )) (setq obj_la (cdr(assoc 8 obj_b))) (setq obj_lt (cdr(assoc 6 obj_b))) (setq obj_color (cdr(assoc 62 obj_b))) (setq obj_70 (cdr(assoc 70 obj_b))) (setq obj_40 (cdr(assoc 40 obj_b))) (setq obj_xdata (assoc -3 obj_b) ) (setq DB_zb (qd_b1 obj) ) (setq nnn(length db_zb)) (if(or(= obj_70 5)(= obj_70 133)) (setq nnn (- nnn 1))) (setq p0(nth 0 db_zb)) (setq p2 p0) (command "osnap" "off") (command "pline" p0 "w" 0 0) (setq j 1) (setq jdd 0) (repeat (- nnn 2) (setq p1(nth j db_zb)) (setq p3(nth (+ j 1) db_zb)) (setq jda (angle p2 p1)) (setq jdb (angle p2 p3)) (setq jdc (abs (- jda jdb))) (if (> jdc pi) (setq jdc (- (* 2 pi) jdc)))
 (if (or (> (distance p1 p2) 4) (> (+ jdd jdc) 0.05)) (progn (command p1) (setq jdd 0) (setq p2 p1) ) (setq jdd (+ jdd jdc)) ) (setq j (+ j 1)) ) (setq p1 (nth (- nnn 1) db_zb)) (command p1) 
 (if( /= (/ obj_70 2) (/ obj_70 2.0) ) (command p0)) (command)

 (command"erase" obj "")
 (setq object (entget (entlast)))
 (if obj_la (setq object (subst (cons 8 obj_la) (assoc 8 object) object)) ) (if obj_lt (setq object (subst (cons 6 obj_lt) (assoc 6 object) object)) ) (if obj_color (setq object (subst (cons 62 obj_color) (assoc 62 object) object)) ) 
 (entmod object) (if (/= obj_xdata nil)(progn (setq xdata (list obj_xdata)) (setq nent (append object xdata)) (entmod nent) )) (if obj_40 (progn (command "pedit" (entlast) "w" obj_40 "x") ))
) 

 (defun plin2a() (command"pline" "near" p1 "w" wid wid) (setq i 1) (while (/= p1 nil) (initget 128) (setq p1 (getpoint p1 "\n/Undo退回/Point选择新点: ")) (if (= 'STR (type p1)) (progn (setq p1 (strcase p1)) (if (= p1 "U") (progn (if (> i 1) (setq i (- i 1))) (command p1)(setq p1 p2) );progn ) ) ;progn (progn (if (/= p1 nil) (setq p2 p1) ) (command p1) (print p1) (setq i (+ i 1)) ) ;progn ) ;if );while (setq object (entlast)) )
(defun jdjs() (setq jdzb nil) (setq q1 (nth (- i 1) zbb)) (while (and (= jdzb nil) ( (setq q2 q1) (setq q1 (nth i zbb)) (setq jd (angle q2 q1)) (setq p2 (polar p1 (+ jd (/ pi 2)) pzjl)) (setq p3 (polar p1 (- jd (/ pi 2)) pzjl)) (setq jdzb (inters q1 q2 p2 p3)) (setq i (+ i 1)) ) (setq i (- i 1)) )

举报回复喜欢评分

您需要登录后才可以回帖，登录或者注册

等高线圆滑拟合

最新喜欢：