Add searching indication text for search mode + a lot of refactoring

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