font: Embrace the bottom-left origin.

* sly/font.scm (flip-pixels-vertically): New procedure.
  (render-text): Flip surface vertically before creating a texture.

1 files changed, 24 insertions, 4 deletions

diff --git a/sly/font.scm b/sly/font.scm
index 3a3a5f8..8ec62dc 100644
--- a/sly/font.scm
+++ b/sly/font.scm
@@ -22,7 +22,9 @@
 ;;; Code:
 
 (define-module (sly font)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
   #:use-module (system foreign)
   #:use-module ((sdl sdl) #:prefix SDL:)
@@ -66,13 +68,31 @@
 argument with a default value of 12."
   (load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") point-size))
 
+(define (flip-pixels-vertically pixels width height)
+  "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x
+HEIGHT, 32 bit color bytevector."
+  (let ((buffer (make-u8vector (bytevector-length pixels)))
+        (row-width (* width 4))) ; assuming 32 bit color
+    (let loop ((y 0))
+      (when (< y height)
+        (let* ((y* (- height y 1))
+               (source-start (* y row-width))
+               (target-start (* y* row-width)))
+          (bytevector-copy! pixels source-start buffer target-start row-width)
+          (loop (1+ y)))))
+    buffer))
+
 (define (render-text font text)
   "Return a new texture with TEXT rendered using FONT."
   ;; An empty string will result in a surface value of #f, in which we
   ;; want to abort the texture creation process.
   (and-let* ((surface (SDL:render-utf8 (font-ttf font) text
                                        (SDL:make-color 255 255 255) #t))
-             (pixels (SDL:surface-pixels surface))
+             (width (SDL:surface:w surface))
+             (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)
@@ -84,10 +104,10 @@ argument with a default value of 12."
       (gl-texture-image-2d (texture-target texture-2d)
                            0
                            (pixel-format rgba)
-                           (SDL:surface:w surface)
-                           (SDL:surface:h surface)
+                           width
+                           height
                            0
-                           (version-1-2 bgra)
+                           (pixel-format rgba)
                            (color-pointer-type unsigned-byte)
                            pixels))
     (make-texture texture-id #f