1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Actions.MouseGestures
-- Copyright : (c) Lukas Mai
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : <l.mai@web.de>
-- Stability : unstable
-- Portability : unportable
--
-- Support for simple mouse gestures.
--
-----------------------------------------------------------------------------
module XMonad.Actions.MouseGestures (
-- * Usage
-- $usage
Direction(..),
mouseGesture
) where
import XMonad
import XMonad.Operations
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Control.Monad.Reader
import Data.IORef
import qualified Data.Map as M
import Data.Map (Map)
import System.IO
-- $usage
--
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Actions.Commands
-- > import qualified XMonad.StackSet as W
--
-- then add an appropriate mouse binding:
--
-- > , ((modMask x .|. shiftMask, button3), mouseGesture gestures)
--
-- where @gestures@ is a 'Data.Map.Map' from gestures to actions on
-- windows, for example:
--
-- > gestures = M.fromList
-- > [ ([], focus)
-- > , ([U], \w -> focus w >> windows W.swapUp)
-- > , ([D], \w -> focus w >> windows W.swapDown)
-- > , ([R, D], \_ -> sendMessage NextLayout)
-- > ]
--
-- This is just an example, of course; you can use any mouse button and
-- gesture definitions you want.
--
-- For detailed instructions on editing your mouse bindings, see
-- "XMonad.Doc.Extending#Editing_mouse_bindings".
-- | The four cardinal screen directions. A \"gesture\" is a sequence of
-- directions.
data Direction = L | U | R | D
deriving (Eq, Ord, Show, Read, Enum, Bounded)
type Pos = (Position, Position)
delta :: Pos -> Pos -> Position
delta (ax, ay) (bx, by) = max (d ax bx) (d ay by)
where
d a b = abs (a - b)
dir :: Pos -> Pos -> Direction
dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromIntegral $ bx - ax)
where
trans :: Double -> Direction
trans x
| rg (-3/4) (-1/4) x = D
| rg (-1/4) (1/4) x = R
| rg (1/4) (3/4) x = U
| otherwise = L
rg a z x = a <= x && x < z
debugging :: Int
debugging = 0
collect :: IORef (Pos, [(Direction, Pos, Pos)]) -> Position -> Position -> X ()
collect st nx ny = do
let np = (nx, ny)
stx@(op, ds) <- io $ readIORef st
when (debugging > 0) $ io $ putStrLn $ show "Mouse Gesture" ++ unwords (map show (extract stx)) ++ (if debugging > 1 then "; " ++ show op ++ "-" ++ show np else "")
case ds of
[]
| insignificant np op -> return ()
| otherwise -> io $ writeIORef st (op, [(dir op np, np, op)])
(d, zp, ap_) : ds'
| insignificant np zp -> return ()
| otherwise -> do
let
d' = dir zp np
ds''
| d == d' = (d, np, ap_) : ds'
| otherwise = (d', np, zp) : ds
io $ writeIORef st (op, ds'')
where
insignificant a b = delta a b < 10
extract :: (Pos, [(Direction, Pos, Pos)]) -> [Direction]
extract (_, xs) = reverse . map (\(x, _, _) -> x) $ xs
-- | Given a 'Data.Map.Map' from lists of directions to actions with
-- windows, figure out which one the user is performing, and return
-- the corresponding action.
mouseGesture :: Map [Direction] (Window -> X ()) -> Window -> X ()
mouseGesture tbl win = withDisplay $ \dpy -> do
root <- asks theRoot
let win' = if win == none then root else win
acc <- io $ do
qp@(_, _, _, ix, iy, _, _, _) <- queryPointer dpy win'
when (debugging > 1) $ putStrLn $ show "queryPointer" ++ show qp
when (debugging > 1 && win' == none) $ putStrLn $ show "mouseGesture" ++ "zomg none"
newIORef ((fromIntegral ix, fromIntegral iy), [])
mouseDrag (collect acc) $ do
when (debugging > 0) $ io $ putStrLn $ show ""
gest <- io $ liftM extract $ readIORef acc
case M.lookup gest tbl of
Nothing -> return ()
Just f -> f win'
|
