opengl.lisp

   1 ;; Copyright 2010-2011 Christoph Senjak\r
   2 \r
   3 (in-package :uxul-world)\r
   4 \r
   5 (defun load-bmp-blob-into-texture (blob)\r
   6   (let*\r
   7       ((id (car (gl:gen-textures 1)))\r
   8        (pix (bmp-pixel-data blob))\r
   9        (w (bmp-width blob))\r
  10        (h (bmp-height blob)))\r
  11     (gl:bind-texture :texture-2d id)\r
  12     (gl:tex-image-2d :texture-2d 0 :rgba8 w h 0 :bgra :unsigned-byte pix)\r
  13     (gl:tex-parameter :texture-2d :texture-min-filter :linear)\r
  14     (gl:tex-parameter :texture-2d :texture-mag-filter :linear)\r
  15     (gl:flush)\r
  16     id))\r
  17 \r
  18 (defun load-spritesheet ()\r
  19   (let*\r
  20       ((id (car (gl:gen-textures 1)))\r
  21        (wh (cadr *spritesheet*))\r
  22        (pix (car *spritesheet*)))\r
  23     (gl:bind-texture :texture-2d id)\r
  24     (gl:tex-image-2d :texture-2d 0 :rgba8 wh wh 0 :bgra :unsigned-byte pix)\r
  25     (gl:tex-parameter :texture-2d :texture-min-filter :linear)\r
  26     (gl:tex-parameter :texture-2d :texture-mag-filter :linear)\r
  27     (gl:flush)\r
  28     id))\r
  29 \r
  30 (defun make-quad (imgs x y w h)\r
  31   (destructuring-bind (x1 y1 x2 y2 bla blubb) imgs\r
  32     (declare (ignore bla blubb))\r
  33     (setf x (- x +screen-width+))\r
  34     (setf y (- y +screen-height+))\r
  35     ;(gl:bind-texture :texture-2d *spritesheet-id*)\r
  36     (macrolet ((writedown (&rest vars)\r
  37                  `(progn\r
  38                     ,@(mapcar #'(lambda (var)\r
  39                                  `(setf (cffi:mem-aref uxul-world::*ptr* :float (1- (incf uxul-world::*offset*))) (float ,var 0.0))) vars))))\r
  40       (writedown x1 y1 x (+ y h)\r
  41                  x2 y1 (+ x w) (+ y h)\r
  42                  x2 y2 (+ x w) y\r
  43                  x1 y2 x y))))