;-------------------------------------------------; ; Apollonius problem - solved ALISP ROUTINE ; ;-------------------------------------------------; ; Author : Marko Ribar, d.i.a. (architect) ; ; Copyright (C) - All rights reserved, 03.2020. ; ;-------------------------------------------------; ; You have permission to copy any part of code ; ; with guarantee that this header will be ; ; present in material that is modified or ; ; partly remained the same as in this routine ; ; version. If header is removed, you are ; ; responsible to mention author and link from ; ; where the code is publiced with explicit ; ; mark that material is copyrighted and is not ; ; for further distribution or selling or base ; ; for gaining any material or any other benefit ; ; than for learning and study and eventual ; ; improvement of its present functionality. ; ;-------------------------------------------------; (defun c:Apollonius-problem-solved nil ;; Unique List (defun unique ( l ) (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l) 1e-6)) l)))) ) ;; Normal Vectors (defun nor+ ( v ) (polar '(0 0 0) (+ (angle '(0 0 0) v) 1.5707963267948966192313216916395) 1.0) ) (defun nor- ( v ) (polar '(0 0 0) (- (angle '(0 0 0) v) 1.5707963267948966192313216916395) 1.0) ) ;; Mid point (defun mid ( a b ) (mapcar '(lambda ( x y ) (/ (+ x y) 2.0)) a b) ) ;; Dist point to line (defun pdl ( a b p / ab nab pp ppp d ) (setq ab (mapcar '- b a)) (setq nab (nor+ ab)) (setq pp (mapcar '+ p nab)) (setq ppp (inters a b p pp nil)) (setq d (distance p ppp)) d ) ;; ci1xci2 ;; 2-Circle Intersection (trans version) - Lee Mac ;; Returns the point(s) of intersection between two circles ;; with centres c1,c2 and radii r1,r2 (defun ci1xci2 ( c1 r1 c2 r2 / n d1 x z ) (if (and (or (< (setq d1 (distance c1 c2)) (+ r1 r2)) (equal d1 (+ r1 r2) 1e-6)) (or (< (abs (- r1 r2)) d1) (equal (abs (- r1 r2)) d1 1e-6)) ) (progn (setq n (mapcar '- c2 c1) c1 (trans c1 0 n) z (abs (/ (- (+ (* r1 r1) (* d1 d1)) (* r2 r2)) (+ d1 d1))) ) (if (equal z r1 1e-6) (list (trans (list (car c1) (cadr c1) (+ (caddr c1) z)) n 0)) (progn (setq x (sqrt (- (* r1 r1) (* z z)))) (list (trans (list (- (car c1) x) (cadr c1) (+ (caddr c1) z)) n 0) (trans (list (+ (car c1) x) (cadr c1) (+ (caddr c1) z)) n 0) ) ) ) ) ) ) ;; cixli ;; Circle-Line Intersection - M.R. (defun cixli ( c r a b / ab cp pp p d h p1 p2 ptl ) (setq ab (mapcar '- b a)) (setq cp (nor+ ab)) (setq pp (mapcar '+ c cp)) (setq p (inters a b c pp nil)) (setq d (distance c p)) (if (or (< d r) (equal d r 1e-6)) (if (equal d r 1e-6) (setq ptl (cons p ptl)) (progn (setq h (sqrt (- (* r r) (* d d)))) (setq p1 (polar p (angle a b) h)) (setq p2 (polar p (angle b a) h)) (setq ptl (cons p2 ptl)) (setq ptl (cons p1 ptl)) ) ) ) ptl ) ;; PPP (defun PPP ( p1 p2 p3 / mp1p2 mp1p3 mp2p3 p1p2 p1p3 p2p3 np1p2 np1p3 np2p3 pnp1p2 pnp1p3 pnp2p3 o1 o2 o3 o r lst ) (setq mp1p2 (mid p1 p2)) (setq mp1p3 (mid p1 p3)) (setq mp2p3 (mid p2 p3)) (setq p1p2 (mapcar '- p2 p1)) (setq p1p3 (mapcar '- p3 p1)) (setq p2p3 (mapcar '- p3 p2)) (setq np1p2 (nor+ p1p2)) (setq np1p3 (nor+ p1p3)) (setq np2p3 (nor+ p2p3)) (setq pnp1p2 (mapcar '+ mp1p2 np1p2)) (setq pnp1p3 (mapcar '+ mp1p3 np1p3)) (setq pnp2p3 (mapcar '+ mp2p3 np2p3)) (setq o1 (inters mp1p2 pnp1p2 mp1p3 pnp1p3 nil)) (setq o2 (inters mp1p2 pnp1p2 mp2p3 pnp2p3 nil)) (setq o3 (inters mp2p3 pnp2p3 mp1p3 pnp1p3 nil)) (if (and (equal o1 o2 1e-6) (equal o1 o3 1e-6) (equal o2 o3 1e-6)) (setq o o1) ) (if o (progn (setq r (distance o p1)) (setq lst (list o r)) ) ) lst ) ;; LLL (defun LLL ( a1 b1 a2 b2 a3 b3 / p1 p2 p3 p12 p13 p21 p23 p31 p32 p13- p23- p12- p32- p21- p31- mp1 mp2 mp3 o1 o2 o3 o r lst ) (setq p1 (inters a1 b1 a2 b2 nil)) (setq p2 (inters a1 b1 a3 b3 nil)) (setq p3 (inters a2 b2 a3 b3 nil)) (setq p12 (polar p1 (angle p1 p2) 1.0)) (setq p13 (polar p1 (angle p1 p3) 1.0)) (setq p21 (polar p2 (angle p2 p1) 1.0)) (setq p23 (polar p2 (angle p2 p3) 1.0)) (setq p31 (polar p3 (angle p3 p1) 1.0)) (setq p32 (polar p3 (angle p3 p2) 1.0)) (setq mp1 (mid p12 p13)) (setq mp2 (mid p21 p23)) (setq mp3 (mid p31 p32)) (setq o1 (inters p1 mp1 p2 mp2 nil)) (setq o2 (inters p1 mp1 p3 mp3 nil)) (setq o3 (inters p2 mp2 p3 mp3 nil)) (if (and (equal o1 o2 1e-6) (equal o1 o3 1e-6) (equal o2 o3 1e-6)) (setq o o1) ) (if o (progn (setq r (pdl a1 b1 o)) (setq lst (cons (list o r) lst)) ) ) (setq p13- (polar p1 (angle p1 p3) -1.0)) (setq p23- (polar p2 (angle p2 p3) -1.0)) (setq mp1 (mid p12 p13-)) (setq mp2 (mid p21 p23-)) (setq o (inters p1 mp1 p2 mp2 nil)) (setq r (pdl a1 b1 o)) (setq lst (cons (list o r) lst)) (setq p12- (polar p1 (angle p1 p2) -1.0)) (setq p32- (polar p3 (angle p3 p2) -1.0)) (setq mp1 (mid p13 p12-)) (setq mp3 (mid p31 p32-)) (setq o (inters p1 mp1 p3 mp3 nil)) (setq r (pdl a2 b2 o)) (setq lst (cons (list o r) lst)) (setq p21- (polar p2 (angle p2 p1) -1.0)) (setq p31- (polar p3 (angle p3 p1) -1.0)) (setq mp2 (mid p23 p21-)) (setq mp3 (mid p32 p31-)) (setq o (inters p2 mp2 p3 mp3 nil)) (setq r (pdl a3 b3 o)) (setq lst (cons (list o r) lst)) (unique lst) ) ;;; LPP (defun LPP ( a b p1 p2 / p d1 d2 mp r1 p1p2 np1p2 pnp1p2 pcixli r2 p31 p32 lst1 lst2 pp lst ) (setq p (inters a b p1 p2 nil)) (if p (progn (setq d1 (distance p1 p)) (setq d2 (distance p2 p)) (if (> d1 d2) (setq mp (mid p1 p)) (setq mp (mid p2 p)) ) (setq r1 (distance mp p)) (setq p1p2 (mapcar '- p2 p1)) (setq np1p2 (nor+ p1p2)) (if (> d1 d2) (progn (setq pnp1p2 (mapcar '+ p2 np1p2)) (setq pcixli (car (cixli mp r1 p2 pnp1p2)))) (progn (setq pnp1p2 (mapcar '+ p1 np1p2)) (setq pcixli (car (cixli mp r1 p1 pnp1p2)))) ) (setq r2 (distance p pcixli)) (setq p31 (car (cixli p r2 a b))) (setq p32 (cadr (cixli p r2 a b))) (if p31 (setq lst1 (PPP p1 p2 p31)) ) (if p32 (setq lst2 (PPP p1 p2 p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a b)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a b)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) (progn (setq pp (inters a b (mid p1 p2) (mapcar '+ (mid p1 p2) (nor+ (mapcar '- p1 p2))) nil)) (setq lst (cons (PPP pp p1 p2) lst)) ) ) (unique lst) ) ;;; LLP (defun LLP ( a1 b1 a2 b2 p / pp pp1 pp2 mpp ppmpp nppmpp pnppmpp pplixli vnor pppp pppparppmpp d1 d2 ppppp mppppp pcixli p31 p32 lst1 lst2 lst ) (setq pp (inters a1 b1 a2 b2 nil)) (if (< (length lst) 2) (progn (setq pp1 (car (cixli pp 1.0 a1 b1))) (setq pp2 (car (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (car (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (cadr (cixli pp 1.0 a1 b1))) (setq pp2 (car (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (car (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (car (cixli pp 1.0 a1 b1))) (setq pp2 (cadr (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (car (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (cadr (cixli pp 1.0 a1 b1))) (setq pp2 (cadr (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (car (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (car (cixli pp 1.0 a1 b1))) (setq pp2 (car (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (cadr (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (cadr (cixli pp 1.0 a1 b1))) (setq pp2 (car (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (cadr (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (car (cixli pp 1.0 a1 b1))) (setq pp2 (cadr (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (cadr (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (if (< (length lst) 2) (progn (setq pp1 (cadr (cixli pp 1.0 a1 b1))) (setq pp2 (cadr (cixli pp 1.0 a2 b2))) (setq mpp (mid pp1 pp2)) (setq ppmpp (mapcar '- mpp pp)) (setq nppmpp (nor+ ppmpp)) (setq pnppmpp (mapcar '+ p nppmpp)) (setq pplixli (inters pp mpp p pnppmpp nil)) (setq vnor (mapcar '- pplixli p)) (setq pppp (mapcar '+ pplixli vnor)) (setq pppparppmpp (mapcar '+ pppp ppmpp)) (setq d1 (pdl a1 b1 p)) (setq d2 (pdl a2 b2 p)) (if (> d1 d2) (setq ppppp (inters p pppp a1 b1 nil)) (setq ppppp (inters p pppp a2 b2 nil)) ) (setq mppppp (mid p ppppp)) (setq pcixli (cadr (cixli mppppp (distance mppppp p) pppp pppparppmpp))) (if pcixli (progn (if (> d1 d2) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a1 b1))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a1 b1)))) (progn (setq p31 (car (cixli ppppp (distance ppppp pcixli) a2 b2))) (setq p32 (cadr (cixli ppppp (distance ppppp pcixli) a2 b2)))) ) (if (and pppp p31) (setq lst1 (PPP p pppp p31)) ) (if (and pppp p32) (setq lst2 (PPP p pppp p32)) ) (if (and lst2 (= (length (cixli (car lst2) (cadr lst2) a1 b1)) 1) (= (length (cixli (car lst2) (cadr lst2) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (cixli (car lst1) (cadr lst1) a1 b1)) 1) (= (length (cixli (car lst1) (cadr lst1) a2 b2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) (unique lst) ) ;; CPP (defun CPP ( c r p1 p2 / p1c p2c mpcp1 mpcp2 ptsnp1c ptsnp2c pp1 pp2 cc mpccc p31 p32 lst1 lst2 lst ) (setq p1c (mapcar '- c p1)) (setq p2c (mapcar '- c p2)) (setq mpcp1 (mid c p1)) (setq mpcp2 (mid c p2)) (setq ptsnp1c (ci1xci2 c r mpcp1 (distance mpcp1 p1))) (setq ptsnp2c (ci1xci2 c r mpcp2 (distance mpcp2 p2))) (setq pp1 (inters c p1 (car ptsnp1c) (cadr ptsnp1c) nil)) (setq pp2 (inters c p2 (car ptsnp2c) (cadr ptsnp2c) nil)) (setq cc (inters p1 p2 pp1 pp2 nil)) (setq mpccc (mid c cc)) (setq p31 (car (ci1xci2 mpccc (distance mpccc cc) c r))) (setq p32 (cadr (ci1xci2 mpccc (distance mpccc cc) c r))) (if p31 (setq lst1 (PPP p1 p2 p31)) ) (if p32 (setq lst2 (PPP p1 p2 p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c r)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c r)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) (unique lst) ) ;; CLP (defun CLP ( c r a b p / ab nab cn plixli ptsci pp1 pp2 lst ) (setq ab (mapcar '- b a)) (setq nab (nor+ ab)) (setq cn (mapcar '+ c nab)) (setq plixli (inters a b c cn nil)) (setq ptsci (cixli c r c cn)) (if (< (length lst) 4) (progn (setq pp1 (car (cixli (car (PPP (cadr ptsci) plixli p)) (cadr (PPP (cadr ptsci) plixli p)) p (car ptsci)))) (setq pp2 (car (cixli (car (PPP (car ptsci) plixli p)) (cadr (PPP (car ptsci) plixli p)) p (cadr ptsci)))) (setq lst (append lst (if (and pp1 (not (equal p pp1 1e-6))) (LPP a b p pp1)) (if (and pp2 (not (equal p pp2 1e-6))) (LPP a b p pp2)))) (foreach x lst (if (and x (or (/= (length (cixli (car x) (cadr x) a b)) 1) (/= (length (ci1xci2 (car x) (cadr x) c r)) 1))) (setq lst (subst (list x t) x lst)) ) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (eq (cadr x) T)) lst)) (setq lst (unique lst)) (if (< (length lst) 4) (progn (setq pp1 (cadr (cixli (car (PPP (cadr ptsci) plixli p)) (cadr (PPP (cadr ptsci) plixli p)) p (car ptsci)))) (setq pp2 (car (cixli (car (PPP (car ptsci) plixli p)) (cadr (PPP (car ptsci) plixli p)) p (cadr ptsci)))) (setq lst (append lst (if (and pp1 (not (equal p pp1 1e-6))) (LPP a b p pp1)) (if (and pp2 (not (equal p pp2 1e-6))) (LPP a b p pp2)))) (foreach x lst (if (and x (or (/= (length (cixli (car x) (cadr x) a b)) 1) (/= (length (ci1xci2 (car x) (cadr x) c r)) 1))) (setq lst (subst (list x t) x lst)) ) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (eq (cadr x) T)) lst)) (setq lst (unique lst)) (if (< (length lst) 4) (progn (setq pp1 (car (cixli (car (PPP (cadr ptsci) plixli p)) (cadr (PPP (cadr ptsci) plixli p)) p (car ptsci)))) (setq pp2 (cadr (cixli (car (PPP (car ptsci) plixli p)) (cadr (PPP (car ptsci) plixli p)) p (cadr ptsci)))) (setq lst (append lst (if (and pp1 (not (equal p pp1 1e-6))) (LPP a b p pp1)) (if (and pp2 (not (equal p pp2 1e-6))) (LPP a b p pp2)))) (foreach x lst (if (and x (or (/= (length (cixli (car x) (cadr x) a b)) 1) (/= (length (ci1xci2 (car x) (cadr x) c r)) 1))) (setq lst (subst (list x t) x lst)) ) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (eq (cadr x) T)) lst)) (setq lst (unique lst)) (if (< (length lst) 4) (progn (setq pp1 (cadr (cixli (car (PPP (cadr ptsci) plixli p)) (cadr (PPP (cadr ptsci) plixli p)) p (car ptsci)))) (setq pp2 (cadr (cixli (car (PPP (car ptsci) plixli p)) (cadr (PPP (car ptsci) plixli p)) p (cadr ptsci)))) (setq lst (append lst (if (and pp1 (not (equal p pp1 1e-6))) (LPP a b p pp1)) (if (and pp2 (not (equal p pp2 1e-6))) (LPP a b p pp2)))) (foreach x lst (if (and x (or (/= (length (cixli (car x) (cadr x) a b)) 1) (/= (length (ci1xci2 (car x) (cadr x) c r)) 1))) (setq lst (subst (list x t) x lst)) ) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (eq (cadr x) T)) lst)) (unique lst) ) ;; CLL (defun CLL ( c r a1 b1 a2 b2 / p a1b1 na1b1+ na1b1- a2b2 na2b2+ na2b2- a1+ b1+ a1- b1- a1 b1 a2+ b2+ a2- b2- a2 b2 lsto rr cc lst ) (setq p c) (setq a1b1 (mapcar '- b1 a1)) (setq na1b1+ (nor+ a1b1)) (setq na1b1- (nor- a1b1)) (setq a2b2 (mapcar '- b2 a2)) (setq na2b2+ (nor+ a2b2)) (setq na2b2- (nor- a2b2)) (setq a1+ (mapcar '+ a1 (mapcar '(lambda ( x ) (* x r)) na1b1+))) (setq b1+ (mapcar '+ b1 (mapcar '(lambda ( x ) (* x r)) na1b1+))) (setq a1- (mapcar '+ a1 (mapcar '(lambda ( x ) (* x r)) na1b1-))) (setq b1- (mapcar '+ b1 (mapcar '(lambda ( x ) (* x r)) na1b1-))) (setq a2+ (mapcar '+ a2 (mapcar '(lambda ( x ) (* x r)) na2b2+))) (setq b2+ (mapcar '+ b2 (mapcar '(lambda ( x ) (* x r)) na2b2+))) (setq a2- (mapcar '+ a2 (mapcar '(lambda ( x ) (* x r)) na2b2-))) (setq b2- (mapcar '+ b2 (mapcar '(lambda ( x ) (* x r)) na2b2-))) (setq lsto (LLP a1+ b1+ a2+ b2+ p)) (foreach lo lsto (setq rr (abs (- (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2+ b2+ p)) (foreach lo lsto (setq rr (abs (+ (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2- b2- p)) (foreach lo lsto (setq rr (abs (- (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2- b2- p)) (foreach lo lsto (setq rr (abs (+ (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2+ b2+ p)) (foreach lo lsto (setq rr (abs (- (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2+ b2+ p)) (foreach lo lsto (setq rr (abs (+ (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2- b2- p)) (foreach lo lsto (setq rr (abs (- (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2- b2- p)) (foreach lo lsto (setq rr (abs (+ (cadr lo) r))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (if (<= (distance p (inters a1 b1 a2 b2 nil)) r) (progn (setq lsto (LLP a1+ b1+ a2+ b2+ p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2+ b2+ p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2- b2- p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1+ b1+ a2- b2- p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2+ b2+ p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2+ b2+ p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2- b2- p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq lsto (LLP a1- b1- a2- b2- p)) (foreach lo lsto (setq rr (abs (pdl a1 b1 (car lo)))) (setq cc (car lo)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (or (/= (length (ci1xci2 (car x) (cadr x) c r)) 1) (/= (length (cixli (car x) (cadr x) a1 b1)) 1) (/= (length (cixli (car x) (cadr x) a2 b2)) 1))) lst)) (unique lst) ) ;; Dilat points (defun dilat ( c1 r1 c2 r2 / c1c2 nc1c2 pc1 pc2 ppc1 ppc2 pd1 mc1c2 mmc1c2pd1 npd21 npd22 pd2 lst ) (setq c1c2 (mapcar '- c2 c1)) (setq nc1c2 (nor+ c1c2)) (setq pc1 (mapcar '+ c1 nc1c2)) (setq pc2 (mapcar '+ c2 nc1c2)) (setq ppc1 (car (cixli c1 r1 c1 pc1))) (if (< (distance ppc1 (car (cixli c2 r2 c2 pc2))) (distance ppc1 (cadr (cixli c2 r2 c2 pc2)))) (setq ppc2 (car (cixli c2 r2 c2 pc2))) (setq ppc2 (cadr (cixli c2 r2 c2 pc2))) ) (setq pd1 (inters c1 c2 ppc1 ppc2 nil)) (setq mc1c2 (mid c1 c2)) (setq mmc1c2pd1 (mid mc1c2 pd1)) (setq npd21 (car (ci1xci2 mc1c2 (distance mc1c2 c1) mmc1c2pd1 (distance mmc1c2pd1 pd1)))) (setq npd22 (cadr (ci1xci2 mc1c2 (distance mc1c2 c1) mmc1c2pd1 (distance mmc1c2pd1 pd1)))) (setq pd2 (inters c1 c2 npd21 npd22 nil)) (setq lst (cons pd1 lst)) (setq lst (cons pd2 lst)) lst ) ;; CCP ;; CCP-SUB (defun CCP-SUB ( c1 r1 c2 r2 p / pd p11 p12 p21 p22 d1 d2 d3 d4 mpp1 pp1 npp1 c1c2 nc1c2 pmpp1npp1 pp1nc1c2 cc rr ci ppcixli pp li po mpoc1 p31 p32 lst1 lst2 lst ) (if (and (not (equal r1 0.0 1e-6)) (not (equal r2 0.0 1e-6))) (progn (if (equal r1 r2 1e-6) (progn (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (setq d1 (distance p11 p21) d2 (distance p11 p22) d3 (distance p21 p11) d4 (distance p21 p12)) (if (< d1 d2) (setq p2 p21) (setq p2 p22) ) (if (< d3 d4) (setq p1 p11) (setq p1 p12) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p (mapcar '+ p (mapcar '- c2 c1)))) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (car ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p (mapcar '+ p (mapcar '- c2 c1)) nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) (progn (setq pd (car (dilat c1 r1 c2 r2))) (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (if (and (> r1 r2) (> (distance p11 pd) (distance p12 pd))) (setq p1 p12) (setq p1 p11) ) (if (and (> r1 r2) (> (distance p21 pd) (distance p22 pd))) (setq p2 p21) (setq p2 p22) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p pd)) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (car ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p pd nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) (setq pd (cadr (dilat c1 r1 c2 r2))) (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (if (and (> r1 r2) (> (distance p11 pd) (distance p12 pd))) (setq p1 p12) (setq p1 p11) ) (if (and (> r1 r2) (> (distance p21 pd) (distance p22 pd))) (setq p2 p21) (setq p2 p22) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p pd)) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (car ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p pd nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) (if (equal r1 r2 1e-6) (progn (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (setq d1 (distance p11 p21) d2 (distance p11 p22) d3 (distance p21 p11) d4 (distance p21 p12)) (if (< d1 d2) (setq p2 p21) (setq p2 p22) ) (if (< d3 d4) (setq p1 p11) (setq p1 p12) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p (mapcar '+ p (mapcar '- c2 c1)))) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (cadr ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p (mapcar '+ p (mapcar '- c2 c1)) nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) (progn (setq pd (car (dilat c1 r1 c2 r2))) (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (if (and (> r1 r2) (> (distance p11 pd) (distance p12 pd))) (setq p1 p12) (setq p1 p11) ) (if (and (> r1 r2) (> (distance p21 pd) (distance p22 pd))) (setq p2 p21) (setq p2 p22) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p pd)) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (cadr ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p pd nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) (setq pd (cadr (dilat c1 r1 c2 r2))) (setq p11 (car (cixli c1 r1 c1 c2))) (setq p12 (cadr (cixli c1 r1 c1 c2))) (setq p21 (car (cixli c2 r2 c1 c2))) (setq p22 (cadr (cixli c2 r2 c1 c2))) (if (and (> r1 r2) (> (distance p11 pd) (distance p12 pd))) (setq p1 p12) (setq p1 p11) ) (if (and (> r1 r2) (> (distance p21 pd) (distance p22 pd))) (setq p2 p21) (setq p2 p22) ) (if (equal p1 p2 1e-6) (setq mpp1 (mid p p1) pp1 (mapcar '- p1 p) npp1 (nor+ pp1) c1c2 (mapcar '- c2 c1) nc1c2 (nor+ c1c2) pmpp1npp1 (mapcar '+ mpp1 npp1) pp1nc1c2 (mapcar '+ p1 nc1c2) cc (inters mpp1 pmpp1npp1 p1 pp1nc1c2 nil) rr (distance cc p1) ci (list cc rr)) (setq ci (PPP p p1 p2)) ) (setq ppcixli (cixli (car ci) (cadr ci) p pd)) (if (vl-member-if '(lambda ( x ) (equal x p 1e-6)) ppcixli) (setq ppcixli (vl-remove-if '(lambda ( x ) (equal x p 1e-6)) ppcixli)) ) (setq pp (cadr ppcixli)) (setq li (ci1xci2 (car ci) (cadr ci) c1 r1)) (setq po (inters (car li) (cadr li) p pd nil)) (setq mpoc1 (mid po c1)) (setq p31 (car (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (setq p32 (cadr (ci1xci2 mpoc1 (distance mpoc1 c1) c1 r1))) (if (and pp p31) (setq lst1 (PPP p pp p31)) ) (if (and pp p32) (setq lst2 (PPP p pp p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) ) ) ) ) lst ) ;; CCP (defun CCP ( c1 r1 c2 r2 p / lst pp c11 r11 c22 r22 ) (setq lst (CCP-SUB c1 r1 c2 r2 p)) (setq lst (append lst (CCP-SUB c2 r2 c1 r1 p))) (setq pp (if (< r1 r2) c1 c2) c11 (if (< r1 r2) c2 c1) r11 (if (< r1 r2) (- r2 r1) (- r1 r2)) c22 p r22 (if (< r1 r2) r1 r2)) (foreach ci (CCP-SUB c11 r11 c22 r22 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))))))) ) ) (foreach ci (CCP-SUB c22 r22 c11 r11 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))))))) ) ) (setq pp (if (< r1 r2) c1 c2) c11 (if (< r1 r2) c2 c1) r11 (+ r1 r2) c22 p r22 (if (< r1 r2) r1 r2)) (foreach ci (CCP-SUB c11 r11 c22 r22 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))))))) ) ) (foreach ci (CCP-SUB c22 r22 c11 r11 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (< r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (< r1 r2) r1 r2))))))) ) ) (setq pp (if (> r1 r2) c1 c2) c11 (if (> r1 r2) c2 c1) r11 (+ r1 r2) c22 p r22 (if (> r1 r2) r1 r2)) (foreach ci (CCP-SUB c11 r11 c22 r22 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))))))) ) ) (foreach ci (CCP-SUB c22 r22 c11 r11 pp) (if (and (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (- (cadr ci) (if (> r1 r2) r1 r2))))))) ) (if (and (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))) c1 r1)) 1) (= (length (ci1xci2 (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))) c2 r2)) 1) (not (vl-member-if '(lambda ( x ) (equal x (list (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2)))) 1e-6)) lst))) (setq lst (append lst (list (list (car ci) (abs (+ (cadr ci) (if (> r1 r2) r1 r2))))))) ) ) (setq lst (vl-remove-if-not '(lambda ( x ) (equal (distance (car x) p) (cadr x) 1e-6)) lst)) (vl-sort (unique lst) '(lambda ( a b ) (< (cadr a) (cadr b)))) ) ;; CCL (defun CCL ( c1 r1 c2 r2 a b / d r c p a b ab nab+ nab- a+ b+ a- b- cio rr cc ln lst ) (if (> r1 r2) (setq d r2 r (- r1 r2) c c1 p c2) (setq d r1 r (- r2 r1) c c2 p c1) ) (if (equal r1 r2 1e-6) (setq d r1 p1 c1 p2 c2) ) (setq ab (mapcar '- b a)) (setq nab+ (nor+ ab)) (setq nab- (nor- ab)) (setq a+ (mapcar '+ a (mapcar '(lambda ( x ) (* x d)) nab+))) (setq b+ (mapcar '+ b (mapcar '(lambda ( x ) (* x d)) nab+))) (setq a- (mapcar '+ a (mapcar '(lambda ( x ) (* x d)) nab-))) (setq b- (mapcar '+ b (mapcar '(lambda ( x ) (* x d)) nab-))) (if (equal r1 r2 1e-6) (progn (setq cio (LPP a+ b+ p1 p2)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq cio (LPP a+ b+ p1 p2)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq cio (LPP a- b- p1 p2)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (setq cio (LPP a- b- p1 p2)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) (if (null (cixli c1 (+ r1 r2) a+ b+)) (progn (setq cio (CLP c1 (+ r1 r2) a+ b+ c2)) (foreach ci cio (setq rr (abs (- (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c1 (+ r1 r2) a+ b+)) (progn (setq cio (CLP c1 (+ r1 r2) a+ b+ c2)) (foreach ci cio (setq rr (abs (+ (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c1 (+ r1 r2) a- b-)) (progn (setq cio (CLP c1 (+ r1 r2) a- b- c2)) (foreach ci cio (setq rr (abs (- (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c1 (+ r1 r2) a- b-)) (progn (setq cio (CLP c1 (+ r1 r2) a- b- c2)) (foreach ci cio (setq rr (abs (+ (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c2 (+ r1 r2) a+ b+)) (progn (setq cio (CLP c2 (+ r1 r2) a+ b+ c1)) (foreach ci cio (setq rr (abs (- (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c2 (+ r1 r2) a+ b+)) (progn (setq cio (CLP c2 (+ r1 r2) a+ b+ c1)) (foreach ci cio (setq rr (abs (+ (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c2 (+ r1 r2) a- b-)) (progn (setq cio (CLP c2 (+ r1 r2) a- b- c1)) (foreach ci cio (setq rr (abs (- (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c2 (+ r1 r2) a- b-)) (progn (setq cio (CLP c2 (+ r1 r2) a- b- c1)) (foreach ci cio (setq rr (abs (+ (cadr ci) r1))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) ) (progn (if (null (cixli c r a+ b+)) (progn (setq cio (CLP c r a+ b+ p)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c r a+ b+)) (progn (setq cio (CLP c r a+ b+ p)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c r a- b-)) (progn (setq cio (CLP c r a- b- p)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c r a- b-)) (progn (setq cio (CLP c r a- b- p)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c (+ r1 r2) a+ b+)) (progn (setq cio (CLP c (+ r1 r2) a+ b+ p)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c (+ r1 r2) a+ b+)) (progn (setq cio (CLP c (+ r1 r2) a+ b+ p)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c (+ r1 r2) a- b-)) (progn (setq cio (CLP c (+ r1 r2) a- b- p)) (foreach ci cio (setq rr (abs (- (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) (if (null (cixli c (+ r1 r2) a- b-)) (progn (setq cio (CLP c (+ r1 r2) a- b- p)) (foreach ci cio (setq rr (abs (+ (cadr ci) d))) (setq cc (car ci)) (setq ln (cons rr ln)) (setq ln (cons cc ln)) (setq lst (cons ln lst)) (setq ln nil) ) ) ) ) ) (setq lst (vl-remove-if '(lambda ( x ) (or (/= (length (ci1xci2 (car x) (cadr x) c1 r1)) 1) (/= (length (ci1xci2 (car x) (cadr x) c2 r2)) 1) (/= (length (cixli (car x) (cadr x) a b)) 1))) lst)) (unique lst) ) ;; CCC ;; Radical center (defun radc ( c1 r1 c2 r2 c3 r3 / d12 d13 d23 x12 p12 c1c2 n12 pp12 x13 p13 c1c3 n13 pp13 x23 p23 c2c3 n23 pp23 o1 o2 o3 o ) (setq d12 (distance c1 c2)) (setq d13 (distance c1 c3)) (setq d23 (distance c2 c3)) (if (>= r1 r2) (setq x12 (/ (+ d12 (/ (abs (- (expt r1 2) (expt r2 2))) d12)) 2)) (setq x12 (/ (- d12 (/ (abs (- (expt r1 2) (expt r2 2))) d12)) 2)) ) (setq p12 (polar c1 (angle c1 c2) x12)) (setq c1c2 (mapcar '- c2 c1)) (setq n12 (nor+ c1c2)) (setq pp12 (mapcar '+ p12 n12)) (if (>= r1 r3) (setq x13 (/ (+ d13 (/ (abs (- (expt r1 2) (expt r3 2))) d13)) 2)) (setq x13 (/ (- d13 (/ (abs (- (expt r1 2) (expt r3 2))) d13)) 2)) ) (setq p13 (polar c1 (angle c1 c3) x13)) (setq c1c3 (mapcar '- c3 c1)) (setq n13 (nor+ c1c3)) (setq pp13 (mapcar '+ p13 n13)) (if (>= r2 r3) (setq x23 (/ (+ d23 (/ (abs (- (expt r2 2) (expt r3 2))) d23)) 2)) (setq x23 (/ (- d23 (/ (abs (- (expt r2 2) (expt r3 2))) d23)) 2)) ) (setq p23 (polar c2 (angle c2 c3) x23)) (setq c2c3 (mapcar '- c3 c2)) (setq n23 (nor+ c2c3)) (setq pp23 (mapcar '+ p23 n23)) (setq o1 (inters p12 pp12 p13 pp13 nil)) (setq o2 (inters p12 pp12 p23 pp23 nil)) (setq o3 (inters p13 pp13 p23 pp23 nil)) (if (and (equal o1 o2 1e-6) (equal o2 o3 1e-6) (equal o1 o3 1e-6)) (setq o o1)) o ) ;; CCC1 (defun CCC1 ( c1 r1 c2 r2 c3 r3 a b / ab nab c1nab c2nab c3nab c1nabp c2nabp c3nabp mc1 mc2 mc3 cxc1 cxc2 cxc3 p1 p2 p3 o p1c1op1 p2c1op1 p1c2op2 p2c2op2 p1c3op3 p2c3op3 p11 p12 p21 p22 p31 p32 lst1 lst2 lst ) (setq ab (mapcar '- b a)) (setq nab (nor+ ab)) (setq c1nab (mapcar '+ c1 nab)) (setq c2nab (mapcar '+ c2 nab)) (setq c3nab (mapcar '+ c3 nab)) (setq c1nabp (inters c1 c1nab a b nil)) (setq c2nabp (inters c2 c2nab a b nil)) (setq c3nabp (inters c3 c3nab a b nil)) (setq mc1 (mid c1 c1nabp)) (setq mc2 (mid c2 c2nabp)) (setq mc3 (mid c3 c3nabp)) (setq cxc1 (ci1xci2 c1 r1 mc1 (distance mc1 c1))) (setq cxc2 (ci1xci2 c2 r2 mc2 (distance mc2 c2))) (setq cxc3 (ci1xci2 c3 r3 mc3 (distance mc3 c3))) (if cxc1 (setq p1 (inters (car cxc1) (cadr cxc1) c1 c1nabp nil)) ) (if cxc2 (setq p2 (inters (car cxc2) (cadr cxc2) c2 c2nabp nil)) ) (if cxc3 (setq p3 (inters (car cxc3) (cadr cxc3) c3 c3nabp nil)) ) (setq o (radc c1 r1 c2 r2 c3 r3)) (if (and p1 p2 p3 (< (distance c1nabp (mid c2nabp c3nabp)) (distance c2nabp (mid c1nabp c3nabp))) (< (distance c1nabp (mid c2nabp c3nabp)) (distance c3nabp (mid c1nabp c2nabp))) ) (progn (setq p1c1op1 (car (cixli c1 r1 o p1))) (setq p2c1op1 (cadr (cixli c1 r1 o p1))) (if (< (distance p1c1op1 o) (distance p2c1op1 o)) (progn (setq p11 p1c1op1) (setq p12 p2c1op1)) (progn (setq p11 p2c1op1) (setq p12 p1c1op1)) ) (setq p1c2op2 (car (cixli c2 r2 o p2))) (setq p2c2op2 (cadr (cixli c2 r2 o p2))) (if (< (distance p1c2op2 o) (distance p2c2op2 o)) (progn (setq p21 p2c2op2) (setq p22 p1c2op2)) (progn (setq p21 p1c2op2) (setq p22 p2c2op2)) ) (setq p1c3op3 (car (cixli c3 r3 o p3))) (setq p2c3op3 (cadr (cixli c3 r3 o p3))) (if (< (distance p1c3op3 o) (distance p2c3op3 o)) (progn (setq p31 p2c3op3) (setq p32 p1c3op3)) (progn (setq p31 p1c3op3) (setq p32 p2c3op3)) ) ) ) (if (and p1 p2 p3 (< (distance c2nabp (mid c1nabp c3nabp)) (distance c1nabp (mid c2nabp c3nabp))) (< (distance c2nabp (mid c1nabp c3nabp)) (distance c3nabp (mid c1nabp c2nabp))) ) (progn (setq p1c2op2 (car (cixli c2 r2 o p2))) (setq p2c2op2 (cadr (cixli c2 r2 o p2))) (if (< (distance p1c2op2 o) (distance p2c2op2 o)) (progn (setq p21 p1c2op2) (setq p22 p2c2op2)) (progn (setq p21 p2c2op2) (setq p22 p1c2op2)) ) (setq p1c1op1 (car (cixli c1 r1 o p1))) (setq p2c1op1 (cadr (cixli c1 r1 o p1))) (if (< (distance p1c1op1 o) (distance p2c1op1 o)) (progn (setq p11 p2c1op1) (setq p12 p1c1op1)) (progn (setq p11 p1c1op1) (setq p12 p2c1op1)) ) (setq p1c3op3 (car (cixli c3 r3 o p3))) (setq p2c3op3 (cadr (cixli c3 r3 o p3))) (if (< (distance p1c3op3 o) (distance p2c3op3 o)) (progn (setq p31 p2c3op3) (setq p32 p1c3op3)) (progn (setq p31 p1c3op3) (setq p32 p2c3op3)) ) ) ) (if (and p1 p2 p3 (< (distance c3nabp (mid c1nabp c2nabp)) (distance c1nabp (mid c2nabp c3nabp))) (< (distance c3nabp (mid c1nabp c2nabp)) (distance c2nabp (mid c1nabp c3nabp))) ) (progn (setq p1c3op3 (car (cixli c3 r3 o p3))) (setq p2c3op3 (cadr (cixli c3 r3 o p3))) (if (< (distance p1c3op3 o) (distance p2c3op3 o)) (progn (setq p31 p1c3op3) (setq p32 p2c3op3)) (progn (setq p31 p2c3op3) (setq p32 p2c3op3)) ) (setq p1c1op1 (car (cixli c1 r1 o p1))) (setq p2c1op1 (cadr (cixli c1 r1 o p1))) (if (< (distance p1c1op1 o) (distance p2c1op1 o)) (progn (setq p11 p2c1op1) (setq p12 p1c1op1)) (progn (setq p11 p1c1op1) (setq p12 p2c1op1)) ) (setq p1c2op2 (car (cixli c2 r2 o p2))) (setq p2c2op2 (cadr (cixli c2 r2 o p2))) (if (< (distance p1c2op2 o) (distance p2c2op2 o)) (progn (setq p21 p2c2op2) (setq p22 p1c2op2)) (progn (setq p21 p1c2op2) (setq p22 p2c2op2)) ) ) ) (if (and p11 p12 (equal p11 p12 1e-6)) (setq p12 (car (vl-remove-if '(lambda ( x ) (equal x p11 1e-6)) (cixli c1 r1 o p11)))) ) (if (and p21 p22 (equal p21 p22 1e-6)) (setq p22 (car (vl-remove-if '(lambda ( x ) (equal x p21 1e-6)) (cixli c2 r2 o p21)))) ) (if (and p31 p32 (equal p31 p32 1e-6)) (setq p32 (car (vl-remove-if '(lambda ( x ) (equal x p31 1e-6)) (cixli c3 r3 o p31)))) ) (if (and p11 p21 p31) (setq lst1 (PPP p11 p21 p31)) ) (if (and p12 p22 p32) (setq lst2 (PPP p12 p22 p32)) ) (if (and lst2 (= (length (ci1xci2 (car lst2) (cadr lst2) c1 r1)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c2 r2)) 1) (= (length (ci1xci2 (car lst2) (cadr lst2) c3 r3)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst2 1e-6)) lst))) (setq lst (cons lst2 lst)) ) (if (and lst1 (= (length (ci1xci2 (car lst1) (cadr lst1) c1 r1)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c2 r2)) 1) (= (length (ci1xci2 (car lst1) (cadr lst1) c3 r3)) 1) (not (vl-member-if '(lambda ( x ) (equal x lst1 1e-6)) lst))) (setq lst (cons lst1 lst)) ) lst ) ;;; CCC2 (defun CCC2 ( c1 r1 c2 r2 c3 r3 / c1 r1 c2 r2 r1o r2o p d p1 p2 p3 lsto lst ) (if (and (equal r1 r2 1e-6) (equal r1 r3 1e-6)) (progn (setq p1 c1 p2 c2 p3 c3 lsto (PPP p1 p2 p3) d r3) (setq lst (list (list (car lsto) (abs (- (cadr lsto) d))))) ) ) (if (and (not (equal r1 r2 1e-6)) (not (equal r2 r3 1e-6)) (not (equal r1 r3 1e-6))) (progn (if (and (< r1 r2) (< r1 r3)) (setq r1o (- r2 r1) r2o (- r3 r1) d r1 p c1 c1 c2 c2 c3) ) (if (and (< r2 r1) (< r2 r3)) (setq r1o (- r1 r2) r2o (- r3 r2) d r2 p c2 c1 c1 c2 c3) ) (if (and (< r3 r2) (< r3 r1)) (setq r1o (- r1 r3) r2o (- r2 r3) d r3 p c3 c1 c1 c2 c2) ) (setq lsto (CCP c1 r1o c2 r2o p)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r1 r2 1e-6) (> r1 r3)) (progn (setq r1o (- r1 r3) r2o (- r2 r3) p c3 c1 c1 c2 c2 d r3) (setq lsto (CCP c1 r1o c2 r2o p)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r1 r3 1e-6) (> r1 r2)) (progn (setq r1o (- r1 r2) r2o (- r3 r2) p c2 c1 c1 c2 c3 d r2) (setq lsto (CCP c1 r1o c2 r2o p)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r2 r3 1e-6) (> r2 r1)) (progn (setq r1o (- r2 r1) r2o (- r3 r1) p c1 c1 c2 c2 c3 d r1) (setq lsto (CCP c1 r1o c2 r2o p)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r1 r2 1e-6) (< r1 r3)) (progn (setq r1o (- r3 r1) p1 c1 p2 c2 c1 c3 d r1) (setq lsto (CPP c1 r1o p1 p2)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r1 r3 1e-6) (< r1 r2)) (progn (setq r1o (- r2 r1) p1 c1 p2 c3 c1 c2 d r1) (setq lsto (CPP c1 r1o p1 p2)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) (if (and (equal r2 r3 1e-6) (< r2 r1)) (progn (setq r1o (- r1 r2) p1 c2 p2 c3 c1 c1 d r2) (setq lsto (CPP c1 r1o p1 p2)) (if (< (abs (cadr (car lsto))) (abs (cadr (cadr lsto)))) (setq lst (list (list (caar lsto) (abs (- (cadar lsto) d))))) (setq lst (list (list (caadr lsto) (abs (- (cadadr lsto) d))))) ) ) ) lst ) ;;; CCC3 (defun CCC3 ( c1 r1 c2 r2 c3 r3 / ci o rrad ox oy pcix px+ px- ppx+ oppx+ noppx+ pppx+ p1 ppx- oppx- noppx- pppx- p2 pciy py+ py- ppy+ oppy+ noppy+ pppy+ p3 lst ) (setq ci (car (CCC2 c1 r1 c2 r2 c3 r3))) (setq o (radc c1 r1 c2 r2 c3 r3)) (if o (progn (setq rrad (sqrt (- (expt (distance o c1) 2) (* r1 r1)))) (setq ox (mapcar '+ o '(1.0 0.0 0.0))) (setq oy (mapcar '+ o '(0.0 1.0 0.0))) ) ) (if ci (setq pcix (cixli (car ci) (cadr ci) o ox)) ) (cond ( (and pcix (> (car (car pcix)) (car (cadr pcix)))) (setq px+ (car pcix)) (setq px- (cadr pcix)) ) ( (and pcix (<= (car (car pcix)) (car (cadr pcix)))) (setq px+ (cadr pcix)) (setq px- (car pcix)) ) ) (if (and o px+) (setq ppx+ (cixli o rrad px+ (mapcar '+ px+ '(0.0 1.0 0.0)))) ) (if (and o ppx+) (setq oppx+ (mapcar '- (car ppx+) o)) ) (if oppx+ (setq noppx+ (nor+ oppx+)) ) (if (and ppx+ noppx+) (setq pppx+ (mapcar '+ (car ppx+) noppx+)) ) (if (and o pppx+) (setq p1 (inters o ox (car ppx+) pppx+ nil)) ) (if (and o px-) (setq ppx- (cixli o rrad px- (mapcar '+ px- '(0.0 1.0 0.0)))) ) (if (and o ppx-) (setq oppx- (mapcar '- (car ppx-) o)) ) (if oppx- (setq noppx- (nor+ oppx-)) ) (if (and ppx- noppx-) (setq pppx- (mapcar '+ (car ppx-) noppx-)) ) (if (and o pppx-) (setq p2 (inters o ox (car ppx-) pppx- nil)) ) (if ci (setq pciy (cixli (car ci) (cadr ci) o oy)) ) (cond ( (and pciy (> (cadr (car pciy)) (cadr (cadr pciy)))) (setq py+ (car pciy)) (setq py- (cadr pciy)) ) ( (and pciy (<= (cadr (car pciy)) (cadr (cadr pciy)))) (setq py+ (cadr pciy)) (setq py- (car pciy)) ) ) (if (and o py+) (setq ppy+ (cixli o rrad py+ (mapcar '+ py+ '(1.0 0.0 0.0)))) ) (if (and o ppy+) (setq oppy+ (mapcar '- (car ppy+) o)) ) (if oppy+ (setq noppy+ (nor+ oppy+)) ) (if (and ppy+ noppy+) (setq pppy+ (mapcar '+ (car ppy+) noppy+)) ) (if (and o pppy+) (setq p3 (inters o oy (car ppy+) pppy+ nil)) ) (if (and p1 p2 p3) (setq lst (list (PPP p1 p2 p3))) ) lst ) ;; CCC (defun CCC ( c1 r1 c2 r2 c3 r3 / pd1 pd2 pd3 lst1 lst2 lst3 lst4 lst5 lst ) (if (and (equal r1 r2 1e-6) (equal r1 r3 1e-6)) (progn (setq pd1 (mid c1 c2)) (setq pd2 (mid c1 c3)) (setq pd3 (mid c2 c3)) (setq lst1 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd2)) (setq lst2 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd3)) (setq lst3 (CCC1 c1 r1 c2 r2 c3 r3 pd2 pd3)) (setq lst4 (CCC2 c1 r1 c2 r2 c3 r3)) (setq lst5 (CCC3 c1 r1 c2 r2 c3 r3)) (setq lst (append lst1 lst2 lst3 lst4 lst5)) ) ) (if (and (equal r1 r2 1e-6) (not (equal r1 r3 1e-6))) (progn (setq pd1 (mid c1 c2)) (setq pd2 (car (dilat c1 r1 c3 r3))) (setq pd3 (car (dilat c2 r2 c3 r3))) (setq lst1 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd2)) (setq lst2 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd3)) (setq lst3 (CCC1 c1 r1 c2 r2 c3 r3 pd2 pd3)) (setq lst4 (CCC2 c1 r1 c2 r2 c3 r3)) (setq lst5 (CCC3 c1 r1 c2 r2 c3 r3)) (setq lst (append lst1 lst2 lst3 lst4 lst5)) ) ) (if (and (equal r1 r3 1e-6) (not (equal r1 r2 1e-6))) (progn (setq pd1 (car (dilat c1 r1 c2 r2))) (setq pd2 (mid c1 c3)) (setq pd3 (car (dilat c2 r2 c3 r3))) (setq lst1 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd2)) (setq lst2 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd3)) (setq lst3 (CCC1 c1 r1 c2 r2 c3 r3 pd2 pd3)) (setq lst4 (CCC2 c1 r1 c2 r2 c3 r3)) (setq lst5 (CCC3 c1 r1 c2 r2 c3 r3)) (setq lst (append lst1 lst2 lst3 lst4 lst5)) ) ) (if (and (equal r2 r3 1e-6) (not (equal r2 r1 1e-6))) (progn (setq pd1 (car (dilat c1 r1 c2 r2))) (setq pd2 (car (dilat c1 r1 c3 r3))) (setq pd3 (mid c2 c3)) (setq lst1 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd2)) (setq lst2 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd3)) (setq lst3 (CCC1 c1 r1 c2 r2 c3 r3 pd2 pd3)) (setq lst4 (CCC2 c1 r1 c2 r2 c3 r3)) (setq lst5 (CCC3 c1 r1 c2 r2 c3 r3)) (setq lst (append lst1 lst2 lst3 lst4 lst5)) ) ) (if (and (not (equal r1 r2 1e-6)) (not (equal r1 r3 1e-6))) (progn (setq pd1 (car (dilat c1 r1 c2 r2))) (setq pd2 (car (dilat c1 r1 c3 r3))) (setq pd3 (car (dilat c2 r2 c3 r3))) (setq lst1 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd2)) (setq lst2 (CCC1 c1 r1 c2 r2 c3 r3 pd1 pd3)) (setq lst3 (CCC1 c1 r1 c2 r2 c3 r3 pd2 pd3)) (setq lst4 (CCC2 c1 r1 c2 r2 c3 r3)) (setq lst5 (CCC3 c1 r1 c2 r2 c3 r3)) (setq lst (append lst1 lst2 lst3 lst4 lst5)) ) ) (setq lst (vl-remove-if '(lambda ( x ) (or (null x) (/= (length (ci1xci2 (car x) (cadr x) c1 r1)) 1) (/= (length (ci1xci2 (car x) (cadr x) c2 r2)) 1) (/= (length (ci1xci2 (car x) (cadr x) c3 r3)) 1))) lst)) (unique lst) ) ;;;; command functions (defun c:PPP ( / p1 p2 p3 lst ) (initget 1) (setq p1 (getpoint "\nPick or specify first point : ")) (setq p1 (list (car p1) (cadr p1) 0.0)) (initget 1) (setq p2 (getpoint "\nPick or specify second point : ")) (setq p2 (list (car p2) (cadr p2) 0.0)) (initget 1) (setq p3 (getpoint "\nPick or specify third point : ")) (setq p3 (list (car p3) (cadr p3) 0.0)) (setq lst (list (PPP p1 p2 p3))) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:LLL ( / ssli1 li1 ssli2 li2 ssli3 li3 a1 b1 a2 b2 a3 b3 lst ) (while (null ssli1) (prompt "\nPick first line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (while (or (null ssli2) (equal (ssname ssli1 0) (ssname ssli2 0))) (prompt "\nPick second line...") (setq ssli2 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li2 (ssname ssli2 0)) (while (or (null ssli3) (or (equal (ssname ssli3 0) (ssname ssli2 0)) (equal (ssname ssli3 0) (ssname ssli1 0)))) (prompt "\nPick third line...") (setq ssli3 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li3 (ssname ssli3 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (setq a2 (trans (cdr (assoc 10 (entget li2))) 0 1)) (setq a2 (list (car a2) (cadr a2) 0.0)) (setq b2 (trans (cdr (assoc 11 (entget li2))) 0 1)) (setq b2 (list (car b2) (cadr b2) 0.0)) (setq a3 (trans (cdr (assoc 10 (entget li3))) 0 1)) (setq a3 (list (car a3) (cadr a3) 0.0)) (setq b3 (trans (cdr (assoc 11 (entget li3))) 0 1)) (setq b3 (list (car b3) (cadr b3) 0.0)) (setq lst (LLL a1 b1 a2 b2 a3 b3)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:LPP ( / ssli1 li1 a1 b1 p1 p2 lst ) (while (null ssli1) (prompt "\nPick line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (initget 1) (setq p1 (getpoint "\nPick or specify first point : ")) (setq p1 (list (car p1) (cadr p1) 0.0)) (initget 1) (setq p2 (getpoint "\nPick or specify second point : ")) (setq p2 (list (car p2) (cadr p2) 0.0)) (setq lst (LPP a1 b1 p1 p2)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:LLP ( / ssli1 li1 ssli2 li2 a1 b1 a2 b2 p lst ) (while (null ssli1) (prompt "\nPick first line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (while (or (null ssli2) (equal (ssname ssli1 0) (ssname ssli2 0))) (prompt "\nPick second line...") (setq ssli2 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li2 (ssname ssli2 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (setq a2 (trans (cdr (assoc 10 (entget li2))) 0 1)) (setq a2 (list (car a2) (cadr a2) 0.0)) (setq b2 (trans (cdr (assoc 11 (entget li2))) 0 1)) (setq b2 (list (car b2) (cadr b2) 0.0)) (initget 1) (setq p (getpoint "\nPick or specify point : ")) (setq p (list (car p) (cadr p) 0.0)) (setq lst (LLP a1 b1 a2 b2 p)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CPP ( / ssci1 ci1 c1 r1 p1 p2 lst ) (while (null ssci1) (prompt "\nPick circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (initget 1) (setq p1 (getpoint "\nPick or specify first point : ")) (setq p1 (list (car p1) (cadr p1) 0.0)) (initget 1) (setq p2 (getpoint "\nPick or specify second point : ")) (setq p2 (list (car p2) (cadr p2) 0.0)) (setq lst (CPP c1 r1 p1 p2)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CLP ( / ssci1 ci1 ssli1 li1 c1 r1 a1 b1 p lst ) (while (null ssci1) (prompt "\nPick circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (while (or (null ssli1) (equal (ssname ssli1 0) (ssname ssci1 0))) (prompt "\nPick line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (initget 1) (setq p (getpoint "\nPick or specify point : ")) (setq p (list (car p) (cadr p) 0.0)) (setq lst (CLP c1 r1 a1 b1 p)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CLL ( / ssci1 ci1 ssli1 li1 ssli2 li2 c1 r1 a1 b1 a2 b2 lst ) (while (null ssci1) (prompt "\nPick circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (while (or (null ssli1) (equal (ssname ssli1 0) (ssname ssci1 0))) (prompt "\nPick first line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (while (or (null ssli2) (or (equal (ssname ssli2 0) (ssname ssli1 0)) (equal (ssname ssli2 0) (ssname ssci1 0)))) (prompt "\nPick second line...") (setq ssli2 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li2 (ssname ssli2 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (setq a2 (trans (cdr (assoc 10 (entget li2))) 0 1)) (setq a2 (list (car a2) (cadr a2) 0.0)) (setq b2 (trans (cdr (assoc 11 (entget li2))) 0 1)) (setq b2 (list (car b2) (cadr b2) 0.0)) (setq lst (CLL c1 r1 a1 b1 a2 b2)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CCP ( / ssci1 ci1 ssci2 ci2 c1 r1 c2 r2 p lst ) (while (null ssci1) (prompt "\nPick first circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (while (or (null ssci2) (equal (ssname ssci2 0) (ssname ssci1 0))) (prompt "\nPick second circle...") (setq ssci2 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci2 (ssname ssci2 0)) (setq c2 (trans (cdr (assoc 10 (entget ci2))) ci2 1)) (setq c2 (list (car c2) (cadr c2) 0.0)) (setq r2 (cdr (assoc 40 (entget ci2)))) (initget 1) (setq p (getpoint "\nPick or specify point : ")) (setq p (list (car p) (cadr p) 0.0)) (setq lst (CCP c1 r1 c2 r2 p)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CCL ( / ssci1 ci1 ssci2 ci2 ssli1 li1 c1 r1 c2 r2 a1 b1 lst ) (while (null ssci1) (prompt "\nPick first circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (while (or (null ssci2) (equal (ssname ssci2 0) (ssname ssci1 0))) (prompt "\nPick second circle...") (setq ssci2 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci2 (ssname ssci2 0)) (setq c2 (trans (cdr (assoc 10 (entget ci2))) ci2 1)) (setq c2 (list (car c2) (cadr c2) 0.0)) (setq r2 (cdr (assoc 40 (entget ci2)))) (while (or (null ssli1) (or (equal (ssname ssli1 0) (ssname ssci1 0)) (equal (ssname ssli1 0) (ssname ssci2 0)))) (prompt "\nPick line...") (setq ssli1 (ssget "_+.:E:S" '((0 . "LINE")))) ) (setq li1 (ssname ssli1 0)) (setq a1 (trans (cdr (assoc 10 (entget li1))) 0 1)) (setq a1 (list (car a1) (cadr a1) 0.0)) (setq b1 (trans (cdr (assoc 11 (entget li1))) 0 1)) (setq b1 (list (car b1) (cadr b1) 0.0)) (setq lst (CCL c1 r1 c2 r2 a1 b1)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (defun c:CCC ( / ssci1 ci1 ssci2 ci2 ssci3 ci3 c1 r1 c2 r2 c3 r3 lst ) (while (null ssci1) (prompt "\nPick first circle...") (setq ssci1 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci1 (ssname ssci1 0)) (setq c1 (trans (cdr (assoc 10 (entget ci1))) ci1 1)) (setq c1 (list (car c1) (cadr c1) 0.0)) (setq r1 (cdr (assoc 40 (entget ci1)))) (while (or (null ssci2) (equal (ssname ssci2 0) (ssname ssci1 0))) (prompt "\nPick second circle...") (setq ssci2 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci2 (ssname ssci2 0)) (setq c2 (trans (cdr (assoc 10 (entget ci2))) ci2 1)) (setq c2 (list (car c2) (cadr c2) 0.0)) (setq r2 (cdr (assoc 40 (entget ci2)))) (while (or (null ssci3) (or (equal (ssname ssci3 0) (ssname ssci1 0)) (equal (ssname ssci3 0) (ssname ssci2 0)))) (prompt "\nPick third circle...") (setq ssci3 (ssget "_+.:E:S" '((0 . "CIRCLE")))) ) (setq ci3 (ssname ssci3 0)) (setq c3 (trans (cdr (assoc 10 (entget ci3))) ci3 1)) (setq c3 (list (car c3) (cadr c3) 0.0)) (setq r3 (cdr (assoc 40 (entget ci3)))) (setq lst (CCC c1 r1 c2 r2 c3 r3)) (foreach ci lst (entmake (list (cons 0 "CIRCLE") (cons 10 (trans (car ci) 1 (trans '(0.0 0.0 1.0) 1 0 t))) (cons 40 (cadr ci)) (cons 62 3) (cons 210 (trans '(0.0 0.0 1.0) 1 0 t)))) ) (princ) ) (prompt "\nCommand functions are : PPP LPP LLP LLL CPP CLP CLL CCP CCL CCC") (princ) )