由于小时候挺喜欢这种玩具也很喜欢几何，而在学习Lisp之初，就用Lisp编了如下一段简单的小程序，最近整理东西的时候才发现，贴贴让大家娱乐一下：）
这种曲线应该和机械的有点关系，假如一个圆沿着一条直线走的话，那么圆内（不一定是圆周）某一点形成的轨迹应该叫滚轮线，似乎和悬链线及最速降线有点关系，而圆沿着一个圆周走，照查询的资料应该叫spirograph－螺旋型星云线，而若其沿着一个封闭的曲线走，应该更复杂一下，反正是按照一种等距离量测的方法在走动。
本程序简单利用参数方程的方法构建，纯属娱乐，毫无作用，见笑了：）
原理
;;; ========================================================================
;;; The following code are writen by qjchen ;
;;; 华南理工大学 建筑学院 ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(defun c:test (/ lst r1 r2 r3 r4 color alpha beta orign orignx orignyp1 p2)
(setq lst (getpattern)
r1 (nth 0 lst)
r2 (nth 1 lst)
r3 (nth 2 lst)
r4 (- r1 r2)
color (nth 3 lst)
alpha 0
beta 0
orign (getpoint "\n the original point:")
orignx (car orign)
origny (cadr orign)
)
(command "color" color "")
(while (< beta 314)
(setq alpha (* -1 (* beta (/ r2 (+ r4 r2)))))
(setq p1 (list (+ orignx (* r4 (cos alpha)) (* r3 (cos beta)))
(+ origny (* r4 (sin alpha)) (* r3 (sin beta)))
0
)
)
(setq beta (+ beta 0.05))
(setq alpha (* -1 (* beta (/ r2 (+ r4 r2)))))
(setq p2 (list (+ orignx (* r4 (cos alpha)) (* r3 (cos beta)))
(+ origny (* r4 (sin alpha)) (* r3 (sin beta)))
0
)
)
(command "line" p1 p2 "")
)
)
(defun getpattern (/ kword pattern pattern1)
(initget "1 2 3 4 5 6 7 8 9 10")
(setq kword (getkword "\n please select the type: 1/2/3/4/5/6/7/8/9/10:"))
(cond
((= kword "1")
(setq res (list 20.0 14.3 7 1))
)
((= kword "2")
(setq res (list 20.0 14.3 15 2))
)
((= kword "3")
(setq res (list 20.0 10.3 5 3))
)
((= kword "4")
(setq res (list 20.0 12 8 4))
)
((= kword "5")
(setq res (list 20.0 9 1 5))
)
((= kword "6")
(setq res (list 20.0 9 5 131))
)
((= kword "7")
(setq res (list 20.0 9 7 30))
)
((= kword "8")
(setq res (list 20.0 8 5 220))
)
((= kword "9")
(setq res (list 20.0 5.2 4.2 170))
)
((= kword "10")
(setq res (list 20.0 5.2 2.2 140))
)
)
res
)
效果 [img]http://qjchen.googlepages.com/HELISCOPE.png[/img]
修改一下，改成变颜色和画圆，得到如下的结果和图形
;;; ========================================================================
;;; The following code are writen by qjchen ;
;;; 华南理工大学 建筑学院 ;
;;; Http://qjchen.googlepages.com ;
;;; ========================================================================
(defun c:test1 (/ lst r1 r2 r3 rad color alpha beta orign orignx orignyp1
p2 rep add)
(setq lst (getpattern1)
r1 (nth 0 lst)
r2 (nth 1 lst)
r3 (nth 2 lst)
rad (nth 3 lst)
rep (nth 4 lst)
add (nth 5 lst)
alpha 0
beta 0
orign (getpoint "\n the original point:")
orignx (car orign)
origny (cadr orign)
)
(entmake (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 orign)
(cons 40 r1)
(cons 62 8)
)
)
(setq i 1)
(setq color 10)
(command "color" color "")
(while (< beta rep)
(if (> beta (* add i))
(progn
(setq i (+ i 1))
(setq color (+ color 10))
(command "color" color "")
)
)
(setq alpha (* -1 (* beta (/ r2 (+ r1 r2)))))
(setq x1 (+ orignx (* r1 (cos alpha)) (* r3 (cos beta))))
(setq y1 (+ origny (* r1 (sin alpha)) (* r3 (sin beta))))
(setq p1 (list x1 y1 0.0))
(setq beta (+ beta 0.05))
(entmake (list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "0")
(cons 10 p1)
(cons 40 rad)
(cons 62 color)
)
)
)
)
(defun getpattern1 (/ kword pattern pattern1)
(initget "1 2")
(setq kword (getkword "\n please select the type: 1/2:"))
(cond
((= kword "1")
(setq res (list 20.0 14.3 7 0.2 75.2 3.14))
)
((= kword "2")
(setq res (list 20.0 15 15 1 44 2.14))
)
)
res
)
效果：
[img]http://qjchen.googlepages.com/HELISCOPE3.png[/img]
