[LISP程序]：图形清理之-----------检查悬挂点

caddog

;;;在成都市中心城区地籍数据库建设的工作中，对DWG图形的细部提出了很高的要求
;;;比如，两个看似重合的多段线顶点，其坐标须在1e-08以内相同方可认为是重合；
;;;若一多段线搭于另一多段线上，比如内部道路搭在房线上，则必须保证没的出头、
;;;未及的情况……个人感觉，其图面要求之严格，检查之细致，实属未见！
;;;为了达到这样的标准，须对图面进行大量的整饰！繁琐之极。
;;;于是，针对上面提到的出头与未及的情况，编写了一个程序，虽然解决了找出悬挂
;;;点的问题，但感觉速度上确实有点过不去，所以斗胆贴出，若能起到抛砖引玉之效
;;;便是我的荣幸。
;;;关于如何提高程序的执行速度，我实在是没想出更好的方法，恳请各位高手能指点迷津，
;;;不胜感激！

;;;关于“悬挂点”的一些说明（因为理解得不是很透彻，描述不当之处望谅）
;;;在AUTOCAD　MAP中，若多段线（还有直线）的一端搭于另一多段线上，另一端未搭在
;;;任何多段线上，则本多段线悬挂。形象的例子比如钟摆。我们在工作中习惯将未搭在
;;;任何多段线上的那个端点称为悬挂点，也许不太准确，但约定俗成嘛：）
;;;我判断一个端点是否悬挂点的标准是：
;;;1.若本点在所有多段线端点坐标中在给定精度范围内出现仅一次，则本点可能悬挂；否则必不悬挂；
;;;2.若本段不位于任何一条多段线上，则本点为悬挂点，否则不悬挂。
;;;程序的最慢之处就是第2步，当有7000多条多段线时。。。我都忘记究竟等了多久了!汗

;;;程序首先提取所有的多段线顶点信息组成二个表
;;;#hang2 所有顶点坐标
;;;#hang 所有多段线的段信息。形如((1 2)(2 3)(3 4).....)
;;;然后按照上面所述的方法进行判断。
;;;程序将在检查出的悬挂点处生成一个红色POINT，位于“悬挂点”层.
;;;另外，提供了一个BV命令，用于遍历检查出的悬挂点

;;;还有一点要说明一下：hj:geoPandLine 函数我好像是借用了在XDCAD上一位朋友编写的函数
;;;但我实在是记不清了，也没有找到原来的文件，借此机会说声谢谢！

[PHP](defun c:CleanHang (/ $LAYERSFILTER $VALUE %RESV BOOL-SELEALL DCL_ID SSHANGOBJECT)

  

  ;;----------------------------------------
    ;;调用对话框
  (SETQ dcl_id (LOAD_DIALOG "mydcl"))
      (IF (< dcl_id 0)
      (EXIT)
    ) ;_ 结束if
  (setq %resv nil)
  (setq bool-SeleAll t)
  (setq $layersFilter "*")
  (while (and (/= %resv 0)(/= %resv 1))
    (NEW_DIALOG "diaCleanHang" dcl_id "" )
    ;;以下开始设置各个控件的值
    (if (not *cleanHangMin*)(setq *cleanHangMin* 1.0e-009))
    (if (not *cleanHangMax*)(setq *cleanHangMax* 9999.0))
    (if bool-SeleAll
      (progn
        (SET_TILE "radSeleAll" "1")
        (cl-Trim:RadSeleAllClick "1")
        )
      (progn
        (SET_TILE "radSeleUser" "1")
        (cl-Trim:RadSeleUserClick "1")
        )
      )
    ;;要根据bool-SeleAll和ssHangObject来设置"确定"的状态
    (if (or bool-seleall (and ssHangObject (not bool-seleall)))
      (MODE_TILE "accept" 0)
      (MODE_TILE "accept" 1)
      )
    (if ssHangObject
      (SET_TILE "textPart1" (strcat "选择了 "(itoa (sslength ssHangObject)) " 个要检查的对象"))
      )

    (SET_TILE "editMin" (rtos *cleanHangMin* 2 9))
    (SET_TILE "editMax" (rtos *cleanHangMax* 2 2))
    (SET_TILE "editSeleLayers"  $layersFilter)
   
    (ACTION_TILE "editMin" "(setq *cleanHangMin* (atof $value))")
    (ACTION_TILE "editMax" "(setq *cleanHangMax* (atof $value))")
    (ACTION_TILE "editSeleLayers" "(setq $layersFilter $value)")
   
    (ACTION_TILE "radSeleUser" "(cl-Hang:RadSeleUserClick $value)")
    (ACTION_TILE "radSeleAll" "(cl-Hang:RadSeleAllClick $value)")
   
    (ACTION_TILE "buSeleLayers" "(cl-Trim:buSeleLayersClick)");_选择图层
    (ACTION_TILE "buSeleUser" "(DONE_DIALOG 2)");_选择要处理实体

    (ACTION_TILE "accept" "(DONE_DIALOG 1)")
    (ACTION_TILE "cancel" "(DONE_DIALOG 0)")
    (ACTION_TILE "help" "(alert \"帮助还没编!\")")

    (setq %resv (START_DIALOG))
    (cond
      ((= %resv 2)
       (setq ssHangObject(ssget (list (cons 0 "LWPOLYLINE") (cons 8 $layersFilter))))
       )      
      (t nil)
      )
  )
  (if (= %resv 1)
    (progn
      (if bool-SeleAll ;_说明是全选
        (setq ssHangObject(ssget "_x" (list (cons 0 "LWPOLYLINE") (cons 8 $layersFilter))))
        )
      ;;调用子函数
      ;;(hj:cleanHang ssHangObject *cleanHangMin* *cleanHangMax*)
      (hj:cleanHangNew ssHangObject *cleanHangMin*)
      )
    )
  )



;;;--------------------------------------------------------
(defun hj:cleanHangNew (ss-TrOrExData
                         *CLEANHANGMIN*               /          #HANG
                         #HANG1            #HANG2     #HANGTRUE  $MSG
                         %ID            CLOSED     ENPTS          ENPTS2
                         LEN-HANG   LEN-SS1    NAME1          PLPTS
                         S            SECONDS    SECONDS1          SECONDSX
                        )
  ;;(setq ss-TrOrExData (ssget '((0 . "LWPOLYLINE"))))
  (setq %id 0)
  (setq plPts nil)
  (setq #hang nil)
  (setq        #hang1 nil
        #hang2 nil
  )
  (setq #hangTrue nil)

  (princ "\n开始采集多段线数据......")
  (setq len-ss1 (sslength ss-TrOrExData))
  ;;----------------------------------
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
  (setq secondsX seconds)
  ;;----------------------------------
  (repeat len-ss1
    (setq name1 (ssname ss-TrOrExData %id))
    (setq enPts (HJ:GETPLLIST name1))
    (if        (= (setq closed (vla-get-closed (vlax-ename->vla-object name1)))
           :vlax-true
        )
      (setq enPts (append enPts (list (car enPts))))
    )
    (setq #hang2 (cons enPts #hang2))
    ;;将ENPTS拆分组合为(1 2)(2 3) (3 4)...的表
    (setq enPts2 (hj:pairList enPts))
    (setq plPts (cons enPts2 plPts)) ;_组合多段线每一段的表
    (if        (= closed :vlax-false)
      (setq #hang (cons (list (car enPts) (last enPts)) #hang))
    )
    (setq %id (1+ %id))
  ) ;_end repeat

  (setq plPts (apply 'append plPts))
  (setq #hang (apply 'append #hang))
  (setq #hang2 (apply 'append #hang2))
  ;;----------------------------------
  (setq s (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s (fix s))))
  (prinC "\n采集多段线数据完成! 共耗时:")
  (princ (- seconds1 seconds))
;;;计算悬挂点
  (princ "\n开始计算悬挂点...........")

  ;;----------------------------------
  (setq s (getvar "DATE"))
  (setq seconds (* 86400.0 (- s (fix s))))
  ;;----------------------------------
  ;;筛选出表中只出现过一次的点656
  (setq
    $msg (strcat "\r开始筛选悬挂点....." (itoa (length #hang)) " / ")
  )
  (setq %id 0)
  (foreach y #hang

    (setq len-hang (length #hang2))
    (setq #hang2 (vl-remove-if
                   '(lambda (x) (equal y x *CLEANHANGMIN*))
                   #hang2
                 )
    )
    (if        (= (length #hang2) (1- len-hang))
      ;;本点只有一个
      (setq #hang1 (cons y #hang1))
    )
    (setq %id (1+ %id))
    (princ (strcat $msg (itoa %id) "..........."))
  )
  (princ "\r开始计算实交点.....")
  (setq %id 0)
  (setq        $msg (strcat "\r开始计算实交点....."
                     (itoa (length #hang1))
                     " / "
             )
  )
  (foreach x #hang1
    ;;若返回有值，则本点在线上，说明本点是交点，则不为悬挂
    ;;3001条多段线 97.344 180个
;;;    (if        (not (vl-member-if
;;;               '(lambda (y) (HJ:GEOPANDLINE x (car y) (last y)))
;;;               plPts
;;;             )
;;;        )
;;;      (setq #hangTrue (cons x #hangTrue))
;;;    )
    ;;看起来用vl-some比较的次数要少些，但反而用了97.593
    (if (not(vl-some '(lambda(y)(HJ:GEOPANDLINE x (car y) (last y)))plPts))
       (setq #hangTrue (cons x #hangTrue))
      )
    (setq %id (1+ %id))
    (princ (strcat $msg (itoa %id) "..........."))

  )
  ;;----------------------------------
  (setq s (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s (fix s))))
  (prinC "\n计算悬挂点完成! 共耗时:")
  (princ (- seconds1 seconds))

;;;生成悬挂点
  (if #hangTrue
    (progn
      (princ "\n标记悬挂点......")
      (foreach x #hangTrue
        (ENTMAKEX (LIST        (CONS 0 "POINT")
                        (CONS 8 "悬挂点")
                        (cons 62 1)
                        (CONS 10 x)
                  )
        )
      ) ;_end foreach x #hang

    )
  )
  ;;----------------------------------
  (setq s (getvar "DATE"))
  (setq seconds1 (* 86400.0 (- s (fix s))))
  (prinC "\n检查悬挂点完成! 共耗时:")
  (princ (- seconds1 secondsX))

  (princ (strcat "\n共有 "
                 (itoa (length #hangTrue))
                 " 个悬挂点!请用 BV 命令浏览!"
         )
  )
  (princ)
)


;;;－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
;;;下面是程序中用到的一些函数

;;;用CONS，因为CONS比APPEND要快.约快1/3
;;;应该加一条，当相邻两点相同时，去掉重点
(defun hj:getpllist (Polyline / enType %repeat #rev-PolyLine #1 %id-PolyLine objPolyline)
  ;;(setq enVertex (ent
  (setq objPolyline(vlax-ename->vla-object Polyline))
  (setq        #1 (vlax-safearray->list
             (vlax-variant-value
               (vla-get-Coordinates
                 objPolyline
               )
             )
           )
  )
  (if (= (vla-get-ObjectName objPolyline) "AcDb2dPolyline")
    (setq enType 3)
    (setq enType 2)
    )
  (setq %id-PolyLine 0
        %repeat (/ (length #1) enType))
  (repeat %repeat
    (setq #rev-polyline1 (list (nth (* %id-PolyLine enType) #1)
                       (nth (1+ (* %id-PolyLine enType)) #1)
                 ))
    (if (not (equal #rev-polyline1 (car #rev-PolyLine) 1e-09))
      (setq #rev-PolyLine
             (cons
               #rev-polyline1
               #rev-PolyLine
               )
            )
      )
    (setq %id-PolyLine (1+ %id-PolyLine))
  ) ;_end repeat
  (REVERSE #rev-PolyLine)
)


;;;将多段线顶点表拆分为((1 2)(2 3)(3 4)....(n-1 n))的表
(defun hj:pairList(pairList / %id-pair %len-pair #rev)
  (setq %id-pair 0)
  (setq %len-pair (1- (length pairList)))
  (repeat %len-pair
    (setq #rev (cons (list (nth %id-pair pairList)(nth (1+ %id-pair) pairList))#rev))
    (setq %id-pair (1+ %id-pair))
    );_end repeat
  #rev
  )

(defun hj:geoPandLine (#inters1 p1 p2 /)
  (setq        tt1 (hj:vector- #inters1 p1)
        tt2 (hj:vector- p2 p1)
  )
  
  (if
    (and
      (equal (- (* (car tt1) (cadr tt2)) (* (cadr tt1) (car tt2)))
             0
             1.0e-009
      )
      (and
        (vl-every '<
                  (APPLY 'MAPCAR (CONS 'MIN (list p1 p2)))
                  #inters1
        )
        (vl-every '>
                  (APPLY 'MAPCAR (CONS 'Max (list p1 p2)))
                  #inters1
        )
      )
    )
     ;;该点在p1 p2线上
     t
     nil
  )
)



;;;--------------------------------------------------------------
;;;以下是控制对话框的各控件状态的一些函数
;;选择所有click事件
  (defun cl-Trim:RadSeleAllClick(Value)
    (if (= value "1")
      (progn
        (MODE_TILE "buSeleUser" 1)
        (setq bool-SeleAll t)
        )
      (progn
        (MODE_TILE "buSeleUser" 0)
        (setq bool-SeleAll nil)
        )
    )
    )

;;用户选择实体click事件
  (defun cl-Trim:RadSeleUserClick(Value)
    (if (= value "1")
      (progn
        (MODE_TILE "buSeleUser" 0)
        (setq bool-SeleAll nil)
        )
      (progn
        (MODE_TILE "buSeleUser" 1)
        (setq bool-SeleAll t)
        )
    )
    )

;;用户选择实体click事件
  (defun cl-Hang:RadSeleUserClick(Value)
    (if (= value "1")
      (progn
        (MODE_TILE "buSeleUser" 0)
        (setq bool-SeleAll nil)
        )
      (progn
        (MODE_TILE "buSeleUser" 1)
        (setq bool-SeleAll t)
        )
    )
    (if (or bool-seleall (and ssHangObject (not bool-seleall)))
      (MODE_TILE "accept" 0)
      (MODE_TILE "accept" 1)
      )
    )
  ;;选择所有click事件
  (defun cl-Hang:RadSeleAllClick(Value)
    (if (= value "1")
      (progn
        (MODE_TILE "buSeleUser" 1)
        (setq bool-SeleAll t)
        )
      (progn
        (MODE_TILE "buSeleUser" 0)
        (setq bool-SeleAll nil)
        )
    )
    (if (or bool-seleall (and ssHangObject (not bool-seleall)))
      (MODE_TILE "accept" 0)
      (MODE_TILE "accept" 1)
      )
    )

  (defun cl-Trim:buSeleLayersClick(/ $addLayer)
    (setq $addLayer (hj:GetLayer))
    (if $addLayer
      (progn
      (if (= $layersFilter "*")
        (setq $layersFilter $addLayer)
        (setq $layersFilter (strcat $layersFilter "," $addLayer))
      )
      (SET_TILE "editSeleLayers" $layersFilter)
      );_end progn
      )
    )
;;;--------------------------------------------------------------



;;;细部处理......遍历图内所有的悬挂点
;;;本程序用于遍历图内所有的悬挂点并执行缩放、删除、延伸、裁剪等操作
(defun c:bv ( / !ZOOMX #CEN-PT $II EN-POINT SS-BR1 $LayerNAME)
  (princ "\n遍历某个图层内所有的点")
  (COMMAND "color" "")
  (COMMAND "_.undo" "_begin")
  (setq $LayerNAME "悬挂点")
  (if (not *zoomX*)
    (setq *zoomX* 3.0)
    )
  ;;(setq $LayerNAME (dos_layerlistbox "AutoCAD 图层列表" "选择要遍历的图层" 0)) ;_调用DOSLIB的对话框
  (if (= $LayerNAME nil) (setq $LayerNAME "悬挂点"))
  ;;(setq !zoomX 3.0)
  (setq ss-br1 (ssget "_x" (list(cons 0  "POINT") (CONS 8 $LayerNAME))))
  (if ss-br1
    (progn
      (while (> (SSLENGTH ss-br1) 0)
        (setq en-point (ssname ss-br1 0)
              !ssleng  (SSLENGTH ss-br1)
        )
        (setq #cen-pt (cdr (assoc 10 (entget en-point))))
        (command "_.zoom" "c" #cen-pt *zoomX*)
        (if  $ii
          (setq $iiOld $ii)
          (setq $iiOld "D")
        )
        (initget "下一个(N),N 删除标记(D),D 缩放值(A),A 退出(X),X _N D A X")
        (setq $ii
               (GETKWORD
                 (strcat "\n(共"
                         (itoa !ssleng)
                         "个)[下一个(N)/删除标记(D)/缩放值(A)/退出(X)]<" $iiOld ">"
                 )
               )
        )
        (if (not $ii)
          (setq $ii $iiOld)
        )
        ;;(princ (strcat "\n" $ii))
        (cond
          ((= $ii "N") (ssdel en-point ss-br1))
          ((= $ii "D") (ssdel en-point ss-br1) (entdel en-point))
          ((= $ii "A")
           (initget (+ 2 4))
           (setq *zoomX* (getreal "\n输入缩放参数:<3>"))
           (if (= *zoomX* nil)
             (setq *zoomX* 3.0)             
           )
           (command "_.zoom" "c" #cen-pt *zoomX*)
          )
          ((= $ii "X")
           (setq ss-br1        nil
                 ss-br1        (ssadd)
           )
          )
          (t nil)
        )

      ) ;_end while
    ) ;_end progn
    (princ"\n图内无悬挂点!")
  ) ;_end if
  (COMMAND "_.undo" "_end")
)[/PHP]

k:\Snap1.jpg

程序执行的效果
k:\Snap2.jpg

还有DCL文件就作为附件传上来了

destnity

不错。虽然有很多工具可以处理，但是自已编的用起来顺手些。努力学习中。
一般我用cad map 中的图形清理功能来处理。速度还是比较快。

caddog

我也常用AUTOCAD　MAP来处理，感觉那个速度真是快啊！一点确定就出来了，不知首是怎么搞的？

yjtylj

opokpko[

skg123

楼主，你的代码有点乱，最好打包上传

神秘将军

确实有点乱，没理清楚:'(

Lizzhao

没看明白，最近也在搞这个

flowerson

是论坛网页问题吗?很多变乱码了。