diff --git a/labyrinth.cabal b/labyrinth.cabal --- a/labyrinth.cabal +++ b/labyrinth.cabal @@ -1,5 +1,5 @@ name: labyrinth -version: 0.1.5.0 +version: 0.1.5.1 synopsis: A complicated turn-based game description: Players take turns in a labyrinth, competing with each other to pick a treasure and carry it out. They only know @@ -22,12 +22,49 @@ description: Link the binary statically default: False +library + build-depends: base >= 4.5 && < 4.7 + , mtl ==2.1.* + , template-haskell >= 2.7 && < 2.9 + , lens ==3.8.* + , filepath ==1.3.* + , derive ==2.5.* + , safecopy ==0.8.* + , parsec ==3.1.* + , containers >= 0.4 && < 0.6 + , random ==1.0.* + , text ==0.11.* + , transformers ==0.3.* + , MonadRandom ==0.1.* + , monad-loops ==0.3.* + hs-source-dirs: src + exposed-modules: Labyrinth + , Labyrinth.Action + , Labyrinth.Common + , Labyrinth.Generate + , Labyrinth.Map + , Labyrinth.Move + , Labyrinth.Reachability + , Labyrinth.Read + , Labyrinth.Show + executable labyrinth-server main-is: LabyrinthServer.hs + other-modules: LabyrinthServer.Data + , Labyrinth + , Labyrinth.Action + , Labyrinth.Common + , Labyrinth.Generate + , Labyrinth.Map + , Labyrinth.Move + , Labyrinth.Reachability + , Labyrinth.Read + , Labyrinth.Show build-depends: base >= 4.5 && < 4.7 , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9 , lens ==3.8.* + , filepath ==1.3.* , acid-state ==0.8.* , happstack-server ==7.1.* , derive ==2.5.* @@ -51,6 +88,7 @@ , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9 , lens ==3.8.* + , filepath ==1.3.* , acid-state ==0.8.* , happstack-server ==7.1.* , derive ==2.5.* diff --git a/src/Labyrinth.hs b/src/Labyrinth.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth.hs @@ -0,0 +1,12 @@ +module Labyrinth ( generateLabyrinth + , parseMove + , performMove + , module LabyrinthCombined + ) where + +import Labyrinth.Action (performMove) +import Labyrinth.Generate (generateLabyrinth) +import Labyrinth.Map as LabyrinthCombined +import Labyrinth.Move as LabyrinthCombined +import Labyrinth.Read (parseMove) +import Labyrinth.Show as LabyrinthCombined diff --git a/src/Labyrinth/Action.hs b/src/Labyrinth/Action.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Action.hs @@ -0,0 +1,438 @@ +{-# Language Rank2Types #-} + +module Labyrinth.Action where + +import Control.Lens hiding (Action) +import Control.Monad.State + +import Data.List +import Data.Maybe +import Data.Tuple + +import Labyrinth.Common +import Labyrinth.Map +import Labyrinth.Move +import Labyrinth.Show + +type ActionState a = LabState (State [ActionResult]) a + +putResult :: ActionResult -> ActionState () +putResult r = lift $ modify (++[r]) + +matchResult :: String -> ActionState Bool +matchResult str = lift $ gets $ any (isInfixOf str . show) + +returnContinue :: [Action] -> ActionResult -> ActionState () +returnContinue rest res = do + putResult res + performActions rest + +alwaysContinue :: [Action] -> ActionState ActionResult -> ActionState () +alwaysContinue rest act = do + res <- act + returnContinue rest res + +performMove :: PlayerId -> Move -> State Labyrinth MoveResult +performMove pi move = do + res <- state $ \s -> swap $ runState (execStateT (performMove' pi move) s) [] + return $ MoveRes res + +onlyWhenCurrent :: PlayerId -> ActionState () -> ActionState () +onlyWhenCurrent pi act = do + ended <- use gameEnded + if ended + then putResult WrongTurn + else do + current <- use currentTurn + if current /= pi + then putResult WrongTurn + else act + +onlyWhenChosen :: ActionState () -> ActionState () +onlyWhenChosen act = do + posChosen <- use positionsChosen + if not posChosen + then putResult InvalidMove + else act + +performMove' :: PlayerId -> Move -> ActionState () +performMove' pi (Move actions) = onlyWhenCurrent pi $ onlyWhenChosen $ + if length (filter isMovement actions) > 1 + then putResult InvalidMove + else do + currentPlayer . pjustShot .= False + performActions actions + next <- advancePlayer + case next of + (Just pi) -> do + justShot <- isFallen pi + when justShot $ putResult $ WoundedAlert pi Wounded + Nothing -> do + gameEnded .= True + putResult Draw + +performMove' pi (ChoosePosition pos) = onlyWhenCurrent pi $ do + out <- gets (isOutside pos) + posChosen <- use positionsChosen + if out || posChosen + then putResult InvalidMove + else do + currentPlayer . position .= pos + (Just next) <- advancePlayer + if next == 0 + then do + positionsChosen .= True + players <- alivePlayers + pos <- forM players $ \pi -> do + (ct, cr) <- cellActions True + advancePlayer + return $ StartR pi ct cr + putResult $ GameStarted pos + else + putResult $ ChoosePositionR ChosenOK + +performMove' pi (ReorderCell pos) = onlyWhenCurrent pi $ onlyWhenChosen $ do + out <- gets (isOutside pos) + if out + then putResult InvalidMove + else do + fell <- use $ currentPlayer . pjustShot + if not fell + then putResult InvalidMove + else do + currentPlayer . position .= pos + currentPlayer . pjustShot .= False + (ct, cr) <- cellActions True + putResult $ ReorderCellR $ ReorderOK ct cr + +performMove' pi (Query queries) = onlyWhenChosen $ performQueries pi queries + +performMove' _ (Say _) = return () + +advancePlayer :: ActionState (Maybe PlayerId) +advancePlayer = do + alive <- alivePlayers + if null alive + then return Nothing + else do + pi <- use currentTurn + players <- allPlayers + let queue = tail $ dropWhile (pi /=) $ cycle players + let advance (pi':ps) = do + alive <- playerAlive pi' + if alive + then return pi' + else do + justShot <- isFallen pi' + when justShot $ do + (player pi' . pjustShot) .= False + putResult $ WoundedAlert pi' Dead + advance ps + next <- advance queue + currentTurn .= next + return $ Just next + +isMovement :: Action -> Bool +isMovement (Go _) = True +isMovement _ = False + +performActions :: [Action] -> ActionState () +performActions [] = return () +performActions (act:rest) = case act of + Go dir -> performMovement dir rest + Grenade dir -> alwaysContinue rest $ performGrenade dir + Shoot dir -> alwaysContinue rest $ performShoot dir + Surrender -> performSurrender + cond@(Conditional{}) -> performConditional cond rest + +type AmmoLocation = Simple Lens Labyrinth Int + +transferAmmo :: Maybe Int -> AmmoLocation -> AmmoLocation -> ActionState Int +transferAmmo maxAmount from to = do + found <- use from + has <- use to + let amount = case maxAmount of + (Just max) -> min found $ max - has + Nothing -> found + let found' = found - amount + let has' = has + amount + from .= found' + to .= has' + return found + +transferAmmo_ :: Maybe Int -> AmmoLocation -> AmmoLocation -> ActionState () +transferAmmo_ maxAmount from to = do + transferAmmo maxAmount from to + return () + +pickBullets :: ActionState Int +pickBullets = do + pos <- use $ currentPlayer . position + out <- gets $ isOutside pos + if out + then return 0 + else transferAmmo + (Just maxBullets) + (cell pos . cbullets) + (currentPlayer . pbullets) + +pickGrenades :: ActionState Int +pickGrenades = do + pos <- use $ currentPlayer . position + out <- gets $ isOutside pos + if out + then return 0 + else transferAmmo + (Just maxGrenades) + (cell pos . cgrenades) + (currentPlayer . pgrenades) + +nextPit :: Monad m => Int -> LabState m Int +nextPit i = do + npits <- gets pitCount + return $ (i + 1) `mod` npits + +cellActions :: Bool -> ActionState (CellTypeResult, CellEvents) +cellActions moved = do + pos <- use (currentPlayer . position) + ct <- use (cell pos . ctype) + pos' <- case ct of + Land -> return Nothing + Armory -> do + currentPlayer . pbullets .= maxBullets + currentPlayer . pgrenades .= maxGrenades + return Nothing + Hospital -> do + currentPlayer . phealth .= Healthy + return Nothing + Pit i -> if not moved then return Nothing else do + i' <- nextPit i + pos' <- gets (pit i') + currentPlayer . position .= pos' + return $ Just pos' + River d -> do + let pos' = advance pos d + currentPlayer . position .= pos' + return $ Just pos' + RiverDelta -> return Nothing + let npos = fromMaybe pos pos' + -- If transported, determine the new cell type + nct <- if isJust pos' + then liftM Just $ use (cell npos . ctype) + else return Nothing + let nctr = fmap ctResult nct + -- Pick ammo + cb <- pickBullets + cg <- pickGrenades + -- Pick treasures + ctr <- use (cell npos . ctreasures) + ptr <- use (currentPlayer . ptreasure) + when (isNothing ptr && not (null ctr)) $ do + let ctr' = tail ctr + let ptr' = Just $ head ctr + cell npos . ctreasures .= ctr' + currentPlayer . ptreasure .= ptr' + return (ctResult ct, CellEvents cb cg (length ctr) nctr) + +performMovement :: MoveDirection -> [Action] -> ActionState () +performMovement (Towards dir) rest = let returnCont = returnContinue rest in do + pos <- use (currentPlayer . position) + let pos' = advance pos dir + out <- gets $ isOutside pos + out' <- gets $ isOutside pos' + if out && out' + then do + currentPlayer . phealth .= Dead + currentPlayer . pbullets .= 0 + currentPlayer . pgrenades .= 0 + putResult $ GoR LostOutside + else do + w <- use (wall pos dir) + if w == NoWall + then do + currentPlayer . position .= pos' + if out' + then do + t <- use (currentPlayer . ptreasure) + case t of + Nothing -> returnCont $ GoR $ WentOutside Nothing + (Just FakeTreasure) -> do + currentPlayer . ptreasure .= Nothing + returnCont $ GoR $ WentOutside $ Just TurnedToAshesR + (Just TrueTreasure) -> do + currentPlayer . ptreasure .= Nothing + gameEnded .= True + putResult $ GoR $ WentOutside $ Just TrueTreasureR + else do + (ct, cr) <- cellActions True + returnCont $ GoR $ Went ct cr + else do + (_, cr) <- cellActions False + returnCont $ GoR $ HitWall cr + +performMovement Next rest = alwaysContinue rest $ liftM GoR $ do + pos <- use (currentPlayer . position) + out <- gets $ isOutside pos + if out + then return InvalidMovement + else do + ct <- use (cell pos . ctype) + case ct of + Pit _ -> do + (ct, cr) <- cellActions True + return $ Went ct cr + River d -> do + (ct, cr) <- cellActions True + return $ Went ct cr + _ -> return InvalidMovement + +performGrenade :: Direction -> ActionState ActionResult +performGrenade dir = do + g <- use (currentPlayer . pgrenades) + if g > 0 + then do + currentPlayer . pgrenades -= 1 + pickGrenades + pos <- use (currentPlayer . position) + out <- gets $ isOutside pos + unless out $ do + ct <- use (cell pos . ctype) + when (ct == Armory) $ + currentPlayer . pgrenades .= maxGrenades + w <- use (wall pos dir) + when (w /= HardWall) $ + wall pos dir .= NoWall + return $ GrenadeR GrenadeOK + else + return $ GrenadeR NoGrenades + +performShoot :: Direction -> ActionState ActionResult +performShoot dir = do + b <- use (currentPlayer . pbullets) + if b > 0 + then do + pos <- use (currentPlayer . position) + ct <- use (cell pos . ctype) + if ct == Hospital || ct == Armory + then return $ ShootR Forbidden + else do + currentPlayer . pbullets -= 1 + pickBullets + res <- performShootFrom pos dir + return $ ShootR res + else + return $ ShootR NoBullets + +allPlayers :: Monad m => LabState m [PlayerId] +allPlayers = do + cnt <- gets playerCount + return [0..cnt - 1] + +alivePlayers :: Monad m => LabState m [PlayerId] +alivePlayers = do + players <- allPlayers + filterM playerAlive players + +playerAlive :: Monad m => PlayerId -> LabState m Bool +playerAlive i = do + ph <- use (player i . phealth) + return $ ph /= Dead + +playersAliveAt :: Monad m => Position -> LabState m [PlayerId] +playersAliveAt pos = do + alive <- alivePlayers + atPos <- filterM (playerAt pos) alive + filterM notFallen atPos + +playerAt :: Monad m => Position -> PlayerId -> LabState m Bool +playerAt pos i = do + pp <- use (player i . position) + return $ pos == pp + +isFallen :: Monad m => PlayerId -> LabState m Bool +isFallen i = use (player i . pjustShot) + +notFallen :: Monad m => PlayerId -> LabState m Bool +notFallen i = liftM not $ isFallen i + +performShootFrom :: Position -> Direction -> ActionState ShootResult +performShootFrom pos dir = do + outside <- gets $ isOutside pos + ct <- use (cell pos . ctype) + cnt <- gets playerCount + hit <- playersAliveAt pos + if not outside && ct == Hospital + then return ShootOK + else do + pi <- use currentTurn + let othersHit = delete pi hit + if null othersHit + then if outside || ct == Armory + then return ShootOK + else do + w <- use (wall pos dir) + if w == NoWall + then performShootFrom (advance pos dir) dir + else return ShootOK + else do + forM_ othersHit $ \i -> do + ph <- use (player i . phealth) + dropBullets i + dropTreasure i + when (ph == Wounded) $ dropGrenades i + player i . pjustShot .= True + player i . phealth %= pred + return Scream + +dropBullets :: PlayerId -> ActionState () +dropBullets i = do + pos <- use $ player i . position + outside <- gets $ isOutside pos + if outside + then (player i . pbullets) .= 0 + else transferAmmo_ Nothing (player i . pbullets) (cell pos . cbullets) + +dropGrenades :: PlayerId -> ActionState () +dropGrenades i = do + pos <- use $ player i . position + outside <- gets $ isOutside pos + if outside + then (player i . pgrenades) .= 0 + else transferAmmo_ Nothing (player i . pgrenades) (cell pos . cgrenades) + +dropTreasure :: PlayerId -> ActionState () +dropTreasure i = do + pos <- use $ player i . position + outside <- gets $ isOutside pos + tr <- (player i . ptreasure) <<.= Nothing + unless outside $ case tr of + Nothing -> return () + Just tr' -> (cell pos . ctreasures) %= (tr':) + +performSurrender :: ActionState () +performSurrender = do + i <- use currentTurn + dropBullets i + dropGrenades i + dropTreasure i + player i . phealth .= Dead + putResult Surrendered + +performConditional :: Action -> [Action] -> ActionState () +performConditional (Conditional cif cthen celse) rest = do + match <- matchResult cif + let branch = if match then cthen else celse + performActions $ branch ++ rest + +performQueries :: PlayerId -> [QueryType] -> ActionState () +performQueries pi = mapM_ (performQuery pi) + +performQuery :: PlayerId -> QueryType -> ActionState () +performQuery pi q = do + let p restype param = liftM restype $ use (player pi . param) + qr <- case q of + BulletCount -> p BulletCountR pbullets + GrenadeCount -> p GrenadeCountR pgrenades + PlayerHealth -> p HealthR phealth + TreasureCarried -> p (TreasureCarriedR . isJust) ptreasure + putResult $ QueryR qr diff --git a/src/Labyrinth/Common.hs b/src/Labyrinth/Common.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Common.hs @@ -0,0 +1,7 @@ +module Labyrinth.Common where + +import Control.Monad.State + +import Labyrinth.Map + +type LabState m a = StateT Labyrinth m a diff --git a/src/Labyrinth/Generate.hs b/src/Labyrinth/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Generate.hs @@ -0,0 +1,256 @@ +module Labyrinth.Generate where + +import Labyrinth.Common +import Labyrinth.Map +import Labyrinth.Reachability + +import Control.Lens hiding (allOf) +import Control.Monad.Loops +import Control.Monad.Random +import Control.Monad.Reader +import Control.Monad.State + +import Data.Functor.Identity +import qualified Data.Map as M +import Data.Maybe +import Data.Tuple + +generateLabyrinth :: RandomGen g => Int -> Int -> Int -> g -> (Labyrinth, g) +generateLabyrinth w h p = runRand $ execStateT generate $ emptyLabyrinth w h p + +type LabGen g a = LabState (Rand g) a + +type CellPredicate m = Position -> LabState m Bool + +type CellPredicateR g = CellPredicate (Rand g) + +isTypeF :: Monad m => (CellType -> Bool) -> CellPredicate m +isTypeF prop pos = do + ct <- use (cell pos . ctype) + return $ prop ct + +isType :: Monad m => CellType -> CellPredicate m +isType ct = isTypeF (ct ==) + +isLand :: Monad m => CellPredicate m +isLand = isType Land + +perimeter :: Labyrinth -> Int +perimeter l = (l ^. labWidth + l ^. labHeight) * 2 + +area :: Labyrinth -> Int +area l = l ^. labWidth * l ^. labHeight + +chooseRandomR :: RandomGen g => [a] -> LabGen g a +chooseRandomR [] = error "cannot generate anything!" +chooseRandomR l = do + i <- getRandomR (0, length l - 1) + return $ l !! i + +randomDirection :: RandomGen g => LabGen g Direction +randomDirection = chooseRandomR allDirections + +allOf :: Monad m => [a -> m Bool] -> a -> m Bool +allOf = flip $ \val -> liftM and . mapM ($ val) + +cellIf :: RandomGen g => CellPredicateR g -> LabGen g Position +cellIf prop = do + cells <- gets allPositions + good <- filterM prop cells + chooseRandomR good + +putCell :: RandomGen g => CellType -> LabGen g Position +putCell = putCellIf (return . const True) + +putCellIf :: RandomGen g => CellPredicateR g -> CellType -> LabGen g Position +putCellIf prop ct = do + pos <- cellIf $ allOf [isLand, prop] + cell pos . ctype .= ct + return pos + +neighbors :: Monad m => Position -> LabState m [Position] +neighbors p = filterM (gets . isInside) possibleNeighbors + where possibleNeighbors = map (advance p) allDirections + +allNeighbors :: Monad m => CellPredicate m -> CellPredicate m +allNeighbors prop pos = do + neigh <- neighbors pos + let neigh' = pos:neigh + res <- mapM prop neigh' + return $ and res + +isArmoryHospital :: Monad m => CellPredicate m +isArmoryHospital = isTypeF isAH + where isAH Armory = True + isAH Hospital = True + isAH _ = False + +putAH :: RandomGen g => CellType -> LabGen g Position +putAH = putCellIf noAHNearby + where noAHNearby = allNeighbors $ liftM not . isArmoryHospital + +putArmories :: RandomGen g => LabGen g () +putArmories = replicateM_ 2 $ putAH Armory + +putHospitals :: RandomGen g => LabGen g () +putHospitals = replicateM_ 2 $ putAH Hospital + +noTreasures :: Monad m => CellPredicate m +noTreasures pos = do + treasures <- use (cell pos . ctreasures) + return $ null treasures + +putTreasure :: RandomGen g => Treasure -> LabGen g () +putTreasure t = do + pos <- cellIf $ allOf [isLand, noTreasures] + cell pos . ctreasures .= [t] + +hasWall :: Monad m => Direction -> CellPredicate m +hasWall d p = do + wall <- use (wall p d) + return $ wall /= NoWall + +putExit :: RandomGen g => Wall -> LabGen g () +putExit w = do + outer <- gets outerPos + outer' <- filterM (allNeighbors noTreasures . fst) outer + outer'' <- filterM (uncurry hasWall . swap) outer + (p, d) <- chooseRandomR outer'' + wall p d .= w + +putExits :: RandomGen g => LabGen g () +putExits = do + p <- gets perimeter + let exits = p `div` 10 + replicateM_ exits $ putExit NoWall + replicateM_ exits $ putExit Wall + +putPits :: RandomGen g => LabGen g () +putPits = do + p <- gets perimeter + let pits = p `div` 4 + forM_ [0..pits - 1] $ putCell . Pit + +foldTimes :: Monad m => a -> Int -> (a -> m a) -> m a +foldTimes init times func = foldM func' init [1..times] + where func' x y = func x + +foldTimes_ :: Monad m => a -> Int -> (a -> m a) -> m () +foldTimes_ init times func = do + foldTimes init times func + return () + +putRivers :: RandomGen g => LabGen g () +putRivers = do + a <- gets area + deltas <- getRandomR (a `div` 12, a `div` 8) + replicateM_ deltas $ do + delta <- putCellIf hasLandAround RiverDelta + riverLen <- getRandomR (2, 5) + foldTimes_ delta riverLen $ \p -> do + landDirs <- filterM (landCellThere p) allDirections + if null landDirs + then return p + else do + d <- chooseRandomR landDirs + let p2 = advance p d + cell p2 . ctype .= River (opposite d) + return p2 + +hasLandAround :: Monad m => CellPredicate m +hasLandAround pos = do + haveLand <- mapM (landCellThere pos) allDirections + return $ or haveLand + +landCellThere :: Monad m => Position -> Direction -> LabState m Bool +landCellThere p d = do + let p2 = advance p d + inside <- gets $ isInside p2 + if inside + then isLand p2 + else return False + +putTreasures :: RandomGen g => LabGen g () +putTreasures = do + putTreasure TrueTreasure + pc <- gets playerCount + fakeTreasures <- getRandomR (1, pc) + replicateM_ fakeTreasures $ putTreasure FakeTreasure + +putWalls :: RandomGen g => LabGen g () +putWalls = do + a <- gets area + walls <- getRandomR (a `div` 4, a `div` 2) + forM_ [1..walls] $ \_ -> do + d <- randomDirection + pos <- cellIf $ allOf $ map ($ d) [ notRiver + , notToOutside + ] + wall pos d .= Wall + where + notRiver dir pos = do + ct1 <- use $ cell pos . ctype + if ct1 == River dir + then return False + else do + let pos2 = advance pos dir + let dir2 = opposite dir + inside <- gets $ isInside pos2 + if inside + then do + ct2 <- use $ cell pos2 . ctype + return $ ct2 /= River dir2 + else return True + notToOutside :: Monad m => Direction -> CellPredicate m + notToOutside dir pos = do + let pos2 = advance pos dir + gets $ isInside pos2 + +goodReachability :: Monad m => LabState m Bool +goodReachability = gets $ runReader $ do + n <- asks area + r <- asks (reachConverge $ n `div` 3) + pos <- asks allPositions + let res = map (\p -> M.findWithDefault False p r) pos + return $ and res + +goodDistribution :: Monad m => LabState m Bool +goodDistribution = gets $ runReader $ do + n <- asks area + r <- asks (converge $ n * 2) + let res = maximum $ M.elems r + return $ res <= 0.15 + +untilR :: MonadState v m => m Bool -> m a -> m () +untilR prop act = do + v <- get + untilM_ (put v >> act) prop + +untilRN :: MonadState v m => Int -> m Bool -> m a -> m Bool +untilRN 0 _ _ = return False +untilRN n prop act = do + v <- get + act + res <- prop + if res + then return True + else do + put v + untilRN (n - 1) prop act + +generate :: RandomGen g => LabGen g () +generate = do + untilRN 10 goodDistribution $ do + res <- untilRN 10 goodReachability $ do + putArmories + putHospitals + putPits + untilRN 50 goodReachability $ do + putRivers + putWalls + if res + then do + putTreasures + putExits + else error "cannot generate anything!" + return () diff --git a/src/Labyrinth/Map.hs b/src/Labyrinth/Map.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Map.hs @@ -0,0 +1,221 @@ +{-# Language TemplateHaskell, Rank2Types #-} +module Labyrinth.Map where + +import Control.Lens +import Control.Monad +import Control.Monad.State + +import Data.List +import Data.List.Lens +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid + +data Direction = L | R | U | D + deriving (Eq) + +allDirections :: [Direction] +allDirections = [L, R, U, D] + +opposite :: Direction -> Direction +opposite L = R +opposite R = L +opposite U = D +opposite D = U + +data CellType = Land + | Armory + | Hospital + | Pit { _pitNumber :: Int } + | River { _riverDirection :: Direction } + | RiverDelta + deriving (Eq) + +makeLenses ''CellType + +data Treasure = TrueTreasure | FakeTreasure + deriving (Eq) + +data Cell = Cell { _ctype :: CellType + , _cbullets :: Int + , _cgrenades :: Int + , _ctreasures :: [Treasure] + } + deriving (Eq) + +makeLenses ''Cell + +emptyCell :: CellType -> Cell +emptyCell ct = Cell { _ctype = ct + , _cbullets = 0 + , _cgrenades = 0 + , _ctreasures = [] + } + +data Wall = NoWall | Wall | HardWall + deriving (Eq) + +data Position = Pos { pX :: Int + , pY :: Int + } + deriving (Eq) + +instance Ord Position where + (Pos x1 y1) `compare` (Pos x2 y2) = + (y1 `compare` y2) `mappend` (x1 `compare` x2) + +instance Show Position where + show (Pos x y) = "(" ++ show x ++ ", " ++ show y ++ ")" + +advance :: Position -> Direction -> Position +advance (Pos x y) L = Pos (x - 1) y +advance (Pos x y) U = Pos x (y - 1) +advance (Pos x y) R = Pos (x + 1) y +advance (Pos x y) D = Pos x (y + 1) + +data Health = Dead | Wounded | Healthy + deriving (Eq, Enum) + +data Player = Player { _position :: Position + , _phealth :: Health + , _pbullets :: Int + , _pgrenades :: Int + , _ptreasure :: Maybe Treasure + , _pjustShot :: Bool + } + deriving (Eq) + +makeLenses ''Player + +maxBullets :: Int +maxBullets = 3 + +maxGrenades :: Int +maxGrenades = 3 + +initialPlayer :: Position -> Player +initialPlayer pos = Player { _position = pos + , _phealth = Healthy + , _pbullets = maxBullets + , _pgrenades = maxGrenades + , _ptreasure = Nothing + , _pjustShot = False + } + +type PlayerId = Int + +-- wallsV and wallsH are considered to be to the left and top of the cells +data Labyrinth = Labyrinth { _labWidth :: Int + , _labHeight :: Int + , _cells :: M.Map Position Cell + , _wallsH :: M.Map Position Wall + , _wallsV :: M.Map Position Wall + , _players :: [Player] + , _currentTurn :: PlayerId + , _positionsChosen :: Bool + , _gameEnded :: Bool + } + deriving (Eq) + +makeLenses ''Labyrinth + +isInside :: Position -> Labyrinth -> Bool +isInside (Pos x y) l = and [ x >= 0 + , x < w + , y >= 0 + , y < h + ] + where w = l ^. labWidth + h = l ^. labHeight + +isOutside :: Position -> Labyrinth -> Bool +isOutside p = not . isInside p + +outerPos :: Labyrinth -> [(Position, Direction)] +outerPos l = concat [ [(Pos x 0, U) | x <- [0..w - 1]] + , [(Pos x (h - 1), D) | x <- [0..w - 1]] + , [(Pos 0 y, L) | y <- [0..h - 1]] + , [(Pos (w - 1) y, R) | y <- [0..h - 1]] + ] + where w = l ^. labWidth + h = l ^. labHeight + +playerCount :: Labyrinth -> Int +playerCount = length . (^. players) + +posRectangle :: Int -> Int -> [Position] +posRectangle w h = [Pos x y | y <- [0..h - 1], x <- [0..w - 1]] + +mapRectangle :: a -> Int -> Int -> M.Map Position a +mapRectangle x w h = M.fromList $ zip (posRectangle w h) (repeat x) + +emptyLabyrinth :: Int -> Int -> Int -> Labyrinth +emptyLabyrinth w h playerCount = + let initialLab = Labyrinth { _labWidth = w + , _labHeight = h + , _cells = mapRectangle (emptyCell Land) w h + , _wallsH = mapRectangle NoWall w (h + 1) + , _wallsV = mapRectangle NoWall (w + 1) h + , _players = replicate playerCount $ initialPlayer $ Pos 0 0 + , _currentTurn = 0 + , _positionsChosen = False + , _gameEnded = False + } + in flip execState initialLab $ do + forM_ [0..w - 1] $ \x -> wall (Pos x 0) U .= HardWall + forM_ [0..w - 1] $ \x -> wall (Pos x (h - 1)) D .= HardWall + forM_ [0..h - 1] $ \y -> wall (Pos 0 y) L .= HardWall + forM_ [0..h - 1] $ \y -> wall (Pos (w - 1) y) R .= HardWall + +cell :: Position -> Simple Lens Labyrinth Cell +cell p = cells . ix' p + +wallH :: Position -> Simple Lens Labyrinth Wall +wallH p = wallsH . ix' p + +wallV :: Position -> Simple Lens Labyrinth Wall +wallV p = wallsV . ix' p + +wall :: Position -> Direction -> Simple Lens Labyrinth Wall +wall p U = wallH p +wall p L = wallV p +wall p D = wallH (advance p D) +wall p R = wallV (advance p R) + +ix' i = singular $ ix i + +player :: PlayerId -> Simple Lens Labyrinth Player +player i = players . ix' i + +currentPlayer :: Simple Lens Labyrinth Player +currentPlayer f l = player i f l + where i = l ^?! currentTurn + +allPositions :: Labyrinth -> [Position] +allPositions l = posRectangle w h + where w = l ^. labWidth + h = l ^. labHeight + +allCells :: Labyrinth -> [Cell] +allCells l = map (\p -> l ^?! cell p) $ allPositions l + +allPosCells :: Labyrinth -> [(Position, Cell)] +allPosCells l = zip (allPositions l) (allCells l) + +pitCount :: Labyrinth -> Int +pitCount = length . filter (isPit . _ctype) . allCells + +armories :: Labyrinth -> [Position] +armories = map fst . filter ((Armory ==) . _ctype . snd) . allPosCells + +pits :: Labyrinth -> [Position] +pits = map fst . filter (isPit . _ctype . snd) . allPosCells + +isPit :: CellType -> Bool +isPit (Pit _) = True +isPit _ = False + +pit :: Int -> Labyrinth -> Position +pit i = fst . fromJust . find (isIthPit . _ctype . snd) . allPosCells + where isIthPit (Pit j) = i == j + isIthPit _ = False diff --git a/src/Labyrinth/Move.hs b/src/Labyrinth/Move.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Move.hs @@ -0,0 +1,144 @@ +{-# Language TemplateHaskell #-} + +module Labyrinth.Move where + +import Control.Lens hiding (Action) + +import Labyrinth.Map + +data MoveDirection = Towards Direction | Next + deriving (Eq) + +type ActionCondition = String + +data Action = Go { _amdirection :: MoveDirection } + | Shoot { _asdirection :: Direction } + | Grenade { _agdirection :: Direction } + | Surrender + | Conditional { _acif :: ActionCondition + , _acthen :: [Action] + , _acelse :: [Action] + } + deriving (Eq) + +makeLenses ''Action + +goTowards :: Direction -> Action +goTowards = Go . Towards + +data QueryType = BulletCount + | GrenadeCount + | PlayerHealth + | TreasureCarried + deriving (Eq) + +data Move = Move { _mactions :: [Action] } + | ChoosePosition { _mcposition :: Position } + | ReorderCell { _mrposition :: Position } + | Query { _mqueries :: [QueryType] } + | Say { _msstext :: String } + deriving (Eq) + +makeLenses ''Move + +data CellTypeResult = LandR + | ArmoryR + | HospitalR + | PitR + | RiverR + | RiverDeltaR + deriving (Eq) + +ctResult :: CellType -> CellTypeResult +ctResult Land = LandR +ctResult Armory = ArmoryR +ctResult Hospital = HospitalR +ctResult (Pit _) = PitR +ctResult (River _) = RiverR +ctResult RiverDelta = RiverDeltaR + +data TreasureResult = TurnedToAshesR + | TrueTreasureR + deriving (Eq) + +data CellEvents = CellEvents { _foundBullets :: Int + , _foundGrenades :: Int + , _foundTreasures :: Int + , _transportedTo :: Maybe CellTypeResult + } deriving (Eq) + +makeLenses ''CellEvents + +noEvents :: CellEvents +noEvents = CellEvents { _foundBullets = 0 + , _foundGrenades = 0 + , _foundTreasures = 0 + , _transportedTo = Nothing + } + +data GoResult = Went { _onto :: CellTypeResult + , _wevents :: CellEvents + } + | WentOutside { _treasureResult :: Maybe TreasureResult + } + | HitWall { _hitr :: CellEvents + } + | LostOutside + | InvalidMovement + deriving (Eq) + +makeLenses ''GoResult + +data ShootResult = ShootOK + | Scream + | NoBullets + | Forbidden + deriving (Eq, Show) + +data GrenadeResult = GrenadeOK + | NoGrenades + deriving (Eq, Show) + +data ChoosePositionResult = ChosenOK + | ChooseAgain + deriving (Eq) + +data ReorderCellResult = ReorderOK { _ronto :: CellTypeResult + , _revents :: CellEvents + } + | ReorderForbidden {} + deriving (Eq) + +makeLenses ''ReorderCellResult + +data QueryResult = BulletCountR { _qrbullets :: Int } + | GrenadeCountR { _qrgrenades :: Int } + | HealthR { _qrhealth :: Health } + | TreasureCarriedR { _qrtreasure :: Bool } + deriving (Eq) + +makeLenses ''QueryResult + +data StartResult = StartR { _splayer :: PlayerId + , _scell :: CellTypeResult + , _sevents :: CellEvents + } deriving (Eq) + +makeLenses ''StartResult + +data ActionResult = GoR GoResult + | ShootR ShootResult + | GrenadeR GrenadeResult + | Surrendered + | WoundedAlert PlayerId Health + | ChoosePositionR ChoosePositionResult + | ReorderCellR ReorderCellResult + | QueryR QueryResult + | GameStarted [StartResult] + | Draw + | WrongTurn + | InvalidMove + deriving (Eq) + +data MoveResult = MoveRes [ActionResult] + deriving (Eq) diff --git a/src/Labyrinth/Reachability.hs b/src/Labyrinth/Reachability.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Reachability.hs @@ -0,0 +1,124 @@ +module Labyrinth.Reachability where + +import Control.Lens +import Control.Monad.Reader + +import Data.Function +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid + +import Labyrinth.Map + +type PositionMap a = M.Map Position a + +type Connectivity = PositionMap [Position] + +type Distribution = PositionMap Double + +type Reachability = PositionMap Bool + +nextCell :: Position -> Reader Labyrinth Position +nextCell pos = do + ct <- view $ cell pos . ctype + case ct of + River d -> return $ advance pos d + Pit i -> do + npits <- asks pitCount + let i' = (i + 1) `mod` npits + asks (pit i') + _ -> return pos + +-- A list of positions player can go from a given cell +reachable :: Position -> Reader Labyrinth [Position] +reachable pos = do + dirs <- filterM (liftM (NoWall ==) . view . wall pos) allDirections + let npos = pos : map (advance pos) dirs + npos' <- filterM (asks . isInside) npos + npos'' <- forM npos' nextCell + return $ nub npos'' + +connectivity :: Labyrinth -> Connectivity +connectivity = runReader $ do + pos <- asks allPositions + posReach <- mapM reachable pos + return $ M.fromList $ zip pos posReach + +insertAppend :: (Ord k) => k -> v -> M.Map k [v] -> M.Map k [v] +insertAppend k v = M.alter (addToList v) k + where addToList v = Just . (v :) . fromMaybe [] + +inverse :: (Ord a, Ord b) => M.Map a [b] -> M.Map b [a] +inverse = M.foldWithKey insertAll M.empty + where insertAll k vs m = foldr (`insertAppend` k) m vs + +foldConcat :: (Monoid v) => M.Map k [v] -> M.Map k v +foldConcat = M.map mconcat + +distribute :: (Ord k, Monoid v) => M.Map k [k] -> M.Map k v -> M.Map k v +distribute dist = foldConcat . M.foldWithKey insertAll M.empty + where insertAll k v m = foldr (`insertAppend` v) m k2s + where k2s = M.findWithDefault [] k dist + +distributeN :: (Ord k, Monoid v) => Int -> M.Map k [k] -> M.Map k v -> M.Map k v +distributeN n dist init = foldr distribute init $ replicate n dist + +distributeU :: (Ord k, Monoid v, Eq v) => M.Map k [k] -> M.Map k v -> M.Map k v +distributeU dist init = + if next == init then init else distributeU dist next + where next = distribute dist init + +normalize :: (Fractional v) => M.Map k v -> M.Map k v +normalize m = M.map norm m + where norm = (/ s) + s = sum $ M.elems m + +converge :: Int -> Labyrinth -> Distribution +converge n l = normalize $ M.map getSum $ distributeN n conn init + where conn = connectivity l + pos = allPositions l + init = uniformBetween (Sum 1) pos + +reachConverge :: Int -> Labyrinth -> Reachability +reachConverge n l = M.map getAny $ distributeN n conn init + where conn = inverse $ connectivity l + init = armoriesDist l + +reachConvergeU :: Labyrinth -> Reachability +reachConvergeU l = M.map getAny $ distributeU conn init + where conn = inverse $ connectivity l + init = armoriesDist l + +uniformBetween :: a -> [Position] -> PositionMap a +uniformBetween x pos = M.fromList $ zip pos $ repeat x + +armoriesDist :: Labyrinth -> PositionMap Any +armoriesDist = uniformBetween (Any True) . armories + +maxKeyBy :: (Ord n) => (k -> n) -> M.Map k a -> n +maxKeyBy prop = maximum . M.keys . M.mapKeys prop + +showReach :: Reachability -> String +showReach = showGrid showReachValue + where showReachValue = pad 2 ' ' . showR . fromMaybe False + showR True = "*" + showR False = "." + +showDist :: Distribution -> String +showDist = showGrid showDistValue + where showDistValue = pad 2 ' ' . show . round . (100 *) . fromMaybe 0 + +showGrid :: (Maybe a -> String) -> PositionMap a -> String +showGrid s g = intercalate "\n" $ flip map [0..maxY] $ showGridLine s g + where maxY = maxKeyBy pY g + +showGridLine :: (Maybe a -> String) -> PositionMap a -> Int -> String +showGridLine s g y = unwords $ flip map [0..maxX] $ showGridPos s g y + where maxX = maxKeyBy pX g + +showGridPos :: (Maybe a -> String) -> PositionMap a -> Int -> Int -> String +showGridPos s g y x = s $ M.lookup (Pos x y) g + +pad :: Int -> a -> [a] -> [a] +pad n c l = replicate d c ++ l where d = max 0 $ n - length l diff --git a/src/Labyrinth/Read.hs b/src/Labyrinth/Read.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Read.hs @@ -0,0 +1,161 @@ +module Labyrinth.Read where + +import Labyrinth.Map +import Labyrinth.Move + +import Control.Monad + +import Text.Parsec +import Text.Parsec.Language +import Text.Parsec.String (Parser) +import qualified Text.Parsec.Token as T + +parseMove :: String -> Either String Move +parseMove str = case parse moveParser "" str of + Right m -> Right m + Left err -> Left $ show err + +stringResult :: String -> a -> Parser a +stringResult s v = do + string s + return v + +spaces1 :: Parser () +spaces1 = skipMany1 space + +commaSpaces :: Parser () +commaSpaces = do + char ',' + spaces + +moveParser :: Parser Move +moveParser = do + spaces + m <- emptyMove + <|> choosePosition + <|> reorderCell + <|> liftM Move actions + <|> queriesParser + <|> sayParser + spaces + eof + return m + +emptyMove :: Parser Move +emptyMove = do + try $ string "skip" + return $ Move [] + +choosePosition :: Parser Move +choosePosition = do + try $ string "choose" + spaces1 + pos <- positionParser + return $ ChoosePosition pos + +reorderCell :: Parser Move +reorderCell = do + try $ string "reorder" + spaces1 + pos <- positionParser + return $ ReorderCell pos + +positionParser :: Parser Position +positionParser = do + x <- integer + spaces + y <- integer + return $ Pos x y + +integer :: Parser Int +integer = liftM fromInteger $ T.integer (T.makeTokenParser emptyDef) + +actions :: Parser [Action] +actions = sepBy1 action commaSpaces + +action :: Parser Action +action = choice $ map try [ goAction + , grenadeAction + , shootAction + , surrenderAction + , conditionalAction + ] + +goAction :: Parser Action +goAction = do + string "go" <|> string "move" + spaces1 + choice [ goNext + , goDirection + ] + where goNext = stringResult "next" $ Go Next + goDirection = do + d <- direction + return $ goTowards d + +grenadeAction :: Parser Action +grenadeAction = do + string "grenade" + spaces1 + d <- direction + return $ Grenade d + +shootAction :: Parser Action +shootAction = do + string "shoot" + spaces1 + d <- direction + return $ Shoot d + +surrenderAction :: Parser Action +surrenderAction = stringResult "surrender" Surrender + +direction :: Parser Direction +direction = choice [ stringResult "left" L + , stringResult "right" R + , stringResult "up" U + , stringResult "down" D + ] + +conditionalPart :: Parser [Action] +conditionalPart = do + spaces + a <- sepBy action commaSpaces + spaces + char '}' + return a + +conditionalAction :: Parser Action +conditionalAction = do + string "if" + spaces + ifPart <- manyTill (satisfy ('{' /=)) $ try openBracket + thenPart <- conditionalPart + spaces + elsePart <- choice [ do + string "else" + openBracket + conditionalPart + , return [] + ] + return $ Conditional ifPart thenPart elsePart + where openBracket = spaces >> char '{' + +queriesParser :: Parser Move +queriesParser = do + string "query" + spaces1 + liftM Query $ sepBy1 queryParser commaSpaces + +queryParser :: Parser QueryType +queryParser = choice [ stringResult "bullets" BulletCount + , stringResult "grenades" GrenadeCount + , stringResult "health" PlayerHealth + , stringResult "treasure" TreasureCarried + ] + +sayParser :: Parser Move +sayParser = do + string "say" + space + liftM Say $ many anyChar diff --git a/src/Labyrinth/Show.hs b/src/Labyrinth/Show.hs new file mode 100644 --- /dev/null +++ b/src/Labyrinth/Show.hs @@ -0,0 +1,272 @@ +module Labyrinth.Show where + +import Labyrinth.Map +import Labyrinth.Move + +import Control.Lens hiding (Action) +import Control.Monad.Reader +import Control.Monad.Writer + +import Data.List +import Data.Maybe + +data Definite = Definite | Indefinite + +pluralize :: (Eq a, Integral a, Show a) => Definite -> a -> String -> String +pluralize Indefinite 1 str = "a " ++ str +pluralize _ n str = show n ++ " " ++ str ++ ending (abs n) + where ending n | n0 == 1 && n1 /= 1 = "" + | otherwise = "s" + where n0 = n `mod` 10 + n1 = n `div` 10 `mod` 10 + +instance Show CellType where + show Land = "." + show Armory = "A" + show Hospital = "H" + show (Pit i) = show (i + 1) + show (River L) = "<" + show (River R) = ">" + show (River U) = "^" + show (River D) = "v" + show RiverDelta = "O" + +instance Show Cell where + show c = show (_ctype c) ++ " " + +instance Show Treasure where + show TrueTreasure = "true treasure" + show FakeTreasure = "fake treasure" + +instance Show Health where + show Healthy = "healthy" + show Wounded = "wounded" + show Dead = "dead" + +instance Show Player where + show p = execWriter $ flip runReaderT p $ do + tell "Player " + pos <- view position + tell $ show pos + tell ", " + b <- view pbullets + tell $ show b + tell "B" + tell ", " + g <- view pgrenades + tell $ show g + tell "G" + h <- view phealth + when (h /= Healthy) $ do + tell ", " + tell $ show h + f <- view pjustShot + when f $ + tell ", just shot" + +showH :: Wall -> String +showH NoWall = " " +showH Wall = "--" +showH HardWall = "==" + +showV :: Wall -> String +showV NoWall = " " +showV Wall = "|" +showV HardWall = "X" + +showWallLine :: Labyrinth -> Int -> String +showWallLine l y = mk ++ intercalate mk ws ++ mk + where mk = "+" + w = l ^. labWidth + ws = map (\x -> showH $ l ^?! wallH (Pos x y)) [0..w - 1] + +showCellLine :: Labyrinth -> Int -> String +showCellLine l y = concatMap (\x -> showVWall l (Pos x y) ++ showCell l (Pos x y)) [0..w - 1] + ++ showVWall l (Pos w y) + where w = l ^. labWidth + showVWall :: Labyrinth -> Position -> String + showVWall l p = showV $ l ^?! wallV p + showCell :: Labyrinth -> Position -> String + showCell l p = show $ l ^?! cell p + +showMap :: Labyrinth -> [String] +showMap l = firstLines ++ [lastLine] + where h = l ^. labHeight + showLine l i = [showWallLine l i, showCellLine l i] + firstLines = concatMap (showLine l) [0..h - 1] + lastLine = showWallLine l h + +showPlayers :: Labyrinth -> [String] +showPlayers l = zipWith showPlayer (l ^. players) [0..] + where showPlayer p i = show i ++ ": " ++ show p + +showCurrentPlayer :: Labyrinth -> [String] +showCurrentPlayer l = ["Current player: " ++ show (l ^. currentTurn)] + +showItems :: Labyrinth -> [String] +showItems = concatMap showCellItemsOn . allPosCells + where showCellItemsOn (p, c) = if itemStr == "" then [] else [showStr] + where itemStr = showCellItems c + showStr = show p ++ ": " ++ itemStr + +showCellItems :: Cell -> String +showCellItems c = intercalate ", " $ execWriter $ flip runReaderT c $ do + b <- view cbullets + when (b > 0) $ tell [show b ++ "B"] + g <- view cgrenades + when (g > 0) $ tell [show g ++ "G"] + t <- view ctreasures + tell $ map show t + +showStatus :: Labyrinth -> [String] +showStatus l = execWriter $ flip runReaderT l $ do + pc <- view positionsChosen + unless pc $ tell ["Positions not chosen"] + end <- view gameEnded + when end $ tell ["Game ended"] + +instance Show Labyrinth where + show l = intercalate "\n" $ concat parts + where parts = map ($ l) [ showMap + , const [""] + , showPlayers + , showCurrentPlayer + , showItems + , showStatus + ] + +instance Show Direction where + show L = "left" + show R = "right" + show U = "up" + show D = "down" + +instance Show MoveDirection where + show (Towards d) = show d + show Next = "next" + +sepShow :: Show a => Char -> [a] -> String +sepShow sep = intercalate (sep:" ") . map show + +commaSepShow :: Show a => [a] -> String +commaSepShow = sepShow ',' + +instance Show Action where + show (Go d) = "go " ++ show d + show (Shoot d) = "shoot " ++ show d + show (Grenade d) = "grenade " ++ show d + show Surrender = "surrender" + show (Conditional cif cthen celse) = + "if " ++ cif ++ " { " ++ commaSepShow cthen ++ showElse celse ++ " }" + where showElse [] = "" + showElse x = " } else { " ++ commaSepShow x + +instance Show QueryType where + show BulletCount = "bullets" + show GrenadeCount = "grenades" + show PlayerHealth = "health" + show TreasureCarried = "treasure" + +instance Show Move where + show (Move []) = "skip" + show (Move acts) = commaSepShow acts + show (Query qs) = "query " ++ commaSepShow qs + show (ChoosePosition _) = "[choose position]" + show (ReorderCell _) = "[reorder cell]" + show (Say str) = "say " ++ str + +instance Show CellTypeResult where + show LandR = "land" + show ArmoryR = "armory" + show HospitalR = "hospital" + show PitR = "pit" + show RiverR = "river" + show RiverDeltaR = "delta" + +instance Show CellEvents where + show r = execWriter $ do + let transported = r ^. transportedTo + when (isJust transported) $ do + tell ", was transported to " + tell $ show $ fromJust transported + let b = r ^. foundBullets + let g = r ^. foundGrenades + let t = r ^. foundTreasures + let found = b > 0 || g > 0 || t > 0 + when found $ do + tell ", found " + tell $ + commaList $ + map (uncurry (pluralize Indefinite)) $ + filter ((0 <) . fst) + [(b, "bullet"), (g, "grenade"), (t, "treasure")] + return () + where commaList [] = "" + commaList [x] = x + commaList xs = intercalate ", " (take (n - 1) xs) + ++ " and " ++ xs !! (n - 1) + where n = length xs + +instance Show ActionResult where + show (GoR (HitWall cr)) = "hit a wall" ++ show cr + show (GoR (Went ct cr)) = "went onto " ++ show ct ++ show cr + show (GoR went@WentOutside{}) = execWriter $ do + tell "went outside" + let tr = went ^?! treasureResult + case tr of + Just TurnedToAshesR -> tell ", treasure turned to ashes" + Just TrueTreasureR -> tell " with a true treasure - victory" + Nothing -> return () + return () + show (GoR InvalidMovement) = "invalid movement" + show (GoR LostOutside) = "lost outside" + + show (ShootR ShootOK) = "ok" + show (ShootR Scream) = "a scream is heard" + show (ShootR NoBullets) = "no bullets" + show (ShootR Forbidden) = "shooting forbidden" + + show (GrenadeR GrenadeOK) = "ok" + show (GrenadeR NoGrenades) = "no grenades" + + show Surrendered = "surrendered" + + show (WoundedAlert pi h) = "player " ++ show pi ++ " is " ++ show h + + show (ChoosePositionR cpr) = show cpr + show (ReorderCellR cr) = show cr + + show (QueryR qr) = show qr + + show (GameStarted rs) = "game started; " ++ sepShow ';' rs + + show Draw = "game ended with a draw" + + show WrongTurn = "wrong turn" + show InvalidMove = "invalid move" + +instance Show ChoosePositionResult where + show ChosenOK = "position chosen" + show ChooseAgain = "positions chosen invalid, choose again" + +instance Show ReorderCellResult where + show (ReorderOK ct cr) = "cell re-ordered, went onto " ++ show ct ++ show cr + show ReorderForbidden = "cannot re-order cell" + +instance Show QueryResult where + show (BulletCountR n) = pluralize Definite n "bullet" + show (GrenadeCountR n) = pluralize Definite n "grenade" + show (HealthR h) = show h + show (TreasureCarriedR True) = "treasure" + show (TreasureCarriedR False) = "no treasure" + +instance Show StartResult where + show (StartR pi ct cr) = "player " ++ show pi + ++ " started at " ++ show ct ++ show cr + +showActResults :: [ActionResult] -> String +showActResults [] = "ok" +showActResults rs = commaSepShow rs + +instance Show MoveResult where + show (MoveRes rs) = showActResults rs diff --git a/src/LabyrinthServer.hs b/src/LabyrinthServer.hs --- a/src/LabyrinthServer.hs +++ b/src/LabyrinthServer.hs @@ -18,6 +18,7 @@ import qualified Text.JSON as J import System.Environment +import System.FilePath.Posix import System.Random import Labyrinth hiding (performMove) @@ -34,21 +35,31 @@ newId :: (MonadIO m) => m String newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z') -getPort :: IO Int -getPort = do - env <- getEnvironment - let envMap = M.fromList env - let port = M.lookup "PORT" envMap - let port' = fromMaybe "8000" port - return $ read port' +envVar :: String -> IO (Maybe String) +envVar var = do + env <- liftM M.fromList getEnvironment + return $ M.lookup var env +envVarWithDefault :: String -> String -> IO String +envVarWithDefault def var = + liftM (fromMaybe def) (envVar var) + +getDataPath :: IO String +getDataPath = do + dataDir <- envVarWithDefault "." "OPENSHIFT_DATA_DIR" + return $ dataDir "state" + main :: IO () main = do - port <- getPort - let conf = nullConf { port = port } + ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP" + port_ <- liftM read $ envVarWithDefault "8080" "PORT" + dataPath <- getDataPath + let conf = nullConf { port = port_ } bracket (openLocalState noGames) createCheckpointAndClose - (simpleHTTP conf . myApp) + $ \acid -> do + socket <- bindIPv4 ip (port conf) + simpleHTTPWithSocket socket conf $ myApp acid myApp :: AcidState Games -> ServerPart Response myApp acid = msum (map ($ acid) actions) `mplus` fileServing diff --git a/src/LabyrinthServer/Data.hs b/src/LabyrinthServer/Data.hs new file mode 100644 --- /dev/null +++ b/src/LabyrinthServer/Data.hs @@ -0,0 +1,167 @@ +{-# Language DeriveDataTypeable, TemplateHaskell, TypeFamilies, Rank2Types #-} + +module LabyrinthServer.Data where + +import Control.Lens hiding (Action) +import Control.Monad.State +import Control.Monad.Reader (ask) + +import Data.Acid (Query, Update, makeAcidic) +import Data.DeriveTH +import Data.Derive.Typeable +import qualified Data.Map as M +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Typeable + +import Text.JSON + +import Labyrinth hiding (performMove) +import qualified Labyrinth as L + +deriveSafeCopy 0 'base ''Direction +deriveSafeCopy 0 'base ''Wall +deriveSafeCopy 0 'base ''CellType +deriveSafeCopy 0 'base ''Cell +deriveSafeCopy 0 'base ''Position +deriveSafeCopy 0 'base ''Treasure +deriveSafeCopy 0 'base ''Health +deriveSafeCopy 0 'base ''Player +deriveSafeCopy 0 'base ''Labyrinth + +deriveSafeCopy 0 'base ''Action +deriveSafeCopy 0 'base ''MoveDirection +deriveSafeCopy 0 'base ''QueryType +deriveSafeCopy 0 'base ''Move + +deriveSafeCopy 0 'base ''CellTypeResult +deriveSafeCopy 0 'base ''TreasureResult +deriveSafeCopy 0 'base ''CellEvents +deriveSafeCopy 0 'base ''GoResult +deriveSafeCopy 0 'base ''GrenadeResult +deriveSafeCopy 0 'base ''ShootResult +deriveSafeCopy 0 'base ''ActionResult +deriveSafeCopy 0 'base ''ChoosePositionResult +deriveSafeCopy 0 'base ''ReorderCellResult +deriveSafeCopy 0 'base ''QueryResult +deriveSafeCopy 0 'base ''StartResult +deriveSafeCopy 0 'base ''MoveResult + +derive makeTypeable ''Labyrinth +derive makeTypeable ''Move +derive makeTypeable ''MoveResult + +type GameId = String + +data MoveRecord = MoveRecord { _rplayer :: PlayerId + , _rmove :: Move + , _rresult :: MoveResult + } + +makeLenses ''MoveRecord + +deriveSafeCopy 0 'base ''MoveRecord + +derive makeTypeable ''MoveRecord + +type MoveLog = [MoveRecord] + +logMoveResult :: MoveRecord -> State MoveLog () +logMoveResult m = modify (++ [m]) + +data Game = Game { _labyrinth :: Labyrinth + , _moves :: MoveLog + } + +newGame :: Labyrinth -> Game +newGame l = Game l [] + +makeLenses ''Game + +deriveSafeCopy 0 'base ''Game + +derive makeTypeable ''Game + +data Games = Games { _games :: M.Map GameId Game } + +noGames :: Games +noGames = Games M.empty + +makeLenses ''Games + +game :: GameId -> Simple Traversal Games Game +game gid = games . ix gid + +getGames :: Query Games Games +getGames = ask + +stateUpdate :: State x y -> Update x y +stateUpdate f = do + st <- get + let (r, st') = runState f st + put st' + return r + +addGame :: GameId -> Labyrinth -> Update Games Bool +addGame gid lab = stateUpdate $ zoom games $ do + existing <- gets (M.member gid) + if existing + then return False + else do + modify $ M.insert gid $ newGame lab + return True + +getGame :: GameId -> Query Games Game +getGame = view . singular . game + +performMove :: GameId -> PlayerId -> Move -> Update Games MoveResult +performMove g p m = stateUpdate $ zoom (singular $ game g) $ do + r <- zoom labyrinth $ L.performMove p m + zoom moves $ logMoveResult $ MoveRecord p m r + return r + +deriveSafeCopy 0 'base ''Games + +derive makeTypeable ''Games + +makeAcidic ''Games [ 'getGames + , 'addGame + , 'getGame + , 'performMove + ] + +logJSON :: MoveLog -> JSValue +logJSON g = JSArray $ map moveJSON g + where moveJSON l = jsObject [ ("player", jsInt $ l ^. rplayer) + , ("move", jsShow $ l ^. rmove) + , ("result", jsShow $ l ^. rresult) + ] + +gameInfoJSON :: Game -> JSValue +gameInfoJSON g = jsObject prop + where prop = [ ("width", jsInt $ l ^. labWidth) + , ("height", jsInt $ l ^. labHeight) + , ("players", jsInt $ playerCount l) + , ("currentTurn", jsInt $ l ^. currentTurn) + , ("gameEnded", jsBool $ l ^. gameEnded) + ] ++ mapProp + mapProp = [("map", jsShow l) | l ^. gameEnded] + l = g ^. labyrinth + +gameListJSON :: Games -> JSValue +gameListJSON = jsObject . M.toList . M.map gameInfoJSON . view games + +gameJSON :: Game -> JSValue +gameJSON g = jsObject [("game", gameInfoJSON g), ("log", logJSON m)] + where m = g ^. moves + +jsObject :: [(String, JSValue)] -> JSValue +jsObject = JSObject . toJSObject + +jsInt :: Int -> JSValue +jsInt = JSRational False . fromIntegral + +jsBool :: Bool -> JSValue +jsBool = JSBool + +jsShow :: (Show a) => a -> JSValue +jsShow = JSString . toJSString . show