diff --git a/haskanoid.cabal b/haskanoid.cabal --- a/haskanoid.cabal +++ b/haskanoid.cabal @@ -4,13 +4,11 @@ -- The name of the package. name: haskanoid --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- The package version. We follow semantic versioning. -- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.1.5.4 +-- | | +----- non-breaking changes +-- | | | +version: 0.1.6 -- A short (one-line) description of the package. synopsis: A breakout game written in Yampa using SDL @@ -45,7 +43,7 @@ build-type: Simple -- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.8 +cabal-version: >=1.10 data-files: data/*.png data/*.wav data/*.mp3 data/*.ttf @@ -57,6 +55,10 @@ Description: Enable Kinect support (with freenect) Default: True +Flag bearriver + Description: Compile with bearriver instead of Yampa + Default: False + executable haskanoid -- .hs or .lhs file containing the Main module. main-is: Main.hs @@ -95,15 +97,24 @@ Physics.TwoDimensions.Dimensions Physics.TwoDimensions.Physics Resources + Paths_haskanoid -- Other library packages from which modules are imported. build-depends: base >= 4.6 && < 5, - transformers >= 0.3 && < 0.6, - mtl, + IfElse, MissingH, - Yampa >= 0.9.6 && < 0.11, + mtl, SDL, SDL-image, SDL-mixer, SDL-ttf, - IfElse + simple-affine-space, + transformers >= 0.3 && < 0.6 + + default-language: + Haskell2010 + + if flag(bearriver) + build-depends: bearriver >= 0.9.6 && < 0.15 + else + build-depends: Yampa >= 0.13 && < 0.15 if flag(wiimote) build-depends: hcwiid diff --git a/src/Audio.hs b/src/Audio.hs --- a/src/Audio.hs +++ b/src/Audio.hs @@ -1,31 +1,38 @@ --- | A layer of abstraction on top of SDL audio. +-- | +-- Copyright : (c) Keera Studios, 2010-2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- +-- A layer of abstraction on top of SDL audio. +-- -- It plays audio soundfx asynchronously (in a new thread), which means that -- programs must be compiled with the threaded Runtime System (ghc flag is -- -threaded). --- --- This module is 2010-2014 (c) Keera Studios, redistributed with permission. module Audio - (Music(..), - Audio(..), - initAudio, - loadAudio, - loadMusic, - playMusic, - playFile, - stopMusic, - musicPlaying) where + ( Music(..) + , Audio(..) + , initAudio + , loadAudio + , loadMusic + , playMusic + , playFile + , stopMusic + , musicPlaying + ) + where -import Control.Applicative ((<$>)) -import Control.Monad -import Control.Concurrent -import qualified Graphics.UI.SDL.Mixer.General as SDL.Mixer +-- External imports +import Control.Applicative ((<$>)) +import Control.Concurrent +import Control.Monad import qualified Graphics.UI.SDL.Mixer.Channels as SDL.Mixer.Channels -import qualified Graphics.UI.SDL.Mixer.Music as SDL.Mixer.Music -import qualified Graphics.UI.SDL.Mixer.Types as SDL.Mixer.Types -import qualified Graphics.UI.SDL.Mixer.Samples as SDL.Mixer.Samples +import qualified Graphics.UI.SDL.Mixer.General as SDL.Mixer +import qualified Graphics.UI.SDL.Mixer.Music as SDL.Mixer.Music +import qualified Graphics.UI.SDL.Mixer.Samples as SDL.Mixer.Samples +import qualified Graphics.UI.SDL.Mixer.Types as SDL.Mixer.Types data Music = Music { musicName :: String, unMusic :: SDL.Mixer.Types.Music } + data Audio = Audio { audioName :: String, unAudio :: SDL.Mixer.Types.Chunk } -- | Initialize the audio subsystem. @@ -63,6 +70,6 @@ -- This function spawns a new OS thread. Remember to compile your program -- with the threaded RTS. playFile :: Audio -> Int -> IO () -playFile wav t = void $ forkOS $ do +playFile wav t = void $ forkOS $ do _v <- SDL.Mixer.Channels.playChannel (-1) (unAudio wav) 0 threadDelay (t * 1000) diff --git a/src/Constants.hs b/src/Constants.hs --- a/src/Constants.hs +++ b/src/Constants.hs @@ -1,20 +1,32 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Game constants. module Constants where +-- External imports import FRP.Yampa + +-- Internal imports import Physics.TwoDimensions.Dimensions width :: Double -width = 640 +width = 640 + height :: Double height = 600 -gameTop :: Double -gameTop = 100 -gameLeft :: Double -gameLeft = 0 +gameTop :: Double +gameTop = 100 +gameLeft :: Double +gameLeft = 0 + gameWidth :: Double gameWidth = width + gameHeight :: Double gameHeight = height - gameTop @@ -24,19 +36,30 @@ paddleWidth, paddleHeight :: Double paddleWidth = 104 paddleHeight = 24 + paddleMargin :: Double paddleMargin = 50 + ballWidth, ballHeight :: Double -ballWidth = 10 -ballHeight = 10 +ballWidth = 10 +ballHeight = 10 + ballMargin :: Double -ballMargin = 30 +ballMargin = 30 + blockWidth, blockHeight :: Double -blockWidth = 64 -blockHeight = 32 +blockWidth = 64 +blockHeight = 32 + blockSeparation :: Double blockSeparation = 10 +maxBlockLife :: Int +maxBlockLife = 3 + +minBlockLife :: Int +minBlockLife = 1 + initialBallVel :: Pos2D initialBallVel = (300, -300) @@ -53,10 +76,10 @@ -- Max speed maxVNorm :: Double maxVNorm = 300 - --- Delays --- restartDelay :: Time --- restartDelay = 3 --- --- wonDelay :: Time --- wonDelay = 3 + +-- * Debugging + +-- | Initial level. Change this in the code to start +-- from a different level. +initialLevel :: Int +initialLevel = 0 diff --git a/src/Control/Extra/Monad.hs b/src/Control/Extra/Monad.hs --- a/src/Control/Extra/Monad.hs +++ b/src/Control/Extra/Monad.hs @@ -1,19 +1,28 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to Control.Monad. module Control.Extra.Monad where +-- External imports import Control.Monad whileLoopM :: Monad m => m a -> (a -> Bool) -> (a -> m ()) -> m () whileLoopM val cond act = r' - where r' = do v <- val - when (cond v) $ do - act v - whileLoopM val cond act + where + r' = do v <- val + when (cond v) $ do + act v + whileLoopM val cond act foldLoopM :: Monad m => a -> m b -> (b -> Bool) -> (a -> b -> m a) -> m a foldLoopM val sense cond act = r' - where r' = do s <- sense - if cond s - then do - val' <- act val s - foldLoopM val' sense cond act - else return val + where + r' = do s <- sense + if cond s + then do + val' <- act val s + foldLoopM val' sense cond act + else return val diff --git a/src/Data/Extra/List.hs b/src/Data/Extra/List.hs --- a/src/Data/Extra/List.hs +++ b/src/Data/Extra/List.hs @@ -1,4 +1,10 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to Data.List. module Data.Extra.List where mapFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b] -mapFilter f p = map f . filter p +mapFilter f p = map f . filter p diff --git a/src/Data/Extra/Num.hs b/src/Data/Extra/Num.hs --- a/src/Data/Extra/Num.hs +++ b/src/Data/Extra/Num.hs @@ -1,3 +1,9 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to the 'Num' typeclass. module Data.Extra.Num where ensurePos :: (Eq a, Num a) => a -> a diff --git a/src/Data/Extra/Ord.hs b/src/Data/Extra/Ord.hs --- a/src/Data/Extra/Ord.hs +++ b/src/Data/Extra/Ord.hs @@ -1,5 +1,10 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to the 'Ord' typeclass. module Data.Extra.Ord where -inRange :: Ord a => (a,a) -> a -> a +inRange :: Ord a => (a, a) -> a -> a inRange (mN, mX) x = min mX (max mN x) - diff --git a/src/Data/Extra/VectorSpace.hs b/src/Data/Extra/VectorSpace.hs --- a/src/Data/Extra/VectorSpace.hs +++ b/src/Data/Extra/VectorSpace.hs @@ -1,6 +1,13 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to Data.VectorSpace. module Data.Extra.VectorSpace where -import FRP.Yampa.VectorSpace +-- External imports +import Data.VectorSpace limitNorm :: (Ord s, VectorSpace v s) => v -> s -> v limitNorm v mn = if norm v > mn then mn *^ normalize v else v diff --git a/src/Display.hs b/src/Display.hs --- a/src/Display.hs +++ b/src/Display.hs @@ -1,24 +1,32 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Audio and video renderer. module Display where -import Control.Applicative ((<$>)) -import Control.Monad -import Control.Monad.IfElse -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Control.Monad.IO.Class -import Data.IORef -import Data.Maybe -import Graphics.UI.SDL as SDL -import qualified Graphics.UI.SDL.TTF as TTF -import Graphics.UI.SDL.Image as Image +-- External imports +import Control.Applicative ((<$>)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.IfElse +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.IORef +import Data.Maybe +import Graphics.UI.SDL as SDL +import Graphics.UI.SDL.Image as Image +import qualified Graphics.UI.SDL.TTF as TTF +-- Internal imports import Audio import Constants import GameState -import Objects -import Resources hiding (audio) import Levels +import Objects import Paths_haskanoid +import Resources hiding (audio) -- * Initialization @@ -44,7 +52,7 @@ -- * Rendering and Sound --- | Loads new resources, renders the game state using SDL, and adjusts music. +-- | Loads new resources, renders the game state using SDL, and adjusts music. render :: ResourceMgr -> GameState -> IO() render resourceManager shownState = do resources <- loadNewResources resourceManager shownState @@ -57,7 +65,7 @@ audio resources shownState = do -- Start bg music if necessary playing <- musicPlaying - unless playing $ awhen (bgMusic resources) playMusic + unless playing $ awhen (bgMusic resources) playMusic -- Play object hits mapM_ (audioObject resources) $ gameObjects shownState @@ -71,7 +79,7 @@ -- ** Painting display :: Resources -> GameState -> IO() -display resources shownState = do +display resources shownState = do -- Obtain surface screen <- getVideoSurface @@ -86,8 +94,8 @@ SDL.blitSurface bg Nothing screen $ Just rectBg hud <- createRGBSurface [SWSurface] - (round width) (round gameTop) - 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF + (round width) (round gameTop) + 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF paintGeneral hud resources (gameInfo shownState) let rectHud = SDL.Rect 0 0 (round width) (round gameTop) SDL.blitSurface hud Nothing screen $ Just rectHud @@ -96,11 +104,12 @@ -- The 32 is important because we are using Word32 for the masks -- FIXME: Should I use HWSurface and possibly other flags (alpha?)? surface <- createRGBSurface [SWSurface] - (round gameWidth) (round gameHeight) - 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF + (round gameWidth) (round gameHeight) + 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF paintGeneralMsg surface resources (gameStatus (gameInfo shownState)) mapM_ (paintObject resources surface) $ gameObjects shownState - let rect = SDL.Rect (round gameLeft) (round gameTop) (round gameWidth) (round gameHeight) + let rect = SDL.Rect (round gameLeft) (round gameTop) + (round gameWidth) (round gameHeight) SDL.blitSurface surface Nothing screen $ Just rect -- Double buffering @@ -115,11 +124,15 @@ 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 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 @@ -134,46 +147,63 @@ 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) + message1 <- TTF.renderTextSolid font + ("Level: " ++ show (gameLevel over)) + (SDL.Color 128 128 128) let w1 = SDL.surfaceGetWidth message1 h1 = SDL.surfaceGetHeight message1 SDL.blitSurface message1 Nothing screen $ Just (SDL.Rect 10 10 w1 h1) - message2 <- TTF.renderTextSolid font ("Points: " ++ show (gamePoints over)) (SDL.Color 128 128 128) + message2 <- TTF.renderTextSolid font + ("Points: " ++ show (gamePoints over)) + (SDL.Color 128 128 128) let w2 = SDL.surfaceGetWidth message2 h2 = SDL.surfaceGetHeight message2 - SDL.blitSurface message2 Nothing screen $ Just (SDL.Rect 10 (10 + h2 + 5) w2 h2) - message3 <- TTF.renderTextSolid font ("Lives: " ++ show (gameLives over)) (SDL.Color 128 128 128) + SDL.blitSurface message2 Nothing screen $ + Just (SDL.Rect 10 (10 + h2 + 5) w2 h2) + message3 <- TTF.renderTextSolid font + ("Lives: " ++ show (gameLives over)) + (SDL.Color 128 128 128) let rightMargin = SDL.surfaceGetWidth screen w2 = SDL.surfaceGetWidth message3 h2 = SDL.surfaceGetHeight message3 - SDL.blitSurface message3 Nothing screen $ Just (SDL.Rect (rightMargin - 10 - w2) 10 w2 h2) + SDL.blitSurface message3 Nothing screen $ + Just (SDL.Rect (rightMargin - 10 - w2) 10 w2 h2) -- | 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 - setColorKey bI [SrcColorKey, RLEAccel] t - SDL.blitSurface bI Nothing screen $ Just (SDL.Rect x y (round w) (round h)) - (Block e (w,h)) -> void $ do let bI = imgSurface $ blockImage e - SDL.blitSurface bI Nothing screen $ Just (SDL.Rect x y (round w) (round h)) - (Ball r) -> void $ do let x' = x - round r - y' = y - round r - sz = round (2*r) - -- b <- convertSurface (imgSurface $ ballImg resources) (format) [] - 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) - _ -> return () - where format = surfaceGetPixelFormat screen - p = objectPos object - x = round (fst p) - y = round (snd p) - blockImage 3 = block1Img resources - blockImage 2 = block2Img resources - blockImage n = block3Img resources + case objectKind object of + (Paddle (w, h)) -> void $ do let bI = imgSurface $ paddleImg resources + t <- mapRGB + (surfaceGetPixelFormat bI) 0 255 0 + setColorKey bI [SrcColorKey, RLEAccel] t + SDL.blitSurface bI Nothing screen $ + Just (SDL.Rect x y (round w) (round h)) + (Block e (w, h)) -> void $ do let bI = imgSurface $ blockImage e + SDL.blitSurface bI Nothing screen $ + Just (SDL.Rect x y (round w) (round h)) + (Ball r) -> void $ do let x' = x - round r + y' = y - round r + sz = round (2 * r) + -- b <- convertSurface + -- (imgSurface $ ballImg resources) + -- (format) + -- [] + 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) + _ -> return () + where + format = surfaceGetPixelFormat screen + p = objectPos object + x = round (fst p) + y = round (snd p) + blockImage 3 = block1Img resources + blockImage 2 = block2Img resources + blockImage n = block3Img resources -- * Resource management @@ -197,26 +227,27 @@ , bgMusic :: Maybe Music } -data Image = Image { imgName :: String, imgSurface :: Surface } -data Font = Font { fontName :: String, unFont :: TTF.Font } +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 -- +-- 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? + 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" + 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" @@ -244,15 +275,18 @@ -- 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 + (Just f, Just b) -> 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) @@ -263,7 +297,7 @@ newResources <- case newState of (GameLoading _) | newState /= oldState -> updateAllResources oldResources newState - _ -> return oldResources + _ -> return oldResources let manager' = ResourceManager { lastKnownStatus = newState , resources = newResources @@ -282,15 +316,16 @@ oldMusicFP = maybe "" musicName oldMusic newMusic <- if oldMusicFP == newMusicFP - then return oldMusic - else do -- Loading can fail, in which case we continue - -- with the old music - bgM <- loadMusic newMusicFP - if isNothing bgM - then do putStrLn $ "Could not load resource " ++ newMusicFP - return oldMusic - else do stopMusic - return bgM + then return oldMusic + else do -- Loading can fail, in which case we continue with the + -- old music + bgM <- loadMusic newMusicFP + if isNothing bgM + then do putStrLn $ + "Could not load resource " ++ newMusicFP + return oldMusic + else do stopMusic + return bgM -- Load new background let newBgFP' = _resourceFP $ levelBg $ levels !! n diff --git a/src/FRP/Extra/Yampa.hs b/src/FRP/Extra/Yampa.hs --- a/src/FRP/Extra/Yampa.hs +++ b/src/FRP/Extra/Yampa.hs @@ -1,29 +1,35 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to FRP.Yampa. module FRP.Extra.Yampa where +-- External imports import Control.Arrow import FRP.Yampa --- Auxiliary Yampa stuff - -- holdWhen behaves normally, outputting only the b, when the second value --- is false, and it holds the last known value when the value is True. -holdWhen :: b -> SF a (b,Bool) -> SF a b -holdWhen b_init sf = sf >>> holdOutput >>> hold b_init - where holdOutput = arr (\(b,discard) -> if discard then noEvent else Event b) +-- is false, and it holds the last known value when the value is True. +holdWhen :: b -> SF a (b, Bool) -> SF a b +holdWhen bInit sf = sf >>> holdOutput >>> hold bInit + where + holdOutput = arr (\(b, discard) -> if discard then noEvent else Event b) --- Given an occasional producer of functions --- and a source of info, apply the functions when they --- exist +-- Given an occasional producer of functions and a source of info, apply the +-- functions when they exist mergeApply :: SF a b -> SF a (Event (b -> b)) -> SF a b mergeApply sf1 sf2 = - (sf1 &&& sf2) >>> (arr (\(b,ef) -> event b ($ b) ef)) + (sf1 &&& sf2) >>> arr (\(b, ef) -> event b ($ b) ef) mergeApply' :: SF a (b, Event (b -> b)) -> SF a b -mergeApply' sf1 = sf1 >>> (arr (\(b,ef) -> event b ($ b) ef)) +mergeApply' sf1 = sf1 >>> arr (\(b, ef) -> event b ($ b) ef) rRestart :: SF a (b, Event c) -> SF a b rRestart sf = r - where r = switch sf (const r) + where + r = switch sf (const r) futureSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b futureSwitch sf cont = switch (sf >>> (arr id *** notYet)) cont @@ -35,4 +41,3 @@ boolToEvent True = Event boolToEvent _ = \_ -> noEvent {-# INLINE boolToEvent #-} - diff --git a/src/Game.hs b/src/Game.hs --- a/src/Game.hs +++ b/src/Game.hs @@ -1,24 +1,28 @@ {-# LANGUAGE Arrows #-} --- | This module defines the game as a big Signal Function that transforms a +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- This module defines the game as a big Signal Function that transforms a -- Signal carrying a Input 'Controller' information into a Signal carrying -- 'GameState'. -- -- There is no randomness in the game, the only input is the user's. -- 'Controller' is an abstract representation of a basic input device with -- position information and a /fire/ button. --- +-- -- The output is defined in 'GameState', and consists of basic information --- (points, current level, etc.) and a universe of objects. +-- (points, current level, etc.) and a universe of objects. -- -- Objects are represented as Signal Functions as well ('ObjectSF'). This -- allows them to react to user input and change with time. Each object is -- responsible for itself, but it cannot affect others: objects can watch --- others, depend on others and react to them, but they cannot /send a --- message/ or eliminate other objects. However, if you would like to --- dynamically introduce new elements in the game (for instance, falling --- powerups that the player must collect before they hit the ground) then it --- might be a good idea to allow objects not only to /kill themselves/ but --- also to spawn new object. +-- others, depend on others and react to them, but they cannot /send a message/ +-- or eliminate other objects. However, if you would like to dynamically +-- introduce new elements in the game (for instance, falling powerups that the +-- player must collect before they hit the ground) then it might be a good idea +-- to allow objects not only to /kill themselves/ but also to spawn new object. -- -- This module contains three sections: -- @@ -68,9 +72,9 @@ -- ('wonGame'). wholeGame :: SF Controller GameState wholeGame = switch - -- restart normal behaviour every time I'm out of lives - (canLose >>> (arr id &&& outOfLevels)) - (\_ -> wonGame) + -- restart normal behaviour every time I'm out of lives + (canLose >>> (arr id &&& outOfLevels)) + (\_ -> wonGame) -- | Detect when the last level is finished. outOfLevels :: SF GameState (Event ()) @@ -80,9 +84,9 @@ -- ('outOfLives'), in which case the game must be restarted ('restartGame'). canLose :: SF Controller GameState canLose = switch - -- retart normal behaviour every time I'm out of lives - (gameAlive >>> (arr id &&& outOfLives)) - (\_ -> restartGame) + -- retart normal behaviour every time I'm out of lives + (gameAlive >>> (arr id &&& outOfLives)) + (\_ -> restartGame) -- | Detect when the last life is lost. outOfLives :: SF GameState (Event ()) @@ -97,7 +101,7 @@ -- | Produces a neutral 'GameOver' 'GameState'. gameOver :: SF a GameState gameOver = arr $ const $ - neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameOver } } + neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameOver } } -- | The game state is finished for 4 seconds, then the game is run again -- ('wholeGame'). @@ -108,7 +112,7 @@ -- | Produces a neutral 'GameFinished' 'GameState'. gameFinished :: SF a GameState gameFinished = arr $ const $ - neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameFinished } } + neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameFinished } } -- | Run the game from the beginning (no points, max lives, etc.). -- @@ -126,16 +130,16 @@ -- continuation. runLevel :: Int -> Int -> Int -> SF Controller GameState runLevel lives level pts = loadLevel lives level pts loadingDelay - (gameWithLives lives level pts) + (gameWithLives lives level pts) -- | Unconditionally output the game in loading state ('levelLoading') for some -- time, and then ('after') switch over to the given continuation. -- -- The given arguments are the lives, the level, the points, the time to stay -- loading the game and the continuation. -loadLevel :: Int -> Int -> Int -> DTime -> SF a GameState -> SF a GameState +loadLevel :: Int -> Int -> Int -> DTime -> SF a GameState -> SF a GameState loadLevel lives level pts time next = switch - -- + -- (levelLoading lives level pts &&& after time ()) (\_ -> next) @@ -152,12 +156,11 @@ -- | Start the game at a given level, with a given number of lives. -- --- It executes the normal gameplay until the level is completed. --- It then switches to the next level (remembering the current --- lives and points). +-- It executes the normal gameplay until the level is completed. It then +-- switches to the next level (remembering the current lives and points). -- --- Conditions like finishing the game or running out of lives are --- detected in 'wholeGame' and 'canLose', respectively. +-- Conditions like finishing the game or running out of lives are detected in +-- 'wholeGame' and 'canLose', respectively. -- gameWithLives :: Int -> Int -> Int -> SF Controller GameState gameWithLives numLives level pts = dSwitch @@ -181,9 +184,8 @@ -- | Run the normal game. -- --- NOTE: The code includes a commented piece that detects --- a request to pause the game. Check out the code to learn how to --- implement pausing. +-- NOTE: The code includes a commented piece that detects a request to pause +-- the game. Check out the code to learn how to implement pausing. gamePlayOrPause :: Int -> Int -> Int -> SF Controller GameState gamePlayOrPause lives level pts = gamePlay lives level pts -- ((arr id) &&& (pause undefined (False --> isPaused) (mainLoop lives level))) @@ -210,8 +212,8 @@ gamePlay' (initialObjects level) >>> composeGameState lives level pts -- | Based on the internal gameplay info, compose the main game state and --- detect when a live is lost. When that happens, restart this SF --- with one less life available. +-- detect when a live is lost. When that happens, restart this SF with one less +-- life available. -- -- NOTE: it will be some other SF's responsibility to determine if the player's -- run out of lives. @@ -224,34 +226,33 @@ -> SF (ObjectOutputs, Event (), Int) GameState composeGameState lives level pts = futureDSwitch (composeGameState' lives level pts) - (\_ -> composeGameState (lives-1) level pts) + (\_ -> composeGameState (lives - 1) level pts) -- | Based on the internal gameplay info, compose the main game state and -- detect when a live is lost. When that happens, keep the last known game -- state. composeGameState' :: Int -> Int -> Int - -> SF (ObjectOutputs, Event (), Int) (GameState, Event GameState) -composeGameState' lives level pts = proc (oos,dead,points) -> do + -> SF (ObjectOutputs, Event (), Int) + (GameState, Event GameState) +composeGameState' lives level pts = proc (oos, dead, points) -> do -- Compose game state objects <- extractObjects -< oos let general = GameState objects - (GameInfo GamePlaying lives level (pts+points)) + (GameInfo GamePlaying lives level (pts + points)) -- Detect death let lastGeneral = dead `tag` general returnA -< (general, lastGeneral) - -- ** Game with partial state information -- | Given an initial list of objects, it runs the game, presenting the output -- from those objects at all times, notifying any time the ball hits the floor, --- and and of any additional points made. +-- and of any additional points made. -- --- This works as a game loop with a post-processing step. It uses --- a well-defined initial accumulator and a traditional feedback --- loop. +-- This works as a game loop with a post-processing step. It uses a +-- well-defined initial accumulator and a traditional feedback loop. -- -- The internal accumulator holds: -- @@ -262,80 +263,89 @@ -- - The last known points (added to the new ones in every loop iteration). -- gamePlay' :: ObjectSFs -> SF Controller (ObjectOutputs, Event (), Int) -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 - - -- Adds the old point count to the newly-made points - >>> (arr fst &&& arr (\((_,cs),o) -> o + countPoints cs)) - - -- Re-arrange output, selecting (objects+dead+points, objects+collisions+points) - >>> (composeOutput &&& arr (\((x,y),z) -> (x,y,z))) +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 + ) - where + -- Adds the old point count to the newly-made points + >>> (arr fst &&& arr (\((_, cs), o) -> o + countPoints cs)) - -- Detect collisions between the ball and the bottom - -- which are the only ones that matter outside gamePlay' - composeOutput = proc ((x,y),z) -> do - y' <- collisionWithBottom -< y - returnA -< (x,y',z) + -- Re-arrange output, selecting + -- (objects + dead + points, objects + collisions + points) + >>> (composeOutput &&& arr (\((x, y), z) -> (x, y, z))) - -- Just reorder the input - adaptInput :: SF (Controller, (ObjectOutputs, Collisions, Int)) ObjectInput - adaptInput = arr (\(gi,(os,cs,pts)) -> ObjectInput gi cs (map outputObject os)) + where - -- Parallely apply all object functions - processMovement :: SF ObjectInput (IL ObjectOutput) - processMovement = processMovement' objs + -- Detect collisions between the ball and the bottom + -- which are the only ones that matter outside gamePlay' + composeOutput = proc ((x, y), z) -> do + y' <- collisionWithBottom -< y + returnA -< (x, y', z) - processMovement' :: ObjectSFs -> SF ObjectInput (IL ObjectOutput) - processMovement' objs = dpSwitchB - objs -- Signal functions - (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) + -- Just reorder the input + adaptInput :: SF (Controller, (ObjectOutputs, Collisions, Int)) ObjectInput + adaptInput = + arr (\(gi, (os, cs, pts)) -> ObjectInput gi cs (map outputObject os)) - 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 - -- all the efects in sequence - foldl (mergeBy (.)) noEvent es + -- Parallely apply all object functions + processMovement :: SF ObjectInput (IL ObjectOutput) + processMovement = processMovement' objs - -- 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 - | (k,oo) <- assocsIL oos ] + processMovement' :: ObjectSFs -> SF ObjectInput (IL ObjectOutput) + processMovement' objs = dpSwitchB + objs -- Signal functions. + (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). - -- From the actual objects, detect which ones collide - detectObjectCollisions :: SF (IL ObjectOutput) Collisions - detectObjectCollisions = extractObjects >>> arr detectCollisions + 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 all the effects + -- in sequence + foldl (mergeBy (.)) noEvent es - -- Count-points - countPoints :: Collisions -> Int - countPoints = sum . map numPoints - where numPoints (Collision cd) - | hasBall cd = countBlocks cd - | otherwise = 0 - hasBall = any ((=="ball").fst) - countBlocks = length . filter (isPrefixOf "block" . fst) + -- 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 + | (k, oo) <- assocsIL oos ] + -- From the actual objects, detect which ones collide + detectObjectCollisions :: SF (IL ObjectOutput) Collisions + detectObjectCollisions = extractObjects >>> arr detectCollisions + -- Count-points + countPoints :: Collisions -> Int + countPoints = sum . map numPoints + where + numPoints (Collision cd) + | hasBall cd = countBlocks cd + | otherwise = 0 + hasBall = any ((=="ball").fst) + countBlocks = length . filter (isPrefixOf "block" . fst) -- * Game objects -- -- | Objects initially present: the walls, the ball, the paddle and the blocks. initialObjects :: Int -> ObjectSFs initialObjects level = listToIL $ - [ objSideRight - , objSideTop - , objSideLeft - , objSideBottom - , objPaddle - , objBall - ] - ++ map (\p -> objBlockAt p (blockWidth, blockHeight)) (blockPoss $ levels!!level) + [ objSideRight + , objSideTop + , objSideLeft + , objSideBottom + , objPaddle + , objBall + ] + ++ map (\p -> objBlock p (blockWidth, blockHeight)) + (blockCfgs $ levels !! level) -- *** Ball @@ -346,29 +356,27 @@ -- bounding around, until it hits the floor ('bounceAroundDetectMiss'). -- objBall :: ObjectSF -objBall = switch followPaddleDetectLaunch $ \p -> +objBall = switch followPaddleDetectLaunch $ \p -> switch (bounceAroundDetectMiss p) $ \_ -> objBall - where - -- Yampa's edge is used to turn the continuous - -- signal produced by controllerClick into an - -- event-carrying signal, only true the instant - -- the mouse button is clicked. - followPaddleDetectLaunch = proc oi -> do - o <- followPaddle -< oi - click <- edge -< controllerClick (userInput oi) - returnA -< (o, click `tag` objectPos (outputObject o)) + where + -- Yampa's edge is used to turn the continuous signal produced by + -- controllerClick into an event-carrying signal, only true the instant the + -- mouse button is clicked. + followPaddleDetectLaunch = proc oi -> do + o <- followPaddle -< oi + click <- edge -< controllerClick (userInput oi) + returnA -< (o, click `tag` objectPos (outputObject o)) - bounceAroundDetectMiss p = proc oi -> do - o <- bouncingBall p initialBallVel -< oi - miss <- collisionWithBottom -< collisions oi - returnA -< (o, miss) + bounceAroundDetectMiss p = proc oi -> do + o <- bouncingBall p initialBallVel -< oi + miss <- collisionWithBottom -< collisions oi + returnA -< (o, miss) --- | Fires an event when the ball *enters in* a collision with the --- bottom wall. +-- | Fires an event when the ball *enters in* a collision with the bottom wall. -- --- NOTE: even if the overlap is not corrected, 'edge' makes --- the event only take place once per collision. +-- NOTE: even if the overlap is not corrected, 'edge' makes the event only take +-- place once per collision. collisionWithBottom :: SF Collisions (Event ()) collisionWithBottom = inCollisionWith "ball" "bottomWall" ^>> edge @@ -376,62 +384,62 @@ -- otherwise). To avoid reacting to collisions, this ball is non-interactive. followPaddle :: ObjectSF followPaddle = arr $ \oi -> - -- Calculate ball position, midway on top of the the paddle - -- - -- This code allows for the paddle not to exist (Maybe), although that should - -- never happen in practice. - let mbPaddlePos = objectPos <$> find isPaddle (knownObjects oi) - ballPos = maybe (outOfScreen, outOfScreen) - ((paddleWidth/2, - ballHeight) ^+^) - mbPaddlePos - in ObjectOutput (inertBallAt ballPos) noEvent - where outOfScreen = -10 - inertBallAt p = Object { objectName = "ball" - , objectKind = Ball ballWidth - , objectPos = p - , objectVel = (0, 0) - , objectAcc = (0, 0) - , objectDead = False - , objectHit = False - , canCauseCollisions = False - , collisionEnergy = 0 - , displacedOnCollision = False - } + -- Calculate ball position, midway on top of the paddle + -- + -- This code allows for the paddle not to exist (Maybe), although that + -- should never happen in practice. + let mbPaddlePos = objectPos <$> find isPaddle (knownObjects oi) + ballPos = maybe (outOfScreen, outOfScreen) + ((paddleWidth / 2, - ballHeight) ^+^) + mbPaddlePos + in ObjectOutput (inertBallAt ballPos) noEvent + where + outOfScreen = -10 + inertBallAt p = Object { objectName = "ball" + , objectKind = Ball ballWidth + , objectPos = p + , objectVel = (0, 0) + , objectAcc = (0, 0) + , objectDead = False + , objectHit = False + , canCauseCollisions = False + , collisionEnergy = 0 + , displacedOnCollision = False + } -- A bouncing ball moves freely until there is a collision, then bounces and -- goes on and on. -- --- This SF needs an initial position and velocity. Every time --- there is a bounce, it takes a snapshot of the point of --- collision and corrected velocity, and starts again. +-- This SF needs an initial position and velocity. Every time there is a +-- bounce, it takes a snapshot of the point of collision and corrected +-- velocity, and starts again. -- bouncingBall :: Pos2D -> Vel2D -> ObjectSF bouncingBall p0 v0 = - switch progressAndBounce - (uncurry bouncingBall) -- Somehow it would be clearer like this: - -- \(p', v') -> bouncingBall p' v') - where + switch progressAndBounce + (uncurry bouncingBall) -- Somehow it would be clearer like this: + -- \(p', v') -> bouncingBall p' v') + where - -- 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 + -- 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 parallelly to the tentative new positions, + -- and then use it to detect when it's time to bounce - -- ========================== ============================ - -- -==--------------------->==--->==- ------------------->== - -- / == == == \ / == - -- -- == == == X == - -- \ == == == / \ == - -- -==----> freeBall' ----->==--->==--------> ballBounce -->== - -- ========================== ============================ - progressAndBounce = (arr id &&& freeBall') >>> (arr snd &&& ballBounce) + -- ========================== ============================ + -- -==--------------------->==--->==- ------------------->== + -- / == == == \ / == + -- -- == == == X == + -- \ == == == / \ == + -- -==----> freeBall' ----->==--->==--------> ballBounce -->== + -- ========================== ============================ + 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. - freeBall' = freeBall p0 v0 + -- Position of the ball, starting from p0 with velocity 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 -- current position and velocity. @@ -439,7 +447,7 @@ -- NOTE: To avoid infinite loops when switching, the initial input is discarded -- and never causes a bounce. This works in this game and in this particular -- case because the ball never-ever bounces immediately as fired from the --- paddle. This might not be true if a block is extremely close, if you add +-- paddle. This might not be true if a block is extremely close, if you add -- flying enemies to the game, etc. ballBounce :: SF (ObjectInput, ObjectOutput) (Event (Pos2D, Vel2D)) ballBounce = noEvent --> ballBounce' @@ -449,18 +457,18 @@ -- -- This does the core of the work, and does not ignore the initial input. -- --- It proceeds by detecting whether any collision affects --- the ball's velocity, and outputs a snapshot of the object --- position and the corrected velocity if necessary. +-- It proceeds by detecting whether any collision affects the ball's velocity, +-- and outputs a snapshot of the object position and the corrected velocity if +-- necessary. ballBounce' :: SF (ObjectInput, ObjectOutput) (Event (Pos2D, Vel2D)) ballBounce' = proc (ObjectInput ci cs os, o) -> do - -- HN 2014-09-07: With the present strategy, need to be able to - -- detect an event directly after - -- ev <- edgeJust -< changedVelocity "ball" cs + -- HN 2014-09-07: With the present strategy, need to be able to detect an + -- event directly after + -- ev <- edgeJust -< changedVelocity "ball" cs let ev = maybe noEvent Event (changedVelocity "ball" cs) returnA -< fmap (\v -> (objectPos (outputObject o), v)) ev --- | Position of the ball, starting from p0 with velicity v0, since the time of +-- | Position of the ball, starting from p0 with velocity v0, since the time of -- last switching (that is, collision, or the beginning of time --being fired -- from the paddle-- if never switched before), provided that no obstacles are -- encountered. @@ -474,9 +482,8 @@ -- Cap speed let v = limitNorm v0 maxVNorm - -- Any free moving object behaves like this (but with - -- acceleration. This should be in some FRP.NewtonianPhysics - -- module) + -- Any free moving object behaves like this (but with acceleration. This + -- should be in some FRP.NewtonianPhysics module) p <- (p0 ^+^) ^<< integral -< v let obj = Object { objectName = name @@ -490,7 +497,7 @@ , collisionEnergy = 1 , displacedOnCollision = True } - + returnA -< livingObject obj -- *** Player paddle @@ -507,30 +514,33 @@ let name = "paddle" let isHit = inCollision name cs - -- Try to get to the mouse position, but with a capped - -- velocity. + -- Try to get to the mouse position, but with a capped velocity. - rec - -- let v = limitNorm (20.0 *^ (refPosPaddle ci ^-^ p)) maxVNorm - -- let p = refPosPaddle ci -- (initPosPaddle ^+^) ^<< integral -< v - let v = 100.00 *^ (refPosPaddle ci ^-^ p) - p <- (initPosPaddle ^+^) ^<< integral -< v - -- let p = refPosPaddle ci + -- rec + -- -- let v = limitNorm (20.0 *^ (refPosPaddle ci ^-^ p)) maxVNorm + -- -- let p = refPosPaddle ci -- (initPosPaddle ^+^) ^<< integral -< v + -- let v = 100.00 *^ (refPosPaddle ci ^-^ p) + -- + -- -- The initial position of the paddle, horizontally centered. + -- initPosPaddle = ((gameWidth - paddleWidth)/2, yPosPaddle) + -- + -- p <- (initPosPaddle ^+^) ^<< integral -< v + let p = refPosPaddle ci + v <- derivative -< p - -- Use this code if you want instantaneous movement, - -- particularly cool with the Wiimote, but remember to cap - -- the balls velocity or you will get incredibly high - -- velocities when the paddle hits the ball. + -- Use this code if you want instantaneous movement, particularly cool with + -- the Wiimote, but remember to cap the balls velocity or you will get + -- incredibly high velocities when the paddle hits the ball. -- -- let p = refPosPaddle ci -- v <- derivative -< p returnA -< livingObject $ Object{ objectName = name - , objectKind = Paddle (paddleWidth,paddleHeight) + , objectKind = Paddle (paddleWidth, paddleHeight) , objectPos = p - , objectVel = (0,0) - , objectAcc = (0,0) + , objectVel = (0, 0) + , objectAcc = (0, 0) , objectDead = False , objectHit = isHit , canCauseCollisions = True @@ -538,17 +548,13 @@ , displacedOnCollision = False } --- | Follow the controller's horizontal position, keeping a constant --- vertical position. +-- | Follow the controller's horizontal position, keeping a constant vertical +-- position. refPosPaddle :: Controller -> Pos2D refPosPaddle c = (x', yPosPaddle) - where - (x, _) = controllerPos c - x' = inRange (0, gameWidth - paddleWidth) (x - (paddleWidth/2)) - --- | The initial position of the paddle, horizontally centered. -initPosPaddle :: Pos2D -initPosPaddle = ((gameWidth - paddleWidth)/2, yPosPaddle) + where + (x, _) = controllerPos c + x' = inRange (0, gameWidth - paddleWidth) (x - (paddleWidth / 2)) -- | The paddle's vertical position, at a reasonable distance from the bottom. yPosPaddle :: Double @@ -556,28 +562,28 @@ -- *** Blocks --- | Block SF generator. It uses the blocks's size and position. The block's --- position is used for it's unique ID, which means that two simulatenously --- existing blocks should never have the same position. This is ok in this case --- because they are static, but would not work if they could move and be --- created dynamically. -objBlockAt :: Pos2D -> Size2D -> ObjectSF -objBlockAt (x,y) (w,h) = proc (ObjectInput ci cs os) -> do +-- | Block SF generator. It uses the blocks' size, position and a number of +-- lives that the block has. The block's position is used for it's unique ID, +-- which means that two simultaneously existing blocks should never have the +-- same position. This is ok in this case because they are static, but would not +-- work if they could move and be created dynamically. +objBlock :: (Pos2D, Int) -> Size2D -> ObjectSF +objBlock ((x, y), initlives) (w, h) = proc (ObjectInput ci cs os) -> do -- Detect collisions - let name = "blockat" ++ show (x,y) + let name = "blockat" ++ show (x, y) isHit = inCollision name cs hit <- edge -< isHit - -- Must be hit three times do disappear + -- Must be hit initlives times to disappear -- - -- If you want them to "recover" or self-heal with time, - -- use the following code in place of lives. + -- If you want them to "recover" or self-heal with time, use the following + -- code in place of lives. -- -- recover <- delayEvent 5.0 -< hit - -- lives <- accumHoldBy (+) 3 -< (hit `tag` (-1) `lMerge` recover `tag` 1) - lives <- accumHoldBy (+) 3 -< (hit `tag` (-1)) - -- + -- lives <- accumHoldBy (+) 3 -< (hit `tag` (-1) `lMerge` recover `tag` 1) + lives <- accumHoldBy (+) initlives -< (hit `tag` (-1)) + -- -- let lives = 3 -- Always perfect -- Dead if out of lives. @@ -585,18 +591,18 @@ dead <- edge -< isDead -- let isDead = False -- immortal blocks - returnA -< ObjectOutput - Object{ objectName = name - , objectKind = Block lives (w, h) - , objectPos = (x,y) - , objectVel = (0,0) - , objectAcc = (0,0) - , objectDead = isDead - , objectHit = isHit - , canCauseCollisions = False - , collisionEnergy = 0 - , displacedOnCollision = False - } + returnA -< ObjectOutput + Object{ objectName = name + , objectKind = Block lives (w, h) + , objectPos = (x, y) + , objectVel = (0, 0) + , objectAcc = (0, 0) + , objectDead = isDead + , objectHit = isHit + , canCauseCollisions = False + , collisionEnergy = 0 + , displacedOnCollision = False + } dead -- *** Walls @@ -607,40 +613,40 @@ -- The function that turns walls into 'Shape's for collision detection -- determines how big they really are. In particular, this has implications in -- ball-through-paper effects (ball going through objects, potentially never --- coming back), which can be seen if the FPS suddently drops due to CPU load +-- coming back), which can be seen if the FPS suddenly drops due to CPU load -- (for instance, if a really major Garbage Collection kicks in. One potential -- optimisation is to trigger these with every SF iteration or every rendering, --- to decrease the workload and thus the likelyhood of BTP effects. -objSideRight :: ObjectSF -objSideRight = objWall "rightWall" RightSide (gameWidth, 0) +-- to decrease the workload and thus the likelihood of BTP effects. +objSideRight :: ObjectSF +objSideRight = objWall "rightWall" RightSide (gameWidth, 0) -- | See 'objSideRight'. -objSideLeft :: ObjectSF -objSideLeft = objWall "leftWall" LeftSide (0, 0) +objSideLeft :: ObjectSF +objSideLeft = objWall "leftWall" LeftSide (0, 0) -- | See 'objSideRight'. -objSideTop :: ObjectSF -objSideTop = objWall "topWall" TopSide (0, 0) +objSideTop :: ObjectSF +objSideTop = objWall "topWall" TopSide (0, 0) -- | See 'objSideRight'. objSideBottom :: ObjectSF -objSideBottom = objWall "bottomWall" BottomSide (0, gameHeight) +objSideBottom = objWall "bottomWall" BottomSide (0, gameHeight) -- | Generic wall builder, given a name, a side and its base -- position. objWall :: ObjectName -> Side -> Pos2D -> ObjectSF objWall name side pos = proc (ObjectInput ci cs os) -> do - let isHit = inCollision name cs - returnA -< ObjectOutput - Object { objectName = name - , objectKind = Side side - , objectPos = pos - , objectVel = (0,0) - , objectAcc = (0,0) - , objectDead = False - , objectHit = isHit - , canCauseCollisions = False - , collisionEnergy = 0 - , displacedOnCollision = False - } - noEvent + let isHit = inCollision name cs + returnA -< ObjectOutput + Object { objectName = name + , objectKind = Side side + , objectPos = pos + , objectVel = (0, 0) + , objectAcc = (0, 0) + , objectDead = False + , objectHit = isHit + , 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 @@ -1,5 +1,10 @@ --- | A very rudimentary collision system. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- +-- A very rudimentary collision system. +-- -- It compares every pair of objects, trying to determine if there is a -- collision between the two of them. -- @@ -10,38 +15,41 @@ -- module GameCollisions where +-- External imports import Data.List import Data.Maybe -import Objects + +-- Internal imports import Data.IdentityList +import Objects import Physics.TwoDimensions.Dimensions -- | Given a list of objects, it detects all the collisions between them. -- --- Note: this is a simple n*m-complex algorithm, with n the --- number of objects and m the number of moving objects (right now, --- only 2). +-- Note: this is a simple n*m-complex algorithm, with n the number of objects +-- and m the number of moving objects (right now, only 2). -- detectCollisions :: IL Object -> Collisions detectCollisions = detectCollisionsH - where detectCollisionsH objsT = flattened - where -- Eliminate empty collision sets - -- TODO: why is this really necessary? - flattened = filter (\(Collision n) -> not (null n)) collisions + where + detectCollisionsH objsT = flattened + where + -- Eliminate empty collision sets + -- TODO: why is this really necessary? + flattened = filter (\(Collision n) -> not (null n)) collisions - -- Detect collisions between moving objects and any other objects - collisions = detectCollisions' objsT moving + -- Detect collisions between moving objects and any other objects + collisions = detectCollisions' objsT moving - -- Partition the object space between moving and static objects - (moving, _static) = partition (canCauseCollisions.snd) $ assocsIL objsT + -- Partition the object space between moving and static objects + (moving, _static) = partition (canCauseCollisions.snd) $ assocsIL objsT --- | Detect collisions between each moving object and --- every other object. +-- | Detect collisions between each moving object and every other object. detectCollisions' :: IL Object -> [(ILKey, Object)] -> [Collision] detectCollisions' objsT ms = concatMap (detectCollisions'' objsT) ms -- | Detect collisions between one specific moving object and every existing --- object. Each collision is idependent of the rest (which is not necessarily +-- object. Each collision is independent of the rest (which is not necessarily -- what should happen, but since the transformed velocities are eventually -- added, there isn't much difference in the end). detectCollisions'' :: IL Object -> (ILKey, Object) -> [Collision] @@ -52,29 +60,8 @@ -- determine whether the two objects do collide. detectCollisions''' :: (ILKey, Object) -> (ILKey, Object) -> [Collision] detectCollisions''' m o - | fst m == fst o = [] -- Same object -> no collision - | otherwise = maybeToList (detectCollision (snd m) (snd o)) - --- updateObjPos :: SF (ILKey, Object) (ILKey, Object) --- updateObjPos = proc (i,o) -> do --- -- Since we are saving the position to avoid having to keep the last known --- -- position in memory every time and integrate over a range every time --- -- (would that really happen???) we use an integral over an interval. --- -- I really wonder if this integration thing in Yampa works the way it is --- -- expected to work. Does it work well for non-linear equations? --- -- --- -- Integral only for dt interval --- actualVel <- iterFrom (\_ (v1,v2) dt _ -> (v1 * dt, v2 * dt)) (0,0) -< objectVel o --- --- -- Update position --- let newPos = objectPos o ^+^ actualVel --- o' = o { objectPos = newPos } --- returnA -< (i,o') - --- killBall :: ObjectOutput -> ObjectOutput --- killBall oo = oo { outputObject = o' } --- where o = outputObject oo --- o' = o { objectDead = True} + | fst m == fst o = [] -- Same object -> no collision + | otherwise = maybeToList (detectCollision (snd m) (snd o)) -- | Return the new velocity as changed by the collection of collisions. -- @@ -83,34 +70,33 @@ -- The assumption is that collision detection happens globally and that the -- changed velocity is figured out for each object involved in a collision -- based on the properties of all objects involved in any specific interaction. --- That may not be how it works now, but the interface means it could work --- that way. Even more physical might be to figure out the impulsive force --- acting on each object. +-- That may not be how it works now, but the interface means it could work that +-- way. Even more physical might be to figure out the impulsive force acting on +-- each object. -- -- However, the whole collision infrastructure should be revisited. -- -- - Statefulness ("edge") might make it more robust. -- --- - Think through how collision events are going to be communicated --- to the objects themselves. Maybe an input event is the natural --- thing to do. Except then we have to be careful to avoid switching --- again immediately after one switch. +-- - Think through how collision events are going to be communicated to the +-- objects themselves. Maybe an input event is the natural thing to do. +-- Except then we have to be careful to avoid switching again immediately +-- after one switch. -- --- - Should try to avoid n^2 checks. Maybe some kind of quad-trees? --- Maybe spawning a stateful collision detector when two objects are --- getting close? Cf. the old tail-gating approach. --- - Maybe a collision should also carry the identity of the object --- one collieded with to facilitate impl. of "inCollisionWith". +-- - Should try to avoid n^2 checks. Maybe some kind of quad-trees? Maybe +-- spawning a stateful collision detector when two objects are getting close? +-- Cf. the old tail-gating approach. +-- - Maybe a collision should also carry the identity of the object one +-- collided with to facilitate impl. of "inCollisionWith". -- changedVelocity :: ObjectName -> Collisions -> Maybe Vel2D -changedVelocity name cs = - case concatMap (filter ((== name) . fst) . collisionData) cs of - [] -> Nothing - (_, v') : _ -> Just v' +changedVelocity name cs = + case concatMap (filter ((== name) . fst) . collisionData) cs of + [] -> Nothing + (_, v') : _ -> Just v' - -- IP: It should be something like the following, but that doesn't - -- work: - -- vs -> Just (foldl (^+^) (0,0) (map snd vs)) + -- 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. inCollision :: ObjectName -> Collisions -> Bool @@ -119,7 +105,7 @@ -- | True if the two objects are colliding with one another. inCollisionWith :: ObjectName -> ObjectName -> Collisions -> Bool inCollisionWith nm1 nm2 cs = any (both nm1 nm2) cs - where - both nm1 nm2 (Collision nmvs) = - any ((== nm1) . fst) nmvs - && any ((== nm2) . fst) nmvs + where + both nm1 nm2 (Collision nmvs) = + any ((== nm1) . fst) nmvs + && any ((== nm2) . fst) nmvs diff --git a/src/GameState.hs b/src/GameState.hs --- a/src/GameState.hs +++ b/src/GameState.hs @@ -1,15 +1,17 @@ --- | The state of the game during execution. It has two --- parts: general info (level, points, etc.) and --- the actual gameplay info (objects). +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- --- Because the game is always in some running state --- (there are no menus, etc.) we assume that there's --- always some gameplay info, even though it can be +-- The state of the game during execution. It has two parts: general info +-- (level, points, etc.) and the actual gameplay info (objects). +-- +-- Because the game is always in some running state (there are no menus, etc.) +-- we assume that there's always some gameplay info, even though it can be -- empty. module GameState where --- import FRP.Yampa as Yampa - +-- Internal imports import Objects -- | The running state is given by a bunch of 'Objects' and the current general @@ -18,7 +20,7 @@ -- -- Different parts of the game deal with these data structures. It is -- therefore convenient to group them in subtrees, even if there's no --- substantial difference betweem them. +-- substantial difference between them. data GameState = GameState { gameObjects :: Objects , gameInfo :: GameInfo @@ -31,9 +33,9 @@ , gameInfo = neutralGameInfo } --- | The gameinfo tells us the current game state (running, paused, etc.) --- and general information, in this case, the number of lives, the level --- and the points. +-- | The GameInfo tells us the current game state (running, paused, etc.) and +-- general information, in this case, the number of lives, the level and the +-- points. -- -- Since this info is then presented together to the users in a top panel, it -- is convenient to give this product of values a proper name. @@ -54,13 +56,13 @@ } -- | Possible actual game statuses. The game is always in one of these. --- Interaction and presentation depend on this. Yampa switches are --- used to jump from one to another, and the display module --- changes presentation depending on the status. +-- Interaction and presentation depend on this. Yampa switches are used to jump +-- from one to another, and the display module changes presentation depending +-- on the status. data GameStatus = GamePlaying | GamePaused | GameLoading Int | GameOver | GameFinished | GameStarted - deriving Eq + deriving Eq diff --git a/src/Graphics/UI/Extra/SDL.hs b/src/Graphics/UI/Extra/SDL.hs --- a/src/Graphics/UI/Extra/SDL.hs +++ b/src/Graphics/UI/Extra/SDL.hs @@ -1,5 +1,12 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Auxiliary functions related to Graphics.UI.SDL. module Graphics.UI.Extra.SDL where +-- External imports import Data.IORef import Graphics.UI.SDL as SDL diff --git a/src/Input.hs b/src/Input.hs --- a/src/Input.hs +++ b/src/Input.hs @@ -1,9 +1,13 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} --- | Defines an abstraction for the game controller and the functions to read --- it. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- --- Lower-level devices replicate the higher-level API, and should accomodate to +-- Defines an abstraction for the game controller and the functions to read it. +-- +-- Lower-level devices replicate the higher-level API, and should accommodate to -- it. Each device should: -- -- - Upon initialisation, return any necessary information to poll it again. @@ -18,7 +22,7 @@ -- updated version. -- -- Limitations: --- +-- -- - Device failures are not handled. -- -- - Falling back to the next available device when there's a problem. @@ -31,34 +35,32 @@ module Input where -- External imports +import Control.Monad import Data.IORef import Graphics.UI.SDL as SDL -import Control.Monad -- External imports (Wiimote) #ifdef wiimote -import Control.Monad(void) +import Control.Monad (void) import Control.Monad.IfElse (awhen) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import System.CWiid #endif -- External imports (Kinect) #ifdef kinect -import Control.Concurrent -import Data.Maybe (fromJust) -import Data.Vector.Storable (Vector,(!)) -import Data.Word -import Freenect +import Control.Concurrent +import Data.Vector.Storable (Vector, (!)) import qualified Data.Vector.Storable as V +import Data.Word +import Freenect #endif -- Internal imports +import Constants import Control.Extra.Monad import Graphics.UI.Extra.SDL -import Constants - -- * Game controller -- | Controller info at any given point. @@ -66,54 +68,53 @@ { controllerPos :: (Double, Double) , controllerClick :: Bool , controllerPause :: Bool + , controllerQuit :: Bool } --- | Controller info at any given point, plus a pointer --- to poll the main device again. This is safe, --- since there is only one writer at a time (the device itself). +-- | Controller info at any given point, plus a pointer to poll the main device +-- again. This is safe, since there is only one writer at a time (the device +-- itself). newtype ControllerRef = ControllerRef (IORef Controller, Controller -> IO Controller) -- * General API --- | Initialize the available input devices. This operation --- returns a reference to a controller, which enables --- getting its state as many times as necessary. It does --- not provide any information about its nature, abilities, etc. +-- | Initialize the available input devices. This operation returns a reference +-- to a controller, which enables getting its state as many times as necessary. +-- It does not provide any information about its nature, abilities, etc. initializeInputDevices :: IO ControllerRef initializeInputDevices = do - let baseDev = sdlGetController + let baseDev = sdlGetController -- Fall back to mouse/kb is no kinect is present #ifdef kinect - print "Kinecting" - dev <- do kn <- kinectController - case kn of - Nothing -> return baseDev - Just kn' -> return kn' + print "Kinecting" + dev <- do kn <- kinectController + case kn of + Nothing -> return baseDev + Just kn' -> return kn' #else - let dev = baseDev + let dev = baseDev #endif -- Fall back to kinect or mouse/kb is no wiimote is present #ifdef wiimote - dev' <- do wm <- wiimoteDev - return $ fromMaybe dev wm + dev' <- do wm <- wiimoteDev + return $ fromMaybe dev wm #else - let dev' = dev + let dev' = dev #endif - nr <- newIORef defaultInfo - return $ ControllerRef (nr, dev') - where defaultInfo = Controller (0,0) False False + nr <- newIORef defaultInfo + return $ ControllerRef (nr, dev') + where + defaultInfo = Controller (0, 0) False False False --- | Sense from the controller, providing its current --- state. This should return a new Controller state --- if available, or the last one there was. --- --- It is assumed that the sensing function is always --- callable, and that it knows how to update the --- Controller info if necessary. +-- | Sense from the controller, providing its current state. This should return +-- a new Controller state if available, or the last one there was. +-- +-- It is assumed that the sensing function is always callable, and that it +-- knows how to update the Controller info if necessary. senseInput :: ControllerRef -> IO Controller senseInput (ControllerRef (cref, sensor)) = do cinfo <- readIORef cref @@ -126,8 +127,8 @@ -- * WiiMote API (mid-level) #ifdef wiimote --- | The wiimote controller as defined using this --- abstract interface. See 'initializeWiimote'. +-- | The wiimote controller as defined using this abstract interface. See +-- 'initializeWiimote'. wiimoteDev :: ControllerDev wiimoteDev = initializeWiimote @@ -140,19 +141,19 @@ initializeWiimote = do putStrLn "Initializing WiiMote. Please press 1+2 to connect." wm <- cwiidOpen - awhen wm (void . (`cwiidSetRptMode` 15)) -- Enable button reception, acc and IR + awhen wm (void . (`cwiidSetRptMode` 15)) -- Enable button reception, acc, IR case wm of - Nothing -> return Nothing - Just wm' -> return $ Just $ senseWiimote wm' + Nothing -> return Nothing + Just wm' -> return $ Just $ senseWiimote wm' -- ** Sensing -- | Sense the Wiimote and update the controller. -- --- This operation uses the IR for the controller's position, --- and the main (A) button for the click. +-- This operation uses the IR for the controller's position, and the main (A) +-- button for the click. -- --- TODO: Allow configuring the button and using other motion mechamisms +-- TODO: Allow configuring the button and using other motion mechanisms -- (accelerometers). -- -- TODO: This should be split in two operations. One that presents a nice @@ -164,8 +165,8 @@ -- Obtain positions of leds 1 and 2 (with a normal wii bar, those -- will be the ones we use). - let led1 = irs!!0 - led2 = irs!!1 + let led1 = irs !! 0 + led2 = irs !! 1 -- Calculate mid point between sensor bar leds let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2 @@ -176,15 +177,17 @@ propY = fromIntegral (max 0 (posY - 384)) / 384.0 -- Calculate game area coordinates - let finX = width * propX - finY = height * propY + let finX = width * propX + finY = height * propY -- Direction (old system based on buttons) -- let isLeft = cwiidIsBtnPushed flags cwiidBtnLeft - -- isRight = cwiidIsBtnPushed flags cwiidBtnRight - -- (x,y) = controllerPos controller - -- x' = if isLeft then x - wiiXDiff else if isRight then x + wiiXDiff else x - -- x'' = inRange (0, gameWidth) x' + -- isRight = cwiidIsBtnPushed flags cwiidBtnRight + -- (x, y) = controllerPos controller + -- x' | isLeft = x - wiiXDiff + -- | isRight = x + wiiXDiff + -- | otherwise = x + -- x'' = inRange (0, gameWidth) x' -- pos' = (x'', y) -- wiiXDiff :: Float -- wiiXDiff = 6 @@ -208,10 +211,9 @@ -- ** Sensing --- | Sense the SDL keyboard and mouse and update --- the controller. It only senses the mouse position, --- the primary mouse button, and the p key to pause --- the game. +-- | Sense the SDL keyboard and mouse and update the controller. It only senses +-- the mouse position, the primary mouse button, and the p key to pause the +-- game. -- -- We need a non-blocking controller-polling function. -- TODO: Check http://gameprogrammer.com/fastevents/fastevents1.html @@ -223,14 +225,21 @@ handleEvent :: Controller -> SDL.Event -> Controller handleEvent c e = case e of - 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 } - _ -> c - + 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 } + KeyDown Keysym { symKey = SDLK_q } -> + c { controllerQuit = True } + _ -> c -- Kinect @@ -253,6 +262,7 @@ kinectHeight = 480 type KinectPosRef = IORef KinectPos + type KinectPos = Maybe (Double, Double) initializeKinect :: (Double, Double) -> IO KinectPosRef @@ -263,54 +273,61 @@ getDepthThread :: (Double, Double) -> KinectPosRef -> IO ThreadId getDepthThread screenSize lastPos = forkIO $ do - withContext $ \context -> do - setLogLevel LogFatal context - selectSubdevices context devices - withDevice context index $ \device -> do - setDepthMode device Medium ElevenBit - setDepthCallback device $ \payload _timestamp -> do - maybe (print ".") -- Too far or too close - (updatePos lastPos) - (calculateMousePos screenSize payload) - return () - startDepth device - forever $ processEvents context + withContext $ \context -> do + setLogLevel LogFatal context + selectSubdevices context devices + withDevice context index $ \device -> do + setDepthMode device Medium ElevenBit + setDepthCallback device $ \payload _timestamp -> do + maybe (print ".") -- Too far or too close + (updatePos lastPos) + (calculateMousePos screenSize payload) + return () + startDepth device + forever $ processEvents context - where devices = [Camera] - index = 0 :: Integer + where + devices = [Camera] + index = 0 :: Integer updatePos :: IORef (Maybe (Double, Double)) -> (Double, Double) -> IO () -updatePos lastPosRef newPos@(nx,ny) = do +updatePos lastPosRef newPos@(nx, ny) = do lastPosM <- readIORef lastPosRef let (mx, my) = case lastPosM of - Nothing -> newPos - (Just (lx,ly)) -> (adjust 50 lx nx, adjust 50 ly ny) + Nothing -> newPos + (Just (lx, ly)) -> (adjust 50 lx nx, adjust 50 ly ny) writeIORef lastPosRef (Just (mx, my)) mx `seq` my `seq` return () -calculateMousePos :: (Double, Double) -> Vector Word16 -> Maybe (Double, Double) +calculateMousePos :: (Double, Double) + -> Vector Word16 + -> Maybe (Double, Double) calculateMousePos (width, height) payload = - fmap g (findFirst payload) - where g (px,py) = (mousex, mousey) - where - pointerx = fromIntegral (640 - px) - pointery = fromIntegral py - mousex = pointerx -- pointerx * adjx - mousey = pointery -- pointery * adjy - adjx = width / 630.0 - adjy = height / 470.0 + fmap g (findFirst payload) + where + g (px, py) = (mousex, mousey) + where + pointerx = fromIntegral (640 - px) + pointery = fromIntegral py + mousex = pointerx -- pointerx * adjx + mousey = pointery -- pointery * adjy + adjx = width / 630.0 + adjy = height / 470.0 mat :: Vector Float -mat = V.generate 2048 (\i -> let v :: Float - v = ((fromIntegral i/2048.0)^3)*6.0 in v * 6.0 * 256.0) +mat = V.generate 2048 $ \i -> + let v :: Float + v = ((fromIntegral i / 2048.0)^3) * 6.0 + in v * 6.0 * 256.0 findFirst :: Vector Word16 -> Maybe (Int, Int) findFirst vs = fmap (\v -> (v `mod` 640, v `div` 640)) i - where i = V.findIndex (\x -> mat!(fromIntegral x) < 512) vs + where + i = V.findIndex (\x -> mat ! (fromIntegral x) < 512) vs processPayload :: Vector Word16 -> [(Float, Int, Int)] -processPayload ps = [(pval, tx, ty) | i <- [0..640*480-1] - , let pval = mat!(fromIntegral (ps!i)) +processPayload ps = [(pval, tx, ty) | i <- [0 .. 640 * 480 - 1] + , let pval = mat ! (fromIntegral (ps ! i)) , pval < 300 , let ty = i `div` 640 tx = i `mod` 640 @@ -319,8 +336,9 @@ -- Drop the fst elem, calculate the avg of snd and trd over the whole list avg :: [(Float, Int, Int)] -> (Int, Int) avg ls = (sumx `div` l, sumy `div` l) - where l = length ls - (sumx, sumy) = foldr (\(_,x,y) (rx,ry) -> (x+rx,y+ry)) (0,0) ls + where + l = length ls + (sumx, sumy) = foldr (\(_, x, y) (rx, ry) -> (x + rx, y + ry)) (0, 0) ls -- Update a value, with a max cap adjust :: (Num a, Ord a) => a -> a -> a -> a @@ -328,6 +346,4 @@ | abs (old - new) < maxD = new | old < new = old + maxD | otherwise = old - maxD - #endif - diff --git a/src/Levels.hs b/src/Levels.hs --- a/src/Levels.hs +++ b/src/Levels.hs @@ -1,117 +1,154 @@ --- | Level definition +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- +-- Level definition +-- -- This module includes the definition of the levels. -- -- Each level has: -- --- - Logical properties (defined in 'blockPosS'). +-- - Logical properties (defined in 'blockDescS'). -- -- - Multimedia properties (a background and audio file). -- -- Together they form 'levels'. module Levels where -import Control.Arrow((***)) -import Data.List (nub) -import Physics.TwoDimensions.Dimensions +-- External imports +import Control.Arrow (first, (***)) +import Data.List (nub) +-- Internal imports import Constants +import Physics.TwoDimensions.Dimensions import Resources -- * Levels -- ** Level specification data LevelSpec = LevelSpec - { blockPoss :: [Pos2D] -- ^ Block positions - , levelBg :: ImageResource -- ^ Background image - , levelMusic :: MusicResource -- ^ Background music - } + { blockCfgs :: [(Pos2D, Int)] -- ^ Block positions and block lives + , levelBg :: ImageResource -- ^ Background image + , levelMusic :: MusicResource -- ^ Background music + } --- | Number of levels. Change this in the code to finish --- in a different level. +-- | Number of levels. Change this in the code to finish in a different level. numLevels :: Int numLevels = length levels -- * Concrete levels levels :: [LevelSpec] levels = [ -- Level 0 - LevelSpec { blockPoss = blockPosS 0 + LevelSpec { blockCfgs = blockDescS 0 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level0.mp3" } , -- Level 1 - LevelSpec { blockPoss = blockPosS 1 + LevelSpec { blockCfgs = blockDescS 1 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level1.mp3" } , -- Level 2 - LevelSpec { blockPoss = blockPosS 2 + LevelSpec { blockCfgs = blockDescS 2 , levelBg = Resource "data/level2.png" , levelMusic = Resource "data/level2.mp3" } , -- Level 3 - LevelSpec { blockPoss = blockPosS 3 + LevelSpec { blockCfgs = blockDescS 3 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level0.mp3" } , -- Level 4 - LevelSpec { blockPoss = blockPosS 4 + LevelSpec { blockCfgs = blockDescS 4 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level1.mp3" } , -- Level 5 - LevelSpec { blockPoss = blockPosS 5 + LevelSpec { blockCfgs = blockDescS 5 , levelBg = Resource "data/level2.png" , levelMusic = Resource "data/level2.mp3" } , -- Level 6 - LevelSpec { blockPoss = blockPosS 6 + LevelSpec { blockCfgs = blockDescS 6 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level0.mp3" } , -- Level 7 - LevelSpec { blockPoss = blockPosS 7 + LevelSpec { blockCfgs = blockDescS 7 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level1.mp3" } , -- Level 8 - LevelSpec { blockPoss = blockPosS 8 + LevelSpec { blockCfgs = blockDescS 8 , levelBg = Resource "data/level2.png" , levelMusic = Resource "data/level2.mp3" } , -- Level 9 - LevelSpec { blockPoss = blockPosS 9 + LevelSpec { blockCfgs = blockDescS 9 , levelBg = Resource "data/level0.png" , levelMusic = Resource "data/level1.mp3" } , -- Level 10 - LevelSpec { blockPoss = blockPosS 10 + LevelSpec { blockCfgs = blockDescS 10 , levelBg = Resource "data/level1.png" , levelMusic = Resource "data/level1.mp3" } , -- Level 11 - LevelSpec { blockPoss = blockPosS 11 + LevelSpec { blockCfgs = blockDescS 11 , levelBg = Resource "data/level2.png" , levelMusic = Resource "data/level2.mp3" } , -- Level 12 - LevelSpec { blockPoss = blockPosS 12 + LevelSpec { blockCfgs = blockDescS 12 , levelBg = Resource "data/level0.png" , levelMusic = Resource "data/level1.mp3" - } ] + } + , + -- Level 13 + LevelSpec { blockCfgs = blockDescS 13 + , levelBg = Resource "data/level1.png" + , levelMusic = Resource "data/level1.mp3" + } + , + -- Level 14 + LevelSpec { blockCfgs = blockDescS 14 + , levelBg = Resource "data/level2.png" + , levelMusic = Resource "data/level2.mp3" + } + , + -- Level 15 + LevelSpec { blockCfgs = blockDescS 15 + , levelBg = Resource "data/level1.png" + , levelMusic = Resource "data/level0.mp3" + } + , + -- Level 16 + LevelSpec { blockCfgs = blockDescS 16 + , levelBg = Resource "data/level1.png" + , levelMusic = Resource "data/level1.mp3" + } + , + -- Level 17 + LevelSpec { blockCfgs = blockDescS 17 + , levelBg = Resource "data/level2.png" + , levelMusic = Resource "data/level2.mp3" + } + ] --- | Level block specification (positions) +-- | Level block specification (positions, lives of block) -- Level 0 -- %%%%%%%% @@ -119,62 +156,74 @@ -- % XXXXXXXX -- % XXXXXXXX -- % XXXXXXXX -blockPosS :: Int -> [Pos2D] -blockPosS 0 = map adjustPos allBlocks - - where allBlocks :: (Enum a, Num a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1], y <- [0..blockRows-1]] +blockDescS :: Int -> [(Pos2D, Int)] +blockDescS 0 = map (first adjustPos) allBlocks - blockRows :: Num a => a - blockRows = 4 + where + allBlocks :: (Enum a, Num a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + ] + blockRows :: Num a => a + blockRows = 4 -- Level 1 -- %%%%%%%% -- % XXXX --- % XXXXX +-- % XXXXX -- % XXXXXX -- % XXXXXX -- % XXXXX -- % XXXX -- -blockPosS 1 = map adjustPos allBlocks - where - allBlocks :: (Enum a, Num a, Eq a, Ord a) => [(a,a)] - allBlocks = [ (x,y) | x <- [0..blockColumns-1], y <- [0..blockRows-1] - , (x + y > 2) && (x + y < 10) - ] - - blockRows :: Num a => a - blockRows = 6 +blockDescS 1 = map (first adjustPos) allBlocks + where + allBlocks :: (Enum a, Num a, Eq a, Ord a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , (x + y > 2) && (x + y < 10) + ] + blockRows :: Num a => a + blockRows = 6 + -- Level 2 -blockPosS 2 = map adjustPos allBlocks - where - allBlocks :: (Enum a, Num a, Eq a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns - 1], y <- [0..blockRows-1] - , x /= y && (blockColumns - 1 - x) /= y] +blockDescS 2 = map (first adjustPos) allBlocks + where + allBlocks :: (Enum a, Num a, Eq a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , x /= y && (blockColumns - 1 - x) /= y + ] - blockRows :: Num a => a - blockRows = 4 - + blockRows :: Num a => a + blockRows = 4 + -- Level 3 -- %%%%%%%% -- % X X X X -- % X X X X -- % X X X X -- % X X X X -blockPosS 3 = map adjustPos allBlocks +blockDescS 3 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1], y <- [0..blockRows-1], - ((even x) && (odd y) || (odd x) && (even y))] + where - blockRows :: Num a => a - blockRows = 4 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , even x && odd y || odd x && even y + ] + blockRows :: Num a => a + blockRows = 4 -- Level 4 -- %%%%%%%% @@ -185,31 +234,44 @@ -- % X X X X -- % -- % XXXXXXXX -blockPosS 4 = map adjustPos allBlocks +blockDescS 4 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1], y <- [0,blockRows-1]] ++ - [(x,y) | x <- [0..blockColumns-1], y <- [2], odd x] ++ - [(x,y) | x <- [0..blockColumns-1], y <- [4], even x] + where - blockRows :: Num a => a - blockRows = 7 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0, blockRows - 1] + ] + ++ [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [2], odd x + ] + ++ [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [4], even x + ] + blockRows :: Num a => a + blockRows = 7 + -- Level 5 -- %%%%%%%% -- % X -- % X X -- % X X -- % XXXXXXX -blockPosS 5 = map adjustPos allBlocks +blockDescS 5 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = nub $ - [(3,0),(blockColumns-4,1)] ++ - [(2,1),(blockColumns-3,1)] ++ - [(1,2),(blockColumns-2,2)] ++ - [(x,y) | x <- [0..blockColumns-1], y <- [3]] + where + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = nub $ + [((3, 0), maxBlockLife), ((blockColumns - 4, 1), maxBlockLife)] + ++ [((2, 1), maxBlockLife), ((blockColumns - 3, 1), maxBlockLife)] + ++ [((1, 2), maxBlockLife), ((blockColumns - 2, 2), maxBlockLife)] + ++ [((x, y), maxBlockLife) | x <- [0..blockColumns - 1], y <- [3]] + -- Level 6 -- %%%%%%%% -- % XXXXXX @@ -217,39 +279,57 @@ -- % X X -- % X X -- % XXXXXX -blockPosS 6 = map adjustPos allBlocks +blockDescS 6 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [1..blockColumns-2], y <- [0,blockRows-1]] ++ - [(x,y) | x <- [0,blockColumns-1], y <- [1..blockRows-2]] + where - blockRows :: Num a => a - blockRows = 5 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [1..blockColumns - 2] + , y <- [0, blockRows - 1] + ] + ++ [ ((x, y), maxBlockLife) + | x <- [0, blockColumns - 1] + , y <- [1..blockRows - 2] + ] + blockRows :: Num a => a + blockRows = 5 -- Level 7 -- %%%%%%%% -- % XXXXXX -- % X X --- % XX --- % XX +-- % XX +-- % XX -- % X X -- % XXXXXX -blockPosS 7 = map adjustPos allBlocks +blockDescS 7 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [1..blockColumns-2], y <- [0,blockRows-1]] ++ - [(x,y) | x <- [0,blockColumns-1], y <- [1,blockRows-2]] ++ - [(x,y) | x <- [3,4], y <- [2..4]] + where - blockRows :: Num a => a - blockRows = 7 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [1..blockColumns - 2] + , y <- [0, blockRows - 1] + ] + ++ [ ((x, y), maxBlockLife) + | x <- [0, blockColumns - 1] + , y <- [1, blockRows - 2] + ] + ++ [ ((x, y), maxBlockLife) + | x <- [3, 4] + , y <- [2..4] + ] + blockRows :: Num a => a + blockRows = 7 + -- Level 8 -- %%%%%%%% -- % XX XXXXX -- % XX XXXXX --- % +-- % -- % XX XXXXX -- % XX XXXXX -- % XX XXXXX @@ -257,16 +337,21 @@ -- % XX XXXXX -- % XX XXXXX -- % XX XXXXX -blockPosS 8 = map adjustPos allBlocks +blockDescS 8 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1] - , y <- [0..blockRows-1] - , x /= 2, y /= 2 ] + where - blockRows :: Num a => a - blockRows = 9 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , x /= 2 + , y /= 2 + ] + blockRows :: Num a => a + blockRows = 9 + -- Level 9 -- %%%%%%%% -- % X @@ -276,69 +361,83 @@ -- % X X X -- % XXX -- % X -blockPosS 9 = map ((adjustHPos *** adjustVPos) . fI2) allBlocks +blockDescS 9 = map (first ((adjustHPos *** adjustVPos) . fI2)) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [3], y <- [0..6]] ++ - [(x,y) | x <- [0..6], y <- [3]] ++ - [(x,y) | x <- [2,4], y <- [1,5]] ++ - [(x,y) | x <- [1,5], y <- [2,4]] - - adjustHPos :: Double -> Double - adjustHPos = (leftMargin +) . ((blockWidth + blockSeparation) *) + where - leftMargin :: Num a => a - leftMargin = round' ((gameWidth - (blockWidth + blockSeparation) * 7)/2) - where round' = fromIntegral . floor + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) | x <- [3], y <- [0..6] ] + ++ [ ((x, y), maxBlockLife) | x <- [0..6], y <- [3] ] + ++ [ ((x, y), maxBlockLife) | x <- [2, 4], y <- [1, 5] ] + ++ [ ((x, y), maxBlockLife) | x <- [1, 5], y <- [2, 4] ] + adjustHPos :: Double -> Double + adjustHPos = (leftMargin +) . ((blockWidth + blockSeparation) *) + leftMargin :: Num a => a + leftMargin = + round' ((gameWidth - (blockWidth + blockSeparation) * 7) / 2) + where + round' = fromIntegral . floor + -- Level 10 -- %%%%%%%% -- % X X X --- % X X X --- % X X X --- % X X X +-- % X X X +-- % X X X +-- % X X X -- % XXXXXXX --- % X X X --- % X X X -- % X X X --- % X X X -blockPosS 10 = map adjustPos allBlocks - - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1] - , y <- [0..blockRows-1], odd x] ++ - [(x,y) | x <- [0..blockColumns-1], y <- [midRow], even x] +-- % X X X +-- % X X X +-- % X X X +blockDescS 10 = map (first adjustPos) allBlocks - blockRows :: Num a => a - blockRows = 9 + where - midRow :: Integral a => a - midRow = blockRows `div` 2 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , odd x + ] + ++ [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [midRow] + , even x + ] + blockRows :: Num a => a + blockRows = 9 + midRow :: Integral a => a + midRow = blockRows `div` 2 -- Level 11 -- %%%%%%%% --- % XX --- % XXXX --- % XXXXXX +-- % XX +-- % XXXX +-- % XXXXXX -- % XXXXXXXX --- % XXXXXX --- % XXXX --- % XX -blockPosS 11 = map adjustPos allBlocks +-- % XXXXXX +-- % XXXX +-- % XX +blockDescS 11 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | y <- [0..blockRows-1] - , x <- [0..(blockColumns-1) - 2 * abs (y - midRow)]] + where - blockRows :: Num a => a - blockRows = 7 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | y <- [0 .. blockRows - 1] + , x <- [0 .. (blockColumns - 1) - (2 * abs (y - midRow))] + ] - midRow :: Integral a => a - midRow = blockRows `div` 2 + blockRows :: Num a => a + blockRows = 7 + midRow :: Integral a => a + midRow = blockRows `div` 2 + -- Level 12 -- %%%%%%%% -- % XXXXXXX @@ -348,21 +447,230 @@ -- % X X -- % X X -blockPosS 12 = map adjustPos allBlocks +blockDescS 12 = map (first adjustPos) allBlocks - where allBlocks :: (Enum a, Num a, Eq a, Integral a) => [(a,a)] - allBlocks = [(x,y) | x <- [0..blockColumns-1], y <- [0]] ++ - [(x,y) | x <- [2, blockColumns-3], y <- [1,2]] ++ - [(1,4), (blockColumns-2,4), (0,5), (blockColumns-1,5)] + where - blockRows :: Num a => a - blockRows = 9 + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0] + ] + ++ [ ((x, y), maxBlockLife) + | x <- [2, blockColumns - 3] + , y <- [1, 2] + ] + ++ [ ((1, 4), maxBlockLife) + , ((blockColumns - 2, 4), maxBlockLife) + , ((0, 5), maxBlockLife) + , ((blockColumns - 1, 5), maxBlockLife) + ] -blockPosS _ = error "No more levels" + blockRows :: Num a => a + blockRows = 9 +-- Level 13 +-- X == maxBlockLife +-- O == maxBlockLife - minBlockLife +-- %%%%%%%% +-- % XOXOXOXO +-- % OXOXOXOX +-- % XOXOXOXO +-- % OXOXOXOX +blockDescS 13 = map (first adjustPos) allBlocks + + where + + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), blockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , let blockLife = + if even (x + y) + then maxBlockLife + else maxBlockLife - 1 + ] + + blockRows :: Num a => a + blockRows = 4 + +-- Level 14 +-- X == maxBlockLife +-- O == maxBlockLife - minBlockLife +-- Y == minBlockLife +-- %%%%%%%% +-- % YYYYYYYY +-- % YXXXXXXY +-- % YXOOOOXY +-- % YXXXXXXY +-- % YYYYYYYY +blockDescS 14 = map (first adjustPos) allBlocks + + where + + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), minBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..blockRows - 1] + , (x == 0) + || (y == 0) + || (x == blockColumns - 1) + || (y == blockRows - 1)] + + ++ [ ((x, y), maxBlockLife - 1) + | x <- [1..blockColumns - 2] + , y <- [1..blockRows - 2] + , (x == 1) + || (y == 1) + || (x == blockColumns - 2) + || (y == blockRows - 2)] + + ++ [ ((x, y), maxBlockLife) + | x <- [2..blockColumns - 3] + , y <- [2..blockRows - 3] + , (x == 2) + || (y == 2) + || (x == blockColumns - 3) + || (y == blockRows - 3)] + + blockRows :: Num a => a + blockRows = 5 + +-- Level 15 +-- maxBlockLife == X +-- minBlockLife == O +-- blockLife == T +-- %%%%%%%% +-- % X X X +-- % X X X +-- % X X X +-- % X X X +-- % OXOXOXO +-- % T T T +-- % T T T +-- % T T T +-- % T T T +blockDescS 15 = map (first adjustPos) allBlocks + + where + + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0..midRow] + , odd x + ] + ++ [ ((x, y), minBlockLife) + | x <- [0..blockColumns - 1] + , y <- [midRow] + , even x + ] + ++ [ ((x, y), maxBlockLife - 1) + | x <- [0..blockColumns - 1] + , y <- [midRow + 1..blockColumns - 1] + , even x + ] + + blockRows :: Num a => a + blockRows = 9 + + midRow :: Integral a => a + midRow = blockRows `div` 2 + +-- Level 16 +-- maxBlockLife == X +-- minBlockLife == O +-- blockLife == T +-- %%%%%%%% +-- % XXXOOXXX +-- % XXXOOXXX +-- % +-- % T T T T +-- % T T T T +-- % +-- % XXXOOXXX +-- % XXXOOXXX + +blockDescS 16 = map (first adjustPos) allBlocks + + where + + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife - 1) + | x <- [0..blockColumns - 1] + , y <- [midColumn - 1, midColumn] + , (even x && y == midColumn) || (odd x && y == midColumn -1) + ] + + ++ [ ((x, y), minBlockLife) + | x <- [midColumn - 1, midColumn] + , y <- [0, 1, blockRows - 2, blockRows - 1] + ] + + ++ [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0, 1, blockRows - 2, blockRows - 1] + , x /= midColumn - 1 + , x /= midColumn + ] + + blockRows :: Num a => a + blockRows = 8 + + midRow :: Integral a => a + midRow = blockRows `div` 2 + + midColumn :: Integral a => a + midColumn = blockColumns `div` 2 + +-- Level 17 +-- maxBlockLife == X +-- minBlockLife == O +-- blockLife == T +-- %%%%%%%% +-- % XXXXXXXX +-- % O O O O +-- % O O O O +-- % T T T T +-- % T T T T +-- % O O O O +-- % O O O O +-- % +-- % XXX XXXX +blockDescS 17 = map (first adjustPos) allBlocks + + where + + allBlocks :: (Enum a, Num a, Eq a, Integral a) => [((a, a), Int)] + allBlocks = [ ((x, y), maxBlockLife - 1) + | x <- [0..blockColumns - 1] + , y <- [3, 4] + , odd x + ] + + ++ [((x, y), minBlockLife) + | x <- [0..blockColumns - 1] + , y <- [1, 2, blockRows - 4, blockRows - 3] + , even x + ] + + ++ [ ((x, y), maxBlockLife) + | x <- [0..blockColumns - 1] + , y <- [0, blockRows - 1] + , y == 0 || x /= midColumn + ] + + blockRows :: Num a => a + blockRows = 9 + + midColumn :: Integral a => a + midColumn = blockColumns `div` 2 + +blockDescS _ = error "No more levels" + -- Dynamic positioning/level size -adjustPos :: Integral a => (a,a) -> (Double, Double) +adjustPos :: Integral a => (a, a) -> (Double, Double) adjustPos = ((adjustHPos *** adjustVPos) . fI2) adjustVPos :: Double -> Double @@ -377,19 +685,8 @@ 1 + round' ( (gameWidth - blockWidth - 2 * leftMargin) / (blockWidth + blockSeparation) ) - where round' = fromIntegral . floor - --- * Testing constants --- --- These constans are used by the game, and can be mofidied on order to test --- different levels. --- --- TODO: should this be moved to the module Constants? - --- | Initial level. Change this in the code to start --- from a different level. -initialLevel :: Int -initialLevel = 0 + where + round' = fromIntegral . floor -- * Constants @@ -401,5 +698,5 @@ -- * Auxiliary functions -fI2 :: Integral a => (a,a) -> (Double, Double) -fI2 (x,y) = (fromIntegral x, fromIntegral y) +fI2 :: Integral a => (a, a) -> (Double, Double) +fI2 (x, y) = (fromIntegral x, fromIntegral y) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,13 @@ -import Control.Applicative ((<$>)) +-- External imports +import Control.Applicative ((<$>)) import Control.Monad.IfElse -import FRP.Yampa as Yampa +import FRP.Yampa as Yampa -import Game +-- Internal imports import Display -import Input +import Game import Graphics.UI.Extra.SDL +import Input -- TODO: Use MaybeT or ErrorT to report errors main :: IO () @@ -25,6 +27,5 @@ mInput <- senseInput controllerRef return (dtSecs, Just mInput) ) - (\_ e -> render res' e >> return False) - wholeGame - + (\_ (e, c) -> render res' e >> return (controllerQuit c)) + (wholeGame &&& arr id) diff --git a/src/ObjectSF.hs b/src/ObjectSF.hs --- a/src/ObjectSF.hs +++ b/src/ObjectSF.hs @@ -1,21 +1,27 @@ --- | Objects as signal functions. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- --- Live objects in the game take user input and the game universe --- and define their state in terms of that. They can remember what --- happened (see Yampa's Arrow combinators, which hide continuations), --- change their behaviour (see switches in Yampa). +-- Objects as signal functions. -- +-- Live objects in the game take user input and the game universe and define +-- their state in terms of that. They can remember what happened (see Yampa's +-- Arrow combinators, which hide continuations), change their behaviour (see +-- switches in Yampa). +-- -- They cannot affect other objects, but they can kill themselves (see --- 'harakiri'). Should you need to spawn new game elements upon --- events, you might want to change 'harakiri' to something more --- general. +-- 'harakiri'). Should you need to spawn new game elements upon events, you +-- might want to change 'harakiri' to something more general. module ObjectSF where +-- External imports import FRP.Yampa -import Objects -import Input +-- Internal imports import Data.IdentityList +import Input +import Objects -- | Objects are defined as transformations that take 'ObjectInput' signals and -- return 'ObjectOutput' signals. @@ -26,13 +32,13 @@ -- ('collisions'), and the presence of any pre-existing objects -- ('knownObjects'). -- --- The reason for depending on 'Collisions' is that objects may ``die'' --- when hit. +-- The reason for depending on 'Collisions' is that objects may ``die'' when +-- hit. -- --- The reason for depending on 'Objects' is that objects may choose to --- follow other objects. +-- The reason for depending on 'Objects' is that objects may choose to follow +-- other objects. -- --- TODO: Would it be possible to depend on the specific object sfs internally +-- TODO: Would it be possible to depend on the specific object SFs internally -- and remove the explicit 'knownObjects'? I guess so, so long as it's possible -- to always provide the same input to those SFs that they will have in the -- game: because they are different instances, we need the exact same input to @@ -43,13 +49,12 @@ , knownObjects :: Objects } --- | What we can see about each live object at each time. It's a --- snapshot of the object. +-- | What we can see about each live object at each time. It's a snapshot of +-- the object. data ObjectOutput = ObjectOutput { outputObject :: Object -- ^ The object's state (position, shape, etc.). , harakiri :: Event () -- ^ Whether the object has died (killed itself). - } - + } -- | Handy function to create an object that is currently alive. livingObject :: Object -> ObjectOutput @@ -64,4 +69,3 @@ -- | A list of object outputs type ObjectOutputs = [ObjectOutput] - diff --git a/src/Objects.hs b/src/Objects.hs --- a/src/Objects.hs +++ b/src/Objects.hs @@ -1,13 +1,21 @@ --- | Game objects and collisions. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Game objects and collisions. module Objects where -import FRP.Yampa.VectorSpace +-- External imports +import Data.VectorSpace +-- Internal imports (general purpose) import Data.Extra.Num -import Physics.TwoDimensions.Dimensions import Physics.TwoDimensions.Collisions +import Physics.TwoDimensions.Dimensions import Physics.TwoDimensions.Physics +-- Internal imports import Constants -- * Objects @@ -26,9 +34,11 @@ , objectHit :: Bool , canCauseCollisions :: Bool , collisionEnergy :: Double - , displacedOnCollision :: Bool -- Theoretically, setting cE == 0 should suffice + , displacedOnCollision :: Bool -- Theoretically, + -- setting cE == 0 + -- should suffice. } - deriving (Show) + deriving (Show) type Objects = [Object] @@ -36,11 +46,11 @@ -- -- TODO: Use a GADT to separate these properties in two types and guarantee a -- proper correspondence in 'Object'. -data ObjectKind = Ball Double -- radius? - | Paddle Size2D - | Block Energy Size2D - | Side Side - deriving (Show,Eq) +data ObjectKind = Ball Double -- radius? + | Paddle Size2D + | Block Energy Size2D + | Side Side + deriving (Show, Eq) type Energy = Int @@ -50,7 +60,7 @@ isBlock :: ObjectKind -> Bool isBlock Block {} = True -isBlock _ = False +isBlock _ = False isPaddle :: Object -> Bool isPaddle o = case objectKind o of @@ -59,30 +69,33 @@ objShape :: Object -> Shape objShape obj = case objectKind obj of - (Ball r) -> Rectangle (p ^-^ (r,r)) (2*r, 2*r) - (Paddle s) -> Rectangle p s - (Block _ s) -> Rectangle p s - (Side s) -> sideToShape p s - where p = objectPos obj - width' = gameWidth - height' = gameHeight - d = collisionErrorMargin - sideToShape p TopSide = Rectangle (p ^-^ (d, d)) (width' + 2*d, d) - sideToShape p LeftSide = Rectangle (p ^-^ (d, d)) (d, height' + 2*d) - sideToShape p RightSide = Rectangle (p ^-^ (0, d)) (d, height' + 2*d) - sideToShape p BottomSide = Rectangle (p ^-^ (d, 0)) (width' + 2*d, d) + (Ball r) -> Rectangle (p ^-^ (r, r)) (2 * r, 2 * r) + (Paddle s) -> Rectangle p s + (Block _ s) -> Rectangle p s + (Side s) -> sideToShape p s + where + + p = objectPos obj + width' = gameWidth + height' = gameHeight + d = collisionErrorMargin + sideToShape p TopSide = Rectangle (p ^-^ (d, d)) (width' + 2 * d, d) + sideToShape p LeftSide = Rectangle (p ^-^ (d, d)) (d, height' + 2 * d) + sideToShape p RightSide = Rectangle (p ^-^ (0, d)) (d, height' + 2 * d) + sideToShape p BottomSide = Rectangle (p ^-^ (d, 0)) (width' + 2 * d, d) + -- * Collisions type Collisions = [Collision] -- | A collision is a list of objects that collided, plus their velocities as -- modified by the collision. --- +-- -- Take into account that the same object could take part in several --- simultaneous collitions, so these velocities should be added (per object). +-- simultaneous collisions, so these velocities should be added (per object). data Collision = Collision - { collisionData :: [(ObjectName, Vel2D)] } -- ObjectId x Velocity - deriving Show + { collisionData :: [(ObjectName, Vel2D)] } -- ObjectId x Velocity + deriving Show -- | Detects a collision between one object and another regardless of -- everything else @@ -101,13 +114,25 @@ collisionResponseObj :: Object -> Object -> Collision collisionResponseObj o1 o2 = - Collision $ - map objectToCollision [(o1, side, o2), (o2, side', o1)] - where side = collisionSide o1 o2 - side' = oppositeSide side - objectReacts o = collisionEnergy o > 0 || displacedOnCollision o - objectToCollision (o,s,o') = (objectName o, correctVel (objectVel o ^+^ (velTrans *^ objectVel o')) (collisionEnergy o) s) - correctVel (vx,vy) e TopSide = (vx, ensurePos (vy * (-e))) - correctVel (vx,vy) e BottomSide = (vx, ensureNeg (vy * (-e))) - correctVel (vx,vy) e LeftSide = (ensureNeg (vx * (-e)),vy) - correctVel (vx,vy) e RightSide = (ensurePos (vx * (-e)),vy) + Collision $ + map objectToCollision [(o1, side, o2), (o2, side', o1)] + + where + + side = collisionSide o1 o2 + side' = oppositeSide side + + objectReacts o = collisionEnergy o > 0 || displacedOnCollision o + + objectToCollision (o, s, o') = + ( objectName o + , correctVel + (objectVel o ^+^ (velTrans *^ objectVel o')) + (collisionEnergy o) + s + ) + + correctVel (vx, vy) e TopSide = (vx, ensurePos (vy * (-e))) + correctVel (vx, vy) e BottomSide = (vx, ensureNeg (vy * (-e))) + correctVel (vx, vy) e LeftSide = (ensureNeg (vx * (-e)), vy) + correctVel (vx, vy) e RightSide = (ensurePos (vx * (-e)), vy) diff --git a/src/Physics/TwoDimensions/Collisions.hs b/src/Physics/TwoDimensions/Collisions.hs --- a/src/Physics/TwoDimensions/Collisions.hs +++ b/src/Physics/TwoDimensions/Collisions.hs @@ -1,39 +1,46 @@ --- | A trivial collision subsystem. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez -- --- Based on the physics module, it determines the side of collision --- between shapes. +-- A trivial collision subsystem. +-- +-- Based on the physics module, it determines the side of collision between +-- shapes. module Physics.TwoDimensions.Collisions where -import FRP.Yampa.VectorSpace as Yampa +-- External imports +import Data.VectorSpace + +-- Internal imports import Physics.TwoDimensions.Physics -- * Collision sides -- | Collision side of a rectangle data Side = TopSide | BottomSide | LeftSide | RightSide - deriving (Eq,Show) + deriving (Eq, Show) -- | Opposite side during a collision. -- --- If A collides with B, the collision sides on --- A and B are always opposite. +-- If A collides with B, the collision sides on A and B are always opposite. oppositeSide :: Side -> Side oppositeSide TopSide = BottomSide oppositeSide BottomSide = TopSide oppositeSide LeftSide = RightSide oppositeSide RightSide = LeftSide --- | Calculates the collision side of a shape --- that collides against another. +-- | Calculates the collision side of a shape that collides against another. -- -- PRE: the shapes do collide. Use 'overlapShape' to check. shapeCollisionSide :: Shape -> Shape -> Side shapeCollisionSide (Rectangle p1 s1) (Rectangle p2 s2) - | wy > hx && wy > -hx = TopSide - | wy > hx = LeftSide - | wy > -hx = RightSide - | otherwise = BottomSide - where (dx,dy) = (p1 ^+^ (0.5 *^ s1)) ^-^ (p2 ^+^ (0.5 *^ s2)) -- p1 ^-^ p2 - (w,h) = 0.5 *^ (s1 ^+^ s2) - wy = w * dy - hx = h * dx + | wy > hx && wy > -hx = TopSide + | wy > hx = LeftSide + | wy > -hx = RightSide + | otherwise = BottomSide + where + (dx, dy) = (p1 ^+^ (0.5 *^ s1)) ^-^ (p2 ^+^ (0.5 *^ s2)) -- p1 ^-^ p2 + (w, h) = 0.5 *^ (s1 ^+^ s2) + wy = w * dy + hx = h * dx diff --git a/src/Physics/TwoDimensions/Dimensions.hs b/src/Physics/TwoDimensions/Dimensions.hs --- a/src/Physics/TwoDimensions/Dimensions.hs +++ b/src/Physics/TwoDimensions/Dimensions.hs @@ -1,9 +1,17 @@ --- | Physical dimensions used all over the game. They are just type synonyms, --- but it's best to use meaningful names to make our type signatures more +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Physical dimensions used all over the game. They are just type synonyms, but +-- it's best to use meaningful names to make our type signatures more -- meaningful. module Physics.TwoDimensions.Dimensions where type Size2D = (Double, Double) -type Pos2D = (Double, Double) -type Vel2D = (Double, Double) -type Acc2D = (Double, Double) + +type Pos2D = (Double, Double) + +type Vel2D = (Double, Double) + +type Acc2D = (Double, Double) diff --git a/src/Physics/TwoDimensions/Physics.hs b/src/Physics/TwoDimensions/Physics.hs --- a/src/Physics/TwoDimensions/Physics.hs +++ b/src/Physics/TwoDimensions/Physics.hs @@ -1,23 +1,31 @@ --- | A very simple physics subsytem. It currently detects shape --- overlaps only, the actual physics movement is carried out --- in Yampa itself, as it is very simple using integrals and --- derivatives. +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- A very simple physics subsystem. It currently detects shape overlaps only, +-- the actual physics movement is carried out in Yampa itself, as it is very +-- simple using integrals and derivatives. module Physics.TwoDimensions.Physics where -import FRP.Yampa.VectorSpace as Yampa +-- External imports +import Data.VectorSpace + +-- Internal imports import Physics.TwoDimensions.Dimensions -data Shape = Rectangle Pos2D Size2D -- A corner and the whole size - -- Circle Pos2D Float -- Position and radius -- NOT FOR NOW - -- SemiPlane Pos2D Float -- Position and angle of plane normal -- NFN +data Shape = Rectangle Pos2D Size2D -- A corner and the whole size + -- Circle Pos2D Float -- Position and radius -- NOT FOR NOW + -- SemiPlane Pos2D Float -- Position, angle of plane normal NFN -- | Detects if two shapes overlap. -- --- Rectangles: overlap if projections on both axis overlap, --- which happens if x distance between centers is less than the sum --- of half the widths, and the analogous for y and the heights. +-- Rectangles: overlap if projections on both axis overlap, which happens if x +-- distance between centers is less than the sum of half the widths, and the +-- analogous for y and the heights. overlapShape :: Shape -> Shape -> Bool overlapShape (Rectangle p1 s1) (Rectangle p2 s2) = abs dx <= w && abs dy <= h - where (dx,dy) = (p1 ^+^ (0.5 *^ s1)) ^-^ (p2 ^+^ (0.5 *^ s2)) - (w,h) = 0.5 *^ (s1 ^+^ s2) + where + (dx, dy) = (p1 ^+^ (0.5 *^ s1)) ^-^ (p2 ^+^ (0.5 *^ s2)) + (w, h) = 0.5 *^ (s1 ^+^ s2) diff --git a/src/Resources.hs b/src/Resources.hs --- a/src/Resources.hs +++ b/src/Resources.hs @@ -1,16 +1,25 @@ +-- | +-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014. +-- License : See LICENSE file. +-- Maintainer : Ivan Perez +-- +-- Resource specifications. module Resources where data ResourceSpec = ResourceSpec - { fonts :: [FontResource] - , images :: [ImageResource] - , music :: [MusicResource] - , audio :: [AudioResource] - } + { fonts :: [FontResource] + , images :: [ImageResource] + , music :: [MusicResource] + , audio :: [AudioResource] + } -type FontResource = Resource +type FontResource = Resource + type ImageResource = Resource + type MusicResource = Resource + type AudioResource = Resource newtype Resource = Resource { _resourceFP :: FilePath } - deriving Eq + deriving Eq