labyrinth 0.1.5.0 → 0.1.5.1
raw patch · 12 files changed
+1862/−11 lines, 12 filesdep +filepath
Dependencies added: filepath
Files
- labyrinth.cabal +39/−1
- src/Labyrinth.hs +12/−0
- src/Labyrinth/Action.hs +438/−0
- src/Labyrinth/Common.hs +7/−0
- src/Labyrinth/Generate.hs +256/−0
- src/Labyrinth/Map.hs +221/−0
- src/Labyrinth/Move.hs +144/−0
- src/Labyrinth/Reachability.hs +124/−0
- src/Labyrinth/Read.hs +161/−0
- src/Labyrinth/Show.hs +272/−0
- src/LabyrinthServer.hs +21/−10
- src/LabyrinthServer/Data.hs +167/−0
labyrinth.cabal view
@@ -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.*
+ src/Labyrinth.hs view
@@ -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
+ src/Labyrinth/Action.hs view
@@ -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
+ src/Labyrinth/Common.hs view
@@ -0,0 +1,7 @@+module Labyrinth.Common where++import Control.Monad.State++import Labyrinth.Map++type LabState m a = StateT Labyrinth m a
+ src/Labyrinth/Generate.hs view
@@ -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 ()
+ src/Labyrinth/Map.hs view
@@ -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
+ src/Labyrinth/Move.hs view
@@ -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)
+ src/Labyrinth/Reachability.hs view
@@ -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
+ src/Labyrinth/Read.hs view
@@ -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
+ src/Labyrinth/Show.hs view
@@ -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
src/LabyrinthServer.hs view
@@ -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
+ src/LabyrinthServer/Data.hs view
@@ -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