Animação com o cl-opengl

Ontem de noite eu adaptei um exemplo do livro OpenGL SuperBible para o lisp. É um programinha que desenha um retângulo que fica andando na tela. Com ajuda do Luís Oliveira eu consegui uasr o evento de tick para controlar a velocidade da animação.

Eu adicionei um efeito com a cor, ela vai mudando conforme o triangulo anda pela tela. Assim o programa fica um pouco menos simplório.

O programa segue abaixo.


;;
;; Bounce Rectangles
;;
;; Adapted from OpenGL Superbible pg. 62
;;

(declaim (optimize (speed 3) (debug 0) (safety 0)))

(eval-when (:load-toplevel :compile-toplevel)
(asdf:oos 'asdf:load-op :cl-glut))

(defclass bounce-window (glut:window)
((x :initform 0)
(y :initform 0)
(range :initform 100.0)
(window-height :initform 100.0)
(window-width :initform 100.0)
(size :initform 10)
(xstep :initform 2)
(ystep :initform 3)
(terminated :accessor terminated :initform nil))

(:default-initargs
;; Call tick event every 25 milis (approx.)
:tick-interval 25
:width 600 :height 400 :pos-x 100 :pos-y 100
:mode '(:double :rgb) :title "Bounce Rectangles"))

(defgeneric color (self color x y))

(defmethod glut:reshape ((win bounce-window) w h)
(gl:viewport 0 0 w h)
(gl:matrix-mode :projection)
(gl:load-identity)
(with-slots (range window-height window-width) win
(let ((aspect-ratio (/ (float w) (float h))))
(declare (float aspect-ratio))
(if (<= w h)
(progn
(setf window-height (/ range aspect-ratio))
(setf window-width range)
(gl:ortho (- range) range (- window-height) window-height range (- range)))
(progn
(setf window-height range)
(setf window-width (* range aspect-ratio))
(gl:ortho (- window-width) window-width (- range) range range (- range))))))
(gl:matrix-mode :modelview)
(gl:load-identity))

;; Calculated color by (x,y)
(defmethod color ((self bounce-window) color x y)
(with-slots (window-width window-height) self
(let ((alpha (/ (* 2 (abs x)) window-width))
(beta (/ (* 2 (abs y)) window-height)))
(case color
(R alpha)
(B beta )
(G (- alpha) beta)))))

;; Change the vertex color according to (x, y)
(defmethod color-vertex ((self bounce-window) x y)
(gl:color (color self 'R x y) (color self 'G x y) (color self 'B x y))
(gl:vertex x y))

(defmethod glut:display ((self bounce-window))
(gl:clear :color-buffer)
(with-slots (x y xstep ystep size) self
(gl:begin :polygon)
(color-vertex self (- x size) (- y size))
(color-vertex self (+ x size) (- y size))
(color-vertex self (+ x size) (+ y size))
(color-vertex self (- x size) (+ y size))
(gl:end))
(glut:swap-buffers))

;; Update rectangle position
(defmethod glut:tick ((self bounce-window))
(with-slots (x y xstep ystep size range terminated window-width window-height) self
(incf x xstep)
(incf y ystep)

(when (> (+ (abs x) size) window-width)
(setf xstep (- xstep)))

(when (> (+ (abs y) size) window-height)
(setf ystep (- ystep)))

;; Check bound. THis is in case the window is made
;; smaller while rectangel is bouncing and the
;; rectangle suddenly find itself outside the new
;; clipping volume
(if (> x (+ window-width (- size) xstep))
(setf x (+ window-width (- size) -1))
(if (< x (- (+ window-width xstep)))
(setf x (- (+ window-width 1)))))

(if (> y (+ window-height (- size) ystep))
(setf y (+ window-height (- size) -1))
(if (< y (- (+ window-height ystep)))
(setf y (- (+ window-height 1)))))

;; Don't post-redisplay if window is closed (otherwise crash sbcl)
(if (not terminated)
(glut:post-redisplay))))


(defmethod glut:keyboard ((win bounce-window) key x y)
(declare (ignore x y))
(when (or (eql key #\Esc) (eql key #\q))
(glut:close win)))

(defmethod glut:close ((win bounce-window))
(glut:disable-tick win)
(setf (terminated win) t)
(glut:destroy-current-window))

(defun bounce-rectangle ()
(let ((win (make-instance 'bounce-window)))
(glut:display-window win)))