diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Chelleport.hs | 116 | ||||
| -rw-r--r-- | src/Chelleport/Config.hs | 3 | ||||
| -rw-r--r-- | src/Chelleport/Context.hs | 17 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 43 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 9 | ||||
| -rw-r--r-- | src/Chelleport/OCR.hs | 18 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 5 | ||||
| -rw-r--r-- | src/Chelleport/Utils.hs | 6 | ||||
| -rw-r--r-- | src/Chelleport/View.hs | 19 |
9 files changed, 141 insertions, 95 deletions
diff --git a/src/Chelleport.hs b/src/Chelleport.hs index 14c181a..d8f74ae 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -4,19 +4,22 @@ import Chelleport.AppShell (MonadAppShell (hideWindow, showWindow, shutdownApp), import Chelleport.Context (initializeContext) import Chelleport.Control ( MonadControl (clickMouseButton, getMousePointerPosition, moveMousePointer, pressMouseButton, releaseMouseButton), + anyAlphanumeric, + anyDigit, + checkKey, + ctrl, directionalIncrement, eventToKeycode, - isKeyPressWith, - isKeyPressed, - isKeyReleaseWith, - withCtrl, - withShift, + key, + pressed, + released, + shift, ) -import Chelleport.Draw (MonadDraw (windowPosition), cellSize) -import Chelleport.KeySequence (findMatchPosition, generateGrid, isKeycodeDigit, isValidKey, keycodeToInt, nextChars, toKeyChar) -import Chelleport.OCR (MonadOCR, getWordsOnScreen) +import Chelleport.Draw (MonadDraw (windowPosition, windowSize), cellSize) +import Chelleport.KeySequence (findMatchPosition, generateGrid, keycodeToInt, nextChars, toKeyChar) +import Chelleport.OCR (MonadOCR (captureScreenshot), getWordsInImage) import Chelleport.Types -import Chelleport.Utils (cIntToInt, clamp, intToCInt, isEmpty, isNotEmpty, itemAt) +import Chelleport.Utils (cIntToInt, clamp, intToCInt, isEmpty, itemAt, (<||>)) import qualified Chelleport.View import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO) @@ -54,46 +57,37 @@ eventHandler state event = case SDL.eventPayload event of SDL.QuitEvent -> Just ShutdownApp SDL.KeyboardEvent ev - -- Escape - | isKeyPressWith ev SDL.KeycodeEscape -> - Just ShutdownApp - -- minus / underscore - | isKeyPressWith ev SDL.KeycodeMinus || isKeyPressWith ev SDL.KeycodeUnderscore -> - if withShift ev + -- Esc: Quit + | checkKey [key SDL.KeycodeEscape, pressed] ev -> Just ShutdownApp + -- <C-s>: Enable search mode + | checkKey [ctrl, key SDL.KeycodeS, pressed] ev -> Just $ SetMode defaultSearchMode + -- <C-h>: Enable hints mode + | checkKey [ctrl, key SDL.KeycodeH, pressed] ev -> Just $ SetMode defaultHintsMode + -- <C-n>, <C-p>: Search increment next/prev + | checkKey [ctrl, key SDL.KeycodeN, pressed] ev -> Just $ IncrementHighlightIndex (stateRepetition state) + | checkKey [ctrl, key SDL.KeycodeP, pressed] ev -> Just $ IncrementHighlightIndex (-1 * stateRepetition state) + -- Space / Shift+Space : Left click/chain left click + | checkKey [key SDL.KeycodeSpace, pressed] ev -> + if shift ev + then Just $ ChainMouseClick LeftClick + else Just $ TriggerMouseClick LeftClick + -- Backspace: Reset keys + | checkKey [key SDL.KeycodeBackspace, pressed] ev -> Just ResetKeys + -- <C-v>: Toggle mouse dragging + | checkKey [ctrl, key SDL.KeycodeV, pressed] ev -> Just MouseDragToggle + -- minus / underscore: Right click/chain right click + | checkKey [key SDL.KeycodeMinus <||> key SDL.KeycodeUnderscore, pressed] ev -> + if shift ev then Just $ ChainMouseClick RightClick else Just $ TriggerMouseClick RightClick - -- 0-9 - | isKeycodeDigit (eventToKeycode ev) -> + -- 0-9: Repetition digit + | checkKey [anyDigit, pressed] ev -> Just $ UpdateRepetition (fromMaybe 0 $ keycodeToInt $ eventToKeycode ev) - -- Enable search mode - | withCtrl ev && isKeyPressWith ev SDL.KeycodeS -> - Just $ SetMode defaultSearchMode - -- Enable hints mode - | withCtrl ev && isKeyPressWith ev SDL.KeycodeH -> - Just $ SetMode defaultHintsMode - -- Search increment next/prev - | withCtrl ev && isKeyPressWith ev SDL.KeycodeN -> Just $ IncrementHighlightIndex (stateRepetition state) - | withCtrl ev && isKeyPressWith ev SDL.KeycodeP -> Just $ IncrementHighlightIndex (-1 * stateRepetition state) - -- Space / Shift+Space - | isKeyPressWith ev SDL.KeycodeSpace -> - if withShift ev - then Just $ ChainMouseClick LeftClick - else Just $ TriggerMouseClick LeftClick - -- Tab / Backspace - | isKeyPressWith ev SDL.KeycodeTab || isKeyPressWith ev SDL.KeycodeBackspace -> - Just ResetKeys - -- Ctrl + V - | withCtrl ev && isKeyPressWith ev SDL.KeycodeV -> - Just MouseDragToggle -- A-Z - | isKeyPressed ev && isValidKey (eventToKeycode ev) -> - Just $ HandleKeyInput $ eventToKeycode ev - -- Shift press - | isKeyPressWith ev SDL.KeycodeLShift || isKeyPressWith ev SDL.KeycodeRShift -> - Just $ UpdateShiftState True - -- Shift release - | isKeyReleaseWith ev SDL.KeycodeLShift || isKeyReleaseWith ev SDL.KeycodeRShift -> - Just $ UpdateShiftState False + | checkKey [anyAlphanumeric, pressed] ev -> Just $ HandleKeyInput $ eventToKeycode ev + -- Shift press/release: Toggle shift mode + | checkKey [pressed, key SDL.KeycodeRShift <||> key SDL.KeycodeLShift] ev -> Just $ UpdateShiftState True + | checkKey [released, key SDL.KeycodeRShift <||> key SDL.KeycodeLShift] ev -> Just $ UpdateShiftState False _ -> Nothing wordPosition :: (MonadDraw m) => OCRMatch -> m (Int, Int) @@ -107,13 +101,17 @@ update state (SetMode mode) = do case mode of ModeHints -> pure (state {stateMode = mode}, Nothing) ModeSearch {} -> do - wordsOnScreen <- getWordsOnScreen + pos <- windowPosition + size <- windowSize + screenshot <- hideWindow >> captureScreenshot pos size <* showWindow + + wordsOnScreen <- getWordsInImage screenshot let updatedMode = mode {searchWords = wordsOnScreen, searchFilteredWords = wordsOnScreen} pure (state {stateMode = updatedMode}, Nothing) -- HINTS MODE: Act on key inputs -update state@(State {stateMode = ModeHints}) (HandleKeyInput key) = do - case (toKeyChar key, validChars) of +update state@(State {stateMode = ModeHints}) (HandleKeyInput keycode) = do + case (toKeyChar keycode, validChars) of (Just keyChar, Just validChars') | stateIsMatched state && keyChar `elem` ("HJKL" :: String) -> do incr <- incrementValue @@ -141,8 +139,8 @@ update state@(State {stateMode = ModeHints}) (HandleKeyInput key) = do else pure (wcell `div` 16, hcell `div` 16) -- SEARCH MODE: Act on key inputs -update state@(State {stateMode = ModeSearch {searchWords, searchInputText}}) (HandleKeyInput key) = do - case toKeyChar key of +update state@(State {stateMode = ModeSearch {searchWords, searchInputText}}) (HandleKeyInput keycode) = do + case toKeyChar keycode of Just keyChar -> do let searchText = searchInputText ++ [toLower keyChar] let matches = filterMatches searchText @@ -193,7 +191,19 @@ update state (MoveMousePosition (x, y)) = do -- Reset entered key sequence and state update state ResetKeys = do - pure (state {stateKeySequence = [], stateIsMatched = False, stateRepetition = 1}, Nothing) + pure + ( state + { stateKeySequence = [], + stateIsMatched = False, + stateRepetition = 1, + stateMode = resetMode (stateMode state) + }, + Nothing + ) + where + resetMode mode@ModeHints = mode + resetMode (ModeSearch {searchWords}) = + defaultSearchMode {searchWords = searchWords, searchFilteredWords = searchWords} -- Trigger click update state (TriggerMouseClick btn) = do @@ -241,5 +251,5 @@ update state (UpdateRepetition count) = do pure (state {stateRepetition = count}, Nothing) -- Set/unset whether shift is pressed -update state (UpdateShiftState shift) = - pure (state {stateIsShiftPressed = shift}, Nothing) +update state (UpdateShiftState shiftPressed) = + pure (state {stateIsShiftPressed = shiftPressed}, Nothing) diff --git a/src/Chelleport/Config.hs b/src/Chelleport/Config.hs index d8b4132..b75abc0 100644 --- a/src/Chelleport/Config.hs +++ b/src/Chelleport/Config.hs @@ -36,6 +36,3 @@ colorFineGrainGrid = SDL.V4 55 52 65 100 windowOpacity :: CFloat windowOpacity = 0.5 - -fontSize :: Int -fontSize = 24 diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs index 30d8516..3109e05 100644 --- a/src/Chelleport/Context.hs +++ b/src/Chelleport/Context.hs @@ -19,7 +19,7 @@ initializeContext = do window <- initializeWindow renderer <- initializeRenderer window - font <- loadFont + (fontSm, fontLg) <- loadFonts display <- X11.openDisplay "" @@ -27,18 +27,21 @@ initializeContext = do DrawContext { ctxWindow = window, ctxRenderer = renderer, - ctxFont = font, + ctxFontLarge = fontLg, + ctxFontSmall = fontSm, ctxX11Display = display } rawFontData :: ByteString rawFontData = $(embedFileRelative "./static/font.ttf") -loadFont :: IO TTF.Font -loadFont = do - font <- TTF.decode rawFontData fontSize - TTF.setStyle font [TTF.Bold] - pure font +loadFonts :: IO (TTF.Font, TTF.Font) +loadFonts = do + fontSm <- TTF.decode rawFontData 14 + TTF.setStyle fontSm [TTF.Bold] + fontLg <- TTF.decode rawFontData 24 + TTF.setStyle fontLg [TTF.Bold] + pure (fontSm, fontLg) initializeRenderer :: SDL.Window -> IO SDL.Renderer initializeRenderer window = do diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index f7a9c66..48bdcb2 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -1,7 +1,8 @@ module Chelleport.Control where +import Chelleport.KeySequence (isKeycodeDigit, isValidKey) import Chelleport.Types -import Chelleport.Utils (cIntToInt) +import Chelleport.Utils import Control.Concurrent (threadDelay) import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -63,31 +64,35 @@ instance (MonadIO m) => MonadControl (AppM m) where xSimulateButtonEvent display X11.button1 False 0 X11.sync display False -isKeyPressed :: SDL.KeyboardEventData -> Bool -isKeyPressed = (SDL.Pressed ==) . SDL.keyboardEventKeyMotion - -isKeyRelease :: SDL.KeyboardEventData -> Bool -isKeyRelease = (SDL.Released ==) . SDL.keyboardEventKeyMotion - eventToKeycode :: SDL.KeyboardEventData -> SDL.Keycode eventToKeycode = SDL.keysymKeycode . SDL.keyboardEventKeysym -isKeyPressWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool -isKeyPressWith keyboardEvent keyCode = - isKeyPressed keyboardEvent && eventToKeycode keyboardEvent == keyCode - -isKeyReleaseWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool -isKeyReleaseWith keyboardEvent keyCode = - isKeyRelease keyboardEvent && eventToKeycode keyboardEvent == keyCode - keyModifier :: SDL.KeyboardEventData -> SDL.KeyModifier keyModifier = SDL.keysymModifier . SDL.keyboardEventKeysym -withShift :: SDL.KeyboardEventData -> Bool -withShift ev = SDL.keyModifierLeftShift (keyModifier ev) || SDL.keyModifierRightShift (keyModifier ev) +checkKey :: [SDL.KeyboardEventData -> Bool] -> SDL.KeyboardEventData -> Bool +checkKey = (<&&>) + +pressed :: SDL.KeyboardEventData -> Bool +pressed = (SDL.Pressed ==) . SDL.keyboardEventKeyMotion + +released :: SDL.KeyboardEventData -> Bool +released = (SDL.Released ==) . SDL.keyboardEventKeyMotion + +key :: SDL.Keycode -> SDL.KeyboardEventData -> Bool +key keycode = (keycode ==) . eventToKeycode + +ctrl :: SDL.KeyboardEventData -> Bool +ctrl ev = SDL.keyModifierLeftCtrl (keyModifier ev) || SDL.keyModifierRightCtrl (keyModifier ev) + +shift :: SDL.KeyboardEventData -> Bool +shift ev = SDL.keyModifierLeftShift (keyModifier ev) || SDL.keyModifierRightShift (keyModifier ev) + +anyDigit :: SDL.KeyboardEventData -> Bool +anyDigit = isKeycodeDigit . eventToKeycode -withCtrl :: SDL.KeyboardEventData -> Bool -withCtrl ev = SDL.keyModifierLeftCtrl (keyModifier ev) || SDL.keyModifierRightCtrl (keyModifier ev) +anyAlphanumeric :: SDL.KeyboardEventData -> Bool +anyAlphanumeric = isValidKey . eventToKeycode directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int) directionalIncrement (incX, incY) = \case diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs index 3720ba0..60944a3 100644 --- a/src/Chelleport/Draw.hs +++ b/src/Chelleport/Draw.hs @@ -12,7 +12,7 @@ import qualified SDL.Font as TTF class (Monad m) => MonadDraw m where drawLine :: (CInt, CInt) -> (CInt, CInt) -> m () - drawText :: (CInt, CInt) -> Color -> Text -> m (CInt, CInt) + drawText :: (CInt, CInt) -> Color -> FontSize -> Text -> m (CInt, CInt) drawCircle :: Int -> (CInt, CInt) -> m () fillRect :: (CInt, CInt) -> (CInt, CInt) -> m () setDrawColor :: Color -> m () @@ -33,8 +33,11 @@ instance (MonadIO m) => MonadDraw (AppM m) where let rect = SDL.Rectangle (SDL.P $ SDL.V2 x y) (SDL.V2 w h) SDL.fillRect renderer (Just rect) - drawText (x, y) color text = do - DrawContext {ctxRenderer = renderer, ctxFont = font} <- ask + drawText (x, y) color size text = do + DrawContext {ctxRenderer = renderer, ctxFontSmall, ctxFontLarge} <- ask + let font = case size of + FontSM -> ctxFontSmall + FontLG -> ctxFontLarge surface <- TTF.blended font color text texture <- SDL.createTextureFromSurface renderer surface SDL.freeSurface surface diff --git a/src/Chelleport/OCR.hs b/src/Chelleport/OCR.hs index f6bc5b9..ef9dc9e 100644 --- a/src/Chelleport/OCR.hs +++ b/src/Chelleport/OCR.hs @@ -1,6 +1,7 @@ module Chelleport.OCR (MonadOCR (..)) where import Chelleport.Types +import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.RWS (MonadReader (ask)) import qualified Data.ByteString as BS @@ -9,7 +10,6 @@ import Foreign.C (CInt, CString, newCString) import GHC.IO.Handle.FD (withFile) import GHC.IO.IOMode (IOMode (WriteMode)) import qualified Graphics.X11 as X11 -import qualified SDL import System.Directory (removeFile) import System.IO (hPutStrLn) import System.IO.Temp (emptySystemTempFile) @@ -18,16 +18,20 @@ foreign import ccall unsafe "libchelleport.h findWordCoordinates" c_getAllWordCoordinates :: CString -> Ptr CInt -> IO (Ptr OCRMatch) class (Monad m) => MonadOCR m where - getWordsOnScreen :: m [OCRMatch] + captureScreenshot :: (CInt, CInt) -> (CInt, CInt) -> m FilePath + getWordsInImage :: FilePath -> m [OCRMatch] instance (MonadIO m) => MonadOCR (AppM m) where - getWordsOnScreen = do + captureScreenshot (x, y) (width, height) = do ctx <- ask - SDL.V2 width height <- SDL.get . SDL.windowSize . ctxWindow $ ctx - SDL.V2 x y <- SDL.getWindowAbsolutePosition . ctxWindow $ ctx liftIO $ do - imgFilePath <- liftIO $ createTemporaryScreenshot ctx (x, y) (width, height) - findWordCoordinates imgFilePath <* removeFile imgFilePath + threadDelay 20_000 + path <- createTemporaryScreenshot ctx (x, y) (width, height) + threadDelay 20_000 + pure path + + getWordsInImage filePath = do + liftIO $ findWordCoordinates filePath <* removeFile filePath findWordCoordinates :: String -> IO [OCRMatch] findWordCoordinates imgPath = alloca $ \sizePtr -> do diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index 43d063f..59ed43d 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -79,10 +79,13 @@ data AppAction | IncrementHighlightIndex Int deriving (Show, Eq) +data FontSize = FontSM | FontLG deriving (Show, Eq) + data DrawContext = DrawContext { ctxWindow :: SDL.Window, ctxRenderer :: SDL.Renderer, - ctxFont :: TTF.Font, + ctxFontSmall :: TTF.Font, + ctxFontLarge :: TTF.Font, ctxX11Display :: X11.Display } diff --git a/src/Chelleport/Utils.hs b/src/Chelleport/Utils.hs index 9423e5d..3f0dd73 100644 --- a/src/Chelleport/Utils.hs +++ b/src/Chelleport/Utils.hs @@ -43,3 +43,9 @@ itemAt (_ : xs) i = itemAt xs (i - 1) clamp :: (Integral a) => (a, a) -> a -> a clamp (low, high) n = max low (min high n) + +(<&&>) :: [a -> Bool] -> a -> Bool +(<&&>) preds ev = all (\p -> p ev) preds + +(<||>) :: (a -> Bool) -> (a -> Bool) -> a -> Bool +(<||>) p1 p2 x = p1 x || p2 x diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs index c2e0ff8..202c636 100644 --- a/src/Chelleport/View.hs +++ b/src/Chelleport/View.hs @@ -15,13 +15,28 @@ render state = case stateMode state of ModeSearch {searchFilteredWords, searchHighlightedIndex} -> renderSearchView state searchFilteredWords searchHighlightedIndex +getSearchText :: State -> String +getSearchText state = case stateMode state of + ModeHints -> "" + ModeSearch {searchInputText, searchFilteredWords, searchHighlightedIndex} -> + "Searching (" ++ matchCount ++ "): " ++ searchInputText + where + matchCount + | isEmpty searchFilteredWords = "0/0" + | otherwise = show (searchHighlightedIndex + 1) ++ "/" ++ show (length searchFilteredWords) + renderSearchView :: (MonadDraw m) => State -> [OCRMatch] -> Int -> m () renderSearchView state matches highlightedIndex = do renderGridLines state + forM_ (zip [0 ..] matches) $ \(index, OCRMatch {matchStartX, matchStartY, matchEndX, matchEndY}) -> do setDrawColor $ if highlightedIndex == index then colorAccent else colorLightGray fillRectVertices (matchStartX, matchStartY) (matchEndX, matchEndY) + (w, h) <- windowSize + drawText (w `div` 2, h `div` 2) colorAccent FontSM (Text.pack $ getSearchText state) + pure () + renderHintsView :: (MonadDraw m) => State -> m () renderHintsView state = do renderGridLines state @@ -50,12 +65,12 @@ renderKeySequence keySequence cell (px, py) = do previousTextWidth <- if isNotEmpty matched - then fst <$> drawText (px, py) colorLightGray (Text.pack matched) + then fst <$> drawText (px, py) colorLightGray FontLG (Text.pack matched) else pure 0 when (isNotEmpty remaining) $ case textColor of Just color -> do - void $ drawText (px + previousTextWidth, py) color $ Text.pack remaining + void $ drawText (px + previousTextWidth, py) color FontLG $ Text.pack remaining Nothing -> pure () pure isVisible |