aboutsummaryrefslogtreecommitdiff
path: root/src/Chelleport
diff options
context:
space:
mode:
Diffstat (limited to 'src/Chelleport')
-rw-r--r--src/Chelleport/AppShell.hs75
-rw-r--r--src/Chelleport/Draw.hs32
-rw-r--r--src/Chelleport/KeySequence.hs104
3 files changed, 211 insertions, 0 deletions
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')
+ ]