haskanoid 0.1.5.4 → 0.1.6
raw patch · 23 files changed
+1337/−847 lines, 23 filesdep +bearriverdep +simple-affine-spacedep ~Yampa
Dependencies added: bearriver, simple-affine-space
Dependency ranges changed: Yampa
Files
- haskanoid.cabal +22/−11
- src/Audio.hs +27/−20
- src/Constants.hs +40/−17
- src/Control/Extra/Monad.hs +19/−10
- src/Data/Extra/List.hs +7/−1
- src/Data/Extra/Num.hs +6/−0
- src/Data/Extra/Ord.hs +7/−2
- src/Data/Extra/VectorSpace.hs +8/−1
- src/Display.hs +113/−78
- src/FRP/Extra/Yampa.hs +18/−13
- src/Game.hs +251/−245
- src/GameCollisions.hs +48/−62
- src/GameState.hs +18/−16
- src/Graphics/UI/Extra/SDL.hs +7/−0
- src/Input.hs +121/−105
- src/Levels.hs +457/−160
- src/Main.hs +8/−7
- src/ObjectSF.hs +24/−20
- src/Objects.hs +62/−37
- src/Physics/TwoDimensions/Collisions.hs +24/−17
- src/Physics/TwoDimensions/Dimensions.hs +13/−5
- src/Physics/TwoDimensions/Physics.hs +21/−13
- src/Resources.hs +16/−7
haskanoid.cabal view
@@ -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
src/Audio.hs view
@@ -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 <ivan.perez@keera.co.uk> --+-- 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)
src/Constants.hs view
@@ -1,20 +1,32 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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
src/Control/Extra/Monad.hs view
@@ -1,19 +1,28 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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
src/Data/Extra/List.hs view
@@ -1,4 +1,10 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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
src/Data/Extra/Num.hs view
@@ -1,3 +1,9 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- Auxiliary functions related to the 'Num' typeclass. module Data.Extra.Num where ensurePos :: (Eq a, Num a) => a -> a
src/Data/Extra/Ord.hs view
@@ -1,5 +1,10 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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)-
src/Data/Extra/VectorSpace.hs view
@@ -1,6 +1,13 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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
src/Display.hs view
@@ -1,24 +1,32 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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
src/FRP/Extra/Yampa.hs view
@@ -1,29 +1,35 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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 #-}-
src/Game.hs view
@@ -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 <ivan.perez@keera.co.uk>+--+-- 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
src/GameCollisions.hs view
@@ -1,5 +1,10 @@--- | A very rudimentary collision system.+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk> --+-- 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
src/GameState.hs view
@@ -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 <ivan.perez@keera.co.uk> ----- 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
src/Graphics/UI/Extra/SDL.hs view
@@ -1,5 +1,12 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- Auxiliary functions related to Graphics.UI.SDL. module Graphics.UI.Extra.SDL where +-- External imports import Data.IORef import Graphics.UI.SDL as SDL
src/Input.hs view
@@ -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 <ivan.perez@keera.co.uk> ----- 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-
src/Levels.hs view
@@ -1,117 +1,154 @@--- | Level definition+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk> --+-- 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)
src/Main.hs view
@@ -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)
src/ObjectSF.hs view
@@ -1,21 +1,27 @@--- | Objects as signal functions.+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk> ----- 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]-
src/Objects.hs view
@@ -1,13 +1,21 @@--- | Game objects and collisions.+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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)
src/Physics/TwoDimensions/Collisions.hs view
@@ -1,39 +1,46 @@--- | A trivial collision subsystem.+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk> ----- 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
src/Physics/TwoDimensions/Dimensions.hs view
@@ -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 <ivan.perez@keera.co.uk>+--+-- 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)
src/Physics/TwoDimensions/Physics.hs view
@@ -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 <ivan.perez@keera.co.uk>+--+-- 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)
src/Resources.hs view
@@ -1,16 +1,25 @@+-- |+-- Copyright : (c) Ivan Perez & Henrik Nilsson, 2014.+-- License : See LICENSE file.+-- Maintainer : Ivan Perez <ivan.perez@keera.co.uk>+--+-- 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