Permalink
Browse files

Implements animated events.

  • Loading branch information...
1 parent ae326fc commit 2d418e29128da172bde01f4746c99d616ad32717 @clanehin committed Oct 5, 2012
@@ -48,6 +48,8 @@ data SnapshotEvent =
sunder_event_target_tool :: ToolRef }
| TeleportEvent {
teleport_event_creature :: CreatureRef }
+ | SpawnEvent {
+ spawn_event_creature :: CreatureRef }
| ClimbEvent {
climb_event_direction :: ClimbDirection,
climb_event_creature :: CreatureRef }
@@ -80,6 +82,7 @@ instance HasSubject SnapshotEvent where
DisarmEvent { disarm_event_source_creature = attacker_ref } -> Just attacker_ref
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
+ SpawnEvent { spawn_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
@@ -10,13 +10,15 @@ module Roguestar.Lib.Roguestar
retrieveGame,
getNumberOfGames,
getPlayerState,
+ getSnapshotPlayerState,
rerollStartingSpecies,
Creature(..),
TerrainPatch(..),
Position(..),
Facing(..),
Roguestar.Lib.Roguestar.beginGame,
perceive,
+ perceiveSnapshot,
behave,
Roguestar.Lib.Roguestar.facingBehavior,
Roguestar.Lib.Roguestar.hasSnapshot,
@@ -248,6 +250,7 @@ unpackMessages_ WeaponExplodesEvent {} = return ["Your weapon explodes!"]
unpackMessages_ DisarmEvent {} = return ["Someone disarms someone else."]
unpackMessages_ SunderEvent {} = return ["The weapon has been sundered!"]
unpackMessages_ TeleportEvent {} = return ["You teleport."]
+unpackMessages_ SpawnEvent {} = return ["A recreant materializes on the teleportation pad!"]
unpackMessages_ ClimbEvent {} = return ["You wonder through a network of tunnels."]
unpackMessages_ HealEvent {} = return ["You heal."]
unpackMessages_ ExpendToolEvent {} = return ["That material sphere has been used up."]
@@ -96,7 +96,8 @@ spawnNPC terrain_type species plane_ref player_locations =
case m_spawn_position of
Nothing -> return False
Just spawn_position ->
- do _ <- newCreature Monsters species (Standing plane_ref spawn_position Here)
+ do new_creature <- newCreature Monsters species (Standing plane_ref spawn_position Here)
+ dbPushSnapshot (SpawnEvent new_creature)
return True
dbPerform1CreatureAITurn :: CreatureRef -> DB ()
@@ -147,30 +147,38 @@ options =
play :: Handler App App ()
play =
- do resolveSnapshots
+ do --resolveSnapshots
g <- getGame
player_state <- oops $ liftIO $ getPlayerState g
route [("",ifTop $ method GET $ displayGameState player_state),
("reroll",method POST $ reroll player_state),
("accept",method POST $ accept player_state),
- ("move",method POST $ move)]
+ ("move",method POST $ move),
+ ("pop",method POST $ resolveOneSnapshot)]
--("inventory",method GET $ displayInventory),
--("pickup",method POST $ pickup),
--("drop",method POST $ Main.drop),
--("wield",method POST $ wield),
--("unwield",method POST $ unwield)]
-resolveSnapshots :: Handler App App ()
-resolveSnapshots =
+resolveAllSnapshots :: Handler App App ()
+resolveAllSnapshots =
do g <- getGame
b <- oops $ liftIO $ hasSnapshot g
case b of
True ->
do oops $ liftIO $ popSnapshot g
- resolveSnapshots
+ resolveAllSnapshots
False ->
do return ()
+resolveOneSnapshot :: Handler App App ()
+resolveOneSnapshot =
+ do g <- getGame
+ b <- oops $ liftIO $ hasSnapshot g
+ when b $ oops $ liftIO $ popSnapshot g
+ replay
+
routeRoguestar :: PlayerState -> [(BS.ByteString,PlayerState -> Handler App App ())] -> Handler App App ()
routeRoguestar ps xs = route $ map (\(bs,f) -> (bs,f ps)) xs
@@ -185,13 +193,17 @@ getGameState (SpeciesSelectionState (Just creature)) =
]
]
getGameState (PlayerCreatureTurn creature_ref) =
- do map_content <- generateMapContent
+ do g <- getGame
+ map_content <- generateMapContent
player_stats <- createStatsBlock
- messages <- liftM (reverse . take 5) $ liftIO . getMessages =<< getGame
+ messages <- liftM (reverse . take 5) $ liftIO $ getMessages g
+ is_snapshot <- oops $ liftIO $ hasSnapshot g
return $ object [ "play" .= object [
"map" .= map_content,
"statsblock" .= player_stats,
- "messages" .= messages ]]
+ "messages" .= messages,
+ "is-snapshot" .= is_snapshot,
+ "controls" .= not is_snapshot ]]
getGameState (GameOver PlayerIsDead) =
do return $ object [
"player-death" .= True ]
@@ -337,7 +349,7 @@ oops action =
liftIO $ putMessage g $ unpackError flag
replay
return $ error "oops: Unreachable code."
- Left (DBError bad) ->
+ Left (DBError bad) ->
do putResponse r
writeText "<html><head><title>Gameplay Error</title></head>"
writeText "<body><h1>Gameplay Error</h1>"
@@ -355,7 +367,7 @@ default_timeout :: Integer
default_timeout = 60*15
getGame :: Handler App App Game
-getGame =
+getGame =
do game_session_cookie <- getsRequest $ List.find ((== "game-uuid") . cookieName) . rqCookies
game_state <- gets _app_game_state
config <- liftIO $ getConfiguration default_timeout
@@ -376,32 +388,29 @@ generateMapContent :: Handler App App Aeson.Value
generateMapContent =
do let (x,y) = (21,21) --we'll probably want to let the player customize this later
g <- getGame
- map_data <- oops $ liftIO $ perceive g $
+ player_state <- oops $ liftIO $ getSnapshotPlayerState g
+ map_data <- oops $ liftIO $ perceiveSnapshot g $
do visible_terrain <- liftM Map.fromList visibleTerrain
visible_objects <- liftM stackVisibleObjects $ visibleObjects (const $ return True)
my_position <- whereAmI
return $ MapData visible_terrain visible_objects my_position
- return $ generateMapContent_ (x,y) map_data
+ return $ generateMapContent_ player_state (x,y) map_data
-generateMapContent_ :: (Integer,Integer) -> MapData -> Aeson.Value
-generateMapContent_ (width,height) _ | width `mod` 2 == 0 || height `mod` 2 == 0 = error "Map widths and heights must be odd numbers"
-generateMapContent_ (width,height) (MapData visible_terrain visible_objects (_,Position (center_x,center_y))) = object [ "map-content" .= maplines ]
+generateMapContent_ :: PlayerState -> (Integer,Integer) -> MapData -> Aeson.Value
+generateMapContent_ _ (width,height) _ | width `mod` 2 == 0 || height `mod` 2 == 0 = error "Map widths and heights must be odd numbers"
+generateMapContent_ player_state (width,height) (MapData visible_terrain visible_objects (_,Position (center_x,center_y))) = object [ "map-content" .= maplines ]
where maplines =
do y <- reverse $ [center_y - height `div` 2 .. center_y + width `div` 2]
- return $ Aeson.toJSON $ map ungroup $ List.group $ mapline y
- ungroup [x] = x -- do run-length encoding on the result:
- ungroup xs@(Aeson.Object hashmap:_) =
- let String str = fromMaybe (error "no 't'") $ HashMap.lookup "t" hashmap
- in Aeson.Object $ HashMap.insert "t" (String $ T.replicate (length xs) str) hashmap
+ return $ mapline y
mapline y =
do x <- [center_x - width `div` 2 .. center_x + width `div` 2]
return $ Aeson.toJSON $ mapstring x y
- mapstring x y =
+ mapstring x y =
let maybe_terrain = Map.lookup (Position (x,y)) visible_terrain
maybe_object = Map.lookup (Position (x,y)) visible_objects
rendered_json = case () of
- () | Just (vob:_) <- maybe_object -> rendering vob
- () | Just terrain <- maybe_terrain -> rendering terrain
+ () | Just (vob:_) <- maybe_object -> rendering player_state vob
+ () | Just terrain <- maybe_terrain -> rendering player_state terrain
() | otherwise -> object [ "t" .= ' ' ]
in rendered_json
@@ -426,7 +435,7 @@ createStatsBlock =
T.concat ["Compass: ",
T.pack $ show $ stats_compass stats]]
-data Style = Empty | Strong | Rocky | Icy | Plants | Dusty | Sandy | Wet | DeepWet | Molten | Gloomy | FaintMagic | StrongMagic | StrongDusty
+data Style = Empty | Strong | Rocky | Icy | Plants | Dusty | Sandy | Wet | DeepWet | Molten | Gloomy | FaintMagic | StrongMagic | StrongDusty | WarpIn | Damage | Active
styleToCSS :: Style -> T.Text
styleToCSS Empty = ""
@@ -442,50 +451,68 @@ styleToCSS Gloomy = "g"
styleToCSS FaintMagic = "a"
styleToCSS StrongMagic = "B A"
styleToCSS StrongDusty = "B d"
+styleToCSS WarpIn = "B warpin"
+styleToCSS Damage = "B damage"
+styleToCSS Active = "B active"
class Charcoded a where
- codedRepresentation :: a -> (Char,Style)
- rendering :: a -> Aeson.Value
- rendering a = object [ "t" .= t, "c" .= styleToCSS c ]
- where (t,c) = codedRepresentation a
-
+ codedRepresentation :: PlayerState -> a -> (Char,Style)
+ rendering :: PlayerState -> a -> Aeson.Value
+ rendering player_state a = object [ "t" .= t, "c" .= styleToCSS c ]
+ where (t,c) = codedRepresentation player_state a
+
instance Charcoded a => Charcoded (Maybe a) where
- codedRepresentation (Just a) = codedRepresentation a
- codedRepresentation Nothing = (' ',Empty)
+ codedRepresentation player_state (Just a) = codedRepresentation player_state a
+ codedRepresentation player_state Nothing = (' ',Empty)
instance Charcoded VisibleObject where
- codedRepresentation (VisibleTool { visible_tool = t }) = codedRepresentation t
- codedRepresentation (VisibleCreature { visible_creature_species = s }) = codedRepresentation s
- codedRepresentation (VisibleBuilding{}) = ('#',StrongMagic)
+ codedRepresentation player_state (VisibleTool { visible_tool = t }) = codedRepresentation player_state t
+ codedRepresentation player_state@(SnapshotEvent (TeleportEvent { teleport_event_creature = teleport_c }))
+ (VisibleCreature { visible_creature_ref = this_c, visible_creature_species = s }) |
+ teleport_c == this_c =
+ (fst $ codedRepresentation player_state s, WarpIn)
+ codedRepresentation player_state@(SnapshotEvent (SpawnEvent { spawn_event_creature = spawn_c }))
+ (VisibleCreature { visible_creature_ref = this_c, visible_creature_species = s }) |
+ spawn_c == this_c =
+ (fst $ codedRepresentation player_state s, WarpIn)
+ codedRepresentation player_state@(SnapshotEvent (AttackEvent { attack_event_target_creature = target_c }))
+ (VisibleCreature { visible_creature_ref = this_c, visible_creature_species = s }) |
+ target_c == this_c =
+ (fst $ codedRepresentation player_state s, Damage)
+ codedRepresentation player_state (VisibleCreature { visible_creature_ref = this_c, visible_creature_species = s }) |
+ subjectOf player_state == Just this_c =
+ (fst $ codedRepresentation player_state s, Active)
+ codedRepresentation player_state (VisibleCreature { visible_creature_species = s }) = codedRepresentation player_state s
+ codedRepresentation _ (VisibleBuilding{}) = ('#',StrongMagic)
instance Charcoded Tool where
- codedRepresentation (Sphere {}) = ('%',Strong)
- codedRepresentation (DeviceTool Gun _) = (')',Strong)
- codedRepresentation (DeviceTool Sword _) = (')',Strong)
+ codedRepresentation _ (Sphere {}) = ('%',Strong)
+ codedRepresentation _ (DeviceTool Gun _) = (')',Strong)
+ codedRepresentation _ (DeviceTool Sword _) = (')',Strong)
instance Charcoded Species where
- codedRepresentation RedRecreant = ('r',Strong)
- codedRepresentation BlueRecreant = ('@',Strong)
+ codedRepresentation _ RedRecreant = ('r',Strong)
+ codedRepresentation _ BlueRecreant = ('@',Strong)
instance Charcoded TerrainPatch where
- codedRepresentation RockFace = ('#',Rocky)
- codedRepresentation Rubble = ('.',Rocky)
- codedRepresentation Ore = ('.',Rocky)
- codedRepresentation RockyGround = ('.',Rocky)
- codedRepresentation Dirt = ('.',Dusty)
- codedRepresentation Grass = ('.',Plants)
- codedRepresentation Sand = ('.',Sandy)
- codedRepresentation Desert = ('.',Sandy)
- codedRepresentation Forest = ('f',Plants)
- codedRepresentation DeepForest = ('f',Plants)
- codedRepresentation TerrainData.Water = ('~',Wet)
- codedRepresentation DeepWater = ('~',Gloomy)
- codedRepresentation Ice = ('.',Icy)
- codedRepresentation Lava = ('~',Molten)
- codedRepresentation Glass = ('.',Gloomy)
- codedRepresentation RecreantFactory = ('_',FaintMagic)
- codedRepresentation Upstairs = ('<',StrongDusty)
- codedRepresentation Downstairs = ('>',StrongDusty)
+ codedRepresentation _ RockFace = ('#',Rocky)
+ codedRepresentation _ Rubble = ('.',Rocky)
+ codedRepresentation _ Ore = ('.',Rocky)
+ codedRepresentation _ RockyGround = ('.',Rocky)
+ codedRepresentation _ Dirt = ('.',Dusty)
+ codedRepresentation _ Grass = ('.',Plants)
+ codedRepresentation _ Sand = ('.',Sandy)
+ codedRepresentation _ Desert = ('.',Sandy)
+ codedRepresentation _ Forest = ('f',Plants)
+ codedRepresentation _ DeepForest = ('f',Plants)
+ codedRepresentation _ TerrainData.Water = ('~',Wet)
+ codedRepresentation _ DeepWater = ('~',Gloomy)
+ codedRepresentation _ Ice = ('.',Icy)
+ codedRepresentation _ Lava = ('~',Molten)
+ codedRepresentation _ Glass = ('.',Gloomy)
+ codedRepresentation _ RecreantFactory = ('_',FaintMagic)
+ codedRepresentation _ Upstairs = ('<',StrongDusty)
+ codedRepresentation _ Downstairs = ('>',StrongDusty)
main :: IO ()
main =
@@ -1,3 +0,0 @@
----
-{ empty-game : true }
----
@@ -4,6 +4,10 @@
<head>
<title>Roguestar</title>
<link rel="stylesheet" type="text/css" href="/static/roguebasic.css"/>
+ <script src="static/jquery-1.8.2.js" type="application/javascript"></script>
+ <script src="static/jquery.cookie-1.2.js" type="application/javascript"></script>
+ <script src="static/jquery.xcolor-1.8.js" type="application/javascript"></script>
+ <script src="static/roguebasic.js" type="application/javascript"></script>
</head>
<body>
<div id="main">
@@ -28,14 +28,14 @@
<dd>Water. It's relatively safe.</dd>
<dt>
-<pre class="A">
- XXX
+<pre class="B A">
+ ###
-X X
-X X X
-X X
+# #
+# # #
+# #
- XXX
+ ###
</pre></dt>
<dd>A stargate. It is your escape route.</dd>
@@ -18,8 +18,10 @@
<div id="version-history">
<h6>Roguestar 0.10.0</h6>
<ul>
+<li>Animated events for javascript-enabled clients.</li>
<li>Color map.</li>
-<li>Switched to mustache templates (hastache). You can append <code>?theme=json</code> to any URL to see (debug) the JSON data used to render each template.</li>
+<li>Switched to mustache templates (hastache). You can append <code>?theme=json</code> to any URL to see/debug the JSON data used to render each template.</li>
+<li>Fixed bug where stale sessions weren't being cleaned up.</li>
</ul>
<h6>Roguestar 0.8</h6>
Oops, something went wrong.

0 comments on commit 2d418e2

Please sign in to comment.