diff options
Diffstat (limited to '')
| -rw-r--r-- | specs/Specs/KeySequenceSpec.hs | 17 | ||||
| -rw-r--r-- | src/Chelleport.hs | 26 | ||||
| -rw-r--r-- | src/Chelleport/KeySequence.hs | 20 |
3 files changed, 52 insertions, 11 deletions
diff --git a/specs/Specs/KeySequenceSpec.hs b/specs/Specs/KeySequenceSpec.hs index 570f1f9..d094741 100644 --- a/specs/Specs/KeySequenceSpec.hs +++ b/specs/Specs/KeySequenceSpec.hs @@ -1,6 +1,6 @@ module Specs.KeySequenceSpec where -import Chelleport.KeySequence (generateKeyCells, nextChars) +import Chelleport.KeySequence (findMatchPosition, generateKeyCells, nextChars) import Test.Hspec test = do @@ -37,3 +37,18 @@ test = do ["HJA", "HJB", "LJA", "LJB"], ["HJA", "HJB", "LJA", "LJB"] ] + + describe "#findMatchPosition" $ do + it "returns the position of the matching key sequence" $ do + findMatchPosition "ABD" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]] + `shouldBe` Just (1, 2) + + context "when sequence is incomplete" $ do + it "returns nothing" $ do + findMatchPosition "AB" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]] + `shouldBe` Nothing + + context "when there are no matches" $ do + it "returns nothing" $ do + findMatchPosition "FOO" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]] + `shouldBe` Nothing diff --git a/src/Chelleport.hs b/src/Chelleport.hs index 74c61e7..4f6aa7b 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -2,11 +2,12 @@ module Chelleport where import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext (ctxWindow), setupAppShell) import Chelleport.Draw (colorLightGray, colorWhite, renderText) -import Chelleport.KeySequence (eventToKeycode, generateKeyCells, isValidKey, nextChars, toKeyChar) +import Chelleport.KeySequence (eventToKeycode, findMatchPosition, generateKeyCells, isValidKey, nextChars, toKeyChar) import Control.Monad (forM_, unless, void) import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (isPrefixOf) import qualified Data.Text as Text +import Foreign.C (CInt (CInt)) import qualified SDL import Unsafe.Coerce (unsafeCoerce) @@ -20,12 +21,6 @@ data AppAction = FilterSequence SDL.Keycode | SetupGrid open :: IO () open = setupAppShell initialState update eventToAction render -padded :: Int -> a -> [a] -> [a] -padded 0 _ ls = ls -padded n x ls - | length ls > n = ls - | otherwise = padded (n - 1) x (ls ++ [x]) - initialState :: DrawContext -> IO State initialState _ctx = do let cells = generateKeyCells (rows, columns) hintKeys @@ -64,11 +59,22 @@ render state ctx = do update :: State -> DrawContext -> AppAction -> IO State update state _ctx SetupGrid = pure state -update state _ctx (FilterSequence key) = +update state ctx (FilterSequence key) = case validChars >>= (\chars -> (,chars) <$> toKeyChar key) of Just (keyChar, validChars') - | keyChar `elem` validChars' -> - pure state {stateKeySequence = stateKeySequence state ++ [keyChar]} + | keyChar `elem` validChars' -> do + (SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx :: IO (SDL.V2 CInt) + let newKeySequence = stateKeySequence state ++ [keyChar] + let rows = stateCells state + let wcell = width `div` unsafeCoerce (length $ head rows) + let hcell = height `div` unsafeCoerce (length rows) + case findMatchPosition newKeySequence rows of + Just (row, col) -> do + let x = wcell * unsafeCoerce col + let y = hcell * unsafeCoerce row + SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y) + Nothing -> pure () + pure state {stateKeySequence = newKeySequence} _ -> pure state where validChars = nextChars (stateKeySequence state) (stateCells state) diff --git a/src/Chelleport/KeySequence.hs b/src/Chelleport/KeySequence.hs index 88658f1..1046a98 100644 --- a/src/Chelleport/KeySequence.hs +++ b/src/Chelleport/KeySequence.hs @@ -2,8 +2,15 @@ module Chelleport.KeySequence where import Data.List (isPrefixOf, nub) import qualified Data.Map as Map +import Data.Maybe (isJust) import qualified SDL +-- padded :: Int -> a -> [a] -> [a] +-- padded 0 _ ls = ls +-- padded n x ls +-- | length ls > n = ls +-- | otherwise = padded (n - 1) x (ls ++ [x]) + safeHead :: a -> [a] -> a safeHead def [] = def safeHead _ (x : _) = x @@ -17,6 +24,19 @@ nextChars keys cells = matches = concatMap (filter (isPrefixOf keys)) cells result = concatMap (take 1 . drop (length keys)) matches +findMatchPosition :: [Char] -> [[[Char]]] -> Maybe (Int, Int) +findMatchPosition keys = findWithIndex findMatch 0 + where + findMatch row = + fst <$> findWithIndex (\c -> if c == keys then Just () else Nothing) 0 row + + findWithIndex :: (x -> Maybe r) -> Int -> [x] -> Maybe (Int, r) + findWithIndex _pred _index [] = Nothing + findWithIndex predicate index (x : ls) = + case predicate x of + Just item -> Just (index, item) + Nothing -> findWithIndex predicate (index + 1) ls + isValidKey :: SDL.Keycode -> Bool isValidKey key = Map.member key keycodeMapping |