packages feed

astrds (empty) → 0.1

raw patch · 27 files changed

+1481/−0 lines, 27 filesdep +MonadRandomdep +OpenGLdep +SDLsetup-changedbinary-added

Dependencies added: MonadRandom, OpenGL, SDL, SDL-image, SDL-mixer, SDL-ttf, base, containers, directory, mtl, random, unix

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2009 Clara Loeh, Andres Loeh++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ astrds.cabal view
@@ -0,0 +1,48 @@+cabal-version: >=1.6+name:          astrds+version:       0.1+license:       BSD3+license-file:  LICENSE+data-files:    fonts/*.ttf+               fonts/*.txt+               pics/*.png+               sound/*.ogg+author:        Clara Loeh <darcs@wuisch.org>,+               Andres Loeh <ksastrds@andres-loeh.de>+maintainer:    Clara Loeh <darcs@wuisch.org>+synopsis:      an incomplete 2d space game+description:   astrds is an intentionally incomplete 2d space game. The code+               is intended to be a playground for Haskell programmers who want+               to add their own features and extensions. The+               implementation is based on SDL and OpenGL and includes+               simple audio and joystick support.+category:      Game+build-type:    Simple++executable astrds+  main-is:        Main.hs+  hs-source-dirs: src+  other-modules:  Config+                  Debug+                  Game+                  Options+                  Pic+                  Render+                  RenderInterface+                  RenderTitle+                  RenderUtil+                  States+                  Static+                  StaticInterface+                  UInputInterface+                  UInputUtils+                  Utilities+  build-depends:  base >= 3 && < 5, containers >= 0.2 && < 1,+                  random >= 1 && < 2, mtl >= 1.1 && < 1.2,+                  directory >= 1 && < 2,+                  OpenGL >= 2.2 && < 2.3,+                  SDL >= 0.5 && < 0.6, SDL-ttf >= 0.5 && < 0.6,+                  SDL-image >= 0.5 && < 0.6,+                  SDL-mixer >= 0.5 && < 0.6,+                  unix >= 2.3 && < 3,+                  MonadRandom >= 0.1 && < 1
+ fonts/AlphaDance.ttf view

binary file changed (absent → 81068 bytes)

+ fonts/AlphaDance.txt view
@@ -0,0 +1,15 @@+Alpha Dance v1.0
+Freeware from Unauthorized Type
+
+This version includes upper and lowercase letters, punctuation, and many international characters. I also included some UA Type dingbats (just to amuse myself, and so you don't get those annoying boxes when you type something that isn't in the font).
+
+I was bored with my job.  I was making way too many copies - about 7000 at one time.  So I drew out some stuff.  After my girlfriend saw what I was making, she told me it looked like the letters were dancing.  I could kinda see it, so I called it Alpha Dance, which is short for Alphabet Dancing (because I thought it sounded cooler). 
+
+You use this font in any way that you see fit.  If you distribute it, I would like for this text file to accompany it.  (That's just so they know who made it.)  You may distribute it on CD, disk, or any other medium, but you may not sell it.
+
+UnAuthorized Type features the creations of:
+Ben McGehee
+bmcgehee@bayou.com
+
+http://members.xoom.com/UAtype/index.htm
+Check back to see when I make new fonts!
+ pics/background.png view

binary file changed (absent → 170551 bytes)

+ pics/collectible.png view

binary file changed (absent → 737 bytes)

+ pics/overlay.png view

binary file changed (absent → 13930 bytes)

+ pics/player.png view

binary file changed (absent → 753 bytes)

+ pics/rock.png view

binary file changed (absent → 728 bytes)

+ sound/background.ogg view

binary file changed (absent → 446242 bytes)

+ src/Config.hs view
@@ -0,0 +1,10 @@+module Config (module Paths_astrds, module Config) where++import Paths_astrds++gametitle = "astrds -- an incomplete 2d space game"++-- size of the game ui+maxXview = 800 :: Int+maxYview = 600 :: Int+
+ src/Debug.hs view
@@ -0,0 +1,8 @@+module Debug where++import Control.Monad++import Options++debug_msg :: Options -> String -> IO ()+debug_msg opts msg = when (debug opts) (putStrLn msg)
+ src/Game.hs view
@@ -0,0 +1,116 @@+-- the main game loop+module Game where++import Data.Maybe++import StaticInterface +import Static ++import States  ++import RenderInterface +import Render ++import UInputInterface +import UInputUtils++import Utilities+import Options+import Debug++startGame :: Options -> IO () +startGame opts+   = do +      -- initialise static data+      debug_msg opts "loading graphical data ..."+      static <- initStatic opts+      -- enter the main game loop+      debug_msg opts "entering main game loop ..."+      runGameWrapper opts static+      return ()++-- | Wrapper around the 'runGame' function+-- (using the concrete engines for rendering and input handling)+runGameWrapper :: Options -> Static -> IO ()+runGameWrapper opts static = runGame opts +                                     (standardRenderEngine static) +                                     (standardUInputEngine (options static)) +                                     getTicks++-- | The length of a "tick" in ms (i.e., the state is updated+-- approximately every @1000/tick_length@ times per second.+tick_length :: Int+tick_length = 30++-----------------------------------------------------------+-- * Game loop+-----------------------------------------------------------++runGame :: Options -> RenderEngine -> UInputEngine -> IO Int -> IO ()+runGame opts rengine iengine getTime +   = do+      -- init State+      let s = initState+      -- wait/quit+      q <- inputWaitQ +      if q then return ()+           else do+                  -- call the runGameLoop with the right arguments+                  t <- getTime+                  s' <- runGameLoop t s +                  -- restart the game+                  runGame opts rengine iengine getTime+ where+  -- unpack the rendering engine+  renderR = render_running   rengine+  renderE = render_end       rengine++  -- unpack the input handling engine+  inputHandle = input_handleRunning iengine+  inputWait   = input_waitForAnyKey iengine+  inputWaitQ  = waitOrQuit inputWait++  -- the game loop +  runGameLoop :: Int -> State -> IO State+  runGameLoop tu s+    = do+       -- player still alive?+       let st = status s+       case st of+         Alive -> runGameLoopAlive tu s+         Dead  -> do+                   renderE s+                   return s++  runGameLoopAlive :: Int -> State -> IO State+  runGameLoopAlive tu s+    = do +       -- has enough time passed since the last update of the state to update again?+       t <- getTime   +       let dt = t - tu+       debug_msg opts (show t ++ " - " ++ show tu ++ " = " ++ show dt)+       if dt >= tick_length+        then  -- update+         do+           -- get user input +           ui <- inputHandle (input s)+           -- did the player quit?+           if hasQuit ui +             then return s+             else+               do+                 -- update the state according to input+                 -- debug_msg "update state"+                 s' <-  updateState s ui dt+                 -- render the state+                 renderR 0 s'+                 -- re-enter the loop+                 runGameLoop t s' +        else  -- render interpolated state+         do+           -- render the state+           renderR dt s+           -- re-enter the loop+           runGameLoopAlive tu s ++
+ src/Main.hs view
@@ -0,0 +1,121 @@+-- a basic rocks game+-- +-- (c) 2009 Clara L\"oh, Andres L\"oh+module Main where++import System.Environment+import System.Console.GetOpt+import Control.Monad+import Data.Maybe+import qualified Control.Monad.State as S+import qualified Control.Monad.Reader as R+import Control.Monad.Trans+import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.TTF as SDL.TTF+import qualified Graphics.UI.SDL.Mixer as SDL.Mixer+import qualified Graphics.Rendering.OpenGL as GL+import Graphics.Rendering.OpenGL (($=))+import Data.Word++-- import rox modules+-- import FsoStatesInterface++import StaticInterface+-- import Static++-- the main game loop+import Game++-- some global settings+import Config++-- additional modules providing debugging functions and option handling+import Debug+import Options++-- for rendering the title+import RenderTitle++-- | Initialising SDL and OpenGL+-- (handling graphics, user input, audio).+initSDL :: Options -> IO ()+initSDL opts =+  do+    -- initialization calls for SDL+    SDL.init [SDL.InitEverything]+    SDL.TTF.init+    -- set up audio+    when (audio opts) $ do+      SDL.Mixer.openAudio 44100 SDL.Mixer.AudioS16Sys 2 4096+      SDL.Mixer.allocateChannels 8 -- todo! adapt number of channels!   +      return ()+    -- it is recommended to set the GL attributes prior to setting the video+    -- mode via SDL ...+    SDL.glSetAttribute SDL.glRedSize   8+    SDL.glSetAttribute SDL.glGreenSize 8+    SDL.glSetAttribute SDL.glBlueSize  8+    SDL.glSetAttribute SDL.glBufferSize 32+    -- the following requests double buffering; it is then not required to+    -- pass a double buffer flag to setVideoMode below+    SDL.glSetAttribute SDL.glDoubleBuffer 1+    -- this sets the video mode and opens a window+    SDL.setVideoMode maxXview maxYview 32+           ((if fullscreen opts then (SDL.Fullscreen :) else id)+            [SDL.OpenGL])+    -- this sets how much of our window we want to handle via OpenGL (all of it)+    GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral maxXview) (fromIntegral maxYview))+    -- set up OpenGL for 2D mode+    GL.matrixMode $= GL.Projection+    GL.loadIdentity+    GL.ortho 0 (fromIntegral maxXview) (fromIntegral maxYview) 0 (-1.0) 1+    GL.matrixMode $= GL.Modelview 0+    GL.loadIdentity+    GL.translate (GL.Vector3 (0 :: Float) 0 0)+    -- we always want blending enabled -- note that if we don't,+    -- this should be moved into the game-specific rendering functions+    GL.blend $= GL.Enabled+    GL.blendEquation $= GL.FuncAdd+    GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+    -- verify that we got double buffering working+    db <- GL.get GL.doubleBuffer+    debug_msg opts $ "double buffering: " ++ show db+    return ()++main :: IO ()+main = do+        -- turn command line arguments into options+        args <- getArgs+        let (xs, _, _) = getOpt Permute optdescrs args+        let opts = foldl (flip ($)) defaultOptions xs+        -- print only help message?+        if help opts +         then putStrLn $ usageInfo ("\n  " ++ gametitle ++ "\n") optdescrs+         else do+               -- init SDL+               initSDL opts+               -- initialize joysticks+               nj <- SDL.countAvailable+               j <- if nj > 0+                     then do+                            SDL.enableEvent SDL.SDLJoyAxisMotion False+                            liftM Just (SDL.open 0)+                     else return Nothing+               -- title sequence+               -- load background music+               titleChunk <- if audio opts +                               then liftM Just $ bgSound >>= SDL.Mixer.loadWAV+                               else return Nothing +               -- background music+               when (audio opts) $ +                    do  +                      SDL.Mixer.playChannel 0 (fromJust titleChunk) (-1)+                      return ()+               -- title images+               renderTitle +               -- start the actual game+               putStrLn "start game!"+               startGame (opts { joystick = j }) +               titleChunk `seq` SDL.quit -- subtle hack: prevent ghc from garbage collecting titleChunk+++
+ src/Options.hs view
@@ -0,0 +1,33 @@+module Options where++import System.Console.GetOpt+import qualified Graphics.UI.SDL as SDL++----------------------------------------------------------------------------+-- * Option handling+----------------------------------------------------------------------------++data Options = Options { debug       :: Bool+                       , fullscreen  :: Bool+                       , joystick    :: Maybe SDL.Joystick +                       , audio       :: Bool+                       , name        :: Maybe String+                       , help        :: Bool+                       }++defaultOptions :: Options+defaultOptions = Options { debug       = False+                         , fullscreen  = False+                         , joystick    = Nothing +                         , audio       = True+                         , name        = Nothing +                         , help        = False }++optdescrs :: [OptDescr (Options -> Options)]+optdescrs = +  [Option "d" ["debug"]      (NoArg (\ o -> o { debug = True }))      "enable debug output",+   Option "f" ["fullscreen"] (NoArg (\ o -> o { fullscreen = True })) "enable fullscreen mode",+   Option "h" ["help"]       (NoArg (\o  -> o { help = True }))       "show this help",+   Option "s" ["silent"]     (NoArg (\o  -> o { audio = False}))      "silent mode -- no audio"+  ]+
+ src/Pic.hs view
@@ -0,0 +1,27 @@+module Pic where++import qualified Data.Map as M++type Dim = (Int, Int)++-- | Simple pic datatype.+data Pic = Pic { picpath :: String +               , picdim  :: (Int, Int) +               }+  deriving (Eq,Show)++-- | Simple sprite datatype.+data Sprite a = Sprite { spic    :: Pic +                       , offsets :: M.Map a Int -- ^ offsets of the pics in the sprite+                       , tiledim :: Dim+                       }++-- | Simple animation datatype+data Animation = Animation { an_sprite      :: Sprite Int+                           , an_description :: Int -> Int -- ^ time to index+                           } ++picToAnimation :: Pic -> Animation+picToAnimation pic@(Pic img dim) = Animation sprite (const 0)+  where +    sprite = Sprite pic (M.singleton 0 0) dim
+ src/Render.hs view
@@ -0,0 +1,105 @@+module Render where++import Control.Monad+import qualified Graphics.UI.SDL as SDL hiding (init)+import qualified Graphics.UI.SDL.TTF as SDL+import qualified Graphics.Rendering.OpenGL as GL+import Data.Word+import qualified Data.Map as M+import qualified Data.Traversable as M+import System.IO+import System.Random+import Data.Maybe++import States++import RenderInterface+import RenderUtil++import StaticInterface ++import Pic +import Utilities+import Config++standardRenderEngine :: Static -> RenderEngine+standardRenderEngine static = RenderEngine (render static)+                                           (renderEnd static)++-- type Render a = Int -> a -> IO ()+-- type RenderStatic a = Static -> Int -> a -> IO ()++render :: RenderStatic State +render st dt s = do +                  clearScreen+                  -- painting the virtual screen +                  renderVirtualScreen dt s st+                  -- update the image on screen+                  showScreen++renderVirtualScreen :: Int -> State -> Static -> IO ()+renderVirtualScreen dt s st+    = do+       -- interpolate the new positions (using dt)+       let s' = if dt /= 0 then interpolateState s dt+                           else s+       -- render the background+       renderBackground st +       -- render the rocks+       mapM_ (renderRock st) (rocks s)+       -- render the collectibles+       mapM_ (renderCollectible st) (collectibles s)+       -- render the player's ship+       renderPlayer st (player s')+       -- render the score +       renderScore st (score s')+       return ()++---------------------------------------------------------------------------+-- * Rendering parts of the level state+---------------------------------------------------------------------------+    +-- | Render the background.+renderBackground :: Static -> IO ()+renderBackground st = renderImg (bg_image (images st)) +                                (fromIntegral maxXview/2, fromIntegral maxYview/2)++-- | Render a rock at the given position.+renderRock :: Static -> Rock -> IO ()+renderRock st f = renderImgAttr (defaultRenderAttr { ra_scale = scale f})+                                (rock_image (images st))+                                (pos f)++-- | Render a collectible at the given position.+renderCollectible :: Static -> Collectible -> IO ()+renderCollectible st f = renderImgAttr (defaultRenderAttr { ra_scale = scale f})+                                       (coll_image (images st))+                                       (pos f)++-- | Render the player's ship.+renderPlayer :: Static -> Player -> IO ()+renderPlayer st f = renderImgAttr (defaultRenderAttr { ra_scale = scale f})+                                  (pl_image (images st))+                                  (pos f)++-- | Render the score.+renderScore :: Static -> Int -> IO ()+renderScore st n = renderText ("score: " ++ show n) textColour (5,5) st++---------------------------------------------------------------------------+-- * Render end of this level+---------------------------------------------------------------------------++renderEnd :: RenderEndStatic+renderEnd st s +  = do +      renderEndOverlay st s+      let msg = "game over! collected: " ++ show (score s)+      renderBigText msg textColour (0, fromIntegral maxYview - 80) st+      SDL.glSwapBuffers++renderEndOverlay :: Static -> State -> IO ()+renderEndOverlay st s =+  let overlay_img = overlay . images $ st+  in  renderImg overlay_img (pos (player s))+
+ src/RenderInterface.hs view
@@ -0,0 +1,14 @@+module RenderInterface where++import States+import StaticInterface++type Render a = Int -> a -> IO ()+type RenderStatic a = Static -> Render a++type RenderEnd = State -> IO ()+type RenderEndStatic = Static -> RenderEnd++data RenderEngine = RenderEngine { render_running   :: Render State+                                 , render_end       :: RenderEnd +                                 }
+ src/RenderTitle.hs view
@@ -0,0 +1,31 @@+module RenderTitle where++import qualified Graphics.UI.SDL as SDL+import qualified Graphics.Rendering.OpenGL as GL++import RenderInterface+import RenderUtil++import StaticInterface+import Static+import Config++-- | This function is called /before/ initialising static+-- (so that the player can already admire the title without+--  waiting for the whole loading marathon)+renderTitle :: IO ()+renderTitle = do+                clearScreen+                -- load the partial information we need+                fnts <- loadFonts+                img  <- bgPic >>= loadPNGPic+                -- render title image+                renderImg img (fromIntegral maxXview / 2, fromIntegral maxYview / 2)+                SDL.glSwapBuffers+                -- render title texts+                renderTextCFnt gametitle textColour (fromIntegral maxXview / 2, fromIntegral maxYview / 2 -40) +                               (bigfont fnts)+                showScreen+                SDL.delay 1500+                return ()+
+ src/RenderUtil.hs view
@@ -0,0 +1,221 @@+module RenderUtil where++import Control.Monad+import qualified Graphics.UI.SDL as SDL hiding (init)+import qualified Graphics.UI.SDL.TTF as SDL+import Graphics.Rendering.OpenGL as GL+import Data.Map as M++import Utilities++import States++import StaticInterface +import Static ++import RenderInterface++import Pic ++-- * Some text colours++textColour, userInputColour, messageColour :: SDL.Color+textColour      = SDL.Color {SDL.colorRed = 255, SDL.colorGreen = 255, SDL.colorBlue = 255}+userInputColour = SDL.Color {SDL.colorRed = 200, SDL.colorGreen = 200, SDL.colorBlue = 255}+messageColour   = SDL.Color {SDL.colorRed = 0,   SDL.colorGreen = 0,   SDL.colorBlue = 0}+++clearScreen :: IO ()+clearScreen = GL.clear [GL.ColorBuffer]++showScreen :: IO ()+showScreen =+  do+    GL.flush+    SDL.glSwapBuffers++---------------------------------------------------------------------------+-- * Render an SDLPic +---------------------------------------------------------------------------++renderImg :: SDLPic -> Pos -> IO ()+renderImg = renderImgAttr defaultRenderAttr++renderImgAnchor :: Anchor -> SDLPic -> Pos -> IO ()+renderImgAnchor anchor =+  renderImgAttr (defaultRenderAttr { ra_anchor = anchor })++fadeOutImg :: SDLPic -> Pos -> Int -> Int -> IO ()+fadeOutImg pic pos t et =+  renderImgAttr+    (defaultRenderAttr { ra_fade = FadeOut fading_duration (et - t) })+    pic pos++renderImgAttr :: RenderAttr -> SDLPic -> Pos -> IO ()+renderImgAttr attr pic =+  renderSpriteAttr attr (sdlPicToSprite pic) ()++data RenderAttr = RenderAttr { ra_anchor  :: Anchor+                             , ra_fade    :: Fade+                             , ra_scale   :: Double+                             } -- etc++-- | The anchor specifies the position of the point that's+-- passed. The result is the upper left and lower right+-- corner in OpenGL terms.+data Anchor = TopLeft+            | Centre+            | TopRight+            | TopCentre++data Fade = NoFade+          | FadeIn Int Int+          | FadeOut Int Int++defaultRenderAttr = RenderAttr Centre NoFade 1.0++type ScaledDim = (Double, Double)++anchorTransform :: Anchor -> Pos -> ScaledDim -> (Pos, Pos)+anchorTransform TopCentre (x,y) (w,h) =+  let w2 = w / 2+  in  ((x - w2, y), (x + w2, y + h))+anchorTransform Centre (x,y) (w,h) =+  let w2 = w / 2+      h2 = h / 2+  in  ((x - w2, y - h2), (x + w2, y + h2))+anchorTransform TopLeft (x,y) (w,h) =+  ((x,y), (x + w,y + h))+anchorTransform TopRight (x,y) (w,h) =+  ((x - w,y), (x, y + h))++renderSprite :: Ord a => SDLSprite a -> a -> Pos -> IO ()+renderSprite = renderSpriteAttr defaultRenderAttr ++renderSpriteAttr :: Ord a => RenderAttr -> SDLSprite a -> a -> Pos -> IO ()+renderSpriteAttr (RenderAttr anchor fade scale) pic o pos+  = do+     let img         = sdl_image (sdl_sprite pic)+     let (w,h)       = sdl_dim (sdl_sprite pic)+     let (tw,th)     = sdl_tiledim pic+     let dim         = (scale * fromIntegral tw, scale * fromIntegral th)+     let op          = sdl_offsets pic M.! o+     -- here, we adapt the alpha channel ...+     let alpha :: Float+         alpha = case fade of+                   NoFade -> 1+                   FadeIn  dur dt ->+                     1 - (fromIntegral dt / fromIntegral dur)+                   FadeOut dur dt ->+                     fromIntegral dt / fromIntegral dur+     GL.color (GL.Color4 1 1 1 (alpha :: Float))+     GL.texture GL.Texture2D $= GL.Enabled+     GL.textureBinding GL.Texture2D $= Just img+     GL.textureFunction $= GL.Modulate+     GL.renderPrimitive GL.Quads $+       do+         let x0, x1, y0, y1, sx, sy, tx, ty :: Double+             ((x0,y0),(x1,y1)) = anchorTransform anchor pos dim+             sx = nextPowerOfTwoFraction op w+             sy = nextPowerOfTwoFraction 0 h+             tx = nextPowerOfTwoFraction (op + tw) w+             ty = nextPowerOfTwoFraction h h+         GL.texCoord (GL.TexCoord2 (sx :: Double) sy)+         GL.vertex   (GL.Vertex2 x0 y0) +         GL.texCoord (GL.TexCoord2 (tx :: Double) sy)+         GL.vertex   (GL.Vertex2 x1 y0)+         GL.texCoord (GL.TexCoord2 (tx :: Double) ty)+         GL.vertex   (GL.Vertex2 x1 y1)+         GL.texCoord (GL.TexCoord2 (sx :: Double) ty)+         GL.vertex   (GL.Vertex2 x0 y1)+         return ()++-- TODO: parametrise+fading_duration :: Int+fading_duration = 30++fadeOutSprite :: Ord a => SDLSprite a -> a -> Pos -> Int -> Int -> IO ()+fadeOutSprite pic o pos t et+  = renderSpriteAttr (defaultRenderAttr { ra_fade = FadeOut fading_duration (et - t) })+                     pic o pos++renderAnimation :: SDLAnimation -> Int -> Pos -> IO ()+renderAnimation (SDLAnimation sprite descr) t pos+  = renderSprite sprite (descr t) pos++renderAnimationAttr :: RenderAttr -> SDLAnimation -> Int -> Pos -> IO ()+renderAnimationAttr ra (SDLAnimation sprite descr) t pos +  = renderSpriteAttr ra sprite (descr t) pos++---------------------------------------------------------------------------+-- * Render text+---------------------------------------------------------------------------++renderTextFontAttr :: String -> SDL.Color -> Pos -> SDL.Font -> RenderAttr -> IO ()+renderTextFontAttr txt c pos fnt attr+  = do+     rtxt <- SDL.renderTextBlended fnt txt c+     pic <- convertSurface (SDL.surfaceGetWidth rtxt, SDL.surfaceGetHeight rtxt) rtxt+     renderImgAttr attr pic pos+     GL.deleteObjectNames [ sdl_image pic ]++renderTextFontAnchor :: String -> SDL.Color -> Pos -> SDL.Font -> Anchor -> IO ()+renderTextFontAnchor txt c pos fnt anchor+  = renderTextFontAttr txt c pos fnt (defaultRenderAttr { ra_anchor = anchor })++renderTextCFnt :: String -> SDL.Color -> Pos -> SDL.Font -> IO ()+renderTextCFnt txt c pos fnt = renderTextFontAnchor txt c pos fnt TopCentre++renderText :: String -> SDL.Color -> Pos -> Static -> IO ()+renderText txt c pos st +  = let fnt = font (fonts st)+    in  renderTextFontAnchor txt c pos fnt TopLeft+++renderTextC :: String -> SDL.Color -> Pos -> Static -> IO ()+renderTextC txt c pos st +  = let fnt = font (fonts st)+    in  renderTextFontAnchor txt c pos fnt Centre++renderBigText :: String -> SDL.Color -> Pos -> Static -> IO ()+renderBigText txt c pos st+  = let bigfnt = bigfont (fonts st)+    in  renderTextFontAnchor txt c pos bigfnt TopLeft++renderTexts :: [String] -> SDL.Color -> Pos -> Static -> IO ()+renderTexts txts c (x,y) st+  = let fnt = font (fonts st)+    in  renderGLines (x,y) fnt txts++renderBigTextR :: String -> SDL.Color -> Pos -> Static -> IO ()+renderBigTextR txt c pos st+  = let bigfnt = bigfont (fonts st)+    in  renderTextFontAnchor txt c pos bigfnt TopRight++renderBigTextC :: String -> SDL.Color -> Pos -> Static -> IO ()+renderBigTextC txt c pos st+  = let bigfnt = bigfont (fonts st)+    in  renderTextFontAnchor txt c pos bigfnt Centre++fadeOutBigTextC :: String -> SDL.Color -> Pos -> Static -> Int -> Int -> IO ()+fadeOutBigTextC txt c pos st t et+  = let bigfnt = bigfont (fonts st)+    in  renderTextFontAttr txt c pos bigfnt (defaultRenderAttr { ra_anchor = Centre, ra_fade = FadeOut fading_duration (et - t) })++---------------------------------------------------------------------------+-- * Render lines in SDL+---------------------------------------------------------------------------++renderGLinesAnchor :: Anchor -> Pos -> SDL.Font -> [String] -> IO ()+renderGLinesAnchor anchor pos       fnt []     = return ()+renderGLinesAnchor anchor pos@(x,y) fnt (s:ss) =+  do+    renderTextFontAnchor s textColour pos fnt anchor+    baselineskip <- SDL.fontLineSkip fnt+    let npos = (x, y + fromIntegral baselineskip)+    renderGLinesAnchor anchor npos fnt ss++renderGLines, renderGLinesR :: Pos -> SDL.Font -> [String] -> IO ()+renderGLines  = renderGLinesAnchor TopLeft+renderGLinesR = renderGLinesAnchor TopRight+
+ src/States.hs view
@@ -0,0 +1,262 @@+module States where++import Control.Monad+import qualified Control.Monad.State as S+import qualified Control.Monad.Random as R+import System.Random+import System.Posix+import Data.List++import UInputInterface +import UInputUtils ++import Config++data State = State { player        :: Player+                   , status        :: Status+                   , score         :: Int +                   , rocks         :: [Rock]+                   , collectibles  :: [Collectible]+                   , time          :: Int           -- ^ abstract game time+                   , input         :: UInput+                   }+++data Status = Alive | Dead+     deriving (Eq, Show)++data FlyingObject = FlyingObject { pos   :: Pos+                                 , speed :: Vel+                                 , size  :: Double +                                 , scale :: Double+                                 }++type Player = FlyingObject+type Rock = FlyingObject+type Collectible = FlyingObject++type Pos = (Double, Double)+type Vel = (Double, Double) -- ^ all speeds are measured in pixels per second++initState :: State+initState = State { player       = FlyingObject { pos   = (fromIntegral maxXview/2, fromIntegral maxYview/2)+                                                , speed = (0,0)+                                                , size  = 30 +                                                , scale = 1 +                                                }+                  , status       = Alive+                  , score        = 0+                  , rocks        = []+                  , collectibles = []+                  , time         = 0 +                  , input        = noInput+                  }++-- | State monad version of the (abstract) game state; +--+-- > S.State s a ~= s -> (a,s)+--+type StateS = S.State State++-- | State monad including a random generator.+type StateR a = R.RandT StdGen StateS a++--------------------------------------------------------------------+-- * Updating the game state+--------------------------------------------------------------------++updateState :: State -> UInput -> Int -> IO State+updateState s ui dt = do+                       -- generate a random random generator+                       tsys <- liftM fromEnum epochTime+                       let tgame = time s+                       let seed  = tsys * tgame+                       let gen   = mkStdGen seed+                       return $ snd (S.runState (R.runRandT (updateStateR ui dt) gen) s)++updateStateR :: UInput -> Int -> StateR()+updateStateR ui dt = do+                      -- force a first random number generation+                      R.getRandom :: StateR Int+                      -- adjust the abstract clock of the game+                      S.modify stepTime+                      -- interpolate the new positions+                      interpolateStateR dt+                      -- collision of the player with a rock?+                      updateHealthR+                      -- update score and remove collected collectibles+                      updateScoreR+                      -- remove rocks/collectibles that are out of reach+                      cleanUpR+                      -- generate new rocks/collectibles?+                      genRocksCollsR+                      -- remember new input+                      setUInput ui++-- | Increment the time counter.+stepTime :: State -> State+stepTime s = s { time = time s + 1 }++-------------------------------------------------------------------+-- * Interpolation+-------------------------------------------------------------------++interpolateStateR  :: Int -> StateR ()+interpolateStateR dt = S.modify (\s -> interpolateState s dt)++-- | Interpolate the positions according to the time passed.+interpolateState :: State -> Int -> State+interpolateState s dt = let pl = (player s) { speed = uiToDir (input s) }+                        in  s { player       = confineToVis $ moveFlyingObject pl dt+                              , rocks        = map (\r -> moveFlyingObject r dt) (rocks s) +                              , collectibles = map (\c -> moveFlyingObject c dt) (collectibles s)+                              }++moveFlyingObject :: FlyingObject -> Int -> FlyingObject+moveFlyingObject f dt = f { pos = movePos (pos f) (speed f) dt }++movePos :: Pos -> Vel -> Int -> Pos+movePos p (velx,vely) dt = inDir p ( (fromIntegral dt * velx)/10^3+                                   , (fromIntegral dt * vely)/10^3 ) ++-- | Confine a FO to the visible part of the galaxy.+confineToVis :: FlyingObject -> FlyingObject+confineToVis f = f { pos = ( max 0 (min x (fromIntegral maxXview))+                           , max 0 (min y (fromIntegral maxYview)) )+                   }+  where (x,y) = pos f++-- | Direction as a delta.+type Dir = (Double,Double) ++-- | Compute a new position from an origin and a delta.+inDir :: Pos -> Dir -> Pos+inDir (x,y) (dx,dy) = ( x + dx, y + dy )++-- | Convert user input into a direction.+uiToDir :: UInput -> Dir+uiToDir ui = let (kx, ky) = dirkeys ui+                 (x,y)    = axes ui+             in ( (x+kx) * unitSpeed, (y+ky) * unitSpeed )++-- | Speed constant.+unitSpeed = 600 +++-------------------------------------------------------------------+-- * Update user input+-------------------------------------------------------------------++setUInput :: UInput -> StateR ()+setUInput ui = S.modify (\ s -> s { input = ui } )+++-------------------------------------------------------------------+-- * Collision of the ship with other objects+-------------------------------------------------------------------++-- | Check whether two flying objects collide+-- (the flying objects are assumed to be circles).+collides :: FlyingObject -> FlyingObject -> Bool+collides f f' =    distance (pos f) (pos f')+                <= scale f * size f + scale f' * size f'++distance :: (Double,Double) -> (Double,Double) -> Double+distance (px,py) (px',py') = sqrt ( (px - px')^2 + (py-py')^2 )++-- check whether the player's ship hits a rock+hitsRock :: State -> Bool+hitsRock s = any (collides (player s)) (rocks s)++updateHealth :: State -> State+updateHealth s = s { status = newstatus }+  where+    newstatus = if hitsRock s then Dead else Alive++updateHealthR :: StateR ()+updateHealthR = S.modify updateHealth++-- computes the new score and removes the collected collectibles+updateScore :: State -> State+updateScore s = s { collectibles = noncollected+                  , score        = score s + length collected+                  }+  where+    collected    = filter (\c -> collides (player s) c) (collectibles s)+    noncollected = filter (\c -> not (collides (player s) c)) (collectibles s) ++updateScoreR :: StateR ()+updateScoreR = S.modify updateScore+++-------------------------------------------------------------------+--- clean up rocks/collectibles that are out of reach+-------------------------------------------------------------------++cleanUp :: State -> State+cleanUp s = s { rocks        = filter inReach (rocks s)+              , collectibles = filter inReach (collectibles s)+              }++cleanUpR :: StateR ()+cleanUpR = S.modify cleanUp++inReach :: FlyingObject -> Bool+inReach f = x >= (- realsize) && x <= fromIntegral maxXview + realsize+         && y >= (- realsize) && y <= fromIntegral maxYview + realsize+  where (x,y) = pos f+        realsize = size f * scale f+++--------------------------------------------------------------------+--- generate new rocks/collectibles+--------------------------------------------------------------------++genRocksCollsR :: StateR ()+genRocksCollsR = do+                  s <- S.get+                  rrock <- genFlyingObject+                  rcoll <- genFlyingObject+                  p <- R.getRandomR (0,100)+                  let newrocks = if p < pRock then [rrock] else []+                  q <- R.getRandomR (0,100)+                  let newcolls = if q < pColl then [rcoll] else []+                  let s' = s { rocks        = newrocks ++ rocks s+                             , collectibles = newcolls ++ collectibles s+                             }+                  S.put s'++-- | Probability for generating a rock (in percent per abstract tick).+pRock = 4 :: Int++-- | Probability for generating a collectible (in percent per abstract tick).+pColl = 2 :: Int++genFlyingObject :: StateR FlyingObject+genFlyingObject =+  do+    b <- R.getRandomR (0,2*maxXview + 2 * maxYview -1)+    aimx <- R.getRandomR (-200,200)+    aimy <- R.getRandomR (-150,150)+    sc <- R.getRandomR (minScale,maxScale)+    let (x,y)   = convertBoundaryToXY b (sc * 30)+        (vx,vy) = ( 1/5*(fromIntegral (maxXview + aimx) / 2 - x)+                  , 1/5*(fromIntegral (maxYview + aimy) / 2 - y) )+    return $ FlyingObject { pos   = (x,y)+                          , speed = (vx,vy)+                          , size  = 30+                          , scale = sc  +                          }++minScale = 0.5+maxScale = 1.5++convertBoundaryToXY :: Int -> Double -> Pos+convertBoundaryToXY b sz | b < maxXview               = ( fromIntegral b+                                                        , - sz) +                         | b < maxXview   + maxYview  = ( fromIntegral maxXview + sz+                                                        , fromIntegral (b - maxXview))+                         | b < 2*maxXview + maxYview  = ( fromIntegral (b - maxXview - maxYview)+                                                        , fromIntegral maxYview + sz)+                         | otherwise                  = ( -sz+                                                        , fromIntegral (b - 2 * maxXview - maxYview))
+ src/Static.hs view
@@ -0,0 +1,145 @@+module Static where++import Control.Monad+import qualified Data.Map as M+import qualified Data.Traversable as M+import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.TTF as SDL+import qualified Graphics.UI.SDL.Image as SDL+import qualified Graphics.UI.SDL.Mixer as SDL+import Graphics.Rendering.OpenGL as GL+import Data.Maybe++import StaticInterface+import Utilities++import Pic++import Options+import Debug+import Config++initStatic :: Options -> IO Static+initStatic opts+   = do +      debug_msg opts "loading images ..."+      images <- loadImages +      debug_msg opts "loading fonts ..."+      fonts  <- loadFonts+      sounds <- if audio opts +                  then do+                         debug_msg opts "loading sounds ..."+                         loadSounds+                  else return emptySounds+      let st = Static { images   = images+                      , fonts    = fonts+                      , sounds   = sounds+                      , options  = opts+                      }+      return st++-----------------------------------------------------------------------------+-- * Load fonts+-----------------------------------------------------------------------------++loadFonts :: IO Fonts+loadFonts =+  do+    ttf    <- getDataFileName "fonts/AlphaDance.ttf"+    fnt    <- SDL.openFont ttf 20            +    bigfnt <- SDL.openFont ttf 40  +    let fts = Fonts { font = fnt+                    , bigfont = bigfnt +                    }+    return fts++-----------------------------------------------------------------------------+-- * Load images+-----------------------------------------------------------------------------+++loadPic :: Pic -> IO SDLPic+loadPic pic =+  do+    imgBMP <- SDL.loadBMP (picpath pic) +    convertSurface (picdim pic) imgBMP++convertSurface :: Dim -> SDL.Surface -> IO SDLPic+convertSurface dim img =+  do+    let pixfo = SDL.surfaceGetPixelFormat img+    bppo <- SDL.pixelFormatGetBytesPerPixel pixfo+    -- putStrLn $ show bppo+    let pfn = case bppo of 3 -> GL.RGB; 4 -> GL.RGBA+    imgTmp <- SDL.createRGBSurfaceEndian [SDL.SWSurface]+                (nextPowerOfTwo $ SDL.surfaceGetWidth img)+                (nextPowerOfTwo $ SDL.surfaceGetHeight img)+                (fromIntegral bppo * 8)+                -- 0x000000ff 0x0000ff00 0x00ff0000 -- small endian+                -- 0xff000000 -- alpha+    -- when (bppo == 4) $+    -- This is important in order to keep the alpha information from the+    -- source image in the temporary image:+    SDL.setAlpha img [] 0xff+    SDL.blitSurface img Nothing imgTmp Nothing+    [imgGL] <- GL.genObjectNames 1+    GL.textureBinding GL.Texture2D $= Just imgGL+    let pixfmt = SDL.surfaceGetPixelFormat imgTmp+    bpp <- SDL.pixelFormatGetBytesPerPixel pixfmt+    GL.rowLength GL.Unpack $=+      fromIntegral (SDL.surfaceGetPitch imgTmp `div`+                    fromIntegral bpp)+    pixels <- SDL.surfaceGetPixels imgTmp+    GL.textureFilter GL.Texture2D $=+      ((GL.Linear',Nothing), GL.Linear')+    GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA'+      (GL.TextureSize2D (fromIntegral $ SDL.surfaceGetWidth  imgTmp)+                        (fromIntegral $ SDL.surfaceGetHeight imgTmp))+      0 -- border+      (GL.PixelData pfn GL.UnsignedByte pixels)+    -- GL.flush+    let picSDL = SDLPic { sdl_image = imgGL +                        , sdl_dim   = dim }+    return picSDL++loadPNGPic :: Pic -> IO SDLPic+loadPNGPic pic = do +                  imgSDL <- SDL.loadTyped (picpath pic) SDL.PNG+                  convertSurface (picdim pic) imgSDL+                +blackRGB, whiteRGB :: (Int, Int, Int)+blackRGB = (0,0,0) +whiteRGB = (255,255,255)++-- Load all images necessary for the game.+loadImages :: IO Images+loadImages = +  do +    -- load images+    [pl_img, bg_img, rock_img, coll_img, overlay]+           <- mapM (>>= loadPNGPic)+                [playerPic, bgPic, rockPic, collPic, overlayPic]+    -- put it all together+    let imgs = Images { pl_image      = pl_img+                      , bg_image      = bg_img+                      , rock_image    = rock_img+                      , coll_image    = coll_img+                      , overlay       = overlay+                      }+    return imgs++-----------------------------------------------------------------------------+-- * Load sounds+-----------------------------------------------------------------------------++loadSounds :: IO Sounds+loadSounds = do+               bgs <- bgSound >>= loadChunk+               let snds = Sounds { bg_sound    = bgs +                                 }+               return snds++loadChunk :: Sound -> IO SDLSound+loadChunk s = do +                chunk <- SDL.loadWAV s+                return SDLSound { sdl_chunk = chunk }
+ src/StaticInterface.hs view
@@ -0,0 +1,88 @@+module StaticInterface where++import qualified Graphics.UI.SDL as SDL+import qualified Graphics.UI.SDL.TTF as SDL+import qualified Graphics.UI.SDL.Mixer as SDL+import qualified Graphics.Rendering.OpenGL as GL+import qualified Data.Map as M+import System.Random++import States++import Pic+import Options+import Config++-- | Static data:+-- this should be viewed as an "internal" datatype+-- (used for rendering and input handling);+-- caveat: depends on SDL!+data Static = Static { images   :: Images+                     , fonts    :: Fonts+                     , sounds   :: Sounds+                     , options  :: Options+                     }+++data Fonts = Fonts { font     :: SDL.Font+                   , bigfont  :: SDL.Font+                   }++data Images = Images { pl_image     :: SDLPic+                     , bg_image     :: SDLPic +                     , rock_image   :: SDLPic+                     , coll_image   :: SDLPic+                     , overlay      :: SDLPic+                     }++data SDLPic = SDLPic { sdl_image :: GL.TextureObject+                     , sdl_dim   :: Dim+                     }++data SDLSprite a = SDLSprite   { sdl_sprite  :: SDLPic+                               , sdl_offsets :: M.Map a Int+                               , sdl_tiledim :: Dim+                               }++data SDLAnimation = SDLAnimation { sdl_an_sprite      :: SDLSprite Int+                                 , sdl_an_description :: Int -> Int+                                 }++sdlPicToSprite :: SDLPic -> SDLSprite ()+sdlPicToSprite pic@(SDLPic img dim) = SDLSprite pic (M.singleton () 0) dim++data Sounds = Sounds { bg_sound :: SDLSound +                     }++data SDLSound = SDLSound { sdl_chunk :: SDL.Chunk }++emptySounds :: Sounds+emptySounds = error "audio turned off -- therefore, audio is not accessible"++------------------------------------------------------------------------------+-- * All the images (abstractly, not as SDL images)+------------------------------------------------------------------------------++picData :: FilePath -> (Int, Int) -> IO Pic+picData f d =+  do+    img <- getDataFileName f+    return $ Pic { picpath = img, picdim = d }++playerPic  = picData "pics/player.png"      (64,64)+rockPic    = picData "pics/rock.png"        (64,64)+collPic    = picData "pics/collectible.png" (64,64)+overlayPic = picData "pics/overlay.png"     (1600,1200)+bgPic      = picData "pics/background.png"  (800,600)++---------------------------------------------------------------------+-- * All the sounds (abstractly)+---------------------------------------------------------------------++type Sound = String -- ^ path to the sound data++bgSound :: IO Sound+bgSound  = getDataFileName "sound/background.ogg"+++
+ src/UInputInterface.hs view
@@ -0,0 +1,69 @@+module UInputInterface where++import Data.List+import Control.Monad++-- | Minimal waiting time.+minWait = 700 :: Int ++-- | Synonyms for joystick button numbers.+joystick_QUIT = 8 :: Int+joystick_PREV = 4 :: Int+joystick_NEXT = 5 :: Int++data UInputEngine =+  UInputEngine { input_handleRunning :: InputHandler+               , input_waitForAnyKey :: IO UInput +               }++-- | The state of user input.+data UInput =+  UInput { dirkeys    :: DirKeys         -- ^ direction keys currently pressed down+         , quit       :: Bool            -- ^ quit?+         , axes       :: (Double,Double) -- ^ joystick axes+         }+++-- | Abstract keys.+data Key =+    KUp | KDown | KRight | KLeft +  | KQuit +  | KUnknown  +  deriving (Show, Eq)++-- | Direction (given by the keys).+type DirKeys = (Double, Double)++type InputHandler = UInput -> IO UInput++hasQuit :: UInput -> Bool+hasQuit = quit++-- | Wait for any key;+-- returns 'True' if "any key" was "quit"+waitOrQuit :: IO UInput -> IO Bool+waitOrQuit waitFAK = liftM quit waitFAK++noInput = UInput { dirkeys  = (0,0)+                 , quit     = False+                 , axes     = (0,0)+                 } ++updateDirkeys :: (DirKeys -> DirKeys) -> UInput -> UInput+updateDirkeys f ui = ui { dirkeys = f (dirkeys ui) }++addKey :: Key -> UInput -> UInput+addKey KUp    = updateDirkeys (\ (x,y) -> (x,y-1))+addKey KDown  = updateDirkeys (\ (x,y) -> (x,y+1))+addKey KLeft  = updateDirkeys (\ (x,y) -> (x-1,y))+addKey KRight = updateDirkeys (\ (x,y) -> (x+1,y))+addKey KQuit  = \ ui -> ui { quit = True }+addKey _      = id++removeKey :: Key -> UInput -> UInput+removeKey KUp    = addKey KDown+removeKey KDown  = addKey KUp+removeKey KLeft  = addKey KRight+removeKey KRight = addKey KLeft+removeKey _      = id+
+ src/UInputUtils.hs view
@@ -0,0 +1,117 @@+module UInputUtils where++import qualified Graphics.UI.SDL as SDL+import Data.Word++import Options+import Debug++import UInputInterface++standardUInputEngine :: Options -> UInputEngine+standardUInputEngine opts = UInputEngine (updateUInput opts)+                                         (waitForAnyKey minWait)++-- clean up the event queue+cleanUpEventQueue :: IO ()+cleanUpEventQueue  = do +                      event <- SDL.pollEvent+                      case event of+                        SDL.NoEvent -> return ()+                        _           -> cleanUpEventQueue++-- | Wait a specificed number of milliseconds, then wait for any key+-- (or joystick button) being pressed and return the pressed key.+waitForAnyKey :: Int -> IO UInput+waitForAnyKey t =+  do+    SDL.delay (fromIntegral t)+    cleanUpEventQueue+    waitForAnyKey'++-- | Wait for a key (or joystick button) being pressed.+waitForAnyKey' :: IO UInput+waitForAnyKey' =+  do+    event  <- SDL.pollEvent+    case event of+         SDL.KeyUp k         -> return $ addKey (sdlKeyToKey k)   noInput+         SDL.JoyButtonUp _ x -> return $ addKey (joystickToKey x) noInput+         _                   -> waitForAnyKey'+++-- Reminder:+-- InputHandler :: UInput -> IO UInput++updateUInput :: Options -> InputHandler+updateUInput opts ui = do +                        -- joystick handling+                        ui' <- updateJoystick opts ui+                        processEvents opts ui'++-- TODO: This could theoretically lead into an infinite loop+-- if processing an event takes longer than producing one+processEvents :: Options -> InputHandler+processEvents opts ui =+  do+    event <- SDL.pollEvent +    -- key handling+    case event of+      SDL.JoyButtonDown x y -> processEvents opts (processJoyButtonDown x y ui)+      SDL.JoyButtonUp   x y -> processEvents opts (processJoyButtonUp x y ui) +      SDL.KeyDown k         -> processEvents opts (processKeyDown k ui)+      SDL.KeyUp k           -> processEvents opts (processKeyUp k ui)+      SDL.NoEvent           -> return ui+      e                     -> do+                                debug_msg opts (show e)+                                return ui     ++updateJoystick :: Options -> InputHandler+updateJoystick opts ui +  = do+      let mj = joystick opts+      case mj of+        Nothing -> return ui+        Just j  -> do+                    SDL.update+                    cs <- mapM (SDL.getAxis j) [0..1]+                    let [x,y] = map ( (\ x -> if abs x < 0.05 then 0 else x)+                                    . (\ x -> x - 1) . (* 2) . (/ (2^16 - 1))+                                    . (+ (2^15)) . fromIntegral+                                    )+                                    cs+                    debug_msg opts (show (x,y))+                    return (ui { axes = (x,y) })+++processKeyDown :: SDL.Keysym -> UInput -> UInput +processKeyDown = addKey . sdlKeyToKey++processKeyUp :: SDL.Keysym -> UInput -> UInput +processKeyUp = removeKey . sdlKeyToKey++processJoyButtonDown :: Word8 -> Word8 -> UInput -> UInput+processJoyButtonDown _ = addKey . joystickToKey++processJoyButtonUp :: Word8 -> Word8 -> UInput -> UInput+processJoyButtonUp   _ _ = id -- has to be changed if more keys are added!++-- | Convert joystick buttons into abstract keys.+joystickToKey :: Word8 -> Key+joystickToKey x | x == fromIntegral joystick_QUIT  = KQuit+                | otherwise                        = KUnknown++-- | Convert actual keys into abstract keys+-- (i.e., for changing game controls redefine this function).+sdlKeyToKey :: SDL.Keysym -> Key+sdlKeyToKey k = case SDL.symKey k of+                  SDL.SDLK_UP     -> KUp+                  SDL.SDLK_DOWN   -> KDown+                  SDL.SDLK_RIGHT  -> KRight+                  SDL.SDLK_LEFT   -> KLeft+                  SDL.SDLK_q      -> KQuit+                  _               -> KUnknown++++
+ src/Utilities.hs view
@@ -0,0 +1,22 @@+module Utilities where++import qualified Graphics.UI.SDL as SDL++-- | Get current ticks value.+getTicks :: IO Int+getTicks = do +             t <- SDL.getTicks+             return (fromIntegral (toInteger t))++-- | Wait for a specified number of ticks.+waitTicks :: Int -> IO ()+waitTicks = SDL.delay . fromIntegral++-- | Some OpenGL functions only work for images with dimensions that+-- are powers of two. This utility function computes the next power+-- of two.+nextPowerOfTwo :: (Integral a) => a -> a+nextPowerOfTwo x = 2 ^ ceiling (logBase 2 (fromIntegral x)) ++nextPowerOfTwoFraction :: (Integral a, Integral b, Floating c) => a -> b -> c+nextPowerOfTwoFraction x y = fromIntegral x / fromIntegral (nextPowerOfTwo y)