basis/ui/backend/windows/windows.factor

   1 ! Copyright (C) 2005, 2006 Doug Coleman.
   2 ! Portions copyright (C) 2007, 2009 Slava Pestov.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: alien alien.c-types alien.strings arrays assocs ui
   5 ui.private ui.gadgets ui.gadgets.private ui.backend
   6 ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
   7 kernel math math.vectors namespaces make sequences strings
   8 vectors words windows.kernel32 windows.gdi32 windows.user32
   9 windows.opengl32 windows.messages windows.types windows.nt
  10 windows threads libc combinators fry combinators.short-circuit
  11 continuations command-line shuffle opengl ui.render ascii
  12 math.bitwise locals accessors math.rectangles math.order ascii
  13 calendar io.encodings.utf16n ;
  14 IN: ui.backend.windows
  15
  16 SINGLETON: windows-ui-backend
  17
  18 : crlf>lf ( str -- str' )
  19     CHAR: \r swap remove ;
  20
  21 : lf>crlf ( str -- str' )
  22     [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
  23
  24 : enum-clipboard ( -- seq )
  25     0
  26     [ EnumClipboardFormats win32-error dup dup 0 > ]
  27     [ ]
  28     produce 2nip ;
  29
  30 : with-clipboard ( quot -- )
  31     f OpenClipboard win32-error=0/f
  32     call
  33     CloseClipboard win32-error=0/f ; inline
  34
  35 : paste ( -- str )
  36     [
  37         CF_UNICODETEXT IsClipboardFormatAvailable zero? [
  38             ! nothing to paste
  39             ""
  40         ] [
  41             CF_UNICODETEXT GetClipboardData dup win32-error=0/f
  42             dup GlobalLock dup win32-error=0/f
  43             GlobalUnlock win32-error=0/f
  44             utf16n alien>string
  45         ] if
  46     ] with-clipboard
  47     crlf>lf ;
  48
  49 : copy ( str -- )
  50     lf>crlf [
  51         utf16n string>alien
  52         EmptyClipboard win32-error=0/f
  53         GMEM_MOVEABLE over length 1+ GlobalAlloc
  54             dup win32-error=0/f
  55
  56         dup GlobalLock dup win32-error=0/f
  57         swapd byte-array>memory
  58         dup GlobalUnlock win32-error=0/f
  59         CF_UNICODETEXT swap SetClipboardData win32-error=0/f
  60     ] with-clipboard ;
  61
  62 TUPLE: pasteboard ;
  63 C: <pasteboard> pasteboard
  64
  65 M: pasteboard clipboard-contents drop paste ;
  66 M: pasteboard set-clipboard-contents drop copy ;
  67
  68 : init-clipboard ( -- )
  69     <pasteboard> clipboard set-global
  70     <clipboard> selection set-global ;
  71
  72 TUPLE: win-base hDC hRC ;
  73 TUPLE: win < win-base hWnd world title ;
  74 TUPLE: win-offscreen < win-base hBitmap bits ;
  75 C: <win> win
  76 C: <win-offscreen> win-offscreen
  77
  78 SYMBOLS: msg-obj class-name-ptr mouse-captured ;
  79
  80 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
  81 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
  82
  83 : get-RECT-top-left ( RECT -- x y )
  84     [ RECT-left ] keep RECT-top ;
  85
  86 : get-RECT-dimensions ( RECT -- x y width height )
  87     [ get-RECT-top-left ] keep
  88     [ RECT-right ] keep [ RECT-left - ] keep
  89     [ RECT-bottom ] keep RECT-top - ;
  90
  91 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
  92     #! wParam and lParam are unused
  93     #! only paint if width/height both > 0
  94     3drop window relayout-1 yield ;
  95
  96 : handle-wm-size ( hWnd uMsg wParam lParam -- )
  97     2nip
  98     [ lo-word ] keep hi-word 2array
  99     dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
 100
 101 : handle-wm-move ( hWnd uMsg wParam lParam -- )
 102     2nip
 103     [ lo-word ] keep hi-word 2array
 104     swap window (>>window-loc) ;
 105
 106 CONSTANT: wm-keydown-codes
 107     H{
 108         { 8 "BACKSPACE" }
 109         { 9 "TAB" }
 110         { 13 "RET" }
 111         { 27 "ESC" }
 112         { 33 "PAGE_UP" }
 113         { 34 "PAGE_DOWN" }
 114         { 35 "END" }
 115         { 36 "HOME" }
 116         { 37 "LEFT" }
 117         { 38 "UP" }
 118         { 39 "RIGHT" }
 119         { 40 "DOWN" }
 120         { 45 "INSERT" }
 121         { 46 "DELETE" }
 122         { 112 "F1" }
 123         { 113 "F2" }
 124         { 114 "F3" }
 125         { 115 "F4" }
 126         { 116 "F5" }
 127         { 117 "F6" }
 128         { 118 "F7" }
 129         { 119 "F8" }
 130         { 120 "F9" }
 131         { 121 "F10" }
 132         { 122 "F11" }
 133         { 123 "F12" }
 134     }
 135
 136 : key-state-down? ( key -- ? )
 137     GetKeyState 16 bit? ;
 138
 139 : left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
 140 : left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
 141 : left-alt? ( -- ? ) VK_LMENU key-state-down? ;
 142 : right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
 143 : right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
 144 : right-alt? ( -- ? ) VK_RMENU key-state-down? ;
 145 : shift? ( -- ? ) left-shift? right-shift? or ;
 146 : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
 147 : alt? ( -- ? ) left-alt? right-alt? or ;
 148 : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
 149
 150 : key-modifiers ( -- seq )
 151     [
 152         shift? [ S+ , ] when
 153         ctrl? [ C+ , ] when
 154         alt? [ A+ , ] when
 155     ] { } make [ empty? not ] keep f ? ;
 156
 157 CONSTANT: exclude-keys-wm-keydown
 158     H{
 159         { 16 "SHIFT" }
 160         { 17 "CTRL" }
 161         { 18 "ALT" }
 162         { 20 "CAPS-LOCK" }
 163     }
 164
 165 ! Values are ignored
 166 CONSTANT: exclude-keys-wm-char
 167     H{
 168         { 8 "BACKSPACE" }
 169         { 9 "TAB" }
 170         { 13 "RET" }
 171         { 27 "ESC" }
 172     }
 173
 174 : exclude-key-wm-keydown? ( n -- ? )
 175     exclude-keys-wm-keydown key? ;
 176
 177 : exclude-key-wm-char? ( n -- ? )
 178     exclude-keys-wm-char key? ;
 179
 180 : keystroke>gesture ( n -- mods sym )
 181     wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
 182
 183 : send-key-gesture ( sym action? quot hWnd -- )
 184     [ [ key-modifiers ] 3dip call ] dip
 185     window propagate-key-gesture ; inline
 186
 187 : send-key-down ( sym action? hWnd -- )
 188     [ [ <key-down> ] ] dip send-key-gesture ;
 189
 190 : send-key-up ( sym action? hWnd -- )
 191     [ [ <key-up> ] ] dip send-key-gesture ;
 192
 193 : key-sym ( wParam -- string/f action? )
 194     {
 195         {
 196             [ dup LETTER? ]
 197             [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
 198         }
 199         { [ dup digit? ] [ 1string f ] }
 200         [ wm-keydown-codes at t ]
 201     } cond ;
 202
 203 :: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
 204     wParam exclude-key-wm-keydown? [
 205         wParam key-sym over [
 206             dup ctrl? alt? xor or [
 207                 hWnd send-key-down
 208             ] [ 2drop ] if
 209         ] [ 2drop ] if
 210     ] unless ;
 211
 212 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
 213     wParam exclude-key-wm-char? [
 214         ctrl? alt? xor [
 215             wParam 1string
 216             [ f hWnd send-key-down ]
 217             [ hWnd window user-input ] bi
 218         ] unless
 219     ] unless ;
 220
 221 :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
 222     wParam exclude-key-wm-keydown? [
 223         wParam key-sym over [
 224             hWnd send-key-up
 225         ] [ 2drop ] if
 226     ] unless ;
 227
 228 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
 229     ? hwnd window (>>active?)
 230     hwnd uMsg wParam lParam DefWindowProc ;
 231
 232 : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
 233     {
 234         { [ over SC_MINIMIZE = ] [ f set-window-active ] }
 235         { [ over SC_RESTORE = ] [ t set-window-active ] }
 236         { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
 237         { [ dup alpha? ] [ 4drop 0 ] }
 238         { [ t ] [ DefWindowProc ] }
 239     } cond ;
 240
 241 : cleanup-window ( handle -- )
 242     dup title>> [ free ] when*
 243     dup hRC>> wglDeleteContext win32-error=0/f
 244     dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
 245
 246 M: windows-ui-backend (close-window)
 247     dup hWnd>> unregister-window
 248     dup cleanup-window
 249     hWnd>> DestroyWindow win32-error=0/f ;
 250
 251 : handle-wm-close ( hWnd uMsg wParam lParam -- )
 252     3drop window ungraft ;
 253
 254 : handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
 255     3drop window [ focus-world ] when* ;
 256
 257 : handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
 258     3drop window [ unfocus-world ] when* ;
 259
 260 : message>button ( uMsg -- button down? )
 261     {
 262         { WM_LBUTTONDOWN   [ 1 t ] }
 263         { WM_LBUTTONUP     [ 1 f ] }
 264         { WM_MBUTTONDOWN   [ 2 t ] }
 265         { WM_MBUTTONUP     [ 2 f ] }
 266         { WM_RBUTTONDOWN   [ 3 t ] }
 267         { WM_RBUTTONUP     [ 3 f ] }
 268
 269         { WM_NCLBUTTONDOWN [ 1 t ] }
 270         { WM_NCLBUTTONUP   [ 1 f ] }
 271         { WM_NCMBUTTONDOWN [ 2 t ] }
 272         { WM_NCMBUTTONUP   [ 2 f ] }
 273         { WM_NCRBUTTONDOWN [ 3 t ] }
 274         { WM_NCRBUTTONUP   [ 3 f ] }
 275     } case ;
 276
 277 ! If the user clicks in the window border ("non-client area")
 278 ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
 279 ! mouse is subsequently released outside the NC area, we receive
 280 ! a [LMR]BUTTONUP message and Factor can get confused. So we
 281 ! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
 282 SYMBOL: nc-buttons
 283
 284 : handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
 285     2drop nip
 286     message>button nc-buttons get
 287     swap [ push ] [ delete ] if ;
 288
 289 : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
 290
 291 : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
 292
 293 : mouse-event>gesture ( uMsg -- button )
 294     key-modifiers swap message>button
 295     [ <button-down> ] [ <button-up> ] if ;
 296
 297 :: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
 298     uMsg mouse-event>gesture
 299     lParam >lo-hi
 300     hWnd window ;
 301
 302 : set-capture ( hwnd -- )
 303     mouse-captured get [
 304         drop
 305     ] [
 306         [ SetCapture drop ] keep
 307         mouse-captured set
 308     ] if ;
 309
 310 : release-capture ( -- )
 311     ReleaseCapture win32-error=0/f
 312     mouse-captured off ;
 313
 314 : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
 315     [
 316         over set-capture
 317         dup message>button drop nc-buttons get delete
 318     ] 2dip prepare-mouse send-button-down ;
 319
 320 : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
 321     mouse-captured get [ release-capture ] when
 322     pick message>button drop dup nc-buttons get member? [
 323         nc-buttons get delete 4drop
 324     ] [
 325         drop prepare-mouse send-button-up
 326     ] if ;
 327
 328 : make-TRACKMOUSEEVENT ( hWnd -- alien )
 329     "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
 330     "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
 331
 332 : handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
 333     2nip
 334     over make-TRACKMOUSEEVENT
 335     TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
 336     0 over set-TRACKMOUSEEVENT-dwHoverTime
 337     TrackMouseEvent drop
 338     >lo-hi swap window move-hand fire-motion ;
 339
 340 :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
 341     wParam mouse-wheel hand-loc get hWnd window send-wheel ;
 342
 343 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
 344     #! message sent if windows needs application to stop dragging
 345     4drop release-capture ;
 346
 347 : handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
 348     #! message sent if mouse leaves main application
 349     4drop forget-rollover ;
 350
 351 SYMBOL: wm-handlers
 352
 353 H{ } clone wm-handlers set-global
 354
 355 : add-wm-handler ( quot wm -- )
 356     dup array?
 357     [ [ execute( -- wm ) add-wm-handler ] with each ]
 358     [ wm-handlers get-global set-at ] if ;
 359
 360 [ handle-wm-close 0                  ] WM_CLOSE add-wm-handler
 361 [ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
 362
 363 [ handle-wm-size 0 ] WM_SIZE add-wm-handler
 364 [ handle-wm-move 0 ] WM_MOVE add-wm-handler
 365
 366 [ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
 367 [ 4dup handle-wm-char DefWindowProc    ] { WM_CHAR WM_SYSCHAR }       add-wm-handler
 368 [ 4dup handle-wm-keyup DefWindowProc   ] { WM_KEYUP WM_SYSKEYUP }     add-wm-handler
 369
 370 [ handle-wm-syscommand   ] WM_SYSCOMMAND add-wm-handler
 371 [ handle-wm-set-focus 0  ] WM_SETFOCUS add-wm-handler
 372 [ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
 373
 374 [ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
 375 [ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
 376 [ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
 377 [ handle-wm-buttonup 0   ] WM_LBUTTONUP   add-wm-handler
 378 [ handle-wm-buttonup 0   ] WM_MBUTTONUP   add-wm-handler
 379 [ handle-wm-buttonup 0   ] WM_RBUTTONUP   add-wm-handler
 380
 381 [ 4dup handle-wm-ncbutton DefWindowProc ]
 382 { WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
 383 WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
 384 add-wm-handler
 385
 386 [ nc-buttons get-global delete-all DefWindowProc ]
 387 { WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
 388
 389 [ handle-wm-mousemove 0  ] WM_MOUSEMOVE  add-wm-handler
 390 [ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
 391 [ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
 392 [ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
 393
 394 SYMBOL: trace-messages?
 395
 396 ! return 0 if you handle the message, else just let DefWindowProc return its val
 397 : ui-wndproc ( -- object )
 398     "uint" { "void*" "uint" "long" "long" } "stdcall" [
 399         pick
 400         trace-messages? get-global [ dup windows-message-name name>> print flush ] when
 401         wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
 402      ] alien-callback ;
 403
 404 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 405
 406 M: windows-ui-backend do-events
 407     msg-obj get-global
 408     dup peek-message? [ drop ui-wait ] [
 409         [ TranslateMessage drop ]
 410         [ DispatchMessage drop ] bi
 411     ] if ;
 412
 413 : register-wndclassex ( -- class )
 414     "WNDCLASSEX" <c-object>
 415     f GetModuleHandle
 416     class-name-ptr get-global
 417     pick GetClassInfoEx zero? [
 418         "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
 419         { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
 420         ui-wndproc over set-WNDCLASSEX-lpfnWndProc
 421         0 over set-WNDCLASSEX-cbClsExtra
 422         0 over set-WNDCLASSEX-cbWndExtra
 423         f GetModuleHandle over set-WNDCLASSEX-hInstance
 424         f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
 425         over set-WNDCLASSEX-hIcon
 426         f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
 427
 428         class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
 429         RegisterClassEx dup win32-error=0/f
 430     ] when ;
 431
 432 : adjust-RECT ( RECT -- )
 433     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 434
 435 : make-RECT ( world -- RECT )
 436     [ window-loc>> dup ] [ dim>> ] bi v+
 437     "RECT" <c-object>
 438     over first over set-RECT-right
 439     swap second over set-RECT-bottom
 440     over first over set-RECT-left
 441     swap second over set-RECT-top ;
 442
 443 : default-position-RECT ( RECT -- )
 444     dup get-RECT-dimensions [ 2drop ] 2dip
 445     CW_USEDEFAULT + pick set-RECT-bottom
 446     CW_USEDEFAULT + over set-RECT-right
 447     CW_USEDEFAULT over set-RECT-left
 448     CW_USEDEFAULT swap set-RECT-top ;
 449
 450 : make-adjusted-RECT ( rect -- RECT )
 451     make-RECT
 452     dup get-RECT-top-left [ zero? ] both? swap
 453     dup adjust-RECT
 454     swap [ dup default-position-RECT ] when ;
 455
 456 : create-window ( rect -- hwnd )
 457     make-adjusted-RECT
 458     [ class-name-ptr get-global f ] dip
 459     [
 460         [ ex-style ] 2dip
 461         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
 462     ] dip get-RECT-dimensions
 463     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 464
 465 : show-window ( hWnd -- )
 466     dup SW_SHOW ShowWindow drop ! always succeeds
 467     dup SetForegroundWindow drop
 468     SetFocus drop ;
 469
 470 : init-win32-ui ( -- )
 471     V{ } clone nc-buttons set-global
 472     "MSG" malloc-object msg-obj set-global
 473     "Factor-window" utf16n malloc-string class-name-ptr set-global
 474     register-wndclassex drop
 475     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 476
 477 : cleanup-win32-ui ( -- )
 478     class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
 479     msg-obj get-global [ free ] when*
 480     f class-name-ptr set-global
 481     f msg-obj set-global ;
 482
 483 : setup-pixel-format ( hdc flags -- )
 484     32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
 485     swapd SetPixelFormat win32-error=0/f ;
 486
 487 : get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
 488
 489 : get-rc ( hDC -- hRC )
 490     dup wglCreateContext dup win32-error=0/f
 491     [ wglMakeCurrent win32-error=0/f ] keep ;
 492
 493 : setup-gl ( hwnd -- hDC hRC )
 494     get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
 495
 496 M: windows-ui-backend (open-window) ( world -- )
 497     [ create-window [ setup-gl ] keep ] keep
 498     [ f <win> ] keep
 499     [ swap hWnd>> register-window ] 2keep
 500     dupd (>>handle)
 501     hWnd>> show-window ;
 502
 503 M: win-base select-gl-context ( handle -- )
 504     [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
 505     GdiFlush drop ;
 506
 507 M: win-base flush-gl-context ( handle -- )
 508     hDC>> SwapBuffers win32-error=0/f ;
 509
 510 : (bitmap-info) ( dim -- BITMAPINFO )
 511     "BITMAPINFO" <c-object> [
 512         BITMAPINFO-bmiHeader {
 513             [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
 514             [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
 515             [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
 516             [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
 517             [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
 518             [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
 519             [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
 520             [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
 521             [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
 522             [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
 523             [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
 524         } 2cleave
 525     ] keep ;
 526
 527 : make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
 528     f CreateCompatibleDC
 529     dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
 530     [ f 0 CreateDIBSection ] keep *void*
 531     [ 2dup SelectObject drop ] dip ;
 532
 533 : setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
 534     make-offscreen-dc-and-bitmap [
 535         [ dup offscreen-pfd-dwFlags setup-pixel-format ]
 536         [ get-rc ] bi
 537     ] 2dip ;
 538
 539 M: windows-ui-backend (open-offscreen-buffer) ( world -- )
 540     dup dim>> setup-offscreen-gl <win-offscreen>
 541     >>handle drop ;
 542
 543 M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
 544     [ hDC>> DeleteDC drop ]
 545     [ hBitmap>> DeleteObject drop ] bi ;
 546
 547 ! Windows 32-bit bitmaps don't actually use the alpha byte of
 548 ! each pixel; it's left as zero
 549
 550 : (make-opaque) ( byte-array -- byte-array' )
 551     [ length 4 / ]
 552     [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
 553     [ ] tri ;
 554
 555 : (opaque-pixels) ( world -- pixels )
 556     [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
 557     memory>byte-array (make-opaque) ;
 558
 559 M: windows-ui-backend offscreen-pixels ( world -- alien w h )
 560     [ (opaque-pixels) ] [ dim>> first2 ] bi ;
 561
 562 M: windows-ui-backend raise-window* ( world -- )
 563     handle>> [ hWnd>> SetFocus drop ] when* ;
 564
 565 M: windows-ui-backend set-title ( string world -- )
 566     handle>>
 567     dup title>> [ free ] when*
 568     swap utf16n malloc-string
 569     [ >>title ]
 570     [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
 571
 572 M: windows-ui-backend (with-ui)
 573     [
 574         [
 575             init-clipboard
 576             init-win32-ui
 577             start-ui
 578             event-loop
 579         ] [ cleanup-win32-ui ] [ ] cleanup
 580     ] ui-running ;
 581
 582 M: windows-ui-backend beep ( -- )
 583     0 MessageBeep drop ;
 584
 585 windows-ui-backend ui-backend set-global
 586
 587 [ "ui.tools" ] main-vocab-hook set-global