Add key sequence filtering and rendering matched keys

7 files changed, 207 insertions, 36 deletions

diff --git a/chelleport.cabal b/chelleport.cabal
index 9ad357a..2f6d458 100644
--- a/chelleport.cabal
+++ b/chelleport.cabal
@@ -46,6 +46,7 @@ library lib-chelleport
     Chelleport
     Chelleport.AppShell
     Chelleport.Draw
+    Chelleport.KeySequence
 
 test-suite specs
   import: common-config
@@ -53,9 +54,7 @@ test-suite specs
   hs-source-dirs: specs
   main-is: Main.hs
   other-modules:
-    Specs.ParserSpec,
-    Specs.SerializerSpec,
-    Specs.TransformerSpec
+    Specs.KeySequenceSpec
   build-depends:
     lib-chelleport,
     neat-interpolation,
diff --git a/specs/Main.hs b/specs/Main.hs
index 436c6aa..335407f 100644
--- a/specs/Main.hs
+++ b/specs/Main.hs
@@ -1,8 +1,8 @@
 module Main (main) where
 
-import qualified Specs.ParserSpec
+import qualified Specs.KeySequenceSpec
 import Test.Hspec (hspec)
 
 main :: IO ()
 main = hspec $ do
-  Specs.ParserSpec.test
+  Specs.KeySequenceSpec.test
diff --git a/specs/Specs/KeySequenceSpec.hs b/specs/Specs/KeySequenceSpec.hs
new file mode 100644
index 0000000..8b820b4
--- /dev/null
+++ b/specs/Specs/KeySequenceSpec.hs
@@ -0,0 +1,22 @@
+module Specs.KeySequenceSpec where
+
+import Chelleport.KeySequence (nextChars)
+import Test.Hspec
+
+test = do
+  describe "#nextChars" $ do
+    it "filters key sequence and returns next characters" $ do
+      nextChars "AB" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+        `shouldBe` Just "CD"
+      nextChars "A" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+        `shouldBe` Just "BM"
+
+    context "when exact match is present" $ do
+      it "returns next characters" $ do
+        nextChars "ABD" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+          `shouldBe` Just ""
+
+    context "when there are no matches" $ do
+      it "returns nothing" $ do
+        nextChars "FOO" [["XYZ", "ABC"], ["AMK", "BBL", "ABD"]]
+          `shouldBe` Nothing
diff --git a/src/Chelleport.hs b/src/Chelleport.hs
index 9511ff5..f34bf27 100644
--- a/src/Chelleport.hs
+++ b/src/Chelleport.hs
@@ -1,42 +1,95 @@
 module Chelleport where
 
-import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext, setupAppShell)
-import Chelleport.Draw (renderText)
+import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext (ctxWindow), setupAppShell)
+import Chelleport.Draw (colorLightGray, colorWhite, renderText)
+import Chelleport.KeySequence (eventToKeycode, generateKeyCells, isValidKey, nextChars, toKeyChar)
+import Control.Monad (forM_, unless, void)
+import Data.IORef (modifyIORef', newIORef, readIORef)
+import Data.List (isPrefixOf)
+import Data.Text (splitOn)
 import qualified Data.Text as Text
 import qualified SDL
+import Unsafe.Coerce (unsafeCoerce)
 
-newtype State = State
-  { stateCount :: Int
+data State = State
+  { stateCells :: [[[Char]]],
+    stateKeySequence :: [Char]
   }
 
-newtype AppAction = ActionUpdateCount Int
+data AppAction = FilterSequence SDL.Keycode | SetupGrid
 
 open :: IO ()
 open = setupAppShell initialState update eventToAction render
 
-initialState :: State
-initialState = State {stateCount = 0}
+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
+  pure $ State {stateCells = cells, stateKeySequence = []}
+  where
+    rows = 16
+    columns = 16
+    hintKeys = "ABCDEFGIMNOPRSTUVWXYZ"
 
 render :: State -> DrawContext -> IO ()
 render state ctx = do
-  renderText ctx $ Text.pack $ "Hello" ++ show (stateCount state)
+  (SDL.V2 width height) <- SDL.get $ SDL.windowSize $ ctxWindow ctx
+  let rows = stateCells state
+  let wcell = width `div` unsafeCoerce (length $ head rows)
+  let hcell = height `div` unsafeCoerce (length rows)
+
+  forM_ (zip [0 ..] rows) $ \(rowIndex, row) -> do
+    forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do
+      let w = colIndex * wcell
+      let h = rowIndex * hcell
+      let keySequence = stateKeySequence state
+      let (matched, remaining) =
+            if keySequence `isPrefixOf` cell
+              then splitAt (length keySequence) cell
+              else ("", cell)
+
+      widthRef <- newIORef 0
+      unless (null matched) $ do
+        let pos = w
+        (textWidth, _h) <- renderText ctx (SDL.V2 pos h) colorLightGray $ Text.pack matched
+        modifyIORef' widthRef (const textWidth)
+      unless (null remaining) $ do
+        prevTextWidth <- readIORef widthRef
+        let pos = w + prevTextWidth
+        void $ renderText ctx (SDL.V2 pos h) colorWhite $ Text.pack remaining
 
 update :: State -> DrawContext -> AppAction -> IO State
-update state _ctx (ActionUpdateCount count) = do
-  -- SDL.warpMouse SDL.WarpGlobal $ SDL.P $ SDL.V2 (unsafeCoerce $ 10 * stateCount state) 100
-  pure state {stateCount = count}
+update state _ctx SetupGrid = pure state
+update state _ctx (FilterSequence key) =
+  case validChars >>= (\chars -> (,chars) <$> toKeyChar key) of
+    Just (keyChar, validChars')
+      | keyChar `elem` validChars' ->
+          pure state {stateKeySequence = stateKeySequence state ++ [keyChar]}
+    _ -> pure state
+  where
+    validChars = nextChars (stateKeySequence state) (stateCells state)
 
 eventToAction :: State -> SDL.Event -> Maybe (Action AppAction)
-eventToAction state event =
+eventToAction _state event =
   case SDL.eventPayload event of
+    -- SDL.WindowShownEvent _ -> Just $ AppAction SetupGrid
+    SDL.QuitEvent -> Just SysQuit
     SDL.KeyboardEvent ev
-      | isKeyPress ev SDL.KeycodeQ -> Just SysQuit
-      | isKeyPress ev SDL.KeycodeEscape -> Just SysQuit
-      | isKeyPress ev SDL.KeycodeJ -> Just $ AppAction $ ActionUpdateCount (stateCount state - 1)
-      | isKeyPress ev SDL.KeycodeK -> Just $ AppAction $ ActionUpdateCount (stateCount state + 1)
+      | isKeyPressWith ev SDL.KeycodeQ -> Just SysQuit
+      | isKeyPressWith ev SDL.KeycodeEscape -> Just SysQuit
+      | isKeyPress ev && isValidKey (eventToKeycode ev) ->
+          Just $ AppAction $ FilterSequence $ eventToKeycode ev
     _ -> Nothing
 
-isKeyPress :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
-isKeyPress keyboardEvent keyCode =
+isKeyPress :: SDL.KeyboardEventData -> Bool
+isKeyPress keyboardEvent =
   SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed
-    && SDL.keysymKeycode (SDL.keyboardEventKeysym keyboardEvent) == keyCode
+
+isKeyPressWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
+isKeyPressWith keyboardEvent keyCode =
+  isKeyPress keyboardEvent && SDL.keysymKeycode (SDL.keyboardEventKeysym keyboardEvent) == keyCode
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index 5f97877..74ca784 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -17,9 +17,18 @@ data DrawContext = DrawContext
 
 createContext :: IO DrawContext
 createContext = do
+  -- bounds <- fmap SDL.displayBoundsSize <$> SDL.getDisplays
+  -- let windowSize = case bounds of
+  --       (x : _) -> x
+  --       _ -> SDL.V2 800 600
+  let windowSize = SDL.V2 0 0
+
   let windowCfg =
-        SDL.defaultWindow -- SDL.windowMode = SDL.Fullscreen,
+        SDL.defaultWindow
           { SDL.windowInputGrabbed = True,
+            SDL.windowMode = SDL.FullscreenDesktop,
+            SDL.windowPosition = SDL.Absolute $ SDL.P $ SDL.V2 0 0,
+            SDL.windowInitialSize = windowSize,
             SDL.windowBorder = False
           }
   window <- SDL.createWindow "My SDL Application" windowCfg
@@ -33,7 +42,7 @@ createContext = do
   pure $ DrawContext {ctxWindow = window, ctxRenderer = renderer, ctxFont = font}
 
 setupAppShell ::
-  state ->
+  (DrawContext -> IO state) ->
   (state -> DrawContext -> appAction -> IO state) ->
   (state -> SDL.Event -> Maybe (Action appAction)) ->
   (state -> DrawContext -> IO ()) ->
@@ -44,7 +53,8 @@ setupAppShell initState update eventHandler draw = do
   TTF.initialize
 
   ctx <- createContext
-  appLoop ctx (initState, SysState {sysExit = False})
+  state <- initState ctx
+  appLoop ctx (state, SysState {sysExit = False})
 
   SDL.destroyRenderer $ ctxRenderer ctx
   SDL.destroyWindow $ ctxWindow ctx
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index c042e32..8401966 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -2,24 +2,31 @@ module Chelleport.Draw where
 
 import Chelleport.AppShell (DrawContext (ctxFont, ctxRenderer))
 import Data.Text (Text)
+import Data.Word (Word8)
+import Foreign.C (CInt)
 import qualified SDL
 import qualified SDL.Font as TTF
 
--- Render text to the screen
-renderText :: DrawContext -> Text -> IO ()
-renderText ctx text = do
-  -- Render text in white
-  surface <- TTF.blended (ctxFont ctx) (SDL.V4 255 255 255 255) text
+colorWhite :: SDL.V4 Word8
+colorWhite = SDL.V4 255 255 255 255
+
+colorLightGray :: SDL.V4 Word8
+colorLightGray = SDL.V4 100 100 100 255
+
+renderText :: DrawContext -> SDL.V2 CInt -> SDL.V4 Word8 -> Text -> IO (CInt, CInt)
+renderText ctx position color text = do
+  surface <- TTF.blended (ctxFont ctx) color text
   texture <- SDL.createTextureFromSurface (ctxRenderer ctx) surface
   SDL.freeSurface surface
 
   -- Get text dimensions
   textureInfo <- SDL.queryTexture texture
   let textWidth = SDL.textureWidth textureInfo
-      textHeight = SDL.textureHeight textureInfo
-      position =
-        SDL.P (SDL.V2 ((640 - textWidth) `div` 2) ((480 - textHeight) `div` 2))
+  let textHeight = SDL.textureHeight textureInfo
 
   -- Render the texture
-  SDL.copy (ctxRenderer ctx) texture Nothing $ Just (SDL.Rectangle position (SDL.V2 textWidth textHeight))
+  SDL.copy (ctxRenderer ctx) texture Nothing $
+    Just (SDL.Rectangle (SDL.P position) (SDL.V2 textWidth textHeight))
   SDL.destroyTexture texture
+
+  pure (textWidth, textHeight)
diff --git a/src/Chelleport/KeySequence.hs b/src/Chelleport/KeySequence.hs
new file mode 100644
index 0000000..1d118cd
--- /dev/null
+++ b/src/Chelleport/KeySequence.hs
@@ -0,0 +1,80 @@
+module Chelleport.KeySequence where
+
+import Data.List (isPrefixOf, nub)
+import qualified Data.Map as Map
+import qualified SDL
+
+safeHead :: a -> [a] -> a
+safeHead def [] = def
+safeHead _ (x : _) = x
+
+nextChars :: [Char] -> [[[Char]]] -> Maybe [Char]
+nextChars keys cells =
+  case matches of
+    [] -> Nothing
+    _ -> Just $ nub result
+  where
+    matches = concatMap (filter (isPrefixOf keys)) cells
+    result = concatMap (take 1 . drop (length keys)) matches
+
+isValidKey :: SDL.Keycode -> Bool
+isValidKey key = Map.member key keycodeMapping
+
+generateKeyCells :: (Int, Int) -> [Char] -> [[[Char]]]
+generateKeyCells (rows, columns) hintKeys =
+  (\row -> getCellSeq row <$> [1 .. columns]) <$> [1 .. rows]
+  where
+    getCellSeq x y = [getPrefix1 x y, getPrefix2 x y, getKey x y]
+    getKey _row col = hintKeys !! (col `mod` (columns `div` 2))
+    getPrefix1 _row col
+      | col <= (columns `div` 2) = 'H'
+      | otherwise = 'L'
+    getPrefix2 row _col
+      | row <= (rows `div` 2) = 'K'
+      | otherwise = 'J'
+
+toKeyChar :: SDL.Keycode -> Maybe Char
+toKeyChar key = Map.lookup key keycodeMapping
+
+eventToKeycode :: SDL.KeyboardEventData -> SDL.Keycode
+eventToKeycode = SDL.keysymKeycode . SDL.keyboardEventKeysym
+
+keycodeMapping :: Map.Map SDL.Keycode Char
+keycodeMapping =
+  Map.fromList
+    [ (SDL.KeycodeA, 'A'),
+      (SDL.KeycodeB, 'B'),
+      (SDL.KeycodeC, 'C'),
+      (SDL.KeycodeD, 'D'),
+      (SDL.KeycodeE, 'E'),
+      (SDL.KeycodeF, 'F'),
+      (SDL.KeycodeG, 'G'),
+      (SDL.KeycodeH, 'H'),
+      (SDL.KeycodeI, 'I'),
+      (SDL.KeycodeJ, 'J'),
+      (SDL.KeycodeK, 'K'),
+      (SDL.KeycodeL, 'L'),
+      (SDL.KeycodeM, 'M'),
+      (SDL.KeycodeN, 'N'),
+      (SDL.KeycodeO, 'O'),
+      (SDL.KeycodeP, 'P'),
+      (SDL.KeycodeR, 'R'),
+      (SDL.KeycodeS, 'S'),
+      (SDL.KeycodeT, 'T'),
+      (SDL.KeycodeU, 'U'),
+      (SDL.KeycodeV, 'V'),
+      (SDL.KeycodeW, 'W'),
+      (SDL.KeycodeX, 'X'),
+      (SDL.KeycodeY, 'Y'),
+      (SDL.KeycodeZ, 'Z'),
+      (SDL.Keycode0, '0'),
+      (SDL.Keycode1, '1'),
+      (SDL.Keycode2, '2'),
+      (SDL.Keycode3, '3'),
+      (SDL.Keycode4, '4'),
+      (SDL.Keycode5, '5'),
+      (SDL.Keycode6, '6'),
+      (SDL.Keycode7, '7'),
+      (SDL.Keycode8, '8'),
+      (SDL.Keycode9, '9')
+    ]