summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
Diffstat (limited to '2d')
-rw-r--r--2d/font.scm188
-rw-r--r--2d/wrappers/ftgl.scm204
2 files changed, 106 insertions, 286 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)