more playthings

This commit is contained in:
nek0 2016-03-25 16:58:46 +01:00
parent 8cb3dc21c4
commit a457313ade
4 changed files with 65 additions and 6 deletions

View file

@ -27,6 +27,7 @@ cabal-version: >=1.10
library library
exposed-modules: Affection exposed-modules: Affection
extensions: OverloadedStrings extensions: OverloadedStrings
, GADTs
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:

View file

@ -3,26 +3,32 @@ module Affection
, withWindow , withWindow
, withDefaultWindow , withDefaultWindow
, delaySec , delaySec
, Affection.Render
, Affection.Types
) where ) where
import SDL import SDL
import Data.Text import Data.Text
import qualified Control.Concurrent as CC import qualified Control.Concurrent as CC
import Affection.Render
import Affection.Types
withAllAffection :: IO () -> IO () withAllAffection :: IO () -> IO ()
withAllAffection ops = do withAllAffection ops = do
initializeAll initializeAll
ops ops
quit quit
withWindow :: Text -> WindowConfig -> (Window -> IO ()) -> IO () withWindow :: Text -> WindowConfig -> RendererConfig -> (Window -> Renderer -> IO ()) -> IO ()
withWindow title conf ops = do withWindow title wconf rconf ops = do
window <- createWindow title conf window <- createWindow title wconf
ops window renderer <- createRenderer window (-1) rconf
inRender renderer $ ops
destroyWindow window destroyWindow window
withDefaultWindow :: Text -> (Window -> IO ()) -> IO () withDefaultWindow :: Text -> (Window -> Renderer -> IO ()) -> IO ()
withDefaultWindow title ops = withWindow title defaultWindow ops withDefaultWindow title ops = withWindow title defaultWindow defaultRenderer ops
delaySec :: Int -> IO () delaySec :: Int -> IO ()
delaySec dur = delay (fromIntegral $ dur * 1000) delaySec dur = delay (fromIntegral $ dur * 1000)

35
src/Affection/Render.hs Normal file
View file

@ -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

17
src/Affection/Types.hs Normal file
View file

@ -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