nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Compare commits

base: nek0:master
Branches Tags
nek0:master
nek0:resourcetify
nek0:affectionate_class
nek0:multiwindow
..
compare: nek0:multiwindow
Branches Tags
nek0:master
nek0:resourcetify
nek0:affectionate_class
nek0:multiwindow

No commits in common. "master" and "multiwindow" have entirely different histories.
master ... multiwindo

26 changed files with 738 additions and 804 deletions
Show stats Expand all files Collapse all files

1
.envrc
View file

@ -1 +0,0 @@
use flake

2
.gitignore vendored
View file

@ -16,5 +16,3 @@ cabal.project.local*
dist*/ dist*/
report.html report.html
*.bak *.bak
.direnv/
result

90
affection.cabal
View file

@ -6,7 +6,7 @@ name: affection
-- PVP summary: +-+------- breaking API changes -- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions -- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change -- | | | +--- code changes with no API change
version: 0.0.0.10 version: 0.0.0.9
synopsis: A simple Game Engine using SDL synopsis: A simple Game Engine using SDL
description: This package contains Affection, a simple game engine description: This package contains Affection, a simple game engine
written in Haskell using SDL. written in Haskell using SDL.
@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
license: LGPL-3 license: LGPL-3
license-file: LICENSE license-file: LICENSE
author: nek0 author: nek0
maintainer: nek0@nek0.eu maintainer: nek0@chelnok.de
category: Game category: Game
build-type: Simple build-type: Simple
extra-source-files: ChangeLog.md extra-source-files: ChangeLog.md
@ -25,11 +25,11 @@ extra-source-files: ChangeLog.md
-- README. -- README.
-- extra-source-files: -- extra-source-files:
cabal-version: >=2.0 cabal-version: >=1.10
source-repository head source-repository head
type: git type: git
location: https://gitea.nek0.eu/nek0/affection.git location: https://github.com/nek0/affection
flag verbose flag verbose
description: Enable verbose debug messages description: Enable verbose debug messages
@ -67,7 +67,6 @@ library
exposed-modules: Affection exposed-modules: Affection
, Affection.Logging , Affection.Logging
, Affection.Types , Affection.Types
, Affection.Class
, Affection.StateMachine , Affection.StateMachine
, Affection.Util , Affection.Util
, Affection.MessageBus , Affection.MessageBus
@ -85,39 +84,35 @@ library
, Affection.Subsystems.AffectionMouse , Affection.Subsystems.AffectionMouse
, Affection.Subsystems.AffectionJoystick , Affection.Subsystems.AffectionJoystick
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
, TypeFamilies
, AllowAmbiguousTypes
-- Modules included in this library but not exported. -- Modules included in this library but not exported.
-- other-modules: -- other-modules:
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: GADTs other-extensions: GADTs
-- , KindSignatures , KindSignatures
-- , FlexibleInstances , FlexibleInstances
-- , MultiParamTypeClasses , MultiParamTypeClasses
-- , UndecidableInstances , UndecidableInstances
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -threaded -Wall ghc-options: -Wall
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base >=4.9 && < 5 build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , sdl2 >= 2.4 && < 2.5
, linear , linear
, text , text
, mtl , mtl
, monad-loops , monad-loops
, monad-parallel , monad-parallel
, containers , containers
, clock >= 0.8 , clock
, glib , glib
, bytestring , bytestring
, OpenGL , OpenGL
, OpenGLRaw
, stm , stm
, uuid , uuid
, vector , vector
, resourcet
-- This example shows the message system. only makes sense when compiling with -- This example shows the message system. only makes sense when compiling with
-- verbose flag. -- verbose flag.
@ -127,11 +122,12 @@ executable example00
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2
if !flag(examples) , stm
else
buildable: False buildable: False
-- A small game of life implementation -- A small game of life implementation
@ -142,18 +138,19 @@ executable example01
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2
, OpenGL , stm
, random , OpenGL
, containers , random
, linear , containers
, matrix , linear
, nanovg >= 0.6.0.0 , matrix
, deepseq , nanovg >= 0.6.0.0
if !flag(examples) , deepseq
else
buildable: False buildable: False
-- Another small game of life implementation -- Another small game of life implementation
@ -164,16 +161,17 @@ executable example02
ghc-options: -threaded -Wall ghc-options: -threaded -Wall
default-language: Haskell2010 default-language: Haskell2010
default-extensions: OverloadedStrings default-extensions: OverloadedStrings
build-depends: base >=4.9 && < 5 if flag(examples)
, affection build-depends: base >=4.9 && < 5
, sdl2 >= 2.5 , affection
, stm , sdl2
, OpenGL , stm
, random , OpenGL
, containers , random
, linear , containers
, matrix , linear
, nanovg >= 0.6.0.0 , matrix
, deepseq , nanovg >= 0.6.0.0
if !flag(examples) , deepseq
else
buildable: False buildable: False

4
cabal.project
View file

@ -1,4 +0,0 @@
packages: ./*.cabal
package affection
flags: +examples

172
examples/example00/Main.hs
View file

@ -1,34 +1,21 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Main where
import Affection as A import Affection as A
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO)
import Control.Monad import Control.Monad (when)
import qualified SDL import qualified SDL hiding (Window(..))
import Data.Maybe (isJust, fromJust) import Data.Maybe (isJust, fromJust)
import Data.String
data StateData = StateData data StateData = StateData
{ sdSubs :: Subsystems { sdSubs :: Subsystems
, sdJoys :: MVar [SDL.Joystick] , sdJoys :: [SDL.Joystick]
, doNextStep :: MVar Bool
} }
instance Affectionate StateData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
data Subsystems = Subsystems data Subsystems = Subsystems
{ subWindow :: Main.Window { subWindow :: Main.Window
, subMouse :: Main.Mouse , subMouse :: Main.Mouse
@ -36,13 +23,36 @@ data Subsystems = Subsystems
, subJoystick :: Main.Joystick , subJoystick :: Main.Joystick
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())]) newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())]) newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
instance Participant Main.Window where generalSubscribers
type Mesg Main.Window = WindowMessage :: TVar [(UUID, msg -> Affection StateData ())]
-> Affection StateData [msg -> Affection StateData ()]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> (msg -> Affection StateData())
-> Affection StateData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> UUID
-> Affection StateData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
instance Participant Main.Window StateData where
type Mesg Main.Window StateData = WindowMessage
partSubscribers (Window t) = generalSubscribers t partSubscribers (Window t) = generalSubscribers t
@ -50,11 +60,11 @@ instance Participant Main.Window where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Main.Window where instance SDLSubsystem Main.Window StateData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse where instance Participant Mouse StateData where
type Mesg Mouse = MouseMessage type Mesg Mouse StateData = MouseMessage
partSubscribers (Mouse t) = generalSubscribers t partSubscribers (Mouse t) = generalSubscribers t
@ -62,11 +72,11 @@ instance Participant Mouse where
partUnSubscribe (Mouse t) = generalUnSubscribe t partUnSubscribe (Mouse t) = generalUnSubscribe t
instance SDLSubsystem Mouse where instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard where instance Participant Keyboard StateData where
type Mesg Keyboard = KeyboardMessage type Mesg Keyboard StateData = KeyboardMessage
partSubscribers (Keyboard t) = generalSubscribers t partSubscribers (Keyboard t) = generalSubscribers t
@ -74,11 +84,11 @@ instance Participant Keyboard where
partUnSubscribe (Keyboard t) = generalUnSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant Joystick where instance Participant Joystick StateData where
type Mesg Joystick = JoystickMessage type Mesg Joystick StateData = JoystickMessage
partSubscribers (Joystick t) = generalSubscribers t partSubscribers (Joystick t) = generalSubscribers t
@ -86,7 +96,7 @@ instance Participant Joystick where
partUnSubscribe (Joystick t) = generalUnSubscribe t partUnSubscribe (Joystick t) = generalUnSubscribe t
instance SDLSubsystem Joystick where instance SDLSubsystem Joystick StateData where
consumeSDLEvents = consumeSDLJoystickEvents consumeSDLEvents = consumeSDLJoystickEvents
main :: IO () main :: IO ()
@ -99,14 +109,21 @@ main = do
[ [
( 0 ( 0
, SDL.defaultWindow , SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
} }
, SDL.Windowed
) )
] ]
} :: AffectionConfig StateData , initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
load :: IO StateData load :: IO StateData
@ -117,80 +134,57 @@ load =
<*> (Keyboard <$> newTVarIO []) <*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO []) <*> (Joystick <$> newTVarIO [])
) )
<*> newMVar [] <*> return []
<*> newMVar True
pre :: StateData -> Affection () pre :: Affection StateData ()
pre sd = do pre = do
_ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd)) sd <- getAffection
_ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd)) _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
_ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd)) _ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
return () return ()
exitOnQ :: MVar Bool -> KeyboardMessage -> Affection () exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) = exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..." liftIO $ logIO Debug "Yo dog I heard..."
void $ liftIO $ swapMVar nextStep False quit
_ -> return () _ -> return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () exitOnWindowClose :: WindowMessage -> Affection StateData ()
exitOnWindowClose nextStep wm = exitOnWindowClose wm =
case wm of case wm of
MsgWindowClose _ _ -> do MsgWindowClose _ _ -> do
liftIO $ logIO Debug "I heard another one..." liftIO $ logIO Debug "I heard another one..."
void $ liftIO $ swapMVar nextStep False quit
_ -> return () _ -> return ()
joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection () joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
joyConnectDisconnect mvjs msg = do joyConnectDisconnect msg = do
mj <- joystickAutoConnect msg mj <- joystickAutoConnect msg
when (isJust mj) $ do when (isJust mj) $ do
js <- liftIO $ readMVar mvjs sd <- getAffection
void $ liftIO $ swapMVar mvjs (fromJust mj : js) putAffection sd
js <- liftIO $ readMVar mvjs { sdJoys = fromJust mj : sdJoys sd
njs <- joystickAutoDisconnect js msg }
liftIO $ putMVar mvjs njs sd <- getAffection
njs <- joystickAutoDisconnect (sdJoys sd) msg
putAffection sd
{ sdJoys = njs
}
handle :: StateData -> [SDL.EventPayload] -> Affection () handle :: [SDL.EventPayload] -> Affection StateData ()
handle sd es = do handle es = do
let (Subsystems a b c d) = sdSubs sd (Subsystems a b c d) <- sdSubs <$> getAffection
leftovers <- consumeSDLEvents a leftovers <- consumeSDLEvents a
=<< consumeSDLEvents b =<< consumeSDLEvents b
=<< consumeSDLEvents c =<< consumeSDLEvents c
=<< consumeSDLEvents d es =<< consumeSDLEvents d es
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e)) mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
leftovers
update :: StateData -> Double -> Affection () update _ = return ()
update _ _ = return ()
draw :: StateData -> Affection () draw = return ()
draw _ = return ()
clean :: StateData -> IO ()
clean _ = return () clean _ = return ()
generalSubscribers
:: TVar [(UUID, msg -> Affection ())]
-> Affection [msg -> Affection ()]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> (msg -> Affection())
-> Affection UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())]
-> UUID
-> Affection ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))

221
examples/example01/Main.hs
View file

@ -3,36 +3,30 @@
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A import Affection as A
import SDL (($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO)
import Control.Monad import Control.Monad (when)
import Control.DeepSeq (deepseq) import Control.DeepSeq (deepseq)
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Set as S import qualified Data.Set as S
import Data.String
import System.Random (randomRIO) import System.Random (randomRIO)
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Linear
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
-- internal imports -- internal imports
import Types import Types
instance Affectionate UserData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
@ -46,16 +40,23 @@ main = do
[ [
( 0 ( 0
, SDL.defaultWindow , SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
, SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True , SDL.windowResizable = True
} }
, SDL.Windowed
) )
] ]
} :: AffectionConfig UserData , initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
load :: IO UserData load :: IO UserData
@ -64,146 +65,156 @@ load = do
liftIO $ logIO A.Debug "init GLEW" liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit _ <- glewInit
liftIO $ logIO A.Debug "making random" liftIO $ logIO A.Debug "making random"
randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
liftIO $ logIO A.Debug "creating context" liftIO $ logIO A.Debug "creating context"
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix -- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
step <- newMVar True return $ UserData
(\life food time -> UserData
{ subsystems = Subsystems { subsystems = Subsystems
(Window empty1) (Window empty1)
(Keyboard empty3) (Keyboard empty3)
, lifeMat = life , lifeMat = fullMatrix
, foodMat = food , foodMat = fromList 60 60 (repeat 10)
, timeMat = time , timeMat = M.zero 60 60
, nano = nanoCtx , nano = nanoCtx
, doNextStep = step
} }
)
<$> newMVar fullMatrix
<*> (newMVar (fromList 60 60 (repeat 10)))
<*> (newMVar (M.zero 60 60))
pre :: UserData -> Affection () pre :: Affection UserData ()
pre ud = do pre = do
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud)) sd <- getAffection
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud) _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud)) _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600)) _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
_ <- partSubscribe (subWindow $ subsystems sd) (fitViewport (600/600))
now <- getElapsedTime
putAffection sd
toggleFullScreen :: KeyboardMessage -> Affection () toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = return () toggleFullScreen _ = return ()
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection () exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) = exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..." liftIO $ logIO A.Debug "Yo dog I heard..."
void $ liftIO $ swapMVar step False quit
_ -> return () _ -> return ()
exitOnEsc _ _ = return () exitOnEsc _ = return ()
reloadOnR :: UserData -> KeyboardMessage -> Affection () reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeR -> reload ud SDL.KeycodeR -> reload
_ -> return () _ -> return ()
reloadOnR _ = return ()
reload :: UserData -> Affection () reload :: Affection UserData ()
reload ud = do reload = do
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] ud <- getAffection
now <- getElapsedTime
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix putAffection ud
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10)) { lifeMat = fullMatrix
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60) , foodMat = fromList 60 60 (repeat 10)
, timeMat = M.zero 60 60
}
showFPS :: KeyboardMessage -> Affection () showFPS :: KeyboardMessage -> Affection UserData ()
showFPS (MsgKeyboardEvent _ _ _ _ sym) = showFPS (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeF -> do SDL.KeycodeF -> do
dt <- getDelta dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt)) liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
_ -> return () _ -> return ()
showFPS _ = return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose step wm = exitOnWindowClose wm =
case wm of case wm of
MsgWindowClose _ _ -> do MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..." liftIO $ logIO A.Debug "I heard another one..."
void $ liftIO $ swapMVar step False quit
_ -> return () _ -> return ()
exitOnWindowClose _ = return ()
handle :: UserData -> [SDL.EventPayload] -> Affection () handle :: [SDL.EventPayload] -> Affection UserData ()
handle ud es = do handle es = do
let (Subsystems a b) = subsystems ud (Subsystems a b) <- subsystems <$> getAffection
_ <- consumeSDLEvents a =<< consumeSDLEvents b es _ <- consumeSDLEvents a =<< consumeSDLEvents b es
return () return ()
update :: UserData -> Double -> Affection () update :: Double -> Affection UserData ()
update ud _ = do update _ = do
-- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt))) ud <- getAffection
pastLife <- liftIO $ readMVar (lifeMat ud)
pastFood <- liftIO $ readMVar (foodMat ud)
pastTime <- liftIO $ readMVar (timeMat ud)
newList <- mapM (\coord -> do newList <- mapM (\coord -> do
let x = (coord `mod` 60) + 1 let x = (coord `mod` 60) + 1
y = (coord `div` 60) + 1 y = (coord `div` 60) + 1
subm subm
| x == 1 && y == 1 = | x == 1 && y == 1 =
(submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife) (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
<-> <->
(submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
| x == 1 && y == 60 = | x == 1 && y == 60 =
(submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
<-> <->
(submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
| x == 60 && y == 1 = | x == 60 && y == 1 =
(submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
<-> <->
(submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
| x == 60 && y == 60 = | x == 60 && y == 60 =
(submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
<-> <->
(submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
| x == 1 = | x == 1 =
(submatrix (y - 1) (y + 1) 60 60 pastLife) (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
<|> <|>
(submatrix (y - 1) (y + 1) 1 2 pastLife) (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
| y == 1 = | y == 1 =
(submatrix 60 60 (x - 1) (x + 1) pastLife) (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
<-> <->
(submatrix 1 2 (x - 1) (x + 1) pastLife) (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
| x == 60 = | x == 60 =
(submatrix (y - 1) (y + 1) 59 60 pastLife) (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
<|> <|>
(submatrix (y - 1) (y + 1) 1 1 pastLife) (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
| y == 60 = | y == 60 =
(submatrix 59 60 (x -1 ) (x + 1) pastLife) (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
<-> <->
(submatrix 1 1 (x - 1) (x + 1) pastLife) (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
| otherwise = | otherwise =
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
life = countLife subm life = countLife subm
if pastLife M.! (y, x) == 1 ret
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0 | life == 0 && lifeMat ud M.! (y, x) == 0 =
then return (1, (pastFood M.! (y, x)) - 1, 0) ( 0
else return (0, pastFood M.! (y, x), 0) , if timeMat ud M.! (y, x) >= 10
else if life == 3 && pastFood M.! (y, x) > 0 then min 10 (foodMat ud M.! (y, x) + 1)
then return (1, (pastFood M.! (y, x)) - 1, 0) else min 10 (foodMat ud M.! (y, x))
, timeMat ud M.! (y, x) + 1
)
| otherwise = (1, 1, 1)
if lifeMat ud M.! (y, x) == 1
then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else return (0, foodMat ud M.! (y, x), 0)
else if life == 3 && foodMat ud M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else return else return
( (0 :: Word) ( 0
, if pastTime M.! (y, x) > 10 , if timeMat ud M.! (y, x) > 10
then min 10 ((pastFood M.! (y, x)) + 1) then min 10 ((foodMat ud M.! (y, x)) + 1)
else min 10 (pastFood M.! (y, x)) else min 10 (foodMat ud M.! (y, x))
, pastTime M.! (y, x) + 1 , timeMat ud M.! (y, x) + 1
) )
) [0..3599] ) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@ -211,21 +222,22 @@ update ud _ = do
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
if newLifeMat == M.zero 60 60 if newLifeMat == M.zero 60 60
then then
reload ud reload
else do else
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ()) putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat { lifeMat = newLifeMat
void $ liftIO $ swapMVar (timeMat ud) newTimeMat --, foodMat = newFoodMat
, timeMat = newTimeMat
}
countLife :: Matrix Word -> Word countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2)) countLife mat = res - (mat M.! (2, 2))
where where
res = foldr (flip (+)) 0 mat res = foldr (flip (+)) 0 mat
draw :: UserData -> Affection () draw :: Affection UserData ()
draw ud = do draw = do
life <- liftIO $ readMVar (lifeMat ud) ud <- getAffection
food <- liftIO $ readMVar (foodMat ud)
liftIO $ do liftIO $ do
beginFrame (nano ud) 600 600 1 beginFrame (nano ud) 600 600 1
save (nano ud) save (nano ud)
@ -233,7 +245,7 @@ draw ud = do
let x = coord `mod` 60 let x = coord `mod` 60
y = coord `div` 60 y = coord `div` 60
ctx = nano ud ctx = nano ud
mult = life M.! (x + 1, y + 1) mult = lifeMat ud M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult -- logIO A.Debug $ show mult
beginPath ctx beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
@ -241,11 +253,10 @@ draw ud = do
then then
fillColor ctx (rgba 255 255 255 255) fillColor ctx (rgba 255 255 255 255)
else else
fillColor ctx (rgba 0 (fromIntegral $ 25 * (food M.! (x+1, y+1))) 0 255) fillColor ctx (rgba 0 (fromIntegral $ 25 * (foodMat ud M.! (x+1, y+1))) 0 255)
fill ctx fill ctx
) [0..3599] ) [0..3599]
restore (nano ud) restore (nano ud)
endFrame (nano ud) endFrame (nano ud)
clean :: UserData -> IO ()
clean _ = return () clean _ = return ()

37
examples/example01/Types.hs
View file

@ -10,15 +10,14 @@ import Data.Matrix as M
import NanoVG import NanoVG
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO)
data UserData = UserData data UserData = UserData
{ lifeMat :: MVar (Matrix Word) { lifeMat :: Matrix Word
, foodMat :: MVar (Matrix Word) , foodMat :: Matrix Word
, timeMat :: MVar (Matrix Word) , timeMat :: Matrix Word
, subsystems :: Subsystems , subsystems :: Subsystems
, nano :: Context , nano :: Context
, doNextStep :: MVar Bool
} }
data Subsystems = Subsystems data Subsystems = Subsystems
@ -26,12 +25,12 @@ data Subsystems = Subsystems
, subKeyboard :: Types.Keyboard , subKeyboard :: Types.Keyboard
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Types.Window where instance Participant Types.Window UserData where
type Mesg Types.Window = WindowMessage type Mesg Types.Window UserData = WindowMessage
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -41,11 +40,11 @@ instance Participant Types.Window where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window where instance SDLSubsystem Types.Window UserData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where instance Participant Keyboard UserData where
type Mesg Keyboard = KeyboardMessage type Mesg Keyboard UserData = KeyboardMessage
partSubscribers (Keyboard t) = do partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -55,24 +54,24 @@ instance Participant Keyboard where
partUnSubscribe (Keyboard t) = generalUnSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe generalSubscribe
:: TVar [(UUID, msg -> Affection ())] :: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection ()) -> (msg -> Affection UserData ())
-> Affection UUID -> Affection UserData UUID
generalSubscribe t funct = do generalSubscribe t funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid return uuid
generalUnSubscribe generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())] :: TVar [(UUID, msg -> Affection UserData ())]
-> UUID -> UUID
-> Affection () -> Affection UserData ()
generalUnSubscribe t uuid = generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p filterMsg (u, _) p = u /= p

224
examples/example02/Main.hs
View file

@ -3,36 +3,30 @@
{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ForeignFunctionInterface #-}
import Affection as A import Affection as A
import SDL (($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO)
import Control.Monad import Control.Monad (when)
import Control.DeepSeq (deepseq) import Control.DeepSeq (deepseq)
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Set as S import qualified Data.Set as S
import Data.String
import System.Random (randomRIO) import System.Random (randomRIO)
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Linear
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
-- internal imports -- internal imports
import Types import Types
instance Affectionate UserData where
loadState = load
preLoop = pre
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = clean
hasNextStep = liftIO . readMVar . doNextStep
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
@ -49,16 +43,23 @@ main = do
[ [
( 0 ( 0
, SDL.defaultWindow , SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
, SDL.windowInitialSize = SDL.V2 600 600 , SDL.windowInitialSize = SDL.V2 600 600
, SDL.windowResizable = True , SDL.windowResizable = True
} }
, SDL.Windowed
) )
] ]
} :: AffectionConfig UserData , initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
}
withAffection conf withAffection conf
load :: IO UserData load :: IO UserData
@ -67,145 +68,156 @@ load = do
liftIO $ logIO A.Debug "init GLEW" liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit _ <- glewInit
liftIO $ logIO A.Debug "making random" liftIO $ logIO A.Debug "making random"
randList <- mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] randList <- mapM (\_ -> randomRIO (0,1)) [0..3599]
liftIO $ logIO A.Debug "creating context" liftIO $ logIO A.Debug "creating context"
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix -- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())]) empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
(\life food time nextStep -> UserData return $ UserData
{ subsystems = Subsystems { subsystems = Subsystems
(Window empty1) (Window empty1)
(Keyboard empty3) (Keyboard empty3)
, lifeMat = life , lifeMat = fullMatrix
, foodMat = food , foodMat = fromList 60 60 (repeat maxFood)
, timeMat = time , timeMat = M.zero 60 60
, nano = nanoCtx , nano = nanoCtx
, doNextStep = nextStep
} }
)
<$> newMVar fullMatrix
<*> newMVar (fromList 60 60 (repeat maxFood))
<*> newMVar (M.zero 60 60)
<*> newMVar True
pre :: UserData -> Affection () pre :: Affection UserData ()
pre ud = do pre = do
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud)) sd <- getAffection
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud) _ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS _ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen _ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud)) _ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600)) _ <- partSubscribe (subWindow $ subsystems sd) exitOnWindowClose
_ <- partSubscribe (subWindow $ subsystems sd) (fitViewport (600/600))
now <- getElapsedTime
putAffection sd
toggleFullScreen :: KeyboardMessage -> Affection () toggleFullScreen :: KeyboardMessage -> Affection UserData ()
toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym) toggleFullScreen (MsgKeyboardEvent _ _ SDL.Pressed False sym)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0 | SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return () | otherwise = return ()
toggleFullScreen _ = return () toggleFullScreen _ = return ()
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection () exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) = exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..." liftIO $ logIO A.Debug "Yo dog I heard..."
void $ liftIO $ swapMVar step False quit
_ -> return () _ -> return ()
exitOnEsc _ _ = return () exitOnEsc _ = return ()
reloadOnR :: UserData -> KeyboardMessage -> Affection () reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) = reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeR -> reload ud SDL.KeycodeR -> reload
_ -> return () _ -> return ()
reloadOnR _ = return ()
reload :: UserData -> Affection () reload :: Affection UserData ()
reload ud = do reload = do
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)] ud <- getAffection
now <- getElapsedTime
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList let fullMatrix = fromList 60 60 randList
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix putAffection ud
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat maxFood)) { lifeMat = fullMatrix
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60) , foodMat = fromList 60 60 (repeat maxFood)
, timeMat = M.zero 60 60
}
showFPS :: KeyboardMessage -> Affection () showFPS :: KeyboardMessage -> Affection UserData ()
showFPS (MsgKeyboardEvent _ _ _ _ sym) = showFPS (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of case SDL.keysymKeycode sym of
SDL.KeycodeF -> do SDL.KeycodeF -> do
dt <- getDelta dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt)) liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
_ -> return () _ -> return ()
showFPS _ = return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection () exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose step wm = exitOnWindowClose wm =
case wm of case wm of
MsgWindowClose _ _ -> do MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..." liftIO $ logIO A.Debug "I heard another one..."
void $ liftIO $ swapMVar step False quit
_ -> return () _ -> return ()
exitOnWindowClose _ = return ()
handle :: UserData -> [SDL.EventPayload] -> Affection () handle :: [SDL.EventPayload] -> Affection UserData ()
handle ud es = do handle es = do
let (Subsystems a b) = subsystems ud (Subsystems a b) <- subsystems <$> getAffection
_ <- consumeSDLEvents a =<< consumeSDLEvents b es _ <- consumeSDLEvents a =<< consumeSDLEvents b es
return () return ()
update :: UserData -> Double -> Affection () update :: Double -> Affection UserData ()
update ud _ = do update _ = do
pastLife <- liftIO $ readMVar (lifeMat ud) ud <- getAffection
pastFood <- liftIO $ readMVar (foodMat ud)
pastTime <- liftIO $ readMVar (timeMat ud)
newList <- mapM (\coord -> do newList <- mapM (\coord -> do
let x = (coord `mod` 60) + 1 let x = (coord `mod` 60) + 1
y = (coord `div` 60) + 1 y = (coord `div` 60) + 1
subm subm
| x == 1 && y == 1 = | x == 1 && y == 1 =
(submatrix 60 60 60 60 pastLife <|> submatrix 60 60 1 2 pastLife) (submatrix 60 60 60 60 (lifeMat ud) <|> submatrix 60 60 1 2 (lifeMat ud))
<-> <->
(submatrix 1 2 60 60 pastLife <|> submatrix 1 2 1 2 pastLife) (submatrix 1 2 60 60 (lifeMat ud) <|> submatrix 1 2 1 2 (lifeMat ud))
| x == 1 && y == 60 = | x == 1 && y == 60 =
(submatrix 59 60 60 60 pastLife <|> submatrix 59 60 1 2 pastLife) (submatrix 59 60 60 60 (lifeMat ud) <|> submatrix 59 60 1 2 (lifeMat ud))
<-> <->
(submatrix 1 1 60 60 pastLife <|> submatrix 1 1 1 2 pastLife) (submatrix 1 1 60 60 (lifeMat ud) <|> submatrix 1 1 1 2 (lifeMat ud))
| x == 60 && y == 1 = | x == 60 && y == 1 =
(submatrix 60 60 59 60 pastLife <|> submatrix 60 60 1 1 pastLife) (submatrix 60 60 59 60 (lifeMat ud) <|> submatrix 60 60 1 1 (lifeMat ud))
<-> <->
(submatrix 1 2 59 60 pastLife <|> submatrix 1 2 1 1 pastLife) (submatrix 1 2 59 60 (lifeMat ud) <|> submatrix 1 2 1 1 (lifeMat ud))
| x == 60 && y == 60 = | x == 60 && y == 60 =
(submatrix 59 60 59 60 pastLife <|> submatrix 59 60 1 1 pastLife) (submatrix 59 60 59 60 (lifeMat ud) <|> submatrix 59 60 1 1 (lifeMat ud))
<-> <->
(submatrix 1 1 59 60 pastLife <|> submatrix 1 1 1 1 pastLife) (submatrix 1 1 59 60 (lifeMat ud) <|> submatrix 1 1 1 1 (lifeMat ud))
| x == 1 = | x == 1 =
(submatrix (y - 1) (y + 1) 60 60 pastLife) (submatrix (y - 1) (y + 1) 60 60 (lifeMat ud))
<|> <|>
(submatrix (y - 1) (y + 1) 1 2 pastLife) (submatrix (y - 1) (y + 1) 1 2 (lifeMat ud))
| y == 1 = | y == 1 =
(submatrix 60 60 (x - 1) (x + 1) pastLife) (submatrix 60 60 (x - 1) (x + 1) (lifeMat ud))
<-> <->
(submatrix 1 2 (x - 1) (x + 1) pastLife) (submatrix 1 2 (x - 1) (x + 1) (lifeMat ud))
| x == 60 = | x == 60 =
(submatrix (y - 1) (y + 1) 59 60 pastLife) (submatrix (y - 1) (y + 1) 59 60 (lifeMat ud))
<|> <|>
(submatrix (y - 1) (y + 1) 1 1 pastLife) (submatrix (y - 1) (y + 1) 1 1 (lifeMat ud))
| y == 60 = | y == 60 =
(submatrix 59 60 (x -1 ) (x + 1) pastLife) (submatrix 59 60 (x -1 ) (x + 1) (lifeMat ud))
<-> <->
(submatrix 1 1 (x - 1) (x + 1) pastLife) (submatrix 1 1 (x - 1) (x + 1) (lifeMat ud))
| otherwise = | otherwise =
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife) (submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
life = countLife subm life = countLife subm
if pastLife M.! (y, x) == 1 ret
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0 | life == 0 && lifeMat ud M.! (y, x) == 0 =
then return (1, (pastFood M.! (y, x)) - 1, 0) ( 0
else return (0, pastFood M.! (y, x), 0) , if timeMat ud M.! (y, x) >= 10
else if life == 3 && pastFood M.! (y, x) > 0 then min 10 (foodMat ud M.! (y, x) + 1)
then return (1, (pastFood M.! (y, x)) - 1, 0) else min 10 (foodMat ud M.! (y, x))
, timeMat ud M.! (y, x) + 1
)
| otherwise = (1, 1, 1)
if lifeMat ud M.! (y, x) == 1
then if (life == 2 || life == 3) && foodMat ud M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else return (0, foodMat ud M.! (y, x), 0)
else if life == 3 && foodMat ud M.! (y, x) > 0
then return (1, (foodMat ud M.! (y, x)) - 1, 0)
else return else return
( 0 :: Word ( 0
, if pastTime M.! (y, x) > 10 , if timeMat ud M.! (y, x) > 10
then min maxFood ((pastFood M.! (y, x)) + 1) then min maxFood ((foodMat ud M.! (y, x)) + 1)
else min maxFood (pastFood M.! (y, x)) else min maxFood (foodMat ud M.! (y, x))
, pastTime M.! (y, x) + 1 , timeMat ud M.! (y, x) + 1
) )
) [0..3599] ) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList) let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@ -213,41 +225,41 @@ update ud _ = do
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList) newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
if newLifeMat == M.zero 60 60 if newLifeMat == M.zero 60 60
then then
reload ud reload
else do else
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ()) putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat { lifeMat = newLifeMat
void $ liftIO $ swapMVar (timeMat ud) newTimeMat , foodMat = newFoodMat
void $ liftIO $ swapMVar (foodMat ud) newFoodMat , timeMat = newTimeMat
}
countLife :: Matrix Word -> Word countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2)) countLife mat = res - (mat M.! (2, 2))
where where
res = foldr (flip (+)) 0 mat res = foldr (flip (+)) 0 mat
draw :: UserData -> Affection () draw :: Affection UserData ()
draw ud = liftIO $ do draw = do
pastLife <- readMVar (lifeMat ud) ud <- getAffection
pastFood <- readMVar (foodMat ud) liftIO $ do
beginFrame (nano ud) 600 600 1 beginFrame (nano ud) 600 600 1
save (nano ud) save (nano ud)
mapM_ (\coord -> do mapM_ (\coord -> do
let x = coord `mod` 60 let x = coord `mod` 60
y = coord `div` 60 y = coord `div` 60
ctx = nano ud ctx = nano ud
multiplicator = pastLife M.! (x + 1, y + 1) mult = lifeMat ud M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult -- logIO A.Debug $ show mult
beginPath ctx beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10 rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
if multiplicator == 1 if mult == 1
then then
fillColor ctx (rgba 255 255 255 255) fillColor ctx (rgba 255 255 255 255)
else else
fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (pastFood M.! (x+1, y+1))) 0 255) fillColor ctx (rgba 0 (fromIntegral $ (255 `div` maxFood) * (foodMat ud M.! (x+1, y+1))) 0 255)
fill ctx fill ctx
) [0..3599] ) [0..3599]
restore (nano ud) restore (nano ud)
endFrame (nano ud) endFrame (nano ud)
clean :: UserData -> IO ()
clean _ = return () clean _ = return ()

37
examples/example02/Types.hs
View file

@ -10,15 +10,14 @@ import Data.Matrix as M
import NanoVG import NanoVG
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar import Control.Monad.IO.Class (liftIO)
data UserData = UserData data UserData = UserData
{ lifeMat :: MVar (Matrix Word) { lifeMat :: Matrix Word
, foodMat :: MVar (Matrix Word) , foodMat :: Matrix Word
, timeMat :: MVar (Matrix Word) , timeMat :: Matrix Word
, subsystems :: Subsystems , subsystems :: Subsystems
, nano :: Context , nano :: Context
, doNextStep :: MVar Bool
} }
data Subsystems = Subsystems data Subsystems = Subsystems
@ -26,12 +25,12 @@ data Subsystems = Subsystems
, subKeyboard :: Types.Keyboard , subKeyboard :: Types.Keyboard
} }
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())]) newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())]) newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Types.Window where instance Participant Types.Window UserData where
type Mesg Types.Window = WindowMessage type Mesg Types.Window UserData = WindowMessage
partSubscribers (Window t) = do partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -41,11 +40,11 @@ instance Participant Types.Window where
partUnSubscribe (Window t) = generalUnSubscribe t partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Types.Window where instance SDLSubsystem Types.Window UserData where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
instance Participant Keyboard where instance Participant Keyboard UserData where
type Mesg Keyboard = KeyboardMessage type Mesg Keyboard UserData = KeyboardMessage
partSubscribers (Keyboard t) = do partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -55,24 +54,24 @@ instance Participant Keyboard where
partUnSubscribe (Keyboard t) = generalUnSubscribe t partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents
generalSubscribe generalSubscribe
:: TVar [(UUID, msg -> Affection ())] :: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection ()) -> (msg -> Affection UserData ())
-> Affection UUID -> Affection UserData UUID
generalSubscribe t funct = do generalSubscribe t funct = do
uuid <- genUUID uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid return uuid
generalUnSubscribe generalUnSubscribe
:: TVar [(UUID, msg -> Affection ())] :: TVar [(UUID, msg -> Affection UserData ())]
-> UUID -> UUID
-> Affection () -> Affection UserData ()
generalUnSubscribe t uuid = generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, msg -> Affection ()) -> UUID -> Bool filterMsg :: (UUID, msg -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p filterMsg (u, _) p = u /= p

60
flake.lock
View file

@ -1,60 +0,0 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1694529238,
"narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "ff7b65b44d01cf9ba6a71320833626af21126384",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1700844339,
"narHash": "sha256-VRlPYk0eRn1ao75hoA99LGehYhxZH5RlkP1YXpVROHM=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "33576fdfce2d11204067d6cfa99a2f990ef2169a",
"type": "github"
},
"original": {
"owner": "NixOS",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",
"version": 7
}

54
flake.nix
View file

@ -1,54 +0,0 @@
{
description = "A game stub written in Haskell";
inputs = {
nixpkgs.url = "github:NixOS/nixpkgs";
flake-utils.url = "github:numtide/flake-utils";
};
outputs = { self, nixpkgs, flake-utils }:
flake-utils.lib.eachDefaultSystem (system:
let
pkgs = nixpkgs.legacyPackages.${system};
haskellPackages = pkgs.haskellPackages;
jailbreakUnbreak = pkg:
pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; }));
packageName = "affection";
in rec {
packages.${packageName} = # (ref:haskell-package-def)
haskellPackages.callCabal2nixWithOptions packageName self "--flag examples" {
# Dependency overrides go here
};
defaultPackage = self.packages.${system}.${packageName};
apps = {
example00 = {
type = "app";
program = "${self.packages.${system}.${packageName}}/bin/example00";
};
example01 = {
type = "app";
program = "${self.packages.${system}.${packageName}}/bin/example01";
};
example02 = {
type = "app";
program = "${self.packages.${system}.${packageName}}/bin/example02";
};
};
devShell = haskellPackages.shellFor {
packages = p: [ defaultPackage ];
withHoogle = true;
buildInputs = with haskellPackages; [
haskell-language-server
ghcid
cabal-install
] ++ (builtins.attrValues self.packages.${system});
};
});
}

9
notes/TODO.md Normal file
View file

@ -0,0 +1,9 @@
# TODO
Implement following things in approximately this Order:
* Message bus
* Console
* GUI
* Framework
* Everything else

124
shell.nix
View file

@ -1,7 +1,123 @@
{ pkgs ? import <nixpkgs> {}}: { nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
let let
affection = pkgs.haskellPackages.callCabal2nix "affection" (gitignore ./.) {};
gitignore = dir: pkgs.nix-gitignore.gitignoreSource [] dir; inherit (nixpkgs) pkgs;
nanovgNeko = with haskellPackages; callPackage (
{ mkDerivation, base, bytestring, c2hs, containers, glew
, hspec, inline-c, libGL, libGLU, QuickCheck, stdenv, text, vector
}:
mkDerivation {
pname = "nanovg";
version = "0.6.0.0";
src = ../nanovg-hs;
isLibrary = true;
isExecutable = true;
doCheck = false;
libraryHaskellDepends = [ base bytestring containers text vector ];
librarySystemDepends = [ glew libGL libGLU ];
libraryPkgconfigDepends = [ glew ];
libraryToolDepends = [ c2hs ];
testHaskellDepends = [ base containers hspec inline-c QuickCheck ];
homepage = "https://github.com/cocreature/nanovg-hs";
description = "Haskell bindings for nanovg";
license = stdenv.lib.licenses.isc;
}) {};
glib = with haskellPackages; callPackage(
{ mkDerivation, base, bytestring, Cabal, containers, glib
, stdenv, text, utf8-string
}:
mkDerivation {
pname = "glib";
version = "0.13.6.0";
sha256 = "4e71062c6a458440294d820e21449aa4666deed2ea233ef5915da7c1d4aee8eb";
setupHaskellDepends = [ base Cabal gtk2hs-buildtools ];
libraryHaskellDepends = [
base bytestring containers text utf8-string
];
libraryPkgconfigDepends = [ pkgs.glib ];
homepage = "http://projects.haskell.org/gtk2hs/";
description = "Binding to the GLIB library for Gtk2Hs";
license = stdenv.lib.licenses.lgpl21;
}) {};
gtk2hs-buildtools = with haskellPackages; callPackage(
{ mkDerivation, alex, array, base, Cabal, containers, directory
, filepath, happy, hashtables, pretty, process, random, stdenv
}:
mkDerivation {
pname = "gtk2hs-buildtools";
version = "0.13.4.0";
src = ../gtk2hs/tools;
isLibrary = true;
isExecutable = true;
enableSeparateDataOutput = true;
libraryHaskellDepends = [
array base Cabal containers directory filepath hashtables pretty
process random
];
libraryToolDepends = [ alex happy ];
executableHaskellDepends = [ base ];
homepage = "http://projects.haskell.org/gtk2hs/";
description = "Tools to build the Gtk2Hs suite of User Interface libraries";
license = stdenv.lib.licenses.gpl2;
}) {};
sdl2Nek0 = with haskellPackages; callPackage(
{ mkDerivation, base, bytestring, deepseq, exceptions, linear, SDL2
, StateVar, stdenv, text, transformers, vector, weigh
}:
mkDerivation {
pname = "sdl2";
version = "2.4.1.0";
sha256 = "21a569c0c19f8ff2bbe1cf1d3eb32f65e8143806de353cedd240df5e9d088b5c";
isLibrary = true;
isExecutable = true;
enableSeparateDataOutput = true;
libraryHaskellDepends = [
base bytestring exceptions linear StateVar text transformers vector
];
librarySystemDepends = [ SDL2 ];
libraryPkgconfigDepends = [ SDL2 ];
testHaskellDepends = [ base deepseq linear vector weigh ];
doCheck = false;
description = "Both high- and low-level bindings to the SDL library (version 2.0.4+).";
license = stdenv.lib.licenses.bsd3;
}) {};
f = { mkDerivation, base, bytestring, clock, containers, deepseq
, linear, matrix, monad-loops, monad-parallel, mtl
, OpenGL, random, stdenv, stm, text, uuid, vector
}:
mkDerivation {
pname = "affection";
version = "0.0.0.9";
src = ./.;
configureFlags = [ "-fexamples" ];
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
base bytestring clock containers glib linear monad-loops
monad-parallel mtl OpenGL sdl2Nek0 stm text uuid vector
];
executableHaskellDepends = [
base containers deepseq linear matrix nanovgNeko OpenGL random sdl2Nek0 stm
];
homepage = "https://github.com/nek0/affection#readme";
description = "A simple Game Engine using SDL";
license = stdenv.lib.licenses.lgpl3;
};
haskellPackages = if compiler == "default"
then pkgs.haskellPackages
else pkgs.haskell.packages.${compiler};
variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
drv = variant (haskellPackages.callPackage f {});
in in
affection.env
if pkgs.lib.inNixShell then drv.env else drv

230
src/Affection.hs
View file

@ -1,8 +1,5 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
module Affection module Affection
( withAffection ( withAffection
, get , get
@ -16,25 +13,15 @@ import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute) import qualified SDL.Raw.Video as SDL (glSetAttribute)
import qualified SDL.Raw.Enum as SDL import qualified SDL.Raw.Enum as SDL
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
import qualified Graphics.GL as GLRaw
import Foreign.Marshal.Array
import qualified Data.ByteString as B
import Data.String (fromString)
import System.Clock import System.Clock
import Control.Monad.Loops import Control.Monad.Loops
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource import Control.Monad.IO.Class (liftIO)
-- internal imports import Foreign.C.Types (CInt(..))
import Affection.Types as A import Affection.Types as A
import Affection.Class as A
import Affection.StateMachine as A import Affection.StateMachine as A
import Affection.Util as A import Affection.Util as A
import Affection.MessageBus as A import Affection.MessageBus as A
@ -42,163 +29,102 @@ import Affection.Subsystems as A
import Affection.Logging as A import Affection.Logging as A
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else. -- | Main function which bootstraps everything else.
withAffection withAffection
:: forall us. (Affectionate us) :: AffectionConfig us -- ^ Configuration of the Game and its engine.
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO () -> IO ()
withAffection AffectionConfig{..} = runResourceT $ do withAffection AffectionConfig{..} = do
liftIO $ logIO Debug "Affection starting" liftIO $ logIO Debug "Affection starting"
liftIO $ logIO Debug "Initializing SDL" liftIO $ logIO Debug "Initializing SDL"
-- intialiaze SDL -- intialiaze SDL
case initComponents of case initComponents of
All -> All ->
SDL.initializeAll SDL.initializeAll
Only is -> Only is ->
SDL.initialize is SDL.initialize is
-- give SDL render quality -- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking… -- just checking…
renderQuality <- SDL.get SDL.HintRenderScaleQuality do
when (renderQuality /= SDL.ScaleLinear) $ renderQuality <- SDL.get SDL.HintRenderScaleQuality
liftIO $ logIO Warn "Linear texture filtering not enabled!" when (renderQuality /= SDL.ScaleLinear) $
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer))) logIO Warn "Linear texture filtering not enabled!"
-- construct window -- construct window
liftIO $ logIO Debug "Creating Window(s)" liftIO $ logIO Debug "Creating Window(s)"
windows <- windows <- zip (map fst windowConfigs) <$>
mapM mapM
(\(_, sdlWindowConfig, mode) -> do (\wc -> SDL.createWindow windowTitle (snd wc))
(windowKey, window) <- windowConfigs
allocate mapM_ (SDL.showWindow . snd) windows
(SDL.createWindow windowTitle sdlWindowConfig) _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
(\window -> do contexts <- zip (map fst windows) <$> mapM (SDL.glCreateContext . snd) windows
logIO Debug "Destroying Window" -- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs
SDL.destroyWindow window -- (w, h) = case canvasSize of
) -- Just (cw, ch) -> (cw, ch)
return $ AffectionWindow window windowKey mode -- Nothing -> (fromIntegral rw, fromIntegral rh)
) mapM_ (flip SDL.setWindowMode initScreenMode . snd) windows
windowConfigs
-- Show windows
mapM_ (SDL.showWindow . awWindow) windows
-- set modes of windows
mapM_ (\(AffectionWindow window _ mode) -> SDL.setWindowMode window mode) windows
-- Make GL context shareable
void $ SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
-- Create OpenGL contexts
contexts <-
mapM
(\(AffectionWindow window _ _) -> do
(contextKey, context) <-
allocate
(SDL.glCreateContext window)
(\context -> do
logIO Debug "Destroying context"
SDL.glDeleteContext context
)
return $ AffectionContext context contextKey
)
windows
-- sync updates with monitor
-- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows -- SDL.swapInterval $= SDL.SynchronizedUpdates -- <- causes Problems with windows
-- print current used GL Version
version <- liftIO $ peekArray0 (0 :: Word8) =<< GLRaw.glGetString GLRaw.GL_VERSION
liftIO $ print (B.pack version)
-- get current time
liftIO $ logIO Debug "Getting Time" liftIO $ logIO Debug "Getting Time"
execTime <- liftIO $ getTime Monotonic -- get current time
execTime <- getTime Monotonic
liftIO $ logIO Debug "Loading initial data container" liftIO $ logIO Debug "Loading initial data container"
initContainer <- (\x -> AffectionData
-- construct game data object from provided Affectionate instance { quitEvent = False
(gameDataKey, gameData) <- , userState = x
allocate , drawWindows = windows
(liftIO $ loadState @us) , glContext = contexts
(liftIO . cleanUp) , screenMode = initScreenMode
-- build state container , elapsedTime = 0
let initContainer = AffectionData , deltaTime = 0
{ drawWindows = windows , sysTime = execTime
, glContext = contexts , pausedTime = False
, elapsedTime = 0 }) <$> loadState
, deltaTime = 0 (_, nState) <- runStateT ( A.runState $ do
, sysTime = execTime liftIO $ logIO Debug "Starting Loop"
, pausedTime = False preLoop
} whileM_ (not . A.quitEvent <$> get)
-- initialize and run state
void $ liftIO $ runAffection initContainer
(do (do
liftIO $ logIO Debug "Running Pre-Loop stage" -- get state
ad <- get
-- run preLoop function from Affectionate -- Measure time difference form last run
preLoop gameData now <- liftIO $ getTime Monotonic
liftIO $ logIO Debug "Starting Loop" let lastTime = sysTime ad
whileM_ (hasNextStep gameData) -- compute dt and update elapsedTime
(do let !dt = fromIntegral
-- get state (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
ad <- get !ne = elapsedTime ad + dt
put $ ad
-- Measure time difference form last run { elapsedTime = ne
now <- liftIO $ getTime Monotonic , deltaTime = dt
let lastTime = sysTime ad }
-- poll events
-- compute dt and update elapsedTime evs <- preHandleEvents =<< liftIO SDL.pollEvents
let dt = fromIntegral -- handle events
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) eventLoop evs
ne = elapsedTime ad + dt -- execute user defined update loop
unless (pausedTime ad) (updateLoop dt)
-- update state data object with new time values -- execute user defined draw loop
put $ ad liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
{ elapsedTime = ne drawLoop
, deltaTime = dt liftIO GL.flush
} -- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . snd) windows
-- poll events -- save new time
liftIO SDL.pumpEvents ad3 <- get
evs <- preHandleEvents =<< liftIO SDL.pollEvents when (sysTime ad == sysTime ad3) (
put ad3
-- handle events { sysTime = now
handleEvents gameData evs }
)
-- execute user defined update loop )
unless (pausedTime ad) (update gameData dt) ) initContainer
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw gameData
liftIO GL.flush
-- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . awWindow) windows
-- save new time
ad3 <- get
when (sysTime ad == sysTime ad3) (
put ad3
{ sysTime = now
}
)
)
)
-- Cleanup works
liftIO $ logIO Debug "Loop ended. Cleaning" liftIO $ logIO Debug "Loop ended. Cleaning"
release gameDataKey cleanUp $ userState nState
-- mapM_ (SDL.glDeleteContext . snd) contexts liftIO $ logIO Debug "Destroying Window"
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.destroyWindow . snd) windows
-- SDL.quit -- <- This causes segfaults depending on hardware -- SDL.quit -- <- This causes segfaults depending on hardware
liftIO $ logIO Debug "This is the end" liftIO $ logIO Debug "This is the end"
runAffection
:: AffectionData
-> AffectionState AffectionData ResIO a
-> IO (a, AffectionData)
runAffection initialState a = runResourceT $ runStateT (A.runState a) initialState

21
src/Affection/Class.hs
View file

@ -1,21 +0,0 @@
module Affection.Class where
import qualified SDL
import Affection.Types as A
class Affectionate a where
loadState :: IO a
preLoop :: a -> Affection ()
handleEvents :: a -> [SDL.EventPayload] -> Affection ()
update :: a -> Double -> Affection ()
draw :: a -> Affection ()
cleanUp :: a -> IO ()
hasNextStep :: a -> Affection Bool

22
src/Affection/Logging.hs
View file

@ -3,8 +3,6 @@
-- from "Debug.Trace". -- from "Debug.Trace".
module Affection.Logging where module Affection.Logging where
import qualified Data.Text as T
import Debug.Trace import Debug.Trace
-- | The log level definition -- | The log level definition
@ -17,38 +15,38 @@ data LogLevel
-- | Pure logging function -- | Pure logging function
log log
:: LogLevel -- ^ Log level to log to :: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string -> String -- ^ The message string
-> a -- ^ Arbitrary datatype to return -> a -- ^ Arbitrary datatype to return
-> a -- ^ Returned data -> a -- ^ Returned data
#if defined(VERBOSE) #if defined(VERBOSE)
log Verbose s = trace ("VERBOSE: " ++ T.unpack s) log Verbose s = trace ("VERBOSE: " ++ s)
#endif #endif
#if defined(DEBUG) || defined(VERBOSE) #if defined(DEBUG) || defined(VERBOSE)
log Debug s = trace ("DEBUG: " ++ T.unpack s) log Debug s = trace ("DEBUG: " ++ s)
#endif #endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Warn s = trace ("WARN: " ++ T.unpack s) log Warn s = trace ("WARN: " ++ s)
#endif #endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Error s = trace ("ERROR: " ++ T.unpack s) log Error s = trace ("ERROR: " ++ s)
#endif #endif
log _ _ = id log _ _ = id
-- | Manadic logging function residing in the 'IO' Monad -- | Manadic logging function residing in the 'IO' Monad
logIO logIO
:: LogLevel -- ^ Log level to log to :: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string -> String -- ^ The message string
-> IO () -> IO ()
#if defined(VERBOSE) #if defined(VERBOSE)
logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s) logIO Verbose s = traceIO ("VERBOSE: " ++ s)
#endif #endif
#if defined(DEBUG) || defined(VERBOSE) #if defined(DEBUG) || defined(VERBOSE)
logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s) logIO Debug s = traceIO ("DEBUG: " ++ s)
#endif #endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE) #if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Warn s = traceIO ("WARN: " ++ T.unpack s) logIO Warn s = traceIO ("WARN: " ++ s)
#endif #endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE) #if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Error s = traceIO ("ERROR: " ++ T.unpack s) logIO Error s = traceIO ("ERROR: " ++ s)
#endif #endif
logIO _ _ = return () logIO _ _ = return ()

3
src/Affection/MessageBus.hs
View file

@ -1,6 +1,9 @@
module Affection.MessageBus module Affection.MessageBus
( module M ( module M
, module Msg
) where ) where
import Affection.MessageBus.Class as M import Affection.MessageBus.Class as M
import Affection.MessageBus.Message as M import Affection.MessageBus.Message as M
import Affection.MessageBus.Message as Msg

22
src/Affection/MessageBus/Class.hs
View file

@ -17,30 +17,28 @@ import Control.Monad.IO.Class (liftIO)
import Data.UUID import Data.UUID
import Data.UUID.V4 import Data.UUID.V4
import Data.String as S (fromString)
import Affection.Logging import Affection.Logging
-- | This typeclass defines the behaviour of a participant in the message system -- | This typeclass defines the behaviour of a participant in the message system
class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
-- | Message datatype -- | Message datatype
type Mesg prt :: * type Mesg prt us :: *
-- | Function to get the list of subscribers from the participant -- | Function to get the list of subscribers from the participant
partSubscribers partSubscribers
:: prt :: prt
-- ^ the 'Participant''s subscriber storage -- ^ the 'Participant''s subscriber storage
-> Affection [Mesg prt -> Affection ()] -> Affection us [Mesg prt us -> Affection us ()]
-- ^ List of Subscriber functions -- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events -- | Subscribe to the 'Participant''s events
partSubscribe partSubscribe
:: prt :: prt
-- ^ The 'Participant''s subscriber storage -- ^ The 'Participant''s subscriber storage
-> (Mesg prt -> Affection ()) -> (Mesg prt us -> Affection us ())
-- ^ What to do in case of a 'Message' -- ^ What to do in case of a 'Message'
-- (Subscriber function) -- (Subscriber function)
-> Affection UUID -> Affection us UUID
-- ^ 'UUID' of the registered subscriber Function -- ^ 'UUID' of the registered subscriber Function
-- | Unsubscribe a Subscriber function from Participant -- | Unsubscribe a Subscriber function from Participant
@ -49,20 +47,20 @@ class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
-- ^ The 'Participant''s subscriber storage to unsubscribe from -- ^ The 'Participant''s subscriber storage to unsubscribe from
-> UUID -> UUID
-- ^ The subscriber function's 'UUID' -- ^ The subscriber function's 'UUID'
-> Affection () -> Affection us ()
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers -- | Get the 'Participant' to emit a 'Message' on all of its subscribers
partEmit partEmit
:: prt :: prt
-- ^ The 'Participant''s subscriber storage -- ^ The 'Participant''s subscriber storage
-> Mesg prt -> Mesg prt us
-- ^ The 'Message' to emit -- ^ The 'Message' to emit
-> Affection () -> Affection us ()
partEmit p m = do partEmit p m = do
liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m) liftIO $ logIO Verbose $ "Emitting message: " ++ show m
l <- partSubscribers p l <- partSubscribers p
mapM_ ($ m) l mapM_ ($ m) l
-- | Helper function to generate new 'UUID's -- | Helper function to generate new 'UUID's
genUUID :: Affection UUID genUUID :: Affection us UUID
genUUID = liftIO nextRandom genUUID = liftIO nextRandom

12
src/Affection/StateMachine.hs
View file

@ -7,14 +7,14 @@ import Affection.Types
import qualified SDL import qualified SDL
-- | Typeclass for simple scaffolding of a state machine -- | Typeclass for simple scaffolding of a state machine
class StateMachine us a where class StateMachine a us where
-- | State load routine -- | State load routine
smLoad :: a -> us -> Affection () smLoad :: a -> Affection us ()
-- | state update routine -- | state update routine
smUpdate :: a -> us -> Double -> Affection () smUpdate :: a -> Double -> Affection us ()
-- | State event handler routine -- | State event handler routine
smEvent :: a -> us -> [SDL.EventPayload] -> Affection () smEvent :: a -> [SDL.EventPayload] -> Affection us ()
-- | State draw routine -- | State draw routine
smDraw :: a -> us -> Affection () smDraw :: a -> Affection us ()
-- | State clean routine -- | State clean routine
smClean :: a -> us -> Affection () smClean :: a -> Affection us ()

23
src/Affection/Subsystems/AffectionJoystick.hs
View file

@ -13,7 +13,6 @@ import Control.Monad (filterM)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.String as S (fromString)
import Foreign.C.Types (CInt(..)) import Foreign.C.Types (CInt(..))
@ -22,15 +21,15 @@ import qualified SDL
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's -- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
-- and emits appropriate 'JoystickMessage's -- and emits appropriate 'JoystickMessage's
consumeSDLJoystickEvents consumeSDLJoystickEvents
:: forall am. (Participant am, Mesg am ~ JoystickMessage) :: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
=> am -- ^ The message system participant => am -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events -> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLJoystickEvents am = doConsume consumeSDLJoystickEvents am = doConsume
where where
doConsume doConsume
:: [SDL.EventPayload] :: [SDL.EventPayload]
-> Affection [SDL.EventPayload] -> Affection us [SDL.EventPayload]
doConsume [] = return [] doConsume [] = return []
doConsume (e:es) = do doConsume (e:es) = do
ts <- getElapsedTime ts <- getElapsedTime
@ -81,14 +80,13 @@ consumeSDLJoystickEvents am = doConsume
joystickAutoConnect joystickAutoConnect
:: JoystickMessage -- ^ Any 'JoystickMessage' will do, :: JoystickMessage -- ^ Any 'JoystickMessage' will do,
-- but listens only on 'MsgJoystickDevice' messages -- but listens only on 'MsgJoystickDevice' messages
-> Affection (Maybe SDL.Joystick) -> Affection us (Maybe SDL.Joystick)
-- ^ Returns a joystick descriptor, if successful -- ^ Returns a joystick descriptor, if successful
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$> [descr] <- V.toList <$>
(V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$> (V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
SDL.availableJoysticks) SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <> logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
fromString (show descr)
Just <$> SDL.openJoystick descr Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing joystickAutoConnect _ = return Nothing
@ -98,20 +96,19 @@ joystickAutoDisconnect
:: [SDL.Joystick] -- ^ List of Joystick descriptors :: [SDL.Joystick] -- ^ List of Joystick descriptors
-> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens -> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
-- specifically to 'MsgJoystickDevice' messages -- specifically to 'MsgJoystickDevice' messages
-> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors -> Affection us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) = joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
liftIO $ do liftIO $ do
joyIds <- mapM SDL.getJoystickID js joyIds <- mapM SDL.getJoystickID js
logIO Verbose $ "These are the Joysticks connected: " <> logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
fromString (show joyIds)
d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
if not (null d) if not (null d)
then do then do
logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d) logIO Verbose $ "disconnected joysticks: " ++ show (head d)
logIO Verbose $ "Disconnecting Joystick " <> fromString (show which) logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick (head d) SDL.closeJoystick (head d)
njoys <- filterM (\j -> return $ head d /= j) js njoys <- filterM (\j -> return $ head d /= j) js
logIO Verbose $ "returning joysticks: " <> fromString (show njoys) logIO Verbose $ "returning joysticks: " ++ show njoys
return njoys return njoys
else do else do
logIO Error $ "Error while disconnecting Joystick" logIO Error $ "Error while disconnecting Joystick"

4
src/Affection/Subsystems/AffectionKeyboard.hs
View file

@ -13,10 +13,10 @@ import qualified SDL
-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's -- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
-- and emits appropriate 'KeyboardMessage's -- and emits appropriate 'KeyboardMessage's
consumeSDLKeyboardEvents consumeSDLKeyboardEvents
:: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage) :: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
=> ak -- ^ The message system participant => ak -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events -> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL Events -> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events
consumeSDLKeyboardEvents ak = doConsume consumeSDLKeyboardEvents ak = doConsume
where where
doConsume [] = return [] doConsume [] = return []

6
src/Affection/Subsystems/AffectionMouse.hs
View file

@ -15,15 +15,15 @@ import qualified SDL
-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's -- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's
-- and emits appropriate 'MouseMessage's -- and emits appropriate 'MouseMessage's
consumeSDLMouseEvents consumeSDLMouseEvents
:: forall am. (Participant am, Mesg am ~ MouseMessage) :: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
=> am -- ^ The message system participant => am -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events -> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLMouseEvents am = doConsume consumeSDLMouseEvents am = doConsume
where where
doConsume doConsume
:: [SDL.EventPayload] :: [SDL.EventPayload]
-> Affection [SDL.EventPayload] -> Affection us [SDL.EventPayload]
doConsume [] = return [] doConsume [] = return []
doConsume (e:es) = do doConsume (e:es) = do
ts <- getElapsedTime ts <- getElapsedTime

8
src/Affection/Subsystems/AffectionWindow.hs
View file

@ -15,16 +15,16 @@ import qualified SDL
-- | Helper function that consumes all Window-related 'SDL.EventPayload's -- | Helper function that consumes all Window-related 'SDL.EventPayload's
-- and emits appropriate 'WindowMessage's. -- and emits appropriate 'WindowMessage's.
consumeSDLWindowEvents consumeSDLWindowEvents
:: forall aw. (Participant aw, Mesg aw ~ WindowMessage) :: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
=> aw -- ^ The message system participant => aw -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events -> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events -> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLWindowEvents aw = doConsume consumeSDLWindowEvents aw = doConsume
where where
doConsume doConsume
:: (Mesg aw ~ WindowMessage) :: (Mesg aw us ~ WindowMessage)
=> [SDL.EventPayload] => [SDL.EventPayload]
-> Affection [SDL.EventPayload] -> Affection us [SDL.EventPayload]
doConsume [] = return [] doConsume [] = return []
doConsume (e:es) = do doConsume (e:es) = do
ts <- getElapsedTime ts <- getElapsedTime

4
src/Affection/Subsystems/Class.hs
View file

@ -7,7 +7,7 @@ import Affection.Types
import qualified SDL import qualified SDL
-- | This class denotes a Subsystem to be part of SDL -- | This class denotes a Subsystem to be part of SDL
class SDLSubsystem s where class SDLSubsystem s us where
-- | Consume the given 'SDL.EventPayload's and return only those not -- | Consume the given 'SDL.EventPayload's and return only those not
-- recognised -- recognised
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload] consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]

74
src/Affection/Types.hs
View file

@ -5,8 +5,6 @@ module Affection.Types
, AffectionData(..) , AffectionData(..)
, AffectionStateInner , AffectionStateInner
, AffectionState(..) , AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..) , InitComponents(..)
, Angle , Angle
-- | SDL reexports -- | SDL reexports
@ -25,7 +23,6 @@ import qualified Data.Text as T
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.State.Strict import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import qualified Control.Monad.Parallel as MP import qualified Control.Monad.Parallel as MP
import System.Clock (TimeSpec) import System.Clock (TimeSpec)
@ -38,12 +35,27 @@ data AffectionConfig us = AffectionConfig
-- ^ Window title -- ^ Window title
, windowConfigs :: , windowConfigs ::
[ [
( Word -- --^ Window identifier ( Word -- ^ Window identifier
, SDL.WindowConfig -- --^ Window config for given window , SDL.WindowConfig -- ^ Window config for given window
, SDL.WindowMode -- -- ^ Window mode to start in
) )
] ]
-- ^ Window configurations -- ^ Window configurations
, canvasSize :: Maybe (Int, Int)
-- ^ size of the texture canvas
, initScreenMode :: SDL.WindowMode
-- ^ Window mode to start in
, loadState :: IO us
-- ^ Provide your own load function to create this data.
, preLoop :: Affection us ()
-- ^ Actions to be performed, before loop starts
, eventLoop :: [SDL.EventPayload] -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, updateLoop :: Double -> Affection us ()
-- ^ Main update function. Takes fractions of a second as input.
, drawLoop :: Affection us ()
-- ^ Function for updating graphics.
, cleanUp :: us -> IO ()
-- ^ Provide your own finisher function to clean your data.
} }
-- | Components to initialize in SDL. -- | Components to initialize in SDL.
@ -52,36 +64,38 @@ data InitComponents
| Only [SDL.InitFlag] | Only [SDL.InitFlag]
-- | Main type for defining the look, feel and action of the whole application. -- | Main type for defining the look, feel and action of the whole application.
data AffectionData = AffectionData data AffectionData us = AffectionData
{ drawWindows :: [ AffectionWindow ] -- ^ SDL windows { quitEvent :: Bool -- ^ Loop breaker.
, glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts , userState :: us -- ^ State data provided by user
, elapsedTime :: Double -- ^ Elapsed time in seconds , drawWindows ::
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick [
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) ( Word -- ^ Window identifier
, pausedTime :: Bool -- ^ Should the update loop be executed? , SDL.Window -- ^ Window linked with identifier
)
] -- ^ SDL windows
, glContext ::
[
( Word -- ^ Window identifier
, SDL.GLContext -- ^ Associated OpenGL context
)
] -- ^ OpenGL rendering contexts
, screenMode :: SDL.WindowMode -- ^ current screen mode
, elapsedTime :: Double -- ^ Elapsed time in seconds
, deltaTime :: Double -- ^ Elapsed time in seconds since last tick
, sysTime :: TimeSpec -- ^ System time (NOT the time on the clock)
, pausedTime :: Bool -- ^ Should the update loop be executed?
} }
-- | Inner 'StateT' monad for the update state -- | Inner 'StateT' monad for the update state
type AffectionStateInner sd m = StateT sd m type AffectionStateInner us a = StateT us a
-- | Affection's state monad -- | Affection's state monad
newtype AffectionState sd m a = AffectionState newtype AffectionState us m a = AffectionState
{ runState :: AffectionStateInner sd m a } { runState :: AffectionStateInner us m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource) deriving (Functor, Applicative, Monad, MonadIO, MonadState us)
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m) instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m)
type Affection a = AffectionState AffectionData ResIO a type Affection us a = AffectionState (AffectionData us) IO a
type Angle = Double type Angle = Double
data AffectionWindow = AffectionWindow
{ awWindow :: SDL.Window
, awReleaseKey :: ReleaseKey
, awMode :: SDL.WindowMode
}
data AffectionContext = AffectionContext
{ acContext :: SDL.GLContext
, acReleaseKey :: ReleaseKey
}

78
src/Affection/Util.hs
View file

@ -10,16 +10,26 @@ import qualified Graphics.Rendering.OpenGL as GL
import System.Clock import System.Clock
import Data.String (fromString)
import Data.List (find)
import Control.Monad.State import Control.Monad.State
-- | Prehandle SDL events -- | Prehandle SDL events
preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload] preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
preHandleEvents evs = preHandleEvents evs =
return $ map SDL.eventPayload evs return $ map SDL.eventPayload evs
-- | Return the userstate to the user
getAffection :: Affection us us
getAffection = gets userState
-- | Put altered user state back
putAffection
:: us -- User state
-> Affection us ()
putAffection us = do
ad <- get
put $ ad
{ userState = us }
-- | block a thread for a specified amount of time -- | block a thread for a specified amount of time
delaySec delaySec
:: Int -- ^ Number of seconds :: Int -- ^ Number of seconds
@ -27,54 +37,46 @@ delaySec
delaySec dur = SDL.delay (fromIntegral $ dur * 1000) delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-- | Get time since start but always the same in the current tick. -- | Get time since start but always the same in the current tick.
getElapsedTime :: Affection Double getElapsedTime :: Affection us Double
getElapsedTime = gets elapsedTime getElapsedTime = gets elapsedTime
-- | Get delta time (time elapsed from last frame) -- | Get delta time (time elapsed from last frame)
getDelta :: Affection Double getDelta :: Affection us Double
getDelta = gets deltaTime getDelta = gets deltaTime
-- | Quit the engine loop
quit :: Affection us ()
quit = do
ad <- get
put $ ad { quitEvent = True }
-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'. -- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
-- Pauses the Engine in the process. -- Pauses the Engine in the process.
toggleScreen :: Word -> Affection () toggleScreen :: Affection us ()
toggleScreen windowIdent = do toggleScreen = do
ad <- get ad <- get
(stop, alteredWindowList) <- foldM newMode <- case screenMode ad of
(\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do SDL.Windowed -> do
if stop || num == windowIdent mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) (drawWindows ad)
then do return SDL.FullscreenDesktop
newMode <- case mode of SDL.FullscreenDesktop -> do
SDL.FullscreenDesktop -> do mapM_ (flip SDL.setWindowMode SDL.Windowed . snd) (drawWindows ad)
liftIO $ SDL.setWindowMode window SDL.Windowed return SDL.Windowed
return SDL.Windowed x -> do
SDL.Windowed -> do liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop return x
return SDL.FullscreenDesktop now <- liftIO $ getTime Monotonic
x -> do put ad
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x)) { sysTime = now
return x , screenMode = newMode
return (True, resWindows ++ [aw { awMode = newMode }]) }
else
return (stop, resWindows ++ [aw])
)
(False, [])
(zip [0..] (drawWindows ad))
if stop
then do
now <- liftIO $ getTime Monotonic
put ad
{ sysTime = now
, drawWindows = alteredWindowList
}
else
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
-- | Fit the GL Viewport to Window size -- | Fit the GL Viewport to Window size
fitViewport fitViewport
:: Double -- ^ Image Ratio (width / height) :: Double -- ^ Image Ratio (width / height)
-> WindowMessage -- ^ Incoming Message. Listens only on -> WindowMessage -- ^ Incoming Message. Listens only on
-- 'MsgWindowResize' and ignores all others. -- 'MsgWindowResize' and ignores all others.
-> Affection () -> Affection us ()
fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
liftIO $ logIO Verbose "Fitting Viewport to size" liftIO $ logIO Verbose "Fitting Viewport to size"
if (fromIntegral w / fromIntegral h) > ratio if (fromIntegral w / fromIntegral h) > ratio