[讨论]：这个图有没有更好的LISP程序？

SLMin

偶是这样写的：
[php](defun c:lsp_12()
   (setvar "cmdecho" 0)
   (setq os (getvar "osmode"))
   (setvar "osmode" 0)
   (setq cen1 (getpoint "\n中心点: "))
   (setq rr1 (getdist cen1 "\n大圆半径: "))
   (command "circle" cen1 rr1)
   (setq en1 (entlast))
   (command "circle" cen1 "d" rr1)   
   (setq cen2 (polar cen1 0 rr1))
   (setq rr2 (getdist cen2 "\n小圆半径: "))
   (setq nn (getint "\n重复几次 <8>: "))
   (if (null nn) (setq nn 8))
   (setq ang 0 ss (ssadd))
   (setq angdd (/ (* pi 2) nn))
   (repeat nn
      (command "circle" cen2 rr2)
      (setq ss (ssadd (entlast) ss))
      (setq ang (+ ang angdd))
      (setq cen2 (polar cen1 ang rr1))
   )
   (setq ang 0)
   (repeat nn
      (command "trim" ss "" (polar cen1 ang rr1) "")
      (setq ang (+ ang angdd))
   )
   (setq ang1 (* -1 (/ angdd 2.0)) ang2 (+ ang1 angdd) ang 0)
   (repeat nn
      (command "trim" (polar cen1 ang1 rr1) (polar cen1 ang2 rr1) ""
                      (polar cen1 ang (- rr1 rr2)) "")
      (setq ang1 (+ ang1 angdd) ang2 (+ ang2 angdd) ang (+ ang angdd))
   )
   (setvar "osmode" os)
   (prin1)  
)[/php]

xyp1964

[php]
;;;试试这个，增加半径大小判断，实际效果判断。
;|
* C:test
-- XYP@bsedi.com
2004.11.13
|;
(defun c:test()
  (cmdla0)
  (setq        cen1 (getpoint "\n中心点: ")
        rr1  (ureal 1 "" "\n大圆半径" rr1)
        rr2  (ureal 1 "" "\n小圆半径" rr2)
        )
  (bjbj rr1 rr2)
  (setq nn   (ureal 1 "" "\n重复几次" nn)
        cen2 (polar cen1 0 rr1)
        )
  (ang-12 rr1 rr2)
  (if (> (- (/ pi (/ nn 2)) ang-R1R2) ang-R1R2)
    (progn
      (vl-cmdf "circle" cen1 "d" rr1)
      (setq ssx1 (ssget"X")
            pt1        (polar cen1 ang-R1R2 rr1)
            pt2        (polar cen2 0 rr2)
            pt3        (polar cen1 (- 0 ang-R1R2) rr1)
            pt4        (polar cen1 (- (/ pi (/ nn 2)) ang-R1R2) rr1)
            ss        (ssadd)
      )
      (vl-cmdf "arc" pt3 pt2 pt1)
      (setq ss (ssadd (entlast) ss))
      (vl-cmdf "arc" "c" cen1 pt1 pt4)
      (setq ss (ssadd (entlast) ss))
      (vl-cmdf "-array" ss "" "P" cen1 (fix nn) "360" "Y")
      (setq ssx2 (ssget"X"))
      (vl-cmdf "_.select" ssx2 "_r" ssx1 "")
      (setq ss (ssget "p"))      
      (command "pedit" (entlast) "Y" "j" ss "" "")
    )
    (alert "\n呵呵……大圆半径太小、或小圆半径太大、或重复几次太多，搞不赢!")
  )
  (cmdla1)
)
;;;半径比较
(defun bjbj(r1 r2)
  (if (< r1 r2)
    (progn
      (alert "\n搞什么搞：大圆半径比小圆半径还小!")
      (exit)
      )
    ))
(defun ang-12(r1 r2)(setq ang-R1R2(* 2 (atan(/ r2 (sqrt(- (* 2 2 r1 r1)(* r2 r2))))))))

;;;通用子函数
(defun CMDLA0 ()
  (setq cmdech (getvar "CMDECHO"))
  (setq oom (getvar "orthomode"))
  (setq osm (getvar "osmode"))
  (SETQ LA (getvar "clayer"))
  (setq rmode (getvar "regenmode"))
  (setq pw (getvar "plinewid"))
  (setvar "regenmode" 0)
  (setvar "CMDECHO" 0)
  (princ)
)
(defun CMDLA1 ()
  (setvar "CMDECHO" cmdech)
  (setvar "orthomode" oom)
  (setvar "osmode" osm)
  (setvar "clayer" LA)
  (setvar "regenmode" rmode)
  (setvar "plinewid" pw)
  (princ)
)
(defun ureal (bit kwd msg def / inp)
  (if def
    (setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
          bit (* 2 (fix (/ bit 2))))
    (setq msg (strcat "\n" msg ": "))
  )
  (initget bit kwd)
  (setq inp (getreal msg))
  (if inp inp def)
)
[/php]

SLMin

错误提示：

错误: no function definition: UREAL

xyp1964

最初由 SLMin 发布
[B]错误提示：

错误: no function definition: UREAL [/B]

已修改！

lsjjm

也可以这样
[php]
(defun C:test ()
  (setq pc (getpoint "\nPick Center Point:"))
  (setq r1 (getdist "\nMajor Radius: "))
  (setq r2 (getdist "\nMinor Radius: "))
  (setq  n (getint "\nNumber of Minor Circle:"))
  (vl-cmdf "circle" pc r1)
  (vl-cmdf "circle" (polar pc 0 r1) r2)
  (vl-cmdf "array" (entlast) "" "P" pc n "360" "")
  (setq m n)
  (repeat m
    (vl-cmdf "trim" "all" "" "f" pc (polar pc (* m (/ (* 2.0 pi) n)) r1) "" "")
    (setq m (1- m))
  )
  (vl-cmdf "circle" pc (/ r1 2))       
)
[/php]

SLMin

长老的程序真不错！

XYP1964:
  你的那个自定义函数(UREAL)是取得默认值？好难理解啊！请执教！

xyp1964

最初由 lsjjm 发布
[B]也可以这样
[php]
(defun C:test ()
  (setq pc (getpoint "\nPick Center Point:"))
  (setq r1 (getdist "\nMajor Radius: "))
  (setq r2 (getdist "\nMinor Radius: "))
  (setq  n (getint "\nNumber of ... [/B]

程序简洁，效果极好！意料不到！
命令: test
Pick Center Point:
Major Radius: 5000
Minor Radius: 4000
Number of Minor Circle:8
及
命令: test
Pick Center Point:
Major Radius: 5000
Minor Radius: 1000
Number of Minor Circle:8
效果如下：