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 libc 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     ! Copy the rect to stack space because the gc might move it
  37     ! because calling GdipBitmapLockBits triggers callbacks to Factor.
  38     { BitmapData GpRect } [
  39         :> ( stack-data stack-rect )
  40         stack-rect rect binary-object memcpy
  41         bitmap stack-rect mode format stack-data GdipBitmapLockBits
  42         check-gdi+-status
  43     ] with-out-parameters drop ;
  44
  45 :: gdi+-bitmap>data ( bitmap -- w h pixels )
  46     bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
  47     bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
  48     PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
  49     bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
  50     memory>byte-array :> pixels
  51     bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
  52     w h pixels ;
  53
  54 :: data>image ( w h pixels -- image )
  55     image new
  56         { w h } >>dim
  57         pixels >>bitmap
  58         BGRA >>component-order
  59         ubyte-components >>component-type
  60         f >>upside-down? ;
  61
  62 ! Loaded images usually have the format BGRA, text rendered BGRX.
  63 ERROR: unsupported-pixel-format component-order ;
  64
  65 : check-pixel-format ( component-order -- )
  66     dup { BGRX BGRA } member? [ drop ] [ unsupported-pixel-format ] if ;
  67
  68 : image>gdi+-bitmap ( image -- bitmap )
  69     dup component-order>> check-pixel-format
  70     [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri
  71     { void* } [
  72         GdipCreateBitmapFromScan0 check-gdi+-status
  73     ] with-out-parameters &GdipFree ;
  74
  75 : image-encoders-size ( -- num size )
  76     { UINT UINT } [
  77         GdipGetImageEncodersSize check-gdi+-status
  78     ] with-out-parameters ;
  79
  80 : image-encoders ( -- codec-infos )
  81     image-encoders-size dup <byte-array> 3dup
  82     GdipGetImageEncoders check-gdi+-status
  83     nip swap ImageCodecInfo <c-direct-array> ;
  84
  85 : extension>mime-type ( extension -- mime-type )
  86     ! Crashes if you let this mime through on my machine.
  87     dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;
  88
  89 : mime-type>clsid ( mime-type -- clsid )
  90     image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;
  91
  92 : startup-gdi+ ( -- )
  93     start-gdi+ &stop-gdi+ drop ;
  94
  95 : write-image-to-stream ( image stream extension -- )
  96     [ image>gdi+-bitmap ]
  97     [ stream>IStream &com-release ]
  98     [ extension>mime-type mime-type>clsid ] tri*
  99     f GdipSaveImageToStream check-gdi+-status ;
 100
 101 PRIVATE>
 102
 103 M: gdi+-image stream>image*
 104     drop startup-gdi+
 105     stream>gdi+-bitmap
 106     gdi+-bitmap>data
 107     data>image ;
 108
 109 M: gdi+-image image>stream ( image extension class -- )
 110     drop startup-gdi+ output-stream get swap write-image-to-stream ;