aboutsummaryrefslogtreecommitdiff
path: root/src/Chelleport
diff options
context:
space:
mode:
Diffstat (limited to 'src/Chelleport')
-rw-r--r--src/Chelleport/AppShell.hs49
-rw-r--r--src/Chelleport/Config.hs41
-rw-r--r--src/Chelleport/Context.hs12
-rw-r--r--src/Chelleport/Control.hs11
-rw-r--r--src/Chelleport/Draw.hs64
-rw-r--r--src/Chelleport/View.hs1
6 files changed, 92 insertions, 86 deletions
diff --git a/src/Chelleport/AppShell.hs b/src/Chelleport/AppShell.hs
index 8f8a19d..ba31982 100644
--- a/src/Chelleport/AppShell.hs
+++ b/src/Chelleport/AppShell.hs
@@ -1,11 +1,11 @@
module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where
+import Chelleport.Config
import Chelleport.Control (MonadControl (releaseMouseButton))
-import Chelleport.Draw (colorBackground)
import Chelleport.Types
import Control.Monad (foldM)
import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.RWS (MonadReader (ask))
+import Control.Monad.RWS (MonadReader (ask), asks)
import qualified Graphics.X11 as X11
import SDL (($=))
import qualified SDL
@@ -17,45 +17,44 @@ class (Monad m) => MonadAppShell m where
shutdownApp :: m ()
instance (MonadIO m) => MonadAppShell (AppM m) where
- hideWindow = ask >>= SDL.hideWindow . ctxWindow
- showWindow = ask >>= SDL.showWindow . ctxWindow
+ hideWindow = asks ctxWindow >>= SDL.hideWindow
+ showWindow = asks ctxWindow >>= SDL.showWindow
shutdownApp = do
- ctx <- ask
- SDL.destroyRenderer $ ctxRenderer ctx
- SDL.destroyWindow $ ctxWindow ctx
+ DrawContext {ctxRenderer = renderer, ctxWindow = window, ctxX11Display = x11Display} <- ask
+ SDL.destroyRenderer renderer
+ SDL.destroyWindow window
releaseMouseButton
SDL.quit
liftIO $ do
- X11.closeDisplay $ ctxX11Display ctx
+ X11.closeDisplay x11Display
exitSuccess
-type Update state appAction = state -> appAction -> IO (state, Maybe appAction)
+type Update m state appAction = state -> appAction -> m (state, Maybe appAction)
type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
-type View state = state -> IO ()
+type View m state = state -> m ()
-type Initializer state = IO state
+type Initializer m state = m state
setupAppShell ::
+ (MonadIO m) =>
DrawContext ->
- Initializer state ->
- Update state appAction ->
+ Initializer m state ->
+ Update m state appAction ->
EventHandler state appAction ->
- View state ->
- IO ()
-setupAppShell ctx initState update eventHandler draw = do
- state <- initState
- appLoop state
+ View m state ->
+ m ()
+setupAppShell (DrawContext {ctxRenderer = renderer}) getInitState update eventHandler draw =
+ getInitState >>= appLoop
where
- appLoop state = do
- SDL.rendererDrawColor (ctxRenderer ctx) $= colorBackground
- SDL.clear $ ctxRenderer ctx
- draw state
- SDL.present $ ctxRenderer ctx
+ appLoop currentState = do
+ SDL.rendererDrawColor renderer $= colorBackground
+ SDL.clear renderer
+ draw currentState
+ SDL.present renderer
- events <- SDL.pollEvents
- newState <- foldM evaluateEvent state events
+ newState <- SDL.pollEvents >>= foldM evaluateEvent currentState
appLoop newState
diff --git a/src/Chelleport/Config.hs b/src/Chelleport/Config.hs
new file mode 100644
index 0000000..65b7077
--- /dev/null
+++ b/src/Chelleport/Config.hs
@@ -0,0 +1,41 @@
+module Chelleport.Config where
+
+import Chelleport.Types
+import Foreign.C (CFloat)
+import qualified SDL
+
+colorWhite :: Color
+colorWhite = SDL.V4 255 255 255 255
+
+colorLightGray :: Color
+colorLightGray = SDL.V4 100 100 100 255
+
+colorGray :: Color
+colorGray = SDL.V4 55 52 65 200
+
+colorAccent :: Color
+colorAccent = SDL.V4 110 112 247 255
+
+colorHighlight :: Color
+colorHighlight = colorAccent
+
+colorGridLines :: Color
+colorGridLines = colorGray
+
+colorFocusLines :: Color
+colorFocusLines = colorLightGray
+
+colorAxisLines :: Color
+colorAxisLines = colorAccent
+
+colorBackground :: Color
+colorBackground = SDL.V4 15 12 25 0
+
+colorFineGrainGrid :: Color
+colorFineGrainGrid = SDL.V4 55 52 65 100
+
+windowOpacity :: CFloat
+windowOpacity = 0.4
+
+fontSize :: Int
+fontSize = 24
diff --git a/src/Chelleport/Context.hs b/src/Chelleport/Context.hs
index 3c2c850..b721812 100644
--- a/src/Chelleport/Context.hs
+++ b/src/Chelleport/Context.hs
@@ -1,22 +1,18 @@
module Chelleport.Context (initializeContext) where
+-- import Data.Time.Clock.System
+-- import qualified Debug.Trace as Debug
+
+import Chelleport.Config
import Chelleport.Types
import Data.ByteString (ByteString)
import Data.FileEmbed (embedFileRelative)
--- import Data.Time.Clock.System
--- import qualified Debug.Trace as Debug
import Foreign.C (CFloat)
import qualified Graphics.X11 as X11
import SDL (($=))
import qualified SDL
import qualified SDL.Font as TTF
-windowOpacity :: CFloat
-windowOpacity = 0.5
-
-fontSize :: Int
-fontSize = 24
-
-- benchmark :: String -> IO a -> IO a
-- benchmark msg m = do
-- start <- systemNanoseconds <$> getSystemTime
diff --git a/src/Chelleport/Control.hs b/src/Chelleport/Control.hs
index fa25681..80be6f8 100644
--- a/src/Chelleport/Control.hs
+++ b/src/Chelleport/Control.hs
@@ -80,15 +80,14 @@ isKeyReleaseWith :: SDL.KeyboardEventData -> SDL.Keycode -> Bool
isKeyReleaseWith keyboardEvent keyCode =
isKeyRelease keyboardEvent && eventToKeycode keyboardEvent == keyCode
+keyModifier :: SDL.KeyboardEventData -> SDL.KeyModifier
+keyModifier = SDL.keysymModifier . SDL.keyboardEventKeysym
+
withShift :: SDL.KeyboardEventData -> Bool
-withShift event = SDL.keyModifierLeftShift modifier || SDL.keyModifierRightShift modifier
- where
- modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event
+withShift ev = SDL.keyModifierLeftShift (keyModifier ev) || SDL.keyModifierRightShift (keyModifier ev)
withCtrl :: SDL.KeyboardEventData -> Bool
-withCtrl event = SDL.keyModifierLeftCtrl modifier || SDL.keyModifierRightCtrl modifier
- where
- modifier = SDL.keysymModifier . SDL.keyboardEventKeysym $ event
+withCtrl ev = SDL.keyModifierLeftCtrl (keyModifier ev) || SDL.keyModifierRightCtrl (keyModifier ev)
directionalIncrement :: (CInt, CInt) -> Char -> (Int, Int)
directionalIncrement (incX, incY) = \case
diff --git a/src/Chelleport/Draw.hs b/src/Chelleport/Draw.hs
index cba040a..3f67848 100644
--- a/src/Chelleport/Draw.hs
+++ b/src/Chelleport/Draw.hs
@@ -2,10 +2,9 @@ module Chelleport.Draw where
import Chelleport.Types
import Chelleport.Utils (intToCInt)
-import Control.Monad.Reader (MonadIO, MonadReader (ask))
+import Control.Monad.Reader (MonadIO, MonadReader (ask), asks)
import Data.Text (Text)
import qualified Data.Vector.Storable as Vector
-import Data.Word (Word8)
import Foreign.C (CInt)
import SDL (($=))
import qualified SDL
@@ -13,19 +12,19 @@ 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)
+ drawText :: (CInt, CInt) -> Color -> Text -> m (CInt, CInt)
drawCircle :: Int -> (CInt, CInt) -> m ()
- setDrawColor :: SDL.V4 Word8 -> m ()
+ setDrawColor :: Color -> m ()
windowSize :: m (CInt, CInt)
windowPosition :: m (CInt, CInt)
instance (MonadIO m) => MonadDraw (AppM m) where
drawLine (x1, y1) (x2, y2) = do
- DrawContext {ctxRenderer = renderer} <- ask
+ renderer <- asks ctxRenderer
SDL.drawLine renderer (SDL.P $ SDL.V2 x1 y1) (SDL.P $ SDL.V2 x2 y2)
setDrawColor color = do
- DrawContext {ctxRenderer = renderer} <- ask
+ renderer <- asks ctxRenderer
SDL.rendererDrawColor renderer $= color
drawText (x, y) color text = do
@@ -47,22 +46,23 @@ instance (MonadIO m) => MonadDraw (AppM m) where
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
+ renderer <- asks ctxRenderer
+ SDL.drawPoints renderer pointsOnACircle
+ where
+ pointsOnACircle = Vector.generate renderedPoints (SDL.P . toPointOnCircle)
+ renderedPoints = radius * 7
+ toTheta n = fromIntegral n * (2 * pi) / fromIntegral renderedPoints
+ toPointOnCircle n =
+ SDL.V2
+ (x + round ((fromIntegral radius :: Float) * cos (toTheta n)))
+ (y + round ((fromIntegral radius :: Float) * sin (toTheta n)))
windowSize = do
- SDL.V2 x y <- ask >>= SDL.get . SDL.windowSize . ctxWindow
+ SDL.V2 x y <- asks ctxWindow >>= SDL.get . SDL.windowSize
pure (x, y)
windowPosition = do
- SDL.V2 x y <- ask >>= SDL.getWindowAbsolutePosition . ctxWindow
+ SDL.V2 x y <- asks ctxWindow >>= SDL.getWindowAbsolutePosition
pure (x, y)
cellSize :: (MonadDraw m) => State -> m (CInt, CInt)
@@ -81,33 +81,3 @@ drawVerticalLine :: (MonadDraw m) => CInt -> m ()
drawVerticalLine x = do
(_, height) <- windowSize
drawLine (x, 0) (x, height)
-
-colorWhite :: SDL.V4 Word8
-colorWhite = SDL.V4 255 255 255 255
-
-colorLightGray :: SDL.V4 Word8
-colorLightGray = SDL.V4 100 100 100 255
-
-colorGray :: SDL.V4 Word8
-colorGray = SDL.V4 55 52 65 200
-
-colorAccent :: SDL.V4 Word8
-colorAccent = SDL.V4 110 112 247 255
-
-colorHighlight :: SDL.V4 Word8
-colorHighlight = colorAccent
-
-colorGridLines :: SDL.V4 Word8
-colorGridLines = colorGray
-
-colorFocusLines :: SDL.V4 Word8
-colorFocusLines = colorLightGray
-
-colorAxisLines :: SDL.V4 Word8
-colorAxisLines = colorAccent
-
-colorBackground :: SDL.V4 Word8
-colorBackground = SDL.V4 15 12 25 0
-
-colorFineGrainGrid :: SDL.V4 Word8
-colorFineGrainGrid = SDL.V4 55 52 65 100
diff --git a/src/Chelleport/View.hs b/src/Chelleport/View.hs
index 069e49c..459251b 100644
--- a/src/Chelleport/View.hs
+++ b/src/Chelleport/View.hs
@@ -1,5 +1,6 @@
module Chelleport.View (render) where
+import Chelleport.Config
import Chelleport.Draw
import Chelleport.Types
import Chelleport.Utils (intToCInt, isEmpty, isNotEmpty)