;;; TRIANGULATE.LSP ;
;;; ;
;;; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
;;; ;
;;; Plain ALisp version of C code "Triangulate" written by PAUL BOURKE ;
;;; ;
;;; This program triangulate an irregular set of points. You can download a plain ;
;;; introduction to this algorithm at Paul Bourke's site. Here you find a complete ;
;;; version in plain Autolisp (for those that not use VLisp). You can replace some ;
;;; code (sorting, list manipulation,...) with VLisp functions to reduce the
;
;;; execution time. This code is not seriously tested, if you find a bug...sorry!! ;
;;; Goodbye, Daniele ;
;;; ;
;;;
;;; Autor: Daniele Piazza <piazza@mec-sol.com>
;;; DXFN ;
;;; ;
;;; Get DXF code from entity. If you would obtain code that run quickly do not use ;
;;; this function (entget is slowly!!) ;
;;; ;
(defun DXFN (code name)
(cdr (assoc code (entget name)))
)


;;; XSORT ;
;;; ;
;;; Sorting function, replace with VLISP sort (more and more efficient!!!) ;
;;; ;
;;; Funzione di ordinamento secondo l'algoritmo shellshort ;
;;; modificato per soddisfare il nostro ordinamento. Ordina una lista ;
;;; di punti secondo x crescente (ordinamento primario) e la y crescente ;
;;; (ordinamento secondario). ;

(defun XSORT (LST / LST1 a b LO HI OK fuzzy)
(setq fuzzy 1e-8)
(repeat (/ (length LST) 2)
(setq LO (car LST)
HI nil
LST1 nil
)
(foreach pt (cdr LST)
(and (or (< (car pt) (car LO))
(and (equal (car pt) (car LO) fuzzy)
(< (cadr pt) (cadr LO))
)
)
(setq OK LO
LO pt
pt OK
)
)
(and (or (> (car pt) (car HI))
(and (equal (car pt) (car HI) fuzzy)
(> (cadr pt) (cadr HI))
)
)
(setq OK HI
HI pt
pt OK
)
)
(setq LST1 (cons pt LST1))
);f
(setq A (cons LO A)
B (cons HI B)
LST (cdr (reverse LST1))
)
);r
(append (reverse A) LST B)
)

;;; NTH_DEL ;
;;; ;
;;; delete the n item in the list (by position, not by value!!) ;
;;; ;
;;; Elimina l'oggetto che si trova nella posizione N della lista LST. L'utilizzo di ;
;;; funzioni ricorsive,oltre a non assicurare maggiore velocita, puo creare problemi;
;;; di overflow dello stack in caso di liste molto lunghe. ;
(defun NTH_DEL (N LST / l)
(repeat n
(setq l (cons (car lst) l)
lst (cdr lst)
)
)
(append (reverse l)(cdr lst))
)

;;; NTH_SUBST ;
;;; ;
;;; Replace the index element in the list with new element. This function is
;
;;; recursive this is not a great solution with a large amount of data. ;
;;; ;
(defun NTH_SUBST (index new Alist)
(cond
((minusp index) Alist)
((zerop index)(cons new (cdr Alist)))
(T (cons (car Alist)(nth_subst (1- index) new (cdr Alist))))
)
)

;;; ISVALIDSET ;
;;; ;
;;; Check selection set ;
;;; ;
(defun ISVALIDSET (ss1)
(and ss1 (not (zerop (sslength ss1))))
)

;;; GETPTLIST ;
;;; ;
;;; sset -> list (p1 p2 p3 ... pn) ;
;;; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (isvalidset ss1)
(progn
(setq i 0)
(while (setq pt (ssname ss1 i))
(setq ptlst (cons (dxfn 10 pt) ptlst)
i (1+ i)
)
)
)
)
ptlst
)

;;; FINDSUPERTRIANGLE ;
;;; ;
;;; Search the supertriangle that contain all points in the data set ;
;;; ;

(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin zmax zmin dx dy dmax
xmid ymid trx1 trx2 trx3 try1 try2 try3
trz1 trz2 trz3
)
(setq xmax (apply 'max (mapcar 'car ptlst))
xmin (apply 'min (mapcar 'car ptlst))
ymax (apply 'max (mapcar 'cadr ptlst))
ymin (apply 'min (mapcar 'cadr ptlst))
;;; zmax (apply 'max (mapcar 'caddr ptlst))
;;; zmin (apply 'min (mapcar 'caddr ptlst))
dx (- xmax xmin)
dy (- ymax ymin)
dmax (max dx dy)
xmid (* (+ xmax xmin) 0.5)
ymid (* (+ ymax ymin) 0.5)
trx1 (- xmid (* dmax 2.0))
try1 (- ymid dmax)
trz1 0.0
trx2 xmid
try2 (+ ymid dmax)
trz2 0.0
trx3 (+ xmid (* dmax 2.0))
try3 (- ymid dmax)
trz3 0.0
)
(list (list trx1 try1 trz1)
(list trx2 try2 trz2)
(list trx3 try3 trz3)
)
)
;;; GETCIRCIRCUMCIRCLE ;
;;; ;
;;; Calculate the circumcircle (center, radius) of triangle in input ;
;;; ;

(defun GETCIRCIRCUMCIRCLE (triangle / p1 p2 p3 p1x p2x p3x p1y p2y p3y d xc
yc rad)
(setq p1 (car triangle)
p2 (cadr triangle)
p3 (caddr triangle)
p1x (car p1) p1y (cadr p1)
p2x (car p2) p2y (cadr p2)
p3x (car p3) p3y (cadr p3)
d (* 2.0 (+ (* p1y p3x)
(* p2y p1x)
(- (* p2y p3x))
(- (* p1y p2x))
(- (* p3y p1x))
(* p3y p2x)
)
)
xc (/ (+ (* p2y p1x p1x )
(- (* p3y p1x p1x))
(- (* p2y p2y p1y))
(* p3y p3y p1y)
(* p2x p2x p3y)
(* p1y p1y p2y)
(* p3x p3x p1y)
(- (* p3y p3y p2y))
(- (* p3x p3x p2y))
(- (* p2x p2x p1y))
(* p2y p2y p3y)
(- (* p1y p1y p3y))
)
d
)
yc (/ (+ (* p1x p1x p3x)
(* p1y p1y p3x)
(* p2x p2x p1x)
(- (* p2x p2x p3x))
(* p2y p2y p1x)
(- (* p2y p2y p3x))
(- (* p1x p1x p2x))
(- (* p1y p1y p2x))
(- (* p3x p3x p1x))
(* p3x p3x p2x)
(- (* p3y p3y p1x))
(* p3y p3y p2x)
)
d
)
rad (sqrt (+ (* (- p1x xc)(- p1x xc))
(* (- p1y yc)(- p1y yc))
)
)
)
(list (list xc yc) rad)
)

;;; ISINSIDE ;
;;; ;
;;; test if pt is inside a circle ;
;;; ;
(defun ISINSIDE (pt circle)
(setq ctr (car circle)
rad (cadr circle)
)
(< (distance pt ctr) rad)
)
;;; ADDTRIANGLEEDGES ;
;;; ;
;;; add triangle edges at the edge queue ;
;;; ;
(defun ADDTRIANGLEEDGES (triangle edgelst)
(append edgelst (list (list (car triangle)(cadr triangle))
(list (cadr triangle)(caddr triangle))
(list (caddr triangle)(car triangle))
)
)
)
;;; DRAWTRIANGLE ;
;;; ;
;;; the fun side if the algorithm. Draw triangulation. ;
;;; ;
(defun DRAWTRIANGLE (triangle)
;(entmake (list (cons 0 "LINE")(cons 10 (car triangle))(cons 11 (cadr triangle))))
;(entmake (list (cons 0 "LINE")(cons 10 (cadr triangle))(cons 11 (caddr triangle))))
;(entmake (list (cons 0 "LINE")(cons 10 (caddr triangle))(cons 11 (car triangle))))
(entmake
(list (cons 0 "3DFACE")
(cons 10 (car triangle))
(cons 11 (cadr triangle))
(cons 12 (caddr triangle))
(cons 13 (car triangle))
)
)
; (grdraw (car triangle)(cadr triangle) 1)
; (grdraw (cadr triangle)(caddr triangle) 1)
; (grdraw (caddr triangle)(car triangle) 1)
)
;;; EQUALMEMBER ;
;;; ;
;;; Check if "item" is in "lista" or not by equality test. With real number the ;
;;; standard fuction "member" not work correctly. ;
;;; ;
(defun EQUALMEMBER (item lista fuzzy)
(apply 'or (mapcar '(lambda (x) (equal x item fuzzy)) lista))
)
;;; REMOVEDOUBLYEDGES ;
;;; ;
;;; Test the edge queue to remove duplicates (warning CW & CCW!) ;
;;; ;
(defun REMOVEDOUBLYEDGES (edgelst fuzzy nulllist / i k)
(setq j 0)
(while (< j (length edgelst))
(setq k (1+ j))
(while (< k (length edgelst))
(if
(or (and (equal (car (nth j edgelst)) (car (nth k edgelst)) fuzzy)
(equal (cadr (nth j edgelst)) (cadr (nth k edgelst)) fuzzy)
)
(and (equal (car (nth j edgelst)) (cadr (nth k edgelst)) fuzzy)
(equal (cadr (nth j edgelst)) (car (nth k edgelst)) fuzzy)
)
)
(setq edgelst (nth_subst j nulllist edgelst)
edgelst (nth_subst k nulllist edgelst)
)
)
(setq k (1+ k))
)
(setq j (1+ j))
)
edgelst
)

;;; ADDNEWTRIANGLES ;
;;; ;
;;; Add new triangle generated by pt to triangle list. ;
;;; ;
(defun ADDNEWTRIANGLES (pt edgelst trianglelst / j triangle )
(setq j 0)
(while (< j (length edgelst))
(if (nth j edgelst)
(setq triangle (cons pt (nth j edgelst))
trianglelst (cons (list triangle nil) trianglelst)
)
)
(setq j (1+ j))
)
trianglelst
)

;;; PURGETRIANGLELST ;
;;; ;
;;; replace all triangles that share a vertex with supertriangle ;
;;; ;
(defun PURGETRIANGLELST (trianglelst supertriangle fuzzy / j triangle)
(setq j 0)
(while (and trianglelst (setq triangle (car (nth j trianglelst))))
(if (apply 'or
(mapcar '(lambda (x) (equalmember x supertriangle fuzzy))
triangle
)
)
(setq trianglelst (nth_del j trianglelst))
(setq j (1+ j))
)
)
)
;;; C:TRIANGULATE ;
;;; ;

(defun C:TRIANGULATE (/ fuzzy nulllist ss1 ptlst nv supertriangle
trianglelst i j k edgelst
circle pt flag
)
(setq fuzzy 1e-8 ;tolerance in equality test
nulllist nil ;
)
(princ "\nSelect points...")
(setq ss1 (ssget)
ptlst (getptlist ss1)
ptlst (xsort ptlst)
nv (length ptlst) ;number of points
supertriangle (findsupertriangle ptlst)
ptlst (append ptlst supertriangle) ;append coordinates to the end of vertex list
trianglelst (list (list supertriangle nil)) ;add supertriangle to the triangle list
)
(setq i 0)
(while (< i nv)
(setq pt (nth i ptlst))
;;; initialize edge buffer
(setq edgelst nil)
(setq j 0)
(while (and trianglelst
(setq triangle (car (nth j trianglelst)))
)
(setq flag t)
(if (not (cadr (nth j trianglelst)))
(progn
;;; calculate circumcircle
(setq circle (getcircircumcircle triangle))
;;; test point x and (pt) location
(if (< (+ (caar circle)(cadr circle)) (car pt))
(setq trianglelst (nth_subst j (list (car (nth j trianglelst)) T)
trianglelst))
)
(if (isinside pt circle)
(setq edgelst (addtriangleedges triangle edgelst)
trianglelst (nth_del j trianglelst)
flag nil
)
)
)
)
(if flag
(setq j (1+ j))
)
)
;;; remove all doubly specified edges
(setq edgelst (removedoublyedges edgelst fuzzy nulllist))
;;; form new triangles for current point
(setq trianglelst (addnewtriangles pt edgelst trianglelst))
;;; get next vertex
(setq i (1+ i))
)
;;; remove triangles with supertriangles edges
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy))
;;; draw triangulation
(foreach triangle (mapcar 'car trianglelst)
(drawtriangle triangle)
)
(princ)
)