voronoi一种cad简单的算法，求改进

qwesxqe

2. (defun c:vo ()
   
3.   (vl-load-com)
   
4.   (setq  AcadObject   (vlax-get-acad-object)
   
5.   AcadDocument (vla-get-ActiveDocument AcadObject)
   
6.   mSpace       (vla-get-ModelSpace AcadDocument)
   
7.   )
   
8.   (defun midpoint (pt1 pt2)
   
9. 
   
10.     (setq pmid
    
11.      (list (/ (+ (car pt2) (car pt1)) 2.0)
    
12.      (/ (+ (cadr pt2) (cadr pt1)) 2.0)
    
13.      (/ (+ (caddr pt2) (caddr pt1)) 2.0)
    
14.      )
    
15.     )
    
16.   )
    
17. 
    
18.   (defun gxl-removeNth (index lst / c)
    
19.     (setq c -1)
    
20.     (apply 'append
    
21.      (mapcar '(lambda (x)
    
22.           (if (/= (setq c (1+ c)) index)
    
23.       (list x)
    
24.           )
    
25.         )
    
26.        lst
    
27.      )
    
28.     )
    
29.   )
    
30.   (print "选择点：")
    
31.   (setq ss (ssget '((0 . "POINT"))))
    
32.   (setq n (sslength ss))
    
33.   (print "选择曲线：")
    
34.   (setq pline (car (entsel)))
    
35.   (setq t0 (getvar "TDUSRTIMER"))
    
36.   (command "undo" "begin")
    
37.   (vla-getboundingbox
    
38.     (vlax-ename->vla-object pline)
    
39.     'pt1a
    
40.     'pt2a
    
41.   )
    
42.   (setq  l (* (distance (vlax-safearray->list pt2a)
    
43.            (vlax-safearray->list pt1a)
    
44.        )
    
45.        5.0
    
46.     )
    
47.   )
    
48. 
    
49. 
    
50.   (setq i 0)
    
51.   (setq listpoint (list))
    
52.   (repeat n
    
53.     (setq ssthnth (ssname ss i))
    
54. 
    
55.     (setq listpoint (cons
    
56.           (cdr (assoc 10 (entget ssthnth)))
    
57.           listpoint
    
58.         )
    
59.     )
    
60.     (setq i (1+ i))
    
61.   )
    
62. 
    
63.   (setq j (length listpoint))
    
64.   (setq j1 (- j 1))
    
65.   (setq jj 0)
    
66. 
    
67. 
    
68.   (repeat j
    
69.     (setq pointj (nth jj listpoint))
    
70.     (setq biao (gxl-removeNth jj listpoint))
    
71.     (setq jjj 0)
    
72.     (setq xuanzhe (ssadd))
    
73.     (repeat j1
    
74.       (setq pointi (nth jjj biao))
    
75. ;(command "line" "non" pointj "non" pointi "")
    
76. 
    
77.       (setq ang (angle pointj pointi))
    
78.       (setq ang2 (+ ang (/ pi 2.0)))
    
79.       (setq ang3 (- ang (/ pi 2.0)))
    
80.       (setq ang4 (- ang (/ pi 1.0)))
    
81.       (setq pt0 (midpoint pointj pointi))
    
82. ;(command "line" "non" pointj "non" pt0 "")
    
83. 
    
84.       (setq pt1 (polar pt0 ang2 l))
    
85.       (setq pt4 (polar pt0 ang3 l))
    
86.       (setq pt2 (polar pt1 ang4 l))
    
87.       (setq pt3 (polar pt4 ang4 l))
    
88. 
    
89. 
    
90. ;(setq LST (append pt1 pt2 pt3 pt4  ))
    
91. ;(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 11)))
    
92. ;(vlax-safearray-fill mat lst)
    
93.       (setq LST (list pt1 pt2 pt3 pt4))
    
94.       (entmake
    
95.   (append  (list '(0 . "LWPOLYLINE")
    
96.           '(100 . "AcDbEntity")
    
97.           '(100 . "AcDbPolyline")
    
98. 
    
99.           (cons 90 (length LST))
    
100.           '(70 . 1)
     
101.     )
     
102.     (mapcar '(lambda (ptrr) (cons 10 ptrr)) LST)
     
103.   )
     
104.       )
     
105. ;(vla-Put-Closed obj :vlax-True)
     
106.       (setq lastwuti (entlast))
     
107. 
     
108. ;(command "_REGION" xxxx "")
     
109. ;(setq xxxxl (entlast))
     
110.       (ssadd lastwuti xuanzhe)
     
111. ;(setq quxian  (vla-AddPolyline mSpace mat))
     
112. ;(setq quxian (vla-Put-Closed quxian :vlax-True))
     
113. ;(setq quxian3 (myRegion LST))
     
114. 
     
115. 
     
116.       (setq jjj (1+ jjj))
     
117.     )
     
118.     (vl-cmdf "-BOUNDARY" pointj "")
     
119.     (vl-cmdf "ERASE" xuanzhe "")
     
120. 
     
121.     (setq jj (1+ jj))
     
122.   )
     
123.   (command "undo" "end")
     
124. 
     
125.   (princ (* (- (getvar "TDUSRTIMER") t0) 86400))
     
126.   (princ "秒")
     
127.   (princ)
     
128. )
     
129. 
     
130. 
     

(defun c:vo ()<br />   (vl-load-com)<br />   (setq  AcadObject   (vlax-get-acad-object)<br />   AcadDocument (vla-get-ActiveDocument AcadObject)<br />   mSpace       (vla-get-ModelSpace AcadDocument)<br />   )<br />   (defun midpoint (pt1 pt2)<br /> <br />     (setq pmid<br />      (list (/ (+ (car pt2) (car pt1)) 2.0)<br />      (/ (+ (cadr pt2) (cadr pt1)) 2.0)<br />      (/ (+ (caddr pt2) (caddr pt1)) 2.0)<br />      )<br />     )<br />   )<br /> <br />   (defun gxl-removeNth (index lst / c)<br />     (setq c -1)<br />     (apply 'append<br />      (mapcar '(lambda (x)<br />           (if (/= (setq c (1+ c)) index)<br />       (list x)<br />           )<br />         )<br />        lst<br />      )<br />     )<br />   )<br />   (print "选择点：")<br />   (setq ss (ssget '((0 . "POINT"))))<br />   (setq n (sslength ss))<br />   (print "选择曲线：")<br />   (setq pline (car (entsel)))<br />   (setq t0 (getvar "TDUSRTIMER"))<br />   (command "undo" "begin")<br />   (vla-getboundingbox<br />     (vlax-ename->vla-object pline)<br />     'pt1a<br />     'pt2a<br />   )<br />   (setq  l (* (distance (vlax-safearray->list pt2a)<br />            (vlax-safearray->list pt1a)<br />        )<br />        5.0<br />     )<br />   )<br /> <br /> <br />   (setq i 0)<br />   (setq listpoint (list))<br />   (repeat n<br />     (setq ssthnth (ssname ss i))<br /> <br />     (setq listpoint (cons<br />           (cdr (assoc 10 (entget ssthnth)))<br />           listpoint<br />         )<br />     )<br />     (setq i (1+ i))<br />   )<br /> <br />   (setq j (length listpoint))<br />   (setq j1 (- j 1))<br />   (setq jj 0)<br /> <br /> <br />   (repeat j<br />     (setq pointj (nth jj listpoint))<br />     (setq biao (gxl-removeNth jj listpoint))<br />     (setq jjj 0)<br />     (setq xuanzhe (ssadd))<br />     (repeat j1<br />       (setq pointi (nth jjj biao))<br /> ;(command "line" "non" pointj "non" pointi "")<br /> <br />       (setq ang (angle pointj pointi))<br />       (setq ang2 (+ ang (/ pi 2.0)))<br />       (setq ang3 (- ang (/ pi 2.0)))<br />       (setq ang4 (- ang (/ pi 1.0)))<br />       (setq pt0 (midpoint pointj pointi))<br /> ;(command "line" "non" pointj "non" pt0 "")<br /> <br />       (setq pt1 (polar pt0 ang2 l))<br />       (setq pt4 (polar pt0 ang3 l))<br />       (setq pt2 (polar pt1 ang4 l))<br />       (setq pt3 (polar pt4 ang4 l))<br /> <br /> <br /> ;(setq LST (append pt1 pt2 pt3 pt4  ))<br /> ;(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 11)))<br /> ;(vlax-safearray-fill mat lst)<br />       (setq LST (list pt1 pt2 pt3 pt4))<br />       (entmake<br />   (append  (list '(0 . "LWPOLYLINE")<br />           '(100 . "AcDbEntity")<br />           '(100 . "AcDbPolyline")<br /> <br />           (cons 90 (length LST))<br />           '(70 . 1)<br />     )<br />     (mapcar '(lambda (ptrr) (cons 10 ptrr)) LST)<br />   )<br />       )<br /> ;(vla-Put-Closed obj :vlax-True)<br />       (setq lastwuti (entlast))<br /> <br /> ;(command "_REGION" xxxx "")<br /> ;(setq xxxxl (entlast))<br />       (ssadd lastwuti xuanzhe)<br /> ;(setq quxian  (vla-AddPolyline mSpace mat))<br /> ;(setq quxian (vla-Put-Closed quxian :vlax-True))<br /> ;(setq quxian3 (myRegion LST))<br /> <br /> <br />       (setq jjj (1+ jjj))<br />     )<br />     (vl-cmdf "-BOUNDARY" pointj "")<br />     (vl-cmdf "ERASE" xuanzhe "")<br /> <br />     (setq jj (1+ jj))<br />   )<br />   (command "undo" "end")<br /> <br />   (princ (* (- (getvar "TDUSRTIMER") t0) 86400))<br />   (princ "秒")<br />   (princ)<br /> )<br /> <br /> <br />