more playthings

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:       
   

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)

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

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