{-# 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