111 lines
3.6 KiB
Factor
111 lines
3.6 KiB
Factor
! (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 libc locals math mime.types namespaces sequences specialized-arrays
|
|
system windows.com windows.gdiplus windows.streams windows.types ;
|
|
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 )
|
|
! Copy the rect to stack space because the gc might move it
|
|
! because calling GdipBitmapLockBits triggers callbacks to Factor.
|
|
{ BitmapData GpRect } [
|
|
:> ( stack-data stack-rect )
|
|
stack-rect rect binary-object memcpy
|
|
bitmap stack-rect mode format stack-data GdipBitmapLockBits
|
|
check-gdi+-status
|
|
] with-out-parameters drop ;
|
|
|
|
:: 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? ;
|
|
|
|
! Loaded images usually have the format BGRA, text rendered BGRX.
|
|
ERROR: unsupported-pixel-format component-order ;
|
|
|
|
: check-pixel-format ( component-order -- )
|
|
dup { BGRX BGRA } member? [ drop ] [ unsupported-pixel-format ] if ;
|
|
|
|
: image>gdi+-bitmap ( image -- bitmap )
|
|
dup component-order>> 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 ;
|