Gauche + c-wrapper + SDL でつくるプレゼンソフト(1)

Scheme Gauche

gauche.nightで話してきたことを、卒研配属された研究室の合宿先で話すことになった。gauche.nightと客層が全然違う(あんまプログラミング言語萌え！ な研究室じゃないし)から説明とか増量とかする必要ある。とかはまあいいんですけど「それでそのSchemeとかGaucheってどこで使われてるの？」みたいな定番の質問がまずある気がしたので「まさに今見てるプレゼンツールがGaucheで書いたものだよ！」メソッドで行こうかなと思った。
そういうわけで「Gauche + c-wrapper + SDL でつくるプレゼンソフト」。


gaucheでSDL使うなら、gauche-sdlとかもあるんですけど、なんか普通にtypoなバグあったりして、なんか微妙だなと。そこでc-wrapperという、Cのソースコードを読んでライブラリのバインディングを自動でやってくれてしまう鬼すごい子を知りまして。こっち使ってSDL叩いた方が楽そうだと感じました。c-wrapperすごい。
ちょうどプログラミングGauche手に入れたばかりだけど、ひどく役にたった。実は割とscheme全然わかってない人なので。foldとかemacsの使い方あたりから。


「----」区切りのテキストを全画面表示して左右でページ切り替え、qかEscapeで終了するところまで書いた。ねむいからここまで。

#!/usr/bin/env gosh
(use srfi-13)
(use srfi-43)
(use c-wrapper)
(c-load '("SDL.h" "SDL_ttf.h" "stdio.h" "stdlib.h" "sdl_helper.c")
        :cppflags-cmd "sdl-config --cflags"
        :libs-cmd "sdl-config --libs; echo '-lSDL_ttf'"
        :import (list (lambda (header sym)
                        (#/\/SDL\/.*\.h$/ header))
                      'NULL
                      'run_sdl_main)
        :compiled-lib "sdllib")

(define *fontpath* "kochi-gothic-subst.ttf")

(define (print-usage script)
  (display "usage: ")
  (display script)
  (print " spres-file"))

(define (assq-value key alist)
  (let ((value (assq key alist)))
    (if value
      (cdr value)
      #f)))

(define (make-rect x y w h)
  (let ((rect (make <SDL_Rect>)))
    (set! (ref rect 'x) x)
    (set! (ref rect 'y) y)
    (set! (ref rect 'w) w)
    (set! (ref rect 'h) h)
    rect))

(define (make-color r g b)
  (let ((color (make <SDL_Color>)))
    (set! (ref color 'r) r)
    (set! (ref color 'g) g)
    (set! (ref color 'b) b)
    color))

(define (make-char-array ls)
  (let ((array (make (c-array (ptr <c-char>) (length ls)))))
    (let iter
      ((index 0) (ls ls))
      (if (null? ls)
        array
        (begin
          (set! (ref array index) (cast (ptr <c-char>) (car ls)))
          (iter (+ index 1) (cdr ls)))))))

(define COLOR_BLACK   (make-color 0 0 0))
(define COLOR_WHITE   (make-color 255 255 255))

(define (wait-event printer input-vector last-page init-index)
  (define event (make <SDL_Event>))
  (define (print-page index)
    (printer (vector-ref input-vector index))
    index)
  (define (run-event index quit)
    (let ((sym (ref* event 'key 'keysym 'sym)))
      (cond
        ((or (= sym SDLK_ESCAPE) (= sym SDLK_q)) (quit #t))
        ((= sym SDLK_RIGHT)
         (let ((index+ (+ index 1)))
           (if (> index+ last-page)
             (print-page 0)
             (print-page index+))))
        ((= sym SDLK_LEFT)
         (let ((index- (- index 1)))
           (if (< index- 0)
             (print-page last-page)
             (print-page index-))))
        (else index))))
  (print-page init-index)
  (call/cc
    (lambda (quit)
      (let poll-event
        ((index init-index))
        (SDL_Delay 100)
        (if
          (and (> (SDL_PollEvent (ptr event)) 0)
            (= SDL_KEYDOWN (ref event 'type)))
          (poll-event (run-event index quit))
          (poll-event index))))))

(define (make-printer screen)
  (let*
    ((width (ref screen 'w))
     (height (ref screen 'h))
     (bgrect (make <SDL_Rect>)))
    (set! (ref bgrect 'w) width)
    (set! (ref bgrect 'h) height)
    (lambda (page)
      (let*
        ((size (assq-value 'size page))
         (text (assq-value 'text page))
         (font (TTF_OpenFont *fontpath* size))
         (lines
           (map
             (lambda (line)
               (if
                 (= 0 (string-size line))
                 (TTF_RenderUTF8 font " " COLOR_BLACK COLOR_WHITE)
                 (TTF_RenderUTF8 font line COLOR_BLACK COLOR_WHITE)))
             text)))
        (SDL_FillRect screen (ptr bgrect) -1)
        (SDL_UpdateRect screen 0 0 width height)
        (let loop
          ((lines lines)
           (y 0))
          (if (null? lines)
            #t
            (let ((line (car lines)))
              (SDL_BlitSurface
                line NULL screen (ptr (make-rect 0 y 0 0)))
              (loop (cdr lines) (+ y (ref line 'h))))))
        (SDL_Flip screen)))))

(define (fit-pages screen input-vector)
  (define screen-w (ref screen 'w))
  (define screen-h (ref screen 'h))
  (define (fit-page page)
    (define lines
      (fold
        (lambda (line lines)
          (if (= 0 (string-size line))
            lines
            (cons line lines)))
        '()
        (assq-value 'text page)))
    page)
  (vector-map!
    (lambda (index page)
      (fit-page page))
    input-vector)
  input-vector)

(define (start-talk input-vector)
  (SDL_Init SDL_INIT_VIDEO)
  (TTF_Init)
  (let* ((screen (SDL_SetVideoMode 1024 768 16 (logior SDL_HWSURFACE SDL_FULLSCREEN)))
         (printer (make-printer screen))
         (fit-vector (fit-pages screen input-vector)))
    (wait-event printer fit-vector (- (vector-length fit-vector) 1) 0))
  (TTF_Quit)
  (SDL_Quit))
(define (start-talk-with-file input)
  (let* ((input-text (port->string input))
         (input-pages (string-split input-text "\n----\n"))
         (input-vector
           (fold
             (let ((i 0))
               (lambda (page vec)
                 (vector-set! vec i
                              `((size . 70)
                                (text . ,(string-split (string-trim-right page #\newline) #\newline))))
                 (inc! i)
                 vec))
             (make-vector (length input-pages))
             input-pages)))
    (start-talk input-vector)))

(define (sdl-main argc argv)
  (if (< argc 2)
    (print-usage (cast <string> (ref argv 0)))
    (start-talk-with-file
      (open-input-file (cast <string> (ref argv 1)))))
  0)

(define (main args)
  (run_sdl_main (length args) args sdl-main))

; (main '("spres.scm" "hoge.stxt"))

test