source: project/release/4/sdl-ttf/trunk/sdl-ttf.scm @ 27337

Last change on this file since 27337 was 27337, checked in by megane, 9 years ago

sdl-ttf: - supports whatever the sdl egg supported + some functionality to extract glyph metrics

File size: 8.3 KB
Line 
1; Copyright (C) 2002-2004 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
2;
3; This library is free software; you can redistribute it and/or modify
4; it under the terms of the GNU Library General Public License as
5; published by the Free Software Foundation; either version 2 of the
6; License, or (at your option) any later version.
7;
8; This library is distributed in the hope that it will be useful, but
9; WITHOUT ANY WARRANTY; without even the implied warranty of
10; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11; Library General Public License for more details.
12;
13; You should have received a copy of the GNU Library General Public
14; License along with this library; if not, write to the Free
15; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
16; USA
17(module sdl-ttf
18
19( ttf-init
20  ttf-was-init
21  ttf-quit
22  ttf-compiled-version
23  ttf-linked-version
24  ttf-font?
25  ttf-font-pointer
26  ttf-open-font
27  ttf-open-font-index
28  ttf-close-font
29  ttf-get-font-style
30  ttf-set-font-style
31  ttf-size-text!
32  ttf-size-utf8!
33 
34  ttf-font-height
35  ttf-font-ascent
36  ttf-font-descent
37  ttf-font-line-skip
38  ttf-font-faces
39  ttf-font-face-is-fixed-width?
40  ttf-font-face-family-name
41  ttf-font-face-style-name
42 
43  ttf-render-text-solid
44  ttf-render-utf8-solid
45  ttf-render-glyph-solid
46  ttf-render-text-shaded
47  ttf-render-utf8-shaded
48  ttf-render-glyph-shaded
49  ttf-render-text-blended
50  ttf-render-utf8-blended
51  ttf-render-glyph-blended
52
53  make-ttf-glyph
54  ttf-glyph-metrics
55  ttf-glyph-minx
56  ttf-glyph-maxx
57  ttf-glyph-miny
58  ttf-glyph-maxy
59  ttf-glyph-advance
60 
61  TTF_STYLE_NORMAL
62  TTF_STYLE_BOLD
63  TTF_STYLE_ITALIC
64  TTF_STYLE_UNDERLINE
65
66)
67
68;---------------------------------------------------------------------------
69
70(import chicken scheme foreign)
71(use srfi-1)
72(use srfi-4)
73(use srfi-13)
74(use srfi-18)
75(use lolevel)
76(use sdl-base)
77
78(foreign-declare #<<EOF
79
80#include "SDL_ttf.h"
81#include <string.h>
82
83EOF
84)
85
86;---------------------------------------------------------------------------
87
88(define-syntax --sdl-flags
89  (lambda (e r c)
90      `(,(r 'begin)
91     ,@(append-map (lambda (str)
92                     (let* ((sym (string->symbol str))
93                            (psym (string->symbol (string-append "-" str))))
94                       `((,(r 'define-foreign-variable) ,psym unsigned-integer ,str)
95                         (,(r 'define) ,sym ,psym))))
96                   (cdr e)))))
97
98(include "sdl-base-foreign-types-include.scm")
99
100(define-syntax pointer-to-record-lambda
101  (ir-macro-transformer
102   (lambda (e i c)
103     (let ((record-name (cadr e)))
104       `(lambda (pointer)
105          (and pointer
106               (,(i (symbol-append 'make- (i record-name))) pointer)))))))
107
108;---------------------------------------------------------------------------
109
110
111(define-record ttf-font pointer)
112
113(define-record-printer (ttf-font f out)
114  (fprintf out "#<ttf-font ~S>"
115           (ttf-font-pointer f)))
116
117(define-foreign-type TTF_Font (c-pointer "TTF_Font")
118  ttf-font-pointer
119  (lambda (p)
120   (set-finalizer! ((pointer-to-record-lambda ttf-font) p)
121                   ttf-close-font)))
122
123(define ttf-init (foreign-lambda integer "TTF_Init"))
124(define ttf-was-init (foreign-lambda integer "TTF_WasInit"))
125(define ttf-quit (foreign-lambda void "TTF_Quit"))
126
127(define ttf-compiled-version
128  (foreign-lambda* SDL_version ()
129                   "SDL_version v; SDL_TTF_VERSION(&v); C_return(&v);"))
130(define ttf-linked-version
131  (foreign-lambda SDL_version "TTF_Linked_Version"))
132
133(define ttf-open-font (foreign-lambda TTF_Font "TTF_OpenFont" c-string integer))
134(define ttf-open-font-index (foreign-lambda TTF_Font "TTF_OpenFontIndex" c-string integer long))
135(define (ttf-close-font f)
136  (if (ttf-font-pointer f)
137   (begin
138     ((foreign-lambda void "TTF_CloseFont" TTF_Font) f)
139     (ttf-font-pointer-set! f #f))))
140
141(--sdl-flags "TTF_STYLE_NORMAL"
142             "TTF_STYLE_BOLD"
143             "TTF_STYLE_ITALIC"
144             "TTF_STYLE_UNDERLINE")
145
146(define ttf-get-font-style (foreign-lambda integer "TTF_GetFontStyle" TTF_Font))
147(define ttf-set-font-style (foreign-lambda void "TTF_SetFontStyle" TTF_Font integer))
148
149(define ttf-font-height (foreign-lambda integer "TTF_FontHeight" TTF_Font))
150(define ttf-font-ascent (foreign-lambda integer "TTF_FontAscent" TTF_Font))
151(define ttf-font-descent (foreign-lambda integer "TTF_FontDescent" TTF_Font))
152(define ttf-font-line-skip (foreign-lambda integer "TTF_FontLineSkip" TTF_Font))
153(define ttf-font-faces (foreign-lambda long "TTF_FontFaces" TTF_Font))
154
155(define ttf-font-face-is-fixed-width? (foreign-lambda bool "TTF_FontFaceIsFixedWidth" TTF_Font))
156(define ttf-font-face-family-name (foreign-lambda c-string "TTF_FontFaceFamilyName" TTF_Font))
157(define ttf-font-face-style-name (foreign-lambda c-string "TTF_FontFaceStyleName" TTF_Font))
158
159(define ttf-size-text! (foreign-lambda* bool ((TTF_Font font)
160                                              (c-string text)
161                                              (SDL_Rect rect))
162                                        "int ww, hh;"
163                                        "int status = TTF_SizeText(font, text, &ww, &hh);"
164                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
165                                        "C_return((status == 0));"))
166(define ttf-size-utf8! (foreign-lambda* bool ((TTF_Font font)
167                                              (c-string text)
168                                              (SDL_Rect rect))
169                                        "int ww, hh;"
170                                        "int status = TTF_SizeUTF8(font, text, &ww, &hh);"
171                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
172                                        "C_return((status == 0));"))
173
174(define ttf-render-text-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
175                                                            (c-string text)
176                                                            (SDL_Color fg))
177                                               "C_return(TTF_RenderText_Solid(font,text,*fg));"))
178(define ttf-render-utf8-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
179                                                            (c-string text)
180                                                            (SDL_Color fg))
181                                               "C_return(TTF_RenderUTF8_Solid(font,text,*fg));"))
182(define ttf-render-glyph-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
183                                                             (unsigned-int ch)
184                                                             (SDL_Color fg))
185                                                "C_return(TTF_RenderGlyph_Solid(font,ch,*fg));"))
186
187(define ttf-render-text-shaded
188  (foreign-lambda* SDL_Surface ((TTF_Font font)
189                                (c-string text)
190                                (SDL_Color fg)
191                                (SDL_Color bg))
192                   "C_return(TTF_RenderText_Shaded(font,text,*fg,*bg));"))
193(define ttf-render-utf8-shaded
194  (foreign-lambda* SDL_Surface ((TTF_Font font)
195                                (c-string text)
196                                (SDL_Color fg)
197                                (SDL_Color bg))
198                   "C_return(TTF_RenderUTF8_Shaded(font,text,*fg,*bg));"))
199(define ttf-render-glyph-shaded
200  (foreign-lambda* SDL_Surface ((TTF_Font font)
201                                (unsigned-int ch)
202                                (SDL_Color fg)
203                                (SDL_Color bg))
204                   "C_return(TTF_RenderGlyph_Shaded(font,ch,*fg, *bg));"))
205
206(define ttf-render-text-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
207                                                              (c-string text)
208                                                              (SDL_Color fg))
209                                                 "C_return(TTF_RenderText_Blended(font,text,*fg));"))
210(define ttf-render-utf8-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
211                                                              (c-string text)
212                                                              (SDL_Color fg))
213                                                 "C_return(TTF_RenderUTF8_Blended(font,text,*fg));"))
214(define ttf-render-glyph-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
215                                                              (unsigned-int ch)
216                                                              (SDL_Color fg))
217                                                 "C_return(TTF_RenderGlyph_Blended(font,ch,*fg));"))
218
219;;
220;; GlyphMetrics
221;;
222
223(define-record ttf-glyph buffer)
224
225(foreign-declare "typedef struct { int minx, maxx, miny, maxy, adv; } GlyphMetrics; ")
226(define-foreign-variable sizeof-glyph-metrics int "sizeof(GlyphMetrics)")
227
228(let ((maker make-ttf-glyph))
229  (set! make-ttf-glyph
230        (lambda () (maker (make-blob sizeof-glyph-metrics)))))
231
232(define (-sdl-unbox-ttf-glyph e)
233  (let ((p (##sys#make-pointer)))
234    (if e (##core#inline "C_pointer_to_block" p (ttf-glyph-buffer e)))
235    p))
236
237(define-foreign-type GlyphMetrics (c-pointer "GlyphMetrics")
238  -sdl-unbox-ttf-glyph)
239
240(define-record-printer (ttf-glyph o out)
241  (fprintf out "#<ttf-glyph minx: ~S maxx: ~S miny: ~S maxy: ~S adv: ~S>"
242           (ttf-glyph-minx o)
243           (ttf-glyph-maxx o)
244           (ttf-glyph-miny o)
245           (ttf-glyph-maxy o)
246           (ttf-glyph-advance o)))
247
248(define ttf-glyph-minx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->minx);"))
249(define ttf-glyph-maxx (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxx);"))
250(define ttf-glyph-miny (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->miny);"))
251(define ttf-glyph-maxy (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->maxy);"))
252(define ttf-glyph-advance (foreign-lambda* int ((GlyphMetrics o)) "C_return(o->adv);"))
253
254(define ttf-glyph-metrics
255  (foreign-lambda*
256   bool ((TTF_Font font)
257         (unsigned-int c)
258         (GlyphMetrics gm))
259   "C_return((0 == TTF_GlyphMetrics(font, c, &gm->minx, &gm->maxx, &gm->miny, &gm->maxy, &gm->adv)));")))
Note: See TracBrowser for help on using the repository browser.