AutoLISP: Fillet a 3D Polyline

Here is a great routine that lets you easily fillet a 3D polyline. It even gives the option to apply the fillet to all of the vertices.

Here’s how:

  • 3DPOLYFILLET <enter> to start
  • R <enter> to specify the radius of the fillet
  • Specify the radius <enter>
  • Select the segments for the fillet
  • Or
  • Select the first segment and then enter A <enter> to apply the fillet to all segments.


;;; 3dPolyFillet -Gilles Chanteau- 21/01/07 -Version 1.5-
;;; "Fillets" a 3D polyline (succession of segments)

(defun c:3dPolyFillet (/	   3dPolyFillet_err	   closest_vertices
		       MakeFillet  AcDoc       ModSp	   cnt
		       prec	   rad	       ent1	   ent2
		       vxlst	   plst	       param	   obj
		      )
  (vl-load-com)

;;;*************************************************************;;;

  (defun 3dPolyFillet_err (msg)
    (if	(= msg "Fonction annulée")
      (princ)
      (princ (strcat "\nErreur: " msg))
    )
    (vla-EndUndoMark AcDoc)
    (setq *error* m:err
	  m:err	nil
    )
    (princ)
  )

;;;*************************************************************;;;

  (defun closest_vertices (obj pt / par)
    (if	(setq par (vlax-curve-getParamAtPoint obj pt))
      (list (vlax-curve-getPointAtParam obj (fix par))
	    (vlax-curve-getPointAtParam obj (1+ (fix par)))
      )
    )
  )

;;;*************************************************************;;;

  (defun MakeFillet (obj   par1	 par2  /     pts1  pts2	 som   p1    p2
		     ptlst norm	 pt0   pt1   pt2   pt3	 pt4   cen   ang
		     inc   n	 vlst  nb1   nb2
		    )
    (if	(and
	  (setq pts1 (closest_vertices obj par1))
	  (setq pts2 (closest_vertices obj par2))
	)
      (progn
	(setq som (inters (car pts1) (cadr pts1) (car pts2) (cadr pts2) nil))
	(if som
	  (if
	    (or	(equal (car pts1) som 1e-9)
		(equal (cadr pts1) som 1e-9)
		(and
		  (< (vlax-curve-getParamAtPoint obj (car pts1))
		     (vlax-curve-getParamAtPoint obj (car pts2))
		  )
		  (equal (vec1 (car pts1) (cadr pts1))
			 (vec1 (car pts1) som)
			 1e-9
		  )
		)
		(and
		  (< (vlax-curve-getParamAtPoint obj (car pts2))
		     (vlax-curve-getParamAtPoint obj (car pts1))
		  )
		  (equal (vec1 (cadr pts1) (car pts1))
			 (vec1 (cadr pts1) som)
			 1e-9
		  )
		)
	    )
	     (progn
	       (if (< (distance som (car pts1)) (distance som (cadr pts1)))
		 (setq p1 (cadr pts1)
		       p2 (car pts2)
		 )
		 (setq p1 (car pts1)
		       p2 (cadr pts2)
		 )
	       )
	       (if (= rad 0)
		 (setq ptlst (list som))
		 (progn
		   (setq norm (norm_3pts som p2 p1)
			 pt0  (trans som 0 norm)
			 pt1  (trans p1 0 norm)
			 pt2  (trans p2 0 norm)
			 cen  (inters
				(polar pt0 (- (angle pt0 pt1) (/ pi 2)) rad)
				(polar pt1 (- (angle pt0 pt1) (/ pi 2)) rad)
				(polar pt0 (+ (angle pt0 pt2) (/ pi 2)) rad)
				(polar pt2 (+ (angle pt0 pt2) (/ pi 2)) rad)
				nil
			      )
			 pt3  (polar cen (- (angle pt1 pt0) (/ pi 2)) rad)
			 pt4  (polar cen (+ (angle pt2 pt0) (/ pi 2)) rad)
			 ang  (- (angle cen pt4) (angle cen pt3))
		   )
		   (if
		     (and (inters pt0 pt1 cen pt3 T) (inters pt0 pt2 cen pt4 T))
		      (progn
			(if (minusp ang)
			  (setq ang (+ (* 2 pi) ang))
			)
			(setq inc (/ ang prec)
			      n	  0
			)
			(repeat	(1+ prec)
			  (setq	ptlst (cons
					(polar cen (- (angle cen pt4) (* inc n)) rad)
					ptlst
				      )
				n     (1+ n)
			  )
			)
			(setq ptlst (mapcar '(lambda (p) (trans p norm 0)) ptlst))
		      )
		   )
		 )
	       )
	       (setq vlst (3d-coord->pt-lst (vlax-get obj 'Coordinates)))
	       (if ptlst
		 (progn
		   (setq nb1 (vl-position p1 vlst)
			 nb2 (vl-position p2 vlst)
		   )
		   (if (= (vla-get-closed obj) :vlax-true)
		     (cond
		       ((and (equal p1 (car vlst))
			     (equal p2 (cadr (reverse vlst)))
			)
			(setq
			  vlst
			   (append (sublst vlst 1 (1+ nb2)) (reverse ptlst))
			)
		       )
		       ((and (equal p1 (cadr (reverse vlst)))
			     (equal p2 (car vlst))
			)
			(setq vlst (append (sublst vlst 1 (1+ nb1)) ptlst))
		       )
		       ((and (equal p1 (cadr vlst))
			     (equal p2 (last vlst))
			)
			(setq
			  vlst
			   (append (reverse ptlst) (sublst vlst (1+ nb1) nil))
			)
		       )
		       ((and (equal p1 (last vlst))
			     (equal p2 (cadr vlst))
			)
			(setq vlst (append ptlst (sublst vlst (1+ nb2) nil))
			)
		       )
		       (T
			(if (< nb1 nb2)
			  (setq	vlst (append (sublst vlst 1 (1+ nb1))
					     ptlst
					     (sublst vlst (1+ nb2) nil)
				     )
			  )
			  (setq	vlst (append (sublst vlst 1 (1+ nb2))
					     (reverse ptlst)
					     (sublst vlst (1+ nb1) nil)
				     )
			  )
			)
		       )
		     )
		     (if (equal (car vlst) (last vlst) 1e-9)
		       (cond
			 ((and (equal p1 (cadr vlst))
			       (equal p2 (cadr (reverse vlst)))
			  )
			  (setq	vlst (append (sublst vlst 2 nb2)
					     (reverse ptlst)
					     (list (cadr vlst))
				     )
			  )
			 )
			 ((and (equal p1 (cadr (reverse vlst)))
			       (equal p2 (cadr vlst))
			  )
			  (setq	vlst (append (sublst vlst 2 nb1)
					     ptlst
					     (list (cadr vlst))
				     )
			  )
			 )
		       )
		       (if (< nb1 nb2)
			 (setq vlst (append (sublst vlst 1 (1+ nb1))
					    ptlst
					    (sublst vlst (1+ nb2) nil)
				    )
			 )
			 (setq vlst (append (sublst vlst 1 (1+ nb2))
					    (reverse ptlst)
					    (sublst vlst (1+ nb1) nil)
				    )
			 )
		       )
		     )
		   )
		   (vlax-put obj 'Coordinates (apply 'append vlst))
		 )
		 (prompt "\nRadius is too large.")
	       )
	     )
	     (prompt "\nDivergent segments.")
	  )
	  (prompt "\nSegments are not converging.")
	)
      )
      (prompt "\nRadius is too large.")
    )
  )




;;;*************************************************************;;;

  (setq	AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
	ModSp (vla-get-ModelSpace AcDoc)
  )
  (setq	m:err	*error*
	*error*	3dPolyFillet_err
  )
  (vla-StartUndoMark AcDoc)

  ;; Saisie des données
  (if (not (vlax-ldata-get "3dFillet" "Prec"))
    (vlax-ldata-put "3dFillet" "Prec" 20)
  )
  (if (not (vlax-ldata-get "3dFillet" "Rad"))
    (vlax-ldata-put "3dFillet" "Rad" 10.0)
  )
  (prompt (strcat "\nCurrent settings.\tSegments: "
		  (itoa (vlax-ldata-get "3dFillet" "Prec"))
		  "\tRadius: "
		  (rtos (vlax-ldata-get "3dFillet" "Rad"))
	  )
  )
  (setq cnt 1)
  (while (= 1 cnt)
    (initget 1 "Segments Radius")
    (setq ent1
	   (entsel
	     "\nSelect first segment ou [Segments/Radius]: "
	   )
    )
    (cond
      ((not ent1)
       (prompt "\nNone selected object.")
      )
      ((= ent1 "Segments")
       (initget 6)
       (if (setq prec
		  (getint
		    (strcat "\nSpecify le number of segments for arcs <"
			    (itoa (vlax-ldata-get "3dFillet" "Prec"))
			    ">: "
		    )
		  )
	   )
	 (vlax-ldata-put "3dFillet" "Prec" prec)
       )
      )
      ((= ent1 "Radius")
       (initget 4)
       (if (setq rad
		  (getdist
		    (strcat "\nSpecify the radius <"
			    (rtos (vlax-ldata-get "3dFillet" "Rad"))
			    ">: "
		    )
		  )
	   )
	 (vlax-ldata-put "3dFillet" "Rad" rad)
       )
      )
      ((and
	 (= (cdr (assoc 0 (entget (car ent1)))) "POLYLINE")
	 (= (logand 8 (cdr (assoc 70 (entget (car ent1))))) 8)
       )
       (setq cnt 0)
      )
      (T
       (prompt "\nSelected object is not a 3D polyline.")
      )
    )
  )
  (setq	prec (vlax-ldata-get "3dFillet" "Prec")
	rad  (vlax-ldata-get "3dFillet" "Rad")
  )
  (while (not ent2)
    (initget 1 "All")
    (setq ent2 (entsel "\nSelect second segment or [All]: "))
    (if	(not (or (= ent2 "All") (eq (car ent1) (car ent2))))
      (progn
	(prompt
	  "\nThe selected segment is not on same object"
	)
	(setq ent2 nil)
      )
    )
  )
  (setq obj (vlax-ename->vla-object (car ent1)))
  (if (= ent2 "All")
    (progn
      (setq vxlst (3d-coord->pt-lst (vlax-get obj 'Coordinates))
	    param 0.5
      )
      (repeat (if (= (vla-get-closed obj) :vlax-true) (length vxlst) (1- (length vxlst)))
	(setq plst  (append plst (list (vlax-curve-getPointAtParam obj param)))
	      param (1+ param)
	)
      )
      (if (or (= (vla-get-closed obj) :vlax-true)
	      (equal (car vxlst) (last vxlst) 1e-9)
	      )
	(setq plst (cons (last plst) plst))
	)
      (setq cnt 0)
	  (repeat (1- (length plst))
	    (MakeFillet obj (nth cnt plst) (nth (setq cnt (1+ cnt)) plst))
	  )
    )
    (MakeFillet	obj
		(trans (osnap (cadr ent1) "_nea") 1 0)
		(trans (osnap (cadr ent2) "_nea") 1 0)
    )
  )
  (vla-EndUndoMark AcDoc)
  (setq	*error*	m:err
	m:err nil
  )
  (princ)
)

;;;*************************************************************;;;
;;;*********************** SOUS ROUTINES ***********************;;;


;;; NORM_3PTS returns the normal vector of a 3 points defined plane

(defun norm_3pts (org xdir ydir / norm)
  (foreach v '(xdir ydir)
    (set v (mapcar '- (eval v) org))
  )
  (if (inters org xdir org ydir)
    (mapcar '(lambda (x) (/ x (distance '(0 0 0) norm)))
	    (setq norm (list (-	(* (cadr xdir) (caddr ydir))
				(* (caddr xdir) (cadr ydir))
			     )
			     (-	(* (caddr xdir) (car ydir))
				(* (car xdir) (caddr ydir))
			     )
			     (-	(* (car xdir) (cadr ydir))
				(* (cadr xdir) (car ydir))
			     )
		       )
	    )
    )
  )
)

;;;*************************************************************;;;

;;; 3d-coord->pt-lst Convert a 3D coordinates flat list in points list
;;; (3d-coord->pt-lst '(1.0 2.0 3.0 4.0 5.0 6.0)) -> ((1.0 2.0 3.0) (4.0 5.0 6.0))

(defun 3d-coord->pt-lst	(lst)
  (if lst
    (cons (list (car lst) (cadr lst) (caddr lst))
	  (3d-coord->pt-lst (cdddr lst))
    )
  )
)

;;;*************************************************************;;;

;;; SUBLST Returns a sub list
;;; First item : 1
;;; (sublst '(1 2 3 4 5 6) 3 2) -> (3 4)
;;; (sublst '(1 2 3 4 5 6) 3 nil) -> (3 4 5 6)

(defun sublst (lst start leng / rslt)
  (if (not (<= 1 leng (- (length lst) start)))
    (setq leng (- (length lst) (1- start)))
  )
  (repeat leng
    (setq rslt	(cons (nth (1- start) lst) rslt)
	  start	(1+ start)
    )
  )
  (reverse rslt)
)

;;;*************************************************************;;;

;;; VEC1 Returns the singleunit vector from p1 to p2

(defun vec1 (p1 p2)
  (if (not (equal p1 p2 1e-009))
    (mapcar '(lambda (x1 x2)
	       (/ (- x2 x1) (distance p1 p2))
	     )
	    p1
	    p2
    )
  )
)

;;;*************************************************************;;;

;;; BUTLAST List but last item

(defun butlast (lst)
  (reverse (cdr (reverse lst)))
)
Advertisements

About AutoCAD Tips

This blog serves as a knowledge base for myself (and anyone else) so that I can reference tips & tricks that I have learned and also refer others to it as well. I hope that this blog helps you learn at least one tip to make your drafting/design experience better.
This entry was posted in AutoLISP, AutoLISP: 3D, AutoLISP: Modify, AutoLISP: Polylines. Bookmark the permalink.

3 Responses to AutoLISP: Fillet a 3D Polyline

  1. Jerry says:

    I would like to use this code in my work. I tried running this in autocad 2002. The lisp would not load. syntax error. Maybe it won’t work with this older version of autocad?

    In my visual lisp editor I tried to check the code and got this message:
    [CHECKING TEXT 3dPolyFillet.lsp loading…]
    .
    ; warning: too few arguments: (TRANS SOM NORM)
    ; warning: too few arguments: (TRANS P1 NORM)
    ; warning: too few arguments: (TRANS P2 NORM)
    ; error: too few arguments in SETQ: (SETQ INC (/ ANG PREC)
    …..
    ; Check done.

    Since your are more familiar with your own code, can you help?

  2. Pither Rukka says:

    Well done…very good, that routine very help me in road design.
    Thanks

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s