From 22070a5551a55a898f4ec9a9427430e491490799 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 30 Nov 2014 13:16:38 -0500
Subject: render: texture: Factorize bytevector to texture conversion.

* sly/render/texture.scm (bytevector->texture): New procedure.
  (bitmap->texture): Define in terms of 'bytevector->texture'.
* sly/render/font.scm (render-text): Likewise.
---
 sly/render/font.scm    | 25 +++----------------------
 sly/render/texture.scm | 35 ++++++++++++++++++-----------------
 2 files changed, 21 insertions(+), 39 deletions(-)

diff --git a/sly/render/font.scm b/sly/render/font.scm
index e50c96a..a4140d8 100644
--- a/sly/render/font.scm
+++ b/sly/render/font.scm
@@ -92,28 +92,9 @@ HEIGHT, 32 bit color bytevector."
              (height (SDL:surface:h surface))
              ;; Need to flip pixels so that origin is on the bottom-left.
              (pixels (flip-pixels-vertically (SDL:surface-pixels surface)
-                                             width height))
-             (texture-id (gl-generate-texture)))
-    (with-gl-bind-texture (texture-target texture-2d) texture-id
-      (gl-texture-parameter (texture-target texture-2d)
-                            (texture-parameter-name texture-min-filter)
-                            (texture-min-filter linear))
-      (gl-texture-parameter (texture-target texture-2d)
-                            (texture-parameter-name texture-mag-filter)
-                            (texture-mag-filter linear))
-      (gl-texture-image-2d (texture-target texture-2d)
-                           0
-                           (pixel-format rgba)
-                           width
-                           height
-                           0
-                           (pixel-format rgba)
-                           (color-pointer-type unsigned-byte)
-                           pixels))
-    (make-texture texture-id #f
-                  (SDL:surface:w surface)
-                  (SDL:surface:h surface)
-                  0 0 1 1)))
+                                             width height)))
+    ;; Need to flip pixels so that origin is on the bottom-left.
+    (bytevector->texture pixels width height 'linear 'linear)))
 
 (define* (make-label font text #:optional #:key
                      (anchor 'top-left)
diff --git a/sly/render/texture.scm b/sly/render/texture.scm
index a462ae4..b2b747e 100644
--- a/sly/render/texture.scm
+++ b/sly/render/texture.scm
@@ -35,6 +35,7 @@
   #:use-module (sly wrappers freeimage)
   #:export (make-texture
             make-texture-region
+            bytevector->texture
             load-texture
             texture?
             texture-region?
@@ -107,13 +108,14 @@ that will be rendered, in pixels."
     (unless (texture-region? texture)
       (gl-delete-texture (texture-id texture)))))
 
-(define (bitmap->texture bitmap min-filter mag-filter)
-  "Translates a freeimage bitmap into an OpenGL texture."
-  (let ((texture-id (gl-generate-texture))
-        (pixels (freeimage-get-bits bitmap)))
+(define* (bytevector->texture pixels width height min-filter mag-filter
+                              #:optional (format (pixel-format rgba)))
+  "Translate the bytevector PIXELS into an OpenGL texture with
+dimensions WIDTHxHEIGHT where each pixel corresponds to the given
+OpenGL pixel FORMAT.  The generated textured uses MIN-FILTER for
+downscaling and MAG-FILTER for upscaling."
+  (let ((texture-id (gl-generate-texture)))
     (with-gl-bind-texture (texture-target texture-2d) texture-id
-      ;; Use "nearest" scaling method so that pixel art doesn't become
-      ;; blurry when scaled.
       (gl-texture-parameter (texture-target texture-2d)
                             (texture-parameter-name texture-min-filter)
                             (match min-filter
@@ -125,19 +127,18 @@ that will be rendered, in pixels."
                               ('nearest (texture-mag-filter nearest))
                               ('linear (texture-mag-filter linear))))
       (gl-texture-image-2d (texture-target texture-2d)
-                           0
-                           (pixel-format rgba)
-                           (freeimage-get-width bitmap)
-                           (freeimage-get-height bitmap)
-                           0
-                           (version-1-2 bgra)
+                           0 (pixel-format rgba) width height 0 format
                            (color-pointer-type unsigned-byte)
                            pixels))
-    (make-texture texture-id
-                  #f
-                  (freeimage-get-width bitmap)
-                  (freeimage-get-height bitmap)
-                  0 0 1 1)))
+    (make-texture texture-id #f width height 0 0 1 1)))
+
+(define (bitmap->texture bitmap min-filter mag-filter)
+  "Translates a freeimage bitmap into an OpenGL texture."
+  (bytevector->texture (freeimage-get-bits bitmap)
+                       (freeimage-get-width bitmap)
+                       (freeimage-get-height bitmap)
+                       min-filter mag-filter
+                       (version-1-2 bgra)))
 
 (define (load-bitmap filename)
   ;; Throw an error if image file does not exist or else we will
-- 
cgit v1.2.3