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

8 files changed, 78 insertions, 42 deletions

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