labyrinth 0.3.0.0 → 0.4.0.0
raw patch · 4 files changed
+37/−508 lines, 4 filesdep −acid-statedep −aesondep −filepath
Dependencies removed: acid-state, aeson, filepath, hamlet, shakespeare-css, shakespeare-js, text, utf8-string, wai-websockets, warp, websockets, yesod, yesod-static
Files
- labyrinth.cabal +1/−44
- src/Labyrinth/Action.hs +36/−24
- src/LabyrinthServer.hs +0/−245
- src/LabyrinthServer/Data.hs +0/−195
labyrinth.cabal view
@@ -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.*
src/Labyrinth/Action.hs view
@@ -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
− src/LabyrinthServer.hs
@@ -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
− src/LabyrinthServer/Data.hs
@@ -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