haskanoid (empty) → 0.1.2

raw patch · 39 files changed

+2411/−0 lines, 39 filesdep +IfElsedep +MissingHdep +SDLsetup-changedbinary-added

Dependencies added: IfElse, MissingH, SDL, SDL-image, SDL-mixer, SDL-ttf, Yampa, base, hcwiid, mtl, transformers

Files

• LICENSE +145/−0
• Setup.hs +2/−0
• data/196106_aiwha_ding-cc-by.wav binary
• data/ball.png binary
• data/ball2.png binary
• data/block1.png binary
• data/block2.png binary
• data/block3.png binary
• data/level0.mp3 too large to diff
• data/level0.png binary
• data/level1.mp3 binary
• data/level1.png binary
• data/level2.mp3 too large to diff
• data/level2.png binary
• data/paddleBlu.png binary
• haskanoid.cabal +92/−0
• src/Audio.hs +67/−0
• src/Constants.hs +62/−0
• src/Control/Extra/Monad.hs +19/−0
• src/Data/Extra/List.hs +4/−0
• src/Data/Extra/Num.hs +7/−0
• src/Data/Extra/Ord.hs +5/−0
• src/Data/Extra/VectorSpace.hs +6/−0
• src/Data/IdentityList.hs +177/−0
• src/Display.hs +283/−0
• src/FRP/Extra/Yampa.hs +39/−0
• src/Game.hs +642/−0
• src/GameCollisions.hs +125/−0
• src/GameState.hs +66/−0
• src/Graphics/UI/Extra/SDL.hs +39/−0
• src/Input.hs +193/−0
• src/Levels.hs +143/−0
• src/Main.hs +30/−0
• src/ObjectSF.hs +67/−0
• src/Objects.hs +111/−0
• src/Physics/TwoDimensions/Collisions.hs +39/−0
• src/Physics/TwoDimensions/Dimensions.hs +9/−0
• src/Physics/TwoDimensions/Physics.hs +23/−0
• src/Resources.hs +16/−0

@@ -0,0 +1,145 @@+This game uses components from different origins, and as such+has a complex licence.++Please, take into account that some of the resources used are only free for+non-commercial purposes. People have worked hard to create them, and we'd like+to honour their work by respecting their terms and ask you to do the same.++Graphics+========+Each graphic has its own licence. If you redistribute the graphics,+with out without the rest of the code, in any form, you must follow+their licence.++The game assets are part of Kenney's Puzzle Game Art set,+together with the licence terms, and can be seen at:+http://opengameart.org/content/puzzle-game-art++Kenney happens to be a Game development studio. Their website is:+http://www.kenney.nl/++Backgrounds:++ - Level0.png is a modification of:+   http://lyshastra.deviantart.com/art/Free-Space-Galaxy-Texture-435800028+   The author authorises any use, but wishes to be credited for it.++ - Level1.png is a picture of Abell 2744 (Pandora's Cluster), it's a composite+   of images taken with the Hubble, the VLT and Chandra ACIS detector.+   It's in the public domain.+   http://hubblesite.org/newscenter/archive/releases/2011/17/+   http://commons.wikimedia.org/wiki/File:Pandora%27s_Cluster_%E2%80%93_Abell_2744.jpg++ - Level2.png is also attributed to Nasa:+   http://hubblesite.org/newscenter/archive/releases/2012/10/image/c/+   If I am not mistaken, it is also in the public domain+   (http://hubblesite.org/about_us/copyright.php).++Fonts++The font that accompanies this game is Lacuna, designed by Peter Hoffmann.+The following note accompanied that font:++  © 2003 Glashaus, designed by Peter Hoffmann+  +  LACUNA is freeware! You have the permission to use the font for every kind of+  publication (electronic/print), it doesn't matter if its commercial or not. You+  can copy and give it away to your friends as long as the font-info-file is+  included with the postscript or true type data.+  +  Lacuna may not be sold or redesigned without permission of the designer! If you+  do so – we have uncanny voodoo-powers and friends in Moscow.+  +  We are looking forward to your comments, suggestions and to any information+  if/how you incorporated this font.+  +  www.glashaus-design.com+  peter.hoffmann@glashaus-design.com++Music and sound+===============+Each sound file has its own licence. If you redistribute the graphics,+with out without the rest of the code, in any form, you must follow+their licence.++The following music files are used:++ - Level0: Space arpeggio, by mmb digidesigns+   Licence: CC-BY-NC-SA+   https://www.jamendo.com/en/track/79664/space-arpeggio+ + - Level1: Move, by mmb digidesigns+   Licence: CC-BY-NC-SA+   https://www.jamendo.com/en/track/79669/move+ + - Level2: Peanuts groove, by Spintronic +   Licence: CC-BY-NC-SA+   https://www.jamendo.com/en/track/230855/peanuts-groove++The following soundfx files are included in this distribution:++ - The sound played when a block is hit is attributed to Aiwha, and can be+   redistributed under the terms of the CC-BY-3.0 licence.+   http://www.freesound.org/people/Aiwha/sounds/196106/++Code+====++The purpose of this publication is to allow studying FRP, Game Programming and+Functional Programming. ++The module Data/IdentityList.hs is Copyright (c) Henrik Nilsson, Antony+Courtney (Yale), and can be redistributed under the terms of the BSD licence.++The Audio module is Copyright 2010-2014 Keera Studios, redistributed with+permission under the terms of the 3-clause BSD licence. If (when) the file is+redistributed, even if it is in binary form as part of another program, a+mention (without any implication of endorsement from Keera Studios) wouldn't+hurt.++The remained of the code is Copyright 2014 Ivan Perez & Henrik Nilsson.+and the following licence applies to it:++    Redistribution and use of the haskanoid code or any derivative works are+    permitted provided that all the following conditions are met:+    +    Redistributions may not be sold, nor may they be used in a commercial+    product or activity.+    +    Redistributions that are modified from the original source must include the+    complete source code, including the source code for all components used by a+    binary built from the modified sources. However, as a special exception, the+    source code distributed need not include anything that is normally distributed+    (in either source or binary form) with the major components (compiler, kernel,+    and so on) of the operating system on which the executable runs, unless that+    component itself accompanies the executable.+    +    Redistributions must reproduce the above copyright notice, this list of+    conditions and the following disclaimer in the documentation and/or other+    materials provided with the distribution.+    +    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+    AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+    IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+    DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE+    FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+    DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+    SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+    OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+    OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ++===============++* Credits++Inspiration has been drawn from Antony Courtney and Henrik Nilsson's asteroids+game. This is mainly present in the definition of ObjectSF and in the main game+loop, which uses a structure similar to the one described in the paper ``The+Yampa Arcade''. Other than that, the code is our own (IP & HN).++Also, if you are using this for a course, or a talk, or something like that; it+would be great if you could let us know ( psxip1@nott.ac.uk or+nhn@cs.nott.ac.uk). Just to know how it has been useful. We have additional+resources that you may find useful for your talk, including videos of this game+running on different platforms, statistics/benchmarks, etc.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

binary file changed (absent → 635284 bytes)

binary file changed (absent → 828 bytes)

binary file changed (absent → 892 bytes)

binary file changed (absent → 577 bytes)

binary file changed (absent → 553 bytes)

binary file changed (absent → 561 bytes)

file too large to diff

binary file changed (absent → 765363 bytes)

binary file changed (absent → 1960967 bytes)

binary file changed (absent → 1157743 bytes)

file too large to diff

binary file changed (absent → 1157743 bytes)

binary file changed (absent → 1090 bytes)

@@ -0,0 +1,92 @@+-- Initial haskanoid.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- 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+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.2++-- A short (one-line) description of the package.+synopsis:            A breakout game written in Yampa using SDL++-- A longer description of the package.+description:         An arkanoid game featuring SDL graphics and sound and+                     Wiimote support, implemented using Yampa. ++-- URL for the project homepage or repository.+homepage:            http://github.com/ivanperez-keera/haskanoid++-- The license under which the package is released.+license:             OtherLicense++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Ivan Perez and Henrik Nilsson++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          ivan.perez@keera.co.uk++-- A copyright notice.+-- copyright:           ++category:            Game++build-type:          Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.8++data-files: data/*.png data/*.wav data/*.mp3+++executable haskanoid+  -- .hs or .lhs file containing the Main module.+  main-is: Main.hs++  ghc-options: -Wall -threaded++  hs-source-dirs: src/++  -- Modules included in this executable, other than Main.+  other-modules: Audio+                 Constants+                 Control.Extra.Monad+                 Data.Extra.List+                 Data.Extra.Num+                 Data.Extra.Ord+                 Data.Extra.VectorSpace+                 Data.IdentityList+                 Display+                 FRP.Extra.Yampa+                 Game+                 GameCollisions+                 GameState+                 Graphics.UI.Extra.SDL+                 Input+                 Levels+                 Objects+                 ObjectSF+                 Physics.TwoDimensions.Collisions+                 Physics.TwoDimensions.Dimensions+                 Physics.TwoDimensions.Physics+                 Resources+  +  -- Other library packages from which modules are imported.+  build-depends:       base ==4.6.*,+                       transformers >= 0.3 && < 0.5,+                       mtl,+                       MissingH,+                       Yampa >= 0.9.6 && < 0.10,+                       hcwiid, +                       SDL, SDL-image, SDL-mixer, SDL-ttf,+                       IfElse+  

@@ -0,0 +1,67 @@+-- | 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++import Control.Monad+import Control.Concurrent+import qualified Graphics.UI.SDL.Mixer.General as SDL.Mixer+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++data Music = Music { musicName :: String, unMusic :: SDL.Mixer.Types.Music }+data Audio = Audio { audioName :: String, unAudio :: SDL.Mixer.Types.Chunk }++-- | Initialize the audio subsystem.+--+-- Audio quality and number of channels are fixed (16).+initAudio :: IO ()+initAudio = void $ do+  _result <- SDL.Mixer.openAudio 44100 SDL.Mixer.AudioS16LSB 2 4096+  SDL.Mixer.Channels.allocateChannels 16++-- | Load a music file, returning a 'Music' if loaded successfully.+loadMusic :: String -> IO (Maybe Music)+loadMusic fp = fmap (fmap (Music fp)) $ SDL.Mixer.Music.tryLoadMUS fp++-- | Play music in a loop at max volume.+playMusic :: Music -> IO ()+playMusic m = do+  SDL.Mixer.Music.setMusicVolume 100+  SDL.Mixer.Music.playMusic (unMusic m) (-1)++-- | Stop playing music+stopMusic :: IO ()+stopMusic = SDL.Mixer.Music.haltMusic++-- | Is music playing?+musicPlaying :: IO Bool+musicPlaying = SDL.Mixer.Music.playingMusic++-- | Load an audio file.+loadAudio :: String -> IO (Maybe Audio)+loadAudio fp = fmap (fmap (Audio fp)) $ SDL.Mixer.Samples.tryLoadWAV fp++-- | Play an audio file for the given number of seconds.+--+-- 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 +  _v <- SDL.Mixer.Channels.playChannel (-1) (unAudio wav) 0+  threadDelay (t * 1000)

@@ -0,0 +1,62 @@+module Constants where++import FRP.Yampa+import Physics.TwoDimensions.Dimensions++width :: Double+width  = 640+height :: Double+height = 600++gameTop    :: Double+gameTop    = 100+gameLeft   :: Double+gameLeft   = 0++gameWidth :: Double+gameWidth = width+gameHeight :: Double+gameHeight = height - gameTop++loadingDelay :: DTime+loadingDelay = 2 -- seconds++paddleWidth, paddleHeight :: Double+paddleWidth  = 104+paddleHeight = 24+paddleMargin :: Double+paddleMargin = 50+ballWidth, ballHeight :: Double+ballWidth    = 10+ballHeight   = 10+ballMargin :: Double+ballMargin   = 30+blockWidth, blockHeight :: Double+blockWidth   = 64+blockHeight  = 32+blockSeparation :: Double+blockSeparation = 10++initialBallVel :: Pos2D+initialBallVel = (300, -300)++collisionErrorMargin :: Double+collisionErrorMargin = 100++stdLives :: Int+stdLives = 3++-- Energy transmission between objects in collisions+velTrans :: Double+velTrans = 0.2++-- Max speed+maxVNorm :: Double+maxVNorm = 500+      +-- Delays+-- restartDelay :: Time+-- restartDelay = 3+-- +-- wonDelay :: Time+-- wonDelay = 3

@@ -0,0 +1,19 @@+module Control.Extra.Monad where++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++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

@@ -0,0 +1,4 @@+module Data.Extra.List where++mapFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b]+mapFilter f p = map f . filter p 

@@ -0,0 +1,7 @@+module Data.Extra.Num where++ensurePos :: (Eq a, Num a) => a -> a+ensurePos e = if signum e == (-1) then negate e else e++ensureNeg :: (Eq a, Num a) => a -> a+ensureNeg e = if signum e == 1 then negate e else e

@@ -0,0 +1,5 @@+module Data.Extra.Ord where++inRange :: Ord a => (a,a) -> a -> a+inRange (mN, mX) x = min mX (max mN x)+

@@ -0,0 +1,6 @@+module Data.Extra.VectorSpace where++import FRP.Yampa.VectorSpace++limitNorm :: (Ord s, VectorSpace v s) => v -> s -> v+limitNorm v mn = if norm v > mn then mn *^ normalize v else v

@@ -0,0 +1,177 @@+{- +******************************************************************************+*                              I N V A D E R S                               *+*                                                                            *+*       Module:         IdentityList                                         *+*       Purpose:        Association list with automatic key assignment and   *+*                       identity-preserving map and filter operations.       *+*       Author:         Henrik Nilsson                                       *+*                                                                            *+*             Copyright (c) Yale University, 2003                            *+*                                                                            *+******************************************************************************+-}++module Data.IdentityList (+    ILKey,        -- Identity-list key type+    IL,           -- Identity-list, abstract. Instance of functor.+    emptyIL,      -- :: IL a+    insertIL_,    -- :: a -> IL a -> IL a+    insertIL,     -- :: a -> IL a -> (ILKey, IL a)+    listToIL,     -- :: [a] -> IL a+    keysIL,       -- :: IL a -> [ILKey]+    elemsIL,      -- :: IL a -> [a]+    assocsIL,     -- :: IL a -> [(ILKey, a)]+    deleteIL,     -- :: ILKey -> IL a -> IL a+    updateIL,     -- :: ILKey -> a -> IL a -> IL a+    updateILWith, -- :: ILKey -> (a -> a) -> IL a -> IL a+    mapIL,        -- :: ((ILKey, a) -> b) -> IL a -> IL b+    filterIL,     -- :: ((ILKey, a) -> Bool) -> IL a -> IL a+    mapFilterIL,  -- :: ((ILKey, a) -> Maybe b) -> IL a -> IL b+    lookupIL,     -- :: ILKey -> IL a -> Maybe a+    findIL,       -- :: ((ILKey, a) -> Bool) -> IL a -> Maybe a+    mapFindIL,    -- :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b+    findAllIL,    -- :: ((ILKey, a) -> Bool) -> IL a -> [a]+    mapFindAllIL  -- :: ((ILKey, a) -> Maybe b) -> IL a -> [b]+) where++import Data.List (find)+++------------------------------------------------------------------------------+-- Data type definitions+------------------------------------------------------------------------------++type ILKey = Int++-- Invariants:+-- * Sorted in descending key order. (We don't worry about+--   key wrap around).+-- * Keys are NOT reused+data IL a = IL { ilNextKey :: ILKey, ilAssocs :: [(ILKey, a)] }+++------------------------------------------------------------------------------+-- Class instances+------------------------------------------------------------------------------++instance Functor IL where+    fmap f (IL {ilNextKey = nk, ilAssocs = kas}) =+        IL {ilNextKey = nk, ilAssocs = [ (i, f a) | (i, a) <- kas ]}+++------------------------------------------------------------------------------+-- Constructors+------------------------------------------------------------------------------++emptyIL :: IL a+emptyIL = IL {ilNextKey = 0, ilAssocs = []}+++insertIL_ :: a -> IL a -> IL a+insertIL_ a il = snd (insertIL a il)+++insertIL :: a -> IL a -> (ILKey, IL a)+insertIL a (IL {ilNextKey = k, ilAssocs = kas}) = (k, il') where+    il' = IL {ilNextKey = k + 1, ilAssocs = (k, a) : kas}+++listToIL :: [a] -> IL a+listToIL as = IL {ilNextKey = length as,+                  ilAssocs = reverse (zip [0..] as)} -- Maintain invariant!+++------------------------------------------------------------------------------+-- Additional selectors+------------------------------------------------------------------------------++assocsIL :: IL a -> [(ILKey, a)]+assocsIL = ilAssocs+++keysIL :: IL a -> [ILKey]+keysIL = map fst . ilAssocs+++elemsIL :: IL a -> [a]+elemsIL = map snd . ilAssocs+++------------------------------------------------------------------------------+-- Mutators+------------------------------------------------------------------------------++deleteIL :: ILKey -> IL a -> IL a+deleteIL k (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = deleteHlp kas}+    where+        deleteHlp []                                   = []+        deleteHlp kakas@(ka@(k', _) : kas) | k > k'    = kakas+                                           | k == k'   = kas+                                           | otherwise = ka : deleteHlp kas++updateIL :: ILKey -> a -> IL a -> IL a+updateIL k v l = updateILWith k (const v) l++updateILWith :: ILKey -> (a -> a) -> IL a -> IL a+updateILWith k f l = mapIL g l+ where g (k',v') | k == k'   = f v' +                 | otherwise = v'++------------------------------------------------------------------------------+-- Filter and map operations+------------------------------------------------------------------------------++-- These are "identity-preserving", i.e. the key associated with an element+-- in the result is the same as the key of the element from which the+-- result element was derived.++mapIL :: ((ILKey, a) -> b) -> IL a -> IL b+mapIL f (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = [(k, f ka) | ka@(k,_) <- kas]}+++filterIL :: ((ILKey, a) -> Bool) -> IL a -> IL a+filterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {ilNextKey = nk, ilAssocs = filter p kas}+++mapFilterIL :: ((ILKey, a) -> Maybe b) -> IL a -> IL b+mapFilterIL p (IL {ilNextKey = nk, ilAssocs = kas}) =+    IL {+        ilNextKey = nk,+        ilAssocs = [(k, b) | ka@(k, _) <- kas, Just b <- [p ka]]+    }+++------------------------------------------------------------------------------+-- Lookup operations+------------------------------------------------------------------------------++lookupIL :: ILKey -> IL a -> Maybe a+lookupIL k il = lookup k (ilAssocs il)+++findIL :: ((ILKey, a) -> Bool) -> IL a -> Maybe a+findIL p (IL {ilAssocs = kas}) = findHlp kas+    where+        findHlp []                = Nothing+        findHlp (ka@(_, a) : kas) = if p ka then Just a else findHlp kas+++mapFindIL :: ((ILKey, a) -> Maybe b) -> IL a -> Maybe b+mapFindIL p (IL {ilAssocs = kas}) = mapFindHlp kas+    where+        mapFindHlp []         = Nothing+        mapFindHlp (ka : kas) = case p ka of+                                    Nothing     -> mapFindHlp kas+                                    jb@(Just _) -> jb+++findAllIL :: ((ILKey, a) -> Bool) -> IL a -> [a]+findAllIL p (IL {ilAssocs = kas}) = [ a | ka@(_, a) <- kas, p ka ]+++mapFindAllIL:: ((ILKey, a) -> Maybe b) -> IL a -> [b]+mapFindAllIL p (IL {ilAssocs = kas}) = [ b | ka <- kas, Just b <- [p ka] ]

@@ -0,0 +1,283 @@+module Display where++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++import Audio+import Constants+import GameState+import Objects+import Resources hiding (audio)+import Levels++-- | Ad-hoc resource loading+-- This function is ad-hoc in two senses: first, because it+-- has the paths to the files hard-coded inside. And second,+-- because it loads the specific resources that are needed,+-- not a general +--+loadResources :: IO (Maybe ResourceMgr)+loadResources = runMaybeT $ do+  -- Font initialization+  ttfOk <- lift TTF.init+  +  let gameFont = "data/lacuna.ttf"+  -- Load the fonts we need+  font  <- liftIO $ TTF.tryOpenFont gameFont 32 -- What does the 32 do?+  let myFont = fmap (Font gameFont) font++  blockHit <- liftIO $ loadAudio "data/196106_aiwha_ding-cc-by.wav"++  -- bgM <- liftIO $ loadMusic "Ckotty_-_Game_Loop_11.ogg"+  -- bgM <- liftIO $ loadMusic "data/level0.mp3"++  -- let levelBg = "data/level0.png"+  -- img <- lift $ fmap (Image levelBg) $ load levelBg++  let ballImg = "data/ball2.png"+  ball <- lift $ fmap (Image ballImg) $ load ballImg++  let b1Img = "data/block1.png"+  b1 <- lift $ fmap (Image b1Img) $ load b1Img++  let b2Img = "data/block2.png"+  b2 <- lift $ fmap (Image b2Img) $ load b2Img++  let b3Img = "data/block3.png"+  b3 <- lift $ fmap (Image b3Img) $ load b3Img++  let paddleImg = "data/paddleBlu.png"+  paddle <- lift $ fmap (Image paddleImg) $ load paddleImg++  -- Start playing music+  -- when (isJust bgM) $ lift (playMusic (fromJust bgM))++  -- Return Nothing or embed in Resources+  res <- case (myFont, blockHit) of+           (Just f, Just b) -> let +                               in return (Resources f b Nothing ball b1 b2 b3 paddle Nothing)+           _                        -> do liftIO $ putStrLn "Some resources could not be loaded"+                                          mzero++  liftIO $ fmap ResourceMgr $+    newIORef (ResourceManager (GameStarted) (res))++initializeDisplay :: IO ()+initializeDisplay = do+   -- Initialise SDL+  SDL.init [InitEverything]++  initAudio++initGraphs :: IO ()+initGraphs = do+  -- Create window+  screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]+  SDL.setCaption "Test" ""++  -- Important if we want the keyboard to work right (I don't know+  -- how to make it work otherwise)+  SDL.enableUnicode True++  -- Hide mouse+  SDL.showCursor False+++render :: ResourceMgr -> GameState -> IO()+render resourceManager shownState = do+  resources <- loadNewResources resourceManager shownState+  audio   resources shownState+  display resources shownState++audio :: Resources -> GameState -> IO()+audio resources shownState = do+  -- Start bg music if necessary+  playing <- musicPlaying+  when (not playing) $ awhen (bgMusic resources) playMusic ++  -- Play object hits+  mapM_ (audioObject resources) $ gameObjects shownState++audioObject resources object = when (objectHit object) $+  case objectKind object of+    (Block _ _) -> playFile (blockHitSnd resources) 3000+    _           -> return ()++display :: Resources -> GameState -> IO()+display resources shownState = do +  -- Obtain surface+  screen <- getVideoSurface++  -- Paint screen green+  let format = surfaceGetPixelFormat screen++  -- Paint background++  awhen (bgImage resources) $ \bg' -> void $ do+    let bg     = imgSurface bg'+    let rectBg = SDL.Rect 0 0 (round width) (round height)+    SDL.blitSurface bg Nothing screen $ Just rectBg++  hud <- createRGBSurface [SWSurface]+             (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++  -- The following line is BIG_ENDIAN specific+  -- 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+  paintGeneralMsg surface resources (gameStatus (gameInfo shownState))+  mapM_ (paintObject resources surface) $ gameObjects shownState+  let rect = SDL.Rect (round gameLeft) (round gameTop) (round gameWidth) (round gameHeight)+  SDL.blitSurface surface Nothing screen $ Just rect++  -- Double buffering+  SDL.flip screen++paintGeneral screen resources over = void $ do+  -- Paint screen green+  let format = surfaceGetPixelFormat screen+  bgColor <- mapRGB format 0x11 0x22 0x33+  fillRect screen Nothing bgColor+  paintGeneralHUD screen resources over++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 msg = void $ do+  let font = resFont resources+  message <- TTF.renderTextSolid (unFont font) msg (SDL.Color 128 128 128)+  let x = (SDL.surfaceGetWidth  screen - w) `div` 2+      y = (SDL.surfaceGetHeight screen - h) `div` 2+      w = SDL.surfaceGetWidth  message+      h = SDL.surfaceGetHeight message+  SDL.blitSurface message Nothing screen $ Just (SDL.Rect x y w h)++paintGeneralHUD screen resources over = void $ do+  let font = unFont $ resFont resources+  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)+  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)+  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)++paintObject resources screen object = do+  red <- mapRGB format 0xFF 0 0+  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++newtype ResourceMgr = ResourceMgr { unResMgr :: IORef ResourceManager }++data ResourceManager = ResourceManager+  { lastKnownStatus :: GameStatus+  , resources       :: Resources+  }++data Resources = Resources+  { resFont     :: Font+  , blockHitSnd :: Audio+  , bgImage     :: Maybe Image+  , ballImg     :: Image+  , block1Img   :: Image+  , block2Img   :: Image+  , block3Img   :: Image+  , paddleImg   :: Image+  , bgMusic     :: Maybe Music+  }++data Image = Image { imgName  :: String, imgSurface :: Surface }+data Font  = Font  { fontName :: String, unFont :: TTF.Font }++loadNewResources :: ResourceMgr ->  GameState -> IO Resources+loadNewResources mgr state = do+  manager <- readIORef (unResMgr mgr)+  let oldState = lastKnownStatus manager+      newState = gameStatus (gameInfo state)+      oldResources = resources manager++  newResources <- case newState of+                    (GameLoading _) | (newState /= oldState)+                                    -> updateAllResources oldResources newState+                    _               -> return oldResources ++  let manager' = ResourceManager { lastKnownStatus = newState+                                 , resources       = newResources+                                 }++  writeIORef (unResMgr mgr) manager'+  return newResources++updateAllResources :: Resources -> GameStatus -> IO Resources+updateAllResources res (GameLoading n) = do+  -- Load new music+  let newMusicFP = _resourceFP $ levelMusic $ levels !! n+      oldMusic   = bgMusic res+      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++  -- Load new background+  let newBgFP = _resourceFP $ levelBg $ levels !! n+      oldBg   = bgImage res+      oldBgFP = maybe "" imgName oldBg++  newBg <- if oldBgFP == newBgFP+             then return oldBg+             else do img' <- load newBgFP+                     return $ Just (Image newBgFP img')++  return (res { bgImage = newBg, bgMusic = newMusic })

@@ -0,0 +1,39 @@+module FRP.Extra.Yampa where++import Control.Arrow+import FRP.Yampa+import FRP.Yampa.Event++-- 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)++-- 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))++mergeApply' :: SF a (b, Event (b -> b)) -> SF a b+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)++futureSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+futureSwitch sf cont = switch (sf >>> (arr id *** notYet)) cont++futureDSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+futureDSwitch sf cont = dSwitch (sf >>> (arr id *** notYet)) cont++boolToEvent :: Bool -> a -> Event a+boolToEvent True = Event+boolToEvent _    = \_ -> noEvent+{-# INLINE boolToEvent #-}+

@@ -0,0 +1,642 @@+{-# LANGUAGE Arrows #-}+-- | 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. +--+-- 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.+--+-- This module contains three sections:+--+--   - A collection of general game SFs. These determine how the game+--   transitions from one state to another based on different internal events+--   (running out of lives, finishing a level, etc.)+--+--   - A collection of gameplay SFs, which control the core game loop, carry+--   out collision detection, add points, etc.+--+--   - One SF per game object. These define the elements in the game universe,+--   which can observe other elements, depend on user input, on previous+--   collisions, etc.+--+-- You may want to read the basic definition of 'GameState', 'Controller' and+-- 'ObjectSF' before you attempt to go through this module.+--+module Game (wholeGame) where++-- External imports+import Data.List+import Data.Tuple.Utils+import FRP.Yampa++-- General-purpose internal imports+import Data.Extra.Ord+import Data.Extra.VectorSpace+import Data.IdentityList+import FRP.Extra.Yampa+import Physics.TwoDimensions.Collisions+import Physics.TwoDimensions.Dimensions++-- Internal iports+import Constants+import GameCollisions+import GameState+import Input+import Levels+import Objects+import ObjectSF++-- * General state transitions++-- | Run the game that the player can lose at ('canLose'), until ('switch')+-- there are no more levels ('outOfLevels'), in which case the player has won+-- ('wonGame').+wholeGame :: SF Controller GameState+wholeGame = switch+   -- 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 ())+outOfLevels = arr ((>= numLevels) . gameLevel . gameInfo) >>> edge++-- | Run the game in which the player is alive, until she runs out of lives+-- ('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)++-- | Detect when the last life is lost.+outOfLives :: SF GameState (Event ())+outOfLives = arr ((< 0) . gameLives . gameInfo) >>> edge++-- | The game state is over for 3 seconds, then the game is run again+-- ('wholeGame').+restartGame :: SF Controller GameState+restartGame = switch+  (gameOver &&& after 3 ()) (\_ -> wholeGame)++-- | Produces a neutral 'GameOver' 'GameState'.+gameOver :: SF a GameState+gameOver = arr $ const $+ neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameOver } }++-- | The game state is finished for 4 seconds, then the game is run again+-- ('wholeGame').+wonGame :: SF Controller GameState+wonGame = switch+  (gameFinished &&& after 4 ()) (\_ -> wholeGame)++-- | Produces a neutral 'GameFinished' 'GameState'.+gameFinished :: SF a GameState+gameFinished = arr $ const $+ neutralGameState { gameInfo = neutralGameInfo { gameStatus = GameFinished } }++-- | Run the game from the beginning (no points, max lives, etc.).+--+-- Load the first level.+--+gameAlive :: SF Controller GameState+gameAlive = runLevel stdLives initialLevel 0+  -- loadLevel stdLives initialLevel loadingDelay+  -- (gameWithLives stdLives initialLevel)++-- ** Level loading++-- | Set the game state as loading for a few seconds, then start the actual+-- game. Uses 'loadLevel', passing the game SF ('gameWithLives') as+-- continuation.+runLevel :: Int -> Int -> Int -> SF Controller GameState+runLevel lives level pts = loadLevel lives level pts loadingDelay+ (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 lives level pts time next = switch+  -- +  (levelLoading lives level pts &&& after time ())+  (\_ -> next)++-- | Unconditionally output a neutral game state with the 'GameLoading' status,+-- forever.+levelLoading :: Int -> Int -> Int -> SF a GameState+levelLoading lvs lvl pts = arr $ const $+  neutralGameState { gameInfo = GameInfo { gameStatus = GameLoading lvl+                                         , gameLevel  = lvl+                                         , gameLives  = lvs+                                         , gamePoints = pts+                                         }+                   }++-- | 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).+--+-- 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+  -- Run normal game until level is completed+  (gamePlayOrPause numLives level pts >>> (arr id &&& isLevelCompleted))++  -- Take last game state, extract basic info, and load the next level+  (\g -> let level' = level + 1+             lives' = gameLives  $ gameInfo g+             pts    = gamePoints $ gameInfo g+         in runLevel lives' level' pts)++-- | Detect if the level is completed (ie. if there are no more blocks).+isLevelCompleted :: SF GameState (Event GameState)+isLevelCompleted = proc (s) -> do+  over <- edge -< not $ any isBlock (map objectKind (gameObjects s))+  let snapshot = over `tag` s+  returnA -< snapshot++-- ** Pausing++-- | 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.+gamePlayOrPause :: Int -> Int -> Int -> SF Controller GameState+gamePlayOrPause lives level pts = gamePlay lives level pts+--  ((arr id) &&& (pause undefined (False --> isPaused) (mainLoop lives level)))+--  >>> pauseGeneral+--+-- isPaused :: SF Controller Bool+-- isPaused = arr controllerPause+--+-- pauseGeneral :: SF (Controller, GameState) GameState+-- pauseGeneral = proc (c, g) -> do+--   let isPause = controllerPause c+--   let o       = gameInfo g+--   returnA -< if isPause+--                 then g { gameInfo = o { gameStatus = GamePaused } }+--                 else g++-- * Gameplay++-- | Run the game, obtain the internal game's running state, and compose it+-- with the more general 'GameState' using the known number of lives and+-- points.+gamePlay :: Int -> Int -> Int -> SF Controller GameState+gamePlay lives level pts =+  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.+--+-- NOTE: it will be some other SF's responsibility to determine if the player's+-- run out of lives.++-- NOTE (about the code): We need to delay the initial event (if it happened to+-- occur) because, at the moment of switching, it will definitely occur and we+-- will fall in an infinite loop.  Therefore, this dswitch only switches for+-- non-start events.+composeGameState :: Int -> Int -> Int+                 -> SF (ObjectOutputs, Event (), Int) GameState+composeGameState lives level pts = futureDSwitch+  (composeGameState' lives 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+  -- Compose game state+  objects <- extractObjects -< oos+  let general = GameState objects+                          (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.+--+-- 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:+--+--    - The last known object outputs (discarded at every iteration).+--+--    - The last known collisions (discarded at every iteration).+--+--    - 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)))++ where++       -- 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)++       -- Just reorder the input+       adaptInput :: SF (Controller, (ObjectOutputs, Collisions, Int)) ObjectInput+       adaptInput = arr (\(gi,(os,cs,pts)) -> ObjectInput gi cs (map outputObject os))++       -- Parallely apply all object functions+       processMovement :: SF ObjectInput (IL ObjectOutput)+       processMovement = processMovement' objs++       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)++       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++         -- 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)++-- *** Ball++-- | Ball+--+-- A ball that follows the paddle until the user fires it+-- ('followPaddleDetectLaunch'), then switches ('switch') over to start+-- bounding around, until it hits the floor ('bounceAroundDetectMiss').+--+objBall :: ObjectSF+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)))++        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.+--+-- 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++-- | Ball follows the paddle if there is one, and it's out of the screen+-- 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 = fmap 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.+--+bouncingBall :: Pos2D -> Vel2D -> ObjectSF+bouncingBall p0 v0 =+  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++       --      ==========================    ============================+       --     -==--------------------->==--->==-   ------------------->==+       --    / ==                      ==    == \ /                    ==+       --  --  ==                      ==    ==  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++-- | Detect if the ball must bounce and, if so, take a snapshot of the object's+-- current position and velocity.+--+-- 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+-- flying enemies to the game, etc.+ballBounce :: SF (ObjectInput, ObjectOutput) (Event (Pos2D, Vel2D))+ballBounce = noEvent --> ballBounce'++-- | Detect if the ball must bounce and, if so, take a snapshot of the object's+-- current position and velocity.+--+-- 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.+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 +  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+-- 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.+freeBall :: Pos2D -> Vel2D -> ObjectSF+freeBall p0 v0 = proc (ObjectInput ci cs os) -> do++  -- Detect collisions+  let name = "ball"+  let isHit = inCollision name cs++  -- 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)+  p <- (p0 ^+^) ^<< integral -< v++  let obj = Object { objectName           = name+                   , objectKind           = Ball ballWidth+                   , objectPos            = p+                   , objectVel            = v0+                   , objectAcc            = (0, 0)+                   , objectDead           = False+                   , objectHit            = isHit+                   , canCauseCollisions   = True+                   , collisionEnergy      = 1+                   , displacedOnCollision = True+                   }+  +  returnA -< livingObject obj++-- *** Player paddle++-- | The paddle tries to be in line with the mouse/pointer/controller.+--+-- It has drag, to make the game a bit harder. Take a look at the code if you+-- want to make it move faster or even instantaneously.+--+objPaddle :: ObjectSF+objPaddle = proc (ObjectInput ci cs os) -> do++  -- Detect collisions+  let name = "paddle"+  let isHit = inCollision name cs++  -- Try to get to the mouse position, but with a capped+  -- velocity.++  rec+      let v = limitNorm (20.0 *^ (refPosPaddle ci ^-^ p)) maxVNorm+      p <- (initPosPaddle ^+^) ^<< integral -< v++  --  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)+                     , objectPos            = p+                     , objectVel            = v+                     , objectAcc            = (0,0)+                     , objectDead           = False+                     , objectHit            = isHit+                     , canCauseCollisions   = True+                     , collisionEnergy      = 0+                     , displacedOnCollision = False+                     }++-- | 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)++-- | The paddle's vertical position, at a reasonable distance from the bottom.+yPosPaddle :: Double+yPosPaddle = gameHeight - paddleMargin++-- *** 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++  -- Detect collisions+  let name  = "blockat" ++ show (x,y)+      isHit = inCollision name cs+  hit   <- edge -< isHit++  -- Must be hit three times do disappear+  --+  -- 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)) +  -- +  -- let lives = 3 -- Always perfect++  -- Dead if out of lives.+  let isDead = lives <= 0+  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+                      })+               dead++-- *** Walls++-- | Walls. Each wall has a side and a position.+--+-- NOTE: They are considered game objects instead of having special treatment.+-- 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+-- (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) ++-- | See 'objSideRight'.+objSideLeft   :: ObjectSF+objSideLeft   = objWall "leftWall"   LeftSide   (0, 0) ++-- | See 'objSideRight'.+objSideTop    :: ObjectSF+objSideTop    = objWall "topWall"    TopSide    (0, 0) ++-- | See 'objSideRight'.+objSideBottom :: ObjectSF+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

@@ -0,0 +1,125 @@+-- | A very rudimentary collision system.+--+-- It compares every pair of objects, trying to determine if there is a+-- collision between the two of them.+--+-- NOTE: In order to minimize the number of comparisons, only moving objects+-- are tested (against every game object). That's only 2 objects right now+-- (making it almost linear in complexity), but it could easily grow and become+-- too slow.+--+module GameCollisions where++import Data.List+import Data.Maybe+import Objects+import Data.IdentityList+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).+--+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++               -- 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++-- | 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+-- 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]+detectCollisions'' objsT m = concatMap (detectCollisions''' m) (assocsIL objsT)++-- | Detect a possible collision between two objects. Uses the object's keys to+-- distinguish them. Uses the basic 'Object'-based 'detectCollision' to+-- 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}++-- | Return the new velocity as changed by the collection of collisions.+--+-- HN 2014-09-07: New interface to collision detection.+--+-- 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.+--+-- 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.+--+-- - 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".+--+changedVelocity :: ObjectName -> Collisions -> Maybe Vel2D+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))++-- | True if the velocity of the object has been changed by any collision.+inCollision :: ObjectName -> Collisions -> Bool+inCollision name cs = isJust (changedVelocity name cs)++-- | 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

@@ -0,0 +1,66 @@+-- | 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++import Objects++-- | The running state is given by a bunch of 'Objects' and the current general+-- 'GameInfo'. The latter contains info regarding the current level, the number+-- of points, etc.+--+-- 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.+data GameState = GameState+  { gameObjects :: Objects+  , gameInfo    :: GameInfo+  }++-- | Initial (default) game state.+neutralGameState :: GameState+neutralGameState = GameState+  { gameObjects = []+  , 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.+--+-- 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.+data GameInfo = GameInfo+  { gameStatus :: GameStatus+  , gameLives  :: Int+  , gameLevel  :: Int+  , gamePoints :: Int+  }++-- | Initial (default) game info (no points, no lives, no level).+neutralGameInfo :: GameInfo+neutralGameInfo = GameInfo+  { gameStatus = GameStarted+  , gameLevel  = 0+  , gameLives  = 0+  , gamePoints = 0+  }++-- | 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.+data GameStatus = GamePlaying+                | GamePaused+                | GameLoading Int+                | GameOver+                | GameFinished+                | GameStarted+ deriving Eq

@@ -0,0 +1,39 @@+module Graphics.UI.Extra.SDL where++import Data.IORef+import Graphics.UI.SDL as SDL++-- Auxiliary SDL stuff+isEmptyEvent :: Event -> Bool+isEmptyEvent NoEvent = True+isEmptyEvent _       = False++initializeTimeRef :: IO (IORef Int)+initializeTimeRef = do+  -- Weird shit I have to do to get accurate time!+  timeRef <- newIORef (0 :: Int)+  _       <- senseTimeRef timeRef+  _       <- senseTimeRef timeRef+  _       <- senseTimeRef timeRef+  _       <- senseTimeRef timeRef++  return timeRef++senseTimeRef :: IORef Int -> IO Int+senseTimeRef timeRef = do+  -- Get time passed since SDL init+  newTime <- fmap fromIntegral SDL.getTicks++  -- Obtain time difference+  dt <- updateTime timeRef newTime+  return dt++-- | Updates the time in an IO Ref and returns the time difference+updateTime :: IORef Int -> Int -> IO Int+updateTime timeRef newTime = do+  previousTime <- readIORef timeRef+  writeIORef timeRef newTime+  return (newTime - previousTime)++milisecsToSecs :: Int -> Double+milisecsToSecs m = fromIntegral m / 1000

@@ -0,0 +1,193 @@+{-# LANGUAGE ExistentialQuantification #-}+-- | Defines an abstraction for the game controller and the functions to read+-- it.+--+-- Lower-level devices replicate the higher-level API, and should accomodate to+-- it. Each device should:+--+--    - Upon initialisation, return any necessary information to poll it again.+--+--    - Update the controller with its own values upon sensing.+--+-- In this case, we only have two: a wiimote and a mouse/keyboard combination.+-- If the wiimote is available, then the mouse isn't used.+--+-- It's very easy to add new devices. In particular, adding a Kinect using the+-- freenect library is easy (see github.com/keera-studios/freenect) for an+-- updated version.+--+-- Limitations:+-- +--    - Device failures are not handled.+--+--    - Falling back to the next available device when there's a problem.+--+--    - Keymap configuration (having an intermediate Action-based layer).+--+--    - Using more than one device at a time. Changing that would be a one-line+--    patch.+--+module Input where++import Control.Monad+import Control.Monad.IfElse+import Data.IORef+import Data.Maybe (fromJust)+import Graphics.UI.SDL as SDL+import System.CWiid++import Control.Extra.Monad+import Graphics.UI.Extra.SDL++import Constants++-- * Game controller++-- | Controller info at any given point.+data Controller = Controller+  { controllerPos   :: (Double, Double)+  , controllerClick :: Bool+  , controllerPause :: 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).+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.+initializeInputDevices :: IO ControllerRef+initializeInputDevices = do+  dev <- do wm <- wiimoteDev+            case wm of+              Nothing  -> fmap fromJust sdlMouseKB+              Just wm' -> return wm'+  nr <- newIORef defaultInfo+  return $ ControllerRef (nr, dev)+ where defaultInfo = Controller (0,0) 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.+senseInput :: ControllerRef -> IO Controller+senseInput (ControllerRef (cref, sensor)) = do+  cinfo <- readIORef cref+  cinfo' <- sensor cinfo+  writeIORef cref cinfo'+  return cinfo'++type ControllerDev = IO (Maybe (Controller -> IO Controller))++-- * WiiMote API (mid-level)++-- | The wiimote controller as defined using this+-- abstract interface. See 'initializeWiimote'.+wiimoteDev :: ControllerDev+wiimoteDev = initializeWiimote++-- ** Initialisation++-- | Initializes the wiimote, optionally returning the sensing function. It+-- returns Nothing if the Wiimote cannot be detected. Users should have a BT+-- device and press 1+2 to connect to it. A message is shown on stdout.+initializeWiimote :: ControllerDev+initializeWiimote = do+  putStrLn "Initializing WiiMote. Please press 1+2 to connect."+  wm <- cwiidOpen+  awhen wm (void . (`cwiidSetRptMode` 15)) -- Enable button reception, acc and IR+  case wm of+    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.+--+-- TODO: Allow configuring the button and using other motion mechamisms+-- (accelerometers).+--+-- TODO: This should be split in two operations. One that presents a nice+-- Wii-like interface and one that actually updates the controller+senseWiimote :: CWiidWiimote -> Controller -> IO Controller+senseWiimote wiimote controller = do+  flags <- cwiidGetBtnState wiimote+  irs   <- cwiidGetIR wiimote++  -- 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++  -- Calculate mid point between sensor bar leds+  let posX = ((cwiidIRSrcPosX led1) + (cwiidIRSrcPosX led2)) `div` 2+      posY = ((cwiidIRSrcPosY led1) + (cwiidIRSrcPosY led2)) `div` 2++  -- Calculate proportional coordinates+  let propX = fromIntegral (1024 - posX) / 1024.0+      propY = fromIntegral (max 0 (posY - 384)) / 384.0++  -- Calculate game area coordinates+  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' +  --     pos'    = (x'', y)+  -- wiiXDiff :: Float+  -- wiiXDiff = 6++  -- Clicks+  let isClick = cwiidIsBtnPushed flags cwiidBtnA++  -- Update state+  return (controller { controllerPos   = (finX, finY) -- pos'+                     , controllerClick = isClick+                     })++-- * SDL API (mid-level)++-- ** Initialization++-- | Dummy initialization. No device is actually initialized.+sdlMouseKB :: ControllerDev+sdlMouseKB = return (Just sdlGetController)++-- ** 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.+--+-- We need a non-blocking controller-polling function.+-- TODO: Check http://gameprogrammer.com/fastevents/fastevents1.html+sdlGetController :: Controller -> IO Controller+sdlGetController info =+  foldLoopM info pollEvent (not.isEmptyEvent) ((return .) . handleEvent)++-- | Handles one event only and returns the updated controller.+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) }+    _                                  -> c

@@ -0,0 +1,143 @@+-- | Level definition+--+-- This module includes the definition of the levels.+--+-- Each level has:+--+--   - Logical properties (defined in 'blockPosS').+--+--   - Multimedia properties (a background and audio file).+--+-- Together they form 'levels'.+module Levels where++import Control.Arrow((***))+import Physics.TwoDimensions.Dimensions++import Constants+import Resources++-- * Levels+-- ** Level specification+data LevelSpec = LevelSpec+ { blockPoss  :: [Pos2D]       -- ^ Block positions+ , levelBg    :: ImageResource -- ^ Background image+ , levelMusic :: MusicResource -- ^ Background music+ }++-- * Concrete levels+levels :: [LevelSpec]+levels = [ -- Level 0+           LevelSpec { blockPoss  = blockPosS 0+                     , levelBg    = Resource "data/level1.png"+                     , levelMusic = Resource "data/level0.mp3"+                     }+         ,+           -- Level 1+           LevelSpec { blockPoss  = blockPosS 1+                     , levelBg    = Resource "data/level1.png"+                     , levelMusic = Resource "data/level1.mp3"+                     }+         ,+           -- Level 2+           LevelSpec { blockPoss  = blockPosS 2+                     , levelBg    = Resource "data/level2.png"+                     , levelMusic = Resource "data/level2.mp3"+                     }+         ]++-- | Level block specification (positions)++-- Level 0+--   %%%%%%%%+-- % XXXXXXXX+-- % XXXXXXXX+-- % XXXXXXXX+-- % XXXXXXXX+blockPosS :: Int -> [Pos2D]+blockPosS 0 = map (adjustHPos *** adjustVPos) allBlocks++ where allBlocks :: (Enum a, Num a) => [(a,a)]+       allBlocks = [(x,y) | x <- [0..blockColumns-1], y <- [0..blockRows-1]]++       adjustHPos :: Double -> Double+       adjustHPos = (leftMargin +) . ((blockWidth + blockSeparation) *)++       adjustVPos :: Double -> Double+       adjustVPos = (topMargin +) . ((blockHeight + blockSeparation) *)++       blockRows :: Num a => a+       blockRows = 4++       -- Fit as many as possible+       blockColumns :: Num a => a+       blockColumns =+         1 + round' ((gameWidth - blockWidth - 2 * leftMargin) / (blockWidth + blockSeparation))+        where round' = fromIntegral . floor++       leftMargin :: Num a => a+       leftMargin = 25++       topMargin :: Num a => a+       topMargin = 10+       ++-- Level 1+--   %%%%%%%%+-- %    XXXX+-- %   XXXXX +-- %  XXXXXX+-- % XXXXXX+-- % XXXXX+-- % XXXX+--+blockPosS 1 = map (adjustHPos *** adjustVPos) allBlocks+ where+   allBlocks :: (Enum a, Num a, Eq a, Ord a) => [(a,a)]+   allBlocks = [ (x,y) | x <- [0..7], y <- [0..5]+                       , (x + y > 2) && (x + y < 10)+               ]++   adjustHPos :: Double -> Double+   adjustHPos = (leftMargin +) . ((blockWidth + blockSeparation) *)++   adjustVPos :: Double -> Double+   adjustVPos = ((blockHeight + blockSeparation) *)++   leftMargin :: Num a => a+   leftMargin = 20++-- Level 2+--   %%%%%%+-- %  XXXXX+-- % X XXXX+-- % XX XXX+blockPosS 2  = map (adjustHPos *** adjustVPos) allBlocks+ where+   allBlocks :: (Enum a, Num a, Eq a) => [(a,a)]+   allBlocks = [(x,y) | x <- [0..5], y <- [0..2], x /= y]++   adjustHPos :: Double -> Double+   adjustHPos = (blockWidth *)++   adjustVPos :: Double -> Double+   adjustVPos = (100 +) . (blockHeight *)++blockPosS _ = error "No more levels"++-- * 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++-- | Number of levels. Change this in the code to finish+-- in a different level.+numLevels :: Int+numLevels = length levels

@@ -0,0 +1,30 @@+{-# LANGUAGE Arrows #-}+import Control.Monad.IfElse+import FRP.Yampa as Yampa++import Game+import Display+import Input+import Graphics.UI.Extra.SDL++-- TODO: Use MaybeT or ErrorT to report errors+main :: IO ()+main = do++  initializeDisplay++  timeRef       <- initializeTimeRef+  controllerRef <- initializeInputDevices+  res           <- loadResources++  awhen res $ \res' -> do+    reactimate (initGraphs >> senseInput controllerRef)+               (\_ -> do+                  -- Get clock and new input+                  dtSecs <- fmap milisecsToSecs $ senseTimeRef timeRef+                  mInput <- senseInput controllerRef+                  return (dtSecs, Just mInput)+               )+               (\_ e -> render res' e >> return False)+               wholeGame+ 

@@ -0,0 +1,67 @@+-- | 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.+module ObjectSF where++import FRP.Yampa++import Objects+import Input+import Data.IdentityList++-- | Objects are defined as transformations that take 'ObjectInput' signals and+-- return 'ObjectOutput' signals.+type ObjectSF = SF ObjectInput ObjectOutput++-- | In order to determine its new output, an object needs to know the user's+-- desires ('userInput'), whether there have been any collisions+-- ('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 'Objects' is that objects may choose to+-- follow other objects.+--+-- 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+-- guarantee the exact same behaviour.+data ObjectInput = ObjectInput+  { userInput    :: Controller+  , collisions   :: Collisions+  , knownObjects :: Objects+  }++-- | 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+livingObject o = ObjectOutput o noEvent++-- | List of identifiable objects. Used to work with dynamic object+-- collections.+type ObjectSFs = IL ObjectSF++extractObjects :: Functor f => SF (f ObjectOutput) (f Object)+extractObjects = arr (fmap outputObject)++-- | A list of object outputs+type ObjectOutputs = [ObjectOutput]+

@@ -0,0 +1,111 @@+-- | Game objects and collisions.+module Objects where++import FRP.Yampa.VectorSpace++import Data.Extra.Num+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.Collisions+import Physics.TwoDimensions.Physics++import Constants++-- * Objects++type ObjectName = String++-- | Objects have logical properties (ID, kind, dead, hit), shape properties+-- (kind), physical properties (kind, pos, vel, acc) and collision properties+-- (hit, 'canCauseCollisions', energy, displaced).+data Object = Object { objectName           :: ObjectName+                     , objectKind           :: ObjectKind+                     , objectPos            :: Pos2D+                     , objectVel            :: Vel2D+                     , objectAcc            :: Acc2D+                     , objectDead           :: Bool+                     , objectHit            :: Bool+                     , canCauseCollisions   :: Bool+                     , collisionEnergy      :: Double+                     , displacedOnCollision :: Bool       -- Theoretically, setting cE == 0 should suffice+                     }+ deriving (Show)++type Objects   = [Object]++-- | The kind of object and any size properties.+--+-- 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)++type Energy = Int++isBall :: ObjectKind -> Bool+isBall (Ball _) = True+isBall _        = False++isBlock :: ObjectKind -> Bool+isBlock (Block {}) = True+isBlock _          = False++isPaddle :: Object -> Bool+isPaddle o = case objectKind o of+  (Paddle _) -> True+  _          -> False++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)++-- * 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).+data Collision = Collision+  { collisionData :: [(ObjectName, Vel2D)] } -- ObjectId x Velocity+ deriving Show++-- | Detects a collision between one object and another regardless of+-- everything else+--+-- FIXME: should we use the last known positions? Or should velocities suffice?+detectCollision :: Object -> Object -> Maybe Collision+detectCollision obj1 obj2+  | overlap obj1 obj2 = Just (collisionResponseObj obj1 obj2)+  | otherwise         = Nothing++overlap obj1 obj2 = overlapShape (objShape obj1) (objShape obj2)++collisionSide :: Object -> Object -> Side+collisionSide obj1 obj2 = shapeCollisionSide (objShape obj1) (objShape obj2)++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)

@@ -0,0 +1,39 @@+-- | 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           as Yampa+import Physics.TwoDimensions.Physics++-- * Collision sides++-- | Collision side of a rectangle+data Side = TopSide | BottomSide | LeftSide | RightSide+  deriving (Eq,Show)++-- | Opposite side during a collision.+--+-- 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.+--+-- 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

@@ -0,0 +1,9 @@+-- | 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)

@@ -0,0 +1,23 @@+-- | 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.+module Physics.TwoDimensions.Physics where++import FRP.Yampa           as Yampa+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++-- | 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.++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)

@@ -0,0 +1,16 @@+module Resources where++data ResourceSpec = ResourceSpec+ { fonts  :: [FontResource]+ , images :: [ImageResource]+ , music  :: [MusicResource]+ , audio  :: [AudioResource]+ }++type FontResource  = Resource+type ImageResource = Resource+type MusicResource = Resource+type AudioResource = Resource++newtype Resource = Resource { _resourceFP :: FilePath }+ deriving Eq