haskelloids/src/InGame.hs

287 lines
8.0 KiB
Haskell

{-# LANGUAGE RecordWildCards #-}
module InGame where
import Affection as A
import qualified SDL
import qualified Data.Set as S
import Data.Maybe (isNothing, catMaybes)
import Control.Monad
import Control.Concurrent.MVar
import System.Random (randomRIO)
import Linear
import NanoVG hiding (V2(..))
import Foreign.C.Types (CFloat(..))
import Types
import Commons
dVel :: Float
dVel = 100
pewVel :: Float
pewVel = 200
pewTTL :: Double
pewTTL = 10
dRot :: Float
dRot = 5
loadGame
:: Affection ()
-> Affection ()
-> UserData
-> Affection ()
loadGame stateChange clean ud = do
liftIO $ logIO A.Debug "loading game"
nhs <- newHaskelloids (haskImage ud)
kid <- partSubscribe
(subKeyboard $ subsystems ud)
(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 ()
-> Affection ()
-> UserData
-> KeyboardMessage
-> 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 ud
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ 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 ud dVel
SDL.KeycodeA -> rotateShip ud dRot
SDL.KeycodeD -> rotateShip ud (-dRot)
_ -> return ()
else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeW -> deThrust ud
SDL.KeycodeA -> deThrust ud
SDL.KeycodeD -> deThrust ud
_ -> return ()
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)
oldshots <- liftIO $ readMVar (shots ud)
void $ liftIO $ swapMVar (shots ud) (npew : oldshots)
accelShip :: UserData -> Float -> Affection ()
accelShip ud vel = do
dt <- getDelta
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 :: UserData -> Affection ()
deThrust ud = do
s <- liftIO $ readMVar (ship ud)
void $ liftIO $ swapMVar (ship ud) (s
{ sThrust = False
})
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
where
nx = x * cos (dtor deg) + y * sin (dtor deg)
ny = x * sin (dtor deg) - y * cos (dtor deg)
dtor = (pi / 180 *)
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 nship) hasks
|| any (checkFriendlyFire nship) hotShots
)
&& isNothing wlcond
) $ do
liftIO $ logIO A.Debug "You Lost!"
void $ liftIO $ swapMVar (wonlost ud) (Just Lost)
when (isNothing wlcond && null hasks) $ do
liftIO $ logIO A.Debug "You Won!"
void $ liftIO $ swapMVar (wonlost ud) (Just Won)
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 =
foldl (\acc h ->
if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h))
then Just (h, p) : acc
else Nothing : acc
) [] hs
checkCollision :: Ship -> Haskelloid -> Bool
checkCollision s h =
distance (sPos s) (hPos h) < minDist
where
minDist = 20 + (50 / fromIntegral (hDiv h))
checkFriendlyFire :: Ship -> Pew -> Bool
checkFriendlyFire s p =
distance (sPos s) (pPos p) < 20
updateShip :: Double -> Ship -> Ship
updateShip ddt s@Ship{..} = s
{ sPos = wrapAround (sPos + fmap (dt *) sVel) 40
}
where
dt = realToFrac ddt
updatePew :: Double -> Pew -> Pew
updatePew ddt p@Pew{..} = p
{ pPos = wrapAround (pPos + fmap (dt *) pVel) 0
, pTTL = pTTL - ddt
}
where
dt = realToFrac ddt
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 :: Context -> WonLost -> Affection ()
drawWonLost ctx wl =
liftIO $ do
let color = case wl of
Won -> rgba 128 255 0 255
Lost -> rgba 255 128 0 255
textStr = case wl of
Won -> "YOU WON!"
Lost -> "YOU LOsT!"
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 textStr
fillColor ctx color
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
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
V2 x1 y1 = pos - (V2 10 0 `rotVec` cRot)
V2 x2 y2 = pos + (V2 10 0 `rotVec` cRot)
V2 x3 y3 = pos - (V2 0 25 `rotVec` cRot)
cRot = CFloat sRot
save ctx
grad <- linearGradient ctx px py x3 y3 (rgba 255 128 0 255) (rgba 0 0 0 0)
fillPaint ctx grad
beginPath ctx
moveTo ctx x1 y1
lineTo ctx x2 y2
lineTo ctx x3 y3
closePath ctx
fill ctx
restore ctx
drawImage ctx sImg (sPos - fmap (/2) dim) dim sRot 1
where
dim = V2 40 40
drawPew :: Context -> Pew -> Affection ()
drawPew ctx Pew{..} =
liftIO $ do
let (V2 x y) = fmap CFloat pPos
save ctx
beginPath ctx
fillColor ctx (rgba 255 128 0 255)
circle ctx x y 2
fill ctx
restore ctx