2009/04/26

イメージ

『OpenGLプログラミングガイド 第2版』はずっととばして第8章へ。イメージを。

glut:reshape のときに glut:width と glut:height が自動的に更新されてほしい気がするだが気のせいだろうか。

(defmethod glut:reshape ((window glut:window) w h)
(setf (glut:width window) w
(glut:height window) h))
というメソッドが定義済であって欲しい。

image.c の cl-opengl バージョン。ひさしぶりに loop ではなく dotimes を使った気がする。

(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cl-opengl)
(require :cl-glu)
(require :cl-glut))

(defconstant +width+ 64)
(defconstant +height+ 64)

(defclass image-window (glut:window)
((image :initform (make-array (* +height+ +width+ 3))
:accessor image)
(zoom-factor :initform 1.0
:accessor zoom-factor))
(:default-initargs :mode '(:rgb :single )))

(defmethod make-check-image ((window image-window))
(with-accessors ((image image)) window
(let ((index -1))
(dotimes (i +height+)
(dotimes (j +width+)
(let ((c (* (logxor (if (zerop (logand i #x8)) 1 0)
(if (zerop (logand j #x8)) 1 0))
255)))
(setf (aref image (incf index)) c)
(setf (aref image (incf index)) c)
(setf (aref image (incf index)) c)))))))

(defmethod glut:display-window :before ((w image-window))
(make-check-image w)
(gl:clear-color 0 0 0 0)
(%gl:shade-model :flat)
(gl:pixel-store :unpack-alignment 1))

(defmethod glut:display ((window image-window))
(gl:clear :color-buffer-bit) ; クリア
(gl:raster-pos 0 0)
(gl:draw-pixels +width+ +height+ :rgb :unsigned-byte (image window))
(%gl:flush))

(defmethod glut:reshape ((window image-window) w h)
(setf (glut:width window) w
(glut:height window) h)
(%gl:viewport 0 0 w h)
(%gl:matrix-mode :projection)
(%gl:load-identity)
(glu:ortho-2d 0 w 0 h)
(%gl:matrix-mode :modelview)
(%gl:load-identity))

(defmethod glut:motion ((window image-window) x y)
(with-accessors ((zoom-factor zoom-factor)) window
(let ((screen-y (- (glut:height window) y)))
(print (list (glut:height window) screen-y y))
(gl:raster-pos x screen-y)
(%gl:pixel-zoom zoom-factor zoom-factor)
(%gl:copy-pixels 0 0 +width+ +height+ :color)
(%gl:pixel-zoom 1 1)
(%gl:flush))))

(defmethod glut:keyboard ((window image-window) key x y)
(declare (ignore x y))
(with-accessors ((zoom-factor zoom-factor)) window
(case key
((#\r #\R)
(setf zoom-factor 1)
(glut:post-redisplay))
(#\z
(when (<= 3 (incf zoom-factor 0.5))
(setf zoom-factor 3)))
(#\Z
(when (<= (decf zoom-factor 0.5) 0.5)
(setf zoom-factor 0.5)))
((#\Esc #\q) (glut:destroy-current-window)))))

;;(glut:display-window (make-instance 'image-window))

0 件のコメント: