aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cpp/libchelleport.cpp10
-rw-r--r--flake.nix2
-rw-r--r--include/libchelleport.h2
-rw-r--r--specs/Specs/AppStateUpdateSpec.hs56
-rw-r--r--specs/Specs/ViewSpec.hs11
-rw-r--r--specs/TestUtils.hs7
-rw-r--r--src/Chelleport.hs91
-rw-r--r--src/Chelleport/AppShell.hs9
-rw-r--r--src/Chelleport/Control.hs4
-rw-r--r--src/Chelleport/Draw.hs9
-rw-r--r--src/Chelleport/OCR.hs40
-rw-r--r--src/Chelleport/Types.hs29
-rw-r--r--src/Chelleport/View.hs14
13 files changed, 159 insertions, 125 deletions
diff --git a/cpp/libchelleport.cpp b/cpp/libchelleport.cpp
index 8f2e9f2..345a454 100644
--- a/cpp/libchelleport.cpp
+++ b/cpp/libchelleport.cpp
@@ -13,6 +13,8 @@
std::vector<OCRMatch> extractTextCoordinates(const char *imagePath);
#define CONFIDENCE_THRESHOLD 30.
+#define MIN_CHARACTER_COUNT 2
+const tesseract::PageIteratorLevel RESULT_ITER_MODE = tesseract::RIL_WORD;
OCRMatch *findWordCoordinates(const char *image_path, int *size) {
auto boxes = extractTextCoordinates(image_path);
@@ -49,7 +51,7 @@ std::vector<OCRMatch> extractTextCoordinates(const char *imagePath) {
tesseract->Recognize(0);
tesseract::ResultIterator *iterator = tesseract->GetIterator();
- tesseract::PageIteratorLevel level = tesseract::RIL_TEXTLINE;
+ auto level = RESULT_ITER_MODE;
if (iterator != 0) {
do {
@@ -58,9 +60,9 @@ std::vector<OCRMatch> extractTextCoordinates(const char *imagePath) {
int x1, y1, x2, y2;
iterator->BoundingBox(level, &x1, &y1, &x2, &y2);
- if (conf > CONFIDENCE_THRESHOLD && word != nullptr && strlen(word) >= 2) {
- OCRMatch box{x1, y1, x2, y2, word};
- results.push_back(box);
+ if (conf > CONFIDENCE_THRESHOLD && word != nullptr &&
+ strlen(word) >= MIN_CHARACTER_COUNT) {
+ results.push_back(OCRMatch{x1, y1, x2, y2, word});
}
} while (iterator->Next(level));
}
diff --git a/flake.nix b/flake.nix
index 48557f5..3486cff 100644
--- a/flake.nix
+++ b/flake.nix
@@ -26,6 +26,7 @@
});
otherFiles = [
{ source = ./static; target = "static"; }
+ { source = ./include; target = "include"; }
];
configurationFlags = [
"--ghc-options=-O2"
@@ -37,7 +38,6 @@
SDL2_ttf
tesseract
leptonica
- imagemagick
gcc
pkg-config
diff --git a/include/libchelleport.h b/include/libchelleport.h
index 8a9a17e..adb9f5d 100644
--- a/include/libchelleport.h
+++ b/include/libchelleport.h
@@ -1,5 +1,3 @@
-#include <string>
-
// NOTE: Remember to update size and alignment in ocr hs module on change
struct OCRMatch {
int startX, startY;
diff --git a/specs/Specs/AppStateUpdateSpec.hs b/specs/Specs/AppStateUpdateSpec.hs
index e54f50f..861264d 100644
--- a/specs/Specs/AppStateUpdateSpec.hs
+++ b/specs/Specs/AppStateUpdateSpec.hs
@@ -2,7 +2,7 @@ module Specs.AppStateUpdateSpec where
import Chelleport (initialState, update)
import Chelleport.Types
-import Chelleport.Utils (intToCInt, uniq)
+import Chelleport.Utils (uniq)
import Control.Monad (join)
import qualified SDL
import Test.Hspec
@@ -12,32 +12,23 @@ test :: SpecWith ()
test = do
describe "#initialState" $ do
it "returns the initial state of the app" $ do
- (initState, _) <- runWithMocks initialState
+ ((initState, _), _) <- runWithMocks initialState
stateKeySequence initState `shouldBe` []
stateIsMatched initState `shouldBe` False
stateIsShiftPressed initState `shouldBe` False
it "returns grid with 16x9 key sequences" $ do
- (initState, _) <- runWithMocks initialState
+ ((initState, _), _) <- runWithMocks initialState
length (stateGrid initState) `shouldBe` 9
stateGrid initState `shouldSatisfy` all ((== 16) . length)
stateGrid initState `shouldSatisfy` all (all ((== 2) . length))
it "returns grid with all unique key sequences" $ do
- (initState, _) <- runWithMocks initialState
+ ((initState, _), _) <- runWithMocks initialState
join (stateGrid initState) `shouldBe` uniq (join $ stateGrid initState)
describe "#update" $ do
- let defaultState =
- State
- { stateKeySequence = [],
- stateIsShiftPressed = False,
- stateIsMatched = False,
- stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]],
- stateRepetition = 1,
- stateIsDragging = False,
- stateMode = ModeHints
- }
+ let defaultState = defaultAppState {stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]]}
context "with action HandleKeyInput" $ do
context "when there are no matches" $ do
@@ -63,9 +54,9 @@ test = do
((nextState, _), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeF
nextState `shouldBe` currentState {stateKeySequence = "DEF", stateIsMatched = True}
- it "continues with MoveMousePosition action" $ do
+ it "continues with MoveMousePosition action at center of matched cell" $ do
((_, action), _) <- runWithMocks $ update currentState $ HandleKeyInput SDL.KeycodeF
- action `shouldBe` Just (MoveMousePosition (0, 1))
+ action `shouldBe` Just (MoveMousePosition (1640, 370))
context "with action TriggerMouseClick" $ do
let currentState = defaultState
@@ -185,16 +176,10 @@ test = do
context "with action MoveMousePosition" $ do
let currentState = defaultState
- let rows = intToCInt $ length $ stateGrid currentState
- let columns = intToCInt $ length $ head $ stateGrid currentState
- -- TODO: Test with inline mocked values
- it "moves mouse pointer to center of cell of given coordinates" $ do
- (_, mock) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0)
- mock
- `shouldHaveCalled` Mock_moveMousePointer
- (mockWindowOffsetX + mockWindowWidth `div` columns `div` 2)
- (mockWindowOffsetY + mockWindowHeight `div` rows `div` 2)
+ it "moves mouse pointer to the given coordinates" $ do
+ (_, mock) <- runWithMocks $ update currentState $ MoveMousePosition (23, 320)
+ mock `shouldHaveCalled` Mock_moveMousePointer 23 320
it "does not continue or update state" $ do
(result, _) <- runWithMocks $ update currentState $ MoveMousePosition (0, 0)
@@ -211,28 +196,27 @@ test = do
context "with action IncrementMouseCursor" $ do
let currentState = defaultState
- -- TODO: Test with inline mocked values
- it "increments mouse position relative to current position" $ do
- (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
- mock `shouldHaveCalled` Mock_moveMousePointer 52 37
+ it "continues with MoveMousePosition" $ do
+ ((_, action), _) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
+ action `shouldBe` Just (MoveMousePosition (52, 37))
- it "does not continue or update state" $ do
- (result, _) <- runWithMocks $ update currentState $ IncrementMouseCursor (0, 0)
- result `shouldBe` (currentState, Nothing)
+ it "does update state" $ do
+ ((state, _), _) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
+ state `shouldBe` currentState
context "when repetition is more than 1" $ do
let currentState = defaultState {stateRepetition = 5}
it "multiplies increment" $ do
- (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
- mock `shouldHaveCalled` Mock_moveMousePointer 92 17
+ ((_, action), _) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
+ action `shouldBe` Just (MoveMousePosition (92, 17))
context "when repetition is 0" $ do
let currentState = defaultState {stateRepetition = 0}
it "increments just once" $ do
- (_, mock) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
- mock `shouldHaveCalled` Mock_moveMousePointer 52 37
+ ((_, action), _) <- runWithMocks $ update currentState $ IncrementMouseCursor (10, -5)
+ action `shouldBe` Just (MoveMousePosition (52, 37))
context "with action ShutdownApp" $ do
let currentState = defaultState
diff --git a/specs/Specs/ViewSpec.hs b/specs/Specs/ViewSpec.hs
index b8418d6..39e7fea 100644
--- a/specs/Specs/ViewSpec.hs
+++ b/specs/Specs/ViewSpec.hs
@@ -8,16 +8,7 @@ import TestUtils
test :: SpecWith ()
test = do
- let defaultState =
- State
- { stateKeySequence = [],
- stateIsShiftPressed = False,
- stateIsMatched = False,
- stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]],
- stateRepetition = 1,
- stateIsDragging = False,
- stateMode = ModeHints
- }
+ let defaultState = defaultAppState {stateGrid = [["ABC", "DEF"], ["DJK", "JKL"]]}
let drawTextCalls = filter (\case Mock_drawText {} -> True; _ -> False) . calls
describe "#render" $ do
diff --git a/specs/TestUtils.hs b/specs/TestUtils.hs
index c98899d..76a185d 100644
--- a/specs/TestUtils.hs
+++ b/specs/TestUtils.hs
@@ -3,6 +3,7 @@ module TestUtils where
import Chelleport.AppShell (MonadAppShell (..))
import Chelleport.Control (MonadControl (..))
import Chelleport.Draw (MonadDraw (..))
+import Chelleport.OCR (MonadOCR (..))
import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (MonadState (state), StateT (runStateT))
@@ -11,7 +12,7 @@ import Foreign.C (CInt)
import Mock
import Test.Hspec
-$(generateMock [''MonadDraw, ''MonadControl, ''MonadAppShell])
+$(generateMock [''MonadDraw, ''MonadControl, ''MonadAppShell, ''MonadOCR])
newtype MockCalls = MockCalls {calls :: [Call]}
deriving (Show)
@@ -53,6 +54,7 @@ instance (MonadIO m) => MonadControl (TestM m) where
instance (MonadIO m) => MonadDraw (TestM m) where
drawLine p1 p2 = registerMockCall $ Mock_drawLine p1 p2
+ fillRect p size = registerMockCall $ Mock_fillRect p size
drawText p color text = (fromIntegral $ mockTextWidth * Text.length text, 0) <$ registerMockCall (Mock_drawText p color text)
drawCircle radius p = registerMockCall $ Mock_drawCircle radius p
setDrawColor color = registerMockCall $ Mock_setDrawColor color
@@ -63,3 +65,6 @@ instance (MonadIO m) => MonadAppShell (TestM m) where
hideWindow = registerMockCall Mock_hideWindow
showWindow = registerMockCall Mock_showWindow
shutdownApp = registerMockCall Mock_shutdownApp
+
+instance (MonadIO m) => MonadOCR (TestM m) where
+ getWordsOnScreen = [] <$ registerMockCall Mock_getWordsOnScreen
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 96c9fb6..4b44dd1 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -14,23 +14,18 @@ import Chelleport.Control
)
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 (intToCInt)
+import Chelleport.Utils (cIntToInt, intToCInt, isEmpty, isNotEmpty)
import qualified Chelleport.View
import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (ReaderT (runReaderT))
+import Data.Char (toLower)
+import Data.List (isInfixOf)
import Data.Maybe (fromMaybe, isJust)
import qualified SDL
--- run :: IO ()
--- run = do
--- ctx <- initializeContext
--- benchmark "ocr" $ do
--- res <- (`runReaderT` ctx) . runAppM $ getWordsOnScreen
--- print $ "---" ++ show (length res)
--- pure ()
-
run :: IO ()
run = do
ctx <- initializeContext
@@ -45,19 +40,10 @@ run = do
runAppWithCtx :: (MonadIO m) => DrawContext -> AppM m x -> m x
runAppWithCtx ctx = (`runReaderT` ctx) . runAppM
-initialState :: (Monad m) => m State
+initialState :: (Monad m) => m (State, Maybe AppAction)
initialState = do
let cells = fromMaybe (pure undefined) $ generateGrid 0 (rows, columns) hintKeys
- pure $
- State
- { stateGrid = cells,
- stateKeySequence = [],
- stateIsMatched = False,
- stateIsShiftPressed = False,
- stateIsDragging = False,
- stateRepetition = 1,
- stateMode = ModeSearch
- }
+ pure (defaultAppState {stateGrid = cells}, Just $ SetMode defaultHintsMode)
where
rows = 9
columns = 16
@@ -79,6 +65,12 @@ eventHandler event =
-- 0-9
| isKeycodeDigit (eventToKeycode 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
-- Space / Shift+Space
| isKeyPressWith ev SDL.KeycodeSpace ->
if withShift ev
@@ -101,9 +93,18 @@ eventHandler event =
Just $ UpdateShiftState False
_ -> Nothing
-update :: (MonadAppShell m, MonadDraw m, MonadControl m) => State -> AppAction -> m (State, Maybe AppAction)
--- Act on key inputs
-update state (HandleKeyInput key) = do
+update :: (MonadAppShell m, MonadDraw m, MonadControl m, MonadOCR m) => State -> AppAction -> m (State, Maybe AppAction)
+-- Set mode
+update state (SetMode mode) = do
+ case mode of
+ ModeHints -> pure (state {stateMode = mode}, Nothing)
+ ModeSearch {} -> do
+ wordsOnScreen <- getWordsOnScreen
+ 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
(Just keyChar, Just validChars')
| stateIsMatched state && keyChar `elem` ("HJKL" :: String) -> do
@@ -114,35 +115,51 @@ update state (HandleKeyInput key) = do
let newKeySequence = stateKeySequence state ++ [keyChar]
let matchPosition = findMatchPosition newKeySequence $ stateGrid state
let state' = state {stateKeySequence = newKeySequence, stateIsMatched = isJust matchPosition}
- pure (state', MoveMousePosition <$> matchPosition)
+ action <- maybe (pure Nothing) (fmap (Just . MoveMousePosition) . getPosition) matchPosition
+ pure (state', action)
_ -> pure (state, Nothing)
where
validChars = nextChars (stateKeySequence state) (stateGrid state)
+ getPosition (row, col) = do
+ (wcell, hcell) <- cellSize state
+ let x = (wcell `div` 2) + wcell * intToCInt col
+ let y = (hcell `div` 2) + hcell * intToCInt row
+ (winx, winy) <- windowPosition
+ pure (cIntToInt $ winx + x, cIntToInt $ winy + y)
incrementValue = do
(wcell, hcell) <- cellSize state
if stateIsShiftPressed state
then pure (wcell `div` 4, hcell `div` 4)
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
+ 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)
+ _ -> 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
+
-- Move mouse incrementally
update state (IncrementMouseCursor (incX, incY)) = do
(curX, curY) <- getMousePointerPosition
- let count = intToCInt $ case stateRepetition state of 0 -> 1; n -> n
- moveMousePointer (curX + count * intToCInt incX) (curY + count * intToCInt incY)
- pure (state {stateRepetition = 1}, Nothing)
+ let count = case stateRepetition state of 0 -> 1; n -> n
+ let pos = (cIntToInt curX + count * incX, cIntToInt curY + count * incY)
+ pure (state {stateRepetition = 1}, Just $ MoveMousePosition pos)
-- Move mouse to given position
-update state (MoveMousePosition (row, col)) = do
- (x, y) <- getPosition
- moveMousePointer x y
+update state (MoveMousePosition (x, y)) = do
+ moveMousePointer (intToCInt x) (intToCInt y)
pure (state, Nothing)
- where
- getPosition = do
- (wcell, hcell) <- cellSize state
- let x = (wcell `div` 2) + wcell * intToCInt col
- let y = (hcell `div` 2) + hcell * intToCInt row
- (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 ba31982..2e95a85 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -35,18 +35,19 @@ type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
type View m state = state -> m ()
-type Initializer m state = m state
+type Initializer m state appAction = m (state, Maybe appAction)
setupAppShell ::
(MonadIO m) =>
DrawContext ->
- Initializer m state ->
+ Initializer m state appAction ->
Update m state appAction ->
EventHandler state appAction ->
View m state ->
m ()
-setupAppShell (DrawContext {ctxRenderer = renderer}) getInitState update eventHandler draw =
- getInitState >>= appLoop
+setupAppShell (DrawContext {ctxRenderer = renderer}) getInitState update eventHandler draw = do
+ state <- getInitState >>= evalUpdateResult
+ appLoop state
where
appLoop currentState = do
SDL.rendererDrawColor renderer $= colorBackground
diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs
index 80be6f8..f7a9c66 100644
--- a/src/Chelleport/Control.hs
+++ b/src/Chelleport/Control.hs
@@ -64,10 +64,10 @@ instance (MonadIO m) => MonadControl (AppM m) where
X11.sync display False
isKeyPressed :: SDL.KeyboardEventData -> Bool
-isKeyPressed = (== SDL.Pressed) . SDL.keyboardEventKeyMotion
+isKeyPressed = (SDL.Pressed ==) . SDL.keyboardEventKeyMotion
isKeyRelease :: SDL.KeyboardEventData -> Bool
-isKeyRelease = (== SDL.Released) . SDL.keyboardEventKeyMotion
+isKeyRelease = (SDL.Released ==) . SDL.keyboardEventKeyMotion
eventToKeycode :: SDL.KeyboardEventData -> SDL.Keycode
eventToKeycode = SDL.keysymKeycode . SDL.keyboardEventKeysym
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index 3f67848..3720ba0 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -14,6 +14,7 @@ class (Monad m) => MonadDraw m where
drawLine :: (CInt, CInt) -> (CInt, CInt) -> m ()
drawText :: (CInt, CInt) -> Color -> Text -> m (CInt, CInt)
drawCircle :: Int -> (CInt, CInt) -> m ()
+ fillRect :: (CInt, CInt) -> (CInt, CInt) -> m ()
setDrawColor :: Color -> m ()
windowSize :: m (CInt, CInt)
windowPosition :: m (CInt, CInt)
@@ -27,6 +28,11 @@ instance (MonadIO m) => MonadDraw (AppM m) where
renderer <- asks ctxRenderer
SDL.rendererDrawColor renderer $= color
+ fillRect (x, y) (w, h) = do
+ renderer <- asks ctxRenderer
+ 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
surface <- TTF.blended font color text
@@ -65,6 +71,9 @@ instance (MonadIO m) => MonadDraw (AppM m) where
SDL.V2 x y <- asks ctxWindow >>= SDL.getWindowAbsolutePosition
pure (x, y)
+fillRectVertices :: (MonadDraw m) => (CInt, CInt) -> (CInt, CInt) -> m ()
+fillRectVertices (x1, y1) (x2, y2) = fillRect (x1, y1) (x2 - x1, y2 - y1)
+
cellSize :: (MonadDraw m) => State -> m (CInt, CInt)
cellSize (State {stateGrid}) = do
(width, height) <- windowSize
diff --git a/src/Chelleport/OCR.hs b/src/Chelleport/OCR.hs
index 496b6a0..f6bc5b9 100644
--- a/src/Chelleport/OCR.hs
+++ b/src/Chelleport/OCR.hs
@@ -1,8 +1,8 @@
-module Chelleport.OCR (getWordsOnScreen) where
+module Chelleport.OCR (MonadOCR (..)) where
import Chelleport.Types
import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.RWS (asks)
+import Control.Monad.RWS (MonadReader (ask))
import qualified Data.ByteString as BS
import Foreign (Bits (shiftR), Ptr, Storable (peek, pokeByteOff), alloca, allocaBytes, peekArray, (.&.))
import Foreign.C (CInt, CString, newCString)
@@ -15,48 +15,39 @@ import System.IO (hPutStrLn)
import System.IO.Temp (emptySystemTempFile)
foreign import ccall unsafe "libchelleport.h findWordCoordinates"
- c_findWordCoordinates :: CString -> Ptr CInt -> IO (Ptr OCRMatch)
+ c_getAllWordCoordinates :: CString -> Ptr CInt -> IO (Ptr OCRMatch)
class (Monad m) => MonadOCR m where
getWordsOnScreen :: m [OCRMatch]
instance (MonadIO m) => MonadOCR (AppM m) where
getWordsOnScreen = do
- SDL.V2 width height <- asks ctxWindow >>= SDL.get . SDL.windowSize
- SDL.V2 x y <- asks ctxWindow >>= SDL.getWindowAbsolutePosition
+ 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 (x, y) (width, height)
+ imgFilePath <- liftIO $ createTemporaryScreenshot ctx (x, y) (width, height)
findWordCoordinates imgFilePath <* removeFile imgFilePath
findWordCoordinates :: String -> IO [OCRMatch]
findWordCoordinates imgPath = alloca $ \sizePtr -> do
imgPathC <- newCString imgPath
- arrayPtr <- c_findWordCoordinates imgPathC sizePtr
+ arrayPtr <- c_getAllWordCoordinates imgPathC sizePtr
size <- peek sizePtr
peekArray (fromIntegral size) arrayPtr
-createTemporaryScreenshot :: (CInt, CInt) -> (CInt, CInt) -> IO String
-createTemporaryScreenshot offset size = do
+createTemporaryScreenshot :: DrawContext -> (CInt, CInt) -> (CInt, CInt) -> IO String
+createTemporaryScreenshot ctx offset size = do
tmpFilePath <- emptySystemTempFile "chelleport-screenshot.png"
- screenshot tmpFilePath offset size
+ screenshot ctx tmpFilePath offset size
pure tmpFilePath
-screenshot :: String -> (CInt, CInt) -> (CInt, CInt) -> IO ()
-screenshot filename (offsetX, offsetY) (width, height) = do
- dpy <- X11.openDisplay ""
- root <- X11.rootWindow dpy (X11.defaultScreen dpy)
+screenshot :: DrawContext -> String -> (CInt, CInt) -> (CInt, CInt) -> IO ()
+screenshot (DrawContext {ctxX11Display = display}) filename (offsetX, offsetY) (width, height) = do
+ root <- X11.rootWindow display (X11.defaultScreen display)
- image <-
- X11.getImage
- dpy
- root
- offsetX
- offsetY
- (fromIntegral width)
- (fromIntegral height)
- (fromIntegral X11.allPlanes_aux)
- X11.zPixmap
+ image <- X11.getImage display root offsetX offsetY (fromIntegral width) (fromIntegral height) (fromIntegral X11.allPlanes_aux) X11.zPixmap
allocaBytes (fromIntegral $ width * height * 3) $ \ptr -> do
let getPixel :: CInt -> CInt -> IO ()
@@ -74,7 +65,6 @@ screenshot filename (offsetX, offsetY) (width, height) = do
savePPMFile filename (fromIntegral width) (fromIntegral height) rgbData
X11.destroyImage image
- X11.closeDisplay dpy
savePPMFile :: FilePath -> Int -> Int -> BS.ByteString -> IO ()
savePPMFile path width height rgbData = withFile path WriteMode $ \h -> do
diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs
index cb580e0..9894e54 100644
--- a/src/Chelleport/Types.hs
+++ b/src/Chelleport/Types.hs
@@ -17,9 +17,21 @@ type KeySequence = [Char]
type KeyGrid = [[Cell]]
-data Mode = ModeHints | ModeSearch
+data Mode
+ = ModeHints
+ | ModeSearch
+ { searchWords :: [OCRMatch],
+ searchFilteredWords :: [OCRMatch],
+ searchInputText :: String
+ }
deriving (Show, Eq)
+defaultSearchMode :: Mode
+defaultSearchMode = ModeSearch {searchWords = [], searchFilteredWords = [], searchInputText = ""}
+
+defaultHintsMode :: Mode
+defaultHintsMode = ModeHints
+
data State = State
{ stateGrid :: KeyGrid,
stateKeySequence :: KeySequence,
@@ -31,6 +43,18 @@ data State = State
}
deriving (Show, Eq)
+defaultAppState :: State
+defaultAppState =
+ State
+ { stateGrid = [],
+ stateKeySequence = "",
+ stateIsMatched = False,
+ stateIsShiftPressed = False,
+ stateIsDragging = False,
+ stateRepetition = 1,
+ stateMode = ModeHints
+ }
+
data AppAction
= ChainMouseClick MouseButtonType
| HandleKeyInput SDL.Keycode
@@ -44,6 +68,7 @@ data AppAction
| TriggerMouseClick MouseButtonType
| UpdateShiftState Bool
| UpdateRepetition Int
+ | SetMode Mode
deriving (Show, Eq)
data DrawContext = DrawContext
@@ -66,7 +91,7 @@ data OCRMatch = OCRMatch
matchEndY :: !CInt,
matchText :: !String
}
- deriving (Show)
+ deriving (Show, Eq)
instance Storable OCRMatch where
sizeOf _ = 4 * sizeOf (undefined :: CInt) + sizeOf (undefined :: Ptr CChar)
diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs
index fe06fd7..1a4f1f8 100644
--- a/src/Chelleport/View.hs
+++ b/src/Chelleport/View.hs
@@ -10,7 +10,19 @@ import qualified Data.Text as Text
import Foreign.C (CInt)
render :: (MonadDraw m) => State -> m ()
-render state = do
+render state = case stateMode state of
+ ModeHints -> renderHintsView state
+ ModeSearch {searchFilteredWords} -> renderSearchView state searchFilteredWords
+
+renderSearchView :: (MonadDraw m) => State -> [OCRMatch] -> m ()
+renderSearchView state matches = do
+ renderGridLines state
+ setDrawColor colorWhite
+ forM_ matches $ \(OCRMatch {matchStartX, matchStartY, matchEndX, matchEndY}) -> do
+ fillRectVertices (matchStartX, matchStartY) (matchEndX, matchEndY)
+
+renderHintsView :: (MonadDraw m) => State -> m ()
+renderHintsView state = do
renderGridLines state
(wcell, hcell) <- cellSize state