GBPOLY at geometricad and gbound at
www.tovna.comare all excellent program to find the boundary, but they are all arx and time limitation,
so I want to find each boundary by lisp
I use the method:scan line
like the graph 1, the green line from bottom to top to scan the object
then find the intersections between the green line and the object selected fence by it.
inter1=[I1, I2, I3, I4, I5, I6]
then get the midpoint of each [I1 I2], [I2,I3] **** and get inter1mid
in each inter1mid, found the boundary by std-poly, at the same time
find the intersections between the scan line and the boundary object in
layer "bound" (I assume no other object in this layer that need to find
boundary], so get the new list
inter2=[I1' I2'] ,
inter2 will update at each production of the new boundary.
then find the midpoint of [I1' I2'], [I3' I4'] (it is different from the
inter1mid)
then if the midpoint of inter1mid is the member of the inter2mid, it
means that the boundary have made, and needn't to make again, the
progress skip to next point.
In many cases it is OK, but it sometimes make some duplicate
boundary, I should continue to improve it.
The efficiency is low, I hope you can give me some advise, thank you
very much.
Qjchen
;;; ========================================================================
;;; 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")
fig.2 and fig.3 is the demoshow