[原创]：在平面相交线集中找出各个封闭区域

snoopychen

最近看了xiaolongxin兄写的好些计算几何方面的文章，好是佩服，其中那个通过点线确定封闭区

域的确实是好文章。
关于查找区域的问题我先做如下描述
平面上有许多相交的线段，线段之间组成了许多区域，如何自动把这些区域找出来。
网络上的好软件有
GBPOLY at geometricad
gbound at www.tovna.com
他们速度都很快，但是是arx或者有时间限制
我希望用lisp可以实现，于是采用了很蠢的扫描线法，逐步增量，用boundary去找区域。
寻找扫描线与原有线的交点，取交点中点进行boundary
解决的一点问题：如何让boundary不要重复产生，这里面进行了扫描线中点是否与已经建立的区

域的交点相同的问题
存在的问题：1）不能针对有spline的线（这个有待改进）
2）对于有内部孤线的问题，有时候会重复产生boundary
3）效率其低，这个是算法问题，假如平面上的线都是直线段的话，应该扫描线可以少很多
大部分情况下可以实现，有时候有些问题
[php]
;;; ========================================================================
;;; Some of the following code are writen by QJCHEN                        
;;; Civil engineering Department, South China University of Technology     
;;; Purpose: To Find each closed boundary in the selection                 
;;; Version: 0.1                                                           
;;; Limitation: Can't generate the boundary by spline                       
;;; 2006.06.01                                                            
;;; Thanks to the code from Korea friend from http://xoutside.com/         
;;; whose code find the intersections of two points and many object         
;;; And thanks to the initial code from Mr.Tony Hotchkiss at Cadalyst      
;;; Original post :www.Theswamp.org                                         
;;; ========================================================================

(defun c:bb (/ clayer a b dis ay by th th0 lp rp inter1 inter1mid inter2
                 inter2mid i len plboundary
              )
  (command "_undo" "_be")
  (startTimer)
  (setting)
  (setq clayer (getvar "clayer"))
  (command "_layer" "n" "bound" "s" "bound" "c" 3 "" "")
  (setq a (getpoint "\n the left up point"))
  (setq b (getcorner a "\n the bottom right point"))
  (setq dis (getdist "\n the minimum distance"))
  (setq ay (nth 1 a)
        by (nth 1 b)
  )
  (setq th by)
  (setq th0 dis)
  (while (< th ay)
    (setq lp (list (nth 0 a) th 0))
    (setq rp (list (nth 0 b) th 0))
    (grdraw lp rp 249)
    (setq inter1 (vl-Get-Int-Pt lp rp "bound" 0))
    (setq inter1mid (midlist inter1))
    (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
          inter2mid (midlista inter2)
    )
    (command "_layer" "s" "bound" "")
    (setq i 0
          len (length inter1)
    )
    (repeat (1- len)
      (setq midpoint (nth i inter1mid))
      (if (not (member1 midpoint inter2mid))
        (progn
          (setq plboundary (STD-BPOLY midpoint nil))
          (if plboundary
            (setq inter2 (vl-Get-Int-Pt lp rp "bound" 1)
                  inter2mid (midlista inter2)
            )
          )
          )
      )
      (setq i (1+ i))
    )
    (command "_layer" "s" clayer "")
    (setq th (+ th th0))
  )
  (resetting)
  (endTimer (vl-symbol-name 'c:bb))
  (command "_undo" "_e")
)

;
(defun member1 (a b / res)
  (if b
    (foreach x b
      (if (< (distance x a) 0.01)
        (progn
          (setq res T)
        )        ; (setq res nil)
      )
    )        ; (setq res nil)
  )
  res
)
(defun midlist (lst / len lst1 midpoint i)
  (setq i 0
        len (length lst)
  )
  (repeat (1- len)
    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
    (setq lst1 (append
                 lst1
                 (list midpoint)
               )
    )
    (setq i (1+ i))
  )
  lst1
)
(defun midlista (lst / len lst1 midpoint i)
  (setq i 0
        len (length lst)
  )
  (repeat (/ len 2)
    (setq midpoint (midp (nth i lst) (nth (1+ i) lst)))
    (setq lst1 (append
                 lst1
                 (list midpoint)
               )
    )
    (setq i (+ i 2))
  )
  lst1
)

;;; -----------------------------------------------------------------
;;; | The following code taken xarch.tu-graz.ac.at/autocad/stdlib/  |
;;; | Thanks to the great code "STDLIB" that wrote by MR.Reini Urban|
;;; -----------------------------------------------------------------

(defun STD-BPOLY (pt ss / ele)
  (cond
    ((member (type C:BPOLY) '(SUBR EXRXSUBR EXSUBR))
      (if ss
        (C:BPOLY pt ss)        ; old arx or ads function
        (C:BPOLY pt)
      )
    )
    (pt        ; >=r14: native command
        (setvar "CMDDIA" 0)
        (setq ele (entlast))        ; (std-break-command)
        (command "_BPOLY" "_A" "_I" "_N" "") ; advanced options
       ; without island detection
        (if ss
          (command "_B" "_N" ss "")
        )        ; define boundary set if ss
        (command "" pt "") (setvar "CMDDIA" 1)
        (if (/= (entlast) ele)
          (entlast)
        )
    )        ; return created BPOLY
    (T
      (alert "command _BPOLY not available")
    )
  )
)


;;; -------------------------------------------------------------------
;;; | The following code are taken from xoutside.com                  |
;;; | http://xoutside.com/CAD/lisp/lisp_chair.htm                     |
;;; | Thanks to the Korea friend                                      |
;;; | Purpose: Get the intersection of Two object                     |
;;; -------------------------------------------------------------------

(defun vl-Get-Int-Pt (FirstPoint SecondPoint lay layindex / acadDocument
                                 mSpace SSetName SSets SSet reapp ex obj
                                 Baseline
                     )
  (vl-load-com)
  (setq acadDocument (vla-get-ActiveDocument (vlax-get-acad-object)))
  (setq mSpace (vla-get-ModelSpace acadDocument))
  (setq SSetName "MySSet")
  (setq SSets (vla-get-SelectionSets acadDocument))
  (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list SSets
                                                               SSetName
                                                         )
                            )
      )
    (vla-clear (vla-Item SSets SSetName))
  )
  (setq SSet (vla-Item SSets SSetName))
  (setq Baseline (vla-Addline mspace (vlax-3d-point FirstPoint)
                              (vlax-3d-point SecondPoint)
                 )
  )
  (vla-SelectByPolygon SSet acSelectionSetFence
                       (kht:list->safearray (append
                                              FirstPoint
                                              SecondPoint
                                            ) 'vlax-vbdouble
                       )
  )
  (vlax-for obj sset (if (setq ex (kht-intersect
                                                 (vlax-vla-object->ename BaseLine)
                                                 (vlax-vla-object->ename obj)
                                                 lay layindex
                                  )
                         )
                       (setq reapp (append
                                     reapp
                                     ex
                                   )
                       )
                     )
  )
  (vla-delete BaseLine)
  (setq reapp (vl-sort reapp '(lambda (e1 e2)
                                (< (car e1) (car e2))
                              )
              )
  )
  reapp
)


;;; Original post:http://xoutside.com/CAD/lisp/lisp_chair.htm
;;; Modify little by QJCHEN to filter TEXT SPLINE and layer   
(defun kht-intersect (en1 en2 lay layindex / a b x ex ex-app c d e la2)
  (vl-load-com)
  (setq c (cdr (assoc 0 (entget en1)))
        d (cdr (assoc 0 (entget en2)))
        la2 (cdr (assoc 8 (entget en2)))
  )
  (if (or
        (= c "TEXT")
        (= d "TEXT")
        (= c "SPLINE")
        (= d "SPLINE")
      )
    (setq e -1)
  )
  (if (= layindex 0)
    (if (= la2 lay)
      (setq e -1)
    )
  )
  (if (= layindex 1)
    (if (/= la2 lay)
      (setq e -1)
    )
  )
  (setq En1 (vlax-ename->vla-object En1))
  (setq En2 (vlax-ename->vla-object En2))
  (setq a (vla-intersectwith en1 en2 acExtendNone))
  (setq a (vlax-variant-value a))
  (setq b (vlax-safearray-get-u-bound a 1))
  (if (= e -1)
    (setq b e)
  )
  (if (/= b -1)
    (progn
      (exapp a)
    )
    nil
  )
)

(defun exapp (a)
  (setq a (vlax-safearray->list a))
  (repeat (/ (length a) 3)
    (setq ex-app (append
                   ex-app
                   (list (list (car a) (cadr a) (caddr a)))
                 )
    )
    (setq a (cdr (cdr (cdr a))))
  )
  ex-app
)

(defun kht:list->safearray (lst datatype)
  (vlax-safearray-fill (vlax-make-safearray (eval datatype) (cons 0
                                                                  (1-
                                                                      (length lst)
                                                                  )
                                                            )
                       ) lst
  )
)

;;; ----------------------------------------------------------
;;; |           midpoint function                            |
;;; ----------------------------------------------------------
(defun midp (p1 p2)
  (mapcar
    '(lambda (x)
       (/ x 2.)
     )
    (mapcar
      '+
      p1
      p2
    )
  )
)


;;; -----------------------------------------------------------------
;;; | The following code taken from Mr.Tony Hotchkiss at Cadalyst   |
;;; | To set and reset the system variable                          |
;;; -----------------------------------------------------------------

(defun err (s)
  (if (= s "Function cancelled")
    (princ "\nALIGNIT - cancelled: ")
    (progn
      (princ "\nALIGNIT - Error: ")
      (princ s)
      (terpri)
    )        ; _ end of progn
  )        ; _ end of if
  (resetting)
  (princ "SYSTEM VARIABLES have been reset\n")
  (princ)
)
;;; err
;;; setting and resetting the system variables
(defun setv (systvar newval / x)
  (setq x (read (strcat systvar "1")))
  (set x (getvar systvar))
  (setvar systvar newval)
)
;;; setv
(defun setting ()
  (setq oerr *error*)
  (setq *error* err)
  (setv "BLIPMODE" 0)
  (setv "CMDECHO" 0)
  (setv "OSMODE" 0)
)
;;; setting
(defun rsetv (systvar)
  (setq x (read (strcat systvar "1")))
  (setvar systvar (eval x))
)
;;; rsetv
(defun resetting ()
  (rsetv "BLIPMODE")
  (rsetv "CMDECHO")
  (rsetv "OSMODE")
  (setq *error* oerr)
)


;;; -----------------------------------------------------------------
;;; | The following code taken from www.theswamp.org                |
;;; | To calculate the time that the program run                    |
;;; -----------------------------------------------------------------

(defun startTimer ()
  (setq time (getvar "DATE"))
)
(defun endTimer (func)
  (setq time (- (getvar "DATE") time)
        seconds (* 86400.0 (- time (fix time)))
  )
  (gc)
  (outPut seconds func)
)
(defun outPut (secs def)
  (princ "\nPurging...")
  (command "PURGE" "Layers" "*" "N")
  (gc)
  (princ (strcat "\nTimed " def ": " (rtos secs 2 6)))
  (princ)
)

(princ "\n Please use the bb command to run")

[/php]

雨箭风刀

想的太复杂，其实很简单
求曲线选集所有交点，交点打断
再用面域命令，就可以生成各个封闭区域。支持spline等

snoopychen

呜呜呜，刀兄早点提醒我啊。原来reg可以一次多个啊，那我就不走弯路了。
那么接下来我的问题就是，怎么提取出region的顶点（假如这些线都是直线的话，顶点是有用的），不过对于hatch，region等复杂实体，还不大懂。还有，region之后原来的线会没有了，可能得备份一次。
谢谢：）

雨箭风刀

单个region可炸开求线顶点，过滤一下重复点
是要备份一份

snoopychen

谢谢，我将会重写这段代码，因为直线段区域的形成对我很有用
刚刚找到了menzi的一段函数来把region变成boundary的，虽然它不能对待spline，但是已经够我用了
也是和刀兄的建议是一样的，采用explode
[php]
;;;;Menzi
(defun VxRegionToBounary (Ent / CurObj CurSet ObjArr)
(vl-load-com)
(setq CurSet (ssadd)
       CurObj (vlax-ename->vla-object Ent)
       ObjArr (vlax-safearray->list
               (vlax-variant-value
                (vla-Explode CurObj)
               )
              )
)
(foreach memb ObjArr
  (setq CurSet (ssadd (vlax-vla-object->ename memb) CurSet))
)
(vla-delete CurObj) ;if the region should remain, remove this line
(command "_.PEDIT" (ssname CurSet 0) "_YES" "_JOIN" CurSet "" "")
(entlast)
)

(setq a (car (entsel)))
(VxRegionToBounary a)

[/php]

eachy

对 Line 形成的 Region 不用这么复杂
(if (setq ss (ssget "i")) (progn (command ".explode" ss "") (command ".pedit" "m" "p" "j" "")))

snoopychen

:p
有时候还有些多线组成的区域的，多线只是打断没有炸开，所以可能还得用menzi那个
eachy版主的这段是要先用夹点选取物体，还是要用什么ssgetfirst呢，不懂用啊，脸红