地形图上的植被符号自动避让程序

caddog 发表于 2012-5-20 23:15:25

本帖最后由 caddog 于 2012-5-20 23:20 编辑

有地形图测绘经验的朋友有没有这样的体会：对于纯地形区域，在内业整饰时很大一部分时间都花在调整植被符号和高程注记对等高线等地物的压盖、遮挡上。基于此，编写了这么一个小程序，欲实现对植被符号位置的自动调整。以便大家从繁琐的重复劳动中解放出来。
程序的原理是以植被符号（图块）的插入点为中心，在0、45、90、135、180、225、270、315度共八个方向上按用户指定的移动步长及限定的移动距离求出一系列备用点，再分别用这些点结合植被符号（图块）的BOUNDINGBOX（我称为外接矩形好不好？）判定是否有地物被压盖。若无，则将图块移至此位置，若全都有压盖，则不处理。
程序执行的效果尚可。就是速度有点见不得人。主要慢在判断是否有压盖上。我使用的方法是用图块的外接矩形作为范围进行“窗交”或“圈交”选择，看能不能选到图元，若不能，则说明没有压盖了。我也知道这样的方式很慢，但苦于没有更好的方法来实现。还请各位高手不吝赐教！
下面上代码：

;;;---------------------------------------------------
;;;函数:围绕指定的基点,以指定的角度旋转点集
;;;---------------------------------------------------
(defun move:Rotate(pts basePoint rad / x)
(mapcar '(lambda(x)
      (polar basePoint (+ rad (angle basePoint x)) (distance basePoint x)))
   pts)
)
;;;---------------------------------------------------
;;;函数:用于创建图块的BOUNDBOX四个角点相对于其插入点
;;; 的偏移量表.
;;;ps 拣懒,没传递参数
;;;---------------------------------------------------
(defun move:bulidEnRota (/ MAXPOINT MINPOINT PT-REC X)
(if (/= 0 enRo) ;_如果有旋转
(vla-put-Rotation (vlax-ename->vla-object en1) 0) ;_先将图块转回0度来
)
;;求boundbox
(vla-GetBoundingBox (vlax-ename->vla-object en1) 'minpoint'maxpoint)
(setq minpoint (3DPOINT->2DPOINT (vlax-safearray->list minpoint))
maxpoint (3DPOINT->2DPOINT (vlax-safearray->list maxpoint)))
;;把块旋转回去得
(vla-put-Rotation (vlax-ename->vla-object en1) enRo)
;;下面求出四个角点相对于插入点之增量
(setq pt-rec (list minpoint (list (car minpoint)(cadr maxpoint)) maxpoint (list (car maxpoint)(cadr minpoint))))
(setq pt-rec
(mapcar '(lambda(x)
         (list (- (car x)(car inspt))(- (cadr x)(cadr inspt)))
         )
      pt-rec))
;;将增量表放入一个表中,用块名进行索引
(setq #EnRota (cons (cons (cdr(assoc 2 ent1)) pt-rec) #EnRota))
)

;;;-------------------------------------------------------------------------
;;;程序功能: 移动植被符号(形和块都可以),以使其不压盖地物(主要是针对等高线)
;;;       程序将以用户给定的距离在0/45/90/135/180/225/270/315度共8个方向上
;;;       依次移动植被并检查是否存在压盖情况.若无,则将植被符号移至此新坐标,
;;;       若在用户限定条件内都存在压盖,则不处理.
;;;判断是否压盖的方法也许不是很合理,速度很慢.2000多个点要花去7/8分钟....
;;;不知道还有没有更加科学的方法呢?
;;;-------------------------------------------------------------------------

(defun c:MPlant(/       $LEN %LEN #LI    #MOVE    #VALUEMAX
      #VALUEMIN    %ID ANGL    EN1    ENLAYER
      ENT1 INSPT MAXPOINT MINPOINT NEWPT    SS1
      STEP STEPMAX STEPMOVE #ENROTA #ROTA ENLAYER ENNAME ENRO PTS-REC)
;;移动步长、移动范围
(setq #EnRota nil);_此表记录所有块的boundingBox矩形四个角点相对于其插入点的增量
(setq step (getreal "\n请输入移动步长(米)<0.1>"))
(if (not step)(setq step 0.1))
(setq stepMax (getreal "\n请输入最大可移动距离(米)<1.5>"))
(if (not stepMax)(setq stepMax 1.5))
(setq stepMove step
angl 0)

(setq ss1 (ssget '((0 . "insert,shape")))) ;_选取块/形
(setq %id0
%len (sslength ss1);_图元个数
$len (itoa %len))
(repeat %len
(setq en1 (ssname ss1 %id);_图元名
   %id (1+ %id))
(setq ent1    (entget en1)
   enLayer (cdr (assoc 8 ent1));_获取图层
   enRo    (cdr (assoc 50 ent1));_获取旋转角度
   enName(cdr (assoc 2 ent1));_获取块名
   insPt (3DPOINT->2DPOINT (cdr (assoc 10 ent1))));_获取插入点
;;;看#EnRota中是否有定义,若无则需要调用程序处理
;;;即使没有旋转,也应该求出其四个角点之增量不是?
(if (not (setq #Rota (cdr (assoc enName #EnRota))))
;_若有定义,则直接返回表.若无,则调用函数建立之
(progn
   (move:bulidEnRota)
   (setq #Rota (cdr (assoc enName #EnRota)))
   )
   );_end if

;;下面根据图块的插入点求出其BOUNDingBOX的四个角点坐标
(setq pts-Rec (mapcar '(lambda(x)
            (list
               (+ (car x)(car insPt))
               (+ (cadr x)(cadr insPt))
               0.0
               )
            )#Rota))
;;移动视口至图块所在位置并适当缩放.
;;因为在调试时发现把视口缩得太小,有些会出现漏移,可能是由于做"_C"选择时出现了问题.故改为如此
(vla-ZoomCenter
   (acad-object)
   (vlax-3d-point insPt)
   (vlax-make-variant (* 5 stepMax) vlax-vbDouble)
   )
(if (ssget "_c"
      (nth 0 pts-Rec)
      (nth 2 pts-Rec)
      (list '(-4 . "<NOT")
         (cons 8 enLayer)
         '(-4 . "NOT>")));_本图层的东东不选(为了防止选中自身)
   ;;若有压盖,则处理
   (progn
;;开始求取移动的坐标.根据移动步长及移动范围,求八个方向上的坐标.
(setq #move nil
      #li nil)
(repeat (fix (/ stepMax step))
   (repeat 8
   (setq #li (cons (polar insPt angl stepMove) #li))
   (setq angl (+ angl (/ pi 4.0)))
   ) ;_end repeat fix...
   (setq stepMove (+ stepMove step)
   #move (cons (REVERSE #li) #move)
   angl 0
   #li nil
   ) ;_end setq
   ) ;_end repeat 8
(setq #move (REVERSE #move)
      stepMove step)

;;根据图块的旋转角度求对其BOUNDBOX进行旋转
;;点集已经有了,下面就是循环/框选看有没有压盖,如果是旋转过的块,要用CP的方式来进行
;;可以使用vl-some函数吧
(setq newpt nil)
(if (= enRo 0.0)
   (setq newPt
      (vl-some
         '(lambda (x)
         ;;求出bound坐标
         (setq pts-Rec (mapcar '(lambda(y)
            (list
            (+ (car y)(car x))
            (+ (cadr y)(cadr x))
            0.0
            )
            )#Rota))
         (if
         ;;选择时排除了块所在的图层
         (not (ssget "c"
                  (nth 0 pts-Rec)
                  (nth 2 pts-Rec)
                  (list '(-4 . "<NOT")
                     (cons 8 enLayer)
                     '(-4 . "NOT>"))))
            x
            nil
            )
         )
         (apply 'append #move)
         ) ;_end vl-some
      );_end progn
   ;;否则,即旋转角度不为0
   (progn
   (setq newPt
      (vl-some
         (function(lambda (x)
         ;;求出bound坐标
         (setq pts-Rec (mapcar '(lambda(y)
            (list
            (+ (car y)(car x))
            (+ (cadr y)(cadr x))
            0.0
            )
            )#Rota))
         (setq pts-Rec (move:Rotate pts-Rec x enRo));_求出旋转后的boundingBox
         (if
         ;;选择时排除了块所在的图层,选择时用的"圈交"方式
         (not (ssget "_cp"
                  pts-Rec
                  (list '(-4 . "<NOT")
                     (cons 8 enLayer)
                     '(-4 . "NOT>"))))
            x
            nil
            )
         ));_end function
         (apply 'append #move)
         ) ;_end vl-some
      )
   );_end progn
   );_end if =0 rota


;_end setq
;;如果有符合要求的点,则将块移到该点
(if newpt
   (entmod (subst (cons 10 newpt) (assoc 10 ent1) ent1))
   )
) ;_end progn 若有压盖则处理
   ) ;_end if 若有....

(setvar "modemacro" (strcat "正处理: " (itoa %id) "/" $len))

) ;_end repeat
(setvar "modemacro" "")
(princ "\n完成!")
(princ)

) ;_end defun

还用到了几个CAD自带帮助里的函数，一起上来哈：

(VL-LOAD-COM)
(SETQ *acad-object* nil)    ; Initialize global variable
(DEFUN acad-object()
(COND (*acad-object*)          ; Return the cached object
(T
(SETQ *acad-object* (VLAX-GET-ACAD-OBJECT))
)
) ;_ 结束cond

) ;_ 结束defun

(SETQ *active-document* nil)    ; Initialize global variable
(DEFUN active-document ()
(COND (*active-document*)    ; Return the cached object
(T
(SETQ *active-document* (VLA-GET-ACTIVEDOCUMENT (acad-object)))
)
) ;_ 结束cond

) ;_ 结束defun

(SETQ *model-space* nil)    ; Initialize global variable
(DEFUN model-space()
(COND (*model-space*)          ; Return the cached object
(T
(SETQ *model-space* (VLA-GET-MODELSPACE (active-document)))
)
) ;_ 结束cond

) ;_ 结束defun
;;; 函数： 3dPoint->2dPoint
;;;--------------------------------------------------
;;; 说明：本函数有一个参数，表示一个三维点
;;;    （由三个整数或实数组成的表），函数将它
;;;    转换为二维点（由两个实数组成的表）。
;;;    本函数并不检查参数 3dpt，而是
;;;    总认为它是一个有效点。
;;;---------------------------------------------------
;;; 要添加的功能：加上一些参数检查功能，
;;;    这样即使传给它空值或不是三维点的值，
;;;    函数也不会导致程序崩溃。
;;;----------------------------------------------------
(DEFUN 3dPoint->2dPoint (3dpt)
(LIST (FLOAT (CAR 3dpt)) (FLOAT (CADR 3dpt)))

) ;_ 结束defun

yanguangfei 发表于 2012-5-21 00:34:52

同行有高程点文字避让的程序不？发上来学习学习。论坛有一个就是慢了点。

print1985 发表于 2012-5-21 09:54:07

谢谢楼主
论坛里避让类的程序大都也是通过ssget来选择判断同求更好的方法

NetBee 发表于 2012-5-21 20:53:31

画个框框求交点。

mandala 发表于 2012-5-22 08:06:28

本帖最后由 mandala 于 2012-5-22 08:06 编辑

可以考虑将所有符号的外接矩形范围统一设为一个大略值。通常符号的大小不会相差太大。

weiyoubao2012 发表于 2012-9-1 00:50:45

很是不错，不知道效果怎么样啊

╰☆珊瑚玉ヤ 发表于 2012-12-8 14:46:50

来学习一下了
不知效果怎样呢

328302216 发表于 2013-1-17 12:16:59

支持楼主的源码无私分享如果是源码加动画那就更好了！

destnity 发表于 2013-1-22 22:51:01

感谢提供。一定仔细研究学习

004 发表于 2013-1-23 10:24:39

很好，测绘高手啊！

页: [1] 2

明经CAD社区's Archiver

地形图上的植被符号自动避让程序