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

なんだっけな自動で画面サイズにでっかくテキストを表示するとこまで書いた。あと[bgImage:hoge.png]とかで画像を読みこめるようにした。画像読み込みは適当。元サイズで(0,0)に描画するだけ。あと上にテキスト領域かぶると白背景で塗り潰される。
SDL_ttfとSDL_imageをつかってる。SDL_gfxとか使った方がよさげかも。なんかaptでいれられなかったのとねむいのとであとまわし。

#!/usr/bin/env gosh
(use srfi-13)
(use srfi-43)
(use c-wrapper)
(c-load '("Xlib.h" "SDL.h" "SDL_ttf.h" "SDL_image.h" "sdl_helper.c")
        :cppflags "-I/usr/include/X11"
	:cppflags-cmd "sdl-config --cflags"
	:libs "-lX11 -L/usr/lib/SDL -lSDL -lSDL_ttf -lSDL_image"
	:import `(XOpenDisplay
		  DefaultScreen
		  DisplayWidth DisplayWidthMM
		  DisplayHeight DisplayHeightMM
		  ,(lambda (header sym)
                        (#/\/SDL\/.*\.h$/ header))
		  run_sdl_main
		  NULL)
        :compiled-lib "sdllib")

(define *fontpath* "font.ttf")
(define *display* (XOpenDisplay NULL))
(define *screen* (DefaultScreen *display*))
(define *screen-w* (DisplayWidth *display* *screen*))
(define *screen-h* (DisplayHeight *display* *screen*))
(define *screen-w-mm* (DisplayWidthMM *display* *screen*))
(define *screen-h-mm* (DisplayHeightMM *display* *screen*))

(define (max-font-size)
  (+ *screen-h* (* *screen-h-mm* 5/254)))

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

(define (assq-cdr 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 (cast (ptr <c-char>) *fontpath*) (cast <c-int> size))))
	(hash-table-put! *font-table* size font)
	font)))
(define *image-table* (make-hash-table))
(define (open-image path)
  (if (hash-table-exists? *image-table* path)
      (hash-table-get *image-table* path)
      (let ((image (IMG_Load (cast (ptr <c-char>) path))))
	(hash-table-put! *image-table* path image)
	image)))

(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 *commands-table* (make-hash-table))
(hash-table-put!
 *commands-table* 'bgImage
 (lambda (page . args)
   (let-optionals*
    args ((image "default.png"))
    (append! page `((image . ,(open-image image)))))))
 
(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! input-vector)
  (vector-map!
   (lambda (index page)
     (let* ((size (assq-cdr 'size page))
	    (text (assq-cdr 'text page))
	    (font (open-font size)))
       (append page `((surf . ,(map (cut render-line font <>) text))))))
   input-vector))

(define (make-printer screen)
  (let
    ((bgrect (make <SDL_Rect>))
     (width (ref screen 'w))
     (height (ref screen 'h)))
    (set! (ref bgrect 'w) width)
    (set! (ref bgrect 'h) height)
    (lambda (page)
      (let*
	  ((size (assq-cdr 'size page))
	   (text (assq-cdr 'text page))
	   (lines (assq-cdr 'surf page))
	   (line-height (ref (car lines) 'h))
	   (page-height (* line-height (length lines)))
	   (image (assq-cdr 'image page)))
        (SDL_FillRect screen (ptr bgrect) -1)
        (SDL_UpdateRect screen 0 0 width height)
	(when image
	      (SDL_BlitSurface image (ptr bgrect) screen (ptr (make-rect 0 0 0 0))))
        (let loop
          ((lines lines)
           (y (/ (- height page-height) 2)))
          (if (null? lines)
            #t
            (let ((line (car lines)))
              (SDL_BlitSurface
	       line NULL screen (ptr (make-rect 0 y 0 0)))
              (loop (cdr lines) (+ y line-height)))))
        (SDL_Flip screen)))))

(define (apply-cmd! input-vector)
  (define (apply-page! page)
    (let ((text (assq 'text page)))
      (for-each
       (lambda (line)
	 (and-let* (;(def-match (#/^\[def:([^:]+):([^\]]+)$\]/ line))
		    (match (#/^\[([^:]+):([^\]]+)\]$/ line))
		    (str (match 1))
		    (sym (string->symbol str))
		    (exists (hash-table-exists? *commands-table* sym))
		    (command! (hash-table-get *commands-table* sym)))
		   (command! page (match 2))))
       (cdr text))
      (set-cdr! text
		(fold
		 (lambda (line lines) (if (#/^\[[^\]]+\]$/ line) lines (cons line lines)))
		 '()
		 (cdr text))))
    page)
  (vector-for-each
   (lambda (index page)
     (apply-page! page))
   input-vector)
  input-vector)

(define *unit* 5)
(define (about-eq? a b)
  (and (<= a (+ b *unit*)) (>= a (- b *unit*))))
(define (fit-pages! screen-w screen-h input-vector)
  (define text-w (make <c-int>))
  (define text-h (make <c-int>))
  (define (fit-line line max-size)
    (let loop ((low 0) (upp max-size))
      (let* ((mid (/. (+ low upp) 2))
	     (font (open-font mid)))
	(TTF_SizeUTF8 font line (ptr text-w) (ptr text-h))
	(let ((w (cast <integer> text-w)) (h (cast <integer> text-h)))
	  (cond
	   ((or (and (about-eq? w screen-w) (< h screen-h))
		(and (about-eq? h screen-h) (< w screen-w))) mid)
	   ((or (>= w screen-w) (>= h screen-h)) (loop low mid))
	   (else (loop mid upp)))))))
  (define (fit-page! page)
    (let* ((size (assq-cdr 'size page))
	   (text (assq-cdr 'text page))
	   (lines (fold
		   (lambda (line lines)
		     (if (string-null? line)
			 lines
			 (cons line lines)))
		   '()
		   text)))
      (set-cdr! (assq 'size page) (apply min (map (cut fit-line <> size) lines)))
      page))
  (vector-map!
    (lambda (index page)
      (fit-page! page))
    input-vector))

(define (start-talk screen-w screen-h input-vector)
  (SDL_Init SDL_INIT_VIDEO)
  (TTF_Init)
  (apply-cmd! input-vector)
  (fit-pages! screen-w screen-h input-vector)
  (display "Return any key to start presentation ") (flush) (read-char)
  (and-let* ((screen (SDL_SetVideoMode *screen-w* *screen-h* 16 SDL_HWSURFACE))
	 (printer (make-printer screen)))
    (make-surfaces! input-vector)
    (wait-event printer input-vector (- (vector-length input-vector) 1) 0))
  (TTF_Quit)
  (SDL_Quit))
(define (start-talk-with-file screen-w screen-h maxsize input)
  (let* ((input-pages (string-split (port->string input) "\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 screen-w screen-h input-vector)))

(define (sdl-main argc argv)
  (if (< argc 2)
    (print-usage (cast <string> (ref argv 0)))
    (start-talk-with-file
     *screen-w* *screen-h* (max-font-size)
     (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