diff --git a/labyrinth.cabal b/labyrinth.cabal --- a/labyrinth.cabal +++ b/labyrinth.cabal @@ -1,5 +1,5 @@ name: labyrinth -version: 0.3.0.0 +version: 0.4.0.0 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 @@ -23,13 +23,11 @@ , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9 , lens ==3.9.* - , 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.* @@ -44,45 +42,6 @@ , 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.9.* - , 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.* - , acid-state ==0.8.* - , yesod ==1.2.* - , yesod-static ==1.2.* - , websockets ==0.7.* - , wai-websockets ==1.3.* - , warp ==1.3.* - , utf8-string ==0.3.* - , aeson ==0.6.* - , shakespeare-css ==1.0.* - , shakespeare-js ==1.1.* - , hamlet ==1.1.* - hs-source-dirs: src - test-Suite tests type: exitcode-stdio-1.0 main-is: Main.hs @@ -90,13 +49,11 @@ , mtl ==2.1.* , template-haskell >= 2.7 && < 2.9 , lens ==3.9.* - , 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.* diff --git a/src/Labyrinth/Action.hs b/src/Labyrinth/Action.hs --- a/src/Labyrinth/Action.hs +++ b/src/Labyrinth/Action.hs @@ -165,28 +165,48 @@ transferAmmo maxAmount from to return () -pickBullets :: ActionState Int -pickBullets = do +pickInside :: ActionState Int -> ActionState Int +pickInside action = do pos <- use $ currentPlayer . position out <- gets $ isOutside pos if out then return 0 + else action + +pickBullets :: ActionState Int +pickBullets = pickInside $ do + pos <- use $ currentPlayer . position + health <- use $ currentPlayer . phealth + if health == Wounded + then use $ cell pos . cbullets else transferAmmo - (Just maxBullets) - (cell pos . cbullets) - (currentPlayer . pbullets) + (Just maxBullets) + (cell pos . cbullets) + (currentPlayer . pbullets) pickGrenades :: ActionState Int -pickGrenades = do +pickGrenades = pickInside $ do pos <- use $ currentPlayer . position - out <- gets $ isOutside pos - if out - then return 0 - else transferAmmo - (Just maxGrenades) - (cell pos . cgrenades) - (currentPlayer . pgrenades) + transferAmmo + (Just maxGrenades) + (cell pos . cgrenades) + (currentPlayer . pgrenades) +pickTreasures :: ActionState Int +pickTreasures = pickInside $ do + pos <- use $ currentPlayer . position + ctr <- use (cell pos . ctreasures) + let nctr = length ctr + health <- use $ currentPlayer . phealth + when (health == Healthy) $ do + ptr <- use (currentPlayer . ptreasure) + when (isNothing ptr && not (null ctr)) $ do + let ctr' = tail ctr + let ptr' = Just $ head ctr + cell pos . ctreasures .= ctr' + currentPlayer . ptreasure .= ptr' + return nctr + nextPit :: Monad m => Int -> LabState m Int nextPit i = do npits <- gets pitCount @@ -220,19 +240,11 @@ nct <- if isJust pos' then liftM Just $ use (cell npos . ctype) else return Nothing - let nctr = fmap ctResult nct - -- Pick ammo + let nctype = fmap ctResult nct 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) + ctr <- pickTreasures + return (ctResult ct, CellEvents cb cg ctr nctype) performMovement :: MoveDirection -> [Action] -> ActionState () performMovement (Towards dir) rest = let returnCont = returnContinue rest in do diff --git a/src/LabyrinthServer.hs b/src/LabyrinthServer.hs deleted file mode 100644 --- a/src/LabyrinthServer.hs +++ /dev/null @@ -1,245 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -module Main where - -import Control.Applicative -import Control.Concurrent -import Control.Exception (bracket) -import Control.Lens -import Control.Monad -import Control.Monad.IO.Class - -import Data.Acid ( AcidState - , EventResult - , EventState - , openLocalStateFrom - , QueryEvent - , UpdateEvent - ) -import Data.Acid.Advanced (query', update') -import Data.Acid.Local (createCheckpointAndClose) -import Data.Aeson -import qualified Data.ByteString.UTF8 as BSU -import Data.List -import qualified Data.Map as M -import Data.Maybe -import qualified Data.Text as T -import qualified Data.String as S - -import Network.Wai.Handler.Warp -import qualified Network.Wai.Handler.WebSockets as WaiWS -import qualified Network.WebSockets as WS - -import System.Environment -import System.FilePath.Posix -import System.Random - -import Text.Hamlet (hamletFile) -import Text.Julius (juliusFile) -import Text.Lucius (luciusFile) - -import Yesod hiding (update) -import Yesod.Static - -import Labyrinth hiding (performMove) - -import LabyrinthServer.Data - -newId :: (MonadIO m) => m String -newId = replicateM 32 $ liftIO $ randomRIO ('a', 'z') - -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" - -data WatchTarget = GameList | GameLog GameId - deriving (Eq, Ord) - -type WSType = WS.Hybi00 - -type WSSink = WS.Sink WSType - -data LabyrinthServer = LabyrinthServer { lsGames :: AcidState Games - , lsStatic :: Static - , lsWatchers :: MVar (M.Map WatchTarget [WSSink]) - } - -staticFiles "static" - -mkYesod "LabyrinthServer" [parseRoutes| -/ HomeR GET -/games GamesR GET -/game NewGameR POST -/game/#GameId GameR GET -/game/#GameId/move MakeMoveR POST -/game/#GameId/delete DeleteGameR DELETE -/examples ExampleMovesR GET -/static StaticR Static lsStatic -|] - -instance Yesod LabyrinthServer where - defaultLayout = mainLayout - -instance RenderMessage LabyrinthServer FormMessage where - renderMessage _ _ = defaultFormMessage - -postForm :: (Html -> MForm Handler (FormResult a, Widget)) - -> (a -> Handler Value) - -> Handler Value -postForm form handler = do - ((result, _), _) <- runFormPostNoToken form - case result of - FormSuccess value -> handler value - FormFailure errors -> returnJson errors - -main :: IO () -main = do - dataPath <- getDataPath - port <- liftM read $ envVarWithDefault "8080" "PORT" - ip <- envVarWithDefault "127.0.0.1" "OPENSHIFT_INTERNAL_IP" - static <- static "static" - bracket - (openLocalStateFrom dataPath noGames) - createCheckpointAndClose $ - \acid -> do - watchers <- newMVar M.empty - let server = LabyrinthServer acid static watchers - app <- toWaiApp server - let intercept = WaiWS.intercept $ wsHandler server - let settings = defaultSettings { settingsPort = port - , settingsHost = Host ip - , settingsIntercept = intercept - } - runSettings settings app - -wsHandler :: LabyrinthServer -> WS.Request -> WS.WebSockets WSType () -wsHandler site rq = do - let path = BSU.toString $ WS.requestPath rq - -- TODO: parse path better - let watch = if path == "/games" then GameList else GameLog $ drop 6 path - WS.acceptRequest rq - sink <- WS.getSink - addWatcher site watch sink - -addWatcher :: (MonadIO m) => LabyrinthServer -> WatchTarget -> WSSink -> m () -addWatcher site watch sink = - liftIO $ modifyMVar_ (lsWatchers site) $ \watchers -> - return $ M.insertWith (++) watch [sink] watchers - -query :: (QueryEvent event, EventState event ~ Games) - => event - -> Handler (EventResult event) -query ev = do - site <- getYesod - let acid = lsGames site - query' acid ev - -update :: (UpdateEvent event, EventState event ~ Games) - => WatchTarget - -> event - -> Handler (EventResult event) -update watch ev = do - site <- getYesod - let acid = lsGames site - res <- update' acid ev - notifyWatchers site watch - return res - -notifyWatchers :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m () -notifyWatchers site watch = liftIO $ withMVar (lsWatchers site) $ \watchersMap -> do - let watchers = fromMaybe [] $ M.lookup watch watchersMap - value <- watchTargetValue site watch - forM_ watchers $ \sink -> - WS.sendSink sink $ WS.textData $ encode value - -watchTargetValue :: (MonadIO m) => LabyrinthServer -> WatchTarget -> m Value -watchTargetValue site GameList = do - let acid = lsGames site - result <- query' acid GetGames - return $ toJSON result -watchTargetValue site (GameLog gameId) = do - let acid = lsGames site - result <- query' acid $ GetGame gameId - return $ toJSON result - -immediateResponse :: WatchTarget -> Handler Value -immediateResponse target = do - site <- getYesod - result <- watchTargetValue site target - returnJson result - -mainLayout :: Widget -> Handler Html -mainLayout widget = do - p <- widgetToPageContent widget - giveUrlRenderer $(hamletFile "templates/layout.hamlet") - -getHomeR :: Handler Html -getHomeR = defaultLayout $ do - addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/jquery/2.0.3/jquery.min.js" - addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/handlebars.js/1.0.0/handlebars.min.js" - toWidget $(juliusFile "templates/index.julius") - toWidget $(luciusFile "templates/index.lucius") - $(whamletFile "templates/index.hamlet") - -getGamesR :: Handler Value -getGamesR = immediateResponse GameList - -named :: T.Text -> FieldSettings LabyrinthServer -named name = FieldSettings "" Nothing Nothing (Just name) [] - -newGameForm :: Html - -> MForm Handler (FormResult LabyrinthParams, Widget) -newGameForm = renderDivs $ LabyrinthParams - <$> areq intField (named "width") Nothing - <*> areq intField (named "height") Nothing - <*> areq intField (named "players") Nothing - -postNewGameR :: Handler Value -postNewGameR = postForm newGameForm $ \params -> do - lab <- createLabyrinth params - gameId <- newId - res <- update GameList $ AddGame gameId lab - returnJson (if res then "ok" else "bad game" :: String) - -getGameR :: GameId -> Handler Value -getGameR gameId = immediateResponse (GameLog gameId) - -data PlayerMove = PlayerMove { pmplayer :: PlayerId - , pmmove :: T.Text - } - -makeMoveForm :: Html - -> MForm Handler (FormResult PlayerMove, Widget) -makeMoveForm = renderDivs $ PlayerMove - <$> areq intField (named "player") Nothing - <*> areq textField (named "move") Nothing - -postMakeMoveR :: GameId -> Handler Value -postMakeMoveR gameId = postForm makeMoveForm $ \playerMove -> do - let PlayerMove playerId moveStr = playerMove - case parseMove (T.unpack moveStr) of - Left err -> returnJson err - Right move -> do - res <- update (GameLog gameId) $ PerformMove gameId playerId move - returnJson $ show res - -deleteDeleteGameR :: GameId -> Handler Value -deleteDeleteGameR gameId = do - update GameList $ RemoveGame gameId - returnJson ("ok" :: String) - -getExampleMovesR :: Handler Value -getExampleMovesR = returnJson exampleMovesJSON diff --git a/src/LabyrinthServer/Data.hs b/src/LabyrinthServer/Data.hs deleted file mode 100644 --- a/src/LabyrinthServer/Data.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -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 qualified Data.Text as T -import Data.Typeable - -import System.Random - -import Yesod hiding (get, Update) - -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 - -data LabyrinthParams = LabyrinthParams { lpwidth :: Int - , lpheight :: Int - , lpplayers :: Int - } - -createLabyrinth :: (MonadIO m) => LabyrinthParams -> m Labyrinth -createLabyrinth p = do - gen <- liftIO getStdGen - let (l, gen') = generateLabyrinth - (lpwidth p) (lpheight p) (lpplayers p) gen - liftIO $ setStdGen gen' - return l - -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 - -removeGame :: GameId -> Update Games () -removeGame gid = stateUpdate $ zoom games $ do - modify $ M.delete gid - return () - -deriveSafeCopy 0 'base ''Games - -derive makeTypeable ''Games - -makeAcidic ''Games [ 'getGames - , 'addGame - , 'getGame - , 'performMove - , 'removeGame - ] - -exampleMoves :: [Move] -exampleMoves = [ ChoosePosition (Pos 2 4) - , Move [goTowards L] - , Move [Shoot U] - , Move [Grenade D, goTowards D] - , ReorderCell (Pos 3 3) - , Query [BulletCount, GrenadeCount, PlayerHealth] - , Say "hello" - , Move [Conditional "hit a wall" [Grenade D] [Shoot L]] - , Move [Surrender] - ] - -exampleMovesJSON :: Value -exampleMovesJSON = array $ map show exampleMoves - -instance ToJSON Labyrinth where - toJSON l = object $ [ "width" .= (l ^. labWidth) - , "height" .= (l ^. labHeight) - , "players" .= playerCount l - , "currentTurn" .= (l ^. currentTurn) - , "gameEnded" .= (l ^. gameEnded) - ] - ++ ["map" .= show l | l ^. gameEnded] - -instance ToJSON MoveRecord where - toJSON r = object [ "player" .= (r ^. rplayer) - , "move" .= show (r ^. rmove) - , "result" .= show (r ^. rresult) - ] - -instance ToJSON Game where - toJSON g = object [ "game" .= (g ^. labyrinth) - , "log" .= (g ^. moves) - ] - -instance ToJSON Games where - toJSON g = object [T.pack id .= game | (id, game) <- lst] - where lst = M.toList $ g ^. games