Create 3 Center Curves for Polylines

November 16, 2016

I am trying to create a LISP that would allow me to create 3 center curves easily for polylines based on knowing the offset distances (for example a 3 center curve w/ 100'-55'-200' w/ 2' and 8' offsets). My issue is that I cannot figure out how to calculate the tangent values via LISP for the different arcs. Attached is a .dwg that shows what exactly I am talking about.

3 Center Curves.dwg

November 16, 2016

What I have so far on the code is:

(defun c:3centercurve (/ *error* prd ent1 ent2 rad1 rad2 rad3 off1 off2)
 (defun *error* (msg)
   (if (not
         (member msg '("Function cancelled" "quit / exit abort"))
       )
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 (setq prd
        '(lambda (x)
           (wcmatch
             (cdr (assoc 0 (entget x)))
             "LWPOLYLINE"
           )
         )
 )
 (if (and (setq ent1 (selectif "\nSelect approach polyline: " prd))
          (setq ent2 (selectif "\nSelect the intersecting pline: " prd))
          (progn
            (initget (+ 1 2 4))
            (setq rad1 (getreal "\nSpecify the approach radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq rad2 (getreal "\nSpecify the center radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq rad3 (getreal "\nSpecify the ending radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq off1 (getreal "\nSpecify the approach offset: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq off2 (getreal "\nSpecify the tie-in offset: "))
          )
     )
   (progn
;;;This is where I am getting stuck
   )
 )
 (princ)
)
;;;Select if written by Lee Mac
(defun selectif (msg prd / ent)
 (while
   (progn (setq ent (car (entsel msg)))
          (cond
            ((= 7 (getvar 'errno))
             (princ "\nMissed, try again.")
            )
            ((not ent) nil)
            ((not (apply prd (list ent)))
             (princ "\nInvalid object selected.")
            )
          )
   )
 )
 ent
)

November 16, 2016

No solution sorry, just had to correct what you have (for readability's sake):

(defun c:test ( / *error* _GRP selfoo ent1 ent2 rad1 rad2 rad3 off1 off2 )

 (defun *error* (msg)
   (and msg
		(not (member msg '("Function cancelled" "quit / exit abort")))
		(princ (strcat "\nError: " msg))
	)
   (princ)
)
(defun _GRP ( msg / rtn ) ; "Get Real Positive"
	(and (not (initget (+ 1 2 4))) (setq rtn (getreal (strcat "\n" msg))) )
	rtn
)
 (setq selfoo (lambda ( x ) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))))

 (if 
	(and 
		(setq ent1 (car (LM:SelectIf "\nSelect approach polyline: " selfoo entsel nil)))
		(setq ent2 (car (LM:SelectIf "\nSelect the intersecting pline: " selfoo entsel nil)))
		(setq rad1 (_GRP "Specify the approach radius: "))
		(setq rad2 (_GRP "Specify the center radius: "))
		(setq rad3 (_GRP "Specify the ending radius: "))
		(setq off1 (_GRP "Specify the approach offset: "))
		(setq off2 (_GRP "Specify the tie-in offset: "))
	); and
	(progn
		;;;This is where I am getting stuck
	)
)
(princ)
)


;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Provides continuous selection prompts until either a      ;;
;;  predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  msg  - prompt string                                      ;;
;;  pred - optional predicate function [selection list arg]   ;;
;;  func - selection function to invoke                       ;;
;;  keyw - optional initget argument list                     ;;
;;------------------------------------------------------------;;
;;  Returns:  Entity selection list, keyword, or nil          ;;
;;------------------------------------------------------------;;

(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))  
(while
	(progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
		(cond
			( (= 7 (getvar 'ERRNO))
				(princ "\nMissed, Try again.")
			)
			( (eq 'STR (type sel))
				nil
			)
			( (vl-consp sel)
				(if (and pred (not (pred sel)))
					(princ "\nInvalid Object Selected.")
				)
			)
		)
	)
)
sel
)

November 16, 2016

Thanks Grr! I hadn't thought of making a separate function, which makes it a lot cleaner than just using progn over and over again.

November 16, 2016

By The Way there was something wrong with that (selectif) function you used, as I was unable to select LWPOLYLINE (and assume because of that errno variable wasn't reset to 0).

Anyway use LM:Selectif and keep the headers so you won't violate LM's terms of use.

Also you might find BIGAL's example useful about finding a tangent from a curve, since its part of your task.

And sorry I'm still not used to math lisps, so I don't know can I help you further

November 17, 2016

This looked to be an interesting geometric challenge!

I haven't pushed my geometry for a while, and so here is my attempt at a solution (very limited testing!):

(defun c:3cc ( / acn aof ard cen crd ecn eof erd int per sg1 sg2 vc1 vc2 )
   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: "))
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: "))
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   t
           (if (< (distance int (car sg1)) (distance int (cadr sg1)))
               (setq sg1 (reverse sg1))
           )
           (if (< (distance int (cadr sg2)) (distance int (car sg2)))
               (setq sg2 (reverse sg2))
           )
           (setq per'((x) (vx1 (list (- (cadr x)) (car x))))
                 vc1 (per (apply 'mapcar (cons '- sg1)))
                 vc2 (per (apply 'mapcar (cons '- sg2)))
                 cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               (mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd eof)))
                           )
                       )
                      '( ( ) )
                   )
               )
           )
           (setq acn
               (last
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                           (list cen (- ard crd))
                       )
                   )
               )
           )
           (setq ecn
               (car
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                           (list cen (- erd crd))
                       )
                   )
               )
           )
           (arc acn ard (angle acn cen) (angle '(0 0) (mapcar '- vc1)))
           (arc ecn erd (angle '(0 0) (mapcar '- vc2)) (angle ecn cen))
           (arc cen crd (angle ecn cen) (angle acn cen))
       )
   )
   (princ)
)
(defun arc ( cen rad sta ena )
   (entmake
       (list
          '(000 . "ARC")
           (cons 010 cen)
           (cons 040 rad)
           (cons 050 sta)
           (cons 051 ena)
       )
   )
)
(defun getsegment ( msg / ent enx par rtn sel typ )
   (while
       (progn (setvar 'errno 0) (setq sel (entsel msg))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null sel) nil)
               (   (= "LINE"
                       (setq ent (car sel)
                             enx (entget ent)
                             typ (cdr (assoc 0 enx))
                       )
                   )
                   (setq rtn
                       (list
                           (trans (cdr (assoc 10 enx)) 0 1)
                           (trans (cdr (assoc 11 enx)) 0 1)
                       )
                   )
                   nil
               )
               (   (= "LWPOLYLINE" typ)
                   (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr sel) 1 0)))
                         rtn
                       (list
                           (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                           (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                       )
                   )
                   nil
               )
               (   (princ "\nPlease select a line or 2D polyline."))
           )
       )
   )
   rtn
)

;; Line-Circle Intersection (vector version)  -  Lee Mac
;; Returns the point(s) of intersection between an infinite line defined by
;; points p,q and circle with centre c and radius r

(defun LM:inters-line-circle ( p q c r / v s )
   (setq v (mapcar '- q p)
         s (mapcar '- p c)
   )
   (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
       (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
   )
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
   (cond
       (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-8)
           (list (/ b (* -2.0 a)))
       )
       (   (< 0 d)
           (setq r (sqrt d))
           (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
       )
   )
)

;; Vector Dot Product  -  Lee Mac
;; Args: u,v - vectors in R^n

(defun vxv ( u v )
   (apply '+ (mapcar '* u v))
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
   (mapcar '(lambda ( n ) (* n s)) v)
)

;; Unit Vector  -  Lee Mac
;; Args: v - vector in R^2 or R^3

(defun vx1 ( v )
   (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
       (distance '(0.0 0.0 0.0) v)
   )
)

(vl-load-com) (princ)

Edited March 4, 2019 by Lee Mac
Fixed typos.

November 17, 2016

Lee, you have typo : change eof to tof

(cond ( (not (and sg1 sg2 (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg))) '(ard crd erd aof tof) '( "\nSpecify approach radius: " "\nSpecify center radius: " "\nSpecify end radius: " "\nSpecify approach offset: " "\nSpecify tie-in offset: " ) ) ) ) )...

Also you need to add (vl-load-com) :

(defun getsegment ( msg / ent enx par rtn sel typ ) (vl-load-com) (while ...

November 17, 2016

This looked to be an interesting geometric challenge!
I haven't pushed my geometry for a while, and so here is my attempt at a solution (very limited testing!):

This code looks awesomely written ( but I know thats your style ).

I like that you put our previous discussion into use:

([color=BLUE]vl-every[/color] '([color=BLUE]lambda[/color] ( sym msg ) ([color=BLUE]initget[/color] 6) ([color=BLUE]set[/color] sym ([color=BLUE]getdist[/color] msg)))
'(ard crd erd aof eof)
'(   [color=MAROON]"\nSpecify approach radius: "[/color]
	[color=MAROON]"\nSpecify center radius: "[/color]
	[color=MAROON]"\nSpecify end radius: "[/color]
	[color=MAROON]"\nSpecify approach offset: "[/color]
	[color=MAROON]"\nSpecify tie-in offset: "[/color]
)
)

This row frustrates me :

([color=BLUE]not[/color] ([color=BLUE]setq[/color] int ([color=BLUE]apply[/color] '[color=BLUE]inters[/color] ([color=BLUE]append[/color] sg1 sg2 '(())))))

What exactly happends, is that appending with nested list '(()) ?

Although I tried it still no idea what the routine does, perhaps some animation would be nice.

I think CADtutor should include an "add to favorites" button, for reviewing awesome threads/posts.

November 17, 2016

Lee, you have typo : change eof to tof

Oops! Fixed.

This code looks awesomely written ( but I know thats your style ).

Thanks!

This row frustrates me :
([color=BLUE]not[/color] ([color=BLUE]setq[/color] int ([color=BLUE]apply[/color] '[color=BLUE]inters[/color] ([color=BLUE]append[/color] sg1 sg2 '(())))))
What exactly happends, is that appending with nested list '(()) ?

This may shed some light:

sg1 = ( )

sg2 = ( )

(()) = ( nil )

November 17, 2016

This looked to be an interesting geometric challenge!

I haven't pushed my geometry for a while, and so here is my attempt at a solution (very limited testing):

Lee, thank you so much! I have just begun to test the code and I haven't noticed any big bugs yet! As I am diving more into the code, I was curious on your prompting method. Is there a distinct advantage to using the vl way, versus using the way I was showing in the original code?

November 17, 2016

I have begun testing the code some more and I get some odd behavior that seems at least somewhat random. Occasionally the curve will not end up tangent and will be almost "flipped" when I select the polylines. The code doesn't error out though, so I don't know what is causing the problem. I have attached a .dwg to show what I am talking about.

3cctesting.dwg

November 17, 2016

Lee, thank you so much! I have just begun to test the code and I haven't noticed any big bugs yet! As I am diving more into the code, I was curious on your prompting method. Is there a distinct advantage to using the vl way, versus using the way I was showing in the original code?

Theres no advantage, its the same thing, written in different way.

Goal is: to get "out of the box" and writing codes for others in the same way everytime won't do it.

Well ofcourse he used getdist instead of getreal, I assume because for user to get the "visual scale".

But IMO this approach would be more useful if instead localizing 5 variables, localize 1 assoc list, with 5 associations inside it (atleast I had this idea).

EDIT:

Like this:

_$ (defun PromptUser ( AssocKeys AssocRtns / Lst )
(if
	(vl-every '(lambda ( key msg / r ) (initget 6)  (and (setq r (getdist msg)) (setq Lst (cons (cons key r) Lst))))
		AssocKeys
		AssocRtns
	)
	Lst
)
)
PROMPTUSER
_$ (setq InputLst
(PromptUser
	'("AR" "CR" "ER" "AO" "TO")
	'(   
		"\nSpecify approach radius: "
		"\nSpecify center radius: "
		"\nSpecify end radius: "
		"\nSpecify approach offset: "
		"\nSpecify tie-in offset: "
	)
)
)
(("TO" . 64.2665) ("AO" . 49.4174) ("ER" . 42.122) ("CR" . 48.0696) ("AR" . 54.2165))
_$

Well I hope atleast Lee get the idea.

Edited November 17, 2016 by Grrr

November 17, 2016

Here, not 100% sure, but if you want like FILLET with the smallest arcs, try this :

(defun c:3cc ( / arc getsegment LM:inters-line-circle quad vxv vxs acn aof ard cen crd ecn erd int sg1 sg2 tof vc1 vc2 p1 p2 p acn1 acn2 ecn1 ecn2 arc1 arc2 arc3 arc4 arc5 arc6 arc7 arc8 d1 d2 d3 d4 d5 d6 d7 d8 )

   (vl-load-com)

   (defun arc ( cen rad sta ena ocs )
       (entmakex
           (list
              '(000 . "ARC")
               (cons 010 cen)
               (cons 040 rad)
               (cons 050 sta)
               (cons 051 ena)
               (cons 210 ocs)
           )
       )
   )

   (defun getsegment ( msg / ent enx par rtn sel typ )
       (while
           (progn (setvar 'errno 0) (setq sel (entsel msg) p (cadr sel))
               (cond
                   (   (= 7 (getvar 'errno))
                       (princ "\nMissed, try again.")
                   )
                   (   (null sel) nil)
                   (   (= "LINE"
                           (setq ent (car sel)
                                 enx (entget ent)
                                 typ (cdr (assoc 0 enx))
                           )
                       )
                       (setq rtn
                           (list
                               (trans (cdr (assoc 10 enx)) 0 1)
                               (trans (cdr (assoc 11 enx)) 0 1)
                           )
                       )
                       nil
                   )
                   (   (= "LWPOLYLINE" typ)
                       (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans p 1 0)))
                             rtn
                           (list
                               (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                               (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                           )
                       )
                       nil
                   )
                   (   (princ "\nPlease select a line or 2D polyline."))
               )
           )
       )
       rtn
   )

   ;; Line-Circle Intersection (vector version)  -  Lee Mac
   ;; Returns the point(s) of intersection between an infinite line defined by
   ;; points p,q and circle with centre c and radius r

   (defun LM:inters-line-circle ( p q c r / v s )
       (setq v (mapcar '- q p)
             s (mapcar '- p c)
       )
       (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
           (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
       )
   )

   ;; Quadratic Solution  -  Lee Mac
   ;; Args: a,b,c - coefficients of ax^2 + bx + c = 0
    
   (defun quad ( a b c / d r )
       (cond
           (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-
               (list (/ b (* -2.0 a)))
           )
           (   (< 0 d)
               (setq r (sqrt d))
               (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
           )
       )
   )

   ;; Vector Dot Product  -  Lee Mac
   ;; Args: u,v - vectors in R^n

   (defun vxv ( u v )
       (apply '+ (mapcar '* u v))
   )

   ;; Vector x Scalar  -  Lee Mac
   ;; Args: v - vector in R^n, s - real scalar

   (defun vxs ( v s )
       (mapcar '(lambda ( n ) (* n s)) v)
   )

   ;; --------- MAIN ---------- ;;

   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: ") p1 p)
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: ") p2 p)
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof tof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   t
           ;;; ;| mod by M.R.
           (setq vc1 (polar '(0 0) (+ (angle (car sg1) (cadr sg1)) (* 0.5 pi)) 1.0))
           (setq vc2 (polar '(0 0) (+ (angle (car sg2) (cadr sg2)) (* 0.5 pi)) 1.0))
           (if (> (distance (mapcar '+ p1 vc1) p2) (distance p1 p2))
             (setq vc1 (mapcar '- vc1))
           )
           (if (> (distance (mapcar '+ p2 vc2) p1) (distance p2 p1))
             (setq vc2 (mapcar '- vc2))
           )
           ;;; |; mod by M.R.
           (setq cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               ;;;(mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd tof))) - mod by M.R.
                               (mapcar 'vxs (list vc1 vc2) (list aof tof)) ;;; mod by M.R.
                           )
                       )
                      '( ( ) )
                   )
               )
           )
           (setq acn1
               (car
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                           (list cen (- ard crd))
                       )
                   )
               )
           )
           (setq acn2
               (last
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                           (list cen (- ard crd))
                       )
                   )
               )
           )
           (setq ecn1
               (car
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                           (list cen (- erd crd))
                       )
                   )
               )
           )
           (setq ecn2
               (last
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                           (list cen (- erd crd))
                       )
                   )
               )
           )

           (setq arc1 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle ecn1 cen) (angle acn1 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc2 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle ecn1 cen) (angle acn2 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc3 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle ecn2 cen) (angle acn1 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc4 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle ecn2 cen) (angle acn2 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc5 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle acn1 cen) (angle ecn1 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc6 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle acn1 cen) (angle ecn2 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc7 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle acn2 cen) (angle ecn1 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc8 (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle acn2 cen) (angle ecn2 cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq d1 (vlax-curve-getdistatparam arc1 (vlax-curve-getendparam arc1)))
           (setq d2 (vlax-curve-getdistatparam arc2 (vlax-curve-getendparam arc2)))
           (setq d3 (vlax-curve-getdistatparam arc3 (vlax-curve-getendparam arc3)))
           (setq d4 (vlax-curve-getdistatparam arc4 (vlax-curve-getendparam arc4)))
           (setq d5 (vlax-curve-getdistatparam arc5 (vlax-curve-getendparam arc5)))
           (setq d6 (vlax-curve-getdistatparam arc6 (vlax-curve-getendparam arc6)))
           (setq d7 (vlax-curve-getdistatparam arc7 (vlax-curve-getendparam arc7)))
           (setq d8 (vlax-curve-getdistatparam arc8 (vlax-curve-getendparam arc8)))
           (cond
             ( (= d1 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc2)
               (entdel arc3)
               (entdel arc4)
               (entdel arc5)
               (entdel arc6)
               (entdel arc7)
               (entdel arc8)
               (setq ecn ecn1 acn acn1)
             )
             ( (= d2 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc3)
               (entdel arc4)
               (entdel arc5)
               (entdel arc6)
               (entdel arc7)
               (entdel arc8)
               (setq ecn ecn1 acn acn2)
             )
             ( (= d3 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc2)
               (entdel arc1)
               (entdel arc4)
               (entdel arc5)
               (entdel arc6)
               (entdel arc7)
               (entdel arc8)
               (setq ecn ecn2 acn acn1)
             )
             ( (= d4 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc2)
               (entdel arc3)
               (entdel arc5)
               (entdel arc6)
               (entdel arc7)
               (entdel arc8)
               (setq ecn ecn2 acn acn2)
             )
             ( (= d5 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc2)
               (entdel arc3)
               (entdel arc4)
               (entdel arc6)
               (entdel arc7)
               (entdel arc8)
               (setq acn acn1 ecn ecn1)
             )
             ( (= d6 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc2)
               (entdel arc3)
               (entdel arc4)
               (entdel arc5)
               (entdel arc7)
               (entdel arc8)
               (setq acn acn1 ecn ecn2)
             )
             ( (= d7 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc2)
               (entdel arc3)
               (entdel arc4)
               (entdel arc5)
               (entdel arc6)
               (entdel arc8)
               (setq acn acn2 ecn ecn1)
             )
             ( (= d8 (min d1 d2 d3 d4 d5 d6 d7 d8))
               (entdel arc1)
               (entdel arc2)
               (entdel arc3)
               (entdel arc4)
               (entdel arc5)
               (entdel arc6)
               (entdel arc7)
               (setq acn acn2 ecn ecn2)
             )
           )
           (setq arc1 (arc (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) ard (angle acn cen) (angle '(0 0) (mapcar '- vc1)) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc2 (arc (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) ard (angle '(0 0) (mapcar '- vc1)) (angle acn cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (if (> (vlax-curve-getdistatparam arc1 (vlax-curve-getendparam arc1)) (vlax-curve-getdistatparam arc2 (vlax-curve-getendparam arc2)))
             (entdel arc1)
             (entdel arc2)
           )
           (setq arc1 (arc (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) erd (angle '(0 0) (mapcar '- vc2)) (angle ecn cen) (trans '(0.0 0.0 1.0) 1 0 t)))
           (setq arc2 (arc (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) erd (angle ecn cen) (angle '(0 0) (mapcar '- vc2)) (trans '(0.0 0.0 1.0) 1 0 t)))
           (if (> (vlax-curve-getdistatparam arc1 (vlax-curve-getendparam arc1)) (vlax-curve-getdistatparam arc2 (vlax-curve-getendparam arc2)))
             (entdel arc1)
             (entdel arc2)
           )
       )
   )
   (princ)
)

@Lee, I couldn't resist to modify... Hope you don't mind...

Edited November 18, 2016 by marko_ribar

November 17, 2016

broncos15 said:

I have begun testing the code some more and I get some odd behavior that seems at least somewhat random. Occasionally the curve will not end up tangent and will be almost "flipped" when I select the polylines.

Version 2

(defun c:3cc ( / acn aof ard cen crd ecn eof erd int per sg1 sg2 tmp vc1 vc2 )
   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: "))
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: "))
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   (setq
               sg1 (sortfarthestfrom int sg1)
               sg2 (sortfarthestfrom int sg2)
               per'((x) (list (- (cadr x)) (car x)))
               tmp (inters
                       (car sg1) (mapcar '+ (car sg1) (per (apply 'mapcar (cons '- sg1))))
                       (car sg2) (mapcar '+ (car sg2) (per (apply 'mapcar (cons '- sg2))))
                       nil
                   )
               vc1 (vx1 (mapcar '- tmp (car sg1)))
               vc2 (vx1 (mapcar '- tmp (car sg2)))
               cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               (mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd eof)))
                           )
                       )
                      '( ( ) )
                   )
               )
               acn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                               (list cen (- ard crd))
                           )
                       )
                   )
               )
               ecn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                               (list cen (- erd crd))
                           )
                       )
                   )
               )
           )
           (if (LM:clockwise-p (car sg1) int (car sg2))
               (progn
                   (arc acn ard (angle acn cen)    (angle vc1 '(0 0)))
                   (arc ecn erd (angle vc2 '(0 0)) (angle ecn cen))
                   (arc cen crd (angle ecn cen)    (angle acn cen))
               )
               (progn
                   (arc acn ard (angle vc1 '(0 0)) (angle acn cen))
                   (arc ecn erd (angle ecn cen)    (angle vc2 '(0 0)))
                   (arc cen crd (angle acn cen)    (angle ecn cen))
               )
           )
       )
   )
   (princ)
)
(defun sortfarthestfrom ( pnt lst )
   (vl-sort lst '(lambda ( a b ) (> (distance pnt a) (distance pnt b))))
)
(defun arc ( cen rad sta ena )
   (entmake
       (list
          '(000 . "ARC")
           (cons 010 cen)
           (cons 040 rad)
           (cons 050 sta)
           (cons 051 ena)
       )
   )
)
(defun getsegment ( msg / ent enx par rtn sel typ )
   (while
       (progn (setvar 'errno 0) (setq sel (entsel msg))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null sel) nil)
               (   (= "LINE"
                       (setq ent (car sel)
                             enx (entget ent)
                             typ (cdr (assoc 0 enx))
                       )
                   )
                   (setq rtn
                       (list
                           (trans (cdr (assoc 10 enx)) 0 1)
                           (trans (cdr (assoc 11 enx)) 0 1)
                       )
                   )
                   nil
               )
               (   (= "LWPOLYLINE" typ)
                   (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr sel) 1 0)))
                         rtn
                       (list
                           (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                           (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                       )
                   )
                   nil
               )
               (   (princ "\nPlease select a line or 2D polyline."))
           )
       )
   )
   rtn
)

;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented

(defun LM:clockwise-p ( p1 p2 p3 )
   (<  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
       (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
   )
)

;; Line-Circle Intersection (vector version)  -  Lee Mac
;; Returns the point(s) of intersection between an infinite line defined by
;; points p,q and circle with centre c and radius r

(defun LM:inters-line-circle ( p q c r / v s )
   (setq v (mapcar '- q p)
         s (mapcar '- p c)
   )
   (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
       (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
   )
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
   (cond
       (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-8)
           (list (/ b (* -2.0 a)))
       )
       (   (< 0 d)
           (setq r (sqrt d))
           (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
       )
   )
)

;; Vector Dot Product  -  Lee Mac
;; Args: u,v - vectors in R^n

(defun vxv ( u v )
   (apply '+ (mapcar '* u v))
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
   (mapcar '(lambda ( n ) (* n s)) v)
)

;; Unit Vector  -  Lee Mac
;; Args: v - vector in R^2 or R^3

(defun vx1 ( v )
   (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
       (distance '(0.0 0.0 0.0) v)
   )
)

(vl-load-com) (princ)

Edited March 4, 2019 by Lee Mac

November 18, 2016

I don't want to steal Lee's version, but I was thinking just in case that someone needs this while working in 3D in random UCS... I thought when I've already modify it for my internal purposes, why not to post it... Sorry Lee, this is just to make more applicable in various situations user may run into... My FILLET version is already 3D... If something's wrong let us know...

(defun c:3cc ( / sortfarthestfrom arc getsegment LM:clockwise-p LM:inters-line-circle quad vxv vxs vx1 acn aof ard cen crd ecn eof erd int per sg1 sg2 tmp vc1 vc2 )

   (vl-load-com)

   (defun sortfarthestfrom ( pnt lst )
       (vl-sort lst '(lambda ( a b ) (> (distance pnt a) (distance pnt b))))
   )

   (defun arc ( cen rad sta ena ocs )
       (entmake
           (list
              '(000 . "ARC")
               (cons 010 cen)
               (cons 040 rad)
               (cons 050 sta)
               (cons 051 ena)
               (cons 210 ocs)
           )
       )
   )

   (defun getsegment ( msg / ent enx par rtn sel typ )
       (while
           (progn (setvar 'errno 0) (setq sel (entsel msg))
               (cond
                   (   (= 7 (getvar 'errno))
                       (princ "\nMissed, try again.")
                   )
                   (   (null sel) nil)
                   (   (= "LINE"
                           (setq ent (car sel)
                                 enx (entget ent)
                                 typ (cdr (assoc 0 enx))
                           )
                       )
                       (setq rtn
                           (list
                               (trans (cdr (assoc 10 enx)) 0 1)
                               (trans (cdr (assoc 11 enx)) 0 1)
                           )
                       )
                       nil
                   )
                   (   (= "LWPOLYLINE" typ)
                       (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr sel) 1 0)))
                             rtn
                           (list
                               (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                               (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                           )
                       )
                       nil
                   )
                   (   (princ "\nPlease select a line or 2D polyline."))
               )
           )
       )
       rtn
   )

   ;; Clockwise-p - Lee Mac
   ;; Returns T if p1,p2,p3 are clockwise oriented

   (defun LM:clockwise-p ( p1 p2 p3 )
       (<  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
           (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
       )
   )

   ;; Line-Circle Intersection (vector version)  -  Lee Mac
   ;; Returns the point(s) of intersection between an infinite line defined by
   ;; points p,q and circle with centre c and radius r

   (defun LM:inters-line-circle ( p q c r / v s )
       (setq v (mapcar '- q p)
             s (mapcar '- p c)
       )
       (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
           (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
       )
   )

   ;; Quadratic Solution  -  Lee Mac
   ;; Args: a,b,c - coefficients of ax^2 + bx + c = 0
    
   (defun quad ( a b c / d r )
       (cond
           (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-
               (list (/ b (* -2.0 a)))
           )
           (   (< 0 d)
               (setq r (sqrt d))
               (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
           )
       )
   )

   ;; Vector Dot Product  -  Lee Mac
   ;; Args: u,v - vectors in R^n

   (defun vxv ( u v )
       (apply '+ (mapcar '* u v))
   )

   ;; Vector x Scalar  -  Lee Mac
   ;; Args: v - vector in R^n, s - real scalar

   (defun vxs ( v s )
       (mapcar '(lambda ( n ) (* n s)) v)
   )

   ;; Unit Vector  -  Lee Mac
   ;; Args: v - vector in R^2 or R^3

   (defun vx1 ( v )
       (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
           (distance '(0.0 0.0 0.0) v)
       )
   )

   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: "))
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: "))
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   (setq
               sg1 (sortfarthestfrom int sg1)
               sg2 (sortfarthestfrom int sg2)
               per'((x) (list (- (cadr x)) (car x)))
               tmp (inters
                       (car sg1) (mapcar '+ (car sg1) (per (apply 'mapcar (cons '- sg1))))
                       (car sg2) (mapcar '+ (car sg2) (per (apply 'mapcar (cons '- sg2))))
                       nil
                   )
               vc1 (vx1 (mapcar '- tmp (car sg1)))
               vc2 (vx1 (mapcar '- tmp (car sg2)))
               cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               (mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd eof)))
                           )
                       )
                      '( ( ) )
                   )
               )
               acn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                               (list cen (- ard crd))
                           )
                       )
                   )
               )
               ecn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                               (list cen (- erd crd))
                           )
                       )
                   )
               )
           )
           (if (LM:clockwise-p (car sg1) int (car sg2))
               (progn
                   (arc (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) ard (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans (mapcar '- acn vc1) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
                   (arc (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) erd (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans (mapcar '- ecn vc2) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
                   (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
               )
               (progn
                   (arc (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) ard (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans (mapcar '- acn vc1) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
                   (arc (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) erd (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans (mapcar '- ecn vc2) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
                   (arc (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t)) crd (angle (trans acn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (angle (trans ecn 1 (trans '(0.0 0.0 1.0) 1 0 t)) (trans cen 1 (trans '(0.0 0.0 1.0) 1 0 t))) (trans '(0.0 0.0 1.0) 1 0 t))
               )
           )
       )
   )
   (princ)
)

HTH. M.R.

November 18, 2016

Lee, thank you so much, this is working perfectly! Marko, I tested yours as well, and it seems to work great as well. Marko, as I am diving into your code, I am trying to understand the difference, does it primarily have to do with you translating the points, so it will work in any UCS (I only use dview, so I don't often have to think about this translation)? I'm curious because I am trying to improve my coding skills, and looking at codes like these have really helped!

November 18, 2016

It mostly has to do with translation function (trans)... In the most cases we all work in WCS, but when you think generally the coding is finished only when routine is applicable for all situations... In this particular case and in the most cases all the job is done in UCS, but when it comes to (entmake) you have to think for various etypes and how they are interpreted through DXF code specifications... This is where your understanding of creation of entities comes into role... You have to account for various situations - here ARC is similar to CIRCLE - while ELLIPSE differs - when ARC/CIRCLE is reference entity then you should think in terms of OCS (object coordinate system)... If it's ELLIPSE then it is little different - you should think WCS and OCS for DXF 210 code... If you look closer into my last code - it's totally the same as Lee's with only difference in (arc) function where is added ocs argument and last lines when it's needed to create ARCs in 3D in random UCS in 3D, appropriate transformations are predicted to make sure correct 3D arc entities are created in 3D... So weather you are working in 3D or 2D, routine is properly coded only when applicable for both situations and this means if it works for random UCS, it should work fine and for WCS which is the case with my replied codes...

2025-10-29T13:42:13Z

On 11/17/2016 at 11:34 PM, Lee Mac said:

Version 2

(defun c:3cc ( / acn aof ard cen crd ecn eof erd int per sg1 sg2 tmp vc1 vc2 )
   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: "))
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: "))
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   (setq
               sg1 (sortfarthestfrom int sg1)
               sg2 (sortfarthestfrom int sg2)
               per'((x) (list (- (cadr x)) (car x)))
               tmp (inters
                       (car sg1) (mapcar '+ (car sg1) (per (apply 'mapcar (cons '- sg1))))
                       (car sg2) (mapcar '+ (car sg2) (per (apply 'mapcar (cons '- sg2))))
                       nil
                   )
               vc1 (vx1 (mapcar '- tmp (car sg1)))
               vc2 (vx1 (mapcar '- tmp (car sg2)))
               cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               (mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd eof)))
                           )
                       )
                      '( ( ) )
                   )
               )
               acn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                               (list cen (- ard crd))
                           )
                       )
                   )
               )
               ecn
               (car
                   (sortfarthestfrom int
                       (apply 'LM:inters-line-circle
                           (append
                               (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                               (list cen (- erd crd))
                           )
                       )
                   )
               )
           )
           (if (LM:clockwise-p (car sg1) int (car sg2))
               (progn
                   (arc acn ard (angle acn cen)    (angle vc1 '(0 0)))
                   (arc ecn erd (angle vc2 '(0 0)) (angle ecn cen))
                   (arc cen crd (angle ecn cen)    (angle acn cen))
               )
               (progn
                   (arc acn ard (angle vc1 '(0 0)) (angle acn cen))
                   (arc ecn erd (angle ecn cen)    (angle vc2 '(0 0)))
                   (arc cen crd (angle acn cen)    (angle ecn cen))
               )
           )
       )
   )
   (princ)
)
(defun sortfarthestfrom ( pnt lst )
   (vl-sort lst '(lambda ( a b ) (> (distance pnt a) (distance pnt b))))
)
(defun arc ( cen rad sta ena )
   (entmake
       (list
          '(000 . "ARC")
           (cons 010 cen)
           (cons 040 rad)
           (cons 050 sta)
           (cons 051 ena)
       )
   )
)
(defun getsegment ( msg / ent enx par rtn sel typ )
   (while
       (progn (setvar 'errno 0) (setq sel (entsel msg))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null sel) nil)
               (   (= "LINE"
                       (setq ent (car sel)
                             enx (entget ent)
                             typ (cdr (assoc 0 enx))
                       )
                   )
                   (setq rtn
                       (list
                           (trans (cdr (assoc 10 enx)) 0 1)
                           (trans (cdr (assoc 11 enx)) 0 1)
                       )
                   )
                   nil
               )
               (   (= "LWPOLYLINE" typ)
                   (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr sel) 1 0)))
                         rtn
                       (list
                           (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                           (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                       )
                   )
                   nil
               )
               (   (princ "\nPlease select a line or 2D polyline."))
           )
       )
   )
   rtn
)

;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented

(defun LM:clockwise-p ( p1 p2 p3 )
   (<  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
       (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
   )
)

;; Line-Circle Intersection (vector version)  -  Lee Mac
;; Returns the point(s) of intersection between an infinite line defined by
;; points p,q and circle with centre c and radius r

(defun LM:inters-line-circle ( p q c r / v s )
   (setq v (mapcar '- q p)
         s (mapcar '- p c)
   )
   (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
       (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
   )
)

;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

(defun quad ( a b c / d r )
   (cond
       (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-8)
           (list (/ b (* -2.0 a)))
       )
       (   (< 0 d)
           (setq r (sqrt d))
           (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
       )
   )
)

;; Vector Dot Product  -  Lee Mac
;; Args: u,v - vectors in R^n

(defun vxv ( u v )
   (apply '+ (mapcar '* u v))
)

;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
   (mapcar '(lambda ( n ) (* n s)) v)
)

;; Unit Vector  -  Lee Mac
;; Args: v - vector in R^2 or R^3

(defun vx1 ( v )
   (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
       (distance '(0.0 0.0 0.0) v)
   )
)

(vl-load-com) (princ)

You have no idea how long I have been looking for a LISP that does this!!!

I tried to hard code some of the values but I am messing it up somewhere (and I don't have enough knowledge of LISP to debut it...). Can someone please let me know how to change the code to put into it the following:

 (setq ard (* 2 crd))        ; Approach radius
 (setq erd (* 3 crd))        ; Exit radius
 (setq aof (* 0.0375 crd))   ; Approach offset
 (setq eof (* 0.1236 crd))   ; Exit offset

Basically, I just want one prompt for the middle radius, the rest are calculated with the above formulas.

2025-10-29T22:31:37Z

replace 
;;----------------------------------------------------------------------;;
(vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '("\nSpecify approach radius: "
                        "\nSpecify center radius: "
                        "\nSpecify end radius: "
                        "\nSpecify approach offset: "
                        "\nSpecify tie-in offset: "
                       )
                   )
;;----------------------------------------------------------------------;;
with
;;----------------------------------------------------------------------;;
(setq crd (getdist "\nMiddle Radius: ")
      ard (* 2 crd)        ; Approach radius
      erd (* 3 crd)        ; Exit radius
      aof (* 0.0375 crd)   ; Approach offset
      eof (* 0.1236 crd)   ; Exit offset
)
;;----------------------------------------------------------------------;;

Tho that is pretty cool way to set a bunch of variables with lambda

2025-10-30T11:07:15Z

You could just modify the LISP to store the last inputs.

Sign In

Create 3 Center Curves for Polylines

Recommended Posts

broncos15

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

Grrr

mhupp

Steven P

broncos15

Grrr

broncos15

Grrr

Lee Mac

marko_ribar

Grrr

Lee Mac

broncos15

broncos15

Grrr

marko_ribar

Lee Mac

marko_ribar

broncos15

marko_ribar

pallas

mhupp

SLW210

Join the conversation

Grrr

mhupp

Steven P

Tutorials

Forums

Activity