diff --git a/haskanoid.cabal b/haskanoid.cabal --- a/haskanoid.cabal +++ b/haskanoid.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.5.2 +version: 0.1.5.3 -- A short (one-line) description of the package. synopsis: A breakout game written in Yampa using SDL @@ -18,6 +18,8 @@ -- A longer description of the package. description: An arkanoid game featuring SDL graphics and sound, and Wiimote & Kinect support, implemented using Yampa. + . + <> -- URL for the project homepage or repository. homepage: http://github.com/ivanperez-keera/haskanoid diff --git a/src/Audio.hs b/src/Audio.hs --- a/src/Audio.hs +++ b/src/Audio.hs @@ -16,6 +16,7 @@ stopMusic, musicPlaying) where +import Control.Applicative ((<$>)) import Control.Monad import Control.Concurrent import qualified Graphics.UI.SDL.Mixer.General as SDL.Mixer @@ -37,7 +38,7 @@ -- | Load a music file, returning a 'Music' if loaded successfully. loadMusic :: String -> IO (Maybe Music) -loadMusic fp = fmap (fmap (Music fp)) $ SDL.Mixer.Music.tryLoadMUS fp +loadMusic fp = fmap (Music fp) <$> SDL.Mixer.Music.tryLoadMUS fp -- | Play music in a loop at max volume. playMusic :: Music -> IO () @@ -55,7 +56,7 @@ -- | Load an audio file. loadAudio :: String -> IO (Maybe Audio) -loadAudio fp = fmap (fmap (Audio fp)) $ SDL.Mixer.Samples.tryLoadWAV fp +loadAudio fp = fmap (Audio fp) <$> SDL.Mixer.Samples.tryLoadWAV fp -- | Play an audio file for the given number of seconds. -- diff --git a/src/Display.hs b/src/Display.hs --- a/src/Display.hs +++ b/src/Display.hs @@ -1,5 +1,6 @@ module Display where +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.IfElse import Control.Monad.Trans.Class @@ -19,57 +20,7 @@ import Levels import Paths_haskanoid --- | Ad-hoc resource loading --- This function is ad-hoc in two senses: first, because it --- has the paths to the files hard-coded inside. And second, --- because it loads the specific resources that are needed, --- not a general --- -loadResources :: IO (Maybe ResourceMgr) -loadResources = runMaybeT $ do - -- Font initialization - ttfOk <- lift TTF.init - - gameFont <- liftIO $ getDataFileName "data/lacuna.ttf" - -- Load the fonts we need - font <- liftIO $ TTF.tryOpenFont gameFont 32 -- What does the 32 do? - let myFont = fmap (Font gameFont) font - - blockHit <- liftIO $ loadAudio =<< getDataFileName "data/196106_aiwha_ding-cc-by.wav" - - -- bgM <- liftIO $ loadMusic "Ckotty_-_Game_Loop_11.ogg" - -- bgM <- liftIO $ loadMusic "data/level0.mp3" - - -- let levelBg = "data/level0.png" - -- img <- lift $ fmap (Image levelBg) $ load levelBg - - ballImg <- liftIO $ getDataFileName "data/ball2.png" - ball <- lift $ fmap (Image ballImg) $ load ballImg - - b1Img <- liftIO $ getDataFileName "data/block1.png" - b1 <- lift $ fmap (Image b1Img) $ load b1Img - - b2Img <- liftIO $ getDataFileName "data/block2.png" - b2 <- lift $ fmap (Image b2Img) $ load b2Img - - b3Img <- liftIO $ getDataFileName "data/block3.png" - b3 <- lift $ fmap (Image b3Img) $ load b3Img - - paddleImg <- liftIO $ getDataFileName "data/paddleBlu.png" - paddle <- lift $ fmap (Image paddleImg) $ load paddleImg - - -- Start playing music - -- when (isJust bgM) $ lift (playMusic (fromJust bgM)) - - -- Return Nothing or embed in Resources - res <- case (myFont, blockHit) of - (Just f, Just b) -> let - in return (Resources f b Nothing ball b1 b2 b3 paddle Nothing) - _ -> do liftIO $ putStrLn "Some resources could not be loaded" - mzero - - liftIO $ fmap ResourceMgr $ - newIORef (ResourceManager (GameStarted) (res)) +-- * Initialization initializeDisplay :: IO () initializeDisplay = do @@ -91,13 +42,17 @@ -- Hide mouse SDL.showCursor False +-- * Rendering and Sound +-- | Loads new resources, renders the game state using SDL, and adjusts music. render :: ResourceMgr -> GameState -> IO() render resourceManager shownState = do resources <- loadNewResources resourceManager shownState audio resources shownState display resources shownState +-- ** Audio + audio :: Resources -> GameState -> IO() audio resources shownState = do -- Start bg music if necessary @@ -107,11 +62,14 @@ -- Play object hits mapM_ (audioObject resources) $ gameObjects shownState +audioObject :: Resources -> Object -> IO () audioObject resources object = when (objectHit object) $ case objectKind object of (Block _ _) -> playFile (blockHitSnd resources) 3000 _ -> return () +-- ** Painting + display :: Resources -> GameState -> IO() display resources shownState = do -- Obtain surface @@ -148,6 +106,7 @@ -- Double buffering SDL.flip screen +paintGeneral :: Surface -> Resources -> GameInfo -> IO () paintGeneral screen resources over = void $ do -- Paint screen green let format = surfaceGetPixelFormat screen @@ -155,12 +114,14 @@ fillRect screen Nothing bgColor paintGeneralHUD screen resources over +paintGeneralMsg :: Surface -> Resources -> GameStatus -> IO () paintGeneralMsg screen resources GamePlaying = return () paintGeneralMsg screen resources GamePaused = paintGeneralMsg' screen resources "Paused" paintGeneralMsg screen resources (GameLoading n) = paintGeneralMsg' screen resources ("Level " ++ show n) paintGeneralMsg screen resources GameOver = paintGeneralMsg' screen resources "GAME OVER!!!" paintGeneralMsg screen resources GameFinished = paintGeneralMsg' screen resources "You won!!! Well done :)" +paintGeneralMsg' :: Surface -> Resources -> String -> IO () paintGeneralMsg' screen resources msg = void $ do let font = resFont resources message <- TTF.renderTextSolid (unFont font) msg (SDL.Color 128 128 128) @@ -170,6 +131,7 @@ h = SDL.surfaceGetHeight message SDL.blitSurface message Nothing screen $ Just (SDL.Rect x y w h) +paintGeneralHUD :: Surface -> Resources -> GameInfo -> IO () paintGeneralHUD screen resources over = void $ do let font = unFont $ resFont resources message1 <- TTF.renderTextSolid font ("Level: " ++ show (gameLevel over)) (SDL.Color 128 128 128) @@ -186,8 +148,9 @@ h2 = SDL.surfaceGetHeight message3 SDL.blitSurface message3 Nothing screen $ Just (SDL.Rect (rightMargin - 10 - w2) 10 w2 h2) -paintObject resources screen object = do - red <- mapRGB format 0xFF 0 0 +-- | Paints a game object on a surface. +paintObject :: Resources -> Surface -> Object -> IO () +paintObject resources screen object = case objectKind object of (Paddle (w,h)) -> void $ do let bI = imgSurface $ paddleImg resources t <- mapRGB (surfaceGetPixelFormat bI) 0 255 0 @@ -199,7 +162,7 @@ y' = y - round r sz = round (2*r) -- b <- convertSurface (imgSurface $ ballImg resources) (format) [] - let bI = imgSurface $ ballImg resources + let bI = imgSurface $ ballImg resources t <- mapRGB (surfaceGetPixelFormat bI) 0 255 0 setColorKey bI [SrcColorKey, RLEAccel] t SDL.blitSurface bI Nothing screen $ Just (SDL.Rect x' y' sz sz) @@ -212,6 +175,8 @@ blockImage 2 = block2Img resources blockImage n = block3Img resources +-- * Resource management + newtype ResourceMgr = ResourceMgr { unResMgr :: IORef ResourceManager } data ResourceManager = ResourceManager @@ -219,6 +184,7 @@ , resources :: Resources } +-- | Includes all the assets needed at the current time in the game. data Resources = Resources { resFont :: Font , blockHitSnd :: Audio @@ -234,6 +200,59 @@ data Image = Image { imgName :: String, imgSurface :: Surface } data Font = Font { fontName :: String, unFont :: TTF.Font } +-- | Ad-hoc resource loading +-- This function is ad-hoc in two senses: first, because it +-- has the paths to the files hard-coded inside. And second, +-- because it loads the specific resources that are needed, +-- not a general +-- +loadResources :: IO (Maybe ResourceMgr) +loadResources = runMaybeT $ do + -- Font initialization + ttfOk <- lift TTF.init + + gameFont <- liftIO $ getDataFileName "data/lacuna.ttf" + -- Load the fonts we need + font <- liftIO $ TTF.tryOpenFont gameFont 32 -- What does the 32 do? + let myFont = fmap (Font gameFont) font + + blockHit <- liftIO $ loadAudio =<< getDataFileName "data/196106_aiwha_ding-cc-by.wav" + + -- bgM <- liftIO $ loadMusic "Ckotty_-_Game_Loop_11.ogg" + -- bgM <- liftIO $ loadMusic "data/level0.mp3" + + -- let levelBg = "data/level0.png" + -- img <- lift $ fmap (Image levelBg) $ load levelBg + + ballImg <- liftIO $ getDataFileName "data/ball2.png" + ball <- lift $ Image ballImg <$> load ballImg + + b1Img <- liftIO $ getDataFileName "data/block1.png" + b1 <- lift $ Image b1Img <$> load b1Img + + b2Img <- liftIO $ getDataFileName "data/block2.png" + b2 <- lift $ Image b2Img <$> load b2Img + + b3Img <- liftIO $ getDataFileName "data/block3.png" + b3 <- lift $ Image b3Img <$> load b3Img + + paddleImg <- liftIO $ getDataFileName "data/paddleBlu.png" + paddle <- lift $ Image paddleImg <$> load paddleImg + + -- Start playing music + -- when (isJust bgM) $ lift (playMusic (fromJust bgM)) + + -- Return Nothing or embed in Resources + res <- case (myFont, blockHit) of + (Just f, Just b) -> let + in return (Resources f b Nothing ball b1 b2 b3 paddle Nothing) + _ -> do liftIO $ putStrLn "Some resources could not be loaded" + mzero + + liftIO $ ResourceMgr <$> + newIORef (ResourceManager GameStarted res) + + loadNewResources :: ResourceMgr -> GameState -> IO Resources loadNewResources mgr state = do manager <- readIORef (unResMgr mgr) @@ -242,7 +261,7 @@ oldResources = resources manager newResources <- case newState of - (GameLoading _) | (newState /= oldState) + (GameLoading _) | newState /= oldState -> updateAllResources oldResources newState _ -> return oldResources @@ -262,7 +281,7 @@ let oldMusic = bgMusic res oldMusicFP = maybe "" musicName oldMusic - newMusic <- if (oldMusicFP == newMusicFP) + newMusic <- if oldMusicFP == newMusicFP then return oldMusic else do -- Loading can fail, in which case we continue -- with the old music diff --git a/src/Game.hs b/src/Game.hs --- a/src/Game.hs +++ b/src/Game.hs @@ -39,6 +39,7 @@ module Game (wholeGame) where -- External imports +import Control.Applicative ((<$>)) import Data.List import Data.Tuple.Utils import FRP.Yampa @@ -51,7 +52,7 @@ import Physics.TwoDimensions.Collisions import Physics.TwoDimensions.Dimensions --- Internal iports +-- Internal imports import Constants import GameCollisions import GameState @@ -171,7 +172,7 @@ -- | Detect if the level is completed (ie. if there are no more blocks). isLevelCompleted :: SF GameState (Event GameState) -isLevelCompleted = proc (s) -> do +isLevelCompleted = proc s -> do over <- edge -< not $ any isBlock (map objectKind (gameObjects s)) let snapshot = over `tag` s returnA -< snapshot @@ -264,7 +265,7 @@ gamePlay' objs = loopPre ([],[],0) $ -- Process physical movement and detect new collisions ((adaptInput >>> processMovement >>> (arr elemsIL &&& detectObjectCollisions)) - &&& (arr (thd3.snd))) -- This last bit just carries the old points forward + &&& arr (thd3.snd)) -- This last bit just carries the old points forward -- Adds the old point count to the newly-made points >>> (arr fst &&& arr (\((_,cs),o) -> o + countPoints cs)) @@ -294,7 +295,7 @@ (noEvent --> arr suicidalSect) -- When necessary, remove all elements that must be removed (\sfs' f -> processMovement' (f sfs')) -- Move along! Move along! (with new state, aka. sfs) - suicidalSect :: (a, IL ObjectOutput) -> (Event (IL ObjectSF -> IL ObjectSF)) + suicidalSect :: (a, IL ObjectOutput) -> Event (IL ObjectSF -> IL ObjectSF) suicidalSect (_,oos) = -- Turn every event carrying a function that transforms the -- object signal function list into one function that performs @@ -304,7 +305,7 @@ -- Turn every object that wants to kill itself into -- a function that removes it from the list where es :: [Event (IL ObjectSF -> IL ObjectSF)] - es = [ harakiri oo `tag` (deleteIL k) + es = [ harakiri oo `tag` deleteIL k | (k,oo) <- assocsIL oos ] -- From the actual objects, detect which ones collide @@ -313,12 +314,12 @@ -- Count-points countPoints :: Collisions -> Int - countPoints = (sum . map numPoints) + countPoints = sum . map numPoints where numPoints (Collision cd) | hasBall cd = countBlocks cd | otherwise = 0 hasBall = any ((=="ball").fst) - countBlocks = length . filter ((isPrefixOf "block").fst) + countBlocks = length . filter (isPrefixOf "block" . fst) @@ -356,7 +357,7 @@ followPaddleDetectLaunch = proc oi -> do o <- followPaddle -< oi click <- edge -< controllerClick (userInput oi) - returnA -< (o, click `tag` (objectPos (outputObject o))) + returnA -< (o, click `tag` objectPos (outputObject o)) bounceAroundDetectMiss p = proc oi -> do o <- bouncingBall p initialBallVel -< oi @@ -379,12 +380,12 @@ -- -- This code allows for the paddle not to exist (Maybe), although that should -- never happen in practice. - let mbPaddlePos = fmap objectPos $ find isPaddle (knownObjects oi) + let mbPaddlePos = objectPos <$> find isPaddle (knownObjects oi) ballPos = maybe (outOfScreen, outOfScreen) ((paddleWidth/2, - ballHeight) ^+^) mbPaddlePos in ObjectOutput (inertBallAt ballPos) noEvent - where outOfScreen = (-10) + where outOfScreen = -10 inertBallAt p = Object { objectName = "ball" , objectKind = Ball ballWidth , objectPos = p @@ -414,9 +415,9 @@ -- Calculate the future tentative position, and -- bounce if necessary. -- - -- The ballBounce needs the ball SF' input (which has knowledge of - -- collisions), so we carry it parallely to the tentative new positions, - -- and then use it to detect when it's time to bounce + -- The ballBounce needs the ball SF' input (which has knowledge of + -- collisions), so we carry it parallely to the tentative new positions, + -- and then use it to detect when it's time to bounce -- ========================== ============================ -- -==--------------------->==--->==- ------------------->== @@ -427,9 +428,9 @@ -- ========================== ============================ progressAndBounce = (arr id &&& freeBall') >>> (arr snd &&& ballBounce) - -- Position of the ball, starting from p0 with velicity v0, since the - -- time of last switching (or being fired, whatever happened last) - -- provided that no obstacles are encountered. + -- Position of the ball, starting from p0 with velicity v0, since the + -- time of last switching (or being fired, whatever happened last) + -- provided that no obstacles are encountered. freeBall' = freeBall p0 v0 -- | Detect if the ball must bounce and, if so, take a snapshot of the object's @@ -585,7 +586,7 @@ -- let isDead = False -- immortal blocks returnA -< ObjectOutput - (Object{ objectName = name + Object{ objectName = name , objectKind = Block lives (w, h) , objectPos = (x,y) , objectVel = (0,0) @@ -595,7 +596,7 @@ , canCauseCollisions = False , collisionEnergy = 0 , displacedOnCollision = False - }) + } dead -- *** Walls @@ -631,7 +632,7 @@ objWall name side pos = proc (ObjectInput ci cs os) -> do let isHit = inCollision name cs returnA -< ObjectOutput - (Object { objectName = name + Object { objectName = name , objectKind = Side side , objectPos = pos , objectVel = (0,0) @@ -641,5 +642,5 @@ , canCauseCollisions = False , collisionEnergy = 0 , displacedOnCollision = False - }) + } noEvent diff --git a/src/GameCollisions.hs b/src/GameCollisions.hs --- a/src/GameCollisions.hs +++ b/src/GameCollisions.hs @@ -108,8 +108,8 @@ [] -> Nothing (_, v') : _ -> Just v' - -- IP: It should be something like the following, but that doesn't - -- work: + -- IP: It should be something like the following, but that doesn't + -- work: -- vs -> Just (foldl (^+^) (0,0) (map snd vs)) -- | True if the velocity of the object has been changed by any collision. diff --git a/src/Input.hs b/src/Input.hs --- a/src/Input.hs +++ b/src/Input.hs @@ -226,9 +226,9 @@ MouseMotion x y _ _ -> c { controllerPos = (fromIntegral x, fromIntegral y)} MouseButtonDown _ _ ButtonLeft -> c { controllerClick = True } MouseButtonUp _ _ ButtonLeft -> c { controllerClick = False} - KeyUp (Keysym { symKey = SDLK_p }) -> c { controllerPause = not (controllerPause c) } - KeyDown (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = True } - KeyUp (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = False } + KeyUp Keysym { symKey = SDLK_p } -> c { controllerPause = not (controllerPause c) } + KeyDown Keysym { symKey = SDLK_SPACE } -> c { controllerClick = True } + KeyUp Keysym { symKey = SDLK_SPACE } -> c { controllerClick = False } _ -> c diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,3 +1,4 @@ +import Control.Applicative ((<$>)) import Control.Monad.IfElse import FRP.Yampa as Yampa @@ -20,7 +21,7 @@ reactimate (initGraphs >> senseInput controllerRef) (\_ -> do -- Get clock and new input - dtSecs <- fmap milisecsToSecs $ senseTimeRef timeRef + dtSecs <- milisecsToSecs <$> senseTimeRef timeRef mInput <- senseInput controllerRef return (dtSecs, Just mInput) ) diff --git a/src/Objects.hs b/src/Objects.hs --- a/src/Objects.hs +++ b/src/Objects.hs @@ -49,7 +49,7 @@ isBall _ = False isBlock :: ObjectKind -> Bool -isBlock (Block {}) = True +isBlock Block {} = True isBlock _ = False isPaddle :: Object -> Bool @@ -93,11 +93,13 @@ | overlap obj1 obj2 = Just (collisionResponseObj obj1 obj2) | otherwise = Nothing +overlap :: Object -> Object -> Bool overlap obj1 obj2 = overlapShape (objShape obj1) (objShape obj2) collisionSide :: Object -> Object -> Side collisionSide obj1 obj2 = shapeCollisionSide (objShape obj1) (objShape obj2) +collisionResponseObj :: Object -> Object -> Collision collisionResponseObj o1 o2 = Collision $ map objectToCollision [(o1, side, o2), (o2, side', o1)]