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

高橋メソッドみたいにでっかい自動ででっかいテキスト表示するところまでできた。
プログラミングGaucheを読み進めながらやっているので、書いてる時間が違う部分で全然違う書き方してたりすると思う。というか、Schemeのコードて書き方固まるほど書いたことなかったし。
cutはソースコードの見通しをかなりよくしてくれる。call/ccも、きっとエライ人にしかわからん謎機能なんだろうなと思ってたけど、大域脱出に使うには普通に便利だった。やっぱダメだな、コード書かんと。

ディスプレイは1024x768、72dpiだと決め付けてはじまる。あとSDL_SetVideoModeにSDL_FULLSCREENを渡してないから、ウィンドウに枠が表示される環境だとずれるんじゃないかな。sevilwmにすればいいんだよ。windowsとかはそもそもc-wrapperが動かない(よねたぶん)から関係無い。

画像表示機能がまだ。習作なので画像表示できるまでやったらそれでいいことにしよう。

#!/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* "font.ttf")
(define *screen-w* 1024)
(define *screen-h* 768)
(define *maxsize* *screen-h*)

(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 *font-table* (make-hash-table))
(define (open-font size)
  (if (hash-table-exists? *font-table* size)
    (hash-table-get *font-table* size)
    (let ((font (TTF_OpenFont *fontpath* size)))
      (hash-table-put! *font-table* size font)
      font)))
(define (render-line font line)
  (if (= 0 (string-length line))
    (TTF_RenderUTF8_Solid font " " COLOR_WHITE)
    (TTF_RenderUTF8 font line COLOR_BLACK COLOR_WHITE)))

(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-surfaces screen input-vector)
  (vector-map!
    (lambda (index page)
      (let* ((size (assq-value 'size page))
             (text (assq-value 'text page))
             (font (open-font size)))
        `((size . ,size)
          (text . ,text)
          (surf . ,(map (cut render-line font <>) text)))))
    input-vector)
  input-vector)

(define (make-printer screen)
  (let
    ((bgrect (make <SDL_Rect>)))
    (set! (ref bgrect 'w) *screen-w*)
    (set! (ref bgrect 'h) *screen-h*)
    (lambda (page)
      (let*
        ((size (assq-value 'size page))
         (text (assq-value 'text page))
         (lines
           (let ((surfaces (assq-value 'surf page)))
             (if surfaces
               surfaces
               (map (cut render-line (open-font size) <>) text)))))
        (SDL_FillRect screen (ptr bgrect) -1)
        (SDL_UpdateRect screen 0 0 *screen-w* *screen-h*)
        (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-w screen-h input-vector)
  (define (fit-line line max-size)
    (define (render size) (TTF_RenderUTF8_Solid (open-font size) line COLOR_BLACK))
    (let iter
      ((size max-size))
      (let* ((surf (render size))
             (surf-w (ref surf 'w)))
        (if (< surf-w screen-w)
          size
          (iter (- size 10))))))
  (define (fit-page page)
    (let* ((size (assq-value 'size page))
           (text (assq-value 'text page))
           (lines (fold
                    (lambda (line lines)
                      (if (= 0 (string-size line))
                        lines
                        (cons line lines)))
                    '()
                    text)))
      `((size . ,(apply min (map (cut fit-line <> size) lines)))
        (text . ,text))))
  (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 ((fit-vector (fit-pages *screen-w* *screen-h* input-vector)))
    (display "Return any key to start presentation ")
    (flush)
    (read-char)
    (let* ((screen (SDL_SetVideoMode *screen-w* *screen-h* 16 SDL_HWSURFACE))
           (printer (make-printer screen))
           (surfaces (make-surfaces screen fit-vector)))
      (wait-event printer surfaces (- (vector-length surfaces) 1) 0)))
  ;      (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)
                 (let ((lines (string-split (string-trim-right page #\newline) #\newline)))
                   (vector-set! vec i
                                `((size . ,(/ *maxsize* (length lines)))
                                  (text . ,lines))))
                 (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"))