chiark / gitweb /
Infra: Rudimentary setup system.
[clg] / pango / pango.lisp
1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2001-2006 Espen S. Johnsen <espen@users.sf.net>
3 ;;
4 ;; Permission is hereby granted, free of charge, to any person obtaining
5 ;; a copy of this software and associated documentation files (the
6 ;; "Software"), to deal in the Software without restriction, including
7 ;; without limitation the rights to use, copy, modify, merge, publish,
8 ;; distribute, sublicense, and/or sell copies of the Software, and to
9 ;; permit persons to whom the Software is furnished to do so, subject to
10 ;; the following conditions:
11 ;;
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
14 ;;
15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22
23 ;; $Id: pango.lisp,v 1.16 2007-10-17 18:07:32 espen Exp $
24
25 (in-package "PANGO")
26
27 (defconstant +pango-scale+ 1024)
28
29 (defun device-to-pango-units (device-units)
30   (round (* device-units +pango-scale+)))
31
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33   (init-types-in-library pango "libpango-1.0" :prefix "pango_")
34   (init-types-in-library pango "libpangoxft-1.0" :prefix "pango_xft")
35   (init-types-in-library pango "libpangoft2-1.0" :prefix "pango_fc")
36   (init-types-in-library pango "libpangocairo-1.0" :prefix "pango_cairo"))
37
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40   (define-types-by-introspection "Pango"))
41   
42 (defclass font-description (boxed)
43   ((family
44     :allocation :virtual
45     :initarg :family :initform "Sans"
46     :getter "pango_font_description_get_family"
47     :setter "pango_font_description_set_family"
48     :boundp %font-description-family-boundp
49     :makunbound %font-description-family-makunbound
50     :accessor font-description-family
51     :type (static string))
52    (style
53     :allocation :virtual
54     :initarg :style :initform :normal
55     :getter "pango_font_description_get_style"
56     :setter "pango_font_description_set_style"
57     :boundp %font-description-style-boundp
58     :makunbound %font-description-style-makunbound
59     :accessor font-description-style
60     :type style)
61    (variant
62    :allocation :virtual
63    :initarg :variant :initform :normal
64    :getter "pango_font_description_get_variant"
65    :setter "pango_font_description_set_variant"
66    :boundp %font-description-variant-boundp
67    :makunbound %font-description-variant-makunbound
68    :accessor font-description-variant
69    :type variant)
70    (weight
71    :allocation :virtual :initform :normal
72    :initarg :weight
73    :getter "pango_font_description_get_weight"
74    :setter "pango_font_description_set_weight"
75    :boundp %font-description-weight-boundp
76    :makunbound %font-description-weight-makunbound
77    :accessor font-description-weight
78    :type weight)
79    (stretch
80    :allocation :virtual :initform :normal
81    :initarg :stretch
82    :getter "pango_font_description_get_stretch"
83    :setter "pango_font_description_set_stretch"
84    :boundp %font-description-stretch-boundp
85    :makunbound %font-description-stretch-makbound
86    :accessor font-description-stretch
87    :type stretch)
88    (size
89    :allocation :virtual
90 ;   :initarg :size :initform 16 ; handled by initialize instance
91 ;   :setter (setf font-description-size)
92    :setter %set-font-description-size
93    :getter "pango_font_description_get_size"
94    :boundp %font-description-size-boundp
95    :makunbound %font-description-size-makunbound
96    :reader font-description-size
97    :type integer)
98    #?(pkg-exists-p "pango" :atleast-version "1.8.0")
99    (size-is-absolute-p
100    :allocation :virtual
101 ;   :initarg :size-is-absolute :initform nil ; handled by initialize instance
102    :getter "pango_font_description_get_size_is_absolute"
103    :boundp %font-description-size-boundp
104    :reader font-description-size-is-absolute-p
105    :type boolean))
106   (:metaclass boxed-class))
107
108 (defclass layout (gobject)
109   ((context
110     :allocation :virtual
111     :getter "pango_layout_get_context"
112     :reader layout-context
113     :type context)
114    (text
115     :allocation :virtual
116     :initarg :text
117     :getter "pango_layout_get_text"
118     :setter %layout-set-text
119     :accessor layout-text
120     :type (static string))
121    (attributes 
122     :allocation :virtual
123     :initarg :attributes
124     :getter "pango_layout_get_attributes"
125     :setter "pango_layout_set_attributes"
126     :accessor layout-attributes
127     :type attr-list)
128    (font-description 
129     :allocation :virtual
130     :initarg :font-description
131     :getter "pango_layout_get_font_description"
132     :setter "pango_layout_set_font_description"
133     :accessor layout-font-description
134     :type font-description)
135    (width
136     :allocation :virtual
137     :initarg :width
138     :getter "pango_layout_get_width"
139     :setter "pango_layout_set_width"
140     :unbound -1
141     :accessor layout-width
142     :type int)
143    (wrap
144     :allocation :virtual
145     :initarg :wrap
146     :getter "pango_layout_get_wrap"
147     :setter "pango_layout_set_wrap"
148     :accessor layout-wrap
149     :type wrap-mode)
150    (ellipsize
151     :allocation :virtual
152     :initarg :ellipsize
153     :getter "pango_layout_get_ellipsize"
154     :setter "pango_layout_set_ellipsize"
155     :accessor layout-ellipsize
156     :type ellipsize-mode)
157    (indent
158     :allocation :virtual
159     :initarg :indent
160     :getter "pango_layout_get_indent"
161     :setter "pango_layout_set_indent"
162     :accessor layout-indent
163     :type int)
164    (spacing
165     :allocation :virtual
166     :initarg :spacing
167     :getter "pango_layout_get_spacing"
168     :setter "pango_layout_set_spacing"
169     :accessor layout-spacing
170     :type int)
171    (justify
172     :allocation :virtual
173     :initarg :justify
174     :getter "pango_layout_get_justify"
175     :setter "pango_layout_set_justify"
176     :accessor layout-justify-p
177     :type boolean)
178    (auto-dir
179     :allocation :virtual
180     :initarg :auto-dir
181     :getter "pango_layout_get_auto_dir"
182     :setter "pango_layout_set_auto_dir"
183     :accessor layout-auto-dir-p
184     :type boolean)
185    (alignment
186     :allocation :virtual
187     :initarg :alignment
188     :getter "pango_layout_get_alignment"
189     :setter "pango_layout_set_alignment"
190     :accessor layout-alignment
191     :type alignment)
192    (tabs
193     :allocation :virtual
194     :initarg :tabs
195     :getter "pango_layout_get_tabs"
196     :setter "pango_layout_set_tabs"
197     :accessor layout-tabs
198     :type tab-array)
199    (single-paragraph
200     :allocation :virtual
201     :initarg :single-paragraph
202     :getter "pango_layout_get_single_paragraph_mode"
203     :setter "pango_layout_set_single_paragraph_mode"
204     :accessor layout-single-paragraph-p
205     :type boolean))
206   (:metaclass gobject-class))
207
208 (defclass cairo-font-map (interface)
209   ((resolution
210     :allocation :virtual
211     :getter "pango_cairo_font_map_get_resolution"
212     :setter "pango_cairo_font_map_set_resolution"
213     :accessor cairo-font-map-resolution
214     :type double-float))
215   (:metaclass interface-class))
216
217
218 ;;;; Font description
219
220 (defmethod initialize-instance ((desc font-description) &key (size 16) size-is-absolute)
221   (call-next-method)
222   (setf (font-description-size desc size-is-absolute) size))
223
224 (defbinding %font-description-new () pointer)
225
226 (defmethod allocate-foreign ((desc font-description) &rest initargs)
227   (declare (ignore initargs))
228   (%font-description-new))
229
230 (defbinding %font-description-get-set-fields () font-mask
231   (desc font-description))
232
233 (defun %font-description-family-boundp (desc)
234   (find :family (%font-description-get-set-fields desc)))
235
236 (defun %font-description-style-boundp (desc)
237   (find :style (%font-description-get-set-fields desc)))
238
239 (defun %font-description-variant-boundp (desc)
240   (find :variant (%font-description-get-set-fields desc)))
241
242 (defun %font-description-weight-boundp (desc)
243   (find :weight (%font-description-get-set-fields desc)))
244
245 (defun %font-description-stretch-boundp (desc)
246   (find :stretch (%font-description-get-set-fields desc)))
247
248 (defun %font-description-size-boundp (desc)
249   (find :size (%font-description-get-set-fields desc)))
250
251 (defbinding %font-description-unset-fields () nil
252   (desc font-description)
253   (mask font-mask))
254
255 (defun %font-description-family-makunbound (desc)
256   (%font-description-unset-fields desc :family))
257
258 (defun %font-description-style-makunbound (desc)
259   (%font-description-unset-fields desc :style))
260
261 (defun %font-description-variant-makunbound (desc)
262   (%font-description-unset-fields desc :variant))
263
264 (defun %font-description-weight-makunbound (desc)
265   (%font-description-unset-fields desc :weight))
266
267 (defun %font-description-stretch-makunbound (desc)
268   (%font-description-unset-fields desc :stretch))
269
270 (defun %font-description-size-makunbound (desc)
271   (%font-description-unset-fields desc :size))
272
273 (defbinding %font-description-set-size () nil
274   (desc font-description)
275   (size int))
276
277 #?(pkg-exists-p "pango" :atleast-version "1.8.0")
278 (defbinding %font-description-set-absolute-size () nil
279   (desc font-description)
280   (size double-float))
281
282 (defun (setf font-description-size) (size desc &optional (absolute-p nil absolute-given-p))
283   (cond
284     (absolute-p
285       #?(pkg-exists-p "pango" :atleast-version "1.8.0")
286       (%font-description-set-absolute-size desc size)
287       #?-(pkg-exists-p "pango" :atleast-version "1.8.0")
288       (error "Setting of absolute font size requires at least Pango 1.8.0"))
289     (#?(pkg-exists-p "pango" :atleast-version "1.8.0") absolute-given-p
290      #?-(pkg-exists-p "pango" :atleast-version "1.8.0") t
291      (%font-description-set-size desc size))
292     #?(pkg-exists-p "pango" :atleast-version "1.8.0")
293     (t (if (font-description-size-is-absolute-p desc)
294            (%font-description-set-absolute-size desc size)
295          (%font-description-set-size desc size))))
296   size)
297
298 (defun %set-font-description-size (size desc)
299   (setf (font-description-size desc) size))
300
301 (defbinding font-description-merge (desc merge-desc &optional replace-p) nil
302   (desc font-description)
303   (merge-desc font-description)
304   (replace-p boolean))
305
306 (defbinding font-description-better-match () boolean
307   (desc font-description)
308   (old-math font-description)
309   (new-math font-description))
310
311 (defbinding font-description-from-string () font-description
312   (desc string))
313
314 (defbinding font-description-to-string () string
315   (desc font-description))
316
317 (defbinding font-description-copy () font-description
318   (font-description font-description))
319
320 (defun ensure-font-description (font-description &optional copy-p)
321   (etypecase font-description
322     (font-description (if copy-p
323                           (font-description-copy font-description)
324                         font-description))
325     (string (font-description-from-string font-description))
326     (list (apply #'make-instance 'font-description font-description))))
327
328
329 ;;;; Layout
330
331 (defmethod initialize-instance ((layout layout) &key markup)
332   (call-next-method)
333   (when markup
334     (layout-set-markup layout markup)))
335
336 (defmethod allocate-foreign ((layout layout) &key context)
337   (etypecase context
338     (context (%layout-new context))
339     (cairo:context (%cairo-create-layout context))))
340
341 (defbinding %layout-new () pointer
342   (context context))
343
344 (defbinding layout-copy () (referenced layout)
345   (layout layout))
346
347 (defbinding layout-context-changed () nil
348   (layout layout))
349
350 (defbinding %layout-set-text (text layout) nil
351   (layout layout)
352   (text string)
353   (-1 int))
354
355 (defbinding layout-set-markup () nil
356   (layout layout)
357   (markup string)
358   (-1 int))
359
360 (defbinding layout-get-size () nil
361   (layout layout)
362   (width int :out)
363   (height int :out))
364
365 (defbinding layout-get-pixel-size () nil
366   (layout layout)
367   (width int :out)
368   (height int :out))
369
370
371
372 ;;; Cairo Rendering
373
374 (defbinding (cairo-create-font-map "pango_cairo_font_map_new") 
375     () (referenced font-map))
376
377 (defbinding cairo-font-map-get-default () font-map)
378
379 (defbinding cairo-font-map-create-context () (referenced context)
380   (font-map cairo-font-map))
381
382 (defbinding (cairo-context-resolution "pango_cairo_context_get_resolution")
383     () double-float
384   (context context))
385
386 (defbinding %cairo-context-set-resolution () nil
387   (context context)
388   (dpi double-float))
389
390 (defun (setf cairo-context-resolution) (dpi context)
391   (%cairo-context-set-resolution context dpi))
392
393 (defbinding (cairo-context-font-options "pango_cairo_context_get_font_options")
394     () cairo:font-options
395   (context context))
396
397 (defbinding %cairo-context-set-font-options () nil
398   (context context)
399   (font-options cairo:font-options))
400
401 (defun (setf cairo-context-font-options) (font-options context)
402   (%cairo-context-set-font-options context font-options))
403
404 (defbinding %cairo-create-layout () pointer
405   (cr cairo:context))
406
407 (defbinding cairo-update-layout () nil
408   (cr cairo:context)
409   (layout layout))
410
411 (defbinding cairo-show-glyph-string () nil
412   (cr cairo:context)
413   (font font)
414   (glyphs glyph-string))
415
416 (defbinding cairo-show-layout-line () nil
417   (cr cairo:context)
418   (line layout-line))
419
420 (defbinding cairo-show-layout () nil
421   (cr cairo:context)
422   (layout layout))
423
424 (defbinding cairo-show-error-underline () nil
425   (cr cairo:context)
426   (x double-float)
427   (y double-float)
428   (width double-float)
429   (height double-float))
430
431 (defbinding cairo-glyph-string-path () nil
432   (cr cairo:context)
433   (font font)
434   (glyphs glyph-string))
435
436 (defbinding cairo-layout-line-path () nil
437   (cr cairo:context)
438   (line layout-line))
439
440 (defbinding cairo-layout-path () nil
441   (cr cairo:context)
442   (layout layout))
443
444 (defbinding cairo-error-underline-path () nil
445   (cr cairo:context)
446   (x double-float)
447   (y double-float)
448   (width double-float)
449   (height double-float))
450