[求助]这个LISP程序如何编写？

meflying

再写了一下，有两个则画两个，如果切点在延长线上，则不画

2. 
   
3. (defun GetInterPoint (ent1 ent2 / ax_ent_1 ax_ent_2 intpoints points i)
   
4.   (setq ax_ent_1 (vlax-ename->vla-object ent1)
   
5.         ax_ent_2 (vlax-ename->vla-object ent2)
   
6.   )
   
7.   (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))
   
8.   (setq intpoints (vlax-variant-value intpoints))
   
9.   (setq i 0)
   
10.   (if (> (vlax-safearray-get-u-bound intpoints 1) 0)
    
11.     (repeat (/ (+ 1
    
12.               (- (vlax-safearray-get-u-bound intpoints 1)
    
13.                  (vlax-safearray-get-l-bound intpoints 1)
    
14.               )
    
15.            )
    
16.            3
    
17.         )
    
18.       (setq points (append points (list (list
    
19.                       (vlax-safearray-get-element intpoints i)
    
20.                       (vlax-safearray-get-element intpoints (+ i 1))
    
21.                       (vlax-safearray-get-element intpoints (+ i 2))
    
22.                     )))
    
23.       )
    
24.       (setq i (+ 3 i))
    
25.     )
    
26.   )
    
27.   points
    
28. )
    
29. 
    
30. (defun c:DrawCircle( / ent pt r entc entl pts i)
    
31.   (setq ent (car (entsel "\n选择直线或圆弧...")))
    
32.   (setq pt (getpoint "\n输入通过点:"))
    
33.   (setq r (getreal "\n输入半径:"))
    
34.   (setvar "cmdecho" 0)
    
35.   (command "_.circle" pt r)
    
36.   (setq entc (entlast))
    
37.   (command "_.offset" r ent pt "")
    
38.   (setq entl (entlast))
    
39.   (setq pts (GetInterpoint entc entl))
    
40.   (entdel entc)
    
41.   (entdel entl)
    
42.   (setq i 0)
    
43.   (repeat (length pts)
    
44.     (setq pt (nth i pts))
    
45.     (command "_.circle" pt r)
    
46.     (setq entc (entlast))
    
47.     (if (= (length (GetInterpoint entc ent)) 0) (entdel entc))
    
48.     (setq i (1+ i))
    
49.   )
    
50.   (princ)
    
51. )
    

<br /> (defun GetInterPoint (ent1 ent2 / ax_ent_1 ax_ent_2 intpoints points i)<br />   (setq ax_ent_1 (vlax-ename->vla-object ent1)<br />         ax_ent_2 (vlax-ename->vla-object ent2)<br />   )<br />   (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))<br />   (setq intpoints (vlax-variant-value intpoints))<br />   (setq i 0)<br />   (if (> (vlax-safearray-get-u-bound intpoints 1) 0)<br />     (repeat (/ (+ 1<br />               (- (vlax-safearray-get-u-bound intpoints 1)<br />                  (vlax-safearray-get-l-bound intpoints 1)<br />               )<br />            )<br />            3<br />         )<br />       (setq points (append points (list (list<br />                       (vlax-safearray-get-element intpoints i)<br />                       (vlax-safearray-get-element intpoints (+ i 1))<br />                       (vlax-safearray-get-element intpoints (+ i 2))<br />                     )))<br />       )<br />       (setq i (+ 3 i))<br />     )<br />   )<br />   points<br /> )<br /> <br /> (defun c:DrawCircle( / ent pt r entc entl pts i)<br />   (setq ent (car (entsel "\n选择直线或圆弧...")))<br />   (setq pt (getpoint "\n输入通过点:"))<br />   (setq r (getreal "\n输入半径:"))<br />   (setvar "cmdecho" 0)<br />   (command "_.circle" pt r)<br />   (setq entc (entlast))<br />   (command "_.offset" r ent pt "")<br />   (setq entl (entlast))<br />   (setq pts (GetInterpoint entc entl))<br />   (entdel entc)<br />   (entdel entl)<br />   (setq i 0)<br />   (repeat (length pts)<br />     (setq pt (nth i pts))<br />     (command "_.circle" pt r)<br />     (setq entc (entlast))<br />     (if (= (length (GetInterpoint entc ent)) 0) (entdel entc))<br />     (setq i (1+ i))<br />   )<br />   (princ)<br /> )<br />

gzy

里面的输入为什么要有半径，我操作的时候不行，麻烦大哥再看一下。
  我认为是不能输入半径的，因为目前只知道点和直线或者圆弧的参数。而且要画的圆只有两种情况，而且两种情况的半径应该是相同的，不知道你是否认为还有其他情况。

meflying

看看楼主的条件，圆的半径为已知，既然已知就必须提供，所以这里要输入半径。

操作过程为：
选择要与之相切的圆弧或直线，输入需要通过的点，然后输入圆的半径。
如果这个半径小于点到直线或圆弧的距离，则不存在这样的圆。

两种情况就是半径相同，且会交与通过的那点的两个圆。没有其它情况，这是几何知识，你画画就可以知道了

gzy

哦，忘记看那个圆半径已知的条件了。呵呵！

meflying

仔细看了看图，发现还有一种情况，就是当选择圆弧时，如果通过的在圆弧的外部，而且圆的半径大于圆弧的半径时，就有可能有另一种情况，就是圆包住圆弧也可能相切，且通过指定点。程序作了修正：

2. (defun GetInterPoint (ent1 ent2 / ax_ent_1 ax_ent_2 intpoints points i)
   
3.   (setq ax_ent_1 (vlax-ename->vla-object ent1)
   
4.         ax_ent_2 (vlax-ename->vla-object ent2)
   
5.   )
   
6.   (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))
   
7.   (setq intpoints (vlax-variant-value intpoints))
   
8.   (setq i 0)
   
9.   (if (> (vlax-safearray-get-u-bound intpoints 1) 0)
   
10.     (repeat (/ (+ 1
    
11.               (- (vlax-safearray-get-u-bound intpoints 1)
    
12.                  (vlax-safearray-get-l-bound intpoints 1)
    
13.               )
    
14.            )
    
15.            3
    
16.         )
    
17.       (setq points (append points (list (list
    
18.                       (vlax-safearray-get-element intpoints i)
    
19.                       (vlax-safearray-get-element intpoints (+ i 1))
    
20.                       (vlax-safearray-get-element intpoints (+ i 2))
    
21.                     )))
    
22.       )
    
23.       (setq i (+ 3 i))
    
24.     )
    
25.   )
    
26.   points
    
27. )
    
28. (defun Draw(pts r ent / pt entc i)
    
29.   (setq i 0)
    
30.   (repeat (length pts)
    
31.     (setq pt (nth i pts))
    
32.     (command "_.circle" pt r)
    
33.     (setq entc (entlast))
    
34.     (if (= (length (GetInterpoint entc ent)) 0) (entdel entc))
    
35.     (setq i (1+ i))
    
36.   )
    
37. )
    
38. 
    
39. (defun c:DrawCircle( / ent pt r entc entl pts rArc ptArc)
    
40.   (setq ent (car (entsel "\n选择直线或圆弧...")))
    
41.   (setq rArc (cdr (assoc 40 (entget ent))))
    
42.   (setq ptArc (cdr (assoc 10 (entget ent))))
    
43.   (setq pt (getpoint "\n输入通过点:"))
    
44.   (setq r (getreal "\n输入半径:"))
    
45.   (if (and (< (distance pt ptArc) rArc) (> r rArc)) (exit))
    
46.   (setvar "cmdecho" 0)
    
47.   (command "_.circle" pt r)
    
48.   (setq entc (entlast))
    
49.   (command "_.offset" r ent pt "")
    
50.   (setq entl (entlast))
    
51.   (if (not (equal entc entl))
    
52.     (progn
    
53.       (setq pts (GetInterpoint entc entl))
    
54.       (entdel entl)
    
55.       (Draw pts r ent)
    
56.     )
    
57.   )
    
58.   (if (> r rArc)
    
59.     (progn
    
60.       (command "_.circle" ptArc (- r rArc))
    
61.       (setq entl (entlast))
    
62.       (setq pts (GetInterpoint entc entl))
    
63.       (Draw pts r ent)
    
64.       (entdel entl)
    
65.     )
    
66.   )
    
67.   (entdel entc)
    
68.   (princ)
    
69. )

(defun GetInterPoint (ent1 ent2 / ax_ent_1 ax_ent_2 intpoints points i)<br />   (setq ax_ent_1 (vlax-ename->vla-object ent1)<br />         ax_ent_2 (vlax-ename->vla-object ent2)<br />   )<br />   (setq intpoints (vla-intersectwith ax_ent_1 ax_ent_2 acextendnone))<br />   (setq intpoints (vlax-variant-value intpoints))<br />   (setq i 0)<br />   (if (> (vlax-safearray-get-u-bound intpoints 1) 0)<br />     (repeat (/ (+ 1<br />               (- (vlax-safearray-get-u-bound intpoints 1)<br />                  (vlax-safearray-get-l-bound intpoints 1)<br />               )<br />            )<br />            3<br />         )<br />       (setq points (append points (list (list<br />                       (vlax-safearray-get-element intpoints i)<br />                       (vlax-safearray-get-element intpoints (+ i 1))<br />                       (vlax-safearray-get-element intpoints (+ i 2))<br />                     )))<br />       )<br />       (setq i (+ 3 i))<br />     )<br />   )<br />   points<br /> )<br /> (defun Draw(pts r ent / pt entc i)<br />   (setq i 0)<br />   (repeat (length pts)<br />     (setq pt (nth i pts))<br />     (command "_.circle" pt r)<br />     (setq entc (entlast))<br />     (if (= (length (GetInterpoint entc ent)) 0) (entdel entc))<br />     (setq i (1+ i))<br />   )<br /> )<br /> <br /> (defun c:DrawCircle( / ent pt r entc entl pts rArc ptArc)<br />   (setq ent (car (entsel "\n选择直线或圆弧...")))<br />   (setq rArc (cdr (assoc 40 (entget ent))))<br />   (setq ptArc (cdr (assoc 10 (entget ent))))<br />   (setq pt (getpoint "\n输入通过点:"))<br />   (setq r (getreal "\n输入半径:"))<br />   (if (and (< (distance pt ptArc) rArc) (> r rArc)) (exit))<br />   (setvar "cmdecho" 0)<br />   (command "_.circle" pt r)<br />   (setq entc (entlast))<br />   (command "_.offset" r ent pt "")<br />   (setq entl (entlast))<br />   (if (not (equal entc entl))<br />     (progn<br />       (setq pts (GetInterpoint entc entl))<br />       (entdel entl)<br />       (Draw pts r ent)<br />     )<br />   )<br />   (if (> r rArc)<br />     (progn<br />       (command "_.circle" ptArc (- r rArc))<br />       (setq entl (entlast))<br />       (setq pts (GetInterpoint entc entl))<br />       (Draw pts r ent)<br />       (entdel entl)<br />     )<br />   )<br />   (entdel entc)<br />   (princ)<br /> )

BDYCAD

我指的可能性就是這些啦.

SWAYWOOD

我是初学者，目前看不懂上面的程序但我觉得有如下几种情况
直线时
1.不交
2.一个切点
3.两个切点
圆弧时
因为可能交在延长线上，应先当作圆

点在圆外，半径增大依次有
1.不交
2.一个切点
3.两个切点
4.一个切点
5.两个切点
点在圆内，半径增大依次有
1.不交
2.一个切点
3.两个切点
4.一个切点

ljpnb

谢谢以上各位的解答!我提得这个问题是实际中经常碰到的问题,解决的办法就是运用尺规作图法,所以我一直就想弄个程序偷懒一下!我对LISP研究不深，还需要各位高手相助！

meflying

程序已经给你写出来了啊？不会看不到吧？

龙龙仔

;;通过任意一点，与一直线或是圆弧切
;;利用TTR原理只缯画唯一"圆"
;;BY 龙龙仔(LUCAS)
(defun C:T_PT_CIRCLE (/ HOLDOSMODE ENT ENT1 ENT2 ENT3 PTARC PT R SS N)
  (defun DO_IT (FLAG)
    (if        SS
      (progn
        (setq N 0)
        (repeat        (sslength SS)
          (vla-put-visible
            (vlax-ename->vla-object (ssname SS N))
            FLAG
          )
          (setq N (1+ N))
        )
      )
    )
  )
  (setq ENT (car (setq ENT1 (entsel "\n选择直线或圆弧..."))))
  (setq PTARC (cdr (assoc 10 (entget ENT))))
  (setq HOLDOSMODE (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq PT (getpoint "\n输入通过点: "))
  (setq R (getdist PT "\n输入半径: "))
  (setq SS (ssget "C" PT PT))
  (DO_IT :vlax-false)
  (command "_.CIRCLE" PT 1E-50)
  (setq ENT2 (entlast))
  (command "_.CIRCLE" "T" PT (cadr ENT1) R)
  (entdel ENT2)
  (DO_IT :vlax-true)
  (setvar "OSMODE" HOLDOSMODE)
  (princ)
)