chiark - git - mdw - clg/blob - 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