Ninjas (empty) → 0.1.0.0
raw patch · 29 files changed
+1295/−0 lines, 29 filesdep +basedep +binarydep +bytestringsetup-changedbinary-added
Dependencies added: base, binary, bytestring, containers, filepath, gloss, network, networked-game, random
Files
- Ninjas.cabal +40/−0
- Setup.hs +2/−0
- images/attack1.bmp binary
- images/attack2.bmp binary
- images/attack3.bmp binary
- images/attack4.bmp binary
- images/death1.bmp binary
- images/death2.bmp binary
- images/smoke1.bmp binary
- images/smoke2.bmp binary
- images/smoke3.bmp binary
- images/smoke4.bmp binary
- images/smoke5.bmp binary
- images/smoke6.bmp binary
- images/stay1.bmp binary
- images/stunned1.bmp binary
- images/tower1.bmp binary
- images/walk1.bmp binary
- images/walk2.bmp binary
- images/walk3.bmp binary
- images/walk4.bmp binary
- src/Anim.hs +113/−0
- src/Character.hs +122/−0
- src/Client.hs +267/−0
- src/Main.hs +81/−0
- src/NetworkMessages.hs +126/−0
- src/Parameters.hs +53/−0
- src/Server.hs +380/−0
- src/Simulation.hs +111/−0
+ Ninjas.cabal view
@@ -0,0 +1,40 @@+-- Initial Ninjas.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: Ninjas+version: 0.1.0.0+synopsis: Ninja game+description: A multiplayer game where you blend in as an NPC while trying to visit all of the ancient pillars. Press 'A' to attack, 'S' to drop smoke, 'N' for new game, 'ESC' to quit, click with your mouse to move.+license: BSD3+author: Eric Mertens+maintainer: emertens@gmail.com+copyright: Eric Mertens 2013+category: Game+build-type: Simple+cabal-version: >=1.8+homepage: http://github.com/glguy/ninjas++data-files: images/*.bmp++executable Ninjas+ main-is: Main.hs+ other-modules:+ Anim,+ Client,+ Character,+ NetworkMessages,+ Parameters,+ Server,+ Simulation+ hs-source-dirs: src+ build-depends:+ base == 4.6.*,+ binary,+ bytestring,+ containers,+ filepath,+ gloss,+ network,+ networked-game,+ random+ ghc-options: -Wall
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ images/attack1.bmp view
binary file changed (absent → 24630 bytes)
+ images/attack2.bmp view
binary file changed (absent → 24630 bytes)
+ images/attack3.bmp view
binary file changed (absent → 24630 bytes)
+ images/attack4.bmp view
binary file changed (absent → 24630 bytes)
+ images/death1.bmp view
binary file changed (absent → 9270 bytes)
+ images/death2.bmp view
binary file changed (absent → 9270 bytes)
+ images/smoke1.bmp view
binary file changed (absent → 270454 bytes)
+ images/smoke2.bmp view
binary file changed (absent → 270454 bytes)
+ images/smoke3.bmp view
binary file changed (absent → 270454 bytes)
+ images/smoke4.bmp view
binary file changed (absent → 270454 bytes)
+ images/smoke5.bmp view
binary file changed (absent → 270454 bytes)
+ images/smoke6.bmp view
binary file changed (absent → 270454 bytes)
+ images/stay1.bmp view
binary file changed (absent → 4150 bytes)
+ images/stunned1.bmp view
binary file changed (absent → 4150 bytes)
+ images/tower1.bmp view
binary file changed (absent → 6454 bytes)
+ images/walk1.bmp view
binary file changed (absent → 4150 bytes)
+ images/walk2.bmp view
binary file changed (absent → 4150 bytes)
+ images/walk3.bmp view
binary file changed (absent → 4150 bytes)
+ images/walk4.bmp view
binary file changed (absent → 4150 bytes)
+ src/Anim.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE RecordWildCards #-}+module Anim where++import Graphics.Gloss.Data.Picture+import System.FilePath+import Control.Exception+import Paths_Ninjas+import Prelude hiding(catch)+++defaultFrameDelay :: Float+defaultFrameDelay = 0.2++-- | This is an animation loop.+data Animation = Animation+ { frameDelay :: Float -- ^ How long to wait between frames+ , moreFrames :: [Picture] -- ^ Total number of frames+ , waitFor :: Float -- ^ Time until next frame+ , curFrame :: Picture -- ^ Current frame+ }++loop :: Animation -> Animation+loop a = a { moreFrames = cycle' (moreFrames a) }+ where+ cycle' [] = error "Animations files missing, try 'cabal install'"+ cycle' xs = cycle xs++once :: Float -> [Picture] -> Animation+once frameDelay moreFrames = Animation { .. }+ where waitFor = 0+ curFrame = blank+++finished :: Float -> Animation -> Bool+finished e a = null (moreFrames a) && waitFor a <= e++update :: Float -> Animation -> Animation+update elapsed a+ | elapsed > waitFor a =+ a { waitFor = frameDelay a+ , curFrame = nextFrame+ , moreFrames = nextFrames+ }+ | otherwise = a { waitFor = waitFor a - elapsed }++ where (nextFrame,nextFrames) = case moreFrames a of+ [] -> (curFrame a, [])+ f : fs -> (f, fs)++++--------------------------------------------------------------------------------++loadImg :: FilePath -> IO Picture+loadImg x = loadBMP =<< getDataFileName ("images" </> x <.> "bmp")++loadFrames :: FilePath -> IO [Picture]+loadFrames path = load (1::Int)+ where+ load n = do let i = path ++ show n+ p <- loadImg i+ ps <- load (n+1)+ return (p:ps)+ `catch` \SomeException {} -> return []++loadAnim :: FilePath -> IO Animation+loadAnim path = once defaultFrameDelay `fmap` loadFrames path++++data NPC = NPC { walk, stay, stun, attack, die :: Animation }++loadNPC :: IO NPC+loadNPC =+ do walk <- loop `fmap` loadAnim "walk"+ stay <- loadAnim "stay"+ stun <- loadAnim "stunned"+ attack <- loop `fmap` loadAnim "attack"+ die <- loadAnim "death"+ return NPC { .. }+++data World = World { background, tower, smoke :: Animation+ , npc :: NPC }++loadWorld :: IO World+loadWorld =+ do npc <- loadNPC+ tower <- loadAnim "tower"+ smoke <- loadSmoke+ let background = once defaultFrameDelay []+ return World { .. }++loadSmoke :: IO Animation+loadSmoke =+ do a <- loadAnim "smoke"+ let fs = case moreFrames a of+ [] -> [blank]+ xs -> xs+ allFs = fs ++ tail (reverse fs)+ let n = fromIntegral (length allFs) :: Float+ return a { moreFrames = allFs, frameDelay = smokeLen / n }+ where+ smokeLen = 5 -- secs+++updateWorld :: Float -> World -> World+updateWorld e w = w { background = update e (background w)+ , tower = update e (tower w)+ }+++
+ src/Character.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE RecordWildCards #-}+module Character where++import Graphics.Gloss.Data.Point+import Graphics.Gloss.Data.Vector++import VectorUtils+import Parameters++data Character = Character+ { charPos :: Point+ , charFacing :: Vector -- Unit vector+ , charState :: State+ }+ deriving (Read, Show, Eq)++data WalkInfo = Walk+ { walkTarget :: Point+ -- Cached, so that we don't recompute all the time.+ , walkDist :: Float+ , walkVelocity :: Vector+ }+ deriving (Show, Read, Eq)++data WaitInfo = Wait+ { waitWaiting :: Maybe Float+ , waitStunned :: Bool+ }+ deriving (Show, Read, Eq)++data State+ = Walking WalkInfo+ | Waiting WaitInfo+ | Dead+ | Attacking Float+ deriving (Show, Read, Eq)++data ThinkTask = ChooseWait | ChooseDestination++-- | Compute a new character given a number of elapsed seconds. An optional+-- update task will be returned if the server should compute a new+-- goal for the character. Clients will ignore this task and wait for the+-- server to send an update.+stepCharacter ::+ Float {- ^ elapsed seconds -} ->+ Character ->+ (Character, Bool, Maybe ThinkTask) -- (new character, did we change states, AI task)+stepCharacter elapsed c =+ case state of+ Walking w+ | walkDist w < step -> done (Just ChooseWait)+ | otherwise ->+ working (Walking w { walkDist = walkDist w - step })+ c { charPos = newPos }++ where step = elapsed * speed+ newPos = addPt (mulSV elapsed (walkVelocity w)) (charPos c)++ Waiting w ->+ case waitWaiting w of+ Nothing -> working state c+ Just todo+ | todo < elapsed -> done (Just ChooseDestination)+ | otherwise ->+ working (Waiting w { waitWaiting = Just (todo - elapsed) }) c+++ Attacking delay+ | elapsed > delay -> done Nothing+ | otherwise -> working (Attacking (delay - elapsed)) c++ Dead -> working state c++ where+ state = charState c+ done next = (c { charState = Waiting Wait { waitWaiting = Nothing+ , waitStunned = False } }+ , True+ , next)+ working s n = (n { charState = s}, False, Nothing)++-- | Update a Character to have the goal of walking to a given point.+walkingCharacter :: Point -> Character -> Character+walkingCharacter walkTarget c = c { charState = state+ , charFacing = facing }+ where+ state = Walking Walk { .. }++ facing | walkDist > 0.001 = mulSV (1 / walkDist) path+ | otherwise = charFacing c++ walkVelocity = mulSV speed facing++ path = subPt walkTarget (charPos c)+ walkDist = magV path++-- | Update an character to have the goal of waiting for an optional+-- duration and optionally to be drawn as stunned. If a duration+-- is specified the character will be updated automatically by the server.+-- characters without a duration are typically players.+waitingCharacter :: Maybe Float -> Bool -> Character -> Character+waitingCharacter waitWaiting waitStunned c =+ c { charState = Waiting Wait { .. } }++-- | Update an character to be dead+deadCharacter :: Character -> Character+deadCharacter c = c { charState = Dead }++-- | Update an character to be stunned for the default stun duration.+stunnedCharacter :: Character -> Character+stunnedCharacter = waitingCharacter (Just stunTime) True++-- | Update an character to be in the attacking state for the+-- default attack duration.+attackingCharacter :: Character -> Character+attackingCharacter c = c { charState = Attacking attackDelay }++isStunned :: Character -> Bool+isStunned c =+ case charState c of+ Waiting Wait { waitStunned = True } -> True+ _ -> False
+ src/Client.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE RecordWildCards #-}+module Client (ClientEnv(..), defaultClientEnv, clientMain) where++import Control.Concurrent+import Control.Monad+import Graphics.Gloss.Interface.IO.Game+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Geometry.Angle+import System.IO+import Network+import Server (ServerEnv(..), defaultServerEnv)+import NetworkMessages+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++import Character+import Parameters+import VectorUtils+import qualified Anim++moveButton, stopButton, attackButton, smokeButton,+ newGameButton, clearButton :: Key+moveButton = MouseButton LeftButton+stopButton = MouseButton RightButton+attackButton = Char 'a'+smokeButton = Char 's'+newGameButton = Char 'n'+clearButton = Char 'c'++windowPadding :: Int+windowPadding = 60++dingPeriod :: Float+dingPeriod = 1++textScale :: Float+textScale = 0.25++dingPosition :: Point+dingPosition = (fst boardMin + 5, snd boardMax - 20)++data ClientEnv = ClientEnv+ { hostname :: HostName+ , clientPort :: Int+ , username :: String+ }++defaultClientEnv :: ClientEnv+defaultClientEnv = ClientEnv+ { hostname = "localhost"+ , clientPort = (serverPort defaultServerEnv)+ , username = "Anon"+ }++clientMain :: ClientEnv -> IO ()+clientMain (ClientEnv host port name) =+ do anim <- Anim.loadWorld+ h <- connectTo host (PortNumber (fromIntegral port))+ hSetBuffering h NoBuffering++ hPutClientCommand h (ClientJoin name)++ poss <- getInitialWorld h+ r <- newMVar (initClientWorld anim poss)+ _ <- forkIO $ clientUpdates h r+ runGame h r++serverWaitingMessage :: Int -> String+serverWaitingMessage n+ = "Server waiting for "+ ++ show n ++ " more ninja"+ ++ if n > 1 then "s." else "."++getInitialWorld :: Handle -> IO [(Int,Point,Vector)]+getInitialWorld h =+ do msg <- hGetServerCommand h+ case msg of+ SetWorld poss -> return poss+ ServerWaiting n ->+ do putStrLn $ serverWaitingMessage n+ getInitialWorld h+ _ -> fail "Unexpected initial message"++initClientWorld :: Anim.World -> [(Int, Point, Vector)] -> World+initClientWorld anim poss =+ World { worldCharacters = IntMap.fromList+ [(i,initClientCharacter (Anim.npc anim) p v)+ | (i,p,v) <- poss ]+ , dingTimers = []+ , worldMessages = []+ , smokeTimers = []+ , appearance = anim+ }++runGame :: Handle -> MVar World -> IO ()+runGame h var =+ playIO+ (InWindow "Ninjas"+ (round width + windowPadding, round height + windowPadding)+ (10,10))+ black+ eventsPerSecond+ () -- "state"+ (\() -> fmap drawWorld (readMVar var))+ (inputEvent h var)+ (\t () -> modifyMVar_ var $ \w -> return $ updateClientWorld t w)+ where (width,height) = subPt boardMax boardMin++drawWorld :: World -> Picture+drawWorld w = pictures+ $ borderPicture+ : dingPicture (length (dingTimers w))+ : map (drawPillar w) pillars+ ++ map drawCharacter (IntMap.elems $ worldCharacters w)+ ++ map drawSmoke (smokeTimers w)+ ++ messagePictures (worldMessages w)++drawSmoke :: (Point, Anim.Animation) -> Picture+drawSmoke (pt,a) = translateV pt (Anim.curFrame a)++messagePictures :: [String] -> [Picture]+messagePictures msgs = zipWith messagePicture [0..] msgs++messagePicture :: Int -> String -> Picture+messagePicture i msg+ = translate (fst boardMin + 5)+ (snd boardMin + 5 + textHeight * fromIntegral i)+ $ scale textScale textScale+ $ color (greyN gray)+ $ text msg+ where+ textHeight = 40+ gray = (4 - fromIntegral (min 3 i)) / 4++dingPicture :: Int -> Picture+dingPicture n =+ pictures [ translateV dingPosition+ $ translate (5 * fromIntegral i) (- 5 * fromIntegral i)+ $ scale textScale textScale+ $ color white+ $ text "DING"+ | i <- [0..n-1]]++drawPillar :: World -> Point -> Picture+drawPillar w pt+ = translateV pt+ $ Anim.curFrame $ Anim.tower $ appearance w++borderPicture :: Picture+borderPicture = color red $ rectangleWire (2 * ninjaRadius + width)+ (2 * ninjaRadius + height)+ where (width,height) = subPt boardMax boardMin++drawCharacter :: ClientCharacter -> Picture+drawCharacter c+ = translateV (charPos char)+ $ rotate (negate $ radToDeg rads)+ $ Anim.curFrame (clientAnim c)+ where char = clientCharacter c+ rads = argV (charFacing char)++++-- | Translate a picture using a 'Vector'+translateV :: Vector -> Picture -> Picture+translateV (x,y) = translate x y++inputEvent :: Handle -> MVar World -> Event -> () -> IO ()+inputEvent h var (EventKey k Down _ pos) ()+ | k == moveButton = hPutClientCommand h (ClientCommand (Move (0,0) pos))+ | k == stopButton = hPutClientCommand h (ClientCommand Stop )+ | k == attackButton = hPutClientCommand h (ClientCommand Attack )+ | k == smokeButton = hPutClientCommand h (ClientSmoke )+ | k == newGameButton = hPutClientCommand h NewGame+ | k == clearButton = clearMessages var+inputEvent _ _ _ () = return ()++clearMessages :: MVar World -> IO ()+clearMessages var = modifyMVar_ var $ \w -> return $ w { worldMessages = [] }++updateClientWorld :: Float -> World -> World+updateClientWorld d w =+ w { worldCharacters = fmap (stepClientCharacter npcLooks d) (worldCharacters w)+ , dingTimers = [ t - d | t <- dingTimers w, t > d]+ , smokeTimers = [(pt, Anim.update d a) |+ (pt,a) <- smokeTimers w, not (Anim.finished d a) ]+ , appearance = Anim.updateWorld d (appearance w)+ }+ where npcLooks = Anim.npc (appearance w)++stepClientCharacter :: Anim.NPC -> Float -> ClientCharacter -> ClientCharacter+stepClientCharacter looks elapsed clientChar =+ case stepCharacter elapsed (clientCharacter clientChar) of+ (char,changed,_)+ | changed -> newClientCharacter looks char+ | otherwise -> clientChar { clientCharacter = char+ , clientAnim = Anim.update elapsed (clientAnim clientChar) }++newClientCharacter :: Anim.NPC -> Character -> ClientCharacter+newClientCharacter looks clientCharacter = ClientCharacter { .. }+ where+ clientAnim = case charState clientCharacter of+ Walking {} -> Anim.walk looks+ Waiting w | waitStunned w -> Anim.stun looks+ | otherwise -> Anim.stay looks+ Attacking {} -> Anim.attack looks+ Dead -> Anim.die looks++clientUpdates :: Handle -> MVar World -> IO ()+clientUpdates h var = forever $+ do c <- hGetServerCommand h+ modifyMVar_ var $ \w -> return $! processCmd w c++ where++ processCmd w c =+ case c of+ ServerReady -> w { worldMessages = [] }+ ServerMessage txt -> w { worldMessages = txt : worldMessages w }+ ServerDing -> w { dingTimers = dingPeriod : dingTimers w }+ ServerSmoke pt -> let smoke = Anim.smoke (appearance w)+ in w { smokeTimers = (pt,smoke) : smokeTimers w }+ SetWorld poss -> initClientWorld (appearance w) poss+ ServerCommand i m -> let f = npcCommand w m+ in w { worldCharacters = updateNpcList i f $ worldCharacters w }+ _ -> w++ npcCommand w cmd cnpc =+ let npc = clientCharacter cnpc+ in newClientCharacter (Anim.npc $ appearance w) $+ case cmd of+ Move from to -> walkingCharacter to npc { charPos = from }+ Stop -> waitingCharacter Nothing False npc+ Stun -> stunnedCharacter npc+ Die -> deadCharacter npc+ Attack -> attackingCharacter npc++updateNpcList ::+ Int ->+ (ClientCharacter -> ClientCharacter) ->+ IntMap ClientCharacter -> IntMap ClientCharacter+updateNpcList i f = IntMap.update (Just . f) i++data World = World+ { worldCharacters :: IntMap ClientCharacter+ , dingTimers :: [Float]+ , smokeTimers :: [(Point, Anim.Animation)]+ , worldMessages :: [String]+ , appearance :: Anim.World+ }++-- | Construct a new character given a name, a position,+-- and a facing unit vector. This function is used+-- by clients who are told the parameters by the+-- server.+initClientCharacter :: Anim.NPC -> Point -> Vector -> ClientCharacter+initClientCharacter anim charPos charFacing =+ let charState = Waiting Wait { waitWaiting = Nothing, waitStunned = False }+ clientAnim = Anim.stay anim+ clientCharacter = Character { .. }+ in ClientCharacter { .. }++data ClientCharacter = ClientCharacter+ { clientCharacter :: Character+ , clientAnim :: Anim.Animation+ }+
+ src/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Monad (mplus)+import Data.Maybe (fromMaybe)+import System.Environment+import System.Exit+import System.Console.GetOpt++import Client (ClientEnv(..), defaultClientEnv, clientMain)+import Server (ServerEnv(..), defaultServerEnv, serverMain)++--------------------------------------------------------------------------------++main :: IO ()+main =+ do args <- getArgs+ case args of+ "server" : args' -> launchServer args'+ "client" : args' -> launchClient args'+ _ -> usage++usage :: IO a+usage =+ do putStrLn "Usage:"+ putStr $ usageInfo "Ninjas server [FLAGS]" serverOpts+ putStr $ usageInfo "Ninjas client [FLAGS] [HOSTNAME [PORT]]" clientOpts+ exitFailure++launchServer :: [String] -> IO ()+launchServer args =+ case getOpt Permute serverOpts args of+ (fs, [], []) -> serverMain (funs defaultServerEnv fs)+ (_ , _ , es) -> mapM_ putStrLn es >> usage+ where+ funs = foldl (\acc f -> f acc)++serverOpts :: [OptDescr (ServerEnv -> ServerEnv)]+serverOpts =+ [ Option [] ["port"]+ (ReqArg (\n env -> env { serverPort = read n }) "NUM")+ "Server port"+ , Option [] ["npcs"]+ (ReqArg (\n env -> env { npcCount = read n }) "NUM")+ "Number of NPCs"+ , Option [] ["smokes"]+ (ReqArg (\n env -> env { initialSmokebombs = read n }) "NUM")+ "Number of initial smokebombs"+ ]++launchClient :: [String] -> IO ()+launchClient args =+ do user <- getUsername+ case getOpt Permute clientOpts args of+ (fs, [h], []) -> clientMain (funs defaultClientEnv { username=user+ , hostname=h+ } fs)+ (fs, _ , []) -> clientMain (funs defaultClientEnv{username=user} fs)+ (_ , _ , es) -> mapM_ putStrLn es >> usage+ where+ funs = foldl (\acc f -> f acc)++clientOpts :: [OptDescr (ClientEnv -> ClientEnv)]+clientOpts =+ [ Option [] ["server"]+ (ReqArg (\n env -> env { hostname = n }) "STRING")+ "Server hostname"+ , Option [] ["port"]+ (ReqArg (\n env -> env { clientPort = read n }) "NUM")+ "Server port"+ , Option [] ["user"]+ (ReqArg (\n env -> env { username = n }) "STRING")+ "User Name"+ ]++getUsername :: IO String+getUsername =+ do env <- getEnvironment+ return $ fromMaybe (username defaultClientEnv)+ $ lookup "USER" env `mplus` lookup "USERNAME" env
+ src/NetworkMessages.hs view
@@ -0,0 +1,126 @@+module NetworkMessages where++import Control.Monad+import Data.Binary (Binary(get,put),getWord8,putWord8, Get,Put)+import Graphics.Gloss.Data.Picture+import Network (PortID(PortNumber))+import System.IO (Handle)++import NetworkedGame.Packet++gamePort :: PortID+gamePort = PortNumber 16000++data Command+ = Move Point Point+ | Stop+ | Attack+ | Stun+ | Die+ deriving (Show, Read, Eq)++data ClientCommand+ = ClientCommand Command+ | ClientSmoke+ | ClientJoin String+ | NewGame+ deriving (Show, Read, Eq)++data ServerCommand+ = ServerCommand Int Command+ | SetWorld [(Int,Point,Vector)]+ | ServerWaiting Int+ | ServerMessage String+ | ServerSmoke Point+ | ServerDing+ | ServerReady+ deriving (Show, Read)++hGetClientCommand :: Handle -> IO ClientCommand+hGetClientCommand = hGetPacketed++hPutClientCommand :: Handle -> ClientCommand -> IO ()+hPutClientCommand h x = hPutPacket h $ mkPacket x++hGetServerCommand :: Handle -> IO ServerCommand+hGetServerCommand = hGetPacketed++hPutServerPacket :: Handle -> Packet -> IO ()+hPutServerPacket = hPutPacket++mkServerPacket :: ServerCommand -> Packet+mkServerPacket = mkPacket++instance Binary Command where+ put = putCommand+ get = getCommand++instance Binary ServerCommand where+ put = putServerCommand+ get = getServerCommand++instance Binary ClientCommand where+ put = putClientCommand+ get = getClientCommand++putCommand :: Command -> Put+putCommand cmd =+ case cmd of+ Move pt1 pt2 -> putWord8 1 >> put pt1 >> put pt2+ Stop -> putWord8 2+ Attack -> putWord8 3+ Stun -> putWord8 4+ Die -> putWord8 5++getCommand :: Get Command+getCommand =+ do tag <- getWord8+ case tag of+ 1 -> Move `fmap` get `ap` get+ 2 -> return Stop+ 3 -> return Attack+ 4 -> return Stun+ 5 -> return Die+ _ -> error ("getCommand: bad tag " ++ show tag)++putClientCommand :: ClientCommand -> Put+putClientCommand cmd =+ case cmd of+ ClientCommand c -> putWord8 1 >> put c+ ClientJoin name -> putWord8 2 >> put name+ ClientSmoke -> putWord8 3+ NewGame -> putWord8 4++getClientCommand :: Get ClientCommand+getClientCommand =+ do tag <- getWord8+ case tag of+ 1 -> return ClientCommand `ap` get+ 2 -> return ClientJoin `ap` get+ 3 -> return ClientSmoke+ 4 -> return NewGame+ _ -> error ("getClientCommand: bad tag " ++ show tag)++getServerCommand :: Get ServerCommand+getServerCommand =+ do tag <- getWord8+ case tag of+ 1 -> return ServerCommand `ap` get `ap` get+ 2 -> return SetWorld `ap` get+ 3 -> return ServerWaiting `ap` get+ 4 -> return ServerMessage `ap` get+ 5 -> return ServerDing+ 6 -> return ServerSmoke `ap` get+ 7 -> return ServerReady+ _ -> error ("getServerCommand: bad tag " ++ show tag)++putServerCommand :: ServerCommand -> Put+putServerCommand cmd =+ case cmd of+ ServerCommand i c -> putWord8 1 >> put i >> put c+ SetWorld xs -> putWord8 2 >> put xs+ ServerWaiting i -> putWord8 3 >> put i+ ServerMessage txt -> putWord8 4 >> put txt+ ServerDing -> putWord8 5+ ServerSmoke pt -> putWord8 6 >> put pt+ ServerReady -> putWord8 7
+ src/Parameters.hs view
@@ -0,0 +1,53 @@+module Parameters where++import Graphics.Gloss.Data.Point (Point)++-- | Smallest point on the board+boardMin :: Point+boardMin = (-350,-250)++-- | Largest point on the board+boardMax :: Point+boardMax = (350,250)++-- | Maximum time an NPC will wait before choosing a new destination+restTime :: Float+restTime = 2++-- | Radius of ninja sprite in pixels. This is used for drawing+-- a ninja and determining when he is hidden under smoke.+ninjaRadius :: Float+ninjaRadius = 10++-- | Maximum distance from the center of a player where an attack has an effect+attackDistance :: Float+attackDistance = 50++-- | Maximum angle in radians in either direction from a player's direction of+-- travel where the attacks have an effect+attackAngle :: Float+attackAngle = pi / 3++-- | The number of time update events gloss should attempt to run per second+eventsPerSecond :: Int+eventsPerSecond = 100++-- | Pixels per second traveled by ninjas+speed :: Float+speed = 100++-- | Duration in seconds a player is stunned after an attack+attackDelay :: Float+attackDelay = 1++-- | Duration in second for which an character will be stunned after an attack+stunTime :: Float+stunTime = 3++-- | The locations of the centers of the win locations in the game+pillars :: [Point]+pillars = [(0,0), (275, 175), (-275, 175), (-275, -175), (275, -175)]++-- | The length of a side of the win location squares+pillarSize :: Float+pillarSize = 40
+ src/Server.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE RecordWildCards #-}+module Server (ServerEnv(..), defaultServerEnv, serverMain) where++import Control.Applicative (Applicative)+import Control.Monad (when, guard)+import Data.Foldable (for_)+import Data.IntMap (IntMap)+import Data.List (intercalate, sortBy, (\\))+import Data.Maybe (fromMaybe)+import Data.Ord (comparing)+import Data.Traversable (sequenceA)+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Geometry.Line+import Network (PortID(..))+import qualified Data.IntMap as IntMap++import Simulation+import Character+import NetworkMessages+import Parameters++import NetworkedGame.Server (NetworkServer(..), announce, announceOne, Handles)+import NetworkedGame.Handles (ConnectionId(..))+import qualified NetworkedGame.Server as NS++data ServerEnv = ServerEnv+ { npcCount :: Int+ , initialSmokebombs :: Int+ , serverPort :: Int+ }++data ServerWorld = ServerWorld+ { serverNpcs :: IntMap Character+ , serverPlayers :: IntMap Player+ , serverMode :: ServerMode+ , serverLobby :: [(Int,String)]+ }++defaultServerEnv :: ServerEnv+defaultServerEnv = ServerEnv+ { npcCount = 10+ , initialSmokebombs = 1+ , serverPort = 16000+ }++-- | Main entry point for server+serverMain :: ServerEnv -> IO ()+serverMain env =+ do w <- initServerWorld env []+ let ServerEnv { serverPort = port } = env+ let settings = NetworkServer+ { serverPort = PortNumber $ fromIntegral port+ , eventsPerSecond = Parameters.eventsPerSecond+ , onTick = updateServerWorld+ , onConnect = connect+ , onDisconnect = disconnect+ , onCommand = command env+ }+ NS.serverMain settings w++-----------------------------------------------------------------------+-- Game logic+-----------------------------------------------------------------------++readyCountdown :: Handles -> ServerWorld -> IO ServerWorld+readyCountdown hs w =+ do announce hs $ ServerMessage "3"+ return w { serverMode = Starting 0 }++-- | Construct a new game world preserving the scores from+-- the previous world and adding the lobby players in.+newGame :: ServerEnv -> ServerWorld -> IO ServerWorld+newGame env w =+ do let scores = serverScores w ++ [(i,u,0) | (i,u) <- serverLobby w]+ initServerWorld env scores++generateSetWorld :: ServerWorld -> ServerCommand+generateSetWorld w =+ SetWorld [(i, charPos char, charFacing char) | (i,char) <- allCharacters w]++allCharacters :: ServerWorld -> [(Int,Character)]+allCharacters w = IntMap.toList (fmap playerCharacter (serverPlayers w))+ ++ IntMap.toList (serverNpcs w)++updateWorldForCommand ::+ ServerEnv ->+ Int {- ^ ID of sender -} ->+ Handles ->+ ServerWorld ->+ ClientCommand ->+ IO ServerWorld+updateWorldForCommand env i hs w msg =+ do let Just me = IntMap.lookup i $ serverPlayers w+ myPos = charPos $ playerCharacter me+ mapPlayer f = w { serverPlayers =+ IntMap.update (Just . f) i (serverPlayers w) }+ mapMyNpc = mapPlayer . mapPlayerCharacter++ case msg of+ NewGame | serverMode w == Stopped+ || not (isInLobby i w)+ && IntMap.size (serverPlayers w) == 1 ->+ do w' <- newGame env w+ announce hs $ generateSetWorld w'+ readyCountdown hs w'+ | otherwise -> return w++ _ | serverMode w /= Playing || isStuckPlayer me -> return w++ ClientSmoke+ | hasSmokebombs me ->+ do announce hs $ ServerSmoke $ charPos $ playerCharacter me+ return $ mapPlayer consumeSmokebomb++ ClientCommand cmd ->+ case cmd of+ Move _ pos0+ -- Disregard where the player says he is moving from+ | pointInBox pos boardMin boardMax ->+ do announce hs $ ServerCommand i+ $ Move myPos pos+ return $ mapMyNpc $ walkingCharacter pos+ where+ pos = constrainPoint myPos pos0++ Stop ->+ do announce hs $ ServerCommand i cmd+ return $ mapMyNpc $ waitingCharacter Nothing False++ Attack ->+ do performAttack hs i w+ _ -> return w+ _ -> return w++serverScores :: ServerWorld -> [(Int,String,Int)]+serverScores w = [ (i, playerUsername p, playerScore p)+ | (i,p) <- IntMap.toList $ serverPlayers w ]++initServerWorld :: ServerEnv -> [(Int,String,Int)] -> IO ServerWorld+initServerWorld env scores =+ do let npcIds = take (npcCount env)+ $ [0..] \\ [i | (i,_,_) <- scores]+ let newPlayer = initPlayer (initialSmokebombs env)+ serverMode = Stopped+ serverLobby = []+ serverPlayers <- fmap IntMap.fromList+ $ mapM (\(i,u,s) -> fmap ((,) i) (newPlayer u s)) scores+ serverNpcs <- fmap IntMap.fromList+ $ mapM (\i -> fmap ((,) i) (initServerCharacter True)) npcIds+ return ServerWorld { .. }++startingMode :: Handles -> Float -> Float -> ServerWorld -> IO ServerWorld+startingMode hs t duration w =+ do when (boundary (1*0.6)) $ announce hs $ ServerMessage "2"+ when (boundary (2*0.6)) $ announce hs $ ServerMessage "1"+ when (boundary (3*0.6)) $ announce hs $ ServerMessage "GO!"+ mode' <- if boundary (4*0.6)+ then do announce hs ServerReady+ return Playing+ else return $ Starting duration'+ return $ w { serverMode = mode' }+ where+ duration' = duration + t+ boundary x = duration < x && x <= duration'++updateServerWorld :: Handles -> Float -> ServerWorld -> IO ServerWorld+updateServerWorld hs t w =+ case serverMode w of+ Stopped -> return w+ Starting duration -> startingMode hs t duration w+ Playing ->+ do pcs' <- mapWithKeyA (playerLogic hs t) $ serverPlayers w+ npcs' <- mapWithKeyA (characterLogic hs t True) $ serverNpcs w++ let winners = IntMap.filter isWinner pcs'++ pcs2 <- if IntMap.null winners+ then return pcs'+ else endGame hs winners pcs' "deception"++ let mode'+ | IntMap.null winners = Playing+ | otherwise = Stopped++ return w { serverPlayers = pcs2+ , serverNpcs = npcs'+ , serverMode = mode'+ }++endGame :: Handles -> IntMap Player -> IntMap Player -> String ->+ IO (IntMap Player)+endGame hs winners players reason =++ do -- Declare victory+ announce hs $ ServerMessage+ $ commas (map playerUsername (IntMap.elems winners))+ ++ " wins by " ++ reason ++ "!"++ -- Update scores+ let players' = IntMap.mapWithKey (addVictory (IntMap.keys winners)) players++ -- Announce scores+ announce hs+ $ ServerMessage $ commas $ map prettyScore+ $ reverse $ sortBy (comparing playerScore) $ IntMap.elems players'++ return players'++prettyScore :: Player -> String+prettyScore p = playerUsername p ++ ": " ++ show (playerScore p)++commas :: [String] -> String+commas = intercalate ", "++addVictory :: [Int] -> Int -> Player -> Player+addVictory winners name p+ | name `elem` winners = p { playerScore = 1 + playerScore p }+ | otherwise = p++playerLogic :: Handles -> Float -> Int -> Player -> IO Player+playerLogic hs t name p =+ do char <- characterLogic hs t False name $ playerCharacter p+ let p' = p { playerCharacter = char }+ case whichPillar (charPos char) of+ Just i | i `notElem` playerVisited p ->+ do announce hs ServerDing+ return p' { playerVisited = i : playerVisited p' }+ _ -> return p'++characterLogic :: Handles -> Float -> Bool -> Int -> Character -> IO Character+characterLogic hs t think charName char =+ do let (char',_,mbTask) = stepCharacter t char++ case guard think >> mbTask of++ Just ChooseWait ->+ do time <- pickWaitTime True+ return $ waitingCharacter time False char'++ Just ChooseDestination ->+ do tgt <- randomBoardPoint+ announce hs $ ServerCommand charName+ $ Move (charPos char) tgt+ return $ walkingCharacter tgt char'++ Nothing -> return char'++constrainPoint :: Point -> Point -> Point+constrainPoint from+ = aux intersectSegVertLine (fst boardMin)+ . aux intersectSegVertLine (fst boardMax)+ . aux intersectSegHorzLine (snd boardMin)+ . aux intersectSegHorzLine (snd boardMax)+ where+ aux f x p = fromMaybe p (f from p x)++connect :: Handles -> ConnectionId -> ServerWorld -> IO ServerWorld+connect hs i w =+ do announceOne hs i $ generateSetWorld w+ return w++command ::+ ServerEnv ->+ Handles ->+ ConnectionId {- ^ player who sent command -} ->+ ClientCommand ->+ ServerWorld ->+ IO ServerWorld+command _ hs (ConnectionId i) (ClientJoin name) w = addClient hs i name w+command env hs (ConnectionId i) msg w+ -- The ids of lobby players might overlap with NPCs+ | isInLobby i w+ && msg /= NewGame = return w+ | otherwise = updateWorldForCommand env i hs w msg++disconnect :: Handles -> ConnectionId -> ServerWorld -> IO ServerWorld+disconnect hs (ConnectionId i) w =+ do putStrLn $ "Client disconnect with id " ++ show i+ case IntMap.lookup i $ serverPlayers w of+ Just p ->+ do let ps = IntMap.delete i $ serverPlayers w+ announce hs $ ServerCommand i Die+ announce hs $ ServerMessage $ playerUsername p ++ " disconnected"++ when (IntMap.null ps) $ announce hs $ ServerMessage "Game Over"++ let mode | IntMap.null ps = Stopped+ | otherwise = serverMode w++ return w { serverPlayers = ps+ , serverMode = mode+ }++ Nothing ->+ case lookup i $ serverLobby w of+ Just u ->+ do announce hs $ ServerMessage $ u ++ " left lobby"+ return w { serverLobby = [(k,v) | (k,v) <- serverLobby w+ , k /= i] }+ Nothing -> return w++addClient :: Handles -> Int -> String -> ServerWorld -> IO ServerWorld+addClient hs i name w =+ do for_ (serverLobby w) $ \(_,u) ->+ announceOne hs (ConnectionId i) $ ServerMessage $ u ++ " in lobby"+ for_ (serverPlayers w) $ \p ->+ announceOne hs (ConnectionId i) $ ServerMessage $ playerUsername p ++ " in game"+ announce hs $ ServerMessage $ name ++ " joined lobby"+ return $ w { serverLobby = (i,name) : serverLobby w }+ -- XXX : Check that the client isn't already registered++performAttack :: Handles -> Int -> ServerWorld -> IO ServerWorld+performAttack hs attackId w =+ do let Just attacker = IntMap.lookup attackId $ serverPlayers w+ them = IntMap.delete attackId $ serverPlayers w+ let attackChar = playerCharacter attacker++ announce hs $ ServerCommand attackId Attack++ let me' = mapPlayerCharacter attackingCharacter attacker+ them' <- mapWithKeyA (attackPlayer hs attacker) them+ npcs' <- mapWithKeyA (attackCharacter hs attackChar) (serverNpcs w)++ let winningAttack = all isDeadPlayer $ IntMap.elems them'+ everyone <- if winningAttack+ then endGame hs (IntMap.singleton attackId me')+ (IntMap.insert attackId me' them') "force"+ else return $ IntMap.insert attackId me' them'++ let mode+ | winningAttack = Stopped+ | otherwise = Playing++ return $ w { serverPlayers = everyone+ , serverNpcs = npcs'+ , serverMode = mode+ }++attackCharacter :: Handles -> Character -> Int -> Character -> IO Character+attackCharacter hs attacker targetId target+ | canHitPoint attacker (charPos target) =+ do announce hs $ ServerCommand targetId Stun+ return $ stunnedCharacter target+ | otherwise = return target++attackPlayer :: Handles -> Player -> Int -> Player -> IO Player+attackPlayer hs attacker charName target+ | canHitPoint attackerChar (charPos targetChar) =+ do let attackerName = playerUsername attacker+ announce hs $ ServerCommand charName Die+ announceOne hs (ConnectionId charName)+ $ ServerMessage $ "Killed by " ++ attackerName+ return $ mapPlayerCharacter deadCharacter target+ | otherwise = return target+ where+ targetChar = playerCharacter target+ attackerChar = playerCharacter attacker++mapWithKeyA :: Applicative f => (Int -> a -> f b) -> IntMap a -> f (IntMap b)+mapWithKeyA f m = sequenceA $ IntMap.mapWithKey f m++-----------------------------------------------------------------------+-- Player predicates+-----------------------------------------------------------------------++isInLobby :: Int -> ServerWorld -> Bool+isInLobby i w = i `elem` map fst (serverLobby w)++isStuckPlayer :: Player -> Bool+isStuckPlayer p =+ case charState (playerCharacter p) of+ Dead -> True+ Attacking {} -> True+ _ -> False++isDeadPlayer :: Player -> Bool+isDeadPlayer p = Dead == charState (playerCharacter p)++isWinner :: Player -> Bool+isWinner p = length (playerVisited p) == length pillars
+ src/Simulation.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RecordWildCards #-}++module Simulation where++import Data.List (findIndex)+import Graphics.Gloss.Data.Point+import Graphics.Gloss.Data.Vector+import Graphics.Gloss.Geometry.Angle+import System.Random (randomRIO)++import Character+import Parameters+import VectorUtils++data Player = Player+ { playerCharacter :: Character+ , playerUsername :: String+ , playerScore :: Int+ , playerVisited :: [Int]+ , playerSmokes :: Int+ }+ deriving (Show, Read, Eq)++data ServerMode = Playing | Starting Float | Stopped+ deriving (Eq, Read, Show)++-- | Lift a function on Characters to one on Players+mapPlayerCharacter :: (Character -> Character) -> Player -> Player+mapPlayerCharacter f p = p { playerCharacter = f (playerCharacter p) }++canHitPoint :: Character -> Point -> Bool+canHitPoint char pt = inRange && inFront+ where+ inRange = attackLen <= attackDistance++ -- u·v = ❘v❘ ❘u❘ cos Θ+ inFront = cos attackAngle * attackLen+ <= charFacing char `dotV` attackVector++ attackVector = subPt pt (charPos char)+ attackLen = magV attackVector++-- | Compute a random point inside a box.+randomPoint :: Point -> Point -> IO Point+randomPoint (minX,minY) (maxX,maxY) =+ do x <- randomRIO (minX,maxX)+ y <- randomRIO (minY,maxY)+ return (x,y)++-- | Compute a random point inside the board.+randomBoardPoint :: IO Point+randomBoardPoint = randomPoint boardMin boardMax++-- | Compute a random unit vector.+randomUnitVector :: IO Vector+randomUnitVector =+ do degrees <- randomRIO (0,359)+ let rads = degToRad $ fromInteger degrees+ return $ unitVectorAtAngle rads++-- | Construct a new character given a name, a position,+-- and a facing unit vector. When think is True,+-- the character will be scheduled to begin walking+-- after a random duration.+initServerCharacter :: Bool -> IO Character+initServerCharacter think =+ do charPos <- randomBoardPoint+ charFacing <- randomUnitVector+ waitWaiting <- pickWaitTime think+ let waitStunned = False+ charState = Waiting Wait { .. }+ return Character { .. }++-- | Construct a new player given an initial number+-- of smokebombs, an identifier, a username, and a+-- starting score.+initPlayer :: Int -> String -> Int -> IO Player+initPlayer smokes playerUsername playerScore =+ do playerCharacter <- initServerCharacter False+ let playerVisited = []+ playerSmokes = smokes+ return Player { .. }++-- | When True, compute a new random wait time value.+pickWaitTime ::+ Bool {- ^ compute random delay -} ->+ IO (Maybe Float)+pickWaitTime False = return Nothing+pickWaitTime True = fmap Just $ randomRIO (0, restTime)++-- | Determine if a point lies within a given pillar.+isInPillar ::+ Point {- ^ location to test -} ->+ Point {- ^ center of pillar -} ->+ Bool+isInPillar p (x,y) = pointInBox p (x-halfside, y-halfside)+ (x+halfside, y+halfside)+ where+ halfside = pillarSize / 2++-- | Determine the index, if any, of the pillar with contains a point.+whichPillar :: Point -> Maybe Int+whichPillar p = findIndex (isInPillar p) pillars++-- | Return true if the given player can use smokebombs.+hasSmokebombs :: Player -> Bool+hasSmokebombs p = playerSmokes p > 0++-- | Update a player to have one fewer smokebombs.+consumeSmokebomb :: Player -> Player+consumeSmokebomb p = p { playerSmokes = playerSmokes p - 1 }