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*/
report.html
*.bak
.direnv/
result

44
affection.cabal
View file

@ -6,7 +6,7 @@ name: affection
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
version: 0.0.0.10
version: 0.0.0.9
synopsis: A simple Game Engine using SDL
description: This package contains Affection, a simple game engine
written in Haskell using SDL.
@ -16,7 +16,7 @@ homepage: https://github.com/nek0/affection#readme
license: LGPL-3
license-file: LICENSE
author: nek0
maintainer: nek0@nek0.eu
maintainer: nek0@chelnok.de
category: Game
build-type: Simple
extra-source-files: ChangeLog.md
@ -25,11 +25,11 @@ extra-source-files: ChangeLog.md
-- README.
-- extra-source-files:
cabal-version: >=2.0
cabal-version: >=1.10
source-repository head
type: git
location: https://gitea.nek0.eu/nek0/affection.git
location: https://github.com/nek0/affection
flag verbose
description: Enable verbose debug messages
@ -67,7 +67,6 @@ library
exposed-modules: Affection
, Affection.Logging
, Affection.Types
, Affection.Class
, Affection.StateMachine
, Affection.Util
, Affection.MessageBus
@ -85,39 +84,35 @@ library
, Affection.Subsystems.AffectionMouse
, Affection.Subsystems.AffectionJoystick
default-extensions: OverloadedStrings
, TypeFamilies
, AllowAmbiguousTypes
-- Modules included in this library but not exported.
-- other-modules:
-- LANGUAGE extensions used by modules in this package.
-- other-extensions: GADTs
-- , KindSignatures
-- , FlexibleInstances
-- , MultiParamTypeClasses
-- , UndecidableInstances
other-extensions: GADTs
, KindSignatures
, FlexibleInstances
, MultiParamTypeClasses
, UndecidableInstances
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -threaded -Wall
ghc-options: -Wall
-- Other library packages from which modules are imported.
build-depends: base >=4.9 && < 5
, sdl2 >= 2.5
, sdl2 >= 2.4 && < 2.5
, linear
, text
, mtl
, monad-loops
, monad-parallel
, containers
, clock >= 0.8
, clock
, glib
, bytestring
, OpenGL
, OpenGLRaw
, stm
, uuid
, vector
, resourcet
-- This example shows the message system. only makes sense when compiling with
-- verbose flag.
@ -127,11 +122,12 @@ executable example00
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base >=4.9 && < 5
, affection
, sdl2 >= 2.5
, sdl2
, stm
if !flag(examples)
else
buildable: False
-- A small game of life implementation
@ -142,9 +138,10 @@ executable example01
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base >=4.9 && < 5
, affection
, sdl2 >= 2.5
, sdl2
, stm
, OpenGL
, random
@ -153,7 +150,7 @@ executable example01
, matrix
, nanovg >= 0.6.0.0
, deepseq
if !flag(examples)
else
buildable: False
-- Another small game of life implementation
@ -164,9 +161,10 @@ executable example02
ghc-options: -threaded -Wall
default-language: Haskell2010
default-extensions: OverloadedStrings
if flag(examples)
build-depends: base >=4.9 && < 5
, affection
, sdl2 >= 2.5
, sdl2
, stm
, OpenGL
, random
@ -175,5 +173,5 @@ executable example02
, matrix
, nanovg >= 0.6.0.0
, deepseq
if !flag(examples)
else
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 TypeFamilies #-}
module Main where
import Affection as A
import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
import qualified SDL
import qualified SDL hiding (Window(..))
import Data.Maybe (isJust, fromJust)
import Data.String
data StateData = StateData
{ sdSubs :: Subsystems
, sdJoys :: MVar [SDL.Joystick]
, doNextStep :: MVar Bool
, sdJoys :: [SDL.Joystick]
}
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
{ subWindow :: Main.Window
, subMouse :: Main.Mouse
@ -36,13 +23,36 @@ data Subsystems = Subsystems
, subJoystick :: Main.Joystick
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection ())])
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
instance Participant Main.Window where
type Mesg Main.Window = WindowMessage
generalSubscribers
:: 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
@ -50,11 +60,11 @@ instance Participant Main.Window where
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Main.Window where
instance SDLSubsystem Main.Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse where
type Mesg Mouse = MouseMessage
instance Participant Mouse StateData where
type Mesg Mouse StateData = MouseMessage
partSubscribers (Mouse t) = generalSubscribers t
@ -62,11 +72,11 @@ instance Participant Mouse where
partUnSubscribe (Mouse t) = generalUnSubscribe t
instance SDLSubsystem Mouse where
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard where
type Mesg Keyboard = KeyboardMessage
instance Participant Keyboard StateData where
type Mesg Keyboard StateData = KeyboardMessage
partSubscribers (Keyboard t) = generalSubscribers t
@ -74,11 +84,11 @@ instance Participant Keyboard where
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard where
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
instance Participant Joystick where
type Mesg Joystick = JoystickMessage
instance Participant Joystick StateData where
type Mesg Joystick StateData = JoystickMessage
partSubscribers (Joystick t) = generalSubscribers t
@ -86,7 +96,7 @@ instance Participant Joystick where
partUnSubscribe (Joystick t) = generalUnSubscribe t
instance SDLSubsystem Joystick where
instance SDLSubsystem Joystick StateData where
consumeSDLEvents = consumeSDLJoystickEvents
main :: IO ()
@ -99,14 +109,21 @@ main = do
[
( 0
, SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ 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
load :: IO StateData
@ -117,80 +134,57 @@ load =
<*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO [])
)
<*> newMVar []
<*> newMVar True
<*> return []
pre :: StateData -> Affection ()
pre sd = do
_ <- partSubscribe (subKeyboard $ sdSubs sd) (exitOnQ (doNextStep sd))
_ <- partSubscribe (subWindow $ sdSubs sd) (exitOnWindowClose (doNextStep sd))
_ <- partSubscribe (subJoystick $ sdSubs sd) (joyConnectDisconnect (sdJoys sd))
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
return ()
exitOnQ :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnQ nextStep (MsgKeyboardEvent _ _ _ _ sym) =
exitOnQ :: KeyboardMessage -> Affection StateData ()
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeQ -> do
liftIO $ logIO Debug "Yo dog I heard..."
void $ liftIO $ swapMVar nextStep False
quit
_ -> return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose nextStep wm =
exitOnWindowClose :: WindowMessage -> Affection StateData ()
exitOnWindowClose wm =
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO Debug "I heard another one..."
void $ liftIO $ swapMVar nextStep False
quit
_ -> return ()
joyConnectDisconnect :: MVar [SDL.Joystick] -> JoystickMessage -> Affection ()
joyConnectDisconnect mvjs msg = do
joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
joyConnectDisconnect msg = do
mj <- joystickAutoConnect msg
when (isJust mj) $ do
js <- liftIO $ readMVar mvjs
void $ liftIO $ swapMVar mvjs (fromJust mj : js)
js <- liftIO $ readMVar mvjs
njs <- joystickAutoDisconnect js msg
liftIO $ putMVar mvjs njs
sd <- getAffection
putAffection sd
{ sdJoys = fromJust mj : sdJoys sd
}
sd <- getAffection
njs <- joystickAutoDisconnect (sdJoys sd) msg
putAffection sd
{ sdJoys = njs
}
handle :: StateData -> [SDL.EventPayload] -> Affection ()
handle sd es = do
let (Subsystems a b c d) = sdSubs sd
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
(Subsystems a b c d) <- sdSubs <$> getAffection
leftovers <- consumeSDLEvents a
=<< consumeSDLEvents b
=<< consumeSDLEvents c
=<< consumeSDLEvents d es
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " <> fromString (show e))
leftovers
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
update :: StateData -> Double -> Affection ()
update _ _ = return ()
update _ = return ()
draw :: StateData -> Affection ()
draw _ = return ()
draw = return ()
clean :: StateData -> IO ()
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 #-}
import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when)
import Control.DeepSeq (deepseq)
import Data.Matrix as M
import qualified Data.Set as S
import Data.String
import System.Random (randomRIO)
import NanoVG hiding (V2(..))
import Linear
import Foreign.C.Types (CInt(..))
-- internal imports
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"
glewInit :: IO CInt
@ -46,16 +40,23 @@ main = do
[
( 0
, SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
, SDL.windowInitialSize = SDL.V2 600 600
, 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
load :: IO UserData
@ -64,146 +65,156 @@ load = do
liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit
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"
nanoCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
let fullMatrix = fromList 60 60 randList
-- logIO A.Debug $ prettyMatrix fullMatrix
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection ())])
step <- newMVar True
(\life food time -> UserData
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection UserData ())])
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection UserData ())])
return $ UserData
{ subsystems = Subsystems
(Window empty1)
(Keyboard empty3)
, lifeMat = life
, foodMat = food
, timeMat = time
, lifeMat = fullMatrix
, foodMat = fromList 60 60 (repeat 10)
, timeMat = M.zero 60 60
, nano = nanoCtx
, doNextStep = step
}
)
<$> newMVar fullMatrix
<*> (newMVar (fromList 60 60 (repeat 10)))
<*> (newMVar (M.zero 60 60))
pre :: UserData -> Affection ()
pre ud = do
void $ partSubscribe (subKeyboard $ subsystems ud) (exitOnEsc (doNextStep ud))
void $ partSubscribe (subKeyboard $ subsystems ud) (reloadOnR ud)
void $ partSubscribe (subKeyboard $ subsystems ud) showFPS
void $ partSubscribe (subKeyboard $ subsystems ud) toggleFullScreen
void $ partSubscribe (subWindow $ subsystems ud) (exitOnWindowClose (doNextStep ud))
void $ partSubscribe (subWindow $ subsystems ud) (fitViewport (600/600))
pre :: Affection UserData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ subsystems sd) exitOnEsc
_ <- partSubscribe (subKeyboard $ subsystems sd) reloadOnR
_ <- partSubscribe (subKeyboard $ subsystems sd) showFPS
_ <- partSubscribe (subKeyboard $ subsystems sd) toggleFullScreen
_ <- 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)
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen 0
| SDL.keysymKeycode sym == SDL.KeycodeF11 = toggleScreen
| otherwise = return ()
toggleFullScreen _ = return ()
exitOnEsc :: MVar Bool -> KeyboardMessage -> Affection ()
exitOnEsc step (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
exitOnEsc :: KeyboardMessage -> Affection UserData ()
exitOnEsc (MsgKeyboardEvent _ _ SDL.Pressed False sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Yo dog I heard..."
void $ liftIO $ swapMVar step False
quit
_ -> return ()
exitOnEsc _ _ = return ()
exitOnEsc _ = return ()
reloadOnR :: UserData -> KeyboardMessage -> Affection ()
reloadOnR ud (MsgKeyboardEvent _ _ _ _ sym) =
reloadOnR :: KeyboardMessage -> Affection UserData ()
reloadOnR (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeR -> reload ud
SDL.KeycodeR -> reload
_ -> return ()
reloadOnR _ = return ()
reload :: UserData -> Affection ()
reload ud = do
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0 .. (3599 :: Int)]
reload :: Affection UserData ()
reload = do
ud <- getAffection
now <- getElapsedTime
randList <- liftIO $ mapM (\_ -> randomRIO (0,1)) [0..3599]
let fullMatrix = fromList 60 60 randList
void $ liftIO $ swapMVar (lifeMat ud) fullMatrix
void $ liftIO $ swapMVar (foodMat ud) (fromList 60 60 (repeat 10))
void $ liftIO $ swapMVar (timeMat ud) (M.zero 60 60)
putAffection ud
{ lifeMat = fullMatrix
, foodMat = fromList 60 60 (repeat 10)
, timeMat = M.zero 60 60
}
showFPS :: KeyboardMessage -> Affection ()
showFPS :: KeyboardMessage -> Affection UserData ()
showFPS (MsgKeyboardEvent _ _ _ _ sym) =
case SDL.keysymKeycode sym of
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " <> fromString (show (1 / dt))
liftIO $ logIO A.Debug $ "FPS: " ++ show (1 / dt)
_ -> return ()
showFPS _ = return ()
exitOnWindowClose :: MVar Bool -> WindowMessage -> Affection ()
exitOnWindowClose step wm =
exitOnWindowClose :: WindowMessage -> Affection UserData ()
exitOnWindowClose wm =
case wm of
MsgWindowClose _ _ -> do
liftIO $ logIO A.Debug "I heard another one..."
void $ liftIO $ swapMVar step False
quit
_ -> return ()
exitOnWindowClose _ = return ()
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud es = do
let (Subsystems a b) = subsystems ud
handle :: [SDL.EventPayload] -> Affection UserData ()
handle es = do
(Subsystems a b) <- subsystems <$> getAffection
_ <- consumeSDLEvents a =<< consumeSDLEvents b es
return ()
update :: UserData -> Double -> Affection ()
update ud _ = do
-- liftIO $ logIO A.Debug ("FPS: " <> fromString (show (1/dt)))
pastLife <- liftIO $ readMVar (lifeMat ud)
pastFood <- liftIO $ readMVar (foodMat ud)
pastTime <- liftIO $ readMVar (timeMat ud)
update :: Double -> Affection UserData ()
update _ = do
ud <- getAffection
newList <- mapM (\coord -> do
let x = (coord `mod` 60) + 1
y = (coord `div` 60) + 1
subm
| 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 =
(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 =
(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 =
(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 =
(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 =
(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 =
(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 =
(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 =
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) pastLife)
(submatrix (y - 1) (y + 1) (x - 1) (x + 1) (lifeMat ud))
life = countLife subm
if pastLife M.! (y, x) == 1
then if (life == 2 || life == 3) && pastFood M.! (y, x) > 0
then return (1, (pastFood M.! (y, x)) - 1, 0)
else return (0, pastFood M.! (y, x), 0)
else if life == 3 && pastFood M.! (y, x) > 0
then return (1, (pastFood M.! (y, x)) - 1, 0)
ret
| life == 0 && lifeMat ud M.! (y, x) == 0 =
( 0
, if timeMat ud M.! (y, x) >= 10
then min 10 (foodMat ud M.! (y, x) + 1)
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
( (0 :: Word)
, if pastTime M.! (y, x) > 10
then min 10 ((pastFood M.! (y, x)) + 1)
else min 10 (pastFood M.! (y, x))
, pastTime M.! (y, x) + 1
( 0
, if timeMat ud M.! (y, x) > 10
then min 10 ((foodMat ud M.! (y, x)) + 1)
else min 10 (foodMat ud M.! (y, x))
, timeMat ud M.! (y, x) + 1
)
) [0..3599]
let newLifeMat = fromList 60 60 (map (\(x, _, _) -> x) newList)
@ -211,21 +222,22 @@ update ud _ = do
newTimeMat = fromList 60 60 (map (\(_, _, x) -> x) newList)
if newLifeMat == M.zero 60 60
then
reload ud
else do
((newLifeMat, newFoodMat, newTimeMat) `deepseq` return ())
void $ liftIO $ swapMVar (lifeMat ud) newLifeMat
void $ liftIO $ swapMVar (timeMat ud) newTimeMat
reload
else
putAffection ((newLifeMat, newFoodMat, newTimeMat) `deepseq` ud)
{ lifeMat = newLifeMat
--, foodMat = newFoodMat
, timeMat = newTimeMat
}
countLife :: Matrix Word -> Word
countLife mat = res - (mat M.! (2, 2))
where
res = foldr (flip (+)) 0 mat
draw :: UserData -> Affection ()
draw ud = do
life <- liftIO $ readMVar (lifeMat ud)
food <- liftIO $ readMVar (foodMat ud)
draw :: Affection UserData ()
draw = do
ud <- getAffection
liftIO $ do
beginFrame (nano ud) 600 600 1
save (nano ud)
@ -233,7 +245,7 @@ draw ud = do
let x = coord `mod` 60
y = coord `div` 60
ctx = nano ud
mult = life M.! (x + 1, y + 1)
mult = lifeMat ud M.! (x + 1, y + 1)
-- logIO A.Debug $ show mult
beginPath ctx
rect ctx (fromIntegral $ x * 10) (fromIntegral $ y * 10) 10 10
@ -241,11 +253,10 @@ draw ud = do
then
fillColor ctx (rgba 255 255 255 255)
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
) [0..3599]
restore (nano ud)
endFrame (nano ud)
clean :: UserData -> IO ()
clean _ = return ()

37
examples/example01/Types.hs
View file

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

224
examples/example02/Main.hs
View file

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

37
examples/example02/Types.hs
View file

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

160
src/Affection.hs
View file

@ -1,8 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
module Affection
( withAffection
, get
@ -16,25 +13,15 @@ import qualified SDL
import qualified SDL.Raw.Video as SDL (glSetAttribute)
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 Control.Monad.Loops
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.Class as A
import Affection.StateMachine as A
import Affection.Util as A
import Affection.MessageBus as A
@ -42,144 +29,89 @@ import Affection.Subsystems as A
import Affection.Logging as A
import qualified Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..))
-- | Main function which bootstraps everything else.
withAffection
:: forall us. (Affectionate us)
=> AffectionConfig us -- ^ Configuration of the Game and its engine.
:: AffectionConfig us -- ^ Configuration of the Game and its engine.
-> IO ()
withAffection AffectionConfig{..} = runResourceT $ do
withAffection AffectionConfig{..} = do
liftIO $ logIO Debug "Affection starting"
liftIO $ logIO Debug "Initializing SDL"
-- intialiaze SDL
case initComponents of
All ->
SDL.initializeAll
Only is ->
SDL.initialize is
-- give SDL render quality
SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear
-- just checking…
do
renderQuality <- SDL.get SDL.HintRenderScaleQuality
when (renderQuality /= SDL.ScaleLinear) $
liftIO $ logIO Warn "Linear texture filtering not enabled!"
void $ liftIO (logIO Debug . fromString . show <$> (SDL.version :: IO (Integer, Integer, Integer)))
logIO Warn "Linear texture filtering not enabled!"
-- construct window
liftIO $ logIO Debug "Creating Window(s)"
windows <-
windows <- zip (map fst windowConfigs) <$>
mapM
(\(_, sdlWindowConfig, mode) -> do
(windowKey, window) <-
allocate
(SDL.createWindow windowTitle sdlWindowConfig)
(\window -> do
logIO Debug "Destroying Window"
SDL.destroyWindow window
)
return $ AffectionWindow window windowKey mode
)
(\wc -> SDL.createWindow windowTitle (snd wc))
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
mapM_ (SDL.showWindow . snd) windows
_ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
contexts <- zip (map fst windows) <$> mapM (SDL.glCreateContext . snd) windows
-- let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfigs
-- (w, h) = case canvasSize of
-- Just (cw, ch) -> (cw, ch)
-- Nothing -> (fromIntegral rw, fromIntegral rh)
mapM_ (flip SDL.setWindowMode initScreenMode . snd) 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"
execTime <- liftIO $ getTime Monotonic
-- get current time
execTime <- getTime Monotonic
liftIO $ logIO Debug "Loading initial data container"
-- construct game data object from provided Affectionate instance
(gameDataKey, gameData) <-
allocate
(liftIO $ loadState @us)
(liftIO . cleanUp)
-- build state container
let initContainer = AffectionData
{ drawWindows = windows
initContainer <- (\x -> AffectionData
{ quitEvent = False
, userState = x
, drawWindows = windows
, glContext = contexts
, screenMode = initScreenMode
, elapsedTime = 0
, deltaTime = 0
, sysTime = execTime
, pausedTime = False
}
-- initialize and run state
void $ liftIO $ runAffection initContainer
(do
liftIO $ logIO Debug "Running Pre-Loop stage"
-- run preLoop function from Affectionate
preLoop gameData
}) <$> loadState
(_, nState) <- runStateT ( A.runState $ do
liftIO $ logIO Debug "Starting Loop"
whileM_ (hasNextStep gameData)
preLoop
whileM_ (not . A.quitEvent <$> get)
(do
-- get state
ad <- get
-- Measure time difference form last run
now <- liftIO $ getTime Monotonic
let lastTime = sysTime ad
-- compute dt and update elapsedTime
let dt = fromIntegral
let !dt = fromIntegral
(toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int))
ne = elapsedTime ad + dt
-- update state data object with new time values
!ne = elapsedTime ad + dt
put $ ad
{ elapsedTime = ne
, deltaTime = dt
}
-- poll events
liftIO SDL.pumpEvents
evs <- preHandleEvents =<< liftIO SDL.pollEvents
-- handle events
handleEvents gameData evs
eventLoop evs
-- execute user defined update loop
unless (pausedTime ad) (update gameData dt)
-- clear GL buffer >> execute user defined draw loop >> flush GL buffer
unless (pausedTime ad) (updateLoop dt)
-- execute user defined draw loop
liftIO $ GL.clear [GL.ColorBuffer, GL.DepthBuffer, GL.StencilBuffer]
draw gameData
drawLoop
liftIO GL.flush
-- actual displaying of newly drawn frame
mapM_ (SDL.glSwapWindow . awWindow) windows
mapM_ (SDL.glSwapWindow . snd) windows
-- save new time
ad3 <- get
when (sysTime ad == sysTime ad3) (
@ -188,17 +120,11 @@ withAffection AffectionConfig{..} = runResourceT $ do
}
)
)
)
-- Cleanup works
) initContainer
liftIO $ logIO Debug "Loop ended. Cleaning"
release gameDataKey
-- mapM_ (SDL.glDeleteContext . snd) contexts
-- mapM_ (SDL.destroyWindow . (\(_,y,_) -> y)) windows
cleanUp $ userState nState
liftIO $ logIO Debug "Destroying Window"
mapM_ (SDL.glDeleteContext . snd) contexts
mapM_ (SDL.destroyWindow . snd) windows
-- SDL.quit -- <- This causes segfaults depending on hardware
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".
module Affection.Logging where
import qualified Data.Text as T
import Debug.Trace
-- | The log level definition
@ -17,38 +15,38 @@ data LogLevel
-- | Pure logging function
log
:: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string
-> String -- ^ The message string
-> a -- ^ Arbitrary datatype to return
-> a -- ^ Returned data
#if defined(VERBOSE)
log Verbose s = trace ("VERBOSE: " ++ T.unpack s)
log Verbose s = trace ("VERBOSE: " ++ s)
#endif
#if defined(DEBUG) || defined(VERBOSE)
log Debug s = trace ("DEBUG: " ++ T.unpack s)
log Debug s = trace ("DEBUG: " ++ s)
#endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Warn s = trace ("WARN: " ++ T.unpack s)
log Warn s = trace ("WARN: " ++ s)
#endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
log Error s = trace ("ERROR: " ++ T.unpack s)
log Error s = trace ("ERROR: " ++ s)
#endif
log _ _ = id
-- | Manadic logging function residing in the 'IO' Monad
logIO
:: LogLevel -- ^ Log level to log to
-> T.Text -- ^ The message string
-> String -- ^ The message string
-> IO ()
#if defined(VERBOSE)
logIO Verbose s = traceIO ("VERBOSE: " ++ T.unpack s)
logIO Verbose s = traceIO ("VERBOSE: " ++ s)
#endif
#if defined(DEBUG) || defined(VERBOSE)
logIO Debug s = traceIO ("DEBUG: " ++ T.unpack s)
logIO Debug s = traceIO ("DEBUG: " ++ s)
#endif
#if defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Warn s = traceIO ("WARN: " ++ T.unpack s)
logIO Warn s = traceIO ("WARN: " ++ s)
#endif
#if defined(ERROR) || defined(WARN) || defined(DEBUG) || defined(VERBOSE)
logIO Error s = traceIO ("ERROR: " ++ T.unpack s)
logIO Error s = traceIO ("ERROR: " ++ s)
#endif
logIO _ _ = return ()

3
src/Affection/MessageBus.hs
View file

@ -1,6 +1,9 @@
module Affection.MessageBus
( module M
, module Msg
) where
import Affection.MessageBus.Class 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.V4
import Data.String as S (fromString)
import Affection.Logging
-- | 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
type Mesg prt :: *
type Mesg prt us :: *
-- | Function to get the list of subscribers from the participant
partSubscribers
:: prt
-- ^ the 'Participant''s subscriber storage
-> Affection [Mesg prt -> Affection ()]
-> Affection us [Mesg prt us -> Affection us ()]
-- ^ List of Subscriber functions
-- | Subscribe to the 'Participant''s events
partSubscribe
:: prt
-- ^ The 'Participant''s subscriber storage
-> (Mesg prt -> Affection ())
-> (Mesg prt us -> Affection us ())
-- ^ What to do in case of a 'Message'
-- (Subscriber function)
-> Affection UUID
-> Affection us UUID
-- ^ 'UUID' of the registered subscriber Function
-- | 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
-> UUID
-- ^ The subscriber function's 'UUID'
-> Affection ()
-> Affection us ()
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
partEmit
:: prt
-- ^ The 'Participant''s subscriber storage
-> Mesg prt
-> Mesg prt us
-- ^ The 'Message' to emit
-> Affection ()
-> Affection us ()
partEmit p m = do
liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
liftIO $ logIO Verbose $ "Emitting message: " ++ show m
l <- partSubscribers p
mapM_ ($ m) l
-- | Helper function to generate new 'UUID's
genUUID :: Affection UUID
genUUID :: Affection us UUID
genUUID = liftIO nextRandom

12
src/Affection/StateMachine.hs
View file

@ -7,14 +7,14 @@ import Affection.Types
import qualified SDL
-- | Typeclass for simple scaffolding of a state machine
class StateMachine us a where
class StateMachine a us where
-- | State load routine
smLoad :: a -> us -> Affection ()
smLoad :: a -> Affection us ()
-- | state update routine
smUpdate :: a -> us -> Double -> Affection ()
smUpdate :: a -> Double -> Affection us ()
-- | State event handler routine
smEvent :: a -> us -> [SDL.EventPayload] -> Affection ()
smEvent :: a -> [SDL.EventPayload] -> Affection us ()
-- | State draw routine
smDraw :: a -> us -> Affection ()
smDraw :: a -> Affection us ()
-- | 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 qualified Data.Vector as V
import Data.String as S (fromString)
import Foreign.C.Types (CInt(..))
@ -22,15 +21,15 @@ import qualified SDL
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
-- and emits appropriate 'JoystickMessage's
consumeSDLJoystickEvents
:: forall am. (Participant am, Mesg am ~ JoystickMessage)
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
=> am -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLJoystickEvents am = doConsume
where
doConsume
:: [SDL.EventPayload]
-> Affection [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime
@ -81,14 +80,13 @@ consumeSDLJoystickEvents am = doConsume
joystickAutoConnect
:: JoystickMessage -- ^ Any 'JoystickMessage' will do,
-- but listens only on 'MsgJoystickDevice' messages
-> Affection (Maybe SDL.Joystick)
-> Affection us (Maybe SDL.Joystick)
-- ^ Returns a joystick descriptor, if successful
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
[descr] <- V.toList <$>
(V.filter (\(SDL.JoystickDevice _ i) -> i == CInt which) <$>
SDL.availableJoysticks)
logIO Verbose $ "Connecting Joystick " <> fromString (show which) <> " " <>
fromString (show descr)
logIO Verbose $ "Connecting Joystick " ++ show which ++ " " ++ show descr
Just <$> SDL.openJoystick descr
joystickAutoConnect _ = return Nothing
@ -98,20 +96,19 @@ joystickAutoDisconnect
:: [SDL.Joystick] -- ^ List of Joystick descriptors
-> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
-- 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) =
liftIO $ do
joyIds <- mapM SDL.getJoystickID js
logIO Verbose $ "These are the Joysticks connected: " <>
fromString (show joyIds)
logIO Verbose $ "These are the Joysticks connected: " ++ show joyIds
d <- filterM (\j -> fmap (== which) (SDL.getJoystickID j)) js
if not (null d)
then do
logIO Verbose $ "disconnected joysticks: " <> fromString (show $ head d)
logIO Verbose $ "Disconnecting Joystick " <> fromString (show which)
logIO Verbose $ "disconnected joysticks: " ++ show (head d)
logIO Verbose $ "Disconnecting Joystick " ++ show which
SDL.closeJoystick (head d)
njoys <- filterM (\j -> return $ head d /= j) js
logIO Verbose $ "returning joysticks: " <> fromString (show njoys)
logIO Verbose $ "returning joysticks: " ++ show njoys
return njoys
else do
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
-- and emits appropriate 'KeyboardMessage's
consumeSDLKeyboardEvents
:: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
:: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
=> ak -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events
consumeSDLKeyboardEvents ak = doConsume
where
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
-- and emits appropriate 'MouseMessage's
consumeSDLMouseEvents
:: forall am. (Participant am, Mesg am ~ MouseMessage)
:: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
=> am -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLMouseEvents am = doConsume
where
doConsume
:: [SDL.EventPayload]
-> Affection [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
doConsume [] = return []
doConsume (e:es) = do
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
-- and emits appropriate 'WindowMessage's.
consumeSDLWindowEvents
:: forall aw. (Participant aw, Mesg aw ~ WindowMessage)
:: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
=> aw -- ^ The message system participant
-> [SDL.EventPayload] -- ^ Incoming events
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
consumeSDLWindowEvents aw = doConsume
where
doConsume
:: (Mesg aw ~ WindowMessage)
:: (Mesg aw us ~ WindowMessage)
=> [SDL.EventPayload]
-> Affection [SDL.EventPayload]
-> Affection us [SDL.EventPayload]
doConsume [] = return []
doConsume (e:es) = do
ts <- getElapsedTime

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

@ -7,7 +7,7 @@ import Affection.Types
import qualified 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
-- recognised
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]

66
src/Affection/Types.hs
View file

@ -5,8 +5,6 @@ module Affection.Types
, AffectionData(..)
, AffectionStateInner
, AffectionState(..)
, AffectionWindow(..)
, AffectionContext(..)
, InitComponents(..)
, Angle
-- | SDL reexports
@ -25,7 +23,6 @@ import qualified Data.Text as T
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Control.Monad.Trans.Resource
import qualified Control.Monad.Parallel as MP
import System.Clock (TimeSpec)
@ -38,12 +35,27 @@ data AffectionConfig us = AffectionConfig
-- ^ Window title
, windowConfigs ::
[
( Word -- --^ Window identifier
, SDL.WindowConfig -- --^ Window config for given window
, SDL.WindowMode -- -- ^ Window mode to start in
( Word -- ^ Window identifier
, SDL.WindowConfig -- ^ Window config for given window
)
]
-- ^ 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.
@ -52,9 +64,22 @@ data InitComponents
| Only [SDL.InitFlag]
-- | Main type for defining the look, feel and action of the whole application.
data AffectionData = AffectionData
{ drawWindows :: [ AffectionWindow ] -- ^ SDL windows
, glContext :: [ AffectionContext ] -- ^ OpenGL rendering contexts
data AffectionData us = AffectionData
{ quitEvent :: Bool -- ^ Loop breaker.
, userState :: us -- ^ State data provided by user
, drawWindows ::
[
( Word -- ^ Window identifier
, 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)
@ -62,26 +87,15 @@ data AffectionData = AffectionData
}
-- | 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
newtype AffectionState sd m a = AffectionState
{ runState :: AffectionStateInner sd m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadState sd, MonadResource)
newtype AffectionState us m a = AffectionState
{ runState :: AffectionStateInner us m a }
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
data AffectionWindow = AffectionWindow
{ awWindow :: SDL.Window
, awReleaseKey :: ReleaseKey
, awMode :: SDL.WindowMode
}
data AffectionContext = AffectionContext
{ acContext :: SDL.GLContext
, acReleaseKey :: ReleaseKey
}

62
src/Affection/Util.hs
View file

@ -10,16 +10,26 @@ import qualified Graphics.Rendering.OpenGL as GL
import System.Clock
import Data.String (fromString)
import Data.List (find)
import Control.Monad.State
-- | Prehandle SDL events
preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
preHandleEvents 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
delaySec
:: Int -- ^ Number of seconds
@ -27,54 +37,46 @@ delaySec
delaySec dur = SDL.delay (fromIntegral $ dur * 1000)
-- | Get time since start but always the same in the current tick.
getElapsedTime :: Affection Double
getElapsedTime :: Affection us Double
getElapsedTime = gets elapsedTime
-- | Get delta time (time elapsed from last frame)
getDelta :: Affection Double
getDelta :: Affection us Double
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'.
-- Pauses the Engine in the process.
toggleScreen :: Word -> Affection ()
toggleScreen windowIdent = do
toggleScreen :: Affection us ()
toggleScreen = do
ad <- get
(stop, alteredWindowList) <- foldM
(\(stop, resWindows) (num, aw@(AffectionWindow window _ mode)) -> do
if stop || num == windowIdent
then do
newMode <- case mode of
SDL.FullscreenDesktop -> do
liftIO $ SDL.setWindowMode window SDL.Windowed
return SDL.Windowed
newMode <- case screenMode ad of
SDL.Windowed -> do
liftIO $ SDL.setWindowMode window SDL.FullscreenDesktop
mapM_ (flip SDL.setWindowMode SDL.FullscreenDesktop . snd) (drawWindows ad)
return SDL.FullscreenDesktop
SDL.FullscreenDesktop -> do
mapM_ (flip SDL.setWindowMode SDL.Windowed . snd) (drawWindows ad)
return SDL.Windowed
x -> do
liftIO $ logIO Warn ("Unexpected window mode: " <> fromString (show x))
liftIO $ logIO Warn ("Unexpected Screen mode: " ++ show x)
return x
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
, screenMode = newMode
}
else
liftIO $ logIO Warn ("No window found with ident " <> fromString (show windowIdent))
-- | Fit the GL Viewport to Window size
fitViewport
:: Double -- ^ Image Ratio (width / height)
-> WindowMessage -- ^ Incoming Message. Listens only on
-- 'MsgWindowResize' and ignores all others.
-> Affection ()
-> Affection us ()
fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
liftIO $ logIO Verbose "Fitting Viewport to size"
if (fromIntegral w / fromIntegral h) > ratio