basis/images/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 arrays combinators
   4 destructors gdk.pixbuf.ffi gobject.ffi grouping images
   5 images.loader io kernel locals math sequences
   6 specialized-arrays ;
   7 FROM: system => os linux freebsd netbsd openbsd ;
   8 IN: images.gtk
   9 SPECIALIZED-ARRAY: uchar
  10
  11 SINGLETON: gtk-image
  12
  13 os { linux freebsd netbsd openbsd } member? [
  14     "png"  gtk-image register-image-class
  15     "tif"  gtk-image register-image-class
  16     "tiff" gtk-image register-image-class
  17     "gif"  gtk-image register-image-class
  18     "jpg"  gtk-image register-image-class
  19     "jpeg" gtk-image register-image-class
  20     "bmp"  gtk-image register-image-class
  21     "ico"  gtk-image register-image-class
  22 ] when
  23
  24 <PRIVATE
  25
  26 : image-data ( GdkPixbuf -- data )
  27     {
  28         [ gdk_pixbuf_get_pixels ]
  29         [ gdk_pixbuf_get_width ]
  30         [ gdk_pixbuf_get_height ]
  31         [ gdk_pixbuf_get_rowstride ]
  32         [ gdk_pixbuf_get_n_channels ]
  33         [ gdk_pixbuf_get_bits_per_sample ]
  34     } cleave
  35     [let :> ( pixels w h rowstride channels bps )
  36         bps channels * 7 + 8 /i w * :> bytes-per-row
  37
  38         bytes-per-row rowstride =
  39         [ pixels h rowstride * memory>byte-array ]
  40         [
  41             pixels rowstride h * uchar <c-direct-array>
  42             rowstride <sliced-groups>
  43             [ bytes-per-row head-slice ] map concat
  44         ] if
  45     ] ;
  46
  47 : component-type ( GdkPixbuf -- component-type )
  48     gdk_pixbuf_get_bits_per_sample {
  49         {  8 [ ubyte-components ] }
  50         { 16 [ ushort-components ] }
  51         { 32 [ uint-components ] }
  52     } case ;
  53
  54 : GdkPixbuf>image ( GdkPixbuf -- image )
  55     [ image new ] dip
  56         {
  57             [ [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array >>dim ]
  58             [ image-data >>bitmap ]
  59             [ gdk_pixbuf_get_has_alpha RGBA RGB ? >>component-order ]
  60             [ component-type >>component-type ]
  61         } cleave
  62         f >>premultiplied-alpha?
  63         f >>upside-down? ;
  64
  65 PRIVATE>
  66
  67 M: gtk-image stream>image
  68     drop [
  69         stream-contents data>GInputStream &g_object_unref
  70         GInputStream>GdkPixbuf &g_object_unref
  71         GdkPixbuf>image
  72     ] with-destructors ;