Topic: -={ Challenge }=- 3-Point Circle Tangent to Two Circles, with given Point.

[chlh_jd]

my new version

Code: [Select]

(defun c:t2 (/ foo cir1 cir2 pnt dxf1 dxf2 rad1 rad2 cen1 cen2 cr1)
  (defun foo (mode / is_go pl1 pl2 mp1 mp2 i)
    ;; Using  Asymptotic method
    ;; mode 1 -- outside 2 circles ; 2 -- include 2 circles
    ;;      3 -- include circle-1  ; 4 -- include circle-2
    ;; edited from highflybird's code , by GSLS(SS)
  (if (setq cr1 (3PCirCle pnt cen1 cen2)) (setq is_go T
i 0))
  (while is_go
    (setq pl1 (C_INT_C (car cr1) (cadr cr1) cen1 rad1)
  pl2 (C_INT_C (car cr1) (cadr cr1) cen2 rad2)  
  )
     (cond ((and pl1 (cadr pl1))
            (setq mp1 (midpt (car pl1) (cadr pl1)))
   )
  (pl1 (setq mp1 (car pl1)))
   )
    (cond ((and pl2 (cadr pl2))
            (setq mp2 (midpt (car pl2) (cadr pl2)))
   )
             (pl2 (setq mp2 (car pl2)))
  ) 
    (if (or (and (not pl1) (not pl2)) (and (not (cadr pl1)) (not (cadr pl2))) (and (equal (car pl1) (cadr pl1) 1e-3) (equal (car pl2) (cadr pl2) 1e-3 )))
      (setq is_go nil)
      (cond ((= mode 1)
     (setq cr1 (3PCirCle pnt (mapcar '+ cen1 (pt* (v2u (mapcar '- mp1 cen1)) rad1)) (mapcar '+ cen2 (pt* (v2u (mapcar '- mp2 cen2)) rad2))))
     )
    ((= mode 2)
     (setq cr1 (3PCirCle pnt (mapcar '+ cen1 (pt* (v2u (if (< i 1)(mapcar '- cen1 mp1) (mapcar '- mp1 cen1))) rad1)) (mapcar '+ cen2 (pt* (v2u (if (< i 1) (mapcar '- cen2 mp2) (mapcar '- mp2 cen2))) rad2))))
     )
    ((= mode 3)
     (setq cr1 (3PCirCle pnt (mapcar '+ cen1 (pt* (v2u (if (< i 1)(mapcar '- cen1 mp1) (mapcar '- mp1 cen1))) rad1)) (mapcar '+ cen2 (pt* (v2u (mapcar '- mp2 cen2)) rad2))))
     )
    ((= mode 4)
     (setq cr1 (3PCirCle pnt (mapcar '+ cen1 (pt* (v2u (mapcar '- mp1 cen1)) rad1)) (mapcar '+ cen2 (pt* (v2u (if (< i 1) (mapcar '- cen2 mp2) (mapcar '- mp2 cen2))) rad2))))
     )
    )     
      )
    (setq i (1+ i))
    )
    (princ (strcat "\nmode = " (rtos mode 2 0) "Recursive " (rtos (1+ i) 2 0) "times ."))
  (if cr1 (entmake (list (cons 0 "CIRCLE") (cons 10 (car cr1)) (cons 40 (cadr cr1)) (cons 62 mode))))
    )
  (setq cir1 (car (entsel "\nPick a circle:")))
  (setq cir2 (car (entsel "\nPick another circle:")))
  (setq pnt (getpoint "\nPick a point:"))
  (if (not (and cir1 cir2 pnt))
    (progn(princ "\nselection is not enough ." )(exit))
  )
  (setq dxf1 (entget cir1))
  (setq dxf2 (entget cir2))
  (setq rad1 (cdr (assoc 40 dxf1)))
  (setq rad2 (cdr (assoc 40 dxf2)))
  (setq cen1 (cdr (assoc 10 dxf1)))
  (setq cen2 (cdr (assoc 10 dxf2)))
  ;;
  (foo 1)
  ;;; 
  (foo 2)
  ;;;include circle-1 , outside circle-2
  (foo 3)
  ;;;include circle-2 , outside circle-1
  (foo 4)
  (princ) 
  )
(defun midpt (pta ptb)
  (mapcar (function (lambda (x y)
      (/ (+ x y) 2.0)
    )
  )
  pta
  ptb
  )
)
;;; unit vector
(defun v2u (v / l)
 (setq l (distance (list 0 0 0) v))
 (if (/= l 0)   
   (mapcar (function (lambda (x) (/ x l))) v)   
   )
)
;;;circle intersect with circle
(defun C_Int_C    (ce1 r1 ce2 r2 / dis a b)
  ;;by w_kai
  (setq dis (distance ce1 ce2))
  (cond
    ((equal dis (+ r1 r2))
     (list (polar ce1 (angle ce1 ce2) r1))
    )
    ((equal dis (abs (- r1 r2)))
     (if (minusp (- r1 r2))
       (list (polar ce2 (angle ce2 ce1) r2))
       (list (polar ce1 (angle ce1 ce2) r1))
     )
    )
    ((and (> dis (abs (- r1 r2)))
  (< dis (+ r1 r2))
     )
     (setq a (/ (- (+ (* dis dis) (* r1 r1))
    (* r2 r2)
)
(* 2. dis)
      )
     )
     (setq b (sqrt (- (* r1 r1) (* a a))))
     (list (polar (polar ce1 (angle ce1 ce2) a)
  (+ (angle ce1 ce2) (/ pi 2))
  b
   )
   (polar (polar ce1 (angle ce1 ce2) a)
  (- (angle ce1 ce2) (/ pi 2))
  b
   )
     )
    )
  )
)
;;;
;;; 三点圆函数
  (defun 3PCirCle
(P0 P1 P2 / X0 Y0 X1 Y1 X2 Y2 DX1 DY1 DX2 DY2 D 2D C1 C2 CE)
    ;;by highflybird
    (setq X0  (car P0)
  Y0  (cadr P0)
  X1  (car P1)
  Y1  (cadr P1)
  X2  (car P2)
  Y2  (cadr P2)
  DX1 (- X1 X0)
  DY1 (- Y1 Y0)
  DX2 (- X2 X0)
  DY2 (- Y2 Y0)
    )
    (setq D (- (* DX1 DY2) (* DX2 DY1)))
    (if (/= D 0.0)
      (progn
(setq 2D (+ D D)
      C1 (+ (* DX1 (+ X0 X1)) (* DY1 (+ Y0 Y1)))
      C2 (+ (* DX2 (+ X0 X2)) (* DY2 (+ Y0 Y2)))
      CE (List (/ (- (* C1 DY2) (* C2 DY1)) 2D)
       (/ (- (* C2 DX1) (* C1 DX2)) 2D)
)
)
(list CE (distance CE P0) (list p0 p1 p2))
      )
    )
  )



[xyp1964]

(defun c:tt ()
  (CMDLA0)
  (defun c3p (p0 p1 p2)
    (command "circle" "3p" p0 "tan" p1 "tan" p2)
  )
  (if (and (setq s1 (car (entsel "\nPick circle 1: ")))
      (setq s2 (car (entsel "\nPick circle 2: ")))
      (setq p1 (getpoint "\nPick a point: "))
      )
    (progn (setq s3   (xyp-line p1 (cdr (assoc 10 (entget s1))))
       s4   (xyp-line p1 (cdr (assoc 10 (entget s2))))
       ptn1 (xyp-get-Inters s3 s1 1)
       ptn2 (xyp-get-Inters s4 s2 1)
      )
      (entdel s3)
      (entdel s4)
      (c3p p1 (car ptn1) (car ptn2))
      (c3p p1 (cadr ptn1) (car ptn2))
      (c3p p1 (car ptn1) (cadr ptn2))
      (c3p p1 (cadr ptn1) (cadr ptn2))
    )
  )
  (CMDLA1)
)

[ElpanovEvgeniy]

Code: [Select]

(defun c:test () (vl-cmdf "_circle" "_3p" "_tan" pause "_tan" pause pause))

[ribarm]

chlh_jd, you forgot to include subfunction pt* in your new version :

Code: [Select]

;;; pt*
(defun pt* (v d)
  (mapcar (function (lambda (x) (* x d))) v)
)

M.R.

[chlh_jd]

chlh_jd, you forgot to include subfunction pt* in your new version :

Code: [Select]

;;; pt*
(defun pt* (v d)
  (mapcar (function (lambda (x) (* x d))) v)
)

M.R.

Sorry to forrget it , thank you  ribarm

[Rod]

New geometry challenge for those interested
Given two lines (or arcs) join the endpoints (one from each) with two arcs tangential to each other and tangential to the original objects.
This could be an S shape or a compound curve.
I have the answer already if you are interested but not in front of CAD today.

This is similar to the 2012 Blend command but using two arcs instead of a spline.
Eventually I'll write a routine to create this as a polyline and join the original objects

Regards Rod

[qjchen]

New geometry challenge for those interested
Given two lines (or arcs) join the endpoints (one from each) with two arcs tangential to each other and tangential to the original objects.
This could be an S shape or a compound curve.
I have the answer already if you are interested but not in front of CAD today.

This is similar to the 2012 Blend command but using two arcs instead of a spline.
Eventually I'll write a routine to create this as a polyline and join the original objects

Regards Rod

I think this problem should add one condition, whether this two arcs has the same radius?

[Rod]

I meant to also say that given a point one of the two arcs must go through the point.
Given any two lines and any point there is always an answer (except when the point lies on the natural fillet one or both of the lines)

[qjchen]

I meant to also say that given a point one of the two arcs must go through the point.
Given any two lines and any point there is always an answer (except when the point lies on the natural fillet)

This is my solution for 2 lines, and it is also the solution for 2 arcs. It is not so difficult into LISP.

[ribarm]

I've just finished code for all cases of tangent circle. (PPP, LPP, LLP, LLL, CPP, CLP, CLL, CCP, CCL, CCC)
There may be still some wrong results, as it is dependable from situation to situation, but all in all it is mostly acceptable...

Regards, M.R.

[chlh_jd]

Code: [Select]

(defun c:test () (vl-cmdf "_circle" "_3p" "_tan" pause "_tan" pause pause))

I believe this is the best solution 
I someone try to solve the equation :

Code: [Select]

;; (x1,y1) center of circle-1
;; (x2,y2) center of circle-2
;; (x,y) center of result circle
;; (a,b) point given .
;; --->
;; (x-x1)^2+(y-y1)^2=(r±r1)^2
;; (x-x2)^2+(y-y2)^2=(r±r2)^2
;; (x-a)^2+ (y-b)^2=r^2
;; ===>

There's a fun result :

Code: [Select]

(defun thp-t2c (p cen1 r1 cen2 r2 / a b x1 y1 x2 y2 mat cl)
  ;;just for fun
  (setq a  (car p)
b  (car p)
x1 (car cen1)
y1 (cadr cen1)
x2 (car cen2)
y2 (cadr cen2)
cl ((lambda (l)
      (mapcar
(function
  (lambda (x)
    (apply
      (function +)
      (mapcar (function (lambda (e1 e2) (* e1 e2 0.5)))
      l
      x
      )
    )
  )
)
(quote ((1 1 -1 -1 -1 1 0 0)
(-1 -1 1 0 0 0 1 1)
(0 0 0 -1 -1 1 1 1)
       )
)
      )
    )
     (list (* x1 x1)
   (* y1 y1)
   (* r1 r1)
   (* x2 x2)
   (* y2 y2)
   (* r2 r2)
   (* a a)
   (* b b)
     )
   )
  )
  (setq mat (list (list (- x1 x2) (- y1 y2))
  (list (- a x1) (- b y1))
  (list (- a x2) (- b y2))
    )
  )
  (mapcar (function (lambda (x / m)
      (setq m (mapcar (function append)
      mat
      (mapcar (function list)
      (mxv x (list r1 r2))
      )
      )
      )
      (mxv ([inv] m) cl)
    )
  )
  (quote (((1 -1) (-1 0) (0 -1))
   ((1 1) (-1 0) (0 1))
   ((-1 -1) (1 0) (0 -1))
   ((-1 1) (1 0) (0 1))
)
  )
  )
)


[Rod]

Most impressed took me a lot longer than you qjchen when this came up at work a while ago. Must admit I did have to go back to my old schoolbooks
Haven't been able to look at the code but will when I get a chance.

[Rod]

Sorry if I hijacked your post Lee

Solutions
For two lines that are not parallel are both pointing towards their point of apparent intersection (see towards offset)
OR
where the are both pointing away from their point of apparent intersection (see away offset)
(shown in white)
The endpoints can be joined using two arcs
(shown in red)
Construct an circle with the centre at the apparent intersection through the NEAREST endpoint
(Shown in yellow)
Construct a second circle using the 3P option through the apparent intersection of the furthermost endpoint and the circle you just created and the two endpoints
(shown in blue)
The tangent between the two arcs in the compound curve will lie on the second circle

For any two lines that are not parallel regardless of whether they are pointing towards their apparent intersection or not
(shown in white) (see in and out)
The endpoints can be joined using two arcs
(shown in red)
Construct an xline using the bisect method from each endpoint
bisect the angle between the extension of the line and the other endpoint
(Shown in yellow)
Construct a circle using the 3P option through the two endpoints and the intersection of the two xlines
(shown in blue)
The tangent between the two arcs in the compound curve will lie on the circle

[chlh_jd]

I post a pitcture that I understand Highflybird suggest method (Not necessary to dump into recursive),but I did not understand the case the point in Circles yet .
Add point at centers-line  case .
New version (recursive yet)

Code: [Select]

(defun c:t2 (/ foo cir1 cir2 pnt ent1 ent2 rad1 rad2 cen1 cen2 cr1 cr0 r1r2)
  ;_(setq gsls_debug "1")
  (defun foo (mode / is_go pl1 pl2 mp1 mp2 i);_(setq mode 2)
    ;; Using  Asymptotic method
    ;; mode 1 -- outside 2 circles ; 2 -- include 2 circles
    ;;      3 -- include circle-1  ; 4 -- include circle-2
    ;; edited from highflybird's code , by GSLS(SS)
    (if (setq cr1 cr0)
      (setq is_go T
    i 0
      )
    )
    (while is_go
      (setq pl1 (C_INT_C (car cr1) (cadr cr1) cen1 rad1)
    pl2 (C_INT_C (car cr1) (cadr cr1) cen2 rad2)
      )
      (cond ((and pl1 (cadr pl1))
     (setq mp1 (midpt (car pl1) (cadr pl1)))
    )
    (pl1 (setq mp1 (car pl1)))    
      )
      (cond ((and pl2 (cadr pl2))
     (setq mp2 (midpt (car pl2) (cadr pl2)))
    )
    (pl2 (setq mp2 (car pl2)))    
      )
      ;_for test
      (if(and (= gsls_debug "1") (or (not mp1) (not mp2)))
(progn
     (entmake (list (cons 0 "CIRCLE")
    (cons 10 (car cr1))
    (cons 40 (cadr cr1))
      )
     )
     (princ (strcat "\nError : mode = "
    (rtos mode 2 0)
    " Recursive "
    (rtos (1+ i) 2 0)
    "times  ."
    )
     ))
);_test
      (if (or (and (not pl1) (not pl2))
      (and (not (cadr pl1)) (not (cadr pl2)))
      (and (equal (car pl1) (cadr pl1) 1e-3)
   (equal (car pl2) (cadr pl2) 1e-3)
      )
      (not mp1)
      (not mp2)
  )
(setq is_go nil)
(cond ((= mode 1)
       (setq cr1
      (3PCirCle pnt
(mapcar '+
cen1
(pt* (v2u (mapcar '- mp1 cen1)) rad1)
)
(mapcar '+
cen2
(pt* (v2u (mapcar '- mp2 cen2)) rad2)
)
      )
       )
      )
      ((= mode 2)
       (setq
cr1 (3PCirCle pnt
       (mapcar '+
       cen1
       (pt* (v2u (if (< i 1)
   (mapcar '- cen1 mp1)
   (mapcar '- mp1 cen1)
)
    )
    rad1
       )
       )
       (mapcar '+
       cen2
       (pt* (v2u (if (< i 1)
   (mapcar '- cen2 mp2)
   (mapcar '- mp2 cen2)
)
    )
    rad2
       )
       )
     )
       )
      )
      ((= mode 3)
       (setq cr1
      (3PCirCle pnt
(mapcar '+
cen1
(pt* (v2u (if (< i 1)
    (mapcar '- cen1 mp1)
    (mapcar '- mp1 cen1)
  )
     )
     rad1
)
)
(mapcar '+
cen2
(pt* (v2u (mapcar '- mp2 cen2)) rad2)
)
      )
       )
      )
      ((= mode 4)
       (setq cr1
      (3PCirCle pnt
(mapcar '+
cen1
(pt* (v2u (mapcar '- mp1 cen1)) rad1)
)
(mapcar '+
cen2
(pt* (v2u (if (< i 1)
    (mapcar '- cen2 mp2)
    (mapcar '- mp2 cen2)
  )
     )
     rad2
)
)
      )
       )
      )
)
      )
      (setq i (1+ i))
    )
    (princ (strcat "\nmode = "
   (rtos mode 2 0)
   "Recursive "
   (rtos i 2 0)
   "times ."
   )
    )
    (if cr1
      (entmake (list (cons 0 "CIRCLE")
     (cons 10 (car cr1))
     (cons 40 (cadr cr1))
     (cons 62 mode)
       )
      )
    )
  )
  (setq cir1 (car (entsel "\nPick a circle:")))
  (setq cir2 (car (entsel "\nPick another circle:")))
  (setq pnt (getpoint "\nPick a point:"))
  (if (not (and cir1 cir2 pnt))
    (progn (princ "\nselection is not enough .") (exit))
  )
  (setq ent1 (entget cir1)
ent2 (entget cir2)
rad1 (cdr (assoc 40 ent1))
rad2 (cdr (assoc 40 ent2))
cen1 (cdr (assoc 10 ent1))
cen2 (cdr (assoc 10 ent2))
r1r2 (distance cen1 cen2) ;_wheelbase
off  (abs (ss-get-d pnt cen1 cen2)) ;_off_axis distance
  )
  (cond
    ((>= r1r2 (+ rad1 rad2))
     (if (or (< (distance pnt cen1) rad1)
     (< (distance pnt cen2) rad2)
)
       (progn (princ "\nError:Point in Circle !") (exit))
       (cond ((<= off 1e-6)
      (setq cr0 (3pcircle pnt
  (polar cen1
(+ (angle cen1 cen2) (/ pi 2))
(/ rad1 2.)
  )
  (polar cen2
(- (angle cen1 cen2) (/ pi 2))
(/ rad2 2.)
  )
)
      )
     )
     (t (setq cr0 (3pcircle pnt cen1 cen2)))
       )
     )
    )
    ((< (abs (- rad1 rad2)) r1r2 (+ rad1 rad2))
     (cond ((<= off 1e-6)
    (setq cr0
   (3pcircle
     pnt
     (polar cen1 (+ (angle cen1 cen2) (/ pi 2)) (/ rad1 2.))
     (polar cen2 (- (angle cen1 cen2) (/ pi 2)) (/ rad2 2.))
   )
    )
   )
   ;|(t (setq cr0 (3pcircle pnt cen1 cen2)))|;
   (t (setq cr0 (3pcircle pnt (polar cen1 (angle cen2 cen1) rad1) (polar cen2 (angle cen1 cen2) rad2))))
     )
    )
    (t
     (cond ((> rad1 rad2)
    (cond ((or (> (distance pnt cen1) rad1)
       (< (distance pnt cen2) rad2)
   )
   (princ "\nError:Point must between the tow Circle !")
   (exit)
  )
  ((<= off 1e-6)
   (setq cr0 (3pcircle pnt
       (polar cen1 (angle cen2 cen1) rad1)
       (polar cen2
      (- (angle cen1 cen2) (/ pi 2))
      (/ rad2 2.)
       )
     )
   )
  )
  (t
   (setq cr0 (3pcircle pnt
       (polar cen1 (angle cen2 cen1) rad1)
       (polar cen2 (angle cen1 cen2) rad2)
     )
   )
  )
    )
   )
   ((< rad1 rad2)
    (cond ((or (> (distance pnt cen2) rad2)
       (< (distance pnt cen1) rad1)
   )
   (princ "\nError:Point must between the tow Circle !")
   (exit)
  )
  ((<= off 1e-6)
   (setq cr0 (3pcircle pnt
       (polar cen2 (angle cen1 cen2) rad2)
       (polar cen1
      (- (angle cen2 cen1) (/ pi 2))
      (/ rad1 2.)
       )
     )
   )
  )
  (t
   (setq cr0 (3pcircle pnt
       (polar cen2 (angle cen1 cen2) rad2)
       (polar cen1 (angle cen2 cen1) rad1)
     )
   )
  )
    )
   )
     )
    )
  )
  ;;
  (foo 1)
;;; 
  (foo 2)
;;;
  (foo 3)
;;;
  (foo 4)
  (princ)
)
(defun midpt (pta ptb)
  (mapcar (function (lambda (x y)
      (/ (+ x y) 2.0)
    )
  )
  pta
  ptb
  )
)
;;; unit vector
(defun v2u (v / l)
  (setq l (distance (list 0 0 0) v))
  (if (/= l 0)
    (mapcar (function (lambda (x) (/ x l))) v)
  )
)
;;;circle intersect with circle
(defun C_Int_C (ce1 r1 ce2 r2 / dis a b)
  ;;by w_kai
  (setq dis (distance ce1 ce2))
  (cond
    ((equal dis (+ r1 r2))
     (list (polar ce1 (angle ce1 ce2) r1))
    )
    ((equal dis (abs (- r1 r2)))
     (if (minusp (- r1 r2))
       (list (polar ce2 (angle ce2 ce1) r2))
       (list (polar ce1 (angle ce1 ce2) r1))
     )
    )
    ((and (> dis (abs (- r1 r2)))
  (< dis (+ r1 r2))
     )
     (setq a (/ (- (+ (* dis dis) (* r1 r1))
   (* r2 r2)
)
(* 2. dis)
     )
     )
     (setq b (sqrt (max 0 (- (* r1 r1) (* a a)))))
     (list (polar (polar ce1 (angle ce1 ce2) a)
  (+ (angle ce1 ce2) (/ pi 2))
  b
   )
   (polar (polar ce1 (angle ce1 ce2) a)
  (- (angle ce1 ce2) (/ pi 2))
  b
   )
     )
    )
  )
)
;;;
;;; 三点圆函数
(defun 3PCirCle
       (P0 P1 P2 / X0 Y0 X1 Y1 X2 Y2 DX1 DY1 DX2 DY2 D 2D C1 C2 CE)
  ;;by highflybird
  (setq X0  (car P0)
Y0  (cadr P0)
X1  (car P1)
Y1  (cadr P1)
X2  (car P2)
Y2  (cadr P2)
DX1 (- X1 X0)
DY1 (- Y1 Y0)
DX2 (- X2 X0)
DY2 (- Y2 Y0)
  )
  (setq D (- (* DX1 DY2) (* DX2 DY1)))
  (if (/= D 0.0)
    (progn
      (setq 2D (+ D D)
    C1 (+ (* DX1 (+ X0 X1)) (* DY1 (+ Y0 Y1)))
    C2 (+ (* DX2 (+ X0 X2)) (* DY2 (+ Y0 Y2)))
    CE (List (/ (- (* C1 DY2) (* C2 DY1)) 2D)
     (/ (- (* C2 DX1) (* C1 DX2)) 2D)
       )
      )
      (list CE (distance CE P0) (list p0 p1 p2))
    )
  )
)
(defun pt* (pt1 sc)
  (mapcar (function (lambda (x)
      (* x sc)
    )
  )
  pt1
  )
)
(defun ss-get-d (pt p1 p2)
  (car (trans (mapcar (function -) pt p2) 0 (mapcar (function -) p1 p2)))
)


[ribarm]

Here is yours subfunction in c:ci1xci2 :

Code: [Select]

(defun c:ci1xci2 ( / ssci1 ssci2 ci1 c1 r1 ci2 c2 r2 lst )
  (while (null ssci1)
    (prompt "\nPick first circle")
    (setq ssci1 (ssget "_+.:E:S" (list (cons 0 "CIRCLE") (cons 210 (list 0.0 0.0 1.0)))))
  )
  (while (or (null ssci2) (equal (ssname ssci1 0) (ssname ssci2 0)) )
    (prompt "\nPick second circle")
    (setq ssci2 (ssget "_+.:E:S" (list (cons 0 "CIRCLE") (cons 210 (list 0.0 0.0 1.0)))))
  )
  (setq ci1 (ssname ssci1 0))
  (setq c1 (cdr (assoc 10 (entget ci1))))
  (setq r1 (cdr (assoc 40 (entget ci1))))
  (setq ci2 (ssname ssci2 0))
  (setq c2 (cdr (assoc 10 (entget ci2))))
  (setq r2 (cdr (assoc 40 (entget ci2))))
  (setq lst (C_Int_C c1 r1 c2 r2))
  (princ lst)
(princ)
)

;;;circle intersect with circle
(defun C_Int_C    (ce1 r1 ce2 r2 / dis a b)
  ;;by w_kai
  (setq dis (distance ce1 ce2))
  (cond
    ((equal dis (+ r1 r2))
     (list (polar ce1 (angle ce1 ce2) r1))
    )
    ((equal dis (abs (- r1 r2)))
     (if (minusp (- r1 r2))
       (list (polar ce2 (angle ce2 ce1) r2))
       (list (polar ce1 (angle ce1 ce2) r1))
     )
    )
    ((and (> dis (abs (- r1 r2)))
  (< dis (+ r1 r2))
     )
     (setq a (/ (- (+ (* dis dis) (* r1 r1))
    (* r2 r2)
)
(* 2. dis)
      )
     )
     (setq b (sqrt (- (* r1 r1) (* a a))))
     (list (polar (polar ce1 (angle ce1 ce2) a)
  (+ (angle ce1 ce2) (/ pi 2))
  b
   )
   (polar (polar ce1 (angle ce1 ce2) a)
  (- (angle ce1 ce2) (/ pi 2))
  b
   )
     )
    )
  )
)

And here is mine command function c:ci1xci2 :

Code: [Select]

;; ArcCosine
;; Args: -1 <= x <= 1

(defun acos ( x )
    (cond
        (   (equal x 1.0 1e-8) 0.0)
        (   (equal x -1.0 1e-8) PI)
        (   (atan (sqrt (- 1.0 (* x x))) x))
    )
)

;; ci1xci2

(defun c:ci1xci2 ( / ssci1 ssci2 ci1 c1 r1 ci2 c2 r2 d b h x1 x2 px1 px2 p1 p2 ptl )
  (while (null ssci1)
    (prompt "\nPick first circle")
    (setq ssci1 (ssget "_+.:E:S" (list (cons 0 "CIRCLE") (cons 210 (list 0.0 0.0 1.0)))))
  )
  (while (or (null ssci2) (equal (ssname ssci1 0) (ssname ssci2 0)) )
    (prompt "\nPick second circle")
    (setq ssci2 (ssget "_+.:E:S" (list (cons 0 "CIRCLE") (cons 210 (list 0.0 0.0 1.0)))))
  )
  (setq ci1 (ssname ssci1 0))
  (setq c1 (cdr (assoc 10 (entget ci1))))
  (setq r1 (cdr (assoc 40 (entget ci1))))
  (setq ci2 (ssname ssci2 0))
  (setq c2 (cdr (assoc 10 (entget ci2))))
  (setq r2 (cdr (assoc 40 (entget ci2))))
  (setq d (distance c1 c2))
  (if (and (> d r1) (> d r2))
    (progn
    (setq h (/ (* r1 r2 (sin (acos (/ (+ (* r1 r1) (* r2 r2) (- (* d d))) (* 2 r1 r2))))) d))
    (setq x1 (sqrt (- (* r1 r1) (* h h))))
    (setq x2 (sqrt (- (* r2 r2) (* h h))))
    (setq px1 (polar c1 (angle c1 c2) x1))
    (setq px2 (polar c2 (angle c2 c1) x2))
    (if (equal px1 px2 1e-6) (setq px px1) )
    (setq p1 (polar px (+ (angle c1 c2) (/ PI 2)) h))
    (setq p2 (polar px (- (angle c1 c2) (/ PI 2)) h))
    (if (equal p1 p2 1e-4) (setq ptl (cons p1 ptl)) (progn (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl))) )
    )
  )
  (if (and (> r1 r2) (or (<= d r1) (<= d r2)))
    (progn
    (setq b (/ (- (* r1 r1) (* r2 r2) (* d d)) (* 2 d)))
    (setq h (sqrt (- (* r2 r2) (* b b))))
    (setq px (polar c1 (angle c1 c2) (+ b d)))
    (setq p1 (polar px (+ (angle c1 c2) (/ PI 2)) h))
    (setq p2 (polar px (- (angle c1 c2) (/ PI 2)) h))
    (if (equal p1 p2 1e-4) (setq ptl (cons p1 ptl)) (progn (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl))) )
    )
  )
  (if (and (> r2 r1) (or (<= d r1) (<= d r2)))
    (progn
    (setq b (/ (- (* r2 r2) (* r1 r1) (* d d)) (* 2 d)))
    (setq h (sqrt (- (* r1 r1) (* b b))))
    (setq px (polar c2 (angle c2 c1) (+ b d)))
    (setq p1 (polar px (+ (angle c1 c2) (/ PI 2)) h))
    (setq p2 (polar px (- (angle c1 c2) (/ PI 2)) h))
    (if (equal p1 p2 1e-4) (setq ptl (cons p1 ptl)) (progn (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl))) )
    )
  )
  (if (and (= r1 r2) (= r1 d))
    (progn
    (setq h (* d (/ (sqrt 3) 2)))
    (setq px (polar c1 (angle c1 c2) (/ d 2)))
    (setq p1 (polar px (+ (angle c1 c2) (/ PI 2)) h))
    (setq p2 (polar px (- (angle c1 c2) (/ PI 2)) h))
    (if (equal p1 p2 1e-4) (setq ptl (cons p1 ptl)) (progn (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl))) )
    )
  )
  (if (and (= r1 r2) (< d r1))
    (progn
    (setq px (polar c1 (angle c1 c2) (/ (distance c1 c2) 2)))
    (setq h (sqrt (- (* r1 r1) (expt (/ (distance c1 c2) 2) 2))))
    (setq p1 (polar px (+ (angle c1 c2) (/ PI 2)) h))
    (setq p2 (polar px (- (angle c1 c2) (/ PI 2)) h))
    (if (equal p1 p2 1e-4) (setq ptl (cons p1 ptl)) (progn (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl))) )
    )
  )
  (if ptl
    (princ ptl)
  )
(princ)
)

Check it for this case :