aboutsummaryrefslogtreecommitdiff
path: root/src/Chelleport
diff options
context:
space:
mode:
Diffstat (limited to 'src/Chelleport')
-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
6 files changed, 71 insertions, 34 deletions
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