basis/cairo/cairo.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! Copyright (C) 2009 Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: colors fonts cairo.ffi alien alien.c-types kernel accessors
   5 sequences namespaces fry continuations destructors math images
   6 images.memory math.rectangles ;
   7 IN: cairo
   8
   9 ERROR: cairo-error n message ;
  10
  11 : (check-cairo) ( cairo_status_t -- )
  12     dup CAIRO_STATUS_SUCCESS =
  13     [ drop ] [ [ ] [ cairo_status_to_string ] bi cairo-error ] if ;
  14
  15 : check-cairo ( cairo -- ) cairo_status (check-cairo) ;
  16
  17 : check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
  18
  19 : width>stride ( width -- stride ) uint heap-size * ; inline
  20
  21 : <image-surface> ( data dim -- surface )
  22     [ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride
  23     cairo_image_surface_create_for_data
  24     dup check-surface ;
  25
  26 : <cairo> ( surface -- cairo ) cairo_create dup check-cairo ; inline
  27
  28 : make-bitmap-image ( dim quot -- image )
  29     '[
  30         <image-surface> &cairo_surface_destroy
  31         <cairo> &cairo_destroy
  32         @
  33     ] make-memory-bitmap
  34     BGRA >>component-order
  35     ubyte-components >>component-type ; inline
  36
  37 : dummy-cairo ( -- cr )
  38     #! Sometimes we want a dummy context; eg with Pango, we want
  39     #! to measure text dimensions to create a new image context with,
  40     #! but we need an existing context to measure text dimensions
  41     #! with so we use the dummy.
  42     \ dummy-cairo [
  43         CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
  44         cairo_create
  45     ] initialize-alien ;
  46
  47 : set-source-color ( cr color -- )
  48     >rgba-components cairo_set_source_rgba ;
  49
  50 : fill-rect ( cr rect -- )
  51     [ rect-bounds [ first2 ] bi@ cairo_rectangle ]
  52     [ drop cairo_fill ]
  53     2bi ;