;******************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*******************************************************************
;
(defun C:TRIANGULATE (/ fuzzy nulllist ss1 ptlst nv supertriangle trianglelst i j k edgelst
circle pt flag perc)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq fuzzy 1e-8) ; tolerance in equality test
(setq nulllist nil)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (getvar "date") THINK-CNT 0) ; initiate timer & Progress Spinner Counter
(setq ptlst (getptlist ss1)) ; convert selection set to point list
(setq ptlst (xsort ptlst)) ; sort point list by X co-ordinate
(setq nv (length ptlst)) ; number of points
(setq supertriangle (findsupertriangle ptlst)) ; find super triangle
(setq ptlst (append ptlst supertriangle)) ; append coordinates to the end of vertex list
(setq trianglelst (list (list supertriangle nil))) ; add supertriangle to the triangle list
(setq i 0)
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% ")) ; update progress spinner
(setq pt (nth i ptlst))
(setq edgelst nil) ; initialize edge buffer
(setq j 0)
(while (and trianglelst (setq triangle (car (nth j trianglelst))))
(setq flag T)
(if (not (cadr (nth j trianglelst)))
(progn
(setq circle (getcircircumcircle triangle)) ; calculate circumcircle
(if (< (+ (caar circle) (cadr circle)) (car pt)) ; test point x and (pt) location
(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
)
)
) ; end progn
) ; end if
(if flag (setq j (1+ j)) )
) ; end while loop
(setq edgelst (removedoublyedges edgelst fuzzy nulllist)) ; remove all doubly specified edges
(setq trianglelst (addnewtriangles pt edgelst trianglelst)) ; form new triangles for current point
(setq i (1+ i)) ; get next vertex
) ; end while loop
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy)) ; remove triangles with supertriangles edges
(foreach triangle (mapcar 'car trianglelst) ; draw triangles
(drawtriangle triangle)
)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(setq stop (getvar "date"))
(princ (strcat "\r TIN Complete - Elapsed time: " (rtos (* 86400.0 (- stop start)) 2 2) " secs."))
(setvar "CMDECHO" OLDCMD)
(princ)
)
; XSORT - Original Shell Sort function replaced with VLISP sort (much quicker ;
; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (e1 e2) (< (car e1) (car e2)) ) ) )
)
; 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 velocità, può 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))))
)
)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (not (zerop (sslength ss1)))
(progn
(setq i 0)
(while
(setq pt (ssname ss1 i))
(setq ptlst (cons (cdr (assoc 10 (entget pt))) ptlst))
(setq i (1+ i))
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin 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))
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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle)
(entmake (list (cons 0 "3DFACE") (cons 10 (car triangle)) (cons 11 (caddr triangle))
(cons 12 (cadr triangle)) (cons 13 (cadr triangle))))
)
; 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 /)
(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 /)
(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))
)
)
)
; ;
; THINKING - STANDARD PROGRESS SPINNER ;
; ;
(defun THINKING (prmpt)
(setq THINK-CNT (1+ THINK-CNT))
(princ (strcat "\r" (nth (rem THINK-CNT 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *******************************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
Command: list
1 found
3D FACE Layer: "GS-ELEV"
Space: Model space
Handle = AB8
first point, X=539837.13728 Y=293829.99543 Z= 2.82000
second point, X=539828.96328 Y=293844.62043 Z= 2.82000
third point, X=539826.73328 Y=293843.57243 Z= 2.87000
fourth point, X=539826.73328 Y=293843.57243 Z= 2.87000
Command:
Command: list
1 found
3D FACE Layer: "GS-ELEV"
Space: Model space
Handle = AB9
first point, X=539837.13728 Y=293829.99543 Z= 2.82000
second point, X=539826.73328 Y=293843.57243 Z= 2.87000
third point, X=539835.71028 Y=293829.00243 Z= 2.87000
fourth point, X=539835.71028 Y=293829.00243 Z= 2.87000
;******************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*******************************************************************
;
;;
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;
(defun C:TRIANGULATE (/ fuzzy nulllist ss1 ptlst nv supertriangle trianglelst i j k edgelst
circle pt flag perc)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq fuzzy 1e-8) ; tolerance in equality test
(setq nulllist nil)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (getvar "date") THINK-CNT 0) ; initiate timer & Progress Spinner Counter
(setq ptlst (getptlist ss1)) ; convert selection set to point list
(setq ptlst (xsort ptlst)) ; sort point list by X co-ordinate
(setq nv (length ptlst)) ; number of points
(setq supertriangle (findsupertriangle ptlst)) ; find super triangle
(setq ptlst (append ptlst supertriangle)) ; append coordinates to the end of vertex list
(setq trianglelst (list (list supertriangle nil))) ; add supertriangle to the triangle list
(setq i 0)
(setq cab 0) ; CAB debug
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% ")) ; update progress spinner
(setq pt (nth i ptlst))
(setq edgelst nil) ; initialize edge buffer
(setq j 0)
(while (and trianglelst (setq triangle (car (nth j trianglelst))))
(setq flag T)
(if (not (cadr (nth j trianglelst)))
(progn
(setq circle (getcircircumcircle triangle)) ; calculate circumcircle
(if (< (+ (caar circle) (cadr circle)) (car pt)) ; test point x and (pt) location
(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
)
)
) ; end progn
) ; end if
(if flag (setq j (1+ j)) )
) ; end while loop
(setq edgelst (removedoublyedges edgelst fuzzy nulllist)) ; remove all doubly specified edges
(setq trianglelst (addnewtriangles pt edgelst trianglelst)) ; form new triangles for current point
(setq i (1+ i)) ; get next vertex
) ; end while loop
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy)) ; remove triangles with supertriangles edges
(foreach triangle (mapcar 'car trianglelst) ; draw triangles
(drawtriangle triangle)
)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(setq stop (getvar "date"))
(princ (strcat "\r TIN Complete - Elapsed time: " (rtos (* 86400.0 (- stop start)) 2 2) " secs."))
(setvar "CMDECHO" OLDCMD)
(princ)
)
; XSORT - Original Shell Sort function replaced with VLISP sort (much quicker :-) ;
; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (e1 e2) (< (car e1) (car e2)) ) ) )
)
; 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 velocità, può 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))))
)
)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (not (zerop (sslength ss1)))
(progn
(setq i 0)
(while
(setq pt (ssname ss1 i))
(setq ptlst (cons (cdr (assoc 10 (entget pt))) ptlst))
(setq i (1+ i))
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin 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))
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)
)
)
;;=============================================================
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;=============================================================
(defun getcircircumcircle (triangle / p1 p2 p3 pr1 pr2 cen rad bisector)
;; return a pt list for a perpendicular bisector 20 units long
(defun bisector (p1 p2 / perp_ang midpt)
(setq p1 (list (car p1) (cadr p1)) ; make sure 2d point
perp_ang (+ (angle p1 p2) (/ pi 2.0))) ; perpendicular angle
(setq midpt (mapcar '(lambda (pa pb) (+ (/ (- pb pa) 2.0) pa)) p1 p2))
(list (polar midpt perp_ang 10) (polar midpt (+ pi perp_ang) 10))
)
(setq p1 (car triangle)
p2 (cadr triangle)
p3 (caddr triangle)
pr1 (bisector p1 p2)
pr2 (bisector p1 p3)
cen (inters (car pr1) (cadr pr1) (car pr2) (cadr pr2) nil)
rad (distance cen p1)
)
(list cen 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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle)
(entmake (list (cons 0 "3DFACE") (cons 10 (car triangle)) (cons 11 (caddr triangle))
(cons 12 (cadr triangle)) (cons 13 (cadr triangle))))
)
; 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 /)
(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 /)
(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))
)
)
)
; ;
; THINKING - STANDARD PROGRESS SPINNER ;
; ;
(defun THINKING (prmpt)
(setq THINK-CNT (1+ THINK-CNT))
(princ (strcat "\r" (nth (rem THINK-CNT 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *******************************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
;;; Purpose: To Generate the triangle by incresing point
;;; Version: 0.1
;;; Credit to Paul Bourke (pbourke@swin.edu.au) for the original C
Program :))
;;; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/
;;; The following codes are translate from C to AutoLisp by QJCHEN
;;; South China University of Technology
;;; Thanks : Eachy at xdcad.net introduce the source code pages
;;; and the STDLIB Function of Reini Urban at http://xarch.tu-
graz.ac.at/autocad/stdlib/archive/
;;; 2006.06.30
(defun c:test (/ tpoints temp howmany ij p1 p2 p3)
(setq tpoints 1
vertex (givever)
triangle (givetri)
edges (giveedg)
)
(while (setq temp (getpoint))
(setq vertex (qj-setnmth (nth 0 temp) tpoints 1 vertex))
(setq vertex (qj-setnmth (nth 1 temp) tpoints 2 vertex))
(if (> tpoints 2)
(progn
(setq howmany (Triangulate tpoints))
)
)
(setq tpoints (1+ tpoints))
(setq ij 0)
(command "redraw")
(if (>= tpoints 4)
(progn
(repeat howmany
(setq ij (1+ ij))
(setq p1 (nth (1- (nth 0 (nth (1- ij) triangle))) vertex))
(setq p2 (nth (1- (nth 1 (nth (1- ij) triangle))) vertex))
(setq p3 (nth (1- (nth 2 (nth (1- ij) triangle))) vertex))
(grdraw p2 p1 1)
(grdraw p1 p3 1)
(grdraw p2 p3 1)
)
)
) ; (grdraw p1 p3 1)
; (grdraw p2 p3 1)
; (grdraw p3 p1 1)
)
)
;|The main function|;
(defun Triangulate (nvert / xmin ymin xmax ymax i dx dy xmid ymid
complete
ntri inc nedge i j Triangulate1
)
(setq xmin (xofv vertex 1))
(setq ymin (yofv vertex 1))
(setq xmax xmin
ymax ymin
)
(setq i 2)
(while (<= i nvert)
(if (< (xofv vertex i) xmin)
(setq xmin (xofv vertex i))
)
(if (> (xofv vertex i) xmax)
(setq xmax (xofv vertex i))
)
(if (< (yofv vertex i) ymin)
(setq ymin (yofv vertex i))
)
(if (> (yofv vertex i) ymax)
(setq ymax (yofv vertex i))
)
(setq i (1+ i))
)
(setq dx (- xmax xmin))
(setq dy (- ymax ymin))
(if (> dx dy)
(setq dmax dx)
(setq dmax dy)
)
(setq xmid (/ (+ xmax xmin) 2))
(setq ymid (/ (+ ymax ymin) 2))
(setq vertex (qj-setnmth (- xmid (* dmax 2)) (1+ nvert) 1 vertex))
(setq vertex (qj-setnmth (- ymid dmax) (1+ nvert) 2 vertex))
(setq vertex (qj-setnmth xmid (+ nvert 2) 1 vertex))
(setq vertex (qj-setnmth (+ ymid (* 2 dmax)) (+ nvert 2) 2 vertex))
(setq vertex (qj-setnmth (+ xmid (* 2 dmax)) (+ nvert 3) 1 vertex))
(setq vertex (qj-setnmth (- ymid dmax) (+ nvert 3) 2 vertex))
(setq triangle (qj-setnmth (+ nvert 1) 1 1 triangle))
(setq triangle (qj-setnmth (+ nvert 2) 1 2 triangle))
(setq triangle (qj-setnmth (+ nvert 3) 1 3 triangle))
(setq complete (append
complete
(list nil)
)
)
(setq ntri 1);;;;;;;;;;;start loop i
(setq i 1)
(while (<= i nvert)
(setq nedge 0);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq j 0
temp (- 1)
)
(while (< temp ntri)
(setq j (1+ j)
temp j
)
(if (/= (nth (1- j) complete) T)
(progn
(setq inc (InCircle1 (xofv vertex i) (yofv vertex i) (xof vertex
triangle
j 1
)
(yof vertex triangle j 1) (xof vertex
triangle j 2
) (yof vertex
triangle j 2
) (xof vertex
triangle j
3
) (yof vertex triangle
j 3
)
)
)
)
)
(if inc
(progn
(setq edges (qj-setnmth (nth 0 (nth (1- j) triangle)) 1
(+ nedge 1) edges
)
)
(setq edges (qj-setnmth (nth 1 (nth (1- j) triangle)) 2
(+ nedge 1) edges
)
)
(setq edges (qj-setnmth (nth 1 (nth (1- j) triangle)) 1
(+ nedge 2) edges
)
)
(setq edges (qj-setnmth (nth 2 (nth (1- j) triangle)) 2
(+ nedge 2) edges
)
)
(setq edges (qj-setnmth (nth 2 (nth (1- j) triangle)) 1
(+ nedge 3) edges
)
)
(setq edges (qj-setnmth (nth 0 (nth (1- j) triangle)) 2
(+ nedge 3) edges
)
)
(setq Nedge (+ Nedge 3))
(setq triangle (qj-setnmth ([n,m] triangle ntri 1) j 1 triangle))
(setq triangle (qj-setnmth ([n,m] triangle ntri 2) j 2 triangle))
(setq triangle (qj-setnmth ([n,m] triangle ntri 3) j 3 triangle))
(setq complete (std-setnth (nth (1- ntri) complete) (1- j)
complete
)
)
(setq j (1- j)
temp j
)
(setq ntri (1- ntri))
)
)
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq j 1)
(while (<= j (1- Nedge))
(if (and
(/= ([n,m] edges 1 j) 0)
(/= ([n,m] edges 2 j) 0)
)
(progn
(setq k (1+ j))
(while (<= k Nedge)
(if (and
(/= ([n,m] edges 1 k) 0)
(/= ([n,m] edges 2 k) 0)
)
(if (= ([n,m] edges 1 j) ([n,m] edges 2 k))
(if (= ([n,m] edges 2 j) ([n,m] edges 1 k))
(progn
(setq edges (qj-setnmth 0 1 j edges))
(setq edges (qj-setnmth 0 2 j edges))
(setq edges (qj-setnmth 0 1 k edges))
(setq edges (qj-setnmth 0 1 k edges))
)
)
)
)
(setq k (1+ k))
)
)
)
(setq j (1+ j))
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq j 1)
(while (<= j Nedge)
(if (and
(/= ([n,m] edges 1 j) 0)
(/= ([n,m] edges 2 j) 0)
)
(progn
(setq ntri (1+ ntri))
(setq triangle (qj-setnmth ([n,m] edges 1 j) ntri 1 triangle))
(setq triangle (qj-setnmth ([n,m] edges 2 j) ntri 2 triangle))
(setq triangle (qj-setnmth i ntri 3 triangle))
(setq complete (std-setnth nil (1- ntri) complete))
)
)
(setq j (1+ j))
);;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq i (1+ i))
);;;;;end of loop i
(setq i 0
temp (- 1)
)
(while (< temp ntri)
(setq i (1+ i)
temp i
)
(if (or
(> ([n,m] triangle i 1) nvert)
(> ([n,m] triangle i 2) nvert)
(> ([n,m] triangle i 3) nvert)
)
(progn
(setq triangle (qj-setnmth ([n,m] triangle ntri 1) i 1 triangle))
(setq triangle (qj-setnmth ([n,m] triangle ntri 2) i 2 triangle))
(setq triangle (qj-setnmth ([n,m] triangle ntri 3) i 3 triangle))
(setq i (1- i)
temp i
)
(setq ntri (1- ntri))
)
)
)
(setq Triangulate1 ntri)
Triangulate1
)
;;; stdlib - to substitute the i element of the list to new value
(defun std-%setnth (new i lst / fst len)
(cond
((minusp i)
lst
)
((> i (setq len (length lst)))
lst
)
((> i (/ len 2))
(reverse (std-%setnth new (1- (- len i)) (reverse lst)))
)
(t
(append
(progn
(setq fst nil) ; ; possible vl lsa compiler bug
(repeat (rem i 4)
(setq fst (cons (car lst) fst)
lst (cdr lst)
)
)
(repeat (/ i 4)
(setq fst (cons (cadddr lst) (cons (caddr lst) (cons
(cadr lst)
(cons
(car lst)
fst
)
)
)
)
lst (cddddr lst)
)
)
(reverse fst)
)
(if (listp new)
new
(list new)
) ; v0.4001
(cdr lst)
)
)
)
)
(defun std-setnth (new i lst)
(std-%setnth (list new) i lst)
)
;;; substitute the i row j column of a 2 dimension array
(defun qj-setnmth (new i j lst / listb lista)
(setq listb lst)
(setq i (1- i))
(setq j (1- j))
(setq lista (nth i lst))
(setq lista (std-setnth new j lista))
(setq listb (std-setnth lista i listb))
listb
)
;;; get the n row m column of the two dimension array
(defun [n,m] (a n m / i)
(setq i (nth (1- m) (nth (1- n) a)))
i
)
;;; get the n row of the one dimension array
(defun [n] (a n / i)
(setq i (nth (1- n) a))
i
)
;|Vertex has the form '((x1 y1)(x2 y2)(x3 y3)(x4 y4)())
The function xofv is to get the x value of the i element,i start from 1|;
(defun xofv (vertex i / res)
(setq res (nth 0 (nth (- i 1) vertex)))
res
)
;|Vertex has the form '((x1 y1)(x2 y2)(x3 y3)(x4 y4)())
The function yofv is to get the y value of the i element,i start from 1|;
(defun yofv (vertex i / res)
(setq res (nth 1 (nth (- i 1) vertex)))
res
)
;|Lis has the form '(((x11 y11)(x12 y12)(x13 y13))((x21 y21)(x22 y22)(x23
y23))(()()()))
The function xof is to get the x value of the i,j element,i and j start from
1
and j is the outer sequence, and i is the inter sequence, total 3|;
(defun xof (lisa lisb j v123 / res1 res2 res)
(setq res1 (nth (1- j) lisb))
(setq res2 (nth (1- v123) res1))
(setq res3 (nth (1- res2) lisa))
(setq res (nth 0 res3))
res
)
;|Lis has the form '(((x11 y11)(x12 y12)(x13 y13))((x21 y21)(x22 y22)(x23
y23))(()()()))
The function xof is to get the y value of the i,j element,i and j start from
1
and j is the outer sequence, and i is the inter sequence, total 3|;
(defun yof (lisa lisb j v123 / res1 res2 res)
(setq res1 (nth (1- j) lisb))
(setq res2 (nth (1- v123) res1))
(setq res3 (nth (1- res2) lisa))
(setq res (nth 1 res3))
res
)
;(defun append1 (new n lis / res1 res2 res)
;
; (setq res1 (nth (1- n) lis))
; (setq res2 (append
; res1
; (list new)
; )
; )
; (setq res (std-setnth res2 (1- n) lis))
; res
;)
;
;|Return TRUE if the point (xp,yp) lies inside the circumcircle
made up by points (x1,y1) (x2,y2) (x3,y3)
The circumcircle centre is returned in (xc,yc) and the radius r
NOTE: A point on the edge is inside the circumcircle|;
(defun InCircle1 (xp yp x1 y1 x2 y2 x3 y3 / InCircle eps mx2 my2 xc yc
m1
mx1 my1 m2 mx2 my2 dx dy rsqr r drsqr
)
(setq eps 0.000001)
(setq InCircle nil)
(if (and
(< (abs (- y1 y2)) eps)
(< (abs (- y2 y3)) eps)
)
(alert "INCIRCUM - F - Points are coincident !!")
(progn
(cond
((< (abs (- y2 y1)) eps)
(setq m2 (/ (- x2 x3) (- y3 y2)))
(setq mx2 (/ (+ x2 x3) 2))
(setq my2 (/ (+ y2 y3) 2))
(setq xc (/ (+ x2 x1) 2))
(setq yc (+ my2 (* m2 (- xc mx2))))
)
((< (abs (- y3 y2)) eps)
(setq m1 (/ (- x1 x2) (- y2 y1)))
(setq mx1 (/ (+ x1 x2) 2))
(setq my1 (/ (+ y1 y2) 2))
(setq xc (/ (+ x3 x2) 2))
(setq yc (+ my1 (* m1 (- xc mx1))))
)
(T
(setq m1 (/ (- x1 x2) (- y2 y1)))
(setq m2 (/ (- x2 x3) (- y3 y2)))
(setq mx1 (/ (+ x1 x2) 2))
(setq mx2 (/ (+ x2 x3) 2))
(setq my1 (/ (+ y1 y2) 2))
(setq my2 (/ (+ y2 y3) 2))
(setq xc (/ (- (+ (* m1 mx1) my2) my1 (* m2 mx2)) (- m1
m2)))
(setq yc (+ my1 (* m1 (- xc mx1))))
)
)
(setq dx (- x2 xc))
(setq dy (- y2 yc))
(setq rsqr (+ (* dx dx) (* dy dy)))
(setq r (sqrt rsqr))
(setq dx (- xp xc))
(setq dy (- yp yc))
(setq drsqr (+ (* dx dx) (* dy dy)))
(if (<= drsqr rsqr)
(setq InCircle T)
)
)
)
InCircle
)
;|Determines which side of a line the point (xp,yp) lies.
The line goes from (x1,y1) to (x2,y2)
Returns -1 for a point to the left
0 for a point on the line
+1 for a point to the right|;
(defun whichside (xp yp x1 y1 x2 y2 / equation)
(setq equation (- (* (- yp y1) (- x2 x1)) (* (- y2 y1) (- xp x1))))
(cond
((> equation 0)
(setq whichside (- 0 1))
)
((= equation 0)
(setq whichside 0)
)
(T
(setq whichside 1)
)
)
whichside
)
(defun givetri (/ lis)
(repeat 200
(setq lis (append
lis
(list (list nil nil nil))
)
)
)
lis
)
(defun givever (/ lis)
(repeat 200
(setq lis (append
lis
(list (list nil nil))
)
)
)
lis
)
(defun giveedg (/ lis lis1 lis2)
(repeat 200
(setq lis1 (append
lis1
(list nil)
)
)
)
(setq lis2 lis1)
(setq lis (append
lis
(list lis1)
)
)
(setq lis (append
lis
(list lis2)
)
)
lis
)
effect(defun c:test (/ I L S)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
(setq l (cons (cdr (assoc 10 (entget (ssname s i)))) l)
i (1+ i)
) ;_ setq
) ;_ repeat
(eea-delone-triangulate i l)
) ;_ progn
) ;_ if
) ;_ defun
(defun eea-delone-triangulate (i1 L / A A1 A2 A3
I I2 L1 L2 L3 LP MA
MI P S TI TR X1 X2
Y1 Y2
)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Program triangulate an irregular set of 3d points.
;;
;;*********************************************************
(if l
(progn
(setq ti (car (_VL-TIMES))
i 1
i1 (/ i1 100.)
i2 0
l (vl-sort
(mapcar
(function (lambda (p)
(list (/ (fix (* (car p) 1000)) 1000.)
(/ (fix (* (cadr p) 1000)) 1000.)
(caddr p)
) ;_ list
) ;_ lambda
) ;_ function
l
) ;_ mapcar
(function (lambda (a b) (>= (car a) (car b))))
) ;_ vl-sort
x2 (caar l)
y1 (cadar l)
y2 y1
) ;_ setq
(while l
(setq a (fix (caar l))
a1 (list (car l))
l (cdr l)
) ;_ setq
(while (and l (= (fix (caar l)) a))
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
) ;_ if
) ;_ if
(setq a1 (cons (car l) (vl-remove a2 a1))
l (cdr l)
) ;_ setq
) ;_ while
(foreach a a1 (setq lp (cons a lp)))
) ;_ while
(setq x1 (caar lp)
a (list (/ (+ x1 x2) 2) (/ (+ y1 y2) 2))
a1 (distance a (list x1 y1))
ma (+ (car a) a1 a1)
mi (- (car a) a1)
s (list (list ma (cadr a) 0)
(list mi (+ (cadr a) a1 a1) 0)
(list (- (car a) a1) (- (cadr a) a1 a1) 0)
) ;_ list
l (list (cons x2 (cons a (cons (+ a1 a1) s))))
ma (1- ma)
mi (1+ mi)
) ;_ setq
(while lp
(setq p (car lp)
lp (cdr lp)
l1 nil
) ;_ setq
(while l
(setq tr (car l)
l (cdr l)
) ;_ setq
(cond
((< (car tr) (car p)) (setq l2 (cons (cdddr tr) l2)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a1 (car tr)
a2 (cadr tr)
a3 (caddr tr)
l1 (cons (list (+ (car a1) (car a2))
(+ (cadr a1) (cadr a2))
a1
a2
) ;_ list
(cons (list (+ (car a2) (car a3))
(+ (cadr a2) (cadr a3))
a2
a3
) ;_ list
(cons (list (+ (car a3) (car a1))
(+ (cadr a3) (cadr a1))
a3
a1
) ;_ list
l1
) ;_ cons
) ;_ cons
) ;_ cons
) ;_ setq
)
(t (setq l3 (cons tr l3)))
) ;_ cond
) ;_ while
(setq l l3
l3 nil
l1 (vl-sort l1
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ setq
(while l1
(if (and (= (caar l1) (caadr l1))
(= (cadar l1) (cadadr l1))
) ;_ and
(setq l1 (cddr l1))
(setq l (cons (eea-data-triangle p (cddar l1)) l)
l1 (cdr l1)
) ;_ setq
) ;_ if
) ;_ while
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn
(setvar
"MODEMACRO"
(strcat
" "
(itoa (setq i2 (1+ i2)))
" % "
(substr
"||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
1
i2
) ;_ substr
(substr
"..."
1
(- 100 i2)
) ;_ substr
) ;_ strcat
) ;_ setvar
(setq i i1)
) ;_ progn
) ;_ if
) ;_ while
(foreach a l (setq l2 (cons (cdddr a) l2)))
(setq
l2 (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
) ;_ lambda
) ;_ function
l2
) ;_ vl-remove-if
) ;_ setq
(foreach a l2
(entmake (list (cons 0 "3DFACE")
(cons 10 (car a))
(cons 11 (car a))
(cons 12 (cadr a))
(cons 13 (caddr a))
) ;_ list
) ;_ entmake
) ;_ foreach
) ;_ progn
) ;_ if
(setvar "MODEMACRO" "")
(princ (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
) ;_ strcat
) ;_ princ
(princ)
) ;_ defun
(defun eea-data-triangle (P1 l / A A1 P2 P3 P4 S)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Calculation of the centre of a circle and circle radius
;; for program triangulate
;;
;; (eea-data-triangle (getpoint)(list(getpoint)(getpoint)))
;;*********************************************************
(setq p2 (car l)
p3 (cadr l)
p4 (list (car p3) (cadr p3))
) ;_ setq
(if
(not
(zerop
(setq s (sin (setq a (- (angle p2 p4) (angle p2 p1)))))
) ;_ zerop
) ;_ not
(progn (setq a (polar p4
(+ -1.570796326794896 (angle p4 p1) a)
(setq a1 (/ (distance p1 p4) s 2.))
) ;_ polar
a1 (abs a1)
) ;_ setq
(list (+ (car a) a1) a a1 p1 p2 p3)
) ;_ progn
) ;_ if
) ;_ defun
Command:
Command: (LOAD "D:/Work/triangle/test/test.VLX") nil
Command: test
select points
Select objects: Specify opposite corner: 100000 found
Select objects:
39.0630 secs.
Command:
Test this:Code: [Select];******************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*******************************************************************
;
;;
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;
(defun C:TRIANGULATE (/ fuzzy nulllist ss1 ptlst nv supertriangle trianglelst i j k edgelst
circle pt flag perc)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq fuzzy 1e-8) ; tolerance in equality test
(setq nulllist nil)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (getvar "date") THINK-CNT 0) ; initiate timer & Progress Spinner Counter
(setq ptlst (getptlist ss1)) ; convert selection set to point list
(setq ptlst (xsort ptlst)) ; sort point list by X co-ordinate
(setq nv (length ptlst)) ; number of points
(setq supertriangle (findsupertriangle ptlst)) ; find super triangle
(setq ptlst (append ptlst supertriangle)) ; append coordinates to the end of vertex list
(setq trianglelst (list (list supertriangle nil))) ; add supertriangle to the triangle list
(setq i 0)
(setq cab 0) ; CAB debug
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% ")) ; update progress spinner
(setq pt (nth i ptlst))
(setq edgelst nil) ; initialize edge buffer
(setq j 0)
(while (and trianglelst (setq triangle (car (nth j trianglelst))))
(setq flag T)
(if (not (cadr (nth j trianglelst)))
(progn
(setq circle (getcircircumcircle triangle)) ; calculate circumcircle
(if (< (+ (caar circle) (cadr circle)) (car pt)) ; test point x and (pt) location
(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
)
)
) ; end progn
) ; end if
(if flag (setq j (1+ j)) )
) ; end while loop
(setq edgelst (removedoublyedges edgelst fuzzy nulllist)) ; remove all doubly specified edges
(setq trianglelst (addnewtriangles pt edgelst trianglelst)) ; form new triangles for current point
(setq i (1+ i)) ; get next vertex
) ; end while loop
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy)) ; remove triangles with supertriangles edges
(foreach triangle (mapcar 'car trianglelst) ; draw triangles
(drawtriangle triangle)
)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(setq stop (getvar "date"))
(princ (strcat "\r TIN Complete - Elapsed time: " (rtos (* 86400.0 (- stop start)) 2 2) " secs."))
(setvar "CMDECHO" OLDCMD)
(princ)
)
; XSORT - Original Shell Sort function replaced with VLISP sort (much quicker :-) ;
; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (e1 e2) (< (car e1) (car e2)) ) ) )
)
; 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 velocità, può 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))))
)
)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (not (zerop (sslength ss1)))
(progn
(setq i 0)
(while
(setq pt (ssname ss1 i))
(setq ptlst (cons (cdr (assoc 10 (entget pt))) ptlst))
(setq i (1+ i))
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin 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))
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)
)
)
;;=============================================================
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;=============================================================
(defun getcircircumcircle (triangle / p1 p2 p3 pr1 pr2 cen rad bisector)
;; return a pt list for a perpendicular bisector 20 units long
(defun bisector (p1 p2 / perp_ang midpt)
(setq p1 (list (car p1) (cadr p1)) ; make sure 2d point
perp_ang (+ (angle p1 p2) (/ pi 2.0))) ; perpendicular angle
(setq midpt (mapcar '(lambda (pa pb) (+ (/ (- pb pa) 2.0) pa)) p1 p2))
(list (polar midpt perp_ang 10) (polar midpt (+ pi perp_ang) 10))
)
(setq p1 (car triangle)
p2 (cadr triangle)
p3 (caddr triangle)
pr1 (bisector p1 p2)
pr2 (bisector p1 p3)
cen (inters (car pr1) (cadr pr1) (car pr2) (cadr pr2) nil)
rad (distance cen p1)
)
(list cen 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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle)
(entmake (list (cons 0 "3DFACE") (cons 10 (car triangle)) (cons 11 (caddr triangle))
(cons 12 (cadr triangle)) (cons 13 (cadr triangle))))
)
; 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 /)
(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 /)
(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))
)
)
)
; ;
; THINKING - STANDARD PROGRESS SPINNER ;
; ;
(defun THINKING (prmpt)
(setq THINK-CNT (1+ THINK-CNT))
(princ (strcat "\r" (nth (rem THINK-CNT 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *******************************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
;******************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*******************************************************************
;;
;;
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;
;; Change by ymg 05/19/2011
;;Modified FINDSUPERTRIANGLE and PURGETRIANGLELST
;;Remove recursion in NTH_SUBST
(defun C:TRIANGULATE (/ fuzzy nulllist ss1
nv ptlst trianglelst
i j k circle
pt flag perc edgelst
)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq fuzzy 1e-8) ; tolerance in equality test
(setq nulllist nil)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (getvar "date")
THINK-CNT 0
)
(setq ptlst (getptlist ss1))
(setq ptlst (xsort ptlst))
(setq nv (length ptlst))
(setq supertriangle (findsupertriangle ptlst)) ; find super triangle
(setq ptlst (append ptlst supertriangle)) ; append coordinates to the end of vertex list
(setq trianglelst (list (list supertriangle nil))) ; add supertriangle to the triangle list
(setq i 0)
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% "))
(setq pt (nth i ptlst))
(setq edgelst nil) ; initialize edge buffer
(setq j 0)
(while
(and trianglelst (setq triangle (car (nth j trianglelst))))
(setq flag T)
(if (not (cadr (nth j trianglelst)))
(progn
(setq circle (getcircircumcircle triangle)) ; calculate circumcircle
(if (< (+ (caar circle) (cadr circle)) (car pt)) ; test point x and (pt) location
(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
)
)
) ; end progn
) ; end if
(if flag
(setq j (1+ j))
)
)
(setq edgelst (removedoublyedges edgelst fuzzy nulllist))
(setq trianglelst (addnewtriangles pt edgelst trianglelst))
(setq i (1+ i))
)
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy)) ; remove triangles with supertriangles edges
(foreach triangle (mapcar 'car trianglelst)
(drawtriangle triangle)
)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(setq stop (getvar "date"))
(princ (strcat "\r TIN Complete - Elapsed time: "
(rtos (* 86400.0 (- stop start)) 2 2)
" secs."
)
)
(setvar "CMDECHO" OLDCMD)
(princ)
)
; XSORT - Original Shell Sort function replaced with VLISP sort (much quicker :-) ;
; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (a b) (< (car a) (car 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 velocità, può 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)))
; )
; )
;)
;;;Removed the recursion ymg --------------------------
(defun NTH_SUBST (index new Alist / temp)
(cond
((minusp index) Alist)
((zerop index)(cons new (cdr Alist)))
((> index 0) (while (> index 0)
(setq temp (cons (car alist) temp)
alist (cdr alist)
index (1- index)
)
)
(append (reverse temp) (list new) (cdr alist))
)
)
)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (not (zerop (sslength ss1)))
(progn
(setq i 0)
(while (setq pt (ssname ss1 i))
(setq ptlst (cons (cdr (assoc 10 (entget pt))) ptlst))
(setq i (1+ i))
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin
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))
dx (- xmax xmin)
dy (- ymax ymin)
dmax (max dx dy)
xmid (* (+ xmax xmin) 0.5)
ymid (* (+ ymax ymin) 0.5)
trx1 (- xmid (* dmax 20.0)) ;modified ymg
try1 (- ymid dmax)
trz1 0.0
trx2 xmid
try2 (+ ymid (* dmax 20.0)) ;modified ymg
trz2 0.0
trx3 (+ xmid (* dmax 20.0)) ;modified ymg
try3 (- ymid dmax)
trz3 0.0
)
(list (list trx1 try1 trz1)
(list trx2 try2 trz2)
(list trx3 try3 trz3)
)
)
;;=============================================================
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;=============================================================
(defun getcircircumcircle (triangle / p1 p2 p3 pr1 pr2 cen rad bisector)
;; return a pt list for a perpendicular bisector 20 units long
(defun bisector (p1 p2 / perp_ang midpt)
(setq p1 (list (car p1) (cadr p1)) ; make sure 2d point
perp_ang (+ (angle p1 p2) (/ pi 2.0))) ; perpendicular angle
(setq midpt (mapcar '(lambda (pa pb) (+ (/ (- pb pa) 2.0) pa)) p1 p2))
(list (polar midpt perp_ang 10) (polar midpt (+ pi perp_ang) 10))
)
(setq p1 (car triangle)
p2 (cadr triangle)
p3 (caddr triangle)
pr1 (bisector p1 p2)
pr2 (bisector p1 p3)
cen (inters (car pr1) (cadr pr1) (car pr2) (cadr pr2) nil)
rad (distance cen p1)
)
(list cen 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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle)
(entmake (list (cons 0 "3DFACE") (cons 10 (car triangle)) (cons 11 (caddr triangle))
(cons 12 (cadr triangle)) (cons 13 (cadr triangle))
)
)
)
; 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 /)
(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 /)
(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))
)
)
(setq trianglelst trianglelst); modified to return trianglelst was returning J in certain case ymg
)
; ;
; THINKING - STANDARD PROGRESS SPINNER ;
; ;
(defun THINKING (prmpt)
(setq THINK-CNT (1+ THINK-CNT))
(princ (strcat "\r" (nth (rem THINK-CNT 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *******************************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
((1652.17 356.759 446.623) (1666.15 431.163 -353.053) (1688.64 379.861 -372.616) (1708.17 888.849 489.959)
(1763.96 799.643 117.206) (1811.9 678.149 -387.295) (1818.56 140.657 -256.432) (1883.13 226.078 -79.1498)
(1888.23 124.665 122.761) (1900.26 864.281 -41.0016) (1950.15 730.671 -164.785) (1979.73 671.496 -19.8523)
(2031.64 260.656 -497.925) (2069.42 69.732 -278.069) (2071.19 123.139 -183.401) (2096.73 383.737 -280.053)
(2173.55 135.927 283.044) (2241.51 1048.67 47.7767) (2298.4 460.399 211.447) (2304.6 871.301 -156.27)
(2441.41 517.957 -411.649) (2455.6 695.636 -390.896) (2462.35 249.15 99.3225) (2585.43 387.857 201.498)
(2591.77 477.032 100.238) (-17456.9 -419.739 0.0) (2121.97 20138.0 0.0) (21700.8 -419.739 0.0))
Hello :
In other word we need to create more than just the 3dface.
With such a structure it becomes easy to walk on the TIN, go to the neighbor of a 3dface , contour etc.
So far none of the triangulation that we have do it well.
ymg
;Create a contour slice through a 3 vertex facet pa, pb, pc
;The contour "level" is a horizontal plane perpendicular to the z axis,
;ie: The equation of the contour plane Ax + By + Cz + D = 0
;has A = 0, B = 0, C = 1, D = -level
; Return:
; ((nil nil nil) (nil nil nil) 0) if the contour plane doesn't cut the facet
; ( (x y z) (x y z) 2) if it does cut the facet
; ((nil nil nil) (nil nil nil) -1) for an unexpected occurrence
;If a vertex touches the contour plane nothing need to be drawn
(defun contourfacet (triangle level / pa pb pc sidea sideb sidec p1x p1y p1z p2x p2y p2z)
(setq pa (car triangle)
pb (cadr triangle)
pc (caddr triangle)
)
(setq sidea (-(caddr pa)level)
sideb (-(caddr pb)level)
sidec (-(caddr pc)level)
)
(cond
;---Are all the vertices on one side----------
((and (>= sidea 0) (>= sideb 0) (>= sidec 0))
(setq ret 0)
)
((and (<= sidea 0) (<= sideb 0) (<= sidec 0))
(setq ret 0)
)
;---Is pa the only point on a side by itself---
((and (/=(sign sidea) (sign sideb)) (/=(sign sidea) (sign sidec)))
(setq p1x (- (car pa) (* sidea (/ (- (car pc) (car pa)) (- sidec sidea)))))
(setq p1y (- (cadr pa) (* sidea (/ (- (cadr pc) (cadr pa)) (- sidec sidea)))))
(setq p1z (- (caddr pa) (* sidea (/ (- (caddr pc) (caddr pa)) (- sidec sidea)))))
(setq p2x (- (car pa) (* sidea (/ (- (car pb) (car pa)) (- sideb sidea)))))
(setq p2y (- (cadr pa) (* sidea (/ (- (cadr pb) (cadr pa)) (- sideb sidea)))))
(setq p2z (- (caddr pa) (* sidea (/ (- (caddr pb) (caddr pa)) (- sideb sidea)))))
(setq ret 2)
)
;---Is pb the only point on a side by itself---
((and (/=(sign sideb) (sign sidea)) (/=(sign sideb) (sign sidec)))
(setq p1x (- (car pb) (* sideb (/ (- (car pc) (car pb)) (- sidec sideb)))))
(setq p1y (- (cadr pb) (* sideb (/ (- (cadr pc) (cadr pb)) (- sidec sideb)))))
(setq p1z (- (caddr pb) (* sideb (/ (- (caddr pc) (caddr pb)) (- sidec sideb)))))
(setq p2x (- (car pb) (* sideb (/ (- (car pa) (car pb)) (- sidea sideb)))))
(setq p2y (- (cadr pb) (* sideb (/ (- (cadr pa) (cadr pb)) (- sidea sideb)))))
(setq p2z (- (caddr pb) (* sideb (/ (- (caddr pa) (caddr pb)) (- sidea sideb)))))
(setq ret 2)
)
;---Is pc the only point on a side by itself---
((and (/=(sign sidec) (sign sidea)) (/=(sign sidec) (sign sideb)))
(setq p1x (- (car pc) (* sidec (/ (- (car pa) (car pc)) (- sidea sidec)))))
(setq p1y (- (cadr pc) (* sidec (/ (- (cadr pa) (cadr pc)) (- sidea sidec)))))
(setq p1z (- (caddr pc) (* sidec (/ (- (caddr pa) (caddr pc)) (- sidea sidec)))))
(setq p2x (- (car pc) (* sidec (/ (- (car pb) (car pc)) (- sideb sidec)))))
(setq p2y (- (cadr pc) (* sidec (/ (- (cadr pb) (cadr pc)) (- sideb sidec)))))
(setq p2z (- (caddr pc) (* sidec (/ (- (caddr pb) (caddr pc)) (- sideb sidec)))))
(setq ret 2)
)
(t (setq ret -1))
)
(list (list p1x p1y p1z) (list p2x p2y p2z) ret)
)
;--Define the Signum function-----
(defun sign (x)
( cond
(( minusp x ) -1 )
(( zerop x) 0 )
( t 1 )
)
)
Now, especially checked - Playing a random mistake. I accidentally deleted a few lines. The code is similar to the line and the code is understandable, what is missing! If, indeed, no one can understand this program, I promise next week to lay out the full code! But I will be sorry that such a code just copy and do not try to understand...hmmm, your variables naming style scares us off, Evgeniy :)
:-o
(vl-remove-if-not
(function (lambda (a) (and (< mi (caadr a) ma) (< mi (caaddr a) ma))))
l2
)
to this(vl-remove-if
(function
(lambda (a)
(or (vl-some (function (lambda (c) (vl-position c s))) a) (null a))
)
)
l2
)
to make it workSofito_Soft,Hello:
That's an interesting way to do it.
How fast would it be if we wanted to generate a contour map from it ?
I will look at it.
Thanks,
ymg
Sofito_soft,Hello :
That is a lot of time in order to unite al those 3dface.
Whereby if we would preserve the data structure of the triangulation in a double edged list it would take very
little time to contour. Most of the work is already done by the triangulation.
ymg
Hello :
That's true. If you just want to contour, no need to tape "3DFACE" as each 3DFACE have what it takes to calculate its intersection with a plane parallel to XY with Z determined. I think what I have done. I'll look and tell you something.
Sofito_Soft,QuoteHello :
That's true. If you just want to contour, no need to tape "3DFACE" as each 3DFACE have what it takes to calculate its intersection with a plane parallel to XY with Z determined. I think what I have done. I'll look and tell you something.
What is more difficult is to trace that contour from face to face. We do not want to go by brute force
because It's gonna take way too long.
With my prehistoric face to face LSP:
Command: 3DF->CURVA_NIVEL
Selecciona las 3DFACE
Select objects: Specify opposite corner: 3073 found
Select objects:
Cronometro a 00:00
Tiempo para la funcion "c:3df->curva_nivel" : 20.985 seg.
With a intervale of 0.25 m in Z.-> 33000 contour level lines (separates )
Greetings.
Tracing contours between triangles may be an inefficient process, since triangles that span multiple elevation levels will have to be processed multiple times. It may be more efficient to process all the contour segments for each triangle, then process those segments into buckets (for lack of a better term) for later processing. Optimization would likely involve a pre-sort of the triangles based on the lowest (bottom to top) or highest (top to bottom). Or, for even more optimization creation of the contour segments as each triangle is created.
What is more difficult is to trace that contour from face to face. We do not want to go by brute force
because It's gonna take way too long.
With my prehistoric face to face LSP:
If you put the polilines in Z, then you can filter to select all under a certain height. It is easy then weld all.
In my LSP
( defun c:3df->SEG_curva_nivel ( / ) : 3dfaces a segment of polilines in deteminate Z
(defun c:test (/ I L S tmp a b )
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
( setq tmp (cdr (assoc 10 (entget (ssname s i)))))
( setq l (cons (list (/ (fix (* (car tmp ) 1000)) 1000. )
(/ (fix (* (cadr tmp) 1000)) 1000. )
(caddr tmp)
)
l)
i (1+ i)
) ;_ setq
) ;_ repeat
( setq l ( remove_doubles l ) )
( setq l (vl-sort
l
(function (lambda (a b) (>= (car a) (car b))))
) ;_ vl-sort
)
( eea-delone-triangulate l )
) ;_ progn
) ;_ if
) ;_ defun
(defun eea-delone-triangulate ( L / A A1 A2 A3
I I2 L1 L2 L3 LP MA
MI P S TI TR X1 X2
Y1 Y2
)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Program triangulate an irregular set of 3d points.
;;
;;*********************************************************
(if l
(progn
(setq ti (car (_VL-TIMES))
i1 ( length l )
i 1
i1 (/ i1 100.)
i2 0
x2 (caar l)
y1 (cadar l)
y2 y1
) ;_ setq
(while l
(setq a (fix (caar l))
a1 (list (car l))
; l (cdr l) ; <<<<<<<<<<<<<<<<<<<<<<< !!!!
) ;_ setq
.......
(defun c:test (/ I L S)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
(setq l (cons (cdr (assoc 10 (entget (ssname s i)))) l)
i (1+ i)
) ;_ setq
) ;_ repeat
(eea-delone-triangulate i l)
) ;_ progn
) ;_ if
) ;_ defun
(defun eea-delone-triangulate
(i1 L / A A1 A2 A3 I I2 L1 L2 L3 LP MA MI P S TI TR X1 X2 Y1 Y2)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; edit 20.05.2011
;; Program triangulate an irregular set of 3d points.
;;
;;*********************************************************
(if l
(progn
(setq ti (car (_VL-TIMES))
i 1
i1 (/ i1 100.)
i2 0
l (vl-sort (mapcar (function (lambda (p)
(list (/ (fix (* (car p) 1000)) 1000.)
(/ (fix (* (cadr p) 1000)) 1000.)
(caddr p)
) ;_ list
) ;_ lambda
) ;_ function
l
) ;_ mapcar
(function (lambda (a b) (>= (car a) (car b))))
) ;_ vl-sort
x2 (caar l)
y1 (cadar l)
y2 y1
) ;_ setq
(while l
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
)
)
(setq a (fix (caar l))
a1 (list (car l))
l (cdr l)
) ;_ setq
(while (and l (= (fix (caar l)) a))
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
) ;_ if
) ;_ if
(setq a1 (cons (car l) (vl-remove a2 a1))
l (cdr l)
) ;_ setq
) ;_ while
(foreach a a1 (setq lp (cons a lp)))
) ;_ while
(setq x1 (caar lp)
a (list (/ (+ x1 x2) 2) (/ (+ y1 y2) 2))
a1 (distance a (list x1 y1))
ma (+ (car a) a1 a1)
mi (- (car a) a1)
s (list (list ma (cadr a) 0)
(list mi (+ (cadr a) a1 a1) 0)
(list (- (car a) a1) (- (cadr a) a1 a1) 0)
) ;_ list
l (list (cons x2 (cons a (cons (+ a1 a1) s))))
ma (1- ma)
mi (1+ mi)
) ;_ setq
(while lp
(setq p (car lp)
lp (cdr lp)
l1 nil
) ;_ setq
(while l
(setq tr (car l)
l (cdr l)
) ;_ setq
(cond ((< (car tr) (car p)) (setq l2 (cons (cdddr tr) l2)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a1 (car tr)
a2 (cadr tr)
a3 (caddr tr)
l1 (cons (list (+ (car a1) (car a2)) (+ (cadr a1) (cadr a2)) a1 a2)
(cons (list (+ (car a2) (car a3)) (+ (cadr a2) (cadr a3)) a2 a3)
(cons (list (+ (car a3) (car a1)) (+ (cadr a3) (cadr a1)) a3 a1) l1)
) ;_ cons
) ;_ cons
) ;_ setq
)
(t (setq l3 (cons tr l3)))
) ;_ cond
) ;_ while
(setq l l3
l3 nil
l1 (vl-sort l1
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ setq
(while l1
(if (and (= (caar l1) (caadr l1)) (= (cadar l1) (cadadr l1)))
(setq l1 (cddr l1))
(setq l (cons (eea-data-triangle p (cddar l1)) l)
l1 (cdr l1)
) ;_ setq
) ;_ if
) ;_ while
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn
(setvar
"MODEMACRO"
(strcat
" "
(itoa (setq i2 (1+ i2)))
" % "
(substr
"||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
1
i2
) ;_ substr
(substr "..." 1 (- 100 i2))
) ;_ strcat
) ;_ setvar
(setq i i1)
) ;_ progn
) ;_ if
) ;_ while
(foreach a l (setq l2 (cons (cdddr a) l2)))
(setq l2 (vl-remove-if-not
(function (lambda (a) (and (< mi (caadr a) ma) (< mi (caaddr a) ma))))
l2
) ;_ vl-remove-if
) ;_ setq
(foreach a l2
(entmake (list (cons 0 "3DFACE")
(cons 10 (car a))
(cons 11 (car a))
(cons 12 (cadr a))
(cons 13 (caddr a))
) ;_ list
) ;_ entmake
) ;_ foreach
) ;_ progn
) ;_ if
(setvar "MODEMACRO" "")
(princ (strcat "\n " (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) " secs."))
(princ)
) ;_ defun
(defun eea-data-triangle (P1 l / A A1 P2 P3 P4 S)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Calculation of the centre of a circle and circle radius
;; for program triangulate
;;
;; (eea-data-triangle (getpoint)(list(getpoint)(getpoint)))
;;*********************************************************
(setq p2 (car l)
p3 (cadr l)
p4 (list (car p3) (cadr p3))
) ;_ setq
(if (not (zerop (setq s (sin (setq a (- (angle p2 p4) (angle p2 p1)))))))
(progn (setq a (polar p4
(+ -1.570796326794896 (angle p4 p1) a)
(setq a1 (/ (distance p1 p4) s 2.))
) ;_ polar
a1 (abs a1)
) ;_ setq
(list (+ (car a) a1) a a1 p1 p2 p3)
) ;_ progn
) ;_ if
) ;_ defun
program with the corrections:
You are still missing triangles on the convex hull Evgenyi.
ymg
((1652.17 356.759 446.623) (1666.15 431.163 -353.053) (1688.64 379.861 -372.616) (1708.17 888.849 489.959)
(1763.96 799.643 117.206) (1811.9 678.149 -387.295) (1818.56 140.657 -256.432) (1883.13 226.078 -79.1498)
(1888.23 124.665 122.761) (1900.26 864.281 -41.0016) (1950.15 730.671 -164.785) (1979.73 671.496 -19.8523)
(2031.64 260.656 -497.925) (2069.42 69.732 -278.069) (2071.19 123.139 -183.401) (2096.73 383.737 -280.053)
(2173.55 135.927 283.044) (2241.51 1048.67 47.7767) (2298.4 460.399 211.447) (2304.6 871.301 -156.27)
(2441.41 517.957 -411.649) (2455.6 695.636 -390.896) (2462.35 249.15 99.3225) (2585.43 387.857 201.498)
(2591.77 477.032 100.238) (-17456.9 -419.739 0.0) (2121.97 20138.0 0.0) (21700.8 -419.739 0.0))
program with the corrections:can you provide a test points list which will show the difference between old and new versions?
can you provide a test points list which will show the difference between old and new versions?
(foreach p '((2516.06 458.26 0.0)
(2520.33 508.832 0.0)
(2563.56 516.802 0.0)
(2562.18 470.832 0.0)
(2594.14 435.458 0.0)
(2614.14 445.705 0.0)
(2611.41 488.645 0.0)
)
(entmakex (list '(0 . "point") (cons 10 p)))
)
;*****************************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*****************************************************************************;
;; ;
;; ;
;; Changes by CAB 03/13/06 ;
;; Replaced the GETCIRCIRCUMCIRCLE routine ;
;; ;
;; Changes by ymg : ;
;; ;
;;Modified FINDSUPERTRIANGLE 19/05/2011 ;
;;and PURGETRIANGLELST 19/05/2011 ;
;; ;
;;Removed recursion in NTH_SUBST 19/05/2011 ;
;; ;
;;Reverted to original GETCIRCIRCUMCIRCLE routine and changed it's ;
;;name to GETCIRCUMCIRCLE 22/05/2011 ;
;; ;
;;Modified so that trianglelst and edgelst are now list of ;
;;indices into ptlst. 25/05/2011 ;
;; ;
;;Removed EQUALMEMBER 25/05/2011 ;
;; ;
;;For Contour generation: ;
;; ;
;;Added GETEDGELST 28/05/2011 ;
;;Added GETCROSSEDEGDGE 28/05/2011 ;
;;Added MAKE_CONTOUR 28/05/2011 ;
;; ;
(defun C:TRIANGULATE (/ ss1 nv
i j k
circle pt flag
ptlst edgelst trianglelst
oldcmd oldsnap supertriangle
triangle start think-cnt
intv zmax zmin
)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (car (_VL-TIMES))
THINK-CNT 0
)
(setq ptlst (getptlist ss1))
(setq ptlst (xsort ptlst))
(setq nv (length ptlst))
(setq supertriangle (findsupertriangle ptlst))
(setq ptlst (append ptlst supertriangle))
(setq supertriangle (list nv (1+ nv) (+ 2 nv)))
(setq trianglelst (list(list supertriangle nil)))
(setq i 0)
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% ") think-cnt)
(setq pt (nth i ptlst))
(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
(setq circle (GETCIRCUMCIRCLE triangle ptlst))
(cond
((< (+ (caar circle) (cadr circle)) (car pt))
(setq trianglelst (nth_subst j (list (car (nth j trianglelst)) T) trianglelst))
)
((isinside pt circle)
(setq edgelst (addtriangleedges triangle edgelst)
trianglelst (nth_del j trianglelst)
flag nil
)
)
)
)
)
(if flag (setq j (1+ j)))
)
(setq edgelst (removedoublyedges edgelst))
(setq trianglelst (addnewtriangles i edgelst trianglelst))
(setq i (1+ i))
)
(setq trianglelst (purgetrianglelst trianglelst supertriangle))
(repeat 3
(setq ptlst (vl-remove (last ptlst) ptlst))
)
(foreach triangle (mapcar 'car trianglelst)
(drawtriangle triangle ptlst)
)
;; Now we set-up to trace the contour ;
(setq edgelst (GETEDGELST trianglelst)
zmax (apply 'max (mapcar 'caddr ptlst))
zmin (apply 'min (mapcar 'caddr ptlst))
intv 1
zmin (+ (fix zmin) intv)
zmax (fix zmax)
)
(MAKE_CONTOUR zmin zmax intv edgelst ptlst)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(princ (strcat "\r TIN Complete - Elapsed time: " (rtos (/ (- (car (_VL-TIMES)) start) 1000.) 2 4) " secs."))
(princ)
(setvar "CMDECHO" OLDCMD)
(princ)
)
;; XSORT ;
;; ;
;; Original Shell Sort function replaced with VLISP sort (much quicker :-) ;
;; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (a b) (< (car a) (car b)))))
)
; NTH_DEL ;
; ;
; delete the n item in the list (by position, not by value!!) ;
; ;
(defun NTH_DEL (N LST / l)
(repeat n
(setq l (cons (car lst) l)
lst (cdr lst)
)
)
(append (reverse l) (cdr lst))
)
;(defun NTH_DEL (index lista)
; (setq i -1)
; (apply 'append (mapcar '(lambda (x)
; (if (= (setq i (+ 1 i)) index)
; nil
; (list x)
; )
; )
; lista
; )
; )
;)
; NTH_SUBST ;
; ;
; Replace the index element in the list with new element. ;
; ;
; ;
(defun NTH_SUBST (n new lst / l)
(cond
((minusp n) lst)
((zerop n)(cons new (cdr lst)))
(t (repeat n
(setq l (cons (car lst) l)
lst (cdr lst)
)
)
(append (reverse l) (list new) (cdr lst))
)
)
)
;Need to check that one for speed
;(defun NTH_SUBST (n new lst / i)
; (setq i -1)
; (mapcar '(lambda (x)
; (if (= (setq i (+ 1 i)) n)
; new
; x
; )
; )
; lst
; )
;)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(setq i 0)
(if (not (zerop (sslength ss1)))
(progn
(repeat (sslength ss1)
(setq ptlst (cons (cdr (assoc 10 (entget (ssname ss1 i)))) ptlst)
i (1+ i)
)
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin
dmax xmid ymid x1 x2 x3
y1 y2 y3
)
(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))
dmax (max (- xmax xmin) (- ymax ymin))
xmid (* (+ xmax xmin) 0.5)
ymid (* (+ ymax ymin) 0.5)
x1 (- xmid (* dmax 20.0)) ;modified ymg
y1 (- ymid dmax)
x2 xmid
y2 (+ ymid (* dmax 20.0)) ;modified ymg
x3 (+ xmid (* dmax 20.0)) ;modified ymg
y3 (- ymid dmax)
)
(list (list x1 y1 0.0) (list x2 y2 0.0) (list x3 y3 0.0))
)
;; GETCIRCUMCIRCLE ;
;; ;
;; Find circle passing through three points ;
;; ;
(defun GETCIRCUMCIRCLE (triangle ptlst / p1 p2 p3 p1x p2x p3x
p1y p2y p3y d xc yc rad)
(setq p1 (nth (car triangle) ptlst)
p2 (nth (cadr triangle) ptlst)
p3 (nth (caddr triangle) ptlst)
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)
(< (distance pt (car circle)) (cadr circle))
)
; 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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle ptlst /)
(entmake (list (cons 0 "3DFACE")
(cons 8 "TIN")
(cons 10 (nth (car triangle) ptlst))
(cons 11 (nth (caddr triangle) ptlst))
(cons 12 (nth (cadr triangle) ptlst))
(cons 13 (nth (cadr triangle) ptlst))
)
)
)
; REMOVEDOUBLYEDGES ;
; ;
; Test the edge queue to remove duplicates (warning CW & CCW!) ;
; ;
(defun REMOVEDOUBLYEDGES (edgelst / j k)
(setq j 0)
(while (< j (length edgelst))
(setq k (1+ j))
(while (< k (length edgelst))
(if
(or (and (= (car (nth j edgelst)) (car (nth k edgelst)))
(= (cadr (nth j edgelst)) (cadr (nth k edgelst)))
)
(and (= (car (nth j edgelst)) (cadr (nth k edgelst)))
(= (cadr (nth j edgelst)) (car (nth k edgelst)))
)
)
(setq edgelst (nth_subst j nil edgelst)
edgelst (nth_subst k nil 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)
(repeat (length edgelst)
(if (nth j edgelst)
(setq triangle (append (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 / a b j triangle)
(setq j 0)
(repeat (length trianglelst)
(setq triangle (car (nth j trianglelst)))
(if
(apply 'or (mapcar '(lambda (a) (apply 'or (mapcar '(lambda (b) (= b a )) supertriangle)))
triangle
)
)
(setq trianglelst (nth_del j trianglelst))
(setq j (1+ j))
)
)
trianglelst
)
;; GETEDGELST ;
;; ;
;; Create list of EDGES of all triangles in trianglelst. ;
;; ;
(defun GETEDGELST (trianglelst / edgelst neighlst)
(setq edgelst nil)
(foreach tr trianglelst
(setq edgelst (cons (list (caar tr)(cadar tr)) edgelst)
edgelst (cons (list (cadar tr)(caddar tr)) edgelst)
edgelst (cons (list (caddar tr)(caar tr)) edgelst)
)
)
)
;; GETCROSSEDEGDGE ;
;; ;
;;Traverses the edges list and creates a list of edges that are crossed by a ;
;;contour level. It then follows contlst from neigbour to neighbor until it ;
;;reaches the exterior of the TIN or the starting point. ;
;; ;
;;Returns crossedlst which contains list of edges. ;
;; ;
(defun GETCROSSEDEDGE (lev edgelst ptlst / e pos nxt contlst lwplst
z1 z2 crossedlst)
(setq contlst nil)
(foreach e edgelst
(setq z1 (caddr (nth (car e) ptlst))
z2 (caddr (nth (cadr e) ptlst))
)
(if (= z1 lev) (setq z1 (+ z1 1e-8)))
(if (= z2 lev) (setq z2 (+ z2 1e-8)))
(if (or (< z1 lev z2)(> z1 lev z2))
(setq contlst (cons e contlst))
)
)
(setq crossedlst nil)
(while contlst
(setq pos 0)
;;Find an edge on the convex hull and start from it if none start at last pos in contlst
(while (and (member (reverse (nth pos contlst)) contlst) (< pos (1- (length contlst))))
(setq pos (1+ pos))
)
(setq lwplst (list (nth pos contlst))
contlst (nth_del pos contlst)
pos (- pos (rem pos 2))
lwplst (cons (nth pos contlst) lwplst)
nxt (reverse (car lwplst))
contlst (nth_del pos contlst)
)
(while (and (setq pos (vl-position nxt contlst)) (not (member nxt lwplst)))
(cond
((> (length contlst) 1)
(setq contlst (nth_del pos contlst)
pos (- pos (rem pos 2))
lwplst (cons (nth pos contlst) lwplst)
nxt (reverse (car lwplst))
contlst (nth_del pos contlst)
)
)
(t (setq lwplst (cons (nth pos contlst) lwplst)
contlst (nth_del pos contlst)
)
)
)
)
(setq crossedlst (cons lwplst crossedlst))
)
crossedlst
)
;; MAKE_CONTOUR ;
;; ;
;; Creates LWPolylines from the edgelst ;
;; ;
(defun MAKE_CONTOUR (zmin zmax intv edgelst ptlst /
lwplst lev edge p1 p2 d pt tmp)
(setq lev zmin)
(repeat (fix (/ (- zmax zmin) intv))
(setq lwplst (GETCROSSEDEDGE lev edgelst ptlst))
(foreach pline lwplst
(setq tmp nil)
(foreach edge pline
(setq p1 (nth (car edge) ptlst)
p2 (nth (cadr edge) ptlst)
r (/ (- l (caddr p1)) (- (caddr p2) (caddr p1)));Modified june 2013
p1 (list (car p1)(cadr p1)) ; Calculation of contour was incorrect
p2 (list (car p2)(cadr p2))
d (* (distance p1 p2) r)
pt (polar p1 (angle p1 p2) d)
pt (list (car pt)(cadr pt))
tmp (cons (cons 10 pt) tmp)
)
)
(setq tmp (cons (cons 38 lev) tmp)
tmp (cons (cons 43 0.0) tmp)
tmp (cons (cons 70 0) tmp)
tmp (cons (cons 90 (length pline)) tmp)
tmp (cons (cons 100 "AcDbPolyline") tmp)
tmp (cons (cons 100 "AcDbEntity") tmp)
tmp (cons (cons 8 "Contour") tmp)
tmp (cons (cons 0 "LWPOLYLINE") tmp)
)
(entmake tmp)
)
(setq lev (+ lev intv))
)
)
;; THINKING ;
;; ;
;; Standard progress spinner ;
;; ;
(defun THINKING (prmpt think-cnt)
(setq think-cnt (1+ think-cnt))
(princ (strcat "\r" (nth (rem think-cnt 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *****************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
( (1652.17 356.759 16.4)
(1666.15 431.163 16.1)
(1688.64 379.861 16.2)
(1708.17 888.849 13.8)
(1763.96 799.643 14.1)
(1818.56 140.657 18.3)
(1883.13 226.078 18.1)
(1888.23 124.665 18.8)
(1900.26 864.281 12.8)
(1950.15 730.671 12.5)
(1979.73 671.496 12.1)
(2031.64 260.656 15.8)
(2069.42 69.732 22.2)
(2071.19 123.139 19.8)
(2096.73 383.737 15.4)
(2173.55 135.927 20.7)
(2241.51 1048.67 15.1)
(2298.4 460.399 12.3)
(2304.6 871.301 12.0)
(2441.41 517.957 11.5)
(2455.6 695.636 10.0)
(2462.35 249.15 18.3)
(2585.43 387.857 9.8)
(2591.77 477.032 9.5)
)
Holas:
Very small differences, but actually looks better.
The best test is made with points that are in one of the sought contour. So, if the new curve (polyline) boundary passes over the points, is that the process can be taken for good.
Eugeny: another "extravaganza" of your algorithm ... please watch the yellow circle in extreme of wellow arrow......
I hope my words do not destroy the great atmosphere of communication and mutual learning on the forum! :?
You've contributed a great piece of code ElpanovEvgeniy, Спасибо.
You've contributed a great piece of code ElpanovEvgeniy, Спасибо.
You wrote this code in another language and your code is much faster...
Also I am sure that this could be optimized <<<< There are 3 or 4 methods ( p.e.geometric general calculation ) that are not highly purified. If you have any interest in something really fast ( productive? ), please write me to e-mail private.
Very good idea! Bravo.
I am manage a process of comprehensive automation of CAD, CAM and CAE.
I have done some testing ...with one MDT based on LWPOLYLINE. I post a micro-video... I fail to generate animated GIF, so herewith a AVI
Greetings
QuoteI am manage a process of comprehensive automation of CAD, CAM and CAE.
Evgenyi,
I got back into triangulation and contouring as part of a hobby of mine which is writing GCode
for router machine.
There exist very good program like Vectric Aspire but they are so pricey!!
If you want to do 3d routing, thr problem is essantially contouring.
Cheers!
ymg
Now I write 3D kernel for the direct management of vertices, edges and faces 3dsolid. All this is necessary in a project of precast ferroconcrete.
You've worked with solids "ACIS"? They are solid autocad. Are well documented.
very very interesting.
Greetings
Eugeny:
I thought rather directly access to 3DSOLID with the "SAT" files .
Giles opened the door, with a wonderful ACISDECODE subfunction.
From there, you can get the points, edges, vertices, faces, normal, holes, etc, of the ACIS solids.
I have read that it is developed also for NET.
It is always a good thing that new developments are compatible with something already established.
I do not know if your head warm.
A greeting. :-)
A very strange sentence!
Individually written program, will always be significantly more expensive than to sell in large quantities. Free software has its price.
Of course developing custom solutions is always more expensive.
However If you are doing it as a hobby, buying every nice program out there can break the bank.
Plus programming is another hobby.
ymg
(defun c:test (/ I L S)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
) ;_ setq
(progn (repeat (sslength s)
(setq l (cons (cdr (assoc 10 (entget (ssname s i)))) l)
i (1+ i)
) ;_ setq
) ;_ repeat
(eea-delone-triangulate i l)
) ;_ progn
) ;_ if
) ;_ defun
(defun eea-delone-triangulate
(i1 L / A A1 A2 A3 I I2 L1
L2 L3 LP MA MI P S TI TR X1
X2 Y1 Y2
)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; edit 20.05.2011
;; Program triangulate an irregular set of 3d points.
;;
;;*********************************************************
(if l
(progn
(setq ti (car (_VL-TIMES))
i 1
i1 (/ i1 100.)
i2 0
l (vl-sort
(mapcar
(function (lambda (p)
(list (/ (fix (* (car p) 1000)) 1000.)
(/ (fix (* (cadr p) 1000)) 1000.)
(caddr p)
) ;_ list
) ;_ lambda
) ;_ function
l
) ;_ mapcar
(function (lambda (a b) (>= (car a) (car b))))
) ;_ vl-sort
x2 (caar l)
y1 (cadar l)
y2 y1
) ;_ setq
(while l
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
)
)
(setq a (fix (caar l))
a1 (list (car l))
l (cdr l)
) ;_ setq
(while (and l (= (fix (caar l)) a))
(setq a2 (car l))
(if (<= (cadr a2) y1)
(setq y1 (cadr a2))
(if (> (cadr a2) y2)
(setq y2 (cadr a2))
) ;_ if
) ;_ if
(setq a1 (cons (car l) (vl-remove a2 a1))
l (cdr l)
) ;_ setq
) ;_ while
(foreach a a1 (setq lp (cons a lp)))
) ;_ while
(setq x1 (caar lp)
a (list (/ (+ x1 x2) 2) (/ (+ y1 y2) 2))
a1 (distance a (list x1 y1))
ma (+ (car a)(* 20 a1));changed ymg
mi (- (car a)(* 20 a1));changed ymg
s (list (list ma (cadr a) 0)
(list mi (+ (cadr a)(* 20 a1)) 0);changed ymg
(list mi (- (cadr a)(* 20 a1)) 0);changed ymg
) ;_ supertriangle
l (list (cons x2 (cons a (cons (+ a1 a1) s))))
;mi (- (car a)(* 20 a1));added ymg
ma (1- ma)
mi (1+ mi)
) ;_ setq
(while lp
(setq p (car lp)
lp (cdr lp)
l1 nil
) ;_ setq
(while l
(setq tr (car l)
l (cdr l)
) ;_ setq
(cond
((< (car tr) (car p)) (setq l2 (cons (cdddr tr) l2)))
((< (distance p (cadr tr)) (caddr tr))
(setq tr (cdddr tr)
a1 (car tr)
a2 (cadr tr)
a3 (caddr tr)
l1 (cons (list (+ (car a1) (car a2))
(+ (cadr a1) (cadr a2))
a1
a2
)
(cons (list (+ (car a2) (car a3))
(+ (cadr a2) (cadr a3))
a2
a3
)
(cons (list (+ (car a3) (car a1))
(+ (cadr a3) (cadr a1))
a3
a1
)
l1
)
) ;_ cons
) ;_ cons
) ;_ setq
)
(t (setq l3 (cons tr l3)))
) ;_ cond
) ;_ while
(setq l l3
l3 nil
l1 (vl-sort l1
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
) ;_ if
) ;_ lambda
) ;_ function
) ;_ vl-sort
) ;_ setq
(while l1
(if (and (= (caar l1) (caadr l1))
(= (cadar l1) (cadadr l1))
)
(setq l1 (cddr l1))
(setq l (cons (eea-data-triangle p (cddar l1)) l)
l1 (cdr l1)
) ;_ setq
) ;_ if
) ;_ while
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn
(setvar
"MODEMACRO"
(strcat
" "
(itoa (setq i2 (1+ i2)))
" % "
(substr
"||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
1
i2
) ;_ substr
(substr "..." 1 (- 100 i2))
) ;_ strcat
) ;_ setvar
(setq i i1)
) ;_ progn
) ;_ if
) ;_ while
(foreach a l (setq l2 (cons (cdddr a) l2)))
;purge triangle list
(setq
l2 (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
l2
) ;_ vl-remove-if
) ;_ setq
(foreach a l2
(entmake (list (cons 0 "3DFACE")
(cons 10 (car a))
(cons 11 (car a))
(cons 12 (cadr a))
(cons 13 (caddr a))
) ;_ list
) ;_ entmake
) ;_ foreach
) ;_ progn
) ;_ if
(setvar "MODEMACRO" "")
(princ (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
)
(princ)
) ;_ defun
(defun eea-data-triangle (P1 l / A A1 P2 P3 P4 S)
;;*********************************************************
;;
;; Written by ElpanovEvgeniy
;; 17.10.2008
;; Calculation of the centre of a circle and circle radius
;; for program triangulate
;;
;; (eea-data-triangle (getpoint)(list(getpoint)(getpoint)))
;;*********************************************************
(setq p2 (car l)
p3 (cadr l)
p4 (list (car p3) (cadr p3))
) ;_ setq
(if (not
(zerop
(setq s (sin (setq a (- (angle p2 p4) (angle p2 p1)))))
)
)
(progn (setq a (polar p4
(+ -1.570796326794896 (angle p4 p1) a)
(setq a1 (/ (distance p1 p4) s 2.))
) ;_ polar
a1 (abs a1)
) ;_ setq
(list (+ (car a) a1) a a1 p1 p2 p3)
) ;_ progn
) ;_ if
) ;_ defun
(defun c:test (/ i pl s)
(princ (strcat "\n select points"))
(if (setq i 0
s (ssget '((0 . "POINT")))
)
(progn (repeat (sslength s)
(setq pl (cons (cdr (assoc 10 (entget (ssname s i)))) pl)
i (1+ i)
)
)
(triangulate pl)
)
)
)
;;********************************************************;
;; ;
;; Written by ElpanovEvgeniy ;
;; 17.10.2008 ;
;; edit 20.05.2011 ;
;; Program triangulate an irregular set of 3d points. ;
;; Modified by ymg June 2011 ;
;;********************************************************;
(defun triangulate (pl / a b c i i1 i2
bb sl al el tl l ma mi
ti tr x1 x2 y1 y2 p r cp
)
(if pl
(progn
(setq ti (car (_VL-TIMES))
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))
)
;Replaced code to get minY and maxY with 3d Bounding Box Routine;
;A bit slower but clearer. minZ and maxZ kept for contouring ;
x1 (caar bb) ;minX
x2 (caadr bb) ;maxX
y1 (cadar bb) ;minY
y2 (cadadr bb) ;maxY
)
(setq cp (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0)); Midpoint of points cloud and center point of circumcircle through supertriangle.
r (* (distance cp (list x1 y1)) 20) ;This could still be too small in certain case. No harm if we make it bigger.
ma (+ (car cp) r);ma is maxX of supertriangle
mi (- (car cp) r);mi is minX of supertriangle
sl (list (list ma (cadr cp) 0);list of 3 points defining the supertriangle
(list mi (+ (cadr cp) r) 0)
(list mi (- (cadr cp) r) 0)
)
al (list (cons x2 (cons cp (cons (* 20 r) sl))))
;al is a work list that contains active triangles each item is a list that contains: ;
; item 0: Xmax of points in triangle. ;
; item 1: List 2d coordinates of center of circle circumscribing triangle. ;
; item 2: Radius of above circle. ;
; item 3: List of 3 points defining the triangle ;
ma (1- ma);Reducing ma to prepare for removal of triangles having a vertex
mi (1+ mi);common with supertriangle. Done once triangulation is completed.
) ;Increasing mi for same reason.
;Begin insertion of points
(repeat (length pl)
(setq p (car pl);Get one point from point list
pl (cdr pl);Remove point from point list
el nil ;Initialize edge list
)
(while al ;Active triangle list
(setq tr (car al);Get one triangle from active triangle list.
al (cdr al);Remove the triangle from the active list.
)
(cond
((< (car tr) (car p)) (setq tl (cons (cdddr tr) tl)));This triangle inactive. We store it's 3 vertex in tl (Final triangle list).
((< (distance p (cadr tr)) (caddr tr));p is inside the triangle.
(setq tr (cdddr tr) ;Trim tr to vertex of triangle only.
a (car tr) ; First point.
b (cadr tr) ; Second point.
c (caddr tr) ; Third point.
el (cons (list (+ (car a) (car b)) ;We create 3 new edges ab, bc and ca,
(+ (cadr a) (cadr b)) ;and store them in edge list.
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))) ;tr did not meet any cond so it is still active.
) ;we store it a temporary list.
);Go to next triangle of active list.
(setq al l ;Restore active triangle list from the temporary list.
l nil ;Re-initialize the temporary list to prepare for next insertion.
el (vl-sort el ;Sort the edges list on X and Y
(function (lambda (a b)
(if (= (car a) (car b))
(<= (cadr a) (cadr b))
(< (car a) (car b))
)
)
)
)
)
;Removes doubled edges, form new triangles, calculates circumcircles and add them to active list.
(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)
)
)
)
;Spinner to show progress
(if (and (< (setq i (1- i)) 1) (< i2 100))
(progn
(setvar
"MODEMACRO"
(strcat
" "
(itoa (setq i2 (1+ i2)))
" % "
(substr
"||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||"
1
i2
)
(substr "..." 1 (- 100 i2))
)
)
(setq i i1)
)
)
) ;Go to insert next point.
;We are done with the triangulation
(foreach tr al (setq tl (cons (cdddr tr) tl)));What's left in active list is added to triangle list
;Purge triangle list of any triangle that has a common vertex with supertriangle.
(setq
tl (vl-remove-if-not
(function
(lambda (a)
(and (< mi (caadr a) ma) (< mi (caaddr a) ma))
)
)
tl
)
)
;Create a layer and Draw the triangulation
(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))
)
)
)
)
)
(setvar "MODEMACRO" "")
(princ (strcat "\n "
(rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4)
" secs."
)
)
(princ)
)
;;*********************************************************;
;; ;
;; Written by ElpanovEvgeniy ;
;; 17.10.2008 ;
;; Calculation of the centre of a circle and circle radius ;
;; for program triangulate ;
;; ;
;; Modified ymg june 2011 (renamed variables) ;
;;*********************************************************;
(defun getcircumcircle (a el / b c c2 cp r ang)
(setq b (car el)
c (cadr el)
c2 (list (car c) (cadr c)) ;c2 is point c but in 2d
)
(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)
)
)
)
Now, the program still seems complicated?
No, since it is basically the same algoritmn as Piazza's program.
The first is GA for TSP .
Can be a little more detail?
I first heard about this algorithm ...
For this program, I developed an algorithm by yourself!]
The Divide and conquer algorithm could be faster than this one if written properly.
do you propose to continue the contest in Lisp?
It is a challenge?
(grread t); Dummy just to force a screen update and avoid that Autocad hangs while calculating
(princ (strcat "\n TIN Completed - Elapsed time: " (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) " secs."))
(princ (strcat "\n Generated " (itoa (length tl)) " 3DFACES"))
(princ "\n")
; Begin Calculation of Contour line
;
; The routine follows each contour from edge to edge resulting in Connected LWPOLYLINE.
;
; 1. Sort triangle list tl on the maximum z value of vertices of each triangles.
; 2. Create el, a list containing all edges of all triangles. ((a b)(b c) (c a).......)
; 3. For each desired contour level l, we traverse el and create list cl containing all
; edges crossed by level l. At this point cl contains 2 edges per triangle.
; As we go through el, we can destroy any triplets of edges whose max z value is below
; the current contour level, thus limiting traversal for next level.
; 4. We now process cl, following from edge to edge until either we've closed the polyline
; or reached the convex hull. If we reached the convex hull, we insure that the beginning
; of the polyline is also on the convex hull. Otherwise we reverse the polyline and
; continue processing. Process continues until cl is empty.
; As we complete each polyline list xl is formed.
; 5. We entmake each element of list xl.
; 6. We go back to step 3 until all levels are completed and el is empty.
;
; Step 4 and 5 could be combined but it is easier to follow contour in index form
;
;
; An alternate way to do this would be compute all al segment between two edges joining with
; with a line for all contour level and at end Join everything together.
;
; Setup for Contouring
(setq ti (car (_VL-TIMES)) ; Re-initialize timer for Contouring
i 1
i1 (/ (length pl) 100.)
i2 0
intv 1 ; Interval between contour
zmin (+ (fix zmin) intv) ; zmin was calculated during triangulation
zmax (fix zmax) ; z2 also calculated at beginning
l zmin ; Initialize Contour level
el nil ; el will be list of all edges
vc 0 ; Vertices Count
pc 0 ; LWPOLYLINE Count
)
(setq tl (vl-sort tl
(function
(lambda (a b)
(< (max (caddr (nth (car a) pl))
(caddr (nth (cadr a) pl)) ;Gotta be a more concise way
(caddr (nth (caddr a) pl)) ;to write this probably with apply.
) ;Help!!!
(max (caddr (nth (car b) pl))
(caddr (nth (cadr b) pl))
(caddr (nth (caddr b) pl))
)
)
)
)
)
)
; Extract all triangle edges from tl and form list el
(foreach tr tl
(setq el (cons (list (car tr)(cadr tr)) el)
el (cons (list (cadr tr)(caddr tr)) el)
el (cons (list (caddr tr)(car tr)) el)
)
)
(repeat (+(fix (/ (- zmax zmin) intv)) 1) ;Main Loop through each contour level
(setq cl nil ; cl will be list of all edges crossed at current level l
j 0 ; Index into edge list el
zm 1e-8 ; zmax value for a given triplets of edges
)
(repeat (length el)
(setq e (nth j el)
z1 (caddr (nth (car e) pl)) ; Get elevation of edges from the point list.
z2 (caddr (nth (cadr e) pl))
zm (max zm z1 z2)
j (1+ j)
)
(if (and (= (rem j 3) 0) (< zm (+ l intv))) ; Reduce size of el on zmax criteria.
(setq j (- j 3)
el (vl-remove (nth j el) el)
el (vl-remove (nth j el) el)
el (vl-remove (nth j el) el)
zm 1e-8
)
)
(if (= z1 l) (setq z1 (- z1 1e-8))); If vertex is equal to l we disturb
(if (= z2 l) (setq z2 (- z2 1e-8))); the z value a little.
(if (or (< z1 l z2)(> z1 l z2))
(setq cl (cons e cl)) ; Edge is added to Crossed List
)
);end foreach e
; cl now contains all edges where all contours at level l passes.
(setq xl nil)
(while cl
;We Initialize a Polyline
(setq pol (list (cadr cl)(car cl)) ; We go reverse as we will cons the polyline
nxt (reverse (car pol)) ; nxt will be our next edge
cl (cddr cl) ; Remove first two edges from cl
)
(if (not (member nxt cl)) ;The previous edge was on convex hull
(setq pol (reverse pol) ;We reverse our Polyline
nxt (reverse(car pol)) ;and adjust our next edge
)
)
(while (setq n (vl-position nxt cl))
(setq cl (vl-remove (nth n cl) cl)
n (- n (rem n 2))
pol (cons (nth n cl) pol)
cl (vl-remove (nth n cl) cl)
)
(if (member nxt pol)
(setq nxt nil)
(setq nxt (reverse (car pol)))
)
(if (not (vl-position nxt cl))
(setq pol (reverse pol)
nxt (reverse (car pol))
)
)
);end while
(setq xl (cons pol xl))
);end while cl
(setq pc (+ pc (length xl)))
(foreach p xl
(setq ent nil
vc (+ vc (length p))
)
(if (equal (car p) (reverse (last p)))
(setq isclosed 1
p (cddr p)
)
(setq isclosed 0)
)
(foreach e p
(setq p1 (nth (car e) pl)
p2 (nth (cadr e) pl)
r (/ (- l (caddr p1)) (- (caddr p2) (caddr p1)))
p1 (list (car p1)(cadr p1))
p2 (list (car p2)(cadr p2))
d (* (distance p1 p2) r)
pt (polar p1 (angle p1 p2) d)
ent (cons (cons 10 pt) ent)
)
)
(setq ent (cons (cons 38 l) ent)
ent (cons (cons 43 0.0) ent)
ent (cons (cons 70 isclosed) ent)
ent (cons (cons 90 (length p)) ent)
ent (cons (cons 100 "AcDbPolyline") ent)
ent (cons (cons 100 "AcDbEntity") ent)
ent (cons (cons 8 "Contour") ent)
ent (cons (cons 0 "LWPOLYLINE") ent)
)
(entmake ent)
);end foreach p
(setq l (+ l intv))
);end repeat
(setvar "MODEMACRO" "")
(princ (strcat "\n CONTOUR Completed - Elapsed time: " (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) " secs."))
(princ (strcat "\n Generated " (itoa pc) " LWPOLYLINE."))
(princ (strcat "\n Total " (itoa vc) " Vertices."))
(princ)
);end defun triangulate
(foreach p xl
(setq ent nil
vc (+ vc (length p))
)
(if (equal (car p) (reverse (last p)))
(setq isclosed 1
p (cdr p) ;Was wrong (cddr p)
)
(setq isclosed 0)
)
I inadvertently introduce a bug in the last posting of tin.lsp, :ugly:
; Contour by ymg (July 2013)
;
; The routine follows each contour from edge to edge resulting in Connected LWPOLYLINE.
; Basic method is per:
; http://www.originlab.com/www/helponline/Origin/en/UserGuide/Creating_Contour_Graphs.html
;
; Contours are then smoothed using Christensen's Eclectic Method.
; For details see:
; http://www.asprs.org/a/publications/pers/2001journal/april/2001_apr_511-517.pdf
; http://www.google.com.mx/patents/US5333248
;
; General Flow:
;
; 1. Sort triangle list tl on the maximum z value of vertices of each triangles.
;
; 2. Create el, a list containing all edges of all triangles. ((a b)(b c) (c a).......)
;
; 3. For each desired contour level l, we traverse el and create list cl containing all
; edges crossed by level l. At this point cl contains 2 edges per triangle.
; As we go through el, we can destroy any triplets of edges whose max z value is below
; the current contour level, thus limiting traversal for next level.
;
; 4. We now process cl, following from edge to edge until either, we've closed the polyline
; or reached the convex hull. If we reached the convex hull, we insure that the beginning
; of the polyline is also on the convex hull. Otherwise we reverse the polyline and
; continue processing until cl is empty.
; As we complete each polyline list xl is formed and contains a series of list tracing all the
; polylines for a given level.
;
; 5. We entmake each element of list xl, smoothing vertices of polylines when conditions are right.
; Variable mang controls if an edge can be smoothed or not preventing crossing of contours.
; Smoothing is controlled by two variables lang and lres which limits the number of segments
; tracing the parabolas of an edge.
;
; 6. We go back to step 3 until all levels are completed and el is empty.
;
;
;
(defun contour (tl pl / a a1 a2 a3 b bb c cl cn1 cn2 e el ent hfac i i1 i2 intv isclosed
j l lang lres mang n nxt p1 p2 p3 p4 pc pl pol prv seg sm ti
v1 v2 v3 vcr vcs xl z1 z2 zm zmax zmin
)
; Setup for Contouring
(setq ti (car (_VL-TIMES)) ; Re-initialize timer for Contouring
i 1
i1 (/ (length pl) 100.)
i2 0
bb (list
(apply 'mapcar (cons 'min pl))
(apply 'mapcar (cons 'max pl))
) ; bb, bounding box of Point List.
zmin (caddar bb) ; zmin, minimum z of Point List.
zmax (caddr(cadr bb)) ; zmax, maximum z of Point List.
intv 1 ; Interval between contour.
zmin (+ (fix zmin) intv) ; zmin, first level for contour.
zmax (fix zmax) ; zmax; last level for contour.
l zmin ; Initialize Current Contour level.
intv 1 ; Interval between contour.
el nil ; el, will be list of all edges in triangle list.
vcr 0 ; Vertices Count for Raw Contours.
vcs 0 ; Vertices Count for Smoothed Contours.
pc 0 ; LWPOLYLINE Count.
lres 5 ; Linear resolution for smoothing.
lang (dtr 5) ; Angular resolution for smoothing.
mang (* lang 1.5) ; Min angle controls if an edge is suitable for smoothing.
hfac 0.5 ; Degree of smoothing, Max is 0.5, Min would be 1.
)
(setq tl (vl-sort tl
(function
(lambda (a b)
(< (max (caddr (nth (car a) pl))
(caddr (nth (cadr a) pl)) ;Gotta be a more concise way
(caddr (nth (caddr a) pl)) ;to write this probably with apply.
) ;Help!!!
(max (caddr (nth (car b) pl))
(caddr (nth (cadr b) pl))
(caddr (nth (caddr b) pl))
)
)
)
)
)
)
; Extract all triangle edges from tl and form edges list el
(foreach tr tl
(setq el (cons (list (car tr)(cadr tr)) el)
el (cons (list (cadr tr)(caddr tr)) el)
el (cons (list (caddr tr)(car tr)) el)
)
)
(repeat (+(fix (/ (- zmax zmin) intv)) 1) ;Main Loop through each contour level
(setq cl nil ; cl will be list of all edges crossed at current level l
j 0 ; Index into edge list el
zm 1e-8 ; zmax value for a given triplets of edges
)
(repeat (length el)
(setq e (nth j el)
z1 (caddr (nth (car e) pl)) ; Get elevation of edges from the point list.
z2 (caddr (nth (cadr e) pl))
zm (max zm z1 z2)
j (1+ j)
)
(if (and (= (rem j 3) 0) (< zm (+ l intv))) ; Reduce size of el on zmax criteria.
(setq j (- j 3)
el (vl-remove (nth j el) el)
el (vl-remove (nth j el) el)
el (vl-remove (nth j el) el)
zm 1e-8
)
)
(if (= z1 l) (setq z1 (- z1 1e-8))); If vertex is equal to l we disturb
(if (= z2 l) (setq z2 (- z2 1e-8))); the z value a little.
(if (or (< z1 l z2)(> z1 l z2))
(setq cl (cons e cl)) ; Edge is added to Crossed List
)
);end foreach e
; cl now contains all edges where all contours at level l passes.
(setq xl nil)
(while cl
;We Initialize a Polyline
(setq pol (list (cadr cl)(car cl)) ; We go reverse as we will cons the polyline
nxt (reverse (car pol)) ; nxt will be our next edge
cl (cddr cl) ; Remove first two edges from cl
)
(if (not (member nxt cl)) ;The previous edge was on convex hull
(setq pol (reverse pol) ;We reverse our Polyline
nxt (reverse(car pol)) ;and adjust our next edge
)
)
(while (setq n (vl-position nxt cl))
(setq cl (vl-remove (nth n cl) cl)
n (- n (rem n 2))
pol (cons (nth n cl) pol)
cl (vl-remove (nth n cl) cl)
)
(if (member nxt pol)
(setq nxt nil)
(setq nxt (reverse (car pol)))
)
(if (not (vl-position nxt cl))
(setq pol (reverse pol)
nxt (reverse (car pol))
)
)
);end while
(setq xl (cons pol xl))
);end while cl
(setq pc (+ pc (length xl)))
(foreach p xl
(setq ent nil)
(if (equal (car p) (reverse (last p)))
(setq isclosed 1
p (append p (list(cadr p)))
)
(setq isclosed 0
ent (list (cons 10 (clv l (car p) pl)))
)
)
(while (> (length p) 2)
(setq v1 (clv l (car p) pl)
v2 (clv l (cadr p) pl)
)
(setq v3 (clv l (caddr p) pl)
prv (car p)
nxt (caddr p)
p (cdr p)
p1 (nth (caar p) pl)
p3 (nth (cadar p) pl)
p2 (nth (car prv) pl)
p4 (nth (car nxt) pl)
)
(if (or (equal p2 p1) (equal p2 p3))
(setq p2 (nth (cadr prv) pl))
)
(if (or (equal p4 p1) (equal p4 p3))
(setq p4 (nth (cadr nxt) pl))
)
; Need to test here if edge p1 p3 is suitable for smoothing
; Unclear to me, what mang should if I set it to same value as lang, we still have
; Contours crossing each other. With (* lang 1.5) no crossing!!
(cond
((and (or (< (defl p1 p2 p3) mang) (< (defl p1 p4 p3) mang))
(> (/ (abs (- (caddr p1) (caddr p3))) intv) 1)
)
(setq sm (list v2 )); Unsuitable we set v2 as the vertices on this edge.
)
(t (setq cn1 (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p2 p3)
cn2 (mapcar '(lambda (a b c) (/ (+ a b c) 3.0)) p1 p3 p4)
a1 (cond
((inters cn1 p1 v1 v2))
((inters cn1 p3 v1 v2))
;((inters cn1 p2 v1 v2))
)
a2 v2
a3 (cond
((inters cn2 p1 v2 v3))
((inters cn2 p3 v2 v3))
;((inters cn2 p4 v2 v3))
)
sm (smooth a1 a2 a3); Probably would be better not to call a function here
); end setq
); end t
); end cond
(foreach e sm
(setq ent (cons (cons 10 e) ent))
)
); end while p
(if (= isclosed 0) (setq ent (cons(cons 10 v3) ent)))
(setq seg (length ent)
vcs (+ vcs seg)
ent (cons (cons 38 l) ent)
ent (cons (cons 43 0.0) ent)
ent (cons (cons 70 isclosed) ent)
ent (cons (cons 90 seg) ent)
ent (cons (cons 100 "AcDbPolyline") ent)
ent (cons (cons 100 "AcDbEntity") ent)
ent (cons (cons 8 "Contour") ent)
ent (cons (cons 0 "LWPOLYLINE") ent)
)
(entmake ent)
);end foreach p
(setq l (+ l intv))
);end repeat
(setvar "MODEMACRO" "")
(princ (strcat "\n CONTOUR - Elapsed time: " (rtos (/ (- (car (_VL-TIMES)) ti) 1000.) 2 4) " secs, "
(itoa pc) " LWPOLYLINES, "
(itoa vcs) " Vertices."
)
)
(princ)
);end defun contour
; Degree to Radian Conversion
(defun dtr (a) (* pi (/ a 180.0)))
; Given: lev, (level of contour being traced).
; ed, (edge defined by a list of two index into the point list.,
; pl, Point List
;
; Returns: Point where contour cross the edge.
(defun clv (lev ed pl / r d p1 p2)
(setq p1 (nth (car ed) pl)
p2 (nth (cadr ed) pl)
r (/ (- lev (caddr p1))
(- (caddr p2) (caddr p1))
)
p1 (list (car p1)(cadr p1))
p2 (list (car p2)(cadr p2))
d (* (distance p1 p2) r)
)
(polar p1 (angle p1 p2) d)
)
; Smooth an edge defined by 3 points
; Returns a list of points starting at a1 and ending at a3
; which traces two parabolas joining a1 to a3
; Global variables lang and lres limits number of segments on parabolas.
; Global variable hfac controls how much smoothing we apply (Not implemented yet)
(defun smooth (a1 a2 a3 / cp f ps tmp)
(setq ps (subdiv a1 a2 a3)
f nil
)
(while ps
(setq cp (car ps)
ps (cdr ps)
)
(while (and (> (min (distance (car cp) (cadr cp))
(distance (cadr cp) (caddr cp))
)
lres
)
(< (defl (car cp) (cadr cp) (caddr cp))
(- pi lang)
)
)
(setq tmp (subdiv (caddr cp)(cadr cp)(car cp))
cp (car tmp)
ps (cons (cadr tmp) ps)
)
) ; end while lres lang
(setq f (cons (car cp) f))
) ; end while ps
(cons a1 f)
)
; Subdivide a pair defined by 3 points (a1 b1 c1)
; Return a list of 6 points (a1 d1 e1 e1 d2 c1)
(defun subdiv (a1 b1 c1 / m1 m2 m3)
(setq m1 (mid a1 b1)
m3 (mid b1 c1)
m2 (mid m1 m3)
)
(list (list c1 m3 m2)(list m2 m1 a1))
)
; Midpoint of two points
(defun mid (a b)
(mapcar '(lambda (a b) (/ (+ a b) 2.0)) a b)
)
; Given 3 points, return the angle smaller than pi between a b and c b
(defun defl (a b c / d)
(abs (- (setq d (- (angle b a)(angle b c))) (* (fix (/ d pi)) (+ pi pi))))
)
;Generate a bunch of points for testing on layer named points.
(defun c:gen ( / n rangex rangey rangez)
(setq n (getint "\nNumber of points: ")
rangex 5000 ; Extent in X for the points
rangey (/ rangex 1.6); Extent in Y * Golden Ratio
rangez 10 ; Extent in Z
)
(while (> n 0)
(entmake
(list
'(0 . "POINT")
'(8 . "Points")
(cons 10 (list (* rangex (ran)) (* rangey (ran)) (* rangez (ran))))
)
)
(setq n (1- n))
)
)
; Random number generator
(defun ran ()
(setq seed (if seed (rem (+ (* seed 15625.7) 0.21137152) 1) 0.3171943))
)
I have also found a bug, the contour iteration is not completing all contours
Just as a thought, if you where to adjust the lres variable (line resolution) at the same time the smoothing factor is
Unacceptable, 3 lashes with a wet hypotenuse.
Thank you ymg . Where i can find the new version ?
intvL '(" 0.02" " 0.1" " 0.2" " 1" " 2" " 5" " 10")
majcntL '(" 0.1" " 0.5" " 1" " 5" " 10" " 50" "100")
hfacL '(" Max" " -20%" " -40%" " -60%" " -80%" " Min" "None")
intvL '(" 0.02" " 0.1" " 0.2"......................)
majcntL '(" 0.1" " 0.5" " 1" ..........................")
hfacL '(" Max" " -20%" " -40%" " -60%" " -80%" " Min" "None")"
Here is an update to the TIN program.Great Program , Yang !
It is still very much a work in progress, so I would appreciate
bug reports and enhancement suggestion.
The Contouring part has been accelerated a little, and now work with
fractionnal contours.
You can also call CONT to do contours on a Selection of existing 3DFACE.
Express Tools is required, as I make use of the Progress Bar.
Still missing Breaklines handling for the triangulation,
and Highlighting of Depression Contours for the contouring section.
ymg
"You can also call CONT to do contours on a Selection of existing 3DFACE." , I hope It can
chlh_jd,I'm sorry for Just finished reading your code in *gress5.lsp and foud add cont command .Quote"You can also call CONT to do contours on a Selection of existing 3DFACE." , I hope It can
Thanks for the feedback.
Agree that my wording is not too clear. What was meant by that is in the case where you already have
a selection of 3dfaces created by another program, you can use command "CONT" and do the contouring.
Normal way would be a set of points that you triangulate and then contours.Sorry for my poor English , I mean that , the zone I mark , smoothed contours less than ideal .
I do not understand exactly what you mean from the attached image. Could you clarify?
I've been playing around a bit with it and manage to accelerate it some. Shall post it soon.Not long ago, I also wrote a contour program is based on existing 3DFACES, and not for smoothing; and I'v lost in smooth annoying.
We still need to handle the marking of "Depression Contour" currently not available.
I highly recommend Christensen's paper, it is well worth the reading.
ymg
I believe that this zone would get crossing contours unless you do it this way.
In other word this is inherent to the method.
ymg
chlh_jd,Thanks Ymg , it did fix the bug in the case "intv=0.25 majcnt=1.0"; but error in the case "intv=0.1 majcnt=0.5".
Here is a revision with the bugs in contour generation removed.
Bear in mind, that this is still a work in progress, so the routine does not clean themselves nicely on completion.
ymg
Thanks Ymg , it did fix the bug in the case "intv=0.25 majcnt=1.0"; but error in the case "intv=0.1 majcnt=0.5".
...
(setq ti (car (_VL-TIMES)) ; Re-initialize timer for Contouring
zl (mapcar (function caddr) pl) ;_only for zlist
zmin (apply (function min) zl) ;_improve speed by GSLS(SS) 2014.3.2
zmax (apply (function max) zl)
zmin (* (fix (/ zmin intv)) intv) ;_zmin, first level for contour. (* (+ (fix (/ zmin intv)) 1) intv)
zmax (* (fix (/ zmax intv)) intv) ;_ zmax; last level for contour.
z zmin ; Initialize Current Contour level.
...
)
(setq tl (vl-sort tl
(function
(lambda (a b)
(< (max (nth (car a) zl)
(nth (cadr a) zl)
(nth (caddr a) zl))
(max (nth (car b) zl)
(nth (cadr b) zl)
(nth (caddr b) zl)))))))
...
In my head , Longer code still requires a larger computer memory
Command: prof
Select a Linear Entity:
Error: bad argument type: fixnump: nil
(setq pl (vl-sort pl (function (lambda (a b) (< (cadr a) (cadr b))))) ;; Sort on Y Coordinate
pl (vl-sort pl (function (lambda (a b) (< (car a) (car b))))) ;; Sort on X Coordinate
pl (vl-remove nil ;; Remove Duplicate Points
(mapcar '(lambda (a b) (if (not (equal (cdr (reverse a)) (cdr (reverse b)) 1e-03)) a))
pl (append (cdr pl) (list (car pl)))
)
)
)
(contour pl tl intv majcnt majcolor mincolor hfac norm)
2. In the "get_ss" function , will be error , if the 3dface is manual change ( because of the osnap accuracy ), it can be solve by two way : (setq pl (cons (mapcar (function (lambda (a) (/ (fix (* a 1e6)) 1e6))) p) pl)
3. In the contour function , some position may get error :?getContour@AcGeCurveBoundary@@QBEXAAHPAPAPAVAcGeEntity3d@@PAPAPAVAcGeCurve2d@@PAPAH3@Z
?getContour@AcGeImpCurveBoundary@@QBEXAAHPAPAPAVAcGeImpEntity3d@@PAPAPAVAcGeImpCurve3d@@PAPAH3@Z
?getContours@AcGeExternalBoundedSurface@@QBEXAAHAAPAVAcGeCurveBoundary@@@Z
?getContours@AcGeImpExternalBoundedSurface@@QBEXAAHAAPAVAcGeImpCurveBoundary@@@Z
ymg,
is a fantastic tool.
However, PROF function is not working. Always returns the same error.QuoteCommand: prof
Select a Linear Entity:
Error: bad argument type: fixnump: nil
I am using a lwpolyline as a linear entity. Not sure what am I doing wrong.
Attached the sample file
(if C:cal (princ "\nGeomcal loaded..")(arxload "geomcal"));** <-- this is optional
(if C:cal ;if loaded
(defun getz (p t1 t2 t3 / ptt ) ;defun opted by hanhphuc
(setq
ptt (list (car p)(cadr p)(1+(caddr p))))
(cal "ilp(p,ptt,t1,t2,t3)")
); getz
(defun getz .... code unchanged ) ;defun by ymg
) ;c:cal
(testgetz)
ymg0. Elapsed: 2.761 sec.
ymg1. Elapsed: 1.700 sec.
ymg2. Elapsed: 1.514 sec.
ymg3. Elapsed: 0.717 sec.
ymg4. Elapsed: 0.609 sec.
ymg5. Elapsed: 0.546 sec.
hanphuc. Elapsed: 16.162 sec.
marko1. Elapsed: 10.608 sec.
marko2. Elapsed: 7.581 sec.
_$
hi chlh_jd, this arx sample used by surveyor jobs can be applied in function: getz?I don't think so that use (cal "ilp...") would be faster than Ymg's getz function , because of it should cal not only z coor.
if we hide the first line (geomcal)** then we still can use ymg's getz, because ARX not loaded :-)
...
What I show In reply 168# I post , it's AutoCAD Interface routine
QuoteWhat I show In reply 168# I post , it's AutoCAD Interface routine
chlh_jd
not too sure that the functions in your post are applicable to isolines.
ymg
Error in dialog file
"C:\Users\Prodromos\AppData\Local\Temp\tin.dcl", line 401: newline in string constant
Error in dialog file
"C:\Users\Prodromos\AppData\Local\Temp\tin.dcl", line 402: missing semicolon
Error in dialog file
"C:\Users\Prodromos\AppData\Local\Temp\tin.dcl", line 402:
syntax error
Symbol: "0
0.0
0.00".
(write-line " list = \"0 \\n0.0 \\n0.00
\\n0.000\\n0.0000\"; " f)
list = \"0 \\n0.0 \\n0.00
\\n0.000\\n0.0000\";
(write-line " list = \"0 \\n0.0 \\n0.00\\n0.000\\n0.0000\"; " f)
Here is the new triangulation as per Sloan's paper.
This is a first version, so there are certainly many ways
to optimize it and gain some speed.
To use it just call sloan instead of triangulate in the Tin program.
;*****************************************************************************;
; Initiated by XXL at TheSwamp ;
; ;
; June 2014 ;
; c:gcmap draws a gradient color map on a TIN ;
; DOSLIB needs to be loaded for 'dos_hlstorgb' function ;
;*****************************************************************************;
(defun c:gcmap (/ col_Hb col_He col_L col_S s i
zl ent ival Hue_i TinMaxZ TinMinZ sug_ival
hue_i
)
(setq col_Hb 0)
;; color min hue value
(setq col_He 200)
;; color max hue value
(setq col_L 120)
;; color light
(setq col_S 240)
;; color saturation
;; select 3DFACES
(setq s (ssget '((0 . "3DFACE"))))
;; make a list from every elevation value in the TIN
(repeat (setq i (sslength s))
(setq ent (ssname s (setq i (1- i))))
(setq
zl (append
(mapcar 'cadddr
(mapcar '(lambda (key) (assoc key (entget ent)))
'(11 12 13)
)
)
zl
)
)
)
(setq TinMaxZ (apply 'max zl)
;; min TIN elevation
TinMinZ (apply 'min zl)
;; max TIN elevation
)
;; compute an interval suggestion for about 20 levels
(setq sug_ival (/ (- TinMaxZ TinMinZ) 20.0))
;; round to mm level
(setq sug_ival (/ (fix (+ 0.5 (* sug_ival 1000.0))) 1000.0))
;; computed suggestion is rounded
(cond ((> sug_ival 1.0)
(setq sug_ival (fix sug_ival))
)
((< sug_ival 0.099)
(setq sug_ival (/ (fix (+ 0.5 (* 100.0 sug_ival))) 100.0))
)
((< sug_ival 0.999)
(setq sug_ival (/ (fix (+ 0.5 (* 10.0 sug_ival))) 10.0))
)
)
;; get user interval input and verify
(while (not ival)
(setq ival
(getreal
(strcat
"\nEnter interval (suggested: "
(rtos sug_ival 2 3)
"m): "
)
)
)
(cond
((not ival)
(setq ival sug_ival)
)
(t
(progn
(if (> (/ (- TinMaxZ TinMinZ) ival) (- col_He col_Hb))
(progn
(alert
"\nEntered interval is too small for color range, please choose a larger interval."
)
(setq ival nil)
)
)
)
)
)
)
(prompt (strcat "\nComputing "
(rtos (/ (- TinMaxZ TinMinZ) ival) 2 0)
" elevation levels... "
)
)
;; compute Hue increment for each elevation level based on color hue range, TIN delta elevation and interval
(setq Hue_i (fix (/ (- col_He col_Hb) (/ (- TinMaxZ TinMinZ) ival))))
;; process every 3DFACE entity from selectionset s
(repeat (setq i (sslength s))
(setq ent (ssname s (setq i (1- i))))
(trfill ent)
)
(princ "done.")
(princ)
)
;; fill every 3DFACE with gradient colors
(defun trfill (e / pl pi1 pi2 pi3 i1 i2 i3 minz maxz dval dval$ cl)
;; create pointlist from 3Dface
(setq
pl (mapcar
'cdr
(mapcar '(lambda (key) (assoc key (entget e))) '(11 12 13))
)
)
(setq pl (vl-sort pl
(function (lambda (a b) (< (caddr a) (caddr b))))
)
)
;; min and max elevation of 3Dface
(setq minz (caddr (car pl)))
(setq maxz (caddr (car (reverse pl))))
(setq dval (* ival (+ 1 (fix (/ minz ival)))))
(setq dval$ (strcat "SOLID_" (rtos (- dval ival) 2 2)))
(if (>= dval maxz)
;;; there will be no intersections, colour the entire 3DFACE with a single solid
(progn
(setq
cl (rgbtotruecolor
(dos_hlstorgb
(+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
col_L
col_S
)
)
)
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 (nth 0 pl))
(cons 11 (nth 1 pl))
(cons 12 (nth 2 pl))
(cons 13 (nth 2 pl))
)
)
)
(progn
(while (< dval maxz)
(progn
(setq
cl (rgbtotruecolor
(dos_hlstorgb
(+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
col_L
col_S
)
)
)
(setq
i2 (inters (nth 0 pl)
(nth 1 pl)
(list (car (nth 0 pl)) (cadr (nth 0 pl)) dval)
(list (car (nth 1 pl)) (cadr (nth 1 pl)) dval)
t
)
)
(setq
i1 (inters (nth 0 pl)
(nth 2 pl)
(list (car (nth 0 pl)) (cadr (nth 0 pl)) dval)
(list (car (nth 2 pl)) (cadr (nth 2 pl)) dval)
t
)
)
(setq
i3 (inters (nth 1 pl)
(nth 2 pl)
(list (car (nth 1 pl)) (cadr (nth 1 pl)) dval)
(list (car (nth 2 pl)) (cadr (nth 2 pl)) dval)
t
)
)
(cond ((and i1 i2)
(if (and (not pi1) (not pi2))
;; no previous intersections on edges
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 (nth 0 pl))
(cons 11 i1)
(cons 12 i2)
(cons 13 i2)
)
)
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 i1)
(cons 12 pi2)
(cons 13 i2)
)
)
)
(setq pi1 i1
pi2 i2
)
)
((and i1 i3)
(if (and (not pi1) (not pi2))
;; no previous intersections on edges
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 (nth 0 pl))
(cons 11 i1)
(cons 12 (nth 1 pl))
(cons 13 i3)
)
)
(progn
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 i1)
(cons 12 pi2)
(cons 13 i3)
)
)
(if (< (caddr pi1) (caddr (nth 1 pl)))
(entmake (list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi2)
(cons 11 i3)
(cons 12 (nth 1 pl))
(cons 13 (nth 1 pl))
)
)
)
)
)
(setq pi1 i1
pi2 i3
)
)
)
(setq dval$ (strcat "SOLID_" (rtos dval 2 2)))
(setq dval (+ ival dval))
(setq
cl (rgbtotruecolor
(dos_hlstorgb
(+ col_Hb (fix (* (/ (- dval TinMinZ) ival) Hue_i)))
col_L
col_S
)
)
)
(if (>= dval maxz)
(progn
;; draw last level
(if i3
(entmake
(list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 pi2)
(cons 12 (nth 2 pl))
(cons 13 (nth 2 pl))
)
)
(entmake
(list (cons 0 "SOLID")
(cons 8 dval$)
(cons 420 cl)
(cons 10 pi1)
(cons 11 pi2)
(cons 12 (nth 2 pl))
(cons 13 (nth 1 pl))
)
)
)
)
)
)
)
)
)
(princ)
)
;; returns a integer for 420 dxf group code, input: rgb list
(defun RGBToTrueColor (rgb / tcol)
(setq r (lsh (car rgb) 16))
(setq g (lsh (cadr rgb) 8))
(setq b (caddr rgb))
(setq tcol (+ (+ r g) b))
)
(princ)
I tried with your triloc function. Is it correct that this keeps track of the previous found triangle ?
So assuming i go to the next point in the grid and when this is inside of the same triangle, this one is tested first ?
btw: does your edge solution work with ElpanovEvgenyi triangulation method
CDT ? what's that ?
(setq temp (vl-remove nil (mapcar '(lambda (x) (if (member 2 x) x)) tl)))
(foreach p temp
(setq l (cons (vl-position p tl) l))
)
((2 1 0) (3 1 2) (8 3 2) (8 2 0))
(21 8 1 0)
btw: is there a 'inters' function that works 2D only ?
thx,
btw: is there a 'inters' function that works 2D only ?
Quotebtw: is there a 'inters' function that works 2D only ?
No, but I believe if a single point is 2d, inters will give you 2d
ymg
Can you explain nl and el ?
(if (setq p (vl-position (reverse e) el))
(setq posl (cons (/ p 3) posl))
(setq posl (cons nil posl) bl (cons e bl))
)
(defun addedge
(a b / ls x lsa ip)
;; get all triangles from tl that have connection with point a of the edge
(setq ls (vl-remove-if-not
'vl-consp
(mapcar '(lambda (x)
(if (member a x)
x
)
)
tl
)
)
)
(print ls)
(setq cnt 0)
(foreach x (mapcar '(lambda (x) (vl-remove a x)) ls) ;; find the intersection of edge a-b
(if (setq ip (inters (list (car (nth a pl)) (cadr (nth a pl)))
(nth b pl)
(nth (car x) pl)
(nth (cadr x) pl)
t
)
)
(progn
(setq tra (nth cnt ls)) ;; triangle is the one that crosses adge a-b
(setq iea (list (car x) (cadr x))) ;; the intersecting edge
(print tra)
(print iea)
(command "point" ip) ;; just for display purpose
)
)
(setq cnt (+ cnt 1))
)
;; next thing to do: based on edge iea search the other triangles until point b is member of a triangle
;; update tl (remove tra) and el, nl...
;;...
)
(if (member '(nil nil) lst)
(progn
(msgbox "Triangulation"
64
(strcat "There Were At Least One Breakline Who"
"\nHad An Endpoint Not In The Point Set\n"
"\nProceeding With Triangulation"
"\nWithout Breaklines."
)
2
)
nil
)
)
nil should be '(nil nil)
Error: too few arguments
Precondition: a; b member of pl and edge ab not member of tl
((if (and (= govor "1")(not cdtl))
(progn
; Generates the Neighbour List ;
(setq tv (car (_vl-times)) ; Timer for Voronoi ;
nl (get_neighbour tl)
)
I think there is still a bug in the add edges function
(defun c:add_steiner (/ ss i e np newlist)
(setq ss
(ssget '((0 . "LINE"))
)
)
(if ss
(progn
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(gabriel e)
;;; (setq newlist (append (gabriel e) newlist))
;;; (setq newlist (cons (cdr (assoc 10 (entget e))) newlist))
;;; (setq newlist (cons (cdr (assoc 11 (entget e))) newlist))
)
)
)
;;; (foreach np newlist
;;; (entmake (list (cons 0 "POINT") (cons 10 np)))
;;; )
)
(defun gabriel (e / entl bp ep mp r elist edge found i ss)
(setq nplist nil)
(setq entl (entget e))
(setq bp (cdr (assoc 10 entl)))
(setq ep (cdr (assoc 11 entl)))
(setq mp (list (/ (+ (car bp) (car ep)) 2.0)
(/ (+ (cadr bp) (cadr ep)) 2.0)
(/ (+ (caddr bp) (caddr ep)) 2.0)
)
)
;; middle point
(setq r (/ (distance bp (list (car ep) (cadr ep))) 2.0))
;; 2D radius
(setq elist (list (list bp ep mp r)))
(setq ss
(ssget "_w"
(list (- (car mp) r) (- (cadr mp) r))
(list (+ (car mp) r) (+ (cadr mp) r))
'((0 . "POINT"))
)
)
;; selectionset of points around edge
(while elist
(setq edge (car elist))
(setq bp (car edge))
(setq ep (cadr edge))
(setq mp (caddr edge))
(setq r (cadddr edge))
;; (command "line" (list (- (car mp) r) (- (cadr mp) r)) (list (+ (car mp) r) (+ (cadr mp) r)) "")
(if ss
(progn
(setq found nil)
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq pt (cdr (assoc 10 (entget e))))
(if (and (not found)
(< (distance (list (car pt) (cadr pt)) mp) (- r 0.001)) ;;; 0.001 fuzz to avoid edge points bp ep
)
;; point in circle, we have to split segment
(progn
(setq newmp_bp (list (/ (+ (car bp)
(car mp)
)
2.0
)
(/ (+ (cadr bp)
(cadr mp)
)
2.0
)
(/ (+ (caddr bp)
(caddr mp)
)
2.0
)
)
)
(setq newmp_ep (list (/ (+ (car ep)
(car mp)
)
2.0
)
(/ (+ (cadr ep)
(cadr mp)
)
2.0
)
(/ (+ (caddr ep)
(caddr mp)
)
2.0
)
)
)
(setq elist (cdr elist));;; remove current edge and add 2 new edge segments
(setq elist (cons (list bp mp newmp_bp (/ r 2.0)) elist))
(setq elist (cons (list ep mp newmp_ep (/ r 2.0)) elist))
(entmake (list (cons 0 "POINT") (cons 10 mp)))
; (setq nplist (cons mp nplist))
(setq found t)
)
)
)
(if (not found)
(setq elist (cdr elist))
)
;;; points do not meet criteria, remove the edge
)
(progn
(setq elist (cdr elist))
;;; no points, remove the edge
)
)
)
; nplist
)
i did (using your dwg), see attachmentXXL, You were right. Retested and got the error as shown.
There Were At Least One Breakline Who Had An Endpoint Not In The Point Set Proceeding With Triangulation Without Breaklines.
Why this error comes ?
(defun c:test (/ s ei ent)
(setq pl nil)
(setq ss (ssget '((0 . "POINT,*LINE"))))
(setq ei 0)
;;edge index number
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(cond ((= (cdr (assoc 0 ent)) "POINT")
(setq
pl (cons (list (cdr (assoc 10 ent)) nil)
;;
pl
)
)
)
((= (cdr (assoc 0 ent)) "LINE")
(setq
pl (cons (list (cdr (assoc 10 ent)) ei)
pl
)
)
(setq
pl (cons (list (cdr (assoc 11 ent)) ei)
pl
)
)
(setq ei (1+ ei))
)
)
)
;; Sort pl on X and Y Coordinate then Remove duplicates ;
(setq
pl (vl-sort pl
(function (lambda (a b)
(or (< (car (car a)) (car (car b)))
(and (= (car (car a)) (car (car b)))
(< (cadr (car a)) (cadr (car b)))
)
)
)
)
)
)
(setq pl (remuppts2 pl 0.001))
(setq cnst nil
i 0
cdtl nil
npl nil
)
;; build constraints
(foreach p pl
(setq npl (cons (car p) npl))
(foreach y (cadr p)
(if (setq q (assoc y cnst))
(progn
(setq cdtl (cons (list (cdr q) i) cdtl))
)
(progn
(setq cnst (cons (cons y i) cnst))
)
)
)
(setq i (1+ i))
)
(setq pl (reverse npl))
)
;;****************************************************************************;
;; remduppts by Joe Burke ;
;; remove duplicate adjacent points from point list with fuzz factor ;
;; Modified by ymg to operate on 2d points ;
;; Modified by XXL for constraints points ;
;;****************************************************************************;
(defun remuppts2 (pl fuz / res p np edgel)
(setq edgel nil)
(repeat (1- (length pl))
(setq p (car pl))
(setq np (cadr pl))
(if (< (distance (list (car (car p)) (cadr (car p)))
(car (cadr pl))
)
fuz
)
;;; points are identical
(progn
(cond
((cdr p)
;; edge point, remove the duplicate point that is defined as solitary
(setq edgel (cons (cadr p) edgel))
)
((cdr np)
;; edge point, remove the duplicate point that is defined as solitary
(setq edgel (cons (cadr np) edgel))
)
((and (cdr p) (cdr np))
(setq edgel (cons (cadr p) edgel))
(setq edgel (cons (cadr np) edgel))
)
)
)
(progn
(setq res (cons (list (car p) edgel) res))
(setq edgel nil)
)
)
(setq pl (cdr pl))
)
(reverse (cons (car pl) res))
;; last one needs still some processing i think
)
(defun addedge_xxl
(a b / pnr tl_r pl_a tl_a el_a el_r ac bc ls v ip z cnt tr)
;;;last point position in pl
(setq pnr (- (length pl) 1)
;;;triangle list that will be removed
tl_r nil
;;;point list that will be added
pl_a nil
;;;triangle list that will be added
tl_a nil
;;;coordinates of point a, first point of constraint
ac (nth a pl)
;;;coordinates of point a, second point of constraint
bc (nth b pl)
)
;;; skip null length constraints both 2D and 3D
(if (> (distance ac bc) 0.001)
(progn
;;; reduce tl to ls that have connection with point a of the constraint
(setq ls (vl-remove-if-not
'vl-consp
(mapcar '(lambda (x)
(if (member a x)
x
)
)
tl
)
)
)
;;;counter for position in ls
(setq cnt 0)
;;;loop ls until intersection with opposed edge of point a is found
(while (not ip)
(setq trr (nth cnt ls))
;;;opposed edge to point a
(if (= (vl-position a trr) 1)
(setq v (reverse (vl-remove a trr)))
(setq v (vl-remove a trr))
)
;;;search for intersection of constraint a-b with the triangle edge opposed to point a
(if (setq ip (inters (list (car ac) (cadr ac))
bc
(nth (car v) pl)
(nth (cadr v) pl)
t
)
)
(progn
;;;add trr to remove list
(setq tl_r (cons trr tl_r))
;; startri by ymg ;
;; Given index a and b defining an edge ;
;; Will find the starting triangle with a as vertex ;
;; Based on orientation of ab ;
(defun startri (a b / an1 an2 ed found p ref tmp tr trl)
(setq trl (vl-remove-if-not '(lambda (x) (member a x)) tl))
(setq p (nth a pl)
ref (angle p (nth b pl))
found nil
)
(while (and trl (not found))
(setq tr (car trl)
trl (cdr trl)
ed (vl-remove a tr)
an1 (if (> (setq tmp (angle p (nth (car ed) pl))) pi) (- tmp (* 2 pi)) tmp)
an2 (if (> (setq tmp (angle p (nth (cadr ed) pl))) pi) (- tmp (* 2 pi)) tmp)
)
(if (< (min an1 an2) ref (max an1 an2))
(setq found t)
)
)
tr
)
;;****************************************************************************;
;; (topp tr v) by ymg ;
;; ;
;; Find Triangle Opposed to Vertex v. ;
;; ;
;; Input: tr Triangle as a list of 3 indices. ;
;; v Vertex number (Must be a member of triangle tr) ;
;; tl Triangle List (External Variable) ;
;; ;
;;****************************************************************************;
(defun topp (tr v / ed trl)
(setq ed (vl-remove v tr)
trl (vl-remove-if-not '(lambda (x) (and (member (car ed) x) (member (cadr ed) x))) tl)
)
(car (vl-remove tr trl))
)
;; startri by ymg ;
;; Given index a and b defining an edge ;
;; Will find the starting triangle with a as vertex ;
;; Based on orientation of ab ;
(defun startri (a b / an1 an2 ed found p ref tmp tr trl)
(setq trl (vl-remove-if-not '(lambda (x) (member a x)) tl))
(setq found nil)
(while (and trl (not found))
(setq tr (car trl)
trl (cdr trl)
)
(if (and (member a tr) (member b tr))
(setq found t) ; edge already exist
(progn
(setq ed (list (list (car tr) (cadr tr))
(list (cadr tr) (caddr tr))
(list (caddr tr) (car tr))
)
ed (vl-remove-if-not '(lambda (x) (member a x)) ed)
)
(if (and (onleft_p b (caar ed) (cadar ed))
(onleft_p b (caadr ed) (cadadr ed))
)
(setq found t)
)
)
)
)
tr
)
I believe that it is more powerfull if you consider 3d polyline with vertices and points
TIN - Elapsed time: 3.4470 secs, 3909 3DFACES
CDT V0.6.0 - Elapsed time: 11.7000 secs, 1941 Constraints
(defun LM:HSL->RGB ( h s l / u v )
(setq h (/ h 360.0)
s (/ s 100.0)
l (/ l 100.0)
)
(cond
( (zerop s)
(setq l (fix (+ 0.5 (* 255.0 l))))
(list l l l)
)
( (zerop l)
'(0 0 0)
)
( (if (< l 0.5)
(setq v (* l (1+ s)))
(setq v (- (+ l s) (* l s)))
)
(setq u (- (* 2.0 l) v))
(mapcar
(function
(lambda ( h )
(setq h (rem (1+ h) 1))
(cond
( (< (* 6.0 h) 1.0)
(fix (+ 0.5 (* 255.0 (+ u (* 6.0 h (- v u))))))
)
( (< (* 2.0 h) 1.0)
(fix (+ 0.5 (* 255.0 v)))
)
( (< (* 3.0 h) 2.0)
(fix (+ 0.5 (* 255.0 (+ u (* 6.0 (- (/ 2.0 3.0) h) (- v u))))))
)
( (fix (+ 0.5 (* 255.0 u))))
)
)
)
(list (+ h (/ 1.0 3.0)) h (- h (/ 1.0 3.0)))
)
)
)
)
(setq pl (vl-sort pl
'(lambda (x y)
(cond
((equal (car (car x)) (car (car y)) 0.001)
(< (cadr (car x)) (cadr (car y)))
)
((< (car (car x)) (car (car y))))
)
)
)
)
(entmod (subst (cons 8 ptlay) (assoc 8 ent) ent))
Didge;You can transform C++ script, or C C++ algorithms ,into autolisp-source-automatically.
I have used this library:
http://www.cs.cmu.edu/~quake/triangle.html
But it is to be use with your C++ solutions. :-(
Long time not hear from ymg about developing triangulation
Enjoy your time off.
;******************************************************************;
; TRIANGULATE - Lisp command to create a TIN from 3D points. ;
; =========== ;
; ;
; Written by Daniele Piazza, ADN member Mechanical Solution s.r.l. ;
; http://pdcode.com/code.htm ;
; ;
; Original C coding "Triangulate" written by PAUL BOURKE ;
; http://astronomy.swin.edu.au/~pbourke/modelling/triangulate/ ;
; ;
; This program triangulates an irregular set of points. ;
; 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 ;
;*******************************************************************
;
;;
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;
(defun C:TRIANGULATE (/ fuzzy nulllist ss1 ptlst nv supertriangle trianglelst i j k edgelst
circle pt flag perc)
(setq OLDCMD (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command ".UNDO" "GROUP")
(setq OLDSNAP (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq fuzzy 1e-8) ; tolerance in equality test
(setq nulllist nil)
(princ "\nSelect points...")
(setq ss1 (ssget '((0 . "POINT"))))
(setq start (getvar "date") THINK-CNT 0) ; initiate timer & Progress Spinner Counter
(setq ptlst (getptlist ss1)) ; convert selection set to point list
(setq ptlst (xsort ptlst)) ; sort point list by X co-ordinate
(setq nv (length ptlst)) ; number of points
(setq supertriangle (findsupertriangle ptlst)) ; find super triangle
(setq ptlst (append ptlst supertriangle)) ; append coordinates to the end of vertex list
(setq trianglelst (list (list supertriangle nil))) ; add supertriangle to the triangle list
(setq i 0)
(setq cab 0) ; CAB debug
(while (< i nv)
(THINKING (strcat "Processing TIN - " (itoa (/ (* i 100) nv)) "% ")) ; update progress spinner
(setq pt (nth i ptlst))
(setq edgelst nil) ; initialize edge buffer
(setq j 0)
(while (and trianglelst (setq triangle (car (nth j trianglelst))))
(setq flag T)
(if (not (cadr (nth j trianglelst)))
(progn
(setq circle (getcircircumcircle triangle)) ; calculate circumcircle
(if (< (+ (caar circle) (cadr circle)) (car pt)) ; test point x and (pt) location
(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
)
)
) ; end progn
) ; end if
(if flag (setq j (1+ j)) )
) ; end while loop
(setq edgelst (removedoublyedges edgelst fuzzy nulllist)) ; remove all doubly specified edges
(setq trianglelst (addnewtriangles pt edgelst trianglelst)) ; form new triangles for current point
(setq i (1+ i)) ; get next vertex
) ; end while loop
(setq trianglelst (purgetrianglelst trianglelst supertriangle fuzzy)) ; remove triangles with supertriangles edges
(foreach triangle (mapcar 'car trianglelst) ; draw triangles
(drawtriangle triangle)
)
(setvar "OSMODE" OLDSNAP)
(setq OLDSNAP nil)
(command ".UNDO" "END")
(setq stop (getvar "date"))
(princ (strcat "\r TIN Complete - Elapsed time: " (rtos (* 86400.0 (- stop start)) 2 2) " secs."))
(setvar "CMDECHO" OLDCMD)
(princ)
)
; XSORT - Original Shell Sort function replaced with VLISP sort (much quicker :-) ;
; ;
(defun XSORT ( PTLST /)
(vl-sort PTLST (function (lambda (e1 e2) (< (car e1) (car e2)) ) ) )
)
; 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 velocità, può 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))))
)
)
; GETPTLIST ;
; ;
; sset -> list (p1 p2 p3 ... pn) ;
; ;
(defun GETPTLIST (ss1 / i pt ptlst)
(if (not (zerop (sslength ss1)))
(progn
(setq i 0)
(while
(setq pt (ssname ss1 i))
(setq ptlst (cons (cdr (assoc 10 (entget pt))) ptlst))
(setq i (1+ i))
)
)
)
ptlst
)
; FINDSUPERTRIANGLE ;
; ;
; Search the supertriangle that contain all points in the data set ;
; ;
(defun FINDSUPERTRIANGLE (ptlst / xmax xmin ymax ymin 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))
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)
)
)
;;=============================================================
;; Changes by CAB 03/13/06
;; replaced the GETCIRCIRCUMCIRCLE routine
;;=============================================================
(defun getcircircumcircle (triangle / p1 p2 p3 pr1 pr2 cen rad bisector)
;; return a pt list for a perpendicular bisector 20 units long
(defun bisector (p1 p2 / perp_ang midpt)
(setq p1 (list (car p1) (cadr p1)) ; make sure 2d point
perp_ang (+ (angle p1 p2) (/ pi 2.0))) ; perpendicular angle
(setq midpt (mapcar '(lambda (pa pb) (+ (/ (- pb pa) 2.0) pa)) p1 p2))
(list (polar midpt perp_ang 10) (polar midpt (+ pi perp_ang) 10))
)
(setq p1 (car triangle)
p2 (cadr triangle)
p3 (caddr triangle)
pr1 (bisector p1 p2)
pr2 (bisector p1 p3)
cen (inters (car pr1) (cadr pr1) (car pr2) (cadr pr2) nil)
rad (distance cen p1)
)
(list cen 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 of the algorithm. Draw triangulation. ;
; ;
(defun DRAWTRIANGLE (triangle)
(entmake (list (cons 0 "3DFACE") (cons 10 (car triangle)) (cons 11 (caddr triangle))
(cons 12 (cadr triangle)) (cons 13 (cadr triangle))))
)
; 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 /)
(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 /)
(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))
)
)
)
; ;
; THINKING - STANDARD PROGRESS SPINNER ;
; ;
(defun THINKING (prmpt)
(setq THINK-CNT (1+ THINK-CNT))
(princ (strcat "\r" (nth (rem THINK-CNT 4) '("\|" "\/" "\-" "\\")) prmpt))
)
; ********************************* END OF CODING *******************************************
(princ "\n'TRIANGULATE' Loaded \n")
(princ)
Error: no function definition: GET_NEIGHBOUR
Missing function?
hi, You can plot the surface of the 3d elevation grid using lisp.
(setq prof (cons (list (vlax-curve-getDistAtPoint en p) (caddr (getz p t1 t2 t3))) prof))
(if (vlax-curve-getDistAtPoint en p)
(setq prof (cons (list (vlax-curve-getDistAtPoint en p)
(caddr (getz p t1 t2 t3))
)
prof)
)
);end if
RAYAKMAL sir,
Please attach lisp TriangV0.5.9A.LSP If you made changes
al (list (list xmax cp r sl))
;Initialize the Active Triangle list ;
; al, List contains active triangles defined by 4 items: ;
; item 0: Xmax of points in triangle. ;
; item 1: Center of circle circumscribing triangle. ;
; item 2: Radius of above circle. ;
; item 3: List of 3 vertices defining the triangle. ;
Marko,
Not sure, but the active triangle list al
should be modified to contain ymax of
each triangle.Code: [Select]al (list (list xmax cp r sl))
;Initialize the Active Triangle list ;
; al, List contains active triangles defined by 4 items: ;
; item 0: Xmax of points in triangle. ;
; item 1: Center of circle circumscribing triangle. ;
; item 2: Radius of above circle. ;
; item 3: List of 3 vertices defining the triangle. ;
ymg
(list (mapcar '+ cp (list 0.0 rr)) cp rr (list p (car el) (cadr el))) ;;; Added Y apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
(cond
( (< (caadr tr) (cadr p)) ;;; Comparison of Y values ;;;
(setq tl (cons (cadddr tr) tl))
)
...
(cond
( (< (cadar tr) (cadr p)) ;;; Comparison of Y values ;;;
(setq tl (cons (cadddr tr) tl))
)
...
(defun c:triangulate-MR-EE ( / unique _vl-remove circumcircle getcircumcircle-Xsortmax triangulate-Xsortmax getcircumcircle-Xsortmin triangulate-Xsortmin getcircumcircle-Ysortmax triangulate-Ysortmax getcircumcircle-Ysortmin triangulate-Ysortmin ss i p pl pl1 pl2 pl3 pl4 pl5 xmin xmax ymin ymax cs pmin pmax tl0 tl1 tl2 tl3 tl4 tl5 tl )
(defun unique ( lst )
(if lst (cons (car lst) (unique (_vl-remove (car lst) (_vl-remove (list (caar lst) (caddar lst) (cadar lst)) (_vl-remove (list (cadar lst) (caar lst) (caddar lst)) (_vl-remove (list (cadar lst) (caddar lst) (caar lst)) (_vl-remove (list (caddar lst) (caar lst) (cadar lst)) (_vl-remove (list (caddar lst) (cadar lst) (caar lst)) (cdr lst) 1e-6) 1e-6) 1e-6) 1e-6) 1e-6) 1e-6))))
)
(defun _vl-remove ( el lst fuzz )
(vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz) (equal (caddr x) (caddr el) fuzz))) lst)
)
(defun circumcircle ( p1 p2 p3 / ang c r )
(if
(not
(zerop
(setq ang (- (angle p2 p3) (angle p2 p1)))
)
)
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance p1 p3) (sin ang) 2.0)))
r (abs r)
)
)
(list c r)
)
(defun getcircumcircle-Xsortmax ( p el / cp cr rr )
(setq cp (car (setq cr (circumcircle (list (car p) (cadr p)) (list (caar el) (cadar el)) (list (caadr el) (cadadr el))))) rr (cadr cr))
(list (mapcar '+ cp (list rr 0.0)) cp rr (list p (car el) (cadr el))) ;;; Added X apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
)
(defun triangulate-Xsortmax ( pl / t1 t2 t3 al p el tr l n str )
(setq pl (vl-sort pl '(lambda ( a b ) (< (car a) (car b)))))
(setq t1 (polar cs 0.0 (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 10.0 (+ n 2)))))) ;;; Added 0.0 in polar for rotating supertriangle t1 is max X apex ;;;
(setq t2 (polar cs (+ 0.0 (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ 0.0 (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list t1 cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (caar tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle-Xsortmax p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
) ;;; end of triangulate X-sort max
(defun getcircumcircle-Xsortmin ( p el / cp cr rr )
(setq cp (car (setq cr (circumcircle (list (car p) (cadr p)) (list (caar el) (cadar el)) (list (caadr el) (cadadr el))))) rr (cadr cr))
(list (mapcar '+ cp (list rr 0.0)) cp rr (list p (car el) (cadr el))) ;;; Added X apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
)
(defun triangulate-Xsortmin ( pl / t1 t2 t3 al p el tr l n str )
(setq pl (vl-sort pl '(lambda ( a b ) (> (car a) (car b)))))
(setq t1 (polar cs pi (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 10.0 (+ n 2)))))) ;;; Added pi in polar for rotating supertriangle t1 is min X apex ;;;
(setq t2 (polar cs (+ pi (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ pi (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list t1 cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (> (caar tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle-Xsortmin p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
) ;;; end of triangulate X-sort min
(defun getcircumcircle-Ysortmax ( p el / cp cr rr )
(setq cp (car (setq cr (circumcircle (list (car p) (cadr p)) (list (caar el) (cadar el)) (list (caadr el) (cadadr el))))) rr (cadr cr))
(list (mapcar '+ cp (list 0.0 rr)) cp rr (list p (car el) (cadr el))) ;;; Added Y apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
)
(defun triangulate-Ysortmax ( pl / t1 t2 t3 al p el tr l n str )
(setq pl (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b)))))
(setq t1 (polar cs (/ pi 2.0) (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 10.0 (+ n 2)))))) ;;; Added (/ pi 2.0) in polar for rotating supertriangle t1 is max Y apex ;;;
(setq t2 (polar cs (+ (/ pi 2.0) (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ (/ pi 2.0) (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list t1 cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (cadar tr) (cadr p)) ;;; Comparison of Y values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle-Ysortmax p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
) ;;; end of triangulate Y-sort max
(defun getcircumcircle-Ysortmin ( p el / cp cr rr )
(setq cp (car (setq cr (circumcircle (list (car p) (cadr p)) (list (caar el) (cadar el)) (list (caadr el) (cadadr el))))) rr (cadr cr))
(list (mapcar '+ cp (list 0.0 rr)) cp rr (list p (car el) (cadr el))) ;;; Added Y apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
)
(defun triangulate-Ysortmin ( pl / t1 t2 t3 al p el tr l n str )
(setq pl (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b)))))
(setq t1 (polar cs (* 3.0 (/ pi 2.0)) (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 10.0 (+ n 2)))))) ;;; Added (* 3.0 (/ pi 2.0)) in polar for rotating supertriangle t1 is min Y apex ;;;
(setq t2 (polar cs (+ (* 3.0 (/ pi 2.0)) (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ (* 3.0 (/ pi 2.0)) (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list t1 cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (> (cadar tr) (cadr p)) ;;; Comparison of Y values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle-Ysortmin p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
) ;;; end of triangulate Y-sort min
(vl-load-com)
(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
(command "_.UCS" "_W")
(setq ss (ssget '((0 . "POINT"))))
(repeat (setq i (sslength ss))
(setq p (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))))
(setq pl (cons p pl))
)
(setq xmin (caar (vl-sort pl '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl)
(triangulate-Xsortmin pl)
(triangulate-Ysortmax pl)
(triangulate-Ysortmin pl)
(setq tl0 tl tl nil)
(command "_.UCS" "_Z" 15)
(setq pl1 (mapcar '(lambda ( p ) (trans p 0 1)) pl))
(setq xmin (caar (vl-sort pl1 '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl1 '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl1 '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl1 '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl1)
(triangulate-Xsortmin pl1)
(triangulate-Ysortmax pl1)
(triangulate-Ysortmin pl1)
(setq tl1 tl tl nil)
(setq tl1 (mapcar '(lambda ( tr ) (list (trans (car tr) 1 0) (trans (cadr tr) 1 0) (trans (caddr tr) 1 0))) tl1))
(command "_.UCS" "_Z" 15)
(setq pl2 (mapcar '(lambda ( p ) (trans p 0 1)) pl))
(setq xmin (caar (vl-sort pl2 '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl2 '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl2 '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl2 '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl2)
(triangulate-Xsortmin pl2)
(triangulate-Ysortmax pl2)
(triangulate-Ysortmin pl2)
(setq tl2 tl tl nil)
(setq tl2 (mapcar '(lambda ( tr ) (list (trans (car tr) 1 0) (trans (cadr tr) 1 0) (trans (caddr tr) 1 0))) tl2))
(command "_.UCS" "_Z" 15)
(setq pl3 (mapcar '(lambda ( p ) (trans p 0 1)) pl))
(setq xmin (caar (vl-sort pl3 '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl3 '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl3 '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl3 '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl3)
(triangulate-Xsortmin pl3)
(triangulate-Ysortmax pl3)
(triangulate-Ysortmin pl3)
(setq tl3 tl tl nil)
(setq tl3 (mapcar '(lambda ( tr ) (list (trans (car tr) 1 0) (trans (cadr tr) 1 0) (trans (caddr tr) 1 0))) tl3))
(command "_.UCS" "_Z" 15)
(setq pl4 (mapcar '(lambda ( p ) (trans p 0 1)) pl))
(setq xmin (caar (vl-sort pl4 '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl4 '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl4 '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl4 '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl4)
(triangulate-Xsortmin pl4)
(triangulate-Ysortmax pl4)
(triangulate-Ysortmin pl4)
(setq tl4 tl tl nil)
(setq tl4 (mapcar '(lambda ( tr ) (list (trans (car tr) 1 0) (trans (cadr tr) 1 0) (trans (caddr tr) 1 0))) tl4))
(command "_.UCS" "_Z" 15)
(setq pl5 (mapcar '(lambda ( p ) (trans p 0 1)) pl))
(setq xmin (caar (vl-sort pl5 '(lambda ( a b ) (< (car a) (car b))))))
(setq xmax (caar (vl-sort pl5 '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl5 '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl5 '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (/ (+ xmax xmin) 2.0) (/ (+ ymax ymin) 2.0)))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(triangulate-Xsortmax pl5)
(triangulate-Xsortmin pl5)
(triangulate-Ysortmax pl5)
(triangulate-Ysortmin pl5)
(setq tl5 tl tl nil)
(setq tl5 (mapcar '(lambda ( tr ) (list (trans (car tr) 1 0) (trans (cadr tr) 1 0) (trans (caddr tr) 1 0))) tl5))
(setq tl (append tl0 tl1 tl2 tl3 tl4 tl5))
(foreach tr (unique tl)
(entmake
(list (cons 0 "3DFACE")
(cons 10 (car tr))
(cons 11 (car tr))
(cons 12 (cadr tr))
(cons 13 (caddr tr))
)
)
)
(command "_.UCS" "_P")
(command "_.UCS" "_P")
(command "_.UCS" "_P")
(command "_.UCS" "_P")
(command "_.UCS" "_P")
(command "_.UCS" "_P")
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(princ)
)
(defun circumcircle3d ( p1 p2 p3 / v^v circumcircleucs zucs p1ucs p2ucs p3ucs cr )
(defun v^v ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(+ (- (* (car u) (caddr v))) (* (car v) (caddr u)))
(- (* (car u) (cadr v)) (* (car v) (cadr u)))
)
)
(defun circumcircleucs ( p1 p2 p3 / D Dcx Dcy c r )
(setq D (* 4.0 (- (* (- (car p1) (car p2)) (- (cadr p1) (cadr p3))) (* (- (car p1) (car p3)) (- (cadr p1) (cadr p2))))))
(setq Dcx (* 2.0 (-
(* (- (cadr p1) (cadr p3)) (+ (expt (car p1) 2) (expt (cadr p1) 2) (- (expt (car p2) 2)) (- (expt (cadr p2) 2))))
(* (- (cadr p1) (cadr p2)) (+ (expt (car p1) 2) (expt (cadr p1) 2) (- (expt (car p3) 2)) (- (expt (cadr p3) 2))))
)
)
)
(setq Dcy (* 2.0 (-
(* (- (car p1) (car p2)) (+ (expt (car p1) 2) (expt (cadr p1) 2) (- (expt (car p3) 2)) (- (expt (cadr p3) 2))))
(* (- (car p1) (car p3)) (+ (expt (car p1) 2) (expt (cadr p1) 2) (- (expt (car p2) 2)) (- (expt (cadr p2) 2))))
)
)
)
(setq c (list (/ Dcx D) (/ Dcy D)))
(setq r (distance c p1))
(list c r)
)
(setq zucs (v^v (mapcar '- p2 p1) (mapcar '- p3 p1)))
(setq p1ucs (trans p1 0 zucs) p2ucs (trans p2 0 zucs) p3ucs (trans p3 0 zucs))
(setq cr (circumcircleucs p1ucs p2ucs p3ucs))
(list (trans (list (caar cr) (cadar cr) (caddr p1ucs)) zucs 0) (cadr cr))
)
; Purge triangle list of any triangle that has a common vertex ;
; with supertriangle. ;
(setq tl (vl-remove-if-not
(function
(lambda (a) (and (< (car a) np)(< (cadr a) np)(< (caddr a) np)))
)
tl
)
)
Marko,
Once you've removed the triangle containing a vertex
of the supertriangle, you are 100% guaranteed to have
a convex hull.
After that any triangle edge which does not have
its reversed in the edge list is on the convex hull.
However a Graham Scan is faster than searching
for reversed edges, if all you want is a convex hull.
ymg
(defun c:triangulate-MR-EE-LM ( / mid LM:Clockwise-p LM:ConvexHull triangulate ss i p pl tl )
(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< c d)
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
(setq ch (cons pt (cddr ch)))
)
)
ch
)
)
)
(defun triangulate ( pl / pll getcircumcircle xmin xmax ymin ymax cs pmin pmax t1 t2 t3 al p el tr l n str och ich )
(defun getcircumcircle ( p el / circumcircle cp cr rr )
(defun circumcircle ( p1 p2 p3 / ang c r )
(if
(not
(zerop
(setq ang (- (angle p2 p3) (angle p2 p1)))
)
)
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance p1 p3) (sin ang) 2.0)))
r (abs r)
)
)
(list c r)
)
(setq cp (car (setq cr (circumcircle (list (car p) (cadr p)) (list (caar el) (cadar el)) (list (caadr el) (cadadr el))))) rr (cadr cr))
(list (mapcar '+ cp (list rr 0.0)) cp rr (list p (car el) (cadr el))) ;;; Added X apex of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
)
(setq pll pl)
(setq xmin (caar (setq pl (vl-sort pl '(lambda ( a b ) (< (car a) (car b))))))) ;;; Sorted pl by X ;;;
(setq xmax (caar (vl-sort pl '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(setq t1 (polar cs 0.0 (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt 10.0 (+ n 2)))))) ;;; Added 0.0 in polar for rotating supertriangle t1 is max X apex ;;;
(setq t2 (polar cs (+ 0.0 (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ 0.0 (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list t1 cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (caar tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq al nil)
(setq el (mapcar '(lambda ( a b ) (list a b)) (setq och (LM:ConvexHull pll)) (cdr (reverse (cons (car och) (reverse och))))))
(mapcar '(lambda ( x ) (setq pll (vl-remove x pll))) och)
(setq ich (LM:ConvexHull pll))
(foreach e el
(if (not (vl-some '(lambda ( x ) (and (member (car e) x) (member (cadr e) x))) tl))
(setq al (cons (getcircumcircle (car (vl-sort ich '(lambda ( a b ) (< (distance a (mid (list (caar e) (cadar e)) (list (caadr e) (cadadr e)))) (distance b (mid (list (caar e) (cadar e)) (list (caadr e) (cadadr e)))))))) e) al))
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
) ;;; end of triangulate
(setq ss (ssget '((0 . "POINT"))))
(repeat (setq i (sslength ss))
(setq p (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))))
(setq pl (cons p pl))
)
(triangulate pl)
(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)
)
...
However as stated before, you do not really need it,
just remove triangles with a vertex on the supertriangles.
ymg
Command: (LOAD "C:/Users/RIBAR/Downloads/TriangV0.6.2.9.LSP")
Triangulation V0.6.2.9 loaded...!
Command: TIN
Select objects: Specify opposite corner: 814 found
Select objects:
TIN - Elapsed time: 1.8870 secs, 5131 3DFACES
CDT V0.6.2.9 - Elapsed time: 14.9610 secs, 2082 Constraints
Command: (entget (car (entsel)))
Select object: ((-1 . <Entity name: 7ffff61ccf0>) (0 . "3DFACE") (330 . <Entity
name: 7ffff6059f0>) (5 . "1C7") (100 . "AcDbEntity") (67 . 0) (410 . "Model")
(8 . "TIN Natural Ground") (100 . "AcDbFace") (10 18.4842 6.96325 1097.52) (11
18.4842 6.96325 1097.52) (12 15.9999 14.4341 1097.52) (13 13.6163 8.10007
1097.55) (70 . 0))
Command: Specify opposite corner or [Fence/WPolygon/CPolygon]:
Command: (entget (car (entsel)))
Select object: ((-1 . <Entity name: 7ffff61cd80>) (0 . "3DFACE") (330 . <Entity
name: 7ffff6059f0>) (5 . "218") (100 . "AcDbEntity") (67 . 0) (410 . "Model")
(8 . "0") (100 . "AcDbFace") (10 21.4421 6.98593 1097.55) (11 26.31 5.84911
1097.55) (12 23.8257 13.32 1097.55) (13 21.4421 6.98593 1097.55) (70 . 0))
to err is human.to forgive, divine.
to forgive, divine.
- Alexander Pope
(if (= opt 1)
(progn
(setq disl (mapcar '(lambda (a) (vlax-curve-getDistAtPoint en a)) pol))
...
I've replaced with : (if (= opt 1)
(progn
(setq disl (mapcar '(lambda (a) (vlax-curve-getDistAtPoint en (vlax-curve-getClosestPointTo en a))) pol))
...
and it worked - command PROFILE didn't fail... (defun xshape (ratio / a b bl ch e kl lg ne ps tn tr v)
(setq kl nil)
(setq ch (get_extcont) ;el (get_edges tl)
bl (mapcar '(lambda (a b) (list a b)) ch (cdr ch))
lg (* (apply 'max (mapcar '(lambda (a) (distance (nth (car a) pl) (nth (cadr a) pl))) bl)) ratio)
)
(while bl
(setq e (car bl)
bl (cdr bl)
tn (/ (vl-position e el) 3)
tr (nth tn tl)
)
...
(defun xshape (ratio / a b bl ch e kl lg ne ps tn tr v)
(setq kl nil)
(setq ch (get_extcont) ;el (get_edges tl)
bl (mapcar '(lambda (a b) (list a b)) ch (cdr ch))
lg (* (apply 'max (mapcar '(lambda (a) (distance (nth (car a) pl) (nth (cadr a) pl))) bl)) ratio)
)
(while bl
(setq e (car bl)
bl (cdr bl)
tn (if (vl-position e el) (/ (vl-position e el) 3) nil)
tr (if tn (nth tn tl) nil)
)
...
'ymg' you are a genius.
I am using your program right now to generate pipeline profiles on the 'wheatsone lng plant' project in West Australia.
In the past I would be using 12D. This program does the job. The client supplied a triangulation of the site, your program does the rest.
Again, great work.
Command: appload
TriangV0.6.5.1.LSP successfully loaded.
Command:
Triangulation V0.6.5.1 loaded...!
Command:
Command: tin
Select objects: all
5150 found
Select objects:
Error: no function definition: ACET-UI-PROGRESS
Error: bad argument type: 2D/3D point: nil
(if (or (equal p1 p2 0.0001) (equal p2 p3 0.0001))
()
(setq n_tl (cons temp n_tl)))
see entity (handent "733b")
(setq n_tl nil)
(foreach temp tl
(setq p1 (list (car (nth 0 temp)) (cadr (nth 0 temp)))
p2 (list (car (nth 1 temp)) (cadr (nth 1 temp)))
p3 (list (car (nth 2 temp)) (cadr (nth 2 temp))))
(if (or (equal p1 p2 0.0001) (equal p2 p3 0.0001))
()
(setq n_tl (cons temp n_tl))))
(setq tl n_tl)
how many people know that the lines are not done well? for example, a client sent me the file so that you do the corners, had thousands of lines, the routine did not work, I had to start investigating where the error occurred, what I say is: is there any way that the user know that that line break this bad?
;; begin patch
(defun c:bnd (/ tmp grdmod grdval plst get_bnd) ;; was c:bound
(if (not csurf) (setq csurf "Natural Ground"))
(if (/= "" (setq tmp (getstring (strcat "\nCreate a Boundary for TIN <" csurf ">: "))))
(setq csurf tmp)
)
(mk_layer (list "Boundary" 2))
(setq grdval (getvar "elevation")) ; save preset elevation (normally 0.0)
(setq grdmod (getvar "OSNAPZ")) ; save elevation snap-mode
(setvar "OSNAPZ" 0) ; set snap to object-grade
(defun get_bnd (/ lst pt OK)
(if (car (setq lst (list (getpoint "\nFirst clockwise Boundary point: ")))) ;; if test
(progn
(while (setq pt
(if (> (length lst) 1)
(progn
(initget "Undo")
(getpoint (car lst) "\nNext clockwise Boundary point [Undo]: ")
) ;; end if=yes
(getpoint (car lst) "\nNext clockwise Boundary point: ")
) ;; end if length
) ;; end while test
(redraw)
(mapcar '(lambda (a b) (grdraw a b 1 1)) (setq lst (if (eq pt "Undo") (cdr lst) (cons pt lst))) (cdr lst))
) ;; end while
(cond ((> (length lst) 1) lst)) ;; post list
) ;; end progn if=yes
) ; end if
) ;; end _getpoints
(if (and (setq plst (get_bnd))
(if (> (length plst) 2)
(setq OK 1) ;; valid list
(alert "Boundary must exceed 2 points")
)
) ;; end test
(progn (if (equal (car plst) (last plst) 0.001)
(setq OK 1) ;; valid loop
(setq plst (append plst (list (car plst)))) ;; close loop
)
(mk_3dp plst)
(setq *bounden* (entlast))
(redraw)
) ;; end progn
) ;; end if
(setvar "OSNAPZ" grdmod) ; restore elevation snap-mode
(setvar "elevation" grdval) ; restore preset-elevation (normally 0.0)
;;(*error* nil) ;; no error catch implemented (I don't know what parameters should be used)
(princ)
) ;; end BND
;; end *upgrade patch*
autocad 2007/2015 x86 win7 ultimate
Error: bad argument type: 2D/3D point: nil
;;funcion lisp
(defun ratiopoint (a b r) (polar a (angle a b) (* (distance a b) r)))
---> error ( b ) = nil
argument a = (5148.52 2400.0)
argument b = nil
argument r = 0.5
(t (setq cn1 (list (/ (+ (car p1) (car p2) (car p3)) 3) (/ (+ (cadr p1) (cadr p2) (cadr p3)) 3))
cn2 (list (/ (+ (car p1) (car p3) (car p4)) 3) (/ (+ (cadr p1) (cadr p3) (cadr p4)) 3))
a1 (cond
((inters cn1 p1 v1 v2))
((inters cn1 p3 v1 v2))
)
a3 (cond
((inters cn2 p1 v2 v3))
((inters cn2 p3 v2 v3))
)
)
;;;;;modification
(if (and a1 a3)
(progn
(setq b1 (ratiopoint a1 v2 hfac)
b2 (ratiopoint v2 a3 hfac)
c1 (midpoint b1 b2)
ps (list (list a1 b1 c1) (list c1 b2 a3)))
)
)
If you use qselect and select according to linetype, you can
isolate the depression contour.
Removing PRAGMA allowed it to load. Then I tried to build a TIN. It reported... Error: no function definition: ACET-UI-PROGRESS.
Maybe Briscad is more rigid when parsing dcl than autocadFWIW: BricsCAD only accepts values in lower case here. In general DCL is case-sensitive.
FWIW: BricsCAD only accepts values in lower case here. In general DCL is case-sensitive.
(write-line " alignment = Left; "f)
(write-line " alignment = left; "f)
Code: [Select](write-line " alignment = Left; "f)
should be changed to:Code: [Select](write-line " alignment = left; "f)
; New Section to Handle Depression Contour June 2015 ;
(if (= godep "1")
(progn
(setq ti (time))
(or
(tblsearch "ltype" "Depression")
(mk_linetype
"Depression"
"____|____|____|____|____|____|__"
"A,.5,-.005,[\"|\",STANDARD,S=.06,R=0.0,X=-0.01125,Y=-.0725],-.005"
)
)
(setq lt (cons 6 "Depression")
sc (cons 48 1.0)
majdepcol (cons 62 majdepcolor)
mindepcol (cons 62 mindepcolor)
lgclosed (length ccont)
)
)
)
;; the above replaces the below...
;; New Section to Handle Depression Contour June 2015 ;
;;(setq ti (time))
;;(or (tblsearch "ltype" "Depression")
;; (mk_linetype "Depression" "____|____|____|____|____|____|__"
;; "A,.5,-.005,[\"|\",STANDARD,S=.06,R=0.0,X=-0.01125,Y=-.0725],-.005"
;; )
;;)
Command: NETLOAD
Cannot load assembly. Error details: System.IO.FileLoadException: Could not
load file or assembly 'file:///C:\Users\ymg\Downloads\CDT2015.dll' or one of
its dependencies. Operation is not supported. (Exception from HRESULT:
0x80131515)
File name: 'file:///C:\Users\ymg\Downloads\CDT2015.dll' --->
System.NotSupportedException: An attempt was made to load an assembly from a
network location which would have caused the assembly to be sandboxed in
previous versions of the .NET Framework. This release of the .NET Framework
does not enable CAS policy by default, so this load may be dangerous. If this
load is not intended to sandbox the assembly, please enable the
loadFromRemoteSources switch. See http://go.microsoft.com/fwlink/?LinkId=155569
for more information.
at System.Reflection.RuntimeAssembly._nLoad(AssemblyName fileName, String
codeBase, Evidence assemblySecurity, RuntimeAssembly locationHint,
StackCrawlMark& stackMark, IntPtr pPrivHostBinder, Boolean throwOnFileNotFound,
Boolean forIntrospection, Boolean suppressSecurityChecks)
at System.Reflection.RuntimeAssembly.InternalLoadAssemblyName(AssemblyName
assemblyRef, Evidence assemblySecurity, RuntimeAssembly reqAssembly,
StackCrawlMark& stackMark, IntPtr pPrivHostBinder, Boolean throwOnFileNotFound,
Boolean forIntrospection, Boolean suppressSecurityChecks)
at System.Reflection.RuntimeAssembly.InternalLoadAssemblyName(AssemblyName
assemblyRef, Evidence assemblySecurity, RuntimeAssembly reqAssembly,
StackCrawlMark& stackMark, Boolean throwOnFileNotFound, Boolean
forIntrospection, Boolean suppressSecurityChecks)
at System.Reflection.RuntimeAssembly.InternalLoadFrom(String assemblyFile,
Evidence securityEvidence, Byte[] hashValue, AssemblyHashAlgorithm
hashAlgorithm, Boolean forIntrospection, Boolean suppressSecurityChecks,
StackCrawlMark& stackMark)
at System.Reflection.Assembly.LoadFrom(String assemblyFile)
at Autodesk.AutoCAD.Runtime.ExtensionLoader.Load(String fileName)
at loadmgd()
(benchmark '((get_extcont) (get_extcont1)))
Benchmarking .............Elapsed milliseconds / relative speed for 1024 iteration(s):
(GET_EXTCONT)......1934 / 1.69 <fastest>
(GET_EXTCONT1).....3260 / 1.00 <slowest>
(benchmark '((get_extcont) (get_extcont1)))
Benchmarking .........Elapsed milliseconds / relative speed for 64 iteration(s):
(GET_EXTCONT)......1185 / 1.36 <fastest>
(GET_EXTCONT1).....1607 / 1.00 <slowest>
d.valkanov,Have a look at this code:
I will write this one in Lisp
(setq temp (list (list (car disl) (caar entl))))
(setq entl (mapcar '(lambda (a)
(setq i -1)
(while (< (caddr (nth (setq i (1+ i)) entl)) a))
(list a (car (nth (1- i) entl)))
)
(cdr disl)
)
)
(setq entl (append temp entl)) ;;;; temp -was- tmp ... tmp is a typo
;; Var prof now contains the list of the profile sorted. ;
(setq chal (mapcar '(lambda (a) (rtosta (+ chbeg (car a)) 1 prec)) prof) ;; 1 prec -was- 2 prec
(defun c:prof (/ *acdoc* *acspc* *hinc* *en* *entl* pstart pclose
cntz ofsy ydatum x1 x2 y1 y2 z1 z2 g1 g2)
;;>>>>>> begin patch by RLW
(setq *en* en
*entl* (getproftin en)
entl (getproftin en)
prof (distinctfuzz
;;>>>>>> end patch by RLW
(if (= opt 1)
(progn
;;>>>>>>>>>>>>>>>>>>>>>> begin RLW patch
;; now updating *hinc* and reassigning hinc, en, and entl
(setq *hinc* hinc hinc 0 en *en* entl *entl*) ;; setup to fool the product
(setq disl (mapcar '(lambda (a) (vlax-curve-getDistAtPoint en (vlax-curve-getClosestPointTo en a))) pol))
(if (> hinc 0) ; We have a profile at selected interval ie hrz increment ;
(setq dist (- hinc (rem chbeg hinc))
disl (vl-sort (append disl (in_range dist dtot hinc)) '<)
)
; Else Points Every of Intersection 3dfaces ie at every break in TIN ;
(setq disl (vl-sort (distinct (append disl (mapcar 'caddr entl))) '<))
)
(setq temp (list (list (car disl) (caar entl))))
(setq entl (mapcar '(lambda (a)
(setq i -1)
(while (< (caddr (nth (setq i (1+ i)) entl)) a))
(list a (car (nth (1- i) entl)))
)
(cdr disl)
)
)
(setq entl (append temp entl)) ;; temp -was- tmp ...I think tmp is a typo
(setq prof0 (mapcar '(lambda (a)
(setq p (vlax-curve-getPointAtDist en (car a))
ps (get_3dfpts (cadr a))
)
(list (car a) (caddr (getz p (car ps) (cadr ps) (caddr ps))))
)
entl
)
)
(if copyen ; If we had a 3dpoly, erase the temporary entity. ;
(setq ** (entdel en)
en copyen copyen nil
)
)
;;>>>>>>>>>>>>>>>>>>>>>>
;; now redoing the above with new assignments...
;;>>>>>>>>>>>>>>>>>>>>>>
;; reassigning hinc, en, and entl
(setq hinc *hinc* en *en* entl *entl*)
(setq disl (mapcar '(lambda (a) (vlax-curve-getDistAtPoint en (vlax-curve-getClosestPointTo en a))) pol))
(if (> hinc 0) ; We have a profile at selected interval ie hrz increment ;
(setq dist (- hinc (rem chbeg hinc))
disl (vl-sort (append disl (in_range dist dtot hinc)) '<)
)
; Else Points Every of Intersection 3dfaces ie at every break in TIN ;
(setq disl (vl-sort (distinct (append disl (mapcar 'caddr entl))) '<))
)
(setq temp (list (list (car disl) (caar entl))))
(setq entl (mapcar '(lambda (a)
(setq i -1)
(while (< (caddr (nth (setq i (1+ i)) entl)) a))
(list a (car (nth (1- i) entl)))
)
(cdr disl)
)
)
(setq entl (append temp entl)) ;; temp -was- tmp ...I think tmp is a typo
(setq prof (mapcar '(lambda (a)
(setq p (vlax-curve-getPointAtDist en (car a))
ps (get_3dfpts (cadr a))
)
(list (car a) (caddr (getz p (car ps) (cadr ps) (caddr ps))))
)
entl
)
)
(if copyen ; If we had a 3dpoly, erase the temporary entity. ;
(setq ** (entdel en)
en copyen copyen nil
)
)
;;>>>>>>>>>>>>>>>>>>>>>> close RLW patch
;; Var prof now contains the list of the profile sorted. ;
(setq chal (mapcar '(lambda (a) (rtosta (+ chbeg (car a)) 1 prec)) prof) ;; 1 IMPERIAL, 2 METRIC
elvl (mapcar '(lambda (a) (rtos (cadr a) 2 prec)) prof)
(mk_layer (list "Profile Grid" gridcolor))
(foreach p prof
(ssadd (entmakex (list '(0 . "LINE") (cons 10 (list (car p) ylinc)) (cons 11 (list (car p) yline)))) ssp)
(ssadd (entmakex (list '(0 . "LINE") (cons 10 (list (car p) yline)) (cons 11 p))) ssp)
)
;;>>>>>>>> start patch by RLW
;; draw horizontal grid and label their elevations
(setq pstart (car prof) pclose (last prof) cntz zmin)
(setq ydatum (- (cadr pstart) (* vexag (- (atof (car elvl)) zmin))))
(while (< cntz zmax)
(setq cntz (+ cntz vinc))
(setq ofsy (* (- cntz zmin) vexag))
(setq x1 (car pstart)
y1 (+ ydatum ofsy)
z1 0
x2 (car pclose)
y2 y1
z2 0
g1 (list x1 y1 z1)
g2 (list x2 y2 z2)
)
(ssadd (entmakex (list '(0 . "LINE") (cons 10 g1) (cons 11 g2))) ssp)
(ssadd (mk_mtext (polar g1 pi txth) (rtos cntz 2 2) 6 txth 0) ssp)
)
(ssadd (entmakex (list '(0 . "LINE") (cons 10 g1) (cons 11 pstart))) ssp) ;; recent addition
(ssadd (entmakex (list '(0 . "LINE") (cons 10 g2) (cons 11 pclose))) ssp) ;; recent addition
;; delete the grid data profile line
(vl-cmdf "._erase" ssx "")
;;>>>>>>> end patch by RLW
;; Moving the profile where we want it. ;
(vl-cmdf "._MOVE" ssp "" org pause)
;; remduppoint by Joe Burke ;
;; Remove Duplicate Adjacent Points from Point List with Fuzz Factor ;
;; Point List Needs to be Sorted Prior to Calling this Function ;
;; Modified by YMG to operate on 2d points... (butlast p) ;
(defun remduppoint (l fuzz / rtn p)
(repeat (1- (length l))
(setq p (car l))
(if (> (distance (butlast p) (cadr l)) fuzz) ;; butlast for 2d
(setq rtn (cons p rtn))
(if (> (distance p (cadr l)) (* 2 fuzz)) ;; 3d & double fuzz
(setq rtn (cons p rtn))
)
)
)
(setq l (cdr l))
)
(reverse (cons (car l) rtn))
)
(defun sortxyz (a / b c e1 e2) ;; a: list of points
(setq b (vl-sort a (function (lambda (e1 e2) (< (caddr e1) (caddr e2)) ) ))) ;; by z
(setq c (vl-sort b (function (lambda (e1 e2) (< (cadr e1) (cadr e2)) ) ))) ;; by y
(setq a (vl-sort c (function (lambda (e1 e2) (< (car e1) (car e2)) ) ))) ;; by x
)
(setq PLIST (TIN:GETPOINTSLIST (ssget)))
(setq BLIST (TIN:GETBREAKLINELIST (ssget)))
(setq TLIST (TIN:TRIANGULATE PLIST BLIST))
(TIN:DRAW TLIST)
(setq TLIST (TIN:GET (car (entsel)))
(setq TLIST (TIN:READ FILENAME))
(TIN:WRITE FILENAME TLIST)
(setq Z (TIN:ELEVATIONATPOINT (getpoint) TLIST)
; find a string in a string - returns position of first letter - zero if none
(defun TIN:GETSTRPOS (ssub sall / lsub lall i n ret)
(setq lall (strlen sall)
lsub (strlen ssub)
)
(setq ssub (strcase ssub))
(setq sall (strcase sall))
(setq ret nil)
(cond ((> lsub lall) 0)
((<= lsub lall) (setq i 1 n (1+ (- lall lsub)))
(while (and (not ret) (<= i n))
(if (= ssub (substr sall i lsub))
(setq ret i)
(setq i (1+ i))
)
)
(if (= ret nil) (setq ret 0))
ret
)
(T (if (= ssub sall) 1))
)
)
; TIN:READ reads the input file and returns a triangle list (lists of 3 3dpoint lists)
(defun TIN:READ (DiskFileName / DataFile DataLine P1 P2 P3 TL TLF X Y Z pos1 dat)
(setq TLF nil dat 0)
(if (setq DataFile (open DiskFileName "r"))
(progn
(while (setq DataLine (read-line DataFile))
(setq dat (+ dat 1))
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq X (atof (substr DataLine 1 (- pos1 1)))) ;; get X element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq Y (atof (substr DataLine 1 (- pos1 1)))) ;; get Y element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq Z (atof (substr DataLine 1 (- pos1 1)))) ;; get Z element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq P1 (list X Y Z))
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq X (atof (substr DataLine 1 (- pos1 1)))) ;; get X element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq Y (atof (substr DataLine 1 (- pos1 1)))) ;; get Y element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq Z (atof (substr DataLine 1 (- pos1 1)))) ;; get Z element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq P2 (list X Y Z))
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq X (atof (substr DataLine 1 (- pos1 1)))) ;; get X element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq pos1 (TIN:GETSTRPOS "," DataLine))
(setq Y (atof (substr DataLine 1 (- pos1 1)))) ;; get Y element of point
(setq DataLine (substr DataLine (+ pos1 1))) ;; reduce DataLine to remainder
(setq Z (atof DataLine)) ;; DataLine no longer has a delimiter
(setq P3 (list X Y Z))
(setq TL (list P1 P2 P3))
(setq TLF (append TLF (list TL)))
) ;; end while
(close DataFile)
) ; end progn
) ; end if
(alert (strcat (itoa dat) " TIN's are imported."))
TLF
) ; end TIN:READ
(defun c:net () ;; select an existing TIN network from drawing
(princ "\nSelect TIN/3D-FACES")
(alert "Choose existing 3DFACES")
(setq ss (ssget '((0 . "3DFACE"))))
(if ss
(get_tin ss)
(alert "No 3DFACES found.")
)
(princ)
)
(defun c:imp () ;; import TIN network from disk file
(setq TIN-NAME (getvar 'dwgname))
(setq pos1 (TIN:GETSTRPOS ".dwg" TIN-NAME))
(setq TIN-NAME (substr TIN-NAME 1 (- pos1 1)))
(setq TIN-LIST (TIN:READ (strcat (getvar 'dwgprefix) TIN-NAME ".tin")))
(if TIN-LIST
(TIN:DRAW TIN-LIST)
(alert "No TIN file found.")
)
(princ)
)
(defun rw-disablesnap ()
(setq actvsnap (getvar "osmode"))
(setvar "osmode" 0)
)
(defun rw-enablesnap ()
(setvar "osmode" actvsnap)
)
(defun rw-StoColor ()
(setq olddrwcolor (getvar "cecolor"))
(if (= setdrwcolor 0)
(command "-color" "BYLAYER")
(command "-color" setdrwcolor)
)
)
(defun rw-RclColor ()
(setvar "cecolor" olddrwcolor)
)
; save text size and style
(defun rw-AlterFont ()
(setq saved_txtstyle (getvar "textstyle"))
(setq saved_txtsize (getvar "textsize"))
(setvar "textstyle" fntdsptyp)
(princ)
)
; restore text size and style
(defun rw-ResetFont ()
(setvar "textstyle" saved_txtstyle)
(setvar "textsize" saved_txtsize)
(princ)
)
(defun c:elv ( / z pnt azm brg lstdir str1 hgtstr) ;; elevation... post the TIN elevation at cursor position
(if (not TIN-LIST) (c:net))
(if (not TIN-LIST) (c:imp))
(if TIN-LIST
(progn (alert "Select an elevation point")
(rw-StoColor)
(rw-disablesnap)
(rw-AlterFont)
(setq hgtstr (* 0.06 (getvar "ltscale")))
(setvar "cecolor" "1")
(setq lstdir 0 z nil azm nil)
(mk_layer (list ".SRF-LBL" 1))
(while (setq pnt (getpoint "\nPick elevation-point... "))
(setq Z (TIN:ELEVATIONATPOINT pnt TIN-LIST))
(if z
(progn (setq str1 (rtos z))
(if (setq azm (getangle pnt "\nDrag-direction for Label <def=last>... "))
(setq brg (angtos azm 4 4))
(setq brg lstdir)
)
(if (= brg "E") (setq brg 0.0))
(command "-style" fntdsptyp fntdspshp hgtstr "1.00" fntobldeg "n" "n" "n")
(command "-TEXT" "J" "MC" pnt brg str1)
(setq lstdir brg)
) ; end progn
(alert "No TIN found at location. ") ; no z
) ; end if
) ; end while
(rw-ResetFont)
(rw-enablesnap)
(rw-RclColor)
(princ)
) ; end progn
(alert "No TIN found nor any file to import. ")
) ; end if
) ; end elv
;; added for TIN:WRITE
;;==========================================
(acet-ui-progress "Finding triangles :" (/ (length tl) (setq count 10))) ;; starts acet-ui-progress bar
(setq TIN-LIST nil) ; Initiate list of faces
(foreach tr tl
(setq TIN-LIST (append TIN-LIST (list (list (nth (car tr) pl)
(nth (cadr tr) pl)
(nth (caddr tr) pl)
)
)
)
)
(prog count) ;; updates acet-ui-progress
) ; end foreach
(acet-ui-progress) ;; ends acet-ui-progress bar
(setq TIN-NAME (getvar 'dwgname))
(setq pos1 (TIN:GETSTRPOS ".dwg" TIN-NAME))
(setq TIN-NAME (substr TIN-NAME 1 (- pos1 1))) ;; get X element of point
(TIN:WRITE (strcat (getvar 'dwgprefix) TIN-NAME ".tin") TIN-LIST) ;; save to disk
;;==========================================
) ; end get_tin
; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
(defun C:OCD ( / en ss lst ssall bbox)
(vl-load-com)
(if (and (setq en (car(entsel "\nSelect contour (polyline): ")))
(wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
(progn
(setq bbox (ACET-ENT-GEOMEXTENTS en))
(setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
(setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
(command "_.Zoom" "0.95x")
(if (null etrim)(load "extrim.lsp"))
(etrim en (polar
(car bbox)
(angle (car bbox)(cadr bbox))
(* (distance (car bbox)(cadr bbox)) 1.1)))
(if (and
(setq ss (ssget "_CP" lst))
(setq ssall (ssget "_X" (list (assoc 410 (entget en)))))
)
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach e1 lst (ssdel e1 ssall))
(ACET-SS-ENTDEL ssall)
)
)
)
)
)
(princ "\nType OCD to start")
(princ)
(if (> (distance (butlast p) (cadr l)) fuzz)
(if (> (distance (butlast p) (butlast (cadr l))) fuzz)
; Required Express tools
; OutSide Contour Delete with Extrim
; Found at http://forums.augi.com/showthread.php?t=55056
(defun C:OCD ( / en ss lst ssall bbox)
(vl-load-com)
(if (and (setq en (car(entsel "\nSelect contour (polyline): ")))
(wcmatch (cdr(assoc 0 (entget en))) "*POLYLINE"))
(progn
;; *** commented out ***
;;(setq bbox (ACET-ENT-GEOMEXTENTS en))
;;(setq bbox (mapcar '(lambda(x)(trans x 0 1)) bbox))
(setq lst (ACET-GEOM-OBJECT-POINT-LIST en 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list en)))
(command "_.Zoom" "0.95x")
;; *** commented out ***
; (if (null etrim)(load "extrim.lsp"))
; (etrim en (polar
; (car bbox)
; (angle (car bbox)(cadr bbox))
; (* (distance (car bbox)(cadr bbox)) 1.1))
; )
;; changed selections to _WP and _X, and added 3DFACE filtering
(if (and
(setq ss (ssget "_WP" lst '((0 . "3DFACE")))) ;; select TINs inside polygon
(setq ssall (ssget "_X" (list (cons 0 "3DFACE")))) ;; select all TINs in drawing
)
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach e1 lst (ssdel e1 ssall))
(ACET-SS-ENTDEL ssall)
)
) ; end if
) ; end progn
)
)
(distance '(10 10) '(10 15 100)) --> 5.0
(distance '(10 10 100) '(10 15)) --> 5.0
(mk_3dp plst)
(setq *bounden* (entlast))
;;==========start patch
;; *bounden* (3dPloyline) is used as a TIN limit and a BREAKLINE
;; *limiten* (2dPloyline) is created to facilitate deletion of extraneous TIN's
;; *limiten* is built at an outside offset of 0.0003 to *bounden*
(mk_lwp plst) ;(mk_2dp plst)
(setq tmpen (entlast))
(setq tmppt (list (- 0 99999999) (- 0 99999999) 0)) ;; a negative 100 million feet away
(command "_offset" 0.0003 tmpen tmppt "") ; 0.0003
(setq *limiten* (entlast))
(entdel tmpen)
;;==========close patch
(redraw)
)
; Required Express tools
; OutSide Contour Delete
; Found at http://forums.augi.com/showthread.php?t=55056
; modified by RW2691 (aka. Rick)
(defun AUGI:OCD (TIN-LIMIT / ss lst ssall e1 lst)
(vl-load-com)
(if TIN-LIMIT
(progn
(setq lst (ACET-GEOM-OBJECT-POINT-LIST TIN-LIMIT 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list TIN-LIMIT)))
(command "_.Zoom" "0.95x")
(if (and
(setq ss (ssget "_WP" lst '((0 . "3DFACE")))) ;; select TINs inside polygon
(setq ssall (ssget "_X" (list (cons 0 "3DFACE")))) ;; select all TINs in drawing
)
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach e1 lst (ssdel e1 ssall))
(ACET-SS-ENTDEL ssall)
)
) ; end if
) ; end progn
)
)
; Required Express tools
; OutSide Contour Delete
; Found at http://forums.augi.com/showthread.php?t=55056
; modified by RW2691 (aka. Rick)
(defun AUGI:OCD (TIN-LIMIT / ss ssall e1 lst ent tp tr) ;; Global: tl 3dfl
(vl-load-com)
(if TIN-LIMIT
(progn ; 1
(setq lst (ACET-GEOM-OBJECT-POINT-LIST TIN-LIMIT 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list TIN-LIMIT)))
(command "_.Zoom" "0.95x")
(if (and (setq ss (ssget "_WP" lst '((0 . "3DFACE")))) ;; select TINs inside polygon
(setq ssall (ssget "_X" (list (cons 0 "3DFACE")))) ;; select all TINs in drawing
)
(progn ; 2
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) ;; lst is save-group
(foreach e1 lst (ssdel e1 ssall)) ;; removes save-group from entity list
(repeat (setq i (sslength ssall)) ;; repeat to update tl and 3dfl
(setq en (ssname ssall (setq i (1- i)))
ent (entget en)
tp (list (cdr (assoc 11 ent)) ;; translate to point
(cdr (assoc 12 ent))
(cdr (assoc 13 ent))
)
tr (list (vl-position (car tp) pl) ;; query point info ;; pl was tl was lst
(vl-position (cadr tp) pl)
(vl-position (caddr tp) pl)
)
tl (vl-remove tr tl) ;; erase TIN-Set from TIN list
3dfl (vl-remove en 3dfl) ;; erase TIN-object from 3DFACE list
) ; end setq
) ;; end repeat
(ACET-SS-ENTDEL ssall) ;; deletes all remaining entities
) ; end progn 2
) ; end if
) ; end progn 1
)
) ;; end AUGI:OCD
(acet-ui-progress) ;; ends acet-ui-progress bar
(if *LIMITEN* (AUGI:OCD *LIMITEN*)) ;; erase extraneous TIN's by LIMITEN patch-insert
;;************* start LIMITEN patch-cut
;; Erasing Triangles in Holes of Triangulation, and those ;
;; outside of the boundary. Adjusting Triangle List. ;
;; Notes: This is a fast hack where we select 3Dfaces with a ;
;; Crossing Polygon then Computes their Centroid and ;
;; remove those whose centroid is inside the poly. ;
;; (But the centroid could be outside the poly) ;
;; Will change it eventually to offset the polyline ;
;; to the outside by a few millimeters, and make the ;
;; Selection by Window Polygon. ;
; (vl-cmdf "._ZOOM" "_E")
; (if *bounden* ;; created by BND function
; (setq bp (distinct (mapcar '(lambda (a) (list (car a) (cadr a))) (listpol *bounden*))))
; )
; (foreach wp wpl
; (setq ss (ssget "_CP" wp '((0 . "3DFACE"))))
; (repeat (setq i (sslength ss)) ;; i is repeat i times
; (setq en (ssname ss (setq i (1- i)))
; ent (entget en)
; tp (list (cdr (assoc 11 ent))
; (cdr (assoc 12 ent))
; (cdr (assoc 13 ent))
; )
; ct (centroid tp) ;; get centroid
; in (ptinpoly_p ct (cons (last wp) wp))
; )
; (if (or (and in (not (equal wp bp)))
; (and (not in) (equal wp bp))
; )
; (setq tr (list (vl-position (car tp) pl)
; (vl-position (cadr tp) pl)
; (vl-position (caddr tp) pl)
; )
; tl (vl-remove tr tl)
; 3dfl (vl-remove en 3dfl)
; ** (entdel en)
; ) ; end setq
; ) ; end if
; ) ;; end repeat
; ) ;; end foreach
;;************* close LIMITEN patch-cut
;; Processing Boundary
(vl-cmdf "._ZOOM" "_P")
(mk_3dp plst)
(setq *bounden* (entlast))
;; *bounden* (3dPloyline) is used as a TIN limit and a BREAKLINE
;; *limiten* (2dPloyline) is created to facilitate deletion of extraneous TIN's
;; *limiten* is built at an outside offset of 0.005 to *bounden*
(mk_lwp plst) ;(mk_2dp plst)
(setq tmpen (entlast))
(setq ofspt (list (- 0 999999) (- 0 999999) 0)) ;; a negative 1 million feet past 0,0,0.
(command "_offset" 0.005 tmpen ofspt "") ;; 0.005
(setq *limiten* (entlast))
(entdel tmpen)
(redraw)
) ;; end progn
I just tried it with a 2D LWpolyline and it did not work because it refused the poly as a selection.
To all,
Can anyone tell me what the MAKEREADABLE function is doing?
Rick
(defun rw-SetTxtUpright (setazm / azmref ucsaxis azmaxs) ;; sets bearing to upright by "twist" perspective
(if (< setazm 0)
(setq azmref (+ setazm (* pi 2))) ; pi radians = 180 deg
(setq azmref setazm)
)
(if (> azmref (* pi 2)) ; 360 deg
(setq azmref (- azmref (* pi 2)))
)
(setq ucsaxs (getvar "viewtwist"))
(if (< ucsaxs 0)
(setq azmaxs (+ ucsaxs (* pi 2)))
(setq azmaxs ucsaxs)
)
(if (> azmaxs (* pi 2))
(setq azmaxs (- azmaxs (* pi 2)))
)
(setq azmref (+ azmref azmaxs)) ; rotate ref by axs
(if (> azmref (* pi 2))
(setq azmref (- azmref (* pi 2)))
)
(if (and (> azmref (/ pi 2)) ; 90 deg
(< azmref (* (/ pi 2) 3)) ; 270 deg
)
(+ setazm pi) ;; report bearing righted
setazm ;; report bearing normal
)
)
;; mk_mtext by ymg *** modified as mk_masked_text by rw2691 for masking *** ;
;; Arguments: p, Insertion Point. ;
;; s, Text. ;
;; j, Justification: ;
;; 1 = Top left; 2 = Top center; 3 = Top right; ;
;; 4 = Middle left; 5 = Middle center; 6 = Middle right; ;
;; 7 = Bottom left; 8 = Bottom center; 9 = Bottom right ;
;; h, Text Height. ;
;; r, Rotation. ;
;; c, text color ;
;; ms, mask state ...1=on 2=off ;
;; mc, mask color ...1, 7, or 254 slight-gray or ash ;
;; mr, mask ratio ...typical is 1.4 ;
;; Limitation: 255 character string for text
(defun mk_masked_text (p s j h r c ms mc mr)
(if (= ms nil) (setq ms 2 mc 1 mr 1.4))
(entmakex
(list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 10 p) ;; point
(cons 71 j) ;; justify
(cons 40 h) ;; height
(cons 50 r) ;; rotate by radians 0=right pi=left
(cons 1 s) ;; string
(cons 62 c) ;; color 256=bylayer 0=byblock negative=layeroff
(cons 90 ms) ;; mask state ;; 1 is mask-on ... 2 is mask-off
(cons 63 mc) ;; mask color ;; 1 is red, 7 white, 254 ash, etc.
(cons 45 mr) ;; mask ratio ;; 1.0 is text height, 1.4 is 0.4 larger than text height
)
)
)
(defun c:lbl () ;; utility command name that can be changed
(rw-cmdlbl)
)
; Label contour line. Works with line, polyline, lwpolyline, 2d & 3d polyline, spline and point.
(defun rw-cmdlbl (/ en0 en1 en2 azm pnt snp i dst str1 elv)
(setq j 0)
(mk_layer (list ".SRF-LBL" 1)) ;; this differs from the standard layer scheme... it can be changed
(while (= j 0) ; 1st while
(setq i 0)
(while (= i 0) ; 2nd while
(setq oldsnap (getvar "osmode") en0 nil en1 nil en2 nil)
(setvar "osmode" 512)
(setq pnt (getpoint "\nSelect contour at label position (snap-nearest active)... "))
(setvar "osmode" oldsnap)
(if pnt (setq en0 (osnap pnt "near")))
(if en0 (setq en1 (car (nentselp en0))))
(if en1 (progn (setq ed (entget en1))
(setq et (cdr (assoc 0 ed)))
(if (= et "POLYLINE") (setq i 1))
(if (= et "LWPOLYLINE") (setq i 2))
(if (= et "2DPOLYLINE") (setq i 1))
(if (= et "3DPOLYLINE") (setq i 1))
(if (= et "SPLINE") (setq i 1))
(if (= et "LINE") (setq i 1))
(if (= et "POINT") (setq i 1))
) ;p
(progn (setq rsp (getstring "\nWarning - No contour found... exit? Y/N <Y>: "))
(if (= rsp "") (setq rsp "Y"))
(setq rsp (strcase rsp))
(if (= rsp "Y") (setq i 9 j 9 et "EXIT")) ; i 0 was i 9
) ;p
) ;i
(if (= i 1) (setq elv (cadddr (assoc 10 ed))))
(if (= i 2) (setq elv (cdr (assoc 38 ed))))
(if (and (= elv 0)(> i 0))
(progn (setq drw (getstring "\nWarning -- Contour is 0... Label? Y/N <Y>: "))
(if (/= drw "") (setq drw (strcase drw)))
(if (/= drw "N") (setq i 1) (setq i 0))
)
)
) ; end 2nd while
(if (and (< i 9) (< j 9)) ; was (and (> i 0) (< i 9))
(progn (setq txtscale (* (getvar "ltscale") 0.06)) ;; 0.06 hight for red's printing width
(setq str1 (rtos elv 2 0)) ;; 0 is precision, ie. 0, 1 or 2... etc.
;>>>>>=====================================================
;; start process for aquiring bearing of line at snap-point
(setq dst (strlen str1))
(setq dst (/ (* dst txtscale) 200))
(command "circle" pnt dst)
(setq en2 (entlast))
(setq snp (osnap pnt "_app")) ;; "_end,_int" to combine snaps for other applications
;; note: it doesn't matter which INT it snaps, rw-SetTxtUpright will correct its display
(setq azm (rw-SetTxtUpright (angle pnt snp))) ;; alternate: (setq azm (makereadable (angle pnt snp)))
(entdel en2)
;; close process for aquiring bearing of line at snap-point
;>>>>>=====================================================
;; (mk_masked_text point string justify height rotation color mask-state mask-color mask-ratio)
(mk_masked_text pnt str1 5 txtscale azm 1 1 254 1.4)
) ;p
) ;i
) ; end 1st while
(princ)
) ;; end rw-cmdlbl
(defun Make_Spline (lst-pts z / p px py pt data closed)
;; Author: R. Togores (togoresr@unican.es)
;; Modified: R. Wills (rick.wills@mapmakers.biz)
;; drawing layer, lisp point-list, contour-elevation or nil
;; point-list can be 2d or 3d, open or closed, contour or radical
;; if z is specified (not nil) it creates 3d spline with uniform elevation
(setq closed nil closed (equal (car lst-pts ) (last lst-pts ) 0.005)) ;; set closed or open
(if z (progn
(setq data nil)
(foreach p lst-pts
(setq pt (list (car p) (cadr p) z)) ;; build contour elevation
(setq data (append data (list pt)))
) ;f
(setq lst-pts data)
) ;p
) ;i
(entmake (append (list '(0 . "SPLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbSpline")
'(44 . 1.0e-005)
(cons 48 0.75) ;; celtscale... pattern scaler
(cons 71 (if closed ;; bitwise 1=closed
11 ;; 2=periodic; default for closed [hence 11]
8 ;; 4=rational
) ;i ;; 8=planar; default for closed [hence 11]
) ;c ;; 16=linear
'(70 . 1) ;; degree of spline: number of control-points + 1, ie. 1 is none
(cons 74 (if closed
(1+ (length lst-pts )) ;; number of fit-points
(length lst-pts )
) ;i
) ;c
) ;l
(if closed (cons (cons 11 (last lst-pts ))
(mapcar '(lambda (x) (cons 11 x)) lst-pts) ;; closed fit-points
) ;c
(mapcar '(lambda (x) (cons 11 x)) lst-pts) ;; open fit-points
) ;i
) ;a
) ;e
) ;m
For the labeling, there is already 3 different way in the program:
dlbl - For dynamic labeling with drag line
flbl - Same as above but not dynamic
lbl - Put label at a given spacing on contours.
The one you are proposing would help in completing the suite.
Incidentally they all use text mask.
; Required Express tools
; OCD: OutSide Contour Delete, was... AUGI:OCD
; Found at http://forums.augi.com/showthread.php?t=55056
; modified by RW2691 (aka. Rick)
(defun ERASE-OUTSIDE (*3D-POLY* / ss ssall e1 lst ent tp tr blst *tmpen* *LIMIT* ofspt blst)
(vl-load-com)
(if *3D-POLY*
(progn ;; #A
;;(setq blst (distinct (mapcar '(lambda (a) (list (car a) (cadr a))) (listpol *3D-POLY*))))
(setq blst (listpol *3D-POLY*))
(mk_lwp blst) ;; build 2dpoly #1
(setq *tmpen* (entlast)) ;; select 2dpoly #1
(setq ofspt (list (- 0 9999) (- 0 9999) 0)) ;; point at a negative 10 thousand feet past 0,0,0.
(command "_offset" 0.005 *tmpen* ofspt "") ;; build 2dpoly #2 at 0.005' offset
(setq *LIMIT* (entlast)) ;; select 2dpoly #2
(entdel *tmpen*) ;; erase 2dpoly #1
(setq lst (ACET-GEOM-OBJECT-POINT-LIST *LIMIT* 1e-3))
(ACET-SS-ZOOM-EXTENTS (ACET-LIST-TO-SS (list *LIMIT*)))
(entdel *LIMIT*) ;; erase 2dpoly #2
(command "_.Zoom" "0.95x")
(if (and (setq ss (ssget "_WP" lst '((0 . "3DFACE")))) ;; select TINs inside polygon
(setq ssall (ssget "_A" (list (cons 0 "3DFACE")))) ;; select all visible TINs in drawing
) ;; _A was _X ;; _A selects all visible items, and _X gets all drawing items
(progn ;; #B
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) ;; lst is save-group
(foreach e1 lst (ssdel e1 ssall)) ;; removes save-group from entity list
;;====================================================================
;; start repeat to update globals: TL and 3DFL per PL
(repeat (setq i (sslength ssall))
(setq en (ssname ssall (setq i (1- i)))
ent (entget en)
tp (list (cdr (assoc 11 ent)) ;; translate to point
(cdr (assoc 12 ent))
(cdr (assoc 13 ent))
)
tr (list (vl-position (car tp) pl) ;; query point info
(vl-position (cadr tp) pl)
(vl-position (caddr tp) pl)
)
tl (vl-remove tr tl) ;; erase TIN-Set from TIN list
3dfl (vl-remove en 3dfl) ;; erase object from 3DFACE list
) ; end setq
)
;; close repeat to update globals: TL and 3DFL per PL
;;====================================================================
(ACET-SS-ENTDEL ssall) ;; deletes all remaining external entities
(vl-cmdf "._DRAWORDER" ss "" "_BACK") ;; sets to back
(vl-cmdf "._regen")
) ; end progn #B
) ; end if 3DFACE
) ; end progn #A
) ; end if *3D-POLY*
(princ)
) ;; end ERASE-OUTSIDE
; example: for a text object with layer assigned...
(entmake
(list (cons 0 "TEXT") ; object
(cons 1 TxtStr) ; string
(cons 7 "STANDARD") ; style
(cons 8 "POINT-TEXT") ; layer
(cons 10 DwgPnt) ; insert point
(cons 11 DwgPnt) ; custom point... not changing
(cons 39 0.0) ; thickness
(cons 40 (* 0.06 (getvar "ltscale"))) ; hight by drawing scale
(cons 50 ortang) ; rotation... using ortho-mode radians
(cons 51 0.06981317) ; oblique radians... using slight slant
(cons 62 256) ; color bylayer
(cons 71 0) ; justify mirror
(cons 72 0) ; justify left
(cons 73 3) ; justify top
(cons 210 (list 0.0 0.0 1.0)) ; extrusion direction
) ;l
) ;e
; example: for a point object
(entmake
(list (cons 0 "POINT") ; object
(cons 6 "BYLAYER") ; linetype
(cons 8 "POINT-MARKER") ; layer
(cons 10 DwgPnt) ; point
(cons 39 0.0) ; thickness
(cons 50 ortang) ; ortho-mode radians
(cons 62 256) ; color bylayer
(cons 210 (list 0.0 0.0 1.0)) ; extrusion direction
) ;l
) ;e
(defun c:lbl () ;; COULD BE NAMED SLBL FOR "SPOT LABEL"
(rw-cmdlbl) ;; for drag-line... (setq ss (ssget "_F" plst (list '(0 . "SPLINE")(cons 8 ".SRF-FIN"))))
)
; Label contour line.
(defun rw-cmdlbl (/ en0 en1 en2 azm pnt snp i dst str1 elv)
(rw-setcadunits)
(setq jst1 "C" jst2 "M" sze 0.06 setdrwcolor 1 dstdsp 0) ;; for rw-SetupText
(rw-SetupText)
(setq j 0)
(mk_layer (list ".SRF-LBL" 1))
(while (= j 0) ; 1st while
(setq grdval (getvar "elevation")) ; save preset elevation (normally 0.0)
(setq grdmod (getvar "OSNAPZ")) ; save elevation snap-mode
(setvar "OSNAPZ" 0) ; set snap to object-grade
(setq oldsnap (getvar "osmode") en0 nil en1 nil en2 nil)
(setvar "osmode" 512) ;; snap nearest
(setq i 0)
(while (= i 0) ; 2nd while
(setq pnt (getpoint "\n\nSelect contour at label position (snap-nearest active)... "))
(if pnt (setq en0 (osnap pnt "near")))
(if en0 (setq en1 (car (nentselp en0))))
(if en1 (progn (setq ed (entget en1))
(setq et (cdr (assoc 0 ed)))
(if (= et "LINE") (setq i 1))
(if (= et "POLYLINE") (setq i 1))
(if (= et "LWPOLYLINE") (setq i 2))
(if (= et "2DPOLYLINE") (setq i 1))
(if (= et "3DPOLYLINE") (setq i 1))
(if (= et "SPLINE") (setq i 1)) ;; for testing splines ...can have phantom snap issue
)
)
(if (or (not en1) (= i 0))
(progn (setq rsp (getstring "\nWarning - No contour found... exit? Y/N <Y>: "))
(if (= rsp "") (setq rsp "Y"))
(setq rsp (strcase rsp))
(if (= rsp "Y") (setq i 9 j 9 et "EXIT")) ; i 0 was i 9
)
)
;;(if (= i 1) (setq elv (cadddr (assoc 10 ed)))) ;; **for when snapz is inactive
;;(if (= i 2) (setq elv (cdr (assoc 38 ed)))) ;; **for when snapz is inactive
(setq elv (caddr pnt)) ;; **for when snapz is active ...this section activates snapz
(if (and (= elv 0)(> i 0))
(progn (setq drw (getstring "\nWarning -- Contour is 0... Label? Y/N <Y>: "))
(if (/= drw "") (setq drw (strcase drw)))
(if (/= drw "N") (setq i 1) (setq i 0))
)
)
) ; end 2nd while
(setvar "osmode" oldsnap)
(setvar "OSNAPZ" grdmod) ; restore elevation snap-mode
(setvar "elevation" grdval) ; restore preset-elevation (normally 0.0)
(if (and (< i 9) (< j 9)) ; was (and (> i 0) (< i 9))
(progn
(rw-StoColor)
(rw-disablesnap)
(rw-AlterFont)
(setq txtscale (* (getvar "ltscale") 0.06)) ;; 0.06 hight for red's printing width
(setq str1 (rtos elv 2 0)) ;; 0 is precision, ie. 0, 1 or 2... etc.
;>>>>>=====================================================
;; start process for aquiring bearing of line at snap-point
(setq dst (strlen str1))
(setq dst (/ (* dst txtscale) 150))
(command "circle" pnt dst) ;; was... dst)
(setq en2 (entlast))
(setq snp (osnap pnt "_app")) ;; "_end,_int" to combine snaps for other applications
(setq azm (rw-SetTxtUpright (angle pnt snp))) ;; alternate: (setq azm (makereadable (angle pnt snp)))
(entdel en2)
;; close process for aquiring bearing of line at snap-point
;>>>>>=====================================================
;; for plain text... cuts the line at front and back of label
;(setvar "textsize" txtscale)
;(setvar "cecolor" "1") ; color red
;(setq dst (+ (strlen str1) 1.0))
;(setq dst (/ (* dst hgt) 2.0))
;(command "circle" pnt dst)
;(setq en2 (entlast))
;(command "trim" en2 "" pnt "") ;; cuts the line from each side of text
;(entdel en2)
;(command "-style" fntdsptyp fntdspshp hgtstr "1.00" fntobldeg "n" "n" "n")
;(command "-TEXT" "J" "MC" pnt brg str1)
;; for mtext...
; mk_masked_text point string justify hight rotation color mask-state mask-color mask-ratio
(mk_masked_text pnt str1 5 txtscale azm 1 1 254 1.3) ;; no need to cut line
(rw-ResetFont)
(rw-enablesnap)
(rw-RclColor)
)
)
) ; end 1st while
(rw-putcadunits)
(princ)
) ;; end lbl
(defun rw-SetTxtUpright (setazm / azmref ucsaxis azmaxs) ;; sets bearing to upright by natural and "viewtwist" perspectives
(if (< setazm 0)
(setq azmref (+ setazm (* pi 2))) ; pi radians = 180 deg
(setq azmref setazm)
)
(if (> azmref (* pi 2)) ; 360 deg
(setq azmref (- azmref (* pi 2)))
)
(setq ucsaxs (getvar "viewtwist"))
(if (< ucsaxs 0)
(setq azmaxs (+ ucsaxs (* pi 2)))
(setq azmaxs ucsaxs)
)
(if (> azmaxs (* pi 2))
(setq azmaxs (- azmaxs (* pi 2)))
)
(setq azmref (+ azmref azmaxs)) ; rotate ref by axs
(if (> azmref (* pi 2))
(setq azmref (- azmref (* pi 2)))
)
(if (and (> azmref (/ pi 2)) ; 90 deg
(< azmref (* (/ pi 2) 3)) ; 270 deg
)
(+ setazm pi) ;; report bearing righted
setazm ;; report bearing normal
)
)
;; mk_mtext by ymg *** modified as mk_masked_text by rw2691 for masking *** ;
;; Arguments: p, Insertion Point. ;
;; s, Text. ;
;; j, Justification: ;
;; 1 = Top left; 2 = Top center; 3 = Top right; ;
;; 4 = Middle left; 5 = Middle center; 6 = Middle right; ;
;; 7 = Bottom left; 8 = Bottom center; 9 = Bottom right ;
;; h, Text Height. ;
;; r, Rotation. ;
;; c, text color ;
;; ms, mask state ...1=on 2=off ;
;; mc, mask color ...254 slight-gray or ash ;
;; mr, mask ratio ...typical is 1.4 ;
;; Limitation: <s> having a maximum 2040 character string <being 8 times 255> ;
(defun mk_masked_text (p s j h r c ms mc mr / x1 ent1)
(if (= ms nil) (setq ms 2)) ;; turns off mask
(if (= mc nil) (setq mc 250)) ;; sets to black
(if (= mr nil) (setq mr 1.3)) ;; better than nothing
;;==================================================================
;; the below is for testing large strings... this is 2040 characters
;; with codes like \\p, only the \p is counted... being 2 characters
;; <s> will actually process this string, but I am testing it parsed
(setq s "*1* xt upon text over and over again\\Ptext upon text over and over 0001*2* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and 0002*3* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext* *512*
*1* xt upon text over and over again\\Ptext upon text over and over 0001*2* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and 0002*3* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext* *512*
*1* xt upon text over and over again\\Ptext upon text over and over 0001*2* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and 0002*3* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext* *512*
*1* xt upon text over and over again\\Ptext upon text over and over 0001*2* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and 0002*3* \\P upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Ptext upon text over and over again\\Pt *508*")
;; rename the above <s> to <sk> in setq for testing by snap-line elevation
;; the below clears <sk> from memory upon switching back to <s>
(setq sk nil)
;;==================================================================
(setq ent1 (entmakex
(list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 10 p) ;; point
(cons 71 j) ;; justify
(cons 40 h) ;; height
(cons 50 r) ;; rotate by radians 0=right pi=left
(cons 62 c) ;; color 256=bylayer 0=byblock negative=layeroff
(cons 90 ms) ;; mask state ;; 1 is mask-on ... 2 is mask-off
(cons 63 mc) ;; mask color ;; 1 is red, 7 white, 254 ash, etc.
(cons 45 mr) ;; mask ratio ;; 1.0 is text height, 1.4 is 0.4 larger than text height
; (foreach x (MakeMTlist s) ;; This did not work but it should have.
; (cons (car x) (cdr x)) ;; Replaced it with late binding below.
; )
) ;l
) ;e
)
(foreach x1 (MakeMTlist s) ;; I think this is called late binding.
(objmod ent1 (car x1) (cdr x1)) ;; This doesn't work but it should have
(princ "\n\n") ;; There seems to be something wrong with the object
(princ (cons (car x1) (cdr x1))) ;; print as test
)
) ;d
(defun objmod (modent moditm modval / moddat) ;; late binder
(setq moddat (entget modent)) ; Sets moddat to the entity data
; for entity name moddat.
(setq moddat
(subst (cons moditm modval)
(assoc moditm moddat) ; Changes the moditm group in
moddat ; moddat to modval.
)
)
(entmod moddat) ; Modifies entity value in drawing.
(entupd modent) ; updates entity object
)
;; Function: MakeMtextLists, Steve Doman, 11-17-99
;; eMail: steved@onlinemac.com
;; modified by RLW 05/19/2016
(defun MakeMTlist (text / sl left k tempstr textlist)
(setq sl (strlen text))
(if (<= sl 250) ;; 250 is the DXF CODE maximum
(setq textlist (list (cons 1 text))) ;; single block
(progn
(setq left 1 k sl textlist nil) ;; **copy method**
(while (> k 250) ;; mutliple blocks
(setq tempstr (substr text left 250)
textlist (append textlist (list (cons 3 tempstr)))
left (+ left 250)
k (- k 250)
)
) ;while
(setq tempstr (substr text left sl) ;; trailing block
textlist (append textlist (list (cons 1 tempstr)))
)
);progn
);if
;;(princ textlist)
textlist
) ;;end defun
;; mk_mtext by ymg *** modified as mk_masked_text by rw2691 for masking *** ;
;; Arguments: p, Insertion Point. ;
;; s, Text. ;
;; j, Justification: ;
;; 1 = Top left; 2 = Top center; 3 = Top right; ;
;; 4 = Middle left; 5 = Middle center; 6 = Middle right; ;
;; 7 = Bottom left; 8 = Bottom center; 9 = Bottom right ;
;; h, Text Height. ;
;; r, Rotation. ;
;; c, text color ;
;; ms, mask state ...1=on 2=off ;
;; mc, mask color ...254 slight-gray or ash ;
;; mr, mask ratio ...typical is 1.4 ;
;; Limitation: No limitation... this can process any volume of text ;
(defun mk_masked_text (p s j h r c ms mc mr / x1 ent1)
(if (= ms nil) (setq ms 2)) ;; turns off mask
(if (= mc nil) (setq mc 250)) ;; sets to black
(if (= mr nil) (setq mr 1.3)) ;; better than nothing
(entmake
(append
(list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 10 p) ;; point
(cons 71 j) ;; justify
(cons 40 h) ;; height
(cons 50 r) ;; rotate by radians 0=right pi=left
(cons 62 c) ;; color 256=bylayer 0=byblock negative=layeroff
(cons 90 ms) ;; mask state ;; 1 is mask-on ... 2 is mask-off
(cons 63 mc) ;; mask color ;; 1 is red, 7 white, 254 ash, etc.
(cons 45 mr) ;; mask ratio ;; 1.0 is text height, 1.4 is 0.4 larger than text height
) ;l
(MakeMTlist s)
) ;a
) ;e
) ;d
;; Function: MakeMtextLists, Steve Doman, 11-17-99
;; eMail: steved@onlinemac.com
;; modified by RLW 05/19/2016
(defun MakeMTlist (text / sl left k tempstr textlist)
(setq sl (strlen text))
(if (<= sl 250) ;; 250 is the DXF CODE maximum
(setq textlist (list (cons 1 text))) ;; single block
(progn
(setq left 1 k sl textlist nil) ;; **copy method**
(while (> k 250) ;; mutliple blocks
(setq tempstr (substr text left 250)
textlist (append textlist (list (cons 3 tempstr)))
left (+ left 250)
k (- k 250)
)
) ;while
(setq tempstr (substr text left sl) ;; final block
textlist (append textlist (list (cons 1 tempstr)))
)
);progn
);if
textlist
) ;end defun
; ----- Error around expression -----Any reason as to why it's not working?
(VLAX-CURVE-GETENDPARAM EN)
;
Error: bad argument type <NIL> ; expected <NUMBER> at [+ ]
(defun c:overkill-pts-average-z ( / ss i ent entptlst k zcoords zaverage subentptlst ti )
(prompt "\nSelect points...")
(setq ss (ssget "_:L" '((0 . "POINT"))))
(setq ti (car (_vl-times)))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst))
)
(setq k 0)
(foreach entpt entptlst
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (and (equal (car (cadr entpt)) (car (cadr x)) 1e-2) (equal (cadr (cadr entpt)) (cadr (cadr x)) 1e-2))) entptlst))
(if subentptlst
(progn
(setq zcoords (mapcar 'caddr (mapcar 'cadr subentptlst)))
(setq zaverage (/ (apply '+ zcoords) (float (length zcoords))))
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(if (not (vlax-erased-p (car subentpt)))
(progn
(setq k (1+ k))
(entdel (car subentpt))
)
)
)
(if (vlax-erased-p (car entpt))
(progn
(entdel (car entpt))
(setq k (1- k))
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc 10 (entget (car entpt))) (entget (car entpt)))))))
)
)
)
)
)
(prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...")
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(princ)
)
(defun c:overkill-pts-average-z-rem-X&Y-collinearity ( / LM:rand ss i ent entptlst k kk zcoords zaverage subentptlst entpt n d ti )
;; Rand - Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
(setq m 4294967296.0
a 1664525.0
c 1013904223.0
$xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
)
(/ $xn m)
)
(prompt "\nSelect points...")
(setq ss (ssget "_:L" '((0 . "POINT"))))
(initget 6)
(setq d (getdist "\nPick or specify fuzz distance for X&Y collinearity modifications <0.05> : "))
(if (null d)
(setq d 0.05)
)
(setq ti (car (_vl-times)))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst))
)
(setq k 0)
(foreach entpt entptlst
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (and (equal (car (cadr entpt)) (car (cadr x)) 1e-2) (equal (cadr (cadr entpt)) (cadr (cadr x)) 1e-2))) entptlst))
(if subentptlst
(progn
(setq zcoords (mapcar 'caddr (mapcar 'cadr subentptlst)))
(setq zaverage (/ (apply '+ zcoords) (float (length zcoords))))
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(if (not (vlax-erased-p (car subentpt)))
(progn
(setq k (1+ k))
(entdel (car subentpt))
(setq entptlst (vl-remove subentpt entptlst))
)
)
)
(if (vlax-erased-p (car entpt))
(progn
(entdel (car entpt))
(setq k (1- k))
(if (not (vl-position entpt entptlst))
(setq entptlst (cons entpt entptlst))
)
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc 10 (entget (car entpt))) (entget (car entpt)))))))
(setq entptlst (subst (list (car entpt) (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc (car entpt) entptlst) entptlst))
)
)
)
)
)
(setq kk 0)
(while (setq entpt (car entptlst))
(setq entptlst (cdr entptlst))
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (equal (car (cadr entpt)) (car (cadr x)) 1e-2)) entptlst))
(setq n 0.0)
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(setq kk (1+ kk))
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list ((if (zerop (rem (setq n (1+ n)) 2)) + -) (car (cadr subentpt)) (* (LM:rand) (* 0.5 d))) (cadr (cadr subentpt)) (caddr (cadr subentpt)))) (assoc 10 (entget (car subentpt))) (entget (car subentpt)))))))
(setq entptlst (subst (list (car subentpt) (cdr (assoc 10 (entget (car subentpt))))) (assoc (car subentpt) entptlst) entptlst))
)
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (equal (cadr (cadr entpt)) (cadr (cadr x)) 1e-2)) entptlst))
(setq n 0.0)
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(setq kk (1+ kk))
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car (cadr subentpt)) ((if (zerop (rem (setq n (1+ n)) 2)) + -) (cadr (cadr subentpt)) (* (LM:rand) (* 0.5 d))) (caddr (cadr subentpt)))) (assoc 10 (entget (car subentpt))) (entget (car subentpt)))))))
(setq entptlst (subst (list (car subentpt) (cdr (assoc 10 (entget (car subentpt))))) (assoc (car subentpt) entptlst) entptlst))
)
)
(prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...")
(prompt "\nTotal : ") (princ kk) (prompt " X&Y collinear point entities modifications made to apply slight X&Y collinearity...")
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(princ)
)
(defun c:overkill-pts-average-z-rem-collinearity-slow ( / LM:rand ss i ent entptlst k kk zcoords zaverage subentptlst entpt d z ang angl anglnth anglsrt angdltl angdnth angn p tst ti )
;; Rand - Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
(setq m 4294967296.0
a 1664525.0
c 1013904223.0
$xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
)
(/ $xn m)
)
(prompt "\nSelect points...")
(setq ss (ssget "_:L" '((0 . "POINT"))))
(initget 6)
(setq d (getdist "\nPick or specify fuzz distance for collinearity modifications <0.05> : "))
(if (null d)
(setq d 0.05)
)
(setq ti (car (_vl-times)))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst))
)
(setq k 0)
(foreach entpt entptlst
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (and (equal (car (cadr entpt)) (car (cadr x)) 1e-2) (equal (cadr (cadr entpt)) (cadr (cadr x)) 1e-2))) entptlst))
(if subentptlst
(progn
(setq zcoords (mapcar 'caddr (mapcar 'cadr subentptlst)))
(setq zaverage (/ (apply '+ zcoords) (float (length zcoords))))
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(if (not (vlax-erased-p (car subentpt)))
(progn
(setq k (1+ k))
(entdel (car subentpt))
(setq entptlst (vl-remove subentpt entptlst))
)
)
)
(if (vlax-erased-p (car entpt))
(progn
(entdel (car entpt))
(setq k (1- k))
(if (not (vl-position entpt entptlst))
(setq entptlst (cons entpt entptlst))
)
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc 10 (entget (car entpt))) (entget (car entpt)))))))
(setq entptlst (subst (list (car entpt) (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc (car entpt) entptlst) entptlst))
)
)
)
)
)
(setq kk 0)
(setq tst (cons nil tst))
(while (not (eval (cons 'and tst)))
(setq z -1 tst nil)
(while (setq entpt (nth (setq z (1+ z)) entptlst))
(foreach subentpt (vl-remove entpt entptlst)
(setq ang (angle (cadr entpt) (cadr subentpt)))
(setq angl (cons ang angl))
)
(setq anglnth (vl-sort-i angl '<))
(setq anglsrt (mapcar '(lambda ( x ) (nth x angl)) anglnth))
(setq angdltl (mapcar '(lambda ( a b ) (- b a)) anglsrt (cdr anglsrt)))
(setq angdnth (vl-sort-i angdltl '<))
(if (zerop (nth (car angdnth) angdltl))
(progn
(setq kk (1+ kk))
(setq angn (nth (car angdnth) anglsrt))
(setq p (polar (cadr entpt) (+ angn (* 0.5 pi)) (* (LM:rand) d)))
(entupd (cdr (assoc -1 (entmod (subst (cons 10 p) (cons 10 (cadr entpt)) (entget (car entpt)))))))
(setq entptlst (subst (list (car entpt) p) (assoc (car entpt) entptlst) entptlst))
(setq tst (cons nil tst))
)
(setq tst (cons t tst))
)
(setq angl nil)
)
)
(prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...")
(prompt "\nTotal : ") (princ kk) (prompt " collinear point entities modifications made to apply slight collinearity...")
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(princ)
)
(defun c:overkill-pts-average-z-rem-collinearity-new ( / LM:rand ss i ent entptlst k zcoords zaverage subentptlst d pl plrand ti )
;; Rand - Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
(setq m 4294967296.0
a 1664525.0
c 1013904223.0
$xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
)
(/ $xn m)
)
(prompt "\nSelect points...")
(setq ss (ssget "_:L" '((0 . "POINT"))))
(initget 6)
(setq d (getdist "\nPick or specify fuzz distance for collinearity modifications <0.05> : "))
(if (null d)
(setq d 0.05)
)
(setq ti (car (_vl-times)))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq entptlst (cons (list ent (cdr (assoc 10 (entget ent)))) entptlst))
)
(setq k 0)
(foreach entpt entptlst
(setq subentptlst (vl-remove-if-not '(lambda ( x ) (and (equal (car (cadr entpt)) (car (cadr x)) 1e-2) (equal (cadr (cadr entpt)) (cadr (cadr x)) 1e-2))) entptlst))
(if subentptlst
(progn
(setq zcoords (mapcar 'caddr (mapcar 'cadr subentptlst)))
(setq zaverage (/ (apply '+ zcoords) (float (length zcoords))))
(setq subentptlst (vl-remove entpt subentptlst))
(foreach subentpt subentptlst
(if (not (vlax-erased-p (car subentpt)))
(progn
(setq k (1+ k))
(entdel (car subentpt))
(setq entptlst (vl-remove subentpt entptlst))
)
)
)
(if (vlax-erased-p (car entpt))
(progn
(entdel (car entpt))
(setq k (1- k))
(if (not (vl-position entpt entptlst))
(setq entptlst (cons entpt entptlst))
)
(entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc 10 (entget (car entpt))) (entget (car entpt)))))))
(setq entptlst (subst (list (car entpt) (list (car (cadr entpt)) (cadr (cadr entpt)) zaverage)) (assoc (car entpt) entptlst) entptlst))
)
)
)
)
)
(setq pl (mapcar 'cadr entptlst))
(setq plrand (mapcar '(lambda ( x ) (polar x (* (LM:rand) (* 2.0 pi)) (* (LM:rand) d))) pl))
(mapcar '(lambda ( a b / e ) (entupd (cdr (assoc -1 (entmod (subst (cons 10 b) (assoc 10 (entget (setq e (caar (vl-member-if '(lambda ( x ) (equal (cadr x) a 1e-50)) entptlst))))) (entget e))))))) pl plrand)
(prompt "\nTotal : ") (princ k) (prompt " duplicate point entities deleted...")
(prompt "\nTotal : ") (princ (length pl)) (prompt " collinear point entities modifications made to apply slight collinearity...")
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(princ)
)
(defun c:triangulate-UCS-new ( / LM:Rand mid 3D->2D MR:Collinear-p LM:Clockwise-p LM:ConvexHull triangulate ss i p pl ell tl z ppp lay d ti )
;; Rand - Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
(setq m 4294967296.0
a 1664525.0
c 1013904223.0
$xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
)
(/ $xn m)
)
;; Point between 2 points or middle list of values from 2 specified lists p1 and p2
(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)
;; 3D to 2D point - M.R.
;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
(defun 3D->2D ( p )
(if (and (listp p) (vl-every '(lambda ( x ) (eq (type x) 'REAL)) p) (eq (length p) 3))
(list (car p) (cadr p))
p
)
)
;; Collinear-p - M.R.
;; Returns T if p1,p2,p3 are collinear
(defun MR:Collinear-p ( p1 p2 p3 )
(equal (distance p1 p3)
(+ (distance p1 p2) (distance p2 p3))
1e-8
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst (vl-remove p0 lst))
(setq lst (append (list p0) lst))
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (MR:Collinear-p (3D->2D (caddr ch)) (3D->2D (cadr ch)) (3D->2D pt))))
(setq ch (cons pt (cddr ch)))
)
)
(reverse ch)
)
)
)
;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
(defun triangulate ( pl factor / tl pll getcircumcircle xmin xmax ymin ymax cs pmin pmax t1 t2 t3 al la p el tr l n m str och ich iche i all elll loop )
(defun getcircumcircle ( p el / circumcircle cp cr rr )
(defun circumcircle ( p1 p2 p3 / ang c r )
(if
(not
(zerop
(setq ang (- (angle p2 p3) (angle p2 p1)))
)
)
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance p1 p3) (sin ang) 2.0)))
r (abs r)
)
)
(list c r)
)
(setq cp (car (setq cr (circumcircle (3D->2D p) (3D->2D (car el)) (3D->2D (cadr el))))) rr (cadr cr))
(if (and cp rr)
(list (+ (car cp) rr) cp rr (list p (car el) (cadr el))) ;;; Added X max of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
(polar p (+ (angle (car el) p) (* 0.5 pi)) (* (LM:Rand) d))
)
)
(setq pll pl)
(setq xmin (caar (setq pl (vl-sort pl '(lambda ( a b ) (< (car a) (car b))))))) ;;; Sorted pl by X ;;;
(setq xmax (caar (vl-sort pl '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(setq t1 (polar cs 0.0 (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt factor (+ n 2)))))) ;;; Added 0.0 in polar for rotating supertriangle t1 is max X apex ;;;
;;(setq t1 (polar cs 0.0 (setq rs (* 2.0 factor (distance pmin cs)))))
(setq t2 (polar cs (+ 0.0 (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ 0.0 (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list (car t1) cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (car tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(setq m -1 all al elll el loop t)
(while loop
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(progn
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(setq loop nil)
)
)
(progn
(while
(and
(setq la (vl-remove-if '(lambda ( x ) (= 4 (length x))) al))
(nth (setq m (1+ m)) la)
(equal p (setq p (nth m la)) 1e-8)
)
)
(setq al all el elll)
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(setq loop nil)
)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
(setq pl pll)
;; och - outside convex hull ring of points
;; ich - inside convex hull ring of points (convex hull obtained from rest of points when och was removed)
(if (null ell)
(progn
(setq el (mapcar '(lambda ( a b ) (list a b)) (setq och (LM:ConvexHull pll)) (cdr (reverse (cons (car och) (reverse och))))))
(mapcar '(lambda ( x ) (setq pll (vl-remove x pll))) och)
(setq ich (LM:ConvexHull pll))
)
)
(if ich
(progn
(setq ell t)
(foreach e el
(if (not (vl-some '(lambda ( x ) (and (member (car e) x) (member (cadr e) x))) tl))
(progn
(setq ich (vl-sort ich '(lambda ( a b ) (< (distance a (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance b (mid (3D->2D (car e)) (3D->2D (cadr e))))))))
(setq iche (vl-remove-if '(lambda ( x ) (> (distance x (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance (car e) (mid (3D->2D (car e)) (3D->2D (cadr e)))))) ich))
(foreach p iche
(if (or
(and
(vl-some '(lambda ( x ) (if (and (member (car e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (car e) x) (member p x))) (vl-remove tr tl))
)
(and
(vl-some '(lambda ( x ) (if (and (member (cadr e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (cadr e) x) (member p x))) (vl-remove tr tl))
)
)
(setq iche (vl-remove p iche))
)
)
(setq i (length iche))
(setq iche (cons (car e) iche) iche (cons (cadr e) iche))
(if (null z)
(setq z 10.0)
)
(setq z
(cond
( (<= i (length (car (triangulate iche 10.0))))
(if (>= z 10.0)
z
(setq z 10.0)
)
)
( (<= i (length (car (triangulate iche 25.0))))
(if (>= z 25.0)
z
(setq z 25.0)
)
)
( (<= i (length (car (triangulate iche 50.0))))
(if (>= z 50.0)
z
(setq z 50.0)
)
)
( (<= i (length (car (triangulate iche 100.0))))
(if (>= z 100.0)
z
(setq z 100.0)
)
)
( (<= i (length (car (triangulate iche 250.0))))
(if (>= z 250.0)
z
(setq z 250.0)
)
)
( (<= i (length (car (triangulate iche 500.0))))
(if (>= z 500.0)
z
(setq z 500.0)
)
)
( (<= i (length (car (triangulate iche 1000.0))))
(if (>= z 1000.0)
z
(setq z 1000.0)
)
)
)
)
)
)
)
)
)
(list tl (if (null z) factor z))
) ;;; end of triangulate
(prompt "\nSelect points...")
(setq ss (ssget '((0 . "POINT"))))
(initget 6)
(setq d (getdist "\nPick or specify fuzz distance for collinearity modifications <0.05> : "))
(if (null d)
(setq d 0.05)
)
(setq ti (car (_vl-times)))
(repeat (setq i (sslength ss))
(setq p (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1))
(setq pl (cons p pl))
)
(setq z (cadr (triangulate pl 10.0)))
(foreach tr (car (triangulate pl z))
(entmake
(list (cons 0 "3DFACE")
(cons 10 (trans (car tr) 1 0))
(cons 11 (trans (car tr) 1 0))
(cons 12 (trans (cadr tr) 1 0))
(cons 13 (trans (caddr tr) 1 0))
)
)
(setq ppp (cons (trans (car tr) 1 0) ppp) ppp (cons (trans (cadr tr) 1 0) ppp) ppp (cons (trans (caddr tr) 1 0) ppp))
)
(setq lay (cdr (assoc 8 (entget (ssname ss 0)))))
(command "_.ERASE" ss "")
(while (setq p (car ppp))
(if (not (vl-position p (setq ppp (cdr ppp))))
(entmake
(list (cons 0 "POINT") (cons 10 p) (cons 8 lay))
)
)
)
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
(princ)
)
(defun c:triangulate-UCS-new ( / LM:Rand mid 3D->2D MR:Collinear-p LM:Clockwise-p LM:ConvexHull triangulate ss i p pl ell tl z ppp lay d ti )
;; Rand - Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
(setq m 4294967296.0
a 1664525.0
c 1013904223.0
$xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
)
(/ $xn m)
)
;; Point between 2 points or middle list of values from 2 specified lists p1 and p2
(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)
;; 3D to 2D point - M.R.
;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
(defun 3D->2D ( p )
(if (and (listp p) (vl-every '(lambda ( x ) (eq (type x) 'REAL)) p) (eq (length p) 3))
(list (car p) (cadr p))
p
)
)
;; Collinear-p - M.R.
;; Returns T if p1,p2,p3 are collinear
(defun MR:Collinear-p ( p1 p2 p3 )
(equal (distance p1 p3)
(+ (distance p1 p2) (distance p2 p3))
1e-8
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst (vl-remove p0 lst))
(setq lst (append (list p0) lst))
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (MR:Collinear-p (3D->2D (caddr ch)) (3D->2D (cadr ch)) (3D->2D pt))))
(setq ch (cons pt (cddr ch)))
)
)
(reverse ch)
)
)
)
;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
(defun triangulate ( pl factor / tl pll getcircumcircle xmin xmax ymin ymax cs pmin pmax t1 t2 t3 al la all p el tr l n m str och ich iche i tll loop )
(defun getcircumcircle ( p el / circumcircle cp cr rr )
(defun circumcircle ( p1 p2 p3 / ang c r )
(if
(not
(zerop
(setq ang (- (angle p2 p3) (angle p2 p1)))
)
)
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance p1 p3) (sin ang) 2.0)))
r (abs r)
)
)
(list c r)
)
(setq cp (car (setq cr (circumcircle (3D->2D p) (3D->2D (car el)) (3D->2D (cadr el))))) rr (cadr cr))
(if (and cp rr)
(list (+ (car cp) rr) cp rr (list p (car el) (cadr el))) ;;; Added X max of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
(polar p (+ (angle (car el) p) (* 0.5 pi)) (* (LM:Rand) d))
)
)
(setq xmin (caar (setq pl (vl-sort pl '(lambda ( a b ) (< (car a) (car b))))))) ;;; Sorted pl by X ;;;
(setq xmax (caar (vl-sort pl '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(setq t1 (polar cs 0.0 (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt factor (+ n 2)))))) ;;; Added 0.0 in polar for rotating supertriangle t1 is max X apex ;;;
;;(setq t1 (polar cs 0.0 (setq rs (* 2.0 factor (distance pmin cs)))))
(setq t2 (polar cs (+ 0.0 (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ 0.0 (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list (car t1) cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq m -1 all al tll tl loop t)
(while loop
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(progn
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (car tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(setq loop nil)
)
)
(progn
(while
(and
(setq la (vl-remove-if '(lambda ( x ) (= 4 (length x))) al))
(nth (setq m (1+ m)) la)
(equal p (setq p (nth m la)) 1e-8)
)
)
(setq el nil al all tl tll)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (car tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
(if (vl-every '(lambda ( x ) (= 4 (length x))) al)
(setq loop nil)
)
)
)
)
(setq pll (cons p pll))
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
(setq pll (reverse pll) pl pll)
;; och - outside convex hull ring of points
;; ich - inside convex hull ring of points (convex hull obtained from rest of points when och was removed)
(if (null ell)
(progn
(setq el (mapcar '(lambda ( a b ) (list a b)) (setq och (LM:ConvexHull pll)) (cdr (reverse (cons (car och) (reverse och))))))
(mapcar '(lambda ( x ) (setq pll (vl-remove x pll))) och)
(setq ich (LM:ConvexHull pll))
)
)
(if ich
(progn
(setq ell t)
(foreach e el
(if (not (vl-some '(lambda ( x ) (and (member (car e) x) (member (cadr e) x))) tl))
(progn
(setq ich (vl-sort ich '(lambda ( a b ) (< (distance a (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance b (mid (3D->2D (car e)) (3D->2D (cadr e))))))))
(setq iche (vl-remove-if '(lambda ( x ) (> (distance x (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance (car e) (mid (3D->2D (car e)) (3D->2D (cadr e)))))) ich))
(foreach p iche
(if (or
(and
(vl-some '(lambda ( x ) (if (and (member (car e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (car e) x) (member p x))) (vl-remove tr tl))
)
(and
(vl-some '(lambda ( x ) (if (and (member (cadr e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (cadr e) x) (member p x))) (vl-remove tr tl))
)
)
(setq iche (vl-remove p iche))
)
)
(setq i (length iche))
(setq iche (cons (car e) iche) iche (cons (cadr e) iche))
(if (null z)
(setq z 10.0)
)
(setq z
(cond
( (<= i (length (car (triangulate iche 10.0))))
(if (>= z 10.0)
z
(setq z 10.0)
)
)
( (<= i (length (car (triangulate iche 25.0))))
(if (>= z 25.0)
z
(setq z 25.0)
)
)
( (<= i (length (car (triangulate iche 50.0))))
(if (>= z 50.0)
z
(setq z 50.0)
)
)
( (<= i (length (car (triangulate iche 100.0))))
(if (>= z 100.0)
z
(setq z 100.0)
)
)
( (<= i (length (car (triangulate iche 250.0))))
(if (>= z 250.0)
z
(setq z 250.0)
)
)
( (<= i (length (car (triangulate iche 500.0))))
(if (>= z 500.0)
z
(setq z 500.0)
)
)
( (<= i (length (car (triangulate iche 1000.0))))
(if (>= z 1000.0)
z
(setq z 1000.0)
)
)
)
)
)
)
)
)
)
(list tl (if (null z) factor z))
) ;;; end of triangulate
(prompt "\nSelect points on ulocked layer(s)...")
(setq ss (ssget "_:L" '((0 . "POINT"))))
(initget 6)
(setq d (getdist "\nPick or specify fuzz distance for collinearity modifications <0.05> : "))
(if (null d)
(setq d 0.05)
)
(setq ti (car (_vl-times)))
(if ss
(progn
(repeat (setq i (sslength ss))
(setq p (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1))
(setq pl (cons p pl))
)
(setq z (cadr (triangulate pl 10.0)))
(foreach tr (car (triangulate pl z))
(entmake
(list (cons 0 "3DFACE")
(cons 10 (trans (car tr) 1 0))
(cons 11 (trans (car tr) 1 0))
(cons 12 (trans (cadr tr) 1 0))
(cons 13 (trans (caddr tr) 1 0))
)
)
(setq ppp (cons (trans (car tr) 1 0) ppp) ppp (cons (trans (cadr tr) 1 0) ppp) ppp (cons (trans (caddr tr) 1 0) ppp))
)
(setq lay (cdr (assoc 8 (entget (ssname ss 0)))))
(command "_.ERASE" ss "")
(while (setq p (car ppp))
(if (not (vl-position p (setq ppp (cdr ppp))))
(entmake
(list (cons 0 "POINT") (cons 10 p) (cons 8 lay))
)
)
)
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
)
)
(princ)
)
(defun c:triangulate-UCS-new ( / mid 3D->2D MR:Collinear-p LM:Clockwise-p LM:ConvexHull triangulate ss i p pl ell tl z ti )
;; Point between 2 points or middle list of values from 2 specified lists p1 and p2
(defun mid ( p1 p2 )
(mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
)
;; 3D to 2D point - M.R.
;; Returns 2D point list from supplied 3D point list or returns supplied argument if it isn't 3D point list
(defun 3D->2D ( p )
(if (and (listp p) (vl-every '(lambda ( x ) (eq (type x) 'REAL)) p) (eq (length p) 3))
(list (car p) (cadr p))
p
)
)
;; Collinear-p - M.R.
;; Returns T if p1,p2,p3 are collinear
(defun MR:Collinear-p ( p1 p2 p3 )
(equal (distance p1 p3)
(+ (distance p1 p2) (distance p2 p3))
1e-8
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst (vl-remove p0 lst))
(setq lst (append (list p0) lst))
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< (if (equal c (* 2.0 pi) 1e-8) 0.0 c) (if (equal d (* 2.0 pi) 1e-8) 0.0 d))
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt) (not (MR:Collinear-p (3D->2D (caddr ch)) (3D->2D (cadr ch)) (3D->2D pt))))
(setq ch (cons pt (cddr ch)))
)
)
(reverse ch)
)
)
)
;; Triangulate - subfunction for drawing Delunay triangulation from specified list of points with provided factor for checking weather calcualted triangulation is convex hull boundary triangulation
;; Returns list of 2 elements - first element is list of triangles defined by 3 points forming triangle and second element is calculated factor for forming supertriangle for next call of triangulate function for gathering correct convex hull boundary of triangulation triangles
(defun triangulate ( pl factor / tl pll getcircumcircle xmin xmax ymin ymax cs pmin pmax t1 t2 t3 al p el tr l n str och ich iche i )
(defun getcircumcircle ( p el / circumcircle cp cr rr )
(defun circumcircle ( p1 p2 p3 / ang c r )
(if
(not
(zerop
(setq ang (- (angle p2 p3) (angle p2 p1)))
)
)
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance p1 p3) (sin ang) 2.0)))
r (abs r)
)
)
(list c r)
)
(setq cp (car (setq cr (circumcircle (3D->2D p) (3D->2D (car el)) (3D->2D (cadr el))))) rr (cadr cr))
(if (and cp rr)
(list (+ (car cp) rr) cp rr (list p (car el) (cadr el))) ;;; Added X max of circumscribed triangle circle as first element of (getcircumcircle) output list ;;;
(progn
(cond
( (MR:Collinear-p (3D->2D p) (3D->2D (car el)) (3D->2D (cadr el)))
(setq cp (list (/ (+ (car p) (car (cadr el))) 2.0) (/ (+ (cadr p) (cadr (cadr el))) 2.0)))
)
( (MR:Collinear-p (3D->2D (car el)) (3D->2D p) (3D->2D (cadr el)))
(setq cp (list (/ (+ (car (car el)) (car (cadr el))) 2.0) (/ (+ (cadr (car el)) (cadr (cadr el))) 2.0)))
)
( (MR:Collinear-p (3D->2D (car el)) (3D->2D (cadr el)) (3D->2D p))
(setq cp (list (/ (+ (car (car el)) (car p)) 2.0) (/ (+ (cadr (car el)) (cadr p)) 2.0)))
)
)
(setq rr (max (distance (3D->2D p) cp) (distance (3D->2D (car el)) cp) (distance (3D->2D (cadr el)) cp)))
(list (+ (car cp) rr) cp rr (list p (car el) (cadr el)))
)
)
)
(setq pll pl)
(setq xmin (caar (setq pl (vl-sort pl '(lambda ( a b ) (< (car a) (car b))))))) ;;; Sorted pl by X ;;;
(setq xmax (caar (vl-sort pl '(lambda ( a b ) (> (car a) (car b))))))
(setq ymin (cadar (vl-sort pl '(lambda ( a b ) (< (cadr a) (cadr b))))))
(setq ymax (cadar (vl-sort pl '(lambda ( a b ) (> (cadr a) (cadr b))))))
(setq cs (list (+ xmin (/ (- xmax xmin) 2.0)) (+ ymin (/ (- ymax ymin) 2.0))))
(setq pmin (list xmin ymin) pmax (list xmax ymax))
(setq t1 (polar cs 0.0 (if (setq n (atoi (substr (setq str (rtos (distance pmin cs) 1 0)) (- (strlen str) 2)))) (setq rs (expt factor (+ n 2)))))) ;;; Added 0.0 in polar for rotating supertriangle t1 is max X apex ;;;
;;(setq t1 (polar cs 0.0 (setq rs (* 2.0 factor (distance pmin cs)))))
(setq t2 (polar cs (+ 0.0 (/ (* 2.0 pi) 3.0)) rs))
(setq t3 (polar cs (+ 0.0 (/ (* 4.0 pi) 3.0)) rs))
(setq al (list (list (car t1) cs rs (list t1 t2 t3))))
(while pl
(setq p (car pl))
(setq pl (cdr pl))
(setq el nil)
(while al
(setq tr (car al))
(setq al (cdr al))
(cond
( (< (car tr) (car p)) ;;; Comparison of X values ;;;
(setq tl (cons (cadddr tr) tl))
)
( (< (distance p (cadr tr)) (caddr tr))
(setq el (append (list
(list (car (last tr)) (cadr (last tr)))
(list (cadr (last tr)) (caddr (last tr)))
(list (caddr (last tr)) (car (last tr)))
) el
)
)
)
( t (setq l (cons tr l)) )
)
)
(if l (setq al l l nil))
(while el ;;; el - edge list = ((a b) (b c) (c a) (d e) (e f) (f d) ... )
(if (or (member (reverse (car el)) el)
(member (car el) (cdr el))
)
(setq el (vl-remove (reverse (car el)) el)
el (vl-remove (car el) el)
)
(setq al (cons (getcircumcircle p (car el)) al)
el (cdr el)
)
)
)
)
(foreach tr al (setq tl (cons (cadddr tr) tl)))
(setq tl (vl-remove-if '(lambda ( x ) (or (member t1 x) (member t2 x) (member t3 x))) tl))
(setq pl pll)
;; och - outside convex hull ring of points
;; ich - inside convex hull ring of points (convex hull obtained from rest of points when och was removed)
(if (null ell)
(progn
(setq el (mapcar '(lambda ( a b ) (list a b)) (setq och (LM:ConvexHull pll)) (cdr (reverse (cons (car och) (reverse och))))))
(mapcar '(lambda ( x ) (setq pll (vl-remove x pll))) och)
(setq ich (LM:ConvexHull pll))
)
)
(if ich
(progn
(setq ell t)
(foreach e el
(if (not (vl-some '(lambda ( x ) (and (member (car e) x) (member (cadr e) x))) tl))
(progn
(setq ich (vl-sort ich '(lambda ( a b ) (< (distance a (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance b (mid (3D->2D (car e)) (3D->2D (cadr e))))))))
(setq iche (vl-remove-if '(lambda ( x ) (> (distance x (mid (3D->2D (car e)) (3D->2D (cadr e)))) (distance (car e) (mid (3D->2D (car e)) (3D->2D (cadr e)))))) ich))
(foreach p iche
(if (or
(and
(vl-some '(lambda ( x ) (if (and (member (car e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (car e) x) (member p x))) (vl-remove tr tl))
)
(and
(vl-some '(lambda ( x ) (if (and (member (cadr e) x) (member p x)) (setq tr x))) tl)
(vl-some '(lambda ( x ) (and (member (cadr e) x) (member p x))) (vl-remove tr tl))
)
)
(setq iche (vl-remove p iche))
)
)
(setq i (length iche))
(setq iche (cons (car e) iche) iche (cons (cadr e) iche))
(if (null z)
(setq z 10.0)
)
(setq z
(cond
( (<= i (length (car (triangulate iche 10.0))))
(if (>= z 10.0)
z
(setq z 10.0)
)
)
( (<= i (length (car (triangulate iche 25.0))))
(if (>= z 25.0)
z
(setq z 25.0)
)
)
( (<= i (length (car (triangulate iche 50.0))))
(if (>= z 50.0)
z
(setq z 50.0)
)
)
( (<= i (length (car (triangulate iche 100.0))))
(if (>= z 100.0)
z
(setq z 100.0)
)
)
( (<= i (length (car (triangulate iche 250.0))))
(if (>= z 250.0)
z
(setq z 250.0)
)
)
( (<= i (length (car (triangulate iche 500.0))))
(if (>= z 500.0)
z
(setq z 500.0)
)
)
( (<= i (length (car (triangulate iche 1000.0))))
(if (>= z 1000.0)
z
(setq z 1000.0)
)
)
)
)
)
)
)
)
)
(list tl (if (null z) factor z))
) ;;; end of triangulate
(prompt "\nSelect points...")
(setq ss (ssget '((0 . "POINT"))))
(setq ti (car (_vl-times)))
(if ss
(progn
(repeat (setq i (sslength ss))
(setq p (trans (cdr (assoc 10 (entget (ssname ss (setq i (1- i)))))) 0 1))
(setq pl (cons p pl))
)
(setq z (cadr (triangulate pl 10.0)))
(foreach tr (car (triangulate pl z))
(entmake
(list (cons 0 "3DFACE")
(cons 10 (trans (car tr) 1 0))
(cons 11 (trans (car tr) 1 0))
(cons 12 (trans (cadr tr) 1 0))
(cons 13 (trans (caddr tr) 1 0))
)
)
)
(prompt "\nElapsed time : ") (princ (rtos (/ (- (car (_vl-times)) ti) 1000.0) 2 50)) (prompt " seconds.")
)
)
(princ)
)
Hi ymg. Where are you ? Are you ok ?
Any new update ?
Marko,
Everything is fine with me, just been away from CAD for the past 5 or 6 months.
Still doing renovation.
Sorry about the lack of progress.
ymg
Hello, there are not many updates, checking the current functions I have realized that many of the functions only run when using TIN, if one closes the drawing can no longer use other functions, since many of them use variables that when closing the Drawing left in NIL or empty, an example of TL variable, ie a function like DEMOZ does not work if not used TIN, every time we use DEMOZ we must use TIN again, it would be nice to be able to solve this, thanks
ribarm, Oh well, thanks for everything !!!
It's here (in post 475)
https://www.theswamp.org/index.php?topic=9042.msg555891#msg555891
Mathias
;;; Delaunay Triangulation ALISP by M.R. ( Marko Ribar, d.i.a. - architect )
;;; Example without supertriangle and with convex hull triangles - optimized as possible - using (vl-some) loops extensively...
;;; Delaunay Triangulation ALISP by M.R. ( Marko Ribar, d.i.a. - architect )
;;; Example without supertriangle and with convex hull triangles - optimized as possible - using (while) loops extensively...
;; Evgeniy Elpanov optimized (circumcircle) sub function
(defun circum ( p1 p2 p3 / ang c r )
(if (not (zerop (setq ang (- (angle p2 p3) (angle p2 p1)))))
(setq c (polar p3 (+ -1.570796326794896 (angle p3 p1) ang) (setq r (/ (distance (mapcar '+ '(0.0 0.0) p1) p3) (sin ang) 2.0)))
r (abs r)
)
)
(list (if c (list (car c) (cadr c))) r)
)
(defun remove-dupl-points ( l / l1 )
(setq l (vl-sort l (function (lambda ( a b ) (< (caddr a) (caddr b))))))
(while (car l)
(setq l1 (cons (car l) (vl-remove-if (function (lambda ( x ) (equal (list (car x) (cadr x)) (list (caar l) (cadar l)) 1e-8))) l1)))
(setq l (cdr l))
)
l1
)
ribarm,
Can you upload revised "Triang" lisp?
...
(if
(and
(setq q (circum (car e) (cadr e) x))
(car q)
(not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
(not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
)
(progn
(setq trl (cons (list (car e) (cadr e) x) trl))
(if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
(setq el (cons (list (cadr e) x) el) ell (cons (list (cadr e) x) ell))
(setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
)
(if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
(setq el (cons (list (car e) x) el) ell (cons (list (car e) x) ell))
(setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
)
...
...
(if
(and
(setq q (circum (car e) (cadr e) x))
(car q)
(not (ptincir (car q) (cadr q) (vl-remove (car e) (vl-remove (cadr e) (vl-remove x (append xx pl))))))
(not (vl-some (function (lambda ( tr ) (and (vl-position (car e) tr) (vl-position (cadr e) tr) (vl-position x tr)))) trl))
)
(progn
(setq trl (cons (list (car e) (cadr e) x) trl))
(if (not (or (vl-position (list (cadr e) x) el) (vl-position (list x (cadr e)) el)))
(setq el (cons (list (cadr e) x) el))
(setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (cadr e) x) ee) (equal (list x (cadr e)) ee)))) el))
)
(setq ell (cons (list (cadr e) x) ell))
(if (not (or (vl-position (list (car e) x) el) (vl-position (list x (car e)) el)))
(setq el (cons (list (car e) x) el))
(setq el (vl-remove-if (function (lambda ( ee ) (or (equal (list (car e) x) ee) (equal (list x (car e)) ee)))) el))
)
(setq ell (cons (list (car e) x) ell))
...
which is ALISP codes that are terribly slow...yes it is significantly slower than compiled executables but much depends on algorithms and optimization
which is ALISP codes that are terribly slow...yes it is significantly slower than compiled executables but much depends on algorithms and optimization
your code is quite long so it is not easy (especially for a stranger like me) to tell where's the flaw
but i'm sure there is a way to make the code run faster
What should the triangles look like for these four points?
... the point of this forum is for users helping users understand and write their own lisp code . compiling the code does not reflect what this forum is for .I am totally agree with you . But , to copy from a lisp file , will not help anybody to learn something .
CostinBos77, do you know if this program works with GStarCAD or ZWCAD??
Hi,
It has been many years since this topic, but regretted that no updates have been received after Lisp triang v.0.6.7. I will request to all members please keep updating Lisp.
Hihttps://www.theswamp.org/index.php?topic=9042.msg555891#msg555891
Can someone plz share Triang V0.6.7
I couldn't find it.
Thanks in advance
Thank you :-DYou're welcome.
Help me!
I used lisp Triangulation v.0.6.7. But I want to create a Tin surface form Autocad like C3D.
Hi everyone.
Can enyone check this file. In my opinion function PROF works wrong with this settings.
pawcyk
Hihttps://www.theswamp.org/index.php?topic=9042.msg555891#msg555891
Can someone plz share Triang V0.6.7
I couldn't find it.
narasimharaoarza0211@gmail.com
Good morning Sir
I am trying to do tin with triangv0.6.7.lsp, but it is not forming tin .
I am attaching a drawing for your kind reference.
Please help me in this regard.
;; Insertion of Constraints ;
(if cdtl ;; cdtl, List of Points (3d) Forming Constraints
(progn
(setq ti (time))
(acet-ui-progress "Inserting Constraint:" (length cdtl)) ;; starts acet-ui-progress bar
(mk_layer (list ".SRF-NET" 9)) ;; color 9: ashes
(rw_disablesnap)
(foreach k cdtl
(rw_FlipEdge (car k) (cadr k)) ;; sends x & y only
(progress-step nil) ;; rw_FlipEdge is a rename for ADDEDGE
) ;; I was avoiding a possible naming conflict
(rw_RebuildNet) ;; THIS IS HOW I REBUILT THE TIN NETWORK ... I ADMIT IT IS A HACK!
(rw_enablesnap)
(acet-ui-progress) ;; ends acet-ui-progress bar
(if *bounden* (erase-outside *bounden*))
(defun rw_RebuildNet () ;; I USED COMMAND METHOD TO AVOID THE DXF ISSUE WITH BRICSCAD
(C:JNK)
(foreach tr tl
(cond
((= (length tr) 3) ;; triangle *** CONSTRUCT TIN ***
(setq p1 (nth (car tr) pl))
(setq p2 (nth (cadr tr) pl))
(setq p3 (nth (caddr tr) pl))
(command "3dface" p1 p2 p3 "" "")
(setq 3DFL (cons (cadddr tr) 3DFL)) ;; update 3dfl
)
((= (length tr) 4) ;; rectangle *** CONCTRUCT SHEET *** NOT USED ***
(setq p1 (nth (car tr) pl))
(setq p2 (nth (cadr tr) pl))
(setq p3 (nth (caddr tr) pl))
(setq cutlist (cdr tr))
(setq p4 (nth (caddr cutlist) pl))
(command "3dface" p1 p2 p3 p4 "")
(setq 3DFL (cons (cadddr tr) 3DFL)) ;; update 3dfl
)
)
)
)
(defun C:JNK ( / Target_Lyr) ;; Junk: deletes TIN group ;; IMP: rebuilds the TIN group
(setq *osm* (getvar 'osmode))
(defun *error* (errmsg)
(if *osm* (setvar 'osmode *osm*))
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(princ)
)
;;
(setq LstLyr (getvar 'clayer))
(setq Target_Lyr ".SRF-NET")
(Delete_Lyr_Items Target_Lyr)
(setvar 'clayer LstLyr)
)
Maybe you can you undefine/redefine BricsCAD’s TIN command?