diff options
Diffstat (limited to '')
| -rw-r--r-- | src/Chelleport.hs | 120 | ||||
| -rw-r--r-- | src/Chelleport/AppShell.hs | 88 | ||||
| -rw-r--r-- | src/Chelleport/Context.hs | 4 | ||||
| -rw-r--r-- | src/Chelleport/Control.hs | 46 | ||||
| -rw-r--r-- | src/Chelleport/Draw.hs | 116 | ||||
| -rw-r--r-- | src/Chelleport/Types.hs | 17 | ||||
| -rw-r--r-- | src/Chelleport/View.hs | 103 |
7 files changed, 271 insertions, 223 deletions
diff --git a/src/Chelleport.hs b/src/Chelleport.hs index 2bdc6c4..2a95a9a 100644 --- a/src/Chelleport.hs +++ b/src/Chelleport.hs @@ -1,22 +1,40 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Chelleport where -import Chelleport.AppShell (Action (AppAction, SysQuit), EventHandler, Update, hideWindow, setupAppShell) -import Chelleport.Control (currentMousePosition, eventToKeycode, isKeyPress, isKeyPressWith, isKeyReleaseWith, moveMouse, triggerMouseLeftClick) -import Chelleport.Draw (cellSize) +import Chelleport.AppShell (MonadAppShell (hideWindow, shutdownApp), setupAppShell) +import Chelleport.Context (initializeContext) +import Chelleport.Control (MonadControl (getMousePointerPosition, moveMousePointer, pressMouseButton), directionalIncrement, eventToKeycode, isKeyPress, isKeyPressWith, isKeyReleaseWith) +import Chelleport.Draw (MonadDraw, cellSize) import Chelleport.KeySequence (findMatchPosition, generateGrid, isValidKey, nextChars, toKeyChar) import Chelleport.Types -import Chelleport.Utils (cIntToInt, intToCInt) +import Chelleport.Utils (intToCInt) import qualified Chelleport.View +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader, ReaderT (runReaderT)) import Data.List ((\\)) import Data.Maybe (fromMaybe, isJust) -import Foreign.C (CInt) import qualified SDL -open :: IO () -open = setupAppShell initialState update eventToAction Chelleport.View.render +runEff :: + (MonadIO m) => + DrawContext -> + AppM m x -> + m x +runEff ctx action = runReaderT (runAppM action) ctx + +run :: IO () +run = do + ctx <- initializeContext + setupAppShell + ctx + (runEff ctx initialState) + (\state -> runEff ctx . update state) + eventToAction + (runEff ctx . Chelleport.View.render) -initialState :: DrawContext -> IO State -initialState _ctx = do +initialState :: (MonadIO m) => m State +initialState = do let cells = fromMaybe (pure undefined) $ generateGrid 0 (rows, columns) hintKeys pure $ State @@ -30,81 +48,83 @@ initialState _ctx = do columns = 16 hintKeys = ['A' .. 'Z'] \\ "Q" -directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int) -directionalIncrement (incx, incy) = \case - 'H' -> (-cIntToInt incx, 0) - 'L' -> (cIntToInt incx, 0) - 'K' -> (0, -cIntToInt incy) - 'J' -> (0, cIntToInt incy) - _ -> undefined +eventToAction :: EventHandler State AppAction +eventToAction _state event = + case SDL.eventPayload event of + SDL.QuitEvent -> Just ShutdownApp + SDL.KeyboardEvent ev + | isKeyPressWith ev SDL.KeycodeQ -> Just ShutdownApp + | isKeyPressWith ev SDL.KeycodeEscape -> Just ShutdownApp + | isKeyPressWith ev SDL.KeycodeSpace -> Just TriggerLeftClick + | isKeyPressWith ev SDL.KeycodeTab -> Just ResetKeys + | isKeyPress ev && isValidKey (eventToKeycode ev) -> + Just $ HandleKeyInput $ eventToKeycode ev + | isKeyPressWith ev SDL.KeycodeLShift || isKeyPressWith ev SDL.KeycodeRShift -> + Just $ UpdateShiftState True + | isKeyReleaseWith ev SDL.KeycodeLShift || isKeyReleaseWith ev SDL.KeycodeRShift -> + Just $ UpdateShiftState False + _ -> Nothing -update :: Update State AppAction +update :: + (MonadIO m, MonadAppShell m, MonadDraw m, MonadControl m, MonadReader DrawContext m) => + State -> + AppAction -> + m (State, Maybe AppAction) -- Act on key inputs -update state ctx (FilterSequence key) = +update state (HandleKeyInput key) = do case liftA2 (,) (toKeyChar key) validChars of Just (keyChar, validChars') | stateIsMatched state && keyChar `elem` ("HJKL" :: String) -> do incr <- incrementValue let action = IncrementMouseCursor $ directionalIncrement incr keyChar - pure (state, Just . AppAction $ action) + pure (state, Just action) | keyChar `elem` validChars' -> do let newKeySequence = stateKeySequence state ++ [keyChar] let matchPosition = findMatchPosition newKeySequence $ stateGrid state let state' = state {stateKeySequence = newKeySequence, stateIsMatched = isJust matchPosition} - pure (state', AppAction . MoveMousePosition <$> matchPosition) + pure (state', MoveMousePosition <$> matchPosition) _ -> pure (state, Nothing) where validChars = nextChars (stateKeySequence state) (stateGrid state) incrementValue = do - (wcell, hcell) <- cellSize state ctx + (wcell, hcell) <- cellSize state if stateIsShiftPressed state then pure (wcell `div` 4, hcell `div` 4) else pure (wcell `div` 16, hcell `div` 16) -- Move mouse incrementally -update state ctx (IncrementMouseCursor (incx, incy)) = do - (SDL.V2 curx cury) <- currentMousePosition ctx - moveMouse ctx (curx + intToCInt incx) (cury + intToCInt incy) +update state (IncrementMouseCursor (incX, incY)) = do + (curX, curY) <- getMousePointerPosition + moveMousePointer (curX + intToCInt incX) (curY + intToCInt incY) pure (state, Nothing) -- Move mouse to given position -update state ctx (MoveMousePosition (row, col)) = do +update state (MoveMousePosition (row, col)) = do (x, y) <- getPosition - moveMouse ctx x y + moveMousePointer x y pure (state, Nothing) where getPosition = do - (wcell, hcell) <- cellSize state ctx + (wcell, hcell) <- cellSize state let x = (wcell `div` 2) + wcell * intToCInt col let y = (hcell `div` 2) + hcell * intToCInt row pure (x, y) -- Reset entered key sequence and state -update state _ctx ResetKeys = do +update state ResetKeys = do pure (state {stateKeySequence = [], stateIsMatched = False}, Nothing) -- Trigger left click -update state ctx TriggerLeftClick = do - hideWindow ctx - triggerMouseLeftClick ctx - pure (state, Just SysQuit) +update state TriggerLeftClick = do + hideWindow + pressMouseButton LeftClick + pure (state, Just ShutdownApp) --- Set/unset whether shift is pressed -update state _ctx (UpdateShiftState shift) = pure (state {stateIsShiftPressed = shift}, Nothing) +-- Cleanup everything and exit +update state ShutdownApp = do + shutdownApp + pure (state, Nothing) -eventToAction :: EventHandler State AppAction -eventToAction _state event = - case SDL.eventPayload event of - SDL.QuitEvent -> Just SysQuit - SDL.KeyboardEvent ev - | isKeyPressWith ev SDL.KeycodeQ -> Just SysQuit - | isKeyPressWith ev SDL.KeycodeEscape -> Just SysQuit - | isKeyPressWith ev SDL.KeycodeSpace -> Just $ AppAction TriggerLeftClick - | isKeyPressWith ev SDL.KeycodeTab -> Just $ AppAction ResetKeys - | isKeyPress ev && isValidKey (eventToKeycode ev) -> - Just . AppAction $ FilterSequence $ eventToKeycode ev - | isKeyPressWith ev SDL.KeycodeLShift || isKeyPressWith ev SDL.KeycodeRShift -> - Just . AppAction $ UpdateShiftState True - | isKeyReleaseWith ev SDL.KeycodeLShift || isKeyReleaseWith ev SDL.KeycodeRShift -> - Just . AppAction $ UpdateShiftState False - _ -> Nothing +-- Set/unset whether shift is pressed +update state (UpdateShiftState shift) = + pure (state {stateIsShiftPressed = shift}, Nothing) diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs index 897af83..e8cd3ab 100644 --- a/src/Chelleport/AppShell.hs +++ b/src/Chelleport/AppShell.hs @@ -1,78 +1,58 @@ module Chelleport.AppShell where -import Chelleport.Context (initializeContext) import Chelleport.Draw (colorBackground) import Chelleport.Types -import Control.Monad (foldM, unless) +import Control.Monad (foldM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.RWS (MonadReader (ask)) import qualified Graphics.X11 as X11 import SDL (($=)) import qualified SDL -import qualified SDL.Font as TTF import System.Exit (exitSuccess) -data Action act = SysQuit | AppAction act +class (Monad m) => MonadAppShell m where + hideWindow :: m () + showWindow :: m () + shutdownApp :: m () -newtype SysState = SysState {sysExit :: Bool} - -type Update state appAction = state -> DrawContext -> appAction -> IO (state, Maybe (Action appAction)) - -type EventHandler state appAction = state -> SDL.Event -> Maybe (Action appAction) - -type View state = state -> DrawContext -> IO () - -type Initializer state = DrawContext -> IO state +instance (MonadIO m) => MonadAppShell (AppM m) where + hideWindow = ask >>= SDL.hideWindow . ctxWindow + showWindow = ask >>= SDL.showWindow . ctxWindow + shutdownApp = do + ctx <- ask + SDL.destroyRenderer $ ctxRenderer ctx + SDL.destroyWindow $ ctxWindow ctx + liftIO $ do + X11.closeDisplay $ ctxX11Display ctx + exitSuccess setupAppShell :: - -- forall state appAction. + DrawContext -> Initializer state -> Update state appAction -> EventHandler state appAction -> View state -> IO () -setupAppShell initState update eventHandler draw = do - -- Initialize SDL - SDL.initializeAll - TTF.initialize - ctx <- initializeContext - state <- initState ctx - - appLoop ctx (state, SysState {sysExit = False}) - - shutdownApp ctx +setupAppShell ctx initState update eventHandler draw = do + state <- initState + appLoop state where - appLoop drawCtx (state, sysState) = do - SDL.rendererDrawColor (ctxRenderer drawCtx) $= colorBackground - SDL.clear $ ctxRenderer drawCtx - draw state drawCtx - SDL.present $ ctxRenderer drawCtx + appLoop state = do + SDL.rendererDrawColor (ctxRenderer ctx) $= colorBackground + SDL.clear $ ctxRenderer ctx + draw state + SDL.present $ ctxRenderer ctx events <- SDL.pollEvents + newState <- foldM evaluateEvent state events - (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) - - evalUpdateResult _drawCtx sysState (state, Nothing) = pure (state, sysState) - evalUpdateResult drawCtx sysState (state, Just action) = updateState drawCtx (state, sysState) action - - updateState _ (state, sysState) SysQuit = pure (state, sysState {sysExit = True}) - updateState drawCtx (state, sysState) (AppAction action) = - update state drawCtx action >>= evalUpdateResult drawCtx sysState + appLoop newState -hideWindow :: DrawContext -> IO () -hideWindow ctx = SDL.hideWindow (ctxWindow ctx) + evaluateEvent state event = + maybe (pure state) (updateState state) (eventHandler state event) -closeWindow :: DrawContext -> IO () -closeWindow ctx = do - SDL.destroyRenderer $ ctxRenderer ctx - SDL.destroyWindow $ ctxWindow ctx + updateState state action = + update state action >>= evalUpdateResult -shutdownApp :: DrawContext -> IO () -shutdownApp ctx = do - closeWindow ctx - X11.closeDisplay $ ctxX11Display ctx - exitSuccess + evalUpdateResult (state, Nothing) = pure state + evalUpdateResult (state, Just action) = updateState state action diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs index 17fdae0..15c0b6a 100644 --- a/src/Chelleport/Context.hs +++ b/src/Chelleport/Context.hs @@ -17,6 +17,10 @@ fontSize = 24 initializeContext :: IO DrawContext initializeContext = do + -- Initialize SDL + SDL.initializeAll + TTF.initialize + window <- initializeWindow renderer <- initializeRenderer window font <- loadFont diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs index 0fd01cc..46c7903 100644 --- a/src/Chelleport/Control.hs +++ b/src/Chelleport/Control.hs @@ -1,27 +1,39 @@ module Chelleport.Control where import Chelleport.Types +import Chelleport.Utils (cIntToInt) import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (MonadReader (ask)) import Foreign.C (CInt) import qualified Graphics.X11 as X11 import qualified Graphics.X11.XTest as X11 import qualified SDL -triggerMouseLeftClick :: DrawContext -> IO () -triggerMouseLeftClick (DrawContext {ctxX11Display = display}) = do - threadDelay 30_000 -- Wrap with delay to prevent async window close issues. TODO: Remove maybe? - X11.fakeButtonPress display X11.button1 - X11.sync display False - threadDelay 30_000 +class (Monad m) => MonadControl m where + pressMouseButton :: MouseButtonType -> m () + moveMousePointer :: CInt -> CInt -> m () + getMousePointerPosition :: m (CInt, CInt) -moveMouse :: DrawContext -> CInt -> CInt -> IO () -moveMouse _ x y = do - SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y) +instance (MonadIO m) => MonadControl (AppM m) where + pressMouseButton btn = do + (DrawContext {ctxX11Display = display}) <- ask + liftIO $ do + -- Wrap with delay to prevent async window close issues. TODO: Remove maybe? + threadDelay 30_000 + X11.fakeButtonPress display x11Button + X11.sync display False + threadDelay 30_000 + where + x11Button = case btn of + LeftClick -> X11.button1 -currentMousePosition :: DrawContext -> IO (SDL.V2 CInt) -currentMousePosition _ctx = do - (SDL.P p) <- SDL.getAbsoluteMouseLocation - pure p + moveMousePointer x y = do + SDL.warpMouse SDL.WarpGlobal (SDL.P $ SDL.V2 x y) + + getMousePointerPosition = do + (SDL.P (SDL.V2 x y)) <- SDL.getAbsoluteMouseLocation + pure (x, y) isKeyPress :: SDL.KeyboardEventData -> Bool isKeyPress = (== SDL.Pressed) . SDL.keyboardEventKeyMotion @@ -39,3 +51,11 @@ isKeyPressWith keyboardEvent keyCode = isKeyReleaseWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool isKeyReleaseWith keyboardEvent keyCode = isKeyRelease keyboardEvent && eventToKeycode keyboardEvent == keyCode + +directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int) +directionalIncrement (incX, incY) = \case + 'H' -> (-cIntToInt incX, 0) + 'L' -> (cIntToInt incX, 0) + 'K' -> (0, -cIntToInt incY) + 'J' -> (0, cIntToInt incY) + _ -> undefined diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs index 9b30b48..2fdb311 100644 --- a/src/Chelleport/Draw.hs +++ b/src/Chelleport/Draw.hs @@ -2,13 +2,79 @@ module Chelleport.Draw where import Chelleport.Types import Chelleport.Utils (intToCInt) +import Control.Monad.Reader (MonadIO, MonadReader (ask)) import Data.Text (Text) import qualified Data.Vector.Storable as Vector import Data.Word (Word8) import Foreign.C (CInt) +import SDL (($=)) import qualified SDL import qualified SDL.Font as TTF +class (Monad m) => MonadDraw m where + drawLine :: (CInt, CInt) -> (CInt, CInt) -> m () + drawText :: (CInt, CInt) -> SDL.V4 Word8 -> Text -> m (CInt, CInt) + drawCircle :: Int -> (CInt, CInt) -> m () + setDrawColor :: SDL.V4 Word8 -> m () + windowSize :: m (SDL.V2 CInt) + +instance (MonadIO m) => MonadDraw (AppM m) where + drawLine (x1, y1) (x2, y2) = do + DrawContext {ctxRenderer = renderer} <- ask + SDL.drawLine renderer (SDL.P $ SDL.V2 x1 y1) (SDL.P $ SDL.V2 x2 y2) + + setDrawColor color = do + DrawContext {ctxRenderer = renderer} <- ask + SDL.rendererDrawColor renderer $= color + + drawText (x, y) color text = do + DrawContext {ctxRenderer = renderer, ctxFont = font} <- ask + surface <- TTF.blended font color text + texture <- SDL.createTextureFromSurface renderer 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 renderer texture Nothing $ + Just (SDL.Rectangle (SDL.P $ SDL.V2 x y) (SDL.V2 textWidth textHeight)) + SDL.destroyTexture texture + + pure (textWidth, textHeight) + + drawCircle radius (x, y) = do + DrawContext {ctxRenderer = renderer} <- ask + let renderedPoints = radius * 7 + let toTheta n = fromIntegral n * (2 * pi) / fromIntegral renderedPoints + let toPointOnCircle n = + SDL.V2 + (x + round ((fromIntegral radius :: Float) * cos (toTheta n))) + (y + round ((fromIntegral radius :: Float) * sin (toTheta n))) + let points = Vector.generate renderedPoints (SDL.P . toPointOnCircle) + SDL.drawPoints renderer points + + windowSize = ask >>= SDL.get . SDL.windowSize . ctxWindow + +cellSize :: (MonadDraw m) => State -> m (CInt, CInt) +cellSize (State {stateGrid}) = do + (SDL.V2 width height) <- windowSize + let wcell = width `div` intToCInt (length $ head stateGrid) + let hcell = height `div` intToCInt (length stateGrid) + pure (wcell, hcell) + +drawHorizontalLine :: (MonadDraw m) => CInt -> m () +drawHorizontalLine y = do + (SDL.V2 width _) <- windowSize + drawLine (0, y) (width, y) + +drawVerticalLine :: (MonadDraw m) => CInt -> m () +drawVerticalLine x = do + (SDL.V2 _width height) <- windowSize + drawLine (x, 0) (x, height) + colorWhite :: SDL.V4 Word8 colorWhite = SDL.V4 255 255 255 255 @@ -38,53 +104,3 @@ colorBackground = SDL.V4 15 12 25 0 colorFineGrainGrid :: SDL.V4 Word8 colorFineGrainGrid = SDL.V4 55 52 65 100 - -drawText :: DrawContext -> SDL.V2 CInt -> SDL.V4 Word8 -> Text -> IO (CInt, CInt) -drawText ctx@(DrawContext {ctxRenderer = renderer}) position color text = do - surface <- TTF.blended (ctxFont ctx) color text - texture <- SDL.createTextureFromSurface renderer 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 renderer texture Nothing $ - Just (SDL.Rectangle (SDL.P position) (SDL.V2 textWidth textHeight)) - SDL.destroyTexture texture - - pure (textWidth, textHeight) - -windowSize :: DrawContext -> IO (SDL.V2 CInt) -windowSize = SDL.get . SDL.windowSize . ctxWindow - -cellSize :: State -> DrawContext -> IO (CInt, CInt) -cellSize state ctx = do - (SDL.V2 width height) <- windowSize ctx - let rows = stateGrid state - let wcell = width `div` intToCInt (length $ head rows) - let hcell = height `div` intToCInt (length rows) - pure (wcell, hcell) - -drawHorizontalLine :: DrawContext -> CInt -> IO () -drawHorizontalLine ctx@(DrawContext {ctxRenderer = renderer}) x = do - (SDL.V2 width _height) <- windowSize ctx - SDL.drawLine renderer (SDL.P $ SDL.V2 0 x) (SDL.P $ SDL.V2 width x) - -drawVerticalLine :: DrawContext -> CInt -> IO () -drawVerticalLine ctx@(DrawContext {ctxRenderer = renderer}) x = do - (SDL.V2 _width height) <- windowSize ctx - SDL.drawLine renderer (SDL.P $ SDL.V2 x 0) (SDL.P $ SDL.V2 x height) - -drawCircle :: DrawContext -> Int -> (CInt, CInt) -> IO () -drawCircle (DrawContext {ctxRenderer = renderer}) radius (x, y) = do - let renderedPoints = radius * 7 - let toTheta n = fromIntegral n * (2 * pi) / fromIntegral renderedPoints - let toPointOnCircle n = - SDL.V2 - (x + round ((fromIntegral radius :: Float) * cos (toTheta n))) - (y + round ((fromIntegral radius :: Float) * sin (toTheta n))) - let points = Vector.generate renderedPoints (SDL.P . toPointOnCircle) - SDL.drawPoints renderer points diff --git a/src/Chelleport/Types.hs b/src/Chelleport/Types.hs index 15d16f4..c1cf386 100644 --- a/src/Chelleport/Types.hs +++ b/src/Chelleport/Types.hs @@ -1,5 +1,6 @@ module Chelleport.Types where +import Control.Monad.Reader (MonadIO, MonadReader, ReaderT) import qualified Graphics.X11 as X11 import qualified SDL import qualified SDL.Font as TTF @@ -18,11 +19,12 @@ data State = State } data AppAction - = FilterSequence SDL.Keycode + = HandleKeyInput SDL.Keycode | MoveMousePosition (Int, Int) | ResetKeys | TriggerLeftClick | IncrementMouseCursor (Int, Int) + | ShutdownApp | UpdateShiftState Bool data DrawContext = DrawContext @@ -31,3 +33,16 @@ data DrawContext = DrawContext ctxFont :: TTF.Font, ctxX11Display :: X11.Display } + +type Update state appAction = state -> appAction -> IO (state, Maybe appAction) + +type EventHandler state appAction = state -> SDL.Event -> Maybe appAction + +type View state = state -> IO () + +type Initializer state = IO state + +data MouseButtonType = LeftClick + +newtype AppM m a = AppM {runAppM :: ReaderT DrawContext m a} + deriving (Functor, Applicative, Monad, MonadIO, MonadReader DrawContext) diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs index 8ef852e..4007bdc 100644 --- a/src/Chelleport/View.hs +++ b/src/Chelleport/View.hs @@ -3,31 +3,27 @@ module Chelleport.View (render) where import Chelleport.Draw import Chelleport.Types import Chelleport.Utils (intToCInt, isEmpty, isNotEmpty) -import Control.Monad (forM_, unless, void, when) -import Data.IORef (modifyIORef', newIORef, readIORef) +import Control.Monad (forM_, void, when) import Data.List (isPrefixOf, (\\)) import Data.Maybe (isJust) import qualified Data.Text as Text import Foreign.C (CInt) -import SDL (($=)) -import qualified SDL -render :: State -> DrawContext -> IO () -render state ctx = do - renderGridLines state ctx +render :: (MonadDraw m) => State -> m () +render state = do + renderGridLines state - (wcell, hcell) <- cellSize state ctx + (wcell, hcell) <- cellSize state - forM_ (zip [0 ..] $ stateGrid state) $ \(rowIndex, row) -> do - forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do - let py = rowIndex * hcell + 10 - let px = colIndex * wcell + wcell `div` 2 - 20 - visible <- renderKeySequence ctx (stateKeySequence state) cell (px, py) - when visible $ do - renderTargetPoints state ctx (rowIndex, colIndex) + forM_ (zip [0 ..] $ stateGrid state) $ \(rowIndex, row) -> forM_ (zip [0 ..] row) $ \(colIndex, cell) -> do + let py = rowIndex * hcell + 10 + let px = colIndex * wcell + wcell `div` 2 - 20 + visible <- renderKeySequence (stateKeySequence state) cell (px, py) + when visible $ do + renderTargetPoints state (rowIndex, colIndex) -renderKeySequence :: DrawContext -> KeySequence -> Cell -> (CInt, CInt) -> IO Bool -renderKeySequence ctx keySequence cell (px, py) = do +renderKeySequence ::(MonadDraw m) => KeySequence -> Cell -> (CInt, CInt) -> m Bool +renderKeySequence keySequence cell (px, py) = do let (matched, remaining) | keySequence `isPrefixOf` cell = splitAt (length keySequence) cell | otherwise = ("", cell) @@ -37,62 +33,59 @@ renderKeySequence ctx keySequence cell (px, py) = do | isNotEmpty matched = Just colorHighlight | otherwise = Nothing - widthRef <- newIORef 0 - unless (isEmpty matched) $ do - (textWidth, _h) <- drawText ctx (SDL.V2 px py) colorLightGray $ Text.pack matched - modifyIORef' widthRef (const textWidth) + previousTextWidth <- if isNotEmpty matched + then fst <$> drawText (px, py) colorLightGray (Text.pack matched) + else pure 0 - unless (isEmpty remaining) $ do - case textColor of - Just color -> do - prevTextWidth <- readIORef widthRef - let pos = px + prevTextWidth - void $ drawText ctx (SDL.V2 pos py) color $ Text.pack remaining - Nothing -> pure () + when (isNotEmpty remaining) $ case textColor of + Just color -> do + let pos = px + previousTextWidth + void $ drawText (pos, py) color $ Text.pack remaining + Nothing -> pure () pure (isJust textColor) -renderGridLines :: State -> DrawContext -> IO () -renderGridLines state ctx@(DrawContext {ctxRenderer = renderer}) = do +renderGridLines :: (MonadDraw m) => State -> m () +renderGridLines state = do let grid = stateGrid state - (wcell, hcell) <- cellSize state ctx + (wcell, hcell) <- cellSize state let rows = intToCInt $ length grid let columns = intToCInt $ length $ head grid forM_ [0 .. rows] $ \rowIndex -> do - SDL.rendererDrawColor renderer $= colorFocusLines - drawHorizontalLine ctx (rowIndex * hcell + hcell `div` 2) - SDL.rendererDrawColor renderer $= colorGridLines - drawHorizontalLine ctx $ rowIndex * hcell + setDrawColor colorFocusLines + drawHorizontalLine (rowIndex * hcell + hcell `div` 2) + setDrawColor colorGridLines + drawHorizontalLine $ rowIndex * hcell forM_ [0 .. columns] $ \colIndex -> do - SDL.rendererDrawColor renderer $= colorFocusLines - drawVerticalLine ctx (colIndex * wcell + wcell `div` 2) - SDL.rendererDrawColor renderer $= colorGridLines - drawVerticalLine ctx $ colIndex * wcell + setDrawColor colorFocusLines + drawVerticalLine (colIndex * wcell + wcell `div` 2) + setDrawColor colorGridLines + drawVerticalLine $ colIndex * wcell - SDL.rendererDrawColor renderer $= colorAxisLines - drawHorizontalLine ctx (rows * hcell `div` 2) - drawVerticalLine ctx (columns * wcell `div` 2) + setDrawColor colorAxisLines + drawHorizontalLine (rows * hcell `div` 2) + drawVerticalLine (columns * wcell `div` 2) -renderTargetPoints :: State -> DrawContext -> (CInt, CInt) -> IO () -renderTargetPoints state ctx@(DrawContext {ctxRenderer = renderer}) (row, col) = do - (wcell, hcell) <- cellSize state ctx +renderTargetPoints :: (MonadDraw m) =>State -> (CInt, CInt) -> m () +renderTargetPoints state (row, col) = do + (wcell, hcell) <- cellSize state let (x, y) = (col * wcell + wcell `div` 2, row * hcell + hcell `div` 2) - SDL.rendererDrawColor renderer $= colorWhite - drawCircle ctx 2 (x, y) + setDrawColor colorWhite + drawCircle 2 (x, y) when (stateIsMatched state) $ do - SDL.rendererDrawColor renderer $= colorFineGrainGrid + setDrawColor colorFineGrainGrid forM_ ([-8 .. 8] \\ [0]) $ \n -> do let px = x + n * wcell `div` 16 - SDL.drawLine renderer (SDL.P $ SDL.V2 px (y - hcell `div` 2)) (SDL.P $ SDL.V2 px (y + hcell `div` 2)) + drawLine (px, y - hcell `div` 2) (px, y + hcell `div` 2) forM_ ([-8 .. 8] \\ [0]) $ \n -> do let py = y + n * hcell `div` 16 - SDL.drawLine renderer (SDL.P $ SDL.V2 (x - wcell `div` 2) py) (SDL.P $ SDL.V2 (x + wcell `div` 2) py) + drawLine (x - wcell `div` 2, py) (x + wcell `div` 2, py) - SDL.rendererDrawColor renderer $= colorLightGray + setDrawColor colorLightGray let lenx = wcell `div` 4 let leny = hcell `div` 4 - SDL.drawLine renderer (SDL.P $ SDL.V2 (x - wcell `div` 4) (y - leny)) (SDL.P $ SDL.V2 (x - wcell `div` 4) (y + leny)) - SDL.drawLine renderer (SDL.P $ SDL.V2 (x + wcell `div` 4) (y - leny)) (SDL.P $ SDL.V2 (x + wcell `div` 4) (y + leny)) - SDL.drawLine renderer (SDL.P $ SDL.V2 (x - lenx) (y - hcell `div` 4)) (SDL.P $ SDL.V2 (x + lenx) (y - hcell `div` 4)) - SDL.drawLine renderer (SDL.P $ SDL.V2 (x - lenx) (y + hcell `div` 4)) (SDL.P $ SDL.V2 (x + lenx) (y + hcell `div` 4)) + drawLine (x - wcell `div` 4, y - leny) (x - wcell `div` 4, y + leny) + drawLine (x + wcell `div` 4, y - leny) (x + wcell `div` 4, y + leny) + drawLine (x - lenx, y - hcell `div` 4) (x + lenx, y - hcell `div` 4) + drawLine (x - lenx, y + hcell `div` 4) (x + lenx, y + hcell `div` 4) |