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