Monadius-0.99: src/Main.hs
{- Copyright 2005 Hideyuki Tanaka & Takayuki Muranushi
This program is distributed under the terms of the GNU General Public License.
NOTE
This project meant to list up, not to solve, many possible problems that will appear
while writing a game in Haskell.
Only nushio is responsible to the unreadability of these codes.
-}
module Main (main) where
import Control.Exception (SomeException (..), catch)
import Control.Monad (mplus, zipWithM_)
import Data.Complex
import Data.IORef
import Data.List
import Data.Maybe
import Graphics.UI.GLUT hiding (position)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.Environment (getArgs, getEnv)
import System.Exit (exitSuccess)
import Demo (ReplayInfo (..), demoData)
import Game (isGameover, render, update)
import Monadius
import Recorder
import Util (intToGLdouble, padding, putDebugStrLn)
data GlobalVariables = GlobalVariables{
saveState :: (Int,Int) ,isCheat :: Bool, demoIndex :: Int,
-- | 'recorderMode' means general gamemode that user wants,
-- 'mode' of a recorder means current gamemode.
-- two are different when temporal demo replays.
recorderMode :: RecorderMode,
playbackKeys :: [[Key]],playbackSaveState :: (Int,Int),playBackName :: Maybe String,
recordSaveState :: (Int,Int),saveHiScore :: Int
}
replayFileExtension :: String
replayFileExtension = ".replay"
presentationMode :: Bool
presentationMode = True
loadReplay :: String-> IO ReplayInfo
loadReplay filename = readFile filename >>= (return . read)
main :: IO ()
main = do
args <- getArgs
putDebugStrLn $ show args
_ <- getArgsAndInitialize
keystate <- newIORef []
(recMode,keys,rss,repName) <- if isJust $ getReplayFilename args then do
ReplayInfo (ss,keystr) <- (loadReplay . fromJust . getReplayFilename) args
return (Playback,decode keystr,ss,Just $ (simplify . fromJust . getReplayFilename) args)
else if "-r" `elem` args then do
return (Play,[],(1,0),Nothing)
else
return (Record,[],(1,0),Nothing)
cp <- newIORef (openingProc 0 0 GlobalVariables{saveState = (1,0) ,isCheat = False,
recorderMode=recMode,playbackKeys=keys,playbackSaveState = rss,recordSaveState=(1,0),demoIndex=0,
playBackName=repName,saveHiScore=0} keystate)
initialWindowSize $= Size 640 480
initialDisplayMode $= [RGBAMode,DoubleBuffered{-,WithDepthBuffer,WithAlphaComponent-}]
wnd <- createWindow "Monadius"
curwnd <- if "-f" `elem` args then do
gameModeCapabilities $= [
Where' GameModeWidth IsLessThan 650,
Where' GameModeHeight IsLessThan 500
--Where' GameModeBitsPerPlane IsEqualTo 32,
--Where' GameModeRefreshRate IsAtLeast 30,
--Where' GameModeNum IsAtLeast 2
]
displayCallback $= dispProc cp
(wnd2,_) <- enterGameMode
destroyWindow wnd
return wnd2
else do
return wnd
displayCallback $= dispProc cp
keyboardMouseCallback $= Just (keyProc keystate)
addTimerCallback 16 (timerProc (dispProc cp))
initMatrix
mainLoop
destroyWindow curwnd
`catch` (\(SomeException _) -> return ())
where
getReplayFilename [] = Nothing
getReplayFilename a = (Just . head . candidates) a
candidates args = filter (replayFileExtension `isSuffixOf`) args
simplify = (removesuffix . removedir)
removedir str = if '\\' `elem` str || '/' `elem` str then (removedir . tail) str else str
removesuffix str = if '.' `elem` str then (removesuffix . init) str else str
exitLoop :: IO a
exitLoop = exitSuccess
initMatrix :: IO ()
initMatrix = do
viewport $= (Position 0 0,Size 640 480)
matrixMode $= Projection
loadIdentity
perspective 30.0 (4/3) 600 1400
lookAt (Vertex3 0 0 (927 :: GLdouble)) (Vertex3 0 0 (0 :: GLdouble)) (Vector3 0 1 (0 :: GLdouble))
dispProc :: IORef (IO Scene) -> IO ()
dispProc cp = do
m <- readIORef cp
Scene next <- m
writeIORef cp next
-- | Scene is something that does some IO,
-- then returns the Scene that are to be executed in next frame.
newtype Scene = Scene (IO Scene)
openingProc :: Int -> Int -> GlobalVariables -> IORef [Key] -> IO Scene
openingProc clock menuCursor vars ks = do
if recorderMode vars == Playback then gameStart (fst $ playbackSaveState vars) (snd $ playbackSaveState vars) (isCheat vars) Playback vars else do
if clock > demoStartTime then do demoStart vars else do
keystate <- readIORef ks
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
if clock < drawCompleteTime then color $ Color3 (0 :: GLdouble) 0.2 0.8
else color $ Color3 (0+shine clock :: GLdouble) (0.2+shine clock) (0.8+shine clock)
preservingMatrix $ do
translate (Vector3 0 (120 :: GLdouble) 0)
scale 1.05 1 (1 :: GLdouble)
mapM_ (renderPrimitive LineStrip . renderVertices2D.delayVertices clock) [lambdaLfoot,lambdaRfoot]
color $ Color3 (1.0 :: GLdouble) 1.0 1.0
preservingMatrix $ do
translate $ Vector3 (-195 :: GLdouble) (130) 0
scale (0.73 :: GLdouble) 0.56 0.56
renderStringGrad Roman 0 "Monadius"
preservingMatrix $ do
if menuCursor==0 then color $ Color3 (1.0 :: GLdouble) 1.0 0 else color $ Color3 (1.0 :: GLdouble) 1.0 1.0
translate $ Vector3 (-230 :: GLdouble) (-200) 0
scale (0.2 :: GLdouble) 0.2 0.3
renderStringGrad Roman 60 $ (if menuCursor==0 then ">" else " ") ++ "New Game"
preservingMatrix $ do
if menuCursor==1 then color $ Color3 (1.0 :: GLdouble) 1.0 0 else color $ Color3 (1.0 :: GLdouble) 1.0 1.0
translate $ Vector3 (70 :: GLdouble) (-200) 0
scale (0.2 :: GLdouble) 0.2 0.3
renderStringGrad Roman 60 $ (if menuCursor==1 then ">" else " ") ++ "Continue " ++ (show . fst . saveState) vars++ "-" ++ (show . (+1) . snd . saveState) vars
color $ Color3 (1.0 :: GLdouble) 1.0 1.0
preservingMatrix $ do
translate $ Vector3 (-250 :: GLdouble) (75) 0
scale (0.15 :: GLdouble) 0.10 0.15
renderStringGrad Roman 10 "Dedicated to the makers, the players, the history,"
preservingMatrix $ do
translate $ Vector3 (-250 :: GLdouble) (55) 0
scale (0.15 :: GLdouble) 0.10 0.15
renderStringGrad Roman 20 " and the 20th anniversary of GRADIUS series."
mapM_ (\ (y,(strA,strB),i) -> preservingMatrix $ do
preservingMatrix $ do
translate $ Vector3 (-180 :: GLdouble) y 0
scale (0.18 :: GLdouble) 0.18 0.2
renderStringGrad Roman (20 + i*5) strA
preservingMatrix $ do
translate $ Vector3 (60 :: GLdouble) y 0
scale (0.18 :: GLdouble) 0.18 0.2
renderStringGrad Roman (25 + i*5) strB
) $ zip3 [0,(-35)..] instructions [1..]
swapBuffers
if Char ' ' `elem` keystate && clock >= timeLimit then
if menuCursor == 0 then
gameStart 1 0 False (recorderMode vars) vars
else
gameStart savedLevel savedArea (isCheat vars) (recorderMode vars) vars
else if isJust $ getNumberKey keystate then
gameStart (fromJust $ getNumberKey keystate) 0 True (recorderMode vars) vars
else return $ Scene $ openingProc (clock+1) (nextCursor keystate) vars ks
where
instructions = [("Move","Arrow Keys"),("Shot","Z Key"),("Missile","X Key"),("Power Up","C Key"),("Start","Space Bar")]
timeLimit = 30 :: Int
renderStringGrad font delay str = renderString font (take (((clock-delay) * length str) `div` timeLimit) str)
getNumberKey keystate = foldl mplus Nothing $ map keyToNumber keystate
keyToNumber :: Key -> Maybe Int
keyToNumber k = case k of
Char c -> if c>='0' && c<='9' then Just $ fromEnum c - fromEnum '0' else Nothing
_ -> Nothing
gameStart level area ischeat recordermode vrs = do
-- it is possible to temporary set (recordermode /= recorderMode vars)
gs <- newIORef $ initialRecorder recordermode (playbackKeys vrs) (initialMonadius GameVariables{
totalScore=0, flagGameover=False, hiScore=saveHiScore vrs,
nextTag=0, gameClock = savePoints!!area ,baseGameLevel = level,
playTitle = if recordermode /= Playback then Nothing else playBackName vrs})
return $ Scene $ mainProc vrs{isCheat=ischeat,recordSaveState=(level,area)} gs ks
(savedLevel,savedArea) = saveState vars
demoStart vrs = do
let i = demoIndex vrs
let ReplayInfo ((lv,area),dat) = demoData!!i
gameStart lv area (isCheat vrs) Playback vrs{
playBackName = Just "Press Space",
playbackKeys = decode dat,
demoIndex = demoIndex vrs+1
}
nextCursor keys =
if SpecialKey KeyLeft `elem` keys then 0 else
if SpecialKey KeyRight `elem` keys then 1 else
menuCursor
delayVertices clck vs = (reverse . take clck . reverse) vs
lambdaLfoot = moreVertices $ [10:+55,(-15):+0] ++ map (\(x:+y)->((-x):+y)) wing
lambdaRfoot = moreVertices $ [(-15):+70,(-12):+77,(-5):+80,(2:+77),(5:+70)] ++ wing
shine t = monoshine (drawCompleteTime + t) + monoshine (drawCompleteTime + t+6)
monoshine t = exp(-0.2*intToGLdouble(t`mod` 240))
drawCompleteTime = length lambdaRfoot
moreVertices (a:b:cs) = if magnitude (a-b) > d then moreVertices (a:((a+b)/(2:+0)):b:cs) else a:moreVertices(b:cs)
where d=6
moreVertices x = x
wing = [(30:+0),(200:+0),(216:+16),(208:+24),(224:+24),(240:+40),(232:+48),(248:+48),(272:+72),(168:+72)]
renderVertices2D :: [Complex GLdouble] -> IO ()
renderVertices2D xys = mapM_ (\(x:+y) -> vertex $ Vertex3 x y 0) xys
demoStartTime = if presentationMode then 480 else 1800
endingProc :: GlobalVariables -> IORef [Key] -> IORef GLdouble -> IO Scene
endingProc vars ks ctr= do
keystate <- readIORef ks
counter <- readIORef ctr
modifyIORef ctr (min 2420 . (+2.0))
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
color $ Color3 (1.0 :: GLdouble) 1.0 1.0
zipWithM_ (\str pos -> preservingMatrix $ do
translate $ Vector3 (-180 :: GLdouble) (-240+counter-pos) 0
scale (0.3 :: GLdouble) 0.3 0.3
renderString Roman str)
stuffRoll [0,60..]
swapBuffers
if Char ' ' `elem` keystate then do
return $ Scene $ openingProc 0 1 vars ks
else return $ Scene $ endingProc vars ks ctr
where
stuffRoll = [
"",
"",
"Game Designer",
" nushio",
"",
"Frame Programmer",
" tanakh",
"",
"Graphics Designer",
" Just nushio",
"",
"Sound Designer",
" Match Makers",
"",
"Lazy Evaluator",
" GHC 6.8",
"",
"Inspired" ,
" Ugo-Tool",
" gradius2.com",
" Gradius series",
"",
"Special thanks to",
" John Peterson",
" Simon Marlow",
" Haskell B. Curry",
" U.Glasgow",
"",
"Presented by",
" team combat",
"",
"",
if (fst . saveState) vars <= 2 then "Congratulations!" else "WE LOVE GAMES!!" ,
"",
" press space key"]
mainProc :: GlobalVariables -> IORef Recorder -> IORef [Key] -> IO Scene
mainProc vars gs ks = do
keystate <- readIORef ks
modifyIORef gs (update keystate)
gamestate <- readIORef gs
clear [ColorBuffer,DepthBuffer]
matrixMode $= Modelview 0
loadIdentity
render gamestate
swapBuffers
let currentLevel = baseGameLevel$getVariables$gameBody gamestate
let currentArea = maximum $ filter (\i -> (savePoints !! i) < (gameClock $ getVariables $ gameBody gamestate)) [0..(length savePoints-1)]
let currentSave = if mode gamestate == Playback then saveState vars else (currentLevel,currentArea)
let currentHi = max (saveHiScore vars) (hiScore$getVariables$gameBody gamestate)
if (isGameover gamestate) then do
counter <- newIORef (0.0 :: GLdouble)
if mode gamestate /= Record then return () else do
writeReplay vars gamestate $ show (ReplayInfo (recordSaveState vars,(encode2 . preEncodedKeyBuf) gamestate))
if currentLevel>1 && (not . isCheat) vars && (mode gamestate /= Playback) then
return $ Scene $ endingProc vars{saveState=currentSave,saveHiScore = currentHi} ks counter
else return $ Scene $ openingProc 0 1 vars{saveState=currentSave,saveHiScore = currentHi} ks
else return $ Scene $ mainProc vars{saveState=currentSave,saveHiScore = currentHi} gs ks
where
writeReplay vs gamestate str = do
home <- getEnv "HOME"
createDirectoryIfMissing True (home ++ "/.monadius-replay/")
filename <- searchForNewFile (
"replay\\" ++ (showsave . recordSaveState) vs ++ "-" ++ (showsave . saveState) vs ++ "." ++
((padding '0' 8) . show . totalScore . getVariables . gameBody) gamestate ++ "pts") 0
writeFile (home ++ "/.monadius-replay/" ++ filename) str
showsave (a,b) = show (a,b+1)
searchForNewFile prefix i = do
let fn = prefix ++ (uniqStrs!!i) ++ replayFileExtension
b <- doesFileExist fn
if not b then return fn else do
searchForNewFile prefix $ i + 1
uniqStrs = ("") : (map (("." ++) . show) ([1..] :: [Int]))
timerProc :: IO () -> IO ()
timerProc m = addTimerCallback 16 $ timerProc m >> m
keyProc :: IORef [Key] -> Key -> KeyState -> t -> t1 -> IO ()
keyProc keystate key ks _ _ =
case (key,ks) of
(Char 'q',_) -> exitLoop
(Char '\ESC',_) -> exitLoop
(_,Down) -> modifyIORef keystate (nub . (++ [key]))
(_,Up) -> modifyIORef keystate (filter (/=key))
savePoints :: [Int]
savePoints = [0,1280,3000,6080]