diff --git a/assets/haskelloid.png b/assets/haskelloid.png index f75a4e7..f633deb 100644 Binary files a/assets/haskelloid.png and b/assets/haskelloid.png differ diff --git a/haskelloids.cabal b/haskelloids.cabal index e5aac0a..aec1e0e 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -58,6 +58,7 @@ executable haskelloids , Commons , StateMachine , Menu + , InGame , Init default-extensions: OverloadedStrings diff --git a/src/Commons.hs b/src/Commons.hs index 4628ca4..ba9a293 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -38,23 +38,25 @@ wrapAround (V2 nx ny) width = (V2 nnx nny) | otherwise = ny half = width / 2 -newHaskelloids :: Image -> Affection UserData [Haskelloid] -newHaskelloids img = liftIO $ mapM (\_ -> do - posx <- randomRIO (0, 800) - posy <- randomRIO (0, 600) - velx <- randomRIO (-10, 10) - vely <- randomRIO (-10, 10) - rot <- randomRIO (-180, 180) - pitch <- randomRIO (-pi, pi) - div <- randomRIO (1, 2) - return $ Haskelloid - (V2 posx posy) - (V2 velx vely) - rot - pitch - div - img - ) [1..10] +newHaskelloids :: Affection UserData [Haskelloid] +newHaskelloids = do + img <- haskImage <$> getAffection + liftIO $ mapM (\_ -> do + posx <- randomRIO (0, 800) + posy <- randomRIO (0, 600) + velx <- randomRIO (-10, 10) + vely <- randomRIO (-10, 10) + rot <- randomRIO (-180, 180) + pitch <- randomRIO (-pi, pi) + div <- randomRIO (1, 2) + return $ Haskelloid + (V2 posx posy) + (V2 velx vely) + rot + pitch + div + img + ) [1..10] updateHaskelloid :: Double -> Haskelloid -> Haskelloid updateHaskelloid dsec has = diff --git a/src/InGame.hs b/src/InGame.hs index 5a5979c..c369b4d 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -1,235 +1,81 @@ +{-# LANGUAGE RecordWildCards #-} module InGame where -import Affection +import Affection as A import qualified SDL -import GEGL import qualified Data.Map as M import Data.Maybe (catMaybes, isJust, fromJust, isNothing) -import Control.Monad (when, foldM) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) import System.Random (randomRIO) -import Debug.Trace +import Linear import Types import Commons import Menu -loadGame :: Affection UserData () -loadGame = do - liftIO $ traceIO "loading game" +loadGame :: Affection UserData () -> Affection UserData () +loadGame stateChange = do + liftIO $ logIO A.Debug "loading game" ud <- getAffection - _ <- liftIO $ gegl_node_connect_to - (nodeGraph ud M.! KeyShipTranslate) - "output" - (nodeGraph ud M.! KeyShipOver) - "aux" - liftIO $ traceIO "nodes connected" - hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do - coords <- liftIO excludeShip - insertHaskelloid acc Nothing coords - ) [] ([0..9] :: [Int]) - liftIO $ traceIO "inserted haskelloids" - liftIO $ gegl_node_link_many $ map hFlange hs - liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop) - liftIO $ gegl_node_disconnect - (nodeGraph ud M.! KeyFGOver) - "aux" - liftIO $ traceIO "nodes linked" + nhs <- newHaskelloids + kid <- partSubscribe (subKeyboard $ subsystems ud) + (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $ + case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeSpace -> do + liftIO $ logIO Debug "TODO: PEW!" + SDL.KeycodeR -> do + liftIO $ logIO Debug "Reloading" + putAffection ud + { stateUUIDs = UUIDClean [] [] + } + loadGame stateChange + SDL.KeycodeEscape -> do + liftIO $ logIO Debug "Leave to Menu" + stateChange + _ -> return () + ) putAffection ud - { haskelloids = hs - , wonlost = Nothing - , shots = ParticleSystem - (ParticleStorage Nothing []) - (nodeGraph ud M.! KeyPNop) - (buffer ud) - , ship = Ship - { sPos = (375, 275) - , sVel = (0, 0) + { stateUUIDs = UUIDClean [] [kid] + , haskelloids = nhs + , ship = (ship ud) + { sPos = V2 400 300 + , sVel = V2 0 0 , sRot = 0 - , sFlange = nodeGraph ud M.! KeyShipRotate } - , pixelSize = 3 , state = InGame } - liftIO $ traceIO "game loaded" - present - (GeglRectangle 0 0 800 600) - (buffer ud) - True -excludeShip :: IO (Double, Double) -excludeShip = do - px <- randomRIO (0, 800) - py <- randomRIO (0, 600) - inter <- gegl_rectangle_intersect - (GeglRectangle px py 100 100) - (GeglRectangle 350 250 100 100) -- Ship's starting position and size - case inter of - Just _ -> - excludeShip - Nothing -> - return (fromIntegral px, fromIntegral py) updateGame :: Double -> Affection UserData () updateGame sec = do - ad <- get ud <- getAffection - when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize ud > 3) $ do - pd <- getAffection - liftIO $ gegl_node_set (nodeGraph pd M.! KeyPixelize) $ Operation "gegl:pixelize" - [ Property "size-x" $ PropertyInt $ pixelSize pd - 1 - , Property "size-y" $ PropertyInt $ pixelSize pd - 1 - ] - putAffection ud - { pixelSize = pixelSize ud -1 - } - let nx = fst (sPos $ ship ud) + fst (sVel $ ship ud) * sec - ny = snd (sPos $ ship ud) + snd (sVel $ ship ud) * sec - (nnx, nny) = wrapAround (nx, ny) 50 - liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble nnx - , Property "y" $ PropertyDouble nny - ] - liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate" - [ Property "degrees" $ PropertyDouble $ sRot $ ship ud - ] - td <- getAffection - putAffection td - { ship = (ship ud) - { sPos = (nnx, nny) - } - } - ud2 <- getAffection - nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) - ud3 <- getAffection - putAffection ud3 + let nhs = map (updateHaskelloid sec) (haskelloids ud) + putAffection ud { haskelloids = nhs + , ship = updateShip sec (ship ud) } - ud3 <- getAffection - ups <- updateParticleSystem (shots ud3) sec shotsUpd - ud4 <- getAffection - when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3) - putAffection ud4 - { shots = ups - } + +updateShip :: Double -> Ship -> Ship +updateShip ddt s@Ship{..} = s + { sPos = wrapAround (sPos + fmap (dt *) sVel) 40 + } + where + dt = realToFrac ddt drawGame :: Affection UserData () drawGame = do ud <- getAffection - liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink - present - (GeglRectangle 0 0 800 600) - (buffer ud) - True + mapM_ drawHaskelloid (haskelloids ud) + drawShip (ship ud) -handleGameEvent :: SDL.EventPayload -> Affection UserData () -handleGameEvent e = do - ad <- get - wd <- getAffection - sec <- getDelta - case e of - SDL.KeyboardEvent dat -> - case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of - SDL.KeycodeLeft -> do - ud <- getAffection - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed - && (isNothing $ wonlost ud)) $ do - let rawRot = (sRot $ ship ud) + 15 * sec - newRot - | rawRot > 360 = rawRot - 360 - | rawRot < 0 = rawRot + 360 - | otherwise = rawRot - putAffection ud - { ship = (ship ud) - { sRot = newRot - } - } - SDL.KeycodeRight -> do - ud <- getAffection - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed - && (isNothing $ wonlost ud)) $ do - let rawRot = (sRot $ ship ud) - 15 * sec - newRot - | rawRot > 360 = rawRot - 360 - | rawRot < 0 = rawRot + 360 - | otherwise = rawRot - putAffection ud - { ship = (ship ud) - { sRot = newRot - } - } - SDL.KeycodeUp -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed - && (isNothing $ wonlost wd)) $ do - ud <- getAffection - let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud) - vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud) - putAffection ud - { ship = (ship ud) - { sVel = (vx, vy) - } - } - -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud) - SDL.KeycodeSpace -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed - && (isNothing $ wonlost wd)) $ do - ud <- getAffection - liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ - Operation "gegl:pixelize" - [ Property "size-x" $ PropertyInt 8 - , Property "size-y" $ PropertyInt 8 - ] - -- ad <- get - let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud) - posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud) - tempRoot <- liftIO gegl_node_new - tempRect <- liftIO $ gegl_node_new_child tempRoot $ - Operation "gegl:rectangle" - [ Property "x" $ PropertyDouble posX - , Property "y" $ PropertyDouble posY - , Property "width" $ PropertyDouble 4 - , Property "height" $ PropertyDouble 4 - , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 - ] - tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation - _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux" - ips <- insertParticle (shots ud) - Particle - { particleTimeToLive = 5 - , particleCreation = elapsedTime ad - , particlePosition = (posX, posY) - , particleRotation = 0 - , particleVelocity = - ( (floor $ -200 * (sin $ toR $ sRot $ ship ud)) - , (floor $ -200 * (cos $ toR $ sRot $ ship ud)) - ) - , particlePitchRate = 0 - , particleRootNode = tempRoot - , particleNodeGraph = M.fromList - [ ("root", tempRoot) - , ("over", tempOver) - , ("rect", tempRect) - ] - , particleStackCont = tempOver - , particleDrawFlange = tempOver - } - putAffection $ ud - { shots = ips - , pixelSize = 8 - } - SDL.KeycodeR -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed - && isJust (wonlost wd)) $ do - liftIO $ traceIO "reloading" - liftIO $ clean wd - nd <- liftIO $ load - putAffection nd - loadGame - _ -> return () - SDL.WindowClosedEvent _ -> do - traceM "seeya!" - quit - _ -> return () +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 diff --git a/src/Main.hs b/src/Main.hs index 4a1e68b..668b0a9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -49,6 +49,7 @@ pre = do liftIO $ logIO A.Debug "Setting global resize event listener" _ <- partSubscribe (subWindow subs) $ \msg -> case msg of MsgWindowResize _ _ (V2 w h) -> do + liftIO $ logIO A.Debug "Window has been resized" let nw = floor $ fromIntegral h * (800/600) dw = floor $ (fromIntegral w - fromIntegral nw) / 2 GL.viewport $= (GL.Position dw 0, GL.Size nw h) diff --git a/src/Menu.hs b/src/Menu.hs index 2436a6a..fa12dcb 100644 --- a/src/Menu.hs +++ b/src/Menu.hs @@ -24,32 +24,27 @@ import Foreign.C.Types import Types import Commons -handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData () -handleMenuEvent _ es = do - (Subsystems w k) <- subsystems <$> getAffection - _ <- consumeSDLEvents w =<< consumeSDLEvents k es - return () - -loadMenu :: Affection UserData () -loadMenu = do +loadMenu :: (Affection UserData ()) -> Affection UserData () +loadMenu stateChange = do liftIO $ logIO A.Debug "Loading Menu" ud <- getAffection - hs <- newHaskelloids (haskImage ud) - _ <- partSubscribe (subKeyboard $ subsystems ud) - (\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of - SDL.KeycodeEscape -> do - liftIO $ logIO A.Debug "seeya" - quit - SDL.KeycodeF -> do - when (msgKbdKeyMotion kbdev == SDL.Pressed) $ do - liftIO $ logIO A.Debug "screen toggling" - toggleScreen - _ -> return () + hs <- newHaskelloids + kbdUUID <- partSubscribe (subKeyboard $ subsystems ud) + (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $ + case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "seeya" + quit + SDL.KeycodeSpace -> do + liftIO $ logIO A.Debug "Leaving Menu to Game" + stateChange + _ -> return () ) putAffection ud { haskelloids = hs , fade = FadeIn 1 , state = Menu + , stateUUIDs = UUIDClean [] [kbdUUID] -- , shots = (shots ud) -- { partSysParts = ParticleStorage Nothing [] } } @@ -83,12 +78,9 @@ drawMenu = do fontSize ctx 120 fontFace ctx "modulo" textAlign ctx (S.fromList [AlignCenter,AlignTop]) - -- (Bounds (V4 b0 b1 b2 b3)) <- textBoxBounds ctx x y' 150 "HASKELLOIDS" fillColor ctx (rgba 255 255 255 255) textBox ctx 0 200 800 "HASKELLOIDS" fillColor ctx (rgba 255 128 0 (alpha $ fade ud)) fontSize ctx 40 textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit" restore ctx - -- t <- getElapsedTime - -- liftIO $ drawSpinner (nano ud) 100 100 100 t diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 0758306..ad5dffd 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -14,20 +14,30 @@ import System.Random (randomRIO) import Types import Commons --- import InGame +import InGame import Menu instance StateMachine State UserData where - smLoad Menu = loadMenu + smLoad Menu = loadMenu (smClean Menu >> smLoad InGame) - -- smLoad InGame = loadGame + smLoad InGame = loadGame (smClean InGame >> smLoad Menu) smUpdate Menu = updateMenu - -- smUpdate InGame sec = updateGame sec + smUpdate InGame = updateGame smDraw Menu = drawMenu - -- smDraw InGame = drawGame + smDraw InGame = drawGame smEvent _ _ = return () + + smClean _ = do + ud <- getAffection + let (UUIDClean uuwin uukbd) = stateUUIDs ud + (Subsystems win kbd) = subsystems ud + mapM_ (partUnSubscribe win) uuwin + mapM_ (partUnSubscribe kbd) uukbd + putAffection ud + { stateUUIDs = UUIDClean [] [] + } diff --git a/src/Types.hs b/src/Types.hs index c063c6b..017e6d5 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -23,6 +23,7 @@ data UserData = UserData , font :: Font , subsystems :: Subsystems , haskImage :: Image + , stateUUIDs :: UUIDClean } data Ship = Ship @@ -60,6 +61,11 @@ data Subsystems = Subsystems , subKeyboard :: Keyboard } +data UUIDClean = UUIDClean + { uuWindow :: [MsgId WindowMessage] + , uuKeyboard :: [MsgId KeyboardMessage] + } + newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) instance Participant Window WindowMessage UserData where @@ -67,10 +73,16 @@ instance Participant Window WindowMessage UserData where subTups <- liftIO $ readTVarIO t return $ map snd subTups - partSubscribe (Window t) = generalSubscribe t + partSubscribe (Window t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgWindowEmptyEvent - partUnSubscribe (Window t) uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + partUnSubscribe (Window t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid)) + where + filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p instance SDLSubsystem Window UserData where consumeSDLEvents = consumeSDLWindowEvents @@ -82,15 +94,16 @@ instance Participant Keyboard KeyboardMessage UserData where subTups <- liftIO $ readTVarIO t return $ map snd subTups - partSubscribe (Keyboard t) = generalSubscribe t + partSubscribe (Keyboard t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgKeyboardEmptyEvent - partUnSubscribe (Keyboard t) uuid = - liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + partUnSubscribe (Keyboard t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid)) + where + filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p instance SDLSubsystem Keyboard UserData where consumeSDLEvents = consumeSDLKeyboardEvents - -generalSubscribe t funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid