From 2dae30227cd7c3ba4c8ab20b04414469c309913a Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Thu, 14 Nov 2019 08:48:11 -0500
Subject: render: texture: Add support for transparent color keys.

---
 chickadee/render/texture.scm | 38 +++++++++++++++++++++++++++++---------
 1 file changed, 29 insertions(+), 9 deletions(-)

diff --git a/chickadee/render/texture.scm b/chickadee/render/texture.scm
index c376bd9..051ec4f 100644
--- a/chickadee/render/texture.scm
+++ b/chickadee/render/texture.scm
@@ -24,9 +24,10 @@
   #:use-module (system foreign)
   #:use-module (gl)
   #:use-module (gl enums)
-  #:use-module (sdl2 surface)
+  #:use-module ((sdl2 surface) #:prefix sdl2:)
   #:use-module (oop goops)
   #:use-module (chickadee math rect)
+  #:use-module (chickadee render color)
   #:use-module (chickadee render gl)
   #:use-module (chickadee render gpu)
   #:export (make-texture
@@ -212,15 +213,32 @@ HEIGHT, 32 bit color bytevector."
           (loop (1+ y)))))
     buffer))
 
-(define (surface->texture surface min-filter mag-filter wrap-s wrap-t)
+(define (surface->texture surface min-filter mag-filter wrap-s wrap-t transparent-color)
   "Convert SURFACE, an SDL2 surface object, into a texture that uses
 the given MIN-FILTER and MAG-FILTER."
   ;; Convert to 32 bit RGBA color.
-  (call-with-surface (convert-surface-format surface 'abgr8888)
+  (sdl2:call-with-surface (sdl2:convert-surface-format surface 'abgr8888)
     (lambda (surface)
-      (let* ((width (surface-width surface))
-             (height (surface-height surface))
-             (pixels (surface-pixels surface)))
+      (let* ((width (sdl2:surface-width surface))
+             (height (sdl2:surface-height surface))
+             (pixels (sdl2:surface-pixels surface)))
+        ;; Zero the alpha channel of pixels that match the transparent
+        ;; color key.
+        (when transparent-color
+          (let ((r (inexact->exact (* (color-r transparent-color) 255)))
+                (g (inexact->exact (* (color-g transparent-color) 255)))
+                (b (inexact->exact (* (color-b transparent-color) 255)))
+                (pixel-count (* width height 4)))
+            (let loop ((i 0))
+              (when (< i pixel-count)
+                (when (and (= r (bytevector-u8-ref pixels i))
+                           (= g (bytevector-u8-ref pixels (+ i 1)))
+                           (= b (bytevector-u8-ref pixels (+ i 2))))
+                  (bytevector-u8-set! pixels i 255)
+                  (bytevector-u8-set! pixels (+ i 1) 255)
+                  (bytevector-u8-set! pixels (+ i 2) 255)
+                  (bytevector-u8-set! pixels (+ i 3) 0))
+                (loop (+ i 4))))))
         (make-texture pixels width height
                       #:min-filter min-filter
                       #:mag-filter mag-filter
@@ -231,14 +249,16 @@ the given MIN-FILTER and MAG-FILTER."
                      (min-filter 'nearest)
                      (mag-filter 'nearest)
                      (wrap-s 'repeat)
-                     (wrap-t 'repeat))
+                     (wrap-t 'repeat)
+                     transparent-color)
   "Load a texture from an image in FILE.  MIN-FILTER and MAG-FILTER
 describe the method that should be used for minification and
 magnification.  Valid values are 'nearest and 'linear.  By default,
 'nearest is used."
-  (call-with-surface ((@ (sdl2 image) load-image) file)
+  (sdl2:call-with-surface ((@ (sdl2 image) load-image) file)
     (lambda (surface)
-      (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
+      (surface->texture surface min-filter mag-filter wrap-s wrap-t
+                        transparent-color))))
 
 
 ;;;
-- 
cgit v1.2.3