ui: use scroll delta information for smoother mouse scrolling on Windows and Mac OS X

db4
Slava Pestov 2010-04-29 02:52:32 -04:00
parent cea21f6a3d
commit 1672c34f9f
6 changed files with 19 additions and 18 deletions

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2008 Slava Pestov
! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
@ -90,11 +90,11 @@ CONSTANT: key-codes
[ drop window ]
2tri send-button-up ;
: send-wheel$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
: send-scroll$ ( view event -- )
[ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
[ mouse-location ]
[ drop window ]
2tri send-wheel ;
2tri send-scroll ;
: send-action$ ( view event gesture -- junk )
[ drop window ] dip send-action f ;
@ -206,7 +206,7 @@ CLASS: {
}
{ "scrollWheel:" void { id SEL id }
[ nip send-wheel$ ]
[ nip send-scroll$ ]
}
{ "keyDown:" void { id SEL id }

View File

@ -1,5 +1,5 @@
! 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
@ -475,7 +475,8 @@ SYMBOL: nc-buttons
message>button nc-buttons get
swap [ push ] [ remove! drop ] if ;
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-wheel ( wParam -- array )
>lo-hi [ -120 /f ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
@ -534,7 +535,7 @@ SYMBOL: nc-buttons
>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

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types ascii assocs classes.struct combinators
combinators.short-circuit command-line environment io.encodings.ascii
@ -151,7 +151,7 @@ M: world button-up-event
M: world wheel-event
[ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
send-wheel ;
send-scroll ;
M: world enter-event motion-event ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math namespaces sequences
vectors models models.range math.vectors math.functions quotations
@ -234,7 +234,7 @@ PRIVATE>
: <slider> ( range orientation -- slider )
slider new-track
swap >>model
32 >>line
16 >>line
dup orientation>> {
[ <slider-pen> >>interior ]
[ <thumb> >>thumb ]

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
@ -304,7 +304,7 @@ SYMBOL: drag-timer
stop-drag-timer
button-gesture ;
: send-wheel ( direction loc world -- )
: send-scroll ( direction loc world -- )
move-hand
scroll-direction set-global
mouse-scroll hand-gadget get-global propagate-gesture ;

View File

@ -16,7 +16,7 @@ GENERIC: enter-event ( event window -- )
GENERIC: leave-event ( event window -- )
GENERIC: wheel-event ( event window -- )
GENERIC: scroll-event ( event window -- )
GENERIC: motion-event ( event window -- )
@ -42,13 +42,13 @@ GENERIC: client-event ( event window -- )
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
: wheel? ( event -- ? ) button>> 4 7 between? ;
: mouse-scroll? ( event -- ? ) button>> 4 7 between? ;
: button-down-event$ ( event window -- )
over wheel? [ wheel-event ] [ button-down-event ] if ;
over mouse-scroll? [ scroll-event ] [ button-down-event ] if ;
: button-up-event$ ( event window -- )
over wheel? [ 2drop ] [ button-up-event ] if ;
over mouse-scroll? [ 2drop ] [ button-up-event ] if ;
: handle-event ( event window -- )
swap dup XAnyEvent>> type>> {