diff options
| -rw-r--r-- | TODO.norg | 7 | ||||
| -rw-r--r-- | src/Chelleport.hs | 46 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 12 | ||||
| -rw-r--r-- | src/Chelleport/Utils.hs | 8 | ||||
| -rw-r--r-- | src/Chelleport/View.hs | 11 |
5 files changed, 68 insertions, 16 deletions
@@ -1,9 +1,14 @@ * Current + - ( ) Optimize speed of ocr + --- Load incrementally? + - ( ) Preprocessing screenshot for better ocr + - ( ) Add hjkl for search mode - ( ) Middle click * Later - ( ) Look into making controls cross-platform - - ( ) Switch to [test-fixture]{https://hackage.haskell.org/package/test-fixture} + - ( ) Lens-ey setup for Mode access + - ( ) Switch to [test-fixture]{https://hackage.haskell.org/package/test-fixture}? * Maybe - ( ) Scroll diff --git a/src/Chelleport.hs b/src/Chelleport.hs index 4b44dd1..14c181a 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -16,7 +16,7 @@ import Chelleport.Draw (MonadDraw (windowPosition), cellSize) import Chelleport.KeySequence (findMatchPosition, generateGrid, isKeycodeDigit, isValidKey, keycodeToInt, nextChars, toKeyChar) import Chelleport.OCR (MonadOCR, getWordsOnScreen) import Chelleport.Types -import Chelleport.Utils (cIntToInt, intToCInt, isEmpty, isNotEmpty) +import Chelleport.Utils (cIntToInt, clamp, intToCInt, isEmpty, isNotEmpty, itemAt) import qualified Chelleport.View import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO) @@ -34,7 +34,7 @@ run = do ctx initialState update - (const eventHandler) + eventHandler Chelleport.View.render where runAppWithCtx :: (MonadIO m) => DrawContext -> AppM m x -> m x @@ -49,8 +49,8 @@ initialState = do columns = 16 hintKeys = ['A' .. 'Z'] -eventHandler :: SDL.Event -> Maybe AppAction -eventHandler event = +eventHandler :: State -> SDL.Event -> Maybe AppAction +eventHandler state event = case SDL.eventPayload event of SDL.QuitEvent -> Just ShutdownApp SDL.KeyboardEvent ev @@ -71,6 +71,9 @@ eventHandler event = -- 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 @@ -93,6 +96,11 @@ eventHandler event = Just $ UpdateShiftState False _ -> Nothing +wordPosition :: (MonadDraw m) => OCRMatch -> m (Int, Int) +wordPosition (OCRMatch {matchStartX, matchStartY}) = do + (x, y) <- windowPosition + pure (cIntToInt $ x + matchStartX, cIntToInt $ y + matchStartY) + update :: (MonadAppShell m, MonadDraw m, MonadControl m, MonadOCR m) => State -> AppAction -> m (State, Maybe AppAction) -- Set mode update state (SetMode mode) = do @@ -138,17 +146,39 @@ update state@(State {stateMode = ModeSearch {searchWords, searchInputText}}) (Ha Just keyChar -> do let searchText = searchInputText ++ [toLower keyChar] let matches = filterMatches searchText - let highlightedWord = if isNotEmpty matches then Just $ head matches else Nothing - let updatedMode = (stateMode state) {searchInputText = searchText, searchFilteredWords = matches} - pure (state {stateMode = updatedMode}, MoveMousePosition . wordPosition <$> highlightedWord) + let mode = stateMode state + let highlightedIndex = clamp (0, length matches - 1) (searchHighlightedIndex mode) + let updatedMode = + mode + { searchInputText = searchText, + searchFilteredWords = matches, + searchHighlightedIndex = highlightedIndex + } + let highlightedWord = matches `itemAt` highlightedIndex + action <- maybe (pure Nothing) (fmap (Just . MoveMousePosition) . wordPosition) highlightedWord + pure (state {stateMode = updatedMode}, action) _ -> do pure (state, Nothing) where - wordPosition w = (cIntToInt $ matchStartX w, cIntToInt $ matchStartY w) filterMatches text | isEmpty text = searchWords | otherwise = filter (isInfixOf text . map toLower . matchText) searchWords +-- Increment highlighted index for search mode +update state (IncrementHighlightIndex n) = do + case stateMode state of + ModeSearch {} -> do + let mode = stateMode state + let index = searchHighlightedIndex mode + n + let highlightedIndex = + if index < 0 + then length (searchFilteredWords mode) - 1 + else index `mod` length (searchFilteredWords mode) + let highlightedWord = searchFilteredWords mode `itemAt` highlightedIndex + action <- maybe (pure Nothing) (fmap (Just . MoveMousePosition) . wordPosition) highlightedWord + pure (state {stateRepetition = 1, stateMode = mode {searchHighlightedIndex = highlightedIndex}}, action) + _ -> pure (state, Nothing) + -- Move mouse incrementally update state (IncrementMouseCursor (incX, incY)) = do (curX, curY) <- getMousePointerPosition diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index 9894e54..43d063f 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -22,12 +22,19 @@ data Mode | ModeSearch { searchWords :: [OCRMatch], searchFilteredWords :: [OCRMatch], - searchInputText :: String + searchInputText :: String, + searchHighlightedIndex :: Int } deriving (Show, Eq) defaultSearchMode :: Mode -defaultSearchMode = ModeSearch {searchWords = [], searchFilteredWords = [], searchInputText = ""} +defaultSearchMode = + ModeSearch + { searchWords = [], + searchFilteredWords = [], + searchInputText = "", + searchHighlightedIndex = 0 + } defaultHintsMode :: Mode defaultHintsMode = ModeHints @@ -69,6 +76,7 @@ data AppAction | UpdateShiftState Bool | UpdateRepetition Int | SetMode Mode + | IncrementHighlightIndex Int deriving (Show, Eq) data DrawContext = DrawContext diff --git a/src/Chelleport/Utils.hs b/src/Chelleport/Utils.hs index c15a3e8..9423e5d 100644 --- a/src/Chelleport/Utils.hs +++ b/src/Chelleport/Utils.hs @@ -35,3 +35,11 @@ benchmark msg m = do end <- systemNanoseconds <$> liftIO getSystemTime Debug.traceM $ msg ++ " (ms): " ++ show (fromIntegral (end - start) / 1_000_000.0 :: Double) pure result + +itemAt :: [a] -> Int -> Maybe a +itemAt [] _ = Nothing +itemAt (x : _) 0 = Just x +itemAt (_ : xs) i = itemAt xs (i - 1) + +clamp :: (Integral a) => (a, a) -> a -> a +clamp (low, high) n = max low (min high n) diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs index 1a4f1f8..c2e0ff8 100644 --- a/src/Chelleport/View.hs +++ b/src/Chelleport/View.hs @@ -12,13 +12,14 @@ import Foreign.C (CInt) render :: (MonadDraw m) => State -> m () render state = case stateMode state of ModeHints -> renderHintsView state - ModeSearch {searchFilteredWords} -> renderSearchView state searchFilteredWords + ModeSearch {searchFilteredWords, searchHighlightedIndex} -> + renderSearchView state searchFilteredWords searchHighlightedIndex -renderSearchView :: (MonadDraw m) => State -> [OCRMatch] -> m () -renderSearchView state matches = do +renderSearchView :: (MonadDraw m) => State -> [OCRMatch] -> Int -> m () +renderSearchView state matches highlightedIndex = do renderGridLines state - setDrawColor colorWhite - forM_ matches $ \(OCRMatch {matchStartX, matchStartY, matchEndX, matchEndY}) -> do + forM_ (zip [0 ..] matches) $ \(index, OCRMatch {matchStartX, matchStartY, matchEndX, matchEndY}) -> do + setDrawColor $ if highlightedIndex == index then colorAccent else colorLightGray fillRectVertices (matchStartX, matchStartY) (matchEndX, matchEndY) renderHintsView :: (MonadDraw m) => State -> m () |