; Copyright (C) 2002-2004 Tony Garnock-Jones ; ; This library is free software; you can redistribute it and/or modify ; it under the terms of the GNU Library General Public License as ; published by the Free Software Foundation; either version 2 of the ; License, or (at your option) any later version. ; ; This library 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 ; Library General Public License for more details. ; ; You should have received a copy of the GNU Library General Public ; License along with this library; if not, write to the Free ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 ; USA (module sdl-ttf ( ttf-init ttf-was-init ttf-quit ttf-compiled-version ttf-linked-version ttf-font? ttf-font-pointer ttf-open-font ttf-open-font-index ttf-close-font ttf-get-font-style ttf-set-font-style ttf-size-text! ttf-size-utf8! ttf-font-height ttf-font-ascent ttf-font-descent ttf-font-line-skip ttf-font-faces ttf-font-face-is-fixed-width? ttf-font-face-family-name ttf-font-face-style-name ttf-render-text-solid ttf-render-utf8-solid ttf-render-glyph-solid ttf-render-text-shaded ttf-render-utf8-shaded ttf-render-glyph-shaded ttf-render-text-blended ttf-render-utf8-blended ttf-render-glyph-blended make-ttf-glyph ttf-glyph-metrics ttf-glyph-minx ttf-glyph-maxx ttf-glyph-miny ttf-glyph-maxy ttf-glyph-advance TTF_STYLE_NORMAL TTF_STYLE_BOLD TTF_STYLE_ITALIC TTF_STYLE_UNDERLINE ) ;--------------------------------------------------------------------------- (import chicken scheme foreign) (use srfi-1) (use srfi-4) (use srfi-13) (use srfi-18) (use lolevel) (use sdl-base) (foreign-declare #< EOF ) ;--------------------------------------------------------------------------- (define-syntax --sdl-flags (lambda (e r c) `(,(r 'begin) ,@(append-map (lambda (str) (let* ((sym (string->symbol str)) (psym (string->symbol (string-append "-" str)))) `((,(r 'define-foreign-variable) ,psym unsigned-integer ,str) (,(r 'define) ,sym ,psym)))) (cdr e))))) (include "sdl-base-foreign-types-include.scm") (define-syntax pointer-to-record-lambda (ir-macro-transformer (lambda (e i c) (let ((record-name (cadr e))) `(lambda (pointer) (and pointer (,(i (symbol-append 'make- (strip-syntax record-name))) pointer))))))) ;--------------------------------------------------------------------------- (define-record ttf-font pointer) (define-record-printer (ttf-font f out) (fprintf out "#" (ttf-font-pointer f))) (define-foreign-type TTF_Font (c-pointer "TTF_Font") ttf-font-pointer (lambda (p) (set-finalizer! ((pointer-to-record-lambda ttf-font) p) ttf-close-font))) (define ttf-init (foreign-lambda integer "TTF_Init")) (define ttf-was-init (foreign-lambda integer "TTF_WasInit")) (define ttf-quit (foreign-lambda void "TTF_Quit")) (define ttf-compiled-version (foreign-lambda* SDL_version () "SDL_version v; SDL_TTF_VERSION(&v); C_return(&v);")) (define ttf-linked-version (foreign-lambda SDL_version "TTF_Linked_Version")) (define ttf-open-font (foreign-lambda TTF_Font "TTF_OpenFont" c-string integer)) (define ttf-open-font-index (foreign-lambda TTF_Font "TTF_OpenFontIndex" c-string integer long)) (define (ttf-close-font f) (if (ttf-font-pointer f) (begin ((foreign-lambda void "TTF_CloseFont" TTF_Font) f) (ttf-font-pointer-set! f #f)))) (--sdl-flags "TTF_STYLE_NORMAL" "TTF_STYLE_BOLD" "TTF_STYLE_ITALIC" "TTF_STYLE_UNDERLINE") (define ttf-get-font-style (foreign-lambda integer "TTF_GetFontStyle" TTF_Font)) (define ttf-set-font-style (foreign-lambda void "TTF_SetFontStyle" TTF_Font integer)) (define ttf-font-height (foreign-lambda integer "TTF_FontHeight" TTF_Font)) (define ttf-font-ascent (foreign-lambda integer "TTF_FontAscent" TTF_Font)) (define ttf-font-descent (foreign-lambda integer "TTF_FontDescent" TTF_Font)) (define ttf-font-line-skip (foreign-lambda integer "TTF_FontLineSkip" TTF_Font)) (define ttf-font-faces (foreign-lambda long "TTF_FontFaces" TTF_Font)) (define ttf-font-face-is-fixed-width? (foreign-lambda bool "TTF_FontFaceIsFixedWidth" TTF_Font)) (define ttf-font-face-family-name (foreign-lambda c-string "TTF_FontFaceFamilyName" TTF_Font)) (define ttf-font-face-style-name (foreign-lambda c-string "TTF_FontFaceStyleName" TTF_Font)) (define ttf-size-text! (foreign-lambda* bool ((TTF_Font font) (c-string text) (SDL_Rect rect)) "int ww, hh;" "int status = TTF_SizeText(font, text, &ww, &hh);" "if (status == 0) { rect->w = ww; rect->h = hh; }" "C_return((status == 0));")) (define ttf-size-utf8! (foreign-lambda* bool ((TTF_Font font) (c-string text) (SDL_Rect rect)) "int ww, hh;" "int status = TTF_SizeUTF8(font, text, &ww, &hh);" "if (status == 0) { rect->w = ww; rect->h = hh; }" "C_return((status == 0));")) (define ttf-render-text-solid (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "C_return(TTF_RenderText_Solid(font,text,*fg));")) (define ttf-render-utf8-solid (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "C_return(TTF_RenderUTF8_Solid(font,text,*fg));")) (define ttf-render-glyph-solid (foreign-lambda* SDL_Surface ((TTF_Font font) (unsigned-int ch) (SDL_Color fg)) "C_return(TTF_RenderGlyph_Solid(font,ch,*fg));")) (define ttf-render-text-shaded (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg) (SDL_Color bg)) "C_return(TTF_RenderText_Shaded(font,text,*fg,*bg));")) (define ttf-render-utf8-shaded (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg) (SDL_Color bg)) "C_return(TTF_RenderUTF8_Shaded(font,text,*fg,*bg));")) (define ttf-render-glyph-shaded (foreign-lambda* SDL_Surface ((TTF_Font font) (unsigned-int ch) (SDL_Color fg) (SDL_Color bg)) "C_return(TTF_RenderGlyph_Shaded(font,ch,*fg, *bg));")) (define ttf-render-text-blended (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "C_return(TTF_RenderText_Blended(font,text,*fg));")) (define ttf-render-utf8-blended (foreign-lambda* SDL_Surface ((TTF_Font font) (c-string text) (SDL_Color fg)) "C_return(TTF_RenderUTF8_Blended(font,text,*fg));")) (define ttf-render-glyph-blended (foreign-lambda* SDL_Surface ((TTF_Font font) (unsigned-int ch) (SDL_Color fg)) "C_return(TTF_RenderGlyph_Blended(font,ch,*fg));")) ;; ;; GlyphMetrics ;; (define-record ttf-glyph buffer) (foreign-declare "typedef struct { int minx, maxx, miny, maxy, adv; } GlyphMetrics; ") (define-foreign-variable sizeof-glyph-metrics int "sizeof(GlyphMetrics)") (let ((maker make-ttf-glyph)) (set! make-ttf-glyph (lambda () (maker (make-blob sizeof-glyph-metrics))))) (define (-sdl-unbox-ttf-glyph e) (let ((p (##sys#make-pointer))) (if e (##core#inline "C_pointer_to_block" p (ttf-glyph-buffer e))) p)) (define-foreign-type GlyphMetrics (c-pointer "GlyphMetrics") -sdl-unbox-ttf-glyph) (define-record-printer (ttf-glyph o out) (fprintf out "#" (ttf-glyph-minx o) (ttf-glyph-maxx o) (ttf-glyph-miny o) (ttf-glyph-maxy o) (ttf-glyph-advance o))) (define ttf-glyph-minx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->minx);")) (define ttf-glyph-maxx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxx);")) (define ttf-glyph-miny (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->miny);")) (define ttf-glyph-maxy (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxy);")) (define ttf-glyph-advance (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->adv);")) (define ttf-glyph-metrics (foreign-lambda* bool ((TTF_Font font) (unsigned-int c) (GlyphMetrics gm)) "C_return((0 == TTF_GlyphMetrics(font, c, &gm->minx, &gm->maxx, &gm->miny, &gm->maxy, &gm->adv)));")))