1 ! Copyright (C) 2009 Joe Groff, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien.c-types kernel combinators sequences
4 math windows.gdi32 windows.types images destructors
8 : (bitmap-info) ( dim -- BITMAPINFO )
9 "BITMAPINFO" <c-object> [
10 BITMAPINFO-bmiHeader {
11 [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
12 [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
13 [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
14 [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
15 [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
16 [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
17 [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
18 [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
19 [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
20 [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
21 [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
25 : make-bitmap ( dim dc -- hBitmap bits )
28 swap (bitmap-info) DIB_RGB_COLORS f <void*>
29 [ f 0 CreateDIBSection ] keep *void*
31 [ [ SelectObject drop ] keep ] dip ;
33 : make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
34 [ f CreateCompatibleDC ] dip over make-bitmap ;
36 : bitmap>byte-array ( bits dim -- byte-array )
37 product 4 * memory>byte-array ;
39 : bitmap>image ( bits dim -- image )
40 [ bitmap>byte-array ] keep
44 BGRX >>component-order
47 : with-memory-dc ( quot: ( hDC -- ) -- )
48 [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
50 :: make-bitmap-image ( dim dc quot -- image )
51 dim dc make-bitmap [ &DeleteObject drop ] dip
53 dim bitmap>image ; inline