haskelloids/src/InGame.hs
2017-12-21 05:21:20 +01:00

258 lines
6.8 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 (when, unless)
import Control.Monad.IO.Class (liftIO)
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 = 150
loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
loadGame stateChange clean = do
liftIO $ logIO A.Debug "loading game"
ud <- getAffection
nhs <- newHaskelloids
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
}
, shots = []
, state = InGame
, wonlost = Nothing
}
handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ logIO A.Debug "PEW!"
shoot
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
unless (isNothing $ wonlost ud) $ do
liftIO $ logIO A.Debug "Reloading"
clean
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
SDL.KeycodeW -> accelShip dVel
SDL.KeycodeS -> accelShip (-dVel)
SDL.KeycodeA -> rotateShip dRot
SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
shoot :: Affection UserData ()
shoot = do
ud <- getAffection
let Ship{..} = ship ud
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
}
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
dt <- getDelta
let s = ship ud
nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s)
putAffection ud
{ ship = s
{ sVel = nVel
}
}
rotateShip :: Float -> Affection UserData ()
rotateShip deg = do
ud <- getAffection
dt <- getDelta
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - 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 :: 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
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
)
&& isNothing (wonlost ud2)
)
(putAffection ud2
{ wonlost = Just Lost
}
)
when (isNothing (wonlost ud2) && null (haskelloids ud2))
(putAffection ud2
{ wonlost = Just Won
}
)
checkShotDown :: Affection UserData ()
checkShotDown =
do
ud <- getAffection
let shoots = shots ud
hasks = haskelloids ud
pairs = catMaybes $ concatMap (crossOut hasks) shoots
deadHasks = map fst pairs
nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks
npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (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
}
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 :: Affection UserData ()
drawGame = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
mapM_ drawPew (shots ud)
case wonlost ud of
Just Lost -> liftIO $ do
let ctx = nano ud
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 "YOU LOST!"
fillColor ctx (rgba 255 128 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Just Won -> liftIO $ do
let ctx = nano ud
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 "YOU WON!"
fillColor ctx (rgba 128 255 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Nothing -> drawShip (ship ud)
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
where
dim = V2 40 40
drawPew :: Pew -> Affection UserData ()
drawPew Pew{..} = do
ctx <- nano <$> getAffection
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