basis/images/loader/gtk/gtk.factor

   1 ! Copyright (C) 2010 Philipp Brüschweiler.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data alien.syntax arrays
   4 assocs combinators gdk.pixbuf.ffi glib.ffi gobject.ffi grouping
   5 images images.loader io kernel math sequences specialized-arrays
   6 system unicode ;
   7 IN: images.loader.gtk
   8 SPECIALIZED-ARRAY: uchar
   9
  10 SINGLETON: gtk-image
  11
  12 os linux? [
  13     { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }
  14     [ gtk-image register-image-class ] each
  15 ] when
  16
  17 <PRIVATE
  18
  19 : image-data ( GdkPixbuf -- data )
  20     {
  21         [ gdk_pixbuf_get_pixels ]
  22         [ gdk_pixbuf_get_width ]
  23         [ gdk_pixbuf_get_height ]
  24         [ gdk_pixbuf_get_rowstride ]
  25         [ gdk_pixbuf_get_n_channels ]
  26         [ gdk_pixbuf_get_bits_per_sample ]
  27     } cleave
  28     [let :> ( pixels w h rowstride channels bps )
  29         bps channels * 7 + 8 /i w * :> bytes-per-row
  30
  31         bytes-per-row rowstride =
  32         [ pixels h rowstride * memory>byte-array ]
  33         [
  34             pixels rowstride h * uchar <c-direct-array>
  35             rowstride <groups>
  36             [ bytes-per-row head-slice ] map concat
  37         ] if
  38     ] ;
  39
  40 CONSTANT: bits>components {
  41     { 8 ubyte-components }
  42     { 16 ushort-components }
  43     { 32 uint-components }
  44 }
  45
  46 : component-type ( GdkPixbuf -- component-type )
  47     gdk_pixbuf_get_bits_per_sample bits>components at ;
  48
  49 : GdkPixbuf>image ( GdkPixbuf -- image )
  50     [ image new ] dip
  51         {
  52             [ [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array >>dim ]
  53             [ image-data >>bitmap ]
  54             [ gdk_pixbuf_get_has_alpha RGBA RGB ? >>component-order ]
  55             [ component-type >>component-type ]
  56         } cleave
  57         f >>premultiplied-alpha?
  58         f >>upside-down? ;
  59
  60 : image>GdkPixbuf ( image -- GdkPixbuf )
  61     {
  62         [ bitmap>> ]
  63         [ drop GDK_COLORSPACE_RGB ]
  64         [ has-alpha? ]
  65         [ component-type>> bytes-per-component 8 * ]
  66         [ dim>> first2 ]
  67         [ rowstride ]
  68     } cleave f f gdk_pixbuf_new_from_data ;
  69
  70 : GdkPixbuf>byte-array ( GdkPixbuf type -- byte-array )
  71     { void* int } [
  72         rot f f
  73         { { pointer: GError initial: f } } [
  74             gdk_pixbuf_save_to_bufferv drop
  75         ] with-out-parameters
  76     ] with-out-parameters rot handle-GError memory>byte-array ;
  77
  78 ! The type parameter is almost always the same as the file extension,
  79 ! except for in the jpg -> jpeg and tif -> tiff cases.
  80 : extension>pixbuf-type ( extension -- type )
  81     >lower { { "jpg" "jpeg" } { "tif" "tiff" } } ?at drop ;
  82
  83 : write-image ( image extension -- )
  84     [ image>GdkPixbuf &g_object_unref ] [ extension>pixbuf-type ] bi*
  85     GdkPixbuf>byte-array write ;
  86
  87 PRIVATE>
  88
  89 M: gtk-image stream>image*
  90     drop
  91     stream-contents data>GInputStream &g_object_unref
  92     GInputStream>GdkPixbuf &g_object_unref
  93     GdkPixbuf>image ;
  94
  95 M: gtk-image image>stream
  96     drop write-image ;