diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Chelleport.hs | 102 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 75 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 32 | ||||
| -rw-r--r-- | src/Chelleport/KeySequence.hs | 104 |
4 files changed, 313 insertions, 0 deletions
diff --git a/src/Chelleport.hs b/src/Chelleport.hs new file mode 100644 index 0000000..d493db3 --- /dev/null +++ b/src/Chelleport.hs @@ -0,0 +1,102 @@ +module Chelleport where + +import Chelleport.AppShell (Action (AppAction, SysQuit), DrawContext (ctxWindow), setupAppShell) +import Chelleport.Draw (colorLightGray, colorWhite, renderText) +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) +import qualified SDL +import Unsafe.Coerce (unsafeCoerce) + +data State = State + { stateCells :: [[[Char]]], + stateKeySequence :: [Char] + } + +data AppAction = FilterSequence SDL.Keycode | SetupGrid + +open :: IO () +open = setupAppShell initialState update eventToAction render + +initialState :: DrawContext -> IO State +initialState _ctx = do + let cells = generateKeyCells (rows, columns) hintKeys + pure $ State {stateCells = cells, stateKeySequence = []} + where + rows = 16 + columns = 16 + hintKeys = "ABCDEFGHIJKLMNOPRSTUVWXYZ1234567890" + +renderKeySequence :: DrawContext -> [Char] -> [Char] -> (CInt, CInt) -> (CInt, CInt) -> IO () +renderKeySequence ctx keySequence cell (px, py) (wcell, hcell) = do + let w = px * wcell + let h = py * hcell + 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 + +render :: State -> DrawContext -> IO () +render state ctx = do + (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 + renderKeySequence ctx (stateKeySequence state) cell (colIndex, rowIndex) (wcell, hcell) + +update :: State -> DrawContext -> AppAction -> IO State +update state _ctx SetupGrid = pure state +update state ctx (FilterSequence key) = + case validChars >>= (\chars -> (,chars) <$> toKeyChar key) of + Just (keyChar, validChars') + | 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) + +eventToAction :: State -> SDL.Event -> Maybe (Action AppAction) +eventToAction _state event = + case SDL.eventPayload event of + -- SDL.WindowShownEvent _ -> Just $ AppAction SetupGrid + SDL.QuitEvent -> Just SysQuit + SDL.KeyboardEvent ev + | 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 -> Bool +isKeyPress keyboardEvent = + SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed + +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 new file mode 100644 index 0000000..74ca784 --- /dev/null +++ b/src/Chelleport/AppShell.hs @@ -0,0 +1,75 @@ +module Chelleport.AppShell where + +import Control.Monad (foldM, unless) +import SDL (($=)) +import qualified SDL +import qualified SDL.Font as TTF + +data Action act = SysQuit | AppAction act + +newtype SysState = SysState {sysExit :: Bool} + +data DrawContext = DrawContext + { ctxWindow :: SDL.Window, + ctxRenderer :: SDL.Renderer, + ctxFont :: TTF.Font + } + +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.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 + renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer + font <- TTF.load "Inter-Regular.ttf" 16 + + SDL.windowOpacity window $= 0.6 + SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend + SDL.rendererDrawColor renderer $= SDL.V4 0 0 0 0 + + pure $ DrawContext {ctxWindow = window, ctxRenderer = renderer, ctxFont = font} + +setupAppShell :: + (DrawContext -> IO state) -> + (state -> DrawContext -> appAction -> IO state) -> + (state -> SDL.Event -> Maybe (Action appAction)) -> + (state -> DrawContext -> IO ()) -> + IO () +setupAppShell initState update eventHandler draw = do + -- Initialize SDL + SDL.initializeAll + TTF.initialize + + ctx <- createContext + state <- initState ctx + appLoop ctx (state, SysState {sysExit = False}) + + SDL.destroyRenderer $ ctxRenderer ctx + SDL.destroyWindow $ ctxWindow ctx + where + appLoop drawCtx (state, sysState) = do + events <- SDL.pollEvents + + SDL.clear $ ctxRenderer drawCtx + draw state drawCtx + SDL.present $ ctxRenderer drawCtx + + (newState, newSysState) <- foldM (evaluateEvent drawCtx) (state, sysState) events + unless (sysExit newSysState) $ appLoop drawCtx (newState, newSysState) + + evaluateEvent drawCtx stTup event = maybe (pure stTup) (updateState drawCtx stTup) (eventHandler (fst stTup) event) + + updateState _drawCtx (state, sysState) SysQuit = pure (state, sysState {sysExit = True}) + updateState drawCtx (state, sysState) (AppAction action) = (,sysState) <$> update state drawCtx action diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs new file mode 100644 index 0000000..8401966 --- /dev/null +++ b/src/Chelleport/Draw.hs @@ -0,0 +1,32 @@ +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 + +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 + let textHeight = SDL.textureHeight textureInfo + + -- Render the texture + 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..1046a98 --- /dev/null +++ b/src/Chelleport/KeySequence.hs @@ -0,0 +1,104 @@ +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 + +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 + +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 + +generateKeyCells :: (Int, Int) -> [Char] -> [[[Char]]] +generateKeyCells (rows, columns) hintKeys = + (\row -> getCellSeq row <$> [1 .. columns]) <$> [1 .. rows] + where + getCellSeq row col = [getPrefixHoriz row col, getPrefixVert row col, getKey row col] + getKey row col = hintKeys !! index + where + index = (secRow * (columns `div` 2) + secCol) `mod` length hintKeys + secCol = (col - 1) `mod` (columns `div` 2) + secRow = (row - 1) `mod` (rows `div` 2) + getPrefixHoriz _row col + | col <= (columns `div` 2) = 'H' + | otherwise = 'L' + getPrefixVert 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') + ] |