haskanoid 0.1.5.2 → 0.1.5.3
raw patch · 8 files changed
+112/−86 lines, 8 files
Files
- haskanoid.cabal +3/−1
- src/Audio.hs +3/−2
- src/Display.hs +75/−56
- src/Game.hs +21/−20
- src/GameCollisions.hs +2/−2
- src/Input.hs +3/−3
- src/Main.hs +2/−1
- src/Objects.hs +3/−1
haskanoid.cabal view
@@ -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.+ .+ <<https://github.com/ivanperez-keera/haskanoid/blob/master/screenshots/android.gif?raw=true>> -- URL for the project homepage or repository. homepage: http://github.com/ivanperez-keera/haskanoid
src/Audio.hs view
@@ -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. --
src/Display.hs view
@@ -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
src/Game.hs view
@@ -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
src/GameCollisions.hs view
@@ -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.
src/Input.hs view
@@ -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
src/Main.hs view
@@ -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) )
src/Objects.hs view
@@ -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)]