More experimental MouseMotion

3 files changed, 123 insertions, 29 deletions

diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index fcf233e..6d34c4a 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -46,6 +46,7 @@ import XMonad.Actions.SpawnOn as SpawnOn
 import qualified Data.Map as Map
 import qualified XMonad.StackSet as W
 
+import Internal.MouseMotion
 import Internal.Windows
 import Internal.Lib
 import Internal.DMenu
@@ -356,34 +357,8 @@ keymap = runKeys $ do
 
       bind xK_q $
         (justMod -|- noMod) $
-          let fi = fromIntegral
-              mag (fi -> x₁, fi -> y₁) (fi -> x₂, fi -> y₂) =
-                sqrt ((x₂ - x₁) ^ 2 + (y₂ - y₁) ^ 2) in
-
-          doc "EXPERIMENTAL: Move mouse to control media." $ fix $ \recur -> do
-
-          -- Moving the mouse 100+ pixels to the right will go to the next song
-          -- Moving the mouse 100+ pixel to the left will go to the prior song
-          -- Moving the mouse vertically 100+ pixels will stop the loop
-          --
-          -- May mess up the mouse, requiring an XMonad reboot, which is why
-          -- this is experimental. It's not the most practical bindings in the
-          -- world, but it shows that it's theoretically possible to program
-          -- some neat mouse moptions to do cool things.
-          firstMotion@(x, y) <- nextMotion
-          (x', y') <- iterateWhile ((<100) . mag firstMotion) nextMotion
-
-
-          if abs (y' - y) > abs (x' - x)
-            then 
-              if (y' - y) < 0
-                then logs "up"
-                else logs "down"
-            else do
-              if (x' - x) < 0
-                then mediaPrev
-                else mediaNext
-              recur
+          doc "EXPERIMENTAL: Move mouse to control media." $
+            mouseRotateMotion (logs "CW") (logs "CCW")
 
   bind xK_r $ do
     justMod $ doc "Run a command via Rofi" runDMenu
@@ -625,9 +600,12 @@ mouseMap = runButtons $ do
 
   bind button13 $ noMod $ subMouse $ do
     bind button1 $ noMod mouseMoveWindow
+    bind button2 $ noMod $ windows . W.sink
     bind button3 $ noMod mouseResizeWindow
-    bind button13 $ noMod $ windows . W.sink
 
+    bind button13 $ noMod $ subMouse $ do
+      bind button13 $ noMod $ subMouse $ do
+        bind button13 $ noMod $ noWindow $ spawnX "xsecurelock"
 
   bind button15 $ do
 
diff --git a/src/Internal/MouseMotion.hs b/src/Internal/MouseMotion.hs
new file mode 100644
index 0000000..c72c824
--- /dev/null
+++ b/src/Internal/MouseMotion.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ViewPatterns, BangPatterns #-}
+module Internal.MouseMotion where
+
+import XMonad
+
+import Control.Monad (void, forever)
+import Text.Printf
+import Internal.Submap
+import Control.Monad.Loops (iterateWhile)
+import Control.Monad.Fix (fix)
+import Internal.Logger
+
+import Linear.V2
+import Linear.Metric
+
+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 ("Button " ++ 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 $ "Motion: " ++ show v
diff --git a/src/Internal/Submap.hs b/src/Internal/Submap.hs
index c51f9b6..32dda2a 100644
--- a/src/Internal/Submap.hs
+++ b/src/Internal/Submap.hs
@@ -3,6 +3,7 @@ module Internal.Submap (
     submapButtonsWithKey,
     nextButton,
     nextMotion,
+    nextMotionOrButton,
     module X) where
 
 import XMonad hiding (keys)
@@ -62,6 +63,24 @@ nextMotion = do
 
   return ret
 
+nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button))
+nextMotionOrButton = do
+  XConf { theRoot = root, display = d } <- ask
+  io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime
+
+  ret <- io $ allocaXEvent $ \xEv -> do
+    maskEvent d (pointerMotionMask .|. buttonPressMask) xEv
+    ev <- getEvent xEv
+    case ev of
+      MotionEvent { ev_x = x, ev_y = y } ->
+        return $ Left (fromIntegral x, fromIntegral y)
+      ButtonEvent { ev_button = button, ev_state = m } ->
+        return $ Right (m, button)
+
+  io $ ungrabPointer d currentTime
+
+  return ret
+
 submapButtonsWithKey ::
     ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X ()
 submapButtonsWithKey defaultAction actions window = do