module XMonad.Actions.MouseGestures (
Direction2D(..),
mouseGestureH,
mouseGesture,
mkCollect
) where
import XMonad.Prelude
import XMonad
import XMonad.Util.Types (Direction2D(..))
import Data.IORef
import qualified Data.Map as M
import Data.Map (Map)
type Pos = (Position, Position)
delta :: Pos -> Pos -> Position
delta :: Pos -> Pos -> Position
delta (Position
ax, Position
ay) (Position
bx, Position
by) = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max (Position -> Position -> Position
forall {a}. Num a => a -> a -> a
d Position
ax Position
bx) (Position -> Position -> Position
forall {a}. Num a => a -> a -> a
d Position
ay Position
by)
where
d :: a -> a -> a
d a
a a
b = a -> a
forall a. Num a => a -> a
abs (a
a a -> a -> a
forall {a}. Num a => a -> a -> a
- a
b)
dir :: Pos -> Pos -> Direction2D
dir :: Pos -> Pos -> Direction2D
dir (Position
ax, Position
ay) (Position
bx, Position
by) = Double -> Direction2D
trans (Double -> Direction2D)
-> (Double -> Double) -> Double -> Direction2D
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
forall a. Floating a => a
pi) (Double -> Direction2D) -> Double -> Direction2D
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. RealFloat a => a -> a -> a
atan2 (Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Double) -> Position -> Double
forall a b. (a -> b) -> a -> b
$ Position
ay Position -> Position -> Position
forall {a}. Num a => a -> a -> a
- Position
by) (Position -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Position -> Double) -> Position -> Double
forall a b. (a -> b) -> a -> b
$ Position
bx Position -> Position -> Position
forall {a}. Num a => a -> a -> a
- Position
ax)
where
trans :: Double -> Direction2D
trans :: Double -> Direction2D
trans Double
x
| Double -> Double -> Double -> Bool
forall {a}. Ord a => a -> a -> a -> Bool
rg (-Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
D
| Double -> Double -> Double -> Bool
forall {a}. Ord a => a -> a -> a -> Bool
rg (-Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
R
| Double -> Double -> Double -> Bool
forall {a}. Ord a => a -> a -> a -> Bool
rg (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) (Double
3Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
4) Double
x = Direction2D
U
| Bool
otherwise = Direction2D
L
rg :: a -> a -> a -> Bool
rg a
a a
z a
x = a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
x Bool -> Bool -> Bool
&& a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
z
gauge :: (Direction2D -> X ()) -> Pos -> IORef (Maybe (Direction2D, Pos)) -> Position -> Position -> X ()
gauge :: (Direction2D -> X ())
-> Pos
-> IORef (Maybe (Direction2D, Pos))
-> Position
-> Position
-> X ()
gauge Direction2D -> X ()
hook Pos
op IORef (Maybe (Direction2D, Pos))
st Position
nx Position
ny = do
let np :: Pos
np = (Position
nx, Position
ny)
stx <- IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos)))
-> IO (Maybe (Direction2D, Pos)) -> X (Maybe (Direction2D, Pos))
forall a b. (a -> b) -> a -> b
$ IORef (Maybe (Direction2D, Pos)) -> IO (Maybe (Direction2D, Pos))
forall a. IORef a -> IO a
readIORef IORef (Maybe (Direction2D, Pos))
st
let pivot = Pos
-> ((Direction2D, Pos) -> Pos) -> Maybe (Direction2D, Pos) -> Pos
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pos
op (Direction2D, Pos) -> Pos
forall a b. (a, b) -> b
snd Maybe (Direction2D, Pos)
stx
when (significant np pivot) $ do
let d' = Pos -> Pos -> Direction2D
dir Pos
pivot Pos
np
when ((fst <$> stx) /= Just d') $ hook d'
io $ writeIORef st (Just (d', np))
where
significant :: Pos -> Pos -> Bool
significant Pos
a Pos
b = Pos -> Pos -> Position
delta Pos
a Pos
b Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
10
mouseGestureH :: (Direction2D -> X ()) -> X () -> X ()
mouseGestureH :: (Direction2D -> X ()) -> X () -> X ()
mouseGestureH Direction2D -> X ()
moveHook X ()
endHook = do
dpy <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
root <- asks theRoot
(pos, acc) <- io $ do
(_, _, _, ix, iy, _, _, _) <- queryPointer dpy root
r <- newIORef Nothing
return ((fromIntegral ix, fromIntegral iy), r)
mouseDrag (gauge moveHook pos acc) endHook
mouseGesture :: Map [Direction2D] (Window -> X ()) -> Window -> X ()
mouseGesture :: Map [Direction2D] (Window -> X ()) -> Window -> X ()
mouseGesture Map [Direction2D] (Window -> X ())
tbl Window
win = do
(mov, end) <- X (Direction2D -> X [Direction2D], X [Direction2D])
forall (m :: * -> *) (m' :: * -> *).
(MonadIO m, MonadIO m') =>
m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect
mouseGestureH (void . mov) $ end >>= \[Direction2D]
gest ->
case [Direction2D]
-> Map [Direction2D] (Window -> X ()) -> Maybe (Window -> X ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Direction2D]
gest Map [Direction2D] (Window -> X ())
tbl of
Maybe (Window -> X ())
Nothing -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Window -> X ()
f -> Window -> X ()
f Window
win
mkCollect :: (MonadIO m, MonadIO m') => m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect :: forall (m :: * -> *) (m' :: * -> *).
(MonadIO m, MonadIO m') =>
m (Direction2D -> m' [Direction2D], m' [Direction2D])
mkCollect = IO (Direction2D -> m' [Direction2D], m' [Direction2D])
-> m (Direction2D -> m' [Direction2D], m' [Direction2D])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Direction2D -> m' [Direction2D], m' [Direction2D])
-> m (Direction2D -> m' [Direction2D], m' [Direction2D]))
-> IO (Direction2D -> m' [Direction2D], m' [Direction2D])
-> m (Direction2D -> m' [Direction2D], m' [Direction2D])
forall a b. (a -> b) -> a -> b
$ do
acc <- [Direction2D] -> IO (IORef [Direction2D])
forall a. a -> IO (IORef a)
newIORef []
let
mov Direction2D
d = IO [Direction2D] -> m [Direction2D]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Direction2D] -> m [Direction2D])
-> IO [Direction2D] -> m [Direction2D]
forall a b. (a -> b) -> a -> b
$ do
ds <- IORef [Direction2D] -> IO [Direction2D]
forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
let ds' = Direction2D
d Direction2D -> [Direction2D] -> [Direction2D]
forall a. a -> [a] -> [a]
: [Direction2D]
ds
writeIORef acc ds'
return $ reverse ds'
end = IO [Direction2D] -> m' [Direction2D]
forall a. IO a -> m' a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Direction2D] -> m' [Direction2D])
-> IO [Direction2D] -> m' [Direction2D]
forall a b. (a -> b) -> a -> b
$ do
ds <- IORef [Direction2D] -> IO [Direction2D]
forall a. IORef a -> IO a
readIORef IORef [Direction2D]
acc
writeIORef acc []
return $ reverse ds
return (mov, end)