basis/images/loader/gdiplus/gdiplus.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.enums alien.strings
   3 assocs byte-arrays classes.struct destructors grouping images images.loader
   4 io kernel locals math mime.types namespaces sequences specialized-arrays
   5 system windows.com windows.gdiplus windows.streams windows.types ;
   6 IN: images.loader.gdiplus
   7
   8 SPECIALIZED-ARRAY: ImageCodecInfo
   9
  10 SINGLETON: gdi+-image
  11
  12 os windows? [
  13     { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }
  14     [ gdi+-image register-image-class ] each
  15 ] when
  16
  17 <PRIVATE
  18
  19 : <GpRect> ( x y w h -- rect )
  20     GpRect <struct-boa> ; inline
  21
  22 : stream>gdi+-bitmap ( stream -- bitmap )
  23     stream>IStream &com-release
  24     { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]
  25     with-out-parameters &GdipFree ;
  26
  27 : gdi+-bitmap-width ( bitmap -- w )
  28     { UINT } [ GdipGetImageWidth check-gdi+-status ]
  29     with-out-parameters ;
  30
  31 : gdi+-bitmap-height ( bitmap -- h )
  32     { UINT } [ GdipGetImageHeight check-gdi+-status ]
  33     with-out-parameters ;
  34
  35 : gdi+-lock-bitmap ( bitmap rect mode format -- data )
  36     { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
  37     with-out-parameters ;
  38
  39 :: gdi+-bitmap>data ( bitmap -- w h pixels )
  40     bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
  41     bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
  42     PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
  43     bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
  44     memory>byte-array :> pixels
  45     bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
  46     w h pixels ;
  47
  48 :: data>image ( w h pixels -- image )
  49     image new
  50         { w h } >>dim
  51         pixels >>bitmap
  52         BGRA >>component-order
  53         ubyte-components >>component-type
  54         f >>upside-down? ;
  55
  56 ! Only one pixel format supported, but I can't find images in the
  57 ! wild, loaded using gdi+, in which the format is different.
  58 ERROR: unsupported-pixel-format component-order ;
  59
  60 : check-pixel-format ( image -- )
  61     component-order>> dup BGRA = [ drop ] [ throw-unsupported-pixel-format ] if ;
  62
  63 : image>gdi+-bitmap ( image -- bitmap )
  64     dup check-pixel-format
  65     [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri
  66     { void* } [
  67         GdipCreateBitmapFromScan0 check-gdi+-status
  68     ] with-out-parameters &GdipFree ;
  69
  70 : image-encoders-size ( -- num size )
  71     { UINT UINT } [
  72         GdipGetImageEncodersSize check-gdi+-status
  73     ] with-out-parameters ;
  74
  75 : image-encoders ( -- codec-infos )
  76     image-encoders-size dup <byte-array> 3dup
  77     GdipGetImageEncoders check-gdi+-status
  78     nip swap ImageCodecInfo <c-direct-array> ;
  79
  80 : extension>mime-type ( extension -- mime-type )
  81     ! Crashes if you let this mime through on my machine.
  82     dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;
  83
  84 : mime-type>clsid ( mime-type -- clsid )
  85     image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;
  86
  87 : startup-gdi+ ( -- )
  88     start-gdi+ &stop-gdi+ drop ;
  89
  90 : write-image-to-stream ( image stream extension -- )
  91     [ image>gdi+-bitmap ]
  92     [ stream>IStream &com-release ]
  93     [ extension>mime-type mime-type>clsid ] tri*
  94     f GdipSaveImageToStream check-gdi+-status ;
  95
  96 PRIVATE>
  97
  98 M: gdi+-image stream>image*
  99     drop startup-gdi+
 100     stream>gdi+-bitmap
 101     gdi+-bitmap>data
 102     data>image ;
 103
 104 M: gdi+-image image>stream ( image extension class -- )
 105     drop startup-gdi+ output-stream get swap write-image-to-stream ;