GaucheとSDLで図形言語 ２
ライブラリとかはインストールできたので、あとはプログラムを書くだけ。
とはいえ、素のSDLは、点を打つ関数しかないので、線を引く関数から始めなければならない。
線を引く関数は、二日ほど悩んで以下のように書いた。*1
うん。いや、まあ済まない。汚いコードだとは分かってる。でも動いて嬉しかったんです。線引いただけなのに。
(use sdl)
;;
;; wait-key
;; wait until a escape key is pressed and released
;;
(define (wait-key)
(define (wait-key-helper e)
(let ((count (sdl-poll-event e)))
(cond ((and (> count 0)
(= SDL_KEYUP (sdl-event-type e))
(= SDLK_ESCAPE (sdl-event-key-keysym-sym e)))
#t)
(else
(sdl-delay 10)
(wait-key-helper e)))))(let ((e (sdl-make-event)))
(wait-key-helper e)));;
;; run-test
;;
(define X_SIZE 512)
(define Y_SIZE 512)
(define SCREEN #f)
(define LINE-COLOR #f)
(define (set-screen screen)
(set! SCREEN screen))(define (set-line-color color)
(set! LINE-COLOR color))(define (init-sdl-simple)
(sdl-init SDL_INIT_VIDEO)
;; 画像を表示する場合は、sdl-set-video-modeの第三引数を画像のBitPerPixelsにあわせる必要がある。
(set-screen (sdl-set-video-mode X_SIZE Y_SIZE 24 0))
(set-line-color (sdl-map-rgb (sdl-surface-pixel-format SCREEN) 0 0 0))
(print "init...")
(sdl-wm-set-caption "図形言語だよ" "")
)(define (do-something do-some)
(if (sdl-must-lock SCREEN)
(sdl-lock-surface SCREEN))
;; 白い画面で初期化
(sdl-fill-rect SCREEN #f (sdl-map-rgb (sdl-surface-pixel-format SCREEN) 255 255 255))
(do-some SCREEN)
(if (sdl-must-lock SCREEN)
(sdl-unlock-surface SCREEN))
(sdl-flip SCREEN))(define (sdl-put-pixel screen x y pixel)
;; 画面外には置けない。
(if (and (> x 0) (> y 0) (< x X_SIZE) (< y Y_SIZE))
(put-pixel screen x y pixel)))(define (put-pixel-linex screen pixel x1 x2 y2 d)
(if (<= x1 x2)
(begin (pixel screen x1 (round->exact (+ (*. d (- x1 x2)) y2)))
(put-pixel-linex screen pixel (+ x1 1) x2 y2 d))))(define (put-pixel-liney screen pixel y1 x2 y2 d)
(if (<= y1 y2)
(begin (pixel screen (round->exact (+ (*. d (- y1 y2)) x2)) y1)
(put-pixel-liney screen pixel (+ y1 1) x2 y2 d))))(define (draw-line-SDL screen pixel x1 y1 x2 y2)
(let )((dx (- x1 x2))(
(dy (- y1 y2)))
(cond ((= dx dy 0)
(sdl-put-pixel screen x1 y1 pixel))
)((>= (abs dx) (abs dy))(
(if (> x1 x2)
(put-pixel-linex screen pixel x2 x1 y1 (/. dy dx))
(put-pixel-linex screen pixel x1 x2 y2 (/. dy dx))))
(else
(if (> y1 y2)
(put-pixel-liney screen pixel y2 x1 y1 (/. dx dy))
(put-pixel-liney screen pixel y1 x2 y2 (/. dx dy)))))));; SDLにおいて、原点は、左上
;; 図形言語において原点は 真ん中 ・・・暫定
(define (transform-SDL-x-rel v)
(round->exact (* X_SIZE (/ (car v) 2.0))))(define (transform-SDL-y-rel v)
(round->exact (* Y_SIZE (/ (cdr v) 2.0))))(define (transform-SDL-x v)
(round->exact (* X_SIZE (/ (+ 1.0 (car v)) 2.0))))(define (transform-SDL-y v)
(round->exact (* Y_SIZE (- 1.0 (/ (+ 1.0 (cdr v)) 2)))))
;; (- (round->exact (/. Y_SIZE 2.0)) (transform-SDL-y-rel v)))
(define (draw-line-internal v1 v2 pixel)
(draw-line-SDL SCREEN pixel
(transform-SDL-x v1)
(transform-SDL-y v1)
(transform-SDL-x v2)
(transform-SDL-y v2)))(define (draw-line v1 v2)
;; v1 v2はともに (0.0 0.0)みたいな形を想定
(draw-line-internal v1 v2
(lambda (screen x y)
(sdl-put-pixel screen x y LINE-COLOR))))
(define (some screen)
(draw-line (cons 0.0 0.0) (cons 0.5 1.0))
(draw-line (cons -0.7 0.0) (cons 0.5 1.0))
(draw-line (cons 0.0 0.0) (cons 0.5 -1.0))
(draw-line (cons -0.7 0.0) (cons 0.5 -1.0)));; main部分
(define (run-test)
(init-sdl-simple)(do-something some)
(wait-key)
(sdl-quit))
(run-test)
実行結果
しかし、はてな記法の脚注記法(( 〜))で、勝手に脚注がつく。
Lisp/schemeは、括弧のお化けなんだから当たり前といえば当たり前なんだけど、
他の人はどうしてるんだろうか。
いちいち回避するために )(をつけてるんだろうか。
*1:x方向に pixelをずらして、dy/dxを掛けてy座標求めるだけだと、xの傾きが急な時、線が飛び飛びになってしまう問題に悩まされました。
