Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fix bug where engine emitted all visible-objects on each query for ob…

…ject-details.
  • Loading branch information...
commit b684d9dcf5872e58b3de6d2454b58ffc0bcdefa5 1 parent 0230243
@clanehin authored
View
3  src/Behavior.hs
@@ -133,7 +133,8 @@ dbBehave Vanish creature_ref =
lift $
do faction <- getCreatureFaction creature_ref
is_visible_to_anyone_else <- liftM (any (creature_ref `elem`)) $
- mapM (flip dbGetVisibleObjectsForFaction plane_ref) ({- all factions except this one: -} delete faction [minBound..maxBound])
+ mapM (\fact -> dbGetVisibleObjectsForFaction (return . const True) fact plane_ref)
+ ({- all factions except this one: -} delete faction [minBound..maxBound])
when (not is_visible_to_anyone_else) $ deleteCreature creature_ref
return ()
View
7 src/Combat.hs
@@ -9,7 +9,6 @@ module Combat
where
import DB
-import DBData
import Creature
import CreatureData
import Tool
@@ -17,8 +16,6 @@ import ToolData
import Control.Monad.Error
import Facing
import Data.Maybe
-import Data.List
-import Data.Ord
import DeviceActivation
import Contact
import Plane
@@ -151,7 +148,7 @@ executeAttack (AttackHit attacker_ref m_tool_ref defender_ref damage) =
dbPushSnapshot $ AttackEvent attacker_ref m_tool_ref defender_ref
executeAttack (AttackMalfunction attacker_ref tool_ref damage) =
do injureCreature damage attacker_ref
- dbMove dbDropTool tool_ref
+ _ <- dbMove dbDropTool tool_ref
dbPushSnapshot $ WeaponOverheatsEvent attacker_ref tool_ref
return ()
executeAttack (AttackExplodes attacker_ref tool_ref damage) =
@@ -160,7 +157,7 @@ executeAttack (AttackExplodes attacker_ref tool_ref damage) =
deleteTool tool_ref
executeAttack (AttackDisarm attacker_ref defender_ref dropped_tool) =
do dbPushSnapshot $ DisarmEvent attacker_ref defender_ref dropped_tool
- dbMove dbDropTool dropped_tool
+ _ <- dbMove dbDropTool dropped_tool
return ()
executeAttack (AttackSunder attacker_ref weapon_ref defender_ref sundered_tool) =
do dbPushSnapshot $ SunderEvent attacker_ref weapon_ref defender_ref sundered_tool
View
10 src/DB.hs
@@ -66,6 +66,7 @@ import ToolData
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Reader
+import Control.Applicative
import TimeCoordinate
import Data.Ord
import Control.Arrow (first,second)
@@ -115,6 +116,13 @@ instance Monad DB where
k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f
fail = error
+instance Functor DB where
+ fmap = liftM
+
+instance Applicative DB where
+ pure = return
+ (<*>) = ap
+
instance MonadState DB_BaseType DB where
get = DB $ \h f -> f (db_here h) h
put s = DB $ \h f -> f () $ modification h
@@ -146,7 +154,7 @@ dbRandom rgen = DB $ \h f -> let (x,g) = rgen (db_random h) in f x (h { db_rando
dbRandomSplit :: DB RNG
dbRandomSplit = DB $ \h f -> let (a,b) = Random.split (db_random h) in f a (h { db_random = b })
-class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db) => DBReadable db where
+class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db,Applicative db) => DBReadable db where
dbSimulate :: DB a -> db a
dbPeepSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db (Maybe a)
View
8 src/Perception.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ExistentialQuantification, Rank2Types #-}
+{-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts #-}
-- |
-- Perception is essentially a catalogue of information that can be
@@ -67,11 +67,11 @@ whoAmI = DBPerception $ ask
runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a
runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref
-visibleObjects :: (DBReadable db,LocationType a,LocationType b) => DBPerception db [Location S a b]
-visibleObjects =
+visibleObjects :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> DBPerception m Bool) -> DBPerception db [a]
+visibleObjects filterF =
do me <- whoAmI
faction <- myFaction
- liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction faction) =<< liftM extractLocation (dbWhere me)
+ liftDB $ maybe (return []) (dbGetVisibleObjectsForFaction (\a -> runPerception me $ filterF a) faction) =<< liftM extractLocation (dbWhere me)
myFaction :: (DBReadable db) => DBPerception db Faction
myFaction = Perception.getCreatureFaction =<< whoAmI
View
27 src/PlaneVisibility.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE PatternGuards, FlexibleContexts, ScopedTypeVariables #-}
+{-# LANGUAGE PatternGuards, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}
module PlaneVisibility
(dbGetVisibleTerrainForFaction,
@@ -20,6 +20,7 @@ import Facing
import Data.Ratio
import Building
import Position
+import Control.Applicative
dbGetSeersForFaction :: (DBReadable db) => Faction -> PlaneRef -> db [CreatureRef]
dbGetSeersForFaction faction plane_ref =
@@ -48,29 +49,31 @@ dbGetVisibleTerrainForCreature creature_ref =
-- |
-- Returns a list of all objects that are visible to any creature belonging
--- to the specified faction on the specified plane.
+-- to the specified faction on the specified plane. Accepts a filter to
+-- determine what kinds of objects will be tested..
--
-dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => Faction -> PlaneRef -> db [a]
-dbGetVisibleObjectsForFaction faction plane_ref =
+dbGetVisibleObjectsForFaction :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> Faction -> PlaneRef -> db [a]
+dbGetVisibleObjectsForFaction filterF faction plane_ref =
do critters <- dbGetSeersForFaction faction plane_ref
- liftM (nubBy (=:=) . concat) $ mapRO dbGetVisibleObjectsForCreature critters
+ liftM (nubBy (=:=) . concat) $ mapRO (dbGetVisibleObjectsForCreature filterF) critters
-- |
-- Returns a list of all objects that are visible to the specified creature.
+-- Accepts a filter to determine what kinds of objects will be tested.
--
-dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => CreatureRef -> db [a]
-dbGetVisibleObjectsForCreature creature_ref =
+dbGetVisibleObjectsForCreature :: (DBReadable db,GenericReference a S) => (forall m. DBReadable m => a -> m Bool) -> CreatureRef -> db [a]
+dbGetVisibleObjectsForCreature filterF creature_ref =
do (loc :: Maybe PlaneRef) <- liftM (fmap location) $ getPlanarPosition creature_ref
case loc of
- Just plane_ref -> filterRO (dbIsPlanarVisibleTo creature_ref . generalizeReference) =<< dbGetContents plane_ref
+ Just plane_ref -> filterRO (\a -> (&&) <$> filterF a <*> (dbIsPlanarVisible creature_ref $ generalizeReference a)) =<< dbGetContents plane_ref
Nothing -> return []
-- |
--- dbIsPlanarVisibleTo (a creature) (some object) is true if the creature can see the object.
+-- dbIsPlanarVisible (a creature) (some object) is true if the creature can see the object.
--
-dbIsPlanarVisibleTo :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool
-dbIsPlanarVisibleTo creature_ref obj_ref | creature_ref =:= obj_ref = return True
-dbIsPlanarVisibleTo creature_ref obj_ref =
+dbIsPlanarVisible :: (DBReadable db,ReferenceType a) => CreatureRef -> Reference a -> db Bool
+dbIsPlanarVisible creature_ref obj_ref | creature_ref =:= obj_ref = return True
+dbIsPlanarVisible creature_ref obj_ref =
do (creature_loc :: Maybe (PlaneRef,Position)) <- liftM (fmap location) $ getPlanarPosition creature_ref
(obj_loc :: Maybe (PlaneRef,MultiPosition)) <- liftM (fmap location) $ getPlanarPosition obj_ref
spot_check <- dbGetOpposedSpotCheck creature_ref obj_ref
View
6 src/Planet.hs
@@ -5,11 +5,9 @@ module Planet
import PlanetData
import DB
-import DBData
import Plane
import TerrainData
import Control.Monad
-import Control.Monad.Random
import Data.Maybe
import Data.Ord
import Town
@@ -28,14 +26,14 @@ makePlanet plane_location planet_info =
town <- liftM catMaybes $ forM (planet_info_town planet_info) $ \(r,b) ->
do p <- rationalRoll r
return $ if p then Just b else Nothing
- createTown plane_ref town
+ _ <- createTown plane_ref town
return plane_ref
makePlanets :: (PlaneLocation l) => l -> [PlanetInfo] -> DB PlaneRef
makePlanets _ [] = return $ error "makePlanetarySystem: empty list"
makePlanets l (planet_info:rest) =
do plane_ref <- makePlanet l planet_info
- makePlanets (Subsequent plane_ref) rest
+ _ <- makePlanets (Subsequent plane_ref) rest
return plane_ref
generatePlanetInfo :: (DBReadable db) => [PlanetInfo] -> db [PlanetInfo]
View
17 src/Protocol.hs
@@ -10,7 +10,6 @@ import CreatureData
import Creature
import Character
import DB
-import DBData
import System.Exit
import System.IO
import BeginGame
@@ -35,8 +34,6 @@ import Substances
import PlayerState
import Make
import Control.Concurrent
-import Control.Concurrent.MVar
-import Control.Concurrent.Chan
import Control.Monad.STM
import Control.Concurrent.STM.TVar
import Control.Exception
@@ -54,14 +51,14 @@ mainLoop db_init =
query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress)
wait_quit <- newEmptyMVar
let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever
- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< getLine
- forkIO $ foreverLoopThenQuit $
+ _ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< getLine
+ _ <- forkIO $ foreverLoopThenQuit $
do next_line <- liftM (map toLower . unlines . lines) (readChan output_chan)
when (not $ null next_line) $
do putStrLn next_line
putStrLn "over"
hFlush stdout
- forkIO $ foreverLoopThenQuit $
+ _ <- forkIO $ foreverLoopThenQuit $
do next_command <- readChan input_chan
case (words $ map toLower next_command) of
["quit"] -> exitWith ExitSuccess
@@ -317,7 +314,7 @@ dbDispatchQuery ["who-player"] = return "answer: who-player 2"
dbDispatchQuery ["visible-objects","0"] =
do maybe_plane_ref <- dbGetCurrentPlane
- (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref
+ (objects :: [Location S (Reference ()) ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
table_rows <- mapM (dbObjectToTableRow . entity) objects
return ("begin-table visible-objects 0 object-unique-id x y facing\n" ++
(unlines $ table_rows) ++
@@ -328,9 +325,9 @@ dbDispatchQuery ["visible-objects","0"] =
(Just (Position (x,y)),maybe_face) -> unwords [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
_ -> ""
-dbDispatchQuery ["object-details",_] = ro $
+dbDispatchQuery ["object-details",uid] = ro $
do maybe_plane_ref <- dbGetCurrentPlane
- (visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction Player) maybe_plane_ref
+ (visibles :: [Reference ()]) <- maybe (return []) (dbGetVisibleObjectsForFaction (return . (== uid) . show . toUID) Player) maybe_plane_ref
let creature_refs = mapMaybe (coerceReferenceTyped _creature) visibles
wielded <- liftM catMaybes $ mapM dbGetWielded creature_refs
let tool_refs = mapMaybe (coerceReferenceTyped _tool) visibles ++ wielded
@@ -399,7 +396,7 @@ dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =
dbDispatchQuery ["wielded-objects","0"] =
do m_plane_ref <- dbGetCurrentPlane
- creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction Player) m_plane_ref
+ creature_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref
wielded_tool_refs <- mapM dbGetWielded creature_refs
let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe String
wieldedPairToTable creature_ref = fmap (\tool_ref -> (show $ toUID tool_ref) ++ " " ++ (show $ toUID creature_ref))
View
2  src/Travel.hs
@@ -71,7 +71,7 @@ resolveTeleportJump creature_ref face = liftM (fromMaybe TeleportJumpFailed) $ r
executeTeleportJump :: TeleportJumpOutcome -> DB ()
executeTeleportJump TeleportJumpFailed = return ()
executeTeleportJump (TeleportJumpGood creature_ref standing_location) =
- do dbMove (return . toStanding standing_location) creature_ref
+ do _ <- dbMove (return . toStanding standing_location) creature_ref
dbPushSnapshot $ TeleportEvent creature_ref
return ()
View
2  src/Turns.hs
@@ -75,7 +75,7 @@ dbPerform1PlanarAITurn plane_ref =
dbPerform1CreatureAITurn :: CreatureRef -> DB ()
dbPerform1CreatureAITurn creature_ref =
atomic $ liftM (flip dbBehave creature_ref) $ P.runPerception creature_ref $ liftM (fromMaybe Vanish) $ runMaybeT $
- do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects
+ do player <- MaybeT $ liftM listToMaybe $ filterM (liftM (== Player) . P.getCreatureFaction . entity) =<< P.visibleObjects (return . const True)
(rand_x :: Integer) <- lift $ getRandomR (1,100)
rand_face <- lift $ pickM [minBound..maxBound]
(_,my_position) <- lift P.whereAmI
Please sign in to comment.
Something went wrong with that request. Please try again.