diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/data/196106_aiwha_ding-cc-by.wav b/data/196106_aiwha_ding-cc-by.wav new file mode 100644 Binary files /dev/null and b/data/196106_aiwha_ding-cc-by.wav differ diff --git a/data/ball.png b/data/ball.png new file mode 100644 Binary files /dev/null and b/data/ball.png differ diff --git a/data/ball2.png b/data/ball2.png new file mode 100644 Binary files /dev/null and b/data/ball2.png differ diff --git a/data/block1.png b/data/block1.png new file mode 100644 Binary files /dev/null and b/data/block1.png differ diff --git a/data/block2.png b/data/block2.png new file mode 100644 Binary files /dev/null and b/data/block2.png differ diff --git a/data/block3.png b/data/block3.png new file mode 100644 Binary files /dev/null and b/data/block3.png differ diff --git a/data/level0.mp3 b/data/level0.mp3 new file mode 100644 # file too large to diff: data/level0.mp3 diff --git a/data/level0.png b/data/level0.png new file mode 100644 Binary files /dev/null and b/data/level0.png differ diff --git a/data/level1.mp3 b/data/level1.mp3 new file mode 100644 Binary files /dev/null and b/data/level1.mp3 differ diff --git a/data/level1.png b/data/level1.png new file mode 100644 Binary files /dev/null and b/data/level1.png differ diff --git a/data/level2.mp3 b/data/level2.mp3 new file mode 100644 # file too large to diff: data/level2.mp3 diff --git a/data/level2.png b/data/level2.png new file mode 100644 Binary files /dev/null and b/data/level2.png differ diff --git a/data/paddleBlu.png b/data/paddleBlu.png new file mode 100644 Binary files /dev/null and b/data/paddleBlu.png differ diff --git a/haskanoid.cabal b/haskanoid.cabal new file mode 100644 --- /dev/null +++ b/haskanoid.cabal @@ -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 + diff --git a/src/Audio.hs b/src/Audio.hs new file mode 100644 --- /dev/null +++ b/src/Audio.hs @@ -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) diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -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 diff --git a/src/Control/Extra/Monad.hs b/src/Control/Extra/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Control/Extra/Monad.hs @@ -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 diff --git a/src/Data/Extra/List.hs b/src/Data/Extra/List.hs new file mode 100644 --- /dev/null +++ b/src/Data/Extra/List.hs @@ -0,0 +1,4 @@ +module Data.Extra.List where + +mapFilter :: (a -> b) -> (a -> Bool) -> [a] -> [b] +mapFilter f p = map f . filter p diff --git a/src/Data/Extra/Num.hs b/src/Data/Extra/Num.hs new file mode 100644 --- /dev/null +++ b/src/Data/Extra/Num.hs @@ -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 diff --git a/src/Data/Extra/Ord.hs b/src/Data/Extra/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Data/Extra/Ord.hs @@ -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) + diff --git a/src/Data/Extra/VectorSpace.hs b/src/Data/Extra/VectorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Data/Extra/VectorSpace.hs @@ -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 diff --git a/src/Data/IdentityList.hs b/src/Data/IdentityList.hs new file mode 100644 --- /dev/null +++ b/src/Data/IdentityList.hs @@ -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] ] diff --git a/src/Display.hs b/src/Display.hs new file mode 100644 --- /dev/null +++ b/src/Display.hs @@ -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 }) diff --git a/src/FRP/Extra/Yampa.hs b/src/FRP/Extra/Yampa.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Extra/Yampa.hs @@ -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 #-} + diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 --- /dev/null +++ b/src/Game.hs @@ -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 diff --git a/src/GameCollisions.hs b/src/GameCollisions.hs new file mode 100644 --- /dev/null +++ b/src/GameCollisions.hs @@ -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 diff --git a/src/GameState.hs b/src/GameState.hs new file mode 100644 --- /dev/null +++ b/src/GameState.hs @@ -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 diff --git a/src/Graphics/UI/Extra/SDL.hs b/src/Graphics/UI/Extra/SDL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Extra/SDL.hs @@ -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 diff --git a/src/Input.hs b/src/Input.hs new file mode 100644 --- /dev/null +++ b/src/Input.hs @@ -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 diff --git a/src/Levels.hs b/src/Levels.hs new file mode 100644 --- /dev/null +++ b/src/Levels.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 + diff --git a/src/ObjectSF.hs b/src/ObjectSF.hs new file mode 100644 --- /dev/null +++ b/src/ObjectSF.hs @@ -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] + diff --git a/src/Objects.hs b/src/Objects.hs new file mode 100644 --- /dev/null +++ b/src/Objects.hs @@ -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) diff --git a/src/Physics/TwoDimensions/Collisions.hs b/src/Physics/TwoDimensions/Collisions.hs new file mode 100644 --- /dev/null +++ b/src/Physics/TwoDimensions/Collisions.hs @@ -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 diff --git a/src/Physics/TwoDimensions/Dimensions.hs b/src/Physics/TwoDimensions/Dimensions.hs new file mode 100644 --- /dev/null +++ b/src/Physics/TwoDimensions/Dimensions.hs @@ -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) diff --git a/src/Physics/TwoDimensions/Physics.hs b/src/Physics/TwoDimensions/Physics.hs new file mode 100644 --- /dev/null +++ b/src/Physics/TwoDimensions/Physics.hs @@ -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) diff --git a/src/Resources.hs b/src/Resources.hs new file mode 100644 --- /dev/null +++ b/src/Resources.hs @@ -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