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 ui.private
   5 ui.gadgets ui.gadgets.private ui.backend ui.clipboards
   6 ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
   7 math.vectors namespaces make sequences strings vectors words
   8 windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
   9 windows.messages windows.types windows.offscreen windows.nt
  10 threads libc combinators fry combinators.short-circuit continuations
  11 command-line shuffle opengl ui.render math.bitwise locals
  12 accessors math.rectangles math.order calendar ascii
  13 io.encodings.utf16n windows.errors literals ui.pixel-formats
  14 ui.pixel-formats.private memoize classes struct-arrays ;
  15 IN: ui.backend.windows
  16
  17 SINGLETON: windows-ui-backend
  18
  19 TUPLE: win-base hDC hRC ;
  20 TUPLE: win < win-base hWnd world title ;
  21 TUPLE: win-offscreen < win-base hBitmap bits ;
  22 C: <win> win
  23 C: <win-offscreen> win-offscreen
  24
  25 <PRIVATE
  26
  27 PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
  28     { double-buffered { $ WGL_DOUBLE_BUFFER_ARB 1 } }
  29     { stereo { $ WGL_STEREO_ARB 1 } }
  30     { offscreen { $ WGL_DRAW_TO_BITMAP_ARB 1 } }
  31     { fullscreen { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
  32     { windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
  33     { accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } }
  34     { software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } }
  35     { backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } }
  36     { color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } }
  37     { color-bits { $ WGL_COLOR_BITS_ARB } }
  38     { red-bits { $ WGL_RED_BITS_ARB } }
  39     { green-bits { $ WGL_GREEN_BITS_ARB } }
  40     { blue-bits { $ WGL_BLUE_BITS_ARB } }
  41     { alpha-bits { $ WGL_ALPHA_BITS_ARB } }
  42     { accum-bits { $ WGL_ACCUM_BITS_ARB } }
  43     { accum-red-bits { $ WGL_ACCUM_RED_BITS_ARB } }
  44     { accum-green-bits { $ WGL_ACCUM_GREEN_BITS_ARB } }
  45     { accum-blue-bits { $ WGL_ACCUM_BLUE_BITS_ARB } }
  46     { accum-alpha-bits { $ WGL_ACCUM_ALPHA_BITS_ARB } }
  47     { depth-bits { $ WGL_DEPTH_BITS_ARB } }
  48     { stencil-bits { $ WGL_STENCIL_BITS_ARB } }
  49     { aux-buffers { $ WGL_AUX_BUFFERS_ARB } }
  50     { sample-buffers { $ WGL_SAMPLE_BUFFERS_ARB } }
  51     { samples { $ WGL_SAMPLES_ARB } }
  52 }
  53
  54 MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
  55     { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
  56 : has-wglChoosePixelFormatARB? ( world -- ? )
  57     handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
  58
  59 : arb-make-pixel-format ( world attributes -- pf )
  60     [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
  61     [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
  62
  63 : arb-pixel-format-attribute ( pixel-format attribute -- value )
  64     >WGL_ARB
  65     [ drop f ] [
  66         [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
  67         first <int> 0 <int>
  68         [ wglGetPixelFormatAttribivARB win32-error=0/f ]
  69         keep *int
  70     ] if-empty ;
  71
  72 CONSTANT: pfd-flag-map H{
  73     { double-buffered $ PFD_DOUBLEBUFFER }
  74     { stereo $ PFD_STEREO }
  75     { offscreen $ PFD_DRAW_TO_BITMAP }
  76     { fullscreen $ PFD_DRAW_TO_WINDOW }
  77     { windowed $ PFD_DRAW_TO_WINDOW }
  78     { backing-store $ PFD_SWAP_COPY }
  79     { software-rendered $ PFD_GENERIC_FORMAT }
  80 }
  81
  82 : >pfd-flag ( attribute -- value )
  83     pfd-flag-map at [ ] [ 0 ] if* ;
  84
  85 : >pfd-flags ( attributes -- flags )
  86     [ >pfd-flag ] [ bitor ] map-reduce
  87     PFD_SUPPORT_OPENGL bitor ;
  88
  89 : attr-value ( attributes name -- value )
  90     [ instance? ] curry find nip
  91     [ value>> ] [ 0 ] if* ;
  92
  93 : >pfd ( attributes -- pfd )
  94     "PIXELFORMATDESCRIPTOR" <c-object>
  95     "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
  96     1 over set-PIXELFORMATDESCRIPTOR-nVersion
  97     over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
  98     PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
  99     over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
 100     over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
 101     over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
 102     over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
 103     over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
 104     over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
 105     over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
 106     over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
 107     over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
 108     over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
 109     over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
 110     over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
 111     over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
 112     PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
 113     nip ;
 114
 115 : pfd-make-pixel-format ( world attributes -- pf )
 116     [ handle>> hDC>> ] [ >pfd ] bi*
 117     ChoosePixelFormat dup win32-error=0/f ;
 118
 119 : get-pfd ( pixel-format -- pfd )
 120     [ world>> handle>> hDC>> ] [ handle>> ] bi
 121     "PIXELFORMATDESCRIPTOR" heap-size
 122     "PIXELFORMATDESCRIPTOR" <c-object>
 123     [ DescribePixelFormat win32-error=0/f ] keep ;
 124
 125 : pfd-flag? ( pfd flag -- ? )
 126     [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
 127
 128 : (pfd-pixel-format-attribute) ( pfd attribute -- value )
 129     {
 130         { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] }
 131         { stereo [ PFD_STEREO pfd-flag? ] }
 132         { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] }
 133         { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
 134         { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
 135         { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
 136         { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
 137         { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
 138         { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
 139         { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
 140         { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
 141         { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
 142         { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
 143         { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
 144         { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
 145         { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
 146         { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
 147         { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
 148         { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
 149         [ 2drop f ]
 150     } case ;
 151
 152 : pfd-pixel-format-attribute ( pixel-format attribute -- value )
 153     [ get-pfd ] dip (pfd-pixel-format-attribute) ;
 154
 155 M: windows-ui-backend (make-pixel-format)
 156     over has-wglChoosePixelFormatARB?
 157     [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ;
 158
 159 M: windows-ui-backend (free-pixel-format)
 160     drop ;
 161
 162 M: windows-ui-backend (pixel-format-attribute)
 163     over world>> has-wglChoosePixelFormatARB?
 164     [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
 165
 166 PRIVATE>
 167
 168 : lo-word ( wparam -- lo ) <short> *short ; inline
 169 : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
 170 : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
 171
 172 : crlf>lf ( str -- str' )
 173     CHAR: \r swap remove ;
 174
 175 : lf>crlf ( str -- str' )
 176     [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
 177
 178 : enum-clipboard ( -- seq )
 179     0
 180     [ EnumClipboardFormats win32-error dup dup 0 > ]
 181     [ ]
 182     produce 2nip ;
 183
 184 : with-clipboard ( quot -- )
 185     f OpenClipboard win32-error=0/f
 186     call
 187     CloseClipboard win32-error=0/f ; inline
 188
 189 : paste ( -- str )
 190     [
 191         CF_UNICODETEXT IsClipboardFormatAvailable zero? [
 192             ! nothing to paste
 193             ""
 194         ] [
 195             CF_UNICODETEXT GetClipboardData dup win32-error=0/f
 196             dup GlobalLock dup win32-error=0/f
 197             GlobalUnlock win32-error=0/f
 198             utf16n alien>string
 199         ] if
 200     ] with-clipboard
 201     crlf>lf ;
 202
 203 : copy ( str -- )
 204     lf>crlf [
 205         utf16n string>alien
 206         EmptyClipboard win32-error=0/f
 207         GMEM_MOVEABLE over length 1+ GlobalAlloc
 208             dup win32-error=0/f
 209
 210         dup GlobalLock dup win32-error=0/f
 211         swapd byte-array>memory
 212         dup GlobalUnlock win32-error=0/f
 213         CF_UNICODETEXT swap SetClipboardData win32-error=0/f
 214     ] with-clipboard ;
 215
 216 TUPLE: pasteboard ;
 217 C: <pasteboard> pasteboard
 218
 219 M: pasteboard clipboard-contents drop paste ;
 220 M: pasteboard set-clipboard-contents drop copy ;
 221
 222 : init-clipboard ( -- )
 223     <pasteboard> clipboard set-global
 224     <clipboard> selection set-global ;
 225
 226 SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 227
 228 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
 229 : ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
 230
 231 : get-RECT-top-left ( RECT -- x y )
 232     [ RECT-left ] keep RECT-top ;
 233
 234 : get-RECT-dimensions ( RECT -- x y width height )
 235     [ get-RECT-top-left ] keep
 236     [ RECT-right ] keep [ RECT-left - ] keep
 237     [ RECT-bottom ] keep RECT-top - ;
 238
 239 : handle-wm-paint ( hWnd uMsg wParam lParam -- )
 240     #! wParam and lParam are unused
 241     #! only paint if width/height both > 0
 242     3drop window relayout-1 yield ;
 243
 244 : handle-wm-size ( hWnd uMsg wParam lParam -- )
 245     2nip
 246     [ lo-word ] keep hi-word 2array
 247     dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
 248
 249 : handle-wm-move ( hWnd uMsg wParam lParam -- )
 250     2nip
 251     [ lo-word ] keep hi-word 2array
 252     swap window (>>window-loc) ;
 253
 254 CONSTANT: wm-keydown-codes
 255     H{
 256         { 8 "BACKSPACE" }
 257         { 9 "TAB" }
 258         { 13 "RET" }
 259         { 27 "ESC" }
 260         { 33 "PAGE_UP" }
 261         { 34 "PAGE_DOWN" }
 262         { 35 "END" }
 263         { 36 "HOME" }
 264         { 37 "LEFT" }
 265         { 38 "UP" }
 266         { 39 "RIGHT" }
 267         { 40 "DOWN" }
 268         { 45 "INSERT" }
 269         { 46 "DELETE" }
 270         { 112 "F1" }
 271         { 113 "F2" }
 272         { 114 "F3" }
 273         { 115 "F4" }
 274         { 116 "F5" }
 275         { 117 "F6" }
 276         { 118 "F7" }
 277         { 119 "F8" }
 278         { 120 "F9" }
 279         { 121 "F10" }
 280         { 122 "F11" }
 281         { 123 "F12" }
 282     }
 283
 284 : key-state-down? ( key -- ? )
 285     GetKeyState 16 bit? ;
 286
 287 : left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
 288 : left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
 289 : left-alt? ( -- ? ) VK_LMENU key-state-down? ;
 290 : right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
 291 : right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
 292 : right-alt? ( -- ? ) VK_RMENU key-state-down? ;
 293 : shift? ( -- ? ) left-shift? right-shift? or ;
 294 : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
 295 : alt? ( -- ? ) left-alt? right-alt? or ;
 296 : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
 297
 298 : key-modifiers ( -- seq )
 299     [
 300         shift? [ S+ , ] when
 301         ctrl? [ C+ , ] when
 302         alt? [ A+ , ] when
 303     ] { } make [ empty? not ] keep f ? ;
 304
 305 CONSTANT: exclude-keys-wm-keydown
 306     H{
 307         { 16 "SHIFT" }
 308         { 17 "CTRL" }
 309         { 18 "ALT" }
 310         { 20 "CAPS-LOCK" }
 311     }
 312
 313 ! Values are ignored
 314 CONSTANT: exclude-keys-wm-char
 315     H{
 316         { 8 "BACKSPACE" }
 317         { 9 "TAB" }
 318         { 13 "RET" }
 319         { 27 "ESC" }
 320     }
 321
 322 : exclude-key-wm-keydown? ( n -- ? )
 323     exclude-keys-wm-keydown key? ;
 324
 325 : exclude-key-wm-char? ( n -- ? )
 326     exclude-keys-wm-char key? ;
 327
 328 : keystroke>gesture ( n -- mods sym )
 329     wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
 330
 331 : send-key-gesture ( sym action? quot hWnd -- )
 332     [ [ key-modifiers ] 3dip call ] dip
 333     window propagate-key-gesture ; inline
 334
 335 : send-key-down ( sym action? hWnd -- )
 336     [ [ <key-down> ] ] dip send-key-gesture ;
 337
 338 : send-key-up ( sym action? hWnd -- )
 339     [ [ <key-up> ] ] dip send-key-gesture ;
 340
 341 : key-sym ( wParam -- string/f action? )
 342     {
 343         {
 344             [ dup LETTER? ]
 345             [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
 346         }
 347         { [ dup digit? ] [ 1string f ] }
 348         [ wm-keydown-codes at t ]
 349     } cond ;
 350
 351 :: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
 352     wParam exclude-key-wm-keydown? [
 353         wParam key-sym over [
 354             dup ctrl? alt? xor or [
 355                 hWnd send-key-down
 356             ] [ 2drop ] if
 357         ] [ 2drop ] if
 358     ] unless ;
 359
 360 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
 361     wParam exclude-key-wm-char? [
 362         ctrl? alt? xor [
 363             wParam 1string
 364             [ f hWnd send-key-down ]
 365             [ hWnd window user-input ] bi
 366         ] unless
 367     ] unless ;
 368
 369 :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
 370     wParam exclude-key-wm-keydown? [
 371         wParam key-sym over [
 372             hWnd send-key-up
 373         ] [ 2drop ] if
 374     ] unless ;
 375
 376 :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
 377     ? hwnd window (>>active?)
 378     hwnd uMsg wParam lParam DefWindowProc ;
 379
 380 : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
 381     {
 382         { [ over SC_MINIMIZE = ] [ f set-window-active ] }
 383         { [ over SC_RESTORE = ] [ t set-window-active ] }
 384         { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
 385         { [ dup alpha? ] [ 4drop 0 ] }
 386         { [ t ] [ DefWindowProc ] }
 387     } cond ;
 388
 389 : cleanup-window ( handle -- )
 390     dup title>> [ free ] when*
 391     dup hRC>> wglDeleteContext win32-error=0/f
 392     dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
 393
 394 M: windows-ui-backend (close-window)
 395     dup hWnd>> unregister-window
 396     dup cleanup-window
 397     hWnd>> DestroyWindow win32-error=0/f ;
 398
 399 : handle-wm-close ( hWnd uMsg wParam lParam -- )
 400     3drop window ungraft ;
 401
 402 : handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
 403     3drop window [ focus-world ] when* ;
 404
 405 : handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
 406     3drop window [ unfocus-world ] when* ;
 407
 408 : message>button ( uMsg -- button down? )
 409     {
 410         { WM_LBUTTONDOWN   [ 1 t ] }
 411         { WM_LBUTTONUP     [ 1 f ] }
 412         { WM_MBUTTONDOWN   [ 2 t ] }
 413         { WM_MBUTTONUP     [ 2 f ] }
 414         { WM_RBUTTONDOWN   [ 3 t ] }
 415         { WM_RBUTTONUP     [ 3 f ] }
 416
 417         { WM_NCLBUTTONDOWN [ 1 t ] }
 418         { WM_NCLBUTTONUP   [ 1 f ] }
 419         { WM_NCMBUTTONDOWN [ 2 t ] }
 420         { WM_NCMBUTTONUP   [ 2 f ] }
 421         { WM_NCRBUTTONDOWN [ 3 t ] }
 422         { WM_NCRBUTTONUP   [ 3 f ] }
 423     } case ;
 424
 425 ! If the user clicks in the window border ("non-client area")
 426 ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
 427 ! mouse is subsequently released outside the NC area, we receive
 428 ! a [LMR]BUTTONUP message and Factor can get confused. So we
 429 ! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
 430 SYMBOL: nc-buttons
 431
 432 : handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
 433     2drop nip
 434     message>button nc-buttons get
 435     swap [ push ] [ delete ] if ;
 436
 437 : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
 438
 439 : mouse-event>gesture ( uMsg -- button )
 440     key-modifiers swap message>button
 441     [ <button-down> ] [ <button-up> ] if ;
 442
 443 :: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
 444     uMsg mouse-event>gesture
 445     lParam >lo-hi
 446     hWnd window ;
 447
 448 : set-capture ( hwnd -- )
 449     mouse-captured get [
 450         drop
 451     ] [
 452         [ SetCapture drop ] keep
 453         mouse-captured set
 454     ] if ;
 455
 456 : release-capture ( -- )
 457     ReleaseCapture win32-error=0/f
 458     mouse-captured off ;
 459
 460 : handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
 461     [
 462         over set-capture
 463         dup message>button drop nc-buttons get delete
 464     ] 2dip prepare-mouse send-button-down ;
 465
 466 : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
 467     mouse-captured get [ release-capture ] when
 468     pick message>button drop dup nc-buttons get member? [
 469         nc-buttons get delete 4drop
 470     ] [
 471         drop prepare-mouse send-button-up
 472     ] if ;
 473
 474 : make-TRACKMOUSEEVENT ( hWnd -- alien )
 475     "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
 476     "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
 477
 478 : handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
 479     2nip
 480     over make-TRACKMOUSEEVENT
 481     TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
 482     0 over set-TRACKMOUSEEVENT-dwHoverTime
 483     TrackMouseEvent drop
 484     >lo-hi swap window move-hand fire-motion ;
 485
 486 :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
 487     wParam mouse-wheel hand-loc get hWnd window send-wheel ;
 488
 489 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
 490     #! message sent if windows needs application to stop dragging
 491     4drop release-capture ;
 492
 493 : handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
 494     #! message sent if mouse leaves main application
 495     4drop forget-rollover ;
 496
 497 SYMBOL: wm-handlers
 498
 499 H{ } clone wm-handlers set-global
 500
 501 : add-wm-handler ( quot wm -- )
 502     dup array?
 503     [ [ execute( -- wm ) add-wm-handler ] with each ]
 504     [ wm-handlers get-global set-at ] if ;
 505
 506 [ handle-wm-close 0                  ] WM_CLOSE add-wm-handler
 507 [ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
 508
 509 [ handle-wm-size 0 ] WM_SIZE add-wm-handler
 510 [ handle-wm-move 0 ] WM_MOVE add-wm-handler
 511
 512 [ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
 513 [ 4dup handle-wm-char DefWindowProc    ] { WM_CHAR WM_SYSCHAR }       add-wm-handler
 514 [ 4dup handle-wm-keyup DefWindowProc   ] { WM_KEYUP WM_SYSKEYUP }     add-wm-handler
 515
 516 [ handle-wm-syscommand   ] WM_SYSCOMMAND add-wm-handler
 517 [ handle-wm-set-focus 0  ] WM_SETFOCUS add-wm-handler
 518 [ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
 519
 520 [ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
 521 [ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
 522 [ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
 523 [ handle-wm-buttonup 0   ] WM_LBUTTONUP   add-wm-handler
 524 [ handle-wm-buttonup 0   ] WM_MBUTTONUP   add-wm-handler
 525 [ handle-wm-buttonup 0   ] WM_RBUTTONUP   add-wm-handler
 526
 527 [ 4dup handle-wm-ncbutton DefWindowProc ]
 528 { WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
 529 WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
 530 add-wm-handler
 531
 532 [ nc-buttons get-global delete-all DefWindowProc ]
 533 { WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
 534
 535 [ handle-wm-mousemove 0  ] WM_MOUSEMOVE  add-wm-handler
 536 [ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
 537 [ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
 538 [ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
 539
 540 SYMBOL: trace-messages?
 541
 542 ! return 0 if you handle the message, else just let DefWindowProc return its val
 543 : ui-wndproc ( -- object )
 544     "uint" { "void*" "uint" "long" "long" } "stdcall" [
 545         pick
 546         trace-messages? get-global [ dup windows-message-name name>> print flush ] when
 547         wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
 548      ] alien-callback ;
 549
 550 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 551
 552 M: windows-ui-backend do-events
 553     msg-obj get-global
 554     dup peek-message? [ drop ui-wait ] [
 555         [ TranslateMessage drop ]
 556         [ DispatchMessage drop ] bi
 557     ] if ;
 558
 559 :: register-window-class ( class-name-ptr -- )
 560     "WNDCLASSEX" <c-object> f GetModuleHandle
 561     class-name-ptr pick GetClassInfoEx 0 = [
 562         "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
 563         { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
 564         ui-wndproc over set-WNDCLASSEX-lpfnWndProc
 565         0 over set-WNDCLASSEX-cbClsExtra
 566         0 over set-WNDCLASSEX-cbWndExtra
 567         f GetModuleHandle over set-WNDCLASSEX-hInstance
 568         f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
 569         over set-WNDCLASSEX-hIcon
 570         f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
 571
 572         class-name-ptr over set-WNDCLASSEX-lpszClassName
 573         RegisterClassEx win32-error=0/f
 574     ] [ drop ] if ;
 575
 576 : adjust-RECT ( RECT -- )
 577     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 578
 579 : make-RECT ( world -- RECT )
 580     [ window-loc>> ] [ dim>> ] bi <RECT> ;
 581
 582 : default-position-RECT ( RECT -- )
 583     dup get-RECT-dimensions [ 2drop ] 2dip
 584     CW_USEDEFAULT + pick set-RECT-bottom
 585     CW_USEDEFAULT + over set-RECT-right
 586     CW_USEDEFAULT over set-RECT-left
 587     CW_USEDEFAULT swap set-RECT-top ;
 588
 589 : make-adjusted-RECT ( rect -- RECT )
 590     make-RECT
 591     dup get-RECT-top-left [ zero? ] both? swap
 592     dup adjust-RECT
 593     swap [ dup default-position-RECT ] when ;
 594
 595 : get-window-class ( -- class-name )
 596     class-name-ptr [
 597         dup expired? [ drop "Factor-window" utf16n malloc-string ] when
 598         dup register-window-class
 599         dup
 600     ] change-global ;
 601
 602 : create-window ( rect -- hwnd )
 603     make-adjusted-RECT
 604     [ get-window-class f ] dip
 605     [
 606         [ ex-style ] 2dip
 607         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
 608     ] dip get-RECT-dimensions
 609     f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
 610
 611 : show-window ( hWnd -- )
 612     dup SW_SHOW ShowWindow drop ! always succeeds
 613     dup SetForegroundWindow drop
 614     SetFocus drop ;
 615
 616 : init-win32-ui ( -- )
 617     V{ } clone nc-buttons set-global
 618     "MSG" malloc-object msg-obj set-global
 619     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 620
 621 : cleanup-win32-ui ( -- )
 622     class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global
 623     msg-obj [ [ free ] when* f ] change-global ;
 624
 625 : get-dc ( world -- )
 626     handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
 627
 628 : get-rc ( world -- )
 629     handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
 630     [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
 631
 632 : set-pixel-format ( pixel-format hdc -- )
 633     swap handle>>
 634     "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
 635
 636 : setup-gl ( world -- )
 637     [ get-dc ] keep
 638     [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
 639     with-world-pixel-format ;
 640
 641 M: windows-ui-backend (open-window) ( world -- )
 642     [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
 643     [ dup handle>> hWnd>> register-window ]
 644     [ handle>> hWnd>> show-window ] tri ;
 645
 646 M: win-base select-gl-context ( handle -- )
 647     [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
 648     GdiFlush drop ;
 649
 650 M: win-base flush-gl-context ( handle -- )
 651     hDC>> SwapBuffers win32-error=0/f ;
 652
 653 : setup-offscreen-gl ( world -- )
 654     dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap
 655     [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [
 656         swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi
 657     ] with-world-pixel-format ;
 658
 659 M: windows-ui-backend (open-offscreen-buffer) ( world -- )
 660     win-offscreen new >>handle
 661     setup-offscreen-gl ;
 662
 663 M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
 664     [ hDC>> DeleteDC drop ]
 665     [ hBitmap>> DeleteObject drop ] bi ;
 666
 667 ! Windows 32-bit bitmaps don't actually use the alpha byte of
 668 ! each pixel; it's left as zero
 669
 670 : (make-opaque) ( byte-array -- byte-array' )
 671     [ length 4 /i ]
 672     [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
 673     [ ] tri ;
 674
 675 : (opaque-pixels) ( world -- pixels )
 676     [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
 677
 678 M: windows-ui-backend offscreen-pixels ( world -- alien w h )
 679     [ (opaque-pixels) ] [ dim>> first2 ] bi ;
 680
 681 M: windows-ui-backend raise-window* ( world -- )
 682     handle>> [ hWnd>> SetFocus drop ] when* ;
 683
 684 M: windows-ui-backend set-title ( string world -- )
 685     handle>>
 686     dup title>> [ free ] when*
 687     swap utf16n malloc-string
 688     [ >>title ]
 689     [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
 690
 691 M: windows-ui-backend (with-ui)
 692     [
 693         [
 694             init-clipboard
 695             init-win32-ui
 696             start-ui
 697             event-loop
 698         ] [ cleanup-win32-ui ] [ ] cleanup
 699     ] ui-running ;
 700
 701 M: windows-ui-backend beep ( -- )
 702     0 MessageBeep drop ;
 703
 704 : fullscreen-RECT ( hwnd -- RECT )
 705     MONITOR_DEFAULTTONEAREST MonitorFromWindow
 706     "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
 707     [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
 708
 709 : client-area>RECT ( hwnd -- RECT )
 710     "RECT" <c-object>
 711     [ GetClientRect win32-error=0/f ]
 712     [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
 713     [ nip ] 2tri ;
 714
 715 : hwnd>RECT ( hwnd -- RECT )
 716     "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
 717
 718 M: windows-ui-backend (grab-input) ( handle -- )
 719     0 ShowCursor drop
 720     hWnd>> client-area>RECT ClipCursor drop ;
 721
 722 M: windows-ui-backend (ungrab-input) ( handle -- )
 723     drop
 724     f ClipCursor drop
 725     1 ShowCursor drop ;
 726
 727 : fullscreen-flags ( -- n )
 728     { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
 729
 730 : enter-fullscreen ( world -- )
 731     handle>> hWnd>>
 732     {
 733         [
 734             GWL_STYLE GetWindowLong
 735             fullscreen-flags unmask
 736         ]
 737         [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
 738         [
 739             HWND_TOP
 740             over hwnd>RECT get-RECT-dimensions
 741             SWP_FRAMECHANGED
 742             SetWindowPos win32-error=0/f
 743         ]
 744         [ SW_MAXIMIZE ShowWindow win32-error=0/f ]
 745     } cleave ;
 746
 747 : exit-fullscreen ( world -- )
 748     handle>> hWnd>>
 749     {
 750         [
 751             GWL_STYLE GetWindowLong
 752             fullscreen-flags bitor
 753         ]
 754         [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
 755         [
 756             f
 757             over hwnd>RECT get-RECT-dimensions
 758             { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
 759             SetWindowPos win32-error=0/f
 760         ]
 761         [ SW_RESTORE ShowWindow win32-error=0/f ]
 762     } cleave ;
 763
 764 M: windows-ui-backend (set-fullscreen) ( ? world -- )
 765     [ enter-fullscreen ] [ exit-fullscreen ] if ;
 766
 767 M: windows-ui-backend (fullscreen?) ( world -- ? )
 768     [ handle>> hWnd>> hwnd>RECT ]
 769     [ handle>> hWnd>> fullscreen-RECT ] bi
 770     [ get-RECT-dimensions 2array 2nip ] bi@ = ;
 771
 772 windows-ui-backend ui-backend set-global
 773
 774 [ "ui.tools" ] main-vocab-hook set-global