2006年10月23日星期一

利用Lisp绘制Spirograph曲线

还记得小时候玩过的一种玩具么?一个塑料板上有带内齿轮大圆形,一系列上面带有孔的小齿轮,把铅笔套在小齿轮的孔上,让小齿轮沿着大内齿轮滚动,于是,笔画出了一道漂亮的曲线。不大记得这种玩具叫什么名字了,好像叫“万花筒”?,今天才知道这种玩具的英文名叫“spirograph”,于是找了一下资料,发现外国的品种要多一些。如下图所示。

由于小时候挺喜欢这种玩具也很喜欢几何,而在学习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]