Rewrite font module.

FTGL has been dropped in favor of SDL_ttf.

* 2d/font: Rewrite everything!
* 2d/wrappers/ftgl.scm: Delete it.
* configure.ac: Check for SDL_ttf.
* data/Makefile.am (shaders_DATA): Add font shaders.
* data/shaders/font-fragment.glsl: New shader.
* data/shaders/font-vertex.glsl: New shader.
* examples/font.scm: Rewrite font example.
* examples/fonts/AUTHORS: Delete it.
* examples/fonts/Boxy-Bold.ttf: Delete it.

9 files changed, 175 insertions, 298 deletions

diff --git a/2d/font.scm b/2d/font.scm
index 7da74a3..0905f69 100644
--- a/2d/font.scm
+++ b/2d/font.scm
@@ -25,102 +25,126 @@
   #:use-module (figl gl)
   #:use-module (srfi srfi-9)
   #:use-module (system foreign)
-  #:use-module (2d wrappers ftgl)
+  #:use-module ((sdl sdl) #:prefix SDL:)
+  #:use-module ((sdl ttf) #:prefix SDL:)
+  #:use-module (figl gl)
+  #:use-module (figl contrib packed-struct)
   #:use-module (2d color)
   #:use-module (2d config)
-  #:use-module (2d vector2))
+  #:use-module (2d shader)
+  #:use-module (2d signals)
+  #:use-module (2d texture)
+  #:use-module (2d vector2)
+  #:use-module (2d window)
+  #:use-module (2d wrappers gl)
+  #:export (load-font
+            load-default-font
+            font?
+            font-point-size
+            make-label
+            label?
+            label-font
+            label-text
+            label-position
+            label-color
+            draw-label))
+
+(SDL:ttf-init)
 
 ;;;
 ;;; Font
 ;;;
 
-;; Font objects represent an FTGL texture font at a given size.
 (define-record-type <font>
-  (make-font ftgl-font size)
+  (make-font ttf point-size)
   font?
-  (ftgl-font font-ftgl-font)
-  (size font-size))
-
-(define (load-font filename size)
-  "Load a font from FILENAME with the given SIZE in points."
-  (let ((ftgl-font (ftgl-create-texture-font filename)))
-    ;; Hardcoded 72 dpi for now.
-    (ftgl-set-font-face-size ftgl-font size 72)
-    (make-font ftgl-font size)))
+  (ttf font-ttf)
+  (point-size font-point-size))
 
-(define (flip-text font)
-  "Flip current GL matrix about the x-axis and translates by the
-negative font ascender value. This is necessary before rendering text
-because guile-2d flips the y-axis so that the origin is in the
-upper-left corner rather than the bottom-left."
-  (gl-scale 1 -1 1)
-  (gl-translate 0 (- (ftgl-get-font-ascender (font-ftgl-font font))) 0))
+(define (load-font filename point-size)
+  "Load the TTF font in FILENAME with the given POINT-SIZE."
+  (if (file-exists? filename)
+      (make-font (SDL:load-font filename point-size) point-size)
+      (error "File not found!" filename)))
 
-(define (draw-font font text)
-  "Renders the string text using the given font."
-  (with-gl-push-matrix
-    (flip-text font)
-    (ftgl-render-font (font-ftgl-font font)
-                      text
-                      (ftgl-render-mode all))))
+(define* (load-default-font #:optional (point-size 12))
+  "Load the guile-2d default TTF font.  POINT-SIZE is an optional
+argument with a default value of 12."
+  (load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") point-size))
 
-(define* (load-default-font #:optional (size 12))
-  (load-font (string-append %pkgdatadir "/fonts/DejaVuSans.ttf") size))
+(define (render-text font text)
+  "Return a new texture with TEXT rendered using FONT."
+  (let* ((surface (SDL:render-utf8 (font-ttf font) text
+                                   (SDL:make-color 255 255 255) #t))
+         (pixels (SDL:surface-pixels surface))
+         (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 nearest))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-mag-filter)
+                            (texture-mag-filter nearest))
+      (gl-texture-image-2d (texture-target texture-2d)
+                           0
+                           (pixel-format rgba)
+                           (SDL:surface:w surface)
+                           (SDL:surface:h surface)
+                           0
+                           (version-1-2 bgra)
+                           (color-pointer-type unsigned-byte)
+                           pixels))
+    (make-texture texture-id #f
+                  (SDL:surface:w surface)
+                  (SDL:surface:h surface)
+                  0 0 1 1)))
 
-(export <font>
-        make-font
-        font?
-        font-size
-        load-font
-        draw-font
-        load-default-font)
-
-;;;
-;;; Textbox
-;;;
+(define-record-type <label>
+  (%make-label font text position anchor color texture vertices)
+  label?
+  (font label-font)
+  (text label-text)
+  (position label-position)
+  (anchor label-anchor)
+  (color label-color)
+  (texture label-texture)
+  (vertices label-vertices))
 
-;; A textbox is a string of word-wrapped text
-(define-record-type <textbox>
-  (%make-textbox font text position color alignment line-length layout)
-  textbox?
-  (font textbox-font)
-  (text textbox-text set-textbox-text!)
-  (position textbox-position set-textbox-position!)
-  (color textbox-color set-textbox-color!)
-  (alignment textbox-alignment)
-  (line-length textbox-line-length)
-  (layout textbox-layout))
+(define (make-label-vertices texture)
+  "Return a packed array of vertices for TEXTURE."
+  (let ((vertices (make-packed-array texture-vertex 4)))
+    (pack-texture-vertices vertices 0
+                           (texture-width texture)
+                           (texture-height texture)
+                           (texture-s1 texture)
+                           (texture-t1 texture)
+                           (texture-s2 texture)
+                           (texture-t2 texture))
+    vertices))
 
-(define (make-textbox font text position color alignment line-length)
-  "Create a textbox that will draw TEXT with the given FONT, at vector
-POSITION, with ALIGNMENT, and a maximum LINE-LENGTH."
-  (let ((layout (ftgl-create-layout)))
-    (ftgl-set-layout-font layout (font-ftgl-font font))
-    ;; (ftgl-set-layout-alignment layout (ftgl-text-alignment alignment))
-    (ftgl-set-layout-line-length layout line-length)
-    (%make-textbox font text position color alignment line-length layout)))
+(define* (make-label font text position #:optional #:key
+                     (color white) (anchor 'top-left))
+  "Return a new label containing the string TEXT rendered with FONT at
+the given position.  Optional arguments are COLOR with a default of
+white and ANCHOR with a default of 'top-left."
+  (let* ((texture (render-text font text))
+         (vertices (make-label-vertices texture))
+         (anchor (anchor-texture texture anchor)))
+    (%make-label font text position anchor color texture vertices)))
 
-(define (draw-textbox textbox)
-  "Draw TEXTBOX."
-  (with-gl-push-matrix
-    (vector2-translate (textbox-position textbox))
-    (flip-text (textbox-font textbox))
-    (use-color (textbox-color textbox))
-    (ftgl-render-layout (textbox-layout textbox)
-                        (textbox-text textbox)
-                        (ftgl-render-mode all))))
+(define font-shader
+  (make-shader-program
+   (load-vertex-shader (string-append %pkgdatadir
+                                      "/shaders/font-vertex.glsl"))
+   (load-fragment-shader (string-append %pkgdatadir
+                                        "/shaders/font-fragment.glsl"))))
 
-(export <textbox>
-        make-textbox
-        textbox?
-        textbox-font
-        textbox-text
-        set-textbox-text!
-        textbox-position
-        set-textbox-position!
-        textbox-color
-        set-textbox-color!
-        textbox-alignment
-        textbox-line-length
-        textbox-layout
-        draw-textbox)
+(define (draw-label label)
+  "Draw LABEL on the screen."
+  (with-shader-program font-shader
+    (uniforms ((projection (signal-ref window-projection))
+               (position (label-position label))
+               (anchor (label-anchor label))
+               (color (label-color label)))
+      (draw-texture-vertices (label-texture label) (label-vertices label) 1)))
+  *unspecified*)
diff --git a/2d/wrappers/ftgl.scm b/2d/wrappers/ftgl.scm
deleted file mode 100644
index 1ff42d7..0000000
--- a/2d/wrappers/ftgl.scm
+++ /dev/null
@@ -1,204 +0,0 @@
-;;; guile-2d
-;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
-;;;
-;;; Guile-2d is free software: you can redistribute it and/or modify it
-;;; under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation, either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; Guile-2d is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; Lesser General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this program.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Quick and dirty wrapper for the FTGL library.
-;;
-;;; Code:
-
-(define-module (2d wrappers ftgl)
-  #:use-module (system foreign)
-  #:use-module (2d wrappers util)
-  #:use-module (ice-9 format))
-
-(define libftgl (dynamic-link "libftgl"))
-
-(define-syntax-rule (define-foreign name ret string-name args)
-  (define name
-    (pointer->procedure ret (dynamic-func string-name libftgl) args)))
-
-;;;
-;;; Enums
-;;;
-
-(define-enumeration ftgl-render-mode
-  (front #x0001)
-  (back  #x0002)
-  (side  #x0004)
-  (all   #xffff))
-
-(define-enumeration ftgl-text-alignment
-  (left    0)
-  (center  1)
-  (right   2)
-  (justify 3))
-
-(export ftgl-render-mode
-        ftgl-text-alignment)
-
-;;;
-;;; Fonts
-;;;
-
-(define-wrapped-pointer-type <ftgl-font>
-  ftgl-font?
-  wrap-ftgl-font unwrap-ftgl-font
-  (lambda (r port)
-    (let ((font (unwrap-ftgl-font r)))
-      (format port
-              "<ftgl-font ~x>"
-              (pointer-address font)))))
-
-(define-foreign %ftgl-create-texture-font
-  '* "ftglCreateTextureFont" '(*))
-
-(define-foreign %ftgl-set-font-face-size
-  void "ftglSetFontFaceSize" (list '* unsigned-int unsigned-int))
-
-(define-foreign %ftgl-render-font
-  void "ftglRenderFont" (list '* '* unsigned-int))
-
-(define-foreign %ftgl-get-font-descender
-  float "ftglGetFontDescender" '(*))
-
-(define-foreign %ftgl-get-font-ascender
-  float "ftglGetFontAscender" '(*))
-
-(define (ftgl-create-texture-font filename)
-  (unless (file-exists? filename)
-    (throw 'font-not-found filename))
-  (let ((font (%ftgl-create-texture-font (string->pointer filename))))
-    (when (null-pointer? font)
-      (throw 'font-load-failure filename))
-    (wrap-ftgl-font font)))
-
-(define (ftgl-set-font-face-size font size res)
-  (%ftgl-set-font-face-size (unwrap-ftgl-font font) size res))
-
-(define (ftgl-render-font font text render-mode)
-  (%ftgl-render-font (unwrap-ftgl-font font)
-                     (string->pointer text)
-                     render-mode))
-
-(define (ftgl-get-font-descender font)
-  (%ftgl-get-font-descender (unwrap-ftgl-font font)))
-
-(define (ftgl-get-font-ascender font)
-  (%ftgl-get-font-ascender (unwrap-ftgl-font font)))
-
-(export ftgl-create-texture-font
-        ftgl-set-font-face-size
-        ftgl-render-font
-        ftgl-get-font-descender
-        ftgl-get-font-ascender)
-
-;;;
-;;; SimpleLayout
-;;;
-
-(define-wrapped-pointer-type <ftgl-simple-layout>
-  ftgl-simple-layout?
-  wrap-ftgl-simple-layout unwrap-ftgl-simple-layout
-  (lambda (r port)
-    (let ((simple-layout (unwrap-ftgl-simple-layout r)))
-      (format port
-              "<ftgl-simple-layout ~x>"
-              (pointer-address simple-layout)))))
-
-(define-foreign %ftgl-create-simple-layout
-  '* "ftglCreateSimpleLayout" '())
-
-(define-foreign %ftgl-destroy-layout
-  void "ftglDestroyLayout" '(*))
-
-(define-foreign %ftgl-set-layout-font
-  void "ftglSetLayoutFont" '(* *))
-
-(define-foreign %ftgl-get-layout-font
-  '* "ftglGetLayoutFont" '(*))
-
-(define-foreign %ftgl-set-layout-line-length
-  void "ftglSetLayoutLineLength" (list '* float))
-
-(define-foreign %ftgl-get-layout-line-length
-  float "ftglGetLayoutLineLength" '(*))
-
-(define-foreign %ftgl-set-layout-alignment
-  void "ftglSetLayoutAlignment" (list '* int))
-
-(define-foreign %ftgl-get-layout-alignment
-  int "ftglGetLayoutAlignement" '(*))
-
-(define-foreign %ftgl-set-layout-line-spacing
-  void "ftglSetLayoutLineSpacing" (list '* float))
-
-;; For some reason this symbol is not found.
-;; (define-foreign %ftgl-get-layout-line-spacing
-;;   float "ftglGetLayoutLineSpacing" '(*))
-
-(define-foreign %ftgl-render-layout
-  void "ftglRenderLayout" (list '* '* int))
-
-(define (ftgl-create-layout)
-  (wrap-ftgl-simple-layout
-   (%ftgl-create-simple-layout)))
-
-(define (ftgl-destroy-layout layout)
-  (%ftgl-destroy-layout (unwrap-ftgl-simple-layout layout)))
-
-(define (ftgl-set-layout-font layout font)
-  (%ftgl-set-layout-font (unwrap-ftgl-simple-layout layout)
-                         (unwrap-ftgl-font font)))
-
-(define (ftgl-get-layout-font layout)
-  (wrap-ftgl-font
-   (%ftgl-get-layout-font (unwrap-ftgl-simple-layout layout))))
-
-(define (ftgl-set-layout-line-length layout line-length)
-  (%ftgl-set-layout-line-length (unwrap-ftgl-simple-layout layout)
-                                line-length))
-
-(define (ftgl-get-layout-line-length layout)
-  (%ftgl-get-layout-line-length (unwrap-ftgl-simple-layout layout)))
-
-(define (ftgl-set-layout-alignment layout alignment)
-  (%ftgl-set-layout-alignment (unwrap-ftgl-simple-layout layout)
-                              alignment))
-
-(define (ftgl-get-layout-alignment layout)
-  (%ftgl-get-layout-alignment (unwrap-ftgl-simple-layout layout)))
-
-(define (ftgl-set-layout-line-spacing layout spacing)
-  (%ftgl-set-layout-line-spacing (unwrap-ftgl-simple-layout layout)
-                                 spacing))
-
-(define (ftgl-render-layout layout text mode)
-  (%ftgl-render-layout (unwrap-ftgl-simple-layout layout)
-                       (string->pointer text)
-                       mode))
-
-(export ftgl-create-layout
-        ftgl-destroy-layout
-        ftgl-set-layout-font
-        ftgl-get-layout-font
-        ftgl-set-layout-line-length
-        ftgl-get-layout-line-length
-        ftgl-set-layout-alignment
-        ftgl-get-layout-alignment
-        ftgl-set-layout-line-spacing
-        ftgl-render-layout)
diff --git a/configure.ac b/configure.ac
index 93b3922..01f74b7 100644
--- a/configure.ac
+++ b/configure.ac
@@ -19,7 +19,7 @@ AC_CONFIG_FILES([Makefile doc/Makefile examples/Makefile data/Makefile])
 AC_CONFIG_FILES([env], [chmod +x env])
 
 PKG_CHECK_MODULES([SDL], [sdl <= 1.3 sdl >= 1.2])
-PKG_CHECK_MODULES([FTGL], [ftgl >= 2.1])
+PKG_CHECK_MODULES([SDL_tff], [SDL_ttf >= 2.0])
 # Why doesn't freeimage have a pkg-config file?
 #PKG_CHECK_MODULES([freeimage], [freeimage >= 3.0])
 
diff --git a/data/Makefile.am b/data/Makefile.am
index b6d0d74..8fc3a3e 100644
--- a/data/Makefile.am
+++ b/data/Makefile.am
@@ -4,4 +4,6 @@ fonts_DATA = fonts/DejaVuSans.ttf
 shadersdir = $(pkgdatadir)/shaders
 shaders_DATA = 					\
   shaders/sprite-vertex.glsl			\
-  shaders/sprite-fragment.glsl
+  shaders/sprite-fragment.glsl			\
+  shaders/font-vertex.glsl			\
+  shaders/font-fragment.glsl
diff --git a/data/shaders/font-fragment.glsl b/data/shaders/font-fragment.glsl
new file mode 100644
index 0000000..3dd10f1
--- /dev/null
+++ b/data/shaders/font-fragment.glsl
@@ -0,0 +1,8 @@
+#version 120
+
+uniform sampler2D color_texture;
+uniform vec4 color;
+
+void main (void) {
+    gl_FragColor = texture2D(color_texture, gl_TexCoord[0].st) * color;
+}
diff --git a/data/shaders/font-vertex.glsl b/data/shaders/font-vertex.glsl
new file mode 100644
index 0000000..196da12
--- /dev/null
+++ b/data/shaders/font-vertex.glsl
@@ -0,0 +1,15 @@
+#version 120
+
+uniform mat4 projection;
+uniform vec2 position;
+uniform vec2 anchor;
+
+void main(void) {
+    mat4 translation = mat4(1.0, 0.0, 0.0, position.x - anchor.x,
+                            0.0, 1.0, 0.0, position.y - anchor.y,
+                            0.0, 0.0, 1.0, 0.0,
+                            0.0, 0.0, 0.0, 1.0);
+
+    gl_Position = projection * (gl_Vertex * translation);
+    gl_TexCoord[0] = gl_MultiTexCoord0;
+}
diff --git a/examples/font.scm b/examples/font.scm
index 465600c..2398b36 100644
--- a/examples/font.scm
+++ b/examples/font.scm
@@ -1,22 +1,56 @@
 (use-modules (srfi srfi-9)
              (figl gl)
+             (2d agenda)
+             (2d fps)
              (2d color)
              (2d font)
              (2d game)
+             (2d mouse)
+             (2d signals)
              (2d vector2)
              (2d window))
 
 (load "common.scm")
 
-(define textbox
-  (make-textbox (load-font "fonts/Boxy-Bold.ttf" 48)
-                "The quick brown fox jumped over the lazy dog."
-                (vector2 240 160)
-                white
-                'left
-                200))
+(define font (load-default-font 18))
+(define position (vector2 320 240))
+(define text "The quick brown fox jumped over the lazy dog.")
+(define label (make-label font text position #:anchor 'center))
 
-(add-hook! draw-hook (lambda (dt alpha) (draw-textbox textbox)))
+(define fps-label-position (vector2 0 0))
+(define (make-fps-label)
+  (make-label font (format #f "FPS: ~d" (fps)) fps-label-position))
+(define fps-label (make-fps-label))
+
+(define mouse-label-position (vector2 0 20))
+(define mouse-label
+  (signal-map (lambda (p)
+                (let ((text (format #f "Mouse: (~d, ~d)" (vx p) (vy p))))
+                  (make-label font text mouse-label-position)))
+              mouse-position))
+
+(define gc-label-position (vector2 0 40))
+(define gc-counter (make-root-signal 0))
+(define gc-label
+  (signal-map (lambda (counter)
+                (let ((text (format #f "GCs: ~d" counter)))
+                  (make-label font text gc-label-position)))
+              gc-counter))
+
+(add-hook! after-gc-hook
+           (lambda ()
+             (signal-set! gc-counter (1+ (signal-ref gc-counter)))))
+
+(schedule-interval game-agenda
+                   (lambda ()
+                     (set! fps-label (make-fps-label)))
+                   60)
+
+(add-hook! draw-hook (lambda (dt alpha)
+                       (draw-label label)
+                       (draw-label fps-label)
+                       (draw-label (signal-ref mouse-label))
+                       (draw-label (signal-ref gc-label))))
 
 (with-window (make-window #:title "Fonts")
   (run-game-loop))
diff --git a/examples/fonts/AUTHORS b/examples/fonts/AUTHORS
deleted file mode 100644
index 0f278b8..0000000
--- a/examples/fonts/AUTHORS
+++ /dev/null
@@ -1,2 +0,0 @@
-Clint Bellanger and William Thompson
-http://opengameart.org/content/boxy-bold-truetype-font
\ No newline at end of file
diff --git a/examples/fonts/Boxy-Bold.ttf b/examples/fonts/Boxy-Bold.ttf
deleted file mode 100644
index 8076dc5..0000000
--- a/examples/fonts/Boxy-Bold.ttf
+++ /dev/null