桥纵断面.lsp

画桥址断面的lisp源代码

  (foreach x ly (setq lyy (cons (- ply x) lyy)))
  (setq qll (append lzz lyy))
  (setq i 0 qlxx ())
  (foreach x qll (setq qlxx (cons (rtos x 2 3) qlxx)))
  (setq qll qlxx)
  (setq qlxx ())
  (setq n (length qll))
  (repeat n
    (setq qk1 (nth i qll))
    (if qk1 (setq qk (read qk1)))
    (setq qk2 (nth (+ i 1) qll))
    (if (/= qk1 qk2) (setq qlxx (cons qk qlxx)))
    (setq i (1+ i))
    )
  (setq qlxx (reverse qlxx))
  (setq qll qlxx)
  (setq qlxx ())
  (setq qll (reverse qll))
  (setq plc (- p2 p1))
  (setq plc (* plc bl))
  (setq px (+ plc (nth 0 p)))
  (setq pd (getpoint "\n输入桥中心放置点:"))
  (setq py (nth 1 pd))
  (setq py (+ py 20))
  (setq p0 (list px py))
  (setq p01 (polar p0 (* 0.5 pi) 10))
  (setq p0t (polar p0 (* 0.5 pi) 15))
  (setq p02 (polar p01 0 20) p03 (polar p01 pi 20))
  (command "color" 2)
  (command "line" p0 p01 "")
  (command "line" p02 p03 "")
  (command)
  (command "color" 7)
  (setq p22 (rem p2 1000))
  (setq p12 (/ p2 1000))
  (command "text" "m" p0t 4 0 (strcat "中心里程:" zx (rtos p12 2 0) "+"  (rtos p22 2 0)))
  (setq p0t1 (mapcar '+ p0 '(-2 5)))
  (setq p0t2 (mapcar '+ p0 '(2 5)))
  (setq kk (getstring "\n孔跨式样:"))
  (setq kk (strcase kk))
  (command "text" "mr" p0t1 4 0 kk)
  (command "text" "ml" p0t2 4 0 (strcat "桥全长:" (rtos ql 2 2) "m"))
  (setq ql1 () ql2 () ql3 () kk nil p0t1 nil p0t2 nil)
  (foreach x qll (setq ql1 (cons (- x p1) ql1)))
  (foreach x ql1 (setq ql2 (cons (* x bl) ql2)))
  (foreach x ql2 (setq ql3 (cons (+ x (nth 0 p)) ql3)))
  (setq py (- py 15) py1 (+ py 5))
  (setq pbzd (list 0 py1))
  (setq ql1 () ql2 ())
  (foreach x ql3 (setq ql1 (cons (list x py) ql1)))
  (foreach x ql3 (setq ql2 (cons (list x 30) ql2)))
  (setq ql1 (reverse ql1))
  (setq ql2 (reverse ql2))
  (foreach x ql1 (command "pline" x (mapcar '+ x '(0 -10)) ""))
  ;(foreach x ql2 (command "pline" x (mapcar '+ x '(0 -10)) ""))
  (setq twlc1 (apply 'min qll)
	twlc2 (apply 'max qll))
  (setq tw1 (rem twlc1 1000)
	tw2 (/ twlc1 1000))
  (setq twlc1 (strcat "台尾里程:" zx (rtos tw2 2 0) "+" (rtos tw1 2 2)))
  (setq tw1 (rem twlc2 1000)
	tw2 (/ twlc2 1000))
  (setq twlc2 (strcat "台尾里程:" zx (rtos tw2 2 0) "+" (rtos tw1 2 2)))  
  (setq twlcd1 (last ql1)
	twlcd2 (car ql1))
  (setq twz (mapcar '+ twlcd1 '(-10 -5))
	twlcd11 (mapcar '+ twlcd1 '(0 2))
	twlcd12 (mapcar '+ twlcd1 '(0 10))
	twlcd13 (mapcar '+ twlcd1 '(30 10))
	twlcd1z (mapcar '+ twlcd1 '(15 10)))
  (setq twy (mapcar '+ twlcd2 '(10 -5))
	twlcd21 (mapcar '+ twlcd2 '(0 2))
	twlcd22 (mapcar '+ twlcd2 '(0 10))
	twlcd23 (mapcar '+ twlcd2 '(-30 10))
	twlcd2z (mapcar '+ twlcd2 '(-15 10)))
  (command "pline" twlcd11 twlcd12 twlcd13 "")
  (command "pline" twlcd21 twlcd22 twlcd23 "")
  (command "text" "bc" twlcd1z 4 0 twlc1)
  (command "text" "bc" twlcd2z 4 0 twlc2)
  (command "insert" "d:\\xsy\\tz" twz "" "" "")
  (command "insert" "d:\\xsy\\ty" twy "" "" "")
  (command)
  (setq qll (reverse qll))
  (setq pd t i 0)
  (setq n (length ql1))
  (repeat n
    (setq pd (nth i ql1))
    (setq pd1 (nth (+ i 1) ql1))
    (setq pt (- (car pd) (car p)))
    (setq pt (/ pt bl))
    (setq pt (+ pt p1))
    (if (< pt 0) (setq pt (+ pt 1000)))
    (setq pt (rem pt 1000))
    (cond
      ((< pt 10) (setq pt (strcat "+00" (rtos pt 2 2))))
      ((< pt 100) (setq pt (strcat "+0" (rtos pt 2 2))))
      (t (setq pt (strcat "+" (rtos pt 2 2))))
      );;cond
    (setq pd0 (mapcar '+ pd '(0 3)))
    ;(if (/= pd pd1) (command "text" "ml" pd0 4 90 pt));;---------------
    (setq i (+ i 1))
    );;repeat
  ;;;
  (foreach x ql2 (command "pline" x (mapcar '+ x '(0 -10)) ""))
  (command)
  (setq ql2 (reverse ql2))
  (setq pd t i 0)
  (setq n (length ql2))
  (repeat n
    (setq pd (nth i ql2))
    (setq pd1 (nth (+ i 1) ql2))
    (setq pt (- (car pd) (car p)))
    (setq pt (/ pt bl))
    (setq pt (+ pt p1))
    (if (< pt 0) (setq pt (+ pt 1000)))
    (setq pt (rem pt 1000))
    (cond
      ((< pt 10) (setq pt (strcat "+00" (rtos pt 2 2))))
      ((< pt 100) (setq pt (strcat "+0" (rtos pt 2 2))))
      (t (setq pt (strcat "+" (rtos pt 2 2))))
      );;cond
    (setq pd0 (mapcar '+ pd '(-2 -5)))
    ;(setq pdy (mapcar '+ pd '(-6 -5)))
    (if (/= pd pd1) (command "text" "m" pd0 3 90 pt))
    (setq i (+ i 1))
    );;repeat
  ;;; 标
  (setq i 0)
  (setq ps1 (nth 0 ql1))
  (setq ps1 (mapcar '+ ps1 '(0 -5)))
  (repeat (- n 1)
    (setq p1 (nth i ql1))
    (setq p2 (nth (+ i 1) ql1))
    (if (/= p1 p2) (command "dim" "hor" p1 p2 ps1 "" "exit"))
    (setq i (+ i 1))
    )
  (setq n (length ql2) m (- n 4) i 2)
  (repeat m
    (setq pd (nth i ql2))
    (setq pdy (mapcar '+ pd '(3 -5)))
    (command "circle" pdy 2)
    (setq it (- i 1))
    (setq it (itoa it))
    (command "text" "m" pdy 3 0 it)
    (setq i (+ i 1))
    )
  (setq pd (mapcar '+ (nth 0 ql2) (nth 1 ql2)))
  (setq pd (mapcar '* pd '(0.5 0.5 0)))
  (setq pdy (mapcar '+ pd '(0 -5)))
  (command "circle" pdy 2)
  (command "text" "m" pdy 3 0 "0")
  (command)
  (setq pd (mapcar '+ (nth (- n 1) ql2) (nth (- n 2) ql2)))
  (setq pd (mapcar '* pd '(0.5 0.5 0)))
  (setq pdy (mapcar '+ pd '(0 -5)))
  (command "circle" pdy 2)
  (command "text" "m" pdy 3 0 (itoa (- n 3)))
  )
;;;------------------------------------------------------------
;(setq i nil p1 nil p2 nil n nil ps1 nil pd nil pd1 nil pt nil)
;;;;end kkbz-----------kkbz
;;;

;;;

;;;


;;;;**********
;;;;*************
;;;----------zdm
(defun zdm (/ fp fal str n true)
  (setq  f nil)
  (while (null f)
    (setq fname (getstring "\n 输入桥数据文件名<不含扩展名 .dat>:"))
    (if (null fname) (setq fname name)(setq name fname))
    (setq f (open (strcat fname ".dat") "r"))
    (setq fal (null f))
    (while fal
      (princ (strcat "\n File文件 " fname ".dat 未找到not found!!!"))
      (setq fal nil)
      );;;while1
    ); while2
  ;;(setq fname nil fal nil)
  ;;;;---------读文
  (setq  tmp () tmp1 ()  tmp2 () str t)
  (while  str
    (setq str (read-line f))
    (princ str)
    (if str (setq tmp (cons str tmp)))
    )
  (close f)
  (setq tmp (reverse tmp))
  (foreach x tmp (setq tmp1 (cons (pcc x) tmp1)))
  (foreach x tmp1 (setq tmp2 (cons (mapcar 'read x) tmp2)))
  (setq n 0 ytmp1 () xtmp1 () xytmp ())
  (foreach x tmp2 (setq xtmp1 (cons (nth 0 x) xtmp1)))
  (foreach x tmp2 (setq ytmp1 (cons (nth 1 x) ytmp1)))
  (setq xtmp1 (reverse xtmp1) ytmp1 (reverse ytmp1))
  )
;;;defun zdm人机交互数
;;;;;;
;;;;;;
(defun csf ()
  (setq gk nil bl nil blx nil bly nil)
  (command "limits" '(0 0) '(420 297) "zoom" "a")
  (setvar "angbase" 0)
  (setvar "angdir" 0)
  (setvar "aunits" 0)
  (setvar "celtype" "continuous")
  (setvar "osmode" 0)
  (setvar "plinewid" 0.0)
  (setq qiao (getstring "\n输入桥名:"))
  (setq zx (getstring "\n输入桥中心里程:"))
  (setq zx (strcase zx))
  (setq kong (getstring "\n 输入孔跨式样:"))
  (setq kong (strcase kong))
  (setq gk (getstring "\n里程冠号<dK>:"))
  (setq kk (getint "\n起点公里标:"))
  (if (null kk) (setq kk 0))
  (if (or (= (strlen gk) 0) (null gk)) (setq gk "DK"))
  (SETQ gk (STRCASE gk))
  (setq bl (getdist "\n输入横向比例值1:500 <5>:"))
  (if (null bl) (setq bl 5.0))
  (setq blx  (/ 10.0 bl))
  (SETQ BLy (getdist "\n输入纵向比例值1:500 <5>:"))
  (if (null bly) (setq bly blx) (setq bly (/ 10.0 bly)))
  )
;;;;; -------------zdm---------------主程序begin
(defun c:qzdm (/ blxs)
  (COMMAND "color" 4)
  (command "layer" "m" "zdm"  "")
  (command)
  (zdm)(csf)(hh)
  (setq blxs (/ bl 10.0))
  (SETVAR "DIMLFAC" blxs)
  ;;;;;画地面
  ;(setq xmin (car xtmp1) xmax (car xtmp1) ymin (car ytmp1))
  ;(foreach x xtmp1 (setq xmin (min xmin x)))
  ;(foreach x xtmp1 (setq xmax (max xmax x)))
  ;(foreach y ytmp1 (setq ymin (min ymin y)))
  (setq xmin (apply 'min xtmp1)
	xmax (apply 'max xtmp1)
	ymin (apply 'min ytmp1))
  (setq x (* blx xmin) y (* bly ymin))
  (setq x1 (rem x 50) y1 (rem y 50))
  (setq y (- y 50))
  (if (>= x1 10) (setq x1 (- x X1 50)) (setq x1 (- x x1 100)))
  (setq y1 (- y y1 50))
  (command "pline")
  (foreach x tmp2
    (progn (setq p0 (car x) p0 (* blx p0) p0 (- p0 x1))
      (setq p1 (last x) p1 (* bly p1) p1 (- p1 y1))
      (setq p (list p0 p1))
      (command p)
      )
    );;;
  (command)
  ;;;;;----------------画标高
  (COMMAND "COLOR" 7)
  (command "style" "xsy" "italc1,fs" 0 0.75 0 "n" "n" "n")
  (setq n 0)
  (setvar "osmode" 0)
  (setq zzz 10)
  (setq p0fx 25)
  (setq zzzx (- zzz 5))
  (setq zzzy (+ zzz 5))
  (setq zlx (- zzz 10))
  (setq zly (+ zzz 10))
  (setq endp (last xtmp1) endp (* blx endp) endp (- endp x1))
  (setq p0 (list p0fx zzz) p1 (list  endp zzz))
  (command "pline" p0 p1 "")
  (setq p0 (list p0fx zly) p1 (list endp zly))
  (command "pline" p0 p1 "")
  ;;;---画标高
  (COMMAND "color" 4)
  (setq p0 (list p0fx zlx) p1 (list endp zlx))
  (command "pline" p0 p1 "");;chang
  (setq p0 (list p0fx 30) p1 (list endp 30))
  (command "pline" p0 p1 "");;chang
  (setq p0 (list 25 0) p1 (list 25 30))
  (command "pline" p0 p1 "");;duan
  (setq p0 (list endp 0) p1 (list endp 30))
  (command "pline" p0 p1 "");;duan
  (setq p0 (list 50 zlx) p1 (list 50 (+ zlx 277)))
  (command "pline" p0 p1 "")
  (SETQ P11 (LIST 48 260))
  (COMMAND "pLINE" P1 P11 "")
  (setq y (+ y1 50) y (/ y bly))
  (setq p0 '(50 100) p1 '(47 100))
  (setq bli (/ 50 bly))
  (setq yh (rem ymin bli))
  (setq y (- ymin yh))
  (repeat 4
    (command "pline" p0 p1 "")
    (command "color" 7)
    (command "text" "br" p1  4.5 0 (rtos y 2 0))
    (setq y (+ y (/ 50 bly)))
    (setq p0 (list 50 (+ (last p0) 50)) p1 (list 47 (+ (last p1) 50)))
    (command "color" 4)
    );;;---------
  
  
  ;;;;---画里程
  (setq xz2 -1000)
  (command "color" 7)
  (command "text" "m" '(37.5 25) 4.5 0 "墩台位置及编号")
  (command "text" "m" '(37.5 15) 4.5 0 "地面标高")
  (command "text" "m" '(37.5 5) 4.5 0 "里  程")
  (setq number (length tmp1))
  (repeat number
    (setq tp (* blx (nth n xtmp1)))
    (setq tp (- tp x1))
    (setq p0 (list tp zlx))
    (setq p1 (list tp zly))
    (command "line" p0 p1)
    (command)
    (setq tpz (- tp 1.5))
    (setq kzp (list (- tpz 2.5) zzzx))
    (setq xtp (list tpz zzzx))
    (setq ytp (list tpz zzzy))
    (setq yz (nth n ytmp1))
    ;	(cond
    ;	((< yz 10) (setq yz (strcat "00" (rtos yz 2 2))))
    ;	((< yz 100) (setq yz (strcat "0" (rtos yz 2 2))))
    ;	(t (setq yz (rtos yz 2 2)))
    ;	);;cond
    (setq yz (rtos yz 2 2)) ;;biao gao
    
    (setq xz (nth n xtmp1))
    (setq xz1 (fix (/ xz 1000)))
    (setq xz1 (+ xz1 kk))
    (setq xz (rem xz 1000))
    (cond
      ((< xz 0) (setq xz (rtos xz 2 2)))
      ((< xz 10) (setq xz (strcat "+" "00" (rtos xz 2 2))))
      ((< xz 100) (setq xz (strcat "+" "0" (rtos xz 2 2))))
      (t (setq xz (strcat "+" (rtos xz 2 2))))
      );;cond
    (COMMAND "COLOR" 7)
    (if (/= xz1 xz2)
      (command "text" "m" kzp 3 90 (strcat Gk (itoa xz1))))
    (setq xz2 xz1);;;公里
    (command "text" "m" xtp 3 90 xz)
    (command "text" "m" ytp 3 90 yz)
    (setq n (1+ n))
    )
  (COMMAND "color" 4)
  (command "line" p0 p1 "")
  (setq KK (getstring "\n需要米厘格子吗？<Y/N>"))
  (if (null (read kk)) (setq kk "y"))
  (setq KK (strcase KK))
  (if (= KK "Y") (tk) (COMMAND));;
  )
;;;;;;;;;;;;;;
;;;
;;;图框程序(tk)
(defun tk (/ mxx mx mx0 p0 p1 tx ty t1 n)
  (setvar "ltscale" 1)
  (setq mx (- (* xmax blx) x1))
  (setq mxx (rem mx 50))
  (if (>= mxx 30)(setq mx (- mx mxx -100)) (setq mx (- mx mxx -50)))
  (setq mx0 (+ mx 110))
  (setq mx1 (+ mx 100))
  (setq p0 '(-25 -10) p1 (list mx0 287))
  (command "layer" "m" "tk"  "")
  (COMMAND "COLOR" 7)
  (command "rectang" p0 p1)
  (setq p0 '(0 0) p1 (list mx1 277))
  (COMMAND "COLOR" 2)
  (command "rectang" p0 p1)
  ;;----------
  (command "color" 9)
  (command "linetype" "s" "dot" "")
  ;;;;;;;;;;;;;
  (setq t1 10)
  (repeat 4
    (setq tx (list 0 t1) ty (list  (+ 20 mx) t1))
    (command "line" tx ty "")
    (setq t1 (+ t1 10))
    )
  (setq t1 (+ t1 10))
  (repeat 4
    (repeat 4
      (setq tx (list 0 t1) ty (list  mx1 t1))
      (command "line" tx ty "")
      (setq t1 (+ t1 10))
      )
    (setq t1 (+ t1 10))
    )
  (repeat 2
    (setq tx (list 0 t1) ty (list  mx1 t1))
    (command "line" tx ty "")
    (setq t1 (+ t1 10))
    )
  ;;;;
  (command "linetype" "s" "dot2" "")
  (setq  t1 50)
  (command "color" 93)
  (repeat 5
    (setq tx (list 0 t1) ty (list  mx1 t1))
    (command "line" tx ty "")
    (setq t1 (+ t1 50))
    )
  ;;;;;;;;;;
  (setq t1 100)
  (setq n (/ mx 50))
  (setq n (fix n))
  (repeat (- n 1)
    (setq tx (list t1 0) ty (list t1 277))
    (command "line" tx ty "")
    (setq t1 (+ t1 50))
    )
  (setq tx (list t1 40) ty (list t1 277))
  (command "line" tx ty "")
  (command "linetype" "s" "dot" "")
  (setq t1 10)
  (command "color" 9)
  (command)
  (repeat n
    (repeat 4
      (setq tx (list t1 0) ty (list t1 277))
      (command "line" tx ty "")
      (setq t1 (+ t1 10))
      )
    (setq t1 (+ 10 t1))
    )
  (setq tx (list t1 0) ty (list t1 277))
  (command "line" tx ty "")
  (repeat 2
    (repeat 4
      (setq tx (list t1 40) ty (list t1 277))
      (command "line" tx ty "")
      (setq t1 (+ t1 10))
      )
    (setq t1 (+ 10 t1))
    )
  (command "color" 7)
  (setq pc (list mx1 0))
  (command "insert" "d:\\xsy\\tb" pc "" "" "")
  (setq pc1 (mapcar '+ pc '(-40 28)))
  (setq pc2 (mapcar '+ pc '(-15 12)))
  (setq pc3 (mapcar '+ pc '(-15 14)))
  (setq pc4 (mapcar '+ pc '(-15 10)))
  (setq pstx (/ 1000 blx))
  (setq psty (/ 1000 bly))
  (initget 7 "1 2 3")
  (setq dw (getkword "选择1-桥址纵断面 2-水文断面 3-水面坡度图:"))
  (cond
    ((= dw "1") (command "text" "m" pc1 4 0  (strcat zx " " kong qiao "桥址纵断面")))
    ((= dw "2") (command "text" "m" pc1 4 0  (strcat zx " " kong qiao "水文断面")))
    ((= dw "3") (command "text" "m" pc1 4 0  (strcat zx " " kong qiao "水面坡度图")))
    )
  (cond
    ((= pstx psty) (command "text" "m" pc2 3.5 0 (strcat "1:" (rtos pstx 2 0))))
    ((/= pstx psty) (command "text" "m" pc3 3.5 0 (strcat "纵1:" (rtos psty 2 0)))
     (command "text" "m" pc4 3.5 0 (strcat "横1:" (rtos pstx 2 0))))
    )
  (command "layer" "m" "0"  "")
  (command "linetype" "s" "continuous" "")
  ;;;
  )
;;;end of file
(grtext -1 "本程序由谢少勇编制")
(print)
(princ "以 qzdm qhdm hddm 3mx kkbz sJx1 sc ucso ucs1 cx mz")
(print)
(princ  "sw tp lc1 lc2 bg1 bg2 bz bzd bz2 bz5 dm pd pd1 tz ty运行程序")(PRINC)