Updated game to use affection 0.0.0.10

This commit is contained in:
nek0 2020-05-04 21:17:06 +02:00
parent 13b6da1e44
commit de77724135
8 changed files with 262 additions and 279 deletions

1
.gitignore vendored
View File

@ -1,6 +1,7 @@
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
dist/ dist/
dist-newstyle/
*.prof *.prof
*.aux *.aux
*.hp *.hp

View File

@ -2,8 +2,6 @@ module Commons where
import Affection import Affection
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO) import System.Random (randomRIO)
import NanoVG as N hiding (V2(..)) import NanoVG as N hiding (V2(..))
@ -30,10 +28,9 @@ wrapAround (V2 nx ny) w = V2 nnx nny
| otherwise = ny | otherwise = ny
half = w / 2 half = w / 2
newHaskelloids :: Affection UserData [Haskelloid] newHaskelloids :: Image -> Affection [Haskelloid]
newHaskelloids = newHaskelloids img =
do do
img <- haskImage <$> getAffection
liftIO $ mapM (\_ -> do liftIO $ mapM (\_ -> do
d <- randomRIO (1, 2) d <- randomRIO (1, 2)
(posx, posy) <- getCoordinates d (posx, posy) <- getCoordinates d
@ -113,9 +110,8 @@ drawSpinner ctx x y cr ct = do
fill ctx fill ctx
restore ctx restore ctx
drawHaskelloid :: Haskelloid -> Affection UserData () drawHaskelloid :: Context -> Haskelloid -> Affection ()
drawHaskelloid (Haskelloid pos _ rot _ d img) = do drawHaskelloid ctx (Haskelloid pos _ rot _ d img) = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1 liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1
where where
dim = fmap (/ fromIntegral d) (V2 100 100) dim = fmap (/ fromIntegral d) (V2 100 100)

View File

@ -7,8 +7,8 @@ import qualified SDL
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe (isNothing, catMaybes) import Data.Maybe (isNothing, catMaybes)
import Control.Monad (when, unless) import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar
import System.Random (randomRIO) import System.Random (randomRIO)
@ -31,103 +31,94 @@ pewTTL :: Double
pewTTL = 10 pewTTL = 10
dRot :: Float dRot :: Float
dRot = 150 dRot = 5
loadGame loadGame
:: Affection UserData () :: Affection ()
-> Affection UserData () -> Affection ()
-> Affection UserData () -> UserData
loadGame stateChange clean = do -> Affection ()
loadGame stateChange clean ud = do
liftIO $ logIO A.Debug "loading game" liftIO $ logIO A.Debug "loading game"
ud <- getAffection nhs <- newHaskelloids (haskImage ud)
nhs <- newHaskelloids
kid <- partSubscribe kid <- partSubscribe
(subKeyboard $ subsystems ud) (subKeyboard $ subsystems ud)
(handleGameKeys stateChange clean) (handleGameKeys stateChange clean ud)
putAffection ud oldship <- liftIO $ readMVar (ship ud)
{ stateUUIDs = UUIDClean [] [kid] void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kid])
, haskelloids = nhs void $ liftIO $ swapMVar (haskelloids ud) (nhs)
, ship = (ship ud) void $ liftIO $ swapMVar (ship ud) (oldship
{ sPos = V2 400 300 { sPos = V2 400 300
, sVel = V2 0 0 , sVel = V2 0 0
, sRot = 0 , sRot = 0
, sThrust = False , sThrust = False
} })
, shots = [] void $ liftIO $ swapMVar (shots ud) []
, state = InGame void $ liftIO $ swapMVar (wonlost ud) Nothing
, wonlost = Nothing void $ liftIO $ swapMVar (state ud) InGame
}
handleGameKeys handleGameKeys
:: Affection UserData () :: Affection ()
-> Affection UserData () -> Affection ()
-> UserData
-> KeyboardMessage -> KeyboardMessage
-> Affection UserData () -> Affection ()
handleGameKeys stateChange clean kbdev = handleGameKeys stateChange clean ud kbdev =
if (msgKbdKeyMotion kbdev == SDL.Pressed) if (msgKbdKeyMotion kbdev == SDL.Pressed)
then case SDL.keysymKeycode (msgKbdKeysym kbdev) of then case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
shoot shoot ud
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection wlcond <- liftIO $ readMVar (wonlost ud)
unless (isNothing $ wonlost ud) $ do unless (isNothing $ wlcond) $ do
liftIO $ logIO A.Debug "Reloading" liftIO $ logIO A.Debug "Reloading"
clean clean
SDL.KeycodeEscape -> do SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu" liftIO $ logIO A.Debug "Leave to Menu"
stateChange stateChange
SDL.KeycodeW -> accelShip dVel SDL.KeycodeW -> accelShip ud dVel
SDL.KeycodeA -> rotateShip dRot SDL.KeycodeA -> rotateShip ud dRot
SDL.KeycodeD -> rotateShip (-dRot) SDL.KeycodeD -> rotateShip ud (-dRot)
_ -> return () _ -> return ()
else case SDL.keysymKeycode (msgKbdKeysym kbdev) of else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeW -> deThrust SDL.KeycodeW -> deThrust ud
SDL.KeycodeA -> deThrust SDL.KeycodeA -> deThrust ud
SDL.KeycodeD -> deThrust SDL.KeycodeD -> deThrust ud
_ -> return () _ -> return ()
shoot :: Affection UserData () shoot :: UserData -> Affection ()
shoot = do shoot ud = do
ud <- getAffection Ship{..} <- liftIO $ readMVar (ship ud)
let Ship{..} = ship ud let npew = Pew ppos pVel pewTTL
npew = Pew ppos pVel pewTTL
ppos = sPos + (V2 0 25 `rotVec` sRot) ppos = sPos + (V2 0 25 `rotVec` sRot)
pVel = sVel + (V2 0 pewVel `rotVec` sRot) pVel = sVel + (V2 0 pewVel `rotVec` sRot)
putAffection ud oldshots <- liftIO $ readMVar (shots ud)
{ shots = npew : shots ud void $ liftIO $ swapMVar (shots ud) (npew : oldshots)
}
accelShip :: Float -> Affection UserData () accelShip :: UserData -> Float -> Affection ()
accelShip vel = do accelShip ud vel = do
ud <- getAffection
dt <- getDelta dt <- getDelta
let s = ship ud s <- liftIO $ readMVar (ship ud)
nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s) let nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
putAffection ud void $ liftIO $ swapMVar (ship ud) (s
{ ship = s { sVel = nVel
{ sVel = nVel , sThrust = True
, sThrust = True })
}
}
deThrust :: Affection UserData () deThrust :: UserData -> Affection ()
deThrust = do deThrust ud = do
ud <- getAffection s <- liftIO $ readMVar (ship ud)
putAffection ud void $ liftIO $ swapMVar (ship ud) (s
{ ship = (ship ud) { sThrust = False
{ sThrust = False })
}
}
rotateShip :: Float -> Affection UserData () rotateShip :: UserData -> Float -> Affection ()
rotateShip deg = do rotateShip ud deg = do
ud <- getAffection -- dt <- getDelta
dt <- getDelta s <- liftIO $ readMVar (ship ud)
putAffection ud void $ liftIO $ swapMVar (ship ud) (s
{ ship = (ship ud) { sRot = sRot s - deg -- * realToFrac dt
{ sRot = sRot (ship ud) - deg * realToFrac dt })
}
}
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny rotVec (V2 x y) deg = V2 nx ny
@ -136,71 +127,64 @@ rotVec (V2 x y) deg = V2 nx ny
ny = x * sin (dtor deg) - y * cos (dtor deg) ny = x * sin (dtor deg) - y * cos (dtor deg)
dtor = (pi / 180 *) dtor = (pi / 180 *)
updateGame :: Double -> Affection UserData () updateGame :: UserData -> Double -> Affection ()
updateGame sec = do updateGame ud sec = do
ud <- getAffection nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar $ haskelloids ud)
let nhs = map (updateHaskelloid sec) (haskelloids ud) npews <- (filter (\p -> pTTL p > 0) . map (updatePew sec)) <$> liftIO (readMVar $ shots ud)
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud) s <- liftIO $ readMVar (ship ud)
putAffection ud let nship = updateShip sec s
{ haskelloids = nhs void $ liftIO $ swapMVar (haskelloids ud) nhs
, shots = npews void $ liftIO $ swapMVar (shots ud) npews
, ship = updateShip sec (ship ud) void $ liftIO $ swapMVar (ship ud) nship
} checkShotDown ud
checkShotDown hasks <- liftIO $ readMVar (haskelloids ud)
ud2 <- getAffection hotShots <- liftIO $ readMVar (shots ud)
wlcond <- liftIO $ readMVar (wonlost ud)
when when
( ( any (checkCollision (ship ud2)) (haskelloids ud2) ( ( any (checkCollision nship) hasks
|| any (checkFriendlyFire (ship ud2)) (shots ud2) || any (checkFriendlyFire nship) hotShots
) )
&& isNothing (wonlost ud2) && isNothing wlcond
) $ do ) $ do
liftIO $ logIO A.Debug "You Lost!" liftIO $ logIO A.Debug "You Lost!"
putAffection ud2 void $ liftIO $ swapMVar (wonlost ud) (Just Lost)
{ wonlost = Just Lost when (isNothing wlcond && null hasks) $ do
}
when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
liftIO $ logIO A.Debug "You Won!" liftIO $ logIO A.Debug "You Won!"
putAffection ud2 void $ liftIO $ swapMVar (wonlost ud) (Just Won)
{ wonlost = Just Won
}
checkShotDown :: Affection UserData () checkShotDown :: UserData -> Affection ()
checkShotDown = checkShotDown ud = do
do pews <- liftIO $ readMVar (shots ud)
ud <- getAffection hasks <- liftIO $ readMVar (haskelloids ud)
let pews = shots ud let pairs = catMaybes $ concatMap (crossOut hasks) pews
hasks = haskelloids ud deadHasks = map fst pairs
pairs = catMaybes $ concatMap (crossOut hasks) pews nhask = foldl
deadHasks = map fst pairs (\acc a -> filter (\x -> a /= x) acc)
nhask = foldl hasks
(\acc a -> filter (\x -> a /= x) acc) deadHasks
hasks npews = foldl
deadHasks (\acc a -> filter (\x -> a /= x) acc)
npews = foldl pews
(\acc a -> filter (\x -> a /= x) acc) (map snd pairs)
pews children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
(map snd pairs) n1velx <- randomRIO (-10, 10)
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do n1vely <- randomRIO (-10, 10)
n1velx <- randomRIO (-10, 10) n1rot <- randomRIO (-180, 180)
n1vely <- randomRIO (-10, 10) n1pitch <- randomRIO (-pi, pi)
n1rot <- randomRIO (-180, 180) n2velx <- randomRIO (-10, 10)
n1pitch <- randomRIO (-pi, pi) n2vely <- randomRIO (-10, 10)
n2velx <- randomRIO (-10, 10) n2rot <- randomRIO (-180, 180)
n2vely <- randomRIO (-10, 10) n2pitch <- randomRIO (-pi, pi)
n2rot <- randomRIO (-180, 180) let ndiv = hDiv + 1
n2pitch <- randomRIO (-pi, pi) if ndiv > 5
let ndiv = hDiv + 1 then return []
if ndiv > 5 else return
then return [] [ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
else return , Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg ]
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg ) deadHasks
] void $ liftIO $ swapMVar (shots ud) npews
) deadHasks void $ liftIO $ swapMVar (haskelloids ud) (nhask ++ children)
putAffection ud
{ shots = npews
, haskelloids = nhask ++ children
}
where where
crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)] crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
crossOut hs p = crossOut hs p =
@ -235,18 +219,20 @@ updatePew ddt p@Pew{..} = p
where where
dt = realToFrac ddt dt = realToFrac ddt
drawGame :: Affection UserData () drawGame :: UserData -> Affection ()
drawGame = do drawGame ud = do
ud <- getAffection hasks <- liftIO $ readMVar (haskelloids ud)
mapM_ drawHaskelloid (haskelloids ud) pews <- liftIO $ readMVar (shots ud)
mapM_ drawPew (shots ud) wlcond <- liftIO $ readMVar (wonlost ud)
case wonlost ud of s <- liftIO $ readMVar (ship ud)
Just x -> drawWonLost x mapM_ (drawHaskelloid (nano ud)) hasks
Nothing -> drawShip (ship ud) mapM_ (drawPew (nano ud)) pews
case wlcond of
Just x -> drawWonLost (nano ud) x
Nothing -> drawShip (nano ud) s
drawWonLost :: WonLost -> Affection UserData () drawWonLost :: Context -> WonLost -> Affection ()
drawWonLost wl = do drawWonLost ctx wl =
ctx <- nano <$> getAffection
liftIO $ do liftIO $ do
let color = case wl of let color = case wl of
Won -> rgba 128 255 0 255 Won -> rgba 128 255 0 255
@ -265,9 +251,8 @@ drawWonLost wl = do
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again" textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx restore ctx
drawShip :: Ship -> Affection UserData () drawShip :: Context -> Ship -> Affection ()
drawShip Ship{..} = do drawShip ctx Ship{..} =
ctx <- nano <$> getAffection
liftIO $ do liftIO $ do
when (sThrust) $ do when (sThrust) $ do
let pos@(V2 px py) = fmap CFloat sPos - V2 0 10 `rotVec` cRot let pos@(V2 px py) = fmap CFloat sPos - V2 0 10 `rotVec` cRot
@ -289,9 +274,8 @@ drawShip Ship{..} = do
where where
dim = V2 40 40 dim = V2 40 40
drawPew :: Pew -> Affection UserData () drawPew :: Context -> Pew -> Affection ()
drawPew Pew{..} = do drawPew ctx Pew{..} =
ctx <- nano <$> getAffection
liftIO $ do liftIO $ do
let (V2 x y) = fmap CFloat pPos let (V2 x y) = fmap CFloat pPos
save ctx save ctx

View File

@ -14,8 +14,8 @@ import qualified Data.Set as S
import Data.Maybe import Data.Maybe
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar
import System.Exit (exitFailure) import System.Exit (exitFailure)
@ -61,22 +61,22 @@ load = do
liftIO $ logIO A.Debug "Setting viewport" liftIO $ logIO A.Debug "Setting viewport"
GL.viewport $= (GL.Position 0 0, GL.Size 800 600) GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
liftIO $ logIO A.Debug "Returning UserData" liftIO $ logIO A.Debug "Returning UserData"
return UserData UserData
{ ship = Ship <$> newMVar (Ship
{ sPos = V2 400 300 { sPos = V2 400 300
, sVel = V2 0 0 , sVel = V2 0 0
, sRot = 0 , sRot = 0
, sImg = fromJust mshipImage , sImg = fromJust mshipImage
, sThrust = False , sThrust = False
} })
, haskelloids = [] <*> newMVar []
, shots = [] <*> newMVar []
, wonlost = Nothing <*> newMVar Nothing
, state = Menu <*> newMVar Menu
, fade = FadeIn 1 <*> newMVar (FadeIn 1)
, nano = nvgCtx <*> return nvgCtx
, font = fromJust mfont <*> return (fromJust mfont)
, subsystems = subs <*> return subs
, haskImage = fromJust mhaskImage <*> return (fromJust mhaskImage)
, stateUUIDs = UUIDClean [] [] <*> newMVar (UUIDClean [] [])
} <*> newMVar True

View File

@ -8,8 +8,11 @@ import Linear as L
import NanoVG hiding (V2(..), V4(..)) import NanoVG hiding (V2(..), V4(..))
import Control.Monad (when) import Control.Concurrent.MVar
import Control.Monad.IO.Class (liftIO)
import Control.Monad (when, void)
import Data.String (fromString)
-- internal imports -- internal imports
@ -17,32 +20,37 @@ import Types
import StateMachine () import StateMachine ()
import Init import Init
instance Affectionate UserData where
loadState = load
preLoop = (\ud -> pre ud >> smLoad Menu ud)
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = \_ -> return ()
hasNextStep = liftIO . readMVar . doNextStep
main :: IO () main :: IO ()
main = do main = do
logIO A.Debug "Starting" logIO A.Debug "Starting"
withAffection AffectionConfig withAffection (AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Haskelloids" , windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow , windowConfigs = [
{ SDL.windowOpenGL = Just SDL.defaultOpenGL ( 0
{ SDL.glProfile = SDL.Core SDL.Normal 3 2 , SDL.defaultWindow
, SDL.glColorPrecision = V4 8 8 8 1 { SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
}
, SDL.windowResizable = True
} }
, SDL.windowResizable = True , SDL.Windowed
} )]
, initScreenMode = SDL.Windowed } :: AffectionConfig UserData)
, canvasSize = Nothing
, loadState = load
, preLoop = pre >> smLoad Menu
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = \_ -> return ()
}
pre :: Affection UserData () pre :: UserData -> Affection ()
pre = do pre ud = do
subs <- subsystems <$> getAffection let subs = subsystems ud
liftIO $ logIO A.Debug "Setting global resize event listener" liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) (fitViewport (800/600)) _ <- partSubscribe (subWindow subs) (fitViewport (800/600))
_ <- partSubscribe (subKeyboard subs) $ \kbdev -> _ <- partSubscribe (subKeyboard subs) $ \kbdev ->
@ -50,33 +58,31 @@ pre = do
case SDL.keysymKeycode (msgKbdKeysym kbdev) of case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do SDL.KeycodeF -> do
dt <- getDelta dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt) liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
SDL.KeycodeO -> toggleScreen SDL.KeycodeO -> toggleScreen 0
_ -> return () _ -> return ()
return () return ()
update :: Double -> Affection UserData () update :: UserData -> Double -> Affection ()
update sec = do update ud sec = do
ud <- getAffection curstate <- liftIO $ readMVar (state ud)
smUpdate (state ud) sec smUpdate curstate ud sec
handle :: [SDL.EventPayload] -> Affection UserData () handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle e = do handle ud e = do
(Subsystems w k) <- subsystems <$> getAffection let (Subsystems w k) = subsystems ud
_ <- consumeSDLEvents w =<< consumeSDLEvents k e void $ consumeSDLEvents w =<< consumeSDLEvents k e
return ()
draw :: Affection UserData () draw :: UserData -> Affection ()
draw = do draw ud = do
ud <- getAffection
liftIO $ beginFrame (nano ud) 800 600 1 liftIO $ beginFrame (nano ud) 800 600 1
smDraw (state ud) curstate <- liftIO $ readMVar (state ud)
drawVignette smDraw curstate ud
drawVignette (nano ud)
liftIO $ endFrame (nano ud) liftIO $ endFrame (nano ud)
drawVignette :: Affection UserData () drawVignette :: Context -> Affection ()
drawVignette = do drawVignette ctx =
ctx <- nano <$> getAffection
liftIO $ do liftIO $ do
save ctx save ctx
beginPath ctx beginPath ctx

View File

@ -5,8 +5,9 @@ import qualified SDL
import qualified Data.Set as S import qualified Data.Set as S
import Control.Monad (when) import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import NanoVG import NanoVG
@ -15,51 +16,41 @@ import NanoVG
import Types import Types
import Commons import Commons
loadMenu :: Affection UserData () -> Affection UserData () loadMenu :: Affection () -> UserData -> Affection ()
loadMenu stateChange = do loadMenu stateChange ud = do
liftIO $ logIO A.Debug "Loading Menu" liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection hs <- newHaskelloids (haskImage ud)
hs <- newHaskelloids
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud) kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $ (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeEscape -> do SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "seeya" liftIO $ logIO A.Debug "seeya"
quit void $ liftIO $ swapMVar (doNextStep ud) False
SDL.KeycodeSpace -> do SDL.KeycodeSpace -> do
liftIO $ logIO A.Debug "Leaving Menu to Game" liftIO $ logIO A.Debug "Leaving Menu to Game"
stateChange stateChange
_ -> return () _ -> return ()
) )
putAffection ud void $ liftIO $ swapMVar (haskelloids ud) hs
{ haskelloids = hs void $ liftIO $ swapMVar (fade ud) (FadeIn 1)
, fade = FadeIn 1 void $ liftIO $ swapMVar (state ud) Menu
, state = Menu void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kbdUUID])
, stateUUIDs = UUIDClean [] [kbdUUID]
-- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] }
}
updateMenu :: Double -> Affection UserData () updateMenu :: UserData -> Double -> Affection ()
updateMenu sec = do updateMenu ud sec = do
ud <- getAffection nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar (haskelloids ud))
let nhs = map (updateHaskelloid sec) (haskelloids ud) void $ liftIO $ swapMVar (haskelloids ud) nhs
case fade ud of fadeState <- liftIO (readMVar $ fade ud)
case fadeState of
FadeIn ttl -> FadeIn ttl ->
putAffection ud void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1)
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> FadeOut ttl ->
putAffection ud void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1)
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}
drawMenu :: Affection UserData () drawMenu :: UserData -> Affection ()
drawMenu = do drawMenu ud = do
ud <- getAffection hasks <- liftIO $ readMVar (haskelloids ud)
mapM_ drawHaskelloid (haskelloids ud) mapM_ (drawHaskelloid (nano ud)) hasks
liftIO $ do liftIO $ do
let ctx = nano ud let ctx = nano ud
alpha fio = case fio of alpha fio = case fio of
@ -71,7 +62,8 @@ drawMenu = do
textAlign ctx (S.fromList [AlignCenter,AlignTop]) textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255) fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "HASKELLOIDS" textBox ctx 0 200 800 "HASKELLOIDS"
fillColor ctx (rgba 0 128 255 (alpha $ fade ud)) fadeState <- readMVar (fade ud)
fillColor ctx (rgba 0 128 255 (alpha $ fadeState))
fontSize ctx 40 fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit" textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx restore ctx

View File

@ -3,16 +3,24 @@
module StateMachine where module StateMachine where
import Control.Concurrent.MVar
import Control.Monad (void)
import Affection import Affection
import Types import Types
import InGame import InGame
import Menu import Menu
instance StateMachine State UserData where instance StateMachine UserData State where
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame) smLoad Menu = (\ud -> loadMenu (smClean Menu ud >> smLoad InGame ud) ud)
smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame) smLoad InGame = (\ud -> loadGame
(smClean InGame ud >> smLoad Menu ud)
(smClean InGame ud >> smLoad InGame ud)
ud
)
smUpdate Menu = updateMenu smUpdate Menu = updateMenu
@ -22,14 +30,11 @@ instance StateMachine State UserData where
smDraw InGame = drawGame smDraw InGame = drawGame
smEvent _ _ = return () smEvent _ _ _ = return ()
smClean _ = do smClean _ ud = do
ud <- getAffection (UUIDClean uuwin uukbd) <- liftIO $ readMVar (stateUUIDs ud)
let (UUIDClean uuwin uukbd) = stateUUIDs ud let (Subsystems win kbd) = subsystems ud
(Subsystems win kbd) = subsystems ud
mapM_ (partUnSubscribe win) uuwin mapM_ (partUnSubscribe win) uuwin
mapM_ (partUnSubscribe kbd) uukbd mapM_ (partUnSubscribe kbd) uukbd
putAffection ud void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [])
{ stateUUIDs = UUIDClean [] []
}

View File

@ -5,24 +5,23 @@ module Types where
import Affection import Affection
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Linear
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar
data UserData = UserData data UserData = UserData
{ ship :: Ship { ship :: MVar Ship
, haskelloids :: [Haskelloid] , haskelloids :: MVar [Haskelloid]
, shots :: [Pew] , shots :: MVar [Pew]
-- , debris :: ParticleSystem , wonlost :: MVar (Maybe WonLost)
, wonlost :: Maybe WonLost , state :: MVar (State)
, state :: State , fade :: MVar (MenuFade)
, fade :: MenuFade , nano :: Context
, nano :: Context , font :: Font
, font :: Font , subsystems :: Subsystems
, subsystems :: Subsystems , haskImage :: Image
, haskImage :: Image , stateUUIDs :: MVar (UUIDClean)
, stateUUIDs :: UUIDClean , doNextStep :: MVar Bool
} }
data Ship = Ship data Ship = Ship
@ -72,10 +71,10 @@ data UUIDClean = UUIDClean
, uuKeyboard :: [UUID] , uuKeyboard :: [UUID]
} }
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())]) newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
instance Participant SubWindow UserData where instance Participant SubWindow where
type Mesg SubWindow UserData = WindowMessage type Mesg SubWindow = WindowMessage
partSubscribers (SubWindow t) = do partSubscribers (SubWindow t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -89,16 +88,16 @@ instance Participant SubWindow UserData where
partUnSubscribe (SubWindow t) uuid = partUnSubscribe (SubWindow t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p filterMsg (u, _) p = u /= p
instance SDLSubsystem SubWindow UserData where instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents consumeSDLEvents = consumeSDLWindowEvents
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
instance Participant SubKeyboard UserData where instance Participant SubKeyboard where
type Mesg SubKeyboard UserData = KeyboardMessage type Mesg SubKeyboard = KeyboardMessage
partSubscribers (SubKeyboard t) = do partSubscribers (SubKeyboard t) = do
subTups <- liftIO $ readTVarIO t subTups <- liftIO $ readTVarIO t
@ -112,8 +111,8 @@ instance Participant SubKeyboard UserData where
partUnSubscribe (SubKeyboard t) uuid = partUnSubscribe (SubKeyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p filterMsg (u, _) p = u /= p
instance SDLSubsystem SubKeyboard UserData where instance SDLSubsystem SubKeyboard where
consumeSDLEvents = consumeSDLKeyboardEvents consumeSDLEvents = consumeSDLKeyboardEvents