haskelloids/src/InGame.hs

289 lines
7.6 KiB
Haskell
Raw Normal View History

2017-12-20 01:00:28 +00:00
{-# LANGUAGE RecordWildCards #-}
2016-12-31 16:01:24 +00:00
module InGame where
2017-12-20 01:00:28 +00:00
import Affection as A
2016-12-31 16:01:24 +00:00
import qualified SDL
2017-12-20 23:56:16 +00:00
import qualified Data.Set as S
2017-12-21 04:21:20 +00:00
import Data.Maybe (isNothing, catMaybes)
2016-12-31 16:01:24 +00:00
2017-12-20 03:58:24 +00:00
import Control.Monad (when, unless)
2017-12-20 01:00:28 +00:00
import Control.Monad.IO.Class (liftIO)
2017-01-03 16:34:37 +00:00
2017-12-21 04:21:20 +00:00
import System.Random (randomRIO)
2017-12-20 01:00:28 +00:00
import Linear
2016-12-31 16:01:24 +00:00
2017-12-20 23:56:16 +00:00
import NanoVG hiding (V2(..))
2017-12-21 04:21:20 +00:00
import Foreign.C.Types (CFloat(..))
2016-12-31 16:01:24 +00:00
import Types
import Commons
2017-12-20 23:56:16 +00:00
dVel :: Float
dVel = 100
2017-12-21 04:21:20 +00:00
pewVel :: Float
pewVel = 200
pewTTL :: Double
pewTTL = 10
2017-12-20 23:56:16 +00:00
dRot :: Float
dRot = 150
2016-12-31 16:01:24 +00:00
2017-12-21 04:21:20 +00:00
loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
loadGame stateChange clean = do
2017-12-20 01:00:28 +00:00
liftIO $ logIO A.Debug "loading game"
2017-01-03 16:34:37 +00:00
ud <- getAffection
2017-12-20 01:00:28 +00:00
nhs <- newHaskelloids
2017-12-21 04:21:20 +00:00
kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
2017-01-03 16:34:37 +00:00
putAffection ud
2017-12-20 01:00:28 +00:00
{ stateUUIDs = UUIDClean [] [kid]
, haskelloids = nhs
, ship = (ship ud)
{ sPos = V2 400 300
, sVel = V2 0 0
2017-01-03 16:34:37 +00:00
, sRot = 0
2018-01-10 03:28:26 +00:00
, sThrust = False
2017-01-03 16:34:37 +00:00
}
2017-12-20 23:56:16 +00:00
, shots = []
2017-01-03 16:34:37 +00:00
, state = InGame
2017-12-20 23:56:16 +00:00
, wonlost = Nothing
2017-01-03 16:34:37 +00:00
}
2017-12-21 04:21:20 +00:00
handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
2018-01-10 03:28:26 +00:00
handleGameKeys stateChange clean kbdev = if (msgKbdKeyMotion kbdev == SDL.Pressed)
then case SDL.keysymKeycode (msgKbdKeysym kbdev) of
2017-12-20 23:56:16 +00:00
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
2017-12-21 04:21:20 +00:00
liftIO $ logIO A.Debug "PEW!"
shoot
2017-12-20 23:56:16 +00:00
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
2017-12-21 04:21:20 +00:00
unless (isNothing $ wonlost ud) $ do
liftIO $ logIO A.Debug "Reloading"
clean
2017-12-20 23:56:16 +00:00
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
SDL.KeycodeW -> accelShip dVel
2018-01-10 03:28:26 +00:00
-- SDL.KeycodeS -> accelShip (-dVel)
2017-12-20 23:56:16 +00:00
SDL.KeycodeA -> rotateShip dRot
SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
2018-01-10 03:28:26 +00:00
else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeW -> deThrust
-- SDL.KeycodeS -> deThrust
SDL.KeycodeA -> deThrust
SDL.KeycodeD -> deThrust
_ -> return ()
2017-12-20 23:56:16 +00:00
2017-12-21 04:21:20 +00:00
shoot :: Affection UserData ()
shoot = do
ud <- getAffection
let Ship{..} = ship ud
npew = Pew ppos pVel pewTTL
2017-12-21 13:43:13 +00:00
ppos = sPos + (V2 0 25 `rotVec` sRot)
pVel = sVel + (V2 0 pewVel `rotVec` sRot)
2017-12-21 04:21:20 +00:00
putAffection ud
{ shots = npew : shots ud
}
2017-12-20 23:56:16 +00:00
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
dt <- getDelta
let s = ship ud
2017-12-21 13:43:13 +00:00
nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
2017-12-20 23:56:16 +00:00
putAffection ud
{ ship = s
{ sVel = nVel
2018-01-10 03:28:26 +00:00
, sThrust = True
}
}
deThrust :: Affection UserData ()
deThrust = do
ud <- getAffection
putAffection ud
{ ship = (ship ud)
{ sThrust = False
2017-12-20 23:56:16 +00:00
}
}
rotateShip :: Float -> Affection UserData ()
rotateShip deg = do
ud <- getAffection
dt <- getDelta
putAffection ud
{ ship = (ship ud)
2017-12-21 13:43:13 +00:00
{ sRot = sRot (ship ud) - deg * realToFrac dt
2017-12-20 23:56:16 +00:00
}
}
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
where
2017-12-21 13:43:13 +00:00
nx = x * cos (dtor deg) + y * sin (dtor deg)
ny = x * sin (dtor deg) - y * cos (dtor deg)
2017-12-20 23:56:16 +00:00
dtor = (pi / 180 *)
2017-01-03 16:34:37 +00:00
updateGame :: Double -> Affection UserData ()
updateGame sec = do
ud <- getAffection
2017-12-20 01:00:28 +00:00
let nhs = map (updateHaskelloid sec) (haskelloids ud)
2017-12-21 04:21:20 +00:00
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
2017-12-20 01:00:28 +00:00
putAffection ud
2017-01-03 16:34:37 +00:00
{ haskelloids = nhs
2017-12-21 04:21:20 +00:00
, shots = npews
2017-12-20 01:00:28 +00:00
, ship = updateShip sec (ship ud)
2017-01-03 16:34:37 +00:00
}
2017-12-21 04:21:20 +00:00
checkShotDown
2017-12-20 23:56:16 +00:00
ud2 <- getAffection
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
)
&& isNothing (wonlost ud2)
2017-12-27 17:44:22 +00:00
) $ do
liftIO $ logIO A.Debug "You Lost!"
putAffection ud2
{ wonlost = Just Lost
}
when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
liftIO $ logIO A.Debug "You Won!"
putAffection ud2
2017-12-21 04:21:20 +00:00
{ 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 []
2017-12-21 13:43:13 +00:00
else return
2017-12-21 04:21:20 +00:00
[ 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
2017-12-20 23:56:16 +00:00
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
2017-01-03 16:34:37 +00:00
2017-12-20 01:00:28 +00:00
updateShip :: Double -> Ship -> Ship
updateShip ddt s@Ship{..} = s
{ sPos = wrapAround (sPos + fmap (dt *) sVel) 40
}
where
dt = realToFrac ddt
2017-12-21 04:21:20 +00:00
updatePew :: Double -> Pew -> Pew
updatePew ddt p@Pew{..} = p
{ pPos = wrapAround (pPos + fmap (dt *) pVel) 0
, pTTL = pTTL - ddt
}
where
dt = realToFrac ddt
2017-01-12 17:48:23 +00:00
drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
2017-12-20 01:00:28 +00:00
mapM_ drawHaskelloid (haskelloids ud)
2017-12-21 04:21:20 +00:00
mapM_ drawPew (shots ud)
2017-12-20 23:56:16 +00:00
case wonlost ud of
2017-12-21 13:43:13 +00:00
Just x -> drawWonLost x
2017-12-20 23:56:16 +00:00
Nothing -> drawShip (ship ud)
2016-12-31 16:01:24 +00:00
2017-12-21 13:43:13 +00:00
drawWonLost :: WonLost -> Affection UserData ()
drawWonLost wl = do
ctx <- nano <$> getAffection
liftIO $ do
let color = case wl of
Won -> rgba 128 255 0 255
Lost -> rgba 255 128 0 255
2017-12-22 08:01:07 +00:00
textStr = case wl of
2017-12-21 13:43:13 +00:00
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)
2017-12-22 08:01:07 +00:00
textBox ctx 0 200 800 textStr
2017-12-21 13:43:13 +00:00
fillColor ctx color
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
2017-12-20 01:00:28 +00:00
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do
ctx <- nano <$> getAffection
2018-01-10 03:28:26 +00:00
liftIO $ do
when (sThrust) $ do
let pos@(V2 px py) = fmap CFloat sPos - V2 0 10 `rotVec` CFloat sRot
V2 x1 y1 = pos - (V2 10 0 `rotVec` CFloat sRot)
V2 x2 y2 = pos + (V2 10 0 `rotVec` CFloat sRot)
V2 x3 y3 = pos - (V2 0 25 `rotVec` 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
2017-12-20 01:00:28 +00:00
where
dim = V2 40 40
2017-12-21 04:21:20 +00:00
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