glrgba.lisp

   1
   2 (in-package :glrepl)
   3
   4
   5 ;; to do -- get these from alexandria or kmcrl or somesuch
   6 (defmacro with-gensyms ((&rest names) &body body)
   7   `(let ,(loop for n in names collect `(,n (gensym)))
   8      ,@body))
   9
  10 (defmacro once-only ((&rest names) &body body)
  11   (let ((gensyms (loop for n in names collect (gensym))))
  12     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  13        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  14           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  15              ,@body)))))
  16
  17 (defmacro with-opengl (&body forms)
  18   (with-gensyms (error-sym)
  19     `(progn ,@forms
  20             (let ((,error-sym  (gl:get-error)))
  21               (unless ,error-sym
  22                 (error "OpenGL Error ~A~%"
  23                        (case ,error-sym
  24                          (gl:+INVALID-ENUM+ "Invalid Enum")
  25                          (gl:+INVALID-VALUE+ "Invalid value")
  26                          (gl:+INVALID-OPERATION+ "Invalid Operation")
  27                          (gl:+OUT-OF-MEMORY+ "Out of memory")
  28                          (gl:+STACK-OVERFLOW+ "Stack overflow")
  29                          (gl:+STACK-UNDERFLOW+ "Stack underflow"))))))))
  30
  31 (defclass rgba-image  ()
  32   ((name :accessor name-of)
  33    (width :accessor width-of :initform 0)
  34    (height :accessor height-of :initform 0)
  35    (format :reader format-of :initform gl:+rgba+)
  36    (bpp :reader bpp-of :initform 4)
  37    (data :accessor data-of)
  38    (size :accessor size-of))
  39   (:documentation "Data  for an opengl RGBA texture"))
  40
  41 (defmethod initialize-instance :after ((self rgba-image) &key width height)
  42   "Create a sized rgba texture"
  43   (setf (width-of self) width)
  44   (setf (height-of self) height)
  45   (setf (slot-value self 'name) (cffi:foreign-alloc :uint32))
  46   (with-opengl
  47     (gl:gen-textures 1 (name-of self))
  48     (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
  49     (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-s+ gl:+repeat+)
  50     (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-wrap-t+ gl:+repeat+)
  51     (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-mag-filter+ gl:+linear+)
  52     (gl:tex-parameter-i gl:+texture-2d+ gl:+texture-min-filter+ gl:+linear+)
  53     (gl:pixel-store-i gl:+unpack-alignment+ 1)
  54     (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+blend+))
  55   (setf (slot-value self 'data)
  56         (cffi:foreign-alloc :uint32
  57                             :count (* (width-of self) (height-of self))
  58                             :initial-element 0)))
  59
  60 (defmethod update-image ((self rgba-image))
  61   "Upload an RGBA texture"
  62   (with-opengl
  63     (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
  64     (gl:tex-image-2d gl:+texture-2d+ 0 gl:+rgba+
  65                      (width-of self) (height-of self)
  66                      0 gl:+rgba+ gl:+unsigned-byte+ (data-of self))))
  67
  68
  69 (defgeneric render (self &key target))
  70
  71 (defmethod render ((self rgba-image) &key target)
  72   "Render an RGBA texture"
  73   (declare (ignore target))
  74   (with-opengl
  75     (gl:bind-texture gl:+texture-2d+ (cffi::mem-ref (name-of self) :uint32))
  76     (gl:tex-env-f gl:+texture-env+ gl:+texture-env-mode+ gl:+decal+)
  77     (gl:with-begin gl:+quads+
  78       (gl:tex-coord-2i 0 0)
  79       (gl:vertex-2f -0.5 -0.5) ;; top lhs
  80       (gl:tex-coord-2i 1 0)
  81       (gl:vertex-2f  0.5 -0.5) ;; top rhs
  82       (gl:tex-coord-2i 1 1)
  83       (gl:vertex-2f  0.5  0.5) ;; bot rhs
  84       (gl:tex-coord-2i 0 1)
  85       (gl:vertex-2f -0.5  0.5)))) ;; bot lhs
  86
  87 (defmethod destroy-image ((self rgba-image))
  88   "Release the memory used by an RGBA texture"
  89   (setf (width-of self) 0)
  90   (setf (height-of self) 0)
  91   (with-opengl
  92     (gl:delete-textures 1 (name-of self))
  93     (cffi:foreign-free (name-of self))
  94     (cffi:foreign-free (data-of self))))
  95
  96
  97 (defmethod image-size ((image rgba-image))
  98   "Overall RGBA texture size in bytes"
  99   (* (width-of image) (height-of image)))
 100
 101 (defmethod pixel ((image rgba-image) i)
 102   "Access a pixel in an RGBA texture"
 103   (cffi:mem-aref (data-of image) :uint32 i))
 104
 105 (defmethod (setf pixel) (pixval (image rgba-image) i)
 106   "Set a pixel in an RGBA texture"
 107   (setf (cffi:mem-aref (data-of image) :uint32 i) pixval))
 108
 109 (defmethod indexxy ((image rgba-image) index)
 110   "Map an i index to an x,y index of a RGBA texure"
 111   (values (mod index (width-of image))
 112           (rem index (width-of image))))
 113
 114 (defmethod xyindex ((image rgba-image) x y)
 115   "Map an x,y index to an i index of a RGBA texure"
 116   (the (unsigned-byte 32) (+ x (* (width-of image) y))))
 117
 118 (defmethod pixel-xy ((image rgba-image) x y)
 119   "Get a pixel in an image using x y oords"
 120   (pixel image (xyindex image x y)))
 121
 122 (defmethod (setf pixel-xy) (pixval (image rgba-image) x y)
 123   "Set a pixel in an image using x y oords"
 124   (setf (cffi:mem-aref (data-of image) :uint32 (xyindex image x y)) pixval))
 125
 126 (defmethod dump ((image rgba-image))
 127   (iterate
 128     (for y from 0 below (height-of image))
 129     (format t "~&")
 130     (iterate
 131       (for x from 0 below (width-of image))
 132       (format t "~X " (pixel-xy  image x y)))))
 133
 134 (defun pixval (r g b &optional (a 0))
 135   "Convert rgb values to a pixel uint32"
 136   (declare ((unsigned-byte 8) r g b a))
 137   (the (unsigned-byte 32)
 138     (logior
 139      (ash a 24)
 140      (ash b 16)
 141      (ash g 8)
 142      r)))
 143
 144
 145