[cl-opengl-devel] Texture Example

[Martin Kielhorn]

Hi,
I am new to Lisp and experimenting with cl-opengl.
I really wanted to see how I can use textures in Lisp
(without having to copy the elements of the array too much).
Strangely there was no example in the cl-opengl package.

So this is what I've come up with.
Copy the code to minimal_texture_example.lisp and run
sbcl --load minimal_texture_example.lisp

It will open a window. Press 't' to create a texture and
'space' to fill it with some pattern.

The interesting part is that with sb-sys:without-gcing
and sb-sys:vector-sap the starting-pointer of the array can be
extracted and used in gl:tex-sub-image-2d.

I also wrote a small wrapper library in C to capture
YUV-frames from a webcam with v4l2 and display the data with
(gl:tex-sub-image-2d :texture-rectangle-nv 0 0 0 +width+ +height+
                                    :ycbcr-mesa
:unsigned-short-8-8-rev-mesa
                                    (video-take))
It is quite fast.

Martin Kielhorn

#| use cl-opengl to display some texture |#
(require 'cl-glut)
(defpackage texture-example
  (:use :cl))
(in-package texture-example)

(defparameter +width+ 512) ; must be power of two
(defparameter +height+ 512) ; must be power of two
(defparameter +window-width+ 800)
(defparameter +window-height+ 600)

(defclass window (glut:window)
  ((tex :accessor tex :initform #x0))
  (:default-initargs :pos-x 100 :pos-y 100
             :width +window-width+ :height +window-height+
             :mode '(:double :rgb)))

(defmethod glut:display ((win window))
  "draw a textured QUAD"
  (gl:clear :color-buffer-bit)
  (gl:load-identity)
  (gl:with-primitive :quads
    (gl:tex-coord 0 0)(gl:vertex +width+ +height+)
    (gl:tex-coord 1 0)(gl:vertex 0       +height+)
    (gl:tex-coord 1 1)(gl:vertex 0       0)
    (gl:tex-coord 0 1)(gl:vertex +width+ 0))
  (glut:swap-buffers))

(defmethod glut:reshape ((win window) width height)
  (when (zerop height)
    (setq height 1))
  (gl:viewport 0 0 width height)
  (gl:matrix-mode :projection)
  (gl:load-identity)
  (gl:ortho 0 +window-width+ 0 +window-height+ -1 1)
  (gl:matrix-mode :modelview)
  (gl:load-identity))

(defvar *field* (make-array (* +width+ +height+ 4)
                :element-type '(unsigned-byte 8)))

(defun update-tex (win)
  (unless (eq (tex win) #x0)
    (loop for i below +width+ do
      (loop for j below +height+
        do
        (let ((pixel (* 4 (+ i (* +width+ j)))))
          (setf (aref *field* (+ 0 pixel)) (mod i 215)
            (aref *field* (+ 1 pixel)) (mod j 215)))))
    (sb-sys:without-gcing
      (let ((addr (sb-sys:vector-sap *field*)))
    (gl:tex-sub-image-2d :texture-2d 0 0 0 +width+ +height+
             :rgba :unsigned-byte addr)))))

(defmethod glut:keyboard ((win window) key x y)
  (declare (ignore x y))
  (case key
    ;; switch textures on/off
    (#\t (if (eq (tex win) #x0)
         (progn (setf (tex win) (first (gl:gen-textures 1)))
            (gl:enable :texture-2d)
            (gl:bind-texture :texture-2d (tex win))
            (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
            (gl:tex-parameter :texture-2d :texture-mag-filter :nearest)
            (gl:tex-image-2d :texture-2d 0 :rgba +width+ +height+ 0
                     :rgba :unsigned-byte (cffi:null-pointer)))
         (progn (gl:delete-textures (list (tex win)))
            (gl:disable :texture-2d)
            (setf (tex win) #x0))))
    (#\space (update-tex win))
    (#\q (glut:destroy-current-window)
     (sb-ext:quit)))
  (glut:post-redisplay))

(defmethod glut:idle ((win window))
  (sleep (/ 1. 30.))
  (glut:post-redisplay))

(defun view ()
  (glut:display-window (make-instance 'window)))

(view)
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cl-opengl-devel/attachments/20080917/88188cf7/attachment.html>