diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/font.scm | 188 | ||||
| -rw-r--r-- | 2d/wrappers/ftgl.scm | 204 |
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) |