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)