;******************************************************************;
; 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/~pbour...ng/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 . "insert"))))
(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)