界面
dlgHDM : dialog {label = "选择输出横断面";
: row {
: column {
: row {
: text_part {label = "可选桩号";}
: text_part {key = "text1";}
}
: list_box {key="allZH";width=30;height=20;tabs="20";multiple_select=true;}
}
: column {
spacer;
: button {label = ">>";key = "addall";}
: button {label = ">";key = "addsel";}
spacer;
: button {label = "<";key = "delsel";}
: button {label = "<<";key = "delall";}
spacer;
}
: column {
: row {
: text_part {label = "输出桩号";}
: text_part {key = "text2";}
}
//: text_part {key = "text2";}
: list_box {key="selZH";width=30;height=20;tabs="20";multiple_select=true;}
}
}
: boxed_row {label = "输出的比例";
: edit_box {label = "横向比例";key = "hxbl";}
: edit_box {label = "竖向比例";key = "sxbl";}
}
: boxed_row {label = "输出的网格距离(单位mm)";
: edit_box {label = "横向";key = "hxwg";}
: edit_box {label = "竖向";key = "sxwg";}
}
: row {
: button {label = "浏览";key = "selfile";}
ok_cancel;
}
}
dlgZDM : dialog {label = "选择输出纵断面";
: row {
: column {
: text_part {key = "text1";}
: list_box {key="allZH";width=30;height=20;tabs="20";multiple_select=true;}
}
: column {
spacer;
: button {label = ">>";key = "addall";}
: button {label = ">";key = "addsel";}
spacer;
: button {label = "<";key = "delsel";}
: button {label = "<<";key = "delall";}
spacer;
}
: column {
: text_part {key = "text2";}
: list_box {key="selZH";width=30;height=20;tabs="20";multiple_select=true;}
}
}
: boxed_row {label = "输出的比例";
: edit_box {label = "横向比例";key = "hxbl";}
: edit_box {label = "竖向比例";key = "sxbl";}
}
: boxed_row {label = "输出的网格距离(单位mm)";
: edit_box {label = "横向";key = "hxwg";}
: edit_box {label = "竖向";key = "sxwg";}
}
: row {
: button {label = "浏览";key = "selfile";}
ok_cancel;
}
}
(defun c:dmcl (/ dwg-flname dwg-flpath sv_filename exit_ ph pzb ldm rdm l&rdm zzlen
p1 p1h p1zb zz zzh zzzb ang i j str str1 str2 str3 lczh a b
*merrmsg*)
(defun *merrmsg* (msg)
(princ msg)
(setq *error* m:err m:err nil)
(princ)
)
(setq m:err *error* *error* *merrmsg*
dwg-flname (getvar "dwgname")
dwg-flpath (getvar "dwgprefix")
sv_filename (strcat dwg-flpath (substr dwg-flname 1 (- (strlen dwg-flname) 3)) "dm")
zz t
)
(if (not duanmiancanshu)(progn
(initget "1 2")
(if (not (setq a (getkword "\n断面主要测量方式:[1--平距高差测量/2--高程点测量](2)")))
(setq a "2")
)
(setq duanmiancanshu (list (atoi a)))
))
(while (and zz
(setq zzlen (getdist "\n输入桩号:"))
(<= 0 zzlen)
)(setq zzlen (float zzlen))
(setq ph (fix (/ zzlen 1000.00))
a (strcat "000" (itoa (- (fix zzlen) (* ph 1000))))
b (- zzlen (fix zzlen))
i 0 ldm nil rdm nil
)
(if (equal 0 b 0.0005)
(setq lczh (strcat "K" (itoa ph) "+" (substr a (- (strlen a) 2)) ".00"))
(setq lczh (strcat "K" (itoa ph) "+" (substr a (- (strlen a) 2)) "." (substr (rtos b) 3)))
)
(princ (strcat "\n该里程桩号=" lczh))
(if (setq zz (getpoint "\n输入中桩点:"))(progn
(setq zzh (caddr zz) zzzb (list (car zz) (cadr zz) 0))
(if (or (>= 0 zzh) (<= 9000 zzh))(progn
(initget 7)
(setq zzh (getreal "\n\t高程无效.用键盘输入该点高程:"))
)(princ (strcat "\t\t该点高程=" (rtos zzh 2 3) ".")))
(repeat 2
(if (= 2 (car duanmiancanshu))(progn
(if (= 0 i)
(setq l&rdm "左"
str1 (strcat "\n 桩号" lczh "断面左. 第")
str2 (strcat "\n 桩号" lczh "断面左. 重新第")
str3 "[P--平距高差输入法/回车输右断面]:"
)
(setq l&rdm "右"
str1 (strcat "\n 桩号" lczh "断面右. 第")
str2 (strcat "\n 桩号" lczh "断面右. 重新第")
str3 "[P--平距高差输入法/回车结束输入]:"
)
)
(setq p zzzb ph zzh pzb zzzb ang nil exit_ nil j 0 str str1)
(while (not exit_)
(initget "P")
(if (setq p1 (getpoint pzb (strcat str (itoa (setq j (1+ j))) "个输入测点 " str3)))
(if (listp p1)
(progn
(setq p1h (caddr p1) p1zb (list (car p1) (cadr p1) 0))
(if (or (>= 0 p1h) (<= 9000 p1h))(progn
(initget 7)
(setq p1h (getreal "\n\t\t高程无效.用键盘输入该点高程:"))
)(princ (strcat "\t\t该点高程=" (rtos p1h 2 3) ".")))
(setq pj (distance p1zb pzb) gc (- p1h ph))
(princ (strcat "\t与上一点: 平距=" (rtos pj 2 2) "\t高差=" (rtos gc 2 2)))
(if (= "左" l&rdm)
(setq ldm (cons (list pj gc) ldm))
(setq rdm (cons (list pj gc) rdm))
)
(setq ang (angle pzb p1zb) ph p1h pzb p1zb p p1zb)
)
(progn
(if (and (setq pj (getdist pzb "\n\t输入平距(回车退出)="))
(setq gc (getreal "\t\t键入高差(回车退出)=")))(progn
(if (= "左" l&rdm)
(setq ldm (cons (list pj gc) ldm))
(setq rdm (cons (list pj gc) rdm))
)
(if (not ang) (setq ang (getangle pzb "\n输入下一点方向(无下一点可回车退出):")))
(if ang
(setq ph (+ ph gc) pzb (polar pzb ang pj) p pzb)
)
)(setq j (1- j) str str2))
)
)
(setq exit_ t)
);(if (setq p1 (getpoint p "\n输入点 [P--平距高差输入法]:"))
)
(setq i (1+ i))
)
(progn
(if (= 0 i)
(setq l&rdm "左"
str1 (strcat "\n 桩号" lczh "断面左. 第")
str2 "(回车输右断面):"
)
(setq l&rdm "右"
str1 (strcat "\n 桩号" lczh "断面右. 第")
str2 "(回车结束输入):"
)
)(setq exit_ nil j 1)
(while (not exit_)
(princ (strcat str1 (itoa j) "段"))
(if (and (setq pj (getdist (strcat "\n输入平距" str2 "=")))
(setq gc (getreal (strcat "\t键入高差" str2 "="))))(progn
(if (= "左" l&rdm)
(setq ldm (cons (list pj gc) ldm))
(setq rdm (cons (list pj gc) rdm))
)(setq j (1+ j))
)
(progn
(setq exit_ t i (1+ i))
))
)
))
);(repeat 2
(if (setq i (open sv_filename "a"))(progn
(princ (strcat "\n/" lczh "," (rtos zzh 2 3) "\n") i)
;;;高差
(foreach j ldm (progn
(setq p (strcat " " (rtos (cadr j) 2 2)) p1 (strlen p) p (substr p (- p1 6)))
(princ (strcat " " p) i)
))
(princ " /" i)
;;;高差
(foreach j (reverse rdm)
(setq p (strcat " " (rtos (cadr j) 2 2)) p1 (strlen p) p (substr p (- p1 6)))
(princ (strcat " " p) i)
)(princ "\n" i)
;;;平距
(foreach j ldm (progn
(setq p (strcat " " (rtos (car j) 2 2)) p1 (strlen p) p (substr p (- p1 6)))
(princ (strcat " " p) i)
))
(princ " /" i)
;;;平距
(foreach j (reverse rdm)
(setq p (strcat " " (rtos (car j) 2 2)) p1 (strlen p) p (substr p (- p1 6)))
(princ (strcat " " p) i)
);(princ "\n\n" i)
(close i)
))
))
)(princ "\t\t=====退出=====")
(princ)
)
(defun c:hdm ( / dmlist ZHlist
a b c i dcl_id oldos
allZHP selZHP ZHl ZHr
showtext showZHlist addordelZH
selDMfile pickZHlist showZHcontrol
DrawHMGrid readdmdata *merrmsg*
)
(defun *merrmsg* (msg)
(if oldos (setvar "osmode" oldos))
(princ msg)
(setq *error* m:err m:err nil)
(princ)
)
(setq m:err *error* *error* *merrmsg*)
;绘纵横断方格网
;方格网左下角坐标lbp 水平比例hbl 水平最小hs 水平最大hd 竖直比例vbl 竖直最小vs 竖直最大vd
(defun DrawHDMGrid (lbp hbl hs hd hwj vbl vs vd vwj inzz texth /
a b c d i p xdjl hsd vsd hsfbl vsfbl texth hl vl)
;相对距离xdjl 水平方向差值hsd 竖直方向差值vsd 水平方向缩放比例hsfbl 竖直方向缩放比例vsfbl
;网距hwj vwj
;CAD图形的尺寸单位为mm,断面测量的单位为m,故需按绘图比例进行比例缩放
;然后按绘图的网距大小进行取整
(setq hsfbl (/ 1000 hbl)
;横向取整
;横向取整
;竖向取整
;竖向取整
)
;修定边距
(if (< a hs)(setq hs (- hs hwj)))
(if (> b hd)(setq hd (+ hd hwj)))
(if (< c vs)(setq vs (- vs vwj)))
;(if (< (abs hs) hd)(setq hs (* -1 hd))(setq hd (* -1 hs)))
(if (> d vd)(setq vd (+ vd vwj)))
(setq hsd (- hd hs)
vsd (- vd vs)
xdjl (strcat "@0," (rtos vsd))
p (polar lbp (* 1.5 pi) (* 1.5 texth))
i -1
)
;画竖线
(while (<= (setq a (* hwj (setq i (1+ i)))) hsd)
(command "line" (polar lbp 0 a) xdjl "")
(if (= 0 i)
(command "chprop" (entlast) "" "color" "white" "")
(command "chprop" (entlast) "" "color" "blue" "")
)
(command "line" (polar lbp 0 a) "@0,3" "" "chprop" (entlast) "" "color" "white" "")
(if (or (= 0 (rem i 2)) (= a hsd) (= 0 (+ hs a)))(progn
(if (= 0 (+ hs a))(setq b "中桩")(setq b (itoa (abs (/ (+ hs a) hsfbl)))))
(command "text" "j" "tc" (polar p 0 a) texth 0 b
"chprop" (entlast) "" "color" "white" ""
)
))
)
(command "text" "j" "tc" (polar (polar p 0 (/ hsd 2.0)) (* 1.5 pi) (* 2.0 texth)) texth 0 (strcat "比例1:" (itoa hbl))
"chprop" (entlast) "" "color" "white" ""
)
(setq xdjl (strcat "@" (rtos hsd) ",0")
p (polar lbp pi (* 0.5 texth))
i -1
)
;画水平线
(while (<= (setq a (* vwj (setq i (1+ i)))) vsd)
(command "line" (polar lbp (/ pi 2.0) a) xdjl "")
(if (= 0 i)
(command "chprop" (entlast) "" "color" "white" "")
(command "chprop" (entlast) "" "color" "blue" "")
)
(command "line" (polar lbp (/ pi 2.0) a) "@3,0" "" "chprop" (entlast) "" "color" "white" "")
(setq c (rtos (/ (+ vs a) vsfbl) 2 0)
d (caadr (textbox (list (cons 1 c))))
)
(if (or (= 0 (rem i 2)) (= a vsd))
(command "text" "j" "mr" (setq b (polar p (/ pi 2.0) a)) texth 0 c
"chprop" (entlast) "" "color" "white" ""
)
)
)
(command "text" "j" "bc" (polar (polar p (* 0.5 pi) (/ vsd 2.0)) pi (+ texth d)) texth 90 (strcat "比例1:" (itoa vbl))
"chprop" (entlast) "" "color" "white" ""
)
;返回最后绘网格的参数,画断面的折线需根据该参数进行定位
(list hs hd vs vd (polar lbp 0 (/ hsd 2.0)))
)
(defun readdmdata (filename / f a b c i lefth righth leftp rightp zhao zhongzh)
;左高差表lefth 右高差表righth 左平距表leftp 右平距表rightp 桩号zhao 中桩高zhongzh
(setq dmlist nil)
(if (setq f (open filename "r"))(progn
(while (setq a (read-line f))
(cond
((or (not a) (= "" a)))
((= "/" (substr a 1 1));(wcmatch a "/*,*")
(if (and zhao zhongzh)
(setq dmlist (cons (list zhao zhongzh lefth righth leftp rightp) dmlist))
)
(setq a (fg a '("/" ",") nil)
zhao (car a)
zhongzh (atof (cadr a))
i 0 lefth nil righth nil leftp nil rightp nil
)
(if (not zhongzh)(setq zhongzh 0))
)
((wcmatch a "*/*")
(setq a (fg a '("/") t))
(if (= 0 i)
(setq lefth (fg (car a) '(" ") nil)
righth (fg (cadr a) '(" ") nil)
)
(setq leftp (fg (car a) '(" ") nil)
rightp (fg (cadr a) '(" ") nil)
)
)
(setq i (1+ i))
)
)
)(close f)
(if (and zhao zhongzh)
(setq dmlist (cons (list zhao zhongzh lefth righth leftp rightp) dmlist))
)
(setq dmlist (reverse dmlist))
))
) ;end read_set
(defun drawhdm (xbl ybl xwg ywg / sellist
xs xd ys yd leftlasty leftlastx P p0 startp
i texth
)
;水平最小xs 水平最大xd 竖直最小ys 竖直最大yd
; (if (< hbl vbl)
; (setq texth (/ 300 vbl))
; (setq texth (/ 300 hbl))
; )
(foreach a dmlist;sellist
;计算高差范围ys-yd 左右断面的边距范围xs-xd
(setq xs 0 xd 0 ys 0 yd 0 c 0)
(foreach b (reverse (nth 2 a))
(setq c (+ c (atof b)))
(if (< yd c)(setq yd c))
(if (> ys c)(setq ys c))
)
(setq leftlasty (* c (/ 1000 ybl)) c 0)
(foreach b (nth 3 a)
(setq c (+ c (atof b)))
(if (< yd c)(setq yd c))
(if (> ys c)(setq ys c))
)
(setq c 0)
(foreach b (reverse (nth 4 a))
(setq c (+ c (atof b)))
)
(setq leftlastx (* c (/ 1000 xbl)) xs (* -1 c) c 0)
(foreach b (nth 5 a)(setq c (+ c (atof b))))
(setq xd c)
;(if (< (abs xs) xd)(setq xs (* -1 xd))(setq xd (* -1 xs)))
(setvar "cmdecho" 0)
(setq oldos (getvar "osmode"))(setvar "osmode" 0)
(setq p (getpoint "\n左下角位置:"))
;绘网格
(setq c (DrawHDMGrid p xbl xs xd xwg ybl ys yd ywg (cadr a) texth))
(setq pzz (polar p 0 (abs (car c))) ;中桩位置
p0 (polar (last c) (* 0.5 pi) (+ ywg (- (cadddr c) (caddr c))))
pzz (polar pzz (/ pi 2.0) (- (* (/ 1000 ybl) (cadr a)) (caddr c)))
)
;左断面的最末端位置
(setq startp (list (- (car pzz) leftlastx) (+ (cadr pzz) leftlasty))
i 0
)
(command "pline" startp)
(foreach b (nth 2 a) ;左
(setq d (* (atof (nth i (nth 4 a))) (/ 1000 xbl))
b (* -1 (atof b) (/ 1000 ybl))
b (strcat "@" (rtos d) "," (rtos b))
i (1+ i)
)
(command b)
)
b (strcat "@" (rtos d) "," (rtos b))
i (1+ i)
)
(command b)
)
(command "" "chprop" (entlast) "" "color" "white" "")
(setvar "osmode" oldos)
(setvar "cmdecho" 1)
)
)
;----------------showtext-------------------------------------------
(defun showtext ($key / a)
(if (or (= "allZH" $key) (= "all" $key))(progn
(if allZHP
(setq a (strcat "选" (itoa (length allZHP)) "/"))
(setq a "未选/")
)
(if ZHl
(setq a (strcat a "总" (itoa (length ZHl))))
(setq a (strcat a "无"))
)
(set_tile "text1" a)
))
(if (or (= "selZH" $key) (= "all" $key)) (progn
(if selZHP
(setq a (strcat "选" (itoa (length selZHP)) "/"))
(setq a "未选/")
)
(if ZHr
(setq a (strcat a "总" (itoa (length ZHr))))
(setq a (strcat a "总0"))
)
(set_tile "text2" a)
))
)
;----------------showZHlist-------------------------------------------
(defun showZHlist (list1 addordel $key / a)
(cond
((= "del" addordel)(start_list $key))
((= "add" addordel)(start_list $key 2))
)
(foreach a list1 (add_list (strcat (car a) "\t" (rtos (cadr a)))))
(end_list)
)
;----------------addordelZH-------------------------------------------
(defun addordelZH (in / a b $key new)
(cond
((> 3 in)
(if (= 1 in) ;all
(setq b ZHl)
(foreach a allZHP (setq b (cons (nth a ZHl) b)))
)
(foreach a ZHlist
(if (or (member a b) (member a ZHr))
(setq new (cons a new))
)
)
(setq ZHr (reverse new) new nil)
(foreach a ZHl (if (not (member a b))(setq new (cons a new))))
(setq ZHl (reverse new))
)
((< 2 in)
(if (= 4 in)
(setq b ZHr) ;all
(foreach a selZHP (setq b (cons (nth a ZHr) b)))
)
(foreach a ZHlist
(if (or (member a b) (member a ZHl))
(setq new (cons a new))
)
)
(setq ZHl (reverse new) new nil)
(foreach a ZHr (if (not (member a b))(setq new (cons a new))))
(setq ZHr (reverse new))
)
)
(setq allZHp nil selZHp nil)
(showZHlist ZHl "del" "allZH")
(showZHlist ZHr "del" "selZH")
(showZHcontrol nil "allZH")
(showZHcontrol nil "selZH")
(showtext "all")
)
;----------------pickZHlist-------------------------------------------
(defun pickZHlist ($key in / a showi)
(setq showi (get_tile $key))
(if (and showi (/= "" showi))(progn
(setq showi (fg showi '(" ") nil))
(foreach a showi (setq showi (subst (atoi a) a showi)))
))
(if (= "allZH" $key)
(setq allZHp showi)
(setq selZHp showi)
)
(showtext $key)
(if in (showZHcontrol showi $key))
)
;----------------showZHcontrol-------------------------------------------
(defun showZHcontrol (ina $key /)
(if (not ina)
(cond;无效
((= "allZH" $key)(mode_tile "addsel" 1))
((= "selZH" $key)(mode_tile "delsel" 1))
((= "all" $key)(mode_tile "addsel" 1)(mode_tile "delsel" 1))
)
(cond
((= "allZH" $key)(mode_tile "addsel" 0))
((= "selZH" $key)(mode_tile "delsel" 0))
((= "all" $key)(mode_tile "addsel" 0)(mode_tile "delsel" 0))
)
)
(if (= 0 (length ZHl))(mode_tile "addall" 1) (mode_tile "addall" 0))
(if (= 0 (length ZHr))(mode_tile "delall" 1) (mode_tile "delall" 0))
)
;----------------selDMfile-------------------------------------------
(defun selDMfile ( / a b i)
(if (setq a (getfiled "选择" "" "dm" 0))(progn
(showZHlist nil "del" "allZH")
(showZHlist nil "del" "selZH")
(readdmdata a)
(setq i 0 ZHlist nil)
(foreach b dmlist (setq ZHlist (cons (list (car b) (cadr b) i) ZHlist) i (1+ i)))
(setq ZHlist (reverse ZHlist) ZHl ZHlist ZHr nil)
(showZHlist ZHl "del" "allZH")
(showZHcontrol nil "all")
(showtext "all")
))
)
;----------------main-------------------------------------------
)
(if (setq a (getfiled "选择横断面数据文件" b "dm" 8)) (progn
(if (not (wcmatch a "*\\*"))(setq a (strcat b a)))
(princ (strcat "\n" a))
(readdmdata a)
))
(foreach b dmlist (setq ZHlist (cons (list (car b) (cadr b) i) ZHlist) i (1+ i)))
(setq ZHlist (reverse ZHlist) ZHl ZHlist);
(if (not (setq dcl_id (load_dialog "断面.dcl")))(exit))
(if (not (new_dialog "dlgHDM" dcl_id))(exit))
(set_tile "hxbl" (itoa hbl))
(set_tile "sxbl" (itoa vbl))
(set_tile "hxwg" (itoa hwg))
(set_tile "sxwg" (itoa vwg))
(showZHlist ZHl "del" "allZH")
(showZHcontrol nil "all")
(showtext "all")
(action_tile "allZH" "(pickZHlist $key t)")
(action_tile "selZH" "(pickZHlist $key t)")
(action_tile "addall" "(addordelZH 1)")
(action_tile "addsel" "(addordelZH 2)")
(action_tile "delsel" "(addordelZH 3)")
(action_tile "delall" "(addordelZH 4)")
(action_tile "hxbl" "(setq hbl (atoi (get_tile $key)))")
(action_tile "sxbl" "(setq vbl (atoi (get_tile $key)))")
(action_tile "hxwg" "(setq hwg (atoi (get_tile $key)))")
(action_tile "sxwg" "(setq vwg (atoi (get_tile $key)))")
(action_tile "selfile" "(selDMfile)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cencel" "(done_dialog 0)")
(if (= 1 (start_dialog))(progn
(setq ZHlist nil)
(foreach a ZHr (setq ZHlist (cons (nth (last a) DMlist) ZHlist)))
(setq DMlist (reverse ZHlist) ZHlist nil ZHl nil ZHr nil)
(drawhdm hbl vbl hwg vwg)
))
(princ)
)
(princ "\n断面测量dmcl,绘制横断面图hdm，绘制纵断面图zdm.")
(PRINC)
posted on 2008-03-11 13:41
深藏记忆 阅读(548)
评论(0) 编辑 收藏 所属分类:
Vlisp之韵