! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2009 Slava Pestov.
+! Portions copyright (C) 2007, 2010 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
windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes colors
specialized-arrays classes.struct alien.data ;
+FROM: namespaces => set ;
SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
drop f ;
: arb-make-pixel-format ( world attributes -- pf )
- [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
- [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+ [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 { int int }
+ [ wglChoosePixelFormatARB win32-error=0/f ] with-out-parameters drop ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
- first <int> 0 <int>
+ first <int> { int }
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
- keep *int
+ with-out-parameters
] if-empty ;
CONSTANT: pfd-flag-map H{
over world>> has-wglChoosePixelFormatARB?
[ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
-M: windows-ui-backend system-background-color
- composition-enabled?
- [ T{ rgba f 0.0 0.0 0.0 0.0 } ]
- [ COLOR_BTNFACE GetSysColor RGB>color ] if ;
-
PRIVATE>
: lo-word ( wparam -- lo ) <short> *short ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
+: GET_APPCOMMAND_LPARAM ( lParam -- appCommand )
+ hi-word FAPPCOMMAND_MASK lo-word bitnot bitand ; inline
: crlf>lf ( str -- str' )
CHAR: \r swap remove ;
dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
- swapd byte-array>memory
+ rot binary-object memcpy
dup GlobalUnlock win32-error=0/f
CF_UNICODETEXT swap SetClipboardData win32-error=0/f
] with-clipboard ;
: handle-wm-size ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window [ (>>dim) ] [ drop ] if* ] if ;
+ dup { 0 0 } = [ 2drop ] [ swap window [ dim<< ] [ drop ] if* ] if ;
: handle-wm-move ( hWnd uMsg wParam lParam -- )
2nip
[ lo-word ] keep hi-word 2array
- swap window [ (>>window-loc) ] [ drop ] if* ;
+ swap window [ window-loc<< ] [ drop ] if* ;
CONSTANT: wm-keydown-codes
H{
] unless ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- ? hwnd window (>>active?)
+ ? hwnd window active?<<
hwnd uMsg wParam lParam DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
2drop nip
message>button nc-buttons get
- swap [ push ] [ delete ] if ;
+ swap [ push ] [ remove! drop ] if ;
-: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+: mouse-scroll ( wParam -- array )
+ >lo-hi [ -80 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
ReleaseCapture win32-error=0/f
mouse-captured off ;
+: handle-app-command ( hWnd uMsg wParam lParam -- )
+ GET_APPCOMMAND_LPARAM
+ {
+ { APPCOMMAND_BROWSER_BACKWARD [ pick window left-action send-action ] }
+ { APPCOMMAND_BROWSER_FORWARD [ pick window right-action send-action ] }
+ [ drop ]
+ } case 3drop ;
+
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
[
over set-capture
- dup message>button drop nc-buttons get delete
+ dup message>button drop nc-buttons get remove! drop
] 2dip 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
+ nc-buttons get remove! drop 4drop
] [
drop prepare-mouse send-button-up
] if ;
>lo-hi swap window move-hand fire-motion ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+ wParam mouse-scroll hand-loc get hWnd window send-scroll ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging
#! message sent if mouse leaves main application
4drop forget-rollover ;
+: system-background-color ( -- color )
+ COLOR_BTNFACE GetSysColor RGB>color ;
+
: ?make-glass ( world hwnd -- )
- swap { [ transparent?>> ] [ drop windows-major 6 >= ] } 1&&
- [ full-window-margins DwmExtendFrameIntoClientArea drop ]
- [ drop ] if ;
+ over window-controls>> textured-background swap member-eq? [
+ composition-enabled? [
+ full-window-margins DwmExtendFrameIntoClientArea drop
+ T{ rgba f 0.0 0.0 0.0 0.0 }
+ ] [ drop system-background-color ] if >>background-color
+ drop
+ ] [ 2drop ] if ;
: handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- )
3drop [ window ] keep ?make-glass ;
[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+[ handle-app-command 0 ] WM_APPCOMMAND 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
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ 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
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
WNDCLASSEX heap-size >>cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
0 >>cbWndExtra
f GetModuleHandle >>hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon >>hIcon
+ f GetModuleHandle "APPICON" utf16n string>alien LoadIcon >>hIcon
f IDC_ARROW LoadCursor >>hCursor
class-name-ptr >>lpszClassName
M: windows-ui-backend beep ( -- )
0 MessageBeep drop ;
+M: windows-ui-backend system-alert
+ [ f ] 2dip swap MB_OK MessageBox drop ;
+
: fullscreen-RECT ( hwnd -- RECT )
MONITOR_DEFAULTTONEAREST MonitorFromWindow
MONITORINFOEX <struct>
: client-area>RECT ( hwnd -- RECT )
RECT <struct>
[ GetClientRect win32-error=0/f ]
- [ >c-ptr byte-array>POINT-array [ ClientToScreen drop ] with each ]
+ [ >c-ptr POINT-array-cast [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
f ClipCursor drop
1 ShowCursor drop ;
-: fullscreen-flags ( -- n )
- { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
: enter-fullscreen ( world -- )
handle>> hWnd>>
[
f
over hwnd>RECT get-RECT-dimensions
- { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+ flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
[ SW_RESTORE ShowWindow win32-error=0/f ]
projects / factor.git / blobdiff