source: project/release/5/freetype/trunk/freetype.scm @ 37529

Last change on this file since 37529 was 37529, checked in by Kooda, 14 months ago

release/5/freetype: Remove the reserved struct component

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