source: project/release/4/freetype/trunk/freetype.scm @ 20027

Last change on this file since 20027 was 20027, checked in by felix winkelmann, 11 years ago

tagged them eggs of da foof

File size: 9.4 KB
Line 
1;;;; freetype.scm -- Freetype 2 interface for Chicken
2;;
3;; Copyright (c) 2007 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5(module freetype *
6  (import scheme chicken foreign data-structures extras srfi-1 srfi-13 foreigners)
7 
8  (import-for-syntax matchable)
9
10  (foreign-declare
11   "
12#include \"ft2build.h\"
13#include FT_FREETYPE_H
14")
15
16  (define-syntax define-foreign-enum
17    (lambda (e r c)
18      `(,(r 'begin)
19        ,@(map
20           (match-lambda
21            ((name realname)
22             `(,(r 'define) ,name (,(r 'foreign-value) ,(symbol->string realname) ,(r 'int))))
23            (name `(,(r 'define) ,name (,(r 'foreign-value) ,(symbol->string name) ,(r 'int)))))
24           (cdr e)))))
25
26  (define-syntax define-foreign-record
27    (lambda (e r c)
28      (let ((rename identity)
29            (record-name (if (atom? (cadr e))
30                             (cadr e)
31                             (caadr e)))
32            (foreign-name (if (atom? (cadr e))
33                              '()
34                              (cadadr e))))
35        (for-each
36         (lambda (C)
37           (if (eq? (car C) 'rename:)
38               (set! rename (eval (cadr C)))))
39         (cddr e))
40        `(,(r 'define-foreign-record-type)
41          ,(if (null? foreign-name)
42               record-name
43               `(,(string->symbol
44                   (rename
45                    (->string record-name)))
46                 ,foreign-name))
47          ,@(remove
48             null?
49             (map
50              (match-lambda
51               (('rename: func) '())
52               (('constructor: . rest) (cons (r 'constructor:) rest))
53               (('destructor: . rest) (cons (r 'destructor:) rest))
54               ((type slotname) `(,type ,slotname
55                                        ,(string->symbol
56                                          (rename
57                                           (string-append
58                                            (->string record-name)
59                                            "-"
60                                            (->string slotname))))
61                                        ,(string->symbol
62                                          (rename
63                                           (string-append
64                                            (->string record-name)
65                                            "-"
66                                            (->string slotname)
67                                            "-set!")))))
68               ((type slotname foreignname) `(,type
69                                              ,foreignname
70                                              ,(string->symbol
71                                                (string-append
72                                                 (->string record-name)
73                                                 "-"
74                                                 (->string slotname)))
75                                              ,(string->symbol
76                                                (string-append
77                                                 (->string record-name)
78                                                 "-"
79                                                 (->string slotname)
80                                                 "-set!")))))
81              (cddr e)))))))
82
83  (define-foreign-enum
84    FT_ENCODING_NONE
85    FT_ENCODING_MS_SYMBOL
86    FT_ENCODING_UNICODE
87    FT_ENCODING_SJIS
88    FT_ENCODING_GB2312
89    FT_ENCODING_BIG5
90    FT_ENCODING_WANSUNG
91    FT_ENCODING_JOHAB
92    FT_ENCODING_ADOBE_STANDARD
93    FT_ENCODING_ADOBE_EXPERT
94    FT_ENCODING_ADOBE_CUSTOM
95    FT_ENCODING_ADOBE_LATIN_1
96    FT_ENCODING_OLD_LATIN_2
97    FT_ENCODING_APPLE_ROMAN)
98
99  (define-foreign-enum
100    FT_FACE_FLAG_SCALABLE
101    FT_FACE_FLAG_FIXED_SIZES
102    FT_FACE_FLAG_FIXED_WIDTH
103    FT_FACE_FLAG_SFNT
104    FT_FACE_FLAG_HORIZONTAL
105    FT_FACE_FLAG_VERTICAL
106    FT_FACE_FLAG_KERNING
107    FT_FACE_FLAG_FAST_GLYPHS
108    FT_FACE_FLAG_MULTIPLE_MASTERS
109    FT_FACE_FLAG_GLYPH_NAMES
110    FT_FACE_FLAG_EXTERNAL_STREAM)
111
112  (define-foreign-enum
113    FT_STYLE_FLAG_ITALIC
114    FT_STYLE_FLAG_BOLD)
115
116  (define-foreign-enum
117    FT_OPEN_MEMORY
118    FT_OPEN_STREAM
119    FT_OPEN_PATHNAME
120    FT_OPEN_DRIVER
121    FT_OPEN_PARAMS)
122
123  (define-foreign-enum
124    FT_LOAD_DEFAULT
125    FT_LOAD_NO_SCALE
126    FT_LOAD_NO_HINTING
127    FT_LOAD_RENDER
128    FT_LOAD_NO_BITMAP
129    FT_LOAD_VERTICAL_LAYOUT
130    FT_LOAD_FORCE_AUTOHINT
131    FT_LOAD_CROP_BITMAP
132    FT_LOAD_PEDANTIC
133    FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH
134    FT_LOAD_NO_RECURSE
135    FT_LOAD_IGNORE_TRANSFORM
136    FT_LOAD_MONOCHROME
137    FT_LOAD_LINEAR_DESIGN
138    FT_LOAD_TARGET_NORMAL
139    FT_LOAD_TARGET_LIGHT
140    FT_LOAD_TARGET_MONO
141    FT_LOAD_TARGET_LCD
142    FT_LOAD_TARGET_LCD_V)
143
144  (define-foreign-enum
145    FT_RENDER_MODE_NORMAL
146    FT_RENDER_MODE_LIGHT
147    FT_RENDER_MODE_MONO
148    FT_RENDER_MODE_LCD
149    FT_RENDER_MODE_LCD_V
150    FT_RENDER_MODE_MAX)
151
152  (define-foreign-enum
153    FT_KERNING_DEFAULT
154    FT_KERNING_UNFITTED
155    FT_KERNING_UNSCALED)
156
157;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
158
159  (define-foreign-record (ft-glyph-metrics FT_Glyph_Metrics)
160    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
161    (destructor: free-ft-glyph-metrics)
162    (long width)
163    (long height)
164    (long hori-bearing-x horiBearingX)
165    (long hori-bearing-y horiBearingY)
166    (long hori-advance horiAdvance)
167    (long vert-bearing-x vertBearingX)
168    (long vert-bearing-y vertBearingY)
169    (long vert-advance vertAdvance)
170    )
171
172  (define ft-init-freetype
173    (foreign-lambda*
174     c-pointer ()
175     "FT_Library library;
176    if (FT_Init_FreeType(&library)) {
177      /* error */
178      return(NULL);
179    } else {
180      return(library);
181    }"
182     ))
183
184  (define-foreign-record (ft-face FT_FaceRec)
185    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
186    (destructor: free-ft-face)
187    (long num_faces)
188    (long face_index)
189    (long face_flags)
190    (long style_flags)
191    (long num_glyphs)
192    (c-string family_name)
193    (c-string style_name)
194    (int num_fixed_sizes)
195    (c-pointer available_sizes)
196    (int num_charmaps)
197    (c-pointer charmaps)
198    (unsigned-short units_per_EM)
199    (short ascender)
200    (short descender)
201    (short height)
202    (short max_advance_width)
203    (short max_advance_height)
204    (short underline_position)
205    (short underline_thickness)
206    (c-pointer glyph)
207    (c-pointer size)
208    (c-pointer charmap)
209    )
210
211  (define ft-new-face
212    (foreign-lambda*
213     c-pointer ((c-pointer library) (c-string file))
214     "FT_Face face;
215    if (FT_New_Face(library, file, 0, &face)) {
216      /* error */
217      return(NULL);
218    } else {
219      return(face);
220    }"
221     ))
222
223  (define ft-set-char-size
224    (foreign-lambda int "FT_Set_Char_Size" c-pointer int int int int))
225
226  (define ft-set-pixel-sizes
227    (foreign-lambda int "FT_Set_Pixel_Sizes" c-pointer int int))
228
229  (define ft-get-char-index
230    (foreign-lambda unsigned-int "FT_Get_Char_Index" c-pointer int))
231
232  (define ft-load-glyph
233    (foreign-lambda int "FT_Load_Glyph" c-pointer int int))
234
235  (define ft-load-char
236    (foreign-lambda int "FT_Load_Char" c-pointer unsigned-long int))
237
238  (define ft-render-glyph
239    (foreign-lambda int "FT_Render_Glyph" c-pointer int))
240
241  (define (ft-load-glyph face ch load-options)
242    (let ((i (ft-get-char-index face (if (char? ch) (char->integer ch) ch))))
243      (and (not (zero? i))
244           (ft-load-glyph face i load-options))))
245
246  (define-foreign-record (ft-glyph-slot FT_GlyphSlotRec)
247    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
248    (destructor: free-ft-glyph-slot)
249    (c-pointer library)
250    (c-pointer face)
251    (c-pointer next)
252    (unsigned-int reserved)
253    (long linear_hori_advance linearHoriAdvance)
254    (long linear_vert_advance linearVertAdvance)
255    (int format)
256    (int bitmap_left)
257    (int bitmap_top)
258    (unsigned-int num_subglyphs)
259    (c-pointer subglyphs)
260    (c-pointer control_data)
261    (long control_len)
262    (long lsb_delta)
263    (long rsb_delta)
264    (c-pointer other)
265    )
266
267  (define ft-glyph-slot-metrics
268    (foreign-lambda*
269     c-pointer ((c-pointer ptr))
270     "FT_GlyphSlot glyph = (FT_GlyphSlot) ptr;
271    return(&(glyph->metrics));
272   "))
273
274  (define ft-glyph-slot-bitmap
275    (foreign-lambda*
276     c-pointer ((c-pointer ptr))
277     "FT_GlyphSlot glyph = (FT_GlyphSlot) ptr;
278    return(&(glyph->bitmap));
279   "))
280
281  (define-foreign-record FT_Vector
282    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
283    (constructor: make-ft-vector)
284    (destructor: free-ft-vector)
285    (long x)
286    (long y))
287
288  (define-foreign-record FT_Matrix
289    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
290    (constructor: make-ft-matrix)
291    (destructor: free-ft-matrix)
292    (long xx)
293    (long xy)
294    (long yx)
295    (long yy))
296
297  (define ft-has-kerning?
298    (foreign-lambda
299     bool "FT_HAS_KERNING"
300     (c-pointer "FT_FaceRec")))
301
302  (define ft-get-kerning
303    (foreign-lambda
304     int "FT_Get_Kerning"
305     c-pointer unsigned-int unsigned-int unsigned-int c-pointer))
306
307  (define ft-select-charmap
308    (foreign-lambda
309     int "FT_Select_Charmap"
310     c-pointer int))
311
312  (define ft-set-transform
313    (foreign-lambda
314     void "FT_Set_Transform"
315     c-pointer c-pointer c-pointer))
316
317  (define-foreign-record FT_Bitmap
318    (rename: (compose string-downcase (cut string-translate <> "_" "-")))
319    (destructor: free-ft-bitmap)
320    (int rows)
321    (int width)
322    (int pitch)
323    (c-pointer buffer)
324    (short num_grays)
325    (char pixel_mode)
326    (char palette_mode)
327    (c-pointer palette)
328    )
329
330  )
Note: See TracBrowser for help on using the repository browser.