DSTM-0.1: Bomberman/Bomberman.hs
{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable #-}
module Main where
import Char
import Control.Concurrent
import Control.Exception as CE hiding (catch)
import qualified Control.Exception as CE (catch)
import Control.Distributed.STM.DebugDSTM
import Control.Distributed.STM.DSTM
import Maybe
import Network.BSD
import Prelude hiding (catch)
import System hiding (system)
import System.IO hiding (hPutStrLn)
import System.IO.Unsafe
import System.Posix
data Point = Point Int Int
deriving (Eq, Show, Read)
instance Num Point where
(Point x1 y1) + (Point x2 y2) = Point (x1 + x2) (y1 + y2)
(Point x1 y1) - (Point x2 y2) = Point (x1 - x2) (y1 - y2)
(Point x1 y1) * (Point x2 y2) = Point (x1 * x2) (y1 * y2)
abs (Point x y) = Point (abs x) (abs y)
signum (Point x y) = Point (signum x) (signum y)
fromInteger x = Point (fromInteger x) (fromInteger x)
data Key = QKey
| AKey | MKey | SKey
| UpKey | DownKey | RightKey | LeftKey
| SpaceKey
| DebugKey
deriving (Eq, Show, Read)
point :: Int -> Int -> Point
point x y = Point x y
cWallSymbol :: Char; cWallSymbol = 'x'
cFSize :: Int; cFSize = 10
cDelay :: Int; cDelay = 2000000 -- 2 s; 50 ms granularity
cInitLifes :: Int; cInitLifes = 0
cInitPlayer :: Point; cInitPlayer = point 2 2
pI :: Point; pI = point 0 0
pR :: Point; pR = point 1 0
pL :: Point; pL = point (-1) 0
pU :: Point; pU = point 0 (-1)
pD :: Point; pD = point 0 1
fieldFile :: String; fieldFile = "./field.txt"
emptyImage :: String; emptyImage = " "
wallImage :: String; wallImage = "W "
playerImage :: String; playerImage = "o "
slaveImage :: String; slaveImage = "@ "
bombImage :: String; bombImage = ". "
blastImage :: String; blastImage = "X "
esc :: Char; esc = chr 27
csi :: Char; csi = chr 91
upKey :: Char; upKey = chr 65
downKey :: Char; downKey = chr 66
rightKey :: Char; rightKey = chr 67
leftKey :: Char; leftKey = chr 68
aKeys :: [Char]; aKeys = ['a','A']
mKeys :: [Char]; mKeys = ['m','M']
sKeys :: [Char]; sKeys = ['s','S']
qKeys :: [Char]; qKeys = ['q','Q']
dKeys :: [Char]; dKeys = ['d','D']
spaceKey :: Char; spaceKey = ' '
initKeys :: [Char]; initKeys = aKeys++mKeys++sKeys
ctrlKeys :: [Char]; ctrlKeys = (esc:spaceKey:qKeys)++dKeys
cursKeys :: [Char]; cursKeys = [upKey,downKey,rightKey,leftKey]
clearScreen :: String; clearScreen = (esc:csi:"2J")
home :: String; home = (esc:csi:"H")
saveCursor :: String; saveCursor = (esc:csi:"s")
restoreCursor :: String; restoreCursor = (esc:csi:"u")
getCursor :: String; getCursor = (esc:csi:"6n")
midScreen :: String; midScreen = (esc:csi:"12;1H")
setCursor :: Point -> String
setCursor (Point x y) = (esc:csi:show (y+1))++(';':show ((x+1)*2))++"H"
line :: Int -> String
line l = (esc:csi:show l)++(";1H")
data Mode = AutonomM | MasterM String | SlaveM String
deriving (Show, Read)
type Input = (Int, Handle)
data Element = Empty | Wall | Player | Slave | Bomb | Blast
deriving (Show, Read, Eq)
type Field = [[Element]]
type Canvas = Field
type Bombs = [Point]
type Blasts = [Bombs]
data GameState = GameState {move :: TVar (Maybe Move),
repaint :: TVar Bool,
field :: TVar Field,
lifes :: TVar Int,
player :: TVar Point,
slaves :: TVar [TVar Point],
repaints :: TVar [TVar Bool],
plBombs :: TVar Bombs,
plBlasts :: TVar Blasts,
plBCount :: TVar Int,
bombs :: TVar [TVar Bombs],
blasts :: TVar [TVar Blasts],
bCounts :: TVar [TVar Int],
quit :: TVar Bool,
quits :: TVar [TVar Bool]}
deriving (Show, Read)
data Move = MoveLeft | MoveRight | MoveUp | MoveDown
| DropBomb | Dead
deriving (Eq, Show, Read)
data View = View Field Point [Point] Bombs Blasts
deriving Show
instance Dist Move where
finTVars _ = return ()
regTVars _ _ = return ()
instance Dist Point where
finTVars _ = return ()
regTVars _ _ = return ()
instance Dist Element where
finTVars _ = return ()
regTVars _ _ = return ()
gKeyCount :: MVar (Int, Int)
gKeyCount = unsafePerformIO (newMVar (0,0))
main :: IO ()
main = CE.catch (do
debugStrLn6 "### bomberman main"
putStr clearScreen
hSetEcho stdin False
hSetBuffering stdin NoBuffering
args <- getArgs
debugStrLn6 (show args)
(mode, input) <- gameMode args
debugStrLn6 (show mode)
debugStrLn6 (show input)
startDist (startGame mode input benchmark)
--showTCPStat (midScreen++"quit")
)(\(e::SomeException) -> error ("error in Bomberman: " ++ show e))
gameMode :: [String] -> IO (Mode, Input)
gameMode ((mode:_):[]) | elem mode aKeys = -- autonom + interactive
return (AutonomM, (1, stdin))
gameMode ((mode:_):input:[]) | elem mode aKeys = -- autonom + file
(openFile input ReadMode) >>= \h -> return (AutonomM, (1, h))
gameMode ((mode:_):[]) | elem mode mKeys = -- master + interactive
return (MasterM gDefaultNameServer, (1, stdin))
gameMode ((mode:_):input:[]) | elem mode mKeys = -- master + file
(openFile input ReadMode) >>= \h -> return (MasterM gDefaultNameServer, (1,h))
gameMode ((mode:_):delay:input:[]) | elem mode mKeys = do -- master+delay+file
h <- (openFile input ReadMode)
return (MasterM gDefaultNameServer, (read delay, h))
gameMode ((mode:_):[]) | elem mode sKeys = -- slave+interactive
return (SlaveM gDefaultNameServer, (1, stdin))
gameMode ((mode:_):input:[]) | elem mode sKeys = -- slave + file
(openFile input ReadMode) >>= \h -> return (SlaveM gDefaultNameServer, (1, h))
gameMode ((mode:_):delay:input:[]) | elem mode sKeys = do -- slave+delay+file
h <- (openFile input ReadMode)
return (SlaveM gDefaultNameServer, (read delay, h))
gameMode ((mode:_):input:nameServer:[]) | elem mode sKeys = -- s+f+nameserver
(openFile input ReadMode) >>= \h -> return (SlaveM nameServer, (1, h))
gameMode ((mode:_):delay:input:nameServer:[]) | elem mode sKeys = do --s+d+f+n
h <- (openFile input ReadMode)
return (SlaveM nameServer, (read delay, h))
gameMode _ = getInitKey >>= \mode -> return (mode, (1, stdin)) -- interactive
benchmark :: IO Int -> Mode -> Input -> IO ()
benchmark action mode (delayStep, file) = do
debugStrLn6 "### bomberman benchmark1"
debugStrLn1 "### bomberman benchmark1"
start <- getProcessTimes
debugStrLn1 "### bomberman benchmark2"
lostLifes <- action
debugStrLn1 "### bomberman benchmark3"
end <- getProcessTimes
debugStrLn1 "### bomberman benchmark4"
debugStrLn6 "### bomberman benchmark2"
clockTick <- getSysVar ClockTick
hostname <- getHostName
(keysPressed, keysProcessed) <- readMVar gKeyCount
let elapsed = toInteger (fromEnum ((elapsedTime end) - (elapsedTime start)))
user = toInteger (fromEnum ((userTime end) - (userTime start)))
system = toInteger (fromEnum ((systemTime end) - (systemTime start)))
delay = toInteger delayStep * clockTick * toInteger keysPressed `div` 20
filler = user + system + delay - elapsed
putStrLn ("\nHost: " ++ hostname)
putStrLn ("Input file: " ++ show file ++ "\n")
putStr (" elapsed: " ++ showJustify elapsed 5 ++ " ticks ")
putStrLn ("-> elapsed time total: "++ ticks2Sec elapsed clockTick)
putStr ("= user: " ++ showJustify user 5 ++ " ticks ")
putStrLn (" (" ++ show clockTick ++ " ticks/sec)")
putStr ("+ system: " ++ showJustify system 5 ++ " ticks ")
putStrLn ("-> user + system time: "++ ticks2Sec (user + system) clockTick)
putStr ("+ delay: " ++ showJustify delay 5 ++ " ticks ")
putStrLn ("<- "++show keysPressed ++ "/" ++ show keysProcessed ++ " keys read/processed")
putStr ("- filler: " ++ showJustify filler 5 ++ " ticks ")
putStrLn (" ("++show (delayStep*50)++" ms/key stroke)")
putStr (showLifes lostLifes)
putStrLn (" Mode: " ++ show mode ++ " ")
ticks2Sec :: Integer -> Integer -> String
ticks2Sec t ticksPerSec =
let (sec, ticks) = divMod t ticksPerSec
ms = ticks * 1000 `div` ticksPerSec
in (show sec ++ "." ++ (concat [show ((ms `mod` (x * 10)) `div` x) | x <- [100,10,1]]) ++ " s")
showLifes :: Int -> String
showLifes l | l == 1 = " 1 life lost "
| otherwise = showJustify (toInteger l) 3 ++ " lifes lost"
showJustify :: Show a => a -> Int -> String
showJustify i len = let s = show i in (replicate (len - length s) ' ') ++ s
launchGame :: Input -> GameState -> IO Int
launchGame input gameState = do
debugStrLn6 ("### bomberman launchGame")
showGameState gameState
forkIO (view gameState) >> return ()
forkIO (playerCtrl gameState) >> return ()
debugStrLn1 ("### bomberman launchGame 0")
processKeyboard gameState input
debugStrLn1 ("### bomberman launchGame 1")
atomic $ readTVar (lifes gameState)
startGame :: Mode -> Input -> (IO Int -> Mode -> Input -> IO ()) -> IO ()
startGame mode input bench = do
debugStrLn6 "### bomberman startGame"
debugStrLn6 (show mode)
debugStrLn6 (show input)
case mode of
AutonomM -> bench (initAuto >>= launchGame input) mode input
MasterM server -> do
gameState <- initMaster server
threadDelay cDelay
bench (launchGame input gameState) mode input
termMaster server
threadDelay cDelay
SlaveM server -> do
gameState <- initSlave server
threadDelay cDelay
bench (launchGame input gameState) mode input
threadDelay cDelay
initMaster :: String -> IO GameState
initMaster server = do
debugStrLn6 ("### bomberman initMaster")
game <- initAuto
atomic $ do
writeTVar (slaves game) [player game]
registerTVar server (quits game) "QUITS"
registerTVar server (field game) "FIELD"
registerTVar server (slaves game) "SLAVES"
registerTVar server (repaints game) "REPAINTS"
registerTVar server (bombs game) "BOMBS"
registerTVar server (blasts game) "BLASTS"
registerTVar server (bCounts game) "BCOUNTS"
return game
termMaster :: String -> IO ()
termMaster server = do
debugStrLn6 ("### bomberman terminateMaster")
deregisterTVar server "QUITS"
deregisterTVar server "FIELD"
deregisterTVar server "SLAVES"
deregisterTVar server "REPAINTS"
deregisterTVar server "BOMBS"
deregisterTVar server "BLASTS"
deregisterTVar server "BCOUNTS"
initSlave :: String -> IO GameState
initSlave server = CE.catch (do
debugStrLn6 ("### bomberman initSlave")
mQuits <- lookupTVar server "QUITS"
let sQuits = fromJust mQuits
mField <- lookupTVar server "FIELD"
let sField = fromJust mField
mSlaves <- lookupTVar server "SLAVES"
let sSlaves = fromJust mSlaves
mRepaints <- lookupTVar server "REPAINTS"
let sRepaints = fromJust mRepaints
mBombs <- lookupTVar server "BOMBS"
let sBombs = fromJust mBombs
mBlasts <- lookupTVar server "BLASTS"
let sBlasts = fromJust mBlasts
mBCounts <- lookupTVar server "BCOUNTS"
let sBCounts = fromJust mBCounts
myLives <- atomic $ newTVar cInitLifes
newSlave <- atomic $ newTVar cInitPlayer
sMove <- atomic $ newTVar Nothing
myBombs <- atomic $ newTVar []
myBlasts <- atomic $ newTVar []
myBCount <- atomic $ newTVar 0
myRepaint <- atomic $ newTVar True
myQuit <- atomic $ newTVar False
atomic $ do
oldSlaves <- readTVar sSlaves
writeTVar sSlaves (newSlave:oldSlaves)
oldBombs <- readTVar sBombs
writeTVar sBombs (myBombs:oldBombs)
oldBlasts <- readTVar sBlasts
writeTVar sBlasts (myBlasts:oldBlasts)
oldBCounts <- readTVar sBCounts
writeTVar sBCounts (myBCount:oldBCounts)
otherRepaints <- readTVar sRepaints
writeTVar sRepaints (myRepaint:otherRepaints)
otherQuits <- readTVar sQuits
writeTVar sQuits (myQuit:otherQuits)
return (GameState sMove myRepaint sField myLives newSlave sSlaves sRepaints myBombs myBlasts myBCount sBombs sBlasts sBCounts myQuit sQuits)
)(\(e::SomeException) -> putStrLn (midScreen ++ show e ++
" in initSlave from "++ show server ++
". Starting auto game.") >> initAuto)
initAuto :: IO GameState
initAuto = do
debugStrLn6 ("### bomberman initAuto")
initField <- readField
atomic $ do
aMove <- newTVar Nothing
aRepaint <- newTVar True
aField <- newTVar initField
aLives <- newTVar cInitLifes
aPlayer <- newTVar cInitPlayer
aSlaves <- newTVar []
aRepaints <- newTVar [aRepaint]
aPlBombs <- newTVar []
aPlBlasts <- newTVar []
aPLBCount <- newTVar 0
aBombs <- newTVar [aPlBombs]
aBlasts <- newTVar [aPlBlasts]
aBCounts <- newTVar [aPLBCount]
aQuit <- newTVar False
aQuits <- newTVar [aQuit]
return (GameState aMove aRepaint aField aLives aPlayer aSlaves aRepaints aPlBombs aPlBlasts aPLBCount aBombs aBlasts aBCounts aQuit aQuits)
readField :: IO Field
readField = do
fieldStr <- readFile fieldFile
return (map (map readEl) (lines fieldStr))
readEl :: Char -> Element
readEl c = if (c == cWallSymbol) then Wall else Empty
view :: GameState -> IO ()
view game = CE.catch (do
debugStrLn6 ("### bomberman view")
initField <- readField -- nur test
debugStrLn6 ("### bomberman view 1")
newView <- atomic $ do
b <- readTVar (repaint game)
proc $ debugStrLn5 ("view 0")
if b
then do
writeTVar (repaint game) False
f1 <- readTVar (field game)
writeTVar (field game) initField
writeTVar (field game) initField
writeTVar (field game) f1
--
p1 <- readTVar (player game)
writeTVar (player game) cInitPlayer
p2 <- readTVar (player game)
writeTVar (player game) cInitPlayer
writeTVar (player game) p1
--}
proc $ debugStrLn6 ("view 0")
f <- readTVar (field game)
proc $ debugStrLn6 ("view 1")
p <- readTVar (player game)
proc $ debugStrLn6 ("view 2")
bsTVars <- readTVar (bombs game)
allBombs <- mapM readTVar bsTVars
proc $ debugStrLn6 ("view 3")
blsTVars <- readTVar (blasts game)
allBlasts <- mapM readTVar blsTVars
proc $ debugStrLn6 ("view 4")
slavesTVars <- readTVar (slaves game)
proc $ debugStrLn6 ("view 5")
slavesPts <- mapM readTVar slavesTVars
proc $ debugStrLn6 ("view 6")
return (View f p slavesPts (concat allBombs) (concat allBlasts))
else retry
debugStrLn6 ("### bomberman view 2")
draw (makeCanvas newView)
debugStrLn6 ("### bomberman view 3")
printStatistics (midScreen)
debugStrLn6 ("### bomberman view 4")
view game
)(\(e::SomeDistTVarException) -> do
debugStrLn1 ("view catch "++show e)
atomic $ do
proc $ debugStrLn1 ("view catch atomic")
cleanupSTM e game
debugStrLn1 ("view catch dyn: <- ")
view game
)
cleanupSTM :: SomeDistTVarException -> GameState -> STM ()
cleanupSTM err game = do
--proc $ debugStrLn1 ("--> cleanupSTM bsTVars")
bsTVars <- readTVar (bombs game)
let new = (removeErrTVars err bsTVars)
--proc $ debugStrLn1 ("--> bsTVars "++ show bsTVars ++ show new)
writeTVar (bombs game) (removeErrTVars err bsTVars)
blsTVars <- readTVar (blasts game)
--proc $ debugStrLn1 ("--> blsTVars "++ show blsTVars)
writeTVar (blasts game) (removeErrTVars err blsTVars)
bCtTVars <- readTVar (bCounts game)
--proc $ debugStrLn1 ("--> bCtTVars "++ show bCtTVars)
writeTVar (bCounts game) (removeErrTVars err bCtTVars)
slavesTVars <- readTVar (slaves game)
--proc $ debugStrLn1 ("--> slavesTVars "++ show slavesTVars)
writeTVar (slaves game) (removeErrTVars err slavesTVars)
repaintsTVars <- readTVar (repaints game)
--proc $ debugStrLn1 ("--> repaintsTVars "++ show repaintsTVars)
writeTVar (repaints game) (removeErrTVars err repaintsTVars)
--proc $ debugStrLn1 ("<-- cleanupSTM bsTVars")
removeErrTVars :: SomeDistTVarException -> [TVar a] -> [TVar a]
removeErrTVars ex tVars = [tVar | tVar <- tVars, not (isDistErrTVar ex tVar)]
draw :: Canvas -> IO ()
draw canvas = do
putStr saveCursor
putStr home
mapM_ (putStrLn.concatMap elToStr) canvas
putStr restoreCursor
elToStr :: Element -> String
elToStr e = case e of
Empty -> emptyImage
Wall -> wallImage
Player -> playerImage
Slave -> slaveImage
Bomb -> bombImage
Blast -> blastImage
processKeyboard :: GameState -> Input -> IO ()
processKeyboard game input@(delayStep, file) = CE.catch (do
debugStrLn6 ("### bomberman processKeyboard")
end <- processEnd game
if end
then hClose file
else do
key <- if delayStep /= 0
then do -- pause between key strokes in micros
threadDelay (delayStep*50000)
oldMove <- atomic (readTVar (move game))
let keyOk = if oldMove == Nothing then 1 else 0
modifyMVar_ gKeyCount (\(key, ok) -> return (key + 1, ok+keyOk))
getGameKey file
else do
atomic $ do
oldMove <- readTVar (move game)
if oldMove /= Nothing then retry else return ()
modifyMVar_ gKeyCount (\(key, ok) -> return (key + 1, ok + 1))
getGameKey file
debugStrLn6 ("### bomberman Key= "++show key)
case key of
QKey -> atomic (writeTVar (quit game) True)
>> debugStrLn1 ("### bomberman Key= "++show key)
>> processKeyboard game input
LeftKey -> atomic (writeTVar (move game) (Just MoveLeft))
>> processKeyboard game input
RightKey -> atomic (writeTVar (move game) (Just MoveRight))
>> processKeyboard game input
UpKey -> atomic (writeTVar (move game) (Just MoveUp))
>> processKeyboard game input
DownKey -> atomic (writeTVar (move game) (Just MoveDown))
>> processKeyboard game input
SpaceKey -> atomic (writeTVar (move game) (Just DropBomb))
>> processKeyboard game input
DebugKey -> startGDebug >> processKeyboard game input
_ -> processKeyboard game input
)(\(e::SomeDistTVarException) -> do
debugStrLn1 ("processKeyboard catch "++show e)
hClose file
)
processEnd :: GameState -> IO Bool
processEnd game = CE.catch (do
debugStrLn6 ("### bomberman processEnd")
atomic $ do -- eof + 0 bombs + all nodes done -> end w/o busy waiting
eof <- readTVar (quit game)
if eof
then retry
else return False
`orElse` do
--proc $ debugStrLn1 ("processEnd 1 ")
count <- getSTMBombCount game -- # of active bombs
--proc $ debugStrLn1 ("processEnd 2 ")
qTVars <- readTVar (quits game) -- list of quit status of all nodes
proc $ debugStrLn1 ("processEnd 3 "++ show count)
qs <- mapM readTVar qTVars
proc $ debugStrLn1 ("processEnd 4 " ++ show qs)
if (count == 0) && (and qs)
then return True
else retry
)(\(e::SomeDistTVarException) -> do
debugStrLn1 ("processEnd catch "++show e)
atomic $ do
qTVars <- readTVar (quits game)
writeTVar (quits game) (removeErrTVars e qTVars)
cTVars <- readTVar (bCounts game)
writeTVar (bCounts game) (removeErrTVars e cTVars)
processEnd game
)
getSTMBombCount :: GameState -> STM Int
getSTMBombCount game = do -- # of active bombs
countTVars <- readTVar (bCounts game)
counts <- mapM readTVar countTVars
return (foldr (+) 0 counts)
getGameKey :: Handle -> IO Key
getGameKey input = do
c <- hGetChar input
if (elem c ctrlKeys)
then if (c == esc)
then do
c1 <- hGetChar input
if (c1 == csi)
then do
c2 <- hGetChar input
if (elem c2 cursKeys)
then return (cursorKey c2)
else getGameKey input
else getGameKey input
else return (controlKey c)
else getGameKey input
cursorKey :: Char -> Key
cursorKey c =
if (c == upKey) then UpKey
else if (c == downKey) then DownKey
else if (c == leftKey) then LeftKey
else if (c == rightKey) then RightKey
else error ("error wrong char '"++(c:"' in cursorKey"))
controlKey :: Char -> Key
controlKey c =
if (elem c qKeys) then QKey
else if (c == spaceKey) then SpaceKey
else if (elem c dKeys) then DebugKey
else error ("error wrong char '"++(c:"' in controlKey"))
getInitKey :: IO Mode
getInitKey = do
putStr clearScreen
putStr (line 15)
putStrLn"Bitte waehlen: Autonom (A), Master (M), Slave (S)"
hSetEcho stdin False
hSetBuffering stdin NoBuffering
c <- getChar
if (elem c initKeys)
then initMode c
else return AutonomM
initMode :: Char -> IO Mode
initMode c =
if (elem c aKeys) then return AutonomM
else if (elem c mKeys) then do
server <- getNameServer
return (MasterM server)
else if (elem c sKeys) then do
server <- getNameServer
return (SlaveM server)
else error ("error wrong char '"++(c:"' in initMode"))
getNameServer :: IO String
getNameServer = do
hSetEcho stdin True
putStrLn "Masterserver [default: localhost]: "
s <- getLine
hSetEcho stdin False
return (if (s == []) then gDefaultNameServer else s)
playerCtrl :: GameState -> IO ()
playerCtrl game = CE.catch (do
debugStrLn6 ("### bomberman playerCtrl")
-- get new move if available orElse check if dead on explosion
m <- atomic $ getSTMCommand (move game) -- get move or retry
`orElse` do -- check active explosions
expls <- getSTMBombCount game -- # of active bombs
if expls > 0
then do
p <- readTVar (player game)
blsTVars <- readTVar (blasts game)
allBlasts <- mapM readTVar blsTVars
-- check player explosion
if elem p ((concat.concat) allBlasts)
then return Dead -- player exploded
else retry -- wait for next move
else retry -- wait for next move
debugStrLn6 ("# case m "++show m)
case m of -- make players move
DropBomb -> forkIO (dropBomb game) >> return ()
Dead -> atomic $ do
p <- readTVar (player game)
blsTVars <- readTVar (blasts game)
allBlasts <- mapM readTVar blsTVars
if elem p ((concat.concat) allBlasts)
then retry
else modifyTVar (lifes game) (+1)
_ -> atomic $ do
f <- readTVar (field game)
p <- readTVar (player game)
let newPlayer = case m of
MoveLeft -> legalPos f p pL
MoveRight -> legalPos f p pR
MoveUp -> legalPos f p pU
MoveDown -> legalPos f p pD
_ -> legalPos f p pI
writeTVar (player game) newPlayer
setSTMRepaintAll (repaints game)
debugStrLn6 ("# end loop")
playerCtrl game
)(\(e::SomeDistTVarException) -> do
debugStrLn1 ("playerCtrl catch "++show e)
atomic $ do
proc $ debugStrLn1 ("playerCtrl catch atomic: ")
cleanupSTM e game
debugStrLn1 ("playerCtrl catch dyn ---: ")
--bs <- atomic $ showSTMRepaintAll (repaints game)
--debugStrLn1 ("reps " ++ show bs)
atomic $ setSTMRepaintAll (repaints game)
debugStrLn1 ("playerCtrl catch dyn <-: ")
playerCtrl game
)
getSTMCommand :: TVar (Maybe Move) -> STM Move
getSTMCommand mTVar = do
m <- readTVar mTVar
proc $ debugStrLn2 ("getSTMCommand: "++(show m))
if (m == Nothing)
then retry
else do
writeTVar mTVar Nothing
return (fromJust m)
legalPos :: Field -> Point -> Point -> Point
legalPos f p moveP = if (isLegal newPos f) then newPos else p
where newPos = p + moveP
inBoundsPos :: Point -> Point -> Point
inBoundsPos p moveP = if (isInBounds newPos) then newPos else p
where newPos = p + moveP
isLegal :: Point -> Field -> Bool
isLegal p f = isInBounds p && ((f `at` p) /= Wall)
isInBounds :: Point -> Bool
isInBounds (Point x y) = x >= 0 && x < cFSize && y >= 0 && y < cFSize
dropBomb :: GameState -> IO ()
dropBomb game = do
debugStrLn6 ("### bomberman dropBomb")
debugStrLn6 "# add new bomb@currPos to list"
pos <- atomic $ do -- add new bomb@currPos to player bombs list
p <- readTVar (player game)
modifyTVar (plBombs game) (p:)
return p
debugStrLn6 "# set repaint"
saveSetRepaintAll game -- mark changes to show
timeBomb game pos
timeBomb :: GameState -> Point -> IO ()
timeBomb game pos = CE.catch (do -- catch bombs from dropped players
debugStrLn6 "# init sema wake"
wake <- atomic $ newTVar False
debugStrLn6 "# start sleep counter wake"
forkIO (threadDelay cDelay >> atomic (writeTVar wake True)) -- start timer
debugStrLn6 "# wait for wake counter orelse active explosions"
atomic $ do
w <- readTVar wake
if w
then return () -- timeout
else retry -- check active explosion @ pos -> new bomb explodes also
`orElse` do
expls <- getSTMBombCount game -- # of active bombs
if expls > 0
then do -- sync with other expls
blsTVars <- readTVar (blasts game)
allBlasts <- mapM readTVar blsTVars
if elem pos ((concat.concat) allBlasts)
then return () -- dont wait for timeout
else retry -- wait for timeout
else retry -- wait for timeout
debugStrLn6 "# end bomb"
blastBomb game pos
)(\(e::SomeDistTVarException) -> do -- clean up and dont wait for timeout
debugStrLn1 ("timeBomb catch "++show e)
atomic $ do
proc $ debugStrLn1 ("timeBomb catch atomic: ")
cleanupSTM e game
debugStrLn1 ("timeBomb catch dyn ---: ")
blastBomb game pos
)
blastBomb :: GameState -> Point -> IO ()
blastBomb game pos = do
debugStrLn6 ("### bomberman blastBomb")
debugStrLn6 "# remove bomb@pos, add new blasts, clear field@blast, inc #blast"
newBls <- atomic $ do
modifyTVar (plBombs game) (filter (/=pos)) --remove new bomb from bombs list
let newBls = neighbours pos
modifyTVar (plBlasts game) (newBls:) -- add new blasts to blasts lists
modifyTVar (field game) (updateField Empty newBls) -- remove bombed walls
modifyTVar (plBCount game) (+1)
return newBls
saveSetRepaintAll game -- mark changes to show
debugStrLn6 "# delay"
threadDelay cDelay
debugStrLn6 "# remove new blast, dec #blast"
atomic $ do
modifyTVar (plBlasts game) (filter (/=newBls)) -- remove new blast
modifyTVar (plBCount game) (+ (-1))
saveSetRepaintAll game -- mark changes to show
debugStrLn6 "# end bomb"
makeCanvas :: View -> Canvas
makeCanvas v =
[ [canvasEl v (Point x y) | x <- [0..cFSize-1] ] | y <- [0..cFSize-1] ]
canvasEl :: View -> Point -> Element
canvasEl (View vField vPlayer vSlaves vBombs vBlasts) p =
if elem p (concat vBlasts)
then Blast
else if (vPlayer == p)
then Player
else if elem p vSlaves
then Slave
else if elem p vBombs
then Bomb
else vField `at` p
updateField :: Element -> [Point] -> Field -> Field
updateField el ps fd =
[ [ f x y | x <- [0..cFSize-1] ] | y <- [0..cFSize-1] ]
where f x y = if (elem (Point x y) ps)
then el else fd `at` (Point x y)
{- [bVec | y <- [0..cFSize-1],
let bVec = [bEl | x <- [0..cFSize-1],
let bEl = if (elem (Point x y) ps)
then el
else fd `at` (Point x y)]]
-}
neighbours :: Point -> [Point]
neighbours p = p:map (inBoundsPos p) [pL,pR,pU,pD]
at :: Field -> Point -> Element
canvas `at` (Point x y) = (canvas !! y) !! x
modifyTVar :: Dist a => TVar a -> (a -> a) -> STM ()
modifyTVar t f = do
v <- readTVar t
writeTVar t (f v)
setSTMRepaintAll :: TVar [TVar Bool] -> STM ()
setSTMRepaintAll allRepaints = do
repaintsTVars <- readTVar allRepaints
mapM_ (flip writeTVar True) repaintsTVars
saveSetRepaintAll :: GameState -> IO ()
saveSetRepaintAll game = CE.catch (atomic $ do
repaintsTVars <- readTVar (repaints game)
mapM_ (flip writeTVar True) repaintsTVars
)(\(e::SomeDistTVarException) -> do
debugStrLn1 ("saveSetRepaintAll catch "++show e)
atomic $ do
proc $ debugStrLn1 ("saveSetRepaintAll catch atomic")
cleanupSTM e game
debugStrLn1 ("saveSetRepaintAll catch dyn: --- ")
saveSetRepaintAll game
debugStrLn1 ("saveSetRepaintAll catch dyn: <- ")
)
showSTMRepaintAll :: TVar [TVar Bool] -> STM [Bool]
showSTMRepaintAll allRepaints = do
proc $ debugStrLn6 ("showSTMRepaintAll")
repaintsTVars <- readTVar allRepaints
proc $ debugStrLn6 ("showSTMRepaintAll "++show repaintsTVars)
bs <- mapM readTVar repaintsTVars
proc $ debugStrLn6 ("showSTMRepaintAll end "++show bs)
return bs
showGameState :: GameState -> IO ()
showGameState g = atomic $ do
mv <- readTVar (move g)
proc $ debugStrLn6 ("TVar move= "++show (move g)++" move= "++show mv)
rp <- readTVar (repaint g)
proc $ debugStrLn6 ("TVar repaint= "++show (repaint g)++" repaint= "++show rp)
fd <- readTVar (field g)
proc $ debugStrLn6 ("TVar field= "++show (field g)++" field= "++show fd)
pl <- readTVar (player g)
proc $ debugStrLn6 ("TVar player= "++show (player g)++" player= "++show pl)
sl <- readTVar (slaves g)
proc $ debugStrLn6 ("TVar slaves= "++show (slaves g)++" slaves= "++show sl)
rs <- readTVar (repaints g)
proc $ debugStrLn6 ("TVar repaints= "++show (repaints g)++" repaints= "++show rs)
bs <- readTVar (bombs g)
proc $ debugStrLn6 ("TVar bombs= "++show (bombs g)++" bombs= "++show bs)
bl <- readTVar (blasts g)
proc $ debugStrLn6 ("TVar blasts= "++show (blasts g)++" blasts= "++show bl)
bc <- readTVar (bCounts g)
proc $ debugStrLn6 ("TVar bCounts= "++show (bCounts g)++" bCount= "++show bc)