Code Red > AutoLISP (Vanilla / Visual)
==={Challenge}=== Voronoi diagram
ribarm:
Hi all...
Recently I've been experimenting with Delunay triangulation and Vonoroi diagram, and I realized I can't make one correctly without help of someone like Evgeniy or Lee... I used Evgeniy's code for triangulation and tried to build Vonoroi diagram based on triangles obtained after trunagulate... But no success, all I get is mess as I don't know how to correctly connect triangles circumcenters...
Here is what I've got so far :
--- Code: ---(defun c:test (/ i s ext)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
)
(repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i (1+ i)
)
)
)
(triangulate pl)
(setq ext (ACET-GEOM-SS-EXTENTS-ACCURATE (ssget "_X" '((0 . "3DFACE") (8 . "TIN")))))
(setq pl (vl-sort pl '(lambda (a b) (< (distance a (car ext)) (distance b (car ext))))))
(or (tblsearch "LAYER" "Vonoroi")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "Vonoroi") '(70 . 0)
'(62 . 1) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(start (list (car pl) (cadr pl)))
)
(defun start (lst / ss pll)
(command "_.region" (ssget "_F" lst '((0 . "3DFACE") (8 . "TIN"))) "")
(command "_.union" (ssget "_X" '((0 . "REGION") (8 . "TIN"))) "")
(command "_.explode" (entlast) "")
(setq ss (ssget "_X" '((0 . "LINE") (8 . "TIN"))))
(command "pedit" "_m" ss "" "_y" "_j" "" "")
(setq pll (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (entlast)))))
(entdel (entlast))
(vonoroi pll lst)
(princ)
)
(defun vonoroi (lst lstt / ss i tr p1 p2 p3 p12 p23 p31 llst o ol oll)
(command "_.erase" (ssget "_X" '((0 . "3DFACE") (8 . "TIN"))) "")
(triangulate pl)
(setq ss (ssget "_F" lst '((0 . "3DFACE") (8 . "TIN"))))
(setq i -1)
(while (setq tr (ssname ss (setq i (1+ i))))
(setq p1 (cdr (assoc 11 (entget tr)))
p2 (cdr (assoc 12 (entget tr)))
p3 (cdr (assoc 13 (entget tr)))
)
(setq p12 (mid p1 p2)
p23 (mid p2 p3)
p31 (mid p3 p1)
)
(if (member-fuzz p1 lstt 1e-6) (setq llst (vl-remove p1 lst)))
(if (member-fuzz p2 lstt 1e-6) (setq llst (vl-remove p2 lst)))
(if (member-fuzz p3 lstt 1e-6) (setq llst (vl-remove p3 lst)))
(setq o (inters p12 (mapcar '+ p12 (polar '(0.0 0.0 0.0) (+ (angle p1 p2) (* pi 0.5)) 1.0)) p23 (mapcar '+ p23 (polar '(0.0 0.0 0.0) (+ (angle p2 p3) (* pi 0.5)) 1.0)) nil))
(setq ol (cons o ol))
)
(setq oll (cons ol oll))
(if llst
(start llst)
(mapcar '(lambda (a b) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 a) (cons 11 b)))) (apply 'append (reverse oll)) (cdr (apply 'append (reverse oll))))
;;; (mapcar '(lambda (a b) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 a) (cons 11 b)))) (apply 'append (apply 'mapcar (cons 'list (reverse oll)))) (cdr (apply 'append (apply 'mapcar (cons 'list (reverse oll)))))) - If I transpose list with lists of points, I also get bad results ;;;
)
)
(defun member-fuzz (el lst fuzz)
(vl-member-if '(lambda (x) (equal x el fuzz)) lst)
)
(defun mid (p1 p2)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun triangulate (pl / a b c i i1 i2 bb sl al el tl l ma mi tr x1 x2
y1 y2 p r cp)
(if pl
(progn
(setq
i 1
i1 (/ (length pl) 100.)
i2 0
pl (vl-sort pl
(function (lambda (a b) (< (car a) (car b))))
)
bb (list (apply 'mapcar (cons 'min pl))
(apply 'mapcar (cons 'max pl))
)
x1 (caar bb)
x2 (caadr bb)
y1 (cadar bb)
y2 (cadadr bb)
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0))
r (* (distance cp (list x1 y1)) 20)
ma (+ (car cp) r)
mi (- (car cp) r)
sl (list (list ma (cadr cp) 0)
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
ma (1- ma)
mi (1+ mi)
)
(repeat (length pl)
(setq p (car pl)
pl (cdr pl)
el nil
)
(while al
(setq tr (car al)
al (cdr al)
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a (car tr)
b (cadr tr)
c (caddr tr)
el (cons (list (+ (car a) (car b))
(+ (cadr a) (cadr b))
a
b
)
(cons (list (+ (car b) (car c))
(+ (cadr b) (cadr c))
b
c
)
(cons (list (+ (car c) (car a))
(+ (cadr c) (cadr a))
c
a
)
el
)
)
)
)
)
(t (setq l (cons tr l)))
)
)
(setq al l
l nil
el (vl-sort el
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
)
)
(while el
(if (and (= (caar el) (caadr el))
(= (cadar el) (cadadr el))
)
(setq el (cddr el))
(setq al (cons (getcircumcircle p (cddar el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cdddr tr) tl)))
(setq
tl (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
(or (tblsearch "LAYER" "TIN")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN") '(70 . 0)
'(62 . 8) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach tr tl
(entmake (list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
)
)
)
(princ)
)
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b (car el)
c (cadr el)
c2 (list (car c) (cadr c))
)
(if (not
(zerop
(setq ang (- (angle b c) (angle b a)))
)
)
(progn (setq cp (polar c2
(+ -1.570796326794896 (angle c a) ang)
(setq r (/ (distance a c2) (sin ang) 2.0))
)
r (abs r)
)
(list (+ (car cp) r) cp r a b c)
)
)
)
--- End code ---
Thanks, M.R.
ribarm:
This won't work also...
--- Code: ---(defun c:test (/ i s)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
)
(repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i (1+ i)
)
)
)
(triangulate pl)
)
(defun triangulate (pl / a b c i i1 i2 bb sl al el tl l ma mi tr x1 x2
y1 y2 p r cp)
(if pl
(progn
(setq
i 1
i1 (/ (length pl) 100.)
i2 0
pl (vl-sort pl
(function (lambda (a b) (< (car a) (car b))))
)
bb (list (apply 'mapcar (cons 'min pl))
(apply 'mapcar (cons 'max pl))
)
x1 (caar bb)
x2 (caadr bb)
y1 (cadar bb)
y2 (cadadr bb)
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0))
r (* (distance cp (list x1 y1)) 20)
ma (+ (car cp) r)
mi (- (car cp) r)
sl (list (list ma (cadr cp) 0)
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
ma (1- ma)
mi (1+ mi)
)
(repeat (length pl)
(setq p (car pl)
pl (cdr pl)
el nil
)
(while al
(setq tr (car al)
al (cdr al)
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a (car tr)
b (cadr tr)
c (caddr tr)
el (cons (list (+ (car a) (car b))
(+ (cadr a) (cadr b))
a
b
)
(cons (list (+ (car b) (car c))
(+ (cadr b) (cadr c))
b
c
)
(cons (list (+ (car c) (car a))
(+ (cadr c) (cadr a))
c
a
)
el
)
)
)
)
)
(t (setq l (cons tr l)))
)
)
(setq al l
l nil
el (vl-sort el
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
)
)
(while el
(if (and (= (caar el) (caadr el))
(= (cadar el) (cadadr el))
)
(setq el (cddr el))
(setq al (cons (getcircumcircle p (cddar el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cdddr tr) tl)))
(setq
tl (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
(or (tblsearch "LAYER" "TIN")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN") '(70 . 0)
'(62 . 8) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(or (tblsearch "LAYER" "Vonoroi")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "Vonoroi") '(70 . 0)
'(62 . 1) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach tr tl
(entmake (list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
)
(mapcar '(lambda (tr1 tr2) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 (otr tr1)) (cons 11 (otr tr2))))) tl (cdr tl))
)
)
(princ)
)
(defun mid (p1 p2)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun otr (tr / p1 p2 p3 p12 p23 p31 o)
(setq p1 (car tr)
p2 (cadr tr)
p3 (caddr tr)
)
(setq p12 (mid p1 p2)
p23 (mid p2 p3)
p31 (mid p3 p1)
)
(setq o (inters p12 (mapcar '+ p12 (polar '(0.0 0.0 0.0) (+ (angle p1 p2) (* pi 0.5)) 1.0)) p23 (mapcar '+ p23 (polar '(0.0 0.0 0.0) (+ (angle p2 p3) (* pi 0.5)) 1.0)) nil))
o
)
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b (car el)
c (cadr el)
c2 (list (car c) (cadr c))
)
(if (not
(zerop
(setq ang (- (angle b c) (angle b a)))
)
)
(progn (setq cp (polar c2
(+ -1.570796326794896 (angle c a) ang)
(setq r (/ (distance a c2) (sin ang) 2.0))
)
r (abs r)
)
(list (+ (car cp) r) cp r a b c)
)
)
)
--- End code ---
Anyone, help, thanks...
:-(
ribarm:
Neither this, my old slow algorithm for up to 100 pts won't work...
--- Code: ---(defun averpttriang (triangle)
(mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) (car triangle) (cadr triangle) (caddr triangle))
)
(defun unique (lst)
(if lst (cons (car lst) (unique (vl-remove (car lst) (cdr lst)))))
)
(defun uniquetriangles (triangles / lst assoctriangles uniquetriangs)
(foreach triangle triangles
(setq lst (cons (averpttriang triangle) lst))
)
(setq lst (unique lst))
(foreach triangle triangles
(setq assoctriangles (cons (cons (averpttriang triangle) triangle) assoctriangles))
)
(foreach averpt lst
(setq uniquetriangs (cons (cdr (assoc averpt assoctriangles)) uniquetriangs))
)
uniquetriangs
)
(defun flatten (lst / lstn)
(foreach triangle (reverse lst)
(setq lstn (cons (caddr triangle) lstn) lstn (cons (cadr triangle) lstn) lstn (cons (car triangle) lstn))
)
(reverse lstn)
)
(defun nearest (pt lst / d1 d2 p1 p2)
(setq lst (vl-remove pt lst))
(setq d1 (distance pt (car lst)) p1 (car lst))
(foreach p2 (cdr lst)
(if (> d1 (setq d2 (distance pt p2)))
(setq d1 d2 p1 p2)
)
)
p1
)
(defun mid (p1 p2)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun otr (tr / p1 p2 p3 p12 p23 p31 o)
(setq p1 (car tr)
p2 (cadr tr)
p3 (caddr tr)
)
(setq p12 (mid p1 p2)
p23 (mid p2 p3)
p31 (mid p3 p1)
)
(setq o (inters p12 (mapcar '+ p12 (polar '(0.0 0.0 0.0) (+ (angle p1 p2) (* pi 0.5)) 1.0)) p23 (mapcar '+ p23 (polar '(0.0 0.0 0.0) (+ (angle p2 p3) (* pi 0.5)) 1.0)) nil))
o
)
(defun circumtriang (p1 p2 p3 / pp1 pp2 pp3 mp1p2 mp2p3 npmp1p2 npmp2p3 cen rad)
(setq pp1 (list (car p1) (cadr p1)))
(setq pp2 (list (car p2) (cadr p2)))
(setq pp3 (list (car p3) (cadr p3)))
(setq mp1p2 (mid pp1 pp2))
(setq mp2p3 (mid pp2 pp3))
(setq npmp1p2 (polar mp1p2 (+ (angle pp1 pp2) (/ pi 2.0)) 1.0))
(setq npmp2p3 (polar mp2p3 (+ (angle pp2 pp3) (/ pi 2.0)) 1.0))
(setq cen (inters mp1p2 npmp1p2 mp2p3 npmp2p3 nil))
(setq rad (distance cen p1))
(list cen rad)
)
(defun ptinsidecir (pt circle)
(setq pt (list (car pt) (cadr pt)))
(> (cadr circle) (distance (car circle) pt))
)
(defun c:triangulate ( / ss n pt ptlst pttlst p1 p2 p3 p2lstt p2lst p3lst loop2 loop3 k circle pp lst triangles tl)
(setq ss (ssget '((0 . "POINT"))))
(vl-cmdf "_.time" "r" "")
(repeat (setq n (sslength ss))
(setq pt (cdr (assoc 10 (entget (ssname ss (setq n (1- n)))))))
(setq ptlst (cons pt ptlst))
)
(setq ptlst (vl-sort ptlst '(lambda (a b) (< (car a) (car b)))))
(setq pttlst ptlst)
(acet-ui-progress "Progress : " n)
(while (> (length ptlst) 2)
(setq p1 (car ptlst))
(setq p2lst (cdr ptlst))
(setq p2lstt p2lst)
(setq loop2 T)
(while loop2
(setq p2 (car p2lst))
(setq p2lst (cdr p2lst))
(setq p3lst (vl-remove p2 p2lstt))
(setq k 0)
(setq loop3 T)
(while loop3
(setq p3 (car p3lst))
(setq p3lst (cdr p3lst))
(setq circle (circumtriang p1 p2 p3))
(setq pp (nearest (car circle) (vl-remove p1 (vl-remove p2 (vl-remove p3 pttlst)))))
(if (not (ptinsidecir pp circle))
(progn
(setq lst (cons p1 lst) lst (cons p2 lst) lst (cons p3 lst))
(setq triangles (cons lst triangles))
(setq k (1+ k))
)
)
(setq lst nil)
(if (equal p1 (car ptlst) 1e-8) (setq ptlst (cdr ptlst)))
(if (eq k 2) (setq loop3 nil p2lst (vl-remove p3 p2lst) p2lst (cons p3 p2lst)))
(if (and (eq k 2) (member p3 (flatten (cdr triangles)))) (setq loop2 nil))
(if (eq p3lst nil) (setq loop3 nil))
(if (or (= (length ptlst) 2) (eq p2lst nil)) (setq loop2 nil))
)
)
(acet-ui-progress -1)
)
(or (tblsearch "LAYER" "TIN")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN") '(70 . 0)
'(62 . 8) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(or (tblsearch "LAYER" "Vonoroi")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "Vonoroi") '(70 . 0)
'(62 . 1) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach triangle (setq tl (uniquetriangles triangles))
(entmake (list (cons 0 "3DFACE")(cons 10 (car triangle))(cons 11 (cadr triangle))(cons 12 (caddr triangle))(cons 13 (caddr triangle))))
)
(mapcar '(lambda (tr1 tr2) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 (otr tr1)) (cons 11 (otr tr2))))) tl (cdr tl))
(acet-ui-progress-done)
(vl-cmdf "_.time" "d" "")
(princ)
)
--- End code ---
M.R.
ribarm:
This is better, but not just what should it be...
Please study this link :
http://www.cs.cornell.edu/home/chew/Delaunay.html
--- Code: ---(defun c:test (/ i s)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
)
(repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i (1+ i)
)
)
)
(triangulate pl)
)
(defun triangulate (pl / a b c i i1 i2 bb sl al el tl l ma mi tr x1 x2
y1 y2 p r cp ol oll)
(if pl
(progn
(setq
i 1
i1 (/ (length pl) 100.)
i2 0
pl (vl-sort pl
(function (lambda (a b) (< (car a) (car b))))
)
bb (list (apply 'mapcar (cons 'min pl))
(apply 'mapcar (cons 'max pl))
)
x1 (caar bb)
x2 (caadr bb)
y1 (cadar bb)
y2 (cadadr bb)
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0))
r (* (distance cp (list x1 y1)) 20)
ma (+ (car cp) r)
mi (- (car cp) r)
sl (list (list ma (cadr cp) 0)
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
ma (1- ma)
mi (1+ mi)
)
(repeat (length pl)
(setq p (car pl)
pl (cdr pl)
el nil
)
(while al
(setq tr (car al)
al (cdr al)
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a (car tr)
b (cadr tr)
c (caddr tr)
el (cons (list (+ (car a) (car b))
(+ (cadr a) (cadr b))
a
b
)
(cons (list (+ (car b) (car c))
(+ (cadr b) (cadr c))
b
c
)
(cons (list (+ (car c) (car a))
(+ (cadr c) (cadr a))
c
a
)
el
)
)
)
)
)
(t (setq l (cons tr l)))
)
)
(setq al l
l nil
el (vl-sort el
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
)
)
(while el
(if (and (= (caar el) (caadr el))
(= (cadar el) (cadadr el))
)
(setq el (cddr el))
(setq al (cons (getcircumcircle p (cddar el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cdddr tr) tl)))
(setq
tl (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
(or (tblsearch "LAYER" "TIN")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN") '(70 . 0)
'(62 . 8) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(or (tblsearch "LAYER" "Vonoroi")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "Vonoroi") '(70 . 0)
'(62 . 1) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach tr tl
(entmake (list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
(setq ol (cons (otr tr) ol))
)
(setq ol (_sortol (car ol) ol))
(mapcar '(lambda (a b) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 a) (cons 11 b)))) ol (cdr ol))
)
)
(princ)
)
(defun _sortol (pt lst)
(setq oll (cons (setq pt (NearestFromPoint lst pt)) oll))
(if (setq lst (vl-remove pt lst)) (_sortol pt lst) (reverse oll))
)
(defun NearestFromPoint (lst pt / d1 d2 p1 p2)
(setq lst (vl-remove pt lst))
(setq d1 (distance pt (car lst))
p1 (car lst)
)
(foreach p2 (cdr lst)
(if (> d1 (setq d2 (distance pt p2)))
(setq d1 d2 p1 p2)
)
)
p1
)
(defun mid (p1 p2)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun otr (tr / p1 p2 p3 p12 p23 p31 o)
(setq p1 (car tr)
p2 (cadr tr)
p3 (caddr tr)
)
(setq p12 (mid p1 p2)
p23 (mid p2 p3)
p31 (mid p3 p1)
)
(setq o (inters p12 (mapcar '+ p12 (polar '(0.0 0.0 0.0) (+ (angle p1 p2) (* pi 0.5)) 1.0)) p23 (mapcar '+ p23 (polar '(0.0 0.0 0.0) (+ (angle p2 p3) (* pi 0.5)) 1.0)) nil))
o
)
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b (car el)
c (cadr el)
c2 (list (car c) (cadr c))
)
(if (not
(zerop
(setq ang (- (angle b c) (angle b a)))
)
)
(progn (setq cp (polar c2
(+ -1.570796326794896 (angle c a) ang)
(setq r (/ (distance a c2) (sin ang) 2.0))
)
r (abs r)
)
(list (+ (car cp) r) cp r a b c)
)
)
)
--- End code ---
ribarm:
This code is too slow - it takes ab 10 min. for 500 pts and it produces too many lines...
--- Code: ---(defun c:test (/ i s)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
)
(repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i (1+ i)
)
)
)
(triangulate pl)
)
(defun triangulate (pl / a b c i i1 i2 bb sl al el tl l ma mi tr x1 x2
y1 y2 p r cp ol ss)
(if pl
(progn
(setq
i 1
i1 (/ (length pl) 100.)
i2 0
pl (vl-sort pl
(function (lambda (a b) (< (car a) (car b))))
)
bb (list (apply 'mapcar (cons 'min pl))
(apply 'mapcar (cons 'max pl))
)
x1 (caar bb)
x2 (caadr bb)
y1 (cadar bb)
y2 (cadadr bb)
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0))
r (* (distance cp (list x1 y1)) 20)
ma (+ (car cp) r)
mi (- (car cp) r)
sl (list (list ma (cadr cp) 0)
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
ma (1- ma)
mi (1+ mi)
)
(repeat (length pl)
(setq p (car pl)
pl (cdr pl)
el nil
)
(while al
(setq tr (car al)
al (cdr al)
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a (car tr)
b (cadr tr)
c (caddr tr)
el (cons (list (+ (car a) (car b))
(+ (cadr a) (cadr b))
a
b
)
(cons (list (+ (car b) (car c))
(+ (cadr b) (cadr c))
b
c
)
(cons (list (+ (car c) (car a))
(+ (cadr c) (cadr a))
c
a
)
el
)
)
)
)
)
(t (setq l (cons tr l)))
)
)
(setq al l
l nil
el (vl-sort el
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
)
)
(while el
(if (and (= (caar el) (caadr el))
(= (cadar el) (cadadr el))
)
(setq el (cddr el))
(setq al (cons (getcircumcircle p (cddar el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cdddr tr) tl)))
(setq
tl (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
(or (tblsearch "LAYER" "TIN")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "TIN") '(70 . 0)
'(62 . 8) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(or (tblsearch "LAYER" "Vonoroi")
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(2 . "Vonoroi") '(70 . 0)
'(62 . 1) '(6 . "Continuous")
'(290 . 1) '(370 . -3)
)
)
)
(setvar "CLAYER" "TIN")
(foreach tr tl
(entmake (list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
(setq ol (cons (otr tr) ol))
)
(foreach o ol
(setq ol (_sortol o ol))
(mapcar '(lambda (a b) (entmake (list '(0 . "LINE") '(8 . "Vonoroi") (cons 10 a) (cons 11 b)))) ol (cdr ol))
(setq oll nil)
)
(setq ss (ssget "_X" '((0 . "LINE") (8 . "Vonoroi"))))
(command "_.-overkill" ss "" "")
)
)
(princ)
)
(defun _sortol (pt lst)
(setq oll (cons (setq pt (NearestFromPoint lst pt)) oll))
(if (setq lst (vl-remove pt lst)) (_sortol pt lst) (reverse oll))
)
(defun NearestFromPoint (lst pt / d1 d2 p1 p2)
(setq lst (vl-remove pt lst))
(setq d1 (distance pt (car lst))
p1 (car lst)
)
(foreach p2 (cdr lst)
(if (> d1 (setq d2 (distance pt p2)))
(setq d1 d2 p1 p2)
)
)
p1
)
(defun mid (p1 p2)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
)
(defun otr (tr / p1 p2 p3 p12 p23 p31 o)
(setq p1 (car tr)
p2 (cadr tr)
p3 (caddr tr)
)
(setq p12 (mid p1 p2)
p23 (mid p2 p3)
p31 (mid p3 p1)
)
(setq o (inters p12 (mapcar '+ p12 (polar '(0.0 0.0 0.0) (+ (angle p1 p2) (* pi 0.5)) 1.0)) p23 (mapcar '+ p23 (polar '(0.0 0.0 0.0) (+ (angle p2 p3) (* pi 0.5)) 1.0)) nil))
o
)
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b (car el)
c (cadr el)
c2 (list (car c) (cadr c))
)
(if (not
(zerop
(setq ang (- (angle b c) (angle b a)))
)
)
(progn (setq cp (polar c2
(+ -1.570796326794896 (angle c a) ang)
(setq r (/ (distance a c2) (sin ang) 2.0))
)
r (abs r)
)
(list (+ (car cp) r) cp r a b c)
)
)
)
--- End code ---
No avail, I give up... Still any post is welcome...
Thanks, M.R.
Navigation
[0] Message Index
[#] Next page
Go to full version