diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Chelleport.hs | 9 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 2 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 48 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 17 |
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 |