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 ;
   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-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
  26     f CreateCompatibleDC
  27     [ nip ]
  28     [
  29         swap (bitmap-info) DIB_RGB_COLORS f <void*>
  30         [ f 0 CreateDIBSection ] keep *void*
  31     ] 2bi
  32     [ 2dup SelectObject drop ] dip ;
  33
  34 : bitmap>byte-array ( bits dim -- byte-array )
  35     product 4 * memory>byte-array ;
  36
  37 : bitmap>image ( bits dim -- image )
  38     [ bitmap>byte-array ] keep
  39     <image> swap >>dim swap >>bitmap XBGR >>component-order ;
  40
  41 : make-bitmap-image ( dim quot: ( hDC -- ) -- image )
  42     '[
  43         [
  44             make-offscreen-dc-and-bitmap
  45             [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
  46         ] keep bitmap>byte-array
  47     ] with-destructors ; inline