McCLIMで時計っぽいもの

Common LispのGUIライブラリといえばMcCLIMがある。日本語資料の少なさとか他のGUIライブラリとの差異とかはご愛嬌というやつでしょう。

このMcCLIM、ユーザインターフェースを作るときは良いけれど、一定時間ごとに再描画したい、というようなユーザの動作が絡まないときの処理をどう書けば良いかよくわからない。

一定時間ごとにイベントを発生させられれば良いのだけど、よくわからないので他にスレッドを作ってそちらに任せることで解決しようとしてみた。

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

(in-package :clim-user)

(defun draw (frame stream)
  (declare (ignore frame))
  (multiple-value-bind
	(sec min hour) (get-decoded-time)
    (let ((sec-rad (* 2 pi (/ (- (* sec 6)90) 360)))
	  (min-rad (* 2 pi (/ (- (* min 6)90) 360)))
	  (hour-rad (* 2 pi
		       (/ (- (+ (* hour 30) (/ min 2)) 90)
			  360))))
      (format stream "~{~a~^:~}" (list hour min sec))
    (draw-line* stream 100 100
		 (+ 100 (* 30 (cos sec-rad)))
		 (+ 100 (* 30 (sin sec-rad)))
		 :ink (make-rgb-color 0.0 1.0 0.0))
    (draw-arrow* stream 100 100
		 (+ 100 (* 30 (cos min-rad)))
		 (+ 100 (* 30 (sin min-rad)))
		 :ink (make-rgb-color 0.0 0.0 1.0))
    (draw-arrow* stream 100 100
		 (+ 100 (* 20 (cos hour-rad)))
		 (+ 100 (* 20 (sin hour-rad)))
		 :ink (make-rgb-color 0.0 0.0 1.0))
    (draw-circle* stream 100 100 30
		  :filled nil
		  :ink (make-rgb-color 1.0 0.0 0.0)))))

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

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

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

(defmethod handle-event ((client application-pane) (event redraw-clock-event))
  (format t "handle-event(redraw)~%")
  (with-application-frame (frame)
    (redisplay-frame-pane frame client)))

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

(defun run ()
  (run-frame-top-level
   (make-application-frame 'clock-frame)))

;;(run)

paneの:display-timeあたりをどうにかするとうまいことできたりするのだろうか。