lispbuilder-sdl-ttfで日本語を表示する

魔法言語リリカル☆LispみたいなものをCommon Lisp処理系の上に直接作れたらと思ったので、とりあえずlispbuilder-sdlで簡単なスクリプトエンジンを作ってみることにした。
と思ったら日本語テキストを表示するところでいきなりはまった。
当初はlispbuilder-sdl-ttfに付いてくるサンプルプログラムを少しいじって、次のようにしていたのだが、

(require :lispbuilder-sdl)
(require :lispbuilder-sdl-ttf)

(defparameter *ttf-font-takao*
  (make-instance 'sdl:ttf-font-definition
     :size 32
     :filename "/usr/share/fonts/truetype/takao-gothic/TakaoGothic.ttf")) ; ttfファイルの場所を指定する

(defun font-example ()
  (sdl:with-init ()
    (sdl:window 600 96 :title-caption "SDL-TTF Font Example" :icon-caption "SDL-TTF Font Example")
    (setf (sdl:frame-rate) 30)
    (sdl:fill-surface sdl:*white* :surface sdl:*default-display*)
    (unless (sdl:initialise-default-font *ttf-font-takao*)
      (error "FONT-EXAMPLE: Cannot initialize the default font."))
    (sdl:draw-string-solid-* "Text UTF8 - Solid 日本語テスト" 0 0
                             :color sdl:*black*)
    (sdl:draw-string-shaded-* "Text UTF8 - Shaded 日本語テスト" 0 32
                              sdl:*black*
                              sdl:*yellow*)
    (sdl:draw-string-blended-* "Text UTF8 - Blended 日本語テスト" 0 64
                               :color sdl:*black*)
    (sdl:update-display)
    (sdl:with-events ()
      (:quit-event () t)
      (:video-expose-event () (sdl:update-display))
      (:key-down-event ()
       (when (sdl:key-down-p :sdl-key-escape)
         (sdl:push-quit-event))))))

このままでfont-exampleを呼んでみると、日本語の部分が文字化けしてしまう。

lispbuilder-sdl-ttfのソースを読んでいくと、sdl-ttf-cffi::render-utf8-solidなどのUTF-8に対応した描画関数が定義されているにも関わらずsdl-ttf-cffi::render-text-solidなどのUTF-8非対応の関数しか呼ばれていないことが分かった。だから単純にこの関数を使っている部分を置き換えて再定義してやればいい。

(in-package #:lispbuilder-sdl)

(defmethod _render-string-solid_ ((string string) (font ttf-font) (color color) free cache)
  (let ((surf nil))
    (with-foreign-color-copy (col-struct color)
      (setf surf (make-instance 'surface
		    :fp (sdl-ttf-cffi::render-utf8-solid
			 (fp font)
			 string
			 (if (cffi:foreign-symbol-pointer "TTF_glue_RenderText_Solid")
			   col-struct
			   (+ (ash (b color) 16)
			      (ash (g color) 8)
			      (r color)))))))
    (when cache
      (setf (cached-surface font) surf))
    surf))

(defmethod _render-string-blended_ ((string string) (color color) (font ttf-font) free cache)
  (let ((surf nil))
    (with-foreign-color-copy (col-struct color)
      (setf surf (make-instance 'surface
		    :fp (sdl-ttf-cffi::render-utf8-blended
			 (fp font) string
			 (if (cffi:foreign-symbol-pointer "TTF_glue_RenderText_Blended")
			   col-struct
			   (+ (ash (b color) 16)
			      (ash (g color) 8)
			      (r color)))))))
    (when cache
      (setf (cached-surface font) surf))
    surf))

(defmethod _render-string-shaded_ ((string string) (fg-color color) (bg-color color) (font ttf-font) free cache)
  (let ((surf nil))
    (with-foreign-color-copy (fg-struct fg-color)
      (with-foreign-color-copy (bg-struct bg-color)
        (multiple-value-bind (fg bg)
            (if (cffi:foreign-symbol-pointer "TTF_glue_RenderText_Shaded")
              (values fg-struct bg-struct)
              (values (+ (ash (b fg-color) 16)
                         (ash (g fg-color) 8)
                         (r fg-color))
                      (+ (ash (b bg-color) 16)
                         (ash (g bg-color) 8)
                         (r bg-color))))
          (setf surf (make-instance 'surface
			:fp (sdl-ttf-cffi::render-utf8-shaded
			     (fp font) string fg bg))))))
    (when cache
      (setf (cached-surface font) surf))
    surf))

font-exampleの結果は次のような画面になってちゃんと表示される。

さらに、フォント定義クラスのインスタンスをwith-initマクロの中でinitialise-fontで初期化することによって、draw-string系の関数に色々なフォントを指定することができる。

(defparameter *ttf-font-definition-small*
  (make-instance 'sdl:ttf-font-definition
     :size 16
     :filename "/usr/share/fonts/truetype/takao-gothic/TakaoGothic.ttf"))

(defparameter *ttf-font-definition-normal*
  (make-instance 'sdl:ttf-font-definition
     :size 24
     :filename "/usr/share/fonts/truetype/takao-gothic/TakaoGothic.ttf"))

(defparameter *ttf-font-definition-big*
  (make-instance 'sdl:ttf-font-definition
     :size 32
     :filename "/usr/share/fonts/truetype/takao-gothic/TakaoGothic.ttf"))

(defvar *ttf-font-small*)
(defvar *ttf-font-normal*)
(defvar *ttf-font-big*)

(defun font-example ()
  (sdl:with-init ()
    (sdl:window 600 100 :title-caption "SDL-TTF Font Example" :icon-caption "SDL-TTF Font Example")
    (setf (sdl:frame-rate) 30)
    (sdl:fill-surface sdl:*white* :surface sdl:*default-display*)

    (setf *ttf-font-small* (sdl:initialise-font *ttf-font-definition-small*)
	  *ttf-font-normal* (sdl:initialise-font *ttf-font-definition-normal*)
	  *ttf-font-big* (sdl:initialise-font *ttf-font-definition-big*))
    
    (sdl:draw-string-solid-* "Text UTF8 - Solid 日本語テスト" 0 0
                             :color sdl:*black*
			     :font *ttf-font-small*)
    (sdl:draw-string-shaded-* "Text UTF8 - Shaded 日本語テスト" 0 32
                              sdl:*black*
                              sdl:*yellow*
			      :font *ttf-font-normal*)
    (sdl:draw-string-blended-* "Text UTF8 - Blended 日本語テスト" 0 64
                               :color sdl:*black*
			       :font *ttf-font-big*)
    (sdl:update-display)
    (sdl:with-events ()
      (:quit-event () t)
      (:video-expose-event () (sdl:update-display))
      (:key-down-event ()
       (when (sdl:key-down-p :sdl-key-escape)
         (sdl:push-quit-event))))))

このfont-exampleの結果はこう。