basis/windows/offscreen/offscreen.factor

   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
   5 accessors fry locals ;
   6 IN: windows.offscreen
   7
   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 ]
  22         } 2cleave
  23     ] keep ;
  24
  25 : make-bitmap ( dim dc -- hBitmap bits )
  26     [ nip ]
  27     [
  28         swap (bitmap-info) DIB_RGB_COLORS f <void*>
  29         [ f 0 CreateDIBSection ] keep *void*
  30     ] 2bi
  31     [ [ SelectObject drop ] keep ] dip ;
  32
  33 : make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
  34     [ f CreateCompatibleDC ] dip over make-bitmap ;
  35
  36 : bitmap>byte-array ( bits dim -- byte-array )
  37     product 4 * memory>byte-array ;
  38
  39 : bitmap>image ( bits dim -- image )
  40     [ bitmap>byte-array ] keep
  41     <image>
  42         swap >>dim
  43         swap >>bitmap
  44         BGRX >>component-order
  45         ubyte-components >>component-type
  46         t >>upside-down? ;
  47
  48 : with-memory-dc ( quot: ( hDC -- ) -- )
  49     [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
  50
  51 :: make-bitmap-image ( dim dc quot -- image )
  52     dim dc make-bitmap [ &DeleteObject drop ] dip
  53     quot dip
  54     dim bitmap>image ; inline