Split off some code from ui.backend.windows into windows.offscreen

db4
Slava Pestov 2009-03-28 22:27:18 -05:00
parent 84b5ace863
commit a58ce33bb3
6 changed files with 67 additions and 42 deletions

View File

@ -1,16 +1,16 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays assocs ui
ui.private ui.gadgets ui.gadgets.private ui.backend
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators fry combinators.short-circuit
continuations command-line shuffle opengl ui.render ascii
math.bitwise locals accessors math.rectangles math.order ascii
calendar io.encodings.utf16n ;
USING: alien alien.c-types alien.strings arrays assocs ui ui.private
ui.gadgets ui.gadgets.private ui.backend ui.clipboards
ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
math.vectors namespaces make sequences strings vectors words
windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
windows.messages windows.types windows.offscreen windows.nt windows
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
io.encodings.utf16n ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
@ -501,35 +501,12 @@ M: windows-ui-backend (open-window) ( world -- )
hWnd>> show-window ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
f CreateCompatibleDC
dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
[ f 0 CreateDIBSection ] keep *void*
[ 2dup SelectObject drop ] dip ;
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
@ -548,13 +525,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
! each pixel; it's left as zero
: (make-opaque) ( byte-array -- byte-array' )
[ length 4 / ]
[ length 4 /i ]
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
[ ] tri ;
: (opaque-pixels) ( world -- pixels )
[ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
memory>byte-array (make-opaque) ;
[ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
[ (opaque-pixels) ] [ dim>> first2 ] bi ;

View File

@ -1,7 +1,6 @@
! FUNCTION: AbortDoc
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel windows.types ;
USING: alien alien.syntax alien.destructors kernel windows.types ;
IN: windows.gdi32
! Stock Logical Objects
@ -36,6 +35,7 @@ CONSTANT: DIB_PAL_COLORS 1
LIBRARY: gdi32
! FUNCTION: AbortDoc
! FUNCTION: AbortPath
! FUNCTION: AddFontMemResourceEx
! FUNCTION: AddFontResourceA
@ -178,9 +178,11 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ;
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
DESTRUCTOR: DeleteDC
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
DESTRUCTOR: DeleteObject
! FUNCTION: DescribePixelFormat
! FUNCTION: DeviceCapabilitiesExA
! FUNCTION: DeviceCapabilitiesExW

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,47 @@
! Copyright (C) 2009 Joe Groff, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel combinators sequences
math windows.gdi32 windows.types images destructors
accessors fry ;
IN: windows.offscreen
: (bitmap-info) ( dim -- BITMAPINFO )
"BITMAPINFO" <c-object> [
BITMAPINFO-bmiHeader {
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
} 2cleave
] keep ;
: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
f CreateCompatibleDC
[ nip ]
[
swap (bitmap-info) DIB_RGB_COLORS f <void*>
[ f 0 CreateDIBSection ] keep *void*
] 2bi
[ 2dup SelectObject drop ] dip ;
: bitmap>byte-array ( bits dim -- byte-array )
product 4 * memory>byte-array ;
: bitmap>image ( bits dim -- image )
[ bitmap>byte-array ] keep
<image> swap >>dim swap >>bitmap XBGR >>component-order ;
: make-bitmap-image ( dim quot: ( hDC -- ) -- image )
'[
[
make-offscreen-dc-and-bitmap
[ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
] keep bitmap>byte-array
] with-destructors ; inline

View File

@ -1,7 +1,7 @@
! (c) 2008 Joe Groff, see license for details
USING: accessors continuations images.bitmap kernel math
sequences ui.gadgets ui.gadgets.worlds ui ui.backend
destructors ;
sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.private ui ui.backend destructors ;
IN: ui.offscreen
TUPLE: offscreen-world < world ;

View File

@ -1,3 +1,2 @@
unportable
ui
graphics