[LISP]求助：帮我改一个展点程序

ivyej

各位大侠，帮我改下这个展点程序，本来是用来将注记展成点的，可是这个程序里面是注记左下角对齐，我想要中心对齐的。不知道我说的名不明白，我的MSN：ivyej11@hotmail，联系我吧。。。谢谢啦。

ivyej

请各位帮忙~~

sxyczpylhp

     ;LISP展点程序
     ;展1000点：在HP(AMD Athlon64  3000+  256MB)电胶上仅耗时0.142秒；
     ;在金利(Geleron(R) CPU 2.40GHz 256MB)电脑上耗时0.882秒
     ;数据文件格式为：每一点的数据（点号、X、Y、H）为一行，用逗号或空格作为分隔符，即
     ;点号1  X1  Y1 H1   或者 点号1,  X1,  Y1, H1
     ;点号2  X2  Y2 H2   或者 点号2,  X2,  Y2, H2
     ;点号3  X3  Y3 H3   或者 点号3,  X3,  Y3, H3
     ;......
     ;点号n  Xn  Yn Hn   或者 点号n,  Xn,  Yn, Hn1
(defun c:kszd ()
  (setq ff   (open (getfiled "请选择要展点的数据文件" "" "txt" 2) "r")
 fhb  nil
 t0   (getvar "cdate")
 cm   (getvar "cmdecho")
 os   (getvar "osmode")
 tcm1 "高程注记"
 tcm2 "点记"
  )
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (if (= (tblsearch "layer" tcm1) nil)
    (command "layer" "n" tcm1 "")
  )
  (if (= (tblsearch "layer" tcm2) nil)
    (command "layer" "n" tcm2 "")
  )
  (setq tap 1)
  (while (= tap 1)
    (Progn
      (setq n 1
     fhb nil

      )

      (while (< n 2001)
 (if (setq zb (read-line ff))
   (Progn
     (while (vl-string-search "," zb)
       (setq zb (vl-string-subst " " "," zb))
     )
     (setq zb  (read (strcat "(" zb ")"))
     ;zb  (list (list (nth 2 zb) (nth 1 zb)) (vl-princ-to-string  (last zb)));注记高程
    zb  (list (list (nth 2 zb) (nth 1 zb))
       (vl-princ-to-string (car zb))
        )   ;提示：注记点号请用该行
    fhb (append fhb (list zb))
     )
     (setq n (+ 1 n))
   )
   (setq n   2001
  tap 0
   )
 )
      )
      (setq t1 (getvar "cdate"))

      (setq zb (vl-sort fhb
   '(lambda (e1 e2) (< (car (car e1)) (car (car e2))))
        )
     x0 (car (car (car zb)))
     x1 (car (car (last zb)))
     zb (vl-sort
   fhb
   '(lambda (e1 e2) (< (cadr (car e1)) (cadr (car e2))))
        )
     y0 (cadr (car (car zb)))
     y1 (cadr (car (last zb)))
      )
      (command "zoom" "w" (list x0 y0) (list x1 y1))
      (setq t2 (getvar "cdate"))
      (foreach zb fhb
 (setq zfc (last zb)
     ;pt  (mapcar '+ (car zb) '(1.5 -1.25));这行改为如下
       pt  (car zb)
 )
 (entmake (list '(0 . "TEXT")
         '(100 . "AcDbEntity")
         '(100 . "AcDbText")
         '(62 . 1)
         '(40 . 2.5)
         '(50 . 0.0)
     ;(cons 8 tcm1)   (cons 1 zfc)  (cons 10 pt);这行改为如下
         (cons 8 tcm1)
         (cons 1 zfc)
         (cons 10 (mapcar '+ pt '(1.5 -1.25)))
   )
 )
 (entmake (list '(0 . "POINT")
         '(100 . "AcDbEntity")
         '(100 . "AcDbPoint")
         '(62 . 2)
         (cons 8 tcm2)
         (cons 10 pt)
   )
 )
      )
      (setq t3 (getvar "cdate")
     dt1 (* 1000000 (- t1 t0))
     dt2 (* 1000000 (- t3 t2))

      )
      (princ (strcat "读入数据共耗时："
       (rtos dt1 2 3)
       "秒   展点共耗时"
       (rtos dt2 2 3)
       "秒"
       "展点数："
       (itoa (length fhb))
       "个  每展一点耗："
       (rtos (/ dt2 (length fhb)) 2 10)
       "秒\n"
      )
      )

      (setq dt3 (* 1000000 (- t3 t0))

      )
      (princ (strcat "共耗时："
       (rtos dt3 2 3)
       "秒\n"

      )
      )
    )
  )
  (setvar "cmdecho" cm)
  (setvar "osmode" os)
  (close ff)
  (princ)
)

sxyczpylhp

这是改进的展点程序，要不展点过20000时太慢

SXYCZPYLHP山西榆次物测院人用半月试验成！！

sxyczpylhp

改进的原理是：分而治之，各个击破，分块解决！！！有同仁欢迎商讨！！

sxyczpylhp

本人邮箱sxyczpylhp@126.com

sxyczpylhp

20101016编成

 

chenxi665

skg123

sxyczpylhp 发表于 2010-10-21 22:06
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;;LISP展点程序 &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;;展1000点：在HP(AMD Athlon ...

标注的是点号，不是高程

太行隐士1992

sxyczpylhp 发表于 2010-10-21 22:09
这是改进的展点程序，要不展点过20000时太慢
SXYCZPYLHP山西榆次物测院人用半月试验成！！

山西省煤炭地质物探测绘院？