basis/ui/windows/windows.factor

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