Add horizontal scroll support

release
Slava Pestov 2007-10-10 02:16:42 -04:00
parent c84ba1d76b
commit 84cd33357a
2 changed files with 7 additions and 3 deletions

View File

@ -93,8 +93,12 @@ M: world button-up-event
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
#! Reminder for myself: 4 is up, 5 is down
XButtonEvent-button 5 = 1 -1 ? 0 swap 2array ;
XButtonEvent-button {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
{ 7 { 1 0 } }
} at ;
M: world wheel-event
>r dup mouse-event>scroll-direction swap mouse-event-loc r>

View File

@ -42,7 +42,7 @@ GENERIC: client-event ( event window -- )
: events-queued ( mode -- n ) >r dpy get r> XEventsQueued ;
: wheel? ( event -- ? ) XButtonEvent-button { 4 5 } member? ;
: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
: button-down-event$ ( event window -- )
over wheel? [ wheel-event ] [ button-down-event ] if ;