steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-12-01 19:51:11 -06:00
parent f72c951a6b 2fa3787d7b
commit 6c5aeca2f7
2 changed files with 7 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/ui/windows/windows.factor
View File

@ -285,12 +285,8 @@ SYMBOL: nc-buttons
swap [ push ] [ delete ] if ; swap [ push ] [ delete ] if ;
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-absolute>relative ( lparam handle -- array ) : mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
[ >lo-hi ] dip
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
: mouse-event>gesture ( uMsg -- button ) : mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button key-modifiers swap message>button
@ -340,9 +336,7 @@ SYMBOL: nc-buttons
>lo-hi swap window move-hand fire-motion ; >lo-hi swap window move-hand fire-motion ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- ) :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
wParam mouse-wheel wParam mouse-wheel hand-loc get hWnd window send-wheel ;
lParam hWnd mouse-absolute>relative
hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- ) : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging #! message sent if windows needs application to stop dragging

10
basis/ui/x11/x11.factor Normal file → Executable file
View File

@ -117,7 +117,7 @@ M: world button-up-event
} at ; } at ;
M: world wheel-event M: world wheel-event
[ dup mouse-event>scroll-direction swap mouse-event-loc ] dip [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
send-wheel ; send-wheel ;
M: world enter-event motion-event ; M: world enter-event motion-event ;
@ -125,7 +125,7 @@ M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ; M: world leave-event 2drop forget-rollover ;
M: world motion-event M: world motion-event
[ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
move-hand fire-motion ; move-hand fire-motion ;
M: world focus-in-event M: world focus-in-event
@ -146,10 +146,10 @@ M: world selection-notify-event
: clipboard-for-atom ( atom -- clipboard ) : clipboard-for-atom ( atom -- clipboard )
{ {
{ [ dup XA_PRIMARY = ] [ drop selection get ] } { XA_PRIMARY [ selection get ] }
{ [ dup XA_CLIPBOARD = ] [ drop clipboard get ] } { XA_CLIPBOARD [ clipboard get ] }
[ drop <clipboard> ] [ drop <clipboard> ]
} cond ; } case ;
: encode-clipboard ( string type -- bytes ) : encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target XSelectionRequestEvent-target