diff --git a/affection.cabal b/affection.cabal index c99d070..0e453c5 100644 --- a/affection.cabal +++ b/affection.cabal @@ -27,6 +27,7 @@ cabal-version: >=1.10 library exposed-modules: Affection extensions: OverloadedStrings + , GADTs -- Modules included in this library but not exported. -- other-modules: diff --git a/src/Affection.hs b/src/Affection.hs index 9fd2465..311d222 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -3,26 +3,32 @@ module Affection , withWindow , withDefaultWindow , delaySec + , Affection.Render + , Affection.Types ) where import SDL import Data.Text import qualified Control.Concurrent as CC +import Affection.Render +import Affection.Types + withAllAffection :: IO () -> IO () withAllAffection ops = do initializeAll ops quit -withWindow :: Text -> WindowConfig -> (Window -> IO ()) -> IO () -withWindow title conf ops = do - window <- createWindow title conf - ops window +withWindow :: Text -> WindowConfig -> RendererConfig -> (Window -> Renderer -> IO ()) -> IO () +withWindow title wconf rconf ops = do + window <- createWindow title wconf + renderer <- createRenderer window (-1) rconf + inRender renderer $ ops destroyWindow window -withDefaultWindow :: Text -> (Window -> IO ()) -> IO () -withDefaultWindow title ops = withWindow title defaultWindow ops +withDefaultWindow :: Text -> (Window -> Renderer -> IO ()) -> IO () +withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops delaySec :: Int -> IO () delaySec dur = delay (fromIntegral $ dur * 1000) diff --git a/src/Affection/Render.hs b/src/Affection/Render.hs new file mode 100644 index 0000000..fc05dab --- /dev/null +++ b/src/Affection/Render.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE GADTs #-} + +module Affection.Render + ( RenderM + , inRender + ) where + +import Affection.Types (RGBA) +import SDL +import Linear (V4(..)) + +data RenderM :: * -> * where + Pure :: a -> RenderM a + Bind :: RenderM a -> (a -> RenderM b) -> RenderM b + Render :: (Renderer -> IO a) -> RenderM a + +instance Functor RenderM where + fmap f m = Bind m (Pure . f) + +instance Applicative RenderM where + pure x = Pure x + mf <*> mx = Bind mf (\f -> Bind mx (\x -> Pure (f x))) + +instance Monad RenderM where + m >>= f = Bind m f + +inRender :: Renderer -> RenderM a -> IO a +inRender _ (Pure a) = return a +inRender r (Bind m f) = do + result <- inRender m r + inRender (f result) r +inRender r (Render f) = f r + +changeColor :: RGBA -> RenderM () +changeColor (RGBA r g b a) = Render $ \renderer -> rendererDrawColor renderer $= V4 r g b a diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs new file mode 100644 index 0000000..5d34a89 --- /dev/null +++ b/src/Affection/Types.hs @@ -0,0 +1,17 @@ +module Affection.Types + ( newRGBA + ) where + +data RGBA = RGBA + { r :: Int + , g :: Int + , b :: Int + , a :: Int + } + +newRGBA :: Int -> Int -> Int -> Int -> RGBA +newRGBA r g b a = RGBA (overflow r) (overflow g) (overflow b) (overflow a) + where + overflow x + | x < 0 = 255 + (x `mod` 255) + | otherwise = x `mod` 255