设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 【越飞越高讲堂18】论圆
123下一页
返回列表 发新帖
查看: 12653|回复: 28

[【高飞鸟】] 【越飞越高讲堂18】论圆

    [复制链接]
highflybir
发表于 2013-4-16 17:58:30 | 显示全部楼层 |阅读模式
本帖最后由 highflybir 于 2013-4-17 03:03 编辑

【越飞越高讲堂18】论圆

圆是CAD里面一种很重要的图形。下面我的一些算法和程序都是与圆或弧相关，读者通过稍加修改就能把其中的函数用于其他。

深究其原理的，可能需要具有一定的几何、代数和CAD作图知识。其中提及的一些名词
譬如反演，共轴，等幂等等，如若不明白，建议去到维基或者百度搜索，我不在此一一解释。

另说明：以下的lisp程序如果结果返回nil，可能是无解，或者无穷解；程序名字中缩写中的L 代表Line（一般来说是要求的圆与Line相切），P代表Point，C代表Circle，T代表垂直于某条直线,R代表半径已知。
程序中可能用到的一些子程序要参见我的另外两个帖子《论点、线、面和三角形》和《矩阵论》。如若找不到子程序，请到下面的链接中寻找。
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99926
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100047
源码见本文最后。
一、圆和点
  1. ;;;----------------------------------------------------;
  2. ;;;判断点跟圆的位置关系                                ;
  3. ;;;输入：Pt,要判断的点，Cen,圆心，Rad半径              ;
  4. ;;;输出：0 为在圆上，-1为在圆内，1为在圆外             ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:GetPos (Pt Cen Rad / d)
  7.   (setq d (distance cen pt))
  8.   (cond
  9.     ( (equal d Rad 1e-8) 0)
  10.     ( (< d Rad) -1)
  11.     ( t 1)
  12.   )
  13. )

  15. ;;;----------------------------------------------------;
  16. ;;;判断两点对某个圆是否异侧                            ;
  17. ;;;----------------------------------------------------;
  18. (defun CIR:Is_Opposite_Side (rad d1 d2)
  19.   (or (and (> d1 rad) (< d2 rad)) (and (< d1 rad) (> d2 rad)))
  20. )

  22. ;;;----------------------------------------------------;
  23. ;;;判断两点对某个圆是否同侧                            ;
  24. ;;;----------------------------------------------------;
  25. (defun CIR:Is_Same_Side (rad d1 d2)
  26.   (or (and (> d1 rad) (> d2 rad)) (and (< d1 rad) (< d2 rad)))
  27. )

  29. ;;;----------------------------------------------------;
  30. ;;;This is known as the "secant-tangent theorem",      ;
  31. ;;;"intersecting chords theorem",   "Secant Theorem"   ;
  32. ;;;or the "power-of-a-point theorem"                   ;
  33. ;;;割弦定理                                            ;
  34. ;;;输入: 在圆上的一点Pc，一给定点P，给定圆圆心C和半径R ;
  35. ;;;输出: 经过定点Pt和PC的弦的另一点                    ;
  36. ;;;----------------------------------------------------;
  37. (defun CIR:Intersecting_Chords (Pc P C R / d L eps)
  38.   (setq eps 1e-6)
  39.   (setq d (distance P C))
  40.   (if (equal d R eps)
  41.     P
  42.     (polar P (angle P Pc) (/ (* (+ d R) (- d R)) (distance P Pc)))
  43.   )
  44. )

二、圆与直线及圆的相交和相切问题。

  1. ;;;----------------------------------------------------;
  2. ;;;求直线和圆的交点                                    ;
  3. ;;;输入：圆心，半径和直线的两个端点                    ;
  4. ;;;输出：直线与圆的交点集(nil,一个点或者两个点)        ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:Circle_Inters_Line (Cen rad PtA PtB / p d L A eps)
  7.   (setq eps 1e-6)
  8.   (setq p (Line:Perpendicular_Foot Cen PtA PtB))        ;圆心到直线的垂足
  9.   (setq d (abs (car p)))                                ;垂距
  10.   (setq p (cadr p))                                        ;垂足
  11.   (if (equal d Rad eps)                                        ;如果垂距等于半径
  12.     (list p)                                                ;相切
  13.     (if (< d Rad)                                        ;如果垂距小于半径
  14.       (progn
  15.         (setq L (sqrt (* (+ Rad d)(- Rad d))))          ;半弦长
  16.         (setq A (angle PtA PtB))                        ;直线的与X轴线的交角
  17.         (list (polar p a (- L)) (polar p a L))                ;有两个交点
  18.       )
  19.     )
  20.   )
  21. )

  23. ;;;----------------------------------------------------;
  24. ;;;直线和圆的交点吗，为CIR:LCR相切圆修改               ;
  25. ;;;输入：圆心，半径，角度方向，与圆心的距离            ;
  26. ;;;输出：直线与圆的交点集(nil,一个点或者两个点)        ;
  27. ;;;----------------------------------------------------;
  28. (defun CIR:Circle_Inters_Line_1 (cen rad An Dist / d p l s)
  29.   (setq d (abs dist))
  30.   (if (equal d Rad 1e-6)
  31.     (list (polar cen (- an (* pi 0.5)) Dist))                ;相切
  32.     (if (< d Rad)
  33.       (setq p (polar cen (- an (* pi 0.5)) Dist)        ;垂足
  34.             L (sqrt (* (+ rad d)(- rad d)))                ;半弦长
  35.             S (list (polar p an (- L))
  36.                     (polar p an L)
  37.               )
  38.       )
  39.     )
  40.   )
  41. )

  43. ;;;----------------------------------------------------;
  44. ;;;圆和圆的交点                                        ;
  45. ;;;输入：两个圆（用圆心和半径表示）                    ;
  46. ;;;输出：两个圆的交集（nil，一个点或者两个点）         ;
  47. ;;;----------------------------------------------------;
  48. (defun CIR:Circle_Inters_Circle (c1 r1 c2 r2 / eps m n L d H A B)
  49.   (setq eps 1e-6)
  50.   (setq m (+ r2 r1))
  51.   (setq n (- r2 r1))
  52.   (setq L (distance c1 c2))
  53.   (cond
  54.     ( (equal L 0 eps) nil)                                ;圆心重合，无解或无穷解
  55.     ( (equal m l eps)                                        ;两个圆外切
  56.       (list (polar c1 (angle c1 c2) r1))               
  57.     )
  58.     ( (equal (abs n) l eps)                                ;内切
  59.       (if (< n 0)
  60.         (list (polar C2 (angle c2 c1) (- r2)))
  61.         (list (polar C2 (angle c2 c1) r2))
  62.       )
  63.     )
  64.     ( (and (> m L) (< (abs n) L))                        ;相交
  65.       (setq d (+ (* r1 r1) (* (+ L r2) (- L r2))))      ;根据余弦定理
  66.       (setq d (/ d (+ L L)))
  67.       (setq H (sqrt (* (+ r1 d) (- r1 d))))             ;交点与圆心连线垂直距离
  68.       (setq A (angle c1 c2))                                ;圆心连线角
  69.       (setq B (atan h d))                                
  70.       (list (polar c1 (- A B) r1)                        ;有两个交点
  71.             (polar c1 (+ A B) r1)
  72.       )
  73.     )
  74.   )
  75. )

  77. ;;;----------------------------------------------------;
  78. ;;;圆外的一点对圆形的切点                              ;
  79. ;;;输入: 给定圆的圆心和半径和圆外的一点Pt              ;
  80. ;;;输出: 这点Pt对圆的切点集(nil，一个或者两个)         ;
  81. ;;;----------------------------------------------------;
  82. (defun CIR:Point_Tangent (cen rad pt / d l a b p q r eps)
  83.   (setq eps 1e-8)
  84.   (setq d (distance cen pt))
  85.   (if (equal d rad eps)
  86.     (list pt)
  87.     (if (> d rad)
  88.       (setq l (sqrt (* (+ d rad) (- d rad)))
  89.             a (atan l rad)
  90.             b (angle cen pt)
  91.             p (polar cen (+ b a) rad)
  92.             q (polar cen (- b a) rad)
  93.             r (list p q)
  94.       )
  95.     )
  96.   )
  97. )

  99. ;;;----------------------------------------------------;
  100. ;;;两个圆的公切线                                      ;
  101. ;;;输入: 给定两个圆的圆心和半径                        ;
  102. ;;;输出: 这两个圆的公切线(nil，一个点或者点对集合)     ;
  103. ;;;----------------------------------------------------;
  104. (defun CIR:Common_Tangent (c1 r1 c2 r2 / a b d eps p q m n u v ret L)
  105.   (setq d (distance c1 c2))
  106.   (setq a (angle c1 c2))
  107.   (setq eps 1e-8)
  108.   (cond
  109.     ( (equal d 0 eps) nil)                                ;圆心重合，无解或者无穷解
  110.     ( (equal d (abs (setq b (- r1 r2))) eps)                 ;内切
  111.       (setq p (polar c1 a (Math:Sign_reversal r1 b)))         ;切点
  112.       (list (list p (polar p (+ a (* pi 0.5)) 1000)))         ;内切线
  113.     )
  114.     ( (> d b)
  115.       (foreach r (list b (+ r1 r2))                        ;考虑内外公切两种情况
  116.         (setq l (* (+ d r) (- d r)))
  117.         (cond
  118.           ( (equal l 0 eps)                                ;两个圆外切
  119.             (setq p (polar c1 a r1))
  120.             (setq q (polar p (+ a (* pi 0.5)) 1000))   
  121.             (setq ret (cons (list p q) ret))
  122.           )
  123.           ( (> l 0)
  124.             (setq u (atan (sqrt l) r))
  125.             (setq v (- a u))
  126.             (setq u (+ a u))
  127.             (setq p (polar C1 u r1))
  128.             (setq q (polar C1 v r1))
  129.             (if (eq r b)                  
  130.               (setq m (polar c2 u r2)                         ;外公切线
  131.                     n (polar c2 v r2)
  132.               )
  133.               (setq m (polar c2 u (- r2))                 ;内公切线
  134.                     n (polar c2 v (- r2))
  135.               )
  136.             )
  137.             (setq ret (cons (list p m) ret))            
  138.             (setq ret (cons (list q n) ret))
  139.           )
  140.         )
  141.       )
  142.       Ret
  143.     )
  144.   )
  145. )

两个圆的公切线图片：
解可能有很多种：

三、已知圆半径作图问题。

  1. ;;;----------------------------------------------------;
  2. ;;;作给定半径并经过两点的圆                            ;
  3. ;;;输入: 不重合的两点和半径                            ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PPR (P1 P2 R / D M H A eps)
  7.   (setq eps 1e-6)
  8.   (setq M (GEO:Midpoint P1 P2))
  9.   (setq D (distance P1 M))
  10.   (cond
  11.     ( (equal D 0 eps) nil)                                ;两点重合，无穷解
  12.     ( (equal D R eps)                                        ;两点为直径的两个端点
  13.       (list (list M R))
  14.     )
  15.     ( (> R D)                                                ;满足两点距离小于给定直径
  16.       (setq H (sqrt (* (+ R D) (- R D))))
  17.       (setq A (+ (angle P1 P2) (* pi 0.5)))
  18.       (list (list (polar M A H) R)                        ;有两解
  19.             (list (polar M A (- H)) R)
  20.       )
  21.     )
  22.   )
  23. )



  1. ;;;----------------------------------------------------;
  2. ;;;经过一点和一直线相切的具有给定半径的圆              ;
  3. ;;;输入: 点和直线的两个端点以及给定的半径              ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PLR (Pt0 PtA PtB Rad / H P D A B X Y eps)
  7.   (setq eps 1e-6)
  8.   (setq P (Line:Perpendicular_Foot Pt0 PtA PtB))
  9.   (setq H (abs (car P)))
  10.   (setq P (cadr P))
  11.   (setq D (+ Rad Rad))
  12.   (cond
  13.     ( (equal H D eps)
  14.       (list (list (GEO:Midpoint  Pt0 P) Rad))
  15.     )
  16.     ( (equal H 0 eps)
  17.       (setq A (+ (angle PtA PtB) (/ pi 2)))
  18.       (list
  19.         (list (polar Pt0 A Rad) Rad)
  20.         (list (polar Pt0 A (- Rad)) Rad)
  21.       )
  22.     )
  23.     ( (< H D)
  24.       (setq Y (- H Rad))
  25.       (setq X (sqrt (* (+ Rad Y) (- Rad Y))))
  26.       (setq B (atan X Y))
  27.       (setq A (angle Pt0 P))
  28.       (list
  29.         (list (polar Pt0 (+ A B) Rad) Rad)
  30.         (list (polar Pt0 (- A B) Rad) Rad)
  31.       )
  32.     )
  33.   )
  34. )


  1. ;;;----------------------------------------------------;
  2. ;;;和两直线相切的具有给定半径的圆(一般来说是两相交直线);
  3. ;;;输入: 两直线的四个端点以及给定的半径                ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:LLR (PtA PtB PtC PtD Rad / a1 a2 a3 a4 a5 L1 L2 Int)
  7.   (setq int (inters PtA PtB PtC PtD nil))
  8.   (if int
  9.     (progn
  10.       (setq a1 (angle pta ptb))
  11.       (setq a2 (angle ptc ptd))
  12.       (setq a3 (* (+ a1 a2) 0.5))
  13.       (setq a4 (* (- a1 a2) 0.5))
  14.       (setq a5 (+ a3 (* pi 0.5)))
  15.       (setq L1 (/ Rad (sin a4)))
  16.       (setq L2 (/ Rad (cos a4)))
  17.       (list
  18.         (list (polar int a3 L1) Rad)
  19.         (list (polar int a3 (- L1)) Rad)
  20.         (list (polar int a5 L2) Rad)
  21.         (list (polar int a5 (- L2)) Rad)
  22.       )            
  23.     )
  24.   )
  25. )



  1. ;;;----------------------------------------------------;
  2. ;;;和一直线及一定圆相切的具有给定半径的圆              ;
  3. ;;;输入: 直线的两个端点，圆的圆心和半径以及给定的半径  ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:LCR (PtA PtB C0 R0 R1 / d a ret)
  7.   (setq d (Line:Perpendicular_Distance C0 PtA PtB))
  8.   (setq A (angle PtA PtB))
  9.   (foreach h (list (+ d r1) (- d r1))
  10.     (foreach r (list (+ r0 r1) (abs (- r0 r1)))
  11.       (foreach p (CIR:Circle_Inters_Line_1 C0 R A h)
  12.         (setq ret (cons (list p r1) ret))
  13.       )
  14.     )
  15.   )
  16.   (reverse ret)
  17. )



  1. ;;;---------------------------------------------------;
  2. ;;;与两个圆相切的具有给定半径的圆                      ;
  3. ;;;输入: 两个圆的圆心和半径以及给定的半径              ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:CCR (C1 R1 C2 R2 R0 / ret)
  7.   (foreach R (list (cons (+ R1 R0) (+ R2 R0))
  8.                    (cons (+ R1 R0) (abs (- R2 R0)))
  9.                    (cons (abs (- R1 R0)) (+ R2 R0))
  10.                    (cons (abs (- R1 R0)) (abs (- R2 R0)))
  11.              )                  
  12.     (foreach p (CIR:Circle_inters_Circle C1 (car R) C2 (cdr R))
  13.       (setq ret (cons (list p R0) Ret))
  14.     )
  15.   )
  16.   ret        
  17. )


  1. ;;;----------------------------------------------------;
  2. ;;;通过一定点和一定圆相切的具有给定半径的圆            ;
  3. ;;;输入: 点，圆的圆心和半径以及给定的半径              ;
  4. ;;;输出: 无解或无穷解为nil,否则用中心半径表示的圆的列表;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PCR (P0 C0 R0 R1 / ret)
  7.   (foreach r (list (+ r0 r1) (abs (- r0 r1)))
  8.     (foreach p (CIR:Circle_inters_Circle p0 r1 c0 r)
  9.       (setq ret (cons (list p R1) ret))
  10.     )
  11.   )
  12.   ret        
  13. )

四、点、线、圆的组合问题。
这段提到的情况，基本都可以用CAD的三点画圆方式作出来。但CAD 的作图在某些情况下可能会失效，或者不准确。

  1. ;;;----------------------------------------------------;
  2. ;;;求三角形外心   TRI:CircumCenter，Or Called ExCenter ;
  3. ;;;尽管这样写很麻烦，显得代码很多，但运行却很快        ;
  4. ;;;输入: 给定不共线的三个点                            ;
  5. ;;;输出: 三点的外接圆(圆心和半径表示),nil表示三点共线  ;
  6. ;;;----------------------------------------------------;
  7. (defun CIR:PPP (P0 P1 P2 / X0 Y0 X1 Y1 X2 Y2 DX1 DY1 DX2 DY2 D 2D C1 C2 CE)
  8.   (setq        X0  (car  P0)
  9.         Y0  (cadr P0)
  10.         X1  (car  P1)
  11.         Y1  (cadr P1)
  12.         X2  (car  P2)
  13.         Y2  (cadr P2)
  14.         DX1 (- X1 X0)
  15.         DY1 (- Y1 Y0)
  16.         DX2 (- X2 X0)
  17.         DY2 (- Y2 Y0)
  18.   )
  19.   (setq D (- (* DX1 DY2) (* DX2 DY1)))
  20.   (if (equal D 0 1e-14)
  21.     nil
  22.     (progn
  23.       (setq 2D (+ D D)
  24.             C1 (+ (* DX1 (+ X0 X1)) (* DY1 (+ Y0 Y1)))
  25.             C2 (+ (* DX2 (+ X0 X2)) (* DY2 (+ Y0 Y2)))
  26.             CE (List (/ (- (* C1 DY2) (* C2 DY1)) 2D)
  27.                      (/ (- (* C2 DX1) (* C1 DX2)) 2D)
  28.                )
  29.       )
  30.       (list CE (distance CE P0))
  31.     )
  32.   )
  33. )


  1. ;;;----------------------------------------------------;
  2. ;;;三角形内心  Tri:InCenter                            ;
  3. ;;;(aX1+bx2+cx3)/(a+b+c)  (aY2+bY2+CY3)/(a+b+c)        ;
  4. ;;;输入: 给定三个点                                    ;
  5. ;;;输出: 三点的内切圆(圆心和半径表示)                  ;
  6. ;;;----------------------------------------------------;
  7. (defun Tri:InCenter (pa pb pc / a b c L I r)
  8.   (setq a (distance pb pc))
  9.   (setq b (distance pc pa))
  10.   (setq c (distance pa pb))
  11.   (setq L (+ a b c))
  12.   (if (/= L 0.0)
  13.     (setq I (MAT:SxVs (list pa pb pc) (list (/ a L) (/ b L) (/ c L)))
  14.           R (list I (abs (Line:Perpendicular_Distance I pa pb)))
  15.     )
  16.     (list pa 0)
  17.   )
  18. )


  1. ;;;----------------------------------------------------;
  2. ;;;跟三条直线相切的圆形                                ;
  3. ;;;输入: 给定三条直线                                  ;
  4. ;;;输出: 与这三条直线都相切的圆（内切圆和旁切圆）      ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:LLL (P1a P1b P2a P2b P3a P3b / bs1 bs2 ret int rad)
  7.   (setq bs1 (LINE:Angular_Bisector P1a p1b p2a p2b))                        ;角平分线1
  8.   (setq bs2 (LINE:Angular_Bisector P2a p2b p3a p3b))                        ;角平分线2
  9.   (foreach p bs1
  10.     (foreach q bs2
  11.       (if (setq int (inters (car p) (cadr p) (car q) (cadr q) nil))        ;如果角平分线相交
  12.         (setq rad (LINE:Perpendicular_Distance int p1a p1b)                ;求出交点到任意线段距离即半径
  13.               ret (cons (list int (abs rad)) ret)                        ;加入到解集中
  14.         )
  15.       )
  16.     )
  17.   )
  18.   ret   
  19. )


  1. ;;;----------------------------------------------------;
  2. ;;;点点切线圆,求通过两定点，和一直线相切的圆           ;
  3. ;;;输入: P1,P2,通过的点,PA,PB直线上的两点。            ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PPL (P1 P2 PA PB / AN D1 D2 P3 DD INT C1 C2 L1 L2 Mid NRM T1 T2 RT eps)
  7.   (setq eps 1e-6)
  8.   (if (and (not (equal p1 p2 eps)) (Line:IsSameSide P1 P2 PA PB))         ;同侧且不重合
  9.     (progn
  10.       (setq int (inters p1 p2 pa pb nil))
  11.       (setq nrm (MAT:Rot90 (mapcar '- pa pb)))                                ;垂直PAPB的矢量
  12.       (setq Mid (GEO:Midpoint p1 p2))                                        ;P1P2的中点
  13.       (if int
  14.         (progn
  15.           (setq l1 (distance int p1))
  16.           (setq l2 (distance int p2))
  17.           (setq P3 (GEO:Rot90 Mid p1 p2))
  18.           (if (or (equal int p1 eps) (equal int p2 eps))                ;如果P1或P2跟交点重合则交点为切点
  19.             (setq C1 (inters Mid P3 int (mapcar '+ int nrm) nil)        ;两点的垂直平分线跟交点处的垂线的交点
  20.                   RT (list (list C1 (distance C1 P1)))                  ;为圆心，半径自然确定了。
  21.             )
  22.             (setq an (angle pA pB)                                    
  23.                   dd (sqrt (* l1 l2))                                   ;利用割弦定理得到交点到切点距离
  24.                   t1 (polar int an dd)                                  ;切点1
  25.                   t2 (polar int an (- dd))                              ;切点2
  26.                   C1 (inters Mid P3 t1 (mapcar '+ t1 nrm) nil)                ;两点的垂直平分线跟过切点1的垂线的交点
  27.                   C2 (inters Mid P3 t2 (mapcar '+ t2 nrm) nil)                ;两点的垂直平分线跟过切点2的垂线的交点
  28.                   RT (list (list C1 (distance C1 P1))                     ;画圆1
  29.                            (list C2 (distance C2 P2))                        ;画圆2
  30.                      )
  31.             )
  32.           )
  33.         )
  34.         (if (setq t1 (inters Mid (mapcar '+ Mid nrm) PA PB nil))        ;两点跟直线平行的情况
  35.           (list (CIR:PPP p1 p2 t1))
  36.         )
  37.       )
  38.     )
  39.   )
  40. )


  1. ;;;----------------------------------------------------;
  2. ;;;点线线切圆，求通过某定点并与两条直线相切的圆        ;
  3. ;;;输入: P,通过的点,PA,PB,PC,PD两直线上的四个端点。    ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PLL-1 (p pA pB Int / H L X r1 r2 an)                ;特殊情况下的处理P点在角平分线上
  7.   (setq H (Line:Perpendicular_Distance p PA PB))
  8.   (setq H (abs H))
  9.   (setq L (distance p Int))
  10.   (setq X (* H L))
  11.   (setq r1 (/ X (+ L H)))
  12.   (setq r2 (/ X (- L H)))
  13.   (setq an (angle P int))
  14.   (list        (list (polar P an r1) r1)
  15.         (list (polar p an (- r2)) r2)
  16.   )
  17. )
  18. (defun CIR:PLL (P pA pB pC pD / A A1 A2 D D1 D2 EPS H INT L P1 P2 PM R)
  19.   (setq eps 1e-6)
  20.   (if (setq int (inters pA pB pC pD nil))                ;判断两直线是否相交
  21.     (if        (equal int P eps)                                ;如果交点跟定点重合
  22.       (list (list int 0))                                ;视作半径为0
  23.       (progn
  24.         (if (equal int PA eps) (setq p1 PA PA PB PB P1))
  25.         (if (equal int PC eps) (setq p2 PC PC PD PD P2))
  26.         (setq D1 (Line:Perpendicular_Distance p int PA));定点到直线1距离
  27.         (setq D2 (Line:Perpendicular_Distance p int PC));定点到直线2距离
  28.         (setq a1 (angle int PA))                 
  29.         (setq a2 (angle int PC))                 
  30.         (setq a1 (* (+ a1 a2) 0.5))                         ;内角平分线
  31.         (setq a2 (+ a1 (* pi 0.5)))                        ;外角平分线
  32.         (setq p1 (GEO:Mirror2D P int a1))                ;对内角平分线的镜像点
  33.         (setq p2 (GEO:Mirror2D P int a2))                ;对外角平分线的镜像点
  34.         (if (or (equal p1 P eps) (equal p2 P eps))        ;如果跟角平分线重合
  35.           (CIR:PLL-1 p pA pB Int)                        ;按特殊情况处理
  36.           (if (or (equal d1 0 eps) (equal d2 0 eps))        ;如果定点在一条直线上
  37.             (append                                        ;则内外角平分线都要考虑
  38.               (CIR:PPL P p1 PA PB)                        
  39.               (CIR:PPL P p2 PA PB)
  40.             )   
  41.             (if (MATH:Same_Sign d1 d2)                        ;剩下的转化为CIR:PPL问题
  42.               (CIR:PPL P p2 PA PB)                             ;同号是外角平分线的镜像点
  43.               (CIR:PPL P p1 PA PB)                        ;异号是内角平分线的镜像点
  44.             )
  45.           )
  46.         )
  47.       )
  48.     )
  49.     (progn                                                ;以下是为平行的两直线考虑
  50.       (setq D1 (Line:Perpendicular_Foot p PA PB))        ;定点到直线的距离
  51.       (setq D2 (Line:Perpendicular_Foot p PC PD))        ;定点到直线的距离
  52.       (setq D  (Line:Perpendicular_Distance PA PC PD))        ;两平行直线的距离
  53.       (setq D  (abs D))
  54.       (setq P1 (cadr D1))
  55.       (setq P2 (cadr D2))
  56.       (setq D1 (abs (car D1)))
  57.       (setq D2 (abs (car D2)))
  58.       (setq pM (GEO:Midpoint P1 P2))                        ;两垂足的中点
  59.       (cond
  60.         ( (or (equal D1 0 eps) (equal D2 0 eps))        ;如果定点在某一直线上
  61.           (list (list PM (* D 0.5)))                        ;两垂足的中点是圆心
  62.         )
  63.         ( (equal D (+ d1 d2) eps)                        ;定点只有在两条直线之间才有解
  64.           (setq R (* D 0.5))                                ;半径是两平行直线距离的一半
  65.           (setq H (- d1 R))
  66.           (setq L (sqrt (- (* R R) (* H H))))
  67.           (setq A (angle PA PB))
  68.           (list (list (polar PM A L) R)                        ;此时有两个解
  69.                 (list (polar pM A (- L)) R)
  70.           )
  71.         )
  72.       )
  73.     )
  74.   )
  75. )



  1. ;;;----------------------------------------------------;
  2. ;;;点点切的圆(求通过两不相同的点并与一个圆相切的圆)    ;
  3. ;;;输入: 两定点和给定的一个圆的圆心及半径              ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PPC (p1 p2 cen rad / PA PB pC PD PM RT an d1 d2 dd eps)
  7.   (setq eps 1e-6)
  8.   (setq dd (distance p1 p2))
  9.   (setq d1 (distance cen p1))
  10.   (setq d2 (distance cen p2))
  11.   (setq pM (GEO:Midpoint  p1 p2))
  12.   (setq an (+ (angle p1 p2) (/ pi 2)))
  13.   (cond
  14.     ( (equal dd 0 eps) nil)                        
  15.     ( (or (equal d1 rad eps) (equal d2 rad eps))
  16.       (if (equal d1 rad eps)
  17.         (setq PA p1 PB p2)
  18.         (setq PA p2 PB p1)
  19.       )
  20.       (setq pC (polar PM an rad))
  21.       (setq pD (inters pM PC PA CEN nil))
  22.       (if PD
  23.         (list (list pD (distance pD p1)))
  24.       )
  25.     )
  26.     ( (equal d1 d2 eps)
  27.       (setq pA (polar cen an rad))
  28.       (setq pB (polar cen an (- rad)))
  29.       (foreach p (list PA PB)
  30.            (setq rt (cons (CIR:PPP p1 p2 p) rt))
  31.       )
  32.     )
  33.     ( (Cir:Is_Same_Side rad d1 d2)
  34.       (setq pA (CIR:Radical_Axis PM (/ dd 2) Cen rad))
  35.       (setq PB (polar pA (+ (angle pA cen) (/ pi 2)) rad))
  36.       (setq pC (inters pA pB p1 p2 nil))
  37.       (foreach p (CIR:Point_Tangent cen rad pC)
  38.         (setq rt (cons (CIR:PPP p1 p2 p) rt))
  39.       )
  40.     )
  41.   )
  42. )



  1. ;;;----------------------------------------------------;
  2. ;;;把点圆圆切问题转化为点点圆切问题                    ;
  3. ;;;Antihomologous Points                               ;
  4. ;;;----------------------------------------------------;
  5. (defun CIR:PCC->PPC (pt c1 r1 c2 r2 / eps k p q d s)
  6.   (setq eps 1e-8)
  7.   (foreach a (list (+ r1 r2) (- r1 r2))
  8.     (if (equal a 0 eps)                                        ;半径相等情况下作镜像
  9.       (setq p (GEO:Midpoint c1 c2)
  10.             q (GEO:Mirror2D pt p (+ (angle c1 c2) (/ pi 2)))
  11.             s (cons q s)
  12.       )
  13.       (progn
  14.         (setq p (GEO:Scale c2 c1 (/ r1 a)))                ;对于内外切线交点的映射
  15.         (setq d (distance pt p))
  16.         (and (= a (+ r1 r2)) (setq d (- d)))
  17.         (if (equal d 0 eps)
  18.           s
  19.           (setq k (/ (distance c1 c2) a)
  20.                 k (* r1 r2 (1- (* k k)))
  21.                 q (polar p (angle p pt) (/ k d))
  22.                 s (cons q s)
  23.           )
  24.         )
  25.       )
  26.     )
  27.   )
  28. )

  30. ;;;----------------------------------------------------;
  31. ;;;点切切的圆(求通过一定点并与两给定圆相切的圆)        ;
  32. ;;;输入: 一定点和给定的两个圆的圆心及半径              ;
  33. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  34. ;;;----------------------------------------------------;
  35. (defun CIR:PCC (pt Cen1 rad1 Cen2 rad2 / HC an c EPS H PM v x y)
  36.   (setq eps 1e-8)
  37.   (setq HC (CIR:PCC->PPC pt cen1 rad1 cen2 rad2))
  38.   (setq pM (GEO:Midpoint  Cen1 Cen2))
  39.   (foreach p HC
  40.     (if        (equal p pt eps)
  41.       (progn
  42.         (setq H (Line:Perpendicular_Distance pt cen1 cen2))
  43.         (setq x (distance cen1 pM))
  44.         (setq x (* x x))
  45.         (setq a (+ (angle cen1 cen2) (/ pi 2)))
  46.         (foreach k (list (+ H rad1) (- H rad1))
  47.           (if (not (equal k 0 eps))
  48.             (setq y (/ (- (* K K) x) K 2)
  49.                   c (polar pm a y)
  50.                   v (cons (list c (distance pt c)) v)
  51.             )
  52.           )
  53.         )
  54.       )
  55.       (setq v (append (CIR:PPC p pt cen1 rad1) v))
  56.     )
  57.   )
  58.   v
  59. )


  1. ;;;----------------------------------------------------;
  2. ;;;点线圆切的圆(求通过一定点并与一直线和一圆都相切的圆);
  3. ;;;输入: 一定点和直线的两个端点给定的圆的圆心及半径    ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:PLC_1 (P0 Pa Pb R0 C0 / eps f a b c d x y y0 y1 dy k k1 a1 a2 s p)
  7.   (setq eps 1e-8)
  8.   (setq f (Line:Equation Pa Pb))
  9.   (setq A (car f))
  10.   (setq B (cadr f))
  11.   (setq C (caddr f))
  12.   (setq D (sqrt (+ (* A A) (* B B))))
  13.   (setq y0 (/ (+ (* A (car C0)) (* B (cadr C0)) C) D))
  14.   (setq y1 (/ (+ (* A (car P0)) (* B (cadr P0)) C) D))
  15.   (setq dy (- y0 y1))
  16.   (setq k1 (- (* dy (+ y0 y1)) (* R0 R0)))
  17.   (setq a1 (angle Pa Pb))
  18.   (setq a2 (+ a1 (* pi 0.5)))
  19.   (setq s nil)
  20.   (foreach R (list R0 (- R0))
  21.     (setq k (+ dy R))
  22.     (setq k (+ k k))
  23.     (if        (not (equal k 0 eps))
  24.       (progn
  25.         (setq y (/ k1 k))
  26.         (setq p (polar C0 a2 (- y y0)))
  27.         (setq x (* y1 (- (+ y y) y1)))
  28.         (cond
  29.           ( (equal x 0 eps)
  30.             (setq s (cons (list p (abs y)) s))
  31.           )
  32.           ( (> x 0)
  33.             (setq x (sqrt x))
  34.             (setq s (cons (list (polar p a1 x) (abs y)) s))
  35.             (setq s (cons (list (polar p a1 (- x)) (abs y)) s))
  36.           )
  37.         )
  38.       )
  39.     )
  40.   )
  41.   s
  42. )

  44. ;;;----------------------------------------------------;
  45. ;;;点线圆切的圆(求通过一定点并与一直线和一圆都相切的圆);
  46. ;;;输入: 一定点和直线的两个端点给定的圆的圆心及半径    ;
  47. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  48. ;;;----------------------------------------------------;
  49. (defun CIR:PLC (Pt0 PtA PtB Cen Rad / v1 v2 P1 P2 PO an q m i c s)
  50.   (setq v1 (mapcar '- cen Pt0))
  51.   (setq v2 (mapcar '- PtA ptb))
  52.   (if (equal (MAT:Dot v1 v2) 0 1e-6)
  53.     (CIR:PLC_1 Pt0 PtA PtB Rad Cen)                        ;定点在过圆心的垂直直线的线上
  54.     (progn
  55.       (setq p1 (CIR:Radical_Axis_Point Cen Rad Pt0))        ;等幂轴线
  56.       (setq p2 (GEO:Rot90 P1 cen Pt0))                        ;等幂轴线另外一点
  57.       (setq pO (inters P1 P2 PtA PtB nil))                     ;等幂中心
  58.       (setq an (+ (angle PtA PtB) (/ pi 2)))                ;垂直直线的角度
  59.       (setq p1 (polar cen an rad))                        ;圆的直径端点1
  60.       (setq p2 (polar cen an (- rad)))                        ;圆的直径端点2
  61.       (foreach p (list p1 p2)                           ;对每个直径端点
  62.         (setq q (CIR:Polar_Point_1 Cen Rad Pt0 p))      ;求出圆对到端点和Pt0的直线的极点
  63.         (foreach n (CIR:Circle_inters_Line Cen rad pO q);对每个极点和等幂中心的直线与圆的交点
  64.           (setq m (Geo:MidPoint Pt0 n))                        ;中点
  65.           (setq i (Geo:Rot90 m Pt0 n))                   ;垂直平分线
  66.           (if (setq c (inters m i Cen n nil))           ;如果相交则交点是圆心
  67.             (setq s (cons (list c (distance c n)) s))   ;加入到解集
  68.           )
  69.         )
  70.       )
  71.       s
  72.     )
  73.   )
  74. )


  1. ;;;----------------------------------------------------;
  2. ;;;切线切线切圆（切两定直线和一定圆的圆）              ;
  3. ;;;输入: 两定直线的四个端点给定的圆的圆心及半径        ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:LLC (PA PB PC PD C0 R0 / Ret Pts eps Int a1 a2 a3 a4 Va Vc Vp Vx Vy L G S P1 P2 Pt c d r)
  7.   (setq eps 1e-6)
  8.   (defun CIR:Equal (P1 P2)
  9.     (equal p1 p2 1e-6)
  10.   )
  11.   (if (setq int (inters PA PB PC PD nil))
  12.     (progn
  13.       (if (equal pa int eps)
  14.         (mapcar 'set '(pb pa) (list pa pb))                ;确保Pa与int不重合
  15.       )                                                  
  16.       (if (equal pc int eps)
  17.         (mapcar 'set '(pd pc) (list pc pd))                ;确保Pc与int不重合
  18.       )                                                
  19.       (setq a1 (angle int pa))                                
  20.       (setq a2 (angle int pc))
  21.       (setq Va (mapcar '- Pa Int))                        ;交点到Pa的矢量
  22.       (setq Vc (mapcar '- Pc Int))                        ;交点到Pc的矢量
  23.       (setq a3 (* (- a1 a2) 0.5))                        ;角度差的一半
  24.       (setq a4 (- a1 a3))                                ;角度和的一半
  25.       (setq P1 (polar int a4 1000))                     ;角平分线1
  26.       (setq P2 (polar int (+ a4 (* pi 0.5)) 1000))        ;角平分线2
  27.       (foreach a (list 0 (* pi 0.5) Pi (* pi -0.5))
  28.         (setq L (abs (/ r0 (sin (+ a3 a)))))                ;圆心到圆的极点的距离
  29.         (setq G (polar C0 (+ a4 a) L))
  30.         (setq S (CIR:Circle_Inters_Line C0 R0 Int G))        ;如果跟圆相交
  31.         (if S
  32.           (progn
  33.             (setq Vp (mapcar '- G int))
  34.             (setq Vx (car (trans Vp 0 Va)))
  35.             (setq Vy (car (trans Vp 0 Vc)))
  36.             (if (or (equal vx 0 eps) (equal vy 0 eps))        ;如果跟其中一边相切
  37.               (setq Pt (list p1 p2))                        ;则内角和外角平分线都要考虑
  38.               (if (MATH:Opposite_Sign vx vy)                ;距离方向是否相反
  39.                 (setq Pt (list p1))                        ;如果距离方向相反则是内角平分线
  40.                 (setq Pt (list p2))                        ;如果距离方向相同则是外角平分线
  41.               )
  42.             )
  43.             (foreach p S
  44.               (if (not (MISC:IsExist p Pts 'CIR:Equal)) ;避免重复
  45.                 (progn
  46.                   (setq pts (cons p pts))
  47.                   (foreach q Pt
  48.                     (setq c (inters p C0 Int q nil))
  49.                     (if c
  50.                       (setq ret (cons (list c (distance c p)) ret))
  51.                       (setq ret (append (CIR:PLL-1 p PA PB Int) ret))
  52.                     )
  53.                   )
  54.                 )
  55.               )
  56.             )
  57.           )
  58.         )
  59.       )
  60.     )
  61.     (progn
  62.       (setq d (LINE:Perpendicular_Distance PA PC PD))
  63.       (setq r (* d 0.5))
  64.       (setq l (LINE:offset PC PD r))
  65.       (grdraw (car l) (cadr l) 6)
  66.       (setq r (abs r))
  67.       (foreach x (list (+ r0  r) (abs (- r0 r)))
  68.         (foreach c (CIR:Circle_Inters_Line C0 x (car l) (cadr l))
  69.           (setq ret (cons (list c r) ret))
  70.         )
  71.       )
  72.     )
  73.   )
  74.   ret
  75. )


  1. ;;;----------------------------------------------------;
  2. ;;;切线圆圆画圆（与一直线和两个圆都相切的圆）          ;
  3. ;;;输入: 给定一条直线和两个圆                          ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:LCC (Pa Pb C1 R1 C2 R2)
  7.   (if (LINE:Colinearity C1 Pa Pb)
  8.     (mapcar 'set '(C1 R1 C2 R2) (list C2 R2 C1 R1))
  9.   )
  10.   (setq IC2 (CIR:Circle_Inversion C1 R1 C2 R2))
  11.   (setq IC3 (CIR:Line_Inversion C1 R1 Pa Pb))
  12.   (setq lst (append (list C1 R1) IC2 IC3))
  13.   (setq ret nil)
  14.   (foreach c (apply 'CIR:CCC lst)
  15.     (setq ret (cons (CIR:Circle_Inversion C1 R1 (car c) (cadr c)) Ret))
  16.   )
  17. )


这种情况是最复杂的一种，叫阿波罗尼奥斯问题。
  1. ;;;----------------------------------------------------;
  2. ;;;切切切的圆(与三个圆都相切的圆) Apollonius' problem  ;
  3. ;;;输入: 三个给定的圆的圆心及半径                      ;
  4. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:CCC (c1 r1 c2 r2 c3 r3 / CC1 CC2 CC3 CCC CEN DAT DMC EX1 EX2 EX3 HC1 HC2 HC3 HCS EPS NT1 NT2 NT3
  7.                                     PC1 PC2 PC3 PS1 PS2 PS3 Pt1 Pt2 PT3 RR1 RR2 RR3 IN1 IN2 IN3 KA1 KB1 KC1
  8.                                     LN1 MT1 MT2 MT3 RAD RET ISALL I AN ARG C IDX INC LST)
  9.   (setq RET nil)
  10.   (setq eps 1e-6)
  11.   (cond
  12.     ( (and (equal c1 c2 eps) (equal c2 c3 eps)) nil)
  13.     ( (LINE:Colinearity c1 c2 c3)
  14.       (setq lst (list (list C1 R1) (list C2 R2) (list C3 R3)))
  15.       (setq idx (vl-sort-i (mapcar 'cadr lst) '>))
  16.       (setq C1  (nth (car idx) lst))
  17.       (setq C2  (nth (cadr idx) lst))
  18.       (setq C3  (nth (caddr idx) lst))
  19.       (setq R1  (cadr C1))
  20.       (setq R2  (cadr C2))
  21.       (setq R3  (cadr C3))
  22.       (setq C1  (car  C1))
  23.       (setq C2  (car  C2))
  24.       (setq C3  (car  C3))
  25.       (if (equal C1 C2 eps)
  26.         (setq an (angle c1 c3))
  27.         (setq an (angle c1 c2))
  28.       )
  29.       (setq InC (polar C1 (+ an (* pi 0.5)) (+ R1 R1)))
  30.       (setq arg nil)
  31.       (setq ret nil)
  32.       (foreach n (list (list C1 R1) (list C2 R2) (list C3 R3))
  33.         (setq C (CIR:Circle_Inversion InC R1 (car n) (cadr n)))
  34.         (setq arg (append c arg))
  35.       )
  36.       (foreach n (apply 'CIR:CCC arg)
  37.         (setq C (CIR:Circle_Inversion InC R1 (car n) (cadr n)))
  38.         (if (numberp (cadr c))
  39.           (setq ret (cons c ret))
  40.         )
  41.       )
  42.     )
  43.     (t
  44.       (setq DMC (CIR:Power_Center c1 r1 c2 r2 c3 r3))
  45.       (setq HC1 (CIR:Homothetic_Center c2 r2 c3 r3))
  46.       (setq HC2 (CIR:Homothetic_Center c3 r3 c1 r1))
  47.       (setq HC3 (CIR:Homothetic_Center c1 r1 c2 r2))
  48.       (setq in1 (car HC1))
  49.       (setq in2 (car HC2))
  50.       (setq in3 (car HC3))
  51.       (setq ex1 (cadr HC1))
  52.       (setq ex2 (cadr HC2))
  53.       (setq ex3 (cadr HC3))

  55.       (setq CCC (car DMC))
  56.       (setq dat (cadr DMC))
  57.       (setq Cen (list c1 c2 c3))
  58.       (setq Rad (list r1 r2 r3))

  60.       (setq HCs        (list (list ex1 ex2 ex3 T)
  61.                       (list in3 in1 ex2)
  62.                       (list in1 in2 ex3)
  63.                       (list in2 in3 ex1)
  64.                 )
  65.       )

  67.       (foreach x HCs
  68.         (setq isAll (cadddr x))
  69.         (setq Pt1 (car x))
  70.         (setq Pt2 (cadr x))
  71.         (setq pt3 (caddr x))

  73.         (setq cc1 (car cen))
  74.         (setq cc2 (cadr cen))
  75.         (setq cc3 (caddr cen))

  77.         (setq rr1 (car rad))
  78.         (setq rr2 (cadr rad))
  79.         (setq rr3 (caddr rad))

  81.         (setq cen (append (cdr cen) (list (car cen))))
  82.         (setq rad (append (cdr rad) (list (car rad))))

  84.         (if (and (= (car Pt1) 1e400) (= (car Pt2) 1e400))
  85.           (setq pc1 cc1 pc2 cc2 pc3 cc3)
  86.           (progn
  87.             (if (= (car Pt1) 1e400)
  88.               (setq Ln1 (Line:Equation Pt2 pt3))
  89.               (if (= (car Pt2) 1e400)
  90.                 (setq Ln1 (Line:Equation pt3 Pt1))
  91.                 (setq Ln1 (Line:Equation Pt1 Pt2))
  92.               )
  93.             )
  94.             (setq kA1 (car Ln1)
  95.                   kB1 (cadr ln1)
  96.                   kC1 (caddr ln1)
  97.                   pc1 (CIR:Polar_Point cc1 rr1 kA1 kB1 kC1)
  98.                   pc2 (CIR:Polar_Point cc2 rr2 kA1 kB1 kC1)
  99.                   pc3 (CIR:Polar_Point cc3 rr3 kA1 kB1 kC1)
  100.             )
  101.           )
  102.         )
  103.         (setq Ps1 (CIr:Circle_Inters_Line cc1 rr1 CCC PC1))
  104.         (setq Ps2 (CIr:Circle_Inters_Line cc2 rr2 CCC pc2))
  105.         (setq ps3 (CIr:Circle_Inters_Line cc3 rr3 CCC pc3))

  107.         (setq mt1 (car ps1))
  108.         (setq mt2 (car ps2))
  109.         (setq mt3 (car ps3))

  111.         (setq nt1 (cadr ps1))
  112.         (setq nt2 (cadr ps2))
  113.         (setq nt3 (cadr ps3))

  115.         (if (and nt1 nt2 nt3)
  116.           (if isAll
  117.             (setq RET (cons (CIR:PPP mt1 mt2 mt3) RET)
  118.                   RET (cons (CIR:PPP nt1 nt2 nt3) RET)
  119.             )
  120.             (setq RET (cons (CIR:PPP mt1 nt2 nt3) RET)
  121.                   RET (cons (CIR:PPP nt1 mt2 mt3) RET)
  122.             )
  123.           )
  124.           (if (and mt1 mt2 mt3)
  125.             (progn
  126.               (setq nt1 mt3)
  127.               (and (equal mt1 mt3 eps) (setq nt1 mt2))
  128.               (setq RET (append (CIR:PPC mt1 nt1 cc1 rr1) RET))
  129.             )
  130.           )
  131.         )
  132.       )
  133.     )
  134.   )
  135.   RET
  136. )

  138. ;;;----------------------------------------------------;
  139. ;;;按照某个函数升序排序                                ;
  140. ;;;----------------------------------------------------;
  141. (defun MISC:ASort (l f)
  142.   (vl-sort l (function (lambda (e1 e2) (< (f e1) (f e2)))))
  143. )

  145. ;;;----------------------------------------------------;
  146. ;;;按照某个函数降序排序                                ;
  147. ;;;----------------------------------------------------;
  148. (defun MISC:DSort (l f)
  149.   (vl-sort l (function (lambda (e1 e2) (> (f e1) (f e2)))))
  150. )

  152. ;;;----------------------------------------------------;
  153. ;;;反号                                                ;
  154. ;;;----------------------------------------------------;
  155. (defun MISC:RevSign (f)
  156.   (if (eq f +) - +)
  157. )

  159. ;;;----------------------------------------------------;
  160. ;;;切切切的圆(与三个圆都相切的圆) 另一种方法           ;
  161. ;;;输入: 三个给定的圆的圆心及半径                      ;
  162. ;;;输出: 符合条件的圆的集合(nil，一个或多个圆的集合)   ;
  163. ;;;注明: 此种作法在某些情况下不完全，还是以前面方法为准;
  164. ;;;----------------------------------------------------;
  165. (defun CIR:CCC_1 (c1 r1 c2 r2 c3 r3 / Ret C D1 D2 EPS LST R S1 S2)
  166.   (setq eps 1e-6)
  167.   (setq lst (mapcar 'cons (list c1 c2 c3) (list r1 r2 r3)))
  168.   (setq lst (MISC:ASort lst cdr))
  169.   (setq c1  (caar lst))
  170.   (setq c2  (caadr lst))
  171.   (setq c3  (caaddr lst))
  172.   (setq r1  (cdar lst))
  173.   (setq r2  (cdadr lst))
  174.   (setq r3  (cdaddr lst))
  175.   (foreach f (mapcar 'cons (list + + - -) (list + - + -))
  176.     (setq s1 (car f))
  177.     (setq s2 (cdr f))
  178.     (foreach p (CIR:PCC c1 c2 (s1 r2 r1) c3 (s2 r3 r1))
  179.       (setq c  (car p))
  180.       (setq r  (cadr p))
  181.       (setq d1 (distance c c2))
  182.       (setq d2 (distance c c3))
  183.       (cond
  184.         ( (equal (abs (s1 d1 r2)) (abs (s2 d2 r3)) eps)
  185.           (setq ret (cons (list c (- r r1)) ret))
  186.         )
  187.         ( (equal (abs ((MISC:RevSign s1) d1 r2))
  188.                  (abs ((MISC:RevSign s2) d2 r3))
  189.                  eps
  190.           )
  191.           (setq ret (cons (list c (+ r r1)) ret))
  192.         )
  193.       )
  194.     )
  195.   )
  196.   ret
  197. )

五、关于三点画圆的Per问题的解
在用三点画圆的时候，
Command: c CIRCLE Specify center point for circle or [3P/2P/Ttr (tan tan radius)]: 3p Specify first point on circle:
Specify second point on circle:
Specify third point on circle: per to  &#61663;注意此处的如果输入Per时候，代表圆心在指定的线段上面。

  1. ;;;----------------------------------------------------;
  2. ;;;点点Per画圆                                         ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:PPT (Pt1 Pt2 PtM PtN / eps mid pt3 cen)
  5.   (setq eps 1e-8)
  6.   (setq Mid (Geo:MidPoint Pt1 Pt2))
  7.   (setq Pt3 (GEO:Rot90 Mid Pt1 Pt2))
  8.   (if (setq cen (inters Mid Pt3 PtM PtN nil))
  9.     (list (list cen (distance Cen Pt1)))
  10.     (if (LINE:Colinearity Mid PtM PtN)
  11.       (list (list Mid (distance Mid Pt1)))
  12.     )
  13.   )
  14. )


  1. ;;;----------------------------------------------------;
  2. ;;;点切线Per画圆                                       ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:PLT (Pt0 PtA PtB PtM PtN / eps ang Pt1)
  5.   (setq eps 1e-8)
  6.   (setq ang (angle PtM PtN))
  7.   (setq Pt1 (GEO:Mirror2D Pt0 PtM ang))
  8.   (if (equal pt1 pt0 eps)
  9.     (CIR:PLL Pt0 PtA PtB (GEO:Mirror2D PtA PtM ang) (GEO:Mirror2D PtB PtM ang))
  10.     (CIR:PPL Pt0 Pt1 PtA PtB)
  11.   )
  12. )


  1. ;;;----------------------------------------------------;
  2. ;;;点切圆Per画圆                                       ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:PCT (Pt0 Cen Rad PM PN / eps AN C0 C1 C2 D1 D2 D3 D4 IsA IsB L PT PT1 S C R R1 R2)
  5.   (setq eps 1e-8)
  6.   (setq Pt1 (GEO:Mirror3D Pt0 PM PN))
  7.   (setq C0  (GEO:Mirror3D Cen PM PN))
  8.   (setq IsA (equal Pt0 Pt1 eps))
  9.   (setq IsB (equal Cen C0 eps))
  10.   (if (and IsA IsB)
  11.     (progn
  12.       (setq d1 (distance Pt0 Cen))
  13.       (if (equal d1 0 eps)
  14.         (setq an (angle PM PN))
  15.         (setq an (angle Pt0 cen))
  16.       )
  17.       (setq R1 (* (+ d1 rad) 0.5))
  18.       (setq R2 (* (- d1 rad) 0.5))
  19.       (setq C1 (polar Pt0 an R1))
  20.       (setq C2 (polar Pt0 an R2))
  21.       (list (list C1 R1) (list C2 (abs R2)))
  22.     )
  23.     (if IsA
  24.       (progn
  25.         (and (equal Pt0 PM eps) (setq Pt PM PM PN PN Pt))
  26.         (setq an (angle PM Pt0))
  27.         (setq Pt (trans (mapcar '- Cen Pt0) 0 (mapcar '- Pt0 pM)))
  28.         (setq d1 (car pt))
  29.         (setq d2 (caddr Pt))
  30.         (setq d3 (- d2 rad))
  31.         (setq d4 (+ d2 rad))
  32.         (setq L  (+ (* d1 d1) (* d3 d4)))
  33.         (foreach d (list (+ d3 d3) (+ d4 d4))
  34.           (if (not (equal d 0 eps))
  35.             (setq r (/ L d)
  36.                   c (polar Pt0 an (/ L d))
  37.                   S (cons (list c (abs r)) S)
  38.             )
  39.           )
  40.         )
  41.         S
  42.       )
  43.       (CIR:PPC Pt0 Pt1 Cen Rad)
  44.     )
  45.   )
  46. )


  1. ;;;----------------------------------------------------;
  2. ;;;切线切线Per画圆                                     ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:LLT (PA PB PC PD PM PN / eps int p1 p2 an cen per ret)
  5.   (setq eps 1e-8)
  6.   (if (setq int (inters PA PB PC PD nil))
  7.     (progn
  8.       (setq an (* (+ (angle pa pb) (angle pc pd)) 0.5))
  9.       (foreach a (list an (+ an (* pi 0.5)))
  10.         (setq p1 (polar int a 100))
  11.         (if (setq cen (inters int p1 PM PN nil))
  12.           (setq Per (LINE:Perpendicular_Foot Cen PA PB)
  13.                 ret (cons (list cen (abs (car per))) ret)
  14.           )
  15.         )
  16.       )
  17.       ret
  18.     )
  19.     (progn
  20.       (setq P1  (GEO:Midpoint PA PC))
  21.       (setq P2  (polar p1 (angle Pa Pb) 100))
  22.       (setq Cen (inters P1 P2 PM PN nil))
  23.       (setq Per (LINE:Perpendicular_Foot Cen PA PB))
  24.       (setq ret (list (list cen (abs (car per)))))
  25.     )
  26.   )
  27. )


  1. ;;;----------------------------------------------------;
  2. ;;;切线切圆Per画圆                                     ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:LCT (PtA PtB Cen Rad PtM PtN / Pt1 Pt2)
  5.   (setq Pt1 (GEO:Mirror3d PtA PtM PtN))
  6.   (setq Pt2 (GEO:Mirror3d PtB PtM PtN))
  7.   (vl-remove-if-not
  8.     (function (lambda (x) (LINE:Colinearity (car x) PtM PtN)))        
  9.     (CIR:LLC PtA PtB Pt1 Pt2 Cen Rad)
  10.   )
  11. )

六、反演、位似、共轴、等幂等等相关程序。

  1. ;;;----------------------------------------------------;
  2. ;;;两个圆的位似中心 Internal,External Homothetic Center;
  3. ;;;也就是公切线的交点(当然也包括没有公切线时候的情况)  ;
  4. ;;;输入: 两个圆的圆心和半径                            ;
  5. ;;;输出: 第一个为内位似中心，第二个为外位似中心        ;
  6. ;;;----------------------------------------------------;
  7. (defun CIR:Homothetic_Center (c1 r1 c2 r2 /)
  8.   (if (equal r1 r2 1e-14)
  9.     (list (GEO:Midpoint c1 c2) '(1e400 1e400 0))        ;中点和无穷远点
  10.     (list (GEO:Scale c2 c1 (/ r1 (+ r1 r2)))            ;内位似中心
  11.           (GEO:Scale c2 c1 (/ r1 (- r1 r2)))                ;外位似中心
  12.     )
  13.   )
  14. )



  1. ;;;----------------------------------------------------;
  2. ;;;点的反演                                            ;
  3. ;;;输入: 圆心，半径和一点                              ;
  4. ;;;输出: nil或者反演点                                 ;
  5. ;;;----------------------------------------------------;
  6. (defun CIR:Inversion (c r p / d)
  7.   (setq d (distance c p))
  8.   (if (equal d 0 1e-8)
  9.     nil                                                        ;圆心处没有反演点
  10.     (polar c (angle c p) (/ (* r r) d))                        ;根据反演公式计算
  11.   )
  12. )

  14. ;;;----------------------------------------------------;
  15. ;;;直线对圆的反演                                      ;
  16. ;;;输入: 圆心，半径和一点                              ;
  17. ;;;输出: 一个用圆心和半径表示的圆或者直线本身          ;
  18. ;;;----------------------------------------------------;
  19. (defun CIR:Line_Inversion (Cen Rad P1 P2 / d p q c r)
  20.   (setq p (Line:Perpendicular_Foot Cen P1 P2))
  21.   (setq d (car p))
  22.   (setq p (cadr p))
  23.   (if (equal d 0.0 1e-8)
  24.     (list P1 P2)                                        ;经过圆心的直线是本身
  25.     (setq q (CIR:Inversion Cen Rad p)
  26.           c (GEO:Midpoint q Cen)
  27.           r (list c (distance c Cen))                   ;把直线反演成圆
  28.     )
  29.   )
  30. )


  33. ;;;----------------------------------------------------;
  34. ;;;圆对圆的反演                                        ;
  35. ;;;输入: 反演圆的圆心半径和被反演的圆的圆心，半径      ;
  36. ;;;输出: 一个用圆心和半径表示的圆或者一条直线的两个端点;
  37. ;;;----------------------------------------------------;
  38. (defun CIR:Circle_Inversion (C0 R0 C R / an P1 P2 PM)
  39.   (if (equal C0 C 1e-8)
  40.     (list C0 (* (/ R0 R) R0))
  41.     (progn
  42.       (setq an (angle C C0))
  43.       (setq p1 (CIR:Inversion C0 R0 (polar C an R)))
  44.       (setq p2 (CIR:Inversion C0 R0 (polar C an (- R))))
  45.       (if (and p1 p2)
  46.         (list (GEO:Midpoint  p1 p2) (* (distance p1 p2) 0.5))
  47.         (progn
  48.           (setq PM (GEO:Midpoint  C0 (CIR:Inversion C0 R0 C)))
  49.           (list PM (mapcar '+ PM (MAT:Rot90 (mapcar '- PM C0))))
  50.         )
  51.       )
  52.     )
  53.   )
  54. )

  56. ;;;----------------------------------------------------;
  57. ;;;等幂轴                                              ;
  58. ;;;输入: 给定的两个圆的圆心和半径                      ;
  59. ;;;输出: 这两个圆的等幂轴与它们的圆心连线的交点        ;
  60. ;;;----------------------------------------------------;
  61. (defun CIR:Radical_Axis (c1 r1 c2 r2 / l d)
  62.   (setq l (distance c1 c2))
  63.   (if (equal l 0 1e-8)
  64.     (setq d (if (> r1 r2) 1e400 -1e400))
  65.     (setq d (* 0.5 (+ L (/ (* (+ r1 r2) (- r1 r2)) L))))
  66.   )
  67.   (polar c1 (angle c1 c2) d)
  68. )

  70. ;;;----------------------------------------------------;
  71. ;;;线段(用系数表示)对圆的极点                          ;
  72. ;;;----------------------------------------------------;
  73. (defun CIR:Polar_Point (cen rad A B C / p d)
  74.   (setq p (Line:Perpendicular_Distance_1 Cen A B C))
  75.   (setq d (car p))
  76.   (setq p (cadr p))
  77.   (if (/= d 0)
  78.     (polar cen (angle cen p) (/ (* rad rad) (abs d)))
  79.   )
  80. )

  82. ;;;----------------------------------------------------;
  83. ;;;线段(用两点表示)对圆的极点                          ;
  84. ;;;----------------------------------------------------;
  85. (defun CIR:Polar_Point_1 (cen rad Pa Pb / p d)
  86.   (setq p (Line:Perpendicular_Foot Cen Pa Pb))
  87.   (setq d (car p))
  88.   (setq p (cadr p))
  89.   (if (/= d 0)
  90.     (polar cen (angle cen p) (/ (* rad rad) (abs d)))
  91.   )
  92. )


  1. ;;;----------------------------------------------------;
  2. ;;;等幂中心(三个圆形的等幂轴的交点)    Radical center, ;
  3. ;;;also called the power center of three circles       ;
  4. ;;;输入: 三个圆（用中心半径表示）                      ;
  5. ;;;输出: 这三个圆的等幂中心                            ;
  6. ;;;----------------------------------------------------;
  7. (defun CIR:Power_Center (c1 r1 c2 r2 c3 r3 / p1 p2 q1 q2 CC d k)
  8.   (setq P1 (CIR:Radical_Axis c1 r1 c2 r2))
  9.   (setq P2 (CIR:Radical_Axis c2 r2 c3 r3))
  10.   (if (and p1 p2)
  11.     (progn
  12.       (setq q1 (GEO:Rot90 p1 c1 c2))
  13.       (setq q2 (GEO:Rot90 p2 c2 c3))
  14.       (setq CC (inters p1 q1 p2 q2 nil))
  15.       (if CC
  16.         (progn
  17.           (setq d (distance CC C1))
  18.           (setq k (* (+ d r1) (- d r1)))
  19.           (list cc K)
  20.         )
  21.       )
  22.     )
  23.   )
  24. )

  1. ;;;----------------------------------------------------;
  2. ;;;阿波罗尼奥斯圆Apollonian circles                    ;
  3. ;;;----------------------------------------------------;
  4. (defun CIR:Apollonian_Circle (P1 P2 k / k k1 k2 d rt)
  5.   (if (and (> k 0) (/= k 1))
  6.     (setq k1 (* k k)
  7.           k2 (/ 1.0 (1- k1))
  8.           d  (distance p1 p2)
  9.           Rt (list (mapcar (function (lambda (i j) (* k2 (- (* k1 j) i)))) p1 p2)
  10.                    (abs (* d k k2))
  11.              )
  12.     )
  13.   )
  14. )

  16. ;;;----------------------------------------------------;
  17. ;;;共轴圆                                              ;
  18. ;;;----------------------------------------------------;
  19. (defun CIR:Coaxal_Circle (c1 r1 c2 r2 / P1 P2 d1 d2 RT)
  20.   (foreach HC (CIR:Homothetic_Center c1 r1 c2 r2)
  21.     (if (= (car HC) 1e400)
  22.       (setq P1 (Geo:MidPoint C1 C2)
  23.             P2 (polar P1 (+ (angle C1 C2) (* pi 0.5)) 1000)
  24.             RT (cons (list P1 P2) RT)
  25.       )
  26.       (setq p1 (polar C1 (angle HC C1) r1)
  27.             p2 (polar c2 (angle HC C2) (- r2))
  28.             d1 (distance HC p1)
  29.             d2 (distance HC p2)
  30.             RT (cons (list HC (sqrt (* d1 d2))) RT)
  31.       )
  32.     )
  33.   )
  34. )

  36. ;;;----------------------------------------------------;
  37. ;;;共轴圆的特殊情况（其中一个圆退化为一点）            ;
  38. ;;;----------------------------------------------------;
  39. (defun CIR:Radical_Axis_Point (C R P / l d)
  40.   (if (equal c p 1e-8)
  41.     nil
  42.     (progn
  43.       (setq l (distance c p))
  44.       (setq d (/ (+ (* r r) (* l l)) 2 l))
  45.       (polar c (angle c p) d)
  46.     )
  47.   )
  48. )


  1. ;;;----------------------------------------------------;
  2. ;;;卡斯蒂郎求解                                        ;
  3. ;;;Castillon's Problem                                 ;
  4. ;;;输入: 一给定圆（圆心半径表示）和不重合的三定点。    ;
  5. ;;;输出：圆上三点，使得三已知点分别通过这三点形成的边  ;
  6. ;;;----------------------------------------------------;
  7. (defun CIR:Castillon (Cen Rad pa pb pc / EPS INT1 INT2 L d1 d2 d3 LST P0 P1 P2 x0 y0 RET)
  8.   (defun Check (Func lst d eps)
  9.     (apply Func (mapcar (function (lambda (x) (equal x d eps))) lst))
  10.   )
  11.   (setq eps 1e-6)
  12.   (setq d1 (abs (- rad (distance pa cen))))
  13.   (setq d2 (abs (- rad (distance pb cen))))
  14.   (setq d3 (abs (- rad (distance pc cen))))
  15.   (if (Check 'or (list d1 d2 d3) 0 eps)
  16.     (if (Check 'and (list d1 d2 d3) 0 eps)
  17.       (list (list pa pb pc))
  18.       (setq l   (vl-sort-i (list d1 d2 d3) '<)
  19.             lst (list pa pb pc)
  20.             pa  (nth (car l) lst)
  21.             pb  (nth (cadr l) lst)
  22.             pc  (nth (caddr l) lst)
  23.             p0  Pa
  24.             p1  (CIR:Intersecting_Chords P0 pb Cen Rad)
  25.             p2  (CIR:Intersecting_Chords P1 PC Cen Rad)
  26.             ret (cons (list p0 p1 p2) ret)
  27.             p1  (CIR:Intersecting_Chords P0 pc Cen Rad)
  28.             p2  (CIR:Intersecting_Chords P1 pb Cen Rad)
  29.             ret (cons (list P0 p1 p2) ret)
  30.       )
  31.     )
  32.     (progn
  33.       (foreach an (list 1 2 3)
  34.         (setq x0 (+ (* rad (cos an)) (car Cen)))
  35.         (setq y0 (+ (* rad (sin an)) (cadr Cen)))
  36.         (setq p0 (list x0 y0 0))
  37.         (setq p1 p0)
  38.         (foreach p (list pa pb pc)
  39.           (setq P2 (CIR:Intersecting_Chords P1 P cen rad))
  40.           (setq p1 p2)
  41.         )
  42.         (setq lst (cons (cons p0 p2) lst))
  43.       )
  44.       ;;到这步得到三个二重映射点。
  45.       (setq int1 (inters (caar lst) (cdadr lst) (cdar lst) (caadr lst) nil))
  46.       (setq int2 (inters (caar lst) (cdaddr lst) (cdar lst) (caaddr lst) nil))
  47.       (if (and int1 int2)
  48.         (foreach q (CIR:Circle_Inters_Line cen rad int1 int2)
  49.           (setq l (list q))
  50.           (setq p1 q)
  51.           (foreach p (list pa pb)
  52.             (setq p2 (CIR:Intersecting_Chords p1 p cen rad))
  53.             (setq l (cons p2 l))
  54.             (setq p1 p2)
  55.           )
  56.           (setq ret (cons (reverse l) ret))
  57.         )
  58.       )
  59.     )
  60.   )
  61. )

七、一些测试样例：
  1. ;|----------------------------------------------------;
  2. ;;;以下样例仅供测试。                                  ;
  3. ;;;----------------------------------------------------;

  5. ;;;----------------------------------------------------;
  6. ;;;A sample for Apollonian circles                     ;
  7. ;;;阿波罗尼斯圆的测试样例                              ;
  8. ;;;----------------------------------------------------;
  9. (defun c:cac (/ p1 p2 k rt)
  10.   (initget 1)
  11.   (setq p1 (getpoint "\n点1:"))
  12.   (initget 2)
  13.   (setq p2 (getpoint p1 "\n点2:"))
  14.   (initget 7)
  15.   (setq k  (getreal "\n比例:"))
  16.   (Ent:Make_Line p1 P2)
  17.   (setq rt (CIR:Apollonian_Circle P1 P2 k))
  18.   (and rt (apply 'Ent:Make_Circle rt))
  19. )

  21. ;;;----------------------------------------------------;
  22. ;;;A sample for CIR:coaxl_Circle                       ;
  23. ;;;共轴圆的测试样例                                    ;
  24. ;;;----------------------------------------------------;
  25. (defun C:CXC (/ sel d1 d2 c1 c2 r1 r1 rt)
  26.   (setq sel (ssget '((0 . "CIRCLE,ARC"))))
  27.   (if (and sel (>= (sslength sel) 2))
  28.     (progn
  29.       (setq d1 (entget (ssname sel 0)))
  30.       (setq d2 (entget (ssname sel 1)))
  31.       (setq c1 (cdr (assoc 10 d1)))
  32.       (setq c2 (cdr (assoc 10 d2)))
  33.       (setq r1 (cdr (assoc 40 d1)))
  34.       (setq r2 (cdr (assoc 40 d2)))
  35.       (setq rt (CIR:Coaxal_Circle c1 r1 c2 r2))
  36.       (foreach c rt
  37.         (if (numberp (cadr c))
  38.           (apply 'Ent:Make_Circle c)
  39.           (apply 'Ent:Make_Line c)
  40.         )
  41.       )
  42.     )
  43.   )
  44. )


  47. ;;;----------------------------------------------------;
  48. ;;;A sample for CIR:Radical_Axis_Point                 ;
  49. ;;;共轴圆特例的测试样                                  ;
  50. ;;;----------------------------------------------------;
  51. (defun c:rax1(/ e p d r c ret)
  52.   (setq e (car (entsel "\n圆1:")))
  53.   (setq p (getpoint "\n点:"))
  54.   (if (and e p)
  55.     (progn
  56.       (setq d (entget e))
  57.       (setq r (cdr (assoc 40 d))
  58.             c (cdr (assoc 10 d))
  59.       )
  60.       (Ent:Make_Point p)
  61.       (setq ret (CIR:Radical_Axis_Point C R p))
  62.       (and ret (Ent:Make_Point ret))
  63.     )
  64.   )
  65. )

  67. ;;;A sample for Castillon's problem
  68. (defun C:Castillon(/ ss pa pb pc ent dxf rad cen ret)
  69.   (setq ss (ssget ":S" '((0 . "CIRCLE,ARC"))))
  70.   (initget 1)
  71.   (setq pa (getpoint "\n点1:"))
  72.   (initget 2)
  73.   (setq pb (getpoint "\n点2:"))
  74.   (initget 3)
  75.   (setq pc (getpoint "\n点3:"))
  76.   (if ss
  77.     (progn
  78.       (setq ent (ssname ss 0))
  79.       (setq dxf (entget ent))
  80.       (setq rad (cdr (assoc 40 dxf)))
  81.       (setq cen (cdr (assoc 10 dxf)))
  82.       (mapcar 'Ent:Make_Point (list pa pb pc))
  83.       (setq ret (CIR:Castillon Cen Rad pa pb pc))
  84.       (foreach p ret
  85.         (apply 'Ent:Make_Triangle p)
  86.       )
  87.     )
  88.   )
  89. )

  91. ;;;测试点点Per画圆
  92. (defun C:PPT (/ s1 p1 p2 dxf pta ptb ret)
  93.   (prompt "\n选取线段: ")
  94.   (setq s1 (ssget ":S" '((0 . "LINE"))))
  95.   (initget 1)
  96.   (setq p1 (getpoint "\n点1:"))
  97.   (initget 1)
  98.   (setq p2 (getpoint "\n点1:"))
  99.   (if (and s1 p1 P2)
  100.     (progn
  101.       (setq dxf (entget (ssname s1 0)))
  102.       (setq ptA (cdr (assoc 10 dxf)))
  103.       (setq ptB (cdr (assoc 11 dxf)))
  104.       (grdraw p1 p2 1)
  105.       (setq ret (CIR:PPT P1 P2 PtA PtB))
  106.       (foreach p Ret
  107.         (apply 'ENt:Make_circle p)
  108.       )
  109.     )
  110.   )
  111. )



  115. ;;;测试点点Per画圆
  116. (defun C:PLT (/ sel Pt0 d1 d2 PtA PtB PtC PtD Ret)
  117.   (prompt "\n选取线段: ")
  118.   (setq sel (ssget '((0 . "LINE"))))
  119.   (initget 1)
  120.   (setq Pt0 (getpoint "\n点1:"))
  121.   (if (and sel Pt0 (>= (sslength sel) 2))
  122.     (progn
  123.       (setq d1  (entget (ssname sel 0)))
  124.       (setq d2  (entget (ssname sel 1)))
  125.       (setq ptA (cdr (assoc 10 d1)))
  126.       (setq ptB (cdr (assoc 11 d1)))
  127.       (setq ptC (cdr (assoc 10 d2)))
  128.       (setq ptD (cdr (assoc 11 d2)))
  129.       (setq ret (CIR:PLT Pt0 PtA PtB PtC PtD))
  130.       (foreach p Ret
  131.         (apply 'ENt:Make_circle p)
  132.       )
  133.     )
  134.   )
  135. )
  136. (defun c:LCC(/ s1 s2 d1 d2 d3 pa pb c1 r1 c2 r2 ret)
  137.   (prompt "\n选线: ")
  138.   (setq s1 (ssget "_+.:E:S:L" '((0 . "LINE"))))
  139.   (prompt "\n选圆: ")
  140.   (setq s2 (ssget '((0 . "ARC,CIRCLE"))))
  141.   (if (and s1 s2 (>= (sslength s2) 2))
  142.     (progn
  143.       (setq d1 (entget (ssname s1 0)))
  144.       (setq d2 (entget (ssname s2 0)))
  145.       (setq d3 (entget (ssname s2 1)))
  146.       (setq pA (cdr (assoc 10 d1)))
  147.       (setq pB (cdr (assoc 11 d1)))
  148.       (setq C1 (cdr (assoc 10 d2)))
  149.       (setq R1 (cdr (assoc 40 d2)))
  150.       (setq C2 (cdr (assoc 10 d3)))
  151.       (setq R2 (cdr (assoc 40 d3)))
  152.       (command "undo" "be")
  153.       (setq ReT (CIR:LCC Pa Pb C1 R1 C2 R2))
  154.       (foreach p ReT
  155.         (apply 'ENt:Make_circle p)
  156.       )
  157.       (command "undo" "e")
  158.     )
  159.   )
  160.   (princ)
  161. )

  163. ;;;测试点点Per画圆
  164. (defun C:LLT (/ sel Pt0 d1 d2 PtA PtB PtC PtD Ret)
  165.   (prompt "\n选取线段: ")
  166.   (setq sel (ssget '((0 . "LINE"))))
  167.   (if (and sel (>= (sslength sel) 3))
  168.     (progn
  169.       (setq d1 (entget (ssname sel 0)))
  170.       (setq d2 (entget (ssname sel 1)))
  171.       (setq d3 (entget (ssname sel 2)))
  172.       (setq pA (cdr (assoc 10 d1)))
  173.       (setq pB (cdr (assoc 11 d1)))
  174.       (setq pC (cdr (assoc 10 d2)))
  175.       (setq pD (cdr (assoc 11 d2)))
  176.       (setq pM (cdr (assoc 10 d3)))
  177.       (setq pN (cdr (assoc 11 d3)))
  178.       (setq RT (CIR:LLT PA PB PC PD PM PN))
  179.       (foreach p RT
  180.         (apply 'ENt:Make_circle p)
  181.       )
  182.     )
  183.   )
  184. )


  187. ;;;测试切线切圆Per画圆
  188. (defun C:PCT (/ ss1 ss2 pt0 dx1 dx2 ptM ptN Cen Rad Ret)
  189.   (prompt "\n选线: ")
  190.   (setq ss1 (ssget "_+.:E:S:L" '((0 . "LINE"))))
  191.   (prompt "\n选圆: ")
  192.   (setq ss2 (ssget "_+.:E:S:L" '((0 . "ARC,CIRCLE"))))
  193.   (initget 1)
  194.   (setq Pt0 (getpoint "\n选取点:"))
  195.   (if (and ss1 ss2)
  196.     (progn
  197.       (setq dx1 (entget (ssname ss1 0)))
  198.       (setq dx2 (entget (ssname ss2 0)))
  199.       (setq ptM (cdr (assoc 10 dx1)))
  200.       (setq ptN (cdr (assoc 11 dx1)))
  201.       (setq cen (cdr (assoc 10 dx2)))
  202.       (setq rad (cdr (assoc 40 dx2)))
  203.       (Ent:Make_Point Pt0)
  204.       (setq Ret (CIR:PCT Pt0 Cen Rad PtM PtN))
  205.       (foreach p Ret
  206.         (apply 'ENt:Make_circle p)
  207.       )
  208.     )
  209.   )
  210. )

  212. ;;;测试切线切圆Per画圆
  213. (defun C:LCT (/ s1 s2 d1 d2 d3 pa pb pc pd c0 r0 ret)
  214.   (prompt "\n选线: ")
  215.   (setq s1 (ssget  '((0 . "LINE"))))
  216.   (prompt "\n选圆: ")
  217.   (setq s2 (ssget "_+.:E:S:L" '((0 . "ARC,CIRCLE"))))
  218.   (if (and s1 s2 (>= (sslength s1) 2))
  219.     (progn
  220.       (setq d1 (entget (ssname s1 0)))
  221.       (setq d2 (entget (ssname s1 1)))
  222.       (setq d3 (entget (ssname s2 0)))
  223.       (setq pA (cdr (assoc 10 d1)))
  224.       (setq pB (cdr (assoc 11 d1)))
  225.       (setq pC (cdr (assoc 10 d2)))
  226.       (setq pD (cdr (assoc 11 d2)))
  227.       (setq c0 (cdr (assoc 10 d3)))
  228.       (setq r0 (cdr (assoc 40 d3)))
  229.       (command "undo" "be")
  230.       (setq ret (CIR:LCT Pa Pb C0 R0 Pc Pd))
  231.       (foreach p ret
  232.         (apply 'ENt:Make_circle p)
  233.       )
  234.       (command "undo" "e")
  235.     )
  236.   )
  237.   (princ)
  238. )
  239. ;;;测试切线切圆Per画圆
  240. (defun C:LLC (/ s1 s2 d1 d2 d3 pa pb pc pd c0 r0 ret)
  241.   (prompt "\n选线: ")
  242.   (setq s1 (ssget  '((0 . "LINE"))))
  243.   (prompt "\n选圆: ")
  244.   (setq s2 (ssget "_+.:E:S:L" '((0 . "ARC,CIRCLE"))))
  245.   (if (and s1 s2 (>= (sslength s1) 2))
  246.     (progn
  247.       (setq d1 (entget (ssname s1 0)))
  248.       (setq d2 (entget (ssname s1 1)))
  249.       (setq d3 (entget (ssname s2 0)))
  250.       (setq pA (cdr (assoc 10 d1)))
  251.       (setq pB (cdr (assoc 11 d1)))
  252.       (setq pC (cdr (assoc 10 d2)))
  253.       (setq pD (cdr (assoc 11 d2)))
  254.       (setq c0 (cdr (assoc 10 d3)))
  255.       (setq r0 (cdr (assoc 40 d3)))
  256.       (command "undo" "be")
  257.       (setq ret (CIR:LLC PA PB PC PD C0 R0))
  258.       (foreach p ret
  259.         (apply 'ENt:Make_circle p)
  260.       )
  261.       (command "undo" "e")
  262.     )
  263.   )
  264.   (princ)
  265. )

  267. ;;; A sample for CIR:Circle_Inters_Line
  268. ;;; 线圆求交示例
  269. (defun C:CIL (/ s1 s2 dx1 dx2 pta ptb cen rad ret)
  270.   (prompt "\n选取线段: ")
  271.   (setq s1 (ssget ":S" '((0 . "LINE"))))
  272.   (prompt "\n选取圆: ")
  273.   (setq s2 (ssget ":S" '((0 . "CIRCLE,ARC"))))
  274.   (if (and s1 s2)
  275.     (progn
  276.       (setq dx1 (entget (ssname s1 0)))
  277.       (setq dx2 (entget (ssname s2 0)))
  278.       (setq ptA (cdr (assoc 10 dx1)))
  279.       (setq ptB (cdr (assoc 11 dx1)))
  280.       (setq cen (cdr (assoc 10 dx2)))
  281.       (setq rad (cdr (assoc 40 dx2)))
  282.       (setq ret (CIR:Circle_Inters_Line cen rad PtA PtB))
  283.       (foreach p Ret
  284.         (Ent:Make_Point p)
  285.       )
  286.     )
  287.   )
  288. )

  290. ;;; A sample for CIR:LLR
  291. ;;; CIR:LLR样例
  292. (defun c:LLR (/ sel rad en1 en2 dx1 dx2 pta ptb ptc ptd ret)
  293.   (setq sel (ssget '((0 . "LINE"))))
  294.   (initget 1)
  295.   (setq rad (getdist "\n半径:"))
  296.   (if (and sel (>= (sslength sel) 2))
  297.     (progn
  298.       (setq en1 (ssname sel 0))
  299.       (setq en2 (ssname sel 1))
  300.       (setq dx1 (entget en1))
  301.       (setq dx2 (entget en2))
  302.       (setq PtA (cdr (assoc 10 d1)))
  303.       (setq PtB (cdr (assoc 11 d1)))
  304.       (setq PtC (cdr (assoc 10 d2)))
  305.       (setq PtD (cdr (assoc 11 d2)))
  306.       (if (setq ret (CIR:LLR PtA PtB PtC PtD Rad))
  307.         (foreach p ret
  308.           (apply 'Ent:Make_Circle p)
  309.         )
  310.       )
  311.     )
  312.   )
  313. )

  315. ;;; A sample for CIR:PLR
  316. ;;; CIR:PLR样例
  317. (defun c:PLR (/ pt0 sel rad ent dxf pta ptb ret)
  318.   (initget 1)
  319.   (setq pt0 (getpoint "\n1:"))
  320.   (initget 1)
  321.   (setq sel (ssget ":S" '((0 . "LINE"))))
  322.   (initget 7)
  323.   (setq rad (getdist "\n半径:"))
  324.   (if (and sel pt0 rad)
  325.     (progn
  326.       (setq ent (ssname sel 0))
  327.       (setq dxf (entget ent))
  328.       (setq PtA (cdr (assoc 10 dxf)))
  329.       (setq PtB (cdr (assoc 11 dxf)))
  330.       (if (setq ret (CIR:PLR Pt0 PtA PtB Rad))
  331.         (foreach p ret
  332.           (apply 'Ent:Make_Circle p)
  333.         )
  334.       )
  335.     )
  336.   )
  337. )


  340. ;;; A sample for CIR:PPR
  341. ;;; CIR:PPR样例
  342. (defun c:PPR (/ pta ptb rad ret)
  343.   (initget 1)
  344.   (setq pta (getpoint "\n1:"))
  345.   (initget 1)
  346.   (setq ptb (getpoint "\n2:"))
  347.   (initget 7)
  348.   (setq rad (getdist "\n半径:"))
  349.   (if (setq ret (CIR:PPR pta ptb rad))
  350.     (foreach p ret
  351.       (apply 'Ent:Make_Circle p)
  352.     )
  353.   )
  354. )

  356. ;;; A sample for CIR:LCR
  357. ;;; CIR:LCR样例
  358. (defun c:LCR (/ s1 s2 r1 d1 d2 pa pb c0 r0)
  359.   (prompt "\n选择直线")
  360.   (setq s1 (ssget ":S" '((0 . "LINE"))))
  361.   (prompt "\n选择圆")
  362.   (setq s2 (ssget ":S" '((0 . "CIRCLE,ARC"))))
  363.   (initget 7)
  364.   (setq r1 (getdist "\n半径:"))
  365.   (if (and s1 s2 r1)
  366.     (progn
  367.       (setq d1 (entget (ssname s1 0)))
  368.       (setq d2 (entget (ssname s2 0)))
  369.       (setq pa (cdr (assoc 10 d1)))
  370.       (setq pb (cdr (assoc 11 d1)))
  371.       (setq c0 (cdr (assoc 10 d2)))
  372.       (setq r0 (cdr (assoc 40 d2)))
  373.       (foreach c (CIR:LCR PA PB C0 R0 R1)
  374.         (apply 'Ent:Make_Circle c)
  375.       )
  376.     )
  377.   )
  378. )

  380. ;;; A sample for CIR:CCR
  381. ;;; CIR:CCR样例
  382. (defun C:CCR (/ s1 r0 d1 d2 c1 c2 r1 r2)
  383.   (prompt "\n选择两个圆")
  384.   (setq s1 (ssget  '((0 . "CIRCLE,ARC"))))
  385.   (initget 7)
  386.   (setq r0 (getdist "\n半径:"))
  387.   (if (and s1 (>= (sslength s1) 2))
  388.     (progn
  389.       (setq d1 (entget (ssname s1 0)))
  390.       (setq d2 (entget (ssname s1 1)))
  391.       (setq c1 (cdr (assoc 10 d1)))
  392.       (setq r1 (cdr (assoc 40 d1)))
  393.       (setq c2 (cdr (assoc 10 d2)))
  394.       (setq r2 (cdr (assoc 40 d2)))
  395.       (foreach c (CIR:CCR C1 R1 C2 R2 R0)
  396.         (apply 'Ent:Make_Circle c)
  397.       )
  398.     )
  399.   )
  400. )

  402. ;;; A sample for CIR:PCR
  403. ;;; CIR:PCR样例
  404. (defun c:PCR (/ p0 ss r1 dxf c0 r0)
  405.   (initget 1)
  406.   (setq p0 (getpoint "\n点:"))
  407.   (setq p0 (trans p0 1 0))
  408.   (prompt "\n选择圆")
  409.   (setq ss (ssget ":S" '((0 . "CIRCLE,ARC"))))
  410.   (initget 7)
  411.   (setq r1 (getdist "\n半径:"))
  412.   (if (and ss p0 r1)
  413.     (progn
  414.       (setq dxf (entget (ssname ss 0)))
  415.       (setq c0  (cdr (assoc 10 dxf)))
  416.       (setq r0  (cdr (assoc 40 dxf)))
  417.       (Ent:Make_Point P0)
  418.       (foreach c (CIR:PCR P0 C0 R0 R1)
  419.         (apply 'Ent:Make_Circle c)
  420.       )
  421.     )
  422.   )
  423. )


  426. ;;;Sample
  427. (defun C:CIV (/ pnt cir dxf rad cen)
  428.   (initget 1)
  429.   (setq pnt (getpoint "\n请选取一点:"))
  430.   (if (setq cir (car (entsel "\n选取圆或者弧:")))
  431.     (progn
  432.       (setq dxf (entget cir))
  433.       (setq rad (cdr (assoc 40 dxf)))
  434.       (setq cen (cdr (assoc 10 dxf)))
  435.       (Ent:Make_Point pnt)
  436.       (if (setq pt (CIR:Inversion cen rad pnt))
  437.         (Ent:Make_Point pt)
  438.       )
  439.       (foreach p (CIR:Point_Tangent cen rad pnt)
  440.         (Ent:Make_Point p)
  441.       )
  442.     )
  443.   )
  444. )
  445. ;;;Sample
  446. (defun C:CLI(/ ent p1 p2 dxf rad cen ret)
  447.   (setq ent (car (entsel)))
  448.   (setq p1  (getpoint "\nP1:"))
  449.   (setq p2  (getpoint "\nP2:"))
  450.   (if (and ent p1 p2)
  451.     (progn
  452.       (setq dxf (entget ent))
  453.       (setq rad (cdr (assoc 40 dxf)))
  454.       (setq cen (cdr (assoc 10 dxf)))
  455.       (setq ret (CIR:Line_Inversion cen rad p1 p2))
  456.       (Ent:Make_Line p1 p2)
  457.       (apply 'Ent:Make_Circle ret)
  458.     )
  459.   )
  460. )

  462. ;;;Sample圆对圆的反演
  463. (defun C:CCI (/ e0 e1 d0 d1 r0 r1 c0 c1 ret)
  464.   (setq e0 (car (entsel "\n选择圆1:")))
  465.   (setq e1 (car (entsel "\n选择圆2:")))
  466.   (if (and e0 e1)
  467.     (progn
  468.       (setq d0 (entget e0))
  469.       (setq d1 (entget e1))
  470.       (setq r0 (cdr (assoc 40 d0)))
  471.       (setq c0 (cdr (assoc 10 d0)))
  472.       (setq r1 (cdr (assoc 40 d1)))
  473.       (setq c1 (cdr (assoc 10 d1)))
  474.       (setq ret (CIR:Circle_Inversion C0 R0 C1 R1))
  475.       (if (numberp (cadr ret))
  476.         (apply 'Ent:Make_Circle ret)
  477.         (apply 'Ent:Make_Line ret)
  478.       )
  479.     )
  480.   )
  481. )

  483. ;;;A sample for CIR:Circle_Inters_Circle
  484. ;;;圆圆求交点
  485. ;;;测试位似中心
  486. (defun C:HC (/ ent1 ent2 dxf1 dxf2 rad1 rad2 cen1 cen2)
  487.   (setq ent1 (car (entsel "\n选取圆1:")))
  488.   (setq ent2 (car (entsel "\n选取圆2:")))
  489.   ;(setq pt (getpoint "\n点取:"))
  490.   (if (and ent1 ent2)
  491.     (progn
  492.       (setq dxf1 (entget ent1))
  493.       (setq dxf2 (entget ent2))
  494.       (setq rad1 (cdr (assoc 40 dxf1)))
  495.       (setq rad2 (cdr (assoc 40 dxf2)))
  496.       (setq cen1 (cdr (assoc 10 dxf1)))
  497.       (setq cen2 (cdr (assoc 10 dxf2)))
  498.       (setq i 1)
  499.       ;(Ent:Make_Point pt)
  500.       (setq ret1 (CIR:Radical_Axis cen1 rad1 cen2 rad2))
  501.       (setq ret2 (CIR:Common_Tangent cen1 rad1 cen2 rad2))
  502.       (setq ret3 (CIR:Homothetic_Center cen1 rad1 cen2 rad2))
  503.       (setq ret4 (CIR:Circle_Inters_Circle cen1 rad1 cen2 rad2))
  504.       (setq ret5 (CIR:Circle_Inversion cen1 rad1 cen2 rad2))
  505.       (if (numberp (cadr ret5))
  506.         (apply 'Ent:Make_Circle ret5)
  507.         (apply 'Ent:Make_Line ret5)
  508.       )
  509.       (and ret1 (Ent:Make_point ret1))
  510.       (and ret3 (mapcar 'Ent:make_Point ret3))
  511.       (and ret4 (mapcar 'Ent:make_Point ret4))
  512.       (foreach p ret2
  513.         (apply 'Ent:make_line p)
  514.       )
  515.     )
  516.   )
  517. )
  518. ;;;测试程序
  519. (defun C:PPP (/ pa pb pc pd ret)
  520.   (initget 1)
  521.   (setq pa (getpoint "\n输入第一点:"))
  522.   (initget 1)
  523.   (setq pb (getpoint "\n输入第二点:"))
  524.   (initget 1)
  525.   (setq pc (getpoint "\n输入第三点:"))
  526.   (initget 1)
  527.   (setq pd (getpoint "\n输入映射点:"))

  529.   (Ent:Make_Poly (list pa pb pc))
  530.   (setq InC (Tri:InCenter pa pb pc))
  531.   (setq CCC (CIR:PPP pa pb pc))
  532.   (setq Pd1 (Tri:Isogonal-Conjugate-Point Pd Pa Pb Pc))
  533.   (setq Otc (tri:OrthoCenter pa pb pc))
  534.   (setq 9pc (Tri:9P_Circle pa pb pc))
  535.   (mapcar 'Ent:Make_Point (list pa pb pc pd Pd1 Otc))
  536.   (foreach n (list Inc CCC 9pc)
  537.     (apply 'Ent:Make_Circle n)
  538.   )
  539.   (princ)
  540. )

  542. ;;;测试点点线
  543. (defun c:PPL(/ p1 p2 ln dxf pa pb ret)
  544.   (setq p1 (getpoint "\n第一点:"))
  545.   (setq p2 (getpoint "\n第二点:"))
  546.   (setq ln (car (entsel "\n请选择线段")))
  547.   (if (and p1 p2 ln)
  548.     (progn
  549.       (setq dxf (entget ln))
  550.       (setq ptA (cdr (assoc 10 dxf)))
  551.       (setq ptb (cdr (assoc 11 dxf)))
  552.       (setq ret (CIR:PPL p1 p2 PtA PtB))
  553.       (Ent:Make_Line p1 p2)
  554.       (if (VL-CONSP ret)
  555.         (foreach n ret
  556.           (and n (apply 'Ent:Make_Circle n))
  557.         )
  558.       )
  559.     )
  560.   )
  561. )

  563. ;;;测试点线线圆
  564. (defun C:PLL(/ pt l1 l2 d1 d2 pa pb pc pd)
  565.   (setq pt (getpoint "\n选择点:"))
  566.   (setq l1 (car (entsel "\n请选择线段")))
  567.   (setq l2 (car (entsel "\n请选择线段")))
  568.   (if (and pt l1 l2)
  569.     (progn
  570.       (setq d1 (entget l1))
  571.       (setq d2 (entget l2))
  572.       (setq pa (cdr (assoc 10 d1)))
  573.       (setq pb (cdr (assoc 11 d1)))
  574.       (setq pc (cdr (assoc 10 d2)))
  575.       (setq pd (cdr (assoc 11 d2)))
  576.       (Ent:Make_Point pt)        
  577.       (setq ret (CIR:PLL pt pa pb Pc Pd))
  578.       (if (VL-CONSP ret)
  579.         (foreach n ret
  580.           (and n (Ent:Make_Circle (car n) (cadr n)))
  581.         )
  582.       )
  583.     )
  584.   )
  585. )

  587. ;;;测试点切切圆
  588. (defun C:PCC(/ pt e1 e2 d1 d2 r1 r2 rt)
  589.   (initget 1)
  590.   (setq pt (getPoint "\n点1："))
  591.   (setq e1 (ssget ":S" '((0 . "CIRCLE,ARC"))))
  592.   (setq e2 (ssget ":S" '((0 . "CIRCLE,ARC"))))
  593.   (if (and pt e1 e2)
  594.     (progn
  595.       (setq d1 (entget (ssname e1 0)))
  596.       (setq d2 (entget (ssname e2 0)))
  597.       (setq r1 (cdr (assoc 40 d1)))
  598.       (setq r2 (cdr (assoc 40 d2)))
  599.       (setq c1 (cdr (assoc 10 d1)))
  600.       (setq c2 (cdr (assoc 10 d2)))
  601.       (setq rt (CIR:PCC pt c1 r1 c2 r2))
  602.       (Ent:Make_Point pt)
  603.       (if rt
  604.         (foreach n rt
  605.           (apply 'Ent:Make_Circle n)
  606.         )
  607.       )
  608.     )
  609.   )
  610. )

  612. ;;;测试点点线圆
  613. (defun C:PPC(/ p1 p2 en dxf rad cen ret)
  614.   (initget 1)
  615.   (setq p1 (getPoint "\n点1："))
  616.   (initget 1)
  617.   (setq p2 (getPoint "\n点2："))
  618.   (setq en (car (entsel "\n选一个圆：")))
  619.   (if (and p1 p2 en)
  620.     (progn
  621.       (setq dxf (entget en))
  622.       (setq rad (cdr (assoc 40 dxf)))
  623.       (setq cen (cdr (assoc 10 dxf)))
  624.       (setq ret (CIR:PPC p1 p2 cen rad))
  625.       (Ent:Make_Point p1)
  626.       (Ent:Make_Point p2)
  627.       (if ret
  628.         (foreach n ret
  629.           (apply 'Ent:Make_Circle n)
  630.         )
  631.       )
  632.     )
  633.   )
  634. )

  636. ;;;测试与三圆都相切的圆(即阿波罗尼斯圆)函数
  637. (defun c:rax (/ e1 e2 e3 d1 d2 d3 c1 c2 c3 r1 r2 r3)
  638.   (setq e1 (car (entsel "\n圆1:")))
  639.   (setq e2 (car (entsel "\n圆2:")))
  640.   (setq e3 (car (entsel "\n圆3:")))
  641.   (if (and e1 e2 e3)
  642.     (progn
  643.       (setq d1  (entget e1))
  644.       (setq d2  (entget e2))
  645.       (setq d3  (entget e3))
  646.       (setq r1  (cdr (assoc 40 d1))
  647.             r2  (cdr (assoc 40 d2))
  648.             r3  (cdr (assoc 40 d3))
  649.             c1  (cdr (assoc 10 d1))
  650.             c2  (cdr (assoc 10 d2))
  651.             c3  (cdr (assoc 10 d3))
  652.       )
  653.       (command "undo" "be")
  654.       (vla-put-color (vlax-ename->vla-object e1) 1)
  655.       (vla-put-color (vlax-ename->vla-object e2) 2)
  656.       (vla-put-color (vlax-ename->vla-object e3) 3)
  657.       (MiSC:test
  658.         100
  659.         '((CIR:CCC c1 r1 c2 r2 c3 r3)
  660.           (CIR:CCC_1 c1 r1 c2 r2 c3 r3)
  661.         )
  662.       )
  663.       (foreach p (CIR:CCC c1 r1 c2 r2 c3 r3)
  664.         (and p (apply 'Ent:Make_Circle p))
  665.       )
  666.       (command "undo" "e")
  667.       (princ)
  668.     )
  669.   )
  670. )

  672. ;;;测试点切切圆
  673. (defun C:PLC(/ pt e1 e2 d1 d2 r1 r2 ret)
  674.   (initget 1)
  675.   (setq pt0 (getPoint "\nPoint:"))
  676.   (princ "\nSelect a line:")
  677.   (setq en1 (ssget ":S" '((0 . "LINE"))))
  678.   (princ "\nSelect a circle:")
  679.   (setq en2 (ssget ":S" '((0 . "CIRCLE"))))
  680.   (if (and pt0 en1 en2)
  681.     (progn
  682.       (setq d1  (entget (ssname en1 0)))
  683.       (setq d2  (entget (ssname en2 0)))
  684.       (setq ptA (cdr (assoc 10 d1)))
  685.       (setq ptB (cdr (assoc 11 d1)))
  686.       (setq rad (cdr (assoc 40 d2)))
  687.       (setq cen (cdr (assoc 10 d2)))
  688.       (Ent:Make_Point pt0)
  689.       (setq ret (CIR:PLC pt0 ptA ptB Cen Rad))
  690.       (foreach n ret
  691.         (apply 'Ent:Make_Circle n)
  692.       )
  693.     )
  694.   )
  695. )

  697. ;;;测试极点和极线的样例
  698. (defun C:RAL(/ e1 e2 d1 d1 c r f p1 p2 rt)
  699.   (setq e1 (car (entsel "\n线:")))
  700.   (setq e2 (car (entsel "\n圆:")))
  701.   (if (and e1 e2)
  702.     (progn
  703.       (setq d1 (entget e1))
  704.       (setq d2 (entget e2))  
  705.       (setq C  (cdr (assoc 10 d2)))
  706.       (setq r  (cdr (assoc 40 d2)))
  707.       (setq p1 (cdr (assoc 10 d1)))
  708.       (setq p2 (cdr (assoc 11 d1)))
  709.       (setq f  (Line:Equation p1 p2))
  710.       (setq rt (CIR:Polar_Point c r (car f) (cadr f) (caddr f)))
  711.       (and rt (Ent:Make_Point rt))
  712.     )
  713.   )
  714. )

  716. ;;;测试三线切圆函数
  717. (defun c:LLL(/ e1 e2 e3 d1 d2 d3 p1 p2 p3 p4 p5 p6 ret)
  718.   (prompt "\n请选择三条直线:")
  719.   (if (and (setq ss (ssget '((0 . "LINE"))))
  720.            (>= (sslength ss) 3)
  721.       )
  722.     (progn
  723.       (setq e1 (ssname ss 0))
  724.       (setq e2 (ssname ss 1))
  725.       (setq e3 (ssname ss 2))
  726.       (setq d1 (entget e1))
  727.       (setq d2 (entget e2))
  728.       (setq d3 (entget e3))
  729.       (setq p1 (cdr (assoc 10 d1)))
  730.       (setq p2 (cdr (assoc 11 d1)))
  731.       (setq p3 (cdr (assoc 10 d2)))
  732.       (setq p4 (cdr (assoc 11 d2)))
  733.       (setq p5 (cdr (assoc 10 d3)))
  734.       (setq p6 (cdr (assoc 11 d3)))
  735.       (setq ret (CIR:LLL p1 p2 p3 p4 p5 p6))
  736.       (foreach n ret
  737.         (apply 'Ent:Make_Circle n)
  738.       )
  739.     )
  740.   )
  741. )
  742. ;;;----------------------------------------------------;
  743. ;;;程序结尾                                            ;
  744. ;;;--------------------------------------------------;|;


欢迎大家提出意见和找出错误。
另，为了方便，我把此文的源代码发上来。










程序, 百度搜索, 代数和, 三角形

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 8明经币 +13 金钱 +60 收起 理由
yxp + 1 + 30 奇文共欣赏，仰视高讲堂。
阿然 + 1 太棒了，正是我需要的
wowan1314 + 1 想不通怎么这么专业！！
rjtiantian + 1 很给力!
xshrimp + 2 神马都是浮云
Gu_xl + 3 + 30 赞一个!
仲文玉 + 3 很给力!
yjr111 + 1 很给力!收藏慢慢看

查看全部评分

"觉得好，就打赏"
打赏
共1人打赏

本帖被以下淘专辑推荐:

相关帖子
回复

使用道具 举报

xzs0829
发表于 2019-7-18 10:05:01 | 显示全部楼层
yxp 发表于 2013-5-20 03:29
多好的研究成果
我怎么没早些看见
这下得更新我的程序了

对瑞典圆弧条分算法感兴趣，可否分享下，谢谢
回复 支持 反对

使用道具 举报


发表于 2018-8-20 18:41:40 | 显示全部楼层
厉害啊，编程文学高数楼主都很精通！
回复 支持 反对

使用道具 举报

白丝折纸
发表于 2019-7-29 11:27:15 | 显示全部楼层
佩服佩服 学习了 谢谢高飞鸟
回复 支持 反对

使用道具 举报

wowan1314
发表于 2013-4-16 18:24:07 | 显示全部楼层
本帖最后由 wowan1314 于 2013-4-16 18:24 编辑

沙发我坐！ 学习中！
一上课就想睡觉！！
回复 支持 反对

使用道具 举报

cnks
发表于 2013-4-16 18:30:34 | 显示全部楼层
好贴一定要留个名
回复 支持 反对

使用道具 举报

仲文玉
发表于 2013-4-16 18:55:05 | 显示全部楼层
哇，高飞又出精品
回复 支持 反对

使用道具 举报

cable2004
发表于 2013-4-16 19:01:49 | 显示全部楼层
精品精品精品
回复 支持 反对

使用道具 举报

springwillow
发表于 2013-4-16 19:20:05 | 显示全部楼层
又是一精品之作，高版作品的特点就是高精深！
回复 支持 反对

使用道具 举报

1993063
发表于 2013-4-16 19:21:07 | 显示全部楼层
精品精品精品
回复 支持 反对

使用道具 举报

ScmTools
发表于 2013-4-16 20:00:12 | 显示全部楼层
支持一个...
回复 支持 反对

使用道具 举报

cxjzxh
发表于 2013-4-16 20:37:03 | 显示全部楼层
本帖最后由 cxjzxh 于 2013-4-16 20:50 编辑

好贴一定要留个名;有了高大师，明经蓬荜生辉。

点评

自贡黄明儒
特别赞同!!!  发表于 2013-4-18 14:41
回复 支持 反对

使用道具 举报

smartstar
发表于 2013-4-16 20:43:35 | 显示全部楼层
敬佩敬佩！谢谢高飞鸟！
回复 支持 反对

使用道具 举报

123下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-22 19:37 , Processed in 0.304056 second(s), 35 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表