packages feed

YACPong (empty) → 0.1

raw patch · 19 files changed

+1226/−0 lines, 19 filesdep +SDLdep +SDL-imagedep +SDL-mixersetup-changedbinary-added

Dependencies added: SDL, SDL-image, SDL-mixer, SDL-ttf, base, data-accessor-transformers, fclabels, monads-fd, random, transformers

Files

+ Collision.hs view
@@ -0,0 +1,77 @@+{-+    The MIT License+    +    Copyright (c) 2010 Korcan Hussein+    +    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:+    +    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.+    +    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Collision where++import Vector2++class Collision a b where+    intersect :: a -> b -> Bool++newtype Bounds = Bounds { sides :: (Float,Float,Float,Float) }++instance Collision Bounds Bounds where+    Bounds (ax, ay, aw, ah) `intersect` Bounds (bx, by, bw, bh)+        | t1 > bw || (-t1) > aw = False+        | t2 > bh || (-t2) > ah = False+        | otherwise = True  +     where t1 = ax - bx+           t2 = ay - by++-- Dynamic seperating-axis test+intersectMoving :: Bounds -> Bounds -> Vector2f -> Vector2f -> Maybe (Float,Float)+intersectMoving a@(Bounds (ax, ay, aw, ah)) b@(Bounds (bx, by, bw, bh)) va vb+    | intersect a b = Just (0,0)+    | otherwise = do+        let v = vb `sub` va+        -- test x-axis+        (t1, t2) <- test (fst v) 0 1 ax maxAx bx maxBx        +        -- test y-axis+        test (snd v) t1 t2 ay maxAy by maxBy++ where maxAx = ax + aw+       maxAy = ay + ah+       maxBx = bx + bw+       maxBy = by + bh+       test vi tfirst tlast aMin aMax bMin bMax =+            case test1 vi tfirst tlast aMin aMax bMin bMax of+                Just (t1, t2) -> if t1 > t2 then Nothing else Just (t1,t2)+                _ -> Nothing+       test1 vi tfirst tlast aMin aMax bMin bMax+        | vi < 0.0 = if bMax < aMin+                    then Nothing -- no-interesection will occur+                    else+                        let t1 = if aMax < bMin then max ((aMax - bMin) / vi) tfirst else tfirst+                            t2 = if bMax > aMin then min ((aMin - bMax) / vi) tlast else tlast+                        in Just (t1,t2)+        | vi > 0.0 = if bMin > aMax+                    then Nothing -- no-interesection will occur+                    else+                        let t1 = if bMax < aMin then max ((aMin - bMax) / vi) tfirst else tfirst+                            t2 = if aMax > bMin then min ((aMax - bMin) / vi) tlast else tlast+                        in Just (t1,t2)+        | otherwise = -- zero component+                    if bMax < aMin || bMin > aMax+                        then Nothing -- no-interesection+                        else Just (max 0.0 tfirst, min 1.0 tlast) 
+ Consts.hs view
@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+--+-- Module      :  Consts+-- Copyright   :  Copyright (c) 2010 Korcan Hussein+-- License     :  MIT+--+-- Maintainer  :  korcan_h@hotmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+module Consts where++import Graphics.UI.SDL.Color++screenBpp :: Int+screenBpp    = 32++screenWidth, screenHeight :: Float+screenWidth  = 640+screenHeight = 480+++halfHeight, halfWidth :: Float+halfHeight = screenHeight / 2+halfWidth  = screenWidth / 2++paddleW, paddleH, ballW, ballH :: Float+paddleW = 22+paddleH = 96+ballW   = 8+ballH   = 8++paddleVel :: Float+paddleVel = 400++secs :: Float+secs = 1.0 / 1000.0++textColor :: Color+textColor = Color 0xFF 0xFF 0xFF++degToRad :: Float+degToRad = pi / 180++ballVel :: Float+ballVel = 350
+ Draw.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+--+-- Module      :  Draw+-- Copyright   :  Copyright (c) 2010 Korcan Hussein+-- License     :  MIT+--+-- Maintainer  :  korcan_h@hotmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------+--+--    The MIT License+--+--    Copyright (c) 2010 Korcan Hussein.+--+--    Permission is hereby granted, free of charge, to any person obtaining a copy+--    of this software and associated documentation files (the "Software"), to deal+--    in the Software without restriction, including without limitation the rights+--    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+--    copies of the Software, and to permit persons to whom the Software is+--    furnished to do so, subject to the following conditions:+--+--    The above copyright notice and this permission notice shall be included in+--    all copies or substantial portions of the Software.+--+--    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+--    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+--    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+--    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+--    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+--    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+--    THE SOFTWARE.+--+{-# LANGUAGE FlexibleContexts #-}+module Draw (+    render,+    renderWin,+    renderPaused+) where++import Prelude hiding (id, (.), mod, init)+import Control.Category++import Control.Monad.Reader+import Control.Monad.Trans++import Data.Record.Label++import Graphics.UI.SDL hiding (flip)+import qualified Graphics.UI.SDL as SDL (flip)++import Graphics.UI.SDL.TTF++import Labels+import Surface+import GameState+import GameEnv+import Consts++render :: GameEnv ()+render = do+    screen <- askM screen+    liftIO $ clear screen 0x00 0x00 0x00++    drawNet+    drawPaddle 0+    drawPaddle 1+    drawBall++    drawScore++    liftIO $ SDL.flip screen++renderWin :: GameEnv ()+renderWin = do+    screen <- askM screen+    liftIO $ clear screen 0x00 0x00 0x00++    drawNet+    drawPaddle 0+    drawPaddle 1+    drawScore++    liftIO $ SDL.flip screen++renderPaused :: GameEnv ()+renderPaused = do+    screen <- askM screen+    liftIO $ clear screen 0x00 0x00 0x00++    --drawNet+    drawPaddle 0+    drawPaddle 1+    drawBall+    drawScore+    drawPaused+    liftIO $ SDL.flip screen++blitScreen :: (MonadIO m, MonadReader GameConfig m) => Int -> Int -> Surface -> Maybe Rect -> m ()+blitScreen x y s r = do+    screen <- askM screen+    applySurface' x y s screen r+{-# INLINE blitScreen #-}++drawNet :: GameEnv ()+drawNet = do+    dst <- askM screen+    liftIO $ drawLine dst (x,0) (screenHeight'-1) 2 Vertical $ Pixel 0xFFFFFFFF+ where screenHeight' = truncate screenHeight+       screenWidth'  = truncate screenWidth+       x = screenWidth' `div` 2+++drawPaddle :: Int -> GameEnv ()+drawPaddle paddleIdx = do+    ps      <- askM paddleSprite+    (px,py) <- getM (pPos . paddlel)+    blitScreen (truncate px) (truncate py) ps Nothing+ where paddlel = if paddleIdx == 0 then paddle1 else paddle2++drawBall :: GameEnv ()+drawBall = do+    bs      <- askM ballSprite+    (bx,by) <- getM (pos . ball)+    blitScreen (truncate bx) (truncate by) bs Nothing++drawScore :: GameEnv ()+drawScore = do+    f   <- askM font+    p1c <- liftM show $ getM $ player1Count . stats+    p2c <- liftM show $ getM $ player2Count . stats++    p1Score <- liftIO $ renderTextSolid f p1c textColor+    p2Score <- liftIO $ renderTextSolid f p2c textColor++    blitScreen (halfWidth' - 50 - surfaceGetWidth p1Score) 20 p1Score Nothing+    blitScreen (halfWidth' + 50) 20 p2Score Nothing+ where+       halfWidth' = truncate halfWidth++drawPaused :: GameEnv ()+drawPaused = do+    pSprite <- askM pausedSprite+    blitScreen (halfWidth' - surfaceGetWidth pSprite `div` 2) (halfHeight' - surfaceGetHeight pSprite `div` 2) pSprite Nothing+ where+       halfWidth'  = truncate halfWidth+       halfHeight' = truncate halfHeight
+ GameEnv.hs view
@@ -0,0 +1,41 @@+{-+    The MIT License++    Copyright (c) 2010 Korcan Hussein.++    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:++    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.++    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module GameEnv+(+    GameEnv(),+    runGame,+) where++import Control.Monad.State+import Control.Monad.Reader++import GameState++type GameState = StateT GameData IO+newtype GameEnv a = GameEnv { runEnv :: ReaderT GameConfig GameState a }+    deriving (Monad, MonadIO, MonadReader GameConfig, MonadState GameData)++runGame :: GameConfig -> GameData -> GameEnv a -> IO (a, GameData)+runGame config state (GameEnv env) = (runStateT . runReaderT env) config state
+ GameState.hs view
@@ -0,0 +1,133 @@+{-+    The MIT License++    Copyright (c) 2010 Korcan Hussein.++    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:++    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.++    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts #-}+module GameState where++import Prelude hiding (id, (.), mod)++import System.Random++import Control.Category+import Control.Monad.Reader+import Control.Monad.State hiding (get)+--import qualified Control.Monad.State as MState (get,put)++import Data.Word+import Data.Record.Label++import Graphics.UI.SDL (Surface)+import Graphics.UI.SDL.TTF (Font)+import Graphics.UI.SDL.Mixer (Chunk)++import Labels+import Vector2+import Collision+import Timer+import Consts++--type Vector2f = (Float, Float)+data Player = Player1 | Player2+    deriving (Eq, Show)++data GameLoopState =+      Win Player+    | Init Player+    | Play+    | Paused++data Ball = Ball {+    _pos :: Vector2f,+    _vel :: Vector2f+} deriving (Eq, Show)++data Paddle = Paddle {+    _pPos    :: Vector2f,+    _yVel    :: Float,+    _lastPos :: Float+} deriving (Eq, Show)++data Stats = Stats {+    _player1Count :: Integer,+    _player2Count :: Integer+} deriving (Eq, Show)++data GameData = GameData {+    _paddle1   :: Paddle,+    _paddle2   :: Paddle,+    _ball      :: Ball,+    _stats     :: Stats,+    _ticker    :: Timer,+    _state     :: GameLoopState,+    _randGen   :: StdGen+}++data GameConfig = GameConfig {+    _font         :: Font,+    _screen       :: Surface,+    _ballSprite   :: Surface,+    _paddleSprite :: Surface,+    _pausedSprite :: Surface,+    _wallBounce   :: Chunk,+    _paddleBounce :: Chunk,+    _winSound     :: Chunk+}++$(mkLabels [''Ball, ''Paddle, ''Stats, ''GameData, ''GameConfig])++getTicksM :: (MonadIO m, MonadState GameData m) => m Word32+getTicksM = getM ticker >>= getTicks++stopTicks :: (MonadIO m, MonadState GameData m) => m ()+stopTicks = modM_ ticker stop++startTicks :: (MonadIO m, MonadState GameData m) => m ()+startTicks = modM_ ticker start++resetTicks :: (MonadIO m, MonadState GameData m) => m ()+resetTicks = start timer >>= setM ticker++newBall :: RandomGen g => Player -> Vector2f -> g -> (Ball,g)+newBall p pos g = (Ball pos vel, g')--(-141.4,-141.4)+ where (deg,g') = randomR (135,225) g+       angle = deg * degToRad+       vel = (xdir * ballVel * cos angle, ballVel * sin angle)+       xdir = case p of+                Player1 -> 1+                Player2 -> (-1)++newBallM :: (MonadState GameData m) => Player -> Vector2f -> m Ball+newBallM p pos = do+    rgen <- getM randGen+    let (b, rgen') = newBall p pos rgen+    randGen =: rgen'+    return b++gameData :: Vector2f -> Vector2f -> Vector2f -> Timer -> GameData+gameData p1 p2 b ticks = GameData (Paddle p1 0 p1LastPos) (Paddle p2 0 p2LastPos) (Ball b (200.0,0)) (Stats 0 0) ticks (Init Player1) $ mkStdGen 0+ where p1LastPos = snd p1+       p2LastPos = snd p2++mapPlayer :: Player -> Stats :-> Integer+mapPlayer Player1 = player1Count+mapPlayer Player2 = player2Count
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License
+
+Copyright (c) 2010 Korcan Hussein
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
+ Labels.hs view
@@ -0,0 +1,40 @@+{-+    The MIT License+    +    Copyright (c) 2010 Korcan Hussein+    +    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:+    +    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.+    +    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Labels where++import Prelude hiding (id, (.), mod)+import Control.Category+import Control.Monad.Reader+import Control.Monad.State hiding (get)++import Data.Record.Label++askM :: MonadReader r m => (r :-> b) -> m b+askM = asks . get+{-# INLINE askM #-}++modM_ :: MonadState s m => (s :-> b) -> (b -> m b) -> m ()+modM_ label act = getM label >>= act >>= setM label+{-# INLINE modM_ #-}
+ README view
@@ -0,0 +1,1 @@+YACPong.
======
Author: Korcan Hussein

Install
-------

cabal configure
cabal build
cabal install

Or:

runhaskell Setup.hs configure --user
runhaskell Setup.hs build
runhaskell Setup.hs install

Keys
-------

W/S      - to move the paddle up/down
P          - Pauses the game. 
ESCAPE - exit the game. 

Known Issues.
-----------------

In this version collision with the side of the paddle is detected but there is no proper response so sometimes the ball can not continue moving.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Sound.hs view
@@ -0,0 +1,86 @@+--    The MIT License+--+--    Copyright (c) 2010 Korcan Hussein.+--+--    Permission is hereby granted, free of charge, to any person obtaining a copy+--    of this software and associated documentation files (the "Software"), to deal+--    in the Software without restriction, including without limitation the rights+--    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+--    copies of the Software, and to permit persons to whom the Software is+--    furnished to do so, subject to the following conditions:+--+--    The above copyright notice and this permission notice shall be included in+--    all copies or substantial portions of the Software.+--+--    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+--    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+--    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+--    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+--    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+--    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+--    THE SOFTWARE.++-----------------------------------------------------------------------------+--+-- Module      :  Sound+-- Copyright   :  Copyright (c) 2010 Korcan Hussein.+-- License     :  MIT+--+-- Maintainer  :  korcan_h@hotmail.com+-- Stability   :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Sound (+    playWallSound,+    playPaddleSound,+    playWinSound,+    isPlayingWin+) where++import Control.Monad+import Control.Monad.Trans++import Labels+import GameState+import GameEnv++import Graphics.UI.SDL.Mixer++-- default number of channels available in SDL-mixer is 8+wallSoundID   = 0+paddleSoundID = 1+winSoundID    = 2++playWallSound :: GameEnv ()+playWallSound = do+    wb <- askM wallBounce+--    playing <- liftIO $ isChannelPlaying winSoundID+--    when (not playing) $ do+    liftIO $ playChannel wallSoundID wb 0+    return ()++playPaddleSound :: GameEnv ()+playPaddleSound = do+    pb <- askM paddleBounce+--    playing <- liftIO $ isChannelPlaying paddleSoundID+--    when (not playing) $ do+    liftIO $ playChannel paddleSoundID pb 0+    return ()++playWinSound :: GameEnv()+playWinSound = do+    ws <- askM winSound+    liftIO $ haltChannel winSoundID+    liftIO $ playChannel winSoundID ws 0+    return ()++isPlayingWin :: GameEnv Bool+isPlayingWin = do+    ws <- askM winSound+    currPlaying <- liftIO $ getChunk winSoundID+    isplaying <- liftIO $ isChannelPlaying winSoundID+    return $ ws == currPlaying && isplaying
+ Surface.hs view
@@ -0,0 +1,97 @@+{-+    The MIT License+    +    Copyright (c) 2010 Korcan Hussein+    +    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:+    +    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.+    +    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+module Surface where++import Foreign++import Control.Monad+import Control.Monad.Trans++import Graphics.UI.SDL+import Graphics.UI.SDL.Image++isInside :: Rect -> Int -> Int -> Bool+isInside (Rect sx sy w h) x y =  x > sx && x < (sx + w) && y > sy && y < (sy + h)++loadImage :: String -> Maybe (Word8, Word8, Word8) -> IO Surface+loadImage filename colorKey = load filename >>= displayFormat >>= setColorKey' colorKey++setColorKey' :: Maybe (Word8,Word8,Word8) -> Surface -> IO Surface+setColorKey' Nothing s = return s+setColorKey' (Just (r, g, b)) surface = mapRGB' surface r g b >>= setColorKey surface [SrcColorKey] >> return surface++applySurface :: Int -> Int -> Surface -> Surface -> Maybe Rect -> IO ()+applySurface x y src dst clip = blitSurface src clip dst offset >> return ()+ where offset = Just Rect { rectX = x, rectY = y, rectW = 0, rectH = 0 }++applySurface' :: MonadIO m => Int -> Int -> Surface -> Surface -> Maybe Rect -> m ()+applySurface' x y src dst = liftIO . applySurface x y src dst++mapRGB' :: Surface -> Word8 -> Word8 -> Word8 -> IO Pixel+mapRGB' = mapRGB . surfaceGetPixelFormat++clear :: Surface -> Word8 -> Word8 -> Word8 -> IO ()+clear surf r g b = do+    jrect      <- Just `liftM` getClipRect surf+    clearColor <- mapRGB' surf r g b+    fillRect surf jrect clearColor+    return ()++getPixel32 :: Surface -> Int -> Int -> IO Pixel+getPixel32 s x y = do+    ps <- surfaceGetPixels s+    Pixel `liftM` peekElemOff (castPtr ps :: Ptr Word32) offset+ where offset = y * (fromIntegral $ surfaceGetPitch s `div` 4) + x++setPixel32 :: Surface -> Int -> Int -> Pixel -> IO ()+setPixel32 s x y (Pixel pixel) = do+    ps <- surfaceGetPixels s+    pokeElemOff (castPtr ps :: Ptr Word32) offset pixel+ where offset = y * (fromIntegral $ surfaceGetPitch s `div` 4) + x++withLock :: MonadIO m => Surface -> m () -> m ()+withLock s act = do+    liftIO $ lockSurface s+    act+    liftIO $ unlockSurface s++type Point2 = (Int,Int)+data LineDir = Vertical | Horizontal++drawLine :: Surface -> Point2 -> Int -> Int -> LineDir -> Pixel -> IO ()+drawLine dst (x,y) len thickness Horizontal colour =+    withLock dst $+        forM_ [(r,c) | c <- [yStart..yEnd], r <- [x..(x + len)]] $ \(r,c) ->+            setPixel32 dst r c colour+ where halfLen = thickness `div` 2+       yStart  = max (y - halfLen) 0+       yEnd    = min (yStart + thickness) $  surfaceGetHeight dst++drawLine dst (x,y) len thickness Vertical colour =+    withLock dst $+        forM_ [(r,c) | r <- [xStart..xEnd], c <- [y..(y + len)]] $ \(r,c) ->+            setPixel32 dst r c colour+ where halfLen = thickness `div` 2+       xStart  = max (x - halfLen) 0+       xEnd    = min (xStart + thickness) $ surfaceGetWidth dst
+ Timer.hs view
@@ -0,0 +1,52 @@+{-+    The MIT License+    Copyright (c) 2010 Korcan Hussein+    +    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:+    +    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.+    +    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+module Timer (Timer(), timer, start, stop, getTicks, isPaused) where++import Control.Monad.Trans++import qualified Graphics.UI.SDL.Time as SdlTime+import Data.Word++data Timer = Timer { startTicks :: Word32, stopTicks :: Word32 }++timer :: Timer+timer = Timer 0 0++start :: MonadIO m => Timer -> m Timer+start Timer { stopTicks=pausedTicks } = getTicksIO >>= \currTick -> return $ Timer (currTick - pausedTicks) 0++stop :: MonadIO m => Timer -> m Timer+stop t@Timer { startTicks = st }+    | isPaused t = return t+    | otherwise  = getTicksIO >>= \currTick -> return t { stopTicks=currTick - st }++getTicks :: MonadIO m => Timer -> m Word32+getTicks t@Timer { startTicks = st }+    | isPaused t = return $ stopTicks t+    | otherwise  = getTicksIO >>= \currTick -> return $ currTick - st++isPaused :: Timer -> Bool+isPaused Timer { stopTicks=st } = st > 0++getTicksIO :: MonadIO m => m Word32+getTicksIO = liftIO SdlTime.getTicks
+ Vector2.hs view
@@ -0,0 +1,50 @@+{-+    The MIT License+    +    Copyright (c) 2010 Korcan Hussein+    +    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:+    +    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.+    +    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+module Vector2 where++type Vector2f = (Float,Float)++magSq,mag :: Vector2f -> Float+normalize :: Vector2f -> Vector2f+mul :: Float -> Vector2f -> Vector2f+add :: Vector2f -> Vector2f -> Vector2f+sub :: Vector2f -> Vector2f -> Vector2f+dot :: Vector2f -> Vector2f -> Float+reflect :: Vector2f -> Vector2f -> Vector2f++s `mul` (x, y) =  (s * x, s * y)++(lx, ly)`sub` (rx, ry) = (lx - rx, ly - ry)++(lx, ly)`add` (rx, ry) = (lx + rx, ly + ry)++(lx, ly) `dot` (rx, ry) = (lx * rx) + (ly * ry)++reflect v n = v `sub` (2 ` mul` ((n `dot` v) `mul` n))++magSq v = v `dot` v+mag v = sqrt $ magSq v++normalize v = len `mul` v+ where len = 1.0 / mag v
+ YACPong.cabal view
@@ -0,0 +1,52 @@+name: YACPong+version: 0.1+cabal-version: >=1.4+build-type: Simple+license: MIT+license-file: LICENSE+copyright: Copyright (c) 2010 Korcan Hussein+maintainer: korcan_h@hotmail.com+build-depends: SDL -any, SDL-image -any, SDL-mixer -any,+               SDL-ttf -any, base >=4 && <5, data-accessor-transformers -any,+               fclabels -any, monads-fd -any, random -any, transformers -any+stability:+homepage: http://github.com/snkkid/YACPong+package-url:+bug-reports:+synopsis: Yet Another Pong Clone using SDL.+description: Yet Another Pong Clone using SDL.+category: Game+author: Korcan Hussein+tested-with: GHC -any+data-files: Crysta.ttf paddle.wav wall.wav win.wav+data-dir: data+extra-source-files: Collision.hs Consts.hs Draw.hs GameEnv.hs+                    GameState.hs Labels.hs README Sound.hs Surface.hs Timer.hs+                    Vector2.hs YACPong.hs+extra-tmp-files:+ +executable: YACPong+main-is: YACPong.hs+buildable: True+build-tools:+cpp-options:+cc-options:+ld-options:+pkgconfig-depends:+frameworks:+c-sources:+extensions:+extra-libraries:+extra-lib-dirs:+includes:+install-includes:+include-dirs:+hs-source-dirs: .+other-modules: Collision Consts Draw GameEnv GameState Labels Sound+               Surface Timer Vector2+ghc-prof-options:+ghc-shared-options:+ghc-options:+hugs-options:+nhc98-options:+jhc-options:
+ YACPong.hs view
@@ -0,0 +1,375 @@+{-+    The MIT License++    Copyright (c) 2010 Korcan Hussein.++    Permission is hereby granted, free of charge, to any person obtaining a copy+    of this software and associated documentation files (the "Software"), to deal+    in the Software without restriction, including without limitation the rights+    to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+    copies of the Software, and to permit persons to whom the Software is+    furnished to do so, subject to the following conditions:++    The above copyright notice and this permission notice shall be included in+    all copies or substantial portions of the Software.++    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+    IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+    FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+    AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+    LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+    OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+    THE SOFTWARE.+-}+{-# LANGUAGE FlexibleContexts, ForeignFunctionInterface #-}+module Main where++import Prelude hiding (id, (.), mod, init)++import Foreign+import Foreign.C.Types++import Control.Category++import Control.Monad+import Control.Monad.State hiding (get)+import qualified Control.Monad.State as MState (get)+import Control.Monad.Reader+import Control.Monad.Trans++import Control.Exception++import Data.Maybe+import Data.Either+import Data.Record.Label+import Data.List hiding (init, intersect)++import Graphics.UI.SDL hiding (init, quit, flip, update, getTicks)+import qualified Graphics.UI.SDL as SDL (flip)+import qualified Graphics.UI.SDL.Utilities as Util++import Graphics.UI.SDL.TTF hiding (init, quit)+import qualified Graphics.UI.SDL.TTF as TTFG (init, quit)++import Graphics.UI.SDL.Mixer++import Labels+import Timer+import Vector2+import Collision+import Surface+import GameState+import GameEnv+import Consts+import Sound+import Draw+import Paths_YACPong++-- SDL_GetKeyState is not defined in Graphic.UI.SDL+foreign import ccall unsafe "SDL_GetKeyState" sdlGetKeyState :: Ptr CInt -> IO (Ptr Word8)++type KeyProc = SDLKey -> Bool+-- this function comes from mokehehe's super nario bros: http://github.com/mokehehe/monao in the file "AppUtil.hs"+getKeyState :: MonadIO m => m KeyProc+getKeyState = liftIO $ alloca $ \numkeysPtr -> do+    keysPtr <- sdlGetKeyState numkeysPtr+    return $ \k -> (/= 0) $ unsafePerformIO $ (peekByteOff keysPtr $ fromIntegral $ Util.fromEnum k :: IO Word8)++init :: IO (GameConfig, GameData)+init = do+    screen  <- setVideoMode (truncate screenWidth) (truncate screenHeight) screenBpp [HWSurface, DoubleBuf]+    setCaption "YACPong" []+    enableUnicode True++    fontFileName   <- getDataFileName "Crysta.ttf"+    wallFileName   <- getDataFileName "wall.wav"+    paddleFileName <- getDataFileName "paddle.wav"+    winFileName    <- getDataFileName "win.wav"++    font         <- openFont fontFileName 36+    wallBounce   <- loadWAV wallFileName+    paddleBounce <- loadWAV paddleFileName+    winSound     <- loadWAV winFileName++    paddleSprite <- createRGBSurfaceEndian [HWSurface] paddleW' paddleH' screenBpp+    ballSprite   <- createRGBSurfaceEndian [HWSurface] ballW' ballH' screenBpp++    paddleColor <- mapRGB' paddleSprite 0xFF 0xFF 0x00+    ballColor   <- mapRGB' ballSprite 0x3F 0xFF 0xF5++    fillRect paddleSprite (Just $ Rect 0 0 paddleW' paddleH') paddleColor+    fillRect ballSprite (Just $ Rect 0 0 ballW' ballH') ballColor++    paused <- renderTextSolid font "PAUSED" textColor++    currTicks <- start timer++    return (GameConfig font screen ballSprite paddleSprite paused wallBounce paddleBounce winSound, gameData pPos1 pPos2 bPos currTicks)+ where paddleW' = truncate paddleW+       paddleH' = truncate paddleH+       ballW'   = truncate ballW+       ballH'   = truncate ballH+       --from (x,y) = (fromIntegral x, fromIntegral y)+       pPos1   = (10, halfHeight - paddleH / 2)+       pPos2   = (screenWidth - 10 - paddleW, halfHeight - paddleH / 2)+       bPos    = (halfWidth, halfHeight)++--whichSide :: Bounds -> Bounds -> Vector2f+--Bounds (lx,ly,lw,lh) `whichSide` Bounds (rx,ry,rw,rh) = flip execState (0,0) $ do+--    when ((lx + lw) <= rx) $ do+--        modify $ \(_,ny) -> (-1,ny)+--+--    when (lx >= (rx + rw)) $ do+--        modify $ \(_,ny) -> (1,ny)+--+--    when ((ly + lh) <= ry) $ do+--        modify $ \(nx,_) -> (nx,-1)+--+--    when (ly >= (ry + rh)) $ do+--        modify $ \(nx,_) -> (nx,1)++collide :: Float -> Paddle -> Ball -> Maybe (Float,Float)+collide dt Paddle { _pPos=(px,py), _yVel=yVel } b@Ball { _pos=(x,y), _vel=v } =+    intersectMoving (Bounds (px,py,pW,pH)) (Bounds (x,y,bW,bH)) (0, dt * yVel) (dt `mul` v)+  where bW = ballW+        bH = ballH+        pW = paddleW+        pH = paddleH++data CollisionType =+      CtWall (Either Paddle Ball)+    | CtPaddle Paddle+    | CtLeftNet+    | CtRightNet+    | CtNone++type CollisionEvent = (CollisionType, Float)++paddleInside :: Float -> Paddle -> Bool+paddleInside dt paddle =  not $ y' < 0 || y' + paddleH > screenHeight+ where (_,y) = get pPos paddle+       vel   = get yVel paddle+       y'    = vel * dt + y++findBallCollision :: Float -> [Paddle] -> Ball -> CollisionEvent+findBallCollision dt paddles b@Ball { _pos=bp@(x,y), _vel=v@(dx,dy) }+    | x' > 0 && x' < screenWidth && y' > 0 && y' < screenHeight = --b { _pos=(x',y') }+        let intersecting (_, Nothing) = False+            intersecting (_, Just (0,_)) = False+            intersecting _ =  True+            collided = find intersecting $ map (\p -> (p, collide dt p b)) paddles+        in case collided of+            Just (p, Just (t1,_)) -> (CtPaddle p, t1)+            _                     -> (CtNone, 0)+    | x' < 0            = (CtLeftNet, dt)+    | x' > screenWidth  = (CtRightNet, dt)+    | y' < 0            = (CtWall $ Right b, dt)+    | y' > screenHeight = (CtWall $ Right b, dt)+    | otherwise = (CtNone, 0)+ where x' = dx * dt + x+       y' = dy * dt + y++findCollisions :: Float -> GameEnv [CollisionEvent]+findCollisions dt = do+    p1 <- getM paddle1+    p2 <- getM paddle2+    let paddles = filter (not . paddleInside dt) [p1,p2]+    let wallPaddles = map (\p -> (CtWall $ Left p,dt)) paddles++    result <- findBallCollision dt [p1,p2] `liftM` getM ball+    case result of+        (CtNone,_) -> return wallPaddles+        _          -> return $ result : wallPaddles++think :: Ball -> Vector2f -> Paddle  -> Paddle+think (Ball (bx,by) bv) pv p@Paddle { _pPos=(x,y), _yVel=pVel, _lastPos=oldY }+    | ang < 0   =+        let newVel = if by < y then -paddleVel+                     else if by > y + paddleH+                        then paddleVel+                        else 0+            p' = saveLastPos newVel p -- capture the first y-pos of the paddle.+        in p' { _yVel=newVel  }+    | otherwise = set yVel 0 p+ where ang = bv `dot` pv++react :: CollisionEvent -> GameEnv ()+react (CtWall (Left p), _) = do+    p1 <- getM paddle1++    let playerL = if p1 == p then paddle1 else paddle2+    modM playerL $ \p@Paddle { _pPos=(x,y) } ->+        p { _pPos=(min w $ max x 0, min h $ max y 0) }+ where w = screenWidth+       h = screenHeight++react (CtWall (Right b@Ball { _pos=(x,y), _vel=(dx,dy) }), dt) = do+    setM ball b { _pos=pos', _vel=reflect (dx,dy) wallNormal }+    playWallSound+ where x' = x + dt * dx+       y' = y + dt * dy+       (pos', wallNormal) = execState collideWall ((x',y'),(0,0))+       collideWall :: State (Vector2f,Vector2f) ()+       collideWall = do+        --modify $ \k@((u,v),(_,ny)) -> if u < 0 then ((0,v),(1,ny)) else k+        --modify $ \k@((u,v),(_,ny)) -> if u > fromIntegral screenWidth then ((fromIntegral $ screenWidth - 1, v),(-1,ny)) else k+        modify $ \k@((u,v),(nx,_)) -> if v < 0 then ((u, 0),(nx,1)) else k+        modify $ \k@((u,v),(nx,_)) -> if v > screenHeight then ((u, screenHeight - 1),(nx,-1)) else k++react (CtPaddle p, t) = do+    modM ball $ \b@Ball { _pos=bp, _vel=v } ->+        let v' = t `mul` normalize v+            p' = bp `add` v'+            --n        = whichSide (i,j,bW,bH) (px,py + dt * yVel,pW,pH)+        --in b { _pos=p', _vel=(0, paddleVel) `add` reflect v (1,0) }+        in b { _pos=p', _vel=paddleInflunceVec `add` reflect v (1,0) }+    playPaddleSound+ where currY     = snd $ get pPos p+       paddleVel = get yVel p+       lastY     = get lastPos p+       paddleInflunceVec = if lastY == 0 then (0,0) else (0, currY - lastY)++react (CtLeftNet,_) = do+    state =: Win Player1+    modM (player2Count . stats) (+1)+    playWinSound++react (CtRightNet, _) = do+    state =: Win Player2+    modM (player1Count . stats) (+1)+    playWinSound++react (CtNone, _) = return ()++updatePaddle :: Float -> Paddle -> Paddle+updatePaddle dt paddle = set pPos (x,y') paddle+ where (x,y) = get pPos paddle+       vel   = get yVel paddle+       y'    = vel * dt + y++updateBall :: Float -> Ball -> Ball+updateBall dt b@Ball { _pos=bp@(x,y), _vel=v@(dx,dy) } = b { _pos=(x',y') }+ where x' = dx * dt + x+       y' = dy * dt + y++saveLastPos :: Float -> Paddle -> Paddle+saveLastPos nextVel p+    | currVel == 0 && nextVel /= 0 = p { _lastPos = snd $ get pPos p }+    | currVel /= 0 && nextVel == 0 = p { _lastPos = 0 }+    | otherwise                    = p+ where currVel = get yVel p++update :: Float -> GameEnv ()+update dt = do++    keyState <- getKeyState++    let pVel = if keyState SDLK_w+                then -paddleVel+               else if (keyState SDLK_s)+                then paddleVel+                else 0.0++    -- capture the first y-pos of the player's paddle.+    modM paddle1 $ saveLastPos pVel++    setM (yVel . paddle1) pVel++    b <- getM ball+    modM paddle2 $ think b (-1,0)++    collisions <- findCollisions dt++    forM_ collisions react++    when (all ballNotHit collisions) $+        modM ball $ updateBall dt++    p1 <- getM paddle1+    when (all (paddleNotHit p1) collisions) $+        modM paddle1 $ updatePaddle dt++    p2 <- getM paddle2+    when (all (paddleNotHit p2) collisions) $+        modM paddle2 $ updatePaddle dt++ where ballNotHit :: CollisionEvent -> Bool+       ballNotHit (CtWall (Left _), _) = True+       ballNotHit (CtNone, _)          = True+       ballNotHit _                    = False++       paddleNotHit :: Paddle -> CollisionEvent -> Bool+       paddleNotHit p (CtWall (Left c), _)  = p /= c+       paddleNotHit _ (CtWall (Right _), _) = True+       paddleNotHit _ (CtNone, _)           = True+       paddleNotHit _  _                    = False++nextState_ :: GameLoopState -> GameEnv ()+nextState_ w@(Win player) = do+    renderWin+    isWinPlay <- isPlayingWin+    stopTicks+    let result = if isWinPlay then w else Init player+    state =: result++nextState_ (Init player) = do+    setM ball =<< newBallM player (halfWidth, halfHeight)+    state =: Play++nextState_ Play = do+    dt <- getTicksM+    update $ secs * fromIntegral dt+    resetTicks+    render++nextState_ Paused = do+    renderPaused+    stopTicks++nextState :: GameEnv ()+nextState = getM state >>= nextState_++loop :: GameEnv ()+loop = do+    quit <- whileEvents $ \event -> do+        gs <- getM state+        case (event, gs) of+            (KeyDown (Keysym SDLK_p _ _), Play)   -> setM state Paused+            (KeyDown (Keysym SDLK_p _ _), Paused) -> setM state Play+            _ -> return ()++    nextState++    -- TODO: use high res performance timer.+    liftIO $ delay 1++    unless quit loop++whileEvents :: MonadIO m => (Event -> m ()) -> m Bool+whileEvents act = do+    event <- liftIO pollEvent+    case event of+        Quit    -> return True+        KeyDown (Keysym SDLK_ESCAPE _ _) -> return True+        NoEvent -> return False+        _       ->  do+            act event+            whileEvents act++main :: IO ()+main = withSDL $ do+        (config, state) <- init+        runGame config state loop+        return ()++withSDL :: IO () -> IO ()+withSDL act = withInit [InitEverything] $ do -- withInit calls quit for us.+            bracket_ sdlInit sdlQuit act+ where sdlInit :: IO ()+       sdlInit = do+            success <- TTFG.init+            when (not success) $+                throwIO $ userError "Failed to init ttf\n"+            openAudio 44100 AudioS16Sys 2 4096+       sdlQuit :: IO ()+       sdlQuit = closeAudio >> TTFG.quit
+ data/Crysta.ttf view

binary file changed (absent → 15786 bytes)

+ data/paddle.wav view

binary file changed (absent → 4624 bytes)

+ data/wall.wav view

binary file changed (absent → 4624 bytes)

+ data/win.wav view

binary file changed (absent → 45820 bytes)