-! (c)2010 Joe Groff bsd license\r
-USING: accessors alien alien.c-types alien.data alien.enums alien.strings\r
-assocs byte-arrays classes.struct destructors grouping images images.loader\r
-io kernel locals math mime.types namespaces sequences specialized-arrays\r
-windows.com windows.gdiplus windows.streams windows.types ;\r
-FROM: system => os windows? ;\r
-IN: images.loader.gdiplus\r
-\r
-SPECIALIZED-ARRAY: ImageCodecInfo\r
-\r
-SINGLETON: gdi+-image\r
-\r
-os windows? [\r
- { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }\r
- [ gdi+-image register-image-class ] each\r
-] when\r
-\r
-<PRIVATE\r
-\r
-: <GpRect> ( x y w h -- rect )\r
- GpRect <struct-boa> ; inline\r
-\r
-: stream>gdi+-bitmap ( stream -- bitmap )\r
- stream>IStream &com-release\r
- { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]\r
- with-out-parameters &GdipFree ;\r
-\r
-: gdi+-bitmap-width ( bitmap -- w )\r
- { UINT } [ GdipGetImageWidth check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-: gdi+-bitmap-height ( bitmap -- h )\r
- { UINT } [ GdipGetImageHeight check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-: gdi+-lock-bitmap ( bitmap rect mode format -- data )\r
- { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]\r
- with-out-parameters ;\r
-\r
-:: gdi+-bitmap>data ( bitmap -- w h pixels )\r
- bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )\r
- bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number\r
- PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data\r
- bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri\r
- memory>byte-array :> pixels\r
- bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status\r
- w h pixels ;\r
-\r
-:: data>image ( w h pixels -- image )\r
- image new\r
- { w h } >>dim\r
- pixels >>bitmap\r
- BGRA >>component-order\r
- ubyte-components >>component-type\r
- f >>upside-down? ;\r
-\r
-! Only one pixel format supported, but I can't find images in the\r
-! wild, loaded using gdi+, in which the format is different.\r
-ERROR: unsupported-pixel-format component-order ;\r
-\r
-: check-pixel-format ( image -- )\r
- component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;\r
-\r
-: image>gdi+-bitmap ( image -- bitmap )\r
- dup check-pixel-format\r
- [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri\r
- { void* } [\r
- GdipCreateBitmapFromScan0 check-gdi+-status\r
- ] with-out-parameters &GdipFree ;\r
-\r
-: image-encoders-size ( -- num size )\r
- { UINT UINT } [\r
- GdipGetImageEncodersSize check-gdi+-status\r
- ] with-out-parameters ;\r
-\r
-: image-encoders ( -- codec-infos )\r
- image-encoders-size dup <byte-array> 3dup\r
- GdipGetImageEncoders check-gdi+-status\r
- nip swap ImageCodecInfo <c-direct-array> ;\r
-\r
-: extension>mime-type ( extension -- mime-type )\r
- ! Crashes if you let this mime through on my machine.\r
- dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;\r
-\r
-: mime-type>clsid ( mime-type -- clsid )\r
- image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;\r
-\r
-: startup-gdi+ ( -- )\r
- start-gdi+ &stop-gdi+ drop ;\r
-\r
-: write-image-to-stream ( image stream extension -- )\r
- [ image>gdi+-bitmap ]\r
- [ stream>IStream &com-release ]\r
- [ extension>mime-type mime-type>clsid ] tri*\r
- f GdipSaveImageToStream check-gdi+-status ;\r
-\r
-PRIVATE>\r
-\r
-M: gdi+-image stream>image*\r
- drop startup-gdi+\r
- stream>gdi+-bitmap\r
- gdi+-bitmap>data\r
- data>image ;\r
-\r
-M: gdi+-image image>stream ( image extension class -- )\r
- drop startup-gdi+ output-stream get swap write-image-to-stream ;\r
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.data alien.enums alien.strings
+assocs byte-arrays classes.struct destructors grouping images images.loader
+io kernel locals math mime.types namespaces sequences specialized-arrays
+windows.com windows.gdiplus windows.streams windows.types ;
+FROM: system => os windows? ;
+IN: images.loader.gdiplus
+
+SPECIALIZED-ARRAY: ImageCodecInfo
+
+SINGLETON: gdi+-image
+
+os windows? [
+ { "png" "tif" "tiff" "gif" "jpg" "jpeg" "bmp" "ico" }
+ [ gdi+-image register-image-class ] each
+] when
+
+<PRIVATE
+
+: <GpRect> ( x y w h -- rect )
+ GpRect <struct-boa> ; inline
+
+: stream>gdi+-bitmap ( stream -- bitmap )
+ stream>IStream &com-release
+ { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]
+ with-out-parameters &GdipFree ;
+
+: gdi+-bitmap-width ( bitmap -- w )
+ { UINT } [ GdipGetImageWidth check-gdi+-status ]
+ with-out-parameters ;
+
+: gdi+-bitmap-height ( bitmap -- h )
+ { UINT } [ GdipGetImageHeight check-gdi+-status ]
+ with-out-parameters ;
+
+: gdi+-lock-bitmap ( bitmap rect mode format -- data )
+ { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
+ with-out-parameters ;
+
+:: gdi+-bitmap>data ( bitmap -- w h pixels )
+ bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
+ bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
+ PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
+ bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
+ memory>byte-array :> pixels
+ bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
+ w h pixels ;
+
+:: data>image ( w h pixels -- image )
+ image new
+ { w h } >>dim
+ pixels >>bitmap
+ BGRA >>component-order
+ ubyte-components >>component-type
+ f >>upside-down? ;
+
+! Only one pixel format supported, but I can't find images in the
+! wild, loaded using gdi+, in which the format is different.
+ERROR: unsupported-pixel-format component-order ;
+
+: check-pixel-format ( image -- )
+ component-order>> dup BGRA = [ drop ] [ unsupported-pixel-format ] if ;
+
+: image>gdi+-bitmap ( image -- bitmap )
+ dup check-pixel-format
+ [ dim>> first2 ] [ rowstride PixelFormat32bppARGB ] [ bitmap>> ] tri
+ { void* } [
+ GdipCreateBitmapFromScan0 check-gdi+-status
+ ] with-out-parameters &GdipFree ;
+
+: image-encoders-size ( -- num size )
+ { UINT UINT } [
+ GdipGetImageEncodersSize check-gdi+-status
+ ] with-out-parameters ;
+
+: image-encoders ( -- codec-infos )
+ image-encoders-size dup <byte-array> 3dup
+ GdipGetImageEncoders check-gdi+-status
+ nip swap ImageCodecInfo <c-direct-array> ;
+
+: extension>mime-type ( extension -- mime-type )
+ ! Crashes if you let this mime through on my machine.
+ dup mime-types at dup "image/bmp" = [ unknown-image-extension ] when nip ;
+
+: mime-type>clsid ( mime-type -- clsid )
+ image-encoders [ MimeType>> alien>native-string = ] with find nip Clsid>> ;
+
+: startup-gdi+ ( -- )
+ start-gdi+ &stop-gdi+ drop ;
+
+: write-image-to-stream ( image stream extension -- )
+ [ image>gdi+-bitmap ]
+ [ stream>IStream &com-release ]
+ [ extension>mime-type mime-type>clsid ] tri*
+ f GdipSaveImageToStream check-gdi+-status ;
+
+PRIVATE>
+
+M: gdi+-image stream>image*
+ drop startup-gdi+
+ stream>gdi+-bitmap
+ gdi+-bitmap>data
+ data>image ;
+
+M: gdi+-image image>stream ( image extension class -- )
+ drop startup-gdi+ output-stream get swap write-image-to-stream ;
projects / factor.git / blobdiff