blob: 7c71644a41f7f662f7444fe6c84a6d10da18bb39 (
plain) (
blame)
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
|
{-# LANGUAGE BangPatterns #-}
module Rahm.Desktop.MouseMotion where
import Control.Monad (forever, void)
import Control.Monad.Fix (fix)
import Control.Monad.Loops (iterateWhile)
import Linear.Metric
import Linear.V2
import Rahm.Desktop.Logger
import Rahm.Desktop.Submap
import Text.Printf
import XMonad
data Quadrant = NE | SE | SW | NW deriving (Enum, Show)
data Direction = CW | CCW deriving (Enum, Show)
getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant
getQuadrant (x, y) | x >= 0 && y >= 0 = NE
getQuadrant (x, y) | x < 0 && y >= 0 = SE
getQuadrant (x, y) | x < 0 && y < 0 = SW
getQuadrant (x, y) = NW
getDirection :: Quadrant -> Quadrant -> Maybe Direction
getDirectory a b | a == b = Nothing
getDirection SW SE = Just CCW
getDirection SE NE = Just CCW
getDirection NE NW = Just CCW
getDirection NW SW = Just CCW
getDirection _ _ = Just CW
liftMouseMotionM :: X a -> MouseMotionM a
liftMouseMotionM = MouseMotionM . fmap Just
motion :: MouseMotionM (V2 Int)
motion = MouseMotionM $ do
ev <- nextMotionOrButton
case ev of
Right button -> do
logs Info "Button %s" (show button)
return Nothing
Left motion -> return (Just $ uncurry V2 motion)
motionSize :: Int -> MouseMotionM (V2 Int)
motionSize size = do
let fsize = fromIntegral size
!firstmotion <- fmap fromIntegral <$> motion
let get = do
!next <- motion
if distance (fmap fromIntegral next) firstmotion >= fsize
then return next
else get
get
runMouseMotionM :: MouseMotionM a -> X (Maybe a)
runMouseMotionM (MouseMotionM a) = a
execMouseMotionM :: MouseMotionM () -> X ()
execMouseMotionM = void . runMouseMotionM
-- Monad for capturing mouse motion. Terminates and holds Nothing when a
-- button is pressed.
newtype MouseMotionM a = MouseMotionM (X (Maybe a))
instance Functor MouseMotionM where
fmap fn (MouseMotionM xma) = MouseMotionM (fmap (fmap fn) xma)
instance Applicative MouseMotionM where
mf <*> ma = do
!f <- mf
!a <- ma
return (f a)
pure = return
instance Monad MouseMotionM where
return a = MouseMotionM (return (Just a))
(MouseMotionM !xa) >>= fn = MouseMotionM $ do
!ma <- xa
case ma of
Just !a ->
let (MouseMotionM !xb) = fn a in xb
Nothing -> return Nothing
mouseRotateMotion :: X () -> X () -> X ()
mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse
where
doMouse = forever $ do
v <- motion
liftMouseMotionM $ logs Info "Motion: %s" (show v)
|
