basis/images/loader/gdiplus/gdiplus.factor

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