Updated game to use affection 0.0.0.10
This commit is contained in:
parent
13b6da1e44
commit
de77724135
8 changed files with 262 additions and 279 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1,6 +1,7 @@
|
|||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
dist/
|
||||
dist-newstyle/
|
||||
*.prof
|
||||
*.aux
|
||||
*.hp
|
||||
|
|
|
|||
|
|
@ -2,8 +2,6 @@ module Commons where
|
|||
|
||||
import Affection
|
||||
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
import System.Random (randomRIO)
|
||||
|
||||
import NanoVG as N hiding (V2(..))
|
||||
|
|
@ -30,10 +28,9 @@ wrapAround (V2 nx ny) w = V2 nnx nny
|
|||
| otherwise = ny
|
||||
half = w / 2
|
||||
|
||||
newHaskelloids :: Affection UserData [Haskelloid]
|
||||
newHaskelloids =
|
||||
newHaskelloids :: Image -> Affection [Haskelloid]
|
||||
newHaskelloids img =
|
||||
do
|
||||
img <- haskImage <$> getAffection
|
||||
liftIO $ mapM (\_ -> do
|
||||
d <- randomRIO (1, 2)
|
||||
(posx, posy) <- getCoordinates d
|
||||
|
|
@ -113,9 +110,8 @@ drawSpinner ctx x y cr ct = do
|
|||
fill ctx
|
||||
restore ctx
|
||||
|
||||
drawHaskelloid :: Haskelloid -> Affection UserData ()
|
||||
drawHaskelloid (Haskelloid pos _ rot _ d img) = do
|
||||
ctx <- nano <$> getAffection
|
||||
drawHaskelloid :: Context -> Haskelloid -> Affection ()
|
||||
drawHaskelloid ctx (Haskelloid pos _ rot _ d img) = do
|
||||
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1
|
||||
where
|
||||
dim = fmap (/ fromIntegral d) (V2 100 100)
|
||||
|
|
|
|||
280
src/InGame.hs
280
src/InGame.hs
|
|
@ -7,8 +7,8 @@ import qualified SDL
|
|||
import qualified Data.Set as S
|
||||
import Data.Maybe (isNothing, catMaybes)
|
||||
|
||||
import Control.Monad (when, unless)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import System.Random (randomRIO)
|
||||
|
||||
|
|
@ -31,103 +31,94 @@ pewTTL :: Double
|
|||
pewTTL = 10
|
||||
|
||||
dRot :: Float
|
||||
dRot = 150
|
||||
dRot = 5
|
||||
|
||||
loadGame
|
||||
:: Affection UserData ()
|
||||
-> Affection UserData ()
|
||||
-> Affection UserData ()
|
||||
loadGame stateChange clean = do
|
||||
:: Affection ()
|
||||
-> Affection ()
|
||||
-> UserData
|
||||
-> Affection ()
|
||||
loadGame stateChange clean ud = do
|
||||
liftIO $ logIO A.Debug "loading game"
|
||||
ud <- getAffection
|
||||
nhs <- newHaskelloids
|
||||
nhs <- newHaskelloids (haskImage ud)
|
||||
kid <- partSubscribe
|
||||
(subKeyboard $ subsystems ud)
|
||||
(handleGameKeys stateChange clean)
|
||||
putAffection ud
|
||||
{ stateUUIDs = UUIDClean [] [kid]
|
||||
, haskelloids = nhs
|
||||
, ship = (ship ud)
|
||||
{ sPos = V2 400 300
|
||||
, sVel = V2 0 0
|
||||
, sRot = 0
|
||||
, sThrust = False
|
||||
}
|
||||
, shots = []
|
||||
, state = InGame
|
||||
, wonlost = Nothing
|
||||
}
|
||||
(handleGameKeys stateChange clean ud)
|
||||
oldship <- liftIO $ readMVar (ship ud)
|
||||
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kid])
|
||||
void $ liftIO $ swapMVar (haskelloids ud) (nhs)
|
||||
void $ liftIO $ swapMVar (ship ud) (oldship
|
||||
{ sPos = V2 400 300
|
||||
, sVel = V2 0 0
|
||||
, sRot = 0
|
||||
, sThrust = False
|
||||
})
|
||||
void $ liftIO $ swapMVar (shots ud) []
|
||||
void $ liftIO $ swapMVar (wonlost ud) Nothing
|
||||
void $ liftIO $ swapMVar (state ud) InGame
|
||||
|
||||
handleGameKeys
|
||||
:: Affection UserData ()
|
||||
-> Affection UserData ()
|
||||
:: Affection ()
|
||||
-> Affection ()
|
||||
-> UserData
|
||||
-> KeyboardMessage
|
||||
-> Affection UserData ()
|
||||
handleGameKeys stateChange clean kbdev =
|
||||
-> Affection ()
|
||||
handleGameKeys stateChange clean ud kbdev =
|
||||
if (msgKbdKeyMotion kbdev == SDL.Pressed)
|
||||
then case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
|
||||
shoot
|
||||
shoot ud
|
||||
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
|
||||
ud <- getAffection
|
||||
unless (isNothing $ wonlost ud) $ do
|
||||
wlcond <- liftIO $ readMVar (wonlost ud)
|
||||
unless (isNothing $ wlcond) $ do
|
||||
liftIO $ logIO A.Debug "Reloading"
|
||||
clean
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO A.Debug "Leave to Menu"
|
||||
stateChange
|
||||
SDL.KeycodeW -> accelShip dVel
|
||||
SDL.KeycodeA -> rotateShip dRot
|
||||
SDL.KeycodeD -> rotateShip (-dRot)
|
||||
SDL.KeycodeW -> accelShip ud dVel
|
||||
SDL.KeycodeA -> rotateShip ud dRot
|
||||
SDL.KeycodeD -> rotateShip ud (-dRot)
|
||||
_ -> return ()
|
||||
else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeW -> deThrust
|
||||
SDL.KeycodeA -> deThrust
|
||||
SDL.KeycodeD -> deThrust
|
||||
SDL.KeycodeW -> deThrust ud
|
||||
SDL.KeycodeA -> deThrust ud
|
||||
SDL.KeycodeD -> deThrust ud
|
||||
_ -> return ()
|
||||
|
||||
shoot :: Affection UserData ()
|
||||
shoot = do
|
||||
ud <- getAffection
|
||||
let Ship{..} = ship ud
|
||||
npew = Pew ppos pVel pewTTL
|
||||
shoot :: UserData -> Affection ()
|
||||
shoot ud = do
|
||||
Ship{..} <- liftIO $ readMVar (ship ud)
|
||||
let npew = Pew ppos pVel pewTTL
|
||||
ppos = sPos + (V2 0 25 `rotVec` sRot)
|
||||
pVel = sVel + (V2 0 pewVel `rotVec` sRot)
|
||||
putAffection ud
|
||||
{ shots = npew : shots ud
|
||||
}
|
||||
oldshots <- liftIO $ readMVar (shots ud)
|
||||
void $ liftIO $ swapMVar (shots ud) (npew : oldshots)
|
||||
|
||||
accelShip :: Float -> Affection UserData ()
|
||||
accelShip vel = do
|
||||
ud <- getAffection
|
||||
accelShip :: UserData -> Float -> Affection ()
|
||||
accelShip ud vel = do
|
||||
dt <- getDelta
|
||||
let s = ship ud
|
||||
nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
|
||||
putAffection ud
|
||||
{ ship = s
|
||||
{ sVel = nVel
|
||||
, sThrust = True
|
||||
}
|
||||
}
|
||||
s <- liftIO $ readMVar (ship ud)
|
||||
let nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
|
||||
void $ liftIO $ swapMVar (ship ud) (s
|
||||
{ sVel = nVel
|
||||
, sThrust = True
|
||||
})
|
||||
|
||||
deThrust :: Affection UserData ()
|
||||
deThrust = do
|
||||
ud <- getAffection
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sThrust = False
|
||||
}
|
||||
}
|
||||
deThrust :: UserData -> Affection ()
|
||||
deThrust ud = do
|
||||
s <- liftIO $ readMVar (ship ud)
|
||||
void $ liftIO $ swapMVar (ship ud) (s
|
||||
{ sThrust = False
|
||||
})
|
||||
|
||||
rotateShip :: Float -> Affection UserData ()
|
||||
rotateShip deg = do
|
||||
ud <- getAffection
|
||||
dt <- getDelta
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = sRot (ship ud) - deg * realToFrac dt
|
||||
}
|
||||
}
|
||||
rotateShip :: UserData -> Float -> Affection ()
|
||||
rotateShip ud deg = do
|
||||
-- dt <- getDelta
|
||||
s <- liftIO $ readMVar (ship ud)
|
||||
void $ liftIO $ swapMVar (ship ud) (s
|
||||
{ sRot = sRot s - deg -- * realToFrac dt
|
||||
})
|
||||
|
||||
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
|
||||
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)
|
||||
dtor = (pi / 180 *)
|
||||
|
||||
updateGame :: Double -> Affection UserData ()
|
||||
updateGame sec = do
|
||||
ud <- getAffection
|
||||
let nhs = map (updateHaskelloid sec) (haskelloids ud)
|
||||
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
|
||||
putAffection ud
|
||||
{ haskelloids = nhs
|
||||
, shots = npews
|
||||
, ship = updateShip sec (ship ud)
|
||||
}
|
||||
checkShotDown
|
||||
ud2 <- getAffection
|
||||
updateGame :: UserData -> Double -> Affection ()
|
||||
updateGame ud sec = do
|
||||
nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar $ haskelloids ud)
|
||||
npews <- (filter (\p -> pTTL p > 0) . map (updatePew sec)) <$> liftIO (readMVar $ shots ud)
|
||||
s <- liftIO $ readMVar (ship ud)
|
||||
let nship = updateShip sec s
|
||||
void $ liftIO $ swapMVar (haskelloids ud) nhs
|
||||
void $ liftIO $ swapMVar (shots ud) npews
|
||||
void $ liftIO $ swapMVar (ship ud) nship
|
||||
checkShotDown ud
|
||||
hasks <- liftIO $ readMVar (haskelloids ud)
|
||||
hotShots <- liftIO $ readMVar (shots ud)
|
||||
wlcond <- liftIO $ readMVar (wonlost ud)
|
||||
when
|
||||
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|
||||
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
|
||||
( ( any (checkCollision nship) hasks
|
||||
|| any (checkFriendlyFire nship) hotShots
|
||||
)
|
||||
&& isNothing (wonlost ud2)
|
||||
&& isNothing wlcond
|
||||
) $ do
|
||||
liftIO $ logIO A.Debug "You Lost!"
|
||||
putAffection ud2
|
||||
{ wonlost = Just Lost
|
||||
}
|
||||
when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
|
||||
void $ liftIO $ swapMVar (wonlost ud) (Just Lost)
|
||||
when (isNothing wlcond && null hasks) $ do
|
||||
liftIO $ logIO A.Debug "You Won!"
|
||||
putAffection ud2
|
||||
{ wonlost = Just Won
|
||||
}
|
||||
void $ liftIO $ swapMVar (wonlost ud) (Just Won)
|
||||
|
||||
checkShotDown :: Affection UserData ()
|
||||
checkShotDown =
|
||||
do
|
||||
ud <- getAffection
|
||||
let pews = shots ud
|
||||
hasks = haskelloids ud
|
||||
pairs = catMaybes $ concatMap (crossOut hasks) pews
|
||||
deadHasks = map fst pairs
|
||||
nhask = foldl
|
||||
(\acc a -> filter (\x -> a /= x) acc)
|
||||
hasks
|
||||
deadHasks
|
||||
npews = foldl
|
||||
(\acc a -> filter (\x -> a /= x) acc)
|
||||
pews
|
||||
(map snd pairs)
|
||||
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
|
||||
n1velx <- randomRIO (-10, 10)
|
||||
n1vely <- randomRIO (-10, 10)
|
||||
n1rot <- randomRIO (-180, 180)
|
||||
n1pitch <- randomRIO (-pi, pi)
|
||||
n2velx <- randomRIO (-10, 10)
|
||||
n2vely <- randomRIO (-10, 10)
|
||||
n2rot <- randomRIO (-180, 180)
|
||||
n2pitch <- randomRIO (-pi, pi)
|
||||
let ndiv = hDiv + 1
|
||||
if ndiv > 5
|
||||
then return []
|
||||
else return
|
||||
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
|
||||
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
|
||||
]
|
||||
) deadHasks
|
||||
putAffection ud
|
||||
{ shots = npews
|
||||
, haskelloids = nhask ++ children
|
||||
}
|
||||
checkShotDown :: UserData -> Affection ()
|
||||
checkShotDown ud = do
|
||||
pews <- liftIO $ readMVar (shots ud)
|
||||
hasks <- liftIO $ readMVar (haskelloids ud)
|
||||
let pairs = catMaybes $ concatMap (crossOut hasks) pews
|
||||
deadHasks = map fst pairs
|
||||
nhask = foldl
|
||||
(\acc a -> filter (\x -> a /= x) acc)
|
||||
hasks
|
||||
deadHasks
|
||||
npews = foldl
|
||||
(\acc a -> filter (\x -> a /= x) acc)
|
||||
pews
|
||||
(map snd pairs)
|
||||
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
|
||||
n1velx <- randomRIO (-10, 10)
|
||||
n1vely <- randomRIO (-10, 10)
|
||||
n1rot <- randomRIO (-180, 180)
|
||||
n1pitch <- randomRIO (-pi, pi)
|
||||
n2velx <- randomRIO (-10, 10)
|
||||
n2vely <- randomRIO (-10, 10)
|
||||
n2rot <- randomRIO (-180, 180)
|
||||
n2pitch <- randomRIO (-pi, pi)
|
||||
let ndiv = hDiv + 1
|
||||
if ndiv > 5
|
||||
then return []
|
||||
else return
|
||||
[ 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
|
||||
void $ liftIO $ swapMVar (haskelloids ud) (nhask ++ children)
|
||||
where
|
||||
crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
|
||||
crossOut hs p =
|
||||
|
|
@ -235,18 +219,20 @@ updatePew ddt p@Pew{..} = p
|
|||
where
|
||||
dt = realToFrac ddt
|
||||
|
||||
drawGame :: Affection UserData ()
|
||||
drawGame = do
|
||||
ud <- getAffection
|
||||
mapM_ drawHaskelloid (haskelloids ud)
|
||||
mapM_ drawPew (shots ud)
|
||||
case wonlost ud of
|
||||
Just x -> drawWonLost x
|
||||
Nothing -> drawShip (ship ud)
|
||||
drawGame :: UserData -> Affection ()
|
||||
drawGame ud = do
|
||||
hasks <- liftIO $ readMVar (haskelloids ud)
|
||||
pews <- liftIO $ readMVar (shots ud)
|
||||
wlcond <- liftIO $ readMVar (wonlost ud)
|
||||
s <- liftIO $ readMVar (ship ud)
|
||||
mapM_ (drawHaskelloid (nano ud)) hasks
|
||||
mapM_ (drawPew (nano ud)) pews
|
||||
case wlcond of
|
||||
Just x -> drawWonLost (nano ud) x
|
||||
Nothing -> drawShip (nano ud) s
|
||||
|
||||
drawWonLost :: WonLost -> Affection UserData ()
|
||||
drawWonLost wl = do
|
||||
ctx <- nano <$> getAffection
|
||||
drawWonLost :: Context -> WonLost -> Affection ()
|
||||
drawWonLost ctx wl =
|
||||
liftIO $ do
|
||||
let color = case wl of
|
||||
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"
|
||||
restore ctx
|
||||
|
||||
drawShip :: Ship -> Affection UserData ()
|
||||
drawShip Ship{..} = do
|
||||
ctx <- nano <$> getAffection
|
||||
drawShip :: Context -> Ship -> Affection ()
|
||||
drawShip ctx Ship{..} =
|
||||
liftIO $ do
|
||||
when (sThrust) $ do
|
||||
let pos@(V2 px py) = fmap CFloat sPos - V2 0 10 `rotVec` cRot
|
||||
|
|
@ -289,9 +274,8 @@ drawShip Ship{..} = do
|
|||
where
|
||||
dim = V2 40 40
|
||||
|
||||
drawPew :: Pew -> Affection UserData ()
|
||||
drawPew Pew{..} = do
|
||||
ctx <- nano <$> getAffection
|
||||
drawPew :: Context -> Pew -> Affection ()
|
||||
drawPew ctx Pew{..} =
|
||||
liftIO $ do
|
||||
let (V2 x y) = fmap CFloat pPos
|
||||
save ctx
|
||||
|
|
|
|||
30
src/Init.hs
30
src/Init.hs
|
|
@ -14,8 +14,8 @@ import qualified Data.Set as S
|
|||
import Data.Maybe
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
|
|
@ -61,22 +61,22 @@ load = do
|
|||
liftIO $ logIO A.Debug "Setting viewport"
|
||||
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
|
||||
liftIO $ logIO A.Debug "Returning UserData"
|
||||
return UserData
|
||||
{ ship = Ship
|
||||
UserData
|
||||
<$> newMVar (Ship
|
||||
{ sPos = V2 400 300
|
||||
, sVel = V2 0 0
|
||||
, sRot = 0
|
||||
, sImg = fromJust mshipImage
|
||||
, sThrust = False
|
||||
}
|
||||
, haskelloids = []
|
||||
, shots = []
|
||||
, wonlost = Nothing
|
||||
, state = Menu
|
||||
, fade = FadeIn 1
|
||||
, nano = nvgCtx
|
||||
, font = fromJust mfont
|
||||
, subsystems = subs
|
||||
, haskImage = fromJust mhaskImage
|
||||
, stateUUIDs = UUIDClean [] []
|
||||
}
|
||||
})
|
||||
<*> newMVar []
|
||||
<*> newMVar []
|
||||
<*> newMVar Nothing
|
||||
<*> newMVar Menu
|
||||
<*> newMVar (FadeIn 1)
|
||||
<*> return nvgCtx
|
||||
<*> return (fromJust mfont)
|
||||
<*> return subs
|
||||
<*> return (fromJust mhaskImage)
|
||||
<*> newMVar (UUIDClean [] [])
|
||||
<*> newMVar True
|
||||
|
|
|
|||
86
src/Main.hs
86
src/Main.hs
|
|
@ -8,8 +8,11 @@ import Linear as L
|
|||
|
||||
import NanoVG hiding (V2(..), V4(..))
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Control.Monad (when, void)
|
||||
|
||||
import Data.String (fromString)
|
||||
|
||||
-- internal imports
|
||||
|
||||
|
|
@ -17,32 +20,37 @@ import Types
|
|||
import StateMachine ()
|
||||
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 = do
|
||||
logIO A.Debug "Starting"
|
||||
withAffection AffectionConfig
|
||||
withAffection (AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "Haskelloids"
|
||||
, windowConfig = SDL.defaultWindow
|
||||
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
|
||||
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
|
||||
, SDL.glColorPrecision = V4 8 8 8 1
|
||||
, windowConfigs = [
|
||||
( 0
|
||||
, SDL.defaultWindow
|
||||
{ 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
|
||||
}
|
||||
, initScreenMode = SDL.Windowed
|
||||
, canvasSize = Nothing
|
||||
, loadState = load
|
||||
, preLoop = pre >> smLoad Menu
|
||||
, eventLoop = handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, cleanUp = \_ -> return ()
|
||||
}
|
||||
, SDL.Windowed
|
||||
)]
|
||||
} :: AffectionConfig UserData)
|
||||
|
||||
pre :: Affection UserData ()
|
||||
pre = do
|
||||
subs <- subsystems <$> getAffection
|
||||
pre :: UserData -> Affection ()
|
||||
pre ud = do
|
||||
let subs = subsystems ud
|
||||
liftIO $ logIO A.Debug "Setting global resize event listener"
|
||||
_ <- partSubscribe (subWindow subs) (fitViewport (800/600))
|
||||
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
|
||||
|
|
@ -50,33 +58,31 @@ pre = do
|
|||
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeF -> do
|
||||
dt <- getDelta
|
||||
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
|
||||
SDL.KeycodeO -> toggleScreen
|
||||
liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
|
||||
SDL.KeycodeO -> toggleScreen 0
|
||||
_ -> return ()
|
||||
return ()
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update sec = do
|
||||
ud <- getAffection
|
||||
smUpdate (state ud) sec
|
||||
update :: UserData -> Double -> Affection ()
|
||||
update ud sec = do
|
||||
curstate <- liftIO $ readMVar (state ud)
|
||||
smUpdate curstate ud sec
|
||||
|
||||
handle :: [SDL.EventPayload] -> Affection UserData ()
|
||||
handle e = do
|
||||
(Subsystems w k) <- subsystems <$> getAffection
|
||||
_ <- consumeSDLEvents w =<< consumeSDLEvents k e
|
||||
return ()
|
||||
handle :: UserData -> [SDL.EventPayload] -> Affection ()
|
||||
handle ud e = do
|
||||
let (Subsystems w k) = subsystems ud
|
||||
void $ consumeSDLEvents w =<< consumeSDLEvents k e
|
||||
|
||||
draw :: Affection UserData ()
|
||||
draw = do
|
||||
ud <- getAffection
|
||||
draw :: UserData -> Affection ()
|
||||
draw ud = do
|
||||
liftIO $ beginFrame (nano ud) 800 600 1
|
||||
smDraw (state ud)
|
||||
drawVignette
|
||||
curstate <- liftIO $ readMVar (state ud)
|
||||
smDraw curstate ud
|
||||
drawVignette (nano ud)
|
||||
liftIO $ endFrame (nano ud)
|
||||
|
||||
drawVignette :: Affection UserData ()
|
||||
drawVignette = do
|
||||
ctx <- nano <$> getAffection
|
||||
drawVignette :: Context -> Affection ()
|
||||
drawVignette ctx =
|
||||
liftIO $ do
|
||||
save ctx
|
||||
beginPath ctx
|
||||
|
|
|
|||
58
src/Menu.hs
58
src/Menu.hs
|
|
@ -5,8 +5,9 @@ import qualified SDL
|
|||
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import NanoVG
|
||||
|
||||
|
|
@ -15,51 +16,41 @@ import NanoVG
|
|||
import Types
|
||||
import Commons
|
||||
|
||||
loadMenu :: Affection UserData () -> Affection UserData ()
|
||||
loadMenu stateChange = do
|
||||
loadMenu :: Affection () -> UserData -> Affection ()
|
||||
loadMenu stateChange ud = do
|
||||
liftIO $ logIO A.Debug "Loading Menu"
|
||||
ud <- getAffection
|
||||
hs <- newHaskelloids
|
||||
hs <- newHaskelloids (haskImage ud)
|
||||
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
|
||||
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
|
||||
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
|
||||
SDL.KeycodeEscape -> do
|
||||
liftIO $ logIO A.Debug "seeya"
|
||||
quit
|
||||
void $ liftIO $ swapMVar (doNextStep ud) False
|
||||
SDL.KeycodeSpace -> do
|
||||
liftIO $ logIO A.Debug "Leaving Menu to Game"
|
||||
stateChange
|
||||
_ -> return ()
|
||||
)
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, fade = FadeIn 1
|
||||
, state = Menu
|
||||
, stateUUIDs = UUIDClean [] [kbdUUID]
|
||||
-- , shots = (shots ud)
|
||||
-- { partSysParts = ParticleStorage Nothing [] }
|
||||
}
|
||||
void $ liftIO $ swapMVar (haskelloids ud) hs
|
||||
void $ liftIO $ swapMVar (fade ud) (FadeIn 1)
|
||||
void $ liftIO $ swapMVar (state ud) Menu
|
||||
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kbdUUID])
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
updateMenu sec = do
|
||||
ud <- getAffection
|
||||
let nhs = map (updateHaskelloid sec) (haskelloids ud)
|
||||
case fade ud of
|
||||
updateMenu :: UserData -> Double -> Affection ()
|
||||
updateMenu ud sec = do
|
||||
nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar (haskelloids ud))
|
||||
void $ liftIO $ swapMVar (haskelloids ud) nhs
|
||||
fadeState <- liftIO (readMVar $ fade ud)
|
||||
case fadeState of
|
||||
FadeIn ttl ->
|
||||
putAffection ud
|
||||
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
|
||||
, haskelloids = nhs
|
||||
}
|
||||
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1)
|
||||
FadeOut ttl ->
|
||||
putAffection ud
|
||||
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
|
||||
, haskelloids = nhs
|
||||
}
|
||||
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1)
|
||||
|
||||
drawMenu :: Affection UserData ()
|
||||
drawMenu = do
|
||||
ud <- getAffection
|
||||
mapM_ drawHaskelloid (haskelloids ud)
|
||||
drawMenu :: UserData -> Affection ()
|
||||
drawMenu ud = do
|
||||
hasks <- liftIO $ readMVar (haskelloids ud)
|
||||
mapM_ (drawHaskelloid (nano ud)) hasks
|
||||
liftIO $ do
|
||||
let ctx = nano ud
|
||||
alpha fio = case fio of
|
||||
|
|
@ -71,7 +62,8 @@ drawMenu = do
|
|||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||
fillColor ctx (rgba 255 255 255 255)
|
||||
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
|
||||
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
|
||||
restore ctx
|
||||
|
|
|
|||
|
|
@ -3,16 +3,24 @@
|
|||
|
||||
module StateMachine where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
import Control.Monad (void)
|
||||
|
||||
import Affection
|
||||
|
||||
import Types
|
||||
import InGame
|
||||
import Menu
|
||||
|
||||
instance StateMachine State UserData where
|
||||
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
|
||||
instance StateMachine UserData State where
|
||||
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
|
||||
|
||||
|
|
@ -22,14 +30,11 @@ instance StateMachine State UserData where
|
|||
|
||||
smDraw InGame = drawGame
|
||||
|
||||
smEvent _ _ = return ()
|
||||
smEvent _ _ _ = return ()
|
||||
|
||||
smClean _ = do
|
||||
ud <- getAffection
|
||||
let (UUIDClean uuwin uukbd) = stateUUIDs ud
|
||||
(Subsystems win kbd) = subsystems ud
|
||||
smClean _ ud = do
|
||||
(UUIDClean uuwin uukbd) <- liftIO $ readMVar (stateUUIDs ud)
|
||||
let (Subsystems win kbd) = subsystems ud
|
||||
mapM_ (partUnSubscribe win) uuwin
|
||||
mapM_ (partUnSubscribe kbd) uukbd
|
||||
putAffection ud
|
||||
{ stateUUIDs = UUIDClean [] []
|
||||
}
|
||||
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [])
|
||||
|
|
|
|||
47
src/Types.hs
47
src/Types.hs
|
|
@ -5,24 +5,23 @@ module Types where
|
|||
|
||||
import Affection
|
||||
import NanoVG hiding (V2(..))
|
||||
import Linear
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Concurrent.MVar
|
||||
|
||||
data UserData = UserData
|
||||
{ ship :: Ship
|
||||
, haskelloids :: [Haskelloid]
|
||||
, shots :: [Pew]
|
||||
-- , debris :: ParticleSystem
|
||||
, wonlost :: Maybe WonLost
|
||||
, state :: State
|
||||
, fade :: MenuFade
|
||||
, nano :: Context
|
||||
, font :: Font
|
||||
, subsystems :: Subsystems
|
||||
, haskImage :: Image
|
||||
, stateUUIDs :: UUIDClean
|
||||
{ ship :: MVar Ship
|
||||
, haskelloids :: MVar [Haskelloid]
|
||||
, shots :: MVar [Pew]
|
||||
, wonlost :: MVar (Maybe WonLost)
|
||||
, state :: MVar (State)
|
||||
, fade :: MVar (MenuFade)
|
||||
, nano :: Context
|
||||
, font :: Font
|
||||
, subsystems :: Subsystems
|
||||
, haskImage :: Image
|
||||
, stateUUIDs :: MVar (UUIDClean)
|
||||
, doNextStep :: MVar Bool
|
||||
}
|
||||
|
||||
data Ship = Ship
|
||||
|
|
@ -72,10 +71,10 @@ data UUIDClean = UUIDClean
|
|||
, uuKeyboard :: [UUID]
|
||||
}
|
||||
|
||||
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())])
|
||||
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
|
||||
|
||||
instance Participant SubWindow UserData where
|
||||
type Mesg SubWindow UserData = WindowMessage
|
||||
instance Participant SubWindow where
|
||||
type Mesg SubWindow = WindowMessage
|
||||
|
||||
partSubscribers (SubWindow t) = do
|
||||
subTups <- liftIO $ readTVarIO t
|
||||
|
|
@ -89,16 +88,16 @@ instance Participant SubWindow UserData where
|
|||
partUnSubscribe (SubWindow t) uuid =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||||
where
|
||||
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
|
||||
filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool
|
||||
filterMsg (u, _) p = u /= p
|
||||
|
||||
instance SDLSubsystem SubWindow UserData where
|
||||
instance SDLSubsystem SubWindow where
|
||||
consumeSDLEvents = consumeSDLWindowEvents
|
||||
|
||||
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
|
||||
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
||||
|
||||
instance Participant SubKeyboard UserData where
|
||||
type Mesg SubKeyboard UserData = KeyboardMessage
|
||||
instance Participant SubKeyboard where
|
||||
type Mesg SubKeyboard = KeyboardMessage
|
||||
|
||||
partSubscribers (SubKeyboard t) = do
|
||||
subTups <- liftIO $ readTVarIO t
|
||||
|
|
@ -112,8 +111,8 @@ instance Participant SubKeyboard UserData where
|
|||
partUnSubscribe (SubKeyboard t) uuid =
|
||||
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
||||
where
|
||||
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
|
||||
filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool
|
||||
filterMsg (u, _) p = u /= p
|
||||
|
||||
instance SDLSubsystem SubKeyboard UserData where
|
||||
instance SDLSubsystem SubKeyboard where
|
||||
consumeSDLEvents = consumeSDLKeyboardEvents
|
||||
|
|
|
|||
Loading…
Reference in a new issue