(defun c:esc (/ TK1 TK2 KD A
R SS N E
IntersLineCircle gxl-Ax:2DPoint gxl-clock
)
(vl-load-com)
(defun IntersLineCircle (p q c r / a d n s)
(setq n (mapcar '- q p)
p (trans p 0 n)
c (trans c 0 n)
a (list (car p) (cadr p) (caddr c))
)
(cond
((equal r (setq d (distance c a)))
(list (trans a n 0))
)
((< d r)
(setq s (sqrt (- (* r r) (* d d))))
(list
(trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
(trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
)
)
)
)
(defun gxl-Ax:2DPoint (pt)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
(list (car pt) (cadr pt))
)
)
)
(defun gxl-clock (PLIST / LW MINP MAXP LST)
(cond
((= 'LIST (type plist))
(not
(minusp
(apply '+
(mapcar
(function
(lambda (a b)
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
plist
(cons (last plist) plist)
)
)
)
)
)
(t
(if (= 'ename (type plist))
(setq lw (vlax-ename->vla-object plist))
(if (= 'VLA-OBJECT (type plist))
(setq lw plist)
)
)
(vla-GetBoundingBox lw 'MinP 'MaxP)
(setq
minp (vlax-safearray->list minp)
MaxP (vlax-safearray->list MaxP)
lst (mapcar
(function
(lambda (x)
(vlax-curve-getParamAtPoint
lw
(vlax-curve-getClosestPointTo lw x)
)
)
)
(list minp
(list (car MaxP) (cadr minp))
MaxP
(list (car minp) (cadr MaxP))
)
)
)
(if (or
(<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
(<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
(<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
(<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
)
t
)
)
)
)
(defun tk1 (E A R / N EL I P1 P2
P3 CLOCKWISEP MIDANG CP MRP STP ENP
MP BULGE ARCDATA OBJ A1 A2
)
(setq obj (vlax-ename->vla-object e))
(vla-put-Closed obj :vlax-true)
(setq n (fix (vlax-curve-getEndParam obj)))
;(if (/= 1 (logand (cdr (assoc 70 el)) 1)) (setq n (- n 2)))
(setq i 0)
(repeat n
(setq p1 (vlax-curve-getPointAtParam e i)
p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
p3 (vlax-curve-getPointAtParam e (1+ i))
)
(if (null p3)
(setq p3 (vlax-curve-getPointAtParam e 1))
)
(setq a1 (angle p2 p1)
a2 (angle p2 p3)
)
(setq clockwisep
(<
(* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(if (< a1 a2)
(setq a1 (+ a1 pi pi))
)
(setq midang (* 0.5 (+ a1 a2)))
(if clockwisep
(setq cp (polar p2 midang (- a r))
mrp (polar p2 midang a)
)
(setq cp (polar p2 midang (- r a))
mrp (polar p2 midang (- a))
)
)
(setq stp (car (vl-remove-if-not
'(lambda (x)
(equal (+ (distance p1 x) (distance p2 x))
(distance p1 p2)
1e-6
)
)
(IntersLineCircle p2 p1 cp r)
)
)
)
(setq enp (car (vl-remove-if-not
'(lambda (x)
(equal (+ (distance p3 x) (distance p2 x))
(distance p3 p2)
1e-6
)
)
(IntersLineCircle p2 p3 cp r)
)
)
)
(setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
(setq bulge (/ (distance mrp mp) (distance mp stp)))
(if clockwisep
(setq bulge (- bulge))
)
(setq arcdata (cons (list stp enp bulge) arcdata))
)
(setq arcdata (reverse arcdata))
(foreach data arcdata
(setq stp (car data)
enp (cadr data)
bulge (caddr data)
)
(setq n (fix (vlax-curve-getParamAtPoint
obj
(vlax-curve-getclosestpointto obj enp)
)
)
)
(vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
(if (vlax-curve-getPointAtParam obj (1+ n))
(vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
(vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
)
(vla-SetBulge obj n bulge)
)
)
(defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
N)
(setq obj (vlax-ename->vla-object e))
(vla-put-Closed obj :vlax-true)
(setq polyClock (not (gxl-clock e)))
(setq i 0)
(repeat (fix (vlax-curve-getEndParam obj))
(setq p1 (vlax-curve-getPointAtParam obj i)
p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
p3 (vlax-curve-getPointAtParam obj (1+ i))
)
(if (null p3)
(setq p3 (vlax-curve-getPointAtParam obj 1))
)
(cond
(polyClock
(cond
(clock
(setq
arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil)
arcdata
)
)
)
(t
(setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t)
arcdata
)
)
)
)
)
(t
(cond
(clock
(setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t)
arcdata
)
)
)
(t
(setq
arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil)
arcdata
)
)
)
)
)
)
)
(setq arcdata (reverse arcdata))
(foreach data arcdata
(setq pt (car data)
bulge (cadr data)
flag (caddr data)
)
(setq n (fix (vlax-curve-getParamAtPoint
obj
(vlax-curve-getclosestpointto obj pt)
)
)
)
(if (vlax-curve-getPointAtParam obj (1+ n))
(progn
(vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
(if flag
(vla-SetBulge obj (1+ n) bulge)
(vla-SetBulge obj n bulge)
)
)
(progn
(vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
(if flag
(vla-SetBulge obj 1 bulge)
(vla-SetBulge obj 0 bulge)
)
)
)
)
)
(initget "1 2 3")
(if (null
(setq kd (getkword
"\n[Standard(1)/ClockWise(2)/CounterClockWise(3)] <1> : "
)
)
)
(setq kd "1")
)
(cond
((= "1" kd)
(if (null (setq a (getreal "\nEscape Deep <0.1> : ")))
(setq a 0.1)
)
(if (null (setq r (getreal "\nEscape Radius <0.4> : ")))
(setq r 0.4)
)
(while (not ss)
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(tk1 e a r)
)
)
)
(t
(if (null (setq r (getreal "\nEscape Radius <0.4> : ")))
(setq r 0.4)
)
(while (not ss)
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(tk2 e r (= "2" kd))
)
)
)
)
(princ)
)
It does seem strange though that arc are converted to straight segments.
;; Author:Gu_xl 2013.05.08;;update: 2014.01.06
(defun c:tt (/ TK1 TK2 KD A R SS N E)
;;standard calculate
(defun tk1 (E A R / N EL I P1 P2
P3 CLOCKWISEP MIDANG CP MRP STP ENP
MP BULGE ARCDATA OBJ A1 A2 k
)
(setq obj (vlax-ename->vla-object e))
(if (vlax-curve-isClosed obj)
(progn
(setq i 0)
(setq n (fix (vlax-curve-getEndParam obj)))
)
(progn
(setq i 0)
(setq n (1- (fix (vlax-curve-getEndParam obj)) ))
)
)
(repeat n
(setq p1 (vlax-curve-getPointAtParam e i)
p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
p3 (vlax-curve-getPointAtParam e (1+ i))
)
(if (and
(vlax-curve-isClosed obj)
(equal i (vlax-curve-getEndParam obj) 1e-6)
)
(setq k 0)
(setq k i)
)
(if (and
(equal 0 (vla-GetBulge obj (1- i)) 1e-6)
(equal 0 (vla-GetBulge obj k) 1e-6)
)
(progn
(if (null p3) (setq p3 (vlax-curve-getPointAtParam e 1)))
(setq a1 (angle p2 p1)
a2 (angle p2 p3)
)
(setq clockwisep
(<
(* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(if (< a1 a2) (setq a1 (+ a1 pi pi)))
(setq midang (* 0.5 (+ a1 a2)))
(if clockwisep
(setq cp (polar p2 midang (- a r))
mrp (polar p2 midang a)
)
(setq cp (polar p2 midang (- r a))
mrp (polar p2 midang (- a))
)
)
(setq stp (car (vl-remove-if-not
'(lambda (x)
(equal (+ (distance p1 x) (distance p2 x))
(distance p1 p2)
1e-6
)
)
(IntersLineCircle p2 p1 cp r)
)
)
) ;_ Arc start
(setq enp (car (vl-remove-if-not
'(lambda (x)
(equal (+ (distance p3 x) (distance p2 x))
(distance p3 p2)
1e-6
)
)
(IntersLineCircle p2 p3 cp r)
)
)
) ;_ Arc end
(setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
(setq bulge (/ (distance mrp mp) (distance mp stp))) ;_ Bowstring ratio
(if clockwisep (setq bulge (- bulge)))
(setq arcdata (cons (list stp enp bulge) arcdata))
)
)
)
(setq arcdata (reverse arcdata))
(foreach data arcdata
(setq stp (car data)
enp (cadr data)
bulge (caddr data)
)
(setq n (fix (vlax-curve-getParamAtPoint
obj
(vlax-curve-getclosestpointto obj enp)
)
)
)
(vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
(if (vlax-curve-getPointAtParam obj (1+ n))
(vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
(vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
)
(vla-SetBulge obj n bulge)
)
)
;;clockwise
(defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
N k)
(setq obj (vlax-ename->vla-object e))
(setq polyClock (not (gxl-clock e)))
(setq i 0)
(if (vlax-curve-isClosed obj)
(progn
(setq i 0)
(setq n (fix (vlax-curve-getEndParam obj)))
)
(progn
(setq i 0)
(setq n (1- (fix (vlax-curve-getEndParam obj))))
)
)
(repeat n
(setq p1 (vlax-curve-getPointAtParam obj i)
p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
p3 (vlax-curve-getPointAtParam obj (1+ i))
)
(if (and
(vlax-curve-isClosed obj)
(equal i (vlax-curve-getEndParam obj) 1e-6)
)
(setq k 0)
(setq k i)
)
(if (and
(equal 0 (vla-GetBulge obj (1- i)) 1e-6)
(equal 0 (vla-GetBulge obj k) 1e-6)
)
(progn
(if (null p3) (setq p3 (vlax-curve-getPointAtParam obj 1)))
(cond
(polyClock ;_ Curve clockwise
(cond
(clock ;_
(setq arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil) arcdata))
)
(t ;_
(setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t) arcdata))
)
)
)
(t ;_ Curve counterclockwise
(cond
(clock ;_
(setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t) arcdata))
)
(t ;_
(setq arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil) arcdata))
)
)
)
)
)
)
)
(setq arcdata (reverse arcdata))
(foreach data arcdata
(setq pt (car data)
bulge (cadr data)
flag (caddr data)
)
(setq n (fix (vlax-curve-getParamAtPoint
obj
(vlax-curve-getclosestpointto obj pt)
)
)
)
(if (vlax-curve-getPointAtParam obj (1+ n))
(progn
(vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
(if flag
(vla-SetBulge obj (1+ n) bulge)
(vla-SetBulge obj n bulge)
)
)
(progn
(vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
(if flag
(vla-SetBulge obj 1 bulge)
(vla-SetBulge obj 0 bulge)
)
)
)
)
)
(initget "1 2 3")
(if (null
(setq kd (getkword "\n[standard(1)/clockwise(2)/counterclockwise(3)]<1>"))
)
(setq kd "1")
)
(cond
((= "1" kd)
(if (null (setq a (getreal "\nMagnitude<5.0>:")))
(setq a 5.0)
)
(if (null (setq r (getreal "\nAperture radius<10.0>:")))
(setq r 10.0)
)
(while (setq ss (ssget '((0 . "lwpolyline"))))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(tk1 e a r) ;_ trim
)
)
)
(t
(if (null (setq r (getreal "\nAperture radius<10.0>:")))
(setq r 10.0)
)
(while (setq ss (ssget '((0 . "*polyline"))))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(tk2 e r (= "2" kd)) ;_ trim
)
)
)
)
(princ)
)
;;*******************A custom function****************************
;; Line-Circle Intersection - Lee Mac
(defun IntersLineCircle ( p q c r / a d n s )
(setq n (mapcar '- q p)
p (trans p 0 n)
c (trans c 0 n)
a (list (car p) (cadr p) (caddr c))
)
(cond
( (equal r (setq d (distance c a)))
(list (trans a n 0))
)
( (< d r)
(setq s (sqrt (- (* r r) (* d d))))
(list
(trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
(trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
)
)
)
)
;;
(defun gxl-Ax:2DPoint (pt)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble '(0 . 1))
(list (car pt) (cadr pt))
)
)
)
;;
(defun gxl-clock (PLIST / LW MINP MAXP LST)
(cond ((= 'LIST (type plist))
(not
(minusp
(apply '+
(mapcar
(function
(lambda (a b)
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
plist
(cons (last plist) plist)
)
)
)
)
)
(t
(if (= 'ename (type plist))
(setq lw (vlax-ename->vla-object plist))
(if (= 'VLA-OBJECT (type plist))
(setq lw plist)
)
)
(vla-GetBoundingBox lw 'MinP 'MaxP)
(setq
minp (vlax-safearray->list minp)
MaxP (vlax-safearray->list MaxP)
lst (mapcar
(function
(lambda (x)
(vlax-curve-getParamAtPoint
lw
(vlax-curve-getClosestPointTo lw x)
)
)
)
(list minp
(list (car MaxP) (cadr minp))
MaxP
(list (car minp) (cadr MaxP))
)
)
)
(if (or
(<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
(<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
(<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
(<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
)
t
)
)
)
)