Fix issue with pointer coordinates + Add mouse press/release actions

4 files changed, 55 insertions, 21 deletions

diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index d00d112..3f78aba 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -1,11 +1,9 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-
 module Chelleport where
 
 import Chelleport.AppShell (MonadAppShell (hideWindow, showWindow, shutdownApp), setupAppShell)
 import Chelleport.Context (initializeContext)
-import Chelleport.Control (MonadControl (getMousePointerPosition, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPressWith, isKeyPressed, isKeyReleaseWith, withShift)
-import Chelleport.Draw (MonadDraw, cellSize)
+import Chelleport.Control (MonadControl (getMousePointerPosition, mouseButtonDown, mouseButtonUp, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPressWith, isKeyPressed, isKeyReleaseWith, withShift)
+import Chelleport.Draw (MonadDraw (windowPosition), cellSize)
 import Chelleport.KeySequence (findMatchPosition, generateGrid, isValidKey, nextChars, toKeyChar)
 import Chelleport.Types
 import Chelleport.Utils (intToCInt)
@@ -110,7 +108,8 @@ update state (MoveMousePosition (row, col)) = do
       (wcell, hcell) <- cellSize state
       let x = (wcell `div` 2) + wcell * intToCInt col
       let y = (hcell `div` 2) + hcell * intToCInt row
-      pure (x, y)
+      (winx, winy) <- windowPosition
+      pure (winx + x, winy + y)
 
 -- Reset entered key sequence and state
 update state ResetKeys = do
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index 28007f7..b31c964 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -1,5 +1,6 @@
 module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where
 
+import Chelleport.Control (MonadControl (mouseButtonUp))
 import Chelleport.Draw (colorBackground)
 import Chelleport.Types
 import Control.Monad (foldM)
@@ -22,6 +23,7 @@ instance (MonadIO m) => MonadAppShell (AppM m) where
     ctx <- ask
     SDL.destroyRenderer $ ctxRenderer ctx
     SDL.destroyWindow $ ctxWindow ctx
+    mouseButtonUp
     liftIO $ do
       X11.closeDisplay $ ctxX11Display ctx
       exitSuccess
diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs
index 2723cd2..2dcb565 100644
--- a/src/Chelleport/Control.hs
+++ b/src/Chelleport/Control.hs
@@ -3,39 +3,65 @@ module Chelleport.Control where
 import Chelleport.Types
 import Chelleport.Utils (cIntToInt)
 import Control.Concurrent (threadDelay)
+import Control.Monad (unless)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Reader (MonadReader (ask))
-import Foreign.C (CInt)
+import qualified Debug.Trace as Debug
+import Foreign.C.Types
 import qualified Graphics.X11 as X11
-import qualified Graphics.X11.XTest as X11
 import qualified SDL
 
 class (Monad m) => MonadControl m where
   pressMouseButton :: MouseButtonType -> m ()
   moveMousePointer :: CInt -> CInt -> m ()
+  mouseButtonDown :: m ()
+  mouseButtonUp :: m ()
   getMousePointerPosition :: m (CInt, CInt)
 
+foreign import ccall unsafe "X11/extensions/XTest.h XTestFakeButtonEvent"
+  xSimulateButtonEvent :: X11.Display -> X11.Button -> Bool -> X11.Time -> IO X11.Status
+
+-- Wrap with delay to prevent async window close issues
+withDelay :: (MonadIO m) => m () -> m ()
+withDelay act = delay >> act >> delay
+  where
+    delay = liftIO (threadDelay 20_000)
+
 instance (MonadIO m) => MonadControl (AppM m) where
   pressMouseButton btn = do
     (DrawContext {ctxX11Display = display}) <- ask
-    liftIO $ do
-      -- Wrap with delay to prevent async window close issues. TODO: Remove maybe?
-      threadDelay 20_000
-      X11.fakeButtonPress display x11Button
+    withDelay . liftIO $ do
+      xSimulateButtonEvent display x11Button True 0
+      xSimulateButtonEvent display x11Button False 0
       X11.sync display False
-      threadDelay 20_000
     where
       x11Button = case btn of
         LeftClick -> X11.button1
         RightClick -> X11.button3
 
   moveMousePointer x y = do
-    DrawContext {ctxWindow = window} <- ask
-    SDL.warpMouse (SDL.WarpInWindow window) (SDL.P $ SDL.V2 x y)
+    SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y)
 
   getMousePointerPosition = do
-    (SDL.P (SDL.V2 x y)) <- SDL.getAbsoluteMouseLocation
-    pure (x, y)
+    DrawContext {ctxX11Display = display} <- ask
+    liftIO $ do
+      win <- X11.rootWindow display $ X11.defaultScreen display
+      (success, _, _, x, y, _, _, _) <- X11.queryPointer display win
+      unless success $ do
+        Debug.traceM "ERROR: Cant query pointer"
+      pure (x, y)
+
+  mouseButtonDown = do
+    (DrawContext {ctxX11Display = display}) <- ask
+    withDelay . liftIO $ do
+      xSimulateButtonEvent display X11.button1 True 0
+      X11.sync display False
+
+  mouseButtonUp = do
+    (DrawContext {ctxX11Display = display}) <- ask
+    withDelay . liftIO $ do
+      xSimulateButtonEvent display X11.button1 False 0
+      X11.sync display False
 
 isKeyPressed :: SDL.KeyboardEventData -> Bool
 isKeyPressed = (== SDL.Pressed) . SDL.keyboardEventKeyMotion
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index 2fdb311..cba040a 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -16,7 +16,8 @@ class (Monad m) => MonadDraw m where
   drawText :: (CInt, CInt) -> SDL.V4 Word8 -> Text -> m (CInt, CInt)
   drawCircle :: Int -> (CInt, CInt) -> m ()
   setDrawColor :: SDL.V4 Word8 -> m ()
-  windowSize :: m (SDL.V2 CInt)
+  windowSize :: m (CInt, CInt)
+  windowPosition :: m (CInt, CInt)
 
 instance (MonadIO m) => MonadDraw (AppM m) where
   drawLine (x1, y1) (x2, y2) = do
@@ -56,23 +57,29 @@ instance (MonadIO m) => MonadDraw (AppM m) where
     let points = Vector.generate renderedPoints (SDL.P . toPointOnCircle)
     SDL.drawPoints renderer points
 
-  windowSize = ask >>= SDL.get . SDL.windowSize . ctxWindow
+  windowSize = do
+    SDL.V2 x y <- ask >>= SDL.get . SDL.windowSize . ctxWindow
+    pure (x, y)
+
+  windowPosition = do
+    SDL.V2 x y <- ask >>= SDL.getWindowAbsolutePosition . ctxWindow
+    pure (x, y)
 
 cellSize :: (MonadDraw m) => State -> m (CInt, CInt)
 cellSize (State {stateGrid}) = do
-  (SDL.V2 width height) <- windowSize
+  (width, height) <- windowSize
   let wcell = width `div` intToCInt (length $ head stateGrid)
   let hcell = height `div` intToCInt (length stateGrid)
   pure (wcell, hcell)
 
 drawHorizontalLine :: (MonadDraw m) => CInt -> m ()
 drawHorizontalLine y = do
-  (SDL.V2 width _) <- windowSize
+  (width, _) <- windowSize
   drawLine (0, y) (width, y)
 
 drawVerticalLine :: (MonadDraw m) => CInt -> m ()
 drawVerticalLine x = do
-  (SDL.V2 _width height) <- windowSize
+  (_, height) <- windowSize
   drawLine (x, 0) (x, height)
 
 colorWhite :: SDL.V4 Word8