FunGEn 1.1.1 → 1.2
raw patch · 19 files changed
+2808/−2801 lines, 19 filesdep ~FunGEnPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: FunGEn
API changes (from Hackage documentation)
- Graphics.UI.Fungen: tracewith :: () => (a -> String) -> a -> a
+ Graphics.UI.Fungen: tracewith :: (a -> String) -> a -> a
- Graphics.UI.Fungen: type Tile t = (Int, Bool, Float, t) " index of picture, possibility to move, cost to move, additional params
"
+ Graphics.UI.Fungen: type Tile t = (Int, Bool, Float, t) " index of picture, possibility to move, cost to move, additional params"
Files
- CHANGES.md +8/−1
- FunGEn.cabal +150/−149
- Graphics/UI/Fungen.hs +76/−76
- Graphics/UI/Fungen/Display.hs +44/−44
- Graphics/UI/Fungen/Game.hs +790/−801
- Graphics/UI/Fungen/Init.hs +73/−73
- Graphics/UI/Fungen/Input.hs +47/−47
- Graphics/UI/Fungen/Loader.hs +82/−82
- Graphics/UI/Fungen/Map.hs +240/−240
- Graphics/UI/Fungen/Objects.hs +337/−337
- Graphics/UI/Fungen/Text.hs +39/−39
- Graphics/UI/Fungen/Timer.hs +39/−39
- Graphics/UI/Fungen/Types.hs +42/−42
- Graphics/UI/Fungen/Util.hs +170/−170
- Graphics/UI/GLUT/Input.hs +103/−103
- README.md +43/−33
- examples/hello.hs +11/−11
- examples/pong/pong.hs +94/−94
- examples/worms/worms.hs +420/−420
CHANGES.md view
@@ -1,6 +1,13 @@+## 1.2 2023-09-01++* fix warnings+* convert to unix line endings+* test up to GHC 9.6+* require GHC >= 8.10+ ## 1.1.1 2020-10-18 -* restore support for GHC 8.6 and perhaps older versions+* restore support for GHC 8.0 - 8.6, fix hackage haddock docs ## 1.1 2020-10-18
FunGEn.cabal view
@@ -1,149 +1,150 @@-name: FunGEn -version: 1.1.1 -synopsis: A lightweight, cross-platform, OpenGL-based game engine. -description: - FunGEn (Functional Game Engine) is a BSD-licensed, cross-platform, - OpenGL-based, non-FRP game engine written in Haskell. - Created by Andre Furtado in 2002, it's the oldest Haskell - game engine, and with very few dependencies and two example games, - it's one of the easiest ways to get started with Haskell game - development. - . - The FunGEn library provides: - . - * Initialization, updating, removing, rendering and grouping - routines for game objects - . - * Definition of a game background (or map), including texture-based - maps and tile maps - . - * Reading and intepretation of the player's keyboard and mouse input - . - * Collision detection - . - * Time-based functions and pre-defined game actions - . - * Loading and displaying of 24-bit bitmap files - . - * Some debugging and game performance evaluation facilities - . - This package receives only basic maintenance (see home page). - -category: Game -stability: beta -homepage: https://github.com/haskell-game/fungen -bug-reports: https://github.com/haskell-game/fungen/issues -author: Andre Furtado <awbf@cin.ufpe.br> -maintainer: Simon Michael <simon@joyful.com> -copyright: (C) 2002 Andre Furtado <awbf@cin.ufpe.br> -license: BSD3 -license-file: LICENSE -tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.2 -build-type: Simple -cabal-version: >= 1.10 - -extra-source-files: - README.md - CHANGES.md - TUTORIAL.md - site/brief.gif - site/example.html - site/logo.gif - site/pong.png - site/tex.bmp - site/worms.png - -data-files: - 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/headn.bmp - examples/worms/heads.bmp - examples/worms/headw.bmp - examples/worms/level1.bmp - examples/worms/level2.bmp - examples/worms/level3.bmp - examples/worms/segment.bmp - -source-repository head - type: git - location: https://github.com/haskell-game/fungen - -library - ghc-options: -W - build-depends: - GLUT - , OpenGL - , base ==4.* - , base-compat - , random - 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 - other-modules: - Paths_FunGEn - default-language: Haskell2010 - -executable fungen-hello - main-is: hello.hs - hs-source-dirs: - examples - ghc-options: -W - build-depends: - FunGEn ==1.1.1.* - , GLUT - , OpenGL - , base - , random - other-modules: - Paths_FunGEn - default-language: Haskell2010 - -executable fungen-pong - main-is: pong/pong.hs - hs-source-dirs: - examples - ghc-options: -W - build-depends: - FunGEn ==1.1.1.* - , GLUT - , OpenGL - , base - , random - other-modules: - Paths_FunGEn - default-language: Haskell2010 - -executable fungen-worms - main-is: worms/worms.hs - hs-source-dirs: - examples - ghc-options: -W - build-depends: - FunGEn ==1.1.1.* - , GLUT - , OpenGL - , base - , random - other-modules: - Paths_FunGEn - default-language: Haskell2010 +name: FunGEn+version: 1.2+synopsis: A lightweight, cross-platform, OpenGL-based game engine.+description:+ FunGEn (Functional Game Engine) is a BSD-licensed, cross-platform,+ OpenGL-based, non-FRP game engine written in Haskell. + Created by Andre Furtado in 2002, it's the oldest Haskell+ game engine, and with very few dependencies and two example games,+ it's one of the easiest ways to get started with Haskell game+ development.+ .+ The FunGEn library provides:+ .+ * Initialization, updating, removing, rendering and grouping+ routines for game objects+ .+ * Definition of a game background (or map), including texture-based+ maps and tile maps+ .+ * Reading and intepretation of the player's keyboard and mouse input+ .+ * Collision detection+ .+ * Time-based functions and pre-defined game actions+ .+ * Loading and displaying of 24-bit bitmap files+ .+ * Some debugging and game performance evaluation facilities+ .+ This package receives only basic maintenance (see home page).++category: Game+stability: beta+homepage: https://github.com/haskell-game/fungen+bug-reports: https://github.com/haskell-game/fungen/issues+author: Andre Furtado <awbf@cin.ufpe.br>+maintainer: Simon Michael <simon@joyful.com>+copyright: (C) 2002 Andre Furtado <awbf@cin.ufpe.br>+license: BSD3+license-file: LICENSE+-- tested-with: GHC==8.0, GHC==8.2, GHC==8.4, GHC==8.6, GHC==8.8 -- not tested since 1.1.1+tested-with: GHC==8.10, GHC==9.0, GHC==9.2, GHC==9.4.6, GHC==9.6.2+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md+ CHANGES.md+ TUTORIAL.md+ site/brief.gif+ site/example.html+ site/logo.gif+ site/pong.png+ site/tex.bmp+ site/worms.png++data-files:+ 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/headn.bmp+ examples/worms/heads.bmp+ examples/worms/headw.bmp+ examples/worms/level1.bmp+ examples/worms/level2.bmp+ examples/worms/level3.bmp+ examples/worms/segment.bmp++source-repository head+ type: git+ location: https://github.com/haskell-game/fungen++library+ ghc-options: -W+ build-depends:+ GLUT+ , OpenGL+ , base >=4.9 && <5+ , base-compat+ , random+ 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+ other-modules:+ Paths_FunGEn+ default-language: Haskell2010++executable fungen-hello+ main-is: hello.hs+ hs-source-dirs:+ examples+ ghc-options: -W+ build-depends:+ FunGEn ==1.2+ , GLUT+ , OpenGL+ , base+ , random+ other-modules:+ Paths_FunGEn+ default-language: Haskell2010++executable fungen-pong+ main-is: pong/pong.hs+ hs-source-dirs:+ examples+ ghc-options: -W+ build-depends:+ FunGEn ==1.2+ , GLUT+ , OpenGL+ , base+ , random+ other-modules:+ Paths_FunGEn+ default-language: Haskell2010++executable fungen-worms+ main-is: worms/worms.hs+ hs-source-dirs:+ examples+ ghc-options: -W+ build-depends:+ FunGEn ==1.2+ , GLUT+ , OpenGL+ , base+ , random+ other-modules:+ Paths_FunGEn+ default-language: Haskell2010
Graphics/UI/Fungen.hs view
@@ -1,76 +1,76 @@-{- | -This is the main module of FunGEN (Functional Game Engine), which re-exports the rest. --} -{- - -FunGEN - Functional Game Engine -http://joyful.com/fungen -Copyright (C) -2002 Andre Furtado <awbf@cin.ufpe.br> -2008, 2011-2013 Simon Michael <simon@joyful.com> - -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 ( - - -- * Execution - -- | Starting and stopping a game. - module Graphics.UI.Fungen.Init, - - -- * Types - -- | Some basic types. - module Graphics.UI.Fungen.Types, - - -- * Images - -- | Loading BMP image files. - module Graphics.UI.Fungen.Loader, - - -- * Text - -- | Printing text on the screen. - module Graphics.UI.Fungen.Text, - - -- * Maps/backgrounds - -- | Game backgrounds, tile maps. - module Graphics.UI.Fungen.Map, - - -- * Objects - -- | Game objects (sprites). - module Graphics.UI.Fungen.Objects, - - -- * Input - -- | User input from mouse and keyboard. - module Graphics.UI.Fungen.Input, - - -- * Timing - -- | Timing control. - module Graphics.UI.Fungen.Timer, - - -- * Game - -- | Game management and various game utilities. - module Graphics.UI.Fungen.Game, - - -- * Display - -- | Rendering the game window. - module Graphics.UI.Fungen.Display, - - -- * Util - -- | Miscellaneous utilities. - module Graphics.UI.Fungen.Util - -) where - -import Graphics.UI.Fungen.Types -import Graphics.UI.Fungen.Util -import Graphics.UI.Fungen.Loader -import Graphics.UI.Fungen.Objects -import Graphics.UI.Fungen.Map -import Graphics.UI.Fungen.Game -import Graphics.UI.Fungen.Display -import Graphics.UI.Fungen.Input -import Graphics.UI.Fungen.Timer -import Graphics.UI.Fungen.Text -import Graphics.UI.Fungen.Init +{- |+This is the main module of FunGEN (Functional Game Engine), which re-exports the rest.+-}+{- ++FunGEN - Functional Game Engine+http://joyful.com/fungen+Copyright (C)+2002 Andre Furtado <awbf@cin.ufpe.br>+2008, 2011-2013 Simon Michael <simon@joyful.com>++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 (++ -- * Execution+ -- | Starting and stopping a game.+ module Graphics.UI.Fungen.Init,++ -- * Types+ -- | Some basic types.+ module Graphics.UI.Fungen.Types,++ -- * Images+ -- | Loading BMP image files.+ module Graphics.UI.Fungen.Loader,++ -- * Text+ -- | Printing text on the screen.+ module Graphics.UI.Fungen.Text,++ -- * Maps/backgrounds+ -- | Game backgrounds, tile maps.+ module Graphics.UI.Fungen.Map,++ -- * Objects+ -- | Game objects (sprites).+ module Graphics.UI.Fungen.Objects,++ -- * Input+ -- | User input from mouse and keyboard.+ module Graphics.UI.Fungen.Input,++ -- * Timing+ -- | Timing control.+ module Graphics.UI.Fungen.Timer,++ -- * Game+ -- | Game management and various game utilities.+ module Graphics.UI.Fungen.Game,++ -- * Display+ -- | Rendering the game window.+ module Graphics.UI.Fungen.Display,++ -- * Util+ -- | Miscellaneous utilities.+ module Graphics.UI.Fungen.Util++) where ++import Graphics.UI.Fungen.Types+import Graphics.UI.Fungen.Util+import Graphics.UI.Fungen.Loader+import Graphics.UI.Fungen.Objects+import Graphics.UI.Fungen.Map+import Graphics.UI.Fungen.Game+import Graphics.UI.Fungen.Display+import Graphics.UI.Fungen.Input+import Graphics.UI.Fungen.Timer+import Graphics.UI.Fungen.Text+import Graphics.UI.Fungen.Init
Graphics/UI/Fungen/Display.hs view
@@ -1,44 +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 <awbf@cin.ufpe.br> - -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 +{-# 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 <awbf@cin.ufpe.br>++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
Graphics/UI/Fungen/Game.hs view
@@ -1,801 +1,790 @@-{-# LANGUAGE CPP #-} -{-# 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 <awbf@cin.ufpe.br> - -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 -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (Applicative(..)) -#endif -#if MIN_VERSION_base(4,13,0) -import Control.Monad -#else -import Prelude hiding (fail) -import Control.Monad.Fail (MonadFail(fail)) -import Control.Monad (ap,liftM) -#endif -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 - -instance MonadFail (IOGame t s u v) where - fail s = liftIOtoIOGame (fail s) - -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 +{-# LANGUAGE CPP #-}+{-# 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 <awbf@cin.ufpe.br>++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.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 (x >=> (\ (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 = unitST+ (<*>) = ap++instance Monad (IOGame t s u v) where+ (>>=) = bindST++instance MonadFail (IOGame t s u v) where+ fail s = liftIOtoIOGame (fail s)++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) = f++runIOGameM :: IOGame t s u v a -> Game t s u v -> IO ()+runIOGameM x g = void (runIOGame x g)++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 = foldr ((>>) . destroyObject) (return ())++-- | 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 = searchObjectManager mngName <$> getObjectManagers++-- | 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 = liftIOtoIOGame' print++-- | 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++
Graphics/UI/Fungen/Init.hs view
@@ -1,73 +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 <awbf@cin.ufpe.br> - -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 - +{-# 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 <awbf@cin.ufpe.br>++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+
Graphics/UI/Fungen/Input.hs view
@@ -1,47 +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 <awbf@cin.ufpe.br> - -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) +{-# 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 <awbf@cin.ufpe.br>++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)
Graphics/UI/Fungen/Loader.hs view
@@ -1,82 +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 <awbf@cin.ufpe.br> - -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" +{-# 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 <awbf@cin.ufpe.br>++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"
Graphics/UI/Fungen/Map.hs view
@@ -1,240 +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 <awbf@cin.ufpe.br> - -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 +{-# 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 <awbf@cin.ufpe.br>++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
Graphics/UI/Fungen/Objects.hs view
@@ -1,337 +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 <awbf@cin.ufpe.br> - -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) +{-# 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 <awbf@cin.ufpe.br>++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)
Graphics/UI/Fungen/Text.hs view
@@ -1,39 +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 <awbf@cin.ufpe.br> - -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 +{-# 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 <awbf@cin.ufpe.br>++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
Graphics/UI/Fungen/Timer.hs view
@@ -1,40 +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 <awbf@cin.ufpe.br> - -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 +{-# 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 <awbf@cin.ufpe.br>++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)
Graphics/UI/Fungen/Types.hs view
@@ -1,42 +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 <awbf@cin.ufpe.br> - -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)] - - - +{-# 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 <awbf@cin.ufpe.br>++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)]+++
Graphics/UI/Fungen/Util.hs view
@@ -1,170 +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 <awbf@cin.ufpe.br> - -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 +{-# 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 <awbf@cin.ufpe.br>++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
Graphics/UI/GLUT/Input.hs view
@@ -1,103 +1,103 @@--- {-# OPTIONS_HADDOCK hide #-} -{- | -GLUT-based keyboard/mouse handling. - -Sven Panne 2000 <Sven.Panne@informatik.uni-muenchen.de> - -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) - - +-- {-# OPTIONS_HADDOCK hide #-}+{- |+GLUT-based keyboard/mouse handling.++Sven Panne 2000 <Sven.Panne@informatik.uni-muenchen.de>++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)++
README.md view
@@ -1,18 +1,17 @@ # **FunGEn** (**Fun**ctional **G**ame **En**gine) -<a href="https://github.com/haskell-game/fungen/blob/master/examples/hello.hs#L1"><img border=0 src="site/logo.gif" title="Click to see the hello world example" style="margin-top:2em;"></a>+<a href="https://github.com/haskell-game/fungen/blob/master/examples/hello.hs#L1"+ ><img border=0 src="site/logo.gif" title="Click to see the hello world example" style="margin-top:2em;"></a> -FunGEn is a BSD-licensed, cross-platform,-OpenGL/GLUT-based, non-FRP game engine written in Haskell. -Created by Andre Furtado in 2002, it's the oldest Haskell-game engine, and with very few dependencies and two example games,-it's one of the easiest ways to get started with Haskell game-development. It provides:+FunGEn is a BSD-licensed, cross-platform, OpenGL-based game engine written in Haskell. +Created by Andre Furtado in 2002, it's the oldest Haskell game engine,+and with very few dependencies and two example games,+it's one of the easiest ways to get started with Haskell game development. -* Initialization, updating, removing, rendering and grouping- routines for game objects-* Definition of a game background (or map), including texture-based- maps and tile maps+FunGEn provides:++* Initialization, updating, removing, rendering and grouping routines for game objects+* Definition of a game background (or map), including texture-based maps and tile maps * Reading and intepretation of the player's keyboard and mouse input * Collision detection * Time-based functions and pre-defined game actions@@ -23,18 +22,26 @@ * No sound support (consider adding - [OpenAL](http://hackage.haskell.org/package/OpenAL), - [elerea](http://hackage.haskell.org/package/elerea), or - [sdl2-mixer](http://hackage.haskell.org/package/sdl2-mixer))+ [OpenAL](https://hackage.haskell.org/package/OpenAL), + [elerea](https://hackage.haskell.org/package/elerea), or + [sdl2-mixer](https://hackage.haskell.org/package/sdl2-mixer)) -[Simon Michael](http://joyful.com) (`sm` in #haskell-game) provides infrequent maintenance for this package, and chat support in #haskell-game. There is no issue tracker and no email support. [Co]maintainers wanted!+[Simon Michael](https://joyful.com) provides infrequent maintenance for this package,+and chat support in #haskell-game on Matrix or Libera IRC (nick: `sm`). +There is no issue tracker and no email support. -<a href="https://github.com/haskell-game/fungen/blob/master/examples/pong/pong.hs#L1"><img border=0 src="site/pong.png" title="Click to see the pong example" style="margin-top:2em;"></a>-<a href="https://github.com/haskell-game/fungen/blob/master/examples/worms/worms.hs#L1"><img border=0 src="site/worms.png" title="Click to see the worms (snake) example" style="margin-top:1em;"></a>+I don't have time to do more with it, but this package is still useful+and could attract users, given a little TLC and a slick home page.+Would you like to take it over ? Maintainers or co-maintainers wanted! +<a href="https://github.com/haskell-game/fungen/blob/master/examples/pong/pong.hs#L1"+ ><img border=0 src="site/pong.png" title="Click to see the pong example" style="margin-top:2em;"></a>+<a href="https://github.com/haskell-game/fungen/blob/master/examples/worms/worms.hs#L1"+ ><img border=0 src="site/worms.png" title="Click to see the worms (snake) example" style="margin-top:1em;"></a>+ ## Install -Install OpenGL/GLUT C libs, if not already installed on your system.+Install the OpenGL C libraries, if not already installed on your system. Eg on Ubuntu/Debian: ``` $ sudo apt install freeglut3-dev@@ -42,22 +49,27 @@ If you don't know whether they are already installed, try the next step and watch for "missing C library" errors. ### Latest released:-([changes](http://hackage.haskell.org/package/FunGEn/changelog))++([changes](https://hackage.haskell.org/package/FunGEn/changelog)) ```-$ stack install FunGEn # or cabal+$ stack install FunGEn # or cabal install ``` Make sure `~/.local/bin` (stack) or `~/.cabal/bin` (cabal) or the windows equivalent are in your shell PATH, then run the example games:+ ``` $ fungen-hello $ fungen-pong $ fungen-worms ```+ ### Latest unreleased:+ ([changes](https://github.com/haskell-game/fungen/blob/master/CHANGES.md#L1))+ ```-$ git clone http://github.com/haskell-game/fungen+$ git clone https://github.com/haskell-game/fungen $ cd fungen-$ stack build # or cabal+$ stack build # or cabal build $ stack exec fungen-hello $ stack exec fungen-pong $ stack exec fungen-worms@@ -67,19 +79,17 @@ ## Docs - https://github.com/haskell-game/fungen#readme+- [Changelog](CHANGES.md) - Andre's tutorial, [original](https://htmlpreview.github.io/?https://github.com/haskell-game/fungen/blob/master/site/example.html) or [reformatted](TUTORIAL.md#fungen-pong-tutorial) version - [Haddock API docs](https://hackage.haskell.org/package/FunGEn/docs/Graphics-UI-Fungen.html)-- [Changelog](CHANGES.md)-- [FunGEn package](http://hackage.haskell.org/package/FunGEn) on Hackage-- [FunGEn questions](http://stackoverflow.com/search?tab=newest&q=fungen) on Stack Overflow-- [Andre's old site](http://www.cin.ufpe.br/~haskell/fungen)-- [#haskell-game](http://webchat.freenode.net/?channels=haskell-game) IRC channel- <!-- ([log](http://ircbrowse.tomsmeding.com/day/haskell-game/today/recent)) -->-- [/r/haskellgamedev](http://www.reddit.com/r/haskellgamedev) reddit-- [haskell-cafe](http://www.haskell.org/haskellwiki/Mailing_lists) mail list-- Haskell wiki: [Game_Development](http://www.haskell.org/haskellwiki/Game_Development)-- Haskell wiki: [OpenGL tutorial](http://www.haskell.org/haskellwiki/OpenGLTutorial1)-+- [FunGEn package](https://hackage.haskell.org/package/FunGEn) on Hackage+- [FunGEn questions](https://stackoverflow.com/search?tab=newest&q=fungen) on Stack Overflow+- [Andre's old site](https://www.cin.ufpe.br/~haskell/fungen)+- #haskell-game chat on Matrix or on Libera IRC (currently separate, not bridged)+- [/r/haskellgamedev](https://www.reddit.com/r/haskellgamedev) reddit+- [haskell-cafe](https://www.haskell.org/haskellwiki/Mailing_lists) mail list+- Haskell wiki: [Game_Development](https://www.haskell.org/haskellwiki/Game_Development)+- Haskell wiki: [OpenGL tutorial](https://www.haskell.org/haskellwiki/OpenGLTutorial1) ## History
examples/hello.hs view
@@ -1,11 +1,11 @@-module Main where - -import Graphics.UI.Fungen - -main :: IO () -main = - let winConfig = ((50,50),(500,300),"Hello, Fungen World! Press Q to quit") - gameMap = colorMap 0.0 0.0 0.0 250 250 - bindings = [(Char 'q', Press, \_ _ -> funExit)] - in funInit winConfig gameMap [] () () bindings (return()) Idle [] - +module Main where++import Graphics.UI.Fungen++main :: IO ()+main =+ let winConfig = ((50,50),(500,300),"Hello, Fungen World! Press Q to quit")+ gameMap = colorMap 0.0 0.0 0.0 250 250+ bindings = [(Char 'q', Press, \_ _ -> funExit)]+ in funInit winConfig gameMap [] () () bindings (return()) Idle []+
examples/pong/pong.hs view
@@ -1,94 +1,94 @@-{- - -pong - a very simple FunGEn example. -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2001 Andre Furtado <awbf@cin.ufpe.br> - -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 Main where - -import Graphics.UI.Fungen -import Graphics.Rendering.OpenGL (GLdouble) -import Paths_FunGEn (getDataFileName) - -data GameAttribute = Score Int - -width = 400 -height = 400 -w = fromIntegral width :: GLdouble -h = fromIntegral height :: GLdouble - -main :: IO () -main = do - texbmp <- getDataFileName "examples/pong/tex.bmp" - let winConfig = ((100,80),(width,height),"A brief example!") - bmpList = [(texbmp, Nothing)] - gameMap = textureMap 0 30 30 w h - bar = objectGroup "barGroup" [createBar] - ball = objectGroup "ballGroup" [createBall] - initScore = Score 0 - input = [ - (SpecialKey KeyRight, StillDown, moveBarToRight) - ,(SpecialKey KeyLeft, StillDown, moveBarToLeft) - ,(Char 'q', Press, \_ _ -> funExit) - ] - funInit winConfig gameMap [bar,ball] () initScore input gameCycle (Timer 30) bmpList - -createBall :: GameObject () -createBall = - let ballPic = Basic (Circle 6.0 0.0 1.0 0.0 Filled) - in object "ball" ballPic False (w/2,h/2) (-8,8) () - -createBar :: GameObject () -createBar = - let barBound = [(-25,-6),(25,-6),(25,6),(-25,6)] - barPic = Basic (Polyg barBound 1.0 1.0 1.0 Filled) - in object "bar" barPic False (w/2,30) (0,0) () - -moveBarToRight :: Modifiers -> Position -> IOGame GameAttribute () () () () -moveBarToRight _ _ = do - obj <- findObject "bar" "barGroup" - (pX,pY) <- getObjectPosition obj - (sX,_) <- getObjectSize obj - if (pX + (sX/2) + 5 <= w) - then (setObjectPosition ((pX + 5),pY) obj) - else (setObjectPosition ((w - (sX/2)),pY) obj) - -moveBarToLeft :: Modifiers -> Position -> IOGame GameAttribute () () () () -moveBarToLeft _ _ = do - obj <- findObject "bar" "barGroup" - (pX,pY) <- getObjectPosition obj - (sX,_) <- getObjectSize obj - if (pX - (sX/2) - 5 >= 0) - then (setObjectPosition ((pX - 5),pY) obj) - else (setObjectPosition (sX/2,pY) obj) - -gameCycle :: IOGame GameAttribute () () () () -gameCycle = do - (Score n) <- getGameAttribute - printOnScreen (show n) TimesRoman24 (0,0) 1.0 1.0 1.0 - - ball <- findObject "ball" "ballGroup" - col1 <- objectLeftMapCollision ball - col2 <- objectRightMapCollision ball - when (col1 || col2) (reverseXSpeed ball) - col3 <- objectTopMapCollision ball - when col3 (reverseYSpeed ball) - col4 <- objectBottomMapCollision ball - when col4 $ do - -- funExit - setGameAttribute (Score 0) - reverseYSpeed ball - - bar <- findObject "bar" "barGroup" - col5 <- objectsCollision ball bar - let (_,vy) = getGameObjectSpeed ball - when (and [col5, vy < 0]) (do reverseYSpeed ball - setGameAttribute (Score (n + 10))) - showFPS TimesRoman24 (w-40,0) 1.0 0.0 0.0 - +{- ++pong - a very simple FunGEn example.+http://www.cin.ufpe.br/~haskell/fungen+Copyright (C) 2001 Andre Furtado <awbf@cin.ufpe.br>++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 Main where++import Graphics.UI.Fungen+import Graphics.Rendering.OpenGL (GLdouble)+import Paths_FunGEn (getDataFileName)++data GameAttribute = Score Int+ +width = 400+height = 400+w = fromIntegral width :: GLdouble+h = fromIntegral height :: GLdouble++main :: IO ()+main = do+ texbmp <- getDataFileName "examples/pong/tex.bmp"+ let winConfig = ((100,80),(width,height),"A brief example!")+ bmpList = [(texbmp, Nothing)]+ gameMap = textureMap 0 30 30 w h+ bar = objectGroup "barGroup" [createBar]+ ball = objectGroup "ballGroup" [createBall]+ initScore = Score 0+ input = [+ (SpecialKey KeyRight, StillDown, moveBarToRight)+ ,(SpecialKey KeyLeft, StillDown, moveBarToLeft)+ ,(Char 'q', Press, \_ _ -> funExit)+ ]+ funInit winConfig gameMap [bar,ball] () initScore input gameCycle (Timer 30) bmpList++createBall :: GameObject ()+createBall =+ let ballPic = Basic (Circle 6.0 0.0 1.0 0.0 Filled)+ in object "ball" ballPic False (w/2,h/2) (-8,8) ()++createBar :: GameObject ()+createBar =+ let barBound = [(-25,-6),(25,-6),(25,6),(-25,6)]+ barPic = Basic (Polyg barBound 1.0 1.0 1.0 Filled)+ in object "bar" barPic False (w/2,30) (0,0) ()++moveBarToRight :: Modifiers -> Position -> IOGame GameAttribute () () () ()+moveBarToRight _ _ = do+ obj <- findObject "bar" "barGroup"+ (pX,pY) <- getObjectPosition obj+ (sX,_) <- getObjectSize obj+ if (pX + (sX/2) + 5 <= w)+ then (setObjectPosition ((pX + 5),pY) obj)+ else (setObjectPosition ((w - (sX/2)),pY) obj)++moveBarToLeft :: Modifiers -> Position -> IOGame GameAttribute () () () ()+moveBarToLeft _ _ = do+ obj <- findObject "bar" "barGroup"+ (pX,pY) <- getObjectPosition obj+ (sX,_) <- getObjectSize obj+ if (pX - (sX/2) - 5 >= 0)+ then (setObjectPosition ((pX - 5),pY) obj)+ else (setObjectPosition (sX/2,pY) obj)++gameCycle :: IOGame GameAttribute () () () ()+gameCycle = do+ (Score n) <- getGameAttribute+ printOnScreen (show n) TimesRoman24 (0,0) 1.0 1.0 1.0++ ball <- findObject "ball" "ballGroup"+ col1 <- objectLeftMapCollision ball+ col2 <- objectRightMapCollision ball+ when (col1 || col2) (reverseXSpeed ball)+ col3 <- objectTopMapCollision ball+ when col3 (reverseYSpeed ball)+ col4 <- objectBottomMapCollision ball+ when col4 $ do+ -- funExit+ setGameAttribute (Score 0)+ reverseYSpeed ball++ bar <- findObject "bar" "barGroup"+ col5 <- objectsCollision ball bar+ let (_,vy) = getGameObjectSpeed ball+ when (and [col5, vy < 0]) (do reverseYSpeed ball+ setGameAttribute (Score (n + 10)))+ showFPS TimesRoman24 (w-40,0) 1.0 0.0 0.0+
examples/worms/worms.hs view
@@ -1,420 +1,420 @@-{- - -worms - a very simple FunGEn example. -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2001 Andre Furtado <awbf@cin.ufpe.br> - -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 Main where - -import Text.Printf -import Graphics.UI.Fungen -import Graphics.Rendering.OpenGL (GLdouble) -import Paths_FunGEn (getDataFileName) - -data GameAttribute = GA Int Int Int (GLdouble,GLdouble) Int -data ObjectAttribute = NoObjectAttribute | Tail Int -data GameState = LevelStart Int | Level Int | GameOver -data TileAttribute = NoTileAttribute - -type WormsAction a = IOGame GameAttribute ObjectAttribute GameState TileAttribute a -type WormsObject = GameObject ObjectAttribute -type WormsTile = Tile TileAttribute -type WormsMap = TileMatrix TileAttribute - -tileSize, speedMod :: GLdouble -tileSize = 30.0 -speedMod = 30.0 - -initPos, tail0Pos, tail1Pos :: (GLdouble,GLdouble) -initPos = (45.0,105.0) -tail0Pos = (45.0,75.0) -tail1Pos = (45.0,45.0) - -maxFood, initTailSize, defaultTimer :: Int -maxFood = 10 -initTailSize = 2 -defaultTimer = 10 - -magenta :: InvList -magenta = Just [(255,0,255)] - -bmpList :: FilePictureList -bmpList = [("level1.bmp", Nothing), - ("level2.bmp", Nothing), - ("level3.bmp", Nothing), - ("gameover.bmp", magenta), - ("congratulations.bmp", magenta), - ("headn.bmp", magenta), - ("heads.bmp", magenta), - ("heade.bmp", magenta), - ("headw.bmp", magenta), - ("food.bmp", magenta), - ("segment.bmp", magenta), - ("border1.bmp", magenta), - ("border2.bmp", magenta), - ("border3.bmp", magenta), - ("free1.bmp", magenta), - ("free2.bmp", magenta), - ("free3.bmp", magenta)] - --- position of the paths in the list: -border1, border2, border3, free1, free2, free3 :: Int -border1 = 11 -border2 = 12 -border3 = 13 -free1 = 14 -free2 = 15 -free3 = 16 - -main :: IO () -main = do - let winConfig = ((200,100),(780,600),"WORMS - by Andre Furtado") - - gameMap = multiMap [(tileMap map1 tileSize tileSize), - (tileMap map2 tileSize tileSize), - (tileMap map3 tileSize tileSize)] 0 - - gameAttribute = GA defaultTimer maxFood initTailSize initPos 0 - - groups = [(objectGroup "messages" createMsgs ), - (objectGroup "head" [createHead]), - (objectGroup "food" [createFood]), - (objectGroup "tail" createTail )] - - input = [ - (SpecialKey KeyLeft, Press, turnLeft ), - (SpecialKey KeyRight, Press, turnRight), - (SpecialKey KeyUp, Press, turnUp ), - (SpecialKey KeyDown, Press, turnDown ) - ,(Char 'q', Press, \_ _ -> funExit) - ] - - bmpList' <- mapM (\(a,b) -> do { a' <- getDataFileName ("examples/worms/"++a); return (a', b)}) bmpList - funInit winConfig gameMap groups (LevelStart 1) gameAttribute input gameCycle (Timer 150) bmpList' - -createMsgs :: [WormsObject] -createMsgs = - let picLevel1 = Tex (150,50) 0 - picLevel2 = Tex (150,50) 1 - picLevel3 = Tex (150,50) 2 - picGameOver = Tex (300,100) 3 - picCongratulations = Tex (300,100) 4 - in [(object "level1" picLevel1 True (395,300) (0,0) NoObjectAttribute), - (object "level2" picLevel2 True (395,300) (0,0) NoObjectAttribute), - (object "level3" picLevel3 True (395,300) (0,0) NoObjectAttribute), - (object "gameover" picGameOver True (395,300) (0,0) NoObjectAttribute), - (object "congratulations" picCongratulations True (395,300) (0,0) NoObjectAttribute)] - -createHead :: WormsObject -createHead = let pic = Tex (tileSize,tileSize) 5 - in object "head" pic True initPos (0,speedMod) NoObjectAttribute - -createFood :: WormsObject -createFood = let pic = Tex (tileSize,tileSize) 9 - in object "food" pic True (0,0) (0,0) NoObjectAttribute - -createTail :: [WormsObject] -createTail = let picTail = Tex (tileSize,tileSize) 10 - in (object "tail0" picTail False tail0Pos (0,0) (Tail 0)): - (object "tail1" picTail False tail1Pos (0,0) (Tail 1)): - (createAsleepTails initTailSize (initTailSize + maxFood - 1) picTail) - -createAsleepTails :: Int -> Int -> ObjectPicture -> [WormsObject] -createAsleepTails tMin tMax pic - | (tMin > tMax) = [] - | otherwise = (object ("tail" ++ (show tMin)) pic True (0,0) (0,0) (Tail 0)):(createAsleepTails (tMin + 1) tMax pic) - -turnLeft :: Modifiers -> Position -> WormsAction () -turnLeft _ _ = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 8 snakeHead - setObjectSpeed (-speedMod,0) snakeHead - -turnRight :: Modifiers -> Position -> WormsAction () -turnRight _ _ = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 7 snakeHead - setObjectSpeed (speedMod,0) snakeHead - -turnUp :: Modifiers -> Position -> WormsAction () -turnUp _ _ = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 5 snakeHead - setObjectSpeed (0,speedMod) snakeHead - -turnDown :: Modifiers -> Position -> WormsAction () -turnDown _ _ = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 6 snakeHead - setObjectSpeed (0,-speedMod) snakeHead - -gameCycle :: WormsAction () -gameCycle = do - (GA timer remainingFood tailSize previousHeadPos score) <- getGameAttribute - gState <- getGameState - case gState of - LevelStart n -> case n of - 4 -> do - congratulations <- findObject "congratulations" "messages" - drawObject congratulations - if (timer == 0) - then funExit - else (setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score)) - _ -> do - disableGameFlags - level <- findObject ("level" ++ (show n)) "messages" - drawObject level - if (timer == 0) - then (do setGameState (Level n) - enableGameFlags - snakeHead <- findObject "head" "head" - setObjectAsleep False snakeHead - setObjectPosition initPos snakeHead - setObjectSpeed (0.0,speedMod) snakeHead - setObjectCurrentPicture 5 snakeHead - setGameAttribute (GA defaultTimer remainingFood tailSize previousHeadPos score) - destroyObject level - setNewMap n) - else setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score) - Level n -> do - if (remainingFood == 0) -- advance level! - then (do setGameState (LevelStart (n + 1)) - resetTails - disableGameFlags - setGameAttribute (GA timer maxFood initTailSize initPos score)) - else if (timer == 0) -- put a new food in the map - then (do food <- findObject "food" "food" - newPos <- createNewFoodPosition - setObjectPosition newPos food - newFood <- findObject "food" "food" - setObjectAsleep False newFood - setGameAttribute (GA (-1) remainingFood tailSize previousHeadPos score) - snakeHead <- findObject "head" "head" - checkSnakeCollision snakeHead - snakeHeadPosition <- getObjectPosition snakeHead - moveTail snakeHeadPosition) - else if (timer > 0) -- there is no food in the map, so decrease the food timer - then (do setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score) - snakeHead <- findObject "head" "head" - checkSnakeCollision snakeHead - snakeHeadPosition <- getObjectPosition snakeHead - moveTail snakeHeadPosition) - else (do -- there is a food in the map - food <- findObject "food" "food" - snakeHead <- findObject "head" "head" - col <- objectsCollision snakeHead food - if col - then (do snakeHeadPosition <- getObjectPosition snakeHead - setGameAttribute (GA defaultTimer (remainingFood-1) (tailSize + 1) snakeHeadPosition (score + 1)) - addTail previousHeadPos - setObjectAsleep True food) - else (do checkSnakeCollision snakeHead - snakeHeadPosition <- getObjectPosition snakeHead - moveTail snakeHeadPosition)) - showScore - - GameOver -> do - disableMapDrawing - gameover <- findObject "gameover" "messages" - drawMap - drawObject gameover - if (timer == 0) - then funExit - else (setGameAttribute (GA (timer - 1) 0 0 (0,0) 0)) - -showScore :: WormsAction () -showScore = do - (GA _ remainingFood _ _ score) <- getGameAttribute - printOnScreen (printf "Score: %d Food remaining: %d" score remainingFood) TimesRoman24 (40,8) 1.0 1.0 1.0 - showFPS TimesRoman24 (780-60,8) 1.0 0.0 0.0 - -setNewMap :: Int -> WormsAction () -setNewMap 2 = setCurrentMapIndex 1 -setNewMap 3 = setCurrentMapIndex 2 -setNewMap _ = return () - -resetTails :: WormsAction () -resetTails = do - tail0 <- findObject "tail0" "tail" - setObjectPosition tail0Pos tail0 - setObjectAttribute (Tail 0) tail0 - tail1 <- findObject "tail1" "tail" - setObjectPosition tail1Pos tail1 - setObjectAttribute (Tail 1) tail1 - resetOtherTails initTailSize - -resetOtherTails :: Int -> WormsAction () -resetOtherTails n | (n == initTailSize + maxFood) = return () - | otherwise = do tailn <- findObject ("tail" ++ (show n)) "tail" - setObjectAsleep True tailn - resetOtherTails (n + 1) - -addTail :: (GLdouble,GLdouble) -> WormsAction () -addTail presentHeadPos = do - tails <- getObjectsFromGroup "tail" - aliveTails <- getAliveTails tails [] - asleepTail <- getAsleepTail tails - setObjectAsleep False asleepTail - setObjectPosition presentHeadPos asleepTail - setObjectAttribute (Tail 0) asleepTail - addTailNumber aliveTails - -getAliveTails :: [WormsObject] -> [WormsObject] -> WormsAction [WormsObject] -getAliveTails [] t = return t -getAliveTails (o:os) t = do - sleeping <- getObjectAsleep o - if sleeping - then getAliveTails os t - else getAliveTails os (o:t) - -getAsleepTail :: [WormsObject] -> WormsAction WormsObject -getAsleepTail [] = error "the impossible has happened!" -getAsleepTail (o:os) = do - sleeping <- getObjectAsleep o - if sleeping - then return o - else getAsleepTail os - - -addTailNumber :: [WormsObject] -> WormsAction () -addTailNumber [] = return () -addTailNumber (a:as) = do - (Tail n) <- getObjectAttribute a - setObjectAttribute (Tail (n + 1)) a - addTailNumber as - -moveTail :: (GLdouble,GLdouble) -> WormsAction () -moveTail presentHeadPos = do - (GA timer remainingFood tailSize previousHeadPos score) <- getGameAttribute - tails <- getObjectsFromGroup "tail" - aliveTails <- getAliveTails tails [] - lastTail <- findLastTail aliveTails - setObjectPosition previousHeadPos lastTail - setGameAttribute (GA timer remainingFood tailSize presentHeadPos score) - changeTailsAttribute tailSize aliveTails - -findLastTail :: [WormsObject] -> WormsAction WormsObject -findLastTail [] = error "the impossible has happened!" -findLastTail (t1:[]) = return t1 -findLastTail (t1:t2:ts) = do (Tail na) <- getObjectAttribute t1 - (Tail nb) <- getObjectAttribute t2 - if (na > nb) - then findLastTail (t1:ts) - else findLastTail (t2:ts) - -changeTailsAttribute :: Int -> [WormsObject] -> WormsAction () -changeTailsAttribute _ [] = return () -changeTailsAttribute tailSize (a:as) = do - Tail n <- getObjectAttribute a - setObjectAttribute (Tail (mod (n + 1) tailSize)) a - changeTailsAttribute tailSize as - -checkSnakeCollision :: WormsObject -> WormsAction () -checkSnakeCollision snakeHead = do - headPos <- getObjectPosition snakeHead - tile <- getTileFromWindowPosition headPos - tails <- getObjectsFromGroup "tail" - col <- objectListObjectCollision tails snakeHead - if ( (getTileBlocked tile) || col) - then (do setGameState GameOver - disableObjectsDrawing - disableObjectsMoving - setGameAttribute (GA defaultTimer 0 0 (0,0) 0)) - else return () - -createNewFoodPosition :: WormsAction (GLdouble,GLdouble) -createNewFoodPosition = do - x <- randomInt (1,18) - y <- randomInt (1,24) - mapPositionOk <- checkMapPosition (x,y) - tails <- getObjectsFromGroup "tail" - tailPositionNotOk <- pointsObjectListCollision (toPixelCoord y) (toPixelCoord x) tileSize tileSize tails - if (mapPositionOk && not tailPositionNotOk) - then (return (toPixelCoord y,toPixelCoord x)) - else createNewFoodPosition - where toPixelCoord a = (tileSize/2) + (fromIntegral a) * tileSize - -checkMapPosition :: (Int,Int) -> WormsAction Bool -checkMapPosition (x,y) = do - mapTile <- getTileFromIndex (x,y) - return (not (getTileBlocked mapTile)) - -b,f,g,h,i,j :: WormsTile -b = (border1, True, 0.0, NoTileAttribute) -f = (free1, False, 0.0, NoTileAttribute) -g = (border2, True, 0.0, NoTileAttribute) -h = (free2, False, 0.0, NoTileAttribute) -i = (border3, True, 0.0, NoTileAttribute) -j = (free3, False, 0.0, NoTileAttribute) - -map1 :: WormsMap -map1 = [[b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b], - [b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b]] - -map2 :: WormsMap -map2 = [[g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,g,g,g,g,g,g,g,g,g,g,g,g,g,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,g,g,g,g,g,g,g,g,g,g,g,g,g,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g], - [g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g]] - -map3 :: WormsMap -map3 = [[i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i], - [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,i,i,i,i,i,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,i,i,i,i,i,i,i,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i], - [i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i]] +{- ++worms - a very simple FunGEn example.+http://www.cin.ufpe.br/~haskell/fungen+Copyright (C) 2001 Andre Furtado <awbf@cin.ufpe.br>++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 Main where++import Text.Printf+import Graphics.UI.Fungen+import Graphics.Rendering.OpenGL (GLdouble)+import Paths_FunGEn (getDataFileName)++data GameAttribute = GA Int Int Int (GLdouble,GLdouble) Int+data ObjectAttribute = NoObjectAttribute | Tail Int+data GameState = LevelStart Int | Level Int | GameOver+data TileAttribute = NoTileAttribute++type WormsAction a = IOGame GameAttribute ObjectAttribute GameState TileAttribute a+type WormsObject = GameObject ObjectAttribute+type WormsTile = Tile TileAttribute+type WormsMap = TileMatrix TileAttribute++tileSize, speedMod :: GLdouble+tileSize = 30.0+speedMod = 30.0++initPos, tail0Pos, tail1Pos :: (GLdouble,GLdouble)+initPos = (45.0,105.0)+tail0Pos = (45.0,75.0)+tail1Pos = (45.0,45.0)++maxFood, initTailSize, defaultTimer :: Int+maxFood = 10+initTailSize = 2+defaultTimer = 10++magenta :: InvList+magenta = Just [(255,0,255)]++bmpList :: FilePictureList+bmpList = [("level1.bmp", Nothing),+ ("level2.bmp", Nothing),+ ("level3.bmp", Nothing),+ ("gameover.bmp", magenta),+ ("congratulations.bmp", magenta),+ ("headn.bmp", magenta),+ ("heads.bmp", magenta),+ ("heade.bmp", magenta),+ ("headw.bmp", magenta),+ ("food.bmp", magenta),+ ("segment.bmp", magenta),+ ("border1.bmp", magenta),+ ("border2.bmp", magenta),+ ("border3.bmp", magenta),+ ("free1.bmp", magenta),+ ("free2.bmp", magenta),+ ("free3.bmp", magenta)]++-- position of the paths in the list:+border1, border2, border3, free1, free2, free3 :: Int+border1 = 11+border2 = 12+border3 = 13+free1 = 14+free2 = 15+free3 = 16++main :: IO ()+main = do+ let winConfig = ((200,100),(780,600),"WORMS - by Andre Furtado")++ gameMap = multiMap [(tileMap map1 tileSize tileSize),+ (tileMap map2 tileSize tileSize),+ (tileMap map3 tileSize tileSize)] 0++ gameAttribute = GA defaultTimer maxFood initTailSize initPos 0++ groups = [(objectGroup "messages" createMsgs ),+ (objectGroup "head" [createHead]),+ (objectGroup "food" [createFood]),+ (objectGroup "tail" createTail )]++ input = [+ (SpecialKey KeyLeft, Press, turnLeft ),+ (SpecialKey KeyRight, Press, turnRight),+ (SpecialKey KeyUp, Press, turnUp ),+ (SpecialKey KeyDown, Press, turnDown )+ ,(Char 'q', Press, \_ _ -> funExit)+ ]+ + bmpList' <- mapM (\(a,b) -> do { a' <- getDataFileName ("examples/worms/"++a); return (a', b)}) bmpList+ funInit winConfig gameMap groups (LevelStart 1) gameAttribute input gameCycle (Timer 150) bmpList'++createMsgs :: [WormsObject]+createMsgs =+ let picLevel1 = Tex (150,50) 0+ picLevel2 = Tex (150,50) 1+ picLevel3 = Tex (150,50) 2+ picGameOver = Tex (300,100) 3+ picCongratulations = Tex (300,100) 4+ in [(object "level1" picLevel1 True (395,300) (0,0) NoObjectAttribute),+ (object "level2" picLevel2 True (395,300) (0,0) NoObjectAttribute),+ (object "level3" picLevel3 True (395,300) (0,0) NoObjectAttribute),+ (object "gameover" picGameOver True (395,300) (0,0) NoObjectAttribute),+ (object "congratulations" picCongratulations True (395,300) (0,0) NoObjectAttribute)]++createHead :: WormsObject+createHead = let pic = Tex (tileSize,tileSize) 5+ in object "head" pic True initPos (0,speedMod) NoObjectAttribute++createFood :: WormsObject+createFood = let pic = Tex (tileSize,tileSize) 9+ in object "food" pic True (0,0) (0,0) NoObjectAttribute++createTail :: [WormsObject]+createTail = let picTail = Tex (tileSize,tileSize) 10+ in (object "tail0" picTail False tail0Pos (0,0) (Tail 0)):+ (object "tail1" picTail False tail1Pos (0,0) (Tail 1)):+ (createAsleepTails initTailSize (initTailSize + maxFood - 1) picTail)++createAsleepTails :: Int -> Int -> ObjectPicture -> [WormsObject]+createAsleepTails tMin tMax pic+ | (tMin > tMax) = []+ | otherwise = (object ("tail" ++ (show tMin)) pic True (0,0) (0,0) (Tail 0)):(createAsleepTails (tMin + 1) tMax pic)++turnLeft :: Modifiers -> Position -> WormsAction ()+turnLeft _ _ = do+ snakeHead <- findObject "head" "head"+ setObjectCurrentPicture 8 snakeHead+ setObjectSpeed (-speedMod,0) snakeHead+ +turnRight :: Modifiers -> Position -> WormsAction ()+turnRight _ _ = do+ snakeHead <- findObject "head" "head"+ setObjectCurrentPicture 7 snakeHead+ setObjectSpeed (speedMod,0) snakeHead++turnUp :: Modifiers -> Position -> WormsAction ()+turnUp _ _ = do+ snakeHead <- findObject "head" "head"+ setObjectCurrentPicture 5 snakeHead+ setObjectSpeed (0,speedMod) snakeHead++turnDown :: Modifiers -> Position -> WormsAction ()+turnDown _ _ = do+ snakeHead <- findObject "head" "head"+ setObjectCurrentPicture 6 snakeHead+ setObjectSpeed (0,-speedMod) snakeHead++gameCycle :: WormsAction ()+gameCycle = do+ (GA timer remainingFood tailSize previousHeadPos score) <- getGameAttribute+ gState <- getGameState+ case gState of+ LevelStart n -> case n of+ 4 -> do+ congratulations <- findObject "congratulations" "messages"+ drawObject congratulations+ if (timer == 0)+ then funExit+ else (setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score))+ _ -> do+ disableGameFlags+ level <- findObject ("level" ++ (show n)) "messages"+ drawObject level+ if (timer == 0)+ then (do setGameState (Level n)+ enableGameFlags+ snakeHead <- findObject "head" "head"+ setObjectAsleep False snakeHead+ setObjectPosition initPos snakeHead+ setObjectSpeed (0.0,speedMod) snakeHead+ setObjectCurrentPicture 5 snakeHead+ setGameAttribute (GA defaultTimer remainingFood tailSize previousHeadPos score)+ destroyObject level+ setNewMap n)+ else setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score)+ Level n -> do+ if (remainingFood == 0) -- advance level!+ then (do setGameState (LevelStart (n + 1))+ resetTails+ disableGameFlags+ setGameAttribute (GA timer maxFood initTailSize initPos score))+ else if (timer == 0) -- put a new food in the map+ then (do food <- findObject "food" "food"+ newPos <- createNewFoodPosition+ setObjectPosition newPos food+ newFood <- findObject "food" "food"+ setObjectAsleep False newFood+ setGameAttribute (GA (-1) remainingFood tailSize previousHeadPos score)+ snakeHead <- findObject "head" "head"+ checkSnakeCollision snakeHead+ snakeHeadPosition <- getObjectPosition snakeHead+ moveTail snakeHeadPosition)+ else if (timer > 0) -- there is no food in the map, so decrease the food timer+ then (do setGameAttribute (GA (timer - 1) remainingFood tailSize previousHeadPos score)+ snakeHead <- findObject "head" "head"+ checkSnakeCollision snakeHead+ snakeHeadPosition <- getObjectPosition snakeHead+ moveTail snakeHeadPosition)+ else (do -- there is a food in the map+ food <- findObject "food" "food"+ snakeHead <- findObject "head" "head"+ col <- objectsCollision snakeHead food+ if col+ then (do snakeHeadPosition <- getObjectPosition snakeHead+ setGameAttribute (GA defaultTimer (remainingFood-1) (tailSize + 1) snakeHeadPosition (score + 1))+ addTail previousHeadPos+ setObjectAsleep True food)+ else (do checkSnakeCollision snakeHead+ snakeHeadPosition <- getObjectPosition snakeHead+ moveTail snakeHeadPosition))+ showScore++ GameOver -> do+ disableMapDrawing+ gameover <- findObject "gameover" "messages"+ drawMap+ drawObject gameover+ if (timer == 0)+ then funExit+ else (setGameAttribute (GA (timer - 1) 0 0 (0,0) 0))++showScore :: WormsAction ()+showScore = do+ (GA _ remainingFood _ _ score) <- getGameAttribute+ printOnScreen (printf "Score: %d Food remaining: %d" score remainingFood) TimesRoman24 (40,8) 1.0 1.0 1.0+ showFPS TimesRoman24 (780-60,8) 1.0 0.0 0.0++setNewMap :: Int -> WormsAction ()+setNewMap 2 = setCurrentMapIndex 1+setNewMap 3 = setCurrentMapIndex 2+setNewMap _ = return ()++resetTails :: WormsAction ()+resetTails = do+ tail0 <- findObject "tail0" "tail"+ setObjectPosition tail0Pos tail0+ setObjectAttribute (Tail 0) tail0+ tail1 <- findObject "tail1" "tail"+ setObjectPosition tail1Pos tail1+ setObjectAttribute (Tail 1) tail1+ resetOtherTails initTailSize++resetOtherTails :: Int -> WormsAction ()+resetOtherTails n | (n == initTailSize + maxFood) = return ()+ | otherwise = do tailn <- findObject ("tail" ++ (show n)) "tail"+ setObjectAsleep True tailn+ resetOtherTails (n + 1)++addTail :: (GLdouble,GLdouble) -> WormsAction ()+addTail presentHeadPos = do+ tails <- getObjectsFromGroup "tail"+ aliveTails <- getAliveTails tails []+ asleepTail <- getAsleepTail tails+ setObjectAsleep False asleepTail+ setObjectPosition presentHeadPos asleepTail+ setObjectAttribute (Tail 0) asleepTail+ addTailNumber aliveTails++getAliveTails :: [WormsObject] -> [WormsObject] -> WormsAction [WormsObject]+getAliveTails [] t = return t+getAliveTails (o:os) t = do+ sleeping <- getObjectAsleep o+ if sleeping+ then getAliveTails os t+ else getAliveTails os (o:t)++getAsleepTail :: [WormsObject] -> WormsAction WormsObject+getAsleepTail [] = error "the impossible has happened!"+getAsleepTail (o:os) = do+ sleeping <- getObjectAsleep o+ if sleeping+ then return o+ else getAsleepTail os+++addTailNumber :: [WormsObject] -> WormsAction ()+addTailNumber [] = return ()+addTailNumber (a:as) = do+ (Tail n) <- getObjectAttribute a+ setObjectAttribute (Tail (n + 1)) a+ addTailNumber as++moveTail :: (GLdouble,GLdouble) -> WormsAction ()+moveTail presentHeadPos = do+ (GA timer remainingFood tailSize previousHeadPos score) <- getGameAttribute+ tails <- getObjectsFromGroup "tail"+ aliveTails <- getAliveTails tails []+ lastTail <- findLastTail aliveTails+ setObjectPosition previousHeadPos lastTail+ setGameAttribute (GA timer remainingFood tailSize presentHeadPos score)+ changeTailsAttribute tailSize aliveTails++findLastTail :: [WormsObject] -> WormsAction WormsObject+findLastTail [] = error "the impossible has happened!"+findLastTail (t1:[]) = return t1+findLastTail (t1:t2:ts) = do (Tail na) <- getObjectAttribute t1+ (Tail nb) <- getObjectAttribute t2+ if (na > nb)+ then findLastTail (t1:ts)+ else findLastTail (t2:ts)++changeTailsAttribute :: Int -> [WormsObject] -> WormsAction ()+changeTailsAttribute _ [] = return ()+changeTailsAttribute tailSize (a:as) = do+ Tail n <- getObjectAttribute a+ setObjectAttribute (Tail (mod (n + 1) tailSize)) a+ changeTailsAttribute tailSize as++checkSnakeCollision :: WormsObject -> WormsAction ()+checkSnakeCollision snakeHead = do+ headPos <- getObjectPosition snakeHead+ tile <- getTileFromWindowPosition headPos+ tails <- getObjectsFromGroup "tail"+ col <- objectListObjectCollision tails snakeHead+ if ( (getTileBlocked tile) || col)+ then (do setGameState GameOver+ disableObjectsDrawing+ disableObjectsMoving+ setGameAttribute (GA defaultTimer 0 0 (0,0) 0))+ else return ()++createNewFoodPosition :: WormsAction (GLdouble,GLdouble)+createNewFoodPosition = do+ x <- randomInt (1,18)+ y <- randomInt (1,24)+ mapPositionOk <- checkMapPosition (x,y)+ tails <- getObjectsFromGroup "tail"+ tailPositionNotOk <- pointsObjectListCollision (toPixelCoord y) (toPixelCoord x) tileSize tileSize tails+ if (mapPositionOk && not tailPositionNotOk)+ then (return (toPixelCoord y,toPixelCoord x))+ else createNewFoodPosition+ where toPixelCoord a = (tileSize/2) + (fromIntegral a) * tileSize++checkMapPosition :: (Int,Int) -> WormsAction Bool+checkMapPosition (x,y) = do+ mapTile <- getTileFromIndex (x,y)+ return (not (getTileBlocked mapTile))++b,f,g,h,i,j :: WormsTile+b = (border1, True, 0.0, NoTileAttribute)+f = (free1, False, 0.0, NoTileAttribute)+g = (border2, True, 0.0, NoTileAttribute)+h = (free2, False, 0.0, NoTileAttribute)+i = (border3, True, 0.0, NoTileAttribute)+j = (free3, False, 0.0, NoTileAttribute)++map1 :: WormsMap+map1 = [[b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,f,b],+ [b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b,b]]++map2 :: WormsMap+map2 = [[g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,g,g,g,g,g,g,g,g,g,g,g,g,g,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,g,g,g,g,g,g,g,g,g,g,g,g,g,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,h,g],+ [g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g,g]]++map3 :: WormsMap+map3 = [[i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i],+ [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,i,i,i,i,i,i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,i,i,i,i,i,i,i,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,j,i,j,j,j,j,j,j,j,i],+ [i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i,i]]