diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,11 @@ +0.4.4 + +* add missing files to cabal file (Samuel Gélineau) + +* support & require latest OpenGL 2.9 + +* make IOGame also a Functor and Applicative, for ghc 7.10 + 0.4.3 * set upper bound on OpenGL to avoid build failure with OpenGL 2.9 diff --git a/FunGEn.cabal b/FunGEn.cabal --- a/FunGEn.cabal +++ b/FunGEn.cabal @@ -1,5 +1,5 @@ name: FunGEn -version: 0.4.3 +version: 0.4.4 copyright: (C) 2002 Andre Furtado license: BSD3 license-file: LICENSE @@ -12,19 +12,51 @@ stability: alpha cabal-version: >= 1.6 build-type: Simple -tested-with: GHC==7.6.3 -extra-source-files: README.md, CHANGES, examples/pong/hit.wav, examples/pong/pong.hs, examples/pong/tex.bmp, - examples/worms/border1.bmp, examples/worms/border2.bmp, examples/worms/border3.bmp, - examples/worms/congratulations.bmp, examples/worms/food.bmp, examples/worms/free1.bmp, - examples/worms/free2.bmp, examples/worms/free3.bmp, examples/worms/gameover.bmp, - examples/worms/heade.bmp, examples/worms/heads.bmp, examples/worms/headn.bmp, - examples/worms/headw.bmp, examples/worms/level1.bmp, examples/worms/level2.bmp, - examples/worms/level3.bmp, examples/worms/segment.bmp, examples/worms/worms.hs +tested-with: GHC==7.8.2 +extra-source-files: + README.md, + CHANGES, + examples/pong/hit.wav, + examples/pong/pong.hs, + examples/pong/tex.bmp, + examples/worms/border1.bmp, + examples/worms/border2.bmp, + examples/worms/border3.bmp, + examples/worms/congratulations.bmp, + examples/worms/food.bmp, + examples/worms/free1.bmp, + examples/worms/free2.bmp, + examples/worms/free3.bmp, + examples/worms/gameover.bmp, + examples/worms/heade.bmp, + examples/worms/heads.bmp, + examples/worms/headn.bmp, + examples/worms/headw.bmp, + examples/worms/level1.bmp, + examples/worms/level2.bmp, + examples/worms/level3.bmp, + examples/worms/segment.bmp, + examples/worms/worms.hs library - exposed-modules: Graphics.UI.Fungen + ghc-options: -W + exposed-modules: + Graphics.UI.Fungen, + Graphics.UI.Fungen.Display, + Graphics.UI.Fungen.Game, + Graphics.UI.Fungen.Init, + Graphics.UI.Fungen.Input, + Graphics.UI.Fungen.Loader, + Graphics.UI.Fungen.Map, + Graphics.UI.Fungen.Objects, + Graphics.UI.Fungen.Text, + Graphics.UI.Fungen.Timer, + Graphics.UI.Fungen.Types, + Graphics.UI.Fungen.Util, + Graphics.UI.GLUT.Input + build-depends: - base == 4.* - ,OpenGL < 2.9 - ,GLUT < 2.5 + base == 4.* + ,OpenGL == 2.9.* + ,GLUT == 2.5.* ,random diff --git a/Graphics/UI/Fungen/Display.hs b/Graphics/UI/Fungen/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Display.hs @@ -0,0 +1,44 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | This FunGEn module renders the game window. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Display ( + display +) where + +import Graphics.UI.Fungen.Game +import Graphics.UI.Fungen.Util (when) +import Graphics.Rendering.OpenGL +import Graphics.UI.GLUT + +-- | Given a fungen Game and IOGame step action, generate a GLUT +-- display callback that steps the game and renders its resulting +-- state. 'Graphics.UI.Fungen.funInit' runs this automatically. +display :: Game t s u v -> IOGame t s u v () -> DisplayCallback +display g gameCycle = do + clear [ColorBuffer] + runIOGame (displayIOGame gameCycle) g + swapBuffers + flush + +-- | Run one update and display an IOGame. +displayIOGame :: IOGame t s u v () -> IOGame t s u v () +displayIOGame gameCycle = do + (_,_,objectsMoving) <- getGameFlags + when objectsMoving moveAllObjects + gameCycle + (mapDrawing,objectsDrawing,_) <- getGameFlags + when mapDrawing drawMap + when objectsDrawing drawAllObjects + printText diff --git a/Graphics/UI/Fungen/Game.hs b/Graphics/UI/Fungen/Game.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Game.hs @@ -0,0 +1,789 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module contains some important game routines. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + + +module Graphics.UI.Fungen.Game ( + Game, IOGame, + -- ** creating + createGame, + -- ** IO utilities + runIOGame, runIOGameM, liftIOtoIOGame, liftIOtoIOGame', + -- ** game state + getGameState, setGameState, + getGameAttribute, setGameAttribute, + -- ** game flags + getGameFlags, setGameFlags, + enableGameFlags, disableGameFlags, + enableMapDrawing, disableMapDrawing, + enableObjectsDrawing, disableObjectsDrawing, + enableObjectsMoving, disableObjectsMoving, + -- ** map operations + drawMap, clearScreen, getTileFromIndex, getTileFromWindowPosition, setCurrentMapIndex, + -- ** object operations + getObjectManagers, setObjectManagers, + drawAllObjects, drawObject, moveAllObjects, destroyObjects, destroyObject, + getObjectsFromGroup, addObjectsToGroup, addObjectsToNewGroup, findObjectManager,findObject, + getObjectName, getObjectGroupName, getObjectAsleep, getObjectSize, + getObjectPosition, getObjectSpeed, getObjectAttribute, + setObjectPosition, setObjectAsleep, setObjectSpeed, setObjectCurrentPicture, setObjectAttribute, + replaceObject, + reverseXSpeed, reverseYSpeed, + -- ** collision detection + objectsCollision, objectsFutureCollision, + objectListObjectCollision, objectListObjectFutureCollision, + objectTopMapCollision, objectBottomMapCollision, objectRightMapCollision, objectLeftMapCollision, + pointsObjectCollision, pointsObjectListCollision, + objectTopMapFutureCollision, objectBottomMapFutureCollision, objectRightMapFutureCollision, objectLeftMapFutureCollision, + -- ** text operations + printOnPrompt, printOnScreen, printText, + -- ** random numbers + randomFloat, randomInt, randomDouble, + -- ** utilities + showFPS, + wait +) where + +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util +import Graphics.UI.Fungen.Loader +import Graphics.UI.Fungen.Text +import Graphics.UI.Fungen.Map +import Graphics.UI.Fungen.Objects +import Graphics.Rendering.OpenGL +import Graphics.UI.GLUT +import Control.Applicative (Applicative(..)) +import Control.Monad +import Data.IORef +import Text.Printf + + +-- | A game has the type @Game t s u v@, where +-- +-- * t is the type of the game special attributes +-- +-- * s is the type of the object special attributes +-- +-- * u is the type of the game levels (state) +-- +-- * v is the type of the map tile special attribute, in case we use a Tile Map as the background of our game +-- +-- For a mnemonic, uh... +-- +-- * t - /T/op-level game attribute type, +-- +-- * s - /S/prite object attribute type, +-- +-- * u - /U/pdating game state type, +-- +-- * v - /V/icinity (map tile) attribute type. +-- +-- Internally, a Game consists of: +-- +-- * @gameMap :: IORef (GameMap v) -- a map (background)@ +-- +-- * @gameState :: IORef u -- initial game state@ +-- +-- * @gameFlags :: IORef GameFlags -- initial game flags@ +-- +-- * @objManagers :: IORef [(ObjectManager s)] -- some object managers@ +-- +-- * @textList :: IORef [Text] -- some texts@ +-- +-- * @quadricObj :: QuadricPrimitive -- a quadric thing@ +-- +-- * @windowConfig :: IORef WindowConfig -- a config for the main window@ +-- +-- * @gameAttribute :: IORef t -- a game attribute@ +-- +-- * @pictureList :: IORef [TextureObject] -- some pictures@ +-- +-- * @fpsInfo :: IORef (Int,Int,Float) -- only for debugging@ +-- +data Game t s u v = Game { + gameMap :: IORef (GameMap v), -- ^ a map (background) + gameState :: IORef u, -- ^ initial game state + gameFlags :: IORef GameFlags, -- ^ initial game flags + objManagers :: IORef [(ObjectManager s)], -- ^ some object managers + textList :: IORef [Text], -- ^ some texts + quadricObj :: QuadricPrimitive, -- ^ a quadric thing + windowConfig :: IORef WindowConfig, -- ^ a config for the main window + gameAttribute :: IORef t, -- ^ a game attribute + pictureList :: IORef [TextureObject], -- ^ some pictures + fpsInfo :: IORef (Int,Int,Float) -- only for debugging + } + +-- | IOGame is the monad in which game actions run. An IOGame action +-- takes a Game (with type parameters @t s u v@), performs some IO, +-- and returns an updated Game along with a result value (@a@): +-- +-- @newtype IOGame t s u v a = IOG (Game t s u v -> IO (Game t s u v,a))@ +-- +-- The name IOGame was chosen to remind that each action deals with a +-- Game, but an IO operation can also be performed between game +-- actions (such as the reading of a file or printing something in the +-- prompt). +newtype IOGame t s u v a = IOG (Game t s u v -> IO (Game t s u v,a)) + +-- | Game flags: mapDrawing, objectsDrawing, objectsMoving +type GameFlags = (Bool,Bool,Bool) + +---------------------------------- +-- IOGame Monad definitions +---------------------------------- +-- OBS.: all of this stuff is done to encapsulate Monad IO inside +-- Monad IOGame. Thanks to Jay Cox who suggested this solution. + +bindST :: IOGame t s u v a -> (a -> IOGame t s u v b) -> IOGame t s u v b +bindST (IOG x) f = + IOG (\s -> ( x s >>= \(s',v) -> let IOG g = f v in g s')) + +unitST :: a -> IOGame t s u v a +unitST v = IOG (\s -> return (s,v)) + +instance Functor (IOGame t s u v) where + fmap = liftM + +instance Applicative (IOGame t s u v) where + pure = return + (<*>) = ap + +instance Monad (IOGame t s u v) where + (>>=) = bindST + return = unitST + +runIOGame :: IOGame t s u v a -> Game t s u v -> IO (Game t s u v,a) -- (a,Game t s u v) the state tuple +runIOGame (IOG f) g = f g + +runIOGameM :: IOGame t s u v a -> Game t s u v -> IO () +runIOGameM x g = runIOGame x g >> return () + +liftIOtoIOGame :: IO a -> IOGame t s u v a +liftIOtoIOGame p = + IOG $ \s -> (do y <- p + return (s,y)) + +liftIOtoIOGame' :: (a -> IO ()) -> a -> IOGame t s u v () +liftIOtoIOGame' p q = + IOG $ \s -> (do p q + return (s,())) + +---------------------------------- +-- get & set routines +---------------------------------- + +getMap :: IOGame t s u v (GameMap v) +getMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> if (isMultiMap gm) + then (return (game,getCurrentMap gm)) + else (return (game,gm)) )) + +getRealMap :: IOGame t s u v (GameMap v) +getRealMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> (return (game,gm)) )) + +setRealMap :: GameMap v -> IOGame t s u v () +setRealMap m = IOG ( \game -> (writeIORef (gameMap game) m >> return (game,()) )) + + +getGameState :: IOGame t s u v u +getGameState = IOG ( \game -> (readIORef (gameState game) >>= \gs -> return (game,gs) )) + +setGameState :: u -> IOGame t s u v () +setGameState s = IOG ( \game -> (writeIORef (gameState game) s >> return (game,()) )) + +getTextList :: IOGame t s u v [Text] +getTextList = IOG ( \game -> (readIORef (textList game) >>= \tl -> return (game,tl) )) + +setTextList :: [Text] -> IOGame t s u v () +setTextList t = IOG ( \game -> (writeIORef (textList game) t >> return (game,()) )) + +getGameFlags :: IOGame t s u v GameFlags +getGameFlags = IOG ( \game -> (readIORef (gameFlags game) >>= \gf -> return (game,gf) )) + +setGameFlags :: GameFlags -> IOGame t s u v () +setGameFlags f = IOG ( \game -> (writeIORef (gameFlags game) f >> return (game,()) )) + +getObjectManagers :: IOGame t s u v [(ObjectManager s)] +getObjectManagers = IOG ( \game -> (readIORef (objManagers game) >>= \om -> return (game,om) )) + +setObjectManagers :: [(ObjectManager s)] -> IOGame t s u v () +setObjectManagers o = IOG ( \game -> (writeIORef (objManagers game) o >> return (game,()) )) + +getQuadric :: IOGame t s u v QuadricPrimitive +getQuadric = IOG ( \game -> return (game,quadricObj game) ) + +getPictureList :: IOGame t s u v [TextureObject] +getPictureList = IOG ( \game -> (readIORef (pictureList game) >>= \pl -> return (game,pl) )) + +getWindowConfig :: IOGame t s u v WindowConfig +getWindowConfig = IOG ( \game -> (readIORef (windowConfig game) >>= \wc -> return (game,wc) )) + +getGameAttribute :: IOGame t s u v t +getGameAttribute = IOG ( \game -> (readIORef (gameAttribute game) >>= \ga -> return (game,ga) )) + +setGameAttribute :: t -> IOGame t s u v () +setGameAttribute ga = IOG ( \game -> (writeIORef (gameAttribute game) ga >> return (game,()) )) + +-- internal use only +getFpsInfo :: IOGame t s u v (Int,Int,Float) +getFpsInfo = IOG ( \game -> (readIORef (fpsInfo game) >>= \fpsi -> return (game,fpsi) )) + +-- internal use only +setFpsInfo :: (Int,Int,Float) -> IOGame t s u v () +setFpsInfo f = IOG ( \game -> (writeIORef (fpsInfo game) f >> return (game,()) )) + +---------------------------------- +-- initialization of the game +---------------------------------- +createGame :: GameMap v -> [(ObjectManager s)] -> WindowConfig -> u -> t -> FilePictureList -> IO (Game t s u v) +createGame gMap objectManagers winConf gState gAttrib filePicList = do + gM <- newIORef gMap + gS <- newIORef gState + gF <- newIORef (True,True,True) + gO <- newIORef objectManagers + gT <- newIORef [] + let gQ = Sphere 0 0 0 + gW <- newIORef winConf + gA <- newIORef gAttrib + picList <- loadPictures filePicList + gP <- newIORef picList + gFPS <- newIORef (0,0,0.0) + return (Game { + gameMap = gM, + gameState = gS, + gameFlags = gF, + objManagers = gO, + textList = gT, + quadricObj = gQ, + windowConfig = gW, + gameAttribute = gA, + pictureList = gP, + fpsInfo = gFPS + }) + +-- | loads all of the pictures used in the game +loadPictures :: [(FilePath,InvList)] -> IO [TextureObject] +loadPictures pathsAndInvLists = do + bmps <- loadBitmapList (map pathAndInv2color3List pathsAndInvLists) + texBmList <- genObjectNames (length bmps) + texStuff texBmList bmps + return texBmList + +---------------------------------- +-- map routines +---------------------------------- + +-- | draws the background map +drawMap :: IOGame t s u v () +drawMap = do + m <- getMap + p <- getPictureList + (_,(winWidth, winHeight),_) <- getWindowConfig + liftIOtoIOGame $ drawGameMap m (fromIntegral winWidth, fromIntegral winHeight) p + +-- | returns a mapTile, given its pixel position (x,y) in the screen +getTileFromWindowPosition :: (GLdouble,GLdouble) -> IOGame t s u v (Tile v) +getTileFromWindowPosition (preX,preY) = do + m <- getMap + if (isTileMap m) + then let (tileXsize,tileYsize) = getTileMapTileSize m + (scrollX,scrollY) = getTileMapScroll m + (x,y) = (preX + scrollX,preY + scrollY) + (sX,sY) = getTileMapSize m + in if (x >= sX || y >= sY) + then error ("Game.getTileFromWindowPosition error: pixel " ++ (show (x,y)) ++ " out of map range!") + else getTileFromIndex (fromEnum (y/tileXsize),fromEnum (x/tileYsize)) -- (x,y) window orientation is different than index (x,y)! + else error "Game.getTileFromWindowPosition error: game map is not a tile map!" + +-- | returns a mapTile, given its index (x,y) in the tile map +getTileFromIndex :: (Int,Int) -> IOGame t s u v (Tile v) +getTileFromIndex (x,y) = do + m <- getMap + if (isTileMap m) + then let matrix = getTileMapTileMatrix m + (mapX,mapY) = matrixSize matrix + in if (mapX >= x && mapY >= y && x >= 0 && y >= 0) + then return ( (matrix !! (mapX - x)) !! y) + else error ("Game.getTileFromIndex error: tile index " ++ (show (x,y)) ++ " out of map range!") + else error "Game.getTileFromIndex error: game map is not a tile map!" + +-- | paint the whole screen with a specified RGB color +clearScreen :: GLclampf -> GLclampf -> GLclampf -> IOGame t s u v () +clearScreen r g b = liftIOtoIOGame $ clearGameScreen r g b + +-- | set the current map for a MultiMap +setCurrentMapIndex :: Int -> IOGame t s u v () +setCurrentMapIndex i = do + m <- getRealMap + if (isMultiMap m) + then (setRealMap (updateCurrentIndex m i)) + else (error "Game.setCurrentMapIndex error: you are not working with MultiMaps!") + +---------------------------------- +-- flags routines +---------------------------------- + +enableGameFlags :: IOGame t s u v () +enableGameFlags = setGameFlags (True,True,True) + +disableGameFlags :: IOGame t s u v () +disableGameFlags = setGameFlags (False,False,False) + +enableMapDrawing :: IOGame t s u v () +enableMapDrawing = do + (_,od,om) <- getGameFlags + setGameFlags (True,od,om) + +disableMapDrawing :: IOGame t s u v () +disableMapDrawing = do + (_,od,om) <- getGameFlags + setGameFlags (False,od,om) + +enableObjectsDrawing :: IOGame t s u v () +enableObjectsDrawing = do + (md,_,om) <- getGameFlags + setGameFlags (md,True,om) + +disableObjectsDrawing :: IOGame t s u v () +disableObjectsDrawing = do + (md,_,om) <- getGameFlags + setGameFlags (md,False,om) + +enableObjectsMoving :: IOGame t s u v () +enableObjectsMoving = do + (md,od,_) <- getGameFlags + setGameFlags (md,od,True) + +disableObjectsMoving :: IOGame t s u v () +disableObjectsMoving = do + (md,od,_) <- getGameFlags + setGameFlags (md,od,False) + +---------------------------------- +-- objects routines +---------------------------------- + +-- | draws all visible objects +drawAllObjects :: IOGame t s u v () +drawAllObjects = do + o <- getObjectManagers + q <- getQuadric + p <- getPictureList + liftIOtoIOGame $ drawGameObjects o q p + +-- | draw one object +drawObject :: GameObject s -> IOGame t s u v () +drawObject o = do + q <- getQuadric + p <- getPictureList + liftIOtoIOGame $ drawGameObject o q p + +-- | changes objects position according to its speed +moveAllObjects :: IOGame t s u v () +moveAllObjects = do + m <- getObjectManagers + let newManagers = moveGameObjects m + setObjectManagers newManagers + +-- | destroys objects from the game +destroyObjects :: [(GameObject s)] -> IOGame t s u v () +destroyObjects [] = return () +destroyObjects (o:os) = destroyObject o >> destroyObjects os + +-- | destroys an object from the game +destroyObject :: GameObject s -> IOGame t s u v () +destroyObject obj = do + m <- getObjectManagers + let objName = getGameObjectName obj + mngName <- getObjectGroupName obj + let newManagers = destroyGameObject objName mngName m + setObjectManagers newManagers + +-- | returns the list of all objects from the group whose name is given +getObjectsFromGroup :: String -> IOGame t s u v [(GameObject s)] +getObjectsFromGroup mngName = do + mng <- findObjectManager mngName + return (getObjectManagerObjects mng) + +-- | adds an object to a previously created group +addObjectsToGroup :: [(GameObject s)] -> String -> IOGame t s u v () +addObjectsToGroup objs managerName = do + -- manager <- findObjectManager managerName + managers <- getObjectManagers + let newManagers = addObjectsToManager objs managerName managers + setObjectManagers newManagers + +-- | adds an object to a new group +addObjectsToNewGroup :: [(GameObject s)] -> String -> IOGame t s u v () +addObjectsToNewGroup objs newMngName = do + let newManager = objectGroup newMngName objs + managers <- getObjectManagers + setObjectManagers (newManager:managers) + +-- | returns an object manager of the game, given its name (internal use) +findObjectManager :: String -> IOGame t s u v (ObjectManager s) +findObjectManager mngName = do + objectManagers <- getObjectManagers + return (searchObjectManager mngName objectManagers) + +-- | returns an object of the game, given its name and is object manager name +findObject :: String -> String -> IOGame t s u v (GameObject s) +findObject objName mngName = do + objectManagers <- getObjectManagers + let m = searchObjectManager mngName objectManagers + return (searchGameObject objName m) + +-- | there is no need to search through the managers, because the name of an object is +-- never modified so the result of this function will always be safe. +getObjectName :: GameObject s -> IOGame t s u v String +getObjectName o = return (getGameObjectName o) + +-- | because an object can have its group (manager) name modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectGroupName :: GameObject s -> IOGame t s u v String +getObjectGroupName o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectManagerName obj) + +-- | because an object can have its sleeping status modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectAsleep :: GameObject s -> IOGame t s u v Bool +getObjectAsleep o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectAsleep obj) + +-- | because an object can have its size modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectSize :: GameObject s -> IOGame t s u v (GLdouble,GLdouble) +getObjectSize o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectSize obj) + +-- | because an object can have its position modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectPosition :: GameObject s -> IOGame t s u v (GLdouble,GLdouble) +getObjectPosition o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectPosition obj) + +-- | because an object can have its speed modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectSpeed :: GameObject s -> IOGame t s u v (GLdouble,GLdouble) +getObjectSpeed o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectSpeed obj) + +-- | because an object can have its attribute modified, it is necessary +-- to search through the managers to find it, otherwise this functions won't be safe. +getObjectAttribute :: GameObject s -> IOGame t s u v s +getObjectAttribute o = do managers <- getObjectManagers + let obj = findObjectFromId o managers + return (getGameObjectAttribute obj) + +-- | changes the sleeping status of an object, given its new status +setObjectAsleep :: Bool -> GameObject s -> IOGame t s u v () +setObjectAsleep asleep obj = replaceObject obj (updateObjectAsleep asleep) + +-- | changes the position of an object, given its new position +setObjectPosition :: (GLdouble,GLdouble) -> GameObject s -> IOGame t s u v () +setObjectPosition pos obj = replaceObject obj (updateObjectPosition pos) + +-- | changes the speed of an object, given its new speed +setObjectSpeed :: (GLdouble,GLdouble) -> GameObject s -> IOGame t s u v () +setObjectSpeed speed obj = replaceObject obj (updateObjectSpeed speed) + +-- | changes the current picture of a multitextured object +setObjectCurrentPicture :: Int -> GameObject s -> IOGame t s u v () +setObjectCurrentPicture n obj = do + picList <- getPictureList + replaceObject obj (updateObjectPicture n ((length picList) - 1)) + +-- | changes the attribute of an object, given its new attribute +setObjectAttribute :: s -> GameObject s -> IOGame t s u v () +setObjectAttribute a obj = replaceObject obj (updateObjectAttribute a) + +-- | replaces an object by a new one, given the old object and the function that must be applied to it. +replaceObject :: GameObject s -> (GameObject s -> GameObject s) -> IOGame t s u v () +replaceObject obj f = do + managerName <- getObjectGroupName obj + oldManagers <- getObjectManagers + let objectId = getGameObjectId obj + newManagers = updateObject f objectId managerName oldManagers + setObjectManagers newManagers + +reverseXSpeed :: GameObject s -> IOGame t s u v () +reverseXSpeed o = do (vX,vY) <- getObjectSpeed o + setObjectSpeed (-vX,vY) o + +reverseYSpeed :: GameObject s -> IOGame t s u v () +reverseYSpeed o = do (vX,vY) <- getObjectSpeed o + setObjectSpeed (vX,-vY) o + +----------------------- +-- collision routines +----------------------- + +-- | checks the collision between an object and the top of the map +objectTopMapCollision :: GameObject s -> IOGame t s u v Bool +objectTopMapCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do m <- getMap + (_,pY) <- getObjectPosition o + (_,sY) <- getObjectSize o + let (_,mY) = getMapSize m + return (pY + (sY/2) > (realToFrac mY)) + +-- | checks the collision between an object and the top of the map in the next game cicle +objectTopMapFutureCollision :: GameObject s -> IOGame t s u v Bool +objectTopMapFutureCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do m <- getMap + (_,pY) <- getObjectPosition o + (_,vY) <- getObjectSpeed o + (_,sY) <- getObjectSize o + let (_,mY) = getMapSize m + return (pY + (sY/2) + vY > (realToFrac mY)) + +-- | checks the collision between an object and the bottom of the map +objectBottomMapCollision :: GameObject s -> IOGame t s u v Bool +objectBottomMapCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do (_,pY) <- getObjectPosition o + (_,sY) <- getObjectSize o + return (pY - (sY/2) < 0) + +-- | checks the collision between an object and the bottom of the map in the next game cicle +objectBottomMapFutureCollision :: GameObject s -> IOGame t s u v Bool +objectBottomMapFutureCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do (_,pY) <- getObjectPosition o + (_,sY) <- getObjectSize o + (_,vY) <- getObjectSpeed o + return (pY - (sY/2) + vY < 0) + +-- | checks the collision between an object and the right side of the map +objectRightMapCollision :: GameObject s -> IOGame t s u v Bool +objectRightMapCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do m <- getMap + (pX,_) <- getObjectPosition o + (sX,_) <- getObjectSize o + let (mX,_) = getMapSize m + return (pX + (sX/2) > (realToFrac mX)) + +-- | checks the collision between an object and the right side of the map in the next game cicle +objectRightMapFutureCollision :: GameObject s -> IOGame t s u v Bool +objectRightMapFutureCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do m <- getMap + (pX,_) <- getObjectPosition o + (sX,_) <- getObjectSize o + (vX,_) <- getObjectSpeed o + let (mX,_) = getMapSize m + return (pX + (sX/2) + vX > (realToFrac mX)) + +-- | checks the collision between an object and the left side of the map +objectLeftMapCollision :: GameObject s -> IOGame t s u v Bool +objectLeftMapCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do (pX,_) <- getObjectPosition o + (sX,_) <- getObjectSize o + return (pX - (sX/2) < 0) + +-- | checks the collision between an object and the left side of the map in the next game cicle +objectLeftMapFutureCollision :: GameObject s -> IOGame t s u v Bool +objectLeftMapFutureCollision o = do + asleep <- getObjectAsleep o + if asleep + then (return False) + else do (pX,_) <- getObjectPosition o + (sX,_) <- getObjectSize o + (vX,_) <- getObjectSpeed o + return (pX - (sX/2) + vX < 0) + +-- | checks the collision between two objects +objectsCollision :: GameObject s -> GameObject s -> IOGame t s u v Bool +objectsCollision o1 o2 = do + asleep1 <- getObjectAsleep o1 + asleep2 <- getObjectAsleep o2 + if (asleep1 || asleep2) + then (return False) + else do (p1X,p1Y) <- getObjectPosition o1 + (p2X,p2Y) <- getObjectPosition o2 + (s1X,s1Y) <- getObjectSize o1 + (s2X,s2Y) <- getObjectSize o2 + + let aX1 = p1X - (s1X/2) + aX2 = p1X + (s1X/2) + aY1 = p1Y - (s1Y/2) + aY2 = p1Y + (s1Y/2) + + bX1 = p2X - (s2X/2) + bX2 = p2X + (s2X/2) + bY1 = p2Y - (s2Y/2) + bY2 = p2Y + (s2Y/2) + + return ((bX1 < aX2) && (aX1 < bX2) && (bY1 < aY2) && (aY1 < bY2)) + +-- | checks the collision between two objects in the next game cicle +objectsFutureCollision :: GameObject s -> GameObject s -> IOGame t s u v Bool +objectsFutureCollision o1 o2 = do + asleep1 <- getObjectAsleep o1 + asleep2 <- getObjectAsleep o2 + if (asleep1 || asleep2) + then (return False) + else do (p1X,p1Y) <- getObjectPosition o1 + (p2X,p2Y) <- getObjectPosition o2 + (v1X,v1Y) <- getObjectSpeed o1 + (v2X,v2Y) <- getObjectSpeed o2 + (s1X,s1Y) <- getObjectSize o1 + (s2X,s2Y) <- getObjectSize o2 + + let aX1 = p1X - (s1X/2) + v1X + aX2 = p1X + (s1X/2) + v1X + aY1 = p1Y - (s1Y/2) + v1Y + aY2 = p1Y + (s1Y/2) + v1Y + + bX1 = p2X - (s2X/2) + v2X + bX2 = p2X + (s2X/2) + v2X + bY1 = p2Y - (s2Y/2) + v2Y + bY2 = p2Y + (s2Y/2) + v2Y + return ((bX1 < aX2) && (aX1 < bX2) && (bY1 < aY2) && (aY1 < bY2)) + +objectListObjectCollision :: [(GameObject s)] -> GameObject s -> IOGame t s u v Bool +objectListObjectCollision [] _ = return False +objectListObjectCollision (a:as) b = do + col <- objectsCollision a b + if col + then (return True) + else (objectListObjectCollision as b) + +objectListObjectFutureCollision :: [(GameObject s)] -> GameObject s -> IOGame t s u v Bool +objectListObjectFutureCollision [] _ = return False +objectListObjectFutureCollision (a:as) b = do + col <- objectsFutureCollision a b + if col + then (return True) + else (objectListObjectFutureCollision as b) + +pointsObjectCollision :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> GameObject s -> IOGame t s u v Bool +pointsObjectCollision p1X p1Y s1X s1Y o2 = do + asleep <- getObjectAsleep o2 + if asleep + then (return False) + else do (p2X,p2Y) <- getObjectPosition o2 + (s2X,s2Y) <- getObjectSize o2 + + let aX1 = p1X - (s1X/2) + aX2 = p1X + (s1X/2) + aY1 = p1Y - (s1Y/2) + aY2 = p1Y + (s1Y/2) + + bX1 = p2X - (s2X/2) + bX2 = p2X + (s2X/2) + bY1 = p2Y - (s2Y/2) + bY2 = p2Y + (s2Y/2) + return ((bX1 < aX2) && (aX1 < bX2) && (bY1 < aY2) && (aY1 < bY2)) + +pointsObjectListCollision :: GLdouble -> GLdouble -> GLdouble -> GLdouble -> [(GameObject s)] -> IOGame t s u v Bool +pointsObjectListCollision _ _ _ _ [] = return False +pointsObjectListCollision p1X p1Y s1X s1Y (o:os) = do + col <- pointsObjectCollision p1X p1Y s1X s1Y o + if col + then (return True) + else (pointsObjectListCollision p1X p1Y s1X s1Y os) + +----------------------------------------------- +-- TEXT ROUTINES -- +----------------------------------------------- +-- | prints a string in the prompt +printOnPrompt :: Show a => a -> IOGame t s u v () +printOnPrompt a = liftIOtoIOGame' print a + +-- | prints a string in the current window +printOnScreen :: String -> BitmapFont -> (GLdouble,GLdouble) -> GLclampf -> GLclampf -> GLclampf -> IOGame t s u v () +printOnScreen text font pos r g b = do + t <- getTextList + setTextList ([(text,font,pos,r,g,b)] ++ t) + +-- | internal use of the engine +printText :: IOGame t s u v () +printText = do + t <- getTextList + liftIOtoIOGame $ putGameText t + setTextList [] + +----------------------------------------------- +-- RANDOM NUMBER GENERATOR ROUTINES -- +----------------------------------------------- +randomInt :: (Int,Int) -> IOGame t s u v Int +randomInt (x,y) = liftIOtoIOGame $ randInt (x,y) + +randomFloat :: (Float,Float) -> IOGame t s u v Float +randomFloat (x,y) = liftIOtoIOGame $ randFloat (x,y) + +randomDouble :: (Double,Double) -> IOGame t s u v Double +randomDouble (x,y) = liftIOtoIOGame $ randDouble (x,y) + +----------------------------------------------- +-- DEBUGGING ROUTINES -- +----------------------------------------------- + +-- | shows the frame rate (or frame per seconds) +showFPS :: BitmapFont -> (GLdouble,GLdouble) -> GLclampf -> GLclampf -> GLclampf -> IOGame t s u v () +showFPS font pos r g b = do + (framei,timebasei,fps) <- getFpsInfo + timei <- getElapsedTime + let frame = (toEnum (framei + 1)) :: Float + timebase = (toEnum timebasei) :: Float + time = (toEnum timei) :: Float + if (timei - timebasei > 1000) + then setFpsInfo (0,timei,(frame*(toEnum 1000)/(time-timebase))) + else setFpsInfo ((framei + 1),timebasei,fps) + printOnScreen (printf "%.1f" fps) font pos r g b + +-- | get the elapsed time of the game +getElapsedTime :: IOGame t s u v Int +getElapsedTime = liftIOtoIOGame $ get elapsedTime + +-- | delay for N seconds while continuing essential game functions +wait :: Int -> IOGame t s u v () +wait delay = do + printText -- force text messages to be printed (is not working properly!) + (framei,timebasei,fps) <- getFpsInfo + setFpsInfo (framei,(timebasei + delay),fps) -- helps FPS info to be displayed correctly (if requested) + startTime <- getElapsedTime + + waitAux delay startTime + +waitAux :: Int -> Int -> IOGame t s u v () +waitAux delay startTime = do + presentTime <- getElapsedTime + if (presentTime - startTime > delay) + then return () + else waitAux delay startTime diff --git a/Graphics/UI/Fungen/Init.hs b/Graphics/UI/Fungen/Init.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Init.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module contains the initialization procedures. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Init ( + funInit + ,funExit +)where + +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Loader(FilePictureList) +import Graphics.UI.Fungen.Display +import Graphics.UI.Fungen.Input +import Graphics.UI.Fungen.Map +import Graphics.UI.Fungen.Objects +import Graphics.UI.Fungen.Game +import Graphics.UI.Fungen.Timer +import Graphics.Rendering.OpenGL +import Graphics.UI.GLUT +import System.Exit + +-- | Configure a FunGEn game and start it running. +funInit :: WindowConfig -- ^ main window layout + -> GameMap v -- ^ background/map(s) + -> [(ObjectManager s)] -- ^ object groups + -> u -- ^ initial game state + -> t -- ^ initial game attribute + -> [InputBinding t s u v] -- ^ input bindings + -> IOGame t s u v () -- ^ step action + -> RefreshType -- ^ main loop timing + -> FilePictureList -- ^ image files + -> IO () +funInit winConfig@((px,py),(sx,sy),t) userMap objectGroups gState gAttrib i gameCicle r picList = do + initialize "FunGen app" [] + createWindow t -- (return ()) [ Double, RGBA ] + windowPosition $= Position (fromIntegral px) (fromIntegral py) + windowSize $= Size (fromIntegral sx) (fromIntegral sy) + basicInit sx sy + game <- createGame userMap objectGroups winConfig gState gAttrib picList + (_bindKey, stillDown) <- funInitInput i game + displayCallback $= (display game gameCicle) + setRefresh r stillDown + mainLoop + +basicInit :: Int -> Int -> IO () +basicInit sx sy = do + clearColor $= (Color4 0 0 0 0) + clear [ColorBuffer] + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + hint PerspectiveCorrection $= Nicest + matrixMode $= Projection + loadIdentity + ortho 0.0 (fromIntegral sx) 0.0 (fromIntegral sy) (-1.0) 1.0 + matrixMode $= Modelview 0 + loadIdentity + +-- | Exit the program successfully (from within a game action). +funExit :: IOGame t s u v () +funExit = liftIOtoIOGame' exitWith ExitSuccess + diff --git a/Graphics/UI/Fungen/Input.hs b/Graphics/UI/Fungen/Input.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Input.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module controls the user input (mouse, keyboard, joystick...) +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Input ( + InputBinding, InputHandler, + KeyEvent(..), Key(..), SpecialKey(..), MouseButton(..), Modifiers(..), Position(..), + funInitInput +) where + +import Graphics.UI.Fungen.Game +import Graphics.UI.GLUT +import Graphics.UI.GLUT.Input (KeyEvent(..), KeyBinder, StillDownHandler, glutInitInput) + +-- | A FunGEn input handler is like an IOGame (game action) that takes +-- two extra arguments: the current keyboard modifiers state, and the +-- current mouse position. (For a StillDown event, these will be the +-- original state and position from the Press event.) +type InputHandler t s u v = Modifiers -> Position -> IOGame t s u v () + +-- | A mapping from an input event to an input handler. +type InputBinding t s u v = (Key, KeyEvent, InputHandler t s u v) + +-- | Initialise the input system, which keeps a list of input event to +-- action bindings and executes the the proper actions automatically. +-- Returns a function for adding bindings (GLUT's - should return the +-- FunGEn-aware one instead ?), and another which should be called +-- periodically (eg from refresh) to trigger still-down actions. +funInitInput :: [InputBinding t s u v] -> Game t s u v -> IO (KeyBinder, StillDownHandler) +funInitInput bindings game = do + (glutBindKey, glutStillDown) <- glutInitInput + let funBindKey (key, keyEvent, inputHandler) = + glutBindKey key keyEvent (Just (\mods pos -> runIOGameM (inputHandler mods pos) game)) + mapM funBindKey bindings + return (glutBindKey, glutStillDown) diff --git a/Graphics/UI/Fungen/Loader.hs b/Graphics/UI/Fungen/Loader.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Loader.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module loads [bmp] files. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Loader ( + loadBitmap, loadBitmapList, FilePictureList +) where + +import Graphics.Rendering.OpenGL +import System.IO +import Foreign +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util + +binAux :: String +binAux = "000000000000000000000000" + +type BmpList = [(GLubyte, GLubyte, GLubyte, GLubyte)] +type FilePictureList = [(FilePath,InvList)] + +-- | Loads a bitmap from a file. +loadBitmap :: FilePath -> Maybe ColorList3 -> IO AwbfBitmap +loadBitmap bmName invList = do + bmFile <- openBinaryFile bmName (ReadMode) + bmString <- hGetContents bmFile + (bmW,bmH) <- getWH (dropGLsizei 18 bmString) + bmData <- getBmData (dropGLsizei 54 bmString) (bmW,bmH) invList + hClose bmFile + return (bmW,bmH,bmData) + +-- | Loads n bitmaps from n files. +loadBitmapList :: [(FilePath, Maybe ColorList3)] -> IO [AwbfBitmap] +loadBitmapList bmps = do + bmList <- loadBmListAux bmps [] + return (reverse bmList) + +loadBmListAux :: [(FilePath, Maybe ColorList3)] -> [AwbfBitmap] -> IO [AwbfBitmap] +loadBmListAux [] bmList = return (bmList) +loadBmListAux ((n,l):as) bmList = do + bm <- loadBitmap n l + loadBmListAux as (bm:bmList) + +getWH :: String -> IO (GLsizei,GLsizei) +getWH (a:b:c:d:e:f:g:h:_) = do + return ( (op (bin a) 0) + (op (bin b) 8) + (op (bin c) 16) + (op (bin d) 24), + (op (bin e) 0) + (op (bin f) 8) + (op (bin g) 16) + (op (bin h) 24)) + where bin x = toBinary(fromEnum x) + op x n = toDecimal(shiftLeft(binAux ++ (make0 (8 - (length x)) ++ x)) n) +getWH _ = error "Loader.getWH error: strange bitmap file" + +getBmData :: String -> (GLsizei,GLsizei) -> Maybe ColorList3 -> IO (PixelData GLubyte) +getBmData bmString (bmW,bmH) invList = + let colorList = makeColorList bmString (bmW,bmH) in + newArray [Color4 r g b a | (r,g,b,a) <- addInvisiblity colorList invList] >>= \bmData -> + return (PixelData RGBA UnsignedByte (castPtr bmData)) + +addInvisiblity :: ColorList3 -> Maybe ColorList3 -> BmpList +addInvisiblity [] _ = [] +addInvisiblity l Nothing = map (\(r,g,b) -> (r,g,b,255)) l +addInvisiblity ((r,g,b):as) i@(Just invList) | (r,g,b) `elem` invList = ((r,g,b,0):(addInvisiblity as i)) + | otherwise = ((r,g,b,255):(addInvisiblity as i)) + +makeColorList :: String -> (GLsizei,GLsizei) -> [(GLubyte, GLubyte, GLubyte)] +makeColorList bmString (bmW,bmH) = makeColorListAux (bmW `mod` 4) bmString (bmW*bmH) (bmW,bmW) + +makeColorListAux :: GLsizei -> String -> GLsizei -> (GLsizei,GLsizei) -> [(GLubyte, GLubyte, GLubyte)] +makeColorListAux _ _ 0 _ = [] +makeColorListAux x bmString totVert (0,bmW) = makeColorListAux x (dropGLsizei x bmString) totVert (bmW,bmW) +makeColorListAux x (b:g:r:bmString) totVert (n,bmW) = (ord2 r,ord2 g,ord2 b): (makeColorListAux x bmString (totVert - 1) (n - 1,bmW)) +makeColorListAux _ _ _ _ = error "Loader.makeColorListAux error: strange bitmap file" diff --git a/Graphics/UI/Fungen/Map.hs b/Graphics/UI/Fungen/Map.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Map.hs @@ -0,0 +1,240 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module contains the map (game background) routines. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Map ( + GameMap, Tile, TileMatrix, + -- ** creating + colorMap, textureMap, tileMap, multiMap, + -- ** map attributes + isTileMap, isMultiMap, getMapSize, getTileMapTileMatrix, getTileMapScroll, getTileMapSize, getTileMapTileSize, + -- ** map tiles + getTilePictureIndex, getTileBlocked, getTileMoveCost, getTileSpecialAttribute, + -- ** setting the current map + getCurrentMap, updateCurrentMap, updateCurrentIndex, + -- ** drawing + drawGameMap, clearGameScreen, +) where + +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util +import Graphics.Rendering.OpenGL + +type Tile t = (Int,Bool,Float,t) -- ^ index of picture, possibility to move, cost to move, additional params +type TileMatrix t = [[(Tile t)]] +type TileLine t = [(Tile t)] + +-- | A game background (flat color, scrollable texture, or tile map), or several of them. +data GameMap t + = ColorMap (Color4 GLclampf) Point2D -- ^ color of the map, size of the map + | TextureMap Int Point2D Point2D Point2D Point2D -- ^ texture id, size of texture, present scroll (visible window bottom & left), scroll speed (X,Y),size of the map + | TileMap (TileMatrix t) Point2D Point2D Point2D Point2D -- ^ texture handles, tiles matrix, size of tile, present scroll (visible window bottom & left), scroll speed (X,Y), size of the map + | MultiMap [(GameMap t)] Int -- ^ list of maps, current map +-- | PolygMap [Primitive] + +getMapSize :: GameMap t -> Point2D +getMapSize (ColorMap _ s) = s +getMapSize (TextureMap _ _ _ _ s) = s +getMapSize (TileMap _ _ _ _ s) = s +getMapSize (MultiMap _ _) = error "Map.getMapSize error: getMapSize cannot be applied with MultiMaps!" + +---------------------------- +-- * special TileMap routines +---------------------------- + +isTileMap :: GameMap t -> Bool +isTileMap (TileMap _ _ _ _ _) = True +isTileMap _ = False + +getTileMapTileMatrix :: GameMap t -> TileMatrix t +getTileMapTileMatrix (TileMap m _ _ _ _) = m +getTileMapTileMatrix _ = error "Map.getTileMapTileMatrix error: game map is not a tile map!" + +getTileMapTileSize :: GameMap t -> Point2D +getTileMapTileSize (TileMap _ ts _ _ _) = ts +getTileMapTileSize _ = error "Map.getTileMapTileSize error: game map is not a tile map!" + +getTileMapScroll :: GameMap t -> Point2D +getTileMapScroll (TileMap _ _ s _ _) = s +getTileMapScroll _ = error "Map.getTileMapScroll error: game map is not a tile map!" + +getTileMapSize :: GameMap t -> Point2D +getTileMapSize (TileMap _ _ _ _ s) = s +getTileMapSize _ = error "Map.getTileMapSize error: game map is not a tile map!" + + +------------------------------ +-- * get routines for a Tile +------------------------------ + +getTilePictureIndex :: Tile t -> Int +getTilePictureIndex (i,_,_,_) = i + +getTileBlocked :: Tile t -> Bool +getTileBlocked (_,b,_,_) = b + +getTileMoveCost :: Tile t -> Float +getTileMoveCost (_,_,m,_) = m + +getTileSpecialAttribute:: Tile t -> t +getTileSpecialAttribute (_,_,_,t) = t + + +------------------------------- +-- * get routines for a MultiMap +------------------------------- + +getCurrentMap :: GameMap t -> GameMap t +getCurrentMap (MultiMap l i) = (l !! i) +getCurrentMap _ = error "Map.getCurrentMap error: getCurrentMap can only be applied with MultiMaps!" + +updateCurrentMap :: GameMap t -> GameMap t -> GameMap t +updateCurrentMap (MultiMap l i) newMap = MultiMap (newMapList l newMap i) i +updateCurrentMap _ _ = error "Map.updateCurrentMap error: updateCurrentMap can only be applied with MultiMaps!" + +-- internal use only! +newMapList :: [(GameMap t)] -> GameMap t -> Int -> [(GameMap t)] +newMapList [] _ _ = error "Map.newMapList error: please report this bug to awbf@uol.com.br" +newMapList (_:ms) newMap 0 = newMap:ms +newMapList (m:ms) newMap n = m:(newMapList ms newMap (n - 1)) + +isMultiMap :: GameMap t -> Bool +isMultiMap (MultiMap _ _) = True +isMultiMap _ = False + +updateCurrentIndex :: GameMap t -> Int -> GameMap t +updateCurrentIndex (MultiMap mapList _) i | (i >= (length mapList)) = error "Map.updateMultiMapIndex error: map index out of range!" + | otherwise = (MultiMap mapList i) +updateCurrentIndex _ _ = error "Map.updateCurrentIndex error: the game map is not a MultiMap!" + +----------------------------- +-- * creation of maps +----------------------------- + +-- | creates a PreColorMap +colorMap :: GLclampf -> GLclampf -> GLclampf -> GLdouble -> GLdouble -> GameMap t +colorMap r g b sX sY = ColorMap (Color4 r g b 1.0) (sX,sY) + +-- | creates a PreTextureMap +textureMap :: Int -> GLdouble -> GLdouble -> GLdouble -> GLdouble -> GameMap t +textureMap texId tX tY sX sY = TextureMap texId (tX,tY) (0,0) (0,0) (sX,sY) + +-- | creates a PreTileMap, cheking if the tileMatrix given is valid and automatically defining the map size +tileMap :: TileMatrix t -> GLdouble -> GLdouble -> GameMap t +tileMap matrix tX tY | matrixOk matrix = TileMap matrix (tX,tY) (0,0) (0,0) (sX,sY) + | otherwise = error "Map.tileMap error: each line of your TileMap must have the same number of tiles!" + where sX = ((fromIntegral.length.head) matrix) * tX + sY = ((fromIntegral.length) matrix) * tY + +-- | creates a multimap +multiMap :: [(GameMap t)] -> Int -> GameMap t +multiMap [] _ = error "Map.multiMap error: the MultiMap map list should not be empty!" +multiMap mapList currentMap | (currentMap >= (length mapList)) = error "Map.multiMap error: map index out of range!" + | (mapListContainsMultiMap mapList) = error "Map.multiMap error: a MultiMap should not contain another MultiMap!" + | otherwise = MultiMap mapList currentMap + +-- checks if a GameMap list contains a multimap (internal use only!) +mapListContainsMultiMap :: [(GameMap t)] -> Bool +mapListContainsMultiMap [] = False +mapListContainsMultiMap (a:as) | (isMultiMap a) = True + | otherwise = mapListContainsMultiMap as + +-- checks if the tile matrix is a square matrix +matrixOk :: TileMatrix t -> Bool +matrixOk [] = False +matrixOk (m:ms) = matrixOkAux (length m) ms + +matrixOkAux :: Int -> TileMatrix t -> Bool +matrixOkAux _ [] = True +matrixOkAux s (m:ms) | (length m) == s = matrixOkAux s ms + | otherwise = False + + +---------------------------------------- +-- * map drawing +---------------------------------------- + +-- | clear the screen +clearGameScreen :: GLclampf -> GLclampf -> GLclampf -> IO () +clearGameScreen r g b = do + clearColor $= (Color4 r g b 1.0) + clear [ColorBuffer] + +-- | draw the background map +drawGameMap :: GameMap t -> Point2D -> [TextureObject] -> IO () +drawGameMap (ColorMap c _) _ _ = do + clearColor $= c + clear [ColorBuffer] + clearColor $= (Color4 0 0 0 0) -- performance drawback? +drawGameMap (TextureMap texId (tX,tY) (vX,vY) _ _) winSize texList = do + texture Texture2D $= Enabled + bindTexture Texture2D (texList !! texId) + drawTextureMap (tX,tY) (new_winX, new_winY) winSize new_winY texList + texture Texture2D $= Disabled + where new_winX | (vX >= 0) = - vX + | otherwise = - vX - tX + new_winY | (vY >= 0) = - vY + | otherwise = - vY - tY +drawGameMap (TileMap matrix size visible _ _) winSize texList = do + texture Texture2D $= Enabled + drawTileMap (reverse matrix) size visible winSize 0.0 texList + texture Texture2D $= Disabled +drawGameMap (MultiMap _ _) _ _ = error "Map.drawGameMap error: drawGameMap cannot be applied with MultiMaps!" + +-- size of texture, drawing position relative to (X,Y) axis of window, lowest Y drawing position +drawTextureMap :: Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTextureMap (tX,tY) (winX,winY) (winWidth,winHeight) baseY texList + | (winY > winHeight) = drawTextureMap (tX,tY) (winX + tX, baseY) (winWidth,winHeight) baseY texList + | (winX > winWidth) = return () + | otherwise = do + loadIdentity + translate (Vector3 winX winY (0 :: GLdouble) ) + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + renderPrimitive Quads $ do + texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) + texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) + drawTextureMap (tX,tY) (winX,winY + tY) (winWidth,winHeight) baseY texList + +-- textures handles, tile matrix, size of texture, (X,Y) scroll, drawing position relative to Y axis of window +drawTileMap :: TileMatrix t -> Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTileMap [] _ _ _ _ _ = return () -- no more tile lines to drawn, so we're done here! +drawTileMap (a:as) (tX,tY) (sX,sY) (winWidth,winHeight) winY texList + | (sY >= tY) = drawTileMap as (tX,tY) (sX,sY-tY) (winWidth,winHeight) winY texList -- scrolls in the Y axis + | (winY > winHeight) = return () -- drawing position is higher than the Y window coordinate + | otherwise = do + drawTileMapLine a (tX,tY) sX (0.0,winY-sY) winWidth texList + drawTileMap as (tX,tY) (sX,sY) (winWidth,winHeight) (winY - sY + tY) texList + +-- textures handles, tile line, size of texture, X scroll, drawing position relative to (X,Y) axis of window +drawTileMapLine :: TileLine t -> Point2D -> GLdouble -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTileMapLine [] _ _ _ _ _ = return () -- no more tiles to drawn, so we're done here! +drawTileMapLine (a:as) (tX,tY) sX (winX,winY) winWidth texList + | (sX >= tX) = drawTileMapLine as (tX,tY) (sX-tX) (winX,winY) winWidth texList -- scrolls in the X axis + | (winX > winWidth) = return () -- drawing position is higher than the X window coordinate + | otherwise = do + bindTexture Texture2D (texList !! (getTilePictureIndex a)) + loadIdentity + translate (Vector3 (new_winX) winY (0 :: GLdouble) ) + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + renderPrimitive Quads $ do + texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) + texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) + drawTileMapLine as (tX,tY) sX (new_winX + sX + tX,winY) winWidth texList + where new_winX | (sX >= 0) = winX + sX + | otherwise = winX + sX diff --git a/Graphics/UI/Fungen/Objects.hs b/Graphics/UI/Fungen/Objects.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Objects.hs @@ -0,0 +1,337 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This module contains the FunGEn objects procedures +-} +{- +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Objects ( + ObjectManager, + GameObject, + ObjectPicture(..), Primitive(..), + FillMode (..), + -- ** creating + object, + -- ** object attributes + getGameObjectId, getGameObjectName, getGameObjectManagerName, getGameObjectAsleep, + getGameObjectPosition, getGameObjectSize, getGameObjectSpeed, getGameObjectAttribute, + -- ** updating + updateObject, updateObjectAsleep, updateObjectSize, updateObjectPosition, + updateObjectSpeed, updateObjectAttribute, updateObjectPicture, + -- ** drawing + drawGameObjects, drawGameObject, + -- ** moving + moveGameObjects, + -- ** destroying + destroyGameObject, + -- ** groups of objects + objectGroup, addObjectsToManager, + getObjectManagerName, getObjectManagerCounter , getObjectManagerObjects, + -- ** searching + findObjectFromId, searchObjectManager, searchGameObject, +) where + +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util +import Graphics.Rendering.OpenGL hiding (Primitive) + +data GameObject t = GO { + objId :: Integer, + objName :: String, + objManagerName :: String, + objPicture :: GameObjectPicture, + objAsleep :: Bool, + objSize :: Point2D, + objPosition :: Point2D, + objSpeed :: Point2D, + objAttribute :: t + } + +data ObjectManager t = OM { + mngName :: String, -- name of the manager + mngCounter :: Integer, -- next current avaible index for a new object + mngObjects :: [(GameObject t)] -- the SET of objects + } + +data GamePrimitive + = P [Vertex3 GLdouble] (Color4 GLfloat) FillMode + | C GLdouble (Color4 GLfloat) FillMode + +data GameObjectPicture + = Tx Int + | B GamePrimitive +-- | A [TextureObject] Int -- miliseconds between frames + +data Primitive + = Polyg [Point2D] GLfloat GLfloat GLfloat FillMode -- the points (must be in CCW order!), color, fill mode + | Circle GLdouble GLfloat GLfloat GLfloat FillMode -- color, radius, fill mode + +data ObjectPicture + = Tex (GLdouble,GLdouble) Int -- size, current texture + | Basic Primitive +-- | Animation [(FilePath,InvList)] Int -- (path to file, invisible colors), miliseconds between frames + +data FillMode + = Filled + | Unfilled + deriving Eq + +------------------------------------------- +-- get & updating routines for GameObjects +------------------------------------------- +getGameObjectId :: GameObject t -> Integer +getGameObjectId = objId + +getGameObjectName :: GameObject t -> String +getGameObjectName = objName + +getGameObjectManagerName :: GameObject t -> String +getGameObjectManagerName = objManagerName + +-- internal use only! +getGameObjectPicture :: GameObject t -> GameObjectPicture +getGameObjectPicture = objPicture + +getGameObjectAsleep :: GameObject t -> Bool +getGameObjectAsleep = objAsleep + +getGameObjectSize :: GameObject t -> (GLdouble,GLdouble) +getGameObjectSize o = (realToFrac sX,realToFrac sY) + where (sX,sY) = objSize o + +getGameObjectPosition :: GameObject t -> (GLdouble,GLdouble) +getGameObjectPosition o = (realToFrac pX,realToFrac pY) + where (pX,pY) = objPosition o + +getGameObjectSpeed :: GameObject t -> (GLdouble,GLdouble) +getGameObjectSpeed o = (realToFrac sX,realToFrac sY) + where (sX,sY) = objSpeed o + +getGameObjectAttribute :: GameObject t -> t +getGameObjectAttribute = objAttribute + +updateObjectPicture :: Int -> Int -> GameObject t -> GameObject t +updateObjectPicture newIndex maxIndex obj = + case (getGameObjectPicture obj) of + Tx _ -> if (newIndex <= maxIndex) + then (obj {objPicture = Tx newIndex}) + else (error ("Objects.updateObjectPicture error: picture index out of range for object " ++ + (getGameObjectName obj) ++ " of group " ++ (getGameObjectManagerName obj))) + _ -> error ("Objects.updateObjectPicture error: object " ++ (getGameObjectName obj) ++ + " of group " ++ (getGameObjectManagerName obj) ++ " is not a textured object!") + +updateObjectAsleep :: Bool -> GameObject t -> GameObject t +updateObjectAsleep asleep o = o {objAsleep = asleep} + +updateObjectSize :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectSize (sX,sY) o = o {objSize = (realToFrac sX, realToFrac sY)} + +updateObjectPosition :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectPosition (pX,pY) o = o {objPosition = (realToFrac pX, realToFrac pY)} + +updateObjectSpeed :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectSpeed (sX,sY) o = o {objSpeed = (realToFrac sX, realToFrac sY)} + +updateObjectAttribute :: t -> GameObject t -> GameObject t +updateObjectAttribute oAttrib o = o {objAttribute = oAttrib} + +---------------------------------------------- +-- get & updating routines for ObjectManagers +---------------------------------------------- +getObjectManagerName :: ObjectManager t -> String +getObjectManagerName = mngName + +getObjectManagerCounter :: ObjectManager t -> Integer +getObjectManagerCounter = mngCounter + +getObjectManagerObjects :: ObjectManager t -> [(GameObject t)] +getObjectManagerObjects = mngObjects + +updateObjectManagerObjects :: [(GameObject t)] -> ObjectManager t -> ObjectManager t +updateObjectManagerObjects objs mng = mng {mngObjects = objs} + +---------------------------------------- +-- initialization of GameObjects +---------------------------------------- +object :: String -> ObjectPicture -> Bool -> (GLdouble,GLdouble) -> (GLdouble,GLdouble) -> t -> GameObject t +object name pic asleep pos speed oAttrib = let (picture, size) = createPicture pic in + GO { + objId = 0, + objName = name, + objManagerName = "object not grouped yet!", + objPicture = picture, + objAsleep = asleep, + objSize = size, + objPosition = pos, + objSpeed = speed, + objAttribute = oAttrib + } + +createPicture :: ObjectPicture -> (GameObjectPicture,Point2D) +createPicture (Basic (Polyg points r g b fillMode)) = (B (P (point2DtoVertex3 points) (Color4 r g b 1.0) fillMode),findSize points) +createPicture (Basic (Circle radius r g b fillMode)) = (B (C radius (Color4 r g b 1.0) fillMode),(2 * radius,2 * radius)) +createPicture (Tex size picIndex) = (Tx picIndex,size) + +-- given a point list, finds the height and width +findSize :: [Point2D] -> Point2D +findSize l = ((x2 - x1),(y2 - y1)) + where (xList,yList) = unzip l + (x2,y2) = (maximum xList,maximum yList) + (x1,y1) = (minimum xList,minimum yList) + +---------------------------------------------- +-- grouping GameObjects and creating managers +---------------------------------------------- +objectGroup :: String -> [(GameObject t)] -> (ObjectManager t) +objectGroup name objs = OM {mngName = name, mngCounter = toEnum (length objs), mngObjects = objectGroupAux objs name 0} + +objectGroupAux :: [(GameObject t)] -> String -> Integer -> [(GameObject t)] +objectGroupAux [] _ _ = [] +objectGroupAux (o:os) managerName oId = (o {objId = oId, objManagerName = managerName}):(objectGroupAux os managerName (oId + 1)) + +addObjectsToManager :: [(GameObject t)] -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +addObjectsToManager _ managerName [] = error ("Objects.addObjectsToManager error: object manager " ++ managerName ++ " does not exists!") +addObjectsToManager objs managerName (m:ms) | (getObjectManagerName m == managerName) = (addObjectsToManagerAux objs m):ms + | otherwise = m:(addObjectsToManager objs managerName ms) + + +addObjectsToManagerAux :: [(GameObject t)] -> ObjectManager t -> ObjectManager t +addObjectsToManagerAux objs mng = let counter = getObjectManagerCounter mng + newObjects = adjustNewObjects objs (getObjectManagerCounter mng) (getObjectManagerName mng) + in mng {mngObjects = newObjects ++ (getObjectManagerObjects mng), mngCounter = counter + (toEnum (length objs))} + +adjustNewObjects :: [(GameObject t)] -> Integer -> String -> [(GameObject t)] +adjustNewObjects [] _ _ = [] +adjustNewObjects (o:os) oId managerName = (o {objId = oId, objManagerName = managerName}):(adjustNewObjects os (oId + 1) managerName) + +------------------------------------------ +-- draw routines +------------------------------------------ +drawGameObjects :: [(ObjectManager t)] -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObjects [] _ _ = return () +drawGameObjects (m:ms) qobj picList = drawGameObjectList (getObjectManagerObjects m) qobj picList >> drawGameObjects ms qobj picList + +drawGameObjectList :: [(GameObject t)] -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObjectList [] _ _ = return () +drawGameObjectList (o:os) qobj picList | (getGameObjectAsleep o) = drawGameObjectList os qobj picList + | otherwise = drawGameObject o qobj picList >> drawGameObjectList os qobj picList + +drawGameObject :: GameObject t -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObject o _qobj picList = do + loadIdentity + let (pX,pY) = getGameObjectPosition o + picture = getGameObjectPicture o + translate (Vector3 pX pY (0 :: GLdouble) ) + case picture of + (B (P points c fillMode)) -> do + color c + if (fillMode == Filled) + then (renderPrimitive Polygon $ mapM_ vertex points) + else (renderPrimitive LineLoop $ mapM_ vertex points) + + (B (C r c fillMode)) -> do + color c + renderQuadric style $ Disk 0 r 20 3 + where style = QuadricStyle Nothing NoTextureCoordinates Outside fillStyle + fillStyle = if (fillMode == Filled) then FillStyle else SilhouetteStyle + + (Tx picIndex) -> do + texture Texture2D $= Enabled + bindTexture Texture2D (picList !! picIndex) + color (Color4 1.0 1.0 1.0 (1.0 :: GLfloat)) + renderPrimitive Quads $ do + texCoord2 0.0 0.0; vertex3 (-x) (-y) 0.0 + texCoord2 1.0 0.0; vertex3 x (-y) 0.0 + texCoord2 1.0 1.0; vertex3 x y 0.0 + texCoord2 0.0 1.0; vertex3 (-x) y 0.0 + texture Texture2D $= Disabled + where (sX,sY) = getGameObjectSize o + x = sX/2 + y = sY/2 + +------------------------------------------ +-- search routines +------------------------------------------ + +findObjectFromId :: GameObject t -> [(ObjectManager t)] -> GameObject t +findObjectFromId o mngs = findObjectFromIdAux (getGameObjectId o) (getGameObjectManagerName o) mngs + +findObjectFromIdAux :: Integer -> String -> [(ObjectManager t)] -> GameObject t +findObjectFromIdAux _ managerName [] = error ("Objects.findObjectFromIdAux error: object group " ++ managerName ++ " not found!") +findObjectFromIdAux objectId managerName (m:ms) | (managerName == getObjectManagerName m) = searchFromId objectId (getObjectManagerObjects m) + | otherwise = findObjectFromIdAux objectId managerName ms + +searchFromId :: Integer -> [(GameObject t)] -> GameObject t +searchFromId _ [] = error ("Objects.searchFromId error: object not found!") +searchFromId objectId (o:os) | (objectId == getGameObjectId o) = o + | otherwise = searchFromId objectId os + + +searchObjectManager :: String -> [(ObjectManager t)] -> ObjectManager t +searchObjectManager managerName [] = error ("Objects.searchObjectManager error: object group " ++ managerName ++ " not found!") +searchObjectManager managerName (m:ms) | (getObjectManagerName m == managerName) = m + | otherwise = searchObjectManager managerName ms + +searchGameObject :: String -> ObjectManager t -> GameObject t +searchGameObject objectName m = searchGameObjectAux objectName (getObjectManagerObjects m) + +searchGameObjectAux :: String -> [(GameObject t)] -> GameObject t +searchGameObjectAux objectName [] = error ("Objects.searchGameObjectAux error: object " ++ objectName ++ " not found!") +searchGameObjectAux objectName (a:as) | (getGameObjectName a == objectName) = a + | otherwise = searchGameObjectAux objectName as + +------------------------------------------ +-- update routines +------------------------------------------ + +-- substitutes an old object by a new one, given the function to be applied to the old object (whose id is given), +-- the name of its manager and the group of game managers. +updateObject :: (GameObject t -> GameObject t) -> Integer -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +updateObject _ _ managerName [] = error ("Objects.updateObject error: object manager: " ++ managerName ++ " not found!") +updateObject f objectId managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms + | otherwise = m:(updateObject f objectId managerName ms) + where newObjects = updateObjectAux f objectId (getObjectManagerObjects m) + +updateObjectAux :: (GameObject t -> GameObject t) -> Integer -> [(GameObject t)] -> [(GameObject t)] +updateObjectAux _ _ [] = error ("Objects.updateObjectAux error: object not found!") +updateObjectAux f objectId (o:os) | (getGameObjectId o == objectId) = (f o):os + | otherwise = o:(updateObjectAux f objectId os) + +------------------------------------------ +-- moving routines +------------------------------------------ + +-- modifies all objects position according to their speed +moveGameObjects :: [(ObjectManager t)] -> [(ObjectManager t)] +moveGameObjects [] = [] +moveGameObjects (m:ms) = (updateObjectManagerObjects (map moveSingleObject (getObjectManagerObjects m)) m):(moveGameObjects ms) + +moveSingleObject :: GameObject t -> GameObject t +moveSingleObject o = if (getGameObjectAsleep o) + then o + else let (vX,vY) = getGameObjectSpeed o + (pX,pY) = getGameObjectPosition o + in updateObjectPosition (pX + vX, pY + vY) o + +------------------------------------------ +-- destroy routines +------------------------------------------ + +destroyGameObject :: String -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +destroyGameObject _ managerName [] = error ("Objects.destroyGameObject error: object manager: " ++ managerName ++ " not found!") +destroyGameObject objectName managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms + | otherwise = m:(destroyGameObject objectName managerName ms) + where newObjects = destroyGameObjectAux objectName (getObjectManagerObjects m) + +destroyGameObjectAux :: String -> [(GameObject t)] -> [(GameObject t)] +destroyGameObjectAux objectName [] = error ("Objects.destroyGameObjectAux error: object: " ++ objectName ++ " not found!") +destroyGameObjectAux objectName (o:os) | (getGameObjectName o == objectName) = os + | otherwise = o:(destroyGameObjectAux objectName os) diff --git a/Graphics/UI/Fungen/Text.hs b/Graphics/UI/Fungen/Text.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Text.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module contains some functions to print text on the screen. +Fonts supported: Bitmap9By15, Bitmap8By13, BitmapTimesRoman10, BitmapTimesRoman24 + BitmapHelvetica10, BitmapHelvetica12, BitmapHelvetica18 +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Text ( + BitmapFont(..), + Text, + putGameText +) where + +import Graphics.UI.GLUT +import Graphics.UI.Fungen.Types + +-- | String to be printed, font, screen position, color RGB. +type Text = (String,BitmapFont,Point2D,GLclampf,GLclampf,GLclampf) + +-- | Display these texts on screen. +putGameText :: [Text] -> IO () +putGameText [] = return () +putGameText ((text,font,(x,y),r,g,b):ts) = do + loadIdentity + color (Color3 r g b) + rasterPos (Vertex2 x y) + renderString font text + putGameText ts diff --git a/Graphics/UI/Fungen/Timer.hs b/Graphics/UI/Fungen/Timer.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Timer.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module controls timing (how time-based functions will behave). +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Timer ( + RefreshType(..), + setRefresh +) where + +import Graphics.UI.GLUT +import Graphics.UI.GLUT.Input + +-- | Used by 'Graphics.UI.Fungen.funInit' to configure the main loop's timing strategy. +data RefreshType + = Idle + | Timer Int + +-- | Change the current timing strategy. +setRefresh :: RefreshType -> StillDownHandler -> IO () +setRefresh Idle stillDown = idleCallback $= Just (stillDown >> postRedisplay Nothing) +setRefresh (Timer t) stillDown = addTimerCallback t (timer stillDown t) + +-- | Generate a GLUT timer callback. +timer :: StillDownHandler -> Int -> TimerCallback +timer stillDown t = do + stillDown + postRedisplay Nothing + addTimerCallback t (timer stillDown t) diff --git a/Graphics/UI/Fungen/Types.hs b/Graphics/UI/Fungen/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Types.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | This FunGEn module contains the FunGEN basic types. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Types ( + WindowConfig, + Point2D, + ColorList3, + AwbfBitmap, + InvList, +) where + +import Graphics.Rendering.OpenGL + +-- | position, size and name of the window +type WindowConfig = ((Int,Int),(Int,Int),String) + +-- | a bidimensional point in space +type Point2D = (GLdouble,GLdouble) + +-- | color in RGB format +type ColorList3 = [(GLubyte, GLubyte, GLubyte)] + +-- | width, height and data of bitmap +type AwbfBitmap = (GLsizei, GLsizei, PixelData GLubyte) + +-- | invisible colors (in RGB) of bitmap +type InvList = Maybe [(Int,Int,Int)] + + + diff --git a/Graphics/UI/Fungen/Util.hs b/Graphics/UI/Fungen/Util.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Util.hs @@ -0,0 +1,170 @@ +{-# OPTIONS_HADDOCK hide #-} +{- | +This FunGEn module contains some auxiliary functions. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Util ( + texCoord2, vertex3, texStuff, + toRad, + randInt, randFloat, randDouble, + shiftLeft, toDecimal, pow2, toBinary, make0, dropGLsizei, + ord2, + addNoInvisibility, + racMod, + matrixToList, matrixSize, + inv2color3, pathAndInv2color3List, point2DtoVertex3, + isEmpty, + when, unless, + bindTexture, + tracewith, strace, ltrace, mtrace +) where + +import Graphics.UI.Fungen.Types +import Graphics.Rendering.OpenGL +import System.Random + +-- debug helpers +import Debug.Trace (trace) +-- | trace an expression using a custom show function +tracewith f e = trace (f e) e +-- | trace a showable expression +strace :: Show a => a -> a +strace = tracewith show +-- | labelled trace - like strace, with a label prepended +ltrace :: Show a => String -> a -> a +ltrace l a = trace (l ++ ": " ++ show a) a +-- | monadic trace - like strace, but works as a standalone line in a monad +mtrace :: (Monad m, Show a) => a -> m a +mtrace a = strace a `seq` return a +-- + +texCoord2 :: GLdouble -> GLdouble -> IO () +texCoord2 x y = texCoord (TexCoord2 x y) + +vertex3 :: GLdouble -> GLdouble -> GLdouble -> IO () +vertex3 x y z = vertex (Vertex3 x y z) + +bindTexture :: TextureTarget2D -> TextureObject -> IO () +bindTexture tt to = textureBinding tt $= Just to + +texStuff :: [TextureObject] -> [AwbfBitmap] -> IO () +texStuff [] _ = return () +texStuff (t:ts) ((bmW,bmH,bmData):bms) = do + bindTexture Texture2D t + texImage2D Texture2D NoProxy 0 RGBA' (TextureSize2D bmW bmH) 0 bmData + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + texStuff ts bms +texStuff _ _ = return () + +toRad :: Float -> Float +toRad a = ((pi * a)/180) + +randInt :: (Int,Int) -> IO Int +randInt (a,b) = randomRIO (a,b) + +randFloat :: (Float,Float) -> IO Float +randFloat (a,b) = randomRIO (a,b) + +randDouble :: (Double,Double) -> IO Double +randDouble (a,b) = randomRIO (a,b) + +shiftLeft :: String -> Int -> String +shiftLeft a 0 = a +shiftLeft (_:as) n = shiftLeft(as ++ "0") (n-1) +shiftLeft _ _ = [] + +toDecimal :: String -> GLsizei +toDecimal a = toDecimalAux (reverse a) 32 + +toDecimalAux :: String -> GLsizei -> GLsizei +toDecimalAux [] _ = 0 +toDecimalAux _ 0 = 0 +toDecimalAux (a:as) n + | a == '0' = toDecimalAux as (n-1) + | otherwise = pow2 (32 - n) + toDecimalAux as (n-1) + +pow2 :: GLsizei -> GLsizei +pow2 0 = 1 +pow2 n = 2 * pow2(n-1) + +toBinary :: Int -> String +toBinary n + | n < 2 = show n + | otherwise = toBinary (n `div` 2) ++ (show (n `mod` 2)) + +make0 :: Int -> String +make0 0 = [] +make0 n = '0':(make0 (n-1)) + +ord2 :: Char -> GLubyte +ord2 a = (toEnum.fromEnum) a + +dropGLsizei :: GLsizei -> [a] -> [a] +dropGLsizei 0 xs = xs +dropGLsizei _ [] = [] +dropGLsizei n (_:xs) | n>0 = dropGLsizei (n-1) xs +dropGLsizei _ _ = error "Util.dropGLsizei error: negative argument" + +-- | to be used when no invisibility must be added when loading a file +addNoInvisibility :: [FilePath] -> [(FilePath, Maybe ColorList3)] +addNoInvisibility [] = [] +addNoInvisibility (a:as) = (a, Nothing):(addNoInvisibility as) + +racMod :: GLdouble -> GLdouble -> GLdouble +racMod a b | (a >= 0) = racModPos a b + | otherwise = racModNeg a b + +racModPos :: GLdouble -> GLdouble -> GLdouble +racModPos a b | (a - b < 0) = a + | otherwise = racModPos (a - b) b + +racModNeg :: GLdouble -> GLdouble -> GLdouble +racModNeg a b | (a + b > 0) = a + | otherwise = racModPos (a + b) b + +matrixToList :: [[a]] -> [a] +matrixToList [] = [] +matrixToList (a:as) = a ++ (matrixToList as) + +-- | return the max indexes of a matrix (assumed that its lines have the same length) +matrixSize :: [[a]] -> (Int,Int) +matrixSize [] = (0,0) +matrixSize m@(a:_) = ((length m) - 1,(length a) - 1) + +inv2color3 :: InvList -> Maybe ColorList3 +inv2color3 Nothing = Nothing +inv2color3 (Just l) = Just (inv2color3Aux l) + +inv2color3Aux :: [(Int,Int,Int)] -> [(GLubyte,GLubyte,GLubyte)] +inv2color3Aux [] = [] +inv2color3Aux ((r,g,b):ls) = (z r,z g,z b):(inv2color3Aux ls) + where z = toEnum.fromEnum + +pathAndInv2color3List :: (FilePath,InvList) -> (FilePath, Maybe ColorList3) +pathAndInv2color3List (f,Nothing) = (f,Nothing) +pathAndInv2color3List (f,Just l) = (f,Just (inv2color3Aux l)) + +point2DtoVertex3 :: [Point2D] -> [Vertex3 GLdouble] +point2DtoVertex3 [] = [] +point2DtoVertex3 ((x,y):as) = (Vertex3 x y 0.0):(point2DtoVertex3 as) + +isEmpty :: [a] -> Bool +isEmpty [] = True +isEmpty _ = False + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = when (not p) s diff --git a/Graphics/UI/GLUT/Input.hs b/Graphics/UI/GLUT/Input.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/GLUT/Input.hs @@ -0,0 +1,103 @@ +-- {-# OPTIONS_HADDOCK hide #-} +{- | +GLUT-based keyboard/mouse handling. + +Sven Panne 2000 + +This provides a "still down" event in addition to GLUT's key/mouse +button up/down events, and manages bindings from input events to actions. + +-} + +module Graphics.UI.GLUT.Input ( + Key(..), KeyEvent(..), KeyBinder, InputHandler, StillDownHandler, glutInitInput +) where + +import Data.IORef(IORef, newIORef, readIORef, modifyIORef) +import Data.List(deleteBy) +import Graphics.UI.GLUT + +--------------------------------------------------------------------------- + +data KeyEvent = Press | StillDown | Release deriving Eq + +--------------------------------------------------------------------------- + +-- | A mutable list of keys (or mouse buttons), along with modifier +-- state and mouse position. +type KeyTable = IORef [(Key, Modifiers, Position)] + +newKeyTable :: IO KeyTable +newKeyTable = newIORef [] + +getKeys :: KeyTable -> IO [(Key, Modifiers, Position)] +getKeys = readIORef + +insertIntoKeyTable :: KeyTable -> Key -> Modifiers -> Position -> IO () +insertIntoKeyTable keyTab key mods pos = modifyIORef keyTab ((key,mods,pos):) + +deleteFromKeyTable :: KeyTable -> Key -> IO () +deleteFromKeyTable keyTab key = modifyIORef keyTab (deleteBy (\(k,_,_) (l,_,_) -> k==l) (key, nullmods, nullpos)) + where nullmods = Modifiers Up Up Up + nullpos = Position 0 0 + +--------------------------------------------------------------------------- + +type InputHandler = Modifiers -> Position -> IO () + +type KeyBinder = Key -> KeyEvent -> Maybe InputHandler -> IO () + +-- TODO: Improve type + +-- | A mutable list of mappings from key/mousebutton up/down/stilldown +-- events to IO actions. +type BindingTable = IORef [((Key,KeyEvent), InputHandler)] + +newBindingTable :: IO BindingTable +newBindingTable = newIORef [] + +bindKey :: BindingTable -> KeyBinder +bindKey bindingTable key event Nothing = + modifyIORef bindingTable (\t -> [ e | e@(b,_) <- t, b /= (key, event)]) +bindKey bindingTable key event (Just action) = do + bindKey bindingTable key event Nothing + modifyIORef bindingTable (((key, event), action) :) + +execAction :: BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO () +execAction bindingTable key event mods pos = + readIORef bindingTable >>= (maybe (return ()) (\a -> a mods pos) . lookup (key, event)) + +--------------------------------------------------------------------------- + +type StillDownHandler = IO () + +stillDown :: BindingTable -> KeyTable -> StillDownHandler +stillDown bindingTable pressedKeys = + getKeys pressedKeys >>= mapM_ (\(k,mods,pos) -> execAction bindingTable k StillDown mods pos) + +--------------------------------------------------------------------------- + +-- | Initialise the input system, which keeps a list of input event to +-- action bindings and executes the the proper actions automatically. +-- Returns a function for adding bindings, and another which should be +-- called periodically (eg from refresh) to trigger still-down actions. +glutInitInput :: IO (KeyBinder, StillDownHandler) +glutInitInput = do + -- globalKeyRepeat would be a little bit more efficient, but it has + -- two disadvantages: it is not yet implemented for MS windows and + -- it changes the global state of X11. + perWindowKeyRepeat $= PerWindowKeyRepeatOff + bindingTable <- newBindingTable + pressedKeys <- newKeyTable + let keyPress k mods pos = do + insertIntoKeyTable pressedKeys k mods pos + execAction bindingTable k Press mods pos + keyRelease k mods pos = do + deleteFromKeyTable pressedKeys k + execAction bindingTable k Release mods pos + keyboardMouse k Down mods pos = keyPress k mods pos + keyboardMouse k Up mods pos = keyRelease k mods pos + keyboardMouseCallback $= Just keyboardMouse + return (bindKey bindingTable, stillDown bindingTable pressedKeys) + +