Gauche-SDLでライフゲーム

最近になってGauche用のSDLラッパーを作成しているので、ここで一つ宣伝をしておきます。
SDLの詳細に関しては本家とかウィキペディアとかで。
作成しているGauche-SDLはこちらのgithub上にあります。
インストール方法などもろもろは同じくgithub上のWikiにあるので参照してください。
Windows上での動作も確認できていますが、コンパイルにはMinGWが必要です。気が向いたらコンパイル済みのバイナリもどこかで配布するかも。

最後に一つサンプルを載せておきます。
こちらのサイトを参考にして、ライフゲームをGauche-SDLを利用して書いてみました。

(use sdl)
(use sdl.gfx)
(use math.mt-random)
(use gauche.uvector)


(define screen #f)
(define-constant stride 100)
(define world (make-u8vector (* stride stride) 0))

(define-macro (world-ref world y x)
  `(ref ,world (+ (* ,y ,stride) ,x)))

(define-macro (world-set! world y x val)
  `(set! (ref ,world (+ (* ,y ,stride) ,x)) ,val))


(define (count-neighboring-individual y x world)
  (let ([next-y (if (eq? y (- stride 1)) 0 (+ y 1))]
        [prev-y (if (zero? y) (- stride 1) (- y 1))]
        [next-x (if (eq? x (- stride 1)) 0 (+ x 1))]
        [prev-x (if (zero? x) (- stride 1) (- x 1))])
    (+ (world-ref world prev-y prev-x) (world-ref world prev-y x) (world-ref world prev-y next-x)
       (world-ref world y prev-x) (world-ref world y next-x)
       (world-ref world next-y prev-x) (world-ref world next-y x) (world-ref world next-y next-x))))

(define (update-next-generation world)
  (let ([w (u8vector-copy world)])
    (dotimes [y stride #f]
      (dotimes [x stride #f]
        (let ([count (count-neighboring-individual y x world)])
          (cond
            [(zero? (world-ref world y x))
             (when (eq? count 3)
               (world-set! w y x 1))]
            [(or (>= count 4) (<= count 1))
             (world-set! w y x 0)]))))
    w))

(define (initialize-world)
  (let ([m (make <mersenne-twister>)])
    (dotimes [y stride #f]
      (dotimes [x stride #f]
        (world-set! world y x
                    (if (< (mt-random-integer m 10) 1) 1 0))))))

(define update
  (let ([wait (/ 1000 3)]
        [next 0])
    (lambda ()
      (set! next
        (if (>= (sdl-get-ticks) next)
          (begin
            (set! world (update-next-generation world))
            (+ next wait))
          next)))))


(define (draw)
  (let ([white (make-sdl-color 255 255 255)]
        [black (make-sdl-color 0 0 0)])
    (dotimes [y stride #f]
      (dotimes [x stride #f]
        (gfx-box-color screen (* x 4) (* y 4) (+ (* x 4) 4) (+ (* y 4) 4)
                       (if (zero? (world-ref world y x)) black white)))))
  (sdl-update-rect screen 0 0 0 0))

(define (initialize)
  (sdl-init SDL_INIT_VIDEO)
  (sdl-wm-set-caption "LifeGame -Gauche SDL-" #f)
  (set! screen (sdl-set-video-mode 400 400 32 SDL_SWSURFACE))
  (initialize-world)
  )

(define-constant wait (/ 1000 60))
(define (main-loop)
  (let loop ([next-frame (sdl-get-ticks)])
    (unless (let proc-event ([event (sdl-poll-event)])
              (and event
                (or
                  (eq? (ref event 'type) SDL_QUIT)
                  (and (eq? (ref event 'type) SDL_KEYUP) (eq? (ref (ref event 'keysym) 'sym) SDLK_ESCAPE))
                  (proc-event (sdl-poll-event)))))
      (let ([next (if (>= (sdl-get-ticks) next-frame)
                    (begin
                      (update)
                      (when (< (sdl-get-ticks) (+ next-frame wait))
                        (draw))
                      (+ next-frame wait))
                    next-frame)])
        (sdl-delay 0)
        (loop next)))))

(define (finalize)
  (sdl-quit))

(initialize)
(main-loop)
(finalize)

動作している画像はこちら。

サンプルを作ってみて気付いたけど、薄いラッパーだけだとどうもSchemeっぽいコードにならない。
もうちょっと抽象度を上げたレイヤもつくりたいなぁ。