pang-a-lambda (empty) → 0.2.0.0
raw patch · 74 files changed
+6558/−0 lines, 74 filesdep +IfElsedep +SDLdep +SDL-gfxsetup-changedbinary-added
Dependencies added: IfElse, SDL, SDL-gfx, SDL-ttf, Yampa, base, bytestring, containers, mtl, transformers
Files
- Experiments/arrowup/Main.hs +83/−0
- Experiments/circling-boxes/Main.hs +77/−0
- Experiments/collisions/Constants.hs +48/−0
- Experiments/collisions/Control/Extra/Monad.hs +19/−0
- Experiments/collisions/Data/Extra/Num.hs +20/−0
- Experiments/collisions/Data/Extra/VectorSpace.hs +6/−0
- Experiments/collisions/Data/IdentityList.hs +190/−0
- Experiments/collisions/Debug.hs +8/−0
- Experiments/collisions/Display.hs +117/−0
- Experiments/collisions/Game.hs +250/−0
- Experiments/collisions/GameState.hs +36/−0
- Experiments/collisions/Graphics/UI/Extra/SDL.hs +40/−0
- Experiments/collisions/Input.hs +109/−0
- Experiments/collisions/Main.hs +47/−0
- Experiments/collisions/ObjectSF.hs +45/−0
- Experiments/collisions/Objects.hs +65/−0
- Experiments/collisions/Physics/TwoDimensions/Collisions.hs +143/−0
- Experiments/collisions/Physics/TwoDimensions/Dimensions.hs +9/−0
- Experiments/collisions/Physics/TwoDimensions/GameCollisions.hs +59/−0
- Experiments/collisions/Physics/TwoDimensions/PhysicalObjects.hs +16/−0
- Experiments/collisions/Physics/TwoDimensions/Shapes.hs +45/−0
- Experiments/collisions/Resources.hs +10/−0
- Experiments/dumbplayer/Main.hs +170/−0
- Experiments/player/Main.hs +209/−0
- Experiments/split/Main.hs +207/−0
- Experiments/splitballs/Constants.hs +44/−0
- Experiments/splitballs/Control/Extra/Monad.hs +19/−0
- Experiments/splitballs/Data/Extra/Num.hs +20/−0
- Experiments/splitballs/Data/Extra/VectorSpace.hs +6/−0
- Experiments/splitballs/Debug.hs +8/−0
- Experiments/splitballs/Display.hs +117/−0
- Experiments/splitballs/Game.hs +301/−0
- Experiments/splitballs/GameState.hs +36/−0
- Experiments/splitballs/Graphics/UI/Extra/SDL.hs +40/−0
- Experiments/splitballs/Input.hs +112/−0
- Experiments/splitballs/Main.hs +43/−0
- Experiments/splitballs/ObjectSF.hs +44/−0
- Experiments/splitballs/Objects.hs +65/−0
- Experiments/splitballs/Physics/TwoDimensions/Collisions.hs +141/−0
- Experiments/splitballs/Physics/TwoDimensions/Dimensions.hs +9/−0
- Experiments/splitballs/Physics/TwoDimensions/GameCollisions.hs +60/−0
- Experiments/splitballs/Physics/TwoDimensions/PhysicalObjects.hs +16/−0
- Experiments/splitballs/Physics/TwoDimensions/Shapes.hs +45/−0
- Experiments/splitballs/Resources.hs +10/−0
- Experiments/splitting-boxes/Main.hs +156/−0
- Experiments/stickyarrowup/Main.hs +81/−0
- LICENSE +674/−0
- Setup.hs +2/−0
- data/lacuna.ttf binary
- pang-a-lambda.cabal +219/−0
- src/Collisions.hs +125/−0
- src/Constants.hs +103/−0
- src/Control/Extra/Monad.hs +19/−0
- src/Data/Extra/IORef.hs +12/−0
- src/Data/Extra/Num.hs +20/−0
- src/Data/Extra/Ord.hs +6/−0
- src/Data/Extra/VectorSpace.hs +6/−0
- src/Debug.hs +8/−0
- src/Display.hs +229/−0
- src/FRP/Yampa/Extra.hs +182/−0
- src/Game.hs +681/−0
- src/GameState.hs +42/−0
- src/Graphics/UI/Extra/SDL.hs +65/−0
- src/Input.hs +133/−0
- src/Main.hs +42/−0
- src/ObjectSF.hs +44/−0
- src/Objects.hs +93/−0
- src/Objects/Walls.hs +101/−0
- src/Physics/TwoDimensions/Collisions.hs +188/−0
- src/Physics/TwoDimensions/Dimensions.hs +9/−0
- src/Physics/TwoDimensions/GameCollisions.hs +62/−0
- src/Physics/TwoDimensions/PhysicalObjects.hs +16/−0
- src/Physics/TwoDimensions/Shapes.hs +66/−0
- src/Resources.hs +10/−0
+ Experiments/arrowup/Main.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE Arrows #-}+import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Primitives as SDL+import FRP.Yampa as Yampa+import Data.IORef+import Debug.Trace++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ reactimate initGraphs+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ return (dtSecs, Nothing))+ (\_ e -> display e >> return False)+ (fire (fromIntegral height / 2) (-10))++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- setVideoMode width height 16 [SWSurface]+ setCaption "Test" ""++display :: (Double, Double) -> IO()+display (boxY0,boxY) = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0xFF 0+ let x = fromIntegral $ (width - boxSide) `div` 2+ y0 = round boxY0+ y = round boxY+ vLine screen x y0 y red++ -- Double buffering+ SDL.flip screen++rising :: Double -> Double -> SF () (Double, Double)+rising y0 v0 = proc () -> do+ y <- (y0+) ^<< integral -< v0+ returnA -< (y0, y)++fire :: Double -> Double -> SF () (Double, Double)+fire y vy = switch (rising y vy >>> (Yampa.identity &&& hitCeiling))+ (\_ -> fire y vy)++hitCeiling :: SF (Double, Double) (Yampa.Event (Double, Double))+hitCeiling = arr (\(y0,y) ->+ let boxTop = y+ in if boxTop < 0+ then Yampa.Event (y0, y)+ else Yampa.NoEvent)++boxSide :: Int+boxSide = 30
+ Experiments/circling-boxes/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE Arrows #-}+import Graphics.UI.SDL as SDL+import FRP.Yampa as Yampa+import Data.IORef++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ reactimate initGraphs+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ return (dtSecs, Nothing))+ (\_ e -> display e >> return False)+ inCirclesL++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- setVideoMode width height 16 [SWSurface]+ setCaption "Test" ""++display :: [(Double,Double)] -> IO()+display xs = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0 0+ let side = 10+ let paintSquare (x,y) =+ fillRect screen (Just (Rect (round x) (round y) side side)) red++ mapM_ paintSquare xs++ -- Double buffering+ SDL.flip screen+++inCirclesL :: SF () [(Double, Double)]+inCirclesL = parB [ inCircles (100, 100)+ , inCircles (200, 200)+ ]++inCircles :: (Double, Double) -> SF () (Double, Double)+inCircles (baseX, baseY) = proc () -> do+ t <- (/5) ^<< localTime -< ()+ let radius = 30+ x = baseX + (cos t * radius)+ y = baseY + (sin t * radius)+ returnA -< (x,y)
+ Experiments/collisions/Constants.hs view
@@ -0,0 +1,48 @@+module Constants where++import Data.Int+import Data.Word+import Graphics.UI.SDL as SDL++width :: Double+width = 640+height :: Double+height = 480++gameWidth :: Double+gameWidth = width++gameHeight :: Double+gameHeight = height++-- Energy transmission between objects in collisions+velTrans :: Double+velTrans = 0.98++-- Max speed+maxVNorm :: Double+maxVNorm = 50000++gravity :: (Double, Double)+gravity = (0, -1000.8)++-- Delays+ballWidth, ballHeight :: Double+ballWidth = 30+ballHeight = 30++ballMargin :: Double+ballMargin = 3++ballSize :: Int16+ballSize = 30++-- Colors+fontColor :: SDL.Color+fontColor = SDL.Color 228 228 228++ballColor :: Word32+ballColor = 0xCC0011FF++velColor :: Word32+velColor = 0xCCBBFFFF
+ Experiments/collisions/Control/Extra/Monad.hs view
@@ -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
+ Experiments/collisions/Data/Extra/Num.hs view
@@ -0,0 +1,20 @@+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++class Similar a where+ sigma :: a -- margin of error++instance Similar Float where+ sigma = 0.01++instance Similar Double where+ sigma = 0.01++(=~) :: (Num a, Ord a, Similar a) => a -> a -> Bool+x =~ y = abs (x - y) < sigma+
+ Experiments/collisions/Data/Extra/VectorSpace.hs view
@@ -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
+ Experiments/collisions/Data/IdentityList.hs view
@@ -0,0 +1,190 @@+{-+******************************************************************************+* 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]+ ilSeq,+) where++import Data.List (find)+import Data.Foldable+++------------------------------------------------------------------------------+-- 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)] }+++instance Foldable IL where+ foldMap f = foldMap f . map snd . ilAssocs+------------------------------------------------------------------------------+-- 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] ]++ilSeq :: IL a -> IL a+ilSeq il = mapSeq (ilAssocs il) `seq` il++mapSeq :: [a] -> [a]+mapSeq x = x `seq` mapSeq' x+mapSeq' [] = []+mapSeq' (a:as) = a `seq` mapSeq as+
+ Experiments/collisions/Debug.hs view
@@ -0,0 +1,8 @@+module Debug where++import Control.Monad (when, void)++import Constants++debug :: Bool -> String -> IO ()+debug b msg = when b $ putStrLn msg
+ Experiments/collisions/Display.hs view
@@ -0,0 +1,117 @@+module Display where++import Control.Arrow ((***))+import Control.Monad+import FRP.Yampa.VectorSpace+import Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Primitives as SDLP+import qualified Graphics.UI.SDL.TTF as TTF+import Text.Printf++import Constants+import GameState+import Objects+import Resources++-- | 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,+-- so it's not a general, parameterised, scalable solution.+--+loadResources :: IO Resources+loadResources = do+ -- Font initialization+ _ <- TTF.init++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font <- TTF.openFont gameFont 32 -- 32: fixed size?+ let myFont = font++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font2 <- TTF.openFont gameFont 8 -- 32: fixed size?+ let myFont2 = font2++ -- Return all resources (just the font)+ return $ Resources myFont myFont2++initializeDisplay :: IO ()+initializeDisplay =+ -- Initialise SDL+ SDL.init [InitEverything]++initGraphs :: Resources -> IO ()+initGraphs _res = do+ screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]+ SDL.setCaption "Voldemort" ""++ -- 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 True++ return ()++render :: Resources -> GameState -> IO()+render resources shownState = do+ -- Obtain surface+ screen <- getVideoSurface++ let format = surfaceGetPixelFormat screen+ bgColor <- mapRGB format 0x37 0x16 0xB4+ fillRect screen Nothing bgColor++ displayInfo screen resources (gameInfo shownState)++ mapM_ (paintObject screen resources ) $ gameObjects shownState++ -- Double buffering+ SDL.flip screen++-- * Painting functions+displayInfo :: Surface -> Resources -> GameInfo -> IO()+displayInfo screen resources over =+ printAlignRight screen resources+ ("Time: " ++ printf "%.3f" (gameTime over)) (10,50)++paintObject :: Surface -> Resources -> Object -> IO ()+paintObject screen resources object =+ case objectKind object of+ (Side {}) -> return ()+ _ -> do+ let (px,py) = (\(u,v) -> (u, gameHeight - v)) (objectPos object)+ let (x,y) = (round *** round) (px,py)+ (vx,vy) = objectVel object+ (x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))+ _ <- SDLP.filledCircle screen x y ballSize (SDL.Pixel ballColor)+ _ <- SDLP.line screen x y x' y' (SDL.Pixel velColor)++ -- Print position+ let font = miniFont resources+ message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor+ let w = SDL.surfaceGetWidth message+ h = SDL.surfaceGetHeight message+ (x'',y'') = (round *** round) (px,py)+ rect = SDL.Rect (x''+30) (y''-30) w h+ SDL.blitSurface message Nothing screen (Just rect)+ return ()++-- * Render text with alignment+printAlignRight :: Surface -> Resources -> String -> (Int, Int) -> IO ()+printAlignRight screen resources msg (x,y) = void $ do+ let font = resFont resources+ message <- TTF.renderTextSolid font msg fontColor+ renderAlignRight screen message (x,y)++-- * SDL Extensions+renderAlignRight :: Surface -> Surface -> (Int, Int) -> IO ()+renderAlignRight screen surface (x,y) = void $ do+ let rightMargin = SDL.surfaceGetWidth screen+ w = SDL.surfaceGetWidth surface+ h = SDL.surfaceGetHeight surface+ rect = SDL.Rect (rightMargin - x - w) y w h+ SDL.blitSurface surface Nothing screen (Just rect)
+ Experiments/collisions/Game.hs view
@@ -0,0 +1,250 @@+{-# 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 two sections:+--+-- - A collection of gameplay SFs, which control the core game loop, carry+-- out collision detection, , 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 FRP.Yampa++-- General-purpose internal imports+import Data.Extra.VectorSpace+import Data.IdentityList+import Physics.TwoDimensions.Collisions+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.GameCollisions+import Physics.TwoDimensions.Shapes++-- Internal iports+import Constants+import GameState+import Input+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 = gamePlay initialObjects >>> composeGameState+ where composeGameState :: SF (Objects, Time) GameState+ composeGameState = arr (second GameInfo >>> uncurry GameState)++-- ** 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 collisions (discarded at every+-- iteration).++gamePlay :: ObjectSFs -> SF Controller (Objects, Time)+gamePlay objs = loopPre [] $+ -- Process physical movement and detect new collisions+ proc (i) -> do+ -- Adapt Input+ let oi = (uncurry ObjectInput) i++ -- Step+ -- Each obj processes its movement forward+ ol <- ilSeq ^<< parB objs -< oi+ let cs' = detectCollisions ol++ -- Output+ elems <- arr elemsIL -< ol+ tLeft <- time -< ()+ returnA -< ((elems, tLeft), cs')++-- * Game objects+--+-- | Objects initially present: the walls, the ball, the paddle and the blocks.+initialObjects :: ObjectSFs+initialObjects = listToIL $+ [ objSideRight+ , objSideTop+ , objSideLeft+ , objSideBottom+ ]+ ++ objEnemies++-- *** Enemy+objEnemies :: [ObjectSF]+objEnemies =+ [ bouncingBall "enemy1" (300, 300) (360, -350)+ , bouncingBall "enemy2" (500, 300) (-330, -280)+ , bouncingBall "enemy3" (200, 100) (-300, -250)+ , bouncingBall "enemy4" (100, 200) (-200, -150)+ ]+-- objEnemies _ =+-- [ bouncingBall "enemy1" (300, 300) (360, -350)+-- , bouncingBall "enemy2" (500, 300) (-300, -250)+-- , bouncingBall "enemy3" (200, 100) (-300, -250)+-- , bouncingBall "enemy4" (100, 200) (-200, -150)+-- , bouncingBall "enemy5" (200, 200) (-300, -150)+-- , bouncingBall "enemy6" (400, 400) (200, 200)+-- ]++-- *** Ball++-- 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 :: String -> Pos2D -> Vel2D -> ObjectSF+bouncingBall bid p0 v0 =+ switch progressAndBounce+ (uncurry (bouncingBall bid)) -- 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 bid)++ -- 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 bid 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 :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce bid = noEvent --> ballBounce' bid++-- | 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' :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce' bid = proc (ObjectInput ci cs, 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 = maybeToEvent (changedVelocity bid cs)+ returnA -< fmap (\v -> (objectPos 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 :: String -> Pos2D -> Vel2D -> ObjectSF+freeBall name p0 v0 = proc (ObjectInput ci cs) -> do++ -- Any free moving object behaves like this (but with+ -- acceleration. This should be in some FRP.NewtonianPhysics+ -- module)+ v <- (v0 ^+^) ^<< integral -< gravity+ p <- (p0 ^+^) ^<< integral -< v++ returnA -< Object { objectName = name+ , objectKind = Ball ballWidth+ , objectPos = p+ , objectVel = v+ , canCauseCollisions = True+ , collisionEnergy = velTrans+ }++-- *** 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 = arr $ \(ObjectInput ci cs) ->+ Object { objectName = name+ , objectKind = Side side+ , objectPos = pos+ , objectVel = (0,0)+ , canCauseCollisions = False+ , collisionEnergy = 0+ }++-- * Auxiliary FRP stuff+maybeToEvent :: Maybe a -> Event a+maybeToEvent = maybe noEvent Event
+ Experiments/collisions/GameState.hs view
@@ -0,0 +1,36 @@+-- | 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 Debug.Trace+import Objects+import FRP.Yampa (Time)++-- | 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 = GameInfo 0+ }++data GameInfo = GameInfo { gameTime :: Time }
+ Experiments/collisions/Graphics/UI/Extra/SDL.hs view
@@ -0,0 +1,40 @@+module Graphics.UI.Extra.SDL where++import Data.IORef+import Data.Maybe (isNothing)+import Graphics.UI.SDL as SDL++-- Auxiliary SDL stuff+isEmptyEvent :: Event -> Bool+isEmptyEvent SDL.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
+ Experiments/collisions/Input.hs view
@@ -0,0 +1,109 @@+-- | 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 one: mouse/keyboard combination.+--+module Input where++-- External imports+import Data.IORef+import Graphics.UI.SDL as SDL++-- Internal imports+import Control.Extra.Monad+import Graphics.UI.Extra.SDL++-- * Game controller++-- | Controller info at any given point.+data Controller = Controller+ { controllerPos :: (Double, Double)+ , controllerClick :: Bool+ , controllerPause :: Bool+ , controllerExit :: Bool+ , controllerFast :: Bool+ , controllerSlow :: Bool+ , controllerSuperSlow :: Bool+ , controllerFullscreen :: 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 { controllerData :: (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+ nr <- newIORef defaultInfo+ return $ ControllerRef (nr, sdlGetController)+ where defaultInfo = Controller (0,0) False False False False False False False++-- | Sense from the controller, providing its current+-- state. This should return a new Controller state+-- if available, or the last one there was.+-- +-- It is assumed that the sensing function is always+-- callable, and that it knows how to update the+-- Controller info if necessary.+senseInput :: ControllerRef -> IO Controller+senseInput (ControllerRef (cref, sensor)) =+ modifyIORefIO cref sensor++type ControllerDev = IO (Maybe (Controller -> IO Controller))++-- * SDL API (mid-level)++-- ** 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)++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) }+ KeyUp (Keysym { symKey = SDLK_f }) -> c { controllerFullscreen = not (controllerFullscreen c) }+ KeyDown (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = True }+ KeyUp (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = False }+ KeyDown (Keysym { symKey = SDLK_s }) -> c { controllerSlow = True }+ KeyUp (Keysym { symKey = SDLK_s }) -> c { controllerSlow = False }+ KeyDown (Keysym { symKey = SDLK_x }) -> c { controllerFast = True }+ KeyUp (Keysym { symKey = SDLK_x }) -> c { controllerFast = False }+ KeyDown (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = True }+ KeyUp (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = False }+ KeyDown (Keysym { symKey = SDLK_ESCAPE}) -> c { controllerExit = True }+ _ -> c+++-- * Aux IOREf+modifyIORefIO :: IORef a -> (a -> IO a) -> IO a+modifyIORefIO ref modify = do+ v <- readIORef ref+ new <- modify v+ writeIORef ref new+ return new
+ Experiments/collisions/Main.hs view
@@ -0,0 +1,47 @@+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.IfElse+import Data.IORef+import Debug.Trace+import FRP.Yampa as Yampa+import Text.Printf++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++ initGraphs res+ reactimate (senseInput controllerRef)+ (\_ -> do+ -- Get clock and new input+ mInput <- senseInput controllerRef+ dtSecs <- senseTime timeRef mInput+ -- trace ("Time : " ++ printf "%.5f" dtSecs) $+ return (if controllerPause mInput then 0 else dtSecs, Just mInput)+ )+ (\_ (e,c) -> do render res e+ -- putStrLn "*********************************************"+ return (controllerExit c)+ )+ (wholeGame &&& arr id)++type MonadicT m a b = a -> m b++senseTime :: IORef Int -> MonadicT IO Controller DTime+senseTime timeRef = \mInput ->+ let tt = if controllerSlow mInput then (/10) else id+ tt1 = if controllerSuperSlow mInput then (/100) else tt+ tt2 = if controllerFast mInput then (*10) else tt1+ in (tt2 . milisecsToSecs) <$> senseTimeRef timeRef
+ Experiments/collisions/ObjectSF.hs view
@@ -0,0 +1,45 @@+-- | 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).+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 Object++-- | In order to determine its new output, an object needs to know the user's+-- desires ('userInput'), whether there have been any collisions+-- ('collisions').+--+-- The reason for depending on 'Collisions' is that objects may ``change''+-- when hit (start moving in a different direction).+data ObjectInput = ObjectInput+ { userInput :: Controller+ , collisions :: Collisions+ }++-- -- | 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.).+-- } ++-- | 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]+--
+ Experiments/collisions/Objects.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Game objects and collisions.+module Objects where++import Control.Arrow ((***))+import FRP.Yampa.VectorSpace++import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import qualified Physics.TwoDimensions.PhysicalObjects as PO+import Physics.TwoDimensions.Shapes++type Collision = C.Collision ObjectName+type Collisions = C.Collisions ObjectName++-- * Objects++type Objects = [Object]+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+ , canCauseCollisions :: !Bool+ , collisionEnergy :: !Double+ }+ deriving (Show)++-- | The kind of object and any size properties.+data ObjectKind = Ball Double -- radius+ | Side Side+ deriving (Show,Eq)++-- Partial function. Object has size.+objectTopLevelCorner :: Object -> Pos2D+objectTopLevelCorner object = objectPos object ^-^ half (objectSize object)+ where half = let h = (/2) in (h *** h)++-- Partial function!+objectSize :: Object -> Size2D+objectSize object = case objectKind object of+ (Ball r) -> let w = 2*r in (w, w)++instance PhysicalObject Object String Shape where+ physObjectPos = objectPos+ physObjectVel = objectVel+ physObjectElas = collisionEnergy+ physObjectShape = objShape+ physObjectCollides = canCauseCollisions+ physObjectId = objectName+ physObjectUpdatePos = \o p -> o { objectPos = p }+ physObjectUpdateVel = \o v -> o { objectVel = v }++objShape :: Object -> Shape+objShape obj = case objectKind obj of+ Ball r -> Circle p r+ Side s -> SemiPlane p s+ where p = objectPos obj
+ Experiments/collisions/Physics/TwoDimensions/Collisions.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE FlexibleContexts #-}+-- | A trivial collision subsystem.+--+-- Based on the physics module, it determines the side of collision+-- between shapes.+module Physics.TwoDimensions.Collisions where++import Data.Extra.Num+import Data.Maybe+import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++-- * Collision points+data CollisionPoint = CollisionSide Side+ | CollisionAngle Double++-- | Calculates the collision side of a shape+-- that collides against another.+--+-- PRE: the shapes do collide. Use 'overlapShape' to check.+shapeCollisionPoint :: Shape -> Shape -> CollisionPoint+shapeCollisionPoint (Circle p1 _) (Circle p2 _) =+ -- | p1x =~ p2x && p1y > p2y = CollisionAngle (- pi / 2)+ -- | p1x =~ p2x && p1y <= p2y = CollisionAngle (pi / 2)+ -- | otherwise =+ CollisionAngle angle+ where (px,py) = p2 ^-^ p1+ angle = atan2 py px+shapeCollisionPoint (Circle _ _) (SemiPlane _ s2) = CollisionSide s2+shapeCollisionPoint (SemiPlane _ s1) (Circle _ _ ) = CollisionSide (oppositeSide s1)+shapeCollisionPoint (SemiPlane _ _) (SemiPlane _ s2) = CollisionSide s2+-- * Collisions+type Collisions k = [Collision k]++-- | 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 k = Collision+ { collisionData :: [(k, Vel2D)] } -- ObjectId x Velocity+ deriving Show++-- | Detects a collision between one object and another.+detectCollision :: (PhysicalObject o k Shape) => o -> o -> Maybe (Collision k)+detectCollision obj1 obj2+ | overlap obj1 obj2+ = case (physObjectShape obj1, physObjectShape obj2) of+ (Circle _ _, Circle _ _) ->+ if vrn < 0+ then Just response+ else Nothing+ _ -> Just response+ | otherwise = Nothing++ where response = collisionResponseObj obj1 obj2+ colNormal = normalize (physObjectPos obj1 ^-^ physObjectPos obj2)+ relativeP = physObjectPos obj1 ^-^ physObjectPos obj2+ relativeV = physObjectVel obj1 ^-^ physObjectVel obj2+ vrn = relativeV `dot` relativeP+ -- NOTE: See Henrik's comment to the main game.++overlap :: PhysicalObject o k Shape => o -> o -> Bool+overlap obj1 obj2 =+ overlapShape (physObjectShape obj1) (physObjectShape obj2)++collisionPoint :: PhysicalObject o k Shape => o -> o -> CollisionPoint+collisionPoint obj1 obj2 =+ shapeCollisionPoint (physObjectShape obj1) (physObjectShape obj2)++collisionResponseObj :: PhysicalObject o k Shape => o -> o -> Collision k+collisionResponseObj o1 o2 = Collision $+ map objectToCollision [(o1, collisionPt, o2), (o2, collisionPt', o1)]+ where collisionPt = collisionPoint o1 o2+ collisionPt' = collisionPoint o2 o1+ objectToCollision (o,pt,o') =+ (physObjectId o,+ correctVel (physObjectPos o) (physObjectPos o')+ (physObjectVel o) (physObjectVel o')+ pt (physObjectElas o))++correctVel :: Pos2D -> Pos2D -> Vel2D -> Vel2D -> CollisionPoint -> Double -> Vel2D+-- Specialised cases: just more optimal execution+correctVel _p1 _p2 v1 _ _ 0 = v1+-- Collision against a wall+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide TopSide) e = (e * v1x, e * ensurePos v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide BottomSide) e = (e * v1x, e * ensureNeg v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide LeftSide) e = (e * ensurePos v1x, e * v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide RightSide) e = (e * ensureNeg v1x, e * v1y)+-- General case+correctVel p1 p2 (v1x,v1y) (v2x, v2y) (CollisionAngle _) e = (v1x, v1y) ^+^ ((e * j) *^ colNormal)+ where colNormal = normalize (p1 ^-^ p2)+ relativeV = (v1x,v1y) ^-^ (v2x,v2y)+ vrn = relativeV `dot` colNormal+ j = (-1) *^ vrn / (colNormal `dot` colNormal)++-- | 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 :: Eq n => n -> Collisions n -> Maybe Vel2D+changedVelocity name cs =+ case concatMap (filter ((== name) . fst) . collisionData) cs of+ [] -> Nothing+ -- vs -> Just (foldl (^+^) (0,0) (map snd vs))+ (_, v') : _ -> Just v'++-- | True if the velocity of the object has been changed by any collision.+inCollision :: Eq n => n -> Collisions n -> Bool+inCollision name cs = isJust (changedVelocity name cs)++-- | True if the two objects are colliding with one another.+inCollisionWith :: Eq n => n -> n -> Collisions n -> Bool+inCollisionWith nm1 nm2 cs = any both cs+ where+ both (Collision nmvs) =+ any ((== nm1) . fst) nmvs+ && any ((== nm2) . fst) nmvs+
+ Experiments/collisions/Physics/TwoDimensions/Dimensions.hs view
@@ -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)
+ Experiments/collisions/Physics/TwoDimensions/GameCollisions.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}+-- | 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 Physics.TwoDimensions.GameCollisions where++import Data.List+import Data.Maybe+import Data.IdentityList+import Physics.TwoDimensions.Collisions+import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++-- | 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 :: (Eq n , PhysicalObject o n Shape) => IL o -> Collisions n+detectCollisions = detectCollisionsH+ where detectCollisionsH objsT = flattened+ where -- Eliminate empty collision sets+ -- TODO: why is this really necessary?+ flattened = filter (\(C.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 (physObjectCollides.snd) $ assocsIL objsT++-- | Detect collisions between each moving object and+-- every other object.+detectCollisions' :: (Eq n, PhysicalObject o n Shape) => IL o -> [(ILKey, o)] -> [Collision n]+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'' :: (Eq n, PhysicalObject o n Shape) => IL o -> (ILKey, o ) -> [Collision n]+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''' :: (Eq n, PhysicalObject o n Shape) => (ILKey, o) -> (ILKey, o) -> [Collision n]+detectCollisions''' m o+ | fst m == fst o = [] -- Same object -> no collision+ | otherwise = maybeToList (detectCollision (snd m) (snd o))
+ Experiments/collisions/Physics/TwoDimensions/PhysicalObjects.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Physics.TwoDimensions.PhysicalObjects where++import Physics.TwoDimensions.Dimensions++class Eq b => PhysicalObject a b c | a -> b, a -> c where+ physObjectPos :: a -> Pos2D+ physObjectVel :: a -> Vel2D+ physObjectElas :: a -> Double+ physObjectShape :: a -> c+ physObjectCollides :: a -> Bool+ physObjectId :: a -> b+ physObjectUpdatePos :: a -> Pos2D -> a+ physObjectUpdateVel :: a -> Vel2D -> a
+ Experiments/collisions/Physics/TwoDimensions/Shapes.hs view
@@ -0,0 +1,45 @@+-- | 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.Shapes where++import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions++-- | Side of a rectangle+data Side = TopSide | BottomSide | LeftSide | RightSide+ deriving (Eq,Show)++-- | Opposite side+--+-- 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++data Shape = -- Rectangle Pos2D Size2D -- A corner and the whole size+ Circle Pos2D Double -- Position and radius+ | SemiPlane Pos2D Side -- ++-- | 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 (Circle p1 s1) (Circle p2 s2) = (dist - (s1 + s2)) < sigma+ where (dx, dy) = p2 ^-^ p1+ dist = sqrt (dx**2 + dy**2)+ sigma = 1+overlapShape (Circle (p1x,p1y) s1) (SemiPlane (px,py) side) = case side of+ LeftSide -> p1x - s1 <= px+ RightSide -> p1x + s1 >= px+ TopSide -> p1y - s1 <= py+ BottomSide -> p1y + s1 >= py+overlapShape s@(SemiPlane _ _) c@(Circle _ _) = overlapShape c s+overlapShape _ _ = False -- Not really, it's just that we don't care
+ Experiments/collisions/Resources.hs view
@@ -0,0 +1,10 @@+module Resources where++import qualified Graphics.UI.SDL.TTF as TTF++-- import Game.Audio++data Resources = Resources+ { resFont :: TTF.Font+ , miniFont :: TTF.Font+ }
+ Experiments/dumbplayer/Main.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE Arrows #-}+import Graphics.UI.SDL as SDL+import FRP.Yampa as Yampa+import Data.IORef+import Debug.Trace++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ controllerRef <- newIORef $ Controller False False False False -- (Controller Nothing)+ reactimate (initGraphs >> readIORef controllerRef)+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ mInput <- sdlGetController controllerRef+ -- print (mInput)+ return (dtSecs, Just mInput)+ )+ (\_ e -> display ((0,0),e) >> return False)+ (player initialPos)++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++-- We need a non-blocking controller-polling function.+sdlGetController :: IORef Controller -> IO Controller+sdlGetController controllerState = do+ state <- readIORef controllerState+ e <- pollEvent+ case e of+ KeyDown v | keyDirection v -> updateControllerState controllerState v True >> sdlGetController controllerState+ KeyUp v | keyDirection v -> updateControllerState controllerState v False >> sdlGetController controllerState+ _ -> return state++keyDirection :: Keysym -> Bool+keyDirection (Keysym SDLK_w _ _) = True+keyDirection (Keysym SDLK_s _ _) = True+keyDirection (Keysym SDLK_a _ _) = True+keyDirection (Keysym SDLK_d _ _) = True+keyDirection _ = False++updateControllerState :: IORef Controller -> Keysym -> Bool -> IO ()+updateControllerState stateRef input state = modifyIORef stateRef (applyInput input state)++applyInput :: Keysym -> Bool -> Controller -> Controller+applyInput input apply c = keyF input apply+ where keyF (Keysym SDLK_w _ _) s = c { controllerUp = s }+ keyF (Keysym SDLK_a _ _) s = c { controllerLeft = s }+ keyF (Keysym SDLK_s _ _) s = c { controllerDown = s }+ keyF (Keysym SDLK_d _ _) s = c { controllerRight = s }+++data Controller = Controller+ { controllerUp :: Bool+ , controllerDown :: Bool+ , controllerLeft :: Bool+ , controllerRight :: Bool+ }++getVelocity :: Controller -> (Double, Double)+getVelocity rc = (rx, ry)+ where ry = rup + rdown+ rx = rleft + rright+ rup = if controllerUp rc then -1 else 0+ rdown = if controllerDown rc then 1 else 0+ rleft = if controllerLeft rc then -1 else 0+ rright = if controllerRight rc then 1 else 0++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- SDL.setVideoMode width height 16 [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++display :: ((Double, Double),(Double, Double)) -> IO()+display ((boxY,_), (playerX, playerY)) = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0 0+ let side = 10+ x = (width - side) `div` 2+ y = round boxY+ fillRect screen (Just (Rect x y side side)) red++ drawPlayer screen (round playerX, round playerY)++ -- Double buffering+ SDL.flip screen++drawPlayer surface (playerX, playerY) = do+ let format = surfaceGetPixelFormat surface+ red <- mapRGB format 0xFF 0 0+ let side = 10+ x = playerX+ y = playerY+ fillRect surface (Just (Rect x y side side)) red++-- | Moves by default using playerProgress, unless the player is+-- slowing down and barely moving, in which case we discard any+-- remanent velocity and reinitiate the player from the new position.+player :: (Double, Double) -> SF Controller (Double, Double)+player p0 = switch (playerProgress p0 >>> (arr fst &&& isTooSmall)) player+ where isTooSmall :: SF ((Double, Double), (Double, Double)) (Yampa.Event (Double, Double))+ isTooSmall = proc (pos,diffV) -> do+ derivV <- derivative -< diffV+ returnA -< if shouldStop diffV derivV+ then Yampa.Event pos+ else Yampa.NoEvent++shouldStop :: (Double, Double) -> (Double, Double) -> Bool+shouldStop (dx, dy) (diffVX, diffVY) =+ abs dx < margin && abs dy < margin -- Small movement+ && sign dx * diffVX <= 0 && diffVY * sign dy <= 0 -- Slowing down+ && (abs dy > 0 || abs dx > 0) -- But moving (break in switch loop)+ where margin = 0.1++playerProgress :: (Double, Double) -> SF Controller ((Double, Double), (Double, Double))+playerProgress p0 = proc (c) -> do+ rec let acc = getVelocity c -- Acceleration (depends on user input)+ v <- integral -< acc -- Velocity according to user input+ vdiff <- integral -< 0.1 *^ vtotal -- "Air" resistance (note: I get strange flickers with exponentiation)+ let vtotal = v ^-^ vdiff -- Subtract resistance from velocity (FIXME: make sure we don't move back")+ p <- (p0 ^+^) ^<< integral -< vtotal -- Add to initial position+ returnA -< (p, vtotal)++-- | FIXME: the old code (commented out) contains a "bug" that makes+-- it misbehave when you change direction twice without stopping.+-- But this code does not guarantee that resistance is not greater than+-- current velocity, which means that (theoretically) it could drag the+-- player back even if it's stopped. I don't know if that can happen+-- because I don't understand how rec works above (but I wrote the thing ;)+-- applyResistance :: (Double, Double) -> (Double, Double) -> (Double, Double)+-- applyResistance (vx, vy) (vdx, vdy) = (vx', vy')+-- where vx' = if abs vdx > abs vx then 0 else (vx - vdx)+-- vy' = if abs vdy > abs vy then 0 else (vy - vdy)++sign :: Double -> Double+sign d | d < 0 = -1+ | otherwise = 1++initialPos = (fromIntegral width/2, fromIntegral height/2)
+ Experiments/player/Main.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE Arrows #-}+import Control.Monad+import Data.IORef+import Data.Maybe+import Debug.Trace+import FRP.Yampa as Yampa+import FRP.Yampa.Switches as Yampa+import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Primitives as SDL++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ controllerRef <- newIORef defaultController+ reactimate (initGraphs >> readIORef controllerRef)+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ mInput <- sdlGetController controllerRef+ -- print (mInput)+ return (dtSecs, Just mInput)+ )+ (\_ e -> display e >> return False)+ (dlSwitch [player] >>> arr composeWorld)++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++-- We need a non-blocking controller-polling function.+sdlGetController :: IORef Controller -> IO Controller+sdlGetController controllerState = do+ state <- readIORef controllerState+ e <- pollEvent+ case e of++ -- Update position+ MouseMotion x y _ _ -> do+ writeIORef controllerState (state { controllerPos = (fromIntegral x, fromIntegral y)})+ sdlGetController controllerState++ -- Fire 1+ MouseButtonDown x y ButtonLeft -> do+ writeIORef controllerState (state { controllerFire1 = True })+ sdlGetController controllerState++ MouseButtonUp x y ButtonLeft -> do+ writeIORef controllerState (state { controllerFire1 = False })+ sdlGetController controllerState++ MouseButtonDown x y ButtonRight -> do+ writeIORef controllerState (state { controllerFire2 = True })+ sdlGetController controllerState++ MouseButtonUp x y ButtonRight -> do+ writeIORef controllerState (state { controllerFire2 = False })+ sdlGetController controllerState++ _ -> return state++data Controller = Controller+ { controllerPos :: (Double, Double)+ , controllerFire1 :: Bool+ , controllerFire2 :: Bool+ }++defaultController :: Controller+defaultController = Controller (0, 0) False False++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- SDL.setVideoMode width height 16 [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++display :: World -> IO()+display world = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Necessary colors+ let format = surfaceGetPixelFormat screen+ red <- mapRGB format 0xFF 0 0+ green <- mapRGB format 0x87 0xFF 0x87+ blue <- mapRGB format 0 0 0xFF+ otherRed <- mapRGBA format 0xFF 0xFF 0x00 0xFF++ -- Paint screen green+ fillRect screen Nothing green++ -- Paint small red square+ case worldPlayer world of+ Just (Player (playerX, playerY)) -> void $ do+ let side = 10+ x = round playerX+ y = round playerY+ fillRect screen (Just (Rect x y side side)) red+ _ -> return ()++ -- Paint vertical lines for all fire arrows+ let paintFire f = do+ let fireColor = if fireSticky f then blue else otherRed+ (x0,y0) = fireOrigin f+ (x1,y1) = fireTip f+ (dx, dy) = (3, y0-y1)+ (x1', y1') = (round x1, round y1)+ (x0', y0', dx', dy') = (round x0 - 1, round y0, round dx, round dy)+ fillRect screen (Just (Rect x1' y1' dx' dy')) fireColor+ print f+ -- vLine screen x0' y0' y1' fireColor+ -- vLine screen (x0'+1) y0' y1' fireColor+ -- vLine screen (x0'+2) y0' y1' fireColor++ mapM_ paintFire (worldFires world)++ -- Double buffering+ SDL.flip screen++data World = World+ { worldPlayer :: Maybe Player+ , worldFires :: [Fire]+ }++composeWorld :: [Object] -> World+composeWorld objs = World pl fs+ where pl = listToMaybe $ mapMaybe objectPlayer objs+ fs = mapMaybe objectFire objs++objectPlayer :: Object -> Maybe Player+objectPlayer (ObjectPlayer pl) = Just pl+objectPlayer _ = Nothing++objectFire :: Object -> Maybe Fire+objectFire (ObjectFire pl) = Just pl+objectFire _ = Nothing++data Object = ObjectPlayer Player+ | ObjectFire Fire+ deriving Show++data Player = Player { playerPos :: (Double, Double) }+ deriving Show++data Fire = Fire { fireOrigin :: (Double, Double)+ , fireTip :: (Double, Double)+ , fireSticky :: Bool+ }+ deriving Show++-- | A player that may die or spawn new objects.+player :: ListSF Controller Object+player = ListSF $ proc (Controller p f1 f2) -> do++ let this = ObjectPlayer $ Player p+ newF1 <- isEvent ^<< edge -< f1+ newF2 <- isEvent ^<< edge -< f2++ let newF1Arrows = [ fire p False | newF1 ]+ newF2Arrows = [ fire p True | newF2 ]+ allArrows = newF1Arrows ++ newF2Arrows++ returnA -< (this, False, allArrows)++ where initialPos = (fromIntegral width / 2, fromIntegral height / 2)++-- | This produces bullets that die when they hit the top of the screen.+-- There's sticky bullets and normal bullets. Sticky bullets get stuck for a+-- while before they die.+fire :: (Double, Double) -> Bool -> ListSF Controller Object+fire (x0, y0) sticky = ListSF $ proc _ -> do+ let v0 = -10++ -- Calculate tip of arrow+ yT <- (y0+) ^<< integral -< v0+ let y = max 0 yT++ -- Delay death if the fire is "sticky"+ hit <- switch (constant noEvent &&& (arr (<= 0) >>> edge))+ (\_ -> stickyDeath sticky)+ -< y+ let dead = isEvent hit++ let object = ObjectFire $ Fire (x0, y0) (x0, y) sticky++ returnA -< (object, dead, [])++stickyDeath True = after 30 ()+stickyDeath False = constant (Event ())
+ Experiments/split/Main.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE Arrows #-}+import Graphics.UI.SDL as SDL+import FRP.Yampa as Yampa+import Data.IORef+import Debug.Trace++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ controllerRef <- newIORef $ Controller False False False False False+ reactimate (initGraphs >> readIORef controllerRef)+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ mInput <- sdlGetController controllerRef+ -- print (mInput)+ return (dtSecs, Just mInput)+ )+ (\_ e -> display ((0,0), fst e) >> return False)+ (bounce initialPos)++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++-- We need a non-blocking controller-polling function.+sdlGetController :: IORef Controller -> IO Controller+sdlGetController controllerState = do+ state <- readIORef controllerState+ e <- pollEvent+ case e of+ KeyDown v | keyDirection v -> updateControllerState controllerState v True >> sdlGetController controllerState+ KeyUp v | keyDirection v -> updateControllerState controllerState v False >> sdlGetController controllerState+ _ -> return state++keyDirection :: Keysym -> Bool+keyDirection (Keysym SDLK_w _ _) = True+keyDirection (Keysym SDLK_s _ _) = True+keyDirection (Keysym SDLK_a _ _) = True+keyDirection (Keysym SDLK_d _ _) = True+keyDirection _ = False++updateControllerState :: IORef Controller -> Keysym -> Bool -> IO ()+updateControllerState stateRef input state = modifyIORef stateRef (applyInput input state)++applyInput :: Keysym -> Bool -> Controller -> Controller+applyInput input apply c = keyF input apply+ where keyF (Keysym SDLK_w _ _) s = c { controllerUp = s }+ keyF (Keysym SDLK_a _ _) s = c { controllerLeft = s }+ keyF (Keysym SDLK_s _ _) s = c { controllerDown = s }+ keyF (Keysym SDLK_d _ _) s = c { controllerRight = s }+ keyF (Keysym SDLK_SPACE _ _) s = c { controllerRight = s }+++data Controller = Controller+ { controllerUp :: Bool+ , controllerDown :: Bool+ , controllerLeft :: Bool+ , controllerRight :: Bool+ , controllerFire :: Bool+ }++getVelocity :: Controller -> (Double, Double)+getVelocity rc = (rx, ry)+ where ry = rup + rdown+ rx = rleft + rright+ rup = if controllerUp rc then -1 else 0+ rdown = if controllerDown rc then 1 else 0+ rleft = if controllerLeft rc then -1 else 0+ rright = if controllerRight rc then 1 else 0++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- SDL.setVideoMode width height 16 [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++display :: ((Double, Double),(Double, Double)) -> IO()+display ((boxY,_), (playerX, playerY)) = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0 0+ let side = 10+ x = (width - side) `div` 2+ y = round boxY+ fillRect screen (Just (Rect x y side side)) red++ drawPlayer screen (round playerX, round playerY)++ -- Double buffering+ SDL.flip screen++drawPlayer surface (playerX, playerY) = do+ let format = surfaceGetPixelFormat surface+ red <- mapRGB format 0xFF 0 0+ let side = 10+ x = playerX+ y = playerY+ fillRect surface (Just (Rect x y side side)) red++-- | Moves by default using playerProgress, unless the player is+-- slowing down and barely moving, in which case we discard any+-- remanent velocity and reinitiate the player from the new position.+player :: (Pos2, (Double, Double)) -> SF Controller (Pos2, (Double, Double))+player (p0, v0) = switch (playerProgress (p0, v0) >>> (arr id &&& isTooSmall)) player+ where isTooSmall :: SF ((Double, Double), (Double, Double)) (Yampa.Event ((Double, Double), Pos2))+ isTooSmall = proc (pos,diffV) -> do+ derivV <- derivative -< diffV+ returnA -< if shouldStop diffV derivV+ then Yampa.Event (pos, derivV)+ else Yampa.NoEvent++shouldStop :: (Double, Double) -> (Double, Double) -> Bool+shouldStop (dx, dy) (diffVX, diffVY) =+ abs dx < margin && abs dy < margin -- Small movement+ && sign dx * diffVX <= 0 && diffVY * sign dy <= 0 -- Slowing down+ && (abs dy > 0 || abs dx > 0) -- But moving (break in switch loop)+ where margin = 0.1++playerProgress :: (Pos2, Pos2) -> SF Controller ((Double, Double), (Double, Double))+playerProgress (p0, v0) = proc (c) -> do+ rec let acc = getVelocity c -- Acceleration (depends on user input)+ v <- integral -< acc -- Velocity according to user input+ vdiff <- integral -< 0.1 *^ vtotal -- "Air" resistance (note: I get strange flickers with exponentiation)+ let vtotal = v0 ^+^ v ^-^ vdiff -- Subtract resistance from velocity (FIXME: make sure we don't move back")+ p <- (p0 ^+^) ^<< integral -< vtotal -- Add to initial position+ returnA -< (p, vtotal)++-- | FIXME: the old code (commented out) contains a "bug" that makes+-- it misbehave when you change direction twice without stopping.+-- But this code does not guarantee that resistance is not greater than+-- current velocity, which means that (theoretically) it could drag the+-- player back even if it's stopped. I don't know if that can happen+-- because I don't understand how rec works above (but I wrote the thing ;)+-- applyResistance :: (Double, Double) -> (Double, Double) -> (Double, Double)+-- applyResistance (vx, vy) (vdx, vdy) = (vx', vy')+-- where vx' = if abs vdx > abs vx then 0 else (vx - vdx)+-- vy' = if abs vdy > abs vy then 0 else (vy - vdy)++sign :: Double -> Double+sign d | d < 0 = -1+ | otherwise = 1++initialPos = (fromIntegral width/2, fromIntegral height/2)++bounce :: Pos2 -> SF Controller (Pos2, Vel2)+bounce y0 = bounce' y0 (0, 0) -- (-20)+ where bounce' y vy = -- trace (show (y, vy)) $+ switch (player (y,vy) >>> (Yampa.identity &&& hitFrame))+ (\(y, vy) -> trace (show vy) $ bounce' y vy)+ side = 10++-- | Detects whether the ball hits the surrounding frame. This is an adhoc+-- function with knowledge of:+-- * Ball shape+-- * Frame shape+-- * Ball size+-- * Rectangular hits, side to side only+-- For these reasons, it is a subideal solution, very unlikely also subobtimal+-- also in terms of speed. So, it would be best to switch to real collision+-- detections with a surrounding frame.+hitFrame :: SF (Pos2,Vel2) (Yampa.Event (Pos2, Vel2))+hitFrame = arr hitFrame'+ where hitFrame' (pos,vel)+ | hits == (1.0,1.0) = Yampa.NoEvent+ | otherwise = Yampa.Event (pos, vel')+ where hits = foldr mergeHit (1,1) [hitB, hitT, hitL, hitR]+ hitB = if (y + side) > fromIntegral height && vy > 0.0 then (1, -1) else (1,1)+ hitT = if y < 0.0 && vy < 0.0 then (1, -1) else (1,1)+ hitL = if x < 0.0 && vx < 0.0 then (-1, 1) else (1,1)+ hitR = if (x + side) > fromIntegral width && vx > 0.0 then (-1, 1) else (1,1)+ (x, y) = pos+ (vx, vy) = vel+ mergeHit (p1, p2) (q1, q2) = (p1 * q1, p2 * q2)+ vel' = (vx * fst hits, vy * snd hits)+ side = 10++type Pos2 = (Double, Double)+type Vel2 = (Double, Double)
+ Experiments/splitballs/Constants.hs view
@@ -0,0 +1,44 @@+module Constants where++import Data.Int+import Data.Word+import Graphics.UI.SDL as SDL++width :: Double+width = 1024+height :: Double+height = 600++gameWidth :: Double+gameWidth = width++gameHeight :: Double+gameHeight = height++-- Energy transmission between objects in collisions+velTrans :: Double+velTrans = 1.00++-- Max speed+maxVNorm :: Double+maxVNorm = 500++ballWidth, ballHeight :: Double+ballWidth = 25+ballHeight = 25++ballMargin :: Double+ballMargin = 3++ballSize :: Int16+ballSize = 25++-- Colors+fontColor :: SDL.Color+fontColor = SDL.Color 228 228 228++ballColor :: Word32+ballColor = 0xCC0011FF++velColor :: Word32+velColor = 0xCCBBFFFF
+ Experiments/splitballs/Control/Extra/Monad.hs view
@@ -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
+ Experiments/splitballs/Data/Extra/Num.hs view
@@ -0,0 +1,20 @@+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++class Similar a where+ sigma :: a -- margin of error++instance Similar Float where+ sigma = 0.01++instance Similar Double where+ sigma = 0.01++(=~) :: (Num a, Ord a, Similar a) => a -> a -> Bool+x =~ y = abs (x - y) < sigma+
+ Experiments/splitballs/Data/Extra/VectorSpace.hs view
@@ -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
+ Experiments/splitballs/Debug.hs view
@@ -0,0 +1,8 @@+module Debug where++import Control.Monad (when, void)++import Constants++debug :: Bool -> String -> IO ()+debug b msg = when b $ putStrLn msg
+ Experiments/splitballs/Display.hs view
@@ -0,0 +1,117 @@+module Display where++import Control.Arrow ((***))+import Control.Monad+import FRP.Yampa.VectorSpace+import Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Primitives as SDLP+import qualified Graphics.UI.SDL.TTF as TTF+import Text.Printf++import Constants+import GameState+import Objects+import Resources++-- | 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,+-- so it's not a general, parameterised, scalable solution.+--+loadResources :: IO Resources+loadResources = do+ -- Font initialization+ _ <- TTF.init++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font <- TTF.openFont gameFont 32 -- 32: fixed size?+ let myFont = font++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font2 <- TTF.openFont gameFont 8 -- 32: fixed size?+ let myFont2 = font2++ -- Return all resources (just the font)+ return $ Resources myFont myFont2++initializeDisplay :: IO ()+initializeDisplay =+ -- Initialise SDL+ SDL.init [InitEverything]++initGraphs :: Resources -> IO ()+initGraphs _res = do+ screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]+ SDL.setCaption "Voldemort" ""++ -- 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 True++ return ()++render :: Resources -> GameState -> IO()+render resources shownState = do+ -- Obtain surface+ screen <- getVideoSurface++ let format = surfaceGetPixelFormat screen+ bgColor <- mapRGB format 0x37 0x16 0xB4+ fillRect screen Nothing bgColor++ mapM_ (paintObject screen resources ) $ gameObjects shownState++ displayInfo screen resources (gameInfo shownState)++ -- Double buffering+ SDL.flip screen++-- * Painting functions+displayInfo :: Surface -> Resources -> GameInfo -> IO()+displayInfo screen resources over =+ printAlignRight screen resources+ ("Time: " ++ printf "%.3f" (gameTime over)) (10,50)++paintObject :: Surface -> Resources -> Object -> IO ()+paintObject screen resources object =+ case objectKind object of+ (Side {}) -> return ()+ (Ball ballSize) -> do+ let (px,py) = (\(u,v) -> (u, gameHeight - v)) (objectPos object)+ let (x,y) = (round *** round) (px,py)+ (vx,vy) = objectVel object+ (x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))+ _ <- SDLP.filledCircle screen x y (round ballSize) (SDL.Pixel ballColor)+ _ <- SDLP.line screen x y x' y' (SDL.Pixel velColor)++ -- Print position+ let font = miniFont resources+ message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor+ let w = SDL.surfaceGetWidth message+ h = SDL.surfaceGetHeight message+ (x'',y'') = (round *** round) (px,py)+ rect = SDL.Rect (x''+30) (y''-30) w h+ SDL.blitSurface message Nothing screen (Just rect)+ return ()++-- * Render text with alignment+printAlignRight :: Surface -> Resources -> String -> (Int, Int) -> IO ()+printAlignRight screen resources msg (x,y) = void $ do+ let font = resFont resources+ message <- TTF.renderTextSolid font msg fontColor+ renderAlignRight screen message (x,y)++-- * SDL Extensions+renderAlignRight :: Surface -> Surface -> (Int, Int) -> IO ()+renderAlignRight screen surface (x,y) = void $ do+ let rightMargin = SDL.surfaceGetWidth screen+ w = SDL.surfaceGetWidth surface+ h = SDL.surfaceGetHeight surface+ rect = SDL.Rect (rightMargin - x - w) y w h+ SDL.blitSurface surface Nothing screen (Just rect)
+ Experiments/splitballs/Game.hs view
@@ -0,0 +1,301 @@+{-# 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 two sections:+--+-- - A collection of gameplay SFs, which control the core game loop, carry+-- out collision detection, , 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 FRP.Yampa+import FRP.Yampa.Switches++-- General-purpose internal imports+import Data.Extra.VectorSpace+import Physics.TwoDimensions.Collisions+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.GameCollisions+import Physics.TwoDimensions.Shapes+import Physics.TwoDimensions.PhysicalObjects++-- Internal iports+import Constants+import GameState+import Input+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 = gamePlay initialObjects >>> composeGameState+ where composeGameState :: SF (Objects, Time) GameState+ composeGameState = arr (second GameInfo >>> uncurry GameState)++-- ** 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 collisions (discarded at every+-- iteration).++gamePlay :: [ListSF ObjectInput Object] -> SF Controller (Objects, Time)+gamePlay objs = loopPre [] $+ -- Process physical movement and detect new collisions+ proc (i) -> do+ -- Adapt Input+ let oi = (uncurry ObjectInput) i++ -- Step+ -- Each obj processes its movement forward+ ol <- dlSwitch objs -< oi+ let cs' = detectCollisions ol++ -- Output+ tLeft <- time -< ()+ returnA -< ((ol, tLeft), cs')++-- * Game objects+--+-- | Objects initially present: the walls, the ball, the paddle and the blocks.+initialObjects :: [ListSF ObjectInput Object]+initialObjects =+ [ inertSF objSideRight+ , inertSF objSideTop+ , inertSF objSideLeft+ , inertSF objSideBottom+ ]+ ++ objEnemies++-- *** Enemy+objEnemies :: [ListSF ObjectInput Object]+objEnemies =+ [ splittingBall ballWidth "enemy1" (300, 300) (360, -350)+ , splittingBall ballWidth "enemy2" (500, 300) (-330, -280)+ , splittingBall ballWidth "enemy3" (200, 100) (-300, -250)+ , splittingBall ballWidth "enemy4" (100, 200) (-200, -150)+ ]++splittingBall :: Double -> String -> Pos2D -> Vel2D -> ListSF ObjectInput Object+splittingBall size bid p0 v0 = ListSF $ proc i -> do+ t <- localTime -< ()+ bo <- bouncingBall size bid p0 v0 -< i+ click <- edge -< controllerClick (userInput i)+ let tooSmall = size <= (ballWidth / 2)+ shouldSplit = isEvent click++ let offspringSize = (5 * size / 6) -- Or: size++ let offspringID = (bid ++ show t) -- Should be unique or collisions won't work++ offspring = [ splittingBall offspringSize offspringID bpos (0,0)+ | shouldSplit && not tooSmall+ , let bpos = physObjectPos bo+ ]++ dead = shouldSplit && tooSmall++ returnA -< (bo, dead, offspring)++-- *** Ball++-- 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 :: Double -> String -> Pos2D -> Vel2D -> ObjectSF+bouncingBall size bid p0 v0 =+ switch progressAndBounce+ (uncurry (bouncingBall size bid)) -- 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 bid)++ -- 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 size bid 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 :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce bid = noEvent --> ballBounce' bid++-- | 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' :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce' bid = proc (ObjectInput ci cs, 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 = maybeToEvent (changedVelocity bid cs)+ returnA -< fmap (\v -> (objectPos 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 :: Double -> String -> Pos2D -> Vel2D -> ObjectSF+freeBall size name p0 v0 = proc (ObjectInput ci cs) -> do++ -- Integrate acceleration, add initial velocity and cap speed. Resets both+ -- the initial velocity and the current velocity to (0,0) when the user+ -- presses the Halt key (hence the dependency on the controller input ci).++ vInit <- startAs v0 -< ci+ vel <- vdiffSF -< (vInit, (0, -100.8), ci)++ -- Any free moving object behaves like this (but with+ -- acceleration. This should be in some FRP.NewtonianPhysics+ -- module)+ pos <- (p0 ^+^) ^<< integral -< vel++ let obj = Object { objectName = name+ , objectKind = Ball size+ , objectPos = pos+ , objectVel = vel+ , canCauseCollisions = True+ , collisionEnergy = 1+ }++ returnA -< obj+ where -- Spike every time the user presses the Halt key+ restartCond = spikeOn (arr controllerStop)++ -- Calculate the velocity, restarting when the user+ -- requests it.+ vdiffSF = proc (iv, acc, ci) -> do+ -- Calculate velocity difference by integrating acceleration+ -- Reset calculation when user requests to stop balls+ vd <- restartOn (arr fst >>> integral)+ (arr snd >>> restartCond) -< (acc, ci)++ -- Add initial velocity, and cap the result+ v <- arr (uncurry (^+^)) -< (iv, vd)+ let vFinal = limitNorm v maxVNorm++ returnA -< vFinal++ -- Initial velocity, reset when the user requests it.+ startAs v0 = switch (constant v0 &&& restartCond)+ (\_ -> startAs (0,0))++-- *** 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 = arr $ \(ObjectInput ci cs) ->+ Object { objectName = name+ , objectKind = Side side+ , objectPos = pos+ , objectVel = (0,0)+ , canCauseCollisions = False+ , collisionEnergy = 0+ }++-- * Auxiliary FRP stuff+maybeToEvent :: Maybe a -> Event a+maybeToEvent = maybe noEvent Event++inertSF :: SF a b -> ListSF a b+inertSF sf = ListSF (sf >>> arr (\o -> (o, False, [])))++restartOn :: SF a b -> SF a (Event c) -> SF a b+restartOn sf sfc = switch (sf &&& sfc)+ (\_ -> restartOn sf sfc)++spikeOn :: SF a Bool -> SF a (Event ())+spikeOn sf = noEvent --> (sf >>> edge)
+ Experiments/splitballs/GameState.hs view
@@ -0,0 +1,36 @@+-- | 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 Debug.Trace+import Objects+import FRP.Yampa (Time)++-- | 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 = GameInfo 0+ }++data GameInfo = GameInfo { gameTime :: Time }
+ Experiments/splitballs/Graphics/UI/Extra/SDL.hs view
@@ -0,0 +1,40 @@+module Graphics.UI.Extra.SDL where++import Data.IORef+import Data.Maybe (isNothing)+import Graphics.UI.SDL as SDL++-- Auxiliary SDL stuff+isEmptyEvent :: Event -> Bool+isEmptyEvent SDL.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
+ Experiments/splitballs/Input.hs view
@@ -0,0 +1,112 @@+-- | 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 one: mouse/keyboard combination.+--+module Input where++-- External imports+import Data.IORef+import Graphics.UI.SDL as SDL++-- Internal imports+import Control.Extra.Monad+import Graphics.UI.Extra.SDL++-- * Game controller++-- | Controller info at any given point.+data Controller = Controller+ { controllerPos :: (Double, Double)+ , controllerClick :: Bool+ , controllerStop :: Bool+ , controllerPause :: Bool+ , controllerExit :: Bool+ , controllerFast :: Bool+ , controllerSlow :: Bool+ , controllerSuperSlow :: Bool+ , controllerFullscreen :: 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 { controllerData :: (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+ nr <- newIORef defaultInfo+ return $ ControllerRef (nr, sdlGetController)+ where defaultInfo = Controller (0,0) False False False False False False False False++-- | Sense from the controller, providing its current+-- state. This should return a new Controller state+-- if available, or the last one there was.+--+-- It is assumed that the sensing function is always+-- callable, and that it knows how to update the+-- Controller info if necessary.+senseInput :: ControllerRef -> IO Controller+senseInput (ControllerRef (cref, sensor)) =+ modifyIORefIO cref sensor++type ControllerDev = IO (Maybe (Controller -> IO Controller))++-- * SDL API (mid-level)++-- ** 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)++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) }+ KeyUp (Keysym { symKey = SDLK_f }) -> c { controllerFullscreen = not (controllerFullscreen c) }+ KeyDown (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = True }+ KeyUp (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = False }+ KeyDown (Keysym { symKey = SDLK_s }) -> c { controllerSlow = True }+ KeyUp (Keysym { symKey = SDLK_s }) -> c { controllerSlow = False }+ KeyDown (Keysym { symKey = SDLK_x }) -> c { controllerFast = True }+ KeyUp (Keysym { symKey = SDLK_x }) -> c { controllerFast = False }+ KeyDown (Keysym { symKey = SDLK_h }) -> c { controllerStop = True }+ KeyUp (Keysym { symKey = SDLK_h }) -> c { controllerStop = False }+ KeyDown (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = True }+ KeyUp (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = False }+ KeyDown (Keysym { symKey = SDLK_ESCAPE}) -> c { controllerExit = True }+ _ -> c+++-- * Aux IOREf+modifyIORefIO :: IORef a -> (a -> IO a) -> IO a+modifyIORefIO ref modify = do+ v <- readIORef ref+ new <- modify v+ writeIORef ref new+ return new
+ Experiments/splitballs/Main.hs view
@@ -0,0 +1,43 @@+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.Monad.IfElse+import Data.IORef+import Debug.Trace+import FRP.Yampa as Yampa+import Text.Printf++import Game+import Display+import Input+import Graphics.UI.Extra.SDL++main :: IO ()+main = do++ initializeDisplay++ timeRef <- initializeTimeRef+ controllerRef <- initializeInputDevices+ res <- loadResources++ initGraphs res+ reactimate (senseInput controllerRef)+ (\_ -> do+ -- Get clock and new input+ mInput <- senseInput controllerRef+ dtSecs <- senseTime timeRef mInput+ -- trace ("Time : " ++ printf "%.5f" dtSecs) $+ return (if controllerPause mInput then 0 else dtSecs, Just mInput)+ )+ (\_ (e,c) -> do render res e+ return (controllerExit c)+ )+ (wholeGame &&& arr id)++senseTime :: IORef Int -> Controller -> IO DTime+senseTime timeRef = \mInput ->+ let tt = if controllerSlow mInput then (/10) else id+ tt1 = if controllerSuperSlow mInput then (/100) else tt+ tt2 = if controllerFast mInput then (*10) else tt1+ in (tt2 . milisecsToSecs) <$> senseTimeRef timeRef
+ Experiments/splitballs/ObjectSF.hs view
@@ -0,0 +1,44 @@+-- | 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).+module ObjectSF where++import FRP.Yampa++import Objects+import Input++-- | Objects are defined as transformations that take 'ObjectInput' signals and+-- return 'ObjectOutput' signals.+type ObjectSF = SF ObjectInput Object++-- | In order to determine its new output, an object needs to know the user's+-- desires ('userInput'), whether there have been any collisions+-- ('collisions').+--+-- The reason for depending on 'Collisions' is that objects may ``change''+-- when hit (start moving in a different direction).+data ObjectInput = ObjectInput+ { userInput :: Controller+ , collisions :: Collisions+ }++-- -- | 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.).+-- }++-- -- | 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]+--
+ Experiments/splitballs/Objects.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Game objects and collisions.+module Objects where++import Control.Arrow ((***))+import FRP.Yampa.VectorSpace++import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import qualified Physics.TwoDimensions.PhysicalObjects as PO+import Physics.TwoDimensions.Shapes++type Collision = C.Collision ObjectName+type Collisions = C.Collisions ObjectName++-- * Objects++type Objects = [Object]+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+ , canCauseCollisions :: !Bool+ , collisionEnergy :: !Double+ }+ deriving (Show)++-- | The kind of object and any size properties.+data ObjectKind = Ball Double -- radius+ | Side Side+ deriving (Show,Eq)++-- Partial function. Object has size.+objectTopLevelCorner :: Object -> Pos2D+objectTopLevelCorner object = objectPos object ^-^ half (objectSize object)+ where half = let h = (/2) in (h *** h)++-- Partial function!+objectSize :: Object -> Size2D+objectSize object = case objectKind object of+ (Ball r) -> let w = 2*r in (w, w)++instance PhysicalObject Object String Shape where+ physObjectPos = objectPos+ physObjectVel = objectVel+ physObjectElas = collisionEnergy+ physObjectShape = objShape+ physObjectCollides = canCauseCollisions+ physObjectId = objectName+ physObjectUpdatePos = \o p -> o { objectPos = p }+ physObjectUpdateVel = \o v -> o { objectVel = v }++objShape :: Object -> Shape+objShape obj = case objectKind obj of+ Ball r -> Circle p r+ Side s -> SemiPlane p s+ where p = objectPos obj
+ Experiments/splitballs/Physics/TwoDimensions/Collisions.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts #-}+-- | A trivial collision subsystem.+--+-- Based on the physics module, it determines the side of collision+-- between shapes.+module Physics.TwoDimensions.Collisions where++import Data.Extra.Num+import Data.Maybe+import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++-- * Collision points+data CollisionPoint = CollisionSide Side+ | CollisionAngle Double++-- | Calculates the collision side of a shape+-- that collides against another.+--+-- PRE: the shapes do collide. Use 'overlapShape' to check.+shapeCollisionPoint :: Shape -> Shape -> CollisionPoint+shapeCollisionPoint (Circle p1 _) (Circle p2 _) =+ -- | p1x =~ p2x && p1y > p2y = CollisionAngle (- pi / 2)+ -- | p1x =~ p2x && p1y <= p2y = CollisionAngle (pi / 2)+ -- | otherwise =+ CollisionAngle angle+ where (px,py) = p2 ^-^ p1+ angle = atan2 py px+shapeCollisionPoint (Circle _ _) (SemiPlane _ s2) = CollisionSide s2+shapeCollisionPoint (SemiPlane _ s1) (Circle _ _ ) = CollisionSide (oppositeSide s1)+shapeCollisionPoint (SemiPlane _ _) (SemiPlane _ s2) = CollisionSide s2+-- * Collisions+type Collisions k = [Collision k]++-- | 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 k = Collision+ { collisionData :: [(k, Vel2D)] } -- ObjectId x Velocity+ deriving Show++-- | Detects a collision between one object and another.+detectCollision :: (PhysicalObject o k Shape) => o -> o -> Maybe (Collision k)+detectCollision obj1 obj2+ | overlap obj1 obj2+ = case (physObjectShape obj1, physObjectShape obj2) of+ (Circle _ _, Circle _ _) ->+ if vrn < 0+ then Just response+ else Nothing+ _ -> Just response+ | otherwise = Nothing++ where response = collisionResponseObj obj1 obj2+ colNormal = normalize (physObjectPos obj1 ^-^ physObjectPos obj2)+ relativeV = physObjectVel obj1 ^-^ physObjectVel obj2+ vrn = relativeV `dot` colNormal++overlap :: PhysicalObject o k Shape => o -> o -> Bool+overlap obj1 obj2 =+ overlapShape (physObjectShape obj1) (physObjectShape obj2)++collisionPoint :: PhysicalObject o k Shape => o -> o -> CollisionPoint+collisionPoint obj1 obj2 =+ shapeCollisionPoint (physObjectShape obj1) (physObjectShape obj2)++collisionResponseObj :: PhysicalObject o k Shape => o -> o -> Collision k+collisionResponseObj o1 o2 = Collision $+ map objectToCollision [(o1, collisionPt, o2), (o2, collisionPt', o1)]+ where collisionPt = collisionPoint o1 o2+ collisionPt' = collisionPoint o2 o1+ objectToCollision (o,pt,o') =+ (physObjectId o,+ correctVel (physObjectPos o) (physObjectPos o')+ (physObjectVel o) (physObjectVel o')+ pt (physObjectElas o))++correctVel :: Pos2D -> Pos2D -> Vel2D -> Vel2D -> CollisionPoint -> Double -> Vel2D+-- Specialised cases: just more optimal execution+correctVel _p1 _p2 v1 _ _ 0 = v1+-- Collision against a wall+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide TopSide) e = (e * v1x, e * ensurePos v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide BottomSide) e = (e * v1x, e * ensureNeg v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide LeftSide) e = (e * ensurePos v1x, e * v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide RightSide) e = (e * ensureNeg v1x, e * v1y)+-- General case+correctVel p1 p2 (v1x,v1y) (v2x, v2y) (CollisionAngle _) e = (v1x, v1y) ^+^ ((e * j) *^ colNormal)+ where colNormal = normalize (p1 ^-^ p2)+ relativeV = (v1x,v1y) ^-^ (v2x,v2y)+ vrn = relativeV `dot` colNormal+ j = (-1) *^ vrn / (colNormal `dot` colNormal)++-- | 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 :: Eq n => n -> Collisions n -> Maybe Vel2D+changedVelocity name cs =+ case concatMap (filter ((== name) . fst) . collisionData) cs of+ [] -> Nothing+ -- vs -> Just (foldl (^+^) (0,0) (map snd vs))+ (_, v') : _ -> Just v'++-- | True if the velocity of the object has been changed by any collision.+inCollision :: Eq n => n -> Collisions n -> Bool+inCollision name cs = isJust (changedVelocity name cs)++-- | True if the two objects are colliding with one another.+inCollisionWith :: Eq n => n -> n -> Collisions n -> Bool+inCollisionWith nm1 nm2 cs = any both cs+ where+ both (Collision nmvs) =+ any ((== nm1) . fst) nmvs+ && any ((== nm2) . fst) nmvs+
+ Experiments/splitballs/Physics/TwoDimensions/Dimensions.hs view
@@ -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)
+ Experiments/splitballs/Physics/TwoDimensions/GameCollisions.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+-- | 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 Physics.TwoDimensions.GameCollisions where++import Data.Foldable+import Prelude hiding (toList, concatMap)+import Data.List hiding (toList, concatMap)+import Data.Maybe+import Physics.TwoDimensions.Collisions+import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++-- | 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 :: Foldable t => (Eq n , PhysicalObject o n Shape) => t o -> Collisions n+detectCollisions = detectCollisionsH+ where detectCollisionsH objsT = flattened+ where -- Eliminate empty collision sets+ -- TODO: why is this really necessary?+ flattened = filter (\(C.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 physObjectCollides $ toList objsT++-- | Detect collisions between each moving object and+-- every other object.+detectCollisions' :: (Foldable t, Foldable u) => (Eq n, PhysicalObject o n Shape) => t o -> u o -> [Collision n]+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'' :: Foldable t => (Eq n, PhysicalObject o n Shape) => t o -> o -> [Collision n]+detectCollisions'' objsT m = concatMap (detectCollisions''' m) (toList 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''' :: (Eq n, PhysicalObject o n Shape) => o -> o -> [Collision n]+detectCollisions''' m o+ | physObjectId m == physObjectId o = [] -- Same object -> no collision+ | otherwise = maybeToList (detectCollision m o)
+ Experiments/splitballs/Physics/TwoDimensions/PhysicalObjects.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Physics.TwoDimensions.PhysicalObjects where++import Physics.TwoDimensions.Dimensions++class Eq b => PhysicalObject a b c | a -> b, a -> c where+ physObjectPos :: a -> Pos2D+ physObjectVel :: a -> Vel2D+ physObjectElas :: a -> Double+ physObjectShape :: a -> c+ physObjectCollides :: a -> Bool+ physObjectId :: a -> b+ physObjectUpdatePos :: a -> Pos2D -> a+ physObjectUpdateVel :: a -> Vel2D -> a
+ Experiments/splitballs/Physics/TwoDimensions/Shapes.hs view
@@ -0,0 +1,45 @@+-- | 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.Shapes where++import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions++-- | Side of a rectangle+data Side = TopSide | BottomSide | LeftSide | RightSide+ deriving (Eq,Show)++-- | Opposite side+--+-- 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++data Shape = -- Rectangle Pos2D Size2D -- A corner and the whole size+ Circle Pos2D Double -- Position and radius+ | SemiPlane Pos2D Side -- ++-- | 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 (Circle p1 s1) (Circle p2 s2) = (dist - (s1 + s2)) < sigma+ where (dx, dy) = p2 ^-^ p1+ dist = sqrt (dx**2 + dy**2)+ sigma = 1+overlapShape (Circle (p1x,p1y) s1) (SemiPlane (px,py) side) = case side of+ LeftSide -> p1x - s1 <= px+ RightSide -> p1x + s1 >= px+ TopSide -> p1y - s1 <= py+ BottomSide -> p1y + s1 >= py+overlapShape s@(SemiPlane _ _) c@(Circle _ _) = overlapShape c s+overlapShape _ _ = False -- Not really, it's just that we don't care
+ Experiments/splitballs/Resources.hs view
@@ -0,0 +1,10 @@+module Resources where++import qualified Graphics.UI.SDL.TTF as TTF++-- import Game.Audio++data Resources = Resources+ { resFont :: TTF.Font+ , miniFont :: TTF.Font+ }
+ Experiments/splitting-boxes/Main.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE Arrows #-}+import Data.IORef+import Data.List+import Debug.Trace+import FRP.Yampa as Yampa+import FRP.Yampa.Switches as Yampa+import Graphics.UI.SDL as SDL++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ reactimate initGraphs+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ return (dtSecs, Nothing))+ (\_ e -> display e >> return False)+ mainSF++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 1000+ return dtSecs++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- setVideoMode width height 16 [SWSurface]+ setCaption "Test" ""++display :: [(Double,Double)] -> IO()+display xs = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0 0+ let side = 10+ let paintSquare (x,y) =+ fillRect screen (Just (Rect (round x) (round y) side side)) red++ mapM_ paintSquare xs++ -- Double buffering+ SDL.flip screen++ SDL.delay 10++-- | Main animation+mainSF :: SF () [(Double, Double)]+mainSF = dlSwitch initialList++-- | A list of position-producing forking-dying SFs+initialList :: [ListSF () (Double, Double)]+initialList = [ inCircles (320, 240) ]++-- | Describe a movement in circles, forking every few samples.+inCircles :: (Double, Double) -> ListSF () (Double, Double)+inCircles (baseX, baseY) = ListSF $ proc () -> do+ t <- localTime -< ()+ let radius = 30+ x = baseX + (cos t * radius)+ y = baseY + (sin t * radius)++ -- OffSpring+ split <- isEvent ^<< spike 300 -< ()+ let offspring = if split+ then [inCircles (y*2, x/2), inCircles (x/2, y*2)]+ else []++ -- Time to die?+ die <- isEvent ^<< spike 350 -< ()++ returnA -< ((x,y), die, offspring)++ -- () <- arr id -< trace ( "Time : " ++ show t+ -- ++ " mod: " ++ show (round t `mod` 10)+ -- ++ " s: " ++ show split+ -- )+ -- ()++-- | Produce a spike every few samples.+spike :: Int -> SF () (Yampa.Event ())+spike m = spikeBool m >>> edge+ where spikeBool m = resetCounter m >>> arr (== 0)++-- | Create a decreasing counter that is reset to the starting value when it+-- reaches 0.+resetCounter :: Int -> SF () Int+resetCounter m = loopPre m $ arr (snd >>> decR m >>> dup)+ where decR m n = if n == 0 then m else n - 1+ dup x = (x, x)++-- Version of list splitting that works in traditional Yampa+-- inCirclesL' ips = inCirclesL ips >>> arr (map fst)+--+-- inCirclesL :: [SF () ((Double, Double), Bool)]+-- -> SF () [((Double, Double), Bool)]+-- inCirclesL ips = dpSwitchB ips evProd addToList+--+-- where+-- evProd :: SF ((), [((Double, Double), Bool)]) (Yampa.Event [(Double, Double)])+-- evProd = noEvent --> arr (snd >>> splitBalls)+--+-- initialList = [ inCircles (320, 240) ]+-- initialList' = [ inCircles' (320, 240) ]+--+-- addToList :: [SF () ((Double, Double), Bool)]+-- -> [(Double, Double)]+-- -> SF () [((Double, Double), Bool)]+-- addToList sfs ips = trace ("Adding new circles: " ++ show ips)+-- $ inCirclesL (sfs ++ map inCircles ips)+--+-- splitBalls :: [((Double, Double), Bool)] -> Yampa.Event [(Double, Double)]+-- splitBalls ps+-- | null ls = noEvent+-- | otherwise = Yampa.Event ls+-- where ls = [ (y-20, x+20) | ((x,y),True) <- ps ]+--+-- inCircles :: (Double, Double) -> SF () ((Double, Double), Bool)+-- inCircles (baseX, baseY) = proc () -> do+-- t <- localTime -< ()+-- let radius = 30+-- x = baseX + (cos t * radius)+-- y = baseY + (sin t * radius)+--+-- split <- noEvent --> spike 100 -< ()+--+-- () <- arr id -< trace ( "Time : " ++ show t+-- ++ " mod: " ++ show (round t `mod` 10)+-- ++ " s: " ++ show split+-- )+-- ()+--+-- returnA -< ((x,y), isEvent split)
+ Experiments/stickyarrowup/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE Arrows #-}+import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Primitives as SDL+import FRP.Yampa as Yampa+import Data.IORef+import Debug.Trace++width = 640+height = 480++main = do+ timeRef <- newIORef (0 :: Int)+ reactimate initGraphs+ (\_ -> do+ dtSecs <- yampaSDLTimeSense timeRef+ return (dtSecs, Nothing))+ (\_ e -> display e >> return False)+ (fire (fromIntegral height / 2) (-10))++-- | 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)++yampaSDLTimeSense :: IORef Int -> IO Yampa.DTime+yampaSDLTimeSense timeRef = do+ -- Get time passed since SDL init+ newTime <- fmap fromIntegral SDL.getTicks++ -- Obtain time difference+ dt <- updateTime timeRef newTime+ let dtSecs = fromIntegral dt / 100+ return dtSecs++initGraphs :: IO ()+initGraphs = do+ -- Initialise SDL+ SDL.init [InitVideo]++ -- Create window+ screen <- setVideoMode width height 16 [SWSurface]+ setCaption "Test" ""++display :: (Double, Double) -> IO()+display (boxY0,boxY) = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Paint screen green+ let format = surfaceGetPixelFormat screen+ green <- mapRGB format 0 0xFF 0+ fillRect screen Nothing green++ -- Paint small red square, at an angle 'angle' with respect to the center+ red <- mapRGB format 0xFF 0xFF 0+ let x = fromIntegral $ width `div` 2+ y0 = round boxY0+ y = round boxY+ vLine screen x y0 y red++ -- Double buffering+ SDL.flip screen++rising :: Double -> Double -> SF () (Double, Double)+rising y0 v0 = proc () -> do+ y <- (y0+) ^<< integral -< v0+ returnA -< (y0, y)++fire :: Double -> Double -> SF () (Double, Double)+fire y vy = switch (rising y vy >>> (Yampa.identity &&& hitCeiling))+ (\(y0, yn) -> switch (constant (y0, yn) &&& after 10 ())+ (\_ -> fire y vy))++hitCeiling :: SF (Double, Double) (Yampa.Event (Double, Double))+hitCeiling = arr (\(y0,y) ->+ let boxTop = y+ in if boxTop < 0+ then Yampa.Event (y0, y)+ else Yampa.NoEvent)
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ data/lacuna.ttf view
binary file changed (absent → 56784 bytes)
+ pang-a-lambda.cabal view
@@ -0,0 +1,219 @@+-- Initial pang-a-lambda.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++name: pang-a-lambda+version: 0.2.0.0+synopsis: A super-pang clone+description: An FRP implementation of superpang+license: GPL-3+license-file: LICENSE+author: Ivan Perez+maintainer: ivan.perez@keera.co.uk+-- copyright:+category: Game+build-type: Simple+-- extra-source-files:+cabal-version: >=1.16+data-files: data/*.ttf++Flag experiments+ Default: False+ Description: Compile experimental demos++executable pang-a-lambda-dumbplayer+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, SDL-gfx, Yampa+ hs-source-dirs: Experiments/dumbplayer/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-arrowup+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, SDL-gfx, Yampa+ hs-source-dirs: Experiments/arrowup/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-stickyarrow+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, SDL-gfx, Yampa+ hs-source-dirs: Experiments/stickyarrowup/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-player+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, SDL-gfx, Yampa+ hs-source-dirs: Experiments/player/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-physics+ build-depends: base >=4.6 && <5,+ bytestring,+ containers -any,+ IfElse -any,+ mtl -any,+ transformers >=0.3 && <0.5,+ Yampa >=0.9.6 && <0.11,++ SDL -any,+ SDL-gfx -any,+ SDL-ttf -any++ main-is: Main.hs+ hs-source-dirs: Experiments/collisions+ other-modules:+ -- Game specific+ Constants+ Debug+ Display+ Game+ GameState+ Input+ Objects+ ObjectSF+ Resources++ -- General modules+ Control.Extra.Monad+ Data.Extra.Num+ Data.Extra.VectorSpace+ Data.IdentityList+ Graphics.UI.Extra.SDL+ Physics.TwoDimensions.Collisions+ Physics.TwoDimensions.Dimensions+ Physics.TwoDimensions.GameCollisions+ Physics.TwoDimensions.PhysicalObjects+ Physics.TwoDimensions.Shapes+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-circlingboxes+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, Yampa+ hs-source-dirs: Experiments/circling-boxes/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-splittingboxes+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, Yampa+ hs-source-dirs: Experiments/splitting-boxes/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-split+ main-is: Main.hs+ -- other-modules:+ other-extensions: Arrows+ build-depends: base >=4.6 && <4.9, SDL, Yampa+ hs-source-dirs: Experiments/split/+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda-splitballs+ build-depends: base >=4.6 && <5,+ bytestring,+ containers -any,+ IfElse -any,+ mtl -any,+ transformers >=0.3 && <0.5,+ Yampa >=0.9.6 && <0.11,++ SDL -any,+ SDL-gfx -any,+ SDL-ttf -any++ main-is: Main.hs+ hs-source-dirs: Experiments/splitballs/+ other-modules:+ -- Game specific+ Constants+ Debug+ Display+ Game+ GameState+ Input+ Objects+ ObjectSF+ Resources++ -- General modules+ Control.Extra.Monad+ Data.Extra.Num+ Data.Extra.VectorSpace+ Graphics.UI.Extra.SDL+ Physics.TwoDimensions.Collisions+ Physics.TwoDimensions.Dimensions+ Physics.TwoDimensions.GameCollisions+ Physics.TwoDimensions.PhysicalObjects+ Physics.TwoDimensions.Shapes+ default-language: Haskell2010+ if !flag(experiments)+ buildable: False++executable pang-a-lambda+ build-depends: base >=4.6 && <5,+ bytestring,+ containers -any,+ IfElse -any,+ mtl -any,+ transformers >=0.3 && <0.5,+ Yampa >=0.9.6 && <0.11,++ SDL -any,+ SDL-gfx -any,+ SDL-ttf -any+ default-language: Haskell2010++ main-is: Main.hs+ hs-source-dirs: src/+ ghc-options: -Wall+ other-modules:+ -- Game specific+ Constants+ Collisions+ Debug+ Display+ Game+ GameState+ Input+ Objects+ Objects.Walls+ ObjectSF+ Resources++ -- General modules+ Control.Extra.Monad+ Data.Extra.IORef+ Data.Extra.Num+ Data.Extra.Ord+ Data.Extra.VectorSpace+ FRP.Yampa.Extra+ Graphics.UI.Extra.SDL+ Physics.TwoDimensions.Collisions+ Physics.TwoDimensions.Dimensions+ Physics.TwoDimensions.GameCollisions+ Physics.TwoDimensions.PhysicalObjects+ Physics.TwoDimensions.Shapes
+ src/Collisions.hs view
@@ -0,0 +1,125 @@+-- Copyright (c) 2011 - All rights reserved - Keera Studios+module Collisions where++import Control.Applicative+import Control.Arrow+import Data.Maybe++import Physics.TwoDimensions.Dimensions+import FRP.Yampa.VectorSpace+import Shapes+import Data ( pointX, rotateRespect, unrotateRespect+ , minimumWith, swap+ )++circleAABBOverlap :: Circle -> AABB -> Bool+circleAABBOverlap c@(cp,cr) (rp, rs) =+ circleAABBOverlap' ((0,0), cr) (rp ^-^ cp, rs)++circleAABBOverlap' :: Circle -> AABB -> Bool+circleAABBOverlap' ((p1x,p1y),r1) (p2@(p2x, p2y), s2@(w2, h2)) =+ overlapX && overlapY && overlapP11 && overlapP12 && overlapP21 && overlapP22+ where -- Square coordinates+ p211@(p211x, p211y) = p2 ^-^ s2+ p212@(p212x, p212y) = p2 ^+^ (-w2, h2)+ p221@(p221x, p221y) = p2 ^+^ (w2, -h2)+ p222@(p222x, p222y) = p2 ^+^ s2++ -- Horizontal projection overlap+ overlapX = (-r1, r1) `overlapSegment` (p2x - w2, p2x + w2)+ overlapY = (-r1, r1) `overlapSegment` (p2y - h2, p2y + h2)++ rectangleVertices = [p211, p212, p221, p222]++ rotatedP211 = map (fst.rotateRespect p211) rectangleVertices+ rotatedP212 = map (fst.rotateRespect p212) rectangleVertices+ rotatedP221 = map (fst.rotateRespect p221) rectangleVertices+ rotatedP222 = map (fst.rotateRespect p222) rectangleVertices++ projection ps = (minimum ps, maximum ps)++ overlapP11 = (-r1, r1) `overlapSegment` projection rotatedP211+ overlapP12 = (-r1, r1) `overlapSegment` projection rotatedP212+ overlapP21 = (-r1, r1) `overlapSegment` projection rotatedP221+ overlapP22 = (-r1, r1) `overlapSegment` projection rotatedP222++ overlapSegment (x01,x02) (x11, x12) = min x02 x12 > max x01 x11++-- * Colision detection+responseCircleAABB :: Circle -> AABB -> Maybe Pos2D+responseCircleAABB c@(cp,cr) (rp, rs) =+ responseCircleAABB' ((0,0), cr) (rp ^-^ cp, rs)++responseCircleAABB' :: Circle -> AABB -> Maybe Pos2D+responseCircleAABB' ((p1x,p1y),r1) (p2@(p2x, p2y), s2@(w2, h2))+ | all isJust overlaps+ = (Just . snd) $ minimumWith (abs.fst) $ map fromJust overlaps+ | otherwise+ = Nothing++ where overlaps = [ overlapX, overlapY+ , overlapP11, overlapP12+ , overlapP21, overlapP22+ ]++ -- Square coordinates+ p211@(p211x, p211y) = p2 ^-^ s2+ p212@(p212x, p212y) = p2 ^+^ (-w2, h2)+ p221@(p221x, p221y) = p2 ^+^ (w2, -h2)+ p222@(p222x, p222y) = p2 ^+^ s2++ -- Horizontal projection overlap+ overlapX = (pointX &&& id) <$> (-r1, r1) `overlapSegment` (p2x - w2, p2x + w2)+ overlapY = (pointX &&& swap) <$> (-r1, r1) `overlapSegment` (p2y - h2, p2y + h2)++ rectangleVertices = [p211, p212, p221, p222]++ rotatedP211 = map (rotateRespect p211) rectangleVertices+ rotatedP212 = map (rotateRespect p212) rectangleVertices+ rotatedP221 = map (rotateRespect p221) rectangleVertices+ rotatedP222 = map (rotateRespect p222) rectangleVertices++ xProjection = (minimum &&& maximum) . map pointX++ circleOverlaps = overlapSegment (-r1, r1)++ overlapP11 = (pointX &&& unrotateRespect p211) <$> circleOverlaps (xProjection rotatedP211)+ overlapP12 = (pointX &&& unrotateRespect p212) <$> circleOverlaps (xProjection rotatedP212)+ overlapP21 = (pointX &&& unrotateRespect p221) <$> circleOverlaps (xProjection rotatedP221)+ overlapP22 = (pointX &&& unrotateRespect p222) <$> circleOverlaps (xProjection rotatedP222)++ overlapSegment (x01,x02) (x11, x12)+ | segmentLength' > 0 = Just (segmentLength, 0)+ | otherwise = Nothing+ where segmentLength = if x01 < x11 then -segmentLength' else segmentLength'+ segmentLength' = if segmentLength'' == 0 then 1 else segmentLength''+ segmentLength'' = min x02 x12 - max x01 x11++responseAABB2 :: AABB -> AABB -> Maybe Pos2D+responseAABB2 (pos1, size1) (pos2, size2)+ | overlap && overlapx > overlapy = Just cy+ | overlap && overlapy > overlapx = Just cx+ | overlap = Just (cx ^+^ cy)+ | otherwise = Nothing+ where (x1,y1) = pos1+ (w1,h1) = size1+ (x2,y2) = pos2+ (w2,h2) = size2+ toRight = x1 > x2+ toLeft = x1 < x2+ above = y1 < y2+ below = y1 > y2+ overlapx = max 0 (w1 + w2 - abs (x1 - x2))+ overlapy = max 0 (h1 + h2 - abs (y1 - y2))+ overlap = overlapx > 0 && overlapy > 0+ cx = if toRight then (overlapx, 0) else (-overlapx, 0)+ cy = if above then (0, -overlapy) else (0, overlapy)+ (x1,y1) ^+^ (x2,y2) = (x1+x2, y1+y2)++overlapsAABB2 :: AABB -> AABB -> Bool+overlapsAABB2 (pos1, size1) (pos2, size2) =+ abs (x1 - x2) < w1 + w2 && abs (y1 - y2) < h1 + h2+ where (x1,y1) = pos1+ (w1,h1) = size1+ (x2,y2) = pos2+ (w2,h2) = size2
+ src/Constants.hs view
@@ -0,0 +1,103 @@+module Constants where++import Data.Word+import Graphics.UI.SDL as SDL++gameName :: String+gameName = "Break-a-ball"++width :: Double+width = 1024+height :: Double+height = 600++gameWidth :: Double+gameWidth = width++gameHeight :: Double+gameHeight = height++-- Energy transmission between objects in collisions+velTrans :: Double+velTrans = 1.00++-- Max speed+maxVNorm :: Double -> Double+maxVNorm n+ | n >= 100 = 800+ | n >= 50 = 733+ | n >= 25 = 666+ | otherwise = 600++ballWidth, ballHeight :: Double+ballWidth = 100+ballHeight = 100++ballMargin :: Double+ballMargin = 3++ballSize :: Integral a => a+ballSize = 25++-- Colors+fontColor :: SDL.Color+fontColor = SDL.Color 94 86 91++ballColor :: Word32+ballColor = 0xDD875FFF++velColor :: Word32+velColor = 0xCCBBFFFF++playerWidth :: Double+playerWidth = 30++playerHeight :: Double+playerHeight = 80++fireColor :: Word32+fireColor = 0xFFDDC34F++playerRightColor :: Word32+playerRightColor = 0xFFD2D454++playerLeftColor :: Word32+playerLeftColor = 0xFFB2D454++playerStandColor :: Word32+playerStandColor = 0xFFE5D454++playerBlinkRightColor :: Word32+playerBlinkRightColor = 0x88D2D454++playerBlinkLeftColor :: Word32+playerBlinkLeftColor = 0x88B2D454++playerBlinkStandColor :: Word32+playerBlinkStandColor = 0x88F2D454++backgroundColor :: Word32+backgroundColor = 0x88EDE9CB++blockColor :: Word32+blockColor = 0xFF85AABC++playerSpeed :: Double+playerSpeed = 200++fireSpeed :: Double+fireSpeed = 400++initialLives :: Int+initialLives = 5++-- Debugging collisions++collisionDebugColor :: Word32+collisionDebugColor = 0x88D2D4FF++collisionDebugThickness :: Num a => a+collisionDebugThickness = 3++debugCollisions :: Bool+debugCollisions = False
+ src/Control/Extra/Monad.hs view
@@ -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
+ src/Data/Extra/IORef.hs view
@@ -0,0 +1,12 @@++module Data.Extra.IORef where++import Data.IORef++-- * Aux IOREf+modifyIORefIO :: IORef a -> (a -> IO a) -> IO a+modifyIORefIO ref modify = do+ v <- readIORef ref+ new <- modify v+ writeIORef ref new+ return new
+ src/Data/Extra/Num.hs view
@@ -0,0 +1,20 @@+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++class Similar a where+ sigma :: a -- margin of error++instance Similar Float where+ sigma = 0.01++instance Similar Double where+ sigma = 0.01++(=~) :: (Num a, Ord a, Similar a) => a -> a -> Bool+x =~ y = abs (x - y) < sigma+
+ src/Data/Extra/Ord.hs view
@@ -0,0 +1,6 @@+module Data.Extra.Ord where++inRange :: Ord a => (a, a) -> a -> a+inRange (mn, mx) n | n < mn = mn+ | n > mx = mx+ | otherwise = n
+ src/Data/Extra/VectorSpace.hs view
@@ -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
+ src/Debug.hs view
@@ -0,0 +1,8 @@+module Debug where++import Control.Monad (when, void)++import Constants++debug :: Bool -> String -> IO ()+debug b msg = when b $ putStrLn msg
+ src/Display.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Display where++import Control.Arrow ((***))+import Control.Monad+import Data.Maybe (fromJust)+import FRP.Yampa.VectorSpace+import Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.Primitives as SDLP+import qualified Graphics.UI.SDL.TTF as TTF+import Graphics.UI.Extra.SDL as SDL+import Text.Printf++import Constants+import GameState+import Objects+import Resources+import Physics.TwoDimensions.Shapes++-- | 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,+-- so it's not a general, parameterised, scalable solution.+--+loadResources :: IO Resources+loadResources = do+ -- Font initialization+ _ <- TTF.init++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font <- TTF.openFont gameFont 32 -- 32: fixed size?++ -- Load the fonts we need+ let gameFont = "data/lacuna.ttf"+ font2 <- TTF.openFont gameFont 8 -- 32: fixed size?++ -- Return all resources (just the font)+ return $ Resources font font2++initializeDisplay :: IO ()+initializeDisplay =+ -- Initialise SDL+ SDL.init [InitEverything]++initGraphs :: Resources -> IO ()+initGraphs _res = do+ screen <- SDL.setVideoMode (round width) (round height) 32 [SWSurface]+ SDL.setCaption gameName ""++ -- 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 True++ return ()++render :: Resources -> GameState -> IO()+render resources shownState = do+ -- Obtain surface+ screen <- getVideoSurface++ -- Clear BG+ fillRect screen Nothing (Pixel backgroundColor)++ -- Paint objects+ mapM_ (paintObject screen resources (gameTime (gameInfo shownState))) (gameObjects shownState)++ when debugCollisions $+ mapM_ (paintShape screen resources (gameTime (gameInfo shownState))) (gameObjects shownState)++ -- Paint HUD+ displayInfo screen resources (gameInfo shownState) (gameObjects shownState)++ -- Paint messages/popups (eg. "Paused", "Level 0", etc.)+ displayMessage screen resources (gameInfo shownState)++ -- Double buffering+ SDL.flip screen++-- * Painting functions+displayInfo :: Surface -> Resources -> GameInfo -> Objects -> IO()+displayInfo screen resources over objs = do+ printAlignRight screen resources+ ("Time: " ++ printf "%.2f" (gameTime over)) (10,50)+ let p = findPlayer objs+ case p of+ Just p' -> let e = playerEnergy p'+ in printAlignRight screen resources ("Energy: " ++ show e) (10,100)+ Nothing -> return ()++paintObject :: Surface -> Resources -> Double -> Object -> IO ()+paintObject screen resources time object =+ case objectKind object of+ (Side {}) -> return ()+ (Ball ballSize) -> do+ let (px,py) = (\(u,v) -> (u, gameHeight - v)) (objectPos object)+ let (x,y) = (round *** round) (px,py)+ (vx,vy) = objectVel object+ (x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))+ _ <- SDLP.filledCircle screen x y (round ballSize) (SDL.Pixel ballColor)+ _ <- SDLP.line screen x y x' y' (SDL.Pixel velColor)++ -- Print position+ let font = miniFont resources+ message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor+ let w = SDL.surfaceGetWidth message+ h = SDL.surfaceGetHeight message+ (x'',y'') = (round *** round) (px,py)+ rect = SDL.Rect (x''+30) (y''-30) w h+ SDL.blitSurface message Nothing screen (Just rect)+ return ()++ (Block sz@(w', h')) -> void $ do+ let (px,py) = (objectPos object)+ (x,y) = (round *** round) (px,gameHeight - py -h')+ (w,h) = (round *** round) sz+ fillRect screen (Just (Rect x y w h)) (Pixel blockColor)++ (Player state _ vulnerable energy) -> do+ let blinkOn = vulnerable || (even (round (time * 10)))+ when blinkOn $ do++ let (px,py) = (\(u,v) -> (u, gameHeight - v - playerHeight)) (objectPos object)+ let (x,y) = (round *** round) (px,py)+ (vx,vy) = objectVel object+ (x',y') = (round *** round) ((px,py) ^+^ (0.1 *^ (vx, -vy)))+ (w,h) = (round playerWidth, round playerHeight)+ playerColor = case (state, vulnerable) of+ (PlayerRight, True) -> playerRightColor+ (PlayerLeft , True) -> playerLeftColor+ (PlayerStand, True) -> playerStandColor+ (PlayerRight, False) -> playerBlinkRightColor+ (PlayerLeft , False) -> playerBlinkLeftColor+ (PlayerStand, False) -> playerBlinkStandColor++ fillRect screen (Just (Rect x y w h)) (Pixel playerColor)++ _ <- SDLP.line screen (fromIntegral x) (fromIntegral y) x' y' (SDL.Pixel velColor)++ -- Print position+ let font = miniFont resources+ message <- TTF.renderTextSolid font (show $ (round *** round) (objectPos object)) fontColor+ let w = SDL.surfaceGetWidth message+ h = SDL.surfaceGetHeight message+ (x'',y'') = (round *** round) (px,py)+ rect = SDL.Rect (x''+30) (y''-30) w h+ SDL.blitSurface message Nothing screen (Just rect)+ return ()++ Projectile -> do+ let (x0,y0) = (\(x,y) -> (x - 5, height - y)) $ objectPos object+ (dx, dy) = (10, snd (objectPos object))+ (x0', y0', dx', dy') = (round x0, round y0, round dx, round dy)+ fillRect screen (Just (Rect x0' y0' dx' dy')) (Pixel fireColor)+ return ()++paintShape :: Surface -> Resources -> Double -> Object -> IO ()+paintShape screen resources time object =+ paintShape' screen resources time (objShape object)++paintShape' screen resources time shape =+ case shape of+ Rectangle (px, py) (w,h) -> void $ do+ let x1 = round px+ x2 = round (px + w)+ y1 = round (gameHeight - py - h)+ y2 = round (gameHeight - py)+ drawThickRectangle screen (Rect x1 y1 x2 y2) (Pixel collisionDebugColor) collisionDebugThickness++ Circle (px, py) rd -> void $ do+ let x = round px+ y = round (gameHeight - py)+ r = round rd+ drawThickCircle screen x y r (Pixel collisionDebugColor) collisionDebugThickness++ SemiPlane (px, py) s ->+ let w = round width+ h = round height+ in case s of+ LeftSide -> drawThickLine screen 0 0 0 h (Pixel collisionDebugColor) collisionDebugThickness+ RightSide -> drawThickLine screen w 0 w h (Pixel collisionDebugColor) collisionDebugThickness+ TopSide -> drawThickLine screen 0 0 w 0 (Pixel collisionDebugColor) collisionDebugThickness+ BottomSide -> drawThickLine screen 0 h w h (Pixel collisionDebugColor) collisionDebugThickness++drawThickRectangle surface (Rect x1 y1 x2 y2) pixel 0 = return ()+drawThickRectangle surface rect@(Rect x1 y1 x2 y2) pixel n = do+ let n' = n-1+ SDLP.rectangle surface (Rect (x1-n') (y1-n') (x2+n') (y2+n')) pixel+ drawThickRectangle surface rect pixel n'++drawThickCircle screen x y r pixel 0 = return ()+drawThickCircle screen x y r pixel n = do+ let n' = n-1+ SDLP.circle screen x y (r+n') pixel+ drawThickCircle screen x y r pixel n'++drawThickLine screen x1 y1 x2 y2 pixel 0 = return ()+drawThickLine screen x1 y1 x2 y2 pixel n = do+ let n' = n-1+ SDLP.line screen (x1) (y1-n') (x2) (y2-n') pixel+ SDLP.line screen (x1) (y1+n') (x2) (y2+n') pixel+ SDLP.line screen (x1-n') (y1) (x2-n') (y2) pixel+ SDLP.line screen (x1+n') (y1) (x2+n') (y2) pixel+ drawThickLine screen x1 y1 x2 y2 pixel n'++-- * Painting functions+displayMessage :: Surface -> Resources -> GameInfo -> IO()+displayMessage screen resources info = case gameStatus info of+ GameLoading ->+ printAlignCenter screen resources ("Level " ++ show (gameLevel info))+ _ -> return ()++-- * Render text with alignment+printAlignRight :: Surface -> Resources -> String -> (Int, Int) -> IO ()+printAlignRight screen resources msg (x,y) = void $ do+ let font = resFont resources+ message <- TTF.renderTextSolid font msg fontColor+ renderAlignRight screen message (x,y)++-- * Render text with alignment+printAlignCenter :: Surface -> Resources -> String -> IO ()+printAlignCenter screen resources msg = void $ do+ let font = resFont resources+ message <- TTF.renderTextSolid font msg fontColor+ renderAlignCenter screen message
+ src/FRP/Yampa/Extra.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE MultiWayIf #-}+module FRP.Yampa.Extra where++import Debug.Trace+import FRP.Yampa+import FRP.Yampa.InternalCore+import FRP.Yampa.Switches++-- * Auxiliary FRP stuff+maybeToEvent :: Maybe a -> Event a+maybeToEvent = maybe noEvent Event++-- ** ListSF that never dies or produces offspring+inertSF :: SF a b -> ListSF a b+inertSF sf = ListSF (sf >>> arr (\o -> (o, False, [])))++-- ** Event-producing SF combinators+spikeOn :: SF a Bool -> SF a (Event ())+spikeOn sf = noEvent --> (sf >>> edge)++ifDiff :: Eq a => a -> SF a (Event a)+ifDiff x = loopPre x $ arr $ \(x',y') ->+ if x' == y'+ then (noEvent, x')+ else (Event x', x')++-- ** Repetitive switching++repeatSF :: (c -> SF a (b, Event c)) -> c -> SF a b+repeatSF sf c = switch (sf c) (repeatSF sf)++repeatRevSF :: (c -> SF a (b, Event c)) -> c -> SF a b+repeatRevSF sf c = revSwitch (sf c) (repeatRevSF sf)++restartOn :: SF a b -> SF a (Event c) -> SF a b+restartOn sf sfc = switch (sf &&& sfc)+ (\_ -> restartOn sf sfc)++-- restartRevOn :: SF a b -> SF a (Event c) -> SF a b+-- restartRevOn sf sfc = switch (sf &&& sfc)+-- (\_ -> restartOn sf sfc)+-- ++revSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b+revSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0}+ where+ tf0 a0 =+ case tf10 a0 of+ (sf1, (b0, NoEvent)) -> (switchAux sf1 k, b0)+ (sf1, (_, Event c0)) -> switchingPoint sf1 k (sfTF (k c0) a0)++ switchingPoint :: SF' a (b, Event c) -> (c -> SF a b) -> (SF' a b, b) -> (SF' a b, b)+ switchingPoint sf1 k (sfN', b) = (sf', b)+ where sf' = SF' tf'+ tf' dt a = if | dt < 0 -> sfTF' (switchAux sf1 k) dt a+ -- let (sf1', b') = sfTF' sf1 dt a+ -- in (switchAux sf1' k, b')+ | dt > 0 -> switchingPoint' sf1 k dt (sfTF' sfN' dt a)+ | dt == 0 -> switchingPoint sf1 k (sfN', b)++ switchingPoint' :: SF' a (b, Event c) -> (c -> SF a b) -> DTime -> (SF' a b, b) -> (SF' a b, b)+ switchingPoint' sf1 k accumDT (sfN', b) = (sf', b)+ where sf' = SF' tf'+ tf' dt a = let dt' = dt + accumDT+ in if | dt < 0 -> if | dt' < 0 -> sfTF' (switchAux sf1 k) dt' a+ | dt' > 0 -> dt' `seq` switchingPoint' sf1 k dt' (sfTF' sfN' dt a)+ | dt' == 0 -> switchingPoint' sf1 k accumDT (sfN', b)+ | dt > 0 -> dt' `seq` switchingPoint' sf1 k dt' (sfTF' sfN' dt a)+ | dt == 0 -> switchingPoint' sf1 k accumDT (sfN', b)+++ switchAux :: SF' a (b, Event c) -> (c -> SF a b) -> SF' a b+ switchAux sf1 k = SF' tf+ where+ tf dt a =+ case (sfTF' sf1) dt a of+ (sf1', (b, NoEvent)) -> (switchAux sf1' k, b)+ (_, (_, Event c)) -> switchingPoint sf1 k (sfTF (k c) a)++alwaysForward :: SF a b -> SF a b+alwaysForward sf = SF $ \a -> let (sf', b) = sfTF sf a+ in (alwaysForward' sf', b)++alwaysForward' :: SF' a b -> SF' a b+alwaysForward' sf = SF' $ \dt a -> let (sf', b) = sfTF' sf (max dt (-dt)) a+ in (alwaysForward' sf', b)++checkpoint :: SF a (b, Event (), Event ()) -> SF a b+checkpoint sf = SF $ \a -> let (sf', (b, save, reset)) = sfTF sf a+ in case reset of+ Event () -> error "loop"+ NoEvent -> let pt = case save of + Event () -> Just (Right sf)+ NoEvent -> Nothing+ in (checkpoint' pt sf', b)++checkpoint' :: Maybe (Either (SF' a (b, Event (), Event ())) (SF a (b, Event (), Event ())))+ -> (SF' a (b, Event (), Event ()))+ -> SF' a b+checkpoint' rstPt sf' = SF' $ \dt a -> let (sf'', (b, save, reset)) = sfTF' sf' dt a+ in case reset of+ Event () -> case rstPt of+ Nothing -> let pt = case save of+ Event () -> Just (Left sf'')+ NoEvent -> rstPt+ in pt `seq` (checkpoint' pt sf'', b) ++ Just (Left sf''') -> (checkpoint' rstPt sf''', b)+ Just (Right sf ) -> sfTF (checkpoint sf) a+ NoEvent -> let pt = case save of+ Event () -> Just (Left sf'')+ NoEvent -> rstPt+ in pt `seq` (checkpoint' pt sf'', b) ++forgetPast sf = SF $ \a -> let (sf', b) = sfTF sf a+ in (forgetPast' 0 sf', b)++forgetPast' time sf' = SF' $ \dt a -> let time' = time + dt+ in -- trace (show time') $+ if time' < 0+ then let (sf'', b) = sfTF' sf' (-time) a+ in (forgetPast' 0 sf'', b)+ else let (sf'', b) = sfTF' sf' dt a+ in (forgetPast' time' sf'', b)++limitHistory :: DTime -> SF a b -> SF a b+limitHistory time sf = SF $ \a -> let (sf', b) = sfTF sf a+ in (limitHistory' 0 time sf', b)++limitHistory' :: Time -> DTime -> SF' a b -> SF' a b+limitHistory' curT maxT sf' = SF' $ \dt a -> let curT' = curT + dt+ time' = if curT' > maxT then maxT else curT'+ in -- trace (show (dt, curT, maxT, maxMaxT)) $+ if time' < 0+ then let (sf'', b) = sfTF' sf' (-curT) a+ in (limitHistory' 0 maxT sf'', b)+ else let (sf'', b) = sfTF' sf' dt a+ in (limitHistory' time' maxT sf'', b)++clocked :: SF a DTime -> SF a b -> SF a b+clocked clockSF sf = SF $ \a -> let (sf', b) = sfTF sf a+ (cSF', _) = sfTF clockSF a+ in (clocked' cSF' sf', b)++clocked' :: SF' a DTime -> SF' a b -> SF' a b+clocked' clockSF sf = SF' $ \dt a -> let (cSF', dt') = sfTF' clockSF dt a+ (sf', b) = sfTF' sf dt' a+ in (clocked' cSF' sf', b)++deltas = localTime >>> loopPre 0 (arr $ \(lt, ot) -> (lt-ot, lt))++type Endo a = a -> a++timeTransform :: Endo DTime -> SF a b -> SF a b+timeTransform transform sf = SF tf+ where tf a = let (sf', b) = (sfTF sf) a+ sf'' = timeTransformF transform sf'+ in (sf'', b)++timeTransformF :: Endo DTime -> SF' a b -> SF' a b+timeTransformF transform sf = SF' tf+ where tf dt a = let dt' = transform dt+ (sf', b) = (sfTF' sf) dt' a+ sf'' = timeTransformF transform sf'+ in (sf'', b)++timeTransformSF :: SF a (DTime -> DTime) -> SF a b -> SF a b+timeTransformSF sfTime sf = SF tf+ where tf a = let (sf', b) = (sfTF sf) a+ (sfTime',_) = (sfTF sfTime) a+ sf'' = timeTransformSF' sfTime' sf'+ in (sf'', b)+++timeTransformSF' :: SF' a (DTime -> DTime) -> SF' a b -> SF' a b+timeTransformSF' sfTime sf = SF' tf+ where tf dt a = let (sfTime', transform) = (sfTF' sfTime) dt a+ dt' = transform dt+ (sf', b) = (sfTF' sf) dt' a+ sf'' = timeTransformSF' sfTime' sf'+ in (sf'', b)+
+ src/Game.hs view
@@ -0,0 +1,681 @@+{-# LANGUAGE MultiWayIf #-}+{-# 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 two sections:+--+-- - A collection of gameplay SFs, which control the core game loop, carry+-- out collision detection, , 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 Prelude hiding (id, (.))+import Control.Category (id, (.))+import Data.List+import Data.Maybe+import Debug.Trace+import FRP.Yampa -- as Yampa+-- import FRP.Yampa.InternalCore+import FRP.Yampa.Extra+import FRP.Yampa.Switches++-- General-purpose internal imports+import Data.Extra.Ord+import Data.Extra.VectorSpace+import Physics.Oscillator+import Physics.TwoDimensions.Collisions as Collisions+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.GameCollisions+import Physics.TwoDimensions.Shapes+import Physics.TwoDimensions.PhysicalObjects++-- Internal iports+import Constants+import GameState+import Input+import Objects+import ObjectSF+import Objects.Walls++-- * General state transitions++-- | Run the game that the player can lose at until ('switch') the player is+-- completely dead, and then restart the game.+wholeGame :: SF Controller GameState+wholeGame = forgetPast $ + switch (level 0 >>> (identity &&& playerDead))+ (\_ -> wholeGame)++-- * Game over++-- | Detect the death of a player by searching for it in the scene (SF).+playerDead :: SF GameState (Event ())+playerDead = playerDead' ^>> edge++-- | Detect the death of a player by searching for it in the scene.+playerDead' :: GameState -> Bool+playerDead' gs = gamePlaying && dead+ where+ -- Dead in the game if not present, or if found dead+ dead = null (filter isPlayer (gameObjects gs))+ || not (null (filter playerIsDead (gameObjects gs)))++ -- Player dead if it has no more lives left+ playerIsDead o = case objectKind o of+ (Player _ lives _ _) -> lives < 0+ otherwise -> False++ -- This is only defined when the game is in progress.+ gamePlaying = GamePlaying == gameStatus (gameInfo gs)++-- | Show loading screen for 2 seconds, then move on to play+-- the game.+level :: Int -> SF Controller GameState+level n = switch+ (levelLoading n &&& after 2 ()) -- show loading screen for 2 seconds+ (\_ -> levelLoaded n)++-- | Play a level till completed, then move on to the next level.+levelLoaded :: Int -> SF Controller GameState+levelLoaded n = switch+ (playLevel n >>> (identity &&& outOfEnemies))+ (\_ -> level (n + 1))++timeProgression :: SF Controller (DTime -> DTime)+timeProgression = slowDown+ -- proc (c) -> do+ -- let rev = if controllerReverse c then ((-1)*) else id+ -- returnA -< rev++slowDown :: SF Controller (DTime -> DTime)+slowDown = proc (c) -> do+ rec let slow = controllerReverse c+ unit = if | power' >= 0 && slow -> (-1)+ | power' >= maxPower -> 0+ | otherwise -> 1+ power <- (maxPower +) ^<< integral -< unit+ let power' = min maxPower (max 0 power)+ dtF = if slow && (power' > 0) then (0.1*) else id+ returnA -< dtF+ where+ maxPower :: Double+ maxPower = 5+++timeProgression' :: SF ObjectInput (DTime -> DTime)+timeProgression' = arr userInput >>> stopClock++stopClock :: SF Controller (DTime -> DTime)+stopClock = switch (arr controllerHalt >>> arr (\c' -> if c' then (const 0, Event ()) else (id, noEvent)))+ (\_ -> switch (constant (const 0) &&& after 25 ())+ (\_ -> stopClock))++-- | Produce a constant game state of loading a particular level.+levelLoading :: Int -> SF a GameState+levelLoading n = constant (GameState [] (GameInfo 0 n GameLoading))++-- | Play one level indefinitely (it never ends or restarts).+playLevel :: Int -> SF Controller GameState+playLevel n = playLevel' n + -- checkpoint $ proc (c) -> do+ -- take <- edge <<^ controllerCheckPointSave -< c+ -- restore <- edge <<^ controllerCheckPointRestore -< c+ -- g <- playLevel' n -< c+ -- returnA -< (g, take, restore)++playLevel' :: Int -> SF Controller GameState+playLevel' n = timeTransformSF timeProgression $ limitHistory 5 $ playLevel'' n++playLevel'' :: Int -> SF Controller GameState+playLevel'' n = gamePlay (initialObjects n) >>^ composeGameState+ where+ -- Compose GameState output from 'gamePlay's output+ composeGameState :: (Objects, Time) -> GameState+ composeGameState (objs, t) = GameState objs (GameInfo t n GamePlaying)++-- | Detect when there are no more enemies in the scene.+outOfEnemies :: SF GameState (Event GameState)+outOfEnemies = arr outOfEnemies'+ where+ outOfEnemies' :: GameState -> (Event GameState)+ outOfEnemies' gs | null balls = Event gs+ | otherwise = NoEvent+ where+ balls = filter isBall (gameObjects gs)++-- ** 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 collisions (discarded at every+-- iteration).++playerEnergy'' :: Objects -> Int+playerEnergy'' objs = + let p = findPlayer objs+ in case p of+ Just p' -> playerEnergy p'+ Nothing -> 0++gameTimeSF = proc (_, (_, e)) -> do+ dt <- deltas -< ()+ let dt' = if e < 0 && dt < 0 then (-dt) else dt+ returnA -< dt'++gamePlay :: [ListSF ObjectInput Object] -> SF Controller (Objects, Time)+gamePlay objs = loopPre ([], 0) $ clocked gameTimeSF (gamePlay' objs)+ -- Process physical movement and detect new collisions+ -- -- Adapt Input+ -- let oi = ObjectInput input cs++ -- -- Step+ -- -- Each obj processes its movement forward+ -- ol <- dlSwitch objs -< oi+ -- let cs' = detectCollisions ol++ -- let energyLeft = playerEnergy'' ol++ -- -- Output+ -- tLeft <- time -< ()+ -- returnA -< ((ol, tLeft), (cs', energyLeft))++-- gamePlay' :: SF (Controller, (Collisions, Int)) ((Objects, Time), (Collisions, Int))+gamePlay' :: [ListSF ObjectInput Object]+ -> SF (Controller, (Objects.Collisions, Int))+ (([Object], Time), (Collisions.Collisions String, Int))+gamePlay' objs = + proc (input, (cs, el)) -> do+ -- Adapt Input+ let oi = ObjectInput input cs++ -- Step+ -- Each obj processes its movement forward+ ol <- dlSwitch objs -< oi+ let cs' = detectCollisions ol++ let eleft = playerEnergy'' ol++ -- Output+ tLeft <- time -< ()+ returnA -< ((ol, tLeft), (cs', eleft))++-- * Game objects+--+-- | Objects initially present: the walls, the ball, the player and the blocks.+initialObjects :: Int -> [ListSF ObjectInput Object]+initialObjects level =+ objEnemies level ++ blocks level ++ objPlayers ++ walls+ where+ walls = [ inertSF objSideRight+ , inertSF objSideTop+ , inertSF objSideLeft+ , inertSF objSideBottom+ ]++-- ** Enemies++-- | Defines the enemies depending on the level.+--+-- This function is paired with 'blocks', because there could be inconsistent+-- initial positions in which blocks and enemies already overlap.+--+-- WARNING: All objects need different names, both at the beginning and during+-- gameplay.++objEnemies :: Int -> [ListSF ObjectInput Object]++objEnemies 0 =+ [ splittingBall ballWidth "ballEnemy1" (600, 300) (360, -350) ]++objEnemies 1 =+ [ splittingBall ballMedium "ballEnemy1" (width/4, 300) (360, -350)+ , splittingBall ballMedium "ballEnemy2" (3*width/4, 300) (360, -350) ]++objEnemies 2 =+ map ballLeft [1..4] ++ map ballRight [1..4]+ where baseL = 20+ sep = width / 20+ baseR = width - (baseL + 4 * sep)++ ballLeft n = splittingBall ballSmall ("ballEnemyL" ++ show n)+ (baseL + n * sep, 100) (-200, -200)++ ballRight n = splittingBall ballSmall ("ballEnemyR" ++ show n)+ (baseR + n * sep, 100) (200, -200)++objEnemies n =+ [ splittingBall ballBig "ballEnemy1" (600, 300) (360, -350) ]++-- ** Blocks+--+-- Blocks are horizontal rectangles that /every/ other element collides+-- with. They need not be static.++-- | List of blocks depending on the level.+blocks :: Int -> [ListSF ObjectInput Object]+blocks 0 = [ objBlock "block1" (200, 55) (100, 50) ]+blocks 1 = [ movingBlock "block1" (400, 200) (100, 50) 200 10 0 0 ]+blocks 2 = [ movingBlock "block1" (400, 200) (100, 50) 0 0 100 10 ]+blocks 3 = [ movingBlock "block1" (324, 200) (100, 40) 200 6 0 0+ , movingBlock "block2" (700, 200) (100, 40) 200 6 100 10+ ]+blocks n = [ objBlock "block1" (200, 200) (100, 50) ]++-- *** Moving blocks++-- | A moving block with an initial position and size, and horizontal and+-- vertical amplitude and periods. If an amplitude is /not/ zero, the+-- block moves along that dimension using a periodic oscillator+-- (see the SF 'osci').++movingBlock :: String+ -> Pos2D -> Size2D -- Geometry+ -> Double -> Double -- Horizontal oscillation amplitude and period+ -> Double -> Double -- Vertical oscillation amplitude and period+ -> ListSF ObjectInput Object+movingBlock name (px, py) size hAmp hPeriod vAmp vPeriod = ListSF $ proc _ -> do+ px' <- vx -< px+ py' <- vy -< py+ returnA -< (Object { objectName = name+ , objectKind = Block size+ , objectPos = (px', py')+ , objectVel = (0,0)+ , canCauseCollisions = False+ , collisionEnergy = 0+ }, False, [])++ where++ -- To avoid errors, we check that the amplitude is non-zero, otherwise+ -- just pass the given position along.+ vx :: SF Double Double+ vx = if hAmp /= 0 then (px +) ^<< osci hAmp hPeriod else identity++ -- To avoid errors, we check that the amplitude is non-zero, otherwise+ -- just pass the given position along.+ vy :: SF Double Double+ vy = if vAmp /= 0 then (py +) ^<< osci vAmp vPeriod else identity++-- | Generic block builder, given a name, a size and its base+-- position.+objBlock :: ObjectName -> Pos2D -> Size2D -> ListSF ObjectInput Object+objBlock name pos size = ListSF $ timeTransformSF timeProgression' $ constant+ (Object { objectName = name+ , objectKind = Block size+ , objectPos = pos+ , objectVel = (0,0)+ , canCauseCollisions = False+ , collisionEnergy = 0+ }, False, [])++-- ** Enemy sizes+ballGiant = ballWidth+ballBig = ballGiant / 2+ballMedium = ballBig / 2+ballSmall = ballMedium / 2++-- ** Player+objPlayers :: [ListSF ObjectInput Object]+objPlayers =+ [ player initialLives playerName (320, 20) True ]++-- ** Guns++gun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]+gun name = normalGun name+ -- To switch between different kinds of guns+ -- gun name = switch+ -- (normalGun name &&& after 5 ())+ -- (\_ -> multipleGun name)++-- *** Normal gun, fires one shot at a time++normalGun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]+normalGun name = revSwitch (constant [] &&& gunFired name)+ (\fireLSF -> blockedGun name fireLSF)++blockedGun name fsf = revSwitch (([fsf] --> constant []) &&& fireDead fsf)+ (\_ -> normalGun name)++fireDead fsf = proc (oi, _) -> do+ (_, b, _) <- listSF fsf -< oi+ justDied <- edge -< b+ returnA -< justDied++gunFired :: String -> SF (ObjectInput, Pos2D) (Event (ListSF ObjectInput Object))+gunFired name = proc (i, ppos) -> do+ -- Fire!!+ newF1 <- edge -< controllerClick (userInput i)+ uniqId <- (\t -> "fire" ++ name ++ show t) ^<< time -< ()++ let newFire = fire uniqId (fst ppos + playerWidth / 2, 0) False+ returnA -< newF1 `tag` newFire++eventToList :: Event a -> [ a ]+eventToList NoEvent = []+eventToList (Event a) = [a]++-- *** Normal gun, fires one shot at a time+multipleGun :: String -> SF (ObjectInput, Pos2D) [ListSF ObjectInput Object]+multipleGun name = eventToList ^<< gunFired name++player :: Int -> String -> Pos2D -> Bool -> ListSF ObjectInput Object+player lives name p0 vul = ListSF $ proc i -> do+ (ppos, pvel) <- playerProgress name p0 -< i++ let state = playerState (userInput i)++ -- newF1 <- isEvent ^<< edge -< controllerClick (userInput i)+ -- uniqId <- (\t -> "fire" ++ name ++ show t) ^<< time -< ()+ -- let newF1Arrows = [ fire uniqId (fst ppos, 0) False+ -- | newF1 ]++ newF1Arrows <- gun name -< (i, ppos)++ -- Dead?+ let hitByBall = not $ null+ $ collisionMask name ("ball" `isPrefixOf`)+ $ collisions i++ vulnerable <- alwaysForward $ + switch (constant vul &&& after 2 ())+ (\_ -> constant True) -< ()++ dead <- isEvent ^<< edge -< hitByBall && vulnerable++ let newPlayer = [ player (lives-1) name p0 False+ | dead && lives > 0 ]++ dt <- deltas -< ()+ energy <- loopPre 5 (arr (dup . max 0 . min 5 . sumTime)) -< dt+ -- max 0 (min 5 (round (fromIntegral (playerEnergy'' ol) + dt)))++ -- Final player+ returnA -< (Object { objectName = name+ , objectKind = Player state lives vulnerable (round energy)+ , objectPos = ppos+ , objectVel = pvel+ , canCauseCollisions = True+ , collisionEnergy = 1+ }+ , dead+ , newF1Arrows ++ newPlayer)++sumTime :: (DTime, DTime) -> DTime+sumTime (dt, e) = e + dt++playerState :: Controller -> PlayerState+playerState controller =+ case (controllerLeft controller, controllerRight controller) of+ (True, _) -> PlayerLeft+ (_, True) -> PlayerRight+ _ -> PlayerStand++playerName :: String+playerName = "player"++playerProgress :: String -> Pos2D -> SF ObjectInput (Pos2D, Vel2D)+playerProgress pid p0 = proc i -> do+ -- Obtain velocity based on state and input, and obtain+ -- velocity delta to be applied to the position.+ v <- repeatSF getVelocity PlayerStand -< userInput i++ let collisionsWithBlocks = filter onlyBlocks (collisions i)++ onlyBlocks (Collision cdata) = any (playerCollisionElem . fst) cdata++ playerCollisionElem s = isBlockId s || isWallId s+ isBlockId = ("block" `isPrefixOf`)+ isWallId = ("Wall" `isSuffixOf`)++ let ev = changedVelocity pid collisionsWithBlocks+ vc = fromMaybe v ev++ (px,py) <- (p0 ^+^) ^<< alwaysForward integral -< vc++ -- Calculate actual velocity based on corrected/capped position+ v' <- derivative -< (px, py)++ returnA -< ((px, py), v')++ where++ capPlayerPos (px, py) = (px', py')+ where px' = inRange (0, width - playerWidth) px+ py' = inRange (0, height - playerHeight) py++ getVelocity :: PlayerState -> SF Controller (Vel2D, Event PlayerState)+ getVelocity pstate = stateVel pstate &&& stateChanged pstate++ stateVel :: PlayerState -> SF a Vel2D+ stateVel PlayerLeft = constant (-playerSpeed, 0)+ stateVel PlayerRight = constant (playerSpeed, 0)+ stateVel PlayerStand = constant (0, 0)++ stateChanged :: PlayerState -> SF Controller (Event PlayerState)+ stateChanged oldState = arr playerState >>> ifDiff oldState++-- *** Fire/arrows/bullets/projectiles++-- | This produces bullets that die when they hit the top of the screen.+-- There's sticky bullets and normal bullets. Sticky bullets get stuck for a+-- while before they die.+fire :: String -> Pos2D -> Bool -> ListSF ObjectInput Object+fire name (x0, y0) sticky = ListSF $ proc i -> do++ -- Calculate arrow tip+ yT <- (y0+) ^<< integral -< fireSpeed+ let y = min height yT++ -- Delay death if the fire is "sticky"+ hit <- revSwitch (never &&& fireHitCeiling) (\_ -> stickyDeath sticky) -< y++ hitBall <- arr (fireCollidedWithBall name) -< collisions i+ hitBlock <- arr (fireCollidedWithBlock name) -< collisions i++ let dead = isEvent hit || hitBall || hitBlock++ let object = Object { objectName = name+ , objectKind = Projectile+ , objectPos = (x0, y)+ , objectVel = (0, 0)+ , canCauseCollisions = True+ , collisionEnergy = 0+ }++ returnA -< (object, dead, [])++ where++ fireHitCeiling = arr (>= height) >>> edge+ fireCollidedWithBall bid = not . null . collisionMask bid ("ball" `isPrefixOf`)+ fireCollidedWithBlock bid = not . null . collisionMask bid ("block" `isPrefixOf`)++stickyDeath :: Bool -> SF a (Event ())+stickyDeath True = after 30 ()+stickyDeath False = constant (Event ())++-- *** Ball++splittingBall :: Double -> String -> Pos2D -> Vel2D -> ListSF ObjectInput Object+splittingBall size bid p0 v0 = ListSF $ timeTransformSF timeProgression' $ proc i -> do++ -- Default, just bouncing behaviour+ bo <- bouncingBall size bid p0 v0 -< i++ -- Hit fire? If so, it should split+ click <- edge <<^ ballCollidedWithFire bid -< collisions i+ let shouldSplit = isEvent click++ -- We need two unique IDs so that collisions work+ t <- localTime -< ()+ let offspringIDL = bid ++ show t ++ "L"+ offspringIDR = bid ++ show t ++ "R"++ let enforceYPositive (x,y) = (x, abs y)++ -- Position and velocity of new offspring+ let bpos = physObjectPos bo+ bvel = enforceYPositive $ physObjectVel bo+ ovel = enforceYPositive $ (\(vx,vy) -> (-vx, vy)) bvel++ -- Offspring size, unless this ball is too small to split+ let tooSmall = size <= (ballWidth / 8)+ let offspringSize = size / 2++ -- Calculate offspring, if any+ let offspringL = splittingBall offspringSize offspringIDL bpos bvel+ offspringR = splittingBall offspringSize offspringIDR bpos ovel+ offspring = if shouldSplit && not tooSmall+ then [ offspringL, offspringR ]+ else []++ -- If it splits, we just remove this one+ let dead = shouldSplit++ returnA -< (bo, dead, offspring)++ballCollidedWithFire :: ObjectName -> Objects.Collisions -> Bool+ballCollidedWithFire bid = not . null . collisionMask bid ("fire" `isPrefixOf`)++-- 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 :: Double -> String -> Pos2D -> Vel2D -> ObjectSF+bouncingBall size bid p0 v0 = repeatRevSF (progressAndBounce size bid) (p0, v0)+++-- | Calculate the future tentative position, and bounce if necessary. Pass on+-- snapshot of ball position and velocity if bouncing.+progressAndBounce :: Double -> String -> (Pos2D, Vel2D)+ -> SF ObjectInput (Object, Event (Pos2D, Vel2D))+progressAndBounce size bid (p0, v0) = proc i -> do++ -- 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.+ o <- freeBall size bid p0 v0 -< i++ -- 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+ b <- ballBounce bid -< (i, o)++ returnA -< (o, b)++-- | 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. Careful: this prevents the ball from bouncing+-- immediately after creation, which may or may not be what we want.+ballBounce :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce bid = noEvent --> ballBounce' bid++-- | 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' :: String -> SF (ObjectInput, Object) (Event (Pos2D, Vel2D))+ballBounce' bid = proc (ObjectInput ci cs, 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 collisionsWithoutBalls = filter (not . allBalls) cs+ allBalls (Collision cdata) = all (isPrefixOf "ball" . fst) cdata++ let collisionsWithoutPlayer = filter (not . anyPlayer)+ collisionsWithoutBalls+ anyPlayer (Collision cdata) = any (isPrefixOf "player" . fst) cdata++ let ev = maybeToEvent (changedVelocity bid collisionsWithoutPlayer)+ returnA -< fmap (\v -> (objectPos 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 :: Double -> String -> Pos2D -> Vel2D -> ObjectSF+freeBall size name p0 v0 = proc (ObjectInput ci cs) -> do++ -- Integrate acceleration, add initial velocity and cap speed. Resets both+ -- the initial velocity and the current velocity to (0,0) when the user+ -- presses the Halt key (hence the dependency on the controller input ci).+ vInit <- startAs v0 -< ci+ vel <- vdiffSF -< (vInit, (0, -1000.8), ci)++ -- Any free moving object behaves like this (but with+ -- acceleration. This should be in some FRP.NewtonianPhysics+ -- module)+ pos <- (p0 ^+^) ^<< integral -< vel++ let obj = Object { objectName = name+ , objectKind = Ball size+ , objectPos = pos+ , objectVel = vel+ , canCauseCollisions = True+ , collisionEnergy = 1+ }++ returnA -< obj+ where -- Spike every time the user presses the Halt key+ restartCond = spikeOn (arr controllerStop)++ -- Calculate the velocity, restarting when the user+ -- requests it.+ vdiffSF = proc (iv, acc, ci) -> do+ -- Calculate velocity difference by integrating acceleration+ -- Reset calculation when user requests to stop balls+ vd <- restartOn (arr fst >>> integral)+ (arr snd >>> restartCond) -< (acc, ci)++ -- Add initial velocity, and cap the result+ v <- arr (uncurry (^+^)) -< (iv, vd)+ let vFinal = limitNorm v (maxVNorm size)++ returnA -< vFinal++ -- Initial velocity, reset when the user requests it.+ startAs v0 = revSwitch (constant v0 &&& restartCond)+ (\_ -> startAs (0,0))
+ src/GameState.hs view
@@ -0,0 +1,42 @@+-- | 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+import FRP.Yampa (Time)++-- | 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 = GameInfo 0 0 GameLoading+ }++data GameInfo = GameInfo { gameTime :: Time+ , gameLevel :: Int+ , gameStatus :: GameStatus+ }++data GameStatus = GamePlaying+ | GameLoading+ deriving (Eq, Show)
+ src/Graphics/UI/Extra/SDL.hs view
@@ -0,0 +1,65 @@+module Graphics.UI.Extra.SDL where++import Control.Monad+import Data.IORef+import Graphics.UI.SDL++-- * Types++-- Auxiliary SDL stuff+isEmptyEvent :: Event -> Bool+isEmptyEvent NoEvent = True+isEmptyEvent _ = False++-- * SDL-based clock++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 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++-- * Rendering++renderAlignRight :: Surface -> Surface -> (Int, Int) -> IO ()+renderAlignRight screen surface (x,y) = void $ do+ let rightMargin = surfaceGetWidth screen+ w = surfaceGetWidth surface+ h = surfaceGetHeight surface+ rect = Rect (rightMargin - x - w) y w h+ blitSurface surface Nothing screen (Just rect)++renderAlignCenter :: Surface -> Surface -> IO ()+renderAlignCenter screen surface = void $ do+ let tWidth = surfaceGetWidth screen+ tHeight = surfaceGetWidth screen+ w = surfaceGetWidth surface+ h = surfaceGetHeight surface+ px = (tWidth - w) `div` 2+ py = (tHeight - h) `div` 2+ rect = Rect px py w h+ blitSurface surface Nothing screen (Just rect)
+ src/Input.hs view
@@ -0,0 +1,133 @@+-- | 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 one: mouse/keyboard combination.+--+module Input where++-- External imports+import Data.IORef+import Graphics.UI.SDL as SDL++-- Internal imports+import Control.Extra.Monad+import Data.Extra.IORef+import Graphics.UI.Extra.SDL++-- * Game controller++-- | Controller info at any given point.+data Controller = Controller+ { controllerPos :: (Double, Double)+ , controllerLeft :: Bool+ , controllerRight :: Bool+ , controllerClick :: Bool+ , controllerStop :: Bool+ , controllerPause :: Bool+ , controllerExit :: Bool+ , controllerFast :: Bool+ , controllerSlow :: Bool+ , controllerSuperSlow :: Bool+ , controllerReverse :: Bool+ , controllerHalt :: Bool+ , controllerFullscreen :: Bool+ , controllerCheckPointSave :: Bool+ , controllerCheckPointRestore :: 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 { controllerData :: (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+ nr <- newIORef defaultInfo+ return $ ControllerRef (nr, sdlGetController)+ where defaultInfo = Controller (0,0) False False -- Position and direction+ False -- Fire+ False -- Stop balls+ False -- Pause+ False -- Exit+ False False False -- Speed control+ False -- Reverse time+ False -- Halt+ False -- Fullscreen+ False -- CheckpointSave+ False -- CheckpointRestore++-- | 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)) =+ modifyIORefIO cref sensor++type ControllerDev = IO (Maybe (Controller -> IO Controller))++-- * SDL API (mid-level)++-- ** 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)++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 }+ KeyDown (Keysym { symKey = SDLK_LEFT }) -> c { controllerLeft = True }+ KeyUp (Keysym { symKey = SDLK_LEFT }) -> c { controllerLeft = False }+ KeyDown (Keysym { symKey = SDLK_RIGHT }) -> c { controllerRight = True }+ KeyUp (Keysym { symKey = SDLK_RIGHT }) -> c { controllerRight = False }+ KeyUp (Keysym { symKey = SDLK_p }) -> c { controllerPause = not (controllerPause c) }+ KeyUp (Keysym { symKey = SDLK_f }) -> c { controllerFullscreen = not (controllerFullscreen c) }+ KeyDown (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = True }+ KeyUp (Keysym { symKey = SDLK_w }) -> c { controllerSuperSlow = False }+ KeyDown (Keysym { symKey = SDLK_s }) -> c { controllerSlow = True }+ KeyUp (Keysym { symKey = SDLK_s }) -> c { controllerSlow = False }+ KeyDown (Keysym { symKey = SDLK_x }) -> c { controllerFast = True }+ KeyUp (Keysym { symKey = SDLK_x }) -> c { controllerFast = False }+ KeyDown (Keysym { symKey = SDLK_r }) -> c { controllerReverse = True }+ KeyUp (Keysym { symKey = SDLK_r }) -> c { controllerReverse = False }+ KeyDown (Keysym { symKey = SDLK_t }) -> c { controllerHalt = True }+ KeyUp (Keysym { symKey = SDLK_t }) -> c { controllerHalt = False }+ KeyDown (Keysym { symKey = SDLK_h }) -> c { controllerStop = True }+ KeyUp (Keysym { symKey = SDLK_h }) -> c { controllerStop = False }+ KeyDown (Keysym { symKey = SDLK_c }) -> c { controllerCheckPointSave = True }+ KeyUp (Keysym { symKey = SDLK_c }) -> c { controllerCheckPointSave = False }+ KeyDown (Keysym { symKey = SDLK_v }) -> c { controllerCheckPointRestore = True }+ KeyUp (Keysym { symKey = SDLK_v }) -> c { controllerCheckPointRestore = False }+ KeyDown (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = True }+ KeyUp (Keysym { symKey = SDLK_SPACE }) -> c { controllerClick = False }+ KeyDown (Keysym { symKey = SDLK_ESCAPE}) -> c { controllerExit = True }+ _ -> c+
+ src/Main.hs view
@@ -0,0 +1,42 @@+import Control.Applicative+import Data.IORef+import FRP.Yampa as Yampa+import System.Mem++import Game+import Display+import Input+import Graphics.UI.Extra.SDL++main :: IO ()+main = do++ initializeDisplay++ timeRef <- initializeTimeRef+ controllerRef <- initializeInputDevices+ res <- loadResources++ initGraphs res+ reactimate (senseInput controllerRef)+ (\_ -> do+ -- Get clock and new input+ mInput <- senseInput controllerRef+ dtSecs <- senseTime timeRef mInput+ -- trace ("Time : " ++ printf "%.5f" dtSecs) $+ return (if controllerPause mInput then 0 else dtSecs, Just mInput)+ )+ (\_ (e,c) -> do render res e+ performGC+ return (controllerExit c)+ )+ (wholeGame &&& arr id)++senseTime :: IORef Int -> Controller -> IO DTime+senseTime timeRef = \mInput ->+ let tt = if controllerSlow mInput then (/10) else id+ tt1 = if controllerSuperSlow mInput then (/100) else tt+ tt2 = if controllerFast mInput then (*10) else tt1+ tt3 = id -- if controllerReverse mInput then (\x -> -x) else id+ in (tt3 . tt2 . milisecsToSecs) <$> senseTimeRef timeRef+
+ src/ObjectSF.hs view
@@ -0,0 +1,44 @@+-- | 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).+module ObjectSF where++import FRP.Yampa++import Objects+import Input++-- | Objects are defined as transformations that take 'ObjectInput' signals and+-- return 'ObjectOutput' signals.+type ObjectSF = SF ObjectInput Object++-- | In order to determine its new output, an object needs to know the user's+-- desires ('userInput'), whether there have been any collisions+-- ('collisions').+--+-- The reason for depending on 'Collisions' is that objects may ``change''+-- when hit (start moving in a different direction).+data ObjectInput = ObjectInput+ { userInput :: Controller+ , collisions :: Collisions+ }++-- -- | 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.).+-- }++-- -- | 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]+--
+ src/Objects.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Game objects and collisions.+module Objects where++import Control.Arrow ((***))+import Data.Maybe (listToMaybe)+import FRP.Yampa.VectorSpace++import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++import Constants++type Collision = C.Collision ObjectName+type Collisions = C.Collisions ObjectName++-- * Objects++type Objects = [Object]+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+ , canCauseCollisions :: !Bool+ , collisionEnergy :: !Double+ }+ deriving (Show)++findPlayer = listToMaybe . filter isPlayer++isBall :: Object -> Bool+isBall o = case objectKind o of+ Ball _ -> True+ _ -> False++isPlayer :: Object -> Bool+isPlayer o = case objectKind o of+ Player {} -> True+ _ -> False++-- | The kind of object and any size properties.+data ObjectKind = Ball !Double -- radius+ | Player !PlayerState !Int {- lives -} !Bool {- Vulnerable -} !Int {- energy -}+ | Side !Side+ | Projectile+ | Block !Size2D+ -- | PowerUp PowerUp+ deriving (Show,Eq)++data PlayerState = PlayerRight+ | PlayerLeft+ | PlayerStand+ deriving (Eq, Show)++playerEnergy :: Object -> Int+playerEnergy o = case objectKind o of+ p@(Player _ _ _ e) -> e+ _ -> 0++-- Partial function!+objectSize :: Object -> Size2D+objectSize object = case objectKind object of+ (Ball r) -> let w = 2*r in (w, w)+ (Player {}) -> (playerWidth, playerHeight)+ (Block s) -> s++instance PhysicalObject Object String Shape where+ physObjectPos = objectPos+ physObjectVel = objectVel+ physObjectElas = collisionEnergy+ physObjectShape = objShape+ physObjectCollides = canCauseCollisions+ physObjectId = objectName+ physObjectUpdatePos = \o p -> o { objectPos = p }+ physObjectUpdateVel = \o v -> o { objectVel = v }++objShape :: Object -> Shape+objShape obj = case objectKind obj of+ Ball r -> Circle p r+ Side s -> SemiPlane p s+ Player {} -> Rectangle p (playerWidth, playerHeight)+ Projectile -> Rectangle (px - 5, 0) (10, py)+ Block s@(w,h) -> Rectangle (px, py) s+ where p@(px,py) = objectPos obj
+ src/Objects/Walls.hs view
@@ -0,0 +1,101 @@+{-# 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 two sections:+--+-- - A collection of gameplay SFs, which control the core game loop, carry+-- out collision detection, , 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 Objects.Walls where++-- External imports+import Prelude hiding (id, (.))+import Control.Category (id, (.))+import Data.List+import Data.Maybe+import Debug.Trace+import FRP.Yampa+import FRP.Yampa.Extra+import FRP.Yampa.Switches++-- General-purpose internal imports+import Data.Extra.Ord+import Data.Extra.VectorSpace+import Physics.Oscillator+import Physics.TwoDimensions.Collisions as Collisions+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.GameCollisions+import Physics.TwoDimensions.Shapes+import Physics.TwoDimensions.PhysicalObjects++-- Internal iports+import Constants+import GameState+import Input+import Objects+import ObjectSF++-- * 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 = arr $ \(ObjectInput ci cs) ->+ Object { objectName = name+ , objectKind = Side side+ , objectPos = pos+ , objectVel = (0,0)+ , canCauseCollisions = False+ , collisionEnergy = 0+ }
+ src/Physics/TwoDimensions/Collisions.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts #-}+-- | A trivial collision subsystem.+--+-- Based on the physics module, it determines the side of collision+-- between shapes.+module Physics.TwoDimensions.Collisions where++import Data.Extra.Num+import Data.Maybe+import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++import Collisions++-- * Collision points+data CollisionPoint = CollisionSide Side+ | CollisionAngle Double++-- | Calculates the collision side of a shape+-- that collides against another.+--+-- PRE: the shapes do collide. Use 'overlapShape' to check.+shapeCollisionPoint :: Shape -> Shape -> CollisionPoint+shapeCollisionPoint (Circle p1 _) (Circle p2 _) = CollisionAngle angle+ where (px,py) = p2 ^-^ p1+ angle = atan2 py px+shapeCollisionPoint (Circle _ _) (SemiPlane _ s2) = CollisionSide s2+shapeCollisionPoint (Circle p1 s1) (Rectangle p2 s2) =+ velCollitionSide $ fromJust $ responseCircleAABB (p1, s1) (rectangleToCentre (p2, s2))++shapeCollisionPoint (SemiPlane _ s1) (Circle _ _ ) = CollisionSide (oppositeSide s1)+shapeCollisionPoint (SemiPlane _ _) (SemiPlane _ s2) = CollisionSide s2+shapeCollisionPoint p@(SemiPlane _ _) r@(Rectangle _ _) = let CollisionSide side = shapeCollisionPoint r p+ in CollisionSide (oppositeSide side)++shapeCollisionPoint r@(Rectangle _ _) c@(Circle _ _) = let CollisionSide side = shapeCollisionPoint c r+ in CollisionSide (oppositeSide side)+shapeCollisionPoint r@(Rectangle _ _) (SemiPlane p2 s2) = let (p2', s2') = semiplaneRectangle p2 s2+ in shapeCollisionPoint r (Rectangle p2' s2')+shapeCollisionPoint (Rectangle p1 s1) (Rectangle p2 s2) =+ velCollitionSide $ fromJust $ responseAABB2 (p1, s1) (p2, s2)++velCollitionSide (vx, vy)+ | vx < 0 && abs vx > abs vy = CollisionSide RightSide+ | vx > 0 && abs vx > abs vy = CollisionSide LeftSide+ | vy > 0 && abs vx < abs vy = CollisionSide TopSide+ -- | vy > 0 && abs vx < abs vy+ | otherwise = CollisionSide BottomSide++-- * Collisions+type Collisions k = [Collision k]++-- | 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 k = Collision+ { collisionData :: [(k, Vel2D)] } -- ObjectId x Velocity+ deriving Show++detectCollision :: (PhysicalObject o k Shape) => o -> o -> Maybe (Collision k)+detectCollision obj1 obj2+ | overlap obj1 obj2+ = case (physObjectShape obj1, physObjectShape obj2) of+ (Circle _ _, Circle _ _) ->+ if vrn < 0+ then Just response+ else Nothing+ _ -> Just response+ | otherwise = Nothing++ where response = collisionResponseObj obj1 obj2+ relativeP = physObjectPos obj1 ^-^ physObjectPos obj2+ relativeV = physObjectVel obj1 ^-^ physObjectVel obj2+ -- If the inner product between the relative position and velocity+ -- is negative, then the two objects are approaching each other.+ -- Note that there is no collision if vrn = 0. This could be+ -- because the objects are at the same position and thus cannot get+ -- any closer. Or because their relative velocity is 0 and thus are+ -- not approaching for that reason. This, if there *is* a collision,+ -- then we know that both the relative position and velocity is non 0,+ -- and it is safe to e.g. normalize the relative position as is done+ -- in "correctVel" below.+ vrn = relativeV `dot` relativeP++ -- HN 2016-04-26: Old code: Problematic if same positions! But all we+ -- want to know here is if the objects are approaching each other.+ -- For this, all that matters is the sign of the inner product. There+ -- is no need to normalize the relative position!+ --+ -- colNormal = normalize (physObjectPos obj1 ^-^ physObjectPos obj2)+ -- relativeV = physObjectVel obj1 ^-^ physObjectVel obj2+ -- vrn = relativeV `dot` colNormal++overlap :: PhysicalObject o k Shape => o -> o -> Bool+overlap obj1 obj2 =+ overlapShape (physObjectShape obj1) (physObjectShape obj2)++collisionPoint :: PhysicalObject o k Shape => o -> o -> CollisionPoint+collisionPoint obj1 obj2 =+ shapeCollisionPoint (physObjectShape obj1) (physObjectShape obj2)++collisionResponseObj :: PhysicalObject o k Shape => o -> o -> Collision k+collisionResponseObj o1 o2 = Collision $+ map objectToCollision [(o1, collisionPt, o2), (o2, collisionPt', o1)]+ where+ collisionPt = collisionPoint o1 o2+ collisionPt' = collisionPoint o2 o1++ objectToCollision (o,pt,o') =+ ( physObjectId o+ , correctVel (physObjectPos o) (physObjectPos o')+ (physObjectVel o) (physObjectVel o')+ pt (physObjectElas o)+ )++correctVel :: Pos2D -> Pos2D -> Vel2D -> Vel2D -> CollisionPoint -> Double -> Vel2D+-- Specialised cases: just more optimal execution+correctVel _p1 _p2 v1 _ _ 0 = v1+-- Collision against a wall+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide TopSide) e = (e * v1x, e * ensurePos v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide BottomSide) e = (e * v1x, e * ensureNeg v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide LeftSide) e = (e * ensurePos v1x, e * v1y)+correctVel _p1 _p2 (v1x,v1y) _ (CollisionSide RightSide) e = (e * ensureNeg v1x, e * v1y)+-- General case+correctVel p1 p2 (v1x,v1y) (v2x, v2y) (CollisionAngle _) e = (v1x, v1y) ^+^ ((e * j) *^ colNormal)+ where colNormal = normalize (p1 ^-^ p2)+ relativeV = (v1x,v1y) ^-^ (v2x,v2y)+ vrn = relativeV `dot` colNormal+ j = (-1) *^ vrn / (colNormal `dot` colNormal)++-- | 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 :: Eq n => n -> Collisions n -> Maybe Vel2D+changedVelocity name cs =+ case concatMap (filter ((== name) . fst) . collisionData) cs of+ [] -> Nothing+ (_, v') : _ -> Just v'+ -- vs -> Just (foldl (^+^) (0,0) (map snd vs))++-- | True if the velocity of the object has been changed by any collision.+inCollision :: Eq n => n -> Collisions n -> Bool+inCollision name cs = isJust (changedVelocity name cs)++-- | True if the two objects are colliding with one another.+inCollisionWith :: Eq n => n -> n -> Collisions n -> Bool+inCollisionWith nm1 nm2 cs = any both cs+ where+ both (Collision nmvs) =+ any ((== nm1) . fst) nmvs && any ((== nm2) . fst) nmvs++-- * Apply an ID-based collision mask+collisionMask :: Eq id+ => id -> (id -> Bool) -> Collisions id -> Collisions id+collisionMask cId mask = onCollisions ( filter (any (mask . fst))+ . filter (any ((== cId).fst))+ )++ where onCollisions :: ([[(id, Vel2D)]] -> [[(id, Vel2D)]])+ -> Collisions id -> Collisions id+ onCollisions f = map Collision . f . map collisionData
+ src/Physics/TwoDimensions/Dimensions.hs view
@@ -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)
+ src/Physics/TwoDimensions/GameCollisions.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts #-}+-- | 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 Physics.TwoDimensions.GameCollisions where++import Data.Foldable+import Prelude hiding (concatMap)+import Data.List hiding (concatMap)+import Data.Maybe+import Physics.TwoDimensions.Collisions+import qualified Physics.TwoDimensions.Collisions as C+import Physics.TwoDimensions.PhysicalObjects+import Physics.TwoDimensions.Shapes++-- | 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 :: Foldable t => (Eq n , PhysicalObject o n Shape) => t o -> Collisions n+detectCollisions objsT = flattened+ where -- Eliminate empty collision sets+ -- TODO: why is this really necessary?+ flattened = filter collisionNotEmpty 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 physObjectCollides $ toList objsT++ -- Is the collision set empty?+ collisionNotEmpty (C.Collision n) = not (null n)++-- | Detect collisions between each moving object and+-- every other object.+detectCollisions' :: (Foldable t, Foldable u) => (Eq n, PhysicalObject o n Shape) => t o -> u o -> [Collision n]+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'' :: Foldable t => (Eq n, PhysicalObject o n Shape) => t o -> o -> [Collision n]+detectCollisions'' objsT m = concatMap (detectCollisions''' m) (toList 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''' :: (Eq n, PhysicalObject o n Shape) => o -> o -> [Collision n]+detectCollisions''' m o+ | physObjectId m == physObjectId o = [] -- Same object -> no collision+ | otherwise = maybeToList (detectCollision m o)
+ src/Physics/TwoDimensions/PhysicalObjects.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Physics.TwoDimensions.PhysicalObjects where++import Physics.TwoDimensions.Dimensions++class Eq b => PhysicalObject a b c | a -> b, a -> c where+ physObjectPos :: a -> Pos2D+ physObjectVel :: a -> Vel2D+ physObjectElas :: a -> Double+ physObjectShape :: a -> c+ physObjectCollides :: a -> Bool+ physObjectId :: a -> b+ physObjectUpdatePos :: a -> Pos2D -> a+ physObjectUpdateVel :: a -> Vel2D -> a
+ src/Physics/TwoDimensions/Shapes.hs view
@@ -0,0 +1,66 @@+-- | 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.Shapes where++import FRP.Yampa.VectorSpace+import Physics.TwoDimensions.Dimensions++import Constants+import Collisions++-- | Side of a rectangle+data Side = TopSide | BottomSide | LeftSide | RightSide+ deriving (Eq,Show)++-- | Opposite side+--+-- 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++data Shape = Rectangle Pos2D Size2D -- A corner and the whole size+ | Circle Pos2D Double -- Position and radius+ | SemiPlane Pos2D Side --++-- | 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 (Circle p1 s1) (Circle p2 s2) = (dist - (s1 + s2)) < sigma+ where (dx, dy) = p2 ^-^ p1+ dist = sqrt (dx**2 + dy**2)+ sigma = 1+overlapShape (Circle (p1x,p1y) s1) (SemiPlane (px,py) side) = case side of+ LeftSide -> p1x - s1 <= px+ RightSide -> p1x + s1 >= px+ TopSide -> p1y - s1 <= py+ BottomSide -> p1y + s1 >= py+overlapShape s@(SemiPlane _ _) c@(Circle _ _) = overlapShape c s+overlapShape r@(Rectangle _ _) c@(Circle _ _) = overlapShape c r+overlapShape (Circle p1 s1) (Rectangle p2 s2) =+ circleAABBOverlap (p1,s1) (rectangleToCentre (p2,s2))+overlapShape (Rectangle p1 s1) (Rectangle p2 s2) =+ overlapsAABB2 (rectangleToCentre (p1, s1)) (rectangleToCentre (p2, s2))+overlapShape (Rectangle p1 s1) (SemiPlane p2 side2) =+ let (p2', s2') = semiplaneRectangle p2 side2+ in overlapsAABB2 (rectangleToCentre (p1, s1)) (rectangleToCentre (p2', s2'))+overlapShape p@(SemiPlane _ _) r@(Rectangle _ _) = overlapShape r p+overlapShape _ _ = False -- Not really, it's just that we don't care++semiplaneRectangle :: Pos2D -> Side -> (Pos2D, (Double, Double))+semiplaneRectangle p2 s2 = case s2 of+ LeftSide -> (p2 ^-^ (100, 100), (100, height + 200))+ RightSide -> (p2 ^-^ (0, 100), (100, height + 200))+ TopSide -> (p2 ^-^ (100, 100), (width + 200, 100))+ BottomSide -> (p2 ^-^ (100, 0), (width + 200, 100))++rectangleToCentre ((px, py), (sw, sh)) = ((px + (sw / 2), py + (sh / 2)), (sw / 2, sh / 2))
+ src/Resources.hs view
@@ -0,0 +1,10 @@+module Resources where++import qualified Graphics.UI.SDL.TTF as TTF++-- import Game.Audio++data Resources = Resources+ { resFont :: TTF.Font+ , miniFont :: TTF.Font+ }