diff --git a/BSD3.txt b/BSD3.txt deleted file mode 100644 --- a/BSD3.txt +++ /dev/null @@ -1,25 +0,0 @@ -Copyright (C) 2002 Andre Furtado - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. The names of the author may not be used to endorse or promote - products derived from this software without specific prior written - permission. - -THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. diff --git a/Examples/pong/hit.wav b/Examples/pong/hit.wav deleted file mode 100644 Binary files a/Examples/pong/hit.wav and /dev/null differ diff --git a/Examples/pong/pong.hs b/Examples/pong/pong.hs deleted file mode 100644 --- a/Examples/pong/pong.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2001 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This is a very simple FunGEn example. -In order to use the Makefile, set the HC, FG (FunGEn dir) and TOP variables correctly. - --} - -module Main where - -import Graphics.UI.FunGEn - -data GameAttribute = Score Int - -type PongObject = GameObject () -type PongAction a = IOGame GameAttribute () () () a - -width = 400 -height = 400 -w = fromIntegral width :: Double -h = fromIntegral height :: Double - -main :: IO () -main = do - let winConfig = ((100,20),(width,height),"A brief example!") - bmpList = [("tex.bmp",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)] - - funInit winConfig gameMap [bar,ball] () initScore input gameCycle (Timer 30) bmpList - -createBall :: PongObject -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 :: PongObject -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 :: PongAction () -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 :: PongAction () -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 :: PongAction () -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 reverseYSpeed ball) -- (funExit) - - 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 - diff --git a/Examples/pong/tex.bmp b/Examples/pong/tex.bmp deleted file mode 100644 Binary files a/Examples/pong/tex.bmp and /dev/null differ diff --git a/Examples/worms/border1.bmp b/Examples/worms/border1.bmp deleted file mode 100644 Binary files a/Examples/worms/border1.bmp and /dev/null differ diff --git a/Examples/worms/border2.bmp b/Examples/worms/border2.bmp deleted file mode 100644 Binary files a/Examples/worms/border2.bmp and /dev/null differ diff --git a/Examples/worms/border3.bmp b/Examples/worms/border3.bmp deleted file mode 100644 Binary files a/Examples/worms/border3.bmp and /dev/null differ diff --git a/Examples/worms/congratulations.bmp b/Examples/worms/congratulations.bmp deleted file mode 100644 Binary files a/Examples/worms/congratulations.bmp and /dev/null differ diff --git a/Examples/worms/food.bmp b/Examples/worms/food.bmp deleted file mode 100644 Binary files a/Examples/worms/food.bmp and /dev/null differ diff --git a/Examples/worms/free1.bmp b/Examples/worms/free1.bmp deleted file mode 100644 Binary files a/Examples/worms/free1.bmp and /dev/null differ diff --git a/Examples/worms/free2.bmp b/Examples/worms/free2.bmp deleted file mode 100644 Binary files a/Examples/worms/free2.bmp and /dev/null differ diff --git a/Examples/worms/free3.bmp b/Examples/worms/free3.bmp deleted file mode 100644 Binary files a/Examples/worms/free3.bmp and /dev/null differ diff --git a/Examples/worms/gameover.bmp b/Examples/worms/gameover.bmp deleted file mode 100644 Binary files a/Examples/worms/gameover.bmp and /dev/null differ diff --git a/Examples/worms/heade.bmp b/Examples/worms/heade.bmp deleted file mode 100644 Binary files a/Examples/worms/heade.bmp and /dev/null differ diff --git a/Examples/worms/headn.bmp b/Examples/worms/headn.bmp deleted file mode 100644 Binary files a/Examples/worms/headn.bmp and /dev/null differ diff --git a/Examples/worms/heads.bmp b/Examples/worms/heads.bmp deleted file mode 100644 Binary files a/Examples/worms/heads.bmp and /dev/null differ diff --git a/Examples/worms/headw.bmp b/Examples/worms/headw.bmp deleted file mode 100644 Binary files a/Examples/worms/headw.bmp and /dev/null differ diff --git a/Examples/worms/level1.bmp b/Examples/worms/level1.bmp deleted file mode 100644 Binary files a/Examples/worms/level1.bmp and /dev/null differ diff --git a/Examples/worms/level2.bmp b/Examples/worms/level2.bmp deleted file mode 100644 Binary files a/Examples/worms/level2.bmp and /dev/null differ diff --git a/Examples/worms/level3.bmp b/Examples/worms/level3.bmp deleted file mode 100644 Binary files a/Examples/worms/level3.bmp and /dev/null differ diff --git a/Examples/worms/segment.bmp b/Examples/worms/segment.bmp deleted file mode 100644 Binary files a/Examples/worms/segment.bmp and /dev/null differ diff --git a/Examples/worms/worms.hs b/Examples/worms/worms.hs deleted file mode 100644 --- a/Examples/worms/worms.hs +++ /dev/null @@ -1,416 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2001 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This is a very simple FunGEn example. -In order to use the Makefile, set the HC, FG (FunGEn dir) and TOP variables correctly. - --} - -module Main where - -import Text.Printf -import Graphics.UI.FunGEn - -data GameAttribute = GA Int Int Int (Double,Double) 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 :: Double -tileSize = 30.0 -speedMod = 30.0 - -initPos, tail0Pos, tail1Pos :: (Double,Double) -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 = ((100,50),(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 )] - - 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 :: WormsAction () -turnLeft = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 8 snakeHead - setObjectSpeed (-speedMod,0) snakeHead - -turnRight :: WormsAction () -turnRight = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 7 snakeHead - setObjectSpeed (speedMod,0) snakeHead - -turnUp :: WormsAction () -turnUp = do - snakeHead <- findObject "head" "head" - setObjectCurrentPicture 5 snakeHead - setObjectSpeed (0,speedMod) snakeHead - -turnDown :: 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 :: (Double,Double) -> 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 :: (Double,Double) -> 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 (Double,Double) -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]] diff --git a/FunGEn.cabal b/FunGEn.cabal --- a/FunGEn.cabal +++ b/FunGEn.cabal @@ -1,29 +1,36 @@ name: FunGEn -version: 0.1 -copyright: (C) 2002 Andre Furtado +version: 0.3 +copyright: (C) 2002 Andre Furtado , (C) 2008 Miloslav Raus <666wman@gmail.com>, (C) 2008,2011 Simon Michael license: BSD3 -license-file: BSD3.txt +license-file: LICENSE author: Andre Furtado -maintainer: wman <666wman@gmail.com> +maintainer: Simon Michael +homepage: http://darcsden.com/simon/fungen category: Game synopsis: FUNctional Game ENgine -description: Multi-platform functional game engine built on top of OpenGL & GLUT +description: Multi-platform 2D game engine built on top of OpenGL & GLUT stability: experimental -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple -tested-with: GHC==6.8.3 -extra-source-files: readme.txt, Examples/pong/hit.wav, Examples/pong/pong.hs, Examples/pong/tex.bmp, - Examples/worms/border1.bmp, Examples/worms/border2.bmp, Examples/worms/border3.bmp, - Examples/worms/congratulations.bmp, Examples/worms/food.bmp, Examples/worms/free1.bmp, - Examples/worms/free2.bmp, Examples/worms/free3.bmp, Examples/worms/gameover.bmp, - Examples/worms/heade.bmp, Examples/worms/heads.bmp, Examples/worms/headn.bmp, - Examples/worms/headw.bmp, Examples/worms/level1.bmp, Examples/worms/level2.bmp, - Examples/worms/level3.bmp, Examples/worms/segment.bmp, Examples/worms/worms.hs +tested-with: GHC==6.12 +extra-source-files: README.md, examples/pong/hit.wav, examples/pong/pong.hs, examples/pong/tex.bmp, + examples/worms/border1.bmp, examples/worms/border2.bmp, examples/worms/border3.bmp, + examples/worms/congratulations.bmp, examples/worms/food.bmp, examples/worms/free1.bmp, + examples/worms/free2.bmp, examples/worms/free3.bmp, examples/worms/gameover.bmp, + examples/worms/heade.bmp, examples/worms/heads.bmp, examples/worms/headn.bmp, + examples/worms/headw.bmp, examples/worms/level1.bmp, examples/worms/level2.bmp, + examples/worms/level3.bmp, examples/worms/segment.bmp, examples/worms/worms.hs library - exposed-modules: Graphics.UI.FunGEn - other-modules: Graphics.UI.FunGEn.Fun_Types, Graphics.UI.FunGEn.Fun_Aux, Graphics.UI.FunGEn.Fun_Loader, - Graphics.UI.FunGEn.Fun_Objects, Graphics.UI.FunGEn.Fun_Map, Graphics.UI.FunGEn.Fun_Game, - Graphics.UI.FunGEn.Fun_Display, Graphics.UI.FunGEn.Fun_Input, Graphics.UI.FunGEn.Fun_Timer, - Graphics.UI.FunGEn.Fun_Text, Graphics.UI.FunGEn.Fun_Init, Graphics.UI.FunGEn.UserInput - build-depends: base, OpenGL, GLUT, haskell98 + exposed-modules: Graphics.UI.Fungen, + Graphics.UI.Fungen.Types, Graphics.UI.Fungen.Util, Graphics.UI.Fungen.Loader, + Graphics.UI.Fungen.Objects, Graphics.UI.Fungen.Map, Graphics.UI.Fungen.Game, + Graphics.UI.Fungen.Display, Graphics.UI.Fungen.Input, Graphics.UI.Fungen.Timer, + Graphics.UI.Fungen.Text, Graphics.UI.Fungen.Init, Graphics.UI.Fungen.UserInput + + build-depends: + base == 4.* + ,OpenGL + ,GLUT + ,haskell98 + ,random diff --git a/Graphics/UI/FunGEn.hs b/Graphics/UI/FunGEn.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This is the main module of FunGEn. - --} - -module Graphics.UI.FunGEn ( - module Graphics.UI.FunGEn.Fun_Types, - module Graphics.UI.FunGEn.Fun_Aux, - module Graphics.UI.FunGEn.Fun_Loader, - module Graphics.UI.FunGEn.Fun_Objects, - module Graphics.UI.FunGEn.Fun_Map, - module Graphics.UI.FunGEn.Fun_Game, - module Graphics.UI.FunGEn.Fun_Display, - module Graphics.UI.FunGEn.Fun_Input, - module Graphics.UI.FunGEn.Fun_Timer, - module Graphics.UI.FunGEn.Fun_Text, - module Graphics.UI.FunGEn.Fun_Init -) where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Aux -import Graphics.UI.FunGEn.Fun_Loader -import Graphics.UI.FunGEn.Fun_Objects -import Graphics.UI.FunGEn.Fun_Map -import Graphics.UI.FunGEn.Fun_Game -import Graphics.UI.FunGEn.Fun_Display -import Graphics.UI.FunGEn.Fun_Input -import Graphics.UI.FunGEn.Fun_Timer -import Graphics.UI.FunGEn.Fun_Text -import Graphics.UI.FunGEn.Fun_Init diff --git a/Graphics/UI/FunGEn/Fun_Aux.hs b/Graphics/UI/FunGEn/Fun_Aux.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Aux.hs +++ /dev/null @@ -1,152 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains some auxiliary functions. - --} - -module Graphics.UI.FunGEn.Fun_Aux ( - 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 -) where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.Rendering.OpenGL -import Random - -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 :: TextureTarget -> 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 Nothing 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 "Fun_Aux.dropGLsizei error: negative argument" - --- to be used when no invisibility must be added when loading a file -addNoInvisibility :: [FilePath] -> [(FilePath, Maybe ColorList3)] -addNoInvisibility [] = [] -addNoInvisibility (a:as) = (a, Nothing):(addNoInvisibility as) - -racMod :: GLdouble -> GLdouble -> GLdouble -racMod a b | (a >= 0) = racModPos a b - | otherwise = racModNeg a b - -racModPos :: GLdouble -> GLdouble -> GLdouble -racModPos a b | (a - b < 0) = a - | otherwise = racModPos (a - b) b - -racModNeg :: GLdouble -> GLdouble -> GLdouble -racModNeg a b | (a + b > 0) = a - | otherwise = racModPos (a + b) b - -matrixToList :: [[a]] -> [a] -matrixToList [] = [] -matrixToList (a:as) = a ++ (matrixToList as) - --- return the max indexes of a matrix (assumed that its lines have the same length) -matrixSize :: [[a]] -> (Int,Int) -matrixSize [] = (0,0) -matrixSize m@(a:_) = ((length m) - 1,(length a) - 1) - -inv2color3 :: InvList -> Maybe ColorList3 -inv2color3 Nothing = Nothing -inv2color3 (Just l) = Just (inv2color3Aux l) - -inv2color3Aux :: [(Int,Int,Int)] -> [(GLubyte,GLubyte,GLubyte)] -inv2color3Aux [] = [] -inv2color3Aux ((r,g,b):ls) = (z r,z g,z b):(inv2color3Aux ls) - where z = toEnum.fromEnum - -pathAndInv2color3List :: (FilePath,InvList) -> (FilePath, Maybe ColorList3) -pathAndInv2color3List (f,Nothing) = (f,Nothing) -pathAndInv2color3List (f,Just l) = (f,Just (inv2color3Aux l)) - -point2DtoVertex3 :: [Point2D] -> [Vertex3 GLdouble] -point2DtoVertex3 [] = [] -point2DtoVertex3 ((x,y):as) = (Vertex3 x y 0.0):(point2DtoVertex3 as) - -isEmpty :: [a] -> Bool -isEmpty [] = True -isEmpty _ = False - -when :: (Monad m) => Bool -> m () -> m () -when p s = if p then s else return () - -unless :: (Monad m) => Bool -> m () -> m () -unless p s = when (not p) s diff --git a/Graphics/UI/FunGEn/Fun_Display.hs b/Graphics/UI/FunGEn/Fun_Display.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Display.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module renders the game window. - --} - -module Graphics.UI.FunGEn.Fun_Display ( - display -) where - -import Graphics.UI.FunGEn.Fun_Game -import Graphics.UI.FunGEn.Fun_Aux (when) -import Graphics.Rendering.OpenGL -import Graphics.UI.GLUT - -display :: Game t s u v -> IOGame t s u v () -> DisplayCallback -display g gameCycle = do - clear [ColorBuffer] - runIOGame (displayIOGame gameCycle) g - swapBuffers - flush - -displayIOGame :: IOGame t s u v () -> IOGame t s u v () -displayIOGame gameCycle = do - (_,_,objectsMoving) <- getGameFlags - when objectsMoving moveAllObjects - gameCycle - (mapDrawing,objectsDrawing,_) <- getGameFlags - when mapDrawing drawMap - when objectsDrawing drawAllObjects - printText diff --git a/Graphics/UI/FunGEn/Fun_Game.hs b/Graphics/UI/FunGEn/Fun_Game.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Game.hs +++ /dev/null @@ -1,721 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains some important game routines. - --} - - -module Graphics.UI.FunGEn.Fun_Game ( - Game, IOGame, runIOGame, runIOGameM, liftIOtoIOGame, liftIOtoIOGame', - getGameState, setGameState, - getGameFlags, setGameFlags, - enableGameFlags, disableGameFlags, - enableMapDrawing, disableMapDrawing, - enableObjectsDrawing, disableObjectsDrawing, - enableObjectsMoving, disableObjectsMoving, - getObjectManagers, setObjectManagers, - getGameAttribute, setGameAttribute, - createGame, funExit, - drawMap, clearScreen, getTileFromIndex, getTileFromWindowPosition, setCurrentMapIndex, - 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, - objectsCollision, objectsFutureCollision, - objectListObjectCollision, objectListObjectFutureCollision, - objectTopMapCollision, objectBottomMapCollision, objectRightMapCollision, objectLeftMapCollision, - pointsObjectCollision, pointsObjectListCollision, - objectTopMapFutureCollision, objectBottomMapFutureCollision, objectRightMapFutureCollision, objectLeftMapFutureCollision, - printOnPrompt, printOnScreen, printText, randomFloat, randomInt, randomDouble, - showFPS, - wait -) where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Aux -import Graphics.UI.FunGEn.Fun_Loader -import Graphics.UI.FunGEn.Fun_Text -import Graphics.UI.FunGEn.Fun_Map -import Graphics.UI.FunGEn.Fun_Objects -import Graphics.Rendering.OpenGL -import Graphics.Rendering.OpenGL.GLU -import Graphics.UI.GLUT -import Monad -import System.Exit -import Data.IORef -import Text.Printf - - -data Game t s u v = Game { - gameMap :: IORef (GameMap v), - gameState :: IORef u, - gameFlags :: IORef GameFlags, - objManagers :: IORef [(ObjectManager s)], - textList :: IORef [Text], - quadricObj :: QuadricPrimitive, - windowConfig :: IORef WindowConfig, - gameAttribute :: IORef t, - pictureList :: IORef [TextureObject], - fpsInfo :: IORef (Int,Int,Float) -- only for debugging - } - -newtype IOGame t s u v a = IOG (Game t s u v -> IO (Game t s u v,a)) -type GameFlags = (Bool,Bool,Bool) -- mapDrawing, objectsDrawing, objectsMoving - ----------------------------------- --- 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 Monad (IOGame t s u v) where - (>>=) = bindST - return = unitST - -runIOGame :: IOGame t s u v a -> Game t s u v -> IO (Game t s u v,a) -- (a,Game t s u v) the state tuple -runIOGame (IOG f) g = f g - -runIOGameM :: IOGame t s u v a -> Game t s u v -> IO () -runIOGameM x g = runIOGame x g >> return () - -liftIOtoIOGame :: IO a -> IOGame t s u v a -liftIOtoIOGame p = - IOG $ \s -> (do y <- p - return (s,y)) - -liftIOtoIOGame' :: (a -> IO ()) -> a -> IOGame t s u v () -liftIOtoIOGame' p q = - IOG $ \s -> (do p q - return (s,())) - ----------------------------------- --- get & set routines ----------------------------------- - -getMap :: IOGame t s u v (GameMap v) -getMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> if (isMultiMap gm) - then (return (game,getCurrentMap gm)) - else (return (game,gm)) )) - -getRealMap :: IOGame t s u v (GameMap v) -getRealMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> (return (game,gm)) )) - -setRealMap :: GameMap v -> IOGame t s u v () -setRealMap m = IOG ( \game -> (writeIORef (gameMap game) m >> return (game,()) )) - - -getGameState :: IOGame t s u v u -getGameState = IOG ( \game -> (readIORef (gameState game) >>= \gs -> return (game,gs) )) - -setGameState :: u -> IOGame t s u v () -setGameState s = IOG ( \game -> (writeIORef (gameState game) s >> return (game,()) )) - -getTextList :: IOGame t s u v [Text] -getTextList = IOG ( \game -> (readIORef (textList game) >>= \tl -> return (game,tl) )) - -setTextList :: [Text] -> IOGame t s u v () -setTextList t = IOG ( \game -> (writeIORef (textList game) t >> return (game,()) )) - -getGameFlags :: IOGame t s u v GameFlags -getGameFlags = IOG ( \game -> (readIORef (gameFlags game) >>= \gf -> return (game,gf) )) - -setGameFlags :: GameFlags -> IOGame t s u v () -setGameFlags f = IOG ( \game -> (writeIORef (gameFlags game) f >> return (game,()) )) - -getObjectManagers :: IOGame t s u v [(ObjectManager s)] -getObjectManagers = IOG ( \game -> (readIORef (objManagers game) >>= \om -> return (game,om) )) - -setObjectManagers :: [(ObjectManager s)] -> IOGame t s u v () -setObjectManagers o = IOG ( \game -> (writeIORef (objManagers game) o >> return (game,()) )) - -getQuadric :: IOGame t s u v QuadricPrimitive -getQuadric = IOG ( \game -> return (game,quadricObj game) ) - -getPictureList :: IOGame t s u v [TextureObject] -getPictureList = IOG ( \game -> (readIORef (pictureList game) >>= \pl -> return (game,pl) )) - -getWindowConfig :: IOGame t s u v WindowConfig -getWindowConfig = IOG ( \game -> (readIORef (windowConfig game) >>= \wc -> return (game,wc) )) - -getGameAttribute :: IOGame t s u v t -getGameAttribute = IOG ( \game -> (readIORef (gameAttribute game) >>= \ga -> return (game,ga) )) - -setGameAttribute :: t -> IOGame t s u v () -setGameAttribute ga = IOG ( \game -> (writeIORef (gameAttribute game) ga >> return (game,()) )) - --- internal use only -getFpsInfo :: IOGame t s u v (Int,Int,Float) -getFpsInfo = IOG ( \game -> (readIORef (fpsInfo game) >>= \fpsi -> return (game,fpsi) )) - --- internal use only -setFpsInfo :: (Int,Int,Float) -> IOGame t s u v () -setFpsInfo f = IOG ( \game -> (writeIORef (fpsInfo game) f >> return (game,()) )) - ----------------------------------- --- initialization of the game ----------------------------------- -createGame :: GameMap v -> [(ObjectManager s)] -> WindowConfig -> u -> t -> FilePictureList -> IO (Game t s u v) -createGame gMap objectManagers winConf gState gAttrib filePicList = do - gM <- newIORef gMap - gS <- newIORef gState - gF <- newIORef (True,True,True) - gO <- newIORef objectManagers - gT <- newIORef [] - let gQ = Sphere 0 0 0 - gW <- newIORef winConf - gA <- newIORef gAttrib - picList <- loadPictures filePicList - gP <- newIORef picList - gFPS <- newIORef (0,0,0.0) - return (Game { - gameMap = gM, - gameState = gS, - gameFlags = gF, - objManagers = gO, - textList = gT, - quadricObj = gQ, - windowConfig = gW, - gameAttribute = gA, - pictureList = gP, - fpsInfo = gFPS - }) - --- loads all of the pictures used in the game -loadPictures :: [(FilePath,InvList)] -> IO [TextureObject] -loadPictures pathsAndInvLists = do - bmps <- loadBitmapList (map pathAndInv2color3List pathsAndInvLists) - texBmList <- genObjectNames (length bmps) - texStuff texBmList bmps - return texBmList - ---------------------------------- --- ending the game ---------------------------------- -funExit :: IOGame t s u v () -funExit = liftIOtoIOGame' exitWith ExitSuccess - ----------------------------------- --- 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 :: (Double,Double) -> 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 ("Fun_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 "Fun_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 ("Fun_Game.getTileFromIndex error: tile index " ++ (show (x,y)) ++ " out of map range!") - else error "Fun_Game.getTileFromIndex error: game map is not a tile map!" - --- paint the whole screen with a specified RGB color -clearScreen :: Float -> Float -> Float -> 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 "Fun_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 (Double,Double) -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 (Double,Double) -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 (Double,Double) -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 :: (Double,Double) -> 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 :: (Double,Double) -> 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 :: Double -> Double -> Double -> Double -> 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 :: Double -> Double -> Double -> Double -> [(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 -> (Double,Double) -> Float -> Float -> Float -> 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 -> (Double,Double) -> Float -> Float -> Float -> 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 - -wait :: Int -> IOGame t s u v () -wait delay = do - printText -- force text messages to be printed (is not working properly!) - (framei,timebasei,fps) <- getFpsInfo - setFpsInfo (framei,(timebasei + delay),fps) -- helps FPS info to be displayed correctly (if requested) - startTime <- getElapsedTime - - waitAux delay startTime - -waitAux :: Int -> Int -> IOGame t s u v () -waitAux delay startTime = do - presentTime <- getElapsedTime - if (presentTime - startTime > delay) - then return () - else waitAux delay startTime - diff --git a/Graphics/UI/FunGEn/Fun_Init.hs b/Graphics/UI/FunGEn/Fun_Init.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Init.hs +++ /dev/null @@ -1,54 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains the initialization procedures. - --} - -module Graphics.UI.FunGEn.Fun_Init ( - funInit -)where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Loader(FilePictureList) -import Graphics.UI.FunGEn.Fun_Display -import Graphics.UI.FunGEn.Fun_Input -import Graphics.UI.FunGEn.Fun_Map -import Graphics.UI.FunGEn.Fun_Objects -import Graphics.UI.FunGEn.Fun_Game -import Graphics.UI.FunGEn.Fun_Timer -import Graphics.Rendering.OpenGL -import Graphics.UI.GLUT - -funInit :: WindowConfig -> GameMap v -> [(ObjectManager s)] -> u -> t -> [InputConfig t s u v] -> IOGame t s u v () -> RefreshType -> FilePictureList -> 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) <- funBinding 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 diff --git a/Graphics/UI/FunGEn/Fun_Input.hs b/Graphics/UI/FunGEn/Fun_Input.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Input.hs +++ /dev/null @@ -1,34 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module controls the user input (mouse, keyboard, joystick...) - --} - -module Graphics.UI.FunGEn.Fun_Input ( - InputConfig, - Key(..), KeyEvent(..), SpecialKey(..), MouseButton(..), - funBinding -) where - -import Graphics.UI.FunGEn.Fun_Game -import Graphics.UI.FunGEn.UserInput -import Graphics.UI.GLUT - -type InputConfig t s u v = (Key,KeyEvent,IOGame t s u v ()) - -funBinding :: [InputConfig t s u v] -> Game t s u v -> IO (KeyBinder, StillDownHandler) -funBinding inputs g = do - (bindKey, stillDown) <- initUserInput - mapM (userBinding g bindKey) inputs - return (bindKey, stillDown) - -userBinding :: Game t s u v -> KeyBinder -> InputConfig t s u v -> IO () -userBinding g bindKey (key,keyEvent,gameAction) = bindKey key keyEvent (Just (runIOGameM gameAction g)) diff --git a/Graphics/UI/FunGEn/Fun_Loader.hs b/Graphics/UI/FunGEn/Fun_Loader.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Loader.hs +++ /dev/null @@ -1,81 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module loads [bmp] files. - --} - -module Graphics.UI.FunGEn.Fun_Loader ( - loadBitmap, loadBitmapList, FilePictureList -)where - -import Graphics.Rendering.OpenGL -import IO -import Foreign -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Aux -import Graphics.UI.FunGEn.Fun_Types(ColorList3, AwbfBitmap) - -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 <- openFile 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 "Fun_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 "Fun_Loader.makeColorListAux error: strange bitmap file" diff --git a/Graphics/UI/FunGEn/Fun_Map.hs b/Graphics/UI/FunGEn/Fun_Map.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Map.hs +++ /dev/null @@ -1,232 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains the map (game background) routines. - --} - -module Graphics.UI.FunGEn.Fun_Map ( - GameMap, - Tile, TileMatrix, - getTilePictureIndex, getTileBlocked, getTileMoveCost, getTileSpecialAttribute, - colorMap, textureMap, tileMap, multiMap, - getMapSize, - isTileMap, getTileMapTileMatrix, getTileMapScroll, getTileMapSize, getTileMapTileSize, - getCurrentMap, updateCurrentMap, updateCurrentIndex, isMultiMap, - drawGameMap, clearGameScreen -)where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Aux -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)] - -data GameMap t - = ColorMap (Color4 GLfloat) 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 "Fun_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 "Fun_Map.getTileMapTileMatrix error: game map is not a tile map!" - -getTileMapTileSize :: GameMap t -> Point2D -getTileMapTileSize (TileMap _ ts _ _ _) = ts -getTileMapTileSize _ = error "Fun_Map.getTileMapTileSize error: game map is not a tile map!" - -getTileMapScroll :: GameMap t -> Point2D -getTileMapScroll (TileMap _ _ s _ _) = s -getTileMapScroll _ = error "Fun_Map.getTileMapScroll error: game map is not a tile map!" - -getTileMapSize :: GameMap t -> Point2D -getTileMapSize (TileMap _ _ _ _ s) = s -getTileMapSize _ = error "Fun_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 "Fun_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 "Fun_Map.updateCurrentMap error: updateCurrentMap can only be applied with MultiMaps!" - --- internal use only! -newMapList :: [(GameMap t)] -> GameMap t -> Int -> [(GameMap t)] -newMapList [] _ _ = error "Fun_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 "Fun_Map.updateMultiMapIndex error: map index out of range!" - | otherwise = (MultiMap mapList i) -updateCurrentIndex _ _ = error "Fun_Map.updateCurrentIndex error: the game map is not a MultiMap!" - ------------------------------ --- creation of maps ------------------------------ - --- creates a PreColorMap -colorMap :: Float -> Float -> Float -> Double -> Double -> GameMap t -colorMap r g b sX sY = ColorMap (Color4 r g b 1.0) (sX,sY) - --- creates a PreTextureMap -textureMap :: Int -> Double -> Double -> Double -> Double -> 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 -> Double -> Double -> GameMap t -tileMap matrix tX tY | matrixOk matrix = TileMap matrix (tX,tY) (0,0) (0,0) (sX,sY) - | otherwise = error "Fun_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 "Fun_Map.multiMap error: the MultiMap map list should not be empty!" -multiMap mapList currentMap | (currentMap >= (length mapList)) = error "Fun_Map.multiMap error: map index out of range!" - | (mapListContainsMultiMap mapList) = error "Fun_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 - --- cheks 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 ROUTINES -- ----------------------------------------- -clearGameScreen :: Float -> Float -> Float -> IO () -clearGameScreen r g b = do - clearColor $= (Color4 r g b (1.0 :: GLfloat)) - clear [ColorBuffer] - --- draws 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 "Fun_Map.drawGameMap error: drawGameMap cannot be applied with MultiMaps!" - --- size of texture, drawing position relative to (X,Y) axis of window, lowest Y drawing position -drawTextureMap :: Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () -drawTextureMap (tX,tY) (winX,winY) (winWidth,winHeight) baseY texList - | (winY > winHeight) = drawTextureMap (tX,tY) (winX + tX, baseY) (winWidth,winHeight) baseY texList - | (winX > winWidth) = return () - | otherwise = do - loadIdentity - translate (Vector3 winX winY (0 :: GLdouble) ) - color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) - renderPrimitive Quads $ do - texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) - texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) - texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) - texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) - drawTextureMap (tX,tY) (winX,winY + tY) (winWidth,winHeight) baseY texList - --- textures handles, tile matrix, size of texture, (X,Y) scroll, drawing position relative to Y axis of window -drawTileMap :: TileMatrix t -> Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () -drawTileMap [] _ _ _ _ _ = return () -- no more tile lines to drawn, so we're done here! -drawTileMap (a:as) (tX,tY) (sX,sY) (winWidth,winHeight) winY texList - | (sY >= tY) = drawTileMap as (tX,tY) (sX,sY-tY) (winWidth,winHeight) winY texList -- scrolls in the Y axis - | (winY > winHeight) = return () -- drawing position is higher than the Y window coordinate - | otherwise = do - drawTileMapLine a (tX,tY) sX (0.0,winY-sY) winWidth texList - drawTileMap as (tX,tY) (sX,sY) (winWidth,winHeight) (winY - sY + tY) texList - --- textures handles, tile line, size of texture, X scroll, drawing position relative to (X,Y) axis of window -drawTileMapLine :: TileLine t -> Point2D -> GLdouble -> Point2D -> GLdouble -> [TextureObject] -> IO () -drawTileMapLine [] _ _ _ _ _ = return () -- no more tiles to drawn, so we're done here! -drawTileMapLine (a:as) (tX,tY) sX (winX,winY) winWidth texList - | (sX >= tX) = drawTileMapLine as (tX,tY) (sX-tX) (winX,winY) winWidth texList -- scrolls in the X axis - | (winX > winWidth) = return () -- drawing position is higher than the X window coordinate - | otherwise = do - bindTexture Texture2D (texList !! (getTilePictureIndex a)) - loadIdentity - translate (Vector3 (new_winX) winY (0 :: GLdouble) ) - color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) - renderPrimitive Quads $ do - texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) - texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) - texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) - texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) - drawTileMapLine as (tX,tY) sX (new_winX + sX + tX,winY) winWidth texList - where new_winX | (sX >= 0) = winX + sX - | otherwise = winX + sX diff --git a/Graphics/UI/FunGEn/Fun_Objects.hs b/Graphics/UI/FunGEn/Fun_Objects.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Objects.hs +++ /dev/null @@ -1,326 +0,0 @@ -{- -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This modules contains the FunGEn objects procedures - --} - -module Graphics.UI.FunGEn.Fun_Objects ( - GameObject, - getGameObjectId, getGameObjectName, getGameObjectManagerName, getGameObjectAsleep, getGameObjectPosition, getGameObjectSize, getGameObjectSpeed, getGameObjectAttribute, - getObjectManagerName, getObjectManagerCounter , getObjectManagerObjects, - ObjectPicture(..), Primitive(..), - FillMode (..), - object, drawGameObjects, drawGameObject, - objectGroup, ObjectManager, - findObjectFromId, searchObjectManager, searchGameObject, - updateObject, updateObjectAsleep, updateObjectSize, updateObjectPosition, - updateObjectSpeed, updateObjectAttribute, updateObjectPicture, - addObjectsToManager, - moveGameObjects, - destroyGameObject -) where - -import Graphics.UI.FunGEn.Fun_Types -import Graphics.UI.FunGEn.Fun_Aux -import Graphics.Rendering.OpenGL hiding (Primitive) -import Graphics.UI.GLUT 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] Float Float Float FillMode -- the points (must be in CCW order!), color, fill mode - | Circle Double Float Float Float FillMode -- color, radius, fill mode - -data ObjectPicture - = Tex (Double,Double) 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 -> (Double,Double) -getGameObjectSize o = (realToFrac sX,realToFrac sY) - where (sX,sY) = objSize o - -getGameObjectPosition :: GameObject t -> (Double,Double) -getGameObjectPosition o = (realToFrac pX,realToFrac pY) - where (pX,pY) = objPosition o - -getGameObjectSpeed :: GameObject t -> (Double,Double) -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 ("Fun_Objects.updateObjectPicture error: picture index out of range for object " ++ - (getGameObjectName obj) ++ " of group " ++ (getGameObjectManagerName obj))) - _ -> error ("Fun_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 :: (Double,Double) -> GameObject t -> GameObject t -updateObjectSize (sX,sY) o = o {objSize = (realToFrac sX, realToFrac sY)} - -updateObjectPosition :: (Double,Double) -> GameObject t -> GameObject t -updateObjectPosition (pX,pY) o = o {objPosition = (realToFrac pX, realToFrac pY)} - -updateObjectSpeed :: (Double,Double) -> 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 -> (Double,Double) -> (Double,Double) -> 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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_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 ("Fun_Objects.destroyGameObjectAux error: object: " ++ objectName ++ " not found!") -destroyGameObjectAux objectName (o:os) | (getGameObjectName o == objectName) = os - | otherwise = o:(destroyGameObjectAux objectName os) diff --git a/Graphics/UI/FunGEn/Fun_Text.hs b/Graphics/UI/FunGEn/Fun_Text.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Text.hs +++ /dev/null @@ -1,36 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains some functions to print text on the screen. -Fonts supported: Bitmap9By15, Bitmap8By13, BitmapTimesRoman10, BitmapTimesRoman24 - BitmapHelvetica10, BitmapHelvetica12, BitmapHelvetica18 - --} - -module Graphics.UI.FunGEn.Fun_Text ( - Text, - BitmapFont(..), - putGameText -) where - -import Graphics.UI.GLUT -import Graphics.Rendering.OpenGL - -type Text = (String,BitmapFont,(GLdouble,GLdouble),GLfloat,GLfloat,GLfloat) - --- string to be printed, type of font, screen position, color RGB -putGameText :: [Text] -> IO () -putGameText [] = return () -putGameText ((text,font,(x,y),r,g,b):ts) = do - loadIdentity - color (Color3 r g b) - rasterPos (Vertex2 x y) - renderString font text - putGameText ts diff --git a/Graphics/UI/FunGEn/Fun_Timer.hs b/Graphics/UI/FunGEn/Fun_Timer.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Timer.hs +++ /dev/null @@ -1,35 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module controls timing (how time-based functions will behave). - --} - -module Graphics.UI.FunGEn.Fun_Timer ( - RefreshType(..), - setRefresh -) where - -import Graphics.UI.FunGEn.UserInput -import Graphics.UI.GLUT - -data RefreshType - = Idle - | Timer Int - -setRefresh :: RefreshType -> StillDownHandler -> IO () -setRefresh Idle stillDown = idleCallback $= Just (stillDown >> postRedisplay Nothing) -setRefresh (Timer t) stillDown = addTimerCallback t (timer stillDown t) - -timer :: StillDownHandler -> Int -> TimerCallback -timer stillDown t = do - stillDown - postRedisplay Nothing - addTimerCallback t (timer stillDown t) diff --git a/Graphics/UI/FunGEn/Fun_Types.hs b/Graphics/UI/FunGEn/Fun_Types.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/Fun_Types.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- - -FunGEN - Functional Game Engine -http://www.cin.ufpe.br/~haskell/fungen -Copyright (C) 2002 Andre Furtado - -This code is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - -This FunGEn module contains the FunGEN basic types. - --} - -module Graphics.UI.FunGEn.Fun_Types ( - WindowConfig, - Point2D, - ColorList3, AwbfBitmap, InvList, -) where - -import Graphics.Rendering.OpenGL - -type WindowConfig = ((Int,Int),(Int,Int),String) -- position, size and name of the window -type Point2D = (GLdouble,GLdouble) -- a bidimensional point in space -type ColorList3 = [(GLubyte, GLubyte, GLubyte)] -- color in RGB format -type AwbfBitmap = (GLsizei, GLsizei, PixelData GLubyte) -- width, height and data of bitmap -type InvList = Maybe [(Int,Int,Int)] -- invisible colors (in RGB) of bitmap diff --git a/Graphics/UI/FunGEn/UserInput.hs b/Graphics/UI/FunGEn/UserInput.hs deleted file mode 100644 --- a/Graphics/UI/FunGEn/UserInput.hs +++ /dev/null @@ -1,82 +0,0 @@ -{- - GLUT-based keyboard/mouse handling - Sven Panne 2000. mailto:Sven.Panne@informatik.uni-muenchen.de --} - -module Graphics.UI.FunGEn.UserInput ( - Key(..), KeyEvent(..), KeyBinder, StillDownHandler, initUserInput -) where - -import Data.IORef(IORef, newIORef, readIORef, modifyIORef) -import List(delete) -import Graphics.UI.GLUT - ---------------------------------------------------------------------------- - -data KeyEvent = Press | StillDown | Release deriving Eq - ---------------------------------------------------------------------------- - -type KeyTable = IORef [Key] - -newKeyTable :: IO KeyTable -newKeyTable = newIORef [] - -getKeys :: KeyTable -> IO [Key] -getKeys = readIORef - -insertIntoKeyTable :: KeyTable -> Key -> IO () -insertIntoKeyTable keyTab key = modifyIORef keyTab (key:) - -deleteFromKeyTable :: KeyTable -> Key -> IO () -deleteFromKeyTable keyTab key = modifyIORef keyTab (delete key) - ---------------------------------------------------------------------------- - -type KeyBinder = Key -> KeyEvent -> Maybe (IO ()) -> IO () - --- TODO: Improve type -type BindingTable = IORef [((Key,KeyEvent), IO ())] - -newBindingTable :: IO BindingTable -newBindingTable = newIORef [] - -bindKey :: BindingTable -> KeyBinder -bindKey bindingTable key event Nothing = - modifyIORef bindingTable (\t -> [ e | e@(b,a) <- 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 -> IO () -execAction bindingTable key event = - readIORef bindingTable >>= (maybe (return ()) id . lookup (key, event)) - ---------------------------------------------------------------------------- - -type StillDownHandler = IO () - -stillDown :: BindingTable -> KeyTable -> StillDownHandler -stillDown bindingTable pressedKeys = - getKeys pressedKeys >>= mapM_ (\k -> execAction bindingTable k StillDown) - ---------------------------------------------------------------------------- - -initUserInput :: IO (KeyBinder, StillDownHandler) -initUserInput = do - -- Using "setKeyRepeat KeyRepeatOff" would be a little bit more - -- efficient, but has two disadvantages: It is not yet implemented - -- for M$ and it changes the global state of X11. - globalKeyRepeat $= GlobalKeyRepeatOff - bindingTable <- newBindingTable - pressedKeys <- newKeyTable - let keyPress k = do insertIntoKeyTable pressedKeys k - execAction bindingTable k Press - keyRelease k = do deleteFromKeyTable pressedKeys k - execAction bindingTable k Release - keyboardMouse k Down _ _ = keyPress k - keyboardMouse k Up _ _ = keyRelease k - keyboardMouseCallback $= Just keyboardMouse - return (bindKey bindingTable, stillDown bindingTable pressedKeys) - - diff --git a/Graphics/UI/Fungen.hs b/Graphics/UI/Fungen.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen.hs @@ -0,0 +1,39 @@ +{- | This is the main module of FunGEN - Functional Game Engine. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen ( + module Graphics.UI.Fungen.Types, + module Graphics.UI.Fungen.Util, + module Graphics.UI.Fungen.Loader, + module Graphics.UI.Fungen.Objects, + module Graphics.UI.Fungen.Map, + module Graphics.UI.Fungen.Game, + module Graphics.UI.Fungen.Display, + module Graphics.UI.Fungen.Input, + module Graphics.UI.Fungen.Timer, + module Graphics.UI.Fungen.Text, + module Graphics.UI.Fungen.Init +) 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 diff --git a/Graphics/UI/Fungen/Display.hs b/Graphics/UI/Fungen/Display.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Display.hs @@ -0,0 +1,41 @@ +{- | This FunGEn module renders the game window. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Display ( + display +) where + +import Graphics.UI.Fungen.Game +import Graphics.UI.Fungen.Util (when) +import Graphics.Rendering.OpenGL +import Graphics.UI.GLUT + +-- | Given a fungen Game and IOGame, generate an opengl display handler. +display :: Game t s u v -> IOGame t s u v () -> DisplayCallback +display g gameCycle = do + clear [ColorBuffer] + runIOGame (displayIOGame gameCycle) g + swapBuffers + flush + +-- | Run one update and display an IOGame. +displayIOGame :: IOGame t s u v () -> IOGame t s u v () +displayIOGame gameCycle = do + (_,_,objectsMoving) <- getGameFlags + when objectsMoving moveAllObjects + gameCycle + (mapDrawing,objectsDrawing,_) <- getGameFlags + when mapDrawing drawMap + when objectsDrawing drawAllObjects + printText diff --git a/Graphics/UI/Fungen/Game.hs b/Graphics/UI/Fungen/Game.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Game.hs @@ -0,0 +1,741 @@ +{- | +This FunGEn module contains some important game routines. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + + +module Graphics.UI.Fungen.Game ( + Game, IOGame, runIOGame, runIOGameM, liftIOtoIOGame, liftIOtoIOGame', + getGameState, setGameState, + getGameFlags, setGameFlags, + enableGameFlags, disableGameFlags, + enableMapDrawing, disableMapDrawing, + enableObjectsDrawing, disableObjectsDrawing, + enableObjectsMoving, disableObjectsMoving, + getObjectManagers, setObjectManagers, + getGameAttribute, setGameAttribute, + createGame, funExit, + drawMap, clearScreen, getTileFromIndex, getTileFromWindowPosition, setCurrentMapIndex, + 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, + objectsCollision, objectsFutureCollision, + objectListObjectCollision, objectListObjectFutureCollision, + objectTopMapCollision, objectBottomMapCollision, objectRightMapCollision, objectLeftMapCollision, + pointsObjectCollision, pointsObjectListCollision, + objectTopMapFutureCollision, objectBottomMapFutureCollision, objectRightMapFutureCollision, objectLeftMapFutureCollision, + printOnPrompt, printOnScreen, printText, randomFloat, randomInt, randomDouble, + 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.Rendering.OpenGL.GLU +import Graphics.UI.GLUT +import Control.Monad +import System.Exit +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 +-- +-- A game consists of: +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 + } + +-- | A game action has the type @IOGame t s u v a@, where t, s, u and v +-- are as for Game and a is the type returned by each action of the game +-- (such as the Int for "IO Int"). 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 Monad (IOGame t s u v) where + (>>=) = bindST + return = unitST + +runIOGame :: IOGame t s u v a -> Game t s u v -> IO (Game t s u v,a) -- (a,Game t s u v) the state tuple +runIOGame (IOG f) g = f g + +runIOGameM :: IOGame t s u v a -> Game t s u v -> IO () +runIOGameM x g = runIOGame x g >> return () + +liftIOtoIOGame :: IO a -> IOGame t s u v a +liftIOtoIOGame p = + IOG $ \s -> (do y <- p + return (s,y)) + +liftIOtoIOGame' :: (a -> IO ()) -> a -> IOGame t s u v () +liftIOtoIOGame' p q = + IOG $ \s -> (do p q + return (s,())) + +---------------------------------- +-- get & set routines +---------------------------------- + +getMap :: IOGame t s u v (GameMap v) +getMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> if (isMultiMap gm) + then (return (game,getCurrentMap gm)) + else (return (game,gm)) )) + +getRealMap :: IOGame t s u v (GameMap v) +getRealMap = IOG ( \game -> (readIORef (gameMap game) >>= \gm -> (return (game,gm)) )) + +setRealMap :: GameMap v -> IOGame t s u v () +setRealMap m = IOG ( \game -> (writeIORef (gameMap game) m >> return (game,()) )) + + +getGameState :: IOGame t s u v u +getGameState = IOG ( \game -> (readIORef (gameState game) >>= \gs -> return (game,gs) )) + +setGameState :: u -> IOGame t s u v () +setGameState s = IOG ( \game -> (writeIORef (gameState game) s >> return (game,()) )) + +getTextList :: IOGame t s u v [Text] +getTextList = IOG ( \game -> (readIORef (textList game) >>= \tl -> return (game,tl) )) + +setTextList :: [Text] -> IOGame t s u v () +setTextList t = IOG ( \game -> (writeIORef (textList game) t >> return (game,()) )) + +getGameFlags :: IOGame t s u v GameFlags +getGameFlags = IOG ( \game -> (readIORef (gameFlags game) >>= \gf -> return (game,gf) )) + +setGameFlags :: GameFlags -> IOGame t s u v () +setGameFlags f = IOG ( \game -> (writeIORef (gameFlags game) f >> return (game,()) )) + +getObjectManagers :: IOGame t s u v [(ObjectManager s)] +getObjectManagers = IOG ( \game -> (readIORef (objManagers game) >>= \om -> return (game,om) )) + +setObjectManagers :: [(ObjectManager s)] -> IOGame t s u v () +setObjectManagers o = IOG ( \game -> (writeIORef (objManagers game) o >> return (game,()) )) + +getQuadric :: IOGame t s u v QuadricPrimitive +getQuadric = IOG ( \game -> return (game,quadricObj game) ) + +getPictureList :: IOGame t s u v [TextureObject] +getPictureList = IOG ( \game -> (readIORef (pictureList game) >>= \pl -> return (game,pl) )) + +getWindowConfig :: IOGame t s u v WindowConfig +getWindowConfig = IOG ( \game -> (readIORef (windowConfig game) >>= \wc -> return (game,wc) )) + +getGameAttribute :: IOGame t s u v t +getGameAttribute = IOG ( \game -> (readIORef (gameAttribute game) >>= \ga -> return (game,ga) )) + +setGameAttribute :: t -> IOGame t s u v () +setGameAttribute ga = IOG ( \game -> (writeIORef (gameAttribute game) ga >> return (game,()) )) + +-- internal use only +getFpsInfo :: IOGame t s u v (Int,Int,Float) +getFpsInfo = IOG ( \game -> (readIORef (fpsInfo game) >>= \fpsi -> return (game,fpsi) )) + +-- internal use only +setFpsInfo :: (Int,Int,Float) -> IOGame t s u v () +setFpsInfo f = IOG ( \game -> (writeIORef (fpsInfo game) f >> return (game,()) )) + +---------------------------------- +-- initialization of the game +---------------------------------- +createGame :: GameMap v -> [(ObjectManager s)] -> WindowConfig -> u -> t -> FilePictureList -> IO (Game t s u v) +createGame gMap objectManagers winConf gState gAttrib filePicList = do + gM <- newIORef gMap + gS <- newIORef gState + gF <- newIORef (True,True,True) + gO <- newIORef objectManagers + gT <- newIORef [] + let gQ = Sphere 0 0 0 + gW <- newIORef winConf + gA <- newIORef gAttrib + picList <- loadPictures filePicList + gP <- newIORef picList + gFPS <- newIORef (0,0,0.0) + return (Game { + gameMap = gM, + gameState = gS, + gameFlags = gF, + objManagers = gO, + textList = gT, + quadricObj = gQ, + windowConfig = gW, + gameAttribute = gA, + pictureList = gP, + fpsInfo = gFPS + }) + +-- loads all of the pictures used in the game +loadPictures :: [(FilePath,InvList)] -> IO [TextureObject] +loadPictures pathsAndInvLists = do + bmps <- loadBitmapList (map pathAndInv2color3List pathsAndInvLists) + texBmList <- genObjectNames (length bmps) + texStuff texBmList bmps + return texBmList + +--------------------------------- +-- ending the game +--------------------------------- +funExit :: IOGame t s u v () +funExit = liftIOtoIOGame' exitWith ExitSuccess + +---------------------------------- +-- 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 + +wait :: Int -> IOGame t s u v () +wait delay = do + printText -- force text messages to be printed (is not working properly!) + (framei,timebasei,fps) <- getFpsInfo + setFpsInfo (framei,(timebasei + delay),fps) -- helps FPS info to be displayed correctly (if requested) + startTime <- getElapsedTime + + waitAux delay startTime + +waitAux :: Int -> Int -> IOGame t s u v () +waitAux delay startTime = do + presentTime <- getElapsedTime + if (presentTime - startTime > delay) + then return () + else waitAux delay startTime + diff --git a/Graphics/UI/Fungen/Init.hs b/Graphics/UI/Fungen/Init.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Init.hs @@ -0,0 +1,55 @@ +{- | +This FunGEn module contains the initialization procedures. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Init ( + funInit +)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 + +funInit :: WindowConfig -> GameMap v -> [(ObjectManager s)] -> u -> t -> [InputConfig t s u v] -> IOGame t s u v () -> RefreshType -> FilePictureList -> 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) <- funBinding 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 diff --git a/Graphics/UI/Fungen/Input.hs b/Graphics/UI/Fungen/Input.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Input.hs @@ -0,0 +1,35 @@ +{- | +This FunGEn module controls the user input (mouse, keyboard, joystick...) +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Input ( + InputConfig, + Key(..), KeyEvent(..), SpecialKey(..), MouseButton(..), + funBinding +) where + +import Graphics.UI.Fungen.Game +import Graphics.UI.Fungen.UserInput +import Graphics.UI.GLUT + +type InputConfig t s u v = (Key,KeyEvent,IOGame t s u v ()) + +funBinding :: [InputConfig t s u v] -> Game t s u v -> IO (KeyBinder, StillDownHandler) +funBinding inputs g = do + (bindKey, stillDown) <- initUserInput + mapM (userBinding g bindKey) inputs + return (bindKey, stillDown) + +userBinding :: Game t s u v -> KeyBinder -> InputConfig t s u v -> IO () +userBinding g bindKey (key,keyEvent,gameAction) = bindKey key keyEvent (Just (runIOGameM gameAction g)) diff --git a/Graphics/UI/Fungen/Loader.hs b/Graphics/UI/Fungen/Loader.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Loader.hs @@ -0,0 +1,82 @@ +{- | +This FunGEn module loads [bmp] files. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Loader ( + loadBitmap, loadBitmapList, FilePictureList +)where + +import Graphics.Rendering.OpenGL +import System.IO +import Foreign +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util +import Graphics.UI.Fungen.Types(ColorList3, AwbfBitmap) + +binAux :: String +binAux = "000000000000000000000000" + +type BmpList = [(GLubyte, GLubyte, GLubyte, GLubyte)] +type FilePictureList = [(FilePath,InvList)] + +--loads a bitmap from a file +loadBitmap :: FilePath -> Maybe ColorList3 -> IO AwbfBitmap +loadBitmap bmName invList = do + bmFile <- openBinaryFile bmName (ReadMode) + bmString <- hGetContents bmFile + (bmW,bmH) <- getWH (dropGLsizei 18 bmString) + bmData <- getBmData (dropGLsizei 54 bmString) (bmW,bmH) invList + hClose bmFile + return (bmW,bmH,bmData) + + -- loads n bitmaps from n files +loadBitmapList :: [(FilePath, Maybe ColorList3)] -> IO [AwbfBitmap] +loadBitmapList bmps = do + bmList <- loadBmListAux bmps [] + return (reverse bmList) + +loadBmListAux :: [(FilePath, Maybe ColorList3)] -> [AwbfBitmap] -> IO [AwbfBitmap] +loadBmListAux [] bmList = return (bmList) +loadBmListAux ((n,l):as) bmList = do + bm <- loadBitmap n l + loadBmListAux as (bm:bmList) + +getWH :: String -> IO (GLsizei,GLsizei) +getWH (a:b:c:d:e:f:g:h:_) = do + return ( (op (bin a) 0) + (op (bin b) 8) + (op (bin c) 16) + (op (bin d) 24), + (op (bin e) 0) + (op (bin f) 8) + (op (bin g) 16) + (op (bin h) 24)) + where bin x = toBinary(fromEnum x) + op x n = toDecimal(shiftLeft(binAux ++ (make0 (8 - (length x)) ++ x)) n) +getWH _ = error "Loader.getWH error: strange bitmap file" + +getBmData :: String -> (GLsizei,GLsizei) -> Maybe ColorList3 -> IO (PixelData GLubyte) +getBmData bmString (bmW,bmH) invList = + let colorList = makeColorList bmString (bmW,bmH) in + newArray [Color4 r g b a | (r,g,b,a) <- addInvisiblity colorList invList] >>= \bmData -> + return (PixelData RGBA UnsignedByte (castPtr bmData)) + +addInvisiblity :: ColorList3 -> Maybe ColorList3 -> BmpList +addInvisiblity [] _ = [] +addInvisiblity l Nothing = map (\(r,g,b) -> (r,g,b,255)) l +addInvisiblity ((r,g,b):as) i@(Just invList) | (r,g,b) `elem` invList = ((r,g,b,0):(addInvisiblity as i)) + | otherwise = ((r,g,b,255):(addInvisiblity as i)) + +makeColorList :: String -> (GLsizei,GLsizei) -> [(GLubyte, GLubyte, GLubyte)] +makeColorList bmString (bmW,bmH) = makeColorListAux (bmW `mod` 4) bmString (bmW*bmH) (bmW,bmW) + +makeColorListAux :: GLsizei -> String -> GLsizei -> (GLsizei,GLsizei) -> [(GLubyte, GLubyte, GLubyte)] +makeColorListAux _ _ 0 _ = [] +makeColorListAux x bmString totVert (0,bmW) = makeColorListAux x (dropGLsizei x bmString) totVert (bmW,bmW) +makeColorListAux x (b:g:r:bmString) totVert (n,bmW) = (ord2 r,ord2 g,ord2 b): (makeColorListAux x bmString (totVert - 1) (n - 1,bmW)) +makeColorListAux _ _ _ _ = error "Loader.makeColorListAux error: strange bitmap file" diff --git a/Graphics/UI/Fungen/Map.hs b/Graphics/UI/Fungen/Map.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Map.hs @@ -0,0 +1,233 @@ +{- | +This FunGEn module contains the map (game background) routines. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Map ( + GameMap, + Tile, TileMatrix, + getTilePictureIndex, getTileBlocked, getTileMoveCost, getTileSpecialAttribute, + colorMap, textureMap, tileMap, multiMap, + getMapSize, + isTileMap, getTileMapTileMatrix, getTileMapScroll, getTileMapSize, getTileMapTileSize, + getCurrentMap, updateCurrentMap, updateCurrentIndex, isMultiMap, + 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)] + +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 + +-- cheks 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 ROUTINES -- +---------------------------------------- +clearGameScreen :: GLclampf -> GLclampf -> GLclampf -> IO () +clearGameScreen r g b = do + clearColor $= (Color4 r g b 1.0) + clear [ColorBuffer] + +-- draws the background map +drawGameMap :: GameMap t -> Point2D -> [TextureObject] -> IO () +drawGameMap (ColorMap c _) _ _ = do + clearColor $= c + clear [ColorBuffer] + clearColor $= (Color4 0 0 0 0) -- performance drawback? +drawGameMap (TextureMap texId (tX,tY) (vX,vY) _ _) winSize texList = do + texture Texture2D $= Enabled + bindTexture Texture2D (texList !! texId) + drawTextureMap (tX,tY) (new_winX, new_winY) winSize new_winY texList + texture Texture2D $= Disabled + where new_winX | (vX >= 0) = - vX + | otherwise = - vX - tX + new_winY | (vY >= 0) = - vY + | otherwise = - vY - tY +drawGameMap (TileMap matrix size visible _ _) winSize texList = do + texture Texture2D $= Enabled + drawTileMap (reverse matrix) size visible winSize 0.0 texList + texture Texture2D $= Disabled +drawGameMap (MultiMap _ _) _ _ = error "Map.drawGameMap error: drawGameMap cannot be applied with MultiMaps!" + +-- size of texture, drawing position relative to (X,Y) axis of window, lowest Y drawing position +drawTextureMap :: Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTextureMap (tX,tY) (winX,winY) (winWidth,winHeight) baseY texList + | (winY > winHeight) = drawTextureMap (tX,tY) (winX + tX, baseY) (winWidth,winHeight) baseY texList + | (winX > winWidth) = return () + | otherwise = do + loadIdentity + translate (Vector3 winX winY (0 :: GLdouble) ) + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + renderPrimitive Quads $ do + texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) + texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) + drawTextureMap (tX,tY) (winX,winY + tY) (winWidth,winHeight) baseY texList + +-- textures handles, tile matrix, size of texture, (X,Y) scroll, drawing position relative to Y axis of window +drawTileMap :: TileMatrix t -> Point2D -> Point2D -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTileMap [] _ _ _ _ _ = return () -- no more tile lines to drawn, so we're done here! +drawTileMap (a:as) (tX,tY) (sX,sY) (winWidth,winHeight) winY texList + | (sY >= tY) = drawTileMap as (tX,tY) (sX,sY-tY) (winWidth,winHeight) winY texList -- scrolls in the Y axis + | (winY > winHeight) = return () -- drawing position is higher than the Y window coordinate + | otherwise = do + drawTileMapLine a (tX,tY) sX (0.0,winY-sY) winWidth texList + drawTileMap as (tX,tY) (sX,sY) (winWidth,winHeight) (winY - sY + tY) texList + +-- textures handles, tile line, size of texture, X scroll, drawing position relative to (X,Y) axis of window +drawTileMapLine :: TileLine t -> Point2D -> GLdouble -> Point2D -> GLdouble -> [TextureObject] -> IO () +drawTileMapLine [] _ _ _ _ _ = return () -- no more tiles to drawn, so we're done here! +drawTileMapLine (a:as) (tX,tY) sX (winX,winY) winWidth texList + | (sX >= tX) = drawTileMapLine as (tX,tY) (sX-tX) (winX,winY) winWidth texList -- scrolls in the X axis + | (winX > winWidth) = return () -- drawing position is higher than the X window coordinate + | otherwise = do + bindTexture Texture2D (texList !! (getTilePictureIndex a)) + loadIdentity + translate (Vector3 (new_winX) winY (0 :: GLdouble) ) + color (Color3 1.0 1.0 1.0 :: Color3 GLfloat) + renderPrimitive Quads $ do + texCoord $ TexCoord2 0.0 (0.0 :: GLdouble); vertex $ Vertex3 0.0 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (0.0 :: GLdouble); vertex $ Vertex3 tX 0.0 (0.0 :: GLdouble) + texCoord $ TexCoord2 1.0 (1.0 :: GLdouble); vertex $ Vertex3 tX tY (0.0 :: GLdouble) + texCoord $ TexCoord2 0.0 (1.0 :: GLdouble); vertex $ Vertex3 0.0 tY (0.0 :: GLdouble) + drawTileMapLine as (tX,tY) sX (new_winX + sX + tX,winY) winWidth texList + where new_winX | (sX >= 0) = winX + sX + | otherwise = winX + sX diff --git a/Graphics/UI/Fungen/Objects.hs b/Graphics/UI/Fungen/Objects.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Objects.hs @@ -0,0 +1,327 @@ +{- | +This module contains the FunGEn objects procedures +-} +{- +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Objects ( + GameObject, + getGameObjectId, getGameObjectName, getGameObjectManagerName, getGameObjectAsleep, getGameObjectPosition, getGameObjectSize, getGameObjectSpeed, getGameObjectAttribute, + getObjectManagerName, getObjectManagerCounter , getObjectManagerObjects, + ObjectPicture(..), Primitive(..), + FillMode (..), + object, drawGameObjects, drawGameObject, + objectGroup, ObjectManager, + findObjectFromId, searchObjectManager, searchGameObject, + updateObject, updateObjectAsleep, updateObjectSize, updateObjectPosition, + updateObjectSpeed, updateObjectAttribute, updateObjectPicture, + addObjectsToManager, + moveGameObjects, + destroyGameObject +) where + +import Graphics.UI.Fungen.Types +import Graphics.UI.Fungen.Util +import Graphics.Rendering.OpenGL hiding (Primitive) +import Graphics.UI.GLUT hiding (Primitive) + +data GameObject t = GO { + objId :: Integer, + objName :: String, + objManagerName :: String, + objPicture :: GameObjectPicture, + objAsleep :: Bool, + objSize :: Point2D, + objPosition :: Point2D, + objSpeed :: Point2D, + objAttribute :: t + } + +data ObjectManager t = OM { + mngName :: String, -- name of the manager + mngCounter :: Integer, -- next current avaible index for a new object + mngObjects :: [(GameObject t)] -- the SET of objects + } + +data GamePrimitive + = P [Vertex3 GLdouble] (Color4 GLfloat) FillMode + | C GLdouble (Color4 GLfloat) FillMode + +data GameObjectPicture + = Tx Int + | B GamePrimitive +-- | A [TextureObject] Int -- miliseconds between frames + +data Primitive + = Polyg [Point2D] GLfloat GLfloat GLfloat FillMode -- the points (must be in CCW order!), color, fill mode + | Circle GLdouble GLfloat GLfloat GLfloat FillMode -- color, radius, fill mode + +data ObjectPicture + = Tex (GLdouble,GLdouble) Int -- size, current texture + | Basic Primitive +-- | Animation [(FilePath,InvList)] Int -- (path to file, invisible colors), miliseconds between frames + +data FillMode + = Filled + | Unfilled + deriving Eq + +------------------------------------------- +-- get & updating routines for GameObjects +------------------------------------------- +getGameObjectId :: GameObject t -> Integer +getGameObjectId = objId + +getGameObjectName :: GameObject t -> String +getGameObjectName = objName + +getGameObjectManagerName :: GameObject t -> String +getGameObjectManagerName = objManagerName + +-- internal use only! +getGameObjectPicture :: GameObject t -> GameObjectPicture +getGameObjectPicture = objPicture + +getGameObjectAsleep :: GameObject t -> Bool +getGameObjectAsleep = objAsleep + +getGameObjectSize :: GameObject t -> (GLdouble,GLdouble) +getGameObjectSize o = (realToFrac sX,realToFrac sY) + where (sX,sY) = objSize o + +getGameObjectPosition :: GameObject t -> (GLdouble,GLdouble) +getGameObjectPosition o = (realToFrac pX,realToFrac pY) + where (pX,pY) = objPosition o + +getGameObjectSpeed :: GameObject t -> (GLdouble,GLdouble) +getGameObjectSpeed o = (realToFrac sX,realToFrac sY) + where (sX,sY) = objSpeed o + +getGameObjectAttribute :: GameObject t -> t +getGameObjectAttribute = objAttribute + +updateObjectPicture :: Int -> Int -> GameObject t -> GameObject t +updateObjectPicture newIndex maxIndex obj = + case (getGameObjectPicture obj) of + Tx _ -> if (newIndex <= maxIndex) + then (obj {objPicture = Tx newIndex}) + else (error ("Objects.updateObjectPicture error: picture index out of range for object " ++ + (getGameObjectName obj) ++ " of group " ++ (getGameObjectManagerName obj))) + _ -> error ("Objects.updateObjectPicture error: object " ++ (getGameObjectName obj) ++ + " of group " ++ (getGameObjectManagerName obj) ++ " is not a textured object!") + +updateObjectAsleep :: Bool -> GameObject t -> GameObject t +updateObjectAsleep asleep o = o {objAsleep = asleep} + +updateObjectSize :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectSize (sX,sY) o = o {objSize = (realToFrac sX, realToFrac sY)} + +updateObjectPosition :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectPosition (pX,pY) o = o {objPosition = (realToFrac pX, realToFrac pY)} + +updateObjectSpeed :: (GLdouble,GLdouble) -> GameObject t -> GameObject t +updateObjectSpeed (sX,sY) o = o {objSpeed = (realToFrac sX, realToFrac sY)} + +updateObjectAttribute :: t -> GameObject t -> GameObject t +updateObjectAttribute oAttrib o = o {objAttribute = oAttrib} + +---------------------------------------------- +-- get & updating routines for ObjectManagers +---------------------------------------------- +getObjectManagerName :: ObjectManager t -> String +getObjectManagerName = mngName + +getObjectManagerCounter :: ObjectManager t -> Integer +getObjectManagerCounter = mngCounter + +getObjectManagerObjects :: ObjectManager t -> [(GameObject t)] +getObjectManagerObjects = mngObjects + +updateObjectManagerObjects :: [(GameObject t)] -> ObjectManager t -> ObjectManager t +updateObjectManagerObjects objs mng = mng {mngObjects = objs} + +---------------------------------------- +-- initialization of GameObjects +---------------------------------------- +object :: String -> ObjectPicture -> Bool -> (GLdouble,GLdouble) -> (GLdouble,GLdouble) -> t -> GameObject t +object name pic asleep pos speed oAttrib = let (picture, size) = createPicture pic in + GO { + objId = 0, + objName = name, + objManagerName = "object not grouped yet!", + objPicture = picture, + objAsleep = asleep, + objSize = size, + objPosition = pos, + objSpeed = speed, + objAttribute = oAttrib + } + +createPicture :: ObjectPicture -> (GameObjectPicture,Point2D) +createPicture (Basic (Polyg points r g b fillMode)) = (B (P (point2DtoVertex3 points) (Color4 r g b 1.0) fillMode),findSize points) +createPicture (Basic (Circle radius r g b fillMode)) = (B (C radius (Color4 r g b 1.0) fillMode),(2 * radius,2 * radius)) +createPicture (Tex size picIndex) = (Tx picIndex,size) + +-- given a point list, finds the height and width +findSize :: [Point2D] -> Point2D +findSize l = ((x2 - x1),(y2 - y1)) + where (xList,yList) = unzip l + (x2,y2) = (maximum xList,maximum yList) + (x1,y1) = (minimum xList,minimum yList) + +---------------------------------------------- +-- grouping GameObjects and creating managers +---------------------------------------------- +objectGroup :: String -> [(GameObject t)] -> (ObjectManager t) +objectGroup name objs = OM {mngName = name, mngCounter = toEnum (length objs), mngObjects = objectGroupAux objs name 0} + +objectGroupAux :: [(GameObject t)] -> String -> Integer -> [(GameObject t)] +objectGroupAux [] _ _ = [] +objectGroupAux (o:os) managerName oId = (o {objId = oId, objManagerName = managerName}):(objectGroupAux os managerName (oId + 1)) + +addObjectsToManager :: [(GameObject t)] -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +addObjectsToManager _ managerName [] = error ("Objects.addObjectsToManager error: object manager " ++ managerName ++ " does not exists!") +addObjectsToManager objs managerName (m:ms) | (getObjectManagerName m == managerName) = (addObjectsToManagerAux objs m):ms + | otherwise = m:(addObjectsToManager objs managerName ms) + + +addObjectsToManagerAux :: [(GameObject t)] -> ObjectManager t -> ObjectManager t +addObjectsToManagerAux objs mng = let counter = getObjectManagerCounter mng + newObjects = adjustNewObjects objs (getObjectManagerCounter mng) (getObjectManagerName mng) + in mng {mngObjects = newObjects ++ (getObjectManagerObjects mng), mngCounter = counter + (toEnum (length objs))} + +adjustNewObjects :: [(GameObject t)] -> Integer -> String -> [(GameObject t)] +adjustNewObjects [] _ _ = [] +adjustNewObjects (o:os) oId managerName = (o {objId = oId, objManagerName = managerName}):(adjustNewObjects os (oId + 1) managerName) + +------------------------------------------ +-- draw routines +------------------------------------------ +drawGameObjects :: [(ObjectManager t)] -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObjects [] _ _ = return () +drawGameObjects (m:ms) qobj picList = drawGameObjectList (getObjectManagerObjects m) qobj picList >> drawGameObjects ms qobj picList + +drawGameObjectList :: [(GameObject t)] -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObjectList [] _ _ = return () +drawGameObjectList (o:os) qobj picList | (getGameObjectAsleep o) = drawGameObjectList os qobj picList + | otherwise = drawGameObject o qobj picList >> drawGameObjectList os qobj picList + +drawGameObject :: GameObject t -> QuadricPrimitive -> [TextureObject] -> IO () +drawGameObject o qobj picList = do + loadIdentity + let (pX,pY) = getGameObjectPosition o + picture = getGameObjectPicture o + translate (Vector3 pX pY (0 :: GLdouble) ) + case picture of + (B (P points c fillMode)) -> do + color c + if (fillMode == Filled) + then (renderPrimitive Polygon $ mapM_ vertex points) + else (renderPrimitive LineLoop $ mapM_ vertex points) + + (B (C r c fillMode)) -> do + color c + renderQuadric style $ Disk 0 r 20 3 + where style = QuadricStyle Nothing NoTextureCoordinates Outside fillStyle + fillStyle = if (fillMode == Filled) then FillStyle else SilhouetteStyle + + (Tx picIndex) -> do + texture Texture2D $= Enabled + bindTexture Texture2D (picList !! picIndex) + color (Color4 1.0 1.0 1.0 (1.0 :: GLfloat)) + renderPrimitive Quads $ do + texCoord2 0.0 0.0; vertex3 (-x) (-y) 0.0 + texCoord2 1.0 0.0; vertex3 x (-y) 0.0 + texCoord2 1.0 1.0; vertex3 x y 0.0 + texCoord2 0.0 1.0; vertex3 (-x) y 0.0 + texture Texture2D $= Disabled + where (sX,sY) = getGameObjectSize o + x = sX/2 + y = sY/2 + +------------------------------------------ +-- search routines +------------------------------------------ + +findObjectFromId :: GameObject t -> [(ObjectManager t)] -> GameObject t +findObjectFromId o mngs = findObjectFromIdAux (getGameObjectId o) (getGameObjectManagerName o) mngs + +findObjectFromIdAux :: Integer -> String -> [(ObjectManager t)] -> GameObject t +findObjectFromIdAux _ managerName [] = error ("Objects.findObjectFromIdAux error: object group " ++ managerName ++ " not found!") +findObjectFromIdAux objectId managerName (m:ms) | (managerName == getObjectManagerName m) = searchFromId objectId (getObjectManagerObjects m) + | otherwise = findObjectFromIdAux objectId managerName ms + +searchFromId :: Integer -> [(GameObject t)] -> GameObject t +searchFromId _ [] = error ("Objects.searchFromId error: object not found!") +searchFromId objectId (o:os) | (objectId == getGameObjectId o) = o + | otherwise = searchFromId objectId os + + +searchObjectManager :: String -> [(ObjectManager t)] -> ObjectManager t +searchObjectManager managerName [] = error ("Objects.searchObjectManager error: object group " ++ managerName ++ " not found!") +searchObjectManager managerName (m:ms) | (getObjectManagerName m == managerName) = m + | otherwise = searchObjectManager managerName ms + +searchGameObject :: String -> ObjectManager t -> GameObject t +searchGameObject objectName m = searchGameObjectAux objectName (getObjectManagerObjects m) + +searchGameObjectAux :: String -> [(GameObject t)] -> GameObject t +searchGameObjectAux objectName [] = error ("Objects.searchGameObjectAux error: object " ++ objectName ++ " not found!") +searchGameObjectAux objectName (a:as) | (getGameObjectName a == objectName) = a + | otherwise = searchGameObjectAux objectName as + +------------------------------------------ +-- update routines +------------------------------------------ + +-- substitutes an old object by a new one, given the function to be applied to the old object (whose id is given), +-- the name of its manager and the group of game managers. +updateObject :: (GameObject t -> GameObject t) -> Integer -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +updateObject _ _ managerName [] = error ("Objects.updateObject error: object manager: " ++ managerName ++ " not found!") +updateObject f objectId managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms + | otherwise = m:(updateObject f objectId managerName ms) + where newObjects = updateObjectAux f objectId (getObjectManagerObjects m) + +updateObjectAux :: (GameObject t -> GameObject t) -> Integer -> [(GameObject t)] -> [(GameObject t)] +updateObjectAux _ _ [] = error ("Objects.updateObjectAux error: object not found!") +updateObjectAux f objectId (o:os) | (getGameObjectId o == objectId) = (f o):os + | otherwise = o:(updateObjectAux f objectId os) + +------------------------------------------ +-- moving routines +------------------------------------------ + +-- modifies all objects position according to their speed +moveGameObjects :: [(ObjectManager t)] -> [(ObjectManager t)] +moveGameObjects [] = [] +moveGameObjects (m:ms) = (updateObjectManagerObjects (map moveSingleObject (getObjectManagerObjects m)) m):(moveGameObjects ms) + +moveSingleObject :: GameObject t -> GameObject t +moveSingleObject o = if (getGameObjectAsleep o) + then o + else let (vX,vY) = getGameObjectSpeed o + (pX,pY) = getGameObjectPosition o + in updateObjectPosition (pX + vX, pY + vY) o + +------------------------------------------ +-- destroy routines +------------------------------------------ + +destroyGameObject :: String -> String -> [(ObjectManager t)] -> [(ObjectManager t)] +destroyGameObject _ managerName [] = error ("Objects.destroyGameObject error: object manager: " ++ managerName ++ " not found!") +destroyGameObject objectName managerName (m:ms) | (getObjectManagerName m == managerName) = (updateObjectManagerObjects newObjects m):ms + | otherwise = m:(destroyGameObject objectName managerName ms) + where newObjects = destroyGameObjectAux objectName (getObjectManagerObjects m) + +destroyGameObjectAux :: String -> [(GameObject t)] -> [(GameObject t)] +destroyGameObjectAux objectName [] = error ("Objects.destroyGameObjectAux error: object: " ++ objectName ++ " not found!") +destroyGameObjectAux objectName (o:os) | (getGameObjectName o == objectName) = os + | otherwise = o:(destroyGameObjectAux objectName os) diff --git a/Graphics/UI/Fungen/Text.hs b/Graphics/UI/Fungen/Text.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Text.hs @@ -0,0 +1,37 @@ +{- | +This FunGEn module contains some functions to print text on the screen. +Fonts supported: Bitmap9By15, Bitmap8By13, BitmapTimesRoman10, BitmapTimesRoman24 + BitmapHelvetica10, BitmapHelvetica12, BitmapHelvetica18 +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Text ( + Text, + BitmapFont(..), + putGameText +) where + +import Graphics.UI.GLUT +import Graphics.Rendering.OpenGL + +type Text = (String,BitmapFont,(GLdouble,GLdouble),GLclampf,GLclampf,GLclampf) + +-- string to be printed, type of font, screen position, color RGB +putGameText :: [Text] -> IO () +putGameText [] = return () +putGameText ((text,font,(x,y),r,g,b):ts) = do + loadIdentity + color (Color3 r g b) + rasterPos (Vertex2 x y) + renderString font text + putGameText ts diff --git a/Graphics/UI/Fungen/Timer.hs b/Graphics/UI/Fungen/Timer.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Timer.hs @@ -0,0 +1,36 @@ +{- | +This FunGEn module controls timing (how time-based functions will behave). +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Timer ( + RefreshType(..), + setRefresh +) where + +import Graphics.UI.Fungen.UserInput +import Graphics.UI.GLUT + +data RefreshType + = Idle + | Timer Int + +setRefresh :: RefreshType -> StillDownHandler -> IO () +setRefresh Idle stillDown = idleCallback $= Just (stillDown >> postRedisplay Nothing) +setRefresh (Timer t) stillDown = addTimerCallback t (timer stillDown t) + +timer :: StillDownHandler -> Int -> TimerCallback +timer stillDown t = do + stillDown + postRedisplay Nothing + addTimerCallback t (timer stillDown t) diff --git a/Graphics/UI/Fungen/Types.hs b/Graphics/UI/Fungen/Types.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Types.hs @@ -0,0 +1,41 @@ +{- | This FunGEn module contains the FunGEN basic types. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Types ( + WindowConfig, + Point2D, + ColorList3, + AwbfBitmap, + InvList, +) where + +import Graphics.Rendering.OpenGL + +-- | position, size and name of the window +type WindowConfig = ((Int,Int),(Int,Int),String) + +-- | a bidimensional point in space +type Point2D = (GLdouble,GLdouble) + +-- | color in RGB format +type ColorList3 = [(GLubyte, GLubyte, GLubyte)] + +-- | width, height and data of bitmap +type AwbfBitmap = (GLsizei, GLsizei, PixelData GLubyte) + +-- | invisible colors (in RGB) of bitmap +type InvList = Maybe [(Int,Int,Int)] + + + diff --git a/Graphics/UI/Fungen/UserInput.hs b/Graphics/UI/Fungen/UserInput.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/UserInput.hs @@ -0,0 +1,82 @@ +{- | + GLUT-based keyboard/mouse handling + Sven Panne 2000. mailto:Sven.Panne@informatik.uni-muenchen.de +-} + +module Graphics.UI.Fungen.UserInput ( + Key(..), KeyEvent(..), KeyBinder, StillDownHandler, initUserInput +) where + +import Data.IORef(IORef, newIORef, readIORef, modifyIORef) +import Data.List(delete) +import Graphics.UI.GLUT + +--------------------------------------------------------------------------- + +data KeyEvent = Press | StillDown | Release deriving Eq + +--------------------------------------------------------------------------- + +type KeyTable = IORef [Key] + +newKeyTable :: IO KeyTable +newKeyTable = newIORef [] + +getKeys :: KeyTable -> IO [Key] +getKeys = readIORef + +insertIntoKeyTable :: KeyTable -> Key -> IO () +insertIntoKeyTable keyTab key = modifyIORef keyTab (key:) + +deleteFromKeyTable :: KeyTable -> Key -> IO () +deleteFromKeyTable keyTab key = modifyIORef keyTab (delete key) + +--------------------------------------------------------------------------- + +type KeyBinder = Key -> KeyEvent -> Maybe (IO ()) -> IO () + +-- TODO: Improve type +type BindingTable = IORef [((Key,KeyEvent), IO ())] + +newBindingTable :: IO BindingTable +newBindingTable = newIORef [] + +bindKey :: BindingTable -> KeyBinder +bindKey bindingTable key event Nothing = + modifyIORef bindingTable (\t -> [ e | e@(b,a) <- 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 -> IO () +execAction bindingTable key event = + readIORef bindingTable >>= (maybe (return ()) id . lookup (key, event)) + +--------------------------------------------------------------------------- + +type StillDownHandler = IO () + +stillDown :: BindingTable -> KeyTable -> StillDownHandler +stillDown bindingTable pressedKeys = + getKeys pressedKeys >>= mapM_ (\k -> execAction bindingTable k StillDown) + +--------------------------------------------------------------------------- + +initUserInput :: IO (KeyBinder, StillDownHandler) +initUserInput = do + -- Using "setKeyRepeat KeyRepeatOff" would be a little bit more + -- efficient, but has two disadvantages: It is not yet implemented + -- for M$ and it changes the global state of X11. + globalKeyRepeat $= GlobalKeyRepeatOff + bindingTable <- newBindingTable + pressedKeys <- newKeyTable + let keyPress k = do insertIntoKeyTable pressedKeys k + execAction bindingTable k Press + keyRelease k = do deleteFromKeyTable pressedKeys k + execAction bindingTable k Release + keyboardMouse k Down _ _ = keyPress k + keyboardMouse k Up _ _ = keyRelease k + keyboardMouseCallback $= Just keyboardMouse + return (bindKey bindingTable, stillDown bindingTable pressedKeys) + + diff --git a/Graphics/UI/Fungen/Util.hs b/Graphics/UI/Fungen/Util.hs new file mode 100644 --- /dev/null +++ b/Graphics/UI/Fungen/Util.hs @@ -0,0 +1,153 @@ +{- | +This FunGEn module contains some auxiliary functions. +-} +{- + +FunGEN - Functional Game Engine +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2002 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Graphics.UI.Fungen.Util ( + texCoord2, vertex3, texStuff, + toRad, + randInt, randFloat, randDouble, + shiftLeft, toDecimal, pow2, toBinary, make0, dropGLsizei, + ord2, + addNoInvisibility, + racMod, + matrixToList, matrixSize, + inv2color3, pathAndInv2color3List, point2DtoVertex3, + isEmpty, + when, unless, + bindTexture +) where + +import Graphics.UI.Fungen.Types +import Graphics.Rendering.OpenGL +import System.Random + +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 :: TextureTarget -> 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 Nothing NoProxy 0 RGBA' (TextureSize2D bmW bmH) 0 bmData + textureFilter Texture2D $= ((Nearest, Nothing), Nearest) + texStuff ts bms +texStuff _ _ = return () + +toRad :: Float -> Float +toRad a = ((pi * a)/180) + +randInt :: (Int,Int) -> IO Int +randInt (a,b) = randomRIO (a,b) + +randFloat :: (Float,Float) -> IO Float +randFloat (a,b) = randomRIO (a,b) + +randDouble :: (Double,Double) -> IO Double +randDouble (a,b) = randomRIO (a,b) + +shiftLeft :: String -> Int -> String +shiftLeft a 0 = a +shiftLeft (_:as) n = shiftLeft(as ++ "0") (n-1) +shiftLeft _ _ = [] + +toDecimal :: String -> GLsizei +toDecimal a = toDecimalAux (reverse a) 32 + +toDecimalAux :: String -> GLsizei -> GLsizei +toDecimalAux [] _ = 0 +toDecimalAux _ 0 = 0 +toDecimalAux (a:as) n + | a == '0' = toDecimalAux as (n-1) + | otherwise = pow2 (32 - n) + toDecimalAux as (n-1) + +pow2 :: GLsizei -> GLsizei +pow2 0 = 1 +pow2 n = 2 * pow2(n-1) + +toBinary :: Int -> String +toBinary n + | n < 2 = show n + | otherwise = toBinary (n `div` 2) ++ (show (n `mod` 2)) + +make0 :: Int -> String +make0 0 = [] +make0 n = '0':(make0 (n-1)) + +ord2 :: Char -> GLubyte +ord2 a = (toEnum.fromEnum) a + +dropGLsizei :: GLsizei -> [a] -> [a] +dropGLsizei 0 xs = xs +dropGLsizei _ [] = [] +dropGLsizei n (_:xs) | n>0 = dropGLsizei (n-1) xs +dropGLsizei _ _ = error "Util.dropGLsizei error: negative argument" + +-- to be used when no invisibility must be added when loading a file +addNoInvisibility :: [FilePath] -> [(FilePath, Maybe ColorList3)] +addNoInvisibility [] = [] +addNoInvisibility (a:as) = (a, Nothing):(addNoInvisibility as) + +racMod :: GLdouble -> GLdouble -> GLdouble +racMod a b | (a >= 0) = racModPos a b + | otherwise = racModNeg a b + +racModPos :: GLdouble -> GLdouble -> GLdouble +racModPos a b | (a - b < 0) = a + | otherwise = racModPos (a - b) b + +racModNeg :: GLdouble -> GLdouble -> GLdouble +racModNeg a b | (a + b > 0) = a + | otherwise = racModPos (a + b) b + +matrixToList :: [[a]] -> [a] +matrixToList [] = [] +matrixToList (a:as) = a ++ (matrixToList as) + +-- return the max indexes of a matrix (assumed that its lines have the same length) +matrixSize :: [[a]] -> (Int,Int) +matrixSize [] = (0,0) +matrixSize m@(a:_) = ((length m) - 1,(length a) - 1) + +inv2color3 :: InvList -> Maybe ColorList3 +inv2color3 Nothing = Nothing +inv2color3 (Just l) = Just (inv2color3Aux l) + +inv2color3Aux :: [(Int,Int,Int)] -> [(GLubyte,GLubyte,GLubyte)] +inv2color3Aux [] = [] +inv2color3Aux ((r,g,b):ls) = (z r,z g,z b):(inv2color3Aux ls) + where z = toEnum.fromEnum + +pathAndInv2color3List :: (FilePath,InvList) -> (FilePath, Maybe ColorList3) +pathAndInv2color3List (f,Nothing) = (f,Nothing) +pathAndInv2color3List (f,Just l) = (f,Just (inv2color3Aux l)) + +point2DtoVertex3 :: [Point2D] -> [Vertex3 GLdouble] +point2DtoVertex3 [] = [] +point2DtoVertex3 ((x,y):as) = (Vertex3 x y 0.0):(point2DtoVertex3 as) + +isEmpty :: [a] -> Bool +isEmpty [] = True +isEmpty _ = False + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = when (not p) s diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright (C) 2002 Andre Furtado +Copyright (C) 2008 Miloslav Raus <666wman@gmail.com> +Copyright (C) 2008,2011 Simon Michael + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Simon Michael nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,143 @@ +# FunGEN - Functional Game Engine + +FunGEn (Functional Game Engine) is a BSD-licensed 2D platform-independent +game engine implemented in and for Haskell, using HOpenGL. It is intended +to help game programmers in the game development process, in a faster and +automated way. Actually, FunGEn supports: + +- 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 input; +- Collision detection; +- Time-based functions and pre-defined game actions; +- Loading and displaying of 24-bit bitmap files; +- Debugging and game performance evaluation facilities; +- Sound support (actually for windows platforms only... :-[ ); +- Hope to expand this list soon :-] + +This README includes most of the docs from the original site, lightly updated. +There is also a [tutorial](TUTORIAL.html). + +Original home: [http://www.cin.ufpe.br/\~haskell/fungen](http://www.cin.ufpe.br/\~haskell/fungen) + +Latest code: [http://darcsden.com/simon/fungen](http://darcsden.com/simon/fungen) + +Latest haddock: [http://joyful.com/repos/fungen/dist/doc/html/FunGEn/](http://joyful.com/repos/fungen/dist/doc/html/fungen/) + +Hackage: [http://hackage.haskell.org/package/FunGEn](http://hackage.haskell.org/package/FunGEn) + +Copyright: [LICENSE](./LICENSE) + +## History + +* Cabalised ghc 6.12-compatible 0.3 released on darcsden & hackage by Simon Michael (2011/02) + +* Cabalised ghc 6.10-compatible 0.1 released on hackage by Miloslav Raus (2008/09) + + *Tested under Win32 & Linux/Intel. Known glitches: Flickering under + linux (at least on my shitty laptop). Weird pong paddle behavior under + Win32.* + +* Repo-ised ghc 6.8-compatible update by Simon Michael (2008/02) + +* 0.1 released by Andre Furtado (2002) + + *Current Status:Some feedback indicated that the first version of + FunGEn was not as "functional" as it was desired: some game issues + were still being dealt through an imperative fashion. This way, the + authors of this project decided to change the game engine philosophy: + programmers should describe a game as a set of "specifications" rather + than defining its behavior imperatively. One plausible alternative for + accomplishing this task is porting the Clean Game Library (CGL) to + Haskell, adding some FunGEn specific features. Hence, this is the + actual status of the FunGEn project: it is being rebuilt in order to + provide game programming mechanisms following the CGL concepts. This + really demands some time, but the authors expect a new version to be + released soon.* + + *FunGEn v1.0 can be downloaded here. (PLEASE NOTE: this is the very + first version of FunGEn, and it was released just to get some feedback + from game programmers. You are strongly invited to tell your game + programming experiences with FunGEn, helping us to release a + definitive, stable version). Ok, after this disclaimer, please fell + yourself free to take a quick tour in the site; it contains a lot of + useful information for those who are really interested in trying a new + game programming experience. Nice coding...* + +## Credits + +FunGEn was created by a Computation Science graduation student, at the +Informatics Center (CIn) of the Federal University of Pernambuco (UFPE), +as part of a Scientific Iniciation (PIBIC/CNPq) research project (Creating +a Game Platform Using Haskell), oriented by lecturer Andre Santos (PhD, +1995, University of Glasgow). He was responsible for figuring out a lot of +FunGEn implementation details. + +I would like to thank also the following people who contributed for the development of FunGEn: + +- Sven Panne +- Jay Cox +- Geber Ramalho +- Carlos Andre Pessoa +- Charles Madeira +- Monique Monteiro +- The people at the Haskell mailing lists + +FunGEn can be distributed freely, 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. I would thank you if you cite my name +and this site if you are going to use FunGEn for other things besides home +programming. + +## To do + +Andre's 2002 list: + +Here you have a list of some upcoming FunGEn features, and some other +desired features (but with no implementation prevision yet). + +- Support map scrolling (coming soon); +- Support mouse input management (coming soon); +- Make a polygon map definition avaiable (coming soon); +- Make sound avaible to non-Win32 platforms; +- Create, if possible, some operators to avoid the excessive (x <- ...) syntax; +- Support auto-animated objects; +- Create a GLUT independent font support (or perhaps extend it); +- Improve the installation process; +- Upgrade FunGEn to be both a 2D (bidimensional) and 2D 1/2 (bi and a half dimensional) engine; +- Create a map editor/generator (possibly in other language, or using the brand new Haskell GUI...); +- Take courage to start thinking about the 3D world... + +Would you like to suggest a feature? Feel free to do it. Would you like to +implement a feature? Please do it! Keep in touch. + +## FAQ + +**What is a game engine?** + +A game engine can be considered as a library that provides game facilities +to a game programmer. When using a game engine, the programmer must +specify when the game events happen, rather than how they are +implemented. A same functionality may have its implementation varying from +platform to platform, in the case the engine is platform-independent. The +main advantage of a game engine is that it can be reused to the +development of many different kind of games, in an automated way, saving a +lot of programming time. + +**Why Haskell?** + +We believe that Haskell is a great language to develop games, because of +its high level of abstraction and the generation of a more concise, +elegant and shorter code. This is great for code maintenance and +understanding. Combining the power of Haskell with the facilities provided +by game engines seems a promising project. You can find more info on +Haskell in its official site. + +**What is HOpenGL?** + +HOpenGL stands for Haskell Open Graphics Library. Actually, it is a +binding to one of the most famous graphics libraries around the world +(OpenGL) and its auxiliary toolkit (GLUT). In other words, it makes +possible to call OpenGL/GLUT routines (which were written in the C +language) when programming in Haskell. You can find more info on HOpenGL +in my HOpenGL Tutorial site, or in its official site. diff --git a/examples/pong/hit.wav b/examples/pong/hit.wav new file mode 100644 Binary files /dev/null and b/examples/pong/hit.wav differ diff --git a/examples/pong/pong.hs b/examples/pong/pong.hs new file mode 100644 --- /dev/null +++ b/examples/pong/pong.hs @@ -0,0 +1,89 @@ +{- + +pong - a very simple FunGEn example. +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2001 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Main where + +import Graphics.UI.Fungen +import Graphics.Rendering.OpenGL (GLdouble) + +data GameAttribute = Score Int + +type PongObject = GameObject () +type PongAction a = IOGame GameAttribute () () () a + +width = 400 +height = 400 +w = fromIntegral width :: GLdouble +h = fromIntegral height :: GLdouble + +main :: IO () +main = do + let winConfig = ((100,20),(width,height),"A brief example!") + bmpList = [("tex.bmp",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)] + + funInit winConfig gameMap [bar,ball] () initScore input gameCycle (Timer 30) bmpList + +createBall :: PongObject +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 :: PongObject +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 :: PongAction () +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 :: PongAction () +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 :: PongAction () +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 reverseYSpeed ball) -- (funExit) + + 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 + diff --git a/examples/pong/tex.bmp b/examples/pong/tex.bmp new file mode 100644 Binary files /dev/null and b/examples/pong/tex.bmp differ diff --git a/examples/worms/border1.bmp b/examples/worms/border1.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/border1.bmp differ diff --git a/examples/worms/border2.bmp b/examples/worms/border2.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/border2.bmp differ diff --git a/examples/worms/border3.bmp b/examples/worms/border3.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/border3.bmp differ diff --git a/examples/worms/congratulations.bmp b/examples/worms/congratulations.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/congratulations.bmp differ diff --git a/examples/worms/food.bmp b/examples/worms/food.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/food.bmp differ diff --git a/examples/worms/free1.bmp b/examples/worms/free1.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/free1.bmp differ diff --git a/examples/worms/free2.bmp b/examples/worms/free2.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/free2.bmp differ diff --git a/examples/worms/free3.bmp b/examples/worms/free3.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/free3.bmp differ diff --git a/examples/worms/gameover.bmp b/examples/worms/gameover.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/gameover.bmp differ diff --git a/examples/worms/heade.bmp b/examples/worms/heade.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/heade.bmp differ diff --git a/examples/worms/headn.bmp b/examples/worms/headn.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/headn.bmp differ diff --git a/examples/worms/heads.bmp b/examples/worms/heads.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/heads.bmp differ diff --git a/examples/worms/headw.bmp b/examples/worms/headw.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/headw.bmp differ diff --git a/examples/worms/level1.bmp b/examples/worms/level1.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/level1.bmp differ diff --git a/examples/worms/level2.bmp b/examples/worms/level2.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/level2.bmp differ diff --git a/examples/worms/level3.bmp b/examples/worms/level3.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/level3.bmp differ diff --git a/examples/worms/segment.bmp b/examples/worms/segment.bmp new file mode 100644 Binary files /dev/null and b/examples/worms/segment.bmp differ diff --git a/examples/worms/worms.hs b/examples/worms/worms.hs new file mode 100644 --- /dev/null +++ b/examples/worms/worms.hs @@ -0,0 +1,414 @@ +{- + +worms - a very simple FunGEn example. +http://www.cin.ufpe.br/~haskell/fungen +Copyright (C) 2001 Andre Furtado + +This code is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +-} + +module Main where + +import Text.Printf +import Graphics.UI.Fungen +import Graphics.Rendering.OpenGL (GLdouble) + +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 = ((100,50),(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 )] + + 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 :: WormsAction () +turnLeft = do + snakeHead <- findObject "head" "head" + setObjectCurrentPicture 8 snakeHead + setObjectSpeed (-speedMod,0) snakeHead + +turnRight :: WormsAction () +turnRight = do + snakeHead <- findObject "head" "head" + setObjectCurrentPicture 7 snakeHead + setObjectSpeed (speedMod,0) snakeHead + +turnUp :: WormsAction () +turnUp = do + snakeHead <- findObject "head" "head" + setObjectCurrentPicture 5 snakeHead + setObjectSpeed (0,speedMod) snakeHead + +turnDown :: 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]] diff --git a/readme.txt b/readme.txt deleted file mode 100644 --- a/readme.txt +++ /dev/null @@ -1,9 +0,0 @@ -Sound support currently not present (originally working only under win32), aiming at multiplatform support through OpenAL. -(If you want a version with sound support, you can find it at FunGEn website: http://www.cin.ufpe.br/~haskell/fungen/download.html) - -Tested under Win32 & Linux/Intel. - -Known glitches: Flickering under linux (at least on my shitty laptop). - Wierd pong paddle behavior under Win32. - -Unless specified otherwisely, all code is Copyright (C) 2002 Andre Furtado .