2010年2月6日土曜日

McCLIMでライフゲーム

McCLIMでライフゲームをやってみた。描画が遅いのでどうしようかと調べてみたところ、 with-output-bufferedとclimi::with-double-buffering というそれっぽいのが見つかった。

with-double-bufferingはエクスポートされていないので、とりあえずは wiht-output-bufferedを使った。

(require :asdf)
(asdf:oos 'asdf:load-op :mcclim)
(asdf:oos 'asdf:load-op :portable-threads)

(in-package :clim-user)
(defparameter +block-size+ 10)
(defparameter +field-size-x+ 10)
(defparameter +field-size-y+ 10)

(defun draw (frame stream)
(let ((f (field frame))
(medium (sheet-medium stream)))
(clim:with-output-buffered (medium)
;; (climi::with-double-buffering ((stream 0 0 500 500) (wtf))
(dotimes (i (array-dimension f 0))
(dotimes (j (array-dimension f 1))
(draw-rectangle* medium
;; (draw-rectangle* stream
(* i +block-size+) (* j +block-size+)
(* (1+ i) +block-size+) (* (1+ j) +block-size+)
:ink (if (= 1 (aref f i j)) +black+ +white+)))))
(medium-finish-output medium)
(clim:medium-force-output medium)
))

(defun update-field (field tmp)
(let ((x-limit (array-dimension tmp 0))
(y-limit (array-dimension tmp 1)))
(dotimes (i x-limit)
(dotimes (j y-limit)
(setf (aref tmp i j)
(next field i j x-limit y-limit)))))
tmp)

(defun next (field x y x-limit y-limit)
(case (- (loop
:for i
from (if (= x 0) 0 -1)
to (if (= x (1- x-limit)) 0 1)
:sum (loop
:for j from (if (= y 0) 0 -1)
to (if (= y (1- y-limit)) 0 1)
:sum (aref field (+ x i) (+ y j))))
(aref field x y) 1 0)
((3) 1)
((2) (if (aref field x y) 1 0))
(T 0)))

(define-application-frame lifegame-frame ()
((field :accessor field :initform nil)
(tmp-field :accessor tmp-field :initform nil)
(timer-process :accessor timer-process :initform nil))
(:menu-bar t)
(:panes
(canvas :application
:min-width 200
:min-height 200
:scroll-bars T
:display-time :command-loop
:display-function 'draw))
(:layouts
(default (horizontally () canvas))))

(define-lifegame-frame-command (com-quit :menu t) ()
(frame-exit *application-frame*))

(define-lifegame-frame-command (com-update :menu t) ()
(setf (tmp-field *application-frame*)
(update-field (field *application-frame*)
(tmp-field *application-frame*)))
(rotatef (tmp-field *application-frame*)
(field *application-frame*))
(redisplay-frame-panes *application-frame*))

(defun init-field (field x y)
(dotimes (i x)
(dotimes (j y)
(setf (aref field i j)
(if (< (random 10) 7)
0 1))))
field)

(defclass timer-event (device-event)
()
(:default-initargs :modifier-state 0))

(defmethod handle-event ((client application-pane) (event timer-event))
(com-update))

(defmethod run-frame-top-level ((frame lifegame-frame) &key)
(let ((tls (frame-top-level-sheet frame))
(canvas (get-frame-pane frame 'canvas)))
(format t "spawn-thread~%")
(setf (timer-process frame)
(portable-threads:spawn-thread
"timer"
#'(lambda ()
(loop
:do
(sleep 1.0)
(queue-event tls (make-instance 'timer-event :sheet canvas))
))))
(call-next-method)
(format t "return from call-next-method~%")
(when (timer-process frame)
(portable-threads:kill-thread (timer-process frame)))))

(defun run (&optional (x +field-size-x+) (y +field-size-x+))
(let ((f (make-array (list x y) :initial-element 0))
(tmp (make-array (list x y) :initial-element 0))
(frame (make-application-frame 'lifegame-frame)))
(init-field f x y)
(setf (field frame) f)
(setf (tmp-field frame) tmp)
(run-frame-top-level frame)))

;;(run 60 50)

0 件のコメント:

コメントを投稿