515 lines
15 KiB
Factor
Executable File
515 lines
15 KiB
Factor
Executable File
! Copyright (C) 2005, 2006 Doug Coleman.
|
|
! Portions copyright (C) 2007, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: alien alien.c-types alien.strings arrays assocs ui
|
|
ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
|
|
ui.gestures 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 continuations
|
|
command-line shuffle opengl ui.render unicode.case ascii
|
|
math.bitwise locals symbols accessors math.geometry.rect ;
|
|
IN: ui.windows
|
|
|
|
SINGLETON: windows-ui-backend
|
|
|
|
: crlf>lf ( str -- str' )
|
|
CHAR: \r swap remove ;
|
|
|
|
: lf>crlf ( str -- str' )
|
|
[ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
|
|
|
|
: enum-clipboard ( -- seq )
|
|
0
|
|
[ EnumClipboardFormats win32-error dup dup 0 > ]
|
|
[ ]
|
|
[ drop ]
|
|
produce nip ;
|
|
|
|
: with-clipboard ( quot -- )
|
|
f OpenClipboard win32-error=0/f
|
|
call
|
|
CloseClipboard win32-error=0/f ; inline
|
|
|
|
: paste ( -- str )
|
|
[
|
|
CF_UNICODETEXT IsClipboardFormatAvailable zero? [
|
|
! nothing to paste
|
|
""
|
|
] [
|
|
CF_UNICODETEXT GetClipboardData dup win32-error=0/f
|
|
dup GlobalLock dup win32-error=0/f
|
|
GlobalUnlock win32-error=0/f
|
|
utf16n alien>string
|
|
] if
|
|
] with-clipboard
|
|
crlf>lf ;
|
|
|
|
: copy ( str -- )
|
|
lf>crlf [
|
|
utf16n string>alien
|
|
EmptyClipboard win32-error=0/f
|
|
GMEM_MOVEABLE over length 1+ GlobalAlloc
|
|
dup win32-error=0/f
|
|
|
|
dup GlobalLock dup win32-error=0/f
|
|
swapd byte-array>memory
|
|
dup GlobalUnlock win32-error=0/f
|
|
CF_UNICODETEXT swap SetClipboardData win32-error=0/f
|
|
] with-clipboard ;
|
|
|
|
TUPLE: pasteboard ;
|
|
C: <pasteboard> pasteboard
|
|
|
|
M: pasteboard clipboard-contents drop paste ;
|
|
M: pasteboard set-clipboard-contents drop copy ;
|
|
|
|
: init-clipboard ( -- )
|
|
<pasteboard> clipboard set-global
|
|
<clipboard> selection set-global ;
|
|
|
|
! world-handle is a <win>
|
|
TUPLE: win hWnd hDC hRC world title ;
|
|
C: <win> win
|
|
|
|
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
|
|
|
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
|
|
: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
|
|
|
|
: get-RECT-top-left ( RECT -- x y )
|
|
[ RECT-left ] keep RECT-top ;
|
|
|
|
: get-RECT-dimensions ( RECT -- x y width height )
|
|
[ get-RECT-top-left ] keep
|
|
[ RECT-right ] keep [ RECT-left - ] keep
|
|
[ RECT-bottom ] keep RECT-top - ;
|
|
|
|
: handle-wm-paint ( hWnd uMsg wParam lParam -- )
|
|
#! wParam and lParam are unused
|
|
#! only paint if width/height both > 0
|
|
3drop window relayout-1 yield ;
|
|
|
|
: handle-wm-size ( hWnd uMsg wParam lParam -- )
|
|
2nip
|
|
[ lo-word ] keep hi-word 2array
|
|
dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
|
|
|
|
: handle-wm-move ( hWnd uMsg wParam lParam -- )
|
|
2nip
|
|
[ lo-word ] keep hi-word 2array
|
|
swap window (>>window-loc) ;
|
|
|
|
: wm-keydown-codes ( -- key )
|
|
H{
|
|
{ 8 "BACKSPACE" }
|
|
{ 9 "TAB" }
|
|
{ 13 "RET" }
|
|
{ 27 "ESC" }
|
|
{ 33 "PAGE_UP" }
|
|
{ 34 "PAGE_DOWN" }
|
|
{ 35 "END" }
|
|
{ 36 "HOME" }
|
|
{ 37 "LEFT" }
|
|
{ 38 "UP" }
|
|
{ 39 "RIGHT" }
|
|
{ 40 "DOWN" }
|
|
{ 45 "INSERT" }
|
|
{ 46 "DELETE" }
|
|
{ 112 "F1" }
|
|
{ 113 "F2" }
|
|
{ 114 "F3" }
|
|
{ 115 "F4" }
|
|
{ 116 "F5" }
|
|
{ 117 "F6" }
|
|
{ 118 "F7" }
|
|
{ 119 "F8" }
|
|
{ 120 "F9" }
|
|
{ 121 "F10" }
|
|
{ 122 "F11" }
|
|
{ 123 "F12" }
|
|
} ;
|
|
|
|
: key-state-down? ( key -- ? )
|
|
GetKeyState 16 bit? ;
|
|
|
|
: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
|
|
: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
|
|
: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
|
|
: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
|
|
: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
|
|
: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
|
|
: shift? ( -- ? ) left-shift? right-shift? or ;
|
|
: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
|
|
: alt? ( -- ? ) left-alt? right-alt? or ;
|
|
: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
|
|
|
|
: switch-case ( seq -- seq )
|
|
dup first CHAR: a >= [ >upper ] [ >lower ] if ;
|
|
|
|
: switch-case? ( -- ? ) shift? caps-lock? xor not ;
|
|
|
|
: key-modifiers ( -- seq )
|
|
[
|
|
shift? [ S+ , ] when
|
|
ctrl? [ C+ , ] when
|
|
alt? [ A+ , ] when
|
|
] { } make [ empty? not ] keep f ? ;
|
|
|
|
: exclude-keys-wm-keydown
|
|
H{
|
|
{ 16 "SHIFT" }
|
|
{ 17 "CTRL" }
|
|
{ 18 "ALT" }
|
|
{ 20 "CAPS-LOCK" }
|
|
} ;
|
|
|
|
: exclude-keys-wm-char
|
|
! Values are ignored
|
|
H{
|
|
{ 8 "BACKSPACE" }
|
|
{ 9 "TAB" }
|
|
{ 13 "RET" }
|
|
{ 27 "ESC" }
|
|
} ;
|
|
|
|
: exclude-key-wm-keydown? ( n -- bool )
|
|
exclude-keys-wm-keydown key? ;
|
|
|
|
: exclude-key-wm-char? ( n -- bool )
|
|
exclude-keys-wm-char key? ;
|
|
|
|
: keystroke>gesture ( n -- mods sym ? )
|
|
dup wm-keydown-codes at* [
|
|
nip >r key-modifiers r> t
|
|
] [
|
|
drop 1string >r key-modifiers r>
|
|
C+ pick member? >r A+ pick member? r> or [
|
|
shift? [ >lower ] unless f
|
|
] [
|
|
switch-case? [ switch-case ] when t
|
|
] if
|
|
] if ;
|
|
|
|
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
|
|
wParam exclude-key-wm-keydown? [
|
|
wParam keystroke>gesture <key-down>
|
|
hWnd window-focus send-gesture drop
|
|
] unless ;
|
|
|
|
:: handle-wm-char ( hWnd uMsg wParam lParam -- )
|
|
wParam exclude-key-wm-char? ctrl? alt? xor or [
|
|
wParam 1string
|
|
hWnd window-focus user-input
|
|
] unless ;
|
|
|
|
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
|
|
wParam keystroke>gesture <key-up>
|
|
hWnd window-focus send-gesture drop ;
|
|
|
|
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
|
? hwnd window (>>active?)
|
|
hwnd uMsg wParam lParam DefWindowProc ;
|
|
|
|
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
|
{
|
|
{ [ over SC_MINIMIZE = ] [ f set-window-active ] }
|
|
{ [ over SC_RESTORE = ] [ t set-window-active ] }
|
|
{ [ over SC_MAXIMIZE = ] [ t set-window-active ] }
|
|
{ [ dup alpha? ] [ 4drop 0 ] }
|
|
{ [ t ] [ DefWindowProc ] }
|
|
} cond ;
|
|
|
|
: cleanup-window ( handle -- )
|
|
dup title>> [ free ] when*
|
|
dup hRC>> wglDeleteContext win32-error=0/f
|
|
dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
|
|
|
|
M: windows-ui-backend (close-window)
|
|
dup hWnd>> unregister-window
|
|
dup cleanup-window
|
|
hWnd>> DestroyWindow win32-error=0/f ;
|
|
|
|
: handle-wm-close ( hWnd uMsg wParam lParam -- )
|
|
3drop window ungraft ;
|
|
|
|
: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
|
|
3drop window [ focus-world ] when* ;
|
|
|
|
: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
|
|
3drop window [ unfocus-world ] when* ;
|
|
|
|
: message>button ( uMsg -- button down? )
|
|
{
|
|
{ [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
|
|
{ [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
|
|
{ [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
|
|
{ [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
|
|
{ [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
|
|
{ [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
|
|
|
|
{ [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
|
|
{ [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
|
|
{ [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
|
|
{ [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
|
|
{ [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
|
|
{ [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
|
|
} cond ;
|
|
|
|
! If the user clicks in the window border ("non-client area")
|
|
! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
|
|
! mouse is subsequently released outside the NC area, we receive
|
|
! a [LMR]BUTTONUP message and Factor can get confused. So we
|
|
! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
|
|
SYMBOL: nc-buttons
|
|
|
|
: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
|
|
2drop nip
|
|
message>button nc-buttons get
|
|
swap [ push ] [ delete ] if ;
|
|
|
|
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
|
|
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
|
|
|
|
: mouse-absolute>relative ( lparam handle -- array )
|
|
>r >lo-hi r>
|
|
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
|
|
get-RECT-top-left 2array v- ;
|
|
|
|
: mouse-event>gesture ( uMsg -- button )
|
|
key-modifiers swap message>button
|
|
[ <button-down> ] [ <button-up> ] if ;
|
|
|
|
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
|
|
nip >r mouse-event>gesture r> >lo-hi rot window ;
|
|
|
|
: set-capture ( hwnd -- )
|
|
mouse-captured get [
|
|
drop
|
|
] [
|
|
[ SetCapture drop ] keep
|
|
mouse-captured set
|
|
] if ;
|
|
|
|
: release-capture ( -- )
|
|
ReleaseCapture win32-error=0/f
|
|
mouse-captured off ;
|
|
|
|
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
|
|
>r >r
|
|
over set-capture
|
|
dup message>button drop nc-buttons get delete
|
|
r> r> prepare-mouse send-button-down ;
|
|
|
|
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
|
|
mouse-captured get [ release-capture ] when
|
|
pick message>button drop dup nc-buttons get member? [
|
|
nc-buttons get delete 4drop
|
|
] [
|
|
drop prepare-mouse send-button-up
|
|
] if ;
|
|
|
|
: make-TRACKMOUSEEVENT ( hWnd -- alien )
|
|
"TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
|
|
"TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
|
|
|
|
: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
|
|
2nip
|
|
over make-TRACKMOUSEEVENT
|
|
TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
|
|
0 over set-TRACKMOUSEEVENT-dwHoverTime
|
|
TrackMouseEvent drop
|
|
>lo-hi swap window move-hand fire-motion ;
|
|
|
|
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
|
>r nip r>
|
|
pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
|
|
|
|
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
|
#! message sent if windows needs application to stop dragging
|
|
4drop release-capture ;
|
|
|
|
: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
|
|
#! message sent if mouse leaves main application
|
|
4drop forget-rollover ;
|
|
|
|
SYMBOL: wm-handlers
|
|
|
|
H{ } clone wm-handlers set-global
|
|
|
|
: add-wm-handler ( quot wm -- )
|
|
dup array?
|
|
[ [ execute add-wm-handler ] with each ]
|
|
[ wm-handlers get-global set-at ] if ;
|
|
|
|
[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
|
|
[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
|
|
|
|
[ handle-wm-size 0 ] WM_SIZE add-wm-handler
|
|
[ handle-wm-move 0 ] WM_MOVE add-wm-handler
|
|
|
|
[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
|
|
[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
|
|
[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
|
|
|
|
[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
|
|
[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
|
|
[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
|
|
|
|
[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
|
|
[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
|
|
[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
|
|
[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
|
|
[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
|
|
[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
|
|
|
|
[ 4dup handle-wm-ncbutton DefWindowProc ]
|
|
{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
|
|
WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
|
|
add-wm-handler
|
|
|
|
[ nc-buttons get-global delete-all DefWindowProc ]
|
|
{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
|
|
|
|
[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
|
|
[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
|
|
[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
|
|
[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
|
|
|
|
SYMBOL: trace-messages?
|
|
|
|
! return 0 if you handle the message, else just let DefWindowProc return its val
|
|
: ui-wndproc ( -- object )
|
|
"uint" { "void*" "uint" "long" "long" } "stdcall" [
|
|
[
|
|
pick
|
|
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
|
|
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
|
|
] ui-try
|
|
] alien-callback ;
|
|
|
|
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
|
|
|
M: windows-ui-backend do-events
|
|
msg-obj get-global
|
|
dup peek-message? [ drop ui-wait ] [
|
|
[ TranslateMessage drop ]
|
|
[ DispatchMessage drop ] bi
|
|
] if ;
|
|
|
|
: register-wndclassex ( -- class )
|
|
"WNDCLASSEX" <c-object>
|
|
f GetModuleHandle
|
|
class-name-ptr get-global
|
|
pick GetClassInfoEx zero? [
|
|
"WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
|
|
{ CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
|
|
ui-wndproc over set-WNDCLASSEX-lpfnWndProc
|
|
0 over set-WNDCLASSEX-cbClsExtra
|
|
0 over set-WNDCLASSEX-cbWndExtra
|
|
f GetModuleHandle over set-WNDCLASSEX-hInstance
|
|
f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
|
|
over set-WNDCLASSEX-hIcon
|
|
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
|
|
|
|
class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
|
|
RegisterClassEx dup win32-error=0/f
|
|
] when ;
|
|
|
|
: adjust-RECT ( RECT -- )
|
|
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
|
|
|
|
: make-RECT ( world -- RECT )
|
|
dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
|
|
"RECT" <c-object>
|
|
over first over set-RECT-right
|
|
swap second over set-RECT-bottom
|
|
over first over set-RECT-left
|
|
swap second over set-RECT-top ;
|
|
|
|
: make-adjusted-RECT ( rect -- RECT )
|
|
make-RECT dup adjust-RECT ;
|
|
|
|
: create-window ( rect -- hwnd )
|
|
make-adjusted-RECT
|
|
>r class-name-ptr get-global f r>
|
|
>r >r >r ex-style r> r>
|
|
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
|
|
r> get-RECT-dimensions
|
|
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
|
|
|
|
: show-window ( hWnd -- )
|
|
dup SW_SHOW ShowWindow drop ! always succeeds
|
|
dup SetForegroundWindow drop
|
|
SetFocus drop ;
|
|
|
|
: init-win32-ui ( -- )
|
|
V{ } clone nc-buttons set-global
|
|
"MSG" malloc-object msg-obj set-global
|
|
"Factor-window" utf16n malloc-string class-name-ptr set-global
|
|
register-wndclassex drop
|
|
GetDoubleClickTime double-click-timeout set-global ;
|
|
|
|
: cleanup-win32-ui ( -- )
|
|
class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
|
|
msg-obj get-global [ free ] when*
|
|
f class-name-ptr set-global
|
|
f msg-obj set-global ;
|
|
|
|
: setup-pixel-format ( hdc -- )
|
|
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
|
|
swapd SetPixelFormat win32-error=0/f ;
|
|
|
|
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
|
|
|
|
: get-rc ( hDC -- hRC )
|
|
dup wglCreateContext dup win32-error=0/f
|
|
[ wglMakeCurrent win32-error=0/f ] keep ;
|
|
|
|
: setup-gl ( hwnd -- hDC hRC )
|
|
get-dc dup setup-pixel-format dup get-rc ;
|
|
|
|
M: windows-ui-backend (open-window) ( world -- )
|
|
[ create-window dup setup-gl ] keep
|
|
[ f <win> ] keep
|
|
[ swap hWnd>> register-window ] 2keep
|
|
dupd (>>handle)
|
|
hWnd>> show-window ;
|
|
|
|
M: windows-ui-backend select-gl-context ( handle -- )
|
|
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f ;
|
|
|
|
M: windows-ui-backend flush-gl-context ( handle -- )
|
|
hDC>> SwapBuffers win32-error=0/f ;
|
|
|
|
! Move window to front
|
|
M: windows-ui-backend raise-window* ( world -- )
|
|
handle>> [
|
|
hWnd>> SetFocus drop
|
|
] when* ;
|
|
|
|
M: windows-ui-backend set-title ( string world -- )
|
|
handle>>
|
|
dup title>> [ free ] when*
|
|
>r utf16n malloc-string r>
|
|
2dup (>>title)
|
|
hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
|
|
|
|
M: windows-ui-backend ui
|
|
[
|
|
[
|
|
stop-after-last-window? on
|
|
init-clipboard
|
|
init-win32-ui
|
|
start-ui
|
|
event-loop
|
|
] [ cleanup-win32-ui ] [ ] cleanup
|
|
] ui-running ;
|
|
|
|
M: windows-ui-backend beep ( -- )
|
|
0 MessageBeep drop ;
|
|
|
|
windows-ui-backend ui-backend set-global
|
|
|
|
[ "ui" ] main-vocab-hook set-global
|