用Racket语言写了一个万花筒的程序

用Racket语言写了一个万花筒的程序

　　Racket语言是Lisp语言的一个方言。Lisp语言具有神奇的魔力，可以全方位诠释哲学，而不像其它语言主要能够表达数学。
　　
　　这是我用它写的第一个完整程序，在此纪念一下下。

　　先来看看我的万花筒的神奇魅力，我相信以下画出来的图（带参数，可按参数重新绘出来）任何一个外边买的万花板都画不出来。不信来比：

• 这一个，注意全是尖角，中间空心呈方形：

• 这一个，花瓣中间的脉络全是直线，花心有两个圆：

• 能画出三角形吗？而且中间镶钻，两颗！

• 这个我画出来自己都被震撼了，如此的完美！

这个是不是超有立体感，不知进入了哪一个维度：

这一个，能不能找到冬天围脖的的温暖？不过哪个建筑这样修一定会拿大奖。

这个，怎么画出来的？（揭秘：将轨道起始角自图中值依次增加5并点画图按钮执行画图，经过N次之后，就出现这个神奇效果啦！）

这个，看起来很常规，不过，仔细看看！（揭秘：这是多次调整转轮半径后得到的效果。不过具体怎么的记不得了，可以自己去试。）

最后贴上源程序：

;=============================================================
;artascope.rkt
;主程序：

#lang racket
(require racket/gui)
(require racket/draw)

(require "model-simple.rkt")

(include "view-main.rkt")

(send main-frame show #t)

;=======================================================
;model-simple.rkt
;万花筒模型

(module model-simple racket

  (provide draw-artascope
           set-f-center
           get-af0 set-af0 get-ap0 set-ap0
           get-rf set-rf get-rw set-rw get-rp set-rp
           get-step-aw set-step-aw
           get-start-af set-start-af  get-end-af set-end-af)

  ;定义全局参数：
  (define f-center (cons 300 300))
  (define af0 30)
  (define ap0 20)
  (define rf 300)
  (define rw 210)
  (define rp 100)
  (define step-aw 30)
  (define start-af 0)
  (define end-af 7720)

  ;设置/取得绘图全局参数：
  (define (get-af0) af0)
  (define (set-af0 a) (set! af0 a))
  (define (get-ap0) ap0)
  (define (set-ap0 a) (set! ap0 a))
  (define (get-rf) rf)
  (define (set-rf r) (set! rf r))
  (define (get-rw) rw)
  (define (set-rw r) (set! rw r))
  (define (get-rp) rp)
  (define (set-rp r) (set! rp r))
  (define (get-step-aw) step-aw)
  (define (set-step-aw a) (set! step-aw a))
  (define (get-start-af) start-af)
  (define (set-start-af a) (set! start-af a))
  (define (get-end-af) end-af)
  (define (set-end-af a) (set! end-af a))

  ;取得绘图点的X、Y坐标：
  (define xp
    (lambda (xw ap)
      (+ xw (* rp (cos (degrees->radians ap))))))
  (define yp
    (lambda (yw ap)
      (+ yw (* rp (sin (degrees->radians ap))))))

  ;计算滚轮圆心X、Y坐标：
  (define xw
    (lambda (af)
      (+ (car f-center) (* (- rf rw) (cos (degrees->radians af))))))
  (define yw
    (lambda (af)
      (+ (cdr f-center) (* (- rf rw) (sin (degrees->radians af))))))

  ;计算af、dlt-af、ap值：
  (define af
    (lambda (dlt-af)
      (+ af0 dlt-af)))
  (define dlt-af
    (lambda (dlt-aw)
      (/ (* rw dlt-aw) rf)))
  (define ap
    (lambda (dlt-aw)
      (- ap0 dlt-aw)))


  ;组合坐标值为点值：
  (define (get-p dlt-aw)
    (cons (xp (xw (af (dlt-af dlt-aw))) (ap dlt-aw))
          (yp (yw (af (dlt-af dlt-aw))) (ap dlt-aw))))

  (define cur-aw
    (lambda (af)
      (/ (* af rf) rw)))

  ;绘制万花筒：
  (define draw-artascope
    (lambda (dc)
      (let ([p1 (get-p af0)])
        (do ([dlt-aw (cur-aw (+ af0 start-af)) (+ dlt-aw step-aw)])
          ((> dlt-aw (cur-aw (+ af0 end-af))) "结束画图。")
          (let ([p2 (get-p dlt-aw)])
            (begin
              (send dc draw-lines (list p1 p2))
              (set! p1 p2)))))))

  ;设置画布中心点为轨道圆心点：
  ;函数参数为函数，该函数参数取得画布的尺寸。
  (define (set-f-center canvas-size)
    (let-values ([(fx fy) (canvas-size)])
      (set! f-center (cons (/ fx 2) (/ fy 2)))))
  )

;===============================================================
;view-mail.rkt
;定义主界面视图：

;;;定义主界面：----------------------------------------------------------
(define main-frame
  (new frame%
       [label "万花筒(Artascope)"]
       [width 800]
       [height 600]
       [border 5]))

;;;分割主界面：----------------------------------------------------------
;定义总面板：
(define panel-all
  (new vertical-panel%
       [parent main-frame]
       [alignment '(left top)]
       [stretchable-width #t]
       [stretchable-height #t]))

;定义工具栏面板：
(define toolbars
  (new horizontal-panel%
       [parent panel-all]
       [alignment '(left top)]
       [stretchable-width #f]
       [stretchable-height #f]
       [border 2]))

;定义工作区：
(define panel-work
  (new horizontal-panel%
       [parent panel-all]
       [alignment '(center center)]))

;定义画布面板：
(define panel-canvas
  (new vertical-panel%
       [parent panel-work]
       [style '(border)]
       [alignment '(left top)]
       [border 10]))

;定义绘图参数设置面板
(define panel-setting
  (new vertical-panel%
       [parent panel-work]
       [alignment '(right top)]
       [border 5]
       [min-width 180]
       [stretchable-width #f]))

;;;定义画布：--------------------------------------------------------------
(define canvas
  (new canvas%
       [parent panel-canvas]))

;;;引入视图控制程序：--------------------------------------------------
(include "control-main.rkt")

;;;定义菜单----------------------------------------------------------------
(define menubar
  (new menu-bar%
       [parent main-frame]))

;;程序菜单：
(define menu-prog
  (new menu%
       [label "程序"]
       [parent menubar]))
(define menu-item-draw
  (new menu-item%
       [label "画图"]
       [parent menu-prog]
       [callback draw]))
(define menu-item-clear
  (new menu-item%
       [label "清空画布"]
       [parent menu-prog]
       [callback clear]))
(define separator-menu-item-1
  (new separator-menu-item%
       [parent menu-prog]))
(define menu-item-exit
  (new menu-item%
       [label "退出"]
       [parent menu-prog]
       [callback
        (lambda (item event)
          (send main-frame on-exit))]))

;;帮助菜单：
(define menu-help
  (new menu%
       [label "帮助"]
       [parent menubar]))
(define menu-item-help
  (new menu-item%
       [label "使用指南"]
       [parent menu-help]
       [callback help]))
(define menu-item-about
  (new menu-item%
       [label "关于"]
       [parent menu-help]
       [callback help]))

;;;定义工具栏按钮：----------------------------------------------------
(define toolbar-general
  (new horizontal-panel%
       [parent toolbars]
       [alignment '(left top)]
       [stretchable-width #f]
       [stretchable-height #f]))

(define button-draw
  (new button%
       [parent toolbar-general]
       [label "画图"]
       [callback draw]))

(define button-clear
  (new button%
       [parent toolbar-general]
       [label "清空画布"]
       [callback clear]))

(define button-help
  (new button%
       [parent toolbar-general]
       [label "关于此程序"]
       [callback help]))

;;;定义绘图参数设置控件：--------------------------------------------
;轨道参数：
(define group-box-panel-frame
  (new group-box-panel%
       (parent panel-setting)
       (label "轨道参数")
       (alignment (list 'right 'top))
       (stretchable-height #f)))
(define text-field-af0
  (new text-field%
       (parent group-box-panel-frame)
       (label "轨道圆起始角")
       (horiz-margin 5)
       (min-width 165)
       (stretchable-width #f)
       (init-value (number->string (get-af0)))))
(define text-field-rf
  (new text-field%
       (parent group-box-panel-frame)
       (label "轨道圆半径")
       (horiz-margin 5)
       (min-width 150)
       (stretchable-width #f)
       (init-value (number->string (get-rf)))))
(define text-field-start-af
  (new text-field%
       (parent group-box-panel-frame)
       (label "轨道起始角")
       (horiz-margin 5)
       (min-width 150)
       (stretchable-width #f)
       (init-value (number->string (get-start-af)))))
(define text-field-end-af
  (new text-field%
       (parent group-box-panel-frame)
       (label "轨道结束角")
       (horiz-margin 5)
       (min-width 150)
       (stretchable-width #f)
       (init-value (number->string (get-end-af)))))

;滚轮参数：
(define group-box-panel-wheel
  (new group-box-panel%
       (parent panel-setting)
       (label "滚轮参数")
       (alignment (list 'right 'top))
       (stretchable-height #f)))
(define text-field-ap0
  (new text-field%
       (parent group-box-panel-wheel)
       (label "绘制点起始角")
       (horiz-margin 5)
       (min-width 165)
       (stretchable-width #f)
       (init-value (number->string (get-ap0)))))
(define text-field-rw
  (new text-field%
       (parent group-box-panel-wheel)
       (label "滚轮半径")
       (horiz-margin 5)
       (min-width 135)
       (stretchable-width #f)
       (init-value (number->string (get-rw)))))
(define text-field-rp
  (new text-field%
       (parent group-box-panel-wheel)
       (label "绘制点半径")
       (horiz-margin 5)
       (min-width 150)
       (stretchable-width #f)
       (init-value (number->string (get-rp)))))
(define text-field-step-aw
  (new text-field%
       (parent group-box-panel-wheel)
       (label "滚轮角步距")
       (horiz-margin 5)
       (min-width 150)
       (stretchable-width #f)
       (init-value (number->string (get-step-aw)))))

;==========================================================
;control-main.rkt
;main视图的控制程序：

;;;取得并设置绘图参数值(绘图面板函数)：---------------------------------
#|
af0 ap0
rf rw rp
step-aw
start-af end-af
|#
(define (set-draw-parameter)
  (set-af0 (string->number (send text-field-af0 get-value)))
  (set-ap0 (string->number (send text-field-ap0 get-value)))
  (set-rf (string->number (send text-field-rf get-value)))
  (set-rw (string->number (send text-field-rw get-value)))
  (set-rp (string->number (send text-field-rp get-value)))
  (set-step-aw (string->number (send text-field-step-aw get-value)))
  (set-start-af (string->number (send text-field-start-af get-value)))
  (set-end-af (string->number (send text-field-end-af get-value))))

;;;菜单命令/工具栏执行程序-----------------------------------------------------
;绘制万花筒：
(define (draw menu-item event)
  (set-draw-parameter);设置绘图参数
  (set-f-center (lambda () (send canvas get-client-size)));设置轨道中心点
  (draw-artascope (send canvas get-dc)))

;清空画布：
(define (clear menu-item event)
  (send canvas refresh))

;显示关于对话框：
(define (help menu-item event)
  (message-box "关于万花筒程序"
               "万花筒程序：一个模拟万花筒的程序，用Racket编写。\n
本程序尽量全面展示了Racket语言GUI编程方式，以及基本的画布绘图操作。\n
作者：Racket" 
               main-frame
               '(ok caution)))

源代码开源在Github上：https://github.com/OnRoadZy/artascope.git