;; ;; chicken-sdl2-ttf: CHICKEN Scheme bindings to SDL_ttf 2 ;; ;; Copyright © 2015 John Croisant. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in ;; the documentation and/or other materials provided with the ;; distribution. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. (export size-text render-text-solid render-text-solid* render-text-shaded render-text-shaded* render-text-blended render-text-blended* size-utf8 render-utf8-solid render-utf8-solid* render-utf8-shaded render-utf8-shaded* render-utf8-blended render-utf8-blended* byte-swapped-unicode-set! size-unicode render-unicode-solid render-unicode-solid* render-unicode-shaded render-unicode-shaded* render-unicode-blended render-unicode-blended* render-glyph-solid render-glyph-solid* render-glyph-shaded render-glyph-shaded* render-glyph-blended render-glyph-blended* ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RENDER LATIN 1 TEXT (define-function-binding TTF_SizeText return: (int zero-on-success) args: ((TTF_Font* font) (c-string text) (int* w-out) (int* h-out))) (define-function-binding* TTF_RenderText_Solid return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg)) body: "C_return( TTF_RenderText_Solid(font, text, *fg) );") (define-function-binding* TTF_RenderText_Shaded return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg) (SDL_Color* bg)) body: "C_return( TTF_RenderText_Shaded(font, text, *fg, *bg) );") (define-function-binding* TTF_RenderText_Blended return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg)) body: "C_return( TTF_RenderText_Blended(font, text, *fg) );") (: size-text (ttf:font string -> fixnum fixnum)) (define (size-text font text) (with-temp-mem ((w-out (%allocate-int)) (h-out (%allocate-int))) (let ((ret-code (TTF_SizeText font text w-out h-out))) (if (zero? ret-code) (values (pointer-u32-ref w-out) (pointer-u32-ref h-out)) (begin (free w-out) (free h-out) (abort (sdl-failure "TTF_SizeText" ret-code))))))) (: render-text-solid (ttf:font string sdl2:color -> sdl2:surface)) (define (render-text-solid font text fg) (set-finalizer! (render-text-solid* font text fg) free-surface!)) (: render-text-solid* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-text-solid* font text fg) (let ((surf (TTF_RenderText_Solid font text fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderText_Solid" #f))))) (: render-text-shaded (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-text-shaded font text fg bg) (set-finalizer! (render-text-shaded* font text fg bg) free-surface!)) (: render-text-shaded* (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-text-shaded* font text fg bg) (let ((surf (TTF_RenderText_Shaded font text fg bg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderText_Shaded" #f))))) (: render-text-blended (ttf:font string sdl2:color -> sdl2:surface)) (define (render-text-blended font text fg) (set-finalizer! (render-text-blended* font text fg) free-surface!)) (: render-text-blended* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-text-blended* font text fg) (let ((surf (TTF_RenderText_Blended font text fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderText_Blended" #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RENDER UTF8 TEXT (define-function-binding TTF_SizeUTF8 return: (int zero-on-success) args: ((TTF_Font* font) (c-string text) (int* w-out) (int* h-out))) (define-function-binding* TTF_RenderUTF8_Solid return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg)) body: "C_return( TTF_RenderUTF8_Solid(font, text, *fg) );") (define-function-binding* TTF_RenderUTF8_Shaded return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg) (SDL_Color* bg)) body: "C_return( TTF_RenderUTF8_Shaded(font, text, *fg, *bg) );") (define-function-binding* TTF_RenderUTF8_Blended return: (SDL_Surface* rendered) args: ((TTF_Font* font) (c-string text) (SDL_Color* fg)) body: "C_return( TTF_RenderUTF8_Blended(font, text, *fg) );") (: size-utf8 (ttf:font string -> fixnum fixnum)) (define (size-utf8 font text) (with-temp-mem ((w-out (%allocate-int)) (h-out (%allocate-int))) (let ((ret-code (TTF_SizeUTF8 font text w-out h-out))) (if (zero? ret-code) (values (pointer-u32-ref w-out) (pointer-u32-ref h-out)) (begin (free w-out) (free h-out) (abort (sdl-failure "TTF_SizeUTF8" ret-code))))))) (: render-utf8-solid (ttf:font string sdl2:color -> sdl2:surface)) (define (render-utf8-solid font text fg) (set-finalizer! (render-utf8-solid* font text fg) free-surface!)) (: render-utf8-solid* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-utf8-solid* font text fg) (let ((surf (TTF_RenderUTF8_Solid font text fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUTF8_Solid" #f))))) (: render-utf8-shaded (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-utf8-shaded font text fg bg) (set-finalizer! (render-utf8-shaded* font text fg bg) free-surface!)) (: render-utf8-shaded* (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-utf8-shaded* font text fg bg) (let ((surf (TTF_RenderUTF8_Shaded font text fg bg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUTF8_Shaded" #f))))) (: render-utf8-blended (ttf:font string sdl2:color -> sdl2:surface)) (define (render-utf8-blended font text fg) (set-finalizer! (render-utf8-blended* font text fg) free-surface!)) (: render-utf8-blended* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-utf8-blended* font text fg) (let ((surf (TTF_RenderUTF8_Blended font text fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUTF8_Blended" #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RENDER UNICODE TEXT (define-function-binding TTF_ByteSwappedUNICODE args: ((bool swapped))) (define-function-binding TTF_SizeUNICODE return: (int zero-on-success) args: ((TTF_Font* font) ((const Uint16*) text) (int* w-out) (int* h-out))) (define-function-binding* TTF_RenderUNICODE_Solid return: (SDL_Surface* rendered) args: ((TTF_Font* font) ((const Uint16*) text) (SDL_Color* fg)) body: "C_return( TTF_RenderUNICODE_Solid(font, text, *fg) );") (define-function-binding* TTF_RenderUNICODE_Shaded return: (SDL_Surface* rendered) args: ((TTF_Font* font) ((const Uint16*) text) (SDL_Color* fg) (SDL_Color* bg)) body: "C_return( TTF_RenderUNICODE_Shaded(font, text, *fg, *bg) );") (define-function-binding* TTF_RenderUNICODE_Blended return: (SDL_Surface* rendered) args: ((TTF_Font* font) ((const Uint16*) text) (SDL_Color* fg)) body: "C_return( TTF_RenderUNICODE_Blended(font, text, *fg) );") (: byte-swapped-unicode-set! (boolean -> void)) (define (byte-swapped-unicode-set! swapped?) (TTF_ByteSwappedUNICODE swapped?)) (: size-unicode (ttf:font (or pointer locative) -> fixnum fixnum)) (define (size-unicode font unicode) (with-temp-mem ((w-out (%allocate-int)) (h-out (%allocate-int))) (let ((ret-code (TTF_SizeUNICODE font unicode w-out h-out))) (if (zero? ret-code) (values (pointer-u32-ref w-out) (pointer-u32-ref h-out)) (begin (free w-out) (free h-out) (abort (sdl-failure "TTF_SizeUNICODE" ret-code))))))) (: render-unicode-solid (ttf:font (or pointer locative) sdl2:color -> sdl2:surface)) (define (render-unicode-solid font unicode fg) (set-finalizer! (render-unicode-solid* font unicode fg) free-surface!)) (: render-unicode-solid* (ttf:font (or pointer locative) sdl2:color -> sdl2:surface)) (define (render-unicode-solid* font unicode fg) (let ((surf (TTF_RenderUNICODE_Solid font unicode fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUNICODE_Solid" #f))))) (: render-unicode-shaded (ttf:font (or pointer locative) sdl2:color sdl2:color -> sdl2:surface)) (define (render-unicode-shaded font unicode fg bg) (set-finalizer! (render-unicode-shaded* font unicode fg bg) free-surface!)) (: render-unicode-shaded* (ttf:font (or pointer locative) sdl2:color sdl2:color -> sdl2:surface)) (define (render-unicode-shaded* font unicode fg bg) (let ((surf (TTF_RenderUNICODE_Shaded font unicode fg bg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUNICODE_Shaded" #f))))) (: render-unicode-blended (ttf:font (or pointer locative) sdl2:color -> sdl2:surface)) (define (render-unicode-blended font unicode fg) (set-finalizer! (render-unicode-blended* font unicode fg) free-surface!)) (: render-unicode-blended* (ttf:font (or pointer locative) sdl2:color -> sdl2:surface)) (define (render-unicode-blended* font unicode fg) (let ((surf (TTF_RenderUNICODE_Blended font unicode fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderUNICODE_Blended" #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; RENDER GLYPH (define-function-binding* TTF_RenderGlyph_Solid return: (SDL_Surface* rendered) args: ((TTF_Font* font) (Uint16 ch) (SDL_Color* fg)) body: "C_return( TTF_RenderGlyph_Solid(font, ch, *fg) );") (define-function-binding* TTF_RenderGlyph_Shaded return: (SDL_Surface* rendered) args: ((TTF_Font* font) (Uint16 ch) (SDL_Color* fg) (SDL_Color* bg)) body: "C_return( TTF_RenderGlyph_Shaded(font, ch, *fg, *bg) );") (define-function-binding* TTF_RenderGlyph_Blended return: (SDL_Surface* rendered) args: ((TTF_Font* font) (Uint16 ch) (SDL_Color* fg)) body: "C_return( TTF_RenderGlyph_Blended(font, ch, *fg) );") (: render-glyph-solid (ttf:font string sdl2:color -> sdl2:surface)) (define (render-glyph-solid font glyph fg) (set-finalizer! (render-glyph-solid* font glyph fg) free-surface!)) (: render-glyph-solid* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-glyph-solid* font glyph fg) (let* ((glyph-int (%glyph->Uint16 glyph 'render-glyph-solid*)) (surf (TTF_RenderGlyph_Solid font glyph-int fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderGlyph_Solid" #f))))) (: render-glyph-shaded (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-glyph-shaded font glyph fg bg) (set-finalizer! (render-glyph-shaded* font glyph fg bg) free-surface!)) (: render-glyph-shaded* (ttf:font string sdl2:color sdl2:color -> sdl2:surface)) (define (render-glyph-shaded* font glyph fg bg) (let* ((glyph-int (%glyph->Uint16 glyph 'render-glyph-shaded*)) (surf (TTF_RenderGlyph_Shaded font glyph-int fg bg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderGlyph_Shaded" #f))))) (: render-glyph-blended (ttf:font string sdl2:color -> sdl2:surface)) (define (render-glyph-blended font glyph fg) (set-finalizer! (render-glyph-blended* font glyph fg) free-surface!)) (: render-glyph-blended* (ttf:font string sdl2:color -> sdl2:surface)) (define (render-glyph-blended* font glyph fg) (let* ((glyph-int (%glyph->Uint16 glyph 'render-glyph-blended*)) (surf (TTF_RenderGlyph_Blended font glyph-int fg))) (if (%nonnull-surface? surf) surf (abort (sdl-failure "TTF_RenderGlyph_Blended" #f)))))